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

Diff Legend

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