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.63 by root, Fri Sep 8 17:41:41 2006 UTC vs.
Revision 1.396 by root, Wed Nov 14 08:09:46 2007 UTC

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

Diff Legend

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