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.12 by root, Tue Mar 28 16:48:11 2006 UTC vs.
Revision 1.375 by root, Sun Sep 30 20:22:21 2007 UTC

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

Diff Legend

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