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

Diff Legend

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