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

Diff Legend

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