ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/deliantra/server/lib/cf.pm
(Generate patch)

Comparing deliantra/server/lib/cf.pm (file contents):
Revision 1.232 by root, Wed Apr 4 02:07:19 2007 UTC vs.
Revision 1.539 by root, Tue May 4 22:49:21 2010 UTC

1#
2# This file is part of Deliantra, the Roguelike Realtime MMORPG.
3#
4# Copyright (©) 2006,2007,2008,2009,2010 Marc Alexander Lehmann / Robin Redeker / the Deliantra team
5#
6# Deliantra is free software: you can redistribute it and/or modify it under
7# the terms of the Affero GNU General Public License as published by the
8# Free Software Foundation, either version 3 of the License, or (at your
9# option) any later version.
10#
11# This program is distributed in the hope that it will be useful,
12# but WITHOUT ANY WARRANTY; without even the implied warranty of
13# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14# GNU General Public License for more details.
15#
16# You should have received a copy of the Affero GNU General Public License
17# and the GNU General Public License along with this program. If not, see
18# <http://www.gnu.org/licenses/>.
19#
20# The authors can be reached via e-mail to <support@deliantra.net>
21#
22
1package cf; 23package cf;
2 24
3use utf8; 25use common::sense;
4use strict;
5 26
6use Symbol; 27use Symbol;
7use List::Util; 28use List::Util;
8use Storable; 29use Socket;
9use Event; 30use EV;
10use Opcode; 31use Opcode;
11use Safe; 32use Safe;
12use Safe::Hole; 33use Safe::Hole;
34use Storable ();
35use Carp ();
13 36
37use Guard ();
14use Coro 3.52 (); 38use Coro ();
15use Coro::State; 39use Coro::State;
40use Coro::Handle;
41use Coro::EV;
16use Coro::Event; 42use Coro::AnyEvent;
17use Coro::Timer; 43use Coro::Timer;
18use Coro::Signal; 44use Coro::Signal;
19use Coro::Semaphore; 45use Coro::Semaphore;
46use Coro::SemaphoreSet;
47use Coro::AnyEvent;
20use Coro::AIO; 48use Coro::AIO;
49use Coro::BDB 1.6;
50use Coro::Storable;
51use Coro::Util ();
21 52
53use JSON::XS 2.01 ();
22use BDB (); 54use BDB ();
23use Data::Dumper; 55use Data::Dumper;
24use Digest::MD5;
25use Fcntl; 56use Fcntl;
26use YAML::Syck (); 57use YAML::XS ();
27use IO::AIO 2.32 (); 58use IO::AIO ();
28use Time::HiRes; 59use Time::HiRes;
29use Compress::LZF; 60use Compress::LZF;
61use Digest::MD5 ();
62
63AnyEvent::detect;
30 64
31# configure various modules to our taste 65# configure various modules to our taste
32# 66#
67$Storable::canonical = 1; # reduce rsync transfers
33Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator 68Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator
69
70$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority
71
72# make sure c-lzf reinitialises itself
73Compress::LZF::set_serializer "Storable", "Storable::net_mstore", "Storable::mretrieve";
34Compress::LZF::sfreeze_cr { }; # prime Compress::LZF so it does not use require later 74Compress::LZF::sfreeze_cr { }; # prime Compress::LZF so it does not use require later
35 75
36$Event::Eval = 1; # no idea why this is required, but it is 76# strictly for debugging
37 77$SIG{QUIT} = sub { Carp::cluck "SIGQUIT" };
38# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode?
39$YAML::Syck::ImplicitUnicode = 1;
40
41$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority
42 78
43sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload 79sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
44 80
45our %COMMAND = (); 81our %COMMAND = ();
46our %COMMAND_TIME = (); 82our %COMMAND_TIME = ();
47 83
48our @EXTS = (); # list of extension package names 84our @EXTS = (); # list of extension package names
49our %EXTCMD = (); 85our %EXTCMD = ();
86our %EXTICMD = ();
50our %EXT_CORO = (); # coroutines bound to extensions 87our %EXT_CORO = (); # coroutines bound to extensions
51our %EXT_MAP = (); # pluggable maps 88our %EXT_MAP = (); # pluggable maps
52 89
53our $RELOAD; # number of reloads so far 90our $RELOAD; # number of reloads so far, non-zero while in reload
54our @EVENT; 91our @EVENT;
55our $LIBDIR = datadir . "/ext"; 92our @REFLECT; # set by XS
93our %REFLECT; # set by us
56 94
57our $TICK = MAX_TIME * 1e-6; 95our $CONFDIR = confdir;
58our $TICK_WATCHER; 96our $DATADIR = datadir;
59our $AIO_POLL_WATCHER; 97our $LIBDIR = "$DATADIR/ext";
98our $PODDIR = "$DATADIR/pod";
99our $MAPDIR = "$DATADIR/" . mapdir;
100our $LOCALDIR = localdir;
101our $TMPDIR = "$LOCALDIR/" . tmpdir;
102our $UNIQUEDIR = "$LOCALDIR/" . uniquedir;
103our $PLAYERDIR = "$LOCALDIR/" . playerdir;
104our $RANDOMDIR = "$LOCALDIR/random";
105our $BDBDIR = "$LOCALDIR/db";
106our $PIDFILE = "$LOCALDIR/pid";
107our $RUNTIMEFILE = "$LOCALDIR/runtime";
108
109our %RESOURCE; # unused
110
111our $OUTPUT_RATE_MIN = 3000;
112our $OUTPUT_RATE_MAX = 1000000;
113
114our $MAX_LINKS = 32; # how many chained exits to follow
115our $VERBOSE_IO = 1;
116
117our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!)
60our $NEXT_RUNTIME_WRITE; # when should the runtime file be written 118our $NEXT_RUNTIME_WRITE; # when should the runtime file be written
61our $NEXT_TICK; 119our $NEXT_TICK;
62our $NOW;
63our $USE_FSYNC = 1; # use fsync to write maps - default off 120our $USE_FSYNC = 1; # use fsync to write maps - default on
64 121
122our $BDB_DEADLOCK_WATCHER;
123our $BDB_CHECKPOINT_WATCHER;
65our $BDB_POLL_WATCHER; 124our $BDB_TRICKLE_WATCHER;
66our $DB_ENV; 125our $DB_ENV;
126
127our @EXTRA_MODULES = qw(pod match mapscript);
67 128
68our %CFG; 129our %CFG;
69 130
70our $UPTIME; $UPTIME ||= time; 131our $UPTIME; $UPTIME ||= time;
71our $RUNTIME; 132our $RUNTIME;
133our $NOW;
72 134
73our %PLAYER; # all users 135our (%PLAYER, %PLAYER_LOADING); # all users
74our %MAP; # all maps 136our (%MAP, %MAP_LOADING ); # all maps
75our $LINK_MAP; # the special {link} map, which is always available 137our $LINK_MAP; # the special {link} map, which is always available
76our $RANDOM_MAPS = cf::localdir . "/random";
77our $BDB_ENV_DIR = cf::localdir . "/db";
78
79our $WAIT_FOR_TICK; $WAIT_FOR_TICK ||= new Coro::Signal;
80our $WAIT_FOR_TICK_ONE; $WAIT_FOR_TICK_ONE ||= new Coro::Signal;
81 138
82# used to convert map paths into valid unix filenames by replacing / by ∕ 139# used to convert map paths into valid unix filenames by replacing / by ∕
83our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons 140our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons
84 141
142our $LOAD; # a number between 0 (idle) and 1 (too many objects)
143our $LOADAVG; # same thing, but with alpha-smoothing
144our $JITTER; # average jitter
145our $TICK_START; # for load detecting purposes
146
147our @POST_INIT;
148
149our $REATTACH_ON_RELOAD; # set to true to force object reattach on reload (slow)
150our $REALLY_UNLOOP; # never set to true, please :)
151
85binmode STDOUT; 152binmode STDOUT;
86binmode STDERR; 153binmode STDERR;
87 154
88# read virtual server time, if available 155# read virtual server time, if available
89unless ($RUNTIME || !-e cf::localdir . "/runtime") { 156unless ($RUNTIME || !-e $RUNTIMEFILE) {
90 open my $fh, "<", cf::localdir . "/runtime" 157 open my $fh, "<", $RUNTIMEFILE
91 or die "unable to read runtime file: $!"; 158 or die "unable to read $RUNTIMEFILE file: $!";
92 $RUNTIME = <$fh> + 0.; 159 $RUNTIME = <$fh> + 0.;
93} 160}
94 161
95mkdir cf::localdir; 162eval "sub TICK() { $TICK } 1" or die;
96mkdir cf::localdir . "/" . cf::playerdir; 163
97mkdir cf::localdir . "/" . cf::tmpdir; 164mkdir $_
98mkdir cf::localdir . "/" . cf::uniquedir; 165 for $LOCALDIR, $TMPDIR, $UNIQUEDIR, $PLAYERDIR, $RANDOMDIR, $BDBDIR;
99mkdir $RANDOM_MAPS;
100mkdir $BDB_ENV_DIR;
101 166
102our $EMERGENCY_POSITION; 167our $EMERGENCY_POSITION;
103 168
104sub cf::map::normalise; 169sub cf::map::normalise;
170
171sub in_main() {
172 $Coro::current == $Coro::main
173}
174
175#############################################################################
176
177%REFLECT = ();
178for (@REFLECT) {
179 my $reflect = JSON::XS::decode_json $_;
180 $REFLECT{$reflect->{class}} = $reflect;
181}
182
183# this is decidedly evil
184$REFLECT{object}{flags} = { map +($_ => undef), grep $_, map /^FLAG_([A-Z0-9_]+)$/ && lc $1, keys %{"cf::"} };
105 185
106############################################################################# 186#############################################################################
107 187
108=head2 GLOBAL VARIABLES 188=head2 GLOBAL VARIABLES
109 189
… …
116=item $cf::RUNTIME 196=item $cf::RUNTIME
117 197
118The time this server has run, starts at 0 and is increased by $cf::TICK on 198The time this server has run, starts at 0 and is increased by $cf::TICK on
119every server tick. 199every server tick.
120 200
121=item $cf::LIBDIR 201=item $cf::CONFDIR $cf::DATADIR $cf::LIBDIR $cf::PODDIR
202$cf::MAPDIR $cf::LOCALDIR $cf::TMPDIR $cf::UNIQUEDIR
203$cf::PLAYERDIR $cf::RANDOMDIR $cf::BDBDIR
122 204
123The perl library directory, where extensions and cf-specific modules can 205Various directories - "/etc", read-only install directory, perl-library
124be found. It will be added to C<@INC> automatically. 206directory, pod-directory, read-only maps directory, "/var", "/var/tmp",
207unique-items directory, player file directory, random maps directory and
208database environment.
125 209
126=item $cf::NOW 210=item $cf::NOW
127 211
128The time of the last (current) server tick. 212The time of the last (current) server tick.
129 213
130=item $cf::TICK 214=item $cf::TICK
131 215
132The interval between server ticks, in seconds. 216The interval between server ticks, in seconds.
133 217
218=item $cf::LOADAVG
219
220The current CPU load on the server (alpha-smoothed), as a value between 0
221(none) and 1 (overloaded), indicating how much time is spent on processing
222objects per tick. Healthy values are < 0.5.
223
224=item $cf::LOAD
225
226The raw value load value from the last tick.
227
134=item %cf::CFG 228=item %cf::CFG
135 229
136Configuration for the server, loaded from C</etc/crossfire/config>, or 230Configuration for the server, loaded from C</etc/deliantra-server/config>, or
137from wherever your confdir points to. 231from wherever your confdir points to.
138 232
139=item $cf::WAIT_FOR_TICK, $cf::WAIT_FOR_TICK_ONE 233=item cf::wait_for_tick, cf::wait_for_tick_begin
140 234
141These are Coro::Signal objects that are C<< ->broadcast >> (WAIT_FOR_TICK) 235These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only
142or C<< ->send >> (WAIT_FOR_TICK_ONE) on after normal server tick 236returns directly I<after> the tick processing (and consequently, can only wake one process
143processing has been done. Call C<< ->wait >> on them to maximise the 237per tick), while cf::wait_for_tick wakes up all waiters after tick processing.
144window of cpu time available, or simply to synchronise to the server tick. 238
239=item @cf::INVOKE_RESULTS
240
241This array contains the results of the last C<invoke ()> call. When
242C<cf::override> is called C<@cf::INVOKE_RESULTS> is set to the parameters of
243that call.
244
245=item %cf::REFLECT
246
247Contains, for each (C++) class name, a hash reference with information
248about object members (methods, scalars, arrays and flags) and other
249metadata, which is useful for introspection.
145 250
146=back 251=back
147 252
148=cut 253=cut
149 254
150BEGIN { 255sub error(@) { LOG llevError, join "", @_ }
151 *CORE::GLOBAL::warn = sub { 256sub warn (@) { LOG llevWarn , join "", @_ }
257sub info (@) { LOG llevInfo , join "", @_ }
258sub debug(@) { LOG llevDebug, join "", @_ }
259sub trace(@) { LOG llevTrace, join "", @_ }
260
261$Coro::State::WARNHOOK = sub {
152 my $msg = join "", @_; 262 my $msg = join "", @_;
153 utf8::encode $msg;
154 263
155 $msg .= "\n" 264 $msg .= "\n"
156 unless $msg =~ /\n$/; 265 unless $msg =~ /\n$/;
157 266
267 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;
268
158 LOG llevError, $msg; 269 LOG llevWarn, $msg;
159 }; 270};
160} 271
272$Coro::State::DIEHOOK = sub {
273 return unless $^S eq 0; # "eq", not "=="
274
275 error Carp::longmess $_[0];
276
277 if (in_main) {#d#
278 error "DIEHOOK called in main context, Coro bug?\n";#d#
279 return;#d#
280 }#d#
281
282 # kill coroutine otherwise
283 Coro::terminate
284};
161 285
162@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable'; 286@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
163@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable'; 287@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';
164@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable'; 288@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable';
165@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable'; 289@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable';
166@safe::cf::map::ISA = @cf::map::ISA = 'cf::attachable'; 290@safe::cf::map::ISA = @cf::map::ISA = 'cf::attachable';
291@safe::cf::arch::ISA = @cf::arch::ISA = 'cf::object';
167@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object'; 292@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object'; # not really true (yet)
168 293
169# we bless all objects into (empty) derived classes to force a method lookup 294# we bless all objects into (empty) derived classes to force a method lookup
170# within the Safe compartment. 295# within the Safe compartment.
171for my $pkg (qw( 296for my $pkg (qw(
172 cf::global cf::attachable 297 cf::global cf::attachable
173 cf::object cf::object::player 298 cf::object cf::object::player
174 cf::client cf::player 299 cf::client cf::player
175 cf::arch cf::living 300 cf::arch cf::living
301 cf::map cf::mapspace
176 cf::map cf::party cf::region 302 cf::party cf::region
177)) { 303)) {
178 no strict 'refs';
179 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg; 304 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
180} 305}
181 306
182$Event::DIED = sub { 307$EV::DIED = sub {
183 warn "error in event callback: @_"; 308 Carp::cluck "error in event callback: @_";
184}; 309};
310
311#############################################################################
185 312
186=head2 UTILITY FUNCTIONS 313=head2 UTILITY FUNCTIONS
187 314
188=over 4 315=over 4
189 316
… …
208 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge; 335 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge;
209 $d 336 $d
210 } || "[unable to dump $_[0]: '$@']"; 337 } || "[unable to dump $_[0]: '$@']";
211} 338}
212 339
213use JSON::XS qw(to_json from_json); # TODO# replace by JSON::PC once working
214
215=item $ref = cf::from_json $json 340=item $ref = cf::decode_json $json
216 341
217Converts a JSON string into the corresponding perl data structure. 342Converts a JSON string into the corresponding perl data structure.
218 343
219=item $json = cf::to_json $ref 344=item $json = cf::encode_json $ref
220 345
221Converts a perl data structure into its JSON representation. 346Converts a perl data structure into its JSON representation.
222 347
348=cut
349
350our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max
351
352sub encode_json($) { $json_coder->encode ($_[0]) }
353sub decode_json($) { $json_coder->decode ($_[0]) }
354
355=item cf::post_init { BLOCK }
356
357Execute the given codeblock, I<after> all extensions have been (re-)loaded,
358but I<before> the server starts ticking again.
359
360The cdoeblock will have a single boolean argument to indicate whether this
361is a reload or not.
362
363=cut
364
365sub post_init(&) {
366 push @POST_INIT, shift;
367}
368
223=item cf::lock_wait $string 369=item cf::lock_wait $string
224 370
225Wait until the given lock is available. See cf::lock_acquire. 371Wait until the given lock is available. See cf::lock_acquire.
226 372
227=item my $lock = cf::lock_acquire $string 373=item my $lock = cf::lock_acquire $string
228 374
229Wait until the given lock is available and then acquires it and returns 375Wait until the given lock is available and then acquires it and returns
230a Coro::guard object. If the guard object gets destroyed (goes out of scope, 376a L<Guard> object. If the guard object gets destroyed (goes out of scope,
231for example when the coroutine gets canceled), the lock is automatically 377for example when the coroutine gets canceled), the lock is automatically
232returned. 378returned.
233 379
380Locks are *not* recursive, locking from the same coro twice results in a
381deadlocked coro.
382
234Lock names should begin with a unique identifier (for example, cf::map::find 383Lock names should begin with a unique identifier (for example, cf::map::find
235uses map_find and cf::map::load uses map_load). 384uses map_find and cf::map::load uses map_load).
236 385
237=cut 386=item $locked = cf::lock_active $string
238 387
239our %LOCK; 388Return true if the lock is currently active, i.e. somebody has locked it.
389
390=cut
391
392our $LOCKS = new Coro::SemaphoreSet;
240 393
241sub lock_wait($) { 394sub lock_wait($) {
242 my ($key) = @_; 395 $LOCKS->wait ($_[0]);
243
244 # wait for lock, if any
245 while ($LOCK{$key}) {
246 push @{ $LOCK{$key} }, $Coro::current;
247 Coro::schedule;
248 }
249} 396}
250 397
251sub lock_acquire($) { 398sub lock_acquire($) {
252 my ($key) = @_; 399 $LOCKS->guard ($_[0])
400}
253 401
254 # wait, to be sure we are not locked 402sub lock_active($) {
255 lock_wait $key; 403 $LOCKS->count ($_[0]) < 1
256
257 $LOCK{$key} = [];
258
259 Coro::guard {
260 # wake up all waiters, to be on the safe side
261 $_->ready for @{ delete $LOCK{$key} };
262 }
263} 404}
264 405
265sub freeze_mainloop { 406sub freeze_mainloop {
266 return unless $TICK_WATCHER->is_active; 407 tick_inhibit_inc;
267 408
268 my $guard = Coro::guard { 409 &Guard::guard (\&tick_inhibit_dec);
269 $TICK_WATCHER->start; 410}
411
412=item cf::periodic $interval, $cb
413
414Like EV::periodic, but randomly selects a starting point so that the actions
415get spread over time.
416
417=cut
418
419sub periodic($$) {
420 my ($interval, $cb) = @_;
421
422 my $start = rand List::Util::min 180, $interval;
423
424 EV::periodic $start, $interval, 0, $cb
425}
426
427=item cf::get_slot $time[, $priority[, $name]]
428
429Allocate $time seconds of blocking CPU time at priority C<$priority>:
430This call blocks and returns only when you have at least C<$time> seconds
431of cpu time till the next tick. The slot is only valid till the next cede.
432
433The optional C<$name> can be used to identify the job to run. It might be
434used for statistical purposes and should identify the same time-class.
435
436Useful for short background jobs.
437
438=cut
439
440our @SLOT_QUEUE;
441our $SLOT_QUEUE;
442our $SLOT_DECAY = 0.9;
443
444$SLOT_QUEUE->cancel if $SLOT_QUEUE;
445$SLOT_QUEUE = Coro::async {
446 $Coro::current->desc ("timeslot manager");
447
448 my $signal = new Coro::Signal;
449 my $busy;
450
451 while () {
452 next_job:
453
454 my $avail = cf::till_tick;
455
456 for (0 .. $#SLOT_QUEUE) {
457 if ($SLOT_QUEUE[$_][0] <= $avail) {
458 $busy = 0;
459 my $job = splice @SLOT_QUEUE, $_, 1, ();
460 $job->[2]->send;
461 Coro::cede;
462 goto next_job;
463 } else {
464 $SLOT_QUEUE[$_][0] *= $SLOT_DECAY;
465 }
466 }
467
468 if (@SLOT_QUEUE) {
469 # we do not use wait_for_tick() as it returns immediately when tick is inactive
470 push @cf::WAIT_FOR_TICK, $signal;
471 $signal->wait;
472 } else {
473 $busy = 0;
474 Coro::schedule;
475 }
270 }; 476 }
271 $TICK_WATCHER->stop; 477};
272 $guard 478
479sub get_slot($;$$) {
480 return if tick_inhibit || $Coro::current == $Coro::main;
481
482 my ($time, $pri, $name) = @_;
483
484 $time = clamp $time, 0.01, $TICK * .6;
485
486 my $sig = new Coro::Signal;
487
488 push @SLOT_QUEUE, [$time, $pri, $sig, $name];
489 @SLOT_QUEUE = sort { $b->[1] <=> $a->[1] } @SLOT_QUEUE;
490 $SLOT_QUEUE->ready;
491 $sig->wait;
273} 492}
274 493
275=item cf::async { BLOCK } 494=item cf::async { BLOCK }
276 495
277Currently the same as Coro::async_pool, meaning you cannot use 496Currently the same as Coro::async_pool, meaning you cannot use
… …
282 501
283BEGIN { *async = \&Coro::async_pool } 502BEGIN { *async = \&Coro::async_pool }
284 503
285=item cf::sync_job { BLOCK } 504=item cf::sync_job { BLOCK }
286 505
287The design of crossfire+ requires that the main coro ($Coro::main) is 506The design of Deliantra requires that the main coroutine ($Coro::main)
288always able to handle events or runnable, as crossfire+ is only partly 507is always able to handle events or runnable, as Deliantra is only
289reentrant. Thus "blocking" it by e.g. waiting for I/O is not acceptable. 508partly reentrant. Thus "blocking" it by e.g. waiting for I/O is not
509acceptable.
290 510
291If it must be done, put the blocking parts into C<sync_job>. This will run 511If it must be done, put the blocking parts into C<sync_job>. This will run
292the given BLOCK in another coroutine while waiting for the result. The 512the given BLOCK in another coroutine while waiting for the result. The
293server will be frozen during this time, so the block should either finish 513server will be frozen during this time, so the block should either finish
294fast or be very important. 514fast or be very important.
… …
296=cut 516=cut
297 517
298sub sync_job(&) { 518sub sync_job(&) {
299 my ($job) = @_; 519 my ($job) = @_;
300 520
301 if ($Coro::current == $Coro::main) { 521 if (in_main) {
522 my $time = AE::time;
523
302 # this is the main coro, too bad, we have to block 524 # this is the main coro, too bad, we have to block
303 # till the operation succeeds, freezing the server :/ 525 # till the operation succeeds, freezing the server :/
304 526
305 # TODO: use suspend/resume instead 527 #LOG llevError, Carp::longmess "sync job";#d#
306 # (but this is cancel-safe) 528
307 my $freeze_guard = freeze_mainloop; 529 my $freeze_guard = freeze_mainloop;
308 530
309 my $busy = 1; 531 my $busy = 1;
310 my @res; 532 my @res;
311 533
312 (async { 534 (async {
535 $Coro::current->desc ("sync job coro");
313 @res = eval { $job->() }; 536 @res = eval { $job->() };
314 warn $@ if $@; 537 error $@ if $@;
315 undef $busy; 538 undef $busy;
316 })->prio (Coro::PRIO_MAX); 539 })->prio (Coro::PRIO_MAX);
317 540
318 while ($busy) { 541 while ($busy) {
319 Coro::cede or Event::one_event; 542 if (Coro::nready) {
543 Coro::cede_notself;
544 } else {
545 EV::loop EV::LOOP_ONESHOT;
320 } 546 }
547 }
548
549 my $time = AE::time - $time;
550
551 $TICK_START += $time; # do not account sync jobs to server load
321 552
322 wantarray ? @res : $res[0] 553 wantarray ? @res : $res[0]
323 } else { 554 } else {
324 # we are in another coroutine, how wonderful, everything just works 555 # we are in another coroutine, how wonderful, everything just works
325 556
… …
345 $EXT_CORO{$coro+0} = $coro; 576 $EXT_CORO{$coro+0} = $coro;
346 577
347 $coro 578 $coro
348} 579}
349 580
350sub write_runtime { 581=item fork_call { }, $args
351 my $guard = cf::lock_acquire "write_runtime";
352 582
353 my $runtime = cf::localdir . "/runtime"; 583Executes the given code block with the given arguments in a seperate
584process, returning the results. Everything must be serialisable with
585Coro::Storable. May, of course, block. Note that the executed sub may
586never block itself or use any form of event handling.
354 587
355 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644 588=cut
356 or return;
357 589
358 my $value = $cf::RUNTIME + 90 + 10; 590sub fork_call(&@) {
359 # 10 is the runtime save interval, for a monotonic clock 591 my ($cb, @args) = @_;
360 # 60 allows for the watchdog to kill the server.
361 592
362 (aio_write $fh, 0, (length $value), $value, 0) <= 0 593 # we seemingly have to make a local copy of the whole thing,
363 and return; 594 # otherwise perl prematurely frees the stuff :/
595 # TODO: investigate and fix (likely this will be rather laborious)
364 596
365 # always fsync - this file is important 597 my @res = Coro::Util::fork_eval {
366 aio_fsync $fh 598 reset_signals;
367 and return; 599 &$cb
600 }, @args;
368 601
369 close $fh 602 wantarray ? @res : $res[-1]
370 or return; 603}
371 604
372 aio_rename "$runtime~", $runtime 605sub objinfo {
373 and return;
374
375 1 606 (
607 "counter value" => cf::object::object_count,
608 "objects created" => cf::object::create_count,
609 "objects destroyed" => cf::object::destroy_count,
610 "freelist size" => cf::object::free_count,
611 "allocated objects" => cf::object::objects_size,
612 "active objects" => cf::object::actives_size,
613 )
614}
615
616=item $coin = coin_from_name $name
617
618=cut
619
620our %coin_alias = (
621 "silver" => "silvercoin",
622 "silvercoin" => "silvercoin",
623 "silvercoins" => "silvercoin",
624 "gold" => "goldcoin",
625 "goldcoin" => "goldcoin",
626 "goldcoins" => "goldcoin",
627 "platinum" => "platinacoin",
628 "platinumcoin" => "platinacoin",
629 "platinumcoins" => "platinacoin",
630 "platina" => "platinacoin",
631 "platinacoin" => "platinacoin",
632 "platinacoins" => "platinacoin",
633 "royalty" => "royalty",
634 "royalties" => "royalty",
635);
636
637sub coin_from_name($) {
638 $coin_alias{$_[0]}
639 ? cf::arch::find $coin_alias{$_[0]}
640 : undef
641}
642
643=item $value = cf::db_get $family => $key
644
645Returns a single value from the environment database.
646
647=item cf::db_put $family => $key => $value
648
649Stores the given C<$value> in the family. It can currently store binary
650data only (use Compress::LZF::sfreeze_cr/sthaw to convert to/from binary).
651
652=item $db = cf::db_table "name"
653
654Create and/or open a new database table. The string must not be "db" and must be unique
655within each server.
656
657=cut
658
659sub db_table($) {
660 cf::error "db_get called from main context"
661 if $Coro::current == $Coro::main;
662
663 my ($name) = @_;
664 my $db = BDB::db_create $DB_ENV;
665
666 eval {
667 $db->set_flags (BDB::CHKSUM);
668
669 utf8::encode $name;
670 BDB::db_open $db, undef, $name, undef, BDB::BTREE,
671 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
672 cf::cleanup "db_open(db): $!" if $!;
673 };
674 cf::cleanup "db_open(db): $@" if $@;
675
676 $db
677}
678
679our $DB;
680
681sub db_init {
682 $DB ||= db_table "db";
683}
684
685sub db_get($$) {
686 my $key = "$_[0]/$_[1]";
687
688 cf::error "db_get called from main context"
689 if $Coro::current == $Coro::main;
690
691 BDB::db_get $DB, undef, $key, my $data;
692
693 $! ? ()
694 : $data
695}
696
697sub db_put($$$) {
698 BDB::dbreq_pri 4;
699 BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { };
700}
701
702=item cf::cache $id => [$paths...], $processversion => $process
703
704Generic caching function that returns the value of the resource $id,
705caching and regenerating as required.
706
707This function can block.
708
709=cut
710
711sub cache {
712 my ($id, $src, $processversion, $process) = @_;
713
714 my $meta =
715 join "\x00",
716 $processversion,
717 map {
718 aio_stat $_
719 and Carp::croak "$_: $!";
720
721 ($_, (stat _)[7,9])
722 } @$src;
723
724 my $dbmeta = db_get cache => "$id/meta";
725 if ($dbmeta ne $meta) {
726 # changed, we may need to process
727
728 my @data;
729 my $md5;
730
731 for (0 .. $#$src) {
732 0 <= aio_load $src->[$_], $data[$_]
733 or Carp::croak "$src->[$_]: $!";
734 }
735
736 # if processing is expensive, check
737 # checksum first
738 if (1) {
739 $md5 =
740 join "\x00",
741 $processversion,
742 map {
743 cf::cede_to_tick;
744 ($src->[$_], Digest::MD5::md5_hex $data[$_])
745 } 0.. $#$src;
746
747
748 my $dbmd5 = db_get cache => "$id/md5";
749 if ($dbmd5 eq $md5) {
750 db_put cache => "$id/meta", $meta;
751
752 return db_get cache => "$id/data";
753 }
754 }
755
756 my $t1 = Time::HiRes::time;
757 my $data = $process->(\@data);
758 my $t2 = Time::HiRes::time;
759
760 info "cache: '$id' processed in ", $t2 - $t1, "s\n";
761
762 db_put cache => "$id/data", $data;
763 db_put cache => "$id/md5" , $md5;
764 db_put cache => "$id/meta", $meta;
765
766 return $data;
767 }
768
769 db_get cache => "$id/data"
376} 770}
377 771
378=item cf::datalog type => key => value, ... 772=item cf::datalog type => key => value, ...
379 773
380Log a datalog packet of the given type with the given key-value pairs. 774Log a datalog packet of the given type with the given key-value pairs.
381 775
382=cut 776=cut
383 777
384sub datalog($@) { 778sub datalog($@) {
385 my ($type, %kv) = @_; 779 my ($type, %kv) = @_;
386 warn "DATALOG ", JSON::XS->new->ascii->encode ({ %kv, type => $type }); 780 info "DATALOG ", JSON::XS->new->ascii->encode ({ %kv, type => $type });
387} 781}
388 782
389=back 783=back
390 784
391=cut 785=cut
392 786
393############################################################################# 787#############################################################################
394 788
395=head2 ATTACHABLE OBJECTS 789=head2 ATTACHABLE OBJECTS
396 790
397Many objects in crossfire are so-called attachable objects. That means you can 791Many objects in deliantra are so-called attachable objects. That means you can
398attach callbacks/event handlers (a collection of which is called an "attachment") 792attach callbacks/event handlers (a collection of which is called an "attachment")
399to it. All such attachable objects support the following methods. 793to it. All such attachable objects support the following methods.
400 794
401In the following description, CLASS can be any of C<global>, C<object> 795In the following description, CLASS can be any of C<global>, C<object>
402C<player>, C<client> or C<map> (i.e. the attachable objects in 796C<player>, C<client> or C<map> (i.e. the attachable objects in
403crossfire+). 797Deliantra).
404 798
405=over 4 799=over 4
406 800
407=item $attachable->attach ($attachment, key => $value...) 801=item $attachable->attach ($attachment, key => $value...)
408 802
… …
452=item cf::CLASS::attachment $name, ... 846=item cf::CLASS::attachment $name, ...
453 847
454Register an attachment by C<$name> through which attachable objects of the 848Register an attachment by C<$name> through which attachable objects of the
455given CLASS can refer to this attachment. 849given CLASS can refer to this attachment.
456 850
457Some classes such as crossfire maps and objects can specify attachments 851Some classes such as deliantra maps and objects can specify attachments
458that are attached at load/instantiate time, thus the need for a name. 852that are attached at load/instantiate time, thus the need for a name.
459 853
460These calls expect any number of the following handler/hook descriptions: 854These calls expect any number of the following handler/hook descriptions:
461 855
462=over 4 856=over 4
… …
571 $registry = $CB_TYPE[$object_type] ||= []; 965 $registry = $CB_TYPE[$object_type] ||= [];
572 966
573 } elsif ($type eq "subtype") { 967 } elsif ($type eq "subtype") {
574 defined $object_type or Carp::croak "subtype specified without type"; 968 defined $object_type or Carp::croak "subtype specified without type";
575 my $object_subtype = shift @arg; 969 my $object_subtype = shift @arg;
576 $registry = $CB_TYPE[$object_type + $object_subtype * NUM_SUBTYPES] ||= []; 970 $registry = $CB_TYPE[$object_type + $object_subtype * NUM_TYPES] ||= [];
577 971
578 } elsif ($type eq "package") { 972 } elsif ($type eq "package") {
579 my $pkg = shift @arg; 973 my $pkg = shift @arg;
580 974
581 while (my ($name, $id) = each %cb_id) { 975 while (my ($name, $id) = each %cb_id) {
… …
586 980
587 } elsif (exists $cb_id{$type}) { 981 } elsif (exists $cb_id{$type}) {
588 _attach_cb $registry, $cb_id{$type}, $prio, shift @arg; 982 _attach_cb $registry, $cb_id{$type}, $prio, shift @arg;
589 983
590 } elsif (ref $type) { 984 } elsif (ref $type) {
591 warn "attaching objects not supported, ignoring.\n"; 985 error "attaching objects not supported, ignoring.\n";
592 986
593 } else { 987 } else {
594 shift @arg; 988 shift @arg;
595 warn "attach argument '$type' not supported, ignoring.\n"; 989 error "attach argument '$type' not supported, ignoring.\n";
596 } 990 }
597 } 991 }
598} 992}
599 993
600sub _object_attach { 994sub _object_attach {
… …
610 _attach $registry, $klass, @attach; 1004 _attach $registry, $klass, @attach;
611 } 1005 }
612 1006
613 $obj->{$name} = \%arg; 1007 $obj->{$name} = \%arg;
614 } else { 1008 } else {
615 warn "object uses attachment '$name' that is not available, postponing.\n"; 1009 info "object uses attachment '$name' which is not available, postponing.\n";
616 } 1010 }
617 1011
618 $obj->{_attachment}{$name} = undef; 1012 $obj->{_attachment}{$name} = undef;
619} 1013}
620 1014
… …
622 if (ref $_[0]) { 1016 if (ref $_[0]) {
623 _object_attach @_; 1017 _object_attach @_;
624 } else { 1018 } else {
625 _attach shift->_attach_registry, @_; 1019 _attach shift->_attach_registry, @_;
626 } 1020 }
1021 _recalc_want;
627}; 1022};
628 1023
629# all those should be optimised 1024# all those should be optimised
630sub cf::attachable::detach { 1025sub cf::attachable::detach {
631 my ($obj, $name) = @_; 1026 my ($obj, $name) = @_;
… …
634 delete $obj->{_attachment}{$name}; 1029 delete $obj->{_attachment}{$name};
635 reattach ($obj); 1030 reattach ($obj);
636 } else { 1031 } else {
637 Carp::croak "cannot, currently, detach class attachments"; 1032 Carp::croak "cannot, currently, detach class attachments";
638 } 1033 }
1034 _recalc_want;
639}; 1035};
640 1036
641sub cf::attachable::attached { 1037sub cf::attachable::attached {
642 my ($obj, $name) = @_; 1038 my ($obj, $name) = @_;
643 1039
… …
658 "; 1054 ";
659 die if $@; 1055 die if $@;
660} 1056}
661 1057
662our $override; 1058our $override;
663our @invoke_results = (); # referenced from .xs code. TODO: play tricks with reify and mortals? 1059our @INVOKE_RESULTS = (); # referenced from .xs code. TODO: play tricks with reify and mortals?
664 1060
665sub override { 1061sub override {
666 $override = 1; 1062 $override = 1;
667 @invoke_results = (); 1063 @INVOKE_RESULTS = (@_);
668} 1064}
669 1065
670sub do_invoke { 1066sub do_invoke {
671 my $event = shift; 1067 my $event = shift;
672 my $callbacks = shift; 1068 my $callbacks = shift;
673 1069
674 @invoke_results = (); 1070 @INVOKE_RESULTS = ();
675 1071
676 local $override; 1072 local $override;
677 1073
678 for (@$callbacks) { 1074 for (@$callbacks) {
679 eval { &{$_->[1]} }; 1075 eval { &{$_->[1]} };
680 1076
681 if ($@) { 1077 if ($@) {
682 warn "$@";
683 warn "... while processing $EVENT[$event][0](@_) event, skipping processing altogether.\n"; 1078 error "$@", "... while processing $EVENT[$event][0](@_) event, skipping processing altogether.\n";
684 override; 1079 override;
685 } 1080 }
686 1081
687 return 1 if $override; 1082 return 1 if $override;
688 } 1083 }
689 1084
690 0 1085 0
691} 1086}
692 1087
693=item $bool = cf::global::invoke (EVENT_CLASS_XXX, ...) 1088=item $bool = cf::global->invoke (EVENT_CLASS_XXX, ...)
694 1089
695=item $bool = $attachable->invoke (EVENT_CLASS_XXX, ...) 1090=item $bool = $attachable->invoke (EVENT_CLASS_XXX, ...)
696 1091
697Generate an object-specific event with the given arguments. 1092Generate an object-specific event with the given arguments.
698 1093
699This API is preliminary (most likely, the EVENT_CLASS_xxx prefix will be 1094This API is preliminary (most likely, the EVENT_CLASS_xxx prefix will be
700removed in future versions), and there is no public API to access override 1095removed in future versions), and there is no public API to access override
701results (if you must, access C<@cf::invoke_results> directly). 1096results (if you must, access C<@cf::INVOKE_RESULTS> directly).
702 1097
703=back 1098=back
704 1099
705=cut 1100=cut
706 1101
707############################################################################# 1102#############################################################################
708# object support 1103# object support
1104
1105sub _object_equal($$);
1106sub _object_equal($$) {
1107 my ($a, $b) = @_;
1108
1109 return 0 unless (ref $a) eq (ref $b);
1110
1111 if ("HASH" eq ref $a) {
1112 my @ka = keys %$a;
1113 my @kb = keys %$b;
1114
1115 return 0 if @ka != @kb;
1116
1117 for (0 .. $#ka) {
1118 return 0 unless $ka[$_] eq $kb[$_];
1119 return 0 unless _object_equal $a->{$ka[$_]}, $b->{$kb[$_]};
1120 }
1121
1122 } elsif ("ARRAY" eq ref $a) {
1123
1124 return 0 if @$a != @$b;
1125
1126 for (0 .. $#$a) {
1127 return 0 unless _object_equal $a->[$_], $b->[$_];
1128 }
1129
1130 } elsif ($a ne $b) {
1131 return 0;
1132 }
1133
1134 1
1135}
1136
1137our $SLOW_MERGES;#d#
1138sub _can_merge {
1139 my ($ob1, $ob2) = @_;
1140
1141 ++$SLOW_MERGES;#d#
1142
1143 # we do the slow way here
1144 return _object_equal $ob1, $ob2
1145}
709 1146
710sub reattach { 1147sub reattach {
711 # basically do the same as instantiate, without calling instantiate 1148 # basically do the same as instantiate, without calling instantiate
712 my ($obj) = @_; 1149 my ($obj) = @_;
713 1150
1151 # no longer needed after getting rid of delete_package?
714 bless $obj, ref $obj; # re-bless in case extensions have been reloaded 1152 #bless $obj, ref $obj; # re-bless in case extensions have been reloaded
715 1153
716 my $registry = $obj->registry; 1154 my $registry = $obj->registry;
717 1155
718 @$registry = (); 1156 @$registry = ();
719 1157
… …
724 for (@$attach) { 1162 for (@$attach) {
725 my ($klass, @attach) = @$_; 1163 my ($klass, @attach) = @$_;
726 _attach $registry, $klass, @attach; 1164 _attach $registry, $klass, @attach;
727 } 1165 }
728 } else { 1166 } else {
729 warn "object uses attachment '$name' that is not available, postponing.\n"; 1167 info "object uses attachment '$name' that is not available, postponing.\n";
730 } 1168 }
731 } 1169 }
732} 1170}
733 1171
734cf::attachable->attach ( 1172cf::attachable->attach (
735 prio => -1000000, 1173 prio => -1000000,
736 on_instantiate => sub { 1174 on_instantiate => sub {
737 my ($obj, $data) = @_; 1175 my ($obj, $data) = @_;
738 1176
739 $data = from_json $data; 1177 $data = decode_json $data;
740 1178
741 for (@$data) { 1179 for (@$data) {
742 my ($name, $args) = @$_; 1180 my ($name, $args) = @$_;
743 1181
744 $obj->attach ($name, %{$args || {} }); 1182 $obj->attach ($name, %{$args || {} });
… …
760sub object_freezer_save { 1198sub object_freezer_save {
761 my ($filename, $rdata, $objs) = @_; 1199 my ($filename, $rdata, $objs) = @_;
762 1200
763 sync_job { 1201 sync_job {
764 if (length $$rdata) { 1202 if (length $$rdata) {
1203 utf8::decode (my $decname = $filename);
765 warn sprintf "saving %s (%d,%d)\n", 1204 trace sprintf "saving %s (%d,%d)\n",
766 $filename, length $$rdata, scalar @$objs; 1205 $decname, length $$rdata, scalar @$objs
1206 if $VERBOSE_IO;
767 1207
768 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) { 1208 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
769 chmod SAVE_MODE, $fh; 1209 aio_chmod $fh, SAVE_MODE;
770 aio_write $fh, 0, (length $$rdata), $$rdata, 0; 1210 aio_write $fh, 0, (length $$rdata), $$rdata, 0;
771 aio_fsync $fh if $cf::USE_FSYNC; 1211 if ($cf::USE_FSYNC) {
1212 aio_sync_file_range $fh, 0, 0, IO::AIO::SYNC_FILE_RANGE_WAIT_BEFORE | IO::AIO::SYNC_FILE_RANGE_WRITE | IO::AIO::SYNC_FILE_RANGE_WAIT_AFTER;
1213 aio_fsync $fh;
1214 }
772 close $fh; 1215 aio_close $fh;
773 1216
774 if (@$objs) { 1217 if (@$objs) {
775 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) { 1218 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) {
776 chmod SAVE_MODE, $fh; 1219 aio_chmod $fh, SAVE_MODE;
777 my $data = Storable::nfreeze { version => 1, objs => $objs }; 1220 my $data = Coro::Storable::nfreeze { version => 1, objs => $objs };
778 aio_write $fh, 0, (length $data), $data, 0; 1221 aio_write $fh, 0, (length $data), $data, 0;
779 aio_fsync $fh if $cf::USE_FSYNC; 1222 if ($cf::USE_FSYNC) {
1223 aio_sync_file_range $fh, 0, 0, IO::AIO::SYNC_FILE_RANGE_WAIT_BEFORE | IO::AIO::SYNC_FILE_RANGE_WRITE | IO::AIO::SYNC_FILE_RANGE_WAIT_AFTER;
1224 aio_fsync $fh;
1225 }
780 close $fh; 1226 aio_close $fh;
781 aio_rename "$filename.pst~", "$filename.pst"; 1227 aio_rename "$filename.pst~", "$filename.pst";
782 } 1228 }
783 } else { 1229 } else {
784 aio_unlink "$filename.pst"; 1230 aio_unlink "$filename.pst";
785 } 1231 }
786 1232
787 aio_rename "$filename~", $filename; 1233 aio_rename "$filename~", $filename;
1234
1235 $filename =~ s%/[^/]+$%%;
1236 aio_pathsync $filename if $cf::USE_FSYNC;
788 } else { 1237 } else {
789 warn "FATAL: $filename~: $!\n"; 1238 error "unable to save objects: $filename~: $!\n";
790 } 1239 }
791 } else { 1240 } else {
792 aio_unlink $filename; 1241 aio_unlink $filename;
793 aio_unlink "$filename.pst"; 1242 aio_unlink "$filename.pst";
794 } 1243 }
795 } 1244 };
796} 1245}
797 1246
798sub object_freezer_as_string { 1247sub object_freezer_as_string {
799 my ($rdata, $objs) = @_; 1248 my ($rdata, $objs) = @_;
800 1249
… …
812 or return; 1261 or return;
813 1262
814 unless (aio_stat "$filename.pst") { 1263 unless (aio_stat "$filename.pst") {
815 (aio_load "$filename.pst", $av) >= 0 1264 (aio_load "$filename.pst", $av) >= 0
816 or return; 1265 or return;
1266
817 $av = eval { (Storable::thaw $av)->{objs} }; 1267 my $st = eval { Coro::Storable::thaw $av };
1268 $av = $st->{objs};
818 } 1269 }
819 1270
1271 utf8::decode (my $decname = $filename);
820 warn sprintf "loading %s (%d)\n", 1272 trace sprintf "loading %s (%d,%d)\n",
821 $filename, length $data, scalar @{$av || []};#d# 1273 $decname, length $data, scalar @{$av || []}
1274 if $VERBOSE_IO;
1275
822 return ($data, $av); 1276 ($data, $av)
823} 1277}
1278
1279=head2 COMMAND CALLBACKS
1280
1281=over 4
1282
1283=cut
824 1284
825############################################################################# 1285#############################################################################
826# command handling &c 1286# command handling &c
827 1287
828=item cf::register_command $name => \&callback($ob,$args); 1288=item cf::register_command $name => \&callback($ob,$args);
… …
841 push @{ $COMMAND{$name} }, [$caller, $cb]; 1301 push @{ $COMMAND{$name} }, [$caller, $cb];
842} 1302}
843 1303
844=item cf::register_extcmd $name => \&callback($pl,$packet); 1304=item cf::register_extcmd $name => \&callback($pl,$packet);
845 1305
846Register a callbackf ro execution when the client sends an extcmd packet. 1306Register a callback for execution when the client sends an (synchronous)
1307extcmd packet. Ext commands will be processed in the order they are
1308received by the server, like other user commands. The first argument is
1309the logged-in player. Ext commands can only be processed after a player
1310has logged in successfully.
847 1311
848If the callback returns something, it is sent back as if reply was being 1312If the callback returns something, it is sent back as if reply was being
849called. 1313called.
850 1314
1315=item cf::register_exticmd $name => \&callback($ns,$packet);
1316
1317Register a callback for execution when the client sends an (asynchronous)
1318exticmd packet. Exti commands are processed by the server as soon as they
1319are received, i.e. out of order w.r.t. other commands. The first argument
1320is a client socket. Exti commands can be received anytime, even before
1321log-in.
1322
1323If the callback returns something, it is sent back as if reply was being
1324called.
1325
851=cut 1326=cut
852 1327
853sub register_extcmd { 1328sub register_extcmd {
854 my ($name, $cb) = @_; 1329 my ($name, $cb) = @_;
855 1330
856 $EXTCMD{$name} = $cb; 1331 $EXTCMD{$name} = $cb;
857} 1332}
858 1333
1334sub register_exticmd {
1335 my ($name, $cb) = @_;
1336
1337 $EXTICMD{$name} = $cb;
1338}
1339
1340use File::Glob ();
1341
859cf::player->attach ( 1342cf::player->attach (
860 on_command => sub { 1343 on_unknown_command => sub {
861 my ($pl, $name, $params) = @_; 1344 my ($pl, $name, $params) = @_;
862 1345
863 my $cb = $COMMAND{$name} 1346 my $cb = $COMMAND{$name}
864 or return; 1347 or return;
865 1348
… …
870 cf::override; 1353 cf::override;
871 }, 1354 },
872 on_extcmd => sub { 1355 on_extcmd => sub {
873 my ($pl, $buf) = @_; 1356 my ($pl, $buf) = @_;
874 1357
875 my $msg = eval { from_json $buf }; 1358 my $msg = eval { $pl->ns->{json_coder}->decode ($buf) };
876 1359
877 if (ref $msg) { 1360 if (ref $msg) {
1361 my ($type, $reply, @payload) =
1362 "ARRAY" eq ref $msg
1363 ? @$msg
1364 : ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
1365
1366 my @reply;
1367
878 if (my $cb = $EXTCMD{$msg->{msgtype}}) { 1368 if (my $cb = $EXTCMD{$type}) {
879 if (my %reply = $cb->($pl, $msg)) { 1369 @reply = $cb->($pl, @payload);
880 $pl->ext_reply ($msg->{msgid}, %reply);
881 }
882 } 1370 }
1371
1372 $pl->ext_reply ($reply, @reply)
1373 if $reply;
1374
883 } else { 1375 } else {
884 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n"; 1376 error "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
885 } 1377 }
886 1378
887 cf::override; 1379 cf::override;
888 }, 1380 },
889); 1381);
890 1382
1383# "readahead" all extensions
891sub load_extension { 1384sub cache_extensions {
892 my ($path) = @_; 1385 my $grp = IO::AIO::aio_group;
893 1386
894 $path =~ /([^\/\\]+)\.ext$/ or die "$path"; 1387 add $grp IO::AIO::aio_readdirx $LIBDIR, IO::AIO::READDIR_STAT_ORDER, sub {
895 my $base = $1; 1388 for (grep /\.ext$/, @{$_[0]}) {
896 my $pkg = $1; 1389 add $grp IO::AIO::aio_load "$LIBDIR/$_", my $data;
897 $pkg =~ s/[^[:word:]]/_/g;
898 $pkg = "ext::$pkg";
899
900 warn "... loading '$path' into '$pkg'\n";
901
902 open my $fh, "<:utf8", $path
903 or die "$path: $!";
904
905 my $source =
906 "package $pkg; use strict; use utf8;\n"
907 . "#line 1 \"$path\"\n{\n"
908 . (do { local $/; <$fh> })
909 . "\n};\n1";
910
911 unless (eval $source) {
912 my $msg = $@ ? "$path: $@\n"
913 : "extension disabled.\n";
914 if ($source =~ /^#!.*perl.*#.*MANDATORY/m) { # ugly match
915 warn $@;
916 warn "mandatory extension failed to load, exiting.\n";
917 exit 1;
918 } 1390 }
919 die $@;
920 } 1391 };
921 1392
922 push @EXTS, $pkg; 1393 $grp
923} 1394}
924 1395
925sub load_extensions { 1396sub load_extensions {
1397 info "loading extensions...";
1398
1399 cf::sync_job {
1400 my %todo;
1401
926 for my $ext (<$LIBDIR/*.ext>) { 1402 for my $path (<$LIBDIR/*.ext>) {
927 next unless -r $ext; 1403 next unless -r $path;
928 eval { 1404
929 load_extension $ext; 1405 $path =~ /([^\/\\]+)\.ext$/ or die "$path";
1406 my $base = $1;
1407 my $pkg = $1;
1408 $pkg =~ s/[^[:word:]]/_/g;
1409 $pkg = "ext::$pkg";
1410
1411 open my $fh, "<:utf8", $path
1412 or die "$path: $!";
1413
1414 my $source = do { local $/; <$fh> };
1415
1416 my %ext = (
1417 path => $path,
1418 base => $base,
1419 pkg => $pkg,
1420 );
1421
1422 $ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 }
1423 if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m;
1424
1425 $ext{source} =
1426 "package $pkg; use common::sense;\n"
1427 . "#line 1 \"$path\"\n{\n"
1428 . $source
1429 . "\n};\n1";
1430
1431 $todo{$base} = \%ext;
1432 }
1433
1434 my $pass = 0;
1435 my %done;
1436 while (%todo) {
1437 my $progress;
1438
1439 ++$pass;
1440
1441 ext:
1442 while (my ($k, $v) = each %todo) {
1443 for (split /,\s*/, $v->{meta}{depends}) {
1444 next ext
1445 unless exists $done{$_};
1446 }
1447
1448 trace "... pass $pass, loading '$k' into '$v->{pkg}'\n";
1449
1450 my $active = eval $v->{source};
1451
1452 if (length $@) {
1453 error "$v->{path}: $@\n";
1454 undef $@; # work around perl 5.10.0 utf-8 caching bug
1455
1456 cf::cleanup "mandatory extension '$k' failed to load, exiting."
1457 if exists $v->{meta}{mandatory};
1458
1459 warn "$v->{base}: optional extension cannot be loaded, skipping.\n";
1460 delete $todo{$k};
1461 } else {
1462 $done{$k} = delete $todo{$k};
1463 push @EXTS, $v->{pkg};
1464 $progress = 1;
1465
1466 info "$v->{base}: extension inactive.\n"
1467 unless $active;
1468 }
930 1 1469 }
931 } or warn "$ext not loaded: $@"; 1470
1471 unless ($progress) {
1472 warn "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n";
1473
1474 while (my ($k, $v) = each %todo) {
1475 cf::cleanup "mandatory extension '$k' has unresolved dependencies, exiting."
1476 if exists $v->{meta}{mandatory};
1477 }
1478 }
1479 }
932 } 1480 };
933} 1481}
934 1482
935############################################################################# 1483#############################################################################
936 1484
1485=back
1486
937=head2 CORE EXTENSIONS 1487=head2 CORE EXTENSIONS
938 1488
939Functions and methods that extend core crossfire objects. 1489Functions and methods that extend core deliantra objects.
940 1490
941=cut 1491=cut
942 1492
943package cf::player; 1493package cf::player;
944 1494
… …
946 1496
947=head3 cf::player 1497=head3 cf::player
948 1498
949=over 4 1499=over 4
950 1500
1501=item cf::player::num_playing
1502
1503Returns the official number of playing players, as per the Crossfire metaserver rules.
1504
1505=cut
1506
1507sub num_playing {
1508 scalar grep
1509 $_->ob->map
1510 && !$_->hidden
1511 && !$_->ob->flag (cf::FLAG_WIZ),
1512 cf::player::list
1513}
1514
951=item cf::player::find $login 1515=item cf::player::find $login
952 1516
953Returns the given player object, loading it if necessary (might block). 1517Returns the given player object, loading it if necessary (might block).
954 1518
955=cut 1519=cut
956 1520
957sub playerdir($) { 1521sub playerdir($) {
958 cf::localdir 1522 "$PLAYERDIR/"
959 . "/"
960 . cf::playerdir
961 . "/"
962 . (ref $_[0] ? $_[0]->ob->name : $_[0]) 1523 . (ref $_[0] ? $_[0]->ob->name : $_[0])
963} 1524}
964 1525
965sub path($) { 1526sub path($) {
966 my $login = ref $_[0] ? $_[0]->ob->name : $_[0]; 1527 my $login = ref $_[0] ? $_[0]->ob->name : $_[0];
967 1528
968 (playerdir $login) . "/$login.pl" 1529 (playerdir $login) . "/playerdata"
969} 1530}
970 1531
971sub find_active($) { 1532sub find_active($) {
972 $cf::PLAYER{$_[0]} 1533 $cf::PLAYER{$_[0]}
973 and $cf::PLAYER{$_[0]}->active 1534 and $cf::PLAYER{$_[0]}->active
… …
976 1537
977sub exists($) { 1538sub exists($) {
978 my ($login) = @_; 1539 my ($login) = @_;
979 1540
980 $cf::PLAYER{$login} 1541 $cf::PLAYER{$login}
981 or cf::sync_job { !aio_stat path $login } 1542 or !aio_stat path $login
982} 1543}
983 1544
984sub find($) { 1545sub find($) {
985 return $cf::PLAYER{$_[0]} || do { 1546 return $cf::PLAYER{$_[0]} || do {
986 my $login = $_[0]; 1547 my $login = $_[0];
987 1548
988 my $guard = cf::lock_acquire "user_find:$login"; 1549 my $guard = cf::lock_acquire "user_find:$login";
989 1550
990 $cf::PLAYER{$_[0]} || do { 1551 $cf::PLAYER{$_[0]} || do {
991 my $pl = load_pl path $login 1552 # rename old playerfiles to new ones
1553 #TODO: remove when no longer required
1554 aio_link +(playerdir $login) . "/$login.pl.pst", (playerdir $login) . "/playerdata.pst";
1555 aio_link +(playerdir $login) . "/$login.pl" , (playerdir $login) . "/playerdata";
1556 aio_unlink +(playerdir $login) . "/$login.pl.pst";
1557 aio_unlink +(playerdir $login) . "/$login.pl";
1558
1559 my $f = new_from_file cf::object::thawer path $login
992 or return; 1560 or return;
1561
1562 my $pl = cf::player::load_pl $f
1563 or return;
1564
1565 local $cf::PLAYER_LOADING{$login} = $pl;
1566 $f->resolve_delayed_derefs;
993 $cf::PLAYER{$login} = $pl 1567 $cf::PLAYER{$login} = $pl
994 } 1568 }
995 } 1569 }
996} 1570}
1571
1572cf::player->attach (
1573 on_load => sub {
1574 my ($pl, $path) = @_;
1575
1576 # restore slots saved in save, below
1577 my $slots = delete $pl->{_slots};
1578
1579 $pl->ob->current_weapon ($slots->[0]);
1580 $pl->combat_ob ($slots->[1]);
1581 $pl->ranged_ob ($slots->[2]);
1582 },
1583);
997 1584
998sub save($) { 1585sub save($) {
999 my ($pl) = @_; 1586 my ($pl) = @_;
1000 1587
1001 return if $pl->{deny_save}; 1588 return if $pl->{deny_save};
… …
1006 return if $pl->{deny_save}; 1593 return if $pl->{deny_save};
1007 1594
1008 aio_mkdir playerdir $pl, 0770; 1595 aio_mkdir playerdir $pl, 0770;
1009 $pl->{last_save} = $cf::RUNTIME; 1596 $pl->{last_save} = $cf::RUNTIME;
1010 1597
1598 cf::get_slot 0.01;
1599
1600 # save slots, to be restored later
1601 local $pl->{_slots} = [$pl->ob->current_weapon, $pl->combat_ob, $pl->ranged_ob];
1602
1011 $pl->save_pl ($path); 1603 $pl->save_pl ($path);
1012 Coro::cede; 1604 cf::cede_to_tick;
1013} 1605}
1014 1606
1015sub new($) { 1607sub new($) {
1016 my ($login) = @_; 1608 my ($login) = @_;
1017 1609
… …
1023 $cf::PLAYER{$login} = $self; 1615 $cf::PLAYER{$login} = $self;
1024 1616
1025 $self 1617 $self
1026} 1618}
1027 1619
1620=item $player->send_msg ($channel, $msg, $color, [extra...])
1621
1622=cut
1623
1624sub send_msg {
1625 my $ns = shift->ns
1626 or return;
1627 $ns->send_msg (@_);
1628}
1629
1028=item $pl->quit_character 1630=item $pl->quit_character
1029 1631
1030Nukes the player without looking back. If logged in, the connection will 1632Nukes the player without looking back. If logged in, the connection will
1031be destroyed. May block for a long time. 1633be destroyed. May block for a long time.
1032 1634
… …
1036 my ($pl) = @_; 1638 my ($pl) = @_;
1037 1639
1038 my $name = $pl->ob->name; 1640 my $name = $pl->ob->name;
1039 1641
1040 $pl->{deny_save} = 1; 1642 $pl->{deny_save} = 1;
1041 $pl->password ("*"); # this should lock out the player until we nuked the dir 1643 $pl->password ("*"); # this should lock out the player until we have nuked the dir
1042 1644
1043 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active; 1645 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active;
1044 $pl->deactivate; 1646 $pl->deactivate;
1647 my $killer = cf::arch::get "killer_quit"; $pl->killer ($killer); $killer->destroy;
1045 $pl->invoke (cf::EVENT_PLAYER_QUIT); 1648 $pl->invoke (cf::EVENT_PLAYER_QUIT);
1046 $pl->ns->destroy if $pl->ns; 1649 $pl->ns->destroy if $pl->ns;
1047 1650
1048 my $path = playerdir $pl; 1651 my $path = playerdir $pl;
1049 my $temp = "$path~$cf::RUNTIME~deleting~"; 1652 my $temp = "$path~$cf::RUNTIME~deleting~";
… …
1079while and may block, so not sync_job-capable, ever. 1682while and may block, so not sync_job-capable, ever.
1080 1683
1081=cut 1684=cut
1082 1685
1083sub list_logins { 1686sub list_logins {
1084 my $dirs = aio_readdir cf::localdir . "/" . cf::playerdir 1687 my $dirs = aio_readdir $PLAYERDIR
1085 or return []; 1688 or return [];
1086 1689
1087 my @logins; 1690 my @logins;
1088 1691
1089 for my $login (@$dirs) { 1692 for my $login (@$dirs) {
1693 my $path = path $login;
1694
1695 # a .pst is a dead give-away for a valid player
1696 # if no pst file found, open and chekc for blocked users
1697 if (aio_stat "$path.pst") {
1090 my $fh = aio_open path $login, Fcntl::O_RDONLY, 0 or next; 1698 my $fh = aio_open $path, Fcntl::O_RDONLY, 0 or next;
1091 aio_read $fh, 0, 512, my $buf, 0 or next; 1699 aio_read $fh, 0, 512, my $buf, 0 or next;
1092 $buf !~ /^password -------------$/m or next; # official not-valid tag 1700 $buf !~ /^password -------------$/m or next; # official not-valid tag
1701 }
1093 1702
1094 utf8::decode $login; 1703 utf8::decode $login;
1095 push @logins, $login; 1704 push @logins, $login;
1096 } 1705 }
1097 1706
1098 \@logins 1707 \@logins
1099} 1708}
1100 1709
1101=item $player->maps 1710=item $player->maps
1711
1712=item cf::player::maps $login
1102 1713
1103Returns an arrayref of map paths that are private for this 1714Returns an arrayref of map paths that are private for this
1104player. May block. 1715player. May block.
1105 1716
1106=cut 1717=cut
… …
1124 } 1735 }
1125 1736
1126 \@paths 1737 \@paths
1127} 1738}
1128 1739
1740=item $protocol_xml = $player->expand_cfpod ($cfpod)
1741
1742Expand deliantra pod fragments into protocol xml.
1743
1129=item $player->ext_reply ($msgid, %msg) 1744=item $player->ext_reply ($msgid, @msg)
1130 1745
1131Sends an ext reply to the player. 1746Sends an ext reply to the player.
1132 1747
1133=cut 1748=cut
1134 1749
1135sub ext_reply($$%) { 1750sub ext_reply($$@) {
1136 my ($self, $id, %msg) = @_; 1751 my ($self, $id, @msg) = @_;
1137 1752
1138 $msg{msgid} = $id; 1753 $self->ns->ext_reply ($id, @msg)
1139
1140 $self->send ("ext " . cf::to_json \%msg);
1141} 1754}
1142 1755
1143=item $player->ext_event ($type, %msg) 1756=item $player->ext_msg ($type, @msg)
1144 1757
1145Sends an ext event to the client. 1758Sends an ext event to the client.
1146 1759
1147=cut 1760=cut
1148 1761
1149sub ext_event($$%) { 1762sub ext_msg($$@) {
1150 my ($self, $type, %msg) = @_; 1763 my ($self, $type, @msg) = @_;
1151 1764
1152 $self->ns->ext_event ($type, %msg); 1765 $self->ns->ext_msg ($type, @msg);
1153} 1766}
1154 1767
1155package cf; 1768=head3 cf::region
1769
1770=over 4
1771
1772=cut
1773
1774package cf::region;
1775
1776=item cf::region::find_by_path $path
1777
1778Tries to decuce the likely region for a map knowing only its path.
1779
1780=cut
1781
1782sub find_by_path($) {
1783 my ($path) = @_;
1784
1785 $path =~ s/^~[^\/]*//; # skip ~login
1786
1787 my ($match, $specificity);
1788
1789 for my $region (list) {
1790 if ($region->{match} && $path =~ $region->{match}) {
1791 ($match, $specificity) = ($region, $region->specificity)
1792 if $region->specificity > $specificity;
1793 }
1794 }
1795
1796 $match
1797}
1156 1798
1157=back 1799=back
1158
1159 1800
1160=head3 cf::map 1801=head3 cf::map
1161 1802
1162=over 4 1803=over 4
1163 1804
… …
1175our $MAX_RESET = 3600; 1816our $MAX_RESET = 3600;
1176our $DEFAULT_RESET = 3000; 1817our $DEFAULT_RESET = 3000;
1177 1818
1178sub generate_random_map { 1819sub generate_random_map {
1179 my ($self, $rmp) = @_; 1820 my ($self, $rmp) = @_;
1821
1822 my $lock = cf::lock_acquire "generate_random_map"; # the random map generator is NOT reentrant ATM
1823
1180 # mit "rum" bekleckern, nicht 1824 # mit "rum" bekleckern, nicht
1181 $self->_create_random_map ( 1825 $self->_create_random_map (
1182 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle}, 1826 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle},
1183 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle}, 1827 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle}, $rmp->{miningstyle},
1184 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map}, 1828 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map},
1185 $rmp->{exit_on_final_map}, 1829 $rmp->{exit_on_final_map},
1186 $rmp->{xsize}, $rmp->{ysize}, 1830 $rmp->{xsize}, $rmp->{ysize},
1187 $rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3}, 1831 $rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3},
1188 $rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase}, 1832 $rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase},
… …
1203 1847
1204sub register { 1848sub register {
1205 my (undef, $regex, $prio) = @_; 1849 my (undef, $regex, $prio) = @_;
1206 my $pkg = caller; 1850 my $pkg = caller;
1207 1851
1208 no strict;
1209 push @{"$pkg\::ISA"}, __PACKAGE__; 1852 push @{"$pkg\::ISA"}, __PACKAGE__;
1210 1853
1211 $EXT_MAP{$pkg} = [$prio, qr<$regex>]; 1854 $EXT_MAP{$pkg} = [$prio, qr<$regex>];
1212} 1855}
1213 1856
1214# also paths starting with '/' 1857# also paths starting with '/'
1215$EXT_MAP{"cf::map"} = [0, qr{^(?=/)}]; 1858$EXT_MAP{"cf::map::wrap"} = [0, qr{^(?=/)}];
1216 1859
1217sub thawer_merge { 1860sub thawer_merge {
1218 my ($self, $merge) = @_; 1861 my ($self, $merge) = @_;
1219 1862
1220 # we have to keep some variables in memory intact 1863 # we have to keep some variables in memory intact
1221 local $self->{path}; 1864 local $self->{path};
1222 local $self->{load_path}; 1865 local $self->{load_path};
1223 local $self->{deny_save};
1224 local $self->{deny_reset};
1225 1866
1226 $self->SUPER::thawer_merge ($merge); 1867 $self->SUPER::thawer_merge ($merge);
1227} 1868}
1228 1869
1229sub normalise { 1870sub normalise {
… …
1276 $self->init; # pass $1 etc. 1917 $self->init; # pass $1 etc.
1277 return $self; 1918 return $self;
1278 } 1919 }
1279 } 1920 }
1280 1921
1281 Carp::carp "unable to resolve path '$path' (base '$base')."; 1922 Carp::cluck "unable to resolve path '$path' (base '$base').";
1282 () 1923 ()
1283} 1924}
1284 1925
1285sub init { 1926sub init {
1286 my ($self) = @_; 1927 my ($self) = @_;
… …
1301 1942
1302# the original (read-only) location 1943# the original (read-only) location
1303sub load_path { 1944sub load_path {
1304 my ($self) = @_; 1945 my ($self) = @_;
1305 1946
1306 sprintf "%s/%s/%s.map", cf::datadir, cf::mapdir, $self->{path} 1947 "$MAPDIR/$self->{path}.map"
1307} 1948}
1308 1949
1309# the temporary/swap location 1950# the temporary/swap location
1310sub save_path { 1951sub save_path {
1311 my ($self) = @_; 1952 my ($self) = @_;
1312 1953
1313 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g; 1954 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/go;
1314 sprintf "%s/%s/%s.map", cf::localdir, cf::tmpdir, $path 1955 "$TMPDIR/$path.map"
1315} 1956}
1316 1957
1317# the unique path, undef == no special unique path 1958# the unique path, undef == no special unique path
1318sub uniq_path { 1959sub uniq_path {
1319 my ($self) = @_; 1960 my ($self) = @_;
1320 1961
1321 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g; 1962 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/go;
1322 sprintf "%s/%s/%s", cf::localdir, cf::uniquedir, $path 1963 "$UNIQUEDIR/$path"
1323} 1964}
1324 1965
1325# and all this just because we cannot iterate over 1966sub decay_objects {
1326# all maps in C++...
1327sub change_all_map_light {
1328 my ($change) = @_; 1967 my ($self) = @_;
1329 1968
1330 $_->change_map_light ($change) 1969 return if $self->{deny_reset};
1331 for grep $_->outdoor, values %cf::MAP; 1970
1971 $self->do_decay_objects;
1332} 1972}
1333 1973
1334sub unlink_save { 1974sub unlink_save {
1335 my ($self) = @_; 1975 my ($self) = @_;
1336 1976
… …
1341 1981
1342sub load_header_from($) { 1982sub load_header_from($) {
1343 my ($self, $path) = @_; 1983 my ($self, $path) = @_;
1344 1984
1345 utf8::encode $path; 1985 utf8::encode $path;
1346 #aio_open $path, O_RDONLY, 0 1986 my $f = new_from_file cf::object::thawer $path
1347 # or return;
1348
1349 $self->_load_header ($path)
1350 or return; 1987 or return;
1988
1989 $self->_load_header ($f)
1990 or return;
1991
1992 local $MAP_LOADING{$self->{path}} = $self;
1993 $f->resolve_delayed_derefs;
1351 1994
1352 $self->{load_path} = $path; 1995 $self->{load_path} = $path;
1353 1996
1354 1 1997 1
1355} 1998}
… …
1394 $self->load_header_orig 2037 $self->load_header_orig
1395 or return; 2038 or return;
1396 $self->prepare_orig; 2039 $self->prepare_orig;
1397 } 2040 }
1398 2041
2042 $self->{deny_reset} = 1
2043 if $self->no_reset;
2044
2045 $self->default_region (cf::region::find_by_path $self->{path})
2046 unless $self->default_region;
2047
1399 1 2048 1
1400} 2049}
1401 2050
1402sub find; 2051sub find;
1403sub find { 2052sub find {
1404 my ($path, $origin) = @_; 2053 my ($path, $origin) = @_;
1405 2054
1406 $path = normalise $path, $origin && $origin->path; 2055 $path = normalise $path, $origin && $origin->path;
1407 2056
2057 my $guard1 = cf::lock_acquire "map_data:$path";#d#remove
1408 cf::lock_wait "map_find:$path"; 2058 my $guard2 = cf::lock_acquire "map_find:$path";
1409 2059
1410 $cf::MAP{$path} || do { 2060 $cf::MAP{$path} || do {
1411 my $guard = cf::lock_acquire "map_find:$path";
1412 my $map = new_from_path cf::map $path 2061 my $map = new_from_path cf::map $path
1413 or return; 2062 or return;
1414 2063
1415 $map->{last_save} = $cf::RUNTIME; 2064 $map->{last_save} = $cf::RUNTIME;
1416 2065
1417 $map->load_header 2066 $map->load_header
1418 or return; 2067 or return;
1419 2068
1420 if ($map->should_reset && 0) {#d#TODO# disabled, crashy (locking issue?) 2069 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?)
1421 # doing this can freeze the server in a sync job, obviously 2070 # doing this can freeze the server in a sync job, obviously
1422 #$cf::WAIT_FOR_TICK->wait; 2071 #$cf::WAIT_FOR_TICK->wait;
2072 undef $guard2;
2073 undef $guard1;
1423 $map->reset; 2074 $map->reset;
1424 undef $guard;
1425 return find $path; 2075 return find $path;
1426 } 2076 }
1427 2077
1428 $cf::MAP{$path} = $map 2078 $cf::MAP{$path} = $map
1429 } 2079 }
1430} 2080}
1431 2081
1432sub pre_load { } 2082sub pre_load { }
1433sub post_load { } 2083#sub post_load { } # XS
1434 2084
1435sub load { 2085sub load {
1436 my ($self) = @_; 2086 my ($self) = @_;
1437 2087
1438 local $self->{deny_reset} = 1; # loading can take a long time 2088 local $self->{deny_reset} = 1; # loading can take a long time
1439 2089
1440 my $path = $self->{path}; 2090 my $path = $self->{path};
2091
2092 {
1441 my $guard = cf::lock_acquire "map_load:$path"; 2093 my $guard = cf::lock_acquire "map_data:$path";
1442 2094
2095 return unless $self->valid;
1443 return if $self->in_memory != cf::MAP_SWAPPED; 2096 return unless $self->in_memory == cf::MAP_SWAPPED;
1444 2097
1445 $self->in_memory (cf::MAP_LOADING); 2098 $self->in_memory (cf::MAP_LOADING);
1446 2099
1447 $self->alloc; 2100 $self->alloc;
1448 2101
1449 $self->pre_load; 2102 $self->pre_load;
2103 cf::cede_to_tick;
1450 2104
1451 $self->_load_objects ($self->{load_path}, 1) 2105 my $f = new_from_file cf::object::thawer $self->{load_path};
2106 $f->skip_block;
2107 $self->_load_objects ($f)
1452 or return; 2108 or return;
1453 2109
1454 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1) 2110 $self->post_load_original
1455 if delete $self->{load_original}; 2111 if delete $self->{load_original};
1456 2112
1457 if (my $uniq = $self->uniq_path) { 2113 if (my $uniq = $self->uniq_path) {
1458 utf8::encode $uniq; 2114 utf8::encode $uniq;
1459 if (aio_open $uniq, O_RDONLY, 0) { 2115 unless (aio_stat $uniq) {
2116 if (my $f = new_from_file cf::object::thawer $uniq) {
1460 $self->clear_unique_items; 2117 $self->clear_unique_items;
1461 $self->_load_objects ($uniq, 0); 2118 $self->_load_objects ($f);
2119 $f->resolve_delayed_derefs;
2120 }
1462 } 2121 }
1463 } 2122 }
1464 2123
1465 Coro::cede; 2124 $f->resolve_delayed_derefs;
1466 2125
2126 cf::cede_to_tick;
1467 # now do the right thing for maps 2127 # now do the right thing for maps
1468 $self->link_multipart_objects; 2128 $self->link_multipart_objects;
1469
1470 unless ($self->{deny_activate}) {
1471 $self->decay_objects;
1472 $self->fix_auto_apply;
1473 $self->update_buttons;
1474 Coro::cede;
1475 $self->set_darkness_map;
1476 $self->difficulty ($self->estimate_difficulty) 2129 $self->difficulty ($self->estimate_difficulty)
1477 unless $self->difficulty; 2130 unless $self->difficulty;
1478 Coro::cede; 2131 cf::cede_to_tick;
2132
2133 unless ($self->{deny_activate}) {
2134 $self->decay_objects;
2135 $self->fix_auto_apply;
2136 $self->update_buttons;
2137 cf::cede_to_tick;
1479 $self->activate; 2138 $self->activate;
2139 }
2140
2141 $self->{last_save} = $cf::RUNTIME;
2142 $self->last_access ($cf::RUNTIME);
2143
2144 $self->in_memory (cf::MAP_ACTIVE);
1480 } 2145 }
1481 2146
1482 $self->post_load; 2147 $self->post_load;
1483
1484 $self->in_memory (cf::MAP_IN_MEMORY);
1485} 2148}
1486 2149
2150# customize the map for a given player, i.e.
2151# return the _real_ map. used by e.g. per-player
2152# maps to change the path to ~playername/mappath
1487sub customise_for { 2153sub customise_for {
1488 my ($self, $ob) = @_; 2154 my ($self, $ob) = @_;
1489 2155
1490 return find "~" . $ob->name . "/" . $self->{path} 2156 return find "~" . $ob->name . "/" . $self->{path}
1491 if $self->per_player; 2157 if $self->per_player;
1492 2158
2159# return find "?party/" . $ob->name . "/" . $self->{path}
2160# if $self->per_party;
2161
1493 $self 2162 $self
1494} 2163}
1495 2164
1496# find and load all maps in the 3x3 area around a map 2165# find and load all maps in the 3x3 area around a map
1497sub load_diag { 2166sub load_neighbours {
1498 my ($map) = @_; 2167 my ($map) = @_;
1499 2168
1500 my @diag; # diagonal neighbours 2169 my @neigh; # diagonal neighbours
1501 2170
1502 for (0 .. 3) { 2171 for (0 .. 3) {
1503 my $neigh = $map->tile_path ($_) 2172 my $neigh = $map->tile_path ($_)
1504 or next; 2173 or next;
1505 $neigh = find $neigh, $map 2174 $neigh = find $neigh, $map
1506 or next; 2175 or next;
1507 $neigh->load; 2176 $neigh->load;
1508 2177
2178 # now find the diagonal neighbours
2179 push @neigh,
1509 push @diag, [$neigh->tile_path (($_ + 3) % 4), $neigh], 2180 [$neigh->tile_path (($_ + 3) % 4), $neigh],
1510 [$neigh->tile_path (($_ + 1) % 4), $neigh]; 2181 [$neigh->tile_path (($_ + 1) % 4), $neigh];
1511 } 2182 }
1512 2183
1513 for (@diag) { 2184 for (grep defined $_->[0], @neigh) {
2185 my ($path, $origin) = @$_;
1514 my $neigh = find @$_ 2186 my $neigh = find $path, $origin
1515 or next; 2187 or next;
1516 $neigh->load; 2188 $neigh->load;
1517 } 2189 }
1518} 2190}
1519 2191
1520sub find_sync { 2192sub find_sync {
1521 my ($path, $origin) = @_; 2193 my ($path, $origin) = @_;
1522 2194
1523 cf::sync_job { find $path, $origin } 2195 return cf::LOG cf::llevError | cf::logBacktrace, "do_find_sync"
2196 if $Coro::current == $Coro::main;
2197
2198 find $path, $origin
1524} 2199}
1525 2200
1526sub do_load_sync { 2201sub do_load_sync {
1527 my ($map) = @_; 2202 my ($map) = @_;
1528 2203
1529 cf::sync_job { $map->load }; 2204 return cf::LOG cf::llevError | cf::logBacktrace, "do_load_sync"
2205 if $Coro::current == $Coro::main;
2206
2207 $map->load;
1530} 2208}
1531 2209
1532our %MAP_PREFETCH; 2210our %MAP_PREFETCH;
1533our $MAP_PREFETCHER = undef; 2211our $MAP_PREFETCHER = undef;
1534 2212
1535sub find_async { 2213sub find_async {
1536 my ($path, $origin) = @_; 2214 my ($path, $origin, $load) = @_;
1537 2215
1538 $path = normalise $path, $origin && $origin->{path}; 2216 $path = normalise $path, $origin && $origin->{path};
1539 2217
1540 if (my $map = $cf::MAP{$path}) { 2218 if (my $map = $cf::MAP{$path}) {
1541 return $map if $map->in_memory == cf::MAP_IN_MEMORY; 2219 return $map if !$load || $map->in_memory == cf::MAP_ACTIVE;
1542 } 2220 }
1543 2221
1544 undef $MAP_PREFETCH{$path}; 2222 $MAP_PREFETCH{$path} |= $load;
2223
1545 $MAP_PREFETCHER ||= cf::async { 2224 $MAP_PREFETCHER ||= cf::async {
2225 $Coro::current->{desc} = "map prefetcher";
2226
1546 while (%MAP_PREFETCH) { 2227 while (%MAP_PREFETCH) {
1547 for my $path (keys %MAP_PREFETCH) { 2228 while (my ($k, $v) = each %MAP_PREFETCH) {
1548 my $map = find $path 2229 if (my $map = find $k) {
1549 or next;
1550 $map->load; 2230 $map->load if $v;
2231 }
1551 2232
1552 delete $MAP_PREFETCH{$path}; 2233 delete $MAP_PREFETCH{$k};
1553 } 2234 }
1554 } 2235 }
1555 undef $MAP_PREFETCHER; 2236 undef $MAP_PREFETCHER;
1556 }; 2237 };
1557 $MAP_PREFETCHER->prio (6); 2238 $MAP_PREFETCHER->prio (6);
1558 2239
1559 () 2240 ()
1560} 2241}
1561 2242
2243# common code, used by both ->save and ->swapout
1562sub save { 2244sub _save {
1563 my ($self) = @_; 2245 my ($self) = @_;
1564
1565 my $lock = cf::lock_acquire "map_data:" . $self->path;
1566 2246
1567 $self->{last_save} = $cf::RUNTIME; 2247 $self->{last_save} = $cf::RUNTIME;
1568 2248
1569 return unless $self->dirty; 2249 return unless $self->dirty;
1570 2250
… …
1576 return if $self->{deny_save}; 2256 return if $self->{deny_save};
1577 2257
1578 local $self->{last_access} = $self->last_access;#d# 2258 local $self->{last_access} = $self->last_access;#d#
1579 2259
1580 cf::async { 2260 cf::async {
2261 $Coro::current->{desc} = "map player save";
1581 $_->contr->save for $self->players; 2262 $_->contr->save for $self->players;
1582 }; 2263 };
2264
2265 cf::get_slot 0.02;
1583 2266
1584 if ($uniq) { 2267 if ($uniq) {
1585 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS); 2268 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS);
1586 $self->_save_objects ($uniq, cf::IO_UNIQUES); 2269 $self->_save_objects ($uniq, cf::IO_UNIQUES);
1587 } else { 2270 } else {
1588 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES); 2271 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES);
1589 } 2272 }
1590} 2273}
1591 2274
2275sub save {
2276 my ($self) = @_;
2277
2278 my $lock = cf::lock_acquire "map_data:$self->{path}";
2279
2280 $self->_save;
2281}
2282
1592sub swap_out { 2283sub swap_out {
1593 my ($self) = @_; 2284 my ($self) = @_;
1594 2285
1595 # save first because save cedes
1596 $self->save;
1597
1598 my $lock = cf::lock_acquire "map_data:" . $self->path; 2286 my $lock = cf::lock_acquire "map_data:$self->{path}";
1599 2287
2288 return if $self->in_memory != cf::MAP_ACTIVE;
2289 return if $self->{deny_save};
1600 return if $self->players; 2290 return if $self->players;
1601 return if $self->in_memory != cf::MAP_IN_MEMORY;
1602 return if $self->{deny_save};
1603 2291
2292 # first deactivate the map and "unlink" it from the core
2293 $self->deactivate;
2294 $_->clear_links_to ($self) for values %cf::MAP;
2295 $self->in_memory (cf::MAP_SWAPPED);
2296
2297 # then atomically save
2298 $self->_save;
2299
2300 # then free the map
1604 $self->clear; 2301 $self->clear;
1605 $self->in_memory (cf::MAP_SWAPPED);
1606} 2302}
1607 2303
1608sub reset_at { 2304sub reset_at {
1609 my ($self) = @_; 2305 my ($self) = @_;
1610 2306
1611 # TODO: safety, remove and allow resettable per-player maps 2307 # TODO: safety, remove and allow resettable per-player maps
1612 return 1e99 if $self->isa ("ext::map_per_player");#d#
1613 return 1e99 if $self->{deny_reset}; 2308 return 1e99 if $self->{deny_reset};
1614 2309
1615 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access; 2310 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
1616 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET; 2311 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET;
1617 2312
… …
1628 my ($self) = @_; 2323 my ($self) = @_;
1629 2324
1630 my $lock = cf::lock_acquire "map_data:$self->{path}"; 2325 my $lock = cf::lock_acquire "map_data:$self->{path}";
1631 2326
1632 return if $self->players; 2327 return if $self->players;
1633 return if $self->isa ("ext::map_per_player");#d#
1634 2328
1635 warn "resetting map ", $self->path;#d# 2329 cf::trace "resetting map ", $self->path, "\n";
1636 2330
1637 $self->in_memory (cf::MAP_SWAPPED); 2331 $self->in_memory (cf::MAP_SWAPPED);
1638 2332
1639 # need to save uniques path 2333 # need to save uniques path
1640 unless ($self->{deny_save}) { 2334 unless ($self->{deny_save}) {
… …
1644 if $uniq; 2338 if $uniq;
1645 } 2339 }
1646 2340
1647 delete $cf::MAP{$self->path}; 2341 delete $cf::MAP{$self->path};
1648 2342
2343 $self->deactivate;
2344 $_->clear_links_to ($self) for values %cf::MAP;
1649 $self->clear; 2345 $self->clear;
1650
1651 $_->clear_links_to ($self) for values %cf::MAP;
1652 2346
1653 $self->unlink_save; 2347 $self->unlink_save;
1654 $self->destroy; 2348 $self->destroy;
1655} 2349}
1656 2350
1657my $nuke_counter = "aaaa"; 2351my $nuke_counter = "aaaa";
1658 2352
1659sub nuke { 2353sub nuke {
1660 my ($self) = @_; 2354 my ($self) = @_;
1661 2355
2356 {
2357 my $lock = cf::lock_acquire "map_data:$self->{path}";
2358
1662 delete $cf::MAP{$self->path}; 2359 delete $cf::MAP{$self->path};
1663 2360
1664 $self->unlink_save; 2361 $self->unlink_save;
1665 2362
1666 bless $self, "cf::map"; 2363 bless $self, "cf::map::wrap";
1667 delete $self->{deny_reset}; 2364 delete $self->{deny_reset};
1668 $self->{deny_save} = 1; 2365 $self->{deny_save} = 1;
1669 $self->reset_timeout (1); 2366 $self->reset_timeout (1);
1670 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++)); 2367 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));
1671 2368
1672 $cf::MAP{$self->path} = $self; 2369 $cf::MAP{$self->path} = $self;
2370 }
1673 2371
1674 $self->reset; # polite request, might not happen 2372 $self->reset; # polite request, might not happen
2373}
2374
2375=item $maps = cf::map::tmp_maps
2376
2377Returns an arrayref with all map paths of currently instantiated and saved
2378maps. May block.
2379
2380=cut
2381
2382sub tmp_maps() {
2383 [
2384 map {
2385 utf8::decode $_;
2386 /\.map$/
2387 ? normalise $_
2388 : ()
2389 } @{ aio_readdir $TMPDIR or [] }
2390 ]
2391}
2392
2393=item $maps = cf::map::random_maps
2394
2395Returns an arrayref with all map paths of currently instantiated and saved
2396random maps. May block.
2397
2398=cut
2399
2400sub random_maps() {
2401 [
2402 map {
2403 utf8::decode $_;
2404 /\.map$/
2405 ? normalise "?random/$_"
2406 : ()
2407 } @{ aio_readdir $RANDOMDIR or [] }
2408 ]
1675} 2409}
1676 2410
1677=item cf::map::unique_maps 2411=item cf::map::unique_maps
1678 2412
1679Returns an arrayref of paths of all shared maps that have 2413Returns an arrayref of paths of all shared maps that have
1680instantiated unique items. May block. 2414instantiated unique items. May block.
1681 2415
1682=cut 2416=cut
1683 2417
1684sub unique_maps() { 2418sub unique_maps() {
1685 my $files = aio_readdir cf::localdir . "/" . cf::uniquedir 2419 [
1686 or return; 2420 map {
1687
1688 my @paths;
1689
1690 for (@$files) {
1691 utf8::decode $_; 2421 utf8::decode $_;
1692 next if /\.pst$/; 2422 s/\.map$//; # TODO future compatibility hack
1693 next unless /^$PATH_SEP/o; 2423 /\.pst$/ || !/^$PATH_SEP/o # TODO unique maps apparebntly lack the .map suffix :/
1694 2424 ? ()
1695 push @paths, cf::map::normalise $_; 2425 : normalise $_
2426 } @{ aio_readdir $UNIQUEDIR or [] }
1696 } 2427 ]
1697
1698 \@paths
1699} 2428}
1700 2429
1701package cf; 2430=item cf::map::static_maps
2431
2432Returns an arrayref if paths of all static maps (all preinstalled F<.map>
2433file in the shared directory excluding F</styles> and F</editor>). May
2434block.
2435
2436=cut
2437
2438sub static_maps() {
2439 my @dirs = "";
2440 my @maps;
2441
2442 while (@dirs) {
2443 my $dir = shift @dirs;
2444
2445 next if $dir eq "/styles" || $dir eq "/editor";
2446
2447 my ($dirs, $files) = Coro::AIO::aio_scandir "$MAPDIR$dir", 2
2448 or return;
2449
2450 for (@$files) {
2451 s/\.map$// or next;
2452 utf8::decode $_;
2453 push @maps, "$dir/$_";
2454 }
2455
2456 push @dirs, map "$dir/$_", @$dirs;
2457 }
2458
2459 \@maps
2460}
1702 2461
1703=back 2462=back
1704 2463
1705=head3 cf::object 2464=head3 cf::object
1706 2465
… …
1710 2469
1711=over 4 2470=over 4
1712 2471
1713=item $ob->inv_recursive 2472=item $ob->inv_recursive
1714 2473
1715Returns the inventory of the object _and_ their inventories, recursively. 2474Returns the inventory of the object I<and> their inventories, recursively,
2475but I<not> the object itself.
1716 2476
1717=cut 2477=cut
1718 2478
1719sub inv_recursive_; 2479sub inv_recursive_;
1720sub inv_recursive_ { 2480sub inv_recursive_ {
… …
1723 2483
1724sub inv_recursive { 2484sub inv_recursive {
1725 inv_recursive_ inv $_[0] 2485 inv_recursive_ inv $_[0]
1726} 2486}
1727 2487
2488=item $ref = $ob->ref
2489
2490Creates and returns a persistent reference to an object that can be stored as a string.
2491
2492=item $ob = cf::object::deref ($refstring)
2493
2494returns the objetc referenced by refstring. may return undef when it cnanot find the object,
2495even if the object actually exists. May block.
2496
2497=cut
2498
2499sub deref {
2500 my ($ref) = @_;
2501
2502 if ($ref =~ m{^player\/(<1\.[0-9a-f]+>)/(.*)$}) {
2503 my ($uuid, $name) = ($1, $2);
2504 my $pl = $cf::PLAYER_LOADING{$name} || cf::player::find $name
2505 or return;
2506 $pl->ob->uuid eq $uuid
2507 or return;
2508
2509 $pl->ob
2510 } else {
2511 warn "$ref: cannot resolve object reference\n";
2512 undef
2513 }
2514}
2515
1728package cf; 2516package cf;
1729 2517
1730=back 2518=back
1731 2519
1732=head3 cf::object::player 2520=head3 cf::object::player
… …
1738Sends a message to the player, as if the npc C<$npc> replied. C<$npc> 2526Sends a message to the player, as if the npc C<$npc> replied. C<$npc>
1739can be C<undef>. Does the right thing when the player is currently in a 2527can be C<undef>. Does the right thing when the player is currently in a
1740dialogue with the given NPC character. 2528dialogue with the given NPC character.
1741 2529
1742=cut 2530=cut
2531
2532our $SAY_CHANNEL = {
2533 id => "say",
2534 title => "Map",
2535 reply => "say ",
2536 tooltip => "Things said to and replied from NPCs near you and other players on the same map only.",
2537};
2538
2539our $CHAT_CHANNEL = {
2540 id => "chat",
2541 title => "Chat",
2542 reply => "chat ",
2543 tooltip => "Player chat and shouts, global to the server.",
2544};
1743 2545
1744# rough implementation of a future "reply" method that works 2546# rough implementation of a future "reply" method that works
1745# with dialog boxes. 2547# with dialog boxes.
1746#TODO: the first argument must go, split into a $npc->reply_to ( method 2548#TODO: the first argument must go, split into a $npc->reply_to ( method
1747sub cf::object::player::reply($$$;$) { 2549sub cf::object::player::reply($$$;$) {
… …
1749 2551
1750 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4; 2552 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4;
1751 2553
1752 if ($self->{record_replies}) { 2554 if ($self->{record_replies}) {
1753 push @{ $self->{record_replies} }, [$npc, $msg, $flags]; 2555 push @{ $self->{record_replies} }, [$npc, $msg, $flags];
2556
1754 } else { 2557 } else {
2558 my $pl = $self->contr;
2559
2560 if ($pl->{npc_dialog} && $pl->{npc_dialog}->{id}) {
2561 my $dialog = $pl->{npc_dialog};
2562 $dialog->{pl}->ext_msg ($dialog->{id}, update => msg => $dialog->{pl}->expand_cfpod ($msg));
2563
2564 } else {
1755 $msg = $npc->name . " says: $msg" if $npc; 2565 $msg = $npc->name . " says: $msg" if $npc;
1756 $self->message ($msg, $flags); 2566 $self->send_msg ($SAY_CHANNEL => $msg, $flags);
2567 }
1757 } 2568 }
2569}
2570
2571=item $object->send_msg ($channel, $msg, $color, [extra...])
2572
2573=cut
2574
2575sub cf::object::send_msg {
2576 my $pl = shift->contr
2577 or return;
2578 $pl->send_msg (@_);
1758} 2579}
1759 2580
1760=item $player_object->may ("access") 2581=item $player_object->may ("access")
1761 2582
1762Returns wether the given player is authorized to access resource "access" 2583Returns wether the given player is authorized to access resource "access"
… …
1775 2596
1776=item $player_object->enter_link 2597=item $player_object->enter_link
1777 2598
1778Freezes the player and moves him/her to a special map (C<{link}>). 2599Freezes the player and moves him/her to a special map (C<{link}>).
1779 2600
1780The player should be reasonably safe there for short amounts of time. You 2601The player should be reasonably safe there for short amounts of time (e.g.
1781I<MUST> call C<leave_link> as soon as possible, though. 2602for loading a map). You I<MUST> call C<leave_link> as soon as possible,
2603though, as the player cannot control the character while it is on the link
2604map.
1782 2605
1783Will never block. 2606Will never block.
1784 2607
1785=item $player_object->leave_link ($map, $x, $y) 2608=item $player_object->leave_link ($map, $x, $y)
1786 2609
… …
1806sub cf::object::player::enter_link { 2629sub cf::object::player::enter_link {
1807 my ($self) = @_; 2630 my ($self) = @_;
1808 2631
1809 $self->deactivate_recursive; 2632 $self->deactivate_recursive;
1810 2633
2634 ++$self->{_link_recursion};
2635
1811 return if UNIVERSAL::isa $self->map, "ext::map_link"; 2636 return if UNIVERSAL::isa $self->map, "ext::map_link";
1812 2637
1813 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y] 2638 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y]
1814 if $self->map; 2639 if $self->map && $self->map->{path} ne "{link}";
1815 2640
1816 $self->enter_map ($LINK_MAP || link_map, 10, 10); 2641 $self->enter_map ($LINK_MAP || link_map, 3, 3);
1817} 2642}
1818 2643
1819sub cf::object::player::leave_link { 2644sub cf::object::player::leave_link {
1820 my ($self, $map, $x, $y) = @_; 2645 my ($self, $map, $x, $y) = @_;
2646
2647 return unless $self->contr->active;
1821 2648
1822 my $link_pos = delete $self->{_link_pos}; 2649 my $link_pos = delete $self->{_link_pos};
1823 2650
1824 unless ($map) { 2651 unless ($map) {
1825 # restore original map position 2652 # restore original map position
… …
1836 ($x, $y) = (-1, -1) 2663 ($x, $y) = (-1, -1)
1837 unless (defined $x) && (defined $y); 2664 unless (defined $x) && (defined $y);
1838 2665
1839 # use -1 or undef as default coordinates, not 0, 0 2666 # use -1 or undef as default coordinates, not 0, 0
1840 ($x, $y) = ($map->enter_x, $map->enter_y) 2667 ($x, $y) = ($map->enter_x, $map->enter_y)
1841 if $x <=0 && $y <= 0; 2668 if $x <= 0 && $y <= 0;
1842 2669
1843 $map->load; 2670 $map->load;
1844 $map->load_diag; 2671 $map->load_neighbours;
1845 2672
1846 return unless $self->contr->active; 2673 return unless $self->contr->active;
1847 $self->activate_recursive;
1848 2674
1849 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext 2675 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
1850 $self->enter_map ($map, $x, $y); 2676 if ($self->enter_map ($map, $x, $y)) {
1851} 2677 # entering was successful
1852 2678 delete $self->{_link_recursion};
1853cf::player->attach ( 2679 # only activate afterwards, to support waiting in hooks
1854 on_logout => sub { 2680 $self->activate_recursive;
1855 my ($pl) = @_;
1856
1857 # abort map switching before logout
1858 if ($pl->ob->{_link_pos}) {
1859 cf::sync_job {
1860 $pl->ob->leave_link
1861 };
1862 }
1863 }, 2681 }
1864 on_login => sub {
1865 my ($pl) = @_;
1866 2682
1867 # try to abort aborted map switching on player login :) 2683}
1868 # should happen only on crashes
1869 if ($pl->ob->{_link_pos}) {
1870 $pl->ob->enter_link;
1871 (async {
1872 $pl->ob->reply (undef,
1873 "There was an internal problem at your last logout, "
1874 . "the server will try to bring you to your intended destination in a second.",
1875 cf::NDI_RED);
1876 # we need this sleep as the login has a concurrent enter_exit running
1877 # and this sleep increases chances of the player not ending up in scorn
1878 Coro::Timer::sleep 1;
1879 $pl->ob->leave_link;
1880 })->prio (2);
1881 }
1882 },
1883);
1884 2684
1885=item $player_object->goto ($path, $x, $y) 2685=item $player_object->goto ($path, $x, $y[, $check->($map, $x, $y, $player)[, $done->($player)]])
1886 2686
2687Moves the player to the given map-path and coordinates by first freezing
2688her, loading and preparing them map, calling the provided $check callback
2689that has to return the map if sucecssful, and then unfreezes the player on
2690the new (success) or old (failed) map position. In either case, $done will
2691be called at the end of this process.
2692
2693Note that $check will be called with a potentially non-loaded map, so if
2694it needs a loaded map it has to call C<< ->load >>.
2695
1887=cut 2696=cut
2697
2698our $GOTOGEN;
1888 2699
1889sub cf::object::player::goto { 2700sub cf::object::player::goto {
1890 my ($self, $path, $x, $y) = @_; 2701 my ($self, $path, $x, $y, $check, $done) = @_;
2702
2703 if ($self->{_link_recursion} >= $MAX_LINKS) {
2704 error "FATAL: link recursion exceeded, ", $self->name, " goto $path $x $y, redirecting.";
2705 $self->failmsg ("Something went wrong inside the server - please contact an administrator!");
2706 ($path, $x, $y) = @$EMERGENCY_POSITION;
2707 }
2708
2709 # do generation counting so two concurrent goto's will be executed in-order
2710 my $gen = $self->{_goto_generation} = ++$GOTOGEN;
1891 2711
1892 $self->enter_link; 2712 $self->enter_link;
1893 2713
1894 (async { 2714 (async {
2715 $Coro::current->{desc} = "player::goto $path $x $y";
2716
2717 # *tag paths override both path and x|y
2718 if ($path =~ /^\*(.*)$/) {
2719 if (my @obs = grep $_->map, ext::map_tags::find $1) {
2720 my $ob = $obs[rand @obs];
2721
2722 # see if we actually can go there
2723 if (@obs = grep !$self->blocked ($_->map, $_->x, $_->y), $ob, $ob->tail) {
2724 $ob = $obs[rand @obs];
2725 } else {
2726 $self->message ("Wow, it's pretty crowded in there.", cf::NDI_UNIQUE | cf::NDI_RED);
2727 }
2728 # else put us there anyways for now #d#
2729
2730 ($path, $x, $y) = ($ob->map, $ob->x, $ob->y);
2731 } else {
2732 ($path, $x, $y) = (undef, undef, undef);
2733 }
2734 }
2735
1895 my $map = eval { 2736 my $map = eval {
1896 my $map = cf::map::find $path; 2737 my $map = defined $path ? cf::map::find $path : undef;
2738
2739 if ($map) {
1897 $map = $map->customise_for ($self) if $map; 2740 $map = $map->customise_for ($self);
2741 $map = $check->($map, $x, $y, $self) if $check && $map;
2742 } else {
2743 $self->message ("The exit to '$path' is closed.", cf::NDI_UNIQUE | cf::NDI_RED);
2744 }
2745
1898 $map 2746 $map
2747 };
2748
2749 if ($@) {
2750 $self->message ("Something went wrong within the server, please report this incident!", cf::NDI_UNIQUE | cf::NDI_RED);
2751 LOG llevError | logBacktrace, Carp::longmess $@;
1899 } or 2752 }
1900 $self->message ("The exit to '$path' is closed", cf::NDI_UNIQUE | cf::NDI_RED);
1901 2753
2754 if ($gen == $self->{_goto_generation}) {
2755 delete $self->{_goto_generation};
1902 $self->leave_link ($map, $x, $y); 2756 $self->leave_link ($map, $x, $y);
2757 }
2758
2759 $done->($self) if $done;
1903 })->prio (1); 2760 })->prio (1);
1904} 2761}
1905 2762
1906=item $player_object->enter_exit ($exit_object) 2763=item $player_object->enter_exit ($exit_object)
1907 2764
… …
1927} 2784}
1928 2785
1929sub prepare_random_map { 2786sub prepare_random_map {
1930 my ($exit) = @_; 2787 my ($exit) = @_;
1931 2788
1932 my $guard = cf::lock_acquire "exit_prepare:$exit";
1933
1934 # all this does is basically replace the /! path by 2789 # all this does is basically replace the /! path by
1935 # a new random map path (?random/...) with a seed 2790 # a new random map path (?random/...) with a seed
1936 # that depends on the exit object 2791 # that depends on the exit object
1937 2792
1938 my $rmp = parse_random_map_params $exit->msg; 2793 my $rmp = parse_random_map_params $exit->msg;
… …
1940 if ($exit->map) { 2795 if ($exit->map) {
1941 $rmp->{region} = $exit->region->name; 2796 $rmp->{region} = $exit->region->name;
1942 $rmp->{origin_map} = $exit->map->path; 2797 $rmp->{origin_map} = $exit->map->path;
1943 $rmp->{origin_x} = $exit->x; 2798 $rmp->{origin_x} = $exit->x;
1944 $rmp->{origin_y} = $exit->y; 2799 $rmp->{origin_y} = $exit->y;
2800
2801 $exit->map->touch;
1945 } 2802 }
1946 2803
1947 $rmp->{random_seed} ||= $exit->random_seed; 2804 $rmp->{random_seed} ||= $exit->random_seed;
1948 2805
1949 my $data = cf::to_json $rmp; 2806 my $data = JSON::XS->new->utf8->pretty->canonical->encode ($rmp);
1950 my $md5 = Digest::MD5::md5_hex $data; 2807 my $md5 = Digest::MD5::md5_hex $data;
1951 my $meta = "$cf::RANDOM_MAPS/$md5.meta"; 2808 my $meta = "$RANDOMDIR/$md5.meta";
1952 2809
1953 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) { 2810 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) {
1954 aio_write $fh, 0, (length $data), $data, 0; 2811 aio_write $fh, 0, (length $data), $data, 0;
1955 undef $fh; 2812 undef $fh;
1956 aio_rename "$meta~", $meta; 2813 aio_rename "$meta~", $meta;
1957 2814
2815 my $slaying = "?random/$md5";
2816
2817 if ($exit->valid) {
1958 $exit->slaying ("?random/$md5"); 2818 $exit->slaying ("?random/$md5");
1959 $exit->msg (undef); 2819 $exit->msg (undef);
2820 }
1960 } 2821 }
1961} 2822}
1962 2823
1963sub cf::object::player::enter_exit { 2824sub cf::object::player::enter_exit {
1964 my ($self, $exit) = @_; 2825 my ($self, $exit) = @_;
1965 2826
1966 return unless $self->type == cf::PLAYER; 2827 return unless $self->type == cf::PLAYER;
1967 2828
1968 if ($exit->slaying eq "/!") {
1969 #TODO: this should de-fi-ni-te-ly not be a sync-job
1970 cf::sync_job { prepare_random_map $exit };
1971 }
1972
1973 my $slaying = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path;
1974 my $hp = $exit->stats->hp;
1975 my $sp = $exit->stats->sp;
1976
1977 $self->enter_link; 2829 $self->enter_link;
1978 2830
1979 (async { 2831 (async {
1980 $self->deactivate_recursive; # just to be sure 2832 $Coro::current->{desc} = "enter_exit";
2833
1981 unless (eval { 2834 unless (eval {
2835 $self->deactivate_recursive; # just to be sure
2836
2837 # random map handling
2838 {
2839 my $guard = cf::lock_acquire "exit_prepare:$exit";
2840
2841 prepare_random_map $exit
2842 if $exit->slaying eq "/!";
2843 }
2844
2845 my $map = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path;
2846 my $x = $exit->stats->hp;
2847 my $y = $exit->stats->sp;
2848
1982 $self->goto ($slaying, $hp, $sp); 2849 $self->goto ($map, $x, $y);
1983 2850
2851 # if exit is damned, update players death & WoR home-position
2852 $self->contr->savebed ($map, $x, $y)
2853 if $exit->flag (cf::FLAG_DAMNED);
2854
1984 1; 2855 1
1985 }) { 2856 }) {
1986 $self->message ("Something went wrong deep within the crossfire server. " 2857 $self->message ("Something went wrong deep within the deliantra server. "
1987 . "I'll try to bring you back to the map you were before. " 2858 . "I'll try to bring you back to the map you were before. "
1988 . "Please report this to the dungeon master!", 2859 . "Please report this to the dungeon master!",
1989 cf::NDI_UNIQUE | cf::NDI_RED); 2860 cf::NDI_UNIQUE | cf::NDI_RED);
1990 2861
1991 warn "ERROR in enter_exit: $@"; 2862 error "ERROR in enter_exit: $@";
1992 $self->leave_link; 2863 $self->leave_link;
1993 } 2864 }
1994 })->prio (1); 2865 })->prio (1);
1995} 2866}
1996 2867
… …
2010 2881
2011 utf8::encode $text; 2882 utf8::encode $text;
2012 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text); 2883 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);
2013} 2884}
2014 2885
2886=item $client->send_big_packet ($pkt)
2887
2888Like C<send_packet>, but tries to compress large packets, and fragments
2889them as required.
2890
2891=cut
2892
2893our $MAXFRAGSIZE = cf::MAXSOCKBUF - 64;
2894
2895sub cf::client::send_big_packet {
2896 my ($self, $pkt) = @_;
2897
2898 # try lzf for large packets
2899 $pkt = "lzf " . Compress::LZF::compress $pkt
2900 if 1024 <= length $pkt and $self->{can_lzf};
2901
2902 # split very large packets
2903 if ($MAXFRAGSIZE < length $pkt and $self->{can_lzf}) {
2904 $self->send_packet ("frag $_") for unpack "(a$MAXFRAGSIZE)*", $pkt;
2905 $pkt = "frag";
2906 }
2907
2908 $self->send_packet ($pkt);
2909}
2910
2911=item $client->send_msg ($channel, $msg, $color, [extra...])
2912
2913Send a drawinfo or msg packet to the client, formatting the msg for the
2914client if neccessary. C<$type> should be a string identifying the type of
2915the message, with C<log> being the default. If C<$color> is negative, suppress
2916the message unless the client supports the msg packet.
2917
2918=cut
2919
2920# non-persistent channels (usually the info channel)
2921our %CHANNEL = (
2922 "c/motd" => {
2923 id => "infobox",
2924 title => "MOTD",
2925 reply => undef,
2926 tooltip => "The message of the day",
2927 },
2928 "c/identify" => {
2929 id => "infobox",
2930 title => "Identify",
2931 reply => undef,
2932 tooltip => "Items recently identified",
2933 },
2934 "c/examine" => {
2935 id => "infobox",
2936 title => "Examine",
2937 reply => undef,
2938 tooltip => "Signs and other items you examined",
2939 },
2940 "c/shopinfo" => {
2941 id => "infobox",
2942 title => "Shop Info",
2943 reply => undef,
2944 tooltip => "What your bargaining skill tells you about the shop",
2945 },
2946 "c/book" => {
2947 id => "infobox",
2948 title => "Book",
2949 reply => undef,
2950 tooltip => "The contents of a note or book",
2951 },
2952 "c/lookat" => {
2953 id => "infobox",
2954 title => "Look",
2955 reply => undef,
2956 tooltip => "What you saw there",
2957 },
2958 "c/who" => {
2959 id => "infobox",
2960 title => "Players",
2961 reply => undef,
2962 tooltip => "Shows players who are currently online",
2963 },
2964 "c/body" => {
2965 id => "infobox",
2966 title => "Body Parts",
2967 reply => undef,
2968 tooltip => "Shows which body parts you posess and are available",
2969 },
2970 "c/statistics" => {
2971 id => "infobox",
2972 title => "Statistics",
2973 reply => undef,
2974 tooltip => "Shows your primary statistics",
2975 },
2976 "c/skills" => {
2977 id => "infobox",
2978 title => "Skills",
2979 reply => undef,
2980 tooltip => "Shows your experience per skill and item power",
2981 },
2982 "c/shopitems" => {
2983 id => "infobox",
2984 title => "Shop Items",
2985 reply => undef,
2986 tooltip => "Shows the items currently for sale in this shop",
2987 },
2988 "c/resistances" => {
2989 id => "infobox",
2990 title => "Resistances",
2991 reply => undef,
2992 tooltip => "Shows your resistances",
2993 },
2994 "c/pets" => {
2995 id => "infobox",
2996 title => "Pets",
2997 reply => undef,
2998 tooltip => "Shows information abotu your pets/a specific pet",
2999 },
3000 "c/perceiveself" => {
3001 id => "infobox",
3002 title => "Perceive Self",
3003 reply => undef,
3004 tooltip => "You gained detailed knowledge about yourself",
3005 },
3006 "c/uptime" => {
3007 id => "infobox",
3008 title => "Uptime",
3009 reply => undef,
3010 tooltip => "How long the server has been running since last restart",
3011 },
3012 "c/mapinfo" => {
3013 id => "infobox",
3014 title => "Map Info",
3015 reply => undef,
3016 tooltip => "Information related to the maps",
3017 },
3018 "c/party" => {
3019 id => "party",
3020 title => "Party",
3021 reply => "gsay ",
3022 tooltip => "Messages and chat related to your party",
3023 },
3024 "c/death" => {
3025 id => "death",
3026 title => "Death",
3027 reply => undef,
3028 tooltip => "Reason for and more info about your most recent death",
3029 },
3030 "c/say" => $SAY_CHANNEL,
3031 "c/chat" => $CHAT_CHANNEL,
3032);
3033
3034sub cf::client::send_msg {
3035 my ($self, $channel, $msg, $color, @extra) = @_;
3036
3037 $msg = $self->pl->expand_cfpod ($msg)
3038 unless $color & cf::NDI_VERBATIM;
3039
3040 $color &= cf::NDI_CLIENT_MASK; # just in case...
3041
3042 # check predefined channels, for the benefit of C
3043 if ($CHANNEL{$channel}) {
3044 $channel = $CHANNEL{$channel};
3045
3046 $self->ext_msg (channel_info => $channel);
3047 $channel = $channel->{id};
3048
3049 } elsif (ref $channel) {
3050 # send meta info to client, if not yet sent
3051 unless (exists $self->{channel}{$channel->{id}}) {
3052 $self->{channel}{$channel->{id}} = $channel;
3053 $self->ext_msg (channel_info => $channel);
3054 }
3055
3056 $channel = $channel->{id};
3057 }
3058
3059 return unless @extra || length $msg;
3060
3061 # default colour, mask it out
3062 $color &= ~(cf::NDI_COLOR_MASK | cf::NDI_DEF)
3063 if $color & cf::NDI_DEF;
3064
3065 my $pkt = "msg "
3066 . $self->{json_coder}->encode (
3067 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]
3068 );
3069
3070 $self->send_big_packet ($pkt);
3071}
3072
2015=item $client->ext_event ($type, %msg) 3073=item $client->ext_msg ($type, @msg)
2016 3074
2017Sends an exti event to the client. 3075Sends an ext event to the client.
2018 3076
2019=cut 3077=cut
2020 3078
2021sub cf::client::ext_event($$%) { 3079sub cf::client::ext_msg($$@) {
2022 my ($self, $type, %msg) = @_; 3080 my ($self, $type, @msg) = @_;
2023 3081
3082 if ($self->extcmd == 2) {
3083 $self->send_big_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
3084 } elsif ($self->extcmd == 1) { # TODO: remove
2024 $msg{msgtype} = "event_$type"; 3085 push @msg, msgtype => "event_$type";
2025 $self->send_packet ("ext " . cf::to_json \%msg); 3086 $self->send_big_packet ("ext " . $self->{json_coder}->encode ({@msg}));
3087 }
3088}
3089
3090=item $client->ext_reply ($msgid, @msg)
3091
3092Sends an ext reply to the client.
3093
3094=cut
3095
3096sub cf::client::ext_reply($$@) {
3097 my ($self, $id, @msg) = @_;
3098
3099 if ($self->extcmd == 2) {
3100 $self->send_big_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg]));
3101 } elsif ($self->extcmd == 1) {
3102 #TODO: version 1, remove
3103 unshift @msg, msgtype => "reply", msgid => $id;
3104 $self->send_big_packet ("ext " . $self->{json_coder}->encode ({@msg}));
3105 }
2026} 3106}
2027 3107
2028=item $success = $client->query ($flags, "text", \&cb) 3108=item $success = $client->query ($flags, "text", \&cb)
2029 3109
2030Queues a query to the client, calling the given callback with 3110Queues a query to the client, calling the given callback with
2031the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>, 3111the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>,
2032C<cf::CS_QUERY_SINGLECHAR> or C<cf::CS_QUERY_HIDEINPUT> or C<0>. 3112C<cf::CS_QUERY_SINGLECHAR> or C<cf::CS_QUERY_HIDEINPUT> or C<0>.
2033 3113
2034Queries can fail, so check the return code. Or don't, as queries will become 3114Queries can fail, so check the return code. Or don't, as queries will
2035reliable at some point in the future. 3115become reliable at some point in the future.
2036 3116
2037=cut 3117=cut
2038 3118
2039sub cf::client::query { 3119sub cf::client::query {
2040 my ($self, $flags, $text, $cb) = @_; 3120 my ($self, $flags, $text, $cb) = @_;
… …
2048 utf8::encode $text; 3128 utf8::encode $text;
2049 push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb]; 3129 push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb];
2050 3130
2051 $self->send_packet ($self->{query_queue}[0][0]) 3131 $self->send_packet ($self->{query_queue}[0][0])
2052 if @{ $self->{query_queue} } == 1; 3132 if @{ $self->{query_queue} } == 1;
3133
3134 1
2053} 3135}
2054 3136
2055cf::client->attach ( 3137cf::client->attach (
3138 on_connect => sub {
3139 my ($ns) = @_;
3140
3141 $ns->{json_coder} = JSON::XS->new->utf8->max_size (1e6)->convert_blessed;
3142 },
2056 on_reply => sub { 3143 on_reply => sub {
2057 my ($ns, $msg) = @_; 3144 my ($ns, $msg) = @_;
2058 3145
2059 # this weird shuffling is so that direct followup queries 3146 # this weird shuffling is so that direct followup queries
2060 # get handled first 3147 # get handled first
… …
2072 } else { 3159 } else {
2073 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM; 3160 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM;
2074 } 3161 }
2075 } 3162 }
2076 }, 3163 },
3164 on_exticmd => sub {
3165 my ($ns, $buf) = @_;
3166
3167 my $msg = eval { $ns->{json_coder}->decode ($buf) };
3168
3169 if (ref $msg) {
3170 my ($type, $reply, @payload) =
3171 "ARRAY" eq ref $msg
3172 ? @$msg
3173 : ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
3174
3175 my @reply;
3176
3177 if (my $cb = $EXTICMD{$type}) {
3178 @reply = $cb->($ns, @payload);
3179 }
3180
3181 $ns->ext_reply ($reply, @reply)
3182 if $reply;
3183
3184 } else {
3185 error "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";
3186 }
3187
3188 cf::override;
3189 },
2077); 3190);
2078 3191
2079=item $client->async (\&cb) 3192=item $client->async (\&cb)
2080 3193
2081Create a new coroutine, running the specified callback. The coroutine will 3194Create a new coroutine, running the specified callback. The coroutine will
… …
2097 3210
2098 $coro 3211 $coro
2099} 3212}
2100 3213
2101cf::client->attach ( 3214cf::client->attach (
2102 on_destroy => sub { 3215 on_client_destroy => sub {
2103 my ($ns) = @_; 3216 my ($ns) = @_;
2104 3217
2105 $_->cancel for values %{ (delete $ns->{_coro}) || {} }; 3218 $_->cancel for values %{ (delete $ns->{_coro}) || {} };
2106 }, 3219 },
2107); 3220);
… …
2122our $safe = new Safe "safe"; 3235our $safe = new Safe "safe";
2123our $safe_hole = new Safe::Hole; 3236our $safe_hole = new Safe::Hole;
2124 3237
2125$SIG{FPE} = 'IGNORE'; 3238$SIG{FPE} = 'IGNORE';
2126 3239
2127$safe->permit_only (Opcode::opset qw(:base_core :base_mem :base_orig :base_math sort time)); 3240$safe->permit_only (Opcode::opset qw(
3241 :base_core :base_mem :base_orig :base_math :base_loop
3242 grepstart grepwhile mapstart mapwhile
3243 sort time
3244));
2128 3245
2129# here we export the classes and methods available to script code 3246# here we export the classes and methods available to script code
2130 3247
2131=pod 3248=pod
2132 3249
2133The following functions and methods are available within a safe environment: 3250The following functions and methods are available within a safe environment:
2134 3251
2135 cf::object contr pay_amount pay_player map 3252 cf::object
3253 contr pay_amount pay_player map x y force_find force_add destroy
3254 insert remove name archname title slaying race decrease split
3255 value
3256
2136 cf::object::player player 3257 cf::object::player
2137 cf::player peaceful 3258 player
2138 cf::map trigger 3259
3260 cf::player
3261 peaceful
3262
3263 cf::map
3264 trigger
2139 3265
2140=cut 3266=cut
2141 3267
2142for ( 3268for (
2143 ["cf::object" => qw(contr pay_amount pay_player map)], 3269 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y
3270 insert remove inv nrof name archname title slaying race
3271 decrease split destroy change_exp value msg lore send_msg)],
2144 ["cf::object::player" => qw(player)], 3272 ["cf::object::player" => qw(player)],
2145 ["cf::player" => qw(peaceful)], 3273 ["cf::player" => qw(peaceful send_msg)],
2146 ["cf::map" => qw(trigger)], 3274 ["cf::map" => qw(trigger)],
2147) { 3275) {
2148 no strict 'refs';
2149 my ($pkg, @funs) = @$_; 3276 my ($pkg, @funs) = @$_;
2150 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"}) 3277 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})
2151 for @funs; 3278 for @funs;
2152} 3279}
2153 3280
… …
2168 3295
2169 my $qcode = $code; 3296 my $qcode = $code;
2170 $qcode =~ s/"/‟/g; # not allowed in #line filenames 3297 $qcode =~ s/"/‟/g; # not allowed in #line filenames
2171 $qcode =~ s/\n/\\n/g; 3298 $qcode =~ s/\n/\\n/g;
2172 3299
3300 %vars = (_dummy => 0) unless %vars;
3301
3302 my @res;
2173 local $_; 3303 local $_;
2174 local @safe::cf::_safe_eval_args = values %vars;
2175 3304
2176 my $eval = 3305 my $eval =
2177 "do {\n" 3306 "do {\n"
2178 . "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n" 3307 . "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n"
2179 . "#line 0 \"{$qcode}\"\n" 3308 . "#line 0 \"{$qcode}\"\n"
2180 . $code 3309 . $code
2181 . "\n}" 3310 . "\n}"
2182 ; 3311 ;
2183 3312
3313 if ($CFG{safe_eval}) {
2184 sub_generation_inc; 3314 sub_generation_inc;
3315 local @safe::cf::_safe_eval_args = values %vars;
2185 my @res = wantarray ? $safe->reval ($eval) : scalar $safe->reval ($eval); 3316 @res = wantarray ? $safe->reval ($eval) : scalar $safe->reval ($eval);
2186 sub_generation_inc; 3317 sub_generation_inc;
3318 } else {
3319 local @cf::_safe_eval_args = values %vars;
3320 @res = wantarray ? eval eval : scalar eval $eval;
3321 }
2187 3322
2188 if ($@) { 3323 if ($@) {
2189 warn "$@"; 3324 warn "$@",
2190 warn "while executing safe code '$code'\n"; 3325 "while executing safe code '$code'\n",
2191 warn "with arguments " . (join " ", %vars) . "\n"; 3326 "with arguments " . (join " ", %vars) . "\n";
2192 } 3327 }
2193 3328
2194 wantarray ? @res : $res[0] 3329 wantarray ? @res : $res[0]
2195} 3330}
2196 3331
… …
2210=cut 3345=cut
2211 3346
2212sub register_script_function { 3347sub register_script_function {
2213 my ($fun, $cb) = @_; 3348 my ($fun, $cb) = @_;
2214 3349
2215 no strict 'refs'; 3350 $fun = "safe::$fun" if $CFG{safe_eval};
2216 *{"safe::$fun"} = $safe_hole->wrap ($cb); 3351 *$fun = $safe_hole->wrap ($cb);
2217} 3352}
2218 3353
2219=back 3354=back
2220 3355
2221=cut 3356=cut
2222
2223#############################################################################
2224
2225=head2 EXTENSION DATABASE SUPPORT
2226
2227Crossfire maintains a very simple database for extension use. It can
2228currently store anything that can be serialised using Storable, which
2229excludes objects.
2230
2231The parameter C<$family> should best start with the name of the extension
2232using it, it should be unique.
2233
2234=over 4
2235
2236=item $value = cf::db_get $family => $key
2237
2238Returns a single value from the database.
2239
2240=item cf::db_put $family => $key => $value
2241
2242Stores the given C<$value> in the family.
2243
2244=cut
2245
2246our $DB;
2247
2248sub db_init {
2249 unless ($DB) {
2250 $DB = BDB::db_create $DB_ENV;
2251
2252 cf::sync_job {
2253 eval {
2254 $DB->set_flags (BDB::CHKSUM);
2255
2256 BDB::db_open $DB, undef, "db", undef, BDB::BTREE,
2257 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
2258 cf::cleanup "db_open(db): $!" if $!;
2259 };
2260 cf::cleanup "db_open(db): $@" if $@;
2261 };
2262
2263 my $path = cf::localdir . "/database.pst";
2264 if (stat $path) {
2265 cf::sync_job {
2266 my $pst = Storable::retrieve $path;
2267
2268 cf::db_put (board => data => $pst->{board});
2269 cf::db_put (guildrules => data => $pst->{guildrules});
2270 cf::db_put (rent => balance => $pst->{rent}{balance});
2271 BDB::db_env_txn_checkpoint $DB_ENV;
2272
2273 unlink $path;
2274 };
2275 }
2276 }
2277}
2278
2279sub db_get($$) {
2280 my $key = "$_[0]/$_[1]";
2281
2282 cf::sync_job {
2283 BDB::db_get $DB, undef, $key, my $data;
2284
2285 $! ? ()
2286 : Compress::LZF::sthaw $data
2287 }
2288}
2289
2290sub db_put($$$) {
2291 BDB::dbreq_pri 4;
2292 BDB::db_put $DB, undef, "$_[0]/$_[1]", Compress::LZF::sfreeze_cr $_[2], 0, sub { };
2293}
2294 3357
2295############################################################################# 3358#############################################################################
2296# the server's init and main functions 3359# the server's init and main functions
2297 3360
2298sub load_facedata { 3361sub load_facedata($) {
2299 my $path = sprintf "%s/facedata", cf::datadir; 3362 my ($path) = @_;
2300 3363
3364 # HACK to clear player env face cache, we need some signal framework
3365 # for this (global event?)
3366 %ext::player_env::MUSIC_FACE_CACHE = ();
3367
3368 my $enc = JSON::XS->new->utf8->canonical->relaxed;
3369
2301 warn "loading facedata from $path\n"; 3370 trace "loading facedata from $path\n";
2302 3371
2303 my $faces; 3372 my $facedata;
2304 0 < aio_load $path, $faces 3373 0 < aio_load $path, $facedata
2305 or die "$path: $!"; 3374 or die "$path: $!";
2306 3375
2307 Coro::cede;
2308 $faces = Storable::thaw $faces; 3376 $facedata = Coro::Storable::thaw $facedata;
2309 Coro::cede;
2310 3377
2311 my $meta = delete $faces->{""};
2312 $meta->{version} == 1 3378 $facedata->{version} == 2
2313 or cf::cleanup "$path: version mismatch, cannot proceed."; 3379 or cf::cleanup "$path: version mismatch, cannot proceed.";
2314 3380
3381 # patch in the exptable
3382 my $exp_table = $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]);
3383 $facedata->{resource}{"res/exp_table"} = {
3384 type => FT_RSRC,
3385 data => $exp_table,
3386 hash => (Digest::MD5::md5 $exp_table),
3387 };
3388 cf::cede_to_tick;
3389
3390 {
3391 my $faces = $facedata->{faceinfo};
3392
2315 while (my ($face, $info) = each %$faces) { 3393 while (my ($face, $info) = each %$faces) {
2316 my $idx = (cf::face::find $face) || cf::face::alloc $face; 3394 my $idx = (cf::face::find $face) || cf::face::alloc $face;
2317 cf::face::set $idx, $info->{visibility}, $info->{magicmap}; 3395
3396 cf::face::set_visibility $idx, $info->{visibility};
3397 cf::face::set_magicmap $idx, $info->{magicmap};
2318 cf::face::set_data $idx, 0, $info->{data32}, $info->{chksum32}; 3398 cf::face::set_data $idx, 0, $info->{data32}, $info->{hash32};
2319 cf::face::set_data $idx, 1, $info->{data64}, $info->{chksum64}; 3399 cf::face::set_data $idx, 1, $info->{data64}, $info->{hash64};
2320 Coro::cede;
2321 }
2322 3400
3401 cf::cede_to_tick;
3402 }
3403
2323 while (my ($face, $info) = each %$faces) { 3404 while (my ($face, $info) = each %$faces) {
2324 next unless $info->{smooth}; 3405 next unless $info->{smooth};
3406
2325 my $idx = cf::face::find $face 3407 my $idx = cf::face::find $face
3408 or next;
3409
3410 if (my $smooth = cf::face::find $info->{smooth}) {
3411 cf::face::set_smooth $idx, $smooth;
3412 cf::face::set_smoothlevel $idx, $info->{smoothlevel};
3413 } else {
3414 error "smooth face '$info->{smooth}' not found for face '$face'";
3415 }
3416
3417 cf::cede_to_tick;
3418 }
3419 }
3420
3421 {
3422 my $anims = $facedata->{animinfo};
3423
3424 while (my ($anim, $info) = each %$anims) {
3425 cf::anim::set $anim, $info->{frames}, $info->{facings};
3426 cf::cede_to_tick;
3427 }
3428
3429 cf::anim::invalidate_all; # d'oh
3430 }
3431
3432 {
3433 my $res = $facedata->{resource};
3434
3435 while (my ($name, $info) = each %$res) {
3436 if (defined $info->{type}) {
3437 my $idx = (cf::face::find $name) || cf::face::alloc $name;
3438
3439 cf::face::set_data $idx, 0, $info->{data}, $info->{hash};
3440 cf::face::set_type $idx, $info->{type};
3441 } else {
3442 $RESOURCE{$name} = $info; # unused
3443 }
3444
3445 cf::cede_to_tick;
3446 }
3447 }
3448
3449 cf::global->invoke (EVENT_GLOBAL_RESOURCE_UPDATE);
3450
3451 1
3452}
3453
3454register_exticmd fx_want => sub {
3455 my ($ns, $want) = @_;
3456
3457 while (my ($k, $v) = each %$want) {
3458 $ns->fx_want ($k, $v);
3459 }
3460};
3461
3462sub load_resource_file($) {
3463 my $guard = lock_acquire "load_resource_file";
3464
3465 my $status = load_resource_file_ $_[0];
3466 get_slot 0.1, 100;
3467 cf::arch::commit_load;
3468
3469 $status
3470}
3471
3472sub reload_regions {
3473 # HACK to clear player env face cache, we need some signal framework
3474 # for this (global event?)
3475 %ext::player_env::MUSIC_FACE_CACHE = ();
3476
3477 load_resource_file "$MAPDIR/regions"
3478 or die "unable to load regions file\n";
3479
3480 for (cf::region::list) {
3481 $_->{match} = qr/$_->{match}/
3482 if exists $_->{match};
3483 }
3484}
3485
3486sub reload_facedata {
3487 load_facedata "$DATADIR/facedata"
3488 or die "unable to load facedata\n";
3489}
3490
3491sub reload_archetypes {
3492 load_resource_file "$DATADIR/archetypes"
3493 or die "unable to load archetypes\n";
3494}
3495
3496sub reload_treasures {
3497 load_resource_file "$DATADIR/treasures"
3498 or die "unable to load treasurelists\n";
3499}
3500
3501sub reload_sound {
3502 trace "loading sound config from $DATADIR/sound\n";
3503
3504 0 < Coro::AIO::aio_load "$DATADIR/sound", my $data
3505 or die "$DATADIR/sound $!";
3506
3507 my $soundconf = JSON::XS->new->utf8->relaxed->decode ($data);
3508
3509 for (0 .. SOUND_CAST_SPELL_0 - 1) {
3510 my $sound = $soundconf->{compat}[$_]
2326 or next; 3511 or next;
2327 if (my $smooth = cf::face::find $info->{smooth}) {
2328 cf::face::set_smooth $idx, $smooth;
2329 } else {
2330 warn "smooth face '$info->{smooth}' not found for face '$face'";
2331 }
2332 Coro::cede;
2333 }
2334 3512
3513 my $face = cf::face::find "sound/$sound->[1]";
3514 cf::sound::set $sound->[0] => $face;
3515 cf::sound::old_sound_index $_, $face; # gcfclient-compat
2335 1 3516 }
3517
3518 while (my ($k, $v) = each %{$soundconf->{event}}) {
3519 my $face = cf::face::find "sound/$v";
3520 cf::sound::set $k => $face;
3521 }
2336} 3522}
2337 3523
2338sub reload_resources { 3524sub reload_resources {
2339 load_resource_file sprintf "%s/%s/regions", cf::datadir, cf::mapdir 3525 trace "reloading resource files...\n";
2340 or die "unable to load regions file\n";#d# 3526
2341 load_facedata 3527 reload_facedata;
2342 or die "unable to load facedata\n";#d# 3528 reload_sound;
2343} 3529 reload_archetypes;
2344
2345sub init {
2346 reload_resources; 3530 reload_regions;
2347} 3531 reload_treasures;
2348 3532
2349sub cfg_load { 3533 trace "finished reloading resource files\n";
3534}
3535
3536sub reload_config {
3537 trace "reloading config file...\n";
3538
2350 open my $fh, "<:utf8", cf::confdir . "/config" 3539 open my $fh, "<:utf8", "$CONFDIR/config"
2351 or return; 3540 or return;
2352 3541
2353 local $/; 3542 local $/;
2354 *CFG = YAML::Syck::Load <$fh>; 3543 *CFG = YAML::XS::Load scalar <$fh>;
2355 3544
2356 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37]; 3545 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_104_115", 49, 38];
2357 3546
2358 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset}; 3547 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset};
2359 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset}; 3548 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset};
2360 3549
2361 if (exists $CFG{mlockall}) { 3550 if (exists $CFG{mlockall}) {
… …
2363 $CFG{mlockall} ? eval "mlockall()" : eval "munlockall()" 3552 $CFG{mlockall} ? eval "mlockall()" : eval "munlockall()"
2364 and die "WARNING: m(un)lockall failed: $!\n"; 3553 and die "WARNING: m(un)lockall failed: $!\n";
2365 }; 3554 };
2366 warn $@ if $@; 3555 warn $@ if $@;
2367 } 3556 }
3557
3558 trace "finished reloading resource files\n";
3559}
3560
3561sub pidfile() {
3562 sysopen my $fh, $PIDFILE, O_RDWR | O_CREAT
3563 or die "$PIDFILE: $!";
3564 flock $fh, &Fcntl::LOCK_EX
3565 or die "$PIDFILE: flock: $!";
3566 $fh
3567}
3568
3569# make sure only one server instance is running at any one time
3570sub atomic {
3571 my $fh = pidfile;
3572
3573 my $pid = <$fh>;
3574 kill 9, $pid if $pid > 0;
3575
3576 seek $fh, 0, 0;
3577 print $fh $$;
3578}
3579
3580sub main_loop {
3581 trace "EV::loop starting\n";
3582 if (1) {
3583 EV::loop;
3584 }
3585 trace "EV::loop returned\n";
3586 goto &main_loop unless $REALLY_UNLOOP;
2368} 3587}
2369 3588
2370sub main { 3589sub main {
3590 cf::init_globals; # initialise logging
3591
3592 LOG llevInfo, "Welcome to Deliantra, v" . VERSION;
3593 LOG llevInfo, "Copyright (C) 2005-2008 Marc Alexander Lehmann / Robin Redeker / the Deliantra team.";
3594 LOG llevInfo, "Copyright (C) 1994 Mark Wedel.";
3595 LOG llevInfo, "Copyright (C) 1992 Frank Tore Johansen.";
3596
3597 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority
3598
2371 # we must not ever block the main coroutine 3599 # we must not ever block the main coroutine
2372 local $Coro::idle = sub { 3600 local $Coro::idle = sub {
2373 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d# 3601 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
2374 (async { 3602 (async {
2375 Event::one_event; 3603 $Coro::current->{desc} = "IDLE BUG HANDLER";
3604 EV::loop EV::LOOP_ONESHOT;
2376 })->prio (Coro::PRIO_MAX); 3605 })->prio (Coro::PRIO_MAX);
2377 }; 3606 };
2378 3607
2379 cfg_load; 3608 evthread_start IO::AIO::poll_fileno;
3609
3610 cf::sync_job {
3611 cf::init_experience;
3612 cf::init_anim;
3613 cf::init_attackmess;
3614 cf::init_dynamic;
3615
3616 cf::load_settings;
3617 cf::load_materials;
3618
3619 reload_resources;
3620 reload_config;
2380 db_init; 3621 db_init;
3622
3623 cf::init_uuid;
3624 cf::init_signals;
3625 cf::init_skills;
3626
3627 cf::init_beforeplay;
3628
3629 atomic;
3630
2381 load_extensions; 3631 load_extensions;
2382 3632
2383 $TICK_WATCHER->start; 3633 utime time, time, $RUNTIMEFILE;
2384 Event::loop; 3634
3635 # no (long-running) fork's whatsoever before this point(!)
3636 use POSIX ();
3637 POSIX::close delete $ENV{LOCKUTIL_LOCK_FD} if exists $ENV{LOCKUTIL_LOCK_FD};
3638
3639 (pop @POST_INIT)->(0) while @POST_INIT;
3640 };
3641
3642 cf::object::thawer::errors_are_fatal 0;
3643 info "parse errors in files are no longer fatal from this point on.\n";
3644
3645 main_loop;
2385} 3646}
2386 3647
2387############################################################################# 3648#############################################################################
2388# initialisation and cleanup 3649# initialisation and cleanup
2389 3650
2390# install some emergency cleanup handlers 3651# install some emergency cleanup handlers
2391BEGIN { 3652BEGIN {
3653 our %SIGWATCHER = ();
2392 for my $signal (qw(INT HUP TERM)) { 3654 for my $signal (qw(INT HUP TERM)) {
2393 Event->signal ( 3655 $SIGWATCHER{$signal} = AE::signal $signal, sub {
2394 reentrant => 0,
2395 data => WF_AUTOCANCEL,
2396 signal => $signal,
2397 prio => 0,
2398 cb => sub {
2399 cf::cleanup "SIG$signal"; 3656 cf::cleanup "SIG$signal";
2400 },
2401 ); 3657 };
3658 }
3659}
3660
3661sub write_runtime_sync {
3662 my $t0 = AE::time;
3663
3664 # first touch the runtime file to show we are still running:
3665 # the fsync below can take a very very long time.
3666
3667 IO::AIO::aio_utime $RUNTIMEFILE, undef, undef;
3668
3669 my $guard = cf::lock_acquire "write_runtime";
3670
3671 my $fh = aio_open "$RUNTIMEFILE~", O_WRONLY | O_CREAT | O_TRUNC, 0644
3672 or return;
3673
3674 my $value = $cf::RUNTIME + 90 + 10;
3675 # 10 is the runtime save interval, for a monotonic clock
3676 # 60 allows for the watchdog to kill the server.
3677
3678 (aio_write $fh, 0, (length $value), $value, 0) <= 0
3679 and return;
3680
3681 # always fsync - this file is important
3682 aio_fsync $fh
3683 and return;
3684
3685 # touch it again to show we are up-to-date
3686 aio_utime $fh, undef, undef;
3687
3688 close $fh
3689 or return;
3690
3691 aio_rename "$RUNTIMEFILE~", $RUNTIMEFILE
3692 and return;
3693
3694 trace sprintf "runtime file written (%gs).\n", AE::time - $t0;
3695
2402 } 3696 1
3697}
3698
3699our $uuid_lock;
3700our $uuid_skip;
3701
3702sub write_uuid_sync($) {
3703 $uuid_skip ||= $_[0];
3704
3705 return if $uuid_lock;
3706 local $uuid_lock = 1;
3707
3708 my $uuid = "$LOCALDIR/uuid";
3709
3710 my $fh = aio_open "$uuid~", O_WRONLY | O_CREAT, 0644
3711 or return;
3712
3713 my $value = uuid_seq uuid_cur;
3714
3715 unless ($value) {
3716 info "cowardly refusing to write zero uuid value!\n";
3717 return;
3718 }
3719
3720 my $value = uuid_str $value + $uuid_skip;
3721 $uuid_skip = 0;
3722
3723 (aio_write $fh, 0, (length $value), $value, 0) <= 0
3724 and return;
3725
3726 # always fsync - this file is important
3727 aio_fsync $fh
3728 and return;
3729
3730 close $fh
3731 or return;
3732
3733 aio_rename "$uuid~", $uuid
3734 and return;
3735
3736 trace "uuid file written ($value).\n";
3737
3738 1
3739
3740}
3741
3742sub write_uuid($$) {
3743 my ($skip, $sync) = @_;
3744
3745 $sync ? write_uuid_sync $skip
3746 : async { write_uuid_sync $skip };
2403} 3747}
2404 3748
2405sub emergency_save() { 3749sub emergency_save() {
2406 my $freeze_guard = cf::freeze_mainloop; 3750 my $freeze_guard = cf::freeze_mainloop;
2407 3751
2408 warn "enter emergency perl save\n"; 3752 info "emergency_perl_save: enter\n";
3753
3754 # this is a trade-off: we want to be very quick here, so
3755 # save all maps without fsync, and later call a global sync
3756 # (which in turn might be very very slow)
3757 local $USE_FSYNC = 0;
2409 3758
2410 cf::sync_job { 3759 cf::sync_job {
3760 cf::write_runtime_sync; # external watchdog should not bark
3761
2411 # use a peculiar iteration method to avoid tripping on perl 3762 # use a peculiar iteration method to avoid tripping on perl
2412 # refcount bugs in for. also avoids problems with players 3763 # refcount bugs in for. also avoids problems with players
2413 # and maps saved/destroyed asynchronously. 3764 # and maps saved/destroyed asynchronously.
2414 warn "begin emergency player save\n"; 3765 info "emergency_perl_save: begin player save\n";
2415 for my $login (keys %cf::PLAYER) { 3766 for my $login (keys %cf::PLAYER) {
2416 my $pl = $cf::PLAYER{$login} or next; 3767 my $pl = $cf::PLAYER{$login} or next;
2417 $pl->valid or next; 3768 $pl->valid or next;
3769 delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt
2418 $pl->save; 3770 $pl->save;
2419 } 3771 }
2420 warn "end emergency player save\n"; 3772 info "emergency_perl_save: end player save\n";
2421 3773
2422 warn "begin emergency map save\n"; 3774 cf::write_runtime_sync; # external watchdog should not bark
3775
3776 info "emergency_perl_save: begin map save\n";
2423 for my $path (keys %cf::MAP) { 3777 for my $path (keys %cf::MAP) {
2424 my $map = $cf::MAP{$path} or next; 3778 my $map = $cf::MAP{$path} or next;
2425 $map->valid or next; 3779 $map->valid or next;
2426 $map->save; 3780 $map->save;
2427 } 3781 }
2428 warn "end emergency map save\n"; 3782 info "emergency_perl_save: end map save\n";
2429 3783
2430 warn "begin emergency database checkpoint\n"; 3784 cf::write_runtime_sync; # external watchdog should not bark
3785
3786 info "emergency_perl_save: begin database checkpoint\n";
2431 BDB::db_env_txn_checkpoint $DB_ENV; 3787 BDB::db_env_txn_checkpoint $DB_ENV;
2432 warn "end emergency database checkpoint\n"; 3788 info "emergency_perl_save: end database checkpoint\n";
3789
3790 info "emergency_perl_save: begin write uuid\n";
3791 write_uuid_sync 1;
3792 info "emergency_perl_save: end write uuid\n";
3793
3794 cf::write_runtime_sync; # external watchdog should not bark
3795
3796 trace "emergency_perl_save: syncing database to disk";
3797 BDB::db_env_txn_checkpoint $DB_ENV;
3798
3799 info "emergency_perl_save: starting sync\n";
3800 IO::AIO::aio_sync sub {
3801 info "emergency_perl_save: finished sync\n";
3802 };
3803
3804 cf::write_runtime_sync; # external watchdog should not bark
3805
3806 trace "emergency_perl_save: flushing outstanding aio requests";
3807 while (IO::AIO::nreqs || BDB::nreqs) {
3808 Coro::EV::timer_once 0.01; # let the sync_job do it's thing
3809 }
3810
3811 cf::write_runtime_sync; # external watchdog should not bark
2433 }; 3812 };
2434 3813
2435 warn "leave emergency perl save\n"; 3814 info "emergency_perl_save: leave\n";
2436} 3815}
2437 3816
2438sub post_cleanup { 3817sub post_cleanup {
2439 my ($make_core) = @_; 3818 my ($make_core) = @_;
2440 3819
3820 IO::AIO::flush;
3821
2441 warn Carp::longmess "post_cleanup backtrace" 3822 error Carp::longmess "post_cleanup backtrace"
2442 if $make_core; 3823 if $make_core;
2443}
2444 3824
3825 my $fh = pidfile;
3826 unlink $PIDFILE if <$fh> == $$;
3827}
3828
3829# a safer delete_package, copied from Symbol
3830sub clear_package($) {
3831 my $pkg = shift;
3832
3833 # expand to full symbol table name if needed
3834 unless ($pkg =~ /^main::.*::$/) {
3835 $pkg = "main$pkg" if $pkg =~ /^::/;
3836 $pkg = "main::$pkg" unless $pkg =~ /^main::/;
3837 $pkg .= '::' unless $pkg =~ /::$/;
3838 }
3839
3840 my($stem, $leaf) = $pkg =~ m/(.*::)(\w+::)$/;
3841 my $stem_symtab = *{$stem}{HASH};
3842
3843 defined $stem_symtab and exists $stem_symtab->{$leaf}
3844 or return;
3845
3846 # clear all symbols
3847 my $leaf_symtab = *{$stem_symtab->{$leaf}}{HASH};
3848 for my $name (keys %$leaf_symtab) {
3849 _gv_clear *{"$pkg$name"};
3850# use PApp::Util; PApp::Util::sv_dump *{"$pkg$name"};
3851 }
3852}
3853
2445sub reload() { 3854sub do_reload_perl() {
2446 # can/must only be called in main 3855 # can/must only be called in main
2447 if ($Coro::current != $Coro::main) { 3856 if (in_main) {
2448 warn "can only reload from main coroutine"; 3857 error "can only reload from main coroutine";
2449 return; 3858 return;
2450 } 3859 }
2451 3860
3861 return if $RELOAD++;
3862
3863 my $t1 = AE::time;
3864
3865 while ($RELOAD) {
2452 warn "reloading..."; 3866 info "reloading...";
2453 3867
2454 warn "entering sync_job"; 3868 trace "entering sync_job";
2455 3869
2456 cf::sync_job { 3870 cf::sync_job {
2457 cf::write_runtime; # external watchdog should not bark
2458 cf::emergency_save; 3871 cf::emergency_save;
2459 cf::write_runtime; # external watchdog should not bark
2460 3872
2461 warn "syncing database to disk";
2462 BDB::db_env_txn_checkpoint $DB_ENV;
2463
2464 # if anything goes wrong in here, we should simply crash as we already saved
2465
2466 warn "cancelling all WF_AUTOCANCEL watchers";
2467 for (Event::all_watchers) {
2468 $_->cancel if $_->data & WF_AUTOCANCEL;
2469 }
2470
2471 warn "flushing outstanding aio requests";
2472 for (;;) {
2473 BDB::flush;
2474 IO::AIO::flush;
2475 Coro::cede;
2476 last unless IO::AIO::nreqs || BDB::nreqs;
2477 warn "iterate...";
2478 }
2479
2480 ++$RELOAD;
2481
2482 warn "cancelling all extension coros"; 3873 trace "cancelling all extension coros";
2483 $_->cancel for values %EXT_CORO; 3874 $_->cancel for values %EXT_CORO;
2484 %EXT_CORO = (); 3875 %EXT_CORO = ();
2485 3876
2486 warn "removing commands"; 3877 trace "removing commands";
2487 %COMMAND = (); 3878 %COMMAND = ();
2488 3879
2489 warn "removing ext commands"; 3880 trace "removing ext/exti commands";
2490 %EXTCMD = (); 3881 %EXTCMD = ();
3882 %EXTICMD = ();
2491 3883
2492 warn "unloading/nuking all extensions"; 3884 trace "unloading/nuking all extensions";
2493 for my $pkg (@EXTS) { 3885 for my $pkg (@EXTS) {
2494 warn "... unloading $pkg"; 3886 trace "... unloading $pkg";
2495 3887
2496 if (my $cb = $pkg->can ("unload")) { 3888 if (my $cb = $pkg->can ("unload")) {
2497 eval { 3889 eval {
2498 $cb->($pkg); 3890 $cb->($pkg);
2499 1 3891 1
2500 } or warn "$pkg unloaded, but with errors: $@"; 3892 } or error "$pkg unloaded, but with errors: $@";
3893 }
3894
3895 trace "... clearing $pkg";
3896 clear_package $pkg;
2501 } 3897 }
2502 3898
2503 warn "... nuking $pkg";
2504 Symbol::delete_package $pkg;
2505 }
2506
2507 warn "unloading all perl modules loaded from $LIBDIR"; 3899 trace "unloading all perl modules loaded from $LIBDIR";
2508 while (my ($k, $v) = each %INC) { 3900 while (my ($k, $v) = each %INC) {
2509 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/; 3901 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
2510 3902
2511 warn "... unloading $k"; 3903 trace "... unloading $k";
2512 delete $INC{$k}; 3904 delete $INC{$k};
2513 3905
2514 $k =~ s/\.pm$//; 3906 $k =~ s/\.pm$//;
2515 $k =~ s/\//::/g; 3907 $k =~ s/\//::/g;
2516 3908
2517 if (my $cb = $k->can ("unload_module")) { 3909 if (my $cb = $k->can ("unload_module")) {
2518 $cb->(); 3910 $cb->();
3911 }
3912
3913 clear_package $k;
2519 } 3914 }
2520 3915
2521 Symbol::delete_package $k;
2522 }
2523
2524 warn "getting rid of safe::, as good as possible"; 3916 trace "getting rid of safe::, as good as possible";
2525 Symbol::delete_package "safe::$_" 3917 clear_package "safe::$_"
2526 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region); 3918 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
2527 3919
2528 warn "unloading cf.pm \"a bit\""; 3920 trace "unloading cf.pm \"a bit\"";
2529 delete $INC{"cf.pm"}; 3921 delete $INC{"cf.pm"};
3922 delete $INC{"cf/$_.pm"} for @EXTRA_MODULES;
2530 3923
2531 # don't, removes xs symbols, too, 3924 # don't, removes xs symbols, too,
2532 # and global variables created in xs 3925 # and global variables created in xs
2533 #Symbol::delete_package __PACKAGE__; 3926 #clear_package __PACKAGE__;
2534 3927
2535 warn "unload completed, starting to reload now"; 3928 info "unload completed, starting to reload now";
2536 3929
2537 warn "reloading cf.pm"; 3930 trace "reloading cf.pm";
2538 require cf; 3931 require cf;
2539 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 3932 cf::_connect_to_perl_1;
2540 3933
2541 warn "loading config and database again"; 3934 trace "loading config and database again";
2542 cf::cfg_load; 3935 cf::reload_config;
2543 3936
2544 warn "loading extensions"; 3937 trace "loading extensions";
2545 cf::load_extensions; 3938 cf::load_extensions;
2546 3939
3940 if ($REATTACH_ON_RELOAD) {
2547 warn "reattaching attachments to objects/players"; 3941 trace "reattaching attachments to objects/players";
2548 _global_reattach; # objects, sockets 3942 _global_reattach; # objects, sockets
2549 warn "reattaching attachments to maps"; 3943 trace "reattaching attachments to maps";
2550 reattach $_ for values %MAP; 3944 reattach $_ for values %MAP;
2551 warn "reattaching attachments to players"; 3945 trace "reattaching attachments to players";
2552 reattach $_ for values %PLAYER; 3946 reattach $_ for values %PLAYER;
3947 }
2553 3948
2554 warn "loading reloadable resources"; 3949 trace "running post_init jobs";
2555 reload_resources; 3950 (pop @POST_INIT)->(1) while @POST_INIT;
2556 3951
2557 warn "leaving sync_job"; 3952 trace "leaving sync_job";
2558 3953
2559 1 3954 1
2560 } or do { 3955 } or do {
2561 warn $@; 3956 error $@;
2562 warn "error while reloading, exiting."; 3957 cf::cleanup "error while reloading, exiting.";
2563 exit 1; 3958 };
3959
3960 info "reloaded";
3961 --$RELOAD;
3962 }
3963
3964 $t1 = AE::time - $t1;
3965 info "reload completed in ${t1}s\n";
3966};
3967
3968our $RELOAD_WATCHER; # used only during reload
3969
3970sub reload_perl() {
3971 # doing reload synchronously and two reloads happen back-to-back,
3972 # coro crashes during coro_state_free->destroy here.
3973
3974 $RELOAD_WATCHER ||= cf::async {
3975 Coro::AIO::aio_wait cache_extensions;
3976
3977 $RELOAD_WATCHER = AE::timer $TICK * 1.5, 0, sub {
3978 do_reload_perl;
3979 undef $RELOAD_WATCHER;
3980 };
2564 }; 3981 };
2565 3982}
2566 warn "reloaded";
2567};
2568
2569our $RELOAD_WATCHER; # used only during reload
2570 3983
2571register_command "reload" => sub { 3984register_command "reload" => sub {
2572 my ($who, $arg) = @_; 3985 my ($who, $arg) = @_;
2573 3986
2574 if ($who->flag (FLAG_WIZ)) { 3987 if ($who->flag (FLAG_WIZ)) {
2575 $who->message ("reloading server."); 3988 $who->message ("reloading server.");
2576 3989 async {
2577 # doing reload synchronously and two reloads happen back-to-back, 3990 $Coro::current->{desc} = "perl_reload";
2578 # coro crashes during coro_state_free->destroy here.
2579
2580 $RELOAD_WATCHER ||= Event->timer (
2581 reentrant => 0,
2582 after => 0,
2583 data => WF_AUTOCANCEL,
2584 cb => sub {
2585 reload; 3991 reload_perl;
2586 undef $RELOAD_WATCHER;
2587 },
2588 ); 3992 };
2589 } 3993 }
2590}; 3994};
2591 3995
2592unshift @INC, $LIBDIR; 3996unshift @INC, $LIBDIR;
2593 3997
2594my $bug_warning = 0; 3998my $bug_warning = 0;
2595 3999
2596$TICK_WATCHER = Event->timer ( 4000our @WAIT_FOR_TICK;
2597 reentrant => 0, 4001our @WAIT_FOR_TICK_BEGIN;
2598 parked => 1, 4002
2599 prio => 0, 4003sub wait_for_tick {
2600 at => $NEXT_TICK || $TICK, 4004 return Coro::cede if tick_inhibit || $Coro::current == $Coro::main;
2601 data => WF_AUTOCANCEL, 4005
2602 cb => sub { 4006 my $signal = new Coro::Signal;
4007 push @WAIT_FOR_TICK, $signal;
4008 $signal->wait;
4009}
4010
4011sub wait_for_tick_begin {
4012 return Coro::cede if tick_inhibit || $Coro::current == $Coro::main;
4013
4014 my $signal = new Coro::Signal;
4015 push @WAIT_FOR_TICK_BEGIN, $signal;
4016 $signal->wait;
4017}
4018
4019sub tick {
2603 if ($Coro::current != $Coro::main) { 4020 if ($Coro::current != $Coro::main) {
2604 Carp::cluck "major BUG: server tick called outside of main coro, skipping it" 4021 Carp::cluck "major BUG: server tick called outside of main coro, skipping it"
2605 unless ++$bug_warning > 10; 4022 unless ++$bug_warning > 10;
2606 return; 4023 return;
2607 } 4024 }
2608 4025
2609 $NOW = Event::time;
2610
2611 cf::server_tick; # one server iteration 4026 cf::server_tick; # one server iteration
2612 $RUNTIME += $TICK;
2613 $NEXT_TICK += $TICK;
2614 4027
4028 #for(1..3e6){} AE::now_update; $NOW=AE::now; # generate load #d#
4029
2615 if ($NOW >= $NEXT_RUNTIME_WRITE) { 4030 if ($NOW >= $NEXT_RUNTIME_WRITE) {
2616 $NEXT_RUNTIME_WRITE = $NOW + 10; 4031 $NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.;
2617 Coro::async_pool { 4032 Coro::async_pool {
4033 $Coro::current->{desc} = "runtime saver";
2618 write_runtime 4034 write_runtime_sync
2619 or warn "ERROR: unable to write runtime file: $!"; 4035 or error "ERROR: unable to write runtime file: $!";
2620 };
2621 } 4036 };
2622
2623 $WAIT_FOR_TICK->broadcast;
2624 $WAIT_FOR_TICK_ONE->send if $WAIT_FOR_TICK_ONE->awaited;
2625
2626# my $AFTER = Event::time;
2627# warn $AFTER - $NOW;#d#
2628
2629 # if we are delayed by four ticks or more, skip them all
2630 $NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4;
2631
2632 $TICK_WATCHER->at ($NEXT_TICK);
2633 $TICK_WATCHER->start;
2634 }, 4037 }
2635); 4038
4039 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
4040 $sig->send;
4041 }
4042 while (my $sig = shift @WAIT_FOR_TICK) {
4043 $sig->send;
4044 }
4045
4046 $LOAD = ($NOW - $TICK_START) / $TICK;
4047 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
4048
4049 if (0) {
4050 if ($NEXT_TICK) {
4051 my $jitter = $TICK_START - $NEXT_TICK;
4052 $JITTER = $JITTER * 0.75 + $jitter * 0.25;
4053 debug "jitter $JITTER\n";#d#
4054 }
4055 }
4056}
2636 4057
2637{ 4058{
2638 BDB::max_poll_time $TICK * 0.1; 4059 # configure BDB
2639 $BDB_POLL_WATCHER = Event->io ( 4060
2640 reentrant => 0,
2641 fd => BDB::poll_fileno,
2642 poll => 'r',
2643 prio => 0,
2644 data => WF_AUTOCANCEL,
2645 cb => \&BDB::poll_cb,
2646 );
2647 BDB::min_parallel 8; 4061 BDB::min_parallel 16;
2648 4062 BDB::max_poll_reqs $TICK * 0.1;
2649 BDB::set_sync_prepare { 4063 $AnyEvent::BDB::WATCHER->priority (1);
2650 my $status;
2651 my $current = $Coro::current;
2652 (
2653 sub {
2654 $status = $!;
2655 $current->ready; undef $current;
2656 },
2657 sub {
2658 Coro::schedule while defined $current;
2659 $! = $status;
2660 },
2661 )
2662 };
2663 4064
2664 unless ($DB_ENV) { 4065 unless ($DB_ENV) {
2665 $DB_ENV = BDB::db_env_create; 4066 $DB_ENV = BDB::db_env_create;
4067 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT);
4068 $DB_ENV->set_flags (&BDB::LOG_AUTOREMOVE ) if BDB::VERSION v0, v4.7;
4069 $DB_ENV->log_set_config (&BDB::LOG_AUTO_REMOVE) if BDB::VERSION v4.7;
4070 $DB_ENV->set_timeout (30, BDB::SET_TXN_TIMEOUT);
4071 $DB_ENV->set_timeout (30, BDB::SET_LOCK_TIMEOUT);
2666 4072
2667 cf::sync_job { 4073 cf::sync_job {
2668 eval { 4074 eval {
2669 BDB::db_env_open 4075 BDB::db_env_open
2670 $DB_ENV, 4076 $DB_ENV,
2671 $BDB_ENV_DIR, 4077 $BDBDIR,
2672 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN 4078 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN
2673 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE, 4079 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE,
2674 0666; 4080 0666;
2675 4081
2676 cf::cleanup "db_env_open($BDB_ENV_DIR): $!" if $!; 4082 cf::cleanup "db_env_open($BDBDIR): $!" if $!;
2677
2678 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC, 1);
2679 $DB_ENV->set_lk_detect;
2680 }; 4083 };
2681 4084
2682 cf::cleanup "db_env_open(db): $@" if $@; 4085 cf::cleanup "db_env_open(db): $@" if $@;
2683 }; 4086 };
2684 } 4087 }
4088
4089 $BDB_DEADLOCK_WATCHER = EV::periodic 0, 3, 0, sub {
4090 BDB::db_env_lock_detect $DB_ENV, 0, BDB::LOCK_DEFAULT, 0, sub { };
4091 };
4092 $BDB_CHECKPOINT_WATCHER = EV::periodic 0, 60, 0, sub {
4093 BDB::db_env_txn_checkpoint $DB_ENV, 0, 0, 0, sub { };
4094 };
4095 $BDB_TRICKLE_WATCHER = EV::periodic 0, 10, 0, sub {
4096 BDB::db_env_memp_trickle $DB_ENV, 20, 0, sub { };
4097 };
2685} 4098}
2686 4099
2687{ 4100{
4101 # configure IO::AIO
4102
2688 IO::AIO::min_parallel 8; 4103 IO::AIO::min_parallel 8;
2689
2690 undef $Coro::AIO::WATCHER;
2691 IO::AIO::max_poll_time $TICK * 0.1; 4104 IO::AIO::max_poll_time $TICK * 0.1;
2692 $AIO_POLL_WATCHER = Event->io ( 4105 undef $AnyEvent::AIO::WATCHER;
2693 reentrant => 0,
2694 data => WF_AUTOCANCEL,
2695 fd => IO::AIO::poll_fileno,
2696 poll => 'r',
2697 prio => 6,
2698 cb => \&IO::AIO::poll_cb,
2699 );
2700} 4106}
4107
4108my $_log_backtrace;
4109
4110sub _log_backtrace {
4111 my ($msg, @addr) = @_;
4112
4113 $msg =~ s/\n//;
4114
4115 # limit the # of concurrent backtraces
4116 if ($_log_backtrace < 2) {
4117 ++$_log_backtrace;
4118 my $perl_bt = Carp::longmess $msg;
4119 async {
4120 $Coro::current->{desc} = "abt $msg";
4121
4122 my @bt = fork_call {
4123 @addr = map { sprintf "%x", $_ } @addr;
4124 my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X;
4125 open my $fh, "exec addr2line -C -f -i -e \Q$self\E @addr 2>&1 |"
4126 or die "addr2line: $!";
4127
4128 my @funcs;
4129 my @res = <$fh>;
4130 chomp for @res;
4131 while (@res) {
4132 my ($func, $line) = splice @res, 0, 2, ();
4133 push @funcs, "[$func] $line";
4134 }
4135
4136 @funcs
4137 };
4138
4139 LOG llevInfo, "[ABT] $perl_bt\n";
4140 LOG llevInfo, "[ABT] --- C backtrace follows ---\n";
4141 LOG llevInfo, "[ABT] $_\n" for @bt;
4142 --$_log_backtrace;
4143 };
4144 } else {
4145 LOG llevInfo, "[ABT] $msg\n";
4146 LOG llevInfo, "[ABT] [suppressed]\n";
4147 }
4148}
4149
4150# load additional modules
4151require "cf/$_.pm" for @EXTRA_MODULES;
4152cf::_connect_to_perl_2;
2701 4153
2702END { cf::emergency_save } 4154END { cf::emergency_save }
2703 4155
27041 41561
2705 4157

Diff Legend

– Removed lines
+ Added lines
< Changed lines
> Changed lines