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

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines