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.53 by root, Tue Aug 29 13:11:58 2006 UTC vs.
Revision 1.363 by root, Mon Sep 10 17:24:36 2007 UTC

1package cf; 1package cf;
2
3use utf8;
4use strict;
2 5
3use Symbol; 6use Symbol;
4use List::Util; 7use List::Util;
8use Socket;
5use Storable; 9use Storable;
10use Event;
6use Opcode; 11use Opcode;
7use Safe; 12use Safe;
8use Safe::Hole; 13use Safe::Hole;
9 14
15use Coro 3.64 ();
16use Coro::State;
17use Coro::Handle;
18use Coro::Event;
19use Coro::Timer;
20use Coro::Signal;
21use Coro::Semaphore;
22use Coro::AIO;
23use Coro::Storable;
24use Coro::Util ();
25
26use JSON::XS ();
27use BDB ();
28use Data::Dumper;
29use Digest::MD5;
30use Fcntl;
31use YAML::Syck ();
32use IO::AIO 2.32 ();
10use Time::HiRes; 33use Time::HiRes;
11use Event; 34use Compress::LZF;
35use Digest::MD5 ();
36
37# configure various modules to our taste
38#
39$Storable::canonical = 1; # reduce rsync transfers
40Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator
41Compress::LZF::sfreeze_cr { }; # prime Compress::LZF so it does not use require later
42
12$Event::Eval = 1; # no idea why this is required, but it is 43$Event::Eval = 1; # no idea why this is required, but it is
13 44
14use strict; 45# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode?
46$YAML::Syck::ImplicitUnicode = 1;
15 47
16_reload_1; 48$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority
17 49
50sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
51
18our %COMMAND = (); 52our %COMMAND = ();
53our %COMMAND_TIME = ();
54
55our @EXTS = (); # list of extension package names
56our %EXTCMD = ();
57our %EXTICMD = ();
58our %EXT_CORO = (); # coroutines bound to extensions
59our %EXT_MAP = (); # pluggable maps
60
61our $RELOAD; # number of reloads so far
19our @EVENT; 62our @EVENT;
20our %PROP_TYPE;
21our %PROP_IDX;
22our $LIBDIR = maps_directory "perl";
23 63
24our $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(!)
25our $TICK_WATCHER; 77our $TICK_WATCHER;
78our $AIO_POLL_WATCHER;
79our $NEXT_RUNTIME_WRITE; # when should the runtime file be written
26our $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;
88
89our %CFG;
90
91our $UPTIME; $UPTIME ||= time;
92our $RUNTIME;
93
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;
121
122#############################################################################
123
124=head2 GLOBAL VARIABLES
125
126=over 4
127
128=item $cf::UPTIME
129
130The timestamp of the server start (so not actually an uptime).
131
132=item $cf::RUNTIME
133
134The time this server has run, starts at 0 and is increased by $cf::TICK on
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.
149
150=item $cf::TICK
151
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.
163
164=item %cf::CFG
165
166Configuration for the server, loaded from C</etc/crossfire/config>, or
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.
180
181=back
182
183=cut
27 184
28BEGIN { 185BEGIN {
29 *CORE::GLOBAL::warn = sub { 186 *CORE::GLOBAL::warn = sub {
30 my $msg = join "", @_; 187 my $msg = join "", @_;
188
31 $msg .= "\n" 189 $msg .= "\n"
32 unless $msg =~ /\n$/; 190 unless $msg =~ /\n$/;
33 191
34 print STDERR "cfperl: $msg"; 192 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;
193
35 LOG llevError, "cfperl: $msg"; 194 LOG llevError, $msg;
36 }; 195 };
37} 196}
38 197
39my %ignore_set = (MAP_PROP_PATH => 1); # I hate the plug-in api. Deeply! 198@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
40 199@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';
41# generate property mutators 200@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable';
42sub prop_gen { 201@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable';
43 my ($prefix, $class) = @_; 202@safe::cf::map::ISA = @cf::map::ISA = 'cf::attachable';
44 203@safe::cf::arch::ISA = @cf::arch::ISA = 'cf::object';
45 no strict 'refs';
46
47 for my $prop (keys %PROP_TYPE) {
48 $prop =~ /^\Q$prefix\E_(.*$)/ or next;
49 my $sub = lc $1;
50
51 my $type = $PROP_TYPE{$prop};
52 my $idx = $PROP_IDX {$prop};
53
54 *{"$class\::get_$sub"} = *{"$class\::$sub"} = sub {
55 $_[0]->get_property ($type, $idx)
56 };
57
58 *{"$class\::set_$sub"} = sub {
59 $_[0]->set_property ($type, $idx, $_[1]);
60 } unless $ignore_set{$prop};
61 }
62}
63
64# auto-generate most of the API
65
66prop_gen OBJECT_PROP => "cf::object";
67# CFAPI_OBJECT_ANIMATION?
68prop_gen PLAYER_PROP => "cf::object::player";
69
70prop_gen MAP_PROP => "cf::map";
71prop_gen ARCH_PROP => "cf::arch";
72
73@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)
74 205
75# 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
76# within the Safe compartment. 207# within the Safe compartment.
77for 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)) {
78 no strict 'refs'; 215 no strict 'refs';
79 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg; 216 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
80} 217}
81 218
82$Event::DIED = sub { 219$Event::DIED = sub {
83 warn "error in event callback: @_"; 220 warn "error in event callback: @_";
84}; 221};
85 222
86my %ext_pkg;
87my @exts;
88my @hook;
89my %command;
90my %extcmd;
91
92############################################################################# 223#############################################################################
93# utility functions
94 224
95use JSON::Syck (); # TODO# replace by JSON::PC once working 225=head2 UTILITY FUNCTIONS
96 226
97sub from_json($) { 227=over 4
98 $JSON::Syck::ImplicitUnicode = 1; # work around JSON::Syck bugs
99 JSON::Syck::Load $_[0]
100}
101 228
102sub to_json($) { 229=item dumpval $ref
103 $JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs 230
104 JSON::Syck::Dump $_[0] 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]: '$@']";
105} 250}
251
252=item $ref = cf::from_json $json
253
254Converts a JSON string into the corresponding perl data structure.
255
256=item $json = cf::to_json $ref
257
258Converts a perl data structure into its JSON representation.
259
260=cut
261
262our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max
263
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 });
641}
642
643=back
644
645=cut
106 646
107############################################################################# 647#############################################################################
108# "new" plug-in system
109 648
110=item $object->attach ($attachment, key => $value...) 649=head2 ATTACHABLE OBJECTS
111 650
112=item $object->detach ($attachment) 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.
113 654
114Attach/detach a pre-registered attachment to an object. 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).
115 658
116=item $player->attach ($attachment, key => $value...) 659=over 4
117 660
118=item $player->detach ($attachment)
119
120Attach/detach a pre-registered attachment to a player.
121
122=item $map->attach ($attachment, key => $value...) 661=item $attachable->attach ($attachment, key => $value...)
123 662
124=item $map->detach ($attachment) 663=item $attachable->detach ($attachment)
125 664
126Attach/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.
127 667
128=item cf::attach_global ... 668Example, attach a minesweeper attachment to the given object, making it a
66910x10 minesweeper game:
129 670
130Attach handlers for global events. 671 $obj->attach (minesweeper => width => 10, height => 10);
131 672
132This and all following C<attach_*>-functions expect any number of the 673=item $bool = $attachable->attached ($name)
133following handler/hook descriptions: 674
675Checks wether the named attachment is currently attached to the object.
676
677=item cf::CLASS->attach ...
678
679=item cf::CLASS->detach ...
680
681Define an anonymous attachment and attach it to all objects of the given
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:
134 715
135=over 4 716=over 4
136 717
137=item prio => $number 718=item prio => $number
138 719
140by another C<prio> setting). Lower priority handlers get executed 721by another C<prio> setting). Lower priority handlers get executed
141earlier. 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
142registered at priority C<-1000>, so lower priorities should not be used 723registered at priority C<-1000>, so lower priorities should not be used
143unless you know what you are doing. 724unless you know what you are doing.
144 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
145=item on_I<event> => \&cb 732=item on_I<event> => \&cb
146 733
147Call the given code reference whenever the named event happens (event is 734Call the given code reference whenever the named event happens (event is
148something 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
149handlers are recognised generally depends on the type of object these 736handlers are recognised generally depends on the type of object these
158package and register them. Only handlers for eevents supported by the 745package and register them. Only handlers for eevents supported by the
159object/class are recognised. 746object/class are recognised.
160 747
161=back 748=back
162 749
163=item cf::attach_to_type $object_type, $subtype, ... 750Example, define an attachment called "sockpuppet" that calls the given
751event handler when a monster attacks:
164 752
165Attach handlers for a specific object type (e.g. TRANSPORT) and 753 cf::object::attachment sockpuppet =>
166subtype. If C<$subtype> is zero or undef, matches all objects of the given 754 on_skill_attack => sub {
167type. 755 my ($self, $victim) = @_;
756 ...
757 }
758 }
168 759
169=item cf::attach_to_objects ... 760=item $attachable->valid
170 761
171Attach handlers to all objects. Do not use this except for debugging or 762Just because you have a perl object does not mean that the corresponding
172very rare events, as handlers are (obviously) called for I<all> objects in 763C-level object still exists. If you try to access an object that has no
173the game. 764valid C counterpart anymore you get an exception at runtime. This method
174 765can be used to test for existence of the C object part without causing an
175=item cf::attach_to_players ... 766exception.
176
177Attach handlers to all players.
178
179=item cf::attach_to_maps ...
180
181Attach handlers to all maps.
182
183=item cf:register_attachment $name, ...
184
185Register an attachment by name through which objects can refer to this
186attachment.
187
188=item cf:register_map_attachment $name, ...
189
190Register an attachment by name through which maps can refer to this
191attachment.
192 767
193=cut 768=cut
194 769
195# the following variables are defined in .xs and must not be re-created 770# the following variables are defined in .xs and must not be re-created
196our @CB_GLOBAL = (); # registry for all global events 771our @CB_GLOBAL = (); # registry for all global events
772our @CB_ATTACHABLE = (); # registry for all attachables
197our @CB_OBJECT = (); # all objects (should not be used except in emergency) 773our @CB_OBJECT = (); # all objects (should not be used except in emergency)
198our @CB_PLAYER = (); 774our @CB_PLAYER = ();
775our @CB_CLIENT = ();
199our @CB_TYPE = (); # registry for type (cf-object class) based events 776our @CB_TYPE = (); # registry for type (cf-object class) based events
200our @CB_MAP = (); 777our @CB_MAP = ();
201 778
202my %attachment; 779my %attachment;
203 780
781sub cf::attachable::thawer_merge {
782 # simply override everything except _meta
783 local $_[0]{_meta};
784 %{$_[0]} = %{$_[1]};
785}
786
204sub _attach_cb($\%$$$) { 787sub _attach_cb($$$$) {
205 my ($registry, $undo, $event, $prio, $cb) = @_; 788 my ($registry, $event, $prio, $cb) = @_;
206 789
207 use sort 'stable'; 790 use sort 'stable';
208 791
209 $cb = [$prio, $cb]; 792 $cb = [$prio, $cb];
210 793
211 @{$registry->[$event]} = sort 794 @{$registry->[$event]} = sort
212 { $a->[0] cmp $b->[0] } 795 { $a->[0] cmp $b->[0] }
213 @{$registry->[$event] || []}, $cb; 796 @{$registry->[$event] || []}, $cb;
214
215 push @{$undo->{cb}}, [$event, $cb];
216} 797}
798
799# hack
800my %attachable_klass = map +($_ => 1), KLASS_OBJECT, KLASS_CLIENT, KLASS_PLAYER, KLASS_MAP;
217 801
218# attach handles attaching event callbacks 802# attach handles attaching event callbacks
219# the only thing the caller has to do is pass the correct 803# the only thing the caller has to do is pass the correct
220# registry (== where the callback attaches to). 804# registry (== where the callback attaches to).
221sub _attach(\@$@) { 805sub _attach {
222 my ($registry, $klass, @arg) = @_; 806 my ($registry, $klass, @arg) = @_;
223 807
808 my $object_type;
224 my $prio = 0; 809 my $prio = 0;
225
226 my %undo = (
227 registry => $registry,
228 cb => [],
229 );
230
231 my %cb_id = map +("on_" . lc $EVENT[$_][0], $_) , grep $EVENT[$_][1] == $klass, 0 .. $#EVENT; 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 }
232 816
233 while (@arg) { 817 while (@arg) {
234 my $type = shift @arg; 818 my $type = shift @arg;
235 819
236 if ($type eq "prio") { 820 if ($type eq "prio") {
237 $prio = shift @arg; 821 $prio = shift @arg;
238 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
239 } elsif ($type eq "package") { 832 } elsif ($type eq "package") {
240 my $pkg = shift @arg; 833 my $pkg = shift @arg;
241 834
242 while (my ($name, $id) = each %cb_id) { 835 while (my ($name, $id) = each %cb_id) {
243 if (my $cb = $pkg->can ($name)) { 836 if (my $cb = $pkg->can ($name)) {
244 _attach_cb $registry, %undo, $id, $prio, $cb; 837 _attach_cb $registry, $id, $prio, $cb;
245 } 838 }
246 } 839 }
247 840
248 } elsif (exists $cb_id{$type}) { 841 } elsif (exists $cb_id{$type}) {
249 _attach_cb $registry, %undo, $cb_id{$type}, $prio, shift @arg; 842 _attach_cb $registry, $cb_id{$type}, $prio, shift @arg;
250 843
251 } elsif (ref $type) { 844 } elsif (ref $type) {
252 warn "attaching objects not supported, ignoring.\n"; 845 warn "attaching objects not supported, ignoring.\n";
253 846
254 } else { 847 } else {
255 shift @arg; 848 shift @arg;
256 warn "attach argument '$type' not supported, ignoring.\n"; 849 warn "attach argument '$type' not supported, ignoring.\n";
257 } 850 }
258 } 851 }
259
260 \%undo
261} 852}
262 853
263sub _attach_attachment { 854sub _object_attach {
264 my ($obj, $name, %arg) = @_; 855 my ($obj, $name, %arg) = @_;
265 856
266 my $res; 857 return if exists $obj->{_attachment}{$name};
267 858
268 if (my $attach = $attachment{$name}) { 859 if (my $attach = $attachment{$name}) {
269 my $registry = $obj->registry; 860 my $registry = $obj->registry;
270 861
271 for (@$attach) { 862 for (@$attach) {
272 my ($klass, @attach) = @$_; 863 my ($klass, @attach) = @$_;
273 $res = _attach @$registry, $klass, @attach; 864 _attach $registry, $klass, @attach;
274 } 865 }
275 866
276 $obj->{$name} = \%arg; 867 $obj->{$name} = \%arg;
277 } else { 868 } else {
278 warn "object uses attachment '$name' that is not available, postponing.\n"; 869 warn "object uses attachment '$name' which is not available, postponing.\n";
279 } 870 }
280 871
281 $obj->{_attachment}{$name} = undef; 872 $obj->{_attachment}{$name} = undef;
282
283 $res->{attachment} = $name;
284 $res
285} 873}
286 874
287sub cf::object::attach { 875sub cf::attachable::attach {
288 my ($obj, $name, %arg) = @_; 876 if (ref $_[0]) {
877 _object_attach @_;
878 } else {
879 _attach shift->_attach_registry, @_;
880 }
881 _recalc_want;
882};
289 883
290 _attach_attachment $obj, $name, %arg; 884# all those should be optimised
291}
292
293sub cf::player::attach {
294 my ($obj, $name, %arg) = @_;
295
296 _attach_attachment $obj, $name, %arg;
297}
298
299sub cf::map::attach {
300 my ($obj, $name, %arg) = @_;
301
302 _attach_attachment $obj, $name, %arg;
303}
304
305sub cf::object::detach { 885sub cf::attachable::detach {
306 my ($obj, $name) = @_; 886 my ($obj, $name) = @_;
307 die;#d# 887
308} 888 if (ref $obj) {
309sub cf::player::detach { 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 {
310 my ($obj, $name) = @_; 898 my ($obj, $name) = @_;
311 die;#d#
312}
313sub cf::map::detach {
314 my ($obj, $name) = @_;
315 die;#d#
316}
317 899
318sub attach_global { 900 exists $obj->{_attachment}{$name}
319 _attach @CB_GLOBAL, KLASS_GLOBAL, @_
320} 901}
321 902
322sub attach_to_type { 903for my $klass (qw(ATTACHABLE GLOBAL OBJECT PLAYER CLIENT MAP)) {
323 my $type = shift; 904 eval "#line " . __LINE__ . " 'cf.pm'
324 my $subtype = shift; 905 sub cf::\L$klass\E::_attach_registry {
906 (\\\@CB_$klass, KLASS_$klass)
907 }
325 908
326 _attach @{$CB_TYPE[$type + $subtype * NUM_SUBTYPES]}, KLASS_OBJECT, @_ 909 sub cf::\L$klass\E::attachment {
327}
328
329sub attach_to_objects {
330 _attach @CB_OBJECT, KLASS_OBJECT, @_
331}
332
333sub attach_to_players {
334 _attach @CB_PLAYER, KLASS_PLAYER, @_
335}
336
337sub attach_to_maps {
338 _attach @CB_MAP, KLASS_MAP, @_
339}
340
341sub register_attachment {
342 my $name = shift; 910 my \$name = shift;
343 911
344 $attachment{$name} = [[KLASS_OBJECT, @_]];
345}
346
347sub register_map_attachment {
348 my $name = shift;
349
350 $attachment{$name} = [[KLASS_MAP, @_]]; 912 \$attachment{\$name} = [[KLASS_$klass, \@_]];
913 }
914 ";
915 die if $@;
351} 916}
352 917
353our $override; 918our $override;
354our @invoke_results = (); # referenced from .xs code. TODO: play tricks with reify and mortals? 919our @INVOKE_RESULTS = (); # referenced from .xs code. TODO: play tricks with reify and mortals?
355 920
356sub override { 921sub override {
357 $override = 1; 922 $override = 1;
358 @invoke_results = (); 923 @INVOKE_RESULTS = (@_);
359} 924}
360 925
361sub do_invoke { 926sub do_invoke {
362 my $event = shift; 927 my $event = shift;
363 my $callbacks = shift; 928 my $callbacks = shift;
364 929
365 @invoke_results = (); 930 @INVOKE_RESULTS = ();
366 931
367 local $override; 932 local $override;
368 933
369 for (@$callbacks) { 934 for (@$callbacks) {
370 eval { &{$_->[1]} }; 935 eval { &{$_->[1]} };
371 936
372 if ($@) { 937 if ($@) {
373 warn "$@"; 938 warn "$@";
374 warn "... while processing $EVENT[$event][0] event, skipping processing altogether.\n"; 939 warn "... while processing $EVENT[$event][0](@_) event, skipping processing altogether.\n";
375 override; 940 override;
376 } 941 }
377 942
378 return 1 if $override; 943 return 1 if $override;
379 } 944 }
380 945
381 0 946 0
382} 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
959=back
960
961=cut
383 962
384############################################################################# 963#############################################################################
385# object support 964# object support
965#
386 966
387sub instantiate { 967sub _can_merge {
388 my ($obj, $data) = @_; 968 my ($ob1, $ob2) = @_;
389 969
390 $data = from_json $data; 970 local $Storable::canonical = 1;
971 my $fob1 = Storable::freeze $ob1;
972 my $fob2 = Storable::freeze $ob2;
391 973
392 for (@$data) { 974 $fob1 eq $fob2
393 my ($name, $args) = @$_;
394
395 $obj->attach ($name, %{$args || {} });
396 }
397} 975}
398 976
399# basically do the same as instantiate, without calling instantiate
400sub reattach { 977sub reattach {
978 # basically do the same as instantiate, without calling instantiate
401 my ($obj) = @_; 979 my ($obj) = @_;
980
981 bless $obj, ref $obj; # re-bless in case extensions have been reloaded
982
402 my $registry = $obj->registry; 983 my $registry = $obj->registry;
403 984
404 @$registry = (); 985 @$registry = ();
405 986
406 delete $obj->{_attachment} unless scalar keys %{ $obj->{_attachment} || {} }; 987 delete $obj->{_attachment} unless scalar keys %{ $obj->{_attachment} || {} };
407 988
408 for my $name (keys %{ $obj->{_attachment} || {} }) { 989 for my $name (keys %{ $obj->{_attachment} || {} }) {
409 if (my $attach = $attachment{$name}) { 990 if (my $attach = $attachment{$name}) {
410 for (@$attach) { 991 for (@$attach) {
411 my ($klass, @attach) = @$_; 992 my ($klass, @attach) = @$_;
412 _attach @$registry, $klass, @attach; 993 _attach $registry, $klass, @attach;
413 } 994 }
414 } else { 995 } else {
415 warn "object uses attachment '$name' that is not available, postponing.\n"; 996 warn "object uses attachment '$name' that is not available, postponing.\n";
416 } 997 }
417 } 998 }
418} 999}
419 1000
420sub object_freezer_save { 1001cf::attachable->attach (
421 my ($filename, $objs) = @_;
422
423 if (@$objs) {
424 open my $fh, ">:raw", "$filename.pst~";
425 syswrite $fh, Storable::nfreeze { version => 1, objs => $objs };
426 close $fh;
427 chmod SAVE_MODE, "$filename.pst~";
428 rename "$filename.pst~", "$filename.pst";
429 } else {
430 unlink "$filename.pst";
431 }
432
433 chmod SAVE_MODE, "$filename~";
434 rename "$filename~", $filename;
435}
436
437sub object_thawer_load {
438 my ($filename) = @_;
439
440 open my $fh, "<:raw:perlio", "$filename.pst"
441 or return;
442
443 eval { local $/; (Storable::thaw <$fh>)->{objs} }
444}
445
446attach_to_objects
447 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,
448 on_clone => sub { 1015 on_clone => sub {
449 my ($src, $dst) = @_; 1016 my ($src, $dst) = @_;
450 1017
451 @{$dst->registry} = @{$src->registry}; 1018 @{$dst->registry} = @{$src->registry};
452 1019
453 %$dst = %$src; 1020 %$dst = %$src;
454 1021
455 %{$dst->{_attachment}} = %{$src->{_attachment}} 1022 %{$dst->{_attachment}} = %{$src->{_attachment}}
456 if exists $src->{_attachment}; 1023 if exists $src->{_attachment};
457 }, 1024 },
458; 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
459 1108
460############################################################################# 1109#############################################################################
461# old plug-in events 1110# command handling &c
462 1111
463sub inject_event { 1112=item cf::register_command $name => \&callback($ob,$args);
464 my $extension = shift;
465 my $event_code = shift;
466 1113
467 my $cb = $hook[$event_code]{$extension} 1114Register a callback for execution when the client sends the user command
468 or return; 1115$name.
469 1116
470 &$cb 1117=cut
471}
472
473sub inject_global_event {
474 my $event = shift;
475
476 my $cb = $hook[$event]
477 or return;
478
479 List::Util::max map &$_, values %$cb
480}
481
482sub inject_command {
483 my ($name, $obj, $params) = @_;
484
485 for my $cmd (@{ $command{$name} }) {
486 $cmd->[1]->($obj, $params);
487 }
488
489 -1
490}
491 1118
492sub register_command { 1119sub register_command {
493 my ($name, $time, $cb) = @_; 1120 my ($name, $cb) = @_;
494 1121
495 my $caller = caller; 1122 my $caller = caller;
496 #warn "registering command '$name/$time' to '$caller'"; 1123 #warn "registering command '$name/$time' to '$caller'";
497 1124
498 push @{ $command{$name} }, [$time, $cb, $caller]; 1125 push @{ $COMMAND{$name} }, [$caller, $cb];
499 $COMMAND{"$name\000"} = List::Util::max map $_->[0], @{ $command{$name} };
500} 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
501 1151
502sub register_extcmd { 1152sub register_extcmd {
503 my ($name, $cb) = @_; 1153 my ($name, $cb) = @_;
504 1154
505 my $caller = caller; 1155 $EXTCMD{$name} = $cb;
506 #warn "registering extcmd '$name' to '$caller'";
507
508 $extcmd{$name} = [$cb, $caller];
509} 1156}
510 1157
511sub register { 1158sub register_exticmd {
512 my ($base, $pkg) = @_; 1159 my ($name, $cb) = @_;
513 1160
514 #TODO 1161 $EXTICMD{$name} = $cb;
515} 1162}
516 1163
517sub load_extension { 1164cf::player->attach (
518 my ($path) = @_; 1165 on_command => sub {
1166 my ($pl, $name, $params) = @_;
519 1167
520 $path =~ /([^\/\\]+)\.ext$/ or die "$path"; 1168 my $cb = $COMMAND{$name}
521 my $base = $1; 1169 or return;
522 my $pkg = $1;
523 $pkg =~ s/[^[:word:]]/_/g;
524 $pkg = "ext::$pkg";
525 1170
526 warn "loading '$path' into '$pkg'\n"; 1171 for my $cmd (@$cb) {
527 1172 $cmd->[1]->($pl->ob, $params);
528 open my $fh, "<:utf8", $path
529 or die "$path: $!";
530
531 my $source =
532 "package $pkg; use strict; use utf8;\n"
533 . "#line 1 \"$path\"\n{\n"
534 . (do { local $/; <$fh> })
535 . "\n};\n1";
536
537 eval $source
538 or die "$path: $@";
539
540 push @exts, $pkg;
541 $ext_pkg{$base} = $pkg;
542
543# no strict 'refs';
544# @{"$pkg\::ISA"} = ext::;
545
546 register $base, $pkg;
547}
548
549sub unload_extension {
550 my ($pkg) = @_;
551
552 warn "removing extension $pkg\n";
553
554 # remove hooks
555 #TODO
556# for my $idx (0 .. $#PLUGIN_EVENT) {
557# delete $hook[$idx]{$pkg};
558# }
559
560 # remove commands
561 for my $name (keys %command) {
562 my @cb = grep $_->[2] ne $pkg, @{ $command{$name} };
563
564 if (@cb) {
565 $command{$name} = \@cb;
566 $COMMAND{"$name\000"} = List::Util::max map $_->[0], @cb;
567 } else {
568 delete $command{$name};
569 delete $COMMAND{"$name\000"};
570 }
571 }
572
573 # remove extcmds
574 for my $name (grep $extcmd{$_}[1] eq $pkg, keys %extcmd) {
575 delete $extcmd{$name};
576 }
577
578 if (my $cb = $pkg->can ("unload")) {
579 eval {
580 $cb->($pkg);
581 1
582 } or warn "$pkg unloaded, but with errors: $@";
583 }
584
585 Symbol::delete_package $pkg;
586}
587
588sub load_extensions {
589 my $LIBDIR = maps_directory "perl";
590
591 for my $ext (<$LIBDIR/*.ext>) {
592 next unless -r $ext;
593 eval {
594 load_extension $ext;
595 1
596 } or warn "$ext not loaded: $@";
597 }
598}
599
600sub _perl_reload(&) {
601 my ($msg) = @_;
602
603 $msg->("reloading...");
604
605 eval {
606 # 1. cancel all watchers
607 $_->cancel for Event::all_watchers;
608
609 # 2. unload all extensions
610 for (@exts) {
611 $msg->("unloading <$_>");
612 unload_extension $_;
613 }
614
615 # 3. unload all modules loaded from $LIBDIR
616 while (my ($k, $v) = each %INC) {
617 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
618
619 $msg->("removing <$k>");
620 delete $INC{$k};
621
622 $k =~ s/\.pm$//;
623 $k =~ s/\//::/g;
624
625 if (my $cb = $k->can ("unload_module")) {
626 $cb->();
627 }
628
629 Symbol::delete_package $k;
630 }
631
632 # 4. get rid of safe::, as good as possible
633 Symbol::delete_package "safe::$_"
634 for qw(cf::object cf::object::player cf::player cf::map cf::party cf::region);
635
636 # 5. remove register_script_function callbacks
637 # TODO
638
639 # 6. unload cf.pm "a bit"
640 delete $INC{"cf.pm"};
641
642 # don't, removes xs symbols, too,
643 # and global variables created in xs
644 #Symbol::delete_package __PACKAGE__;
645
646 # 7. reload cf.pm
647 $msg->("reloading cf.pm");
648 require cf;
649 };
650 $msg->($@) if $@;
651
652 $msg->("reloaded");
653};
654
655sub perl_reload() {
656 _perl_reload {
657 warn $_[0];
658 print "$_[0]\n";
659 };
660}
661
662register_command "perl-reload", 0, sub {
663 my ($who, $arg) = @_;
664
665 if ($who->flag (FLAG_WIZ)) {
666 _perl_reload {
667 warn $_[0];
668 $who->message ($_[0]);
669 }; 1173 }
1174
1175 cf::override;
670 } 1176 },
671};
672
673#############################################################################
674# extcmd framework, basically convert ext <msg>
675# into pkg::->on_extcmd_arg1 (...) while shortcutting a few
676
677attach_to_players
678 on_extcmd => sub { 1177 on_extcmd => sub {
679 my ($pl, $buf) = @_; 1178 my ($pl, $buf) = @_;
680 1179
681 my $msg = eval { from_json $buf }; 1180 my $msg = eval { $pl->ns->{json_coder}->decode ($buf) };
682 1181
683 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
684 if (my $cb = $extcmd{$msg->{msgtype}}) { 1190 if (my $cb = $EXTCMD{$type}) {
685 if (my %reply = $cb->[0]->($pl, $msg)) { 1191 @reply = $cb->($pl, @payload);
686 $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;
687 } 1948 }
688 } 1949 }
689 } else {
690 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
691 } 1950 }
692 1951
693 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);
694 }, 1975 }
695;
696 1976
697############################################################################# 1977 $self->post_load;
698# load/save/clean perl data associated with a map 1978}
699 1979
700*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 {
701 my ($map) = @_; 1994 my ($map) = @_;
702 1995
703 my $path = $map->tmpname; 1996 my @neigh; # diagonal neighbours
704 defined $path or return;
705 1997
706 unlink "$path.pst"; 1998 for (0 .. 3) {
707}; 1999 my $neigh = $map->tile_path ($_)
2000 or next;
2001 $neigh = find $neigh, $map
2002 or next;
2003 $neigh->load;
708 2004
709# old style persistent data, TODO: remove #d# 2005 push @neigh,
710*cf::mapsupport::on_swapin = 2006 [$neigh->tile_path (($_ + 3) % 4), $neigh],
711*cf::mapsupport::on_load = sub { 2007 [$neigh->tile_path (($_ + 1) % 4), $neigh];
2008 }
2009
2010 for (grep defined $_->[0], @neigh) {
2011 my ($path, $origin) = @$_;
2012 my $neigh = find $path, $origin
2013 or next;
2014 $neigh->load;
2015 }
2016}
2017
2018sub find_sync {
2019 my ($path, $origin) = @_;
2020
2021 cf::sync_job { find $path, $origin }
2022}
2023
2024sub do_load_sync {
712 my ($map) = @_; 2025 my ($map) = @_;
713 2026
714 my $path = $map->tmpname; 2027 cf::LOG cf::llevDebug | cf::logBacktrace, "do_load_sync"
715 $path = $map->path unless defined $path; 2028 if $Coro::current == $Coro::main;
716 2029
717 open my $fh, "<:raw", "$path.cfperl" 2030 cf::sync_job { $map->load };
718 or return; # no perl data
719
720 my $data = Storable::thaw do { local $/; <$fh> };
721
722 $data->{version} <= 1
723 or return; # too new
724
725 $map->_set_obs ($data->{obs});
726 $map->invoke (EVENT_MAP_UPGRADE);
727};
728
729attach_to_maps prio => -10000, package => cf::mapsupport::;
730
731#############################################################################
732# load/save perl data associated with player->ob objects
733
734sub all_objects(@) {
735 @_, map all_objects ($_->inv), @_
736} 2031}
737 2032
738attach_to_players 2033our %MAP_PREFETCH;
739 on_load => sub { 2034our $MAP_PREFETCHER = undef;
740 my ($pl, $path) = @_;
741 2035
742 for my $o (all_objects $pl->ob) { 2036sub find_async {
743 if (my $value = $o->get_ob_key_value ("_perl_data")) { 2037 my ($path, $origin, $load) = @_;
744 $o->set_ob_key_value ("_perl_data");
745 2038
746 %$o = %{ Storable::thaw pack "H*", $value }; 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};
747 } 2055 }
748 } 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);
749 }, 2091 }
750;
751
752#############################################################################
753# core extensions - in perl
754
755=item cf::player::exists $login
756
757Returns true when the given account exists.
758
759=cut
760
761sub cf::player::exists($) {
762 cf::player::find $_[0]
763 or -f sprintf "%s/%s/%s/%s.pl", cf::localdir, cf::playerdir, ($_[0]) x 2;
764} 2092}
765 2093
2094sub swap_out {
2095 my ($self) = @_;
2096
2097 # save first because save cedes
2098 $self->save;
2099
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;
2247
2248=over 4
2249
2250=item $ob->inv_recursive
2251
2252Returns the inventory of the object _and_ their inventories, recursively.
2253
2254=cut
2255
2256sub inv_recursive_;
2257sub inv_recursive_ {
2258 map { $_, inv_recursive_ $_->inv } @_
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
2303
766=item $player->reply ($npc, $msg[, $flags]) 2304=item $player_object->reply ($npc, $msg[, $flags])
767 2305
768Sends 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>
769can 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
770dialogue with the given NPC character. 2308dialogue with the given NPC character.
771 2309
772=cut 2310=cut
773 2311
774# rough implementation of a future "reply" method that works 2312# rough implementation of a future "reply" method that works
775# with dialog boxes. 2313# with dialog boxes.
2314#TODO: the first argument must go, split into a $npc->reply_to ( method
776sub cf::object::player::reply($$$;$) { 2315sub cf::object::player::reply($$$;$) {
777 my ($self, $npc, $msg, $flags) = @_; 2316 my ($self, $npc, $msg, $flags) = @_;
778 2317
779 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4; 2318 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4;
780 2319
781 if ($self->{record_replies}) { 2320 if ($self->{record_replies}) {
782 push @{ $self->{record_replies} }, [$npc, $msg, $flags]; 2321 push @{ $self->{record_replies} }, [$npc, $msg, $flags];
2322
783 } 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 {
784 $msg = $npc->name . " says: $msg" if $npc; 2331 $msg = $npc->name . " says: $msg" if $npc;
785 $self->message ($msg, $flags); 2332 $self->message ($msg, $flags);
2333 }
2334 }
2335}
2336
2337=item $object->send_msg ($channel, $msg, $color, [extra...])
2338
2339=cut
2340
2341sub cf::object::send_msg {
2342 my $pl = shift->contr
2343 or return;
2344 $pl->send_msg (@_);
2345}
2346
2347=item $player_object->may ("access")
2348
2349Returns wether the given player is authorized to access resource "access"
2350(e.g. "command_wizcast").
2351
2352=cut
2353
2354sub cf::object::player::may {
2355 my ($self, $access) = @_;
2356
2357 $self->flag (cf::FLAG_WIZ) ||
2358 (ref $cf::CFG{"may_$access"}
2359 ? scalar grep $self->name eq $_, @{$cf::CFG{"may_$access"}}
2360 : $cf::CFG{"may_$access"})
2361}
2362
2363=item $player_object->enter_link
2364
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 my $map = eval {
2464 my $map = cf::map::find $path;
2465
2466 if ($map) {
2467 $map = $map->customise_for ($self);
2468 $map = $check->($map) if $check && $map;
2469 } else {
2470 $self->message ("The exit to '$path' is closed", cf::NDI_UNIQUE | cf::NDI_RED);
2471 }
2472
2473 $map
2474 };
2475
2476 if ($@) {
2477 $self->message ("Something went wrong within the server, please report this incident!", cf::NDI_UNIQUE | cf::NDI_RED);
2478 LOG llevError | logBacktrace, Carp::longmess $@;
2479 }
2480
2481 if ($gen == $self->{_goto_generation}) {
2482 delete $self->{_goto_generation};
2483 $self->leave_link ($map, $x, $y);
2484 }
2485
2486 $done->() if $done;
2487 })->prio (1);
2488}
2489
2490=item $player_object->enter_exit ($exit_object)
2491
2492=cut
2493
2494sub parse_random_map_params {
2495 my ($spec) = @_;
2496
2497 my $rmp = { # defaults
2498 xsize => (cf::rndm 15, 40),
2499 ysize => (cf::rndm 15, 40),
2500 symmetry => (cf::rndm 1, cf::SYMMETRY_XY),
2501 #layout => string,
786 } 2502 };
787}
788 2503
2504 for (split /\n/, $spec) {
2505 my ($k, $v) = split /\s+/, $_, 2;
2506
2507 $rmp->{lc $k} = $v if (length $k) && (length $v);
2508 }
2509
2510 $rmp
2511}
2512
2513sub prepare_random_map {
2514 my ($exit) = @_;
2515
2516 my $guard = cf::lock_acquire "exit_prepare:$exit";
2517
2518 # all this does is basically replace the /! path by
2519 # a new random map path (?random/...) with a seed
2520 # that depends on the exit object
2521
2522 my $rmp = parse_random_map_params $exit->msg;
2523
2524 if ($exit->map) {
2525 $rmp->{region} = $exit->region->name;
2526 $rmp->{origin_map} = $exit->map->path;
2527 $rmp->{origin_x} = $exit->x;
2528 $rmp->{origin_y} = $exit->y;
2529 }
2530
2531 $rmp->{random_seed} ||= $exit->random_seed;
2532
2533 my $data = cf::to_json $rmp;
2534 my $md5 = Digest::MD5::md5_hex $data;
2535 my $meta = "$RANDOMDIR/$md5.meta";
2536
2537 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) {
2538 aio_write $fh, 0, (length $data), $data, 0;
2539 undef $fh;
2540 aio_rename "$meta~", $meta;
2541
2542 $exit->slaying ("?random/$md5");
2543 $exit->msg (undef);
2544 }
2545}
2546
2547sub cf::object::player::enter_exit {
2548 my ($self, $exit) = @_;
2549
2550 return unless $self->type == cf::PLAYER;
2551
2552 if ($exit->slaying eq "/!") {
2553 #TODO: this should de-fi-ni-te-ly not be a sync-job
2554 # the problem is that $exit might not survive long enough
2555 # so it needs to be done right now, right here
2556 cf::sync_job { prepare_random_map $exit };
2557 }
2558
2559 my $slaying = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path;
2560 my $hp = $exit->stats->hp;
2561 my $sp = $exit->stats->sp;
2562
2563 $self->enter_link;
2564
2565 # if exit is damned, update players death & WoR home-position
2566 $self->contr->savebed ($slaying, $hp, $sp)
2567 if $exit->flag (FLAG_DAMNED);
2568
2569 (async {
2570 $self->deactivate_recursive; # just to be sure
2571 unless (eval {
2572 $self->goto ($slaying, $hp, $sp);
2573
2574 1;
2575 }) {
2576 $self->message ("Something went wrong deep within the crossfire server. "
2577 . "I'll try to bring you back to the map you were before. "
2578 . "Please report this to the dungeon master!",
2579 cf::NDI_UNIQUE | cf::NDI_RED);
2580
2581 warn "ERROR in enter_exit: $@";
2582 $self->leave_link;
2583 }
2584 })->prio (1);
2585}
2586
2587=head3 cf::client
2588
2589=over 4
2590
2591=item $client->send_drawinfo ($text, $flags)
2592
2593Sends a drawinfo packet to the client. Circumvents output buffering so
2594should not be used under normal circumstances.
2595
2596=cut
2597
2598sub cf::client::send_drawinfo {
2599 my ($self, $text, $flags) = @_;
2600
2601 utf8::encode $text;
2602 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);
2603}
2604
2605=item $client->send_msg ($channel, $msg, $color, [extra...])
2606
2607Send a drawinfo or msg packet to the client, formatting the msg for the
2608client if neccessary. C<$type> should be a string identifying the type of
2609the message, with C<log> being the default. If C<$color> is negative, suppress
2610the message unless the client supports the msg packet.
2611
2612=cut
2613
2614our %CHANNEL = (
2615 "c/identify" => {
2616 id => "identify",
2617 title => "Identify",
2618 reply => undef,
2619 tooltip => "Items recently identified",
2620 },
2621 "c/examine" => {
2622 id => "examine",
2623 title => "Examine",
2624 reply => undef,
2625 tooltip => "Signs and other items you examined",
2626 },
2627);
2628
2629sub cf::client::send_msg {
2630 my ($self, $channel, $msg, $color, @extra) = @_;
2631
2632 $msg = $self->pl->expand_cfpod ($msg);
2633
2634 $color &= cf::NDI_CLIENT_MASK; # just in case...
2635
2636 # check predefined channels, for the benefit of C
2637 $channel = $CHANNEL{$channel} if $CHANNEL{$channel};
2638
2639 if (ref $channel) {
2640 # send meta info to client, if not yet sent
2641 unless (exists $self->{channel}{$channel->{id}}) {
2642 $self->{channel}{$channel->{id}} = $channel;
2643 $self->ext_msg (channel_info => $channel)
2644 if $self->can_msg;
2645 }
2646
2647 $channel = $channel->{id};
2648 }
2649
2650 return unless @extra || length $msg;
2651
2652 if ($self->can_msg) {
2653 # default colour, mask it out
2654 $color &= ~(cf::NDI_COLOR_MASK | cf::NDI_DEF)
2655 if $color & cf::NDI_DEF;
2656
2657 $self->send_packet ("msg " . $self->{json_coder}->encode (
2658 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]));
2659 } else {
2660 if ($color >= 0) {
2661 # replace some tags by gcfclient-compatible ones
2662 for ($msg) {
2663 1 while
2664 s/<b>([^<]*)<\/b>/[b]${1}[\/b]/
2665 || s/<i>([^<]*)<\/i>/[i]${1}[\/i]/
2666 || s/<u>([^<]*)<\/u>/[ul]${1}[\/ul]/
2667 || s/<tt>([^<]*)<\/tt>/[fixed]${1}[\/fixed]/
2668 || s/<fg name=\"([^"]+)\">([^<]*)<\/fg>/[color=$1]${2}[\/color]/;
2669 }
2670
2671 $color &= cf::NDI_COLOR_MASK;
2672
2673 utf8::encode $msg;
2674
2675 if (0 && $msg =~ /\[/) {
2676 # COMMAND/INFO
2677 $self->send_packet ("drawextinfo $color 10 8 $msg")
2678 } else {
2679 $msg =~ s/\[\/?(?:b|i|u|fixed|color)[^\]]*\]//g;
2680 $self->send_packet ("drawinfo $color $msg")
2681 }
2682 }
2683 }
2684}
2685
2686=item $client->ext_msg ($type, @msg)
2687
2688Sends an ext event to the client.
2689
2690=cut
2691
2692sub cf::client::ext_msg($$@) {
2693 my ($self, $type, @msg) = @_;
2694
2695 if ($self->extcmd == 2) {
2696 $self->send_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
2697 } elsif ($self->extcmd == 1) { # TODO: remove
2698 push @msg, msgtype => "event_$type";
2699 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2700 }
2701}
2702
789=item $player->ext_reply ($msgid, $msgtype, %msg) 2703=item $client->ext_reply ($msgid, @msg)
790 2704
791Sends an ext reply to the player. 2705Sends an ext reply to the client.
792 2706
793=cut 2707=cut
794 2708
795sub cf::player::ext_reply($$$%) { 2709sub cf::client::ext_reply($$@) {
796 my ($self, $id, %msg) = @_; 2710 my ($self, $id, @msg) = @_;
797 2711
798 $msg{msgid} = $id; 2712 if ($self->extcmd == 2) {
799 2713 $self->send_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg]));
800 $self->send ("ext " . to_json \%msg); 2714 } elsif ($self->extcmd == 1) {
2715 #TODO: version 1, remove
2716 unshift @msg, msgtype => "reply", msgid => $id;
2717 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2718 }
801} 2719}
802 2720
803############################################################################# 2721=item $success = $client->query ($flags, "text", \&cb)
804# map scripting support 2722
2723Queues a query to the client, calling the given callback with
2724the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>,
2725C<cf::CS_QUERY_SINGLECHAR> or C<cf::CS_QUERY_HIDEINPUT> or C<0>.
2726
2727Queries can fail, so check the return code. Or don't, as queries will
2728become reliable at some point in the future.
2729
2730=cut
2731
2732sub cf::client::query {
2733 my ($self, $flags, $text, $cb) = @_;
2734
2735 return unless $self->state == ST_PLAYING
2736 || $self->state == ST_SETUP
2737 || $self->state == ST_CUSTOM;
2738
2739 $self->state (ST_CUSTOM);
2740
2741 utf8::encode $text;
2742 push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb];
2743
2744 $self->send_packet ($self->{query_queue}[0][0])
2745 if @{ $self->{query_queue} } == 1;
2746
2747 1
2748}
2749
2750cf::client->attach (
2751 on_connect => sub {
2752 my ($ns) = @_;
2753
2754 $ns->{json_coder} = JSON::XS->new->utf8->max_size (1e6)->convert_blessed;
2755 },
2756 on_reply => sub {
2757 my ($ns, $msg) = @_;
2758
2759 # this weird shuffling is so that direct followup queries
2760 # get handled first
2761 my $queue = delete $ns->{query_queue}
2762 or return; # be conservative, not sure how that can happen, but we saw a crash here
2763
2764 (shift @$queue)->[1]->($msg);
2765 return unless $ns->valid; # temporary(?) workaround for callback destroying socket
2766
2767 push @{ $ns->{query_queue} }, @$queue;
2768
2769 if (@{ $ns->{query_queue} } == @$queue) {
2770 if (@$queue) {
2771 $ns->send_packet ($ns->{query_queue}[0][0]);
2772 } else {
2773 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM;
2774 }
2775 }
2776 },
2777 on_exticmd => sub {
2778 my ($ns, $buf) = @_;
2779
2780 my $msg = eval { $ns->{json_coder}->decode ($buf) };
2781
2782 if (ref $msg) {
2783 my ($type, $reply, @payload) =
2784 "ARRAY" eq ref $msg
2785 ? @$msg
2786 : ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
2787
2788 my @reply;
2789
2790 if (my $cb = $EXTICMD{$type}) {
2791 @reply = $cb->($ns, @payload);
2792 }
2793
2794 $ns->ext_reply ($reply, @reply)
2795 if $reply;
2796
2797 } else {
2798 warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";
2799 }
2800
2801 cf::override;
2802 },
2803);
2804
2805=item $client->async (\&cb)
2806
2807Create a new coroutine, running the specified callback. The coroutine will
2808be automatically cancelled when the client gets destroyed (e.g. on logout,
2809or loss of connection).
2810
2811=cut
2812
2813sub cf::client::async {
2814 my ($self, $cb) = @_;
2815
2816 my $coro = &Coro::async ($cb);
2817
2818 $coro->on_destroy (sub {
2819 delete $self->{_coro}{$coro+0};
2820 });
2821
2822 $self->{_coro}{$coro+0} = $coro;
2823
2824 $coro
2825}
2826
2827cf::client->attach (
2828 on_destroy => sub {
2829 my ($ns) = @_;
2830
2831 $_->cancel for values %{ (delete $ns->{_coro}) || {} };
2832 },
2833);
2834
2835=back
2836
2837
2838=head2 SAFE SCRIPTING
2839
2840Functions that provide a safe environment to compile and execute
2841snippets of perl code without them endangering the safety of the server
2842itself. Looping constructs, I/O operators and other built-in functionality
2843is not available in the safe scripting environment, and the number of
2844functions and methods that can be called is greatly reduced.
2845
2846=cut
805 2847
806our $safe = new Safe "safe"; 2848our $safe = new Safe "safe";
807our $safe_hole = new Safe::Hole; 2849our $safe_hole = new Safe::Hole;
808 2850
809$SIG{FPE} = 'IGNORE'; 2851$SIG{FPE} = 'IGNORE';
810 2852
811$safe->permit_only (Opcode::opset qw(:base_core :base_mem :base_orig :base_math sort time)); 2853$safe->permit_only (Opcode::opset qw(
2854 :base_core :base_mem :base_orig :base_math
2855 grepstart grepwhile mapstart mapwhile
2856 sort time
2857));
812 2858
813# here we export the classes and methods available to script code 2859# here we export the classes and methods available to script code
814 2860
2861=pod
2862
2863The following functions and methods are available within a safe environment:
2864
2865 cf::object
2866 contr pay_amount pay_player map x y force_find force_add
2867 insert remove name archname title slaying race decrease_ob_nr
2868
2869 cf::object::player
2870 player
2871
2872 cf::player
2873 peaceful
2874
2875 cf::map
2876 trigger
2877
2878=cut
2879
815for ( 2880for (
816 ["cf::object" => qw(contr pay_amount pay_player)], 2881 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y
2882 insert remove inv name archname title slaying race
2883 decrease_ob_nr)],
817 ["cf::object::player" => qw(player)], 2884 ["cf::object::player" => qw(player)],
818 ["cf::player" => qw(peaceful)], 2885 ["cf::player" => qw(peaceful)],
2886 ["cf::map" => qw(trigger)],
819) { 2887) {
820 no strict 'refs'; 2888 no strict 'refs';
821 my ($pkg, @funs) = @$_; 2889 my ($pkg, @funs) = @$_;
822 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"}) 2890 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})
823 for @funs; 2891 for @funs;
824} 2892}
2893
2894=over 4
2895
2896=item @retval = safe_eval $code, [var => value, ...]
2897
2898Compiled and executes the given perl code snippet. additional var/value
2899pairs result in temporary local (my) scalar variables of the given name
2900that are available in the code snippet. Example:
2901
2902 my $five = safe_eval '$first + $second', first => 1, second => 4;
2903
2904=cut
825 2905
826sub safe_eval($;@) { 2906sub safe_eval($;@) {
827 my ($code, %vars) = @_; 2907 my ($code, %vars) = @_;
828 2908
829 my $qcode = $code; 2909 my $qcode = $code;
852 } 2932 }
853 2933
854 wantarray ? @res : $res[0] 2934 wantarray ? @res : $res[0]
855} 2935}
856 2936
2937=item cf::register_script_function $function => $cb
2938
2939Register a function that can be called from within map/npc scripts. The
2940function should be reasonably secure and should be put into a package name
2941like the extension.
2942
2943Example: register a function that gets called whenever a map script calls
2944C<rent::overview>, as used by the C<rent> extension.
2945
2946 cf::register_script_function "rent::overview" => sub {
2947 ...
2948 };
2949
2950=cut
2951
857sub register_script_function { 2952sub register_script_function {
858 my ($fun, $cb) = @_; 2953 my ($fun, $cb) = @_;
859 2954
860 no strict 'refs'; 2955 no strict 'refs';
861 *{"safe::$fun"} = $safe_hole->wrap ($cb); 2956 *{"safe::$fun"} = $safe_hole->wrap ($cb);
862} 2957}
863 2958
2959=back
2960
2961=cut
2962
864############################################################################# 2963#############################################################################
865# the server's main() 2964# the server's init and main functions
2965
2966sub load_facedata($) {
2967 my ($path) = @_;
2968
2969 # HACK to clear player env face cache, we need some signal framework
2970 # for this (global event?)
2971 %ext::player_env::MUSIC_FACE_CACHE = ();
2972
2973 my $enc = JSON::XS->new->utf8->canonical->relaxed;
2974
2975 warn "loading facedata from $path\n";
2976
2977 my $facedata;
2978 0 < aio_load $path, $facedata
2979 or die "$path: $!";
2980
2981 $facedata = Coro::Storable::thaw $facedata;
2982
2983 $facedata->{version} == 2
2984 or cf::cleanup "$path: version mismatch, cannot proceed.";
2985
2986 # patch in the exptable
2987 $facedata->{resource}{"res/exp_table"} = {
2988 type => FT_RSRC,
2989 data => $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]),
2990 };
2991 cf::cede_to_tick;
2992
2993 {
2994 my $faces = $facedata->{faceinfo};
2995
2996 while (my ($face, $info) = each %$faces) {
2997 my $idx = (cf::face::find $face) || cf::face::alloc $face;
2998 cf::face::set_visibility $idx, $info->{visibility};
2999 cf::face::set_magicmap $idx, $info->{magicmap};
3000 cf::face::set_data $idx, 0, $info->{data32}, Digest::MD5::md5 $info->{data32};
3001 cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64};
3002
3003 cf::cede_to_tick;
3004 }
3005
3006 while (my ($face, $info) = each %$faces) {
3007 next unless $info->{smooth};
3008 my $idx = cf::face::find $face
3009 or next;
3010 if (my $smooth = cf::face::find $info->{smooth}) {
3011 cf::face::set_smooth $idx, $smooth;
3012 cf::face::set_smoothlevel $idx, $info->{smoothlevel};
3013 } else {
3014 warn "smooth face '$info->{smooth}' not found for face '$face'";
3015 }
3016
3017 cf::cede_to_tick;
3018 }
3019 }
3020
3021 {
3022 my $anims = $facedata->{animinfo};
3023
3024 while (my ($anim, $info) = each %$anims) {
3025 cf::anim::set $anim, $info->{frames}, $info->{facings};
3026 cf::cede_to_tick;
3027 }
3028
3029 cf::anim::invalidate_all; # d'oh
3030 }
3031
3032 {
3033 # TODO: for gcfclient pleasure, we should give resources
3034 # that gcfclient doesn't grok a >10000 face index.
3035 my $res = $facedata->{resource};
3036
3037 my $soundconf = delete $res->{"res/sound.conf"};
3038
3039 while (my ($name, $info) = each %$res) {
3040 my $idx = (cf::face::find $name) || cf::face::alloc $name;
3041 my $data;
3042
3043 if ($info->{type} & 1) {
3044 # prepend meta info
3045
3046 my $meta = $enc->encode ({
3047 name => $name,
3048 %{ $info->{meta} || {} },
3049 });
3050
3051 $data = pack "(w/a*)*", $meta, $info->{data};
3052 } else {
3053 $data = $info->{data};
3054 }
3055
3056 cf::face::set_data $idx, 0, $data, Digest::MD5::md5 $data;
3057 cf::face::set_type $idx, $info->{type};
3058
3059 cf::cede_to_tick;
3060 }
3061
3062 if ($soundconf) {
3063 $soundconf = $enc->decode (delete $soundconf->{data});
3064
3065 for (0 .. SOUND_CAST_SPELL_0 - 1) {
3066 my $sound = $soundconf->{compat}[$_]
3067 or next;
3068
3069 my $face = cf::face::find "sound/$sound->[1]";
3070 cf::sound::set $sound->[0] => $face;
3071 cf::sound::old_sound_index $_, $face; # gcfclient-compat
3072 }
3073
3074 while (my ($k, $v) = each %{$soundconf->{event}}) {
3075 my $face = cf::face::find "sound/$v";
3076 cf::sound::set $k => $face;
3077 }
3078 }
3079 }
3080
3081 1
3082}
3083
3084register_exticmd fx_want => sub {
3085 my ($ns, $want) = @_;
3086
3087 while (my ($k, $v) = each %$want) {
3088 $ns->fx_want ($k, $v);
3089 }
3090};
3091
3092sub reload_regions {
3093 # HACK to clear player env face cache, we need some signal framework
3094 # for this (global event?)
3095 %ext::player_env::MUSIC_FACE_CACHE = ();
3096
3097 load_resource_file "$MAPDIR/regions"
3098 or die "unable to load regions file\n";
3099
3100 for (cf::region::list) {
3101 $_->{match} = qr/$_->{match}/
3102 if exists $_->{match};
3103 }
3104}
3105
3106sub reload_facedata {
3107 load_facedata "$DATADIR/facedata"
3108 or die "unable to load facedata\n";
3109}
3110
3111sub reload_archetypes {
3112 load_resource_file "$DATADIR/archetypes"
3113 or die "unable to load archetypes\n";
3114 #d# NEED to laod twice to resolve forward references
3115 # this really needs to be done in an extra post-pass
3116 # (which needs to be synchronous, so solve it differently)
3117 load_resource_file "$DATADIR/archetypes"
3118 or die "unable to load archetypes\n";
3119}
3120
3121sub reload_treasures {
3122 load_resource_file "$DATADIR/treasures"
3123 or die "unable to load treasurelists\n";
3124}
3125
3126sub reload_resources {
3127 warn "reloading resource files...\n";
3128
3129 reload_regions;
3130 reload_facedata;
3131 #reload_archetypes;#d#
3132 reload_archetypes;
3133 reload_treasures;
3134
3135 warn "finished reloading resource files\n";
3136}
3137
3138sub init {
3139 reload_resources;
3140}
3141
3142sub reload_config {
3143 open my $fh, "<:utf8", "$CONFDIR/config"
3144 or return;
3145
3146 local $/;
3147 *CFG = YAML::Syck::Load <$fh>;
3148
3149 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37];
3150
3151 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset};
3152 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset};
3153
3154 if (exists $CFG{mlockall}) {
3155 eval {
3156 $CFG{mlockall} ? eval "mlockall()" : eval "munlockall()"
3157 and die "WARNING: m(un)lockall failed: $!\n";
3158 };
3159 warn $@ if $@;
3160 }
3161}
866 3162
867sub main { 3163sub main {
3164 # we must not ever block the main coroutine
3165 local $Coro::idle = sub {
3166 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
3167 (async {
3168 Event::one_event;
3169 })->prio (Coro::PRIO_MAX);
3170 };
3171
3172 reload_config;
3173 db_init;
3174 load_extensions;
3175
3176 $TICK_WATCHER->start;
868 Event::loop; 3177 Event::loop;
869} 3178}
870 3179
871############################################################################# 3180#############################################################################
872# initialisation 3181# initialisation and cleanup
873 3182
874register "<global>", __PACKAGE__; 3183# install some emergency cleanup handlers
3184BEGIN {
3185 for my $signal (qw(INT HUP TERM)) {
3186 Event->signal (
3187 reentrant => 0,
3188 data => WF_AUTOCANCEL,
3189 signal => $signal,
3190 prio => 0,
3191 cb => sub {
3192 cf::cleanup "SIG$signal";
3193 },
3194 );
3195 }
3196}
3197
3198sub write_runtime {
3199 my $runtime = "$LOCALDIR/runtime";
3200
3201 # first touch the runtime file to show we are still running:
3202 # the fsync below can take a very very long time.
3203
3204 IO::AIO::aio_utime $runtime, undef, undef;
3205
3206 my $guard = cf::lock_acquire "write_runtime";
3207
3208 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644
3209 or return;
3210
3211 my $value = $cf::RUNTIME + 90 + 10;
3212 # 10 is the runtime save interval, for a monotonic clock
3213 # 60 allows for the watchdog to kill the server.
3214
3215 (aio_write $fh, 0, (length $value), $value, 0) <= 0
3216 and return;
3217
3218 # always fsync - this file is important
3219 aio_fsync $fh
3220 and return;
3221
3222 # touch it again to show we are up-to-date
3223 aio_utime $fh, undef, undef;
3224
3225 close $fh
3226 or return;
3227
3228 aio_rename "$runtime~", $runtime
3229 and return;
3230
3231 warn "runtime file written.\n";
3232
3233 1
3234}
3235
3236sub emergency_save() {
3237 my $freeze_guard = cf::freeze_mainloop;
3238
3239 warn "enter emergency perl save\n";
3240
3241 cf::sync_job {
3242 # use a peculiar iteration method to avoid tripping on perl
3243 # refcount bugs in for. also avoids problems with players
3244 # and maps saved/destroyed asynchronously.
3245 warn "begin emergency player save\n";
3246 for my $login (keys %cf::PLAYER) {
3247 my $pl = $cf::PLAYER{$login} or next;
3248 $pl->valid or next;
3249 $pl->save;
3250 }
3251 warn "end emergency player save\n";
3252
3253 warn "begin emergency map save\n";
3254 for my $path (keys %cf::MAP) {
3255 my $map = $cf::MAP{$path} or next;
3256 $map->valid or next;
3257 $map->save;
3258 }
3259 warn "end emergency map save\n";
3260
3261 warn "begin emergency database checkpoint\n";
3262 BDB::db_env_txn_checkpoint $DB_ENV;
3263 warn "end emergency database checkpoint\n";
3264 };
3265
3266 warn "leave emergency perl save\n";
3267}
3268
3269sub post_cleanup {
3270 my ($make_core) = @_;
3271
3272 warn Carp::longmess "post_cleanup backtrace"
3273 if $make_core;
3274}
3275
3276sub do_reload_perl() {
3277 # can/must only be called in main
3278 if ($Coro::current != $Coro::main) {
3279 warn "can only reload from main coroutine";
3280 return;
3281 }
3282
3283 warn "reloading...";
3284
3285 warn "entering sync_job";
3286
3287 cf::sync_job {
3288 cf::write_runtime; # external watchdog should not bark
3289 cf::emergency_save;
3290 cf::write_runtime; # external watchdog should not bark
3291
3292 warn "syncing database to disk";
3293 BDB::db_env_txn_checkpoint $DB_ENV;
3294
3295 # if anything goes wrong in here, we should simply crash as we already saved
3296
3297 warn "cancelling all WF_AUTOCANCEL watchers";
3298 for (Event::all_watchers) {
3299 $_->cancel if $_->data & WF_AUTOCANCEL;
3300 }
3301
3302 warn "flushing outstanding aio requests";
3303 for (;;) {
3304 BDB::flush;
3305 IO::AIO::flush;
3306 Coro::cede;
3307 last unless IO::AIO::nreqs || BDB::nreqs;
3308 warn "iterate...";
3309 }
3310
3311 ++$RELOAD;
3312
3313 warn "cancelling all extension coros";
3314 $_->cancel for values %EXT_CORO;
3315 %EXT_CORO = ();
3316
3317 warn "removing commands";
3318 %COMMAND = ();
3319
3320 warn "removing ext/exti commands";
3321 %EXTCMD = ();
3322 %EXTICMD = ();
3323
3324 warn "unloading/nuking all extensions";
3325 for my $pkg (@EXTS) {
3326 warn "... unloading $pkg";
3327
3328 if (my $cb = $pkg->can ("unload")) {
3329 eval {
3330 $cb->($pkg);
3331 1
3332 } or warn "$pkg unloaded, but with errors: $@";
3333 }
3334
3335 warn "... nuking $pkg";
3336 Symbol::delete_package $pkg;
3337 }
3338
3339 warn "unloading all perl modules loaded from $LIBDIR";
3340 while (my ($k, $v) = each %INC) {
3341 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
3342
3343 warn "... unloading $k";
3344 delete $INC{$k};
3345
3346 $k =~ s/\.pm$//;
3347 $k =~ s/\//::/g;
3348
3349 if (my $cb = $k->can ("unload_module")) {
3350 $cb->();
3351 }
3352
3353 Symbol::delete_package $k;
3354 }
3355
3356 warn "getting rid of safe::, as good as possible";
3357 Symbol::delete_package "safe::$_"
3358 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
3359
3360 warn "unloading cf.pm \"a bit\"";
3361 delete $INC{"cf.pm"};
3362 delete $INC{"cf/pod.pm"};
3363
3364 # don't, removes xs symbols, too,
3365 # and global variables created in xs
3366 #Symbol::delete_package __PACKAGE__;
3367
3368 warn "unload completed, starting to reload now";
3369
3370 warn "reloading cf.pm";
3371 require cf;
3372 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
3373
3374 warn "loading config and database again";
3375 cf::reload_config;
3376
3377 warn "loading extensions";
3378 cf::load_extensions;
3379
3380 warn "reattaching attachments to objects/players";
3381 _global_reattach; # objects, sockets
3382 warn "reattaching attachments to maps";
3383 reattach $_ for values %MAP;
3384 warn "reattaching attachments to players";
3385 reattach $_ for values %PLAYER;
3386
3387 warn "leaving sync_job";
3388
3389 1
3390 } or do {
3391 warn $@;
3392 warn "error while reloading, exiting.";
3393 exit 1;
3394 };
3395
3396 warn "reloaded";
3397};
3398
3399our $RELOAD_WATCHER; # used only during reload
3400
3401sub reload_perl() {
3402 # doing reload synchronously and two reloads happen back-to-back,
3403 # coro crashes during coro_state_free->destroy here.
3404
3405 $RELOAD_WATCHER ||= Event->timer (
3406 reentrant => 0,
3407 after => 0,
3408 data => WF_AUTOCANCEL,
3409 cb => sub {
3410 do_reload_perl;
3411 undef $RELOAD_WATCHER;
3412 },
3413 );
3414}
3415
3416register_command "reload" => sub {
3417 my ($who, $arg) = @_;
3418
3419 if ($who->flag (FLAG_WIZ)) {
3420 $who->message ("reloading server.");
3421 async { reload_perl };
3422 }
3423};
875 3424
876unshift @INC, $LIBDIR; 3425unshift @INC, $LIBDIR;
877 3426
878load_extensions; 3427my $bug_warning = 0;
879 3428
3429our @WAIT_FOR_TICK;
3430our @WAIT_FOR_TICK_BEGIN;
3431
3432sub wait_for_tick {
3433 return unless $TICK_WATCHER->is_active;
3434 return if $Coro::current == $Coro::main;
3435
3436 my $signal = new Coro::Signal;
3437 push @WAIT_FOR_TICK, $signal;
3438 $signal->wait;
3439}
3440
3441sub wait_for_tick_begin {
3442 return unless $TICK_WATCHER->is_active;
3443 return if $Coro::current == $Coro::main;
3444
3445 my $signal = new Coro::Signal;
3446 push @WAIT_FOR_TICK_BEGIN, $signal;
3447 $signal->wait;
3448}
3449
3450 my $min = 1e6;#d#
3451 my $avg = 10;
880$TICK_WATCHER = Event->timer ( 3452$TICK_WATCHER = Event->timer (
3453 reentrant => 0,
3454 parked => 1,
881 prio => 1, 3455 prio => 0,
882 at => $NEXT_TICK || 1, 3456 at => $NEXT_TICK || $TICK,
3457 data => WF_AUTOCANCEL,
883 cb => sub { 3458 cb => sub {
3459 if ($Coro::current != $Coro::main) {
3460 Carp::cluck "major BUG: server tick called outside of main coro, skipping it"
3461 unless ++$bug_warning > 10;
3462 return;
3463 }
3464
3465 $NOW = $tick_start = Event::time;
3466
884 cf::server_tick; # one server iteration 3467 cf::server_tick; # one server iteration
885 3468
3469 0 && sync_job {#d#
3470 for(1..10) {
886 my $NOW = Event::time; 3471 my $t = Event::time;
3472 my $map = my $map = new_from_path cf::map "/tmp/x.map"
3473 or die;
3474
3475 $map->width (50);
3476 $map->height (50);
3477 $map->alloc;
3478 $map->_load_objects ("/tmp/x.map", 1); #TODO: does not work
3479 my $t = Event::time - $t;
3480
3481 #next unless $t < 0.0013;#d#
3482 if ($t < $min) {
3483 $min = $t;
3484 }
3485 $avg = $avg * 0.99 + $t * 0.01;
3486 }
3487 warn "XXXXXXXXXXXXXXXXXX min $min avg $avg\n";#d#
3488 exit 0;
3489 # 2007-05-22 02:33:04.569 min 0.00112509727478027 avg 0.0012259249572477
3490 };
3491
3492 $RUNTIME += $TICK;
887 $NEXT_TICK += $TICK; 3493 $NEXT_TICK += $TICK;
888 3494
3495 if ($NOW >= $NEXT_RUNTIME_WRITE) {
3496 $NEXT_RUNTIME_WRITE = $NOW + 10;
3497 Coro::async_pool {
3498 write_runtime
3499 or warn "ERROR: unable to write runtime file: $!";
3500 };
3501 }
3502
3503# my $AFTER = Event::time;
3504# warn $AFTER - $NOW;#d#
3505
3506 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
3507 $sig->send;
3508 }
3509 while (my $sig = shift @WAIT_FOR_TICK) {
3510 $sig->send;
3511 }
3512
3513 $NOW = Event::time;
3514
889 # if we are delayed by four ticks, skip them all 3515 # if we are delayed by four ticks or more, skip them all
890 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4; 3516 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
891 3517
892 $TICK_WATCHER->at ($NEXT_TICK); 3518 $TICK_WATCHER->at ($NEXT_TICK);
893 $TICK_WATCHER->start; 3519 $TICK_WATCHER->start;
3520
3521 $LOAD = ($NOW - $tick_start) / $TICK;
3522 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
3523
3524 _post_tick;
3525
3526
894 }, 3527 },
895); 3528);
896 3529
897_reload_2; 3530{
3531 BDB::min_parallel 8;
3532 BDB::max_poll_time $TICK * 0.1;
3533 $BDB_POLL_WATCHER = Event->io (
3534 reentrant => 0,
3535 fd => BDB::poll_fileno,
3536 poll => 'r',
3537 prio => 0,
3538 data => WF_AUTOCANCEL,
3539 cb => \&BDB::poll_cb,
3540 );
3541
3542 BDB::set_sync_prepare {
3543 my $status;
3544 my $current = $Coro::current;
3545 (
3546 sub {
3547 $status = $!;
3548 $current->ready; undef $current;
3549 },
3550 sub {
3551 Coro::schedule while defined $current;
3552 $! = $status;
3553 },
3554 )
3555 };
3556
3557 unless ($DB_ENV) {
3558 $DB_ENV = BDB::db_env_create;
3559
3560 cf::sync_job {
3561 eval {
3562 BDB::db_env_open
3563 $DB_ENV,
3564 $BDBDIR,
3565 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN
3566 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE,
3567 0666;
3568
3569 cf::cleanup "db_env_open($BDBDIR): $!" if $!;
3570
3571 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC
3572 | BDB::LOG_AUTOREMOVE, 1);
3573 $DB_ENV->set_lk_detect;
3574 };
3575
3576 cf::cleanup "db_env_open(db): $@" if $@;
3577 };
3578 }
3579
3580 $BDB_CHECKPOINT_WATCHER = Event->timer (
3581 after => 11,
3582 interval => 60,
3583 hard => 1,
3584 prio => 0,
3585 data => WF_AUTOCANCEL,
3586 cb => sub {
3587 BDB::db_env_txn_checkpoint $DB_ENV, 0, 0, 0, sub { };
3588 },
3589 );
3590 $BDB_TRICKLE_WATCHER = Event->timer (
3591 after => 5,
3592 interval => 10,
3593 hard => 1,
3594 prio => 0,
3595 data => WF_AUTOCANCEL,
3596 cb => sub {
3597 BDB::db_env_memp_trickle $DB_ENV, 20, 0, sub { };
3598 },
3599 );
3600}
3601
3602{
3603 IO::AIO::min_parallel 8;
3604
3605 undef $Coro::AIO::WATCHER;
3606 IO::AIO::max_poll_time $TICK * 0.1;
3607 $AIO_POLL_WATCHER = Event->io (
3608 reentrant => 0,
3609 data => WF_AUTOCANCEL,
3610 fd => IO::AIO::poll_fileno,
3611 poll => 'r',
3612 prio => 6,
3613 cb => \&IO::AIO::poll_cb,
3614 );
3615}
3616
3617my $_log_backtrace;
3618
3619sub _log_backtrace {
3620 my ($msg, @addr) = @_;
3621
3622 $msg =~ s/\n//;
3623
3624 # limit the # of concurrent backtraces
3625 if ($_log_backtrace < 2) {
3626 ++$_log_backtrace;
3627 async {
3628 my @bt = fork_call {
3629 @addr = map { sprintf "%x", $_ } @addr;
3630 my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X;
3631 open my $fh, "exec addr2line -C -f -i -e \Q$self\E @addr 2>&1 |"
3632 or die "addr2line: $!";
3633
3634 my @funcs;
3635 my @res = <$fh>;
3636 chomp for @res;
3637 while (@res) {
3638 my ($func, $line) = splice @res, 0, 2, ();
3639 push @funcs, "[$func] $line";
3640 }
3641
3642 @funcs
3643 };
3644
3645 LOG llevInfo, "[ABT] $msg\n";
3646 LOG llevInfo, "[ABT] $_\n" for @bt;
3647 --$_log_backtrace;
3648 };
3649 } else {
3650 LOG llevInfo, "[ABT] $msg\n";
3651 LOG llevInfo, "[ABT] [suppressed]\n";
3652 }
3653}
3654
3655# load additional modules
3656use cf::pod;
3657
3658END { cf::emergency_save }
898 3659
8991 36601
900 3661

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines