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

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines