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.43 by root, Fri Aug 25 17:11:53 2006 UTC vs.
Revision 1.358 by root, Fri Sep 7 18:10:52 2007 UTC

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

Diff Legend

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