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.33 by root, Mon Aug 21 01:51:23 2006 UTC vs.
Revision 1.281 by root, Sat Jun 16 23:22:59 2007 UTC

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

Diff Legend

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