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.108 by root, Sun Dec 31 21:02:05 2006 UTC vs.
Revision 1.398 by root, Wed Dec 5 11:08:34 2007 UTC

… …
3use utf8; 3use utf8;
4use strict; 4use strict;
5 5
6use Symbol; 6use Symbol;
7use List::Util; 7use List::Util;
8use Storable; 8use Socket;
9use EV;
9use Opcode; 10use Opcode;
10use Safe; 11use Safe;
11use Safe::Hole; 12use Safe::Hole;
13use Storable ();
12 14
13use Coro 3.3; 15use Coro 4.1 ();
16use Coro::State;
17use Coro::Handle;
14use Coro::Event; 18use Coro::EV;
15use Coro::Timer; 19use Coro::Timer;
16use Coro::Signal; 20use Coro::Signal;
17use Coro::Semaphore; 21use Coro::Semaphore;
18use Coro::AIO; 22use Coro::AIO;
23use Coro::Storable;
24use Coro::Util ();
19 25
26use JSON::XS 2.01 ();
27use BDB ();
28use Data::Dumper;
20use Digest::MD5; 29use Digest::MD5;
21use Fcntl; 30use Fcntl;
22use IO::AIO 2.31 ();
23use YAML::Syck (); 31use YAML::Syck ();
32use IO::AIO 2.51 ();
24use Time::HiRes; 33use Time::HiRes;
34use Compress::LZF;
35use Digest::MD5 ();
25 36
26use Event; $Event::Eval = 1; # no idea why this is required, but it is 37# configure various modules to our taste
38#
39$Storable::canonical = 1; # reduce rsync transfers
40Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator
41Compress::LZF::sfreeze_cr { }; # prime Compress::LZF so it does not use require later
27 42
28# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode? 43# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode?
29$YAML::Syck::ImplicitUnicode = 1; 44$YAML::Syck::ImplicitUnicode = 1;
30 45
31$Coro::main->prio (2); # run main coroutine ("the server") with very high priority 46$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority
32 47
33sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload 48sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
34 49
35our %COMMAND = (); 50our %COMMAND = ();
36our %COMMAND_TIME = (); 51our %COMMAND_TIME = ();
52
53our @EXTS = (); # list of extension package names
37our %EXTCMD = (); 54our %EXTCMD = ();
55our %EXTICMD = ();
56our %EXT_CORO = (); # coroutines bound to extensions
57our %EXT_MAP = (); # pluggable maps
38 58
59our $RELOAD; # number of reloads so far
39our @EVENT; 60our @EVENT;
40our $LIBDIR = datadir . "/ext";
41 61
42our $TICK = MAX_TIME * 1e-6; 62our $CONFDIR = confdir;
63our $DATADIR = datadir;
64our $LIBDIR = "$DATADIR/ext";
65our $PODDIR = "$DATADIR/pod";
66our $MAPDIR = "$DATADIR/" . mapdir;
67our $LOCALDIR = localdir;
68our $TMPDIR = "$LOCALDIR/" . tmpdir;
69our $UNIQUEDIR = "$LOCALDIR/" . uniquedir;
70our $PLAYERDIR = "$LOCALDIR/" . playerdir;
71our $RANDOMDIR = "$LOCALDIR/random";
72our $BDBDIR = "$LOCALDIR/db";
73
74our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!)
43our $TICK_WATCHER; 75our $TICK_WATCHER;
76our $AIO_POLL_WATCHER;
77our $NEXT_RUNTIME_WRITE; # when should the runtime file be written
44our $NEXT_TICK; 78our $NEXT_TICK;
45our $NOW; 79our $NOW;
80our $USE_FSYNC = 1; # use fsync to write maps - default off
81
82our $BDB_POLL_WATCHER;
83our $BDB_DEADLOCK_WATCHER;
84our $BDB_CHECKPOINT_WATCHER;
85our $BDB_TRICKLE_WATCHER;
86our $DB_ENV;
46 87
47our %CFG; 88our %CFG;
48 89
49our $UPTIME; $UPTIME ||= time; 90our $UPTIME; $UPTIME ||= time;
50our $RUNTIME; 91our $RUNTIME;
51 92
52our %MAP; # all maps 93our (%PLAYER, %PLAYER_LOADING); # all users
53our $LINK_MAP; # the special {link} map 94our (%MAP, %MAP_LOADING ); # all maps
54our $FREEZE; 95our $LINK_MAP; # the special {link} map, which is always available
55our $RANDOM_MAPS = cf::localdir . "/random"; 96
56our %EXT_CORO; 97# used to convert map paths into valid unix filenames by replacing / by ∕
98our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons
99
100our $LOAD; # a number between 0 (idle) and 1 (too many objects)
101our $LOADAVG; # same thing, but with alpha-smoothing
102our $tick_start; # for load detecting purposes
57 103
58binmode STDOUT; 104binmode STDOUT;
59binmode STDERR; 105binmode STDERR;
60 106
61# read virtual server time, if available 107# read virtual server time, if available
62unless ($RUNTIME || !-e cf::localdir . "/runtime") { 108unless ($RUNTIME || !-e "$LOCALDIR/runtime") {
63 open my $fh, "<", cf::localdir . "/runtime" 109 open my $fh, "<", "$LOCALDIR/runtime"
64 or die "unable to read runtime file: $!"; 110 or die "unable to read runtime file: $!";
65 $RUNTIME = <$fh> + 0.; 111 $RUNTIME = <$fh> + 0.;
66} 112}
67 113
68mkdir cf::localdir; 114mkdir $_
69mkdir cf::localdir . "/" . cf::playerdir; 115 for $LOCALDIR, $TMPDIR, $UNIQUEDIR, $PLAYERDIR, $RANDOMDIR, $BDBDIR;
70mkdir cf::localdir . "/" . cf::tmpdir;
71mkdir cf::localdir . "/" . cf::uniquedir;
72mkdir $RANDOM_MAPS;
73 116
74# a special map that is always available 117our $EMERGENCY_POSITION;
75our $LINK_MAP; 118
119sub cf::map::normalise;
76 120
77############################################################################# 121#############################################################################
78 122
79=head2 GLOBAL VARIABLES 123=head2 GLOBAL VARIABLES
80 124
… …
87=item $cf::RUNTIME 131=item $cf::RUNTIME
88 132
89The time this server has run, starts at 0 and is increased by $cf::TICK on 133The time this server has run, starts at 0 and is increased by $cf::TICK on
90every server tick. 134every server tick.
91 135
92=item $cf::LIBDIR 136=item $cf::CONFDIR $cf::DATADIR $cf::LIBDIR $cf::PODDIR
137$cf::MAPDIR $cf::LOCALDIR $cf::TMPDIR $cf::UNIQUEDIR
138$cf::PLAYERDIR $cf::RANDOMDIR $cf::BDBDIR
93 139
94The perl library directory, where extensions and cf-specific modules can 140Various directories - "/etc", read-only install directory, perl-library
95be found. It will be added to C<@INC> automatically. 141directory, pod-directory, read-only maps directory, "/var", "/var/tmp",
142unique-items directory, player file directory, random maps directory and
143database environment.
96 144
97=item $cf::NOW 145=item $cf::NOW
98 146
99The time of the last (current) server tick. 147The time of the last (current) server tick.
100 148
101=item $cf::TICK 149=item $cf::TICK
102 150
103The interval between server ticks, in seconds. 151The interval between server ticks, in seconds.
104 152
153=item $cf::LOADAVG
154
155The current CPU load on the server (alpha-smoothed), as a value between 0
156(none) and 1 (overloaded), indicating how much time is spent on processing
157objects per tick. Healthy values are < 0.5.
158
159=item $cf::LOAD
160
161The raw value load value from the last tick.
162
105=item %cf::CFG 163=item %cf::CFG
106 164
107Configuration for the server, loaded from C</etc/crossfire/config>, or 165Configuration for the server, loaded from C</etc/deliantra-server/config>, or
108from wherever your confdir points to. 166from wherever your confdir points to.
167
168=item cf::wait_for_tick, cf::wait_for_tick_begin
169
170These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only
171returns directly I<after> the tick processing (and consequently, can only wake one process
172per tick), while cf::wait_for_tick wakes up all waiters after tick processing.
173
174=item @cf::INVOKE_RESULTS
175
176This array contains the results of the last C<invoke ()> call. When
177C<cf::override> is called C<@cf::INVOKE_RESULTS> is set to the parameters of
178that call.
109 179
110=back 180=back
111 181
112=cut 182=cut
113 183
114BEGIN { 184BEGIN {
115 *CORE::GLOBAL::warn = sub { 185 *CORE::GLOBAL::warn = sub {
116 my $msg = join "", @_; 186 my $msg = join "", @_;
117 utf8::encode $msg;
118 187
119 $msg .= "\n" 188 $msg .= "\n"
120 unless $msg =~ /\n$/; 189 unless $msg =~ /\n$/;
121 190
191 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;
192
122 LOG llevError, "cfperl: $msg"; 193 LOG llevError, $msg;
123 }; 194 };
124} 195}
125 196
126@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable'; 197@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
127@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable'; 198@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';
128@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable'; 199@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable';
129@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable'; 200@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable';
130@safe::cf::map::ISA = @cf::map::ISA = 'cf::attachable'; 201@safe::cf::map::ISA = @cf::map::ISA = 'cf::attachable';
202@safe::cf::arch::ISA = @cf::arch::ISA = 'cf::object';
131@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object'; 203@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object'; # not really true (yet)
132 204
133# we bless all objects into (empty) derived classes to force a method lookup 205# we bless all objects into (empty) derived classes to force a method lookup
134# within the Safe compartment. 206# within the Safe compartment.
135for my $pkg (qw( 207for my $pkg (qw(
136 cf::global cf::attachable 208 cf::global cf::attachable
… …
141)) { 213)) {
142 no strict 'refs'; 214 no strict 'refs';
143 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg; 215 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
144} 216}
145 217
146$Event::DIED = sub { 218$EV::DIED = sub {
147 warn "error in event callback: @_"; 219 warn "error in event callback: @_";
148}; 220};
149 221
150my %ext_pkg; 222#############################################################################
151my @exts;
152my @hook;
153 223
154=head2 UTILITY FUNCTIONS 224=head2 UTILITY FUNCTIONS
155 225
156=over 4 226=over 4
157 227
158=cut 228=item dumpval $ref
159 229
160use JSON::Syck (); # TODO# replace by JSON::PC once working 230=cut
161 231
232sub dumpval {
233 eval {
234 local $SIG{__DIE__};
235 my $d;
236 if (1) {
237 $d = new Data::Dumper([$_[0]], ["*var"]);
238 $d->Terse(1);
239 $d->Indent(2);
240 $d->Quotekeys(0);
241 $d->Useqq(1);
242 #$d->Bless(...);
243 $d->Seen($_[1]) if @_ > 1;
244 $d = $d->Dump();
245 }
246 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge;
247 $d
248 } || "[unable to dump $_[0]: '$@']";
249}
250
162=item $ref = cf::from_json $json 251=item $ref = cf::decode_json $json
163 252
164Converts a JSON string into the corresponding perl data structure. 253Converts a JSON string into the corresponding perl data structure.
165 254
166=cut
167
168sub from_json($) {
169 $JSON::Syck::ImplicitUnicode = 1; # work around JSON::Syck bugs
170 JSON::Syck::Load $_[0]
171}
172
173=item $json = cf::to_json $ref 255=item $json = cf::encode_json $ref
174 256
175Converts a perl data structure into its JSON representation. 257Converts a perl data structure into its JSON representation.
176 258
177=cut 259=cut
178 260
179sub to_json($) { 261our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max
180 $JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs 262
181 JSON::Syck::Dump $_[0] 263sub encode_json($) { $json_coder->encode ($_[0]) }
264sub decode_json($) { $json_coder->decode ($_[0]) }
265
266=item cf::lock_wait $string
267
268Wait until the given lock is available. See cf::lock_acquire.
269
270=item my $lock = cf::lock_acquire $string
271
272Wait until the given lock is available and then acquires it and returns
273a Coro::guard object. If the guard object gets destroyed (goes out of scope,
274for example when the coroutine gets canceled), the lock is automatically
275returned.
276
277Locks are *not* recursive, locking from the same coro twice results in a
278deadlocked coro.
279
280Lock names should begin with a unique identifier (for example, cf::map::find
281uses map_find and cf::map::load uses map_load).
282
283=item $locked = cf::lock_active $string
284
285Return true if the lock is currently active, i.e. somebody has locked it.
286
287=cut
288
289our %LOCK;
290our %LOCKER;#d#
291
292sub lock_wait($) {
293 my ($key) = @_;
294
295 if ($LOCKER{$key} == $Coro::current) {#d#
296 Carp::cluck "lock_wait($key) for already-acquired lock";#d#
297 return;#d#
298 }#d#
299
300 # wait for lock, if any
301 while ($LOCK{$key}) {
302 push @{ $LOCK{$key} }, $Coro::current;
303 Coro::schedule;
304 }
182} 305}
306
307sub lock_acquire($) {
308 my ($key) = @_;
309
310 # wait, to be sure we are not locked
311 lock_wait $key;
312
313 $LOCK{$key} = [];
314 $LOCKER{$key} = $Coro::current;#d#
315
316 Coro::guard {
317 delete $LOCKER{$key};#d#
318 # wake up all waiters, to be on the safe side
319 $_->ready for @{ delete $LOCK{$key} };
320 }
321}
322
323sub lock_active($) {
324 my ($key) = @_;
325
326 ! ! $LOCK{$key}
327}
328
329sub freeze_mainloop {
330 return unless $TICK_WATCHER->is_active;
331
332 my $guard = Coro::guard {
333 $TICK_WATCHER->start;
334 };
335 $TICK_WATCHER->stop;
336 $guard
337}
338
339=item cf::periodic $interval, $cb
340
341Like EV::periodic, but randomly selects a starting point so that the actions
342get spread over timer.
343
344=cut
345
346sub periodic($$) {
347 my ($interval, $cb) = @_;
348
349 my $start = rand List::Util::min 180, $interval;
350
351 EV::periodic $start, $interval, 0, $cb
352}
353
354=item cf::get_slot $time[, $priority[, $name]]
355
356Allocate $time seconds of blocking CPU time at priority C<$priority>:
357This call blocks and returns only when you have at least C<$time> seconds
358of cpu time till the next tick. The slot is only valid till the next cede.
359
360The optional C<$name> can be used to identify the job to run. It might be
361used for statistical purposes and should identify the same time-class.
362
363Useful for short background jobs.
364
365=cut
366
367our @SLOT_QUEUE;
368our $SLOT_QUEUE;
369
370$SLOT_QUEUE->cancel if $SLOT_QUEUE;
371$SLOT_QUEUE = Coro::async {
372 $Coro::current->desc ("timeslot manager");
373
374 my $signal = new Coro::Signal;
375
376 while () {
377 next_job:
378 my $avail = cf::till_tick;
379 if ($avail > 0.01) {
380 for (0 .. $#SLOT_QUEUE) {
381 if ($SLOT_QUEUE[$_][0] < $avail) {
382 my $job = splice @SLOT_QUEUE, $_, 1, ();
383 $job->[2]->send;
384 Coro::cede;
385 goto next_job;
386 }
387 }
388 }
389
390 if (@SLOT_QUEUE) {
391 # we do not use wait_for_tick() as it returns immediately when tick is inactive
392 push @cf::WAIT_FOR_TICK, $signal;
393 $signal->wait;
394 } else {
395 Coro::schedule;
396 }
397 }
398};
399
400sub get_slot($;$$) {
401 my ($time, $pri, $name) = @_;
402
403 $time = $TICK * .6 if $time > $TICK * .6;
404 my $sig = new Coro::Signal;
405
406 push @SLOT_QUEUE, [$time, $pri, $sig, $name];
407 @SLOT_QUEUE = sort { $b->[1] <=> $a->[1] } @SLOT_QUEUE;
408 $SLOT_QUEUE->ready;
409 $sig->wait;
410}
411
412=item cf::async { BLOCK }
413
414Currently the same as Coro::async_pool, meaning you cannot use
415C<on_destroy>, C<join> or other gimmicks on these coroutines. The only
416thing you are allowed to do is call C<prio> on it.
417
418=cut
419
420BEGIN { *async = \&Coro::async_pool }
183 421
184=item cf::sync_job { BLOCK } 422=item cf::sync_job { BLOCK }
185 423
186The design of crossfire+ requires that the main coro ($Coro::main) is 424The design of Deliantra requires that the main coroutine ($Coro::main)
187always able to handle events or runnable, as crossfire+ is only partly 425is always able to handle events or runnable, as Deliantra is only
188reentrant. Thus "blocking" it by e.g. waiting for I/O is not acceptable. 426partly reentrant. Thus "blocking" it by e.g. waiting for I/O is not
427acceptable.
189 428
190If it must be done, put the blocking parts into C<sync_job>. This will run 429If it must be done, put the blocking parts into C<sync_job>. This will run
191the given BLOCK in another coroutine while waiting for the result. The 430the given BLOCK in another coroutine while waiting for the result. The
192server will be frozen during this time, so the block should either finish 431server will be frozen during this time, so the block should either finish
193fast or be very important. 432fast or be very important.
… …
195=cut 434=cut
196 435
197sub sync_job(&) { 436sub sync_job(&) {
198 my ($job) = @_; 437 my ($job) = @_;
199 438
200 my $busy = 1;
201 my @res;
202
203 # TODO: use suspend/resume instead
204 local $FREEZE = 1;
205
206 my $coro = Coro::async {
207 @res = eval { $job->() };
208 warn $@ if $@;
209 undef $busy;
210 };
211
212 if ($Coro::current == $Coro::main) { 439 if ($Coro::current == $Coro::main) {
440 my $time = EV::time;
441
442 # this is the main coro, too bad, we have to block
443 # till the operation succeeds, freezing the server :/
444
445 LOG llevError, Carp::longmess "sync job";#d#
446
447 # TODO: use suspend/resume instead
448 # (but this is cancel-safe)
449 my $freeze_guard = freeze_mainloop;
450
451 my $busy = 1;
452 my @res;
453
454 (async {
455 $Coro::current->desc ("sync job coro");
456 @res = eval { $job->() };
457 warn $@ if $@;
458 undef $busy;
213 $coro->prio (Coro::PRIO_MAX); 459 })->prio (Coro::PRIO_MAX);
460
214 while ($busy) { 461 while ($busy) {
462 if (Coro::nready) {
215 Coro::cede_notself; 463 Coro::cede_notself;
216 Event::one_event unless Coro::nready; 464 } else {
465 EV::loop EV::LOOP_ONESHOT;
217 } 466 }
467 }
468
469 $time = EV::time - $time;
470
471 LOG llevError | logBacktrace, Carp::longmess "long sync job"
472 if $time > $TICK * 0.5 && $TICK_WATCHER->is_active;
473
474 $tick_start += $time; # do not account sync jobs to server load
475
476 wantarray ? @res : $res[0]
218 } else { 477 } else {
219 $coro->join; 478 # we are in another coroutine, how wonderful, everything just works
479
480 $job->()
220 } 481 }
221
222 wantarray ? @res : $res[0]
223} 482}
224 483
225=item $coro = cf::coro { BLOCK } 484=item $coro = cf::async_ext { BLOCK }
226 485
227Creates and returns a new coro. This coro is automcatially being canceled 486Like async, but this coro is automatically being canceled when the
228when the extension calling this is being unloaded. 487extension calling this is being unloaded.
229 488
230=cut 489=cut
231 490
232sub coro(&) { 491sub async_ext(&) {
233 my $cb = shift; 492 my $cb = shift;
234 493
235 my $coro; $coro = async { 494 my $coro = &Coro::async ($cb);
236 eval {
237 $cb->();
238 };
239 warn $@ if $@;
240 };
241 495
242 $coro->on_destroy (sub { 496 $coro->on_destroy (sub {
243 delete $EXT_CORO{$coro+0}; 497 delete $EXT_CORO{$coro+0};
244 }); 498 });
245 $EXT_CORO{$coro+0} = $coro; 499 $EXT_CORO{$coro+0} = $coro;
246 500
247 $coro 501 $coro
248} 502}
249 503
250sub write_runtime { 504=item fork_call { }, $args
251 my $runtime = cf::localdir . "/runtime";
252 505
253 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644 506Executes the given code block with the given arguments in a seperate
254 or return; 507process, returning the results. Everything must be serialisable with
508Coro::Storable. May, of course, block. Note that the executed sub may
509never block itself or use any form of event handling.
255 510
256 my $value = $cf::RUNTIME; 511=cut
257 (aio_write $fh, 0, (length $value), $value, 0) <= 0
258 and return;
259 512
260 aio_fsync $fh 513sub fork_call(&@) {
261 and return; 514 my ($cb, @args) = @_;
262 515
263 close $fh 516 # we seemingly have to make a local copy of the whole thing,
264 or return; 517 # otherwise perl prematurely frees the stuff :/
518 # TODO: investigate and fix (likely this will be rather laborious)
265 519
266 aio_rename "$runtime~", $runtime 520 my @res = Coro::Util::fork_eval {
267 and return; 521 reset_signals;
522 &$cb
523 }, @args;
268 524
525 wantarray ? @res : $res[-1]
526}
527
528=item $value = cf::db_get $family => $key
529
530Returns a single value from the environment database.
531
532=item cf::db_put $family => $key => $value
533
534Stores the given C<$value> in the family. It can currently store binary
535data only (use Compress::LZF::sfreeze_cr/sthaw to convert to/from binary).
536
537=item $db = cf::db_table "name"
538
539Create and/or open a new database table. The string must not be "db" and must be unique
540within each server.
541
542=cut
543
544sub db_table($) {
545 my ($name) = @_;
546 my $db = BDB::db_create $DB_ENV;
547
548 eval {
549 $db->set_flags (BDB::CHKSUM);
550
551 utf8::encode $name;
552 BDB::db_open $db, undef, $name, undef, BDB::BTREE,
553 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
554 cf::cleanup "db_open(db): $!" if $!;
555 };
556 cf::cleanup "db_open(db): $@" if $@;
557
558 $db
559}
560
561our $DB;
562
563sub db_init {
564 cf::sync_job {
565 $DB ||= db_table "db";
566 };
567}
568
569sub db_get($$) {
570 my $key = "$_[0]/$_[1]";
571
572 cf::sync_job {
573 BDB::db_get $DB, undef, $key, my $data;
574
575 $! ? ()
576 : $data
269 1 577 }
578}
579
580sub db_put($$$) {
581 BDB::dbreq_pri 4;
582 BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { };
583}
584
585=item cf::cache $id => [$paths...], $processversion => $process
586
587Generic caching function that returns the value of the resource $id,
588caching and regenerating as required.
589
590This function can block.
591
592=cut
593
594sub cache {
595 my ($id, $src, $processversion, $process) = @_;
596
597 my $meta =
598 join "\x00",
599 $processversion,
600 map {
601 aio_stat $_
602 and Carp::croak "$_: $!";
603
604 ($_, (stat _)[7,9])
605 } @$src;
606
607 my $dbmeta = db_get cache => "$id/meta";
608 if ($dbmeta ne $meta) {
609 # changed, we may need to process
610
611 my @data;
612 my $md5;
613
614 for (0 .. $#$src) {
615 0 <= aio_load $src->[$_], $data[$_]
616 or Carp::croak "$src->[$_]: $!";
617 }
618
619 # if processing is expensive, check
620 # checksum first
621 if (1) {
622 $md5 =
623 join "\x00",
624 $processversion,
625 map {
626 cf::cede_to_tick;
627 ($src->[$_], Digest::MD5::md5_hex $data[$_])
628 } 0.. $#$src;
629
630
631 my $dbmd5 = db_get cache => "$id/md5";
632 if ($dbmd5 eq $md5) {
633 db_put cache => "$id/meta", $meta;
634
635 return db_get cache => "$id/data";
636 }
637 }
638
639 my $t1 = Time::HiRes::time;
640 my $data = $process->(\@data);
641 my $t2 = Time::HiRes::time;
642
643 warn "cache: '$id' processed in ", $t2 - $t1, "s\n";
644
645 db_put cache => "$id/data", $data;
646 db_put cache => "$id/md5" , $md5;
647 db_put cache => "$id/meta", $meta;
648
649 return $data;
650 }
651
652 db_get cache => "$id/data"
653}
654
655=item cf::datalog type => key => value, ...
656
657Log a datalog packet of the given type with the given key-value pairs.
658
659=cut
660
661sub datalog($@) {
662 my ($type, %kv) = @_;
663 warn "DATALOG ", JSON::XS->new->ascii->encode ({ %kv, type => $type });
270} 664}
271 665
272=back 666=back
273 667
274=cut 668=cut
275
276#############################################################################
277
278package cf::path;
279
280sub new {
281 my ($class, $path, $base) = @_;
282
283 my $self = bless { }, $class;
284
285 if ($path =~ s{^\?random/}{}) {
286 $self->{random} = cf::from_json $path;
287 } else {
288 if ($path =~ s{^~([^/]+)?}{}) {
289 $self->{user_rel} = 1;
290
291 if (defined $1) {
292 $self->{user} = $1;
293 } elsif ($base =~ m{^~([^/]+)/}) {
294 $self->{user} = $1;
295 } else {
296 warn "cannot resolve user-relative path without user <$path,$base>\n";
297 }
298 } elsif ($path =~ /^\//) {
299 # already absolute
300 } else {
301 $base =~ s{[^/]+/?$}{};
302 return $class->new ("$base/$path");
303 }
304
305 for ($path) {
306 redo if s{/\.?/}{/};
307 redo if s{/[^/]+/\.\./}{/};
308 }
309 }
310
311 $self->{path} = $path;
312
313 $self
314}
315
316# the name / primary key / in-game path
317sub as_string {
318 my ($self) = @_;
319
320 $self->{user_rel} ? "~$self->{user}$self->{path}"
321 : $self->{random} ? "?random/$self->{path}"
322 : $self->{path}
323}
324
325# the displayed name, this is a one way mapping
326sub visible_name {
327 my ($self) = @_;
328
329 $self->{random} ? "?random/$self->{random}{origin_map}+$self->{random}{origin_x}+$self->{random}{origin_y}/$self->{random}{dungeon_level}"
330 : $self->as_string
331}
332
333# escape the /'s in the path
334sub _escaped_path {
335 # ∕ is U+2215
336 (my $path = $_[0]{path}) =~ s/\//∕/g;
337 $path
338}
339
340# the original (read-only) location
341sub load_path {
342 my ($self) = @_;
343
344 sprintf "%s/%s/%s", cf::datadir, cf::mapdir, $self->{path}
345}
346
347# the temporary/swap location
348sub save_path {
349 my ($self) = @_;
350
351 $self->{user_rel} ? sprintf "%s/%s/%s/%s", cf::localdir, cf::playerdir, $self->{user}, $self->_escaped_path
352 : $self->{random} ? sprintf "%s/%s", $RANDOM_MAPS, Digest::MD5::md5_hex $self->{path}
353 : sprintf "%s/%s/%s", cf::localdir, cf::tmpdir, $self->_escaped_path
354}
355
356# the unique path, might be eq to save_path
357sub uniq_path {
358 my ($self) = @_;
359
360 $self->{user_rel} || $self->{random}
361 ? undef
362 : sprintf "%s/%s/%s", cf::localdir, cf::uniquedir, $self->_escaped_path
363}
364
365# return random map parameters, or undef
366sub random_map_params {
367 my ($self) = @_;
368
369 $self->{random}
370}
371
372# this is somewhat ugly, but style maps do need special treatment
373sub is_style_map {
374 $_[0]{path} =~ m{^/styles/}
375}
376
377package cf;
378 669
379############################################################################# 670#############################################################################
380 671
381=head2 ATTACHABLE OBJECTS 672=head2 ATTACHABLE OBJECTS
382 673
… …
384attach callbacks/event handlers (a collection of which is called an "attachment") 675attach callbacks/event handlers (a collection of which is called an "attachment")
385to it. All such attachable objects support the following methods. 676to it. All such attachable objects support the following methods.
386 677
387In the following description, CLASS can be any of C<global>, C<object> 678In the following description, CLASS can be any of C<global>, C<object>
388C<player>, C<client> or C<map> (i.e. the attachable objects in 679C<player>, C<client> or C<map> (i.e. the attachable objects in
389crossfire+). 680Deliantra).
390 681
391=over 4 682=over 4
392 683
393=item $attachable->attach ($attachment, key => $value...) 684=item $attachable->attach ($attachment, key => $value...)
394 685
… …
508our @CB_TYPE = (); # registry for type (cf-object class) based events 799our @CB_TYPE = (); # registry for type (cf-object class) based events
509our @CB_MAP = (); 800our @CB_MAP = ();
510 801
511my %attachment; 802my %attachment;
512 803
804sub cf::attachable::thawer_merge {
805 # simply override everything except _meta
806 local $_[0]{_meta};
807 %{$_[0]} = %{$_[1]};
808}
809
513sub _attach_cb($$$$) { 810sub _attach_cb($$$$) {
514 my ($registry, $event, $prio, $cb) = @_; 811 my ($registry, $event, $prio, $cb) = @_;
515 812
516 use sort 'stable'; 813 use sort 'stable';
517 814
… …
551 $registry = $CB_TYPE[$object_type] ||= []; 848 $registry = $CB_TYPE[$object_type] ||= [];
552 849
553 } elsif ($type eq "subtype") { 850 } elsif ($type eq "subtype") {
554 defined $object_type or Carp::croak "subtype specified without type"; 851 defined $object_type or Carp::croak "subtype specified without type";
555 my $object_subtype = shift @arg; 852 my $object_subtype = shift @arg;
556 $registry = $CB_TYPE[$object_type + $object_subtype * NUM_SUBTYPES] ||= []; 853 $registry = $CB_TYPE[$object_type + $object_subtype * NUM_TYPES] ||= [];
557 854
558 } elsif ($type eq "package") { 855 } elsif ($type eq "package") {
559 my $pkg = shift @arg; 856 my $pkg = shift @arg;
560 857
561 while (my ($name, $id) = each %cb_id) { 858 while (my ($name, $id) = each %cb_id) {
… …
590 _attach $registry, $klass, @attach; 887 _attach $registry, $klass, @attach;
591 } 888 }
592 889
593 $obj->{$name} = \%arg; 890 $obj->{$name} = \%arg;
594 } else { 891 } else {
595 warn "object uses attachment '$name' that is not available, postponing.\n"; 892 warn "object uses attachment '$name' which is not available, postponing.\n";
596 } 893 }
597 894
598 $obj->{_attachment}{$name} = undef; 895 $obj->{_attachment}{$name} = undef;
599} 896}
600 897
… …
602 if (ref $_[0]) { 899 if (ref $_[0]) {
603 _object_attach @_; 900 _object_attach @_;
604 } else { 901 } else {
605 _attach shift->_attach_registry, @_; 902 _attach shift->_attach_registry, @_;
606 } 903 }
904 _recalc_want;
607}; 905};
608 906
609# all those should be optimised 907# all those should be optimised
610sub cf::attachable::detach { 908sub cf::attachable::detach {
611 my ($obj, $name) = @_; 909 my ($obj, $name) = @_;
… …
614 delete $obj->{_attachment}{$name}; 912 delete $obj->{_attachment}{$name};
615 reattach ($obj); 913 reattach ($obj);
616 } else { 914 } else {
617 Carp::croak "cannot, currently, detach class attachments"; 915 Carp::croak "cannot, currently, detach class attachments";
618 } 916 }
917 _recalc_want;
619}; 918};
620 919
621sub cf::attachable::attached { 920sub cf::attachable::attached {
622 my ($obj, $name) = @_; 921 my ($obj, $name) = @_;
623 922
… …
638 "; 937 ";
639 die if $@; 938 die if $@;
640} 939}
641 940
642our $override; 941our $override;
643our @invoke_results = (); # referenced from .xs code. TODO: play tricks with reify and mortals? 942our @INVOKE_RESULTS = (); # referenced from .xs code. TODO: play tricks with reify and mortals?
644 943
645sub override { 944sub override {
646 $override = 1; 945 $override = 1;
647 @invoke_results = (); 946 @INVOKE_RESULTS = (@_);
648} 947}
649 948
650sub do_invoke { 949sub do_invoke {
651 my $event = shift; 950 my $event = shift;
652 my $callbacks = shift; 951 my $callbacks = shift;
653 952
654 @invoke_results = (); 953 @INVOKE_RESULTS = ();
655 954
656 local $override; 955 local $override;
657 956
658 for (@$callbacks) { 957 for (@$callbacks) {
659 eval { &{$_->[1]} }; 958 eval { &{$_->[1]} };
… …
676 975
677Generate an object-specific event with the given arguments. 976Generate an object-specific event with the given arguments.
678 977
679This API is preliminary (most likely, the EVENT_CLASS_xxx prefix will be 978This API is preliminary (most likely, the EVENT_CLASS_xxx prefix will be
680removed in future versions), and there is no public API to access override 979removed in future versions), and there is no public API to access override
681results (if you must, access C<@cf::invoke_results> directly). 980results (if you must, access C<@cf::INVOKE_RESULTS> directly).
682 981
683=back 982=back
684 983
685=cut 984=cut
686 985
687############################################################################# 986#############################################################################
688# object support 987# object support
988
989sub _object_equal($$);
990sub _object_equal($$) {
991 my ($a, $b) = @_;
992
993 return 0 unless (ref $a) eq (ref $b);
994
995 if ("HASH" eq ref $a) {
996 my @ka = keys %$a;
997 my @kb = keys %$b;
998
999 return 0 if @ka != @kb;
1000
1001 for (0 .. $#ka) {
1002 return 0 unless $ka[$_] eq $kb[$_];
1003 return 0 unless _object_equal $a->{$ka[$_]}, $b->{$kb[$_]};
1004 }
1005
1006 } elsif ("ARRAY" eq ref $a) {
1007
1008 return 0 if @$a != @$b;
1009
1010 for (0 .. $#$a) {
1011 return 0 unless _object_equal $a->[$_], $b->[$_];
1012 }
1013
1014 } elsif ($a ne $b) {
1015 return 0;
1016 }
1017
1018 1
1019}
1020
1021our $SLOW_MERGES;#d#
1022sub _can_merge {
1023 my ($ob1, $ob2) = @_;
1024
1025 ++$SLOW_MERGES;#d#
1026
1027 # we do the slow way here
1028 return _object_equal $ob1, $ob2
1029}
689 1030
690sub reattach { 1031sub reattach {
691 # basically do the same as instantiate, without calling instantiate 1032 # basically do the same as instantiate, without calling instantiate
692 my ($obj) = @_; 1033 my ($obj) = @_;
1034
1035 bless $obj, ref $obj; # re-bless in case extensions have been reloaded
693 1036
694 my $registry = $obj->registry; 1037 my $registry = $obj->registry;
695 1038
696 @$registry = (); 1039 @$registry = ();
697 1040
… …
712cf::attachable->attach ( 1055cf::attachable->attach (
713 prio => -1000000, 1056 prio => -1000000,
714 on_instantiate => sub { 1057 on_instantiate => sub {
715 my ($obj, $data) = @_; 1058 my ($obj, $data) = @_;
716 1059
717 $data = from_json $data; 1060 $data = decode_json $data;
718 1061
719 for (@$data) { 1062 for (@$data) {
720 my ($name, $args) = @$_; 1063 my ($name, $args) = @$_;
721 1064
722 $obj->attach ($name, %{$args || {} }); 1065 $obj->attach ($name, %{$args || {} });
… …
738sub object_freezer_save { 1081sub object_freezer_save {
739 my ($filename, $rdata, $objs) = @_; 1082 my ($filename, $rdata, $objs) = @_;
740 1083
741 sync_job { 1084 sync_job {
742 if (length $$rdata) { 1085 if (length $$rdata) {
1086 utf8::decode (my $decname = $filename);
743 warn sprintf "saving %s (%d,%d)\n", 1087 warn sprintf "saving %s (%d,%d)\n",
744 $filename, length $$rdata, scalar @$objs; 1088 $decname, length $$rdata, scalar @$objs;
745 1089
746 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) { 1090 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
747 chmod SAVE_MODE, $fh; 1091 chmod SAVE_MODE, $fh;
748 aio_write $fh, 0, (length $$rdata), $$rdata, 0; 1092 aio_write $fh, 0, (length $$rdata), $$rdata, 0;
749 aio_fsync $fh; 1093 aio_fsync $fh if $cf::USE_FSYNC;
750 close $fh; 1094 close $fh;
751 1095
752 if (@$objs) { 1096 if (@$objs) {
753 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) { 1097 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) {
754 chmod SAVE_MODE, $fh; 1098 chmod SAVE_MODE, $fh;
755 my $data = Storable::nfreeze { version => 1, objs => $objs }; 1099 my $data = Coro::Storable::nfreeze { version => 1, objs => $objs };
756 aio_write $fh, 0, (length $data), $data, 0; 1100 aio_write $fh, 0, (length $data), $data, 0;
757 aio_fsync $fh; 1101 aio_fsync $fh if $cf::USE_FSYNC;
758 close $fh; 1102 close $fh;
759 aio_rename "$filename.pst~", "$filename.pst"; 1103 aio_rename "$filename.pst~", "$filename.pst";
760 } 1104 }
761 } else { 1105 } else {
762 aio_unlink "$filename.pst"; 1106 aio_unlink "$filename.pst";
… …
768 } 1112 }
769 } else { 1113 } else {
770 aio_unlink $filename; 1114 aio_unlink $filename;
771 aio_unlink "$filename.pst"; 1115 aio_unlink "$filename.pst";
772 } 1116 }
773 } 1117 };
774} 1118}
775 1119
776sub object_freezer_as_string { 1120sub object_freezer_as_string {
777 my ($rdata, $objs) = @_; 1121 my ($rdata, $objs) = @_;
778 1122
… …
790 or return; 1134 or return;
791 1135
792 unless (aio_stat "$filename.pst") { 1136 unless (aio_stat "$filename.pst") {
793 (aio_load "$filename.pst", $av) >= 0 1137 (aio_load "$filename.pst", $av) >= 0
794 or return; 1138 or return;
1139
795 $av = eval { (Storable::thaw <$av>)->{objs} }; 1140 my $st = eval { Coro::Storable::thaw $av };
1141 $av = $st->{objs};
796 } 1142 }
797 1143
1144 utf8::decode (my $decname = $filename);
1145 warn sprintf "loading %s (%d,%d)\n",
1146 $decname, length $data, scalar @{$av || []};
1147
798 return ($data, $av); 1148 ($data, $av)
799} 1149}
1150
1151=head2 COMMAND CALLBACKS
1152
1153=over 4
1154
1155=cut
800 1156
801############################################################################# 1157#############################################################################
802# command handling &c 1158# command handling &c
803 1159
804=item cf::register_command $name => \&callback($ob,$args); 1160=item cf::register_command $name => \&callback($ob,$args);
… …
817 push @{ $COMMAND{$name} }, [$caller, $cb]; 1173 push @{ $COMMAND{$name} }, [$caller, $cb];
818} 1174}
819 1175
820=item cf::register_extcmd $name => \&callback($pl,$packet); 1176=item cf::register_extcmd $name => \&callback($pl,$packet);
821 1177
822Register a callbackf ro execution when the client sends an extcmd packet. 1178Register a callback for execution when the client sends an (synchronous)
1179extcmd packet. Ext commands will be processed in the order they are
1180received by the server, like other user commands. The first argument is
1181the logged-in player. Ext commands can only be processed after a player
1182has logged in successfully.
823 1183
824If the callback returns something, it is sent back as if reply was being 1184If the callback returns something, it is sent back as if reply was being
825called. 1185called.
826 1186
1187=item cf::register_exticmd $name => \&callback($ns,$packet);
1188
1189Register a callback for execution when the client sends an (asynchronous)
1190exticmd packet. Exti commands are processed by the server as soon as they
1191are received, i.e. out of order w.r.t. other commands. The first argument
1192is a client socket. Exti commands can be received anytime, even before
1193log-in.
1194
1195If the callback returns something, it is sent back as if reply was being
1196called.
1197
827=cut 1198=cut
828 1199
829sub register_extcmd { 1200sub register_extcmd {
830 my ($name, $cb) = @_; 1201 my ($name, $cb) = @_;
831 1202
832 my $caller = caller;
833 #warn "registering extcmd '$name' to '$caller'";
834
835 $EXTCMD{$name} = [$cb, $caller]; 1203 $EXTCMD{$name} = $cb;
1204}
1205
1206sub register_exticmd {
1207 my ($name, $cb) = @_;
1208
1209 $EXTICMD{$name} = $cb;
836} 1210}
837 1211
838cf::player->attach ( 1212cf::player->attach (
839 on_command => sub { 1213 on_command => sub {
840 my ($pl, $name, $params) = @_; 1214 my ($pl, $name, $params) = @_;
… …
849 cf::override; 1223 cf::override;
850 }, 1224 },
851 on_extcmd => sub { 1225 on_extcmd => sub {
852 my ($pl, $buf) = @_; 1226 my ($pl, $buf) = @_;
853 1227
854 my $msg = eval { from_json $buf }; 1228 my $msg = eval { $pl->ns->{json_coder}->decode ($buf) };
855 1229
856 if (ref $msg) { 1230 if (ref $msg) {
1231 my ($type, $reply, @payload) =
1232 "ARRAY" eq ref $msg
1233 ? @$msg
1234 : ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
1235
1236 my @reply;
1237
857 if (my $cb = $EXTCMD{$msg->{msgtype}}) { 1238 if (my $cb = $EXTCMD{$type}) {
858 if (my %reply = $cb->[0]->($pl, $msg)) { 1239 @reply = $cb->($pl, @payload);
859 $pl->ext_reply ($msg->{msgid}, %reply);
860 }
861 } 1240 }
1241
1242 $pl->ext_reply ($reply, @reply)
1243 if $reply;
1244
862 } else { 1245 } else {
863 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n"; 1246 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
864 } 1247 }
865 1248
866 cf::override; 1249 cf::override;
867 }, 1250 },
868); 1251);
869 1252
1253sub load_extensions {
1254 cf::sync_job {
1255 my %todo;
1256
1257 for my $path (<$LIBDIR/*.ext>) {
1258 next unless -r $path;
1259
1260 $path =~ /([^\/\\]+)\.ext$/ or die "$path";
1261 my $base = $1;
1262 my $pkg = $1;
1263 $pkg =~ s/[^[:word:]]/_/g;
1264 $pkg = "ext::$pkg";
1265
1266 open my $fh, "<:utf8", $path
1267 or die "$path: $!";
1268
1269 my $source = do { local $/; <$fh> };
1270
1271 my %ext = (
1272 path => $path,
1273 base => $base,
1274 pkg => $pkg,
1275 );
1276
1277 $ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 }
1278 if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m;
1279
1280 $ext{source} =
1281 "package $pkg; use strict; use utf8;\n"
1282 . "#line 1 \"$path\"\n{\n"
1283 . $source
1284 . "\n};\n1";
1285
1286 $todo{$base} = \%ext;
1287 }
1288
1289 my %done;
1290 while (%todo) {
1291 my $progress;
1292
1293 while (my ($k, $v) = each %todo) {
1294 for (split /,\s*/, $v->{meta}{depends}) {
1295 goto skip
1296 unless exists $done{$_};
1297 }
1298
1299 warn "... loading '$k' into '$v->{pkg}'\n";
1300
1301 unless (eval $v->{source}) {
1302 my $msg = $@ ? "$v->{path}: $@\n"
1303 : "$v->{base}: extension inactive.\n";
1304
1305 if (exists $v->{meta}{mandatory}) {
1306 warn $msg;
1307 warn "mandatory extension failed to load, exiting.\n";
1308 exit 1;
1309 }
1310
1311 warn $msg;
1312 }
1313
1314 $done{$k} = delete $todo{$k};
1315 push @EXTS, $v->{pkg};
1316 $progress = 1;
1317 }
1318
1319 skip:
1320 die "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n"
1321 unless $progress;
1322 }
1323 };
1324}
1325
1326#############################################################################
1327
1328=back
1329
1330=head2 CORE EXTENSIONS
1331
1332Functions and methods that extend core crossfire objects.
1333
1334=cut
1335
1336package cf::player;
1337
1338use Coro::AIO;
1339
1340=head3 cf::player
1341
1342=over 4
1343
1344=item cf::player::num_playing
1345
1346Returns the official number of playing players, as per the Crossfire metaserver rules.
1347
1348=cut
1349
1350sub num_playing {
1351 scalar grep
1352 $_->ob->map
1353 && !$_->hidden
1354 && !$_->ob->flag (cf::FLAG_WIZ),
1355 cf::player::list
1356}
1357
1358=item cf::player::find $login
1359
1360Returns the given player object, loading it if necessary (might block).
1361
1362=cut
1363
1364sub playerdir($) {
1365 "$PLAYERDIR/"
1366 . (ref $_[0] ? $_[0]->ob->name : $_[0])
1367}
1368
1369sub path($) {
1370 my $login = ref $_[0] ? $_[0]->ob->name : $_[0];
1371
1372 (playerdir $login) . "/playerdata"
1373}
1374
1375sub find_active($) {
1376 $cf::PLAYER{$_[0]}
1377 and $cf::PLAYER{$_[0]}->active
1378 and $cf::PLAYER{$_[0]}
1379}
1380
1381sub exists($) {
1382 my ($login) = @_;
1383
1384 $cf::PLAYER{$login}
1385 or cf::sync_job { !aio_stat path $login }
1386}
1387
1388sub find($) {
1389 return $cf::PLAYER{$_[0]} || do {
1390 my $login = $_[0];
1391
1392 my $guard = cf::lock_acquire "user_find:$login";
1393
1394 $cf::PLAYER{$_[0]} || do {
1395 # rename old playerfiles to new ones
1396 #TODO: remove when no longer required
1397 aio_link +(playerdir $login) . "/$login.pl.pst", (playerdir $login) . "/playerdata.pst";
1398 aio_link +(playerdir $login) . "/$login.pl" , (playerdir $login) . "/playerdata";
1399 aio_unlink +(playerdir $login) . "/$login.pl.pst";
1400 aio_unlink +(playerdir $login) . "/$login.pl";
1401
1402 my $f = new_from_file cf::object::thawer path $login
1403 or return;
1404
1405 my $pl = cf::player::load_pl $f
1406 or return;
1407 local $cf::PLAYER_LOADING{$login} = $pl;
1408 $f->resolve_delayed_derefs;
1409 $cf::PLAYER{$login} = $pl
1410 }
1411 }
1412}
1413
1414sub save($) {
1415 my ($pl) = @_;
1416
1417 return if $pl->{deny_save};
1418
1419 my $path = path $pl;
1420 my $guard = cf::lock_acquire "user_save:$path";
1421
1422 return if $pl->{deny_save};
1423
1424 aio_mkdir playerdir $pl, 0770;
1425 $pl->{last_save} = $cf::RUNTIME;
1426
1427 $pl->save_pl ($path);
1428 cf::cede_to_tick;
1429}
1430
1431sub new($) {
1432 my ($login) = @_;
1433
1434 my $self = create;
1435
1436 $self->ob->name ($login);
1437 $self->{deny_save} = 1;
1438
1439 $cf::PLAYER{$login} = $self;
1440
1441 $self
1442}
1443
1444=item $player->send_msg ($channel, $msg, $color, [extra...])
1445
1446=cut
1447
1448sub send_msg {
1449 my $ns = shift->ns
1450 or return;
1451 $ns->send_msg (@_);
1452}
1453
1454=item $pl->quit_character
1455
1456Nukes the player without looking back. If logged in, the connection will
1457be destroyed. May block for a long time.
1458
1459=cut
1460
1461sub quit_character {
1462 my ($pl) = @_;
1463
1464 my $name = $pl->ob->name;
1465
1466 $pl->{deny_save} = 1;
1467 $pl->password ("*"); # this should lock out the player until we nuked the dir
1468
1469 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active;
1470 $pl->deactivate;
1471 $pl->invoke (cf::EVENT_PLAYER_QUIT);
1472 $pl->ns->destroy if $pl->ns;
1473
1474 my $path = playerdir $pl;
1475 my $temp = "$path~$cf::RUNTIME~deleting~";
1476 aio_rename $path, $temp;
1477 delete $cf::PLAYER{$pl->ob->name};
1478 $pl->destroy;
1479
1480 my $prefix = qr<^~\Q$name\E/>;
1481
1482 # nuke player maps
1483 $cf::MAP{$_}->nuke for grep /$prefix/, keys %cf::MAP;
1484
1485 IO::AIO::aio_rmtree $temp;
1486}
1487
1488=item $pl->kick
1489
1490Kicks a player out of the game. This destroys the connection.
1491
1492=cut
1493
1494sub kick {
1495 my ($pl, $kicker) = @_;
1496
1497 $pl->invoke (cf::EVENT_PLAYER_KICK, $kicker);
1498 $pl->killer ("kicked");
1499 $pl->ns->destroy;
1500}
1501
1502=item cf::player::list_logins
1503
1504Returns am arrayref of all valid playernames in the system, can take a
1505while and may block, so not sync_job-capable, ever.
1506
1507=cut
1508
1509sub list_logins {
1510 my $dirs = aio_readdir $PLAYERDIR
1511 or return [];
1512
1513 my @logins;
1514
1515 for my $login (@$dirs) {
1516 my $path = path $login;
1517
1518 # a .pst is a dead give-away for a valid player
1519 unless (-e "$path.pst") {
1520 my $fh = aio_open $path, Fcntl::O_RDONLY, 0 or next;
1521 aio_read $fh, 0, 512, my $buf, 0 or next;
1522 $buf !~ /^password -------------$/m or next; # official not-valid tag
1523 }
1524
1525 utf8::decode $login;
1526 push @logins, $login;
1527 }
1528
1529 \@logins
1530}
1531
1532=item $player->maps
1533
1534Returns an arrayref of map paths that are private for this
1535player. May block.
1536
1537=cut
1538
1539sub maps($) {
1540 my ($pl) = @_;
1541
1542 $pl = ref $pl ? $pl->ob->name : $pl;
1543
1544 my $files = aio_readdir playerdir $pl
1545 or return;
1546
1547 my @paths;
1548
1549 for (@$files) {
1550 utf8::decode $_;
1551 next if /\.(?:pl|pst)$/;
1552 next unless /^$PATH_SEP/o;
1553
1554 push @paths, cf::map::normalise "~$pl/$_";
1555 }
1556
1557 \@paths
1558}
1559
1560=item $protocol_xml = $player->expand_cfpod ($crossfire_pod)
1561
1562Expand crossfire pod fragments into protocol xml.
1563
1564=cut
1565
1566use re 'eval';
1567
1568my $group;
1569my $interior; $interior = qr{
1570 # match a pod interior sequence sans C<< >>
1571 (?:
1572 \ (.*?)\ (?{ $group = $^N })
1573 | < (??{$interior}) >
1574 )
1575}x;
1576
1577sub expand_cfpod {
1578 my ($self, $pod) = @_;
1579
1580 my $xml;
1581
1582 while () {
1583 if ($pod =~ /\G( (?: [^BCGHITU]+ | .(?!<) )+ )/xgcs) {
1584 $group = $1;
1585
1586 $group =~ s/&/&amp;/g;
1587 $group =~ s/</&lt;/g;
1588
1589 $xml .= $group;
1590 } elsif ($pod =~ m%\G
1591 ([BCGHITU])
1592 <
1593 (?:
1594 ([^<>]*) (?{ $group = $^N })
1595 | < $interior >
1596 )
1597 >
1598 %gcsx
1599 ) {
1600 my ($code, $data) = ($1, $group);
1601
1602 if ($code eq "B") {
1603 $xml .= "<b>" . expand_cfpod ($self, $data) . "</b>";
1604 } elsif ($code eq "I") {
1605 $xml .= "<i>" . expand_cfpod ($self, $data) . "</i>";
1606 } elsif ($code eq "U") {
1607 $xml .= "<u>" . expand_cfpod ($self, $data) . "</u>";
1608 } elsif ($code eq "C") {
1609 $xml .= "<tt>" . expand_cfpod ($self, $data) . "</tt>";
1610 } elsif ($code eq "T") {
1611 $xml .= "<big><b>" . expand_cfpod ($self, $data) . "</b></big>";
1612 } elsif ($code eq "G") {
1613 my ($male, $female) = split /\|/, $data;
1614 $data = $self->gender ? $female : $male;
1615 $xml .= expand_cfpod ($self, $data);
1616 } elsif ($code eq "H") {
1617 $xml .= ("<fg name=\"lightblue\">[" . expand_cfpod ($self, $data) . " (Use hintmode to suppress hints)]</fg>",
1618 "<fg name=\"lightblue\">[Hint suppressed, see hintmode]</fg>",
1619 "")
1620 [$self->{hintmode}];
1621 } else {
1622 $xml .= "error processing '$code($data)' directive";
1623 }
1624 } else {
1625 if ($pod =~ /\G(.+)/) {
1626 warn "parse error while expanding $pod (at $1)";
1627 }
1628 last;
1629 }
1630 }
1631
1632 for ($xml) {
1633 # create single paragraphs (very hackish)
1634 s/(?<=\S)\n(?=\w)/ /g;
1635
1636 # compress some whitespace
1637 s/\s+\n/\n/g; # ws line-ends
1638 s/\n\n+/\n/g; # double lines
1639 s/^\n+//; # beginning lines
1640 s/\n+$//; # ending lines
1641 }
1642
1643 $xml
1644}
1645
1646no re 'eval';
1647
1648sub hintmode {
1649 $_[0]{hintmode} = $_[1] if @_ > 1;
1650 $_[0]{hintmode}
1651}
1652
1653=item $player->ext_reply ($msgid, @msg)
1654
1655Sends an ext reply to the player.
1656
1657=cut
1658
1659sub ext_reply($$@) {
1660 my ($self, $id, @msg) = @_;
1661
1662 $self->ns->ext_reply ($id, @msg)
1663}
1664
1665=item $player->ext_msg ($type, @msg)
1666
1667Sends an ext event to the client.
1668
1669=cut
1670
1671sub ext_msg($$@) {
1672 my ($self, $type, @msg) = @_;
1673
1674 $self->ns->ext_msg ($type, @msg);
1675}
1676
1677=head3 cf::region
1678
1679=over 4
1680
1681=cut
1682
1683package cf::region;
1684
1685=item cf::region::find_by_path $path
1686
1687Tries to decuce the likely region for a map knowing only its path.
1688
1689=cut
1690
1691sub find_by_path($) {
1692 my ($path) = @_;
1693
1694 my ($match, $specificity);
1695
1696 for my $region (list) {
1697 if ($region->{match} && $path =~ $region->{match}) {
1698 ($match, $specificity) = ($region, $region->specificity)
1699 if $region->specificity > $specificity;
1700 }
1701 }
1702
1703 $match
1704}
1705
1706=back
1707
1708=head3 cf::map
1709
1710=over 4
1711
1712=cut
1713
1714package cf::map;
1715
1716use Fcntl;
1717use Coro::AIO;
1718
1719use overload
1720 '""' => \&as_string,
1721 fallback => 1;
1722
1723our $MAX_RESET = 3600;
1724our $DEFAULT_RESET = 3000;
1725
1726sub generate_random_map {
1727 my ($self, $rmp) = @_;
1728 # mit "rum" bekleckern, nicht
1729 $self->_create_random_map (
1730 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle},
1731 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle},
1732 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map},
1733 $rmp->{exit_on_final_map},
1734 $rmp->{xsize}, $rmp->{ysize},
1735 $rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3},
1736 $rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase},
1737 $rmp->{dungeon_level}, $rmp->{dungeon_depth}, $rmp->{decoroptions}, $rmp->{orientation},
1738 $rmp->{origin_y}, $rmp->{origin_x}, $rmp->{random_seed}, $rmp->{total_map_hp},
1739 $rmp->{map_layout_style}, $rmp->{treasureoptions}, $rmp->{symmetry_used},
1740 (cf::region::find $rmp->{region}), $rmp->{custom}
1741 )
1742}
1743
1744=item cf::map->register ($regex, $prio)
1745
1746Register a handler for the map path matching the given regex at the
1747givne priority (higher is better, built-in handlers have priority 0, the
1748default).
1749
1750=cut
1751
870sub register { 1752sub register {
1753 my (undef, $regex, $prio) = @_;
1754 my $pkg = caller;
1755
1756 no strict;
1757 push @{"$pkg\::ISA"}, __PACKAGE__;
1758
1759 $EXT_MAP{$pkg} = [$prio, qr<$regex>];
1760}
1761
1762# also paths starting with '/'
1763$EXT_MAP{"cf::map"} = [0, qr{^(?=/)}];
1764
1765sub thawer_merge {
871 my ($base, $pkg) = @_; 1766 my ($self, $merge) = @_;
872 1767
873 #TODO 1768 # we have to keep some variables in memory intact
874} 1769 local $self->{path};
1770 local $self->{load_path};
875 1771
876sub load_extension { 1772 $self->SUPER::thawer_merge ($merge);
1773}
1774
1775sub normalise {
877 my ($path) = @_; 1776 my ($path, $base) = @_;
878 1777
879 $path =~ /([^\/\\]+)\.ext$/ or die "$path"; 1778 $path = "$path"; # make sure its a string
880 my $base = $1;
881 my $pkg = $1;
882 $pkg =~ s/[^[:word:]]/_/g;
883 $pkg = "ext::$pkg";
884 1779
885 warn "loading '$path' into '$pkg'\n"; 1780 $path =~ s/\.map$//;
886 1781
887 open my $fh, "<:utf8", $path 1782 # map plan:
888 or die "$path: $!"; 1783 #
1784 # /! non-realised random map exit (special hack!)
1785 # {... are special paths that are not being touched
1786 # ?xxx/... are special absolute paths
1787 # ?random/... random maps
1788 # /... normal maps
1789 # ~user/... per-player map of a specific user
889 1790
890 my $source = 1791 $path =~ s/$PATH_SEP/\//go;
891 "package $pkg; use strict; use utf8;\n"
892 . "#line 1 \"$path\"\n{\n"
893 . (do { local $/; <$fh> })
894 . "\n};\n1";
895 1792
896 eval $source 1793 # treat it as relative path if it starts with
897 or die $@ ? "$path: $@\n" 1794 # something that looks reasonable
898 : "extension disabled.\n"; 1795 if ($path =~ m{^(?:\./|\.\./|\w)}) {
1796 $base or Carp::carp "normalise called with relative path and no base: '$path'";
899 1797
900 push @exts, $pkg; 1798 $base =~ s{[^/]+/?$}{};
901 $ext_pkg{$base} = $pkg; 1799 $path = "$base/$path";
902
903# no strict 'refs';
904# @{"$pkg\::ISA"} = ext::;
905
906 register $base, $pkg;
907}
908
909sub unload_extension {
910 my ($pkg) = @_;
911
912 warn "removing extension $pkg\n";
913
914 # remove hooks
915 #TODO
916# for my $idx (0 .. $#PLUGIN_EVENT) {
917# delete $hook[$idx]{$pkg};
918# } 1800 }
919 1801
920 # remove commands 1802 for ($path) {
921 for my $name (keys %COMMAND) { 1803 redo if s{//}{/};
922 my @cb = grep $_->[0] ne $pkg, @{ $COMMAND{$name} }; 1804 redo if s{/\.?/}{/};
1805 redo if s{/[^/]+/\.\./}{/};
1806 }
923 1807
924 if (@cb) { 1808 $path
925 $COMMAND{$name} = \@cb; 1809}
1810
1811sub new_from_path {
1812 my (undef, $path, $base) = @_;
1813
1814 return $path if UNIVERSAL::isa $path, "cf::map"; # already a map object
1815
1816 $path = normalise $path, $base;
1817
1818 for my $pkg (sort { $EXT_MAP{$b}[0] <=> $EXT_MAP{$a}[0] } keys %EXT_MAP) {
1819 if ($path =~ $EXT_MAP{$pkg}[1]) {
1820 my $self = bless cf::map::new, $pkg;
1821 $self->{path} = $path; $self->path ($path);
1822 $self->init; # pass $1 etc.
1823 return $self;
1824 }
1825 }
1826
1827 Carp::cluck "unable to resolve path '$path' (base '$base').";
1828 ()
1829}
1830
1831sub init {
1832 my ($self) = @_;
1833
1834 $self
1835}
1836
1837sub as_string {
1838 my ($self) = @_;
1839
1840 "$self->{path}"
1841}
1842
1843# the displayed name, this is a one way mapping
1844sub visible_name {
1845 &as_string
1846}
1847
1848# the original (read-only) location
1849sub load_path {
1850 my ($self) = @_;
1851
1852 "$MAPDIR/$self->{path}.map"
1853}
1854
1855# the temporary/swap location
1856sub save_path {
1857 my ($self) = @_;
1858
1859 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g;
1860 "$TMPDIR/$path.map"
1861}
1862
1863# the unique path, undef == no special unique path
1864sub uniq_path {
1865 my ($self) = @_;
1866
1867 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g;
1868 "$UNIQUEDIR/$path"
1869}
1870
1871# and all this just because we cannot iterate over
1872# all maps in C++...
1873sub change_all_map_light {
1874 my ($change) = @_;
1875
1876 $_->change_map_light ($change)
1877 for grep $_->outdoor, values %cf::MAP;
1878}
1879
1880sub decay_objects {
1881 my ($self) = @_;
1882
1883 return if $self->{deny_reset};
1884
1885 $self->do_decay_objects;
1886}
1887
1888sub unlink_save {
1889 my ($self) = @_;
1890
1891 utf8::encode (my $save = $self->save_path);
1892 IO::AIO::aioreq_pri 4; Coro::AIO::aio_unlink $save;
1893 IO::AIO::aioreq_pri 4; Coro::AIO::aio_unlink "$save.pst";
1894}
1895
1896sub load_header_from($) {
1897 my ($self, $path) = @_;
1898
1899 utf8::encode $path;
1900 my $f = new_from_file cf::object::thawer $path
1901 or return;
1902
1903 $self->_load_header ($f)
1904 or return;
1905
1906 local $MAP_LOADING{$self->{path}} = $self;
1907 $f->resolve_delayed_derefs;
1908
1909 $self->{load_path} = $path;
1910
1911 1
1912}
1913
1914sub load_header_orig {
1915 my ($self) = @_;
1916
1917 $self->load_header_from ($self->load_path)
1918}
1919
1920sub load_header_temp {
1921 my ($self) = @_;
1922
1923 $self->load_header_from ($self->save_path)
1924}
1925
1926sub prepare_temp {
1927 my ($self) = @_;
1928
1929 $self->last_access ((delete $self->{last_access})
1930 || $cf::RUNTIME); #d#
1931 # safety
1932 $self->{instantiate_time} = $cf::RUNTIME
1933 if $self->{instantiate_time} > $cf::RUNTIME;
1934}
1935
1936sub prepare_orig {
1937 my ($self) = @_;
1938
1939 $self->{load_original} = 1;
1940 $self->{instantiate_time} = $cf::RUNTIME;
1941 $self->last_access ($cf::RUNTIME);
1942 $self->instantiate;
1943}
1944
1945sub load_header {
1946 my ($self) = @_;
1947
1948 if ($self->load_header_temp) {
1949 $self->prepare_temp;
926 } else { 1950 } else {
927 delete $COMMAND{$name}; 1951 $self->load_header_orig
928 } 1952 or return;
1953 $self->prepare_orig;
1954 }
1955
1956 $self->{deny_reset} = 1
1957 if $self->no_reset;
1958
1959 $self->default_region (cf::region::find_by_path $self->{path})
1960 unless $self->default_region;
1961
929 } 1962 1
1963}
930 1964
931 # remove extcmds 1965sub find;
932 for my $name (grep $EXTCMD{$_}[1] eq $pkg, keys %EXTCMD) { 1966sub find {
933 delete $EXTCMD{$name}; 1967 my ($path, $origin) = @_;
1968
1969 $path = normalise $path, $origin && $origin->path;
1970
1971 cf::lock_wait "map_data:$path";#d#remove
1972 cf::lock_wait "map_find:$path";
1973
1974 $cf::MAP{$path} || do {
1975 my $guard1 = cf::lock_acquire "map_find:$path";
1976 my $guard2 = cf::lock_acquire "map_data:$path"; # just for the fun of it
1977
1978 my $map = new_from_path cf::map $path
1979 or return;
1980
1981 $map->{last_save} = $cf::RUNTIME;
1982
1983 $map->load_header
1984 or return;
1985
1986 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?)
1987 # doing this can freeze the server in a sync job, obviously
1988 #$cf::WAIT_FOR_TICK->wait;
1989 undef $guard1;
1990 undef $guard2;
1991 $map->reset;
1992 return find $path;
1993 }
1994
1995 $cf::MAP{$path} = $map
1996 }
1997}
1998
1999sub pre_load { }
2000sub post_load { }
2001
2002sub load {
2003 my ($self) = @_;
2004
2005 local $self->{deny_reset} = 1; # loading can take a long time
2006
2007 my $path = $self->{path};
2008
934 } 2009 {
2010 my $guard = cf::lock_acquire "map_data:$path";
935 2011
936 if (my $cb = $pkg->can ("unload")) { 2012 return unless $self->valid;
937 eval { 2013 return unless $self->in_memory == cf::MAP_SWAPPED;
938 $cb->($pkg); 2014
2015 $self->in_memory (cf::MAP_LOADING);
2016
2017 $self->alloc;
2018
2019 $self->pre_load;
2020 cf::cede_to_tick;
2021
2022 my $f = new_from_file cf::object::thawer $self->{load_path};
2023 $f->skip_block;
2024 $self->_load_objects ($f)
2025 or return;
2026
2027 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1)
2028 if delete $self->{load_original};
2029
2030 if (my $uniq = $self->uniq_path) {
2031 utf8::encode $uniq;
2032 unless (aio_stat $uniq) {
2033 if (my $f = new_from_file cf::object::thawer $uniq) {
2034 $self->clear_unique_items;
2035 $self->_load_objects ($f);
2036 $f->resolve_delayed_derefs;
2037 }
939 1 2038 }
940 } or warn "$pkg unloaded, but with errors: $@"; 2039 }
941 }
942 2040
943 Symbol::delete_package $pkg; 2041 $f->resolve_delayed_derefs;
944}
945 2042
946sub load_extensions { 2043 cf::cede_to_tick;
947 for my $ext (<$LIBDIR/*.ext>) { 2044 # now do the right thing for maps
948 next unless -r $ext; 2045 $self->link_multipart_objects;
949 eval { 2046 $self->difficulty ($self->estimate_difficulty)
950 load_extension $ext; 2047 unless $self->difficulty;
951 1 2048 cf::cede_to_tick;
952 } or warn "$ext not loaded: $@";
953 }
954}
955 2049
956############################################################################# 2050 unless ($self->{deny_activate}) {
957# load/save/clean perl data associated with a map 2051 $self->decay_objects;
2052 $self->fix_auto_apply;
2053 $self->update_buttons;
2054 cf::cede_to_tick;
2055 $self->set_darkness_map;
2056 cf::cede_to_tick;
2057 $self->activate;
2058 }
958 2059
959*cf::mapsupport::on_clean = sub { 2060 $self->{last_save} = $cf::RUNTIME;
2061 $self->last_access ($cf::RUNTIME);
2062
2063 $self->in_memory (cf::MAP_IN_MEMORY);
2064 }
2065
2066 $self->post_load;
2067}
2068
2069sub customise_for {
2070 my ($self, $ob) = @_;
2071
2072 return find "~" . $ob->name . "/" . $self->{path}
2073 if $self->per_player;
2074
2075# return find "?party/" . $ob->name . "/" . $self->{path}
2076# if $self->per_party;
2077
2078 $self
2079}
2080
2081# find and load all maps in the 3x3 area around a map
2082sub load_neighbours {
960 my ($map) = @_; 2083 my ($map) = @_;
961 2084
962 my $path = $map->tmpname; 2085 my @neigh; # diagonal neighbours
963 defined $path or return;
964 2086
965 unlink "$path.pst"; 2087 for (0 .. 3) {
966}; 2088 my $neigh = $map->tile_path ($_)
2089 or next;
2090 $neigh = find $neigh, $map
2091 or next;
2092 $neigh->load;
967 2093
968cf::map->attach (prio => -10000, package => cf::mapsupport::); 2094 push @neigh,
2095 [$neigh->tile_path (($_ + 3) % 4), $neigh],
2096 [$neigh->tile_path (($_ + 1) % 4), $neigh];
2097 }
969 2098
970############################################################################# 2099 for (grep defined $_->[0], @neigh) {
971# load/save perl data associated with player->ob objects 2100 my ($path, $origin) = @$_;
972 2101 my $neigh = find $path, $origin
973sub all_objects(@) { 2102 or next;
974 @_, map all_objects ($_->inv), @_ 2103 $neigh->load;
2104 }
975} 2105}
976 2106
977# TODO: compatibility cruft, remove when no longer needed 2107sub find_sync {
978cf::player->attach ( 2108 my ($path, $origin) = @_;
979 on_load => sub {
980 my ($pl, $path) = @_;
981 2109
982 for my $o (all_objects $pl->ob) { 2110 cf::sync_job { find $path, $origin }
983 if (my $value = $o->get_ob_key_value ("_perl_data")) { 2111}
984 $o->set_ob_key_value ("_perl_data");
985 2112
986 %$o = %{ Storable::thaw pack "H*", $value }; 2113sub do_load_sync {
2114 my ($map) = @_;
2115
2116 cf::LOG cf::llevDebug | cf::logBacktrace, "do_load_sync"
2117 if $Coro::current == $Coro::main;
2118
2119 cf::sync_job { $map->load };
2120}
2121
2122our %MAP_PREFETCH;
2123our $MAP_PREFETCHER = undef;
2124
2125sub find_async {
2126 my ($path, $origin, $load) = @_;
2127
2128 $path = normalise $path, $origin && $origin->{path};
2129
2130 if (my $map = $cf::MAP{$path}) {
2131 return $map if !$load || $map->in_memory == cf::MAP_IN_MEMORY;
2132 }
2133
2134 $MAP_PREFETCH{$path} |= $load;
2135
2136 $MAP_PREFETCHER ||= cf::async {
2137 $Coro::current->{desc} = "map prefetcher";
2138
2139 while (%MAP_PREFETCH) {
2140 while (my ($k, $v) = each %MAP_PREFETCH) {
2141 if (my $map = find $k) {
2142 $map->load if $v;
2143 }
2144
2145 delete $MAP_PREFETCH{$k};
987 } 2146 }
988 } 2147 }
2148 undef $MAP_PREFETCHER;
2149 };
2150 $MAP_PREFETCHER->prio (6);
2151
2152 ()
2153}
2154
2155sub save {
2156 my ($self) = @_;
2157
2158 my $lock = cf::lock_acquire "map_data:$self->{path}";
2159
2160 $self->{last_save} = $cf::RUNTIME;
2161
2162 return unless $self->dirty;
2163
2164 my $save = $self->save_path; utf8::encode $save;
2165 my $uniq = $self->uniq_path; utf8::encode $uniq;
2166
2167 $self->{load_path} = $save;
2168
2169 return if $self->{deny_save};
2170
2171 local $self->{last_access} = $self->last_access;#d#
2172
2173 cf::async {
2174 $Coro::current->{desc} = "map player save";
2175 $_->contr->save for $self->players;
2176 };
2177
2178 if ($uniq) {
2179 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS);
2180 $self->_save_objects ($uniq, cf::IO_UNIQUES);
2181 } else {
2182 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES);
989 }, 2183 }
990); 2184}
991 2185
992############################################################################# 2186sub swap_out {
2187 my ($self) = @_;
993 2188
994=head2 CORE EXTENSIONS 2189 # save first because save cedes
2190 $self->save;
995 2191
996Functions and methods that extend core crossfire objects. 2192 my $lock = cf::lock_acquire "map_data:$self->{path}";
997 2193
998=head3 cf::player 2194 return if $self->players;
2195 return if $self->in_memory != cf::MAP_IN_MEMORY;
2196 return if $self->{deny_save};
2197
2198 $self->in_memory (cf::MAP_SWAPPED);
2199
2200 $self->deactivate;
2201 $_->clear_links_to ($self) for values %cf::MAP;
2202 $self->clear;
2203}
2204
2205sub reset_at {
2206 my ($self) = @_;
2207
2208 # TODO: safety, remove and allow resettable per-player maps
2209 return 1e99 if $self->{deny_reset};
2210
2211 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
2212 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET;
2213
2214 $time + $to
2215}
2216
2217sub should_reset {
2218 my ($self) = @_;
2219
2220 $self->reset_at <= $cf::RUNTIME
2221}
2222
2223sub reset {
2224 my ($self) = @_;
2225
2226 my $lock = cf::lock_acquire "map_data:$self->{path}";
2227
2228 return if $self->players;
2229
2230 warn "resetting map ", $self->path;
2231
2232 $self->in_memory (cf::MAP_SWAPPED);
2233
2234 # need to save uniques path
2235 unless ($self->{deny_save}) {
2236 my $uniq = $self->uniq_path; utf8::encode $uniq;
2237
2238 $self->_save_objects ($uniq, cf::IO_UNIQUES)
2239 if $uniq;
2240 }
2241
2242 delete $cf::MAP{$self->path};
2243
2244 $self->deactivate;
2245 $_->clear_links_to ($self) for values %cf::MAP;
2246 $self->clear;
2247
2248 $self->unlink_save;
2249 $self->destroy;
2250}
2251
2252my $nuke_counter = "aaaa";
2253
2254sub nuke {
2255 my ($self) = @_;
2256
2257 {
2258 my $lock = cf::lock_acquire "map_data:$self->{path}";
2259
2260 delete $cf::MAP{$self->path};
2261
2262 $self->unlink_save;
2263
2264 bless $self, "cf::map";
2265 delete $self->{deny_reset};
2266 $self->{deny_save} = 1;
2267 $self->reset_timeout (1);
2268 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));
2269
2270 $cf::MAP{$self->path} = $self;
2271 }
2272
2273 $self->reset; # polite request, might not happen
2274}
2275
2276=item $maps = cf::map::tmp_maps
2277
2278Returns an arrayref with all map paths of currently instantiated and saved
2279maps. May block.
2280
2281=cut
2282
2283sub tmp_maps() {
2284 [
2285 map {
2286 utf8::decode $_;
2287 /\.map$/
2288 ? normalise $_
2289 : ()
2290 } @{ aio_readdir $TMPDIR or [] }
2291 ]
2292}
2293
2294=item $maps = cf::map::random_maps
2295
2296Returns an arrayref with all map paths of currently instantiated and saved
2297random maps. May block.
2298
2299=cut
2300
2301sub random_maps() {
2302 [
2303 map {
2304 utf8::decode $_;
2305 /\.map$/
2306 ? normalise "?random/$_"
2307 : ()
2308 } @{ aio_readdir $RANDOMDIR or [] }
2309 ]
2310}
2311
2312=item cf::map::unique_maps
2313
2314Returns an arrayref of paths of all shared maps that have
2315instantiated unique items. May block.
2316
2317=cut
2318
2319sub unique_maps() {
2320 [
2321 map {
2322 utf8::decode $_;
2323 /\.map$/
2324 ? normalise $_
2325 : ()
2326 } @{ aio_readdir $UNIQUEDIR or [] }
2327 ]
2328}
2329
2330package cf;
2331
2332=back
2333
2334=head3 cf::object
2335
2336=cut
2337
2338package cf::object;
999 2339
1000=over 4 2340=over 4
1001 2341
1002=item cf::player::exists $login 2342=item $ob->inv_recursive
1003 2343
1004Returns true when the given account exists. 2344Returns the inventory of the object _and_ their inventories, recursively.
1005 2345
1006=cut 2346=cut
1007 2347
1008sub cf::player::exists($) { 2348sub inv_recursive_;
1009 cf::player::find $_[0] 2349sub inv_recursive_ {
1010 or -f sprintf "%s/%s/%s/%s.pl", cf::localdir, cf::playerdir, ($_[0]) x 2; 2350 map { $_, inv_recursive_ $_->inv } @_
1011} 2351}
1012 2352
1013=item $player->ext_reply ($msgid, $msgtype, %msg) 2353sub inv_recursive {
1014 2354 inv_recursive_ inv $_[0]
1015Sends an ext reply to the player.
1016
1017=cut
1018
1019sub cf::player::ext_reply($$$%) {
1020 my ($self, $id, %msg) = @_;
1021
1022 $msg{msgid} = $id;
1023
1024 $self->send ("ext " . to_json \%msg);
1025} 2355}
2356
2357=item $ref = $ob->ref
2358
2359creates and returns a persistent reference to an objetc that can be stored as a string.
2360
2361=item $ob = cf::object::deref ($refstring)
2362
2363returns the objetc referenced by refstring. may return undef when it cnanot find the object,
2364even if the object actually exists. May block.
2365
2366=cut
2367
2368sub deref {
2369 my ($ref) = @_;
2370
2371 if ($ref =~ m{^player\/(<1\.[0-9a-f]+>)/(.*)$}) {
2372 my ($uuid, $name) = ($1, $2);
2373 my $pl = $cf::PLAYER_LOADING{$name} || cf::player::find $name
2374 or return;
2375 $pl->ob->uuid eq $uuid
2376 or return;
2377
2378 $pl->ob
2379 } else {
2380 warn "$ref: cannot resolve object reference\n";
2381 undef
2382 }
2383}
2384
2385package cf;
1026 2386
1027=back 2387=back
1028 2388
1029=head3 cf::object::player 2389=head3 cf::object::player
1030 2390
… …
1046 2406
1047 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4; 2407 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4;
1048 2408
1049 if ($self->{record_replies}) { 2409 if ($self->{record_replies}) {
1050 push @{ $self->{record_replies} }, [$npc, $msg, $flags]; 2410 push @{ $self->{record_replies} }, [$npc, $msg, $flags];
2411
1051 } else { 2412 } else {
2413 my $pl = $self->contr;
2414
2415 if ($pl->{npc_dialog} && $pl->{npc_dialog}->{id}) {
2416 my $dialog = $pl->{npc_dialog};
2417 $dialog->{pl}->ext_msg ($dialog->{id}, update => msg => $dialog->{pl}->expand_cfpod ($msg));
2418
2419 } else {
1052 $msg = $npc->name . " says: $msg" if $npc; 2420 $msg = $npc->name . " says: $msg" if $npc;
1053 $self->message ($msg, $flags); 2421 $self->message ($msg, $flags);
2422 }
1054 } 2423 }
2424}
2425
2426=item $object->send_msg ($channel, $msg, $color, [extra...])
2427
2428=cut
2429
2430sub cf::object::send_msg {
2431 my $pl = shift->contr
2432 or return;
2433 $pl->send_msg (@_);
1055} 2434}
1056 2435
1057=item $player_object->may ("access") 2436=item $player_object->may ("access")
1058 2437
1059Returns wether the given player is authorized to access resource "access" 2438Returns wether the given player is authorized to access resource "access"
… …
1068 (ref $cf::CFG{"may_$access"} 2447 (ref $cf::CFG{"may_$access"}
1069 ? scalar grep $self->name eq $_, @{$cf::CFG{"may_$access"}} 2448 ? scalar grep $self->name eq $_, @{$cf::CFG{"may_$access"}}
1070 : $cf::CFG{"may_$access"}) 2449 : $cf::CFG{"may_$access"})
1071} 2450}
1072 2451
2452=item $player_object->enter_link
2453
2454Freezes the player and moves him/her to a special map (C<{link}>).
2455
2456The player should be reasonably safe there for short amounts of time. You
2457I<MUST> call C<leave_link> as soon as possible, though.
2458
2459Will never block.
2460
2461=item $player_object->leave_link ($map, $x, $y)
2462
2463Moves the player out of the special C<{link}> map onto the specified
2464map. If the map is not valid (or omitted), the player will be moved back
2465to the location he/she was before the call to C<enter_link>, or, if that
2466fails, to the emergency map position.
2467
2468Might block.
2469
2470=cut
2471
2472sub link_map {
2473 unless ($LINK_MAP) {
2474 $LINK_MAP = cf::map::find "{link}"
2475 or cf::cleanup "FATAL: unable to provide {link} map, exiting.";
2476 $LINK_MAP->load;
2477 }
2478
2479 $LINK_MAP
2480}
2481
2482sub cf::object::player::enter_link {
2483 my ($self) = @_;
2484
2485 $self->deactivate_recursive;
2486
2487 return if UNIVERSAL::isa $self->map, "ext::map_link";
2488
2489 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y]
2490 if $self->map && $self->map->{path} ne "{link}";
2491
2492 $self->enter_map ($LINK_MAP || link_map, 10, 10);
2493}
2494
2495sub cf::object::player::leave_link {
2496 my ($self, $map, $x, $y) = @_;
2497
2498 return unless $self->contr->active;
2499
2500 my $link_pos = delete $self->{_link_pos};
2501
2502 unless ($map) {
2503 # restore original map position
2504 ($map, $x, $y) = @{ $link_pos || [] };
2505 $map = cf::map::find $map;
2506
2507 unless ($map) {
2508 ($map, $x, $y) = @$EMERGENCY_POSITION;
2509 $map = cf::map::find $map
2510 or die "FATAL: cannot load emergency map\n";
2511 }
2512 }
2513
2514 ($x, $y) = (-1, -1)
2515 unless (defined $x) && (defined $y);
2516
2517 # use -1 or undef as default coordinates, not 0, 0
2518 ($x, $y) = ($map->enter_x, $map->enter_y)
2519 if $x <=0 && $y <= 0;
2520
2521 $map->load;
2522 $map->load_neighbours;
2523
2524 return unless $self->contr->active;
2525 $self->activate_recursive;
2526
2527 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
2528 $self->enter_map ($map, $x, $y);
2529}
2530
2531=item $player_object->goto ($path, $x, $y[, $check->($map)[, $done->()]])
2532
2533Moves the player to the given map-path and coordinates by first freezing
2534her, loading and preparing them map, calling the provided $check callback
2535that has to return the map if sucecssful, and then unfreezes the player on
2536the new (success) or old (failed) map position. In either case, $done will
2537be called at the end of this process.
2538
2539=cut
2540
2541our $GOTOGEN;
2542
2543sub cf::object::player::goto {
2544 my ($self, $path, $x, $y, $check, $done) = @_;
2545
2546 # do generation counting so two concurrent goto's will be executed in-order
2547 my $gen = $self->{_goto_generation} = ++$GOTOGEN;
2548
2549 $self->enter_link;
2550
2551 (async {
2552 $Coro::current->{desc} = "player::goto $path $x $y";
2553
2554 # *tag paths override both path and x|y
2555 if ($path =~ /^\*(.*)$/) {
2556 if (my @obs = grep $_->map, ext::map_tags::find $1) {
2557 my $ob = $obs[rand @obs];
2558
2559 # see if we actually can go there
2560 if (@obs = grep !$self->blocked ($_->map, $_->x, $_->y), $ob, $ob->tail) {
2561 $ob = $obs[rand @obs];
2562 } else {
2563 $self->message ("Wow, it's pretty crowded in there.", cf::NDI_UNIQUE | cf::NDI_RED);
2564 }
2565 # else put us there anyways for now #d#
2566
2567 ($path, $x, $y) = ($ob->map, $ob->x, $ob->y);
2568 } else {
2569 ($path, $x, $y) = (undef, undef, undef);
2570 }
2571 }
2572
2573 my $map = eval {
2574 my $map = defined $path ? cf::map::find $path : undef;
2575
2576 if ($map) {
2577 $map = $map->customise_for ($self);
2578 $map = $check->($map) if $check && $map;
2579 } else {
2580 $self->message ("The exit to '$path' is closed.", cf::NDI_UNIQUE | cf::NDI_RED);
2581 }
2582
2583 $map
2584 };
2585
2586 if ($@) {
2587 $self->message ("Something went wrong within the server, please report this incident!", cf::NDI_UNIQUE | cf::NDI_RED);
2588 LOG llevError | logBacktrace, Carp::longmess $@;
2589 }
2590
2591 if ($gen == $self->{_goto_generation}) {
2592 delete $self->{_goto_generation};
2593 $self->leave_link ($map, $x, $y);
2594 }
2595
2596 $done->() if $done;
2597 })->prio (1);
2598}
2599
2600=item $player_object->enter_exit ($exit_object)
2601
2602=cut
2603
2604sub parse_random_map_params {
2605 my ($spec) = @_;
2606
2607 my $rmp = { # defaults
2608 xsize => (cf::rndm 15, 40),
2609 ysize => (cf::rndm 15, 40),
2610 symmetry => (cf::rndm 1, cf::SYMMETRY_XY),
2611 #layout => string,
2612 };
2613
2614 for (split /\n/, $spec) {
2615 my ($k, $v) = split /\s+/, $_, 2;
2616
2617 $rmp->{lc $k} = $v if (length $k) && (length $v);
2618 }
2619
2620 $rmp
2621}
2622
2623sub prepare_random_map {
2624 my ($exit) = @_;
2625
2626 my $guard = cf::lock_acquire "exit_prepare:$exit";
2627
2628 # all this does is basically replace the /! path by
2629 # a new random map path (?random/...) with a seed
2630 # that depends on the exit object
2631
2632 my $rmp = parse_random_map_params $exit->msg;
2633
2634 if ($exit->map) {
2635 $rmp->{region} = $exit->region->name;
2636 $rmp->{origin_map} = $exit->map->path;
2637 $rmp->{origin_x} = $exit->x;
2638 $rmp->{origin_y} = $exit->y;
2639 }
2640
2641 $rmp->{random_seed} ||= $exit->random_seed;
2642
2643 my $data = cf::encode_json $rmp;
2644 my $md5 = Digest::MD5::md5_hex $data;
2645 my $meta = "$RANDOMDIR/$md5.meta";
2646
2647 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) {
2648 aio_write $fh, 0, (length $data), $data, 0;
2649 undef $fh;
2650 aio_rename "$meta~", $meta;
2651
2652 $exit->slaying ("?random/$md5");
2653 $exit->msg (undef);
2654 }
2655}
2656
2657sub cf::object::player::enter_exit {
2658 my ($self, $exit) = @_;
2659
2660 return unless $self->type == cf::PLAYER;
2661
2662 if ($exit->slaying eq "/!") {
2663 #TODO: this should de-fi-ni-te-ly not be a sync-job
2664 # the problem is that $exit might not survive long enough
2665 # so it needs to be done right now, right here
2666 cf::sync_job { prepare_random_map $exit };
2667 }
2668
2669 my $slaying = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path;
2670 my $hp = $exit->stats->hp;
2671 my $sp = $exit->stats->sp;
2672
2673 $self->enter_link;
2674
2675 # if exit is damned, update players death & WoR home-position
2676 $self->contr->savebed ($slaying, $hp, $sp)
2677 if $exit->flag (FLAG_DAMNED);
2678
2679 (async {
2680 $Coro::current->{desc} = "enter_exit $slaying $hp $sp";
2681
2682 $self->deactivate_recursive; # just to be sure
2683 unless (eval {
2684 $self->goto ($slaying, $hp, $sp);
2685
2686 1;
2687 }) {
2688 $self->message ("Something went wrong deep within the crossfire server. "
2689 . "I'll try to bring you back to the map you were before. "
2690 . "Please report this to the dungeon master!",
2691 cf::NDI_UNIQUE | cf::NDI_RED);
2692
2693 warn "ERROR in enter_exit: $@";
2694 $self->leave_link;
2695 }
2696 })->prio (1);
2697}
2698
1073=head3 cf::client 2699=head3 cf::client
1074 2700
1075=over 4 2701=over 4
1076 2702
1077=item $client->send_drawinfo ($text, $flags) 2703=item $client->send_drawinfo ($text, $flags)
… …
1083 2709
1084sub cf::client::send_drawinfo { 2710sub cf::client::send_drawinfo {
1085 my ($self, $text, $flags) = @_; 2711 my ($self, $text, $flags) = @_;
1086 2712
1087 utf8::encode $text; 2713 utf8::encode $text;
1088 $self->send_packet (sprintf "drawinfo %d %s", $flags, $text); 2714 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);
1089} 2715}
1090 2716
2717=item $client->send_msg ($channel, $msg, $color, [extra...])
2718
2719Send a drawinfo or msg packet to the client, formatting the msg for the
2720client if neccessary. C<$type> should be a string identifying the type of
2721the message, with C<log> being the default. If C<$color> is negative, suppress
2722the message unless the client supports the msg packet.
2723
2724=cut
2725
2726# non-persistent channels (usually the info channel)
2727our %CHANNEL = (
2728 "c/identify" => {
2729 id => "infobox",
2730 title => "Identify",
2731 reply => undef,
2732 tooltip => "Items recently identified",
2733 },
2734 "c/examine" => {
2735 id => "infobox",
2736 title => "Examine",
2737 reply => undef,
2738 tooltip => "Signs and other items you examined",
2739 },
2740 "c/book" => {
2741 id => "infobox",
2742 title => "Book",
2743 reply => undef,
2744 tooltip => "The contents of a note or book",
2745 },
2746 "c/lookat" => {
2747 id => "infobox",
2748 title => "Look",
2749 reply => undef,
2750 tooltip => "What you saw there",
2751 },
2752 "c/who" => {
2753 id => "infobox",
2754 title => "Players",
2755 reply => undef,
2756 tooltip => "Shows players who are currently online",
2757 },
2758 "c/body" => {
2759 id => "infobox",
2760 title => "Body Parts",
2761 reply => undef,
2762 tooltip => "Shows which body parts you posess and are available",
2763 },
2764 "c/uptime" => {
2765 id => "infobox",
2766 title => "Uptime",
2767 reply => undef,
2768 tooltip => "How long the server has been running since last restart",
2769 },
2770 "c/mapinfo" => {
2771 id => "infobox",
2772 title => "Map Info",
2773 reply => undef,
2774 tooltip => "Information related to the maps",
2775 },
2776);
2777
2778sub cf::client::send_msg {
2779 my ($self, $channel, $msg, $color, @extra) = @_;
2780
2781 $msg = $self->pl->expand_cfpod ($msg);
2782
2783 $color &= cf::NDI_CLIENT_MASK; # just in case...
2784
2785 # check predefined channels, for the benefit of C
2786 if ($CHANNEL{$channel}) {
2787 $channel = $CHANNEL{$channel};
2788
2789 $self->ext_msg (channel_info => $channel)
2790 if $self->can_msg;
2791
2792 $channel = $channel->{id};
2793
2794 } elsif (ref $channel) {
2795 # send meta info to client, if not yet sent
2796 unless (exists $self->{channel}{$channel->{id}}) {
2797 $self->{channel}{$channel->{id}} = $channel;
2798 $self->ext_msg (channel_info => $channel)
2799 if $self->can_msg;
2800 }
2801
2802 $channel = $channel->{id};
2803 }
2804
2805 return unless @extra || length $msg;
2806
2807 if ($self->can_msg) {
2808 # default colour, mask it out
2809 $color &= ~(cf::NDI_COLOR_MASK | cf::NDI_DEF)
2810 if $color & cf::NDI_DEF;
2811
2812 $self->send_packet ("msg " . $self->{json_coder}->encode (
2813 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]));
2814 } else {
2815 if ($color >= 0) {
2816 # replace some tags by gcfclient-compatible ones
2817 for ($msg) {
2818 1 while
2819 s/<b>([^<]*)<\/b>/[b]${1}[\/b]/
2820 || s/<i>([^<]*)<\/i>/[i]${1}[\/i]/
2821 || s/<u>([^<]*)<\/u>/[ul]${1}[\/ul]/
2822 || s/<tt>([^<]*)<\/tt>/[fixed]${1}[\/fixed]/
2823 || s/<fg name=\"([^"]+)\">([^<]*)<\/fg>/[color=$1]${2}[\/color]/;
2824 }
2825
2826 $color &= cf::NDI_COLOR_MASK;
2827
2828 utf8::encode $msg;
2829
2830 if (0 && $msg =~ /\[/) {
2831 # COMMAND/INFO
2832 $self->send_packet ("drawextinfo $color 10 8 $msg")
2833 } else {
2834 $msg =~ s/\[\/?(?:b|i|u|fixed|color)[^\]]*\]//g;
2835 $self->send_packet ("drawinfo $color $msg")
2836 }
2837 }
2838 }
2839}
2840
2841=item $client->ext_msg ($type, @msg)
2842
2843Sends an ext event to the client.
2844
2845=cut
2846
2847sub cf::client::ext_msg($$@) {
2848 my ($self, $type, @msg) = @_;
2849
2850 if ($self->extcmd == 2) {
2851 $self->send_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
2852 } elsif ($self->extcmd == 1) { # TODO: remove
2853 push @msg, msgtype => "event_$type";
2854 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2855 }
2856}
2857
2858=item $client->ext_reply ($msgid, @msg)
2859
2860Sends an ext reply to the client.
2861
2862=cut
2863
2864sub cf::client::ext_reply($$@) {
2865 my ($self, $id, @msg) = @_;
2866
2867 if ($self->extcmd == 2) {
2868 $self->send_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg]));
2869 } elsif ($self->extcmd == 1) {
2870 #TODO: version 1, remove
2871 unshift @msg, msgtype => "reply", msgid => $id;
2872 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2873 }
2874}
1091 2875
1092=item $success = $client->query ($flags, "text", \&cb) 2876=item $success = $client->query ($flags, "text", \&cb)
1093 2877
1094Queues a query to the client, calling the given callback with 2878Queues a query to the client, calling the given callback with
1095the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>, 2879the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>,
1096C<cf::CS_QUERY_SINGLECHAR> or C<cf::CS_QUERY_HIDEINPUT> or C<0>. 2880C<cf::CS_QUERY_SINGLECHAR> or C<cf::CS_QUERY_HIDEINPUT> or C<0>.
1097 2881
1098Queries can fail, so check the return code. Or don't, as queries will become 2882Queries can fail, so check the return code. Or don't, as queries will
1099reliable at some point in the future. 2883become reliable at some point in the future.
1100 2884
1101=cut 2885=cut
1102 2886
1103sub cf::client::query { 2887sub cf::client::query {
1104 my ($self, $flags, $text, $cb) = @_; 2888 my ($self, $flags, $text, $cb) = @_;
… …
1112 utf8::encode $text; 2896 utf8::encode $text;
1113 push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb]; 2897 push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb];
1114 2898
1115 $self->send_packet ($self->{query_queue}[0][0]) 2899 $self->send_packet ($self->{query_queue}[0][0])
1116 if @{ $self->{query_queue} } == 1; 2900 if @{ $self->{query_queue} } == 1;
2901
2902 1
1117} 2903}
1118 2904
1119cf::client->attach ( 2905cf::client->attach (
2906 on_connect => sub {
2907 my ($ns) = @_;
2908
2909 $ns->{json_coder} = JSON::XS->new->utf8->max_size (1e6)->convert_blessed;
2910 },
1120 on_reply => sub { 2911 on_reply => sub {
1121 my ($ns, $msg) = @_; 2912 my ($ns, $msg) = @_;
1122 2913
1123 # this weird shuffling is so that direct followup queries 2914 # this weird shuffling is so that direct followup queries
1124 # get handled first 2915 # get handled first
1125 my $queue = delete $ns->{query_queue}; 2916 my $queue = delete $ns->{query_queue}
2917 or return; # be conservative, not sure how that can happen, but we saw a crash here
1126 2918
1127 (shift @$queue)->[1]->($msg); 2919 (shift @$queue)->[1]->($msg);
2920 return unless $ns->valid; # temporary(?) workaround for callback destroying socket
1128 2921
1129 push @{ $ns->{query_queue} }, @$queue; 2922 push @{ $ns->{query_queue} }, @$queue;
1130 2923
1131 if (@{ $ns->{query_queue} } == @$queue) { 2924 if (@{ $ns->{query_queue} } == @$queue) {
1132 if (@$queue) { 2925 if (@$queue) {
… …
1134 } else { 2927 } else {
1135 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM; 2928 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM;
1136 } 2929 }
1137 } 2930 }
1138 }, 2931 },
2932 on_exticmd => sub {
2933 my ($ns, $buf) = @_;
2934
2935 my $msg = eval { $ns->{json_coder}->decode ($buf) };
2936
2937 if (ref $msg) {
2938 my ($type, $reply, @payload) =
2939 "ARRAY" eq ref $msg
2940 ? @$msg
2941 : ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
2942
2943 my @reply;
2944
2945 if (my $cb = $EXTICMD{$type}) {
2946 @reply = $cb->($ns, @payload);
2947 }
2948
2949 $ns->ext_reply ($reply, @reply)
2950 if $reply;
2951
2952 } else {
2953 warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";
2954 }
2955
2956 cf::override;
2957 },
1139); 2958);
1140 2959
1141=item $client->coro (\&cb) 2960=item $client->async (\&cb)
1142 2961
1143Create a new coroutine, running the specified callback. The coroutine will 2962Create a new coroutine, running the specified callback. The coroutine will
1144be automatically cancelled when the client gets destroyed (e.g. on logout, 2963be automatically cancelled when the client gets destroyed (e.g. on logout,
1145or loss of connection). 2964or loss of connection).
1146 2965
1147=cut 2966=cut
1148 2967
1149sub cf::client::coro { 2968sub cf::client::async {
1150 my ($self, $cb) = @_; 2969 my ($self, $cb) = @_;
1151 2970
1152 my $coro; $coro = async { 2971 my $coro = &Coro::async ($cb);
1153 eval {
1154 $cb->();
1155 };
1156 warn $@ if $@;
1157 };
1158 2972
1159 $coro->on_destroy (sub { 2973 $coro->on_destroy (sub {
1160 delete $self->{_coro}{$coro+0}; 2974 delete $self->{_coro}{$coro+0};
1161 }); 2975 });
1162 2976
… …
1189our $safe = new Safe "safe"; 3003our $safe = new Safe "safe";
1190our $safe_hole = new Safe::Hole; 3004our $safe_hole = new Safe::Hole;
1191 3005
1192$SIG{FPE} = 'IGNORE'; 3006$SIG{FPE} = 'IGNORE';
1193 3007
1194$safe->permit_only (Opcode::opset qw(:base_core :base_mem :base_orig :base_math sort time)); 3008$safe->permit_only (Opcode::opset qw(
3009 :base_core :base_mem :base_orig :base_math
3010 grepstart grepwhile mapstart mapwhile
3011 sort time
3012));
1195 3013
1196# here we export the classes and methods available to script code 3014# here we export the classes and methods available to script code
1197 3015
1198=pod 3016=pod
1199 3017
1200The following fucntions and emthods are available within a safe environment: 3018The following functions and methods are available within a safe environment:
1201 3019
1202 cf::object contr pay_amount pay_player map 3020 cf::object
3021 contr pay_amount pay_player map x y force_find force_add destroy
3022 insert remove name archname title slaying race decrease_ob_nr
3023
1203 cf::object::player player 3024 cf::object::player
1204 cf::player peaceful 3025 player
1205 cf::map trigger 3026
3027 cf::player
3028 peaceful
3029
3030 cf::map
3031 trigger
1206 3032
1207=cut 3033=cut
1208 3034
1209for ( 3035for (
1210 ["cf::object" => qw(contr pay_amount pay_player map)], 3036 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y
3037 insert remove inv name archname title slaying race
3038 decrease_ob_nr destroy)],
1211 ["cf::object::player" => qw(player)], 3039 ["cf::object::player" => qw(player)],
1212 ["cf::player" => qw(peaceful)], 3040 ["cf::player" => qw(peaceful)],
1213 ["cf::map" => qw(trigger)], 3041 ["cf::map" => qw(trigger)],
1214) { 3042) {
1215 no strict 'refs'; 3043 no strict 'refs';
… …
1286=back 3114=back
1287 3115
1288=cut 3116=cut
1289 3117
1290############################################################################# 3118#############################################################################
3119# the server's init and main functions
1291 3120
1292=head2 EXTENSION DATABASE SUPPORT 3121sub load_facedata($) {
3122 my ($path) = @_;
1293 3123
1294Crossfire maintains a very simple database for extension use. It can 3124 # HACK to clear player env face cache, we need some signal framework
1295currently store anything that can be serialised using Storable, which 3125 # for this (global event?)
1296excludes objects. 3126 %ext::player_env::MUSIC_FACE_CACHE = ();
1297 3127
1298The parameter C<$family> should best start with the name of the extension 3128 my $enc = JSON::XS->new->utf8->canonical->relaxed;
1299using it, it should be unique.
1300 3129
1301=over 4 3130 warn "loading facedata from $path\n";
1302 3131
1303=item $hashref = cf::db_get $family 3132 my $facedata;
3133 0 < aio_load $path, $facedata
3134 or die "$path: $!";
1304 3135
1305Return a hashref for use by the extension C<$family>, which can be 3136 $facedata = Coro::Storable::thaw $facedata;
1306modified. After modifications, you have to call C<cf::db_dirty> or
1307C<cf::db_sync>.
1308 3137
1309=item $value = cf::db_get $family => $key 3138 $facedata->{version} == 2
3139 or cf::cleanup "$path: version mismatch, cannot proceed.";
1310 3140
1311Returns a single value from the database 3141 # patch in the exptable
1312 3142 $facedata->{resource}{"res/exp_table"} = {
1313=item cf::db_put $family => $hashref 3143 type => FT_RSRC,
1314 3144 data => $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]),
1315Stores the given family hashref into the database. Updates are delayed, if
1316you want the data to be synced to disk immediately, use C<cf::db_sync>.
1317
1318=item cf::db_put $family => $key => $value
1319
1320Stores the given C<$value> in the family hash. Updates are delayed, if you
1321want the data to be synced to disk immediately, use C<cf::db_sync>.
1322
1323=item cf::db_dirty
1324
1325Marks the database as dirty, to be updated at a later time.
1326
1327=item cf::db_sync
1328
1329Immediately write the database to disk I<if it is dirty>.
1330
1331=cut
1332
1333our $DB;
1334
1335{
1336 my $path = cf::localdir . "/database.pst";
1337
1338 sub db_load() {
1339 warn "loading database $path\n";#d# remove later
1340 $DB = stat $path ? Storable::retrieve $path : { };
1341 }
1342
1343 my $pid;
1344
1345 sub db_save() {
1346 warn "saving database $path\n";#d# remove later
1347 waitpid $pid, 0 if $pid;
1348 if (0 == ($pid = fork)) {
1349 $DB->{_meta}{version} = 1;
1350 Storable::nstore $DB, "$path~";
1351 rename "$path~", $path;
1352 cf::_exit 0 if defined $pid;
1353 }
1354 }
1355
1356 my $dirty;
1357
1358 sub db_sync() {
1359 db_save if $dirty;
1360 undef $dirty;
1361 }
1362
1363 my $idle = Event->idle (min => $TICK * 2.8, max => 10, repeat => 0, data => WF_AUTOCANCEL, cb => sub {
1364 db_sync;
1365 }); 3145 };
3146 cf::cede_to_tick;
1366 3147
1367 sub db_dirty() {
1368 $dirty = 1;
1369 $idle->start;
1370 } 3148 {
3149 my $faces = $facedata->{faceinfo};
1371 3150
1372 sub db_get($;$) { 3151 while (my ($face, $info) = each %$faces) {
1373 @_ >= 2 3152 my $idx = (cf::face::find $face) || cf::face::alloc $face;
1374 ? $DB->{$_[0]}{$_[1]} 3153 cf::face::set_visibility $idx, $info->{visibility};
1375 : ($DB->{$_[0]} ||= { }) 3154 cf::face::set_magicmap $idx, $info->{magicmap};
1376 } 3155 cf::face::set_data $idx, 0, $info->{data32}, Digest::MD5::md5 $info->{data32};
3156 cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64};
1377 3157
1378 sub db_put($$;$) { 3158 cf::cede_to_tick;
1379 if (@_ >= 3) {
1380 $DB->{$_[0]}{$_[1]} = $_[2];
1381 } else {
1382 $DB->{$_[0]} = $_[1];
1383 }
1384 db_dirty;
1385 }
1386
1387 cf::global->attach (
1388 prio => 10000,
1389 on_cleanup => sub {
1390 db_sync;
1391 }, 3159 }
1392 );
1393}
1394 3160
1395############################################################################# 3161 while (my ($face, $info) = each %$faces) {
1396# the server's main() 3162 next unless $info->{smooth};
3163 my $idx = cf::face::find $face
3164 or next;
3165 if (my $smooth = cf::face::find $info->{smooth}) {
3166 cf::face::set_smooth $idx, $smooth;
3167 cf::face::set_smoothlevel $idx, $info->{smoothlevel};
3168 } else {
3169 warn "smooth face '$info->{smooth}' not found for face '$face'";
3170 }
1397 3171
1398sub cfg_load { 3172 cf::cede_to_tick;
3173 }
3174 }
3175
3176 {
3177 my $anims = $facedata->{animinfo};
3178
3179 while (my ($anim, $info) = each %$anims) {
3180 cf::anim::set $anim, $info->{frames}, $info->{facings};
3181 cf::cede_to_tick;
3182 }
3183
3184 cf::anim::invalidate_all; # d'oh
3185 }
3186
3187 {
3188 # TODO: for gcfclient pleasure, we should give resources
3189 # that gcfclient doesn't grok a >10000 face index.
3190 my $res = $facedata->{resource};
3191
3192 my $soundconf = delete $res->{"res/sound.conf"};
3193
3194 while (my ($name, $info) = each %$res) {
3195 my $idx = (cf::face::find $name) || cf::face::alloc $name;
3196 my $data;
3197
3198 if ($info->{type} & 1) {
3199 # prepend meta info
3200
3201 my $meta = $enc->encode ({
3202 name => $name,
3203 %{ $info->{meta} || {} },
3204 });
3205
3206 $data = pack "(w/a*)*", $meta, $info->{data};
3207 } else {
3208 $data = $info->{data};
3209 }
3210
3211 cf::face::set_data $idx, 0, $data, Digest::MD5::md5 $data;
3212 cf::face::set_type $idx, $info->{type};
3213
3214 cf::cede_to_tick;
3215 }
3216
3217 if ($soundconf) {
3218 $soundconf = $enc->decode (delete $soundconf->{data});
3219
3220 for (0 .. SOUND_CAST_SPELL_0 - 1) {
3221 my $sound = $soundconf->{compat}[$_]
3222 or next;
3223
3224 my $face = cf::face::find "sound/$sound->[1]";
3225 cf::sound::set $sound->[0] => $face;
3226 cf::sound::old_sound_index $_, $face; # gcfclient-compat
3227 }
3228
3229 while (my ($k, $v) = each %{$soundconf->{event}}) {
3230 my $face = cf::face::find "sound/$v";
3231 cf::sound::set $k => $face;
3232 }
3233 }
3234 }
3235
3236 1
3237}
3238
3239register_exticmd fx_want => sub {
3240 my ($ns, $want) = @_;
3241
3242 while (my ($k, $v) = each %$want) {
3243 $ns->fx_want ($k, $v);
3244 }
3245};
3246
3247sub reload_regions {
3248 # HACK to clear player env face cache, we need some signal framework
3249 # for this (global event?)
3250 %ext::player_env::MUSIC_FACE_CACHE = ();
3251
3252 load_resource_file "$MAPDIR/regions"
3253 or die "unable to load regions file\n";
3254
3255 for (cf::region::list) {
3256 $_->{match} = qr/$_->{match}/
3257 if exists $_->{match};
3258 }
3259}
3260
3261sub reload_facedata {
3262 load_facedata "$DATADIR/facedata"
3263 or die "unable to load facedata\n";
3264}
3265
3266sub reload_archetypes {
3267 load_resource_file "$DATADIR/archetypes"
3268 or die "unable to load archetypes\n";
3269 #d# NEED to laod twice to resolve forward references
3270 # this really needs to be done in an extra post-pass
3271 # (which needs to be synchronous, so solve it differently)
3272 load_resource_file "$DATADIR/archetypes"
3273 or die "unable to load archetypes\n";
3274}
3275
3276sub reload_treasures {
3277 load_resource_file "$DATADIR/treasures"
3278 or die "unable to load treasurelists\n";
3279}
3280
3281sub reload_resources {
3282 warn "reloading resource files...\n";
3283
3284 reload_regions;
3285 reload_facedata;
3286 #reload_archetypes;#d#
3287 reload_archetypes;
3288 reload_treasures;
3289
3290 warn "finished reloading resource files\n";
3291}
3292
3293sub init {
3294 reload_resources;
3295}
3296
3297sub reload_config {
1399 open my $fh, "<:utf8", cf::confdir . "/config" 3298 open my $fh, "<:utf8", "$CONFDIR/config"
1400 or return; 3299 or return;
1401 3300
1402 local $/; 3301 local $/;
1403 *CFG = YAML::Syck::Load <$fh>; 3302 *CFG = YAML::Syck::Load <$fh>;
3303
3304 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37];
3305
3306 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset};
3307 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset};
3308
3309 if (exists $CFG{mlockall}) {
3310 eval {
3311 $CFG{mlockall} ? eval "mlockall()" : eval "munlockall()"
3312 and die "WARNING: m(un)lockall failed: $!\n";
3313 };
3314 warn $@ if $@;
3315 }
1404} 3316}
1405 3317
1406sub main { 3318sub main {
1407 # we must not ever block the main coroutine 3319 # we must not ever block the main coroutine
1408 local $Coro::idle = sub { 3320 local $Coro::idle = sub {
1409 Carp::cluck "FATAL: Coro::idle was called, major BUG\n";#d# 3321 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
1410 (Coro::unblock_sub { 3322 (async {
1411 Event::one_event; 3323 $Coro::current->{desc} = "IDLE BUG HANDLER";
1412 })->(); 3324 EV::loop EV::LOOP_ONESHOT;
3325 })->prio (Coro::PRIO_MAX);
1413 }; 3326 };
1414 3327
1415 cfg_load; 3328 reload_config;
1416 db_load; 3329 db_init;
1417 load_extensions; 3330 load_extensions;
3331
3332 $TICK_WATCHER->start;
3333 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority
1418 Event::loop; 3334 EV::loop;
1419} 3335}
1420 3336
1421############################################################################# 3337#############################################################################
1422# initialisation 3338# initialisation and cleanup
1423 3339
1424sub perl_reload() { 3340# install some emergency cleanup handlers
3341BEGIN {
3342 our %SIGWATCHER = ();
3343 for my $signal (qw(INT HUP TERM)) {
3344 $SIGWATCHER{$signal} = EV::signal $signal, sub {
3345 cf::cleanup "SIG$signal";
3346 };
3347 }
3348}
3349
3350sub write_runtime {
3351 my $runtime = "$LOCALDIR/runtime";
3352
3353 # first touch the runtime file to show we are still running:
3354 # the fsync below can take a very very long time.
3355
3356 IO::AIO::aio_utime $runtime, undef, undef;
3357
3358 my $guard = cf::lock_acquire "write_runtime";
3359
3360 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644
3361 or return;
3362
3363 my $value = $cf::RUNTIME + 90 + 10;
3364 # 10 is the runtime save interval, for a monotonic clock
3365 # 60 allows for the watchdog to kill the server.
3366
3367 (aio_write $fh, 0, (length $value), $value, 0) <= 0
3368 and return;
3369
3370 # always fsync - this file is important
3371 aio_fsync $fh
3372 and return;
3373
3374 # touch it again to show we are up-to-date
3375 aio_utime $fh, undef, undef;
3376
3377 close $fh
3378 or return;
3379
3380 aio_rename "$runtime~", $runtime
3381 and return;
3382
3383 warn "runtime file written.\n";
3384
3385 1
3386}
3387
3388sub emergency_save() {
3389 my $freeze_guard = cf::freeze_mainloop;
3390
3391 warn "enter emergency perl save\n";
3392
3393 cf::sync_job {
3394 # use a peculiar iteration method to avoid tripping on perl
3395 # refcount bugs in for. also avoids problems with players
3396 # and maps saved/destroyed asynchronously.
3397 warn "begin emergency player save\n";
3398 for my $login (keys %cf::PLAYER) {
3399 my $pl = $cf::PLAYER{$login} or next;
3400 $pl->valid or next;
3401 delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt
3402 $pl->save;
3403 }
3404 warn "end emergency player save\n";
3405
3406 warn "begin emergency map save\n";
3407 for my $path (keys %cf::MAP) {
3408 my $map = $cf::MAP{$path} or next;
3409 $map->valid or next;
3410 $map->save;
3411 }
3412 warn "end emergency map save\n";
3413
3414 warn "begin emergency database checkpoint\n";
3415 BDB::db_env_txn_checkpoint $DB_ENV;
3416 warn "end emergency database checkpoint\n";
3417 };
3418
3419 warn "leave emergency perl save\n";
3420}
3421
3422sub post_cleanup {
3423 my ($make_core) = @_;
3424
3425 warn Carp::longmess "post_cleanup backtrace"
3426 if $make_core;
3427}
3428
3429sub do_reload_perl() {
1425 # can/must only be called in main 3430 # can/must only be called in main
1426 if ($Coro::current != $Coro::main) { 3431 if ($Coro::current != $Coro::main) {
1427 warn "can only reload from main coroutine\n"; 3432 warn "can only reload from main coroutine";
1428 return; 3433 return;
1429 } 3434 }
1430 3435
1431 warn "reloading..."; 3436 warn "reloading...";
1432 3437
1433 local $FREEZE = 1; 3438 warn "entering sync_job";
3439
3440 cf::sync_job {
3441 cf::write_runtime; # external watchdog should not bark
1434 cf::emergency_save; 3442 cf::emergency_save;
3443 cf::write_runtime; # external watchdog should not bark
1435 3444
1436 eval { 3445 warn "syncing database to disk";
3446 BDB::db_env_txn_checkpoint $DB_ENV;
3447
1437 # if anything goes wrong in here, we should simply crash as we already saved 3448 # if anything goes wrong in here, we should simply crash as we already saved
1438 3449
1439 # cancel all watchers 3450 warn "flushing outstanding aio requests";
1440 for (Event::all_watchers) { 3451 for (;;) {
1441 $_->cancel if $_->data & WF_AUTOCANCEL; 3452 BDB::flush;
3453 IO::AIO::flush;
3454 Coro::cede_notself;
3455 last unless IO::AIO::nreqs || BDB::nreqs;
3456 warn "iterate...";
1442 } 3457 }
1443 3458
3459 ++$RELOAD;
3460
1444 # cancel all extension coros 3461 warn "cancelling all extension coros";
1445 $_->cancel for values %EXT_CORO; 3462 $_->cancel for values %EXT_CORO;
1446 %EXT_CORO = (); 3463 %EXT_CORO = ();
1447 3464
1448 # unload all extensions 3465 warn "removing commands";
1449 for (@exts) { 3466 %COMMAND = ();
3467
3468 warn "removing ext/exti commands";
3469 %EXTCMD = ();
3470 %EXTICMD = ();
3471
3472 warn "unloading/nuking all extensions";
3473 for my $pkg (@EXTS) {
1450 warn "unloading <$_>"; 3474 warn "... unloading $pkg";
1451 unload_extension $_; 3475
3476 if (my $cb = $pkg->can ("unload")) {
3477 eval {
3478 $cb->($pkg);
3479 1
3480 } or warn "$pkg unloaded, but with errors: $@";
1452 } 3481 }
1453 3482
3483 warn "... nuking $pkg";
3484 Symbol::delete_package $pkg;
3485 }
3486
1454 # unload all modules loaded from $LIBDIR 3487 warn "unloading all perl modules loaded from $LIBDIR";
1455 while (my ($k, $v) = each %INC) { 3488 while (my ($k, $v) = each %INC) {
1456 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/; 3489 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
1457 3490
1458 warn "removing <$k>"; 3491 warn "... unloading $k";
1459 delete $INC{$k}; 3492 delete $INC{$k};
1460 3493
1461 $k =~ s/\.pm$//; 3494 $k =~ s/\.pm$//;
1462 $k =~ s/\//::/g; 3495 $k =~ s/\//::/g;
1463 3496
… …
1466 } 3499 }
1467 3500
1468 Symbol::delete_package $k; 3501 Symbol::delete_package $k;
1469 } 3502 }
1470 3503
1471 # sync database to disk
1472 cf::db_sync;
1473 IO::AIO::flush;
1474
1475 # get rid of safe::, as good as possible 3504 warn "getting rid of safe::, as good as possible";
1476 Symbol::delete_package "safe::$_" 3505 Symbol::delete_package "safe::$_"
1477 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region); 3506 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
1478 3507
1479 # remove register_script_function callbacks
1480 # TODO
1481
1482 # unload cf.pm "a bit" 3508 warn "unloading cf.pm \"a bit\"";
1483 delete $INC{"cf.pm"}; 3509 delete $INC{"cf.pm"};
3510 delete $INC{"cf/pod.pm"};
1484 3511
1485 # don't, removes xs symbols, too, 3512 # don't, removes xs symbols, too,
1486 # and global variables created in xs 3513 # and global variables created in xs
1487 #Symbol::delete_package __PACKAGE__; 3514 #Symbol::delete_package __PACKAGE__;
1488 3515
1489 # reload cf.pm 3516 warn "unload completed, starting to reload now";
3517
1490 warn "reloading cf.pm"; 3518 warn "reloading cf.pm";
1491 require cf; 3519 require cf;
1492 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 3520 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
1493 3521
1494 # load config and database again 3522 warn "loading config and database again";
1495 cf::cfg_load; 3523 cf::reload_config;
1496 cf::db_load;
1497 3524
1498 # load extensions
1499 warn "load extensions"; 3525 warn "loading extensions";
1500 cf::load_extensions; 3526 cf::load_extensions;
1501 3527
1502 # reattach attachments to objects 3528 warn "reattaching attachments to objects/players";
1503 warn "reattach"; 3529 _global_reattach; # objects, sockets
1504 _global_reattach; 3530 warn "reattaching attachments to maps";
1505 }; 3531 reattach $_ for values %MAP;
3532 warn "reattaching attachments to players";
3533 reattach $_ for values %PLAYER;
1506 3534
1507 if ($@) { 3535 warn "leaving sync_job";
3536
3537 1
3538 } or do {
1508 warn $@; 3539 warn $@;
1509 warn "error while reloading, exiting."; 3540 warn "error while reloading, exiting.";
1510 exit 1; 3541 exit 1;
1511 } 3542 };
1512 3543
1513 warn "reloaded successfully"; 3544 warn "reloaded";
1514}; 3545};
1515 3546
1516############################################################################# 3547our $RELOAD_WATCHER; # used only during reload
1517 3548
1518unless ($LINK_MAP) { 3549sub reload_perl() {
1519 $LINK_MAP = cf::map::new; 3550 # doing reload synchronously and two reloads happen back-to-back,
3551 # coro crashes during coro_state_free->destroy here.
1520 3552
1521 $LINK_MAP->width (41); 3553 $RELOAD_WATCHER ||= EV::timer 0, 0, sub {
1522 $LINK_MAP->height (41); 3554 undef $RELOAD_WATCHER;
1523 $LINK_MAP->alloc; 3555 do_reload_perl;
1524 $LINK_MAP->path ("{link}"); 3556 };
1525 $LINK_MAP->{path} = bless { path => "{link}" }, "cf::path";
1526 $LINK_MAP->in_memory (MAP_IN_MEMORY);
1527} 3557}
1528 3558
1529register "<global>", __PACKAGE__;
1530
1531register_command "perl-reload" => sub { 3559register_command "reload" => sub {
1532 my ($who, $arg) = @_; 3560 my ($who, $arg) = @_;
1533 3561
1534 if ($who->flag (FLAG_WIZ)) { 3562 if ($who->flag (FLAG_WIZ)) {
1535 $who->message ("start of reload.");
1536 perl_reload;
1537 $who->message ("end of reload."); 3563 $who->message ("reloading server.");
3564 async {
3565 $Coro::current->{desc} = "perl_reload";
3566 reload_perl;
3567 };
1538 } 3568 }
1539}; 3569};
1540 3570
1541unshift @INC, $LIBDIR; 3571unshift @INC, $LIBDIR;
1542 3572
1543$TICK_WATCHER = Event->timer ( 3573my $bug_warning = 0;
1544 reentrant => 0, 3574
1545 prio => 0, 3575our @WAIT_FOR_TICK;
1546 at => $NEXT_TICK || $TICK, 3576our @WAIT_FOR_TICK_BEGIN;
1547 data => WF_AUTOCANCEL, 3577
1548 cb => sub { 3578sub wait_for_tick {
1549 unless ($FREEZE) { 3579 return unless $TICK_WATCHER->is_active;
3580 return if $Coro::current == $Coro::main;
3581
3582 my $signal = new Coro::Signal;
3583 push @WAIT_FOR_TICK, $signal;
3584 $signal->wait;
3585}
3586
3587sub wait_for_tick_begin {
3588 return unless $TICK_WATCHER->is_active;
3589 return if $Coro::current == $Coro::main;
3590
3591 my $signal = new Coro::Signal;
3592 push @WAIT_FOR_TICK_BEGIN, $signal;
3593 $signal->wait;
3594}
3595
3596$TICK_WATCHER = EV::periodic_ns 0, $TICK, 0, sub {
3597 if ($Coro::current != $Coro::main) {
3598 Carp::cluck "major BUG: server tick called outside of main coro, skipping it"
3599 unless ++$bug_warning > 10;
3600 return;
3601 }
3602
3603 $NOW = $tick_start = EV::now;
3604
1550 cf::server_tick; # one server iteration 3605 cf::server_tick; # one server iteration
3606
1551 $RUNTIME += $TICK; 3607 $RUNTIME += $TICK;
1552 }
1553
1554 $NEXT_TICK += $TICK; 3608 $NEXT_TICK += $TICK;
1555 3609
1556 # if we are delayed by four ticks or more, skip them all 3610 if ($NOW >= $NEXT_RUNTIME_WRITE) {
1557 $NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4; 3611 $NEXT_RUNTIME_WRITE = $NOW + 10;
1558 3612 Coro::async_pool {
1559 $TICK_WATCHER->at ($NEXT_TICK); 3613 $Coro::current->{desc} = "runtime saver";
1560 $TICK_WATCHER->start;
1561 },
1562);
1563
1564IO::AIO::max_poll_time $TICK * 0.2;
1565
1566Event->io (
1567 fd => IO::AIO::poll_fileno,
1568 poll => 'r',
1569 prio => 5,
1570 data => WF_AUTOCANCEL,
1571 cb => \&IO::AIO::poll_cb,
1572);
1573
1574Event->timer (
1575 data => WF_AUTOCANCEL,
1576 after => 0,
1577 interval => 10,
1578 cb => sub {
1579 (Coro::unblock_sub {
1580 write_runtime 3614 write_runtime
1581 or warn "ERROR: unable to write runtime file: $!"; 3615 or warn "ERROR: unable to write runtime file: $!";
1582 })->(); 3616 };
1583 }, 3617 }
1584); 3618
3619 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
3620 $sig->send;
3621 }
3622 while (my $sig = shift @WAIT_FOR_TICK) {
3623 $sig->send;
3624 }
3625
3626 $LOAD = ($NOW - $tick_start) / $TICK;
3627 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
3628
3629 _post_tick;
3630};
3631$TICK_WATCHER->priority (EV::MAXPRI);
3632
3633{
3634 BDB::min_parallel 8;
3635 BDB::max_poll_time $TICK * 0.1;
3636 $BDB_POLL_WATCHER = EV::io BDB::poll_fileno, EV::READ, \&BDB::poll_cb;
3637
3638 BDB::set_sync_prepare {
3639 my $status;
3640 my $current = $Coro::current;
3641 (
3642 sub {
3643 $status = $!;
3644 $current->ready; undef $current;
3645 },
3646 sub {
3647 Coro::schedule while defined $current;
3648 $! = $status;
3649 },
3650 )
3651 };
3652
3653 unless ($DB_ENV) {
3654 $DB_ENV = BDB::db_env_create;
3655 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC
3656 | BDB::LOG_AUTOREMOVE, 1);
3657 $DB_ENV->set_timeout (30, BDB::SET_TXN_TIMEOUT);
3658 $DB_ENV->set_timeout (30, BDB::SET_LOCK_TIMEOUT);
3659
3660 cf::sync_job {
3661 eval {
3662 BDB::db_env_open
3663 $DB_ENV,
3664 $BDBDIR,
3665 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN
3666 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE,
3667 0666;
3668
3669 cf::cleanup "db_env_open($BDBDIR): $!" if $!;
3670 };
3671
3672 cf::cleanup "db_env_open(db): $@" if $@;
3673 };
3674 }
3675
3676 $BDB_DEADLOCK_WATCHER = EV::periodic 0, 3, 0, sub {
3677 BDB::db_env_lock_detect $DB_ENV, 0, BDB::LOCK_DEFAULT, 0, sub { };
3678 };
3679 $BDB_CHECKPOINT_WATCHER = EV::periodic 0, 60, 0, sub {
3680 BDB::db_env_txn_checkpoint $DB_ENV, 0, 0, 0, sub { };
3681 };
3682 $BDB_TRICKLE_WATCHER = EV::periodic 0, 10, 0, sub {
3683 BDB::db_env_memp_trickle $DB_ENV, 20, 0, sub { };
3684 };
3685}
3686
3687{
3688 IO::AIO::min_parallel 8;
3689
3690 undef $Coro::AIO::WATCHER;
3691 IO::AIO::max_poll_time $TICK * 0.1;
3692 $AIO_POLL_WATCHER = EV::io IO::AIO::poll_fileno, EV::READ, \&IO::AIO::poll_cb;
3693}
3694
3695my $_log_backtrace;
3696
3697sub _log_backtrace {
3698 my ($msg, @addr) = @_;
3699
3700 $msg =~ s/\n//;
3701
3702 # limit the # of concurrent backtraces
3703 if ($_log_backtrace < 2) {
3704 ++$_log_backtrace;
3705 async {
3706 $Coro::current->{desc} = "abt $msg";
3707
3708 my @bt = fork_call {
3709 @addr = map { sprintf "%x", $_ } @addr;
3710 my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X;
3711 open my $fh, "exec addr2line -C -f -i -e \Q$self\E @addr 2>&1 |"
3712 or die "addr2line: $!";
3713
3714 my @funcs;
3715 my @res = <$fh>;
3716 chomp for @res;
3717 while (@res) {
3718 my ($func, $line) = splice @res, 0, 2, ();
3719 push @funcs, "[$func] $line";
3720 }
3721
3722 @funcs
3723 };
3724
3725 LOG llevInfo, "[ABT] $msg\n";
3726 LOG llevInfo, "[ABT] $_\n" for @bt;
3727 --$_log_backtrace;
3728 };
3729 } else {
3730 LOG llevInfo, "[ABT] $msg\n";
3731 LOG llevInfo, "[ABT] [suppressed]\n";
3732 }
3733}
3734
3735# load additional modules
3736use cf::pod;
3737
3738END { cf::emergency_save }
1585 3739
15861 37401
1587 3741

Diff Legend

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