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.28 by root, Sun Jul 30 17:42:14 2006 UTC vs.
Revision 1.321 by root, Thu Jul 26 21:44:43 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->in_memory (cf::MAP_IN_MEMORY);
253 $k =~ s/\//::/g; 1927 }
254 1928
255 if (my $cb = $k->can ("unload_module")) { 1929 $self->post_load;
1930}
1931
1932sub customise_for {
1933 my ($self, $ob) = @_;
1934
1935 return find "~" . $ob->name . "/" . $self->{path}
1936 if $self->per_player;
1937
1938# return find "?party/" . $ob->name . "/" . $self->{path}
1939# if $self->per_party;
1940
1941 $self
1942}
1943
1944# find and load all maps in the 3x3 area around a map
1945sub load_diag {
1946 my ($map) = @_;
1947
1948 my @diag; # diagonal neighbours
1949
1950 for (0 .. 3) {
1951 my $neigh = $map->tile_path ($_)
1952 or next;
1953 $neigh = find $neigh, $map
1954 or next;
1955 $neigh->load;
1956
1957 push @diag, [$neigh->tile_path (($_ + 3) % 4), $neigh],
1958 [$neigh->tile_path (($_ + 1) % 4), $neigh];
1959 }
1960
1961 for (@diag) {
1962 my $neigh = find @$_
1963 or next;
1964 $neigh->load;
1965 }
1966}
1967
1968sub find_sync {
1969 my ($path, $origin) = @_;
1970
1971 cf::sync_job { find $path, $origin }
1972}
1973
1974sub do_load_sync {
1975 my ($map) = @_;
1976
1977 cf::sync_job { $map->load };
1978}
1979
1980our %MAP_PREFETCH;
1981our $MAP_PREFETCHER = undef;
1982
1983sub find_async {
1984 my ($path, $origin) = @_;
1985
1986 $path = normalise $path, $origin && $origin->{path};
1987
1988 if (my $map = $cf::MAP{$path}) {
1989 return $map if $map->in_memory == cf::MAP_IN_MEMORY;
1990 }
1991
1992 undef $MAP_PREFETCH{$path};
1993 $MAP_PREFETCHER ||= cf::async {
1994 while (%MAP_PREFETCH) {
1995 for my $path (keys %MAP_PREFETCH) {
1996 if (my $map = find $path) {
256 $cb->(); 1997 $map->load;
257 } 1998 }
258 1999
259 Symbol::delete_package $k; 2000 delete $MAP_PREFETCH{$path};
260 } 2001 }
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 }; 2002 }
279 warn $@ if $@; 2003 undef $MAP_PREFETCHER;
280 $who->message ($@) if $@; 2004 };
281 warn "reloaded\n"; 2005 $MAP_PREFETCHER->prio (6);
282 2006
283 $who->message ("reloaded"); 2007 ()
2008}
2009
2010sub save {
2011 my ($self) = @_;
2012
2013 my $lock = cf::lock_acquire "map_data:" . $self->path;
2014
2015 $self->{last_save} = $cf::RUNTIME;
2016
2017 return unless $self->dirty;
2018
2019 my $save = $self->save_path; utf8::encode $save;
2020 my $uniq = $self->uniq_path; utf8::encode $uniq;
2021
2022 $self->{load_path} = $save;
2023
2024 return if $self->{deny_save};
2025
2026 local $self->{last_access} = $self->last_access;#d#
2027
2028 cf::async {
2029 $_->contr->save for $self->players;
2030 };
2031
2032 if ($uniq) {
2033 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS);
2034 $self->_save_objects ($uniq, cf::IO_UNIQUES);
284 } else { 2035 } else {
285 $who->message ("Intruder Alert!"); 2036 $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
294$JSON::Syck::ImplicitUnicode = 1;
295
296sub from_json($) {
297 JSON::Syck::Load $_[0]
298}
299
300sub to_json($) {
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 2037 }
324} 2038}
325 2039
326############################################################################# 2040sub swap_out {
327# load/save/clean perl data associated with a map
328
329*on_mapclean = sub {
330 my ($map) = @_; 2041 my ($self) = @_;
331 2042
332 my $path = $map->tmpname; 2043 # save first because save cedes
333 defined $path or return; 2044 $self->save;
334 2045
335 unlink "$path.cfperl"; 2046 my $lock = cf::lock_acquire "map_data:" . $self->path;
336};
337 2047
338*on_mapin = 2048 return if $self->players;
339*on_mapload = sub { 2049 return if $self->in_memory != cf::MAP_IN_MEMORY;
2050 return if $self->{deny_save};
2051
2052 $self->clear;
2053 $self->in_memory (cf::MAP_SWAPPED);
2054}
2055
2056sub reset_at {
340 my ($map) = @_; 2057 my ($self) = @_;
341 2058
342 my $path = $map->tmpname; 2059 # TODO: safety, remove and allow resettable per-player maps
343 $path = $map->path unless defined $path; 2060 return 1e99 if $self->{deny_reset};
344 2061
345 open my $fh, "<:raw", "$path.cfperl" 2062 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
346 or return; # no perl data 2063 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET;
347 2064
348 my $data = Storable::thaw do { local $/; <$fh> }; 2065 $time + $to
2066}
349 2067
350 $data->{version} <= 1 2068sub should_reset {
351 or return; # too new
352
353 $map->_set_obs ($data->{obs});
354};
355
356*on_mapout = sub {
357 my ($map) = @_; 2069 my ($self) = @_;
358 2070
359 my $path = $map->tmpname; 2071 $self->reset_at <= $cf::RUNTIME
360 $path = $map->path unless defined $path; 2072}
361 2073
362 my $obs = $map->_get_obs; 2074sub reset {
2075 my ($self) = @_;
363 2076
364 if (defined $obs) { 2077 my $lock = cf::lock_acquire "map_data:$self->{path}";
365 open my $fh, ">:raw", "$path.cfperl"
366 or die "$path.cfperl: $!";
367 2078
368 stat $path; 2079 return if $self->players;
369 2080
370 print $fh Storable::nfreeze { 2081 warn "resetting map ", $self->path;
371 size => (stat _)[7],
372 time => (stat _)[9],
373 version => 1,
374 obs => $obs,
375 };
376 2082
377 chmod SAVE_MODE, "$path.cfperl"; # very racy, but cf-compatible *g* 2083 $self->in_memory (cf::MAP_SWAPPED);
378 } else { 2084
379 unlink "$path.cfperl"; 2085 # need to save uniques path
2086 unless ($self->{deny_save}) {
2087 my $uniq = $self->uniq_path; utf8::encode $uniq;
2088
2089 $self->_save_objects ($uniq, cf::IO_UNIQUES)
2090 if $uniq;
2091 }
2092
2093 delete $cf::MAP{$self->path};
2094
2095 $self->clear;
2096
2097 $_->clear_links_to ($self) for values %cf::MAP;
2098
2099 $self->unlink_save;
2100 $self->destroy;
2101}
2102
2103my $nuke_counter = "aaaa";
2104
2105sub nuke {
2106 my ($self) = @_;
2107
2108 delete $cf::MAP{$self->path};
2109
2110 $self->unlink_save;
2111
2112 bless $self, "cf::map";
2113 delete $self->{deny_reset};
2114 $self->{deny_save} = 1;
2115 $self->reset_timeout (1);
2116 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));
2117
2118 $cf::MAP{$self->path} = $self;
2119
2120 $self->reset; # polite request, might not happen
2121}
2122
2123=item $maps = cf::map::tmp_maps
2124
2125Returns an arrayref with all map paths of currently instantiated and saved
2126maps. May block.
2127
2128=cut
2129
2130sub tmp_maps() {
380 } 2131 [
381}; 2132 map {
382 2133 utf8::decode $_;
383############################################################################# 2134 /\.map$/
384# load/save perl data associated with player->ob objects 2135 ? normalise $_
385 2136 : ()
386*on_player_load = sub { 2137 } @{ 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 } 2138 ]
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} 2139}
418 2140
2141=item $maps = cf::map::random_maps
2142
2143Returns an arrayref with all map paths of currently instantiated and saved
2144random maps. May block.
2145
2146=cut
2147
2148sub random_maps() {
2149 [
2150 map {
2151 utf8::decode $_;
2152 /\.map$/
2153 ? normalise "?random/$_"
2154 : ()
2155 } @{ aio_readdir $RANDOMDIR or [] }
2156 ]
2157}
2158
2159=item cf::map::unique_maps
2160
2161Returns an arrayref of paths of all shared maps that have
2162instantiated unique items. May block.
2163
2164=cut
2165
2166sub unique_maps() {
2167 [
2168 map {
2169 utf8::decode $_;
2170 /\.map$/
2171 ? normalise $_
2172 : ()
2173 } @{ aio_readdir $UNIQUEDIR or [] }
2174 ]
2175}
2176
2177package cf;
2178
2179=back
2180
2181=head3 cf::object
2182
2183=cut
2184
2185package cf::object;
2186
2187=over 4
2188
2189=item $ob->inv_recursive
2190
2191Returns the inventory of the object _and_ their inventories, recursively.
2192
2193=cut
2194
2195sub inv_recursive_;
2196sub inv_recursive_ {
2197 map { $_, inv_recursive_ $_->inv } @_
2198}
2199
2200sub inv_recursive {
2201 inv_recursive_ inv $_[0]
2202}
2203
2204package cf;
2205
2206=back
2207
2208=head3 cf::object::player
2209
2210=over 4
2211
419=item $player->reply ($npc, $msg[, $flags]) 2212=item $player_object->reply ($npc, $msg[, $flags])
420 2213
421Sends a message to the player, as if the npc C<$npc> replied. C<$npc> 2214Sends 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 2215can be C<undef>. Does the right thing when the player is currently in a
423dialogue with the given NPC character. 2216dialogue with the given NPC character.
424 2217
425=cut 2218=cut
426 2219
427# rough implementation of a future "reply" method that works 2220# rough implementation of a future "reply" method that works
428# with dialog boxes. 2221# with dialog boxes.
2222#TODO: the first argument must go, split into a $npc->reply_to ( method
429sub cf::object::player::reply($$$;$) { 2223sub cf::object::player::reply($$$;$) {
430 my ($self, $npc, $msg, $flags) = @_; 2224 my ($self, $npc, $msg, $flags) = @_;
431 2225
432 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4; 2226 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4;
433 2227
434 if ($self->{record_replies}) { 2228 if ($self->{record_replies}) {
435 push @{ $self->{record_replies} }, [$npc, $msg, $flags]; 2229 push @{ $self->{record_replies} }, [$npc, $msg, $flags];
2230
436 } else { 2231 } else {
2232 my $pl = $self->contr;
2233
2234 if ($pl->{npc_dialog} && $pl->{npc_dialog}->{id}) {
2235 my $dialog = $pl->{npc_dialog};
2236 $dialog->{pl}->ext_msg ($dialog->{id}, update => msg => $dialog->{pl}->expand_cfpod ($msg));
2237
2238 } else {
437 $msg = $npc->name . " says: $msg" if $npc; 2239 $msg = $npc->name . " says: $msg" if $npc;
438 $self->message ($msg, $flags); 2240 $self->message ($msg, $flags);
2241 }
2242 }
2243}
2244
2245=item $player_object->may ("access")
2246
2247Returns wether the given player is authorized to access resource "access"
2248(e.g. "command_wizcast").
2249
2250=cut
2251
2252sub cf::object::player::may {
2253 my ($self, $access) = @_;
2254
2255 $self->flag (cf::FLAG_WIZ) ||
2256 (ref $cf::CFG{"may_$access"}
2257 ? scalar grep $self->name eq $_, @{$cf::CFG{"may_$access"}}
2258 : $cf::CFG{"may_$access"})
2259}
2260
2261=item $player_object->enter_link
2262
2263Freezes the player and moves him/her to a special map (C<{link}>).
2264
2265The player should be reasonably safe there for short amounts of time. You
2266I<MUST> call C<leave_link> as soon as possible, though.
2267
2268Will never block.
2269
2270=item $player_object->leave_link ($map, $x, $y)
2271
2272Moves the player out of the special C<{link}> map onto the specified
2273map. If the map is not valid (or omitted), the player will be moved back
2274to the location he/she was before the call to C<enter_link>, or, if that
2275fails, to the emergency map position.
2276
2277Might block.
2278
2279=cut
2280
2281sub link_map {
2282 unless ($LINK_MAP) {
2283 $LINK_MAP = cf::map::find "{link}"
2284 or cf::cleanup "FATAL: unable to provide {link} map, exiting.";
2285 $LINK_MAP->load;
2286 }
2287
2288 $LINK_MAP
2289}
2290
2291sub cf::object::player::enter_link {
2292 my ($self) = @_;
2293
2294 $self->deactivate_recursive;
2295
2296 return if UNIVERSAL::isa $self->map, "ext::map_link";
2297
2298 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y]
2299 if $self->map && $self->map->{path} ne "{link}";
2300
2301 $self->enter_map ($LINK_MAP || link_map, 10, 10);
2302}
2303
2304sub cf::object::player::leave_link {
2305 my ($self, $map, $x, $y) = @_;
2306
2307 return unless $self->contr->active;
2308
2309 my $link_pos = delete $self->{_link_pos};
2310
2311 unless ($map) {
2312 # restore original map position
2313 ($map, $x, $y) = @{ $link_pos || [] };
2314 $map = cf::map::find $map;
2315
2316 unless ($map) {
2317 ($map, $x, $y) = @$EMERGENCY_POSITION;
2318 $map = cf::map::find $map
2319 or die "FATAL: cannot load emergency map\n";
2320 }
2321 }
2322
2323 ($x, $y) = (-1, -1)
2324 unless (defined $x) && (defined $y);
2325
2326 # use -1 or undef as default coordinates, not 0, 0
2327 ($x, $y) = ($map->enter_x, $map->enter_y)
2328 if $x <=0 && $y <= 0;
2329
2330 $map->load;
2331 $map->load_diag;
2332
2333 return unless $self->contr->active;
2334 $self->activate_recursive;
2335
2336 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
2337 $self->enter_map ($map, $x, $y);
2338}
2339
2340=item $player_object->goto ($path, $x, $y[, $check->($map)[, $done->()]])
2341
2342Moves the player to the given map-path and coordinates by first freezing
2343her, loading and preparing them map, calling the provided $check callback
2344that has to return the map if sucecssful, and then unfreezes the player on
2345the new (success) or old (failed) map position. In either case, $done will
2346be called at the end of this process.
2347
2348=cut
2349
2350our $GOTOGEN;
2351
2352sub cf::object::player::goto {
2353 my ($self, $path, $x, $y, $check, $done) = @_;
2354
2355 # do generation counting so two concurrent goto's will be executed in-order
2356 my $gen = $self->{_goto_generation} = ++$GOTOGEN;
2357
2358 $self->enter_link;
2359
2360 (async {
2361 my $map = eval {
2362 my $map = cf::map::find $path;
2363
2364 if ($map) {
2365 $map = $map->customise_for ($self);
2366 $map = $check->($map) if $check && $map;
2367 } else {
2368 $self->message ("The exit to '$path' is closed", cf::NDI_UNIQUE | cf::NDI_RED);
2369 }
2370
2371 $map
2372 };
2373
2374 if ($@) {
2375 $self->message ("Something went wrong within the server, please report this incident!", cf::NDI_UNIQUE | cf::NDI_RED);
2376 LOG llevError | logBacktrace, Carp::longmess $@;
2377 }
2378
2379 if ($gen == $self->{_goto_generation}) {
2380 delete $self->{_goto_generation};
2381 $self->leave_link ($map, $x, $y);
2382 }
2383
2384 $done->() if $done;
2385 })->prio (1);
2386}
2387
2388=item $player_object->enter_exit ($exit_object)
2389
2390=cut
2391
2392sub parse_random_map_params {
2393 my ($spec) = @_;
2394
2395 my $rmp = { # defaults
2396 xsize => (cf::rndm 15, 40),
2397 ysize => (cf::rndm 15, 40),
2398 symmetry => (cf::rndm 1, cf::SYMMETRY_XY),
2399 #layout => string,
439 } 2400 };
440}
441 2401
442=item $player->ext_reply ($msgid, $msgtype, %msg) 2402 for (split /\n/, $spec) {
2403 my ($k, $v) = split /\s+/, $_, 2;
443 2404
2405 $rmp->{lc $k} = $v if (length $k) && (length $v);
2406 }
2407
2408 $rmp
2409}
2410
2411sub prepare_random_map {
2412 my ($exit) = @_;
2413
2414 my $guard = cf::lock_acquire "exit_prepare:$exit";
2415
2416 # all this does is basically replace the /! path by
2417 # a new random map path (?random/...) with a seed
2418 # that depends on the exit object
2419
2420 my $rmp = parse_random_map_params $exit->msg;
2421
2422 if ($exit->map) {
2423 $rmp->{region} = $exit->region->name;
2424 $rmp->{origin_map} = $exit->map->path;
2425 $rmp->{origin_x} = $exit->x;
2426 $rmp->{origin_y} = $exit->y;
2427 }
2428
2429 $rmp->{random_seed} ||= $exit->random_seed;
2430
2431 my $data = cf::to_json $rmp;
2432 my $md5 = Digest::MD5::md5_hex $data;
2433 my $meta = "$RANDOMDIR/$md5.meta";
2434
2435 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) {
2436 aio_write $fh, 0, (length $data), $data, 0;
2437 undef $fh;
2438 aio_rename "$meta~", $meta;
2439
2440 $exit->slaying ("?random/$md5");
2441 $exit->msg (undef);
2442 }
2443}
2444
2445sub cf::object::player::enter_exit {
2446 my ($self, $exit) = @_;
2447
2448 return unless $self->type == cf::PLAYER;
2449
2450 if ($exit->slaying eq "/!") {
2451 #TODO: this should de-fi-ni-te-ly not be a sync-job
2452 # the problem is that $exit might not survive long enough
2453 # so it needs to be done right now, right here
2454 cf::sync_job { prepare_random_map $exit };
2455 }
2456
2457 my $slaying = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path;
2458 my $hp = $exit->stats->hp;
2459 my $sp = $exit->stats->sp;
2460
2461 $self->enter_link;
2462
2463 # if exit is damned, update players death & WoR home-position
2464 $self->contr->savebed ($slaying, $hp, $sp)
2465 if $exit->flag (FLAG_DAMNED);
2466
2467 (async {
2468 $self->deactivate_recursive; # just to be sure
2469 unless (eval {
2470 $self->goto ($slaying, $hp, $sp);
2471
2472 1;
2473 }) {
2474 $self->message ("Something went wrong deep within the crossfire server. "
2475 . "I'll try to bring you back to the map you were before. "
2476 . "Please report this to the dungeon master!",
2477 cf::NDI_UNIQUE | cf::NDI_RED);
2478
2479 warn "ERROR in enter_exit: $@";
2480 $self->leave_link;
2481 }
2482 })->prio (1);
2483}
2484
2485=head3 cf::client
2486
2487=over 4
2488
2489=item $client->send_drawinfo ($text, $flags)
2490
2491Sends a drawinfo packet to the client. Circumvents output buffering so
2492should not be used under normal circumstances.
2493
2494=cut
2495
2496sub cf::client::send_drawinfo {
2497 my ($self, $text, $flags) = @_;
2498
2499 utf8::encode $text;
2500 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);
2501}
2502
2503=item $client->send_msg ($channel, $msg, $color, [extra...])
2504
2505Send a drawinfo or msg packet to the client, formatting the msg for the
2506client if neccessary. C<$type> should be a string identifying the type of
2507the message, with C<log> being the default. If C<$color> is negative, suppress
2508the message unless the client supports the msg packet.
2509
2510=cut
2511
2512sub cf::client::send_msg {
2513 my ($self, $channel, $msg, $color, @extra) = @_;
2514
2515 $msg = $self->pl->expand_cfpod ($msg);
2516
2517 $color &= ~cf::NDI_UNIQUE; # just in case...
2518
2519 if (ref $channel) {
2520 # send meta info to client, if not yet sent
2521 unless (exists $self->{channel}{$channel->{id}}) {
2522 $self->{channel}{$channel->{id}} = $channel;
2523 $self->ext_msg (channel_info => $channel);
2524 }
2525
2526 $channel = $channel->{id};
2527 }
2528
2529 return unless @extra || length $msg;
2530
2531 if ($self->can_msg) {
2532 $self->send_packet ("msg " . $self->{json_coder}->encode ([$color, $channel, $msg, @extra]));
2533 } else {
2534 # replace some tags by gcfclient-compatible ones
2535 for ($msg) {
2536 1 while
2537 s/<b>([^<]*)<\/b>/[b]${1}[\/b]/
2538 || s/<i>([^<]*)<\/i>/[i]${1}[\/i]/
2539 || s/<u>([^<]*)<\/u>/[ul]${1}[\/ul]/
2540 || s/<tt>([^<]*)<\/tt>/[fixed]${1}[\/fixed]/
2541 || s/<fg name=\"([^"]+)\">([^<]*)<\/fg>/[color=$1]${2}[\/color]/;
2542 }
2543
2544 if ($color >= 0) {
2545 if (0 && $msg =~ /\[/) {
2546 $self->send_packet ("drawextinfo $color 4 0 $msg")
2547 } else {
2548 $msg =~ s/\[\/?(?:b|i|u|fixed|color)[^\]]*\]//g;
2549 $self->send_packet ("drawinfo $color $msg")
2550 }
2551 }
2552 }
2553}
2554
2555=item $client->ext_msg ($type, @msg)
2556
444Sends an ext reply to the player. 2557Sends an ext event to the client.
445 2558
446=cut 2559=cut
447 2560
448sub cf::player::ext_reply($$$%) { 2561sub cf::client::ext_msg($$@) {
449 my ($self, $id, %msg) = @_; 2562 my ($self, $type, @msg) = @_;
450 2563
451 $msg{msgid} = $id; 2564 my $extcmd = $self->extcmd;
452 2565
453 $self->send ("ext " . to_json \%msg); 2566 if ($extcmd == 2) {
2567 $self->send_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
2568 } elsif ($extcmd == 1) { # TODO: remove
2569 push @msg, msgtype => "event_$type";
2570 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2571 }
454} 2572}
455 2573
456############################################################################# 2574=item $success = $client->query ($flags, "text", \&cb)
457# map scripting support
458 2575
2576Queues a query to the client, calling the given callback with
2577the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>,
2578C<cf::CS_QUERY_SINGLECHAR> or C<cf::CS_QUERY_HIDEINPUT> or C<0>.
2579
2580Queries can fail, so check the return code. Or don't, as queries will
2581become reliable at some point in the future.
2582
2583=cut
2584
2585sub cf::client::query {
2586 my ($self, $flags, $text, $cb) = @_;
2587
2588 return unless $self->state == ST_PLAYING
2589 || $self->state == ST_SETUP
2590 || $self->state == ST_CUSTOM;
2591
2592 $self->state (ST_CUSTOM);
2593
2594 utf8::encode $text;
2595 push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb];
2596
2597 $self->send_packet ($self->{query_queue}[0][0])
2598 if @{ $self->{query_queue} } == 1;
2599
2600 1
2601}
2602
2603cf::client->attach (
2604 on_connect => sub {
2605 my ($ns) = @_;
2606
2607 $ns->{json_coder} = JSON::XS->new->utf8->max_size (1e6)->convert_blessed;
2608 },
2609 on_reply => sub {
2610 my ($ns, $msg) = @_;
2611
2612 # this weird shuffling is so that direct followup queries
2613 # get handled first
2614 my $queue = delete $ns->{query_queue}
2615 or return; # be conservative, not sure how that can happen, but we saw a crash here
2616
2617 (shift @$queue)->[1]->($msg);
2618 return unless $ns->valid; # temporary(?) workaround for callback destroying socket
2619
2620 push @{ $ns->{query_queue} }, @$queue;
2621
2622 if (@{ $ns->{query_queue} } == @$queue) {
2623 if (@$queue) {
2624 $ns->send_packet ($ns->{query_queue}[0][0]);
2625 } else {
2626 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM;
2627 }
2628 }
2629 },
2630 on_exticmd => sub {
2631 my ($ns, $buf) = @_;
2632
2633 my $msg = eval { $ns->{json_coder}->decode ($buf) };
2634
2635 if (ref $msg) {
2636 my ($type, $reply, @payload) =
2637 "ARRAY" eq ref $msg
2638 ? @$msg
2639 : ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
2640
2641 if (my $cb = $EXTICMD{$type}) {
2642 my @reply = $cb->($ns, @payload);
2643
2644 $ns->ext_reply ($reply, @reply)
2645 if $reply;
2646 }
2647 } else {
2648 warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";
2649 }
2650
2651 cf::override;
2652 },
2653);
2654
2655=item $client->async (\&cb)
2656
2657Create a new coroutine, running the specified callback. The coroutine will
2658be automatically cancelled when the client gets destroyed (e.g. on logout,
2659or loss of connection).
2660
2661=cut
2662
2663sub cf::client::async {
2664 my ($self, $cb) = @_;
2665
2666 my $coro = &Coro::async ($cb);
2667
2668 $coro->on_destroy (sub {
2669 delete $self->{_coro}{$coro+0};
2670 });
2671
2672 $self->{_coro}{$coro+0} = $coro;
2673
2674 $coro
2675}
2676
2677cf::client->attach (
2678 on_destroy => sub {
2679 my ($ns) = @_;
2680
2681 $_->cancel for values %{ (delete $ns->{_coro}) || {} };
2682 },
2683);
2684
2685=back
2686
2687
2688=head2 SAFE SCRIPTING
2689
2690Functions that provide a safe environment to compile and execute
2691snippets of perl code without them endangering the safety of the server
2692itself. Looping constructs, I/O operators and other built-in functionality
2693is not available in the safe scripting environment, and the number of
2694functions and methods that can be called is greatly reduced.
2695
2696=cut
2697
459our $safe = new Safe "ext"; 2698our $safe = new Safe "safe";
460our $safe_hole = new Safe::Hole; 2699our $safe_hole = new Safe::Hole;
461 2700
462$SIG{FPE} = 'IGNORE'; 2701$SIG{FPE} = 'IGNORE';
463 2702
464$safe->permit_only (Opcode::opset qw(:base_core :base_mem :base_orig :base_math sort time)); 2703$safe->permit_only (Opcode::opset qw(:base_core :base_mem :base_orig :base_math sort time));
465 2704
466# here we export the classes and methods available to script code 2705# here we export the classes and methods available to script code
467 2706
2707=pod
2708
2709The following functions and methods are available within a safe environment:
2710
2711 cf::object
2712 contr pay_amount pay_player map x y force_find force_add
2713 insert remove
2714
2715 cf::object::player
2716 player
2717
2718 cf::player
2719 peaceful
2720
2721 cf::map
2722 trigger
2723
2724=cut
2725
468for ( 2726for (
469 ["cf::object" => qw(contr pay_amount pay_player)], 2727 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y
2728 insert remove)],
470 ["cf::object::player" => qw(player)], 2729 ["cf::object::player" => qw(player)],
471 ["cf::player" => qw(peaceful)], 2730 ["cf::player" => qw(peaceful)],
2731 ["cf::map" => qw(trigger)],
472) { 2732) {
473 no strict 'refs'; 2733 no strict 'refs';
474 my ($pkg, @funs) = @$_; 2734 my ($pkg, @funs) = @$_;
475 *{"ext::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"}) 2735 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})
476 for @funs; 2736 for @funs;
477} 2737}
2738
2739=over 4
2740
2741=item @retval = safe_eval $code, [var => value, ...]
2742
2743Compiled and executes the given perl code snippet. additional var/value
2744pairs result in temporary local (my) scalar variables of the given name
2745that are available in the code snippet. Example:
2746
2747 my $five = safe_eval '$first + $second', first => 1, second => 4;
2748
2749=cut
478 2750
479sub safe_eval($;@) { 2751sub safe_eval($;@) {
480 my ($code, %vars) = @_; 2752 my ($code, %vars) = @_;
481 2753
482 my $qcode = $code; 2754 my $qcode = $code;
483 $qcode =~ s/"/‟/g; # not allowed in #line filenames 2755 $qcode =~ s/"/‟/g; # not allowed in #line filenames
484 $qcode =~ s/\n/\\n/g; 2756 $qcode =~ s/\n/\\n/g;
485 2757
486 local $_; 2758 local $_;
487 local @ext::cf::_safe_eval_args = values %vars; 2759 local @safe::cf::_safe_eval_args = values %vars;
488 2760
489 $code = 2761 my $eval =
490 "do {\n" 2762 "do {\n"
491 . "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n" 2763 . "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n"
492 . "#line 0 \"{$qcode}\"\n" 2764 . "#line 0 \"{$qcode}\"\n"
493 . $code 2765 . $code
494 . "\n}" 2766 . "\n}"
495 ; 2767 ;
496 2768
497 sub_generation_inc; 2769 sub_generation_inc;
498 my @res = wantarray ? $safe->reval ($code) : scalar $safe->reval ($code); 2770 my @res = wantarray ? $safe->reval ($eval) : scalar $safe->reval ($eval);
499 sub_generation_inc; 2771 sub_generation_inc;
500 2772
2773 if ($@) {
2774 warn "$@";
2775 warn "while executing safe code '$code'\n";
2776 warn "with arguments " . (join " ", %vars) . "\n";
2777 }
2778
501 wantarray ? @res : $res[0] 2779 wantarray ? @res : $res[0]
502} 2780}
2781
2782=item cf::register_script_function $function => $cb
2783
2784Register a function that can be called from within map/npc scripts. The
2785function should be reasonably secure and should be put into a package name
2786like the extension.
2787
2788Example: register a function that gets called whenever a map script calls
2789C<rent::overview>, as used by the C<rent> extension.
2790
2791 cf::register_script_function "rent::overview" => sub {
2792 ...
2793 };
2794
2795=cut
503 2796
504sub register_script_function { 2797sub register_script_function {
505 my ($fun, $cb) = @_; 2798 my ($fun, $cb) = @_;
506 2799
507 no strict 'refs'; 2800 no strict 'refs';
508 *{"ext::$fun"} = $safe_hole->wrap ($cb); 2801 *{"safe::$fun"} = $safe_hole->wrap ($cb);
509} 2802}
2803
2804=back
2805
2806=cut
510 2807
511############################################################################# 2808#############################################################################
512# initialisation 2809# the server's init and main functions
513 2810
514register "<global>", __PACKAGE__; 2811sub load_facedata($) {
2812 my ($path) = @_;
2813
2814 warn "loading facedata from $path\n";
2815
2816 my $facedata;
2817 0 < aio_load $path, $facedata
2818 or die "$path: $!";
2819
2820 $facedata = Coro::Storable::thaw $facedata;
2821
2822 $facedata->{version} == 2
2823 or cf::cleanup "$path: version mismatch, cannot proceed.";
2824
2825 {
2826 my $faces = $facedata->{faceinfo};
2827
2828 while (my ($face, $info) = each %$faces) {
2829 my $idx = (cf::face::find $face) || cf::face::alloc $face;
2830 cf::face::set_visibility $idx, $info->{visibility};
2831 cf::face::set_magicmap $idx, $info->{magicmap};
2832 cf::face::set_data $idx, 0, $info->{data32}, $info->{chksum32};
2833 cf::face::set_data $idx, 1, $info->{data64}, $info->{chksum64};
2834
2835 cf::cede_to_tick;
2836 }
2837
2838 while (my ($face, $info) = each %$faces) {
2839 next unless $info->{smooth};
2840 my $idx = cf::face::find $face
2841 or next;
2842 if (my $smooth = cf::face::find $info->{smooth}) {
2843 cf::face::set_smooth $idx, $smooth;
2844 cf::face::set_smoothlevel $idx, $info->{smoothlevel};
2845 } else {
2846 warn "smooth face '$info->{smooth}' not found for face '$face'";
2847 }
2848
2849 cf::cede_to_tick;
2850 }
2851 }
2852
2853 {
2854 my $anims = $facedata->{animinfo};
2855
2856 while (my ($anim, $info) = each %$anims) {
2857 cf::anim::set $anim, $info->{frames}, $info->{facings};
2858 cf::cede_to_tick;
2859 }
2860
2861 cf::anim::invalidate_all; # d'oh
2862 }
2863
2864 {
2865 # TODO: for gcfclient pleasure, we should give resources
2866 # that gcfclient doesn't grok a >10000 face index.
2867 my $res = $facedata->{resource};
2868 my $enc = JSON::XS->new->utf8->canonical;
2869
2870 my $soundconf = delete $res->{"res/sound.conf"};
2871
2872 while (my ($name, $info) = each %$res) {
2873 my $meta = $enc->encode ({
2874 name => $name,
2875 %{ $info->{meta} || {} },
2876 });
2877
2878 my $idx = (cf::face::find $name) || cf::face::alloc $name;
2879
2880 if ($info->{type} & 1) {
2881 # prepend meta info
2882
2883 my $data = pack "(w/a*)*", $meta, $info->{data};
2884 my $chk = Digest::MD5::md5 "$info->{chksum},$meta"; # mangle data checksum and metadata
2885
2886 cf::face::set_data $idx, 0, $data, $chk;
2887 } else {
2888 cf::face::set_data $idx, 0, $info->{data}, $info->{chksum};
2889 }
2890
2891 cf::face::set_type $idx, $info->{type};
2892
2893 cf::cede_to_tick;
2894 }
2895
2896 if ($soundconf) {
2897 $soundconf = $enc->decode (delete $soundconf->{data});
2898
2899 for (0 .. SOUND_CAST_SPELL_0 - 1) {
2900 my $sound = $soundconf->{compat}[$_]
2901 or next;
2902
2903 my $face = cf::face::find "sound/$sound->[1]";
2904 warn "$sound->[0]: $face\n";#d#
2905
2906 cf::sound::set $sound->[0] => $face;
2907 cf::sound::old_sound_index $_, $face; # gcfclient-compat
2908 }
2909
2910 #TODO
2911 }
2912 }
2913
2914 1
2915}
2916
2917register_exticmd fx_want => sub {
2918 my ($ns, $want) = @_;
2919
2920 while (my ($k, $v) = each %$want) {
2921 $ns->fx_want ($k, $v);
2922 }
2923};
2924
2925sub reload_regions {
2926 load_resource_file "$MAPDIR/regions"
2927 or die "unable to load regions file\n";
2928
2929 for (cf::region::list) {
2930 $_->{match} = qr/$_->{match}/
2931 if exists $_->{match};
2932 }
2933}
2934
2935sub reload_facedata {
2936 load_facedata "$DATADIR/facedata"
2937 or die "unable to load facedata\n";
2938}
2939
2940sub reload_archetypes {
2941 load_resource_file "$DATADIR/archetypes"
2942 or die "unable to load archetypes\n";
2943 #d# NEED to laod twice to resolve forward references
2944 # this really needs to be done in an extra post-pass
2945 # (which needs to be synchronous, so solve it differently)
2946 load_resource_file "$DATADIR/archetypes"
2947 or die "unable to load archetypes\n";
2948}
2949
2950sub reload_treasures {
2951 load_resource_file "$DATADIR/treasures"
2952 or die "unable to load treasurelists\n";
2953}
2954
2955sub reload_resources {
2956 warn "reloading resource files...\n";
2957
2958 reload_regions;
2959 reload_facedata;
2960 #reload_archetypes;#d#
2961 reload_archetypes;
2962 reload_treasures;
2963
2964 warn "finished reloading resource files\n";
2965}
2966
2967sub init {
2968 reload_resources;
2969}
2970
2971sub cfg_load {
2972 open my $fh, "<:utf8", "$CONFDIR/config"
2973 or return;
2974
2975 local $/;
2976 *CFG = YAML::Syck::Load <$fh>;
2977
2978 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37];
2979
2980 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset};
2981 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset};
2982
2983 if (exists $CFG{mlockall}) {
2984 eval {
2985 $CFG{mlockall} ? eval "mlockall()" : eval "munlockall()"
2986 and die "WARNING: m(un)lockall failed: $!\n";
2987 };
2988 warn $@ if $@;
2989 }
2990}
2991
2992sub main {
2993 # we must not ever block the main coroutine
2994 local $Coro::idle = sub {
2995 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
2996 (async {
2997 Event::one_event;
2998 })->prio (Coro::PRIO_MAX);
2999 };
3000
3001 cfg_load;
3002 db_init;
3003 load_extensions;
3004
3005 $TICK_WATCHER->start;
3006 Event::loop;
3007}
3008
3009#############################################################################
3010# initialisation and cleanup
3011
3012# install some emergency cleanup handlers
3013BEGIN {
3014 for my $signal (qw(INT HUP TERM)) {
3015 Event->signal (
3016 reentrant => 0,
3017 data => WF_AUTOCANCEL,
3018 signal => $signal,
3019 prio => 0,
3020 cb => sub {
3021 cf::cleanup "SIG$signal";
3022 },
3023 );
3024 }
3025}
3026
3027sub write_runtime {
3028 my $runtime = "$LOCALDIR/runtime";
3029
3030 # first touch the runtime file to show we are still running:
3031 # the fsync below can take a very very long time.
3032
3033 IO::AIO::aio_utime $runtime, undef, undef;
3034
3035 my $guard = cf::lock_acquire "write_runtime";
3036
3037 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644
3038 or return;
3039
3040 my $value = $cf::RUNTIME + 90 + 10;
3041 # 10 is the runtime save interval, for a monotonic clock
3042 # 60 allows for the watchdog to kill the server.
3043
3044 (aio_write $fh, 0, (length $value), $value, 0) <= 0
3045 and return;
3046
3047 # always fsync - this file is important
3048 aio_fsync $fh
3049 and return;
3050
3051 # touch it again to show we are up-to-date
3052 aio_utime $fh, undef, undef;
3053
3054 close $fh
3055 or return;
3056
3057 aio_rename "$runtime~", $runtime
3058 and return;
3059
3060 warn "runtime file written.\n";
3061
3062 1
3063}
3064
3065sub emergency_save() {
3066 my $freeze_guard = cf::freeze_mainloop;
3067
3068 warn "enter emergency perl save\n";
3069
3070 cf::sync_job {
3071 # use a peculiar iteration method to avoid tripping on perl
3072 # refcount bugs in for. also avoids problems with players
3073 # and maps saved/destroyed asynchronously.
3074 warn "begin emergency player save\n";
3075 for my $login (keys %cf::PLAYER) {
3076 my $pl = $cf::PLAYER{$login} or next;
3077 $pl->valid or next;
3078 $pl->save;
3079 }
3080 warn "end emergency player save\n";
3081
3082 warn "begin emergency map save\n";
3083 for my $path (keys %cf::MAP) {
3084 my $map = $cf::MAP{$path} or next;
3085 $map->valid or next;
3086 $map->save;
3087 }
3088 warn "end emergency map save\n";
3089
3090 warn "begin emergency database checkpoint\n";
3091 BDB::db_env_txn_checkpoint $DB_ENV;
3092 warn "end emergency database checkpoint\n";
3093 };
3094
3095 warn "leave emergency perl save\n";
3096}
3097
3098sub post_cleanup {
3099 my ($make_core) = @_;
3100
3101 warn Carp::longmess "post_cleanup backtrace"
3102 if $make_core;
3103}
3104
3105sub do_reload_perl() {
3106 # can/must only be called in main
3107 if ($Coro::current != $Coro::main) {
3108 warn "can only reload from main coroutine";
3109 return;
3110 }
3111
3112 warn "reloading...";
3113
3114 warn "entering sync_job";
3115
3116 cf::sync_job {
3117 cf::write_runtime; # external watchdog should not bark
3118 cf::emergency_save;
3119 cf::write_runtime; # external watchdog should not bark
3120
3121 warn "syncing database to disk";
3122 BDB::db_env_txn_checkpoint $DB_ENV;
3123
3124 # if anything goes wrong in here, we should simply crash as we already saved
3125
3126 warn "cancelling all WF_AUTOCANCEL watchers";
3127 for (Event::all_watchers) {
3128 $_->cancel if $_->data & WF_AUTOCANCEL;
3129 }
3130
3131 warn "flushing outstanding aio requests";
3132 for (;;) {
3133 BDB::flush;
3134 IO::AIO::flush;
3135 Coro::cede;
3136 last unless IO::AIO::nreqs || BDB::nreqs;
3137 warn "iterate...";
3138 }
3139
3140 ++$RELOAD;
3141
3142 warn "cancelling all extension coros";
3143 $_->cancel for values %EXT_CORO;
3144 %EXT_CORO = ();
3145
3146 warn "removing commands";
3147 %COMMAND = ();
3148
3149 warn "removing ext/exti commands";
3150 %EXTCMD = ();
3151 %EXTICMD = ();
3152
3153 warn "unloading/nuking all extensions";
3154 for my $pkg (@EXTS) {
3155 warn "... unloading $pkg";
3156
3157 if (my $cb = $pkg->can ("unload")) {
3158 eval {
3159 $cb->($pkg);
3160 1
3161 } or warn "$pkg unloaded, but with errors: $@";
3162 }
3163
3164 warn "... nuking $pkg";
3165 Symbol::delete_package $pkg;
3166 }
3167
3168 warn "unloading all perl modules loaded from $LIBDIR";
3169 while (my ($k, $v) = each %INC) {
3170 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
3171
3172 warn "... unloading $k";
3173 delete $INC{$k};
3174
3175 $k =~ s/\.pm$//;
3176 $k =~ s/\//::/g;
3177
3178 if (my $cb = $k->can ("unload_module")) {
3179 $cb->();
3180 }
3181
3182 Symbol::delete_package $k;
3183 }
3184
3185 warn "getting rid of safe::, as good as possible";
3186 Symbol::delete_package "safe::$_"
3187 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
3188
3189 warn "unloading cf.pm \"a bit\"";
3190 delete $INC{"cf.pm"};
3191 delete $INC{"cf/pod.pm"};
3192
3193 # don't, removes xs symbols, too,
3194 # and global variables created in xs
3195 #Symbol::delete_package __PACKAGE__;
3196
3197 warn "unload completed, starting to reload now";
3198
3199 warn "reloading cf.pm";
3200 require cf;
3201 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
3202
3203 warn "loading config and database again";
3204 cf::cfg_load;
3205
3206 warn "loading extensions";
3207 cf::load_extensions;
3208
3209 warn "reattaching attachments to objects/players";
3210 _global_reattach; # objects, sockets
3211 warn "reattaching attachments to maps";
3212 reattach $_ for values %MAP;
3213 warn "reattaching attachments to players";
3214 reattach $_ for values %PLAYER;
3215
3216 warn "leaving sync_job";
3217
3218 1
3219 } or do {
3220 warn $@;
3221 warn "error while reloading, exiting.";
3222 exit 1;
3223 };
3224
3225 warn "reloaded";
3226};
3227
3228our $RELOAD_WATCHER; # used only during reload
3229
3230sub reload_perl() {
3231 # doing reload synchronously and two reloads happen back-to-back,
3232 # coro crashes during coro_state_free->destroy here.
3233
3234 $RELOAD_WATCHER ||= Event->timer (
3235 reentrant => 0,
3236 after => 0,
3237 data => WF_AUTOCANCEL,
3238 cb => sub {
3239 do_reload_perl;
3240 undef $RELOAD_WATCHER;
3241 },
3242 );
3243}
3244
3245register_command "reload" => sub {
3246 my ($who, $arg) = @_;
3247
3248 if ($who->flag (FLAG_WIZ)) {
3249 $who->message ("reloading server.");
3250 async { reload_perl };
3251 }
3252};
515 3253
516unshift @INC, $LIBDIR; 3254unshift @INC, $LIBDIR;
517 3255
518load_extensions; 3256my $bug_warning = 0;
3257
3258our @WAIT_FOR_TICK;
3259our @WAIT_FOR_TICK_BEGIN;
3260
3261sub wait_for_tick {
3262 return unless $TICK_WATCHER->is_active;
3263 return if $Coro::current == $Coro::main;
3264
3265 my $signal = new Coro::Signal;
3266 push @WAIT_FOR_TICK, $signal;
3267 $signal->wait;
3268}
3269
3270sub wait_for_tick_begin {
3271 return unless $TICK_WATCHER->is_active;
3272 return if $Coro::current == $Coro::main;
3273
3274 my $signal = new Coro::Signal;
3275 push @WAIT_FOR_TICK_BEGIN, $signal;
3276 $signal->wait;
3277}
3278
3279 my $min = 1e6;#d#
3280 my $avg = 10;
3281$TICK_WATCHER = Event->timer (
3282 reentrant => 0,
3283 parked => 1,
3284 prio => 0,
3285 at => $NEXT_TICK || $TICK,
3286 data => WF_AUTOCANCEL,
3287 cb => sub {
3288 if ($Coro::current != $Coro::main) {
3289 Carp::cluck "major BUG: server tick called outside of main coro, skipping it"
3290 unless ++$bug_warning > 10;
3291 return;
3292 }
3293
3294 $NOW = $tick_start = Event::time;
3295
3296 cf::server_tick; # one server iteration
3297
3298 0 && sync_job {#d#
3299 for(1..10) {
3300 my $t = Event::time;
3301 my $map = my $map = new_from_path cf::map "/tmp/x.map"
3302 or die;
3303
3304 $map->width (50);
3305 $map->height (50);
3306 $map->alloc;
3307 $map->_load_objects ("/tmp/x.map", 1);
3308 my $t = Event::time - $t;
3309
3310 #next unless $t < 0.0013;#d#
3311 if ($t < $min) {
3312 $min = $t;
3313 }
3314 $avg = $avg * 0.99 + $t * 0.01;
3315 }
3316 warn "XXXXXXXXXXXXXXXXXX min $min avg $avg\n";#d#
3317 exit 0;
3318 # 2007-05-22 02:33:04.569 min 0.00112509727478027 avg 0.0012259249572477
3319 };
3320
3321 $RUNTIME += $TICK;
3322 $NEXT_TICK += $TICK;
3323
3324 if ($NOW >= $NEXT_RUNTIME_WRITE) {
3325 $NEXT_RUNTIME_WRITE = $NOW + 10;
3326 Coro::async_pool {
3327 write_runtime
3328 or warn "ERROR: unable to write runtime file: $!";
3329 };
3330 }
3331
3332# my $AFTER = Event::time;
3333# warn $AFTER - $NOW;#d#
3334
3335 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
3336 $sig->send;
3337 }
3338 while (my $sig = shift @WAIT_FOR_TICK) {
3339 $sig->send;
3340 }
3341
3342 $NOW = Event::time;
3343
3344 # if we are delayed by four ticks or more, skip them all
3345 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
3346
3347 $TICK_WATCHER->at ($NEXT_TICK);
3348 $TICK_WATCHER->start;
3349
3350 $LOAD = ($NOW - $tick_start) / $TICK;
3351 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
3352
3353 _post_tick;
3354
3355
3356 },
3357);
3358
3359{
3360 BDB::max_poll_time $TICK * 0.1;
3361 $BDB_POLL_WATCHER = Event->io (
3362 reentrant => 0,
3363 fd => BDB::poll_fileno,
3364 poll => 'r',
3365 prio => 0,
3366 data => WF_AUTOCANCEL,
3367 cb => \&BDB::poll_cb,
3368 );
3369 BDB::min_parallel 8;
3370
3371 BDB::set_sync_prepare {
3372 my $status;
3373 my $current = $Coro::current;
3374 (
3375 sub {
3376 $status = $!;
3377 $current->ready; undef $current;
3378 },
3379 sub {
3380 Coro::schedule while defined $current;
3381 $! = $status;
3382 },
3383 )
3384 };
3385
3386 unless ($DB_ENV) {
3387 $DB_ENV = BDB::db_env_create;
3388
3389 cf::sync_job {
3390 eval {
3391 BDB::db_env_open
3392 $DB_ENV,
3393 $BDBDIR,
3394 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN
3395 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE,
3396 0666;
3397
3398 cf::cleanup "db_env_open($BDBDIR): $!" if $!;
3399
3400 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC, 1);
3401 $DB_ENV->set_lk_detect;
3402 };
3403
3404 cf::cleanup "db_env_open(db): $@" if $@;
3405 };
3406 }
3407}
3408
3409{
3410 IO::AIO::min_parallel 8;
3411
3412 undef $Coro::AIO::WATCHER;
3413 IO::AIO::max_poll_time $TICK * 0.1;
3414 $AIO_POLL_WATCHER = Event->io (
3415 reentrant => 0,
3416 data => WF_AUTOCANCEL,
3417 fd => IO::AIO::poll_fileno,
3418 poll => 'r',
3419 prio => 6,
3420 cb => \&IO::AIO::poll_cb,
3421 );
3422}
3423
3424my $_log_backtrace;
3425
3426sub _log_backtrace {
3427 my ($msg, @addr) = @_;
3428
3429 $msg =~ s/\n//;
3430
3431 # limit the # of concurrent backtraces
3432 if ($_log_backtrace < 2) {
3433 ++$_log_backtrace;
3434 async {
3435 my @bt = fork_call {
3436 @addr = map { sprintf "%x", $_ } @addr;
3437 my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X;
3438 open my $fh, "exec addr2line -C -f -i -e \Q$self\E @addr 2>&1 |"
3439 or die "addr2line: $!";
3440
3441 my @funcs;
3442 my @res = <$fh>;
3443 chomp for @res;
3444 while (@res) {
3445 my ($func, $line) = splice @res, 0, 2, ();
3446 push @funcs, "[$func] $line";
3447 }
3448
3449 @funcs
3450 };
3451
3452 LOG llevInfo, "[ABT] $msg\n";
3453 LOG llevInfo, "[ABT] $_\n" for @bt;
3454 --$_log_backtrace;
3455 };
3456 } else {
3457 LOG llevInfo, "[ABT] $msg\n";
3458 LOG llevInfo, "[ABT] [suppressed]\n";
3459 }
3460}
3461
3462# load additional modules
3463use cf::pod;
3464
3465END { cf::emergency_save }
519 3466
5201 34671
521 3468

Diff Legend

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