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.43 by root, Fri Aug 25 17:11:53 2006 UTC vs.
Revision 1.334 by root, Mon Aug 20 22:09:04 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# "new" plug-in system
98 223
99=item cf::object::attach ... # NYI 224=head2 UTILITY FUNCTIONS
100 225
101=item cf::attach_global ... 226=over 4
102 227
103=item cf::attach_to_type ... 228=item dumpval $ref
104 229
105=item cf::attach_to_objects ... 230=cut
106 231
107=item cf::attach_to_players ... 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]: '$@']";
249}
108 250
109=item cf::attach_to_maps ... 251=item $ref = cf::from_json $json
110 252
111 prio => $number, # lower is earlier 253Converts a JSON string into the corresponding perl data structure.
112 on_xxx => \&cb, 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
623
624#############################################################################
625
626=head2 ATTACHABLE OBJECTS
627
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.
631
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).
635
636=over 4
637
638=item $attachable->attach ($attachment, key => $value...)
639
640=item $attachable->detach ($attachment)
641
642Attach/detach a pre-registered attachment to a specific object and give it
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
113 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.
114 744
115=cut 745=cut
116 746
117# 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
118our @CB_GLOBAL = (); # registry for all global events 748our @CB_GLOBAL = (); # registry for all global events
119our @CB_OBJECT = (); 749our @CB_ATTACHABLE = (); # registry for all attachables
750our @CB_OBJECT = (); # all objects (should not be used except in emergency)
120our @CB_PLAYER = (); 751our @CB_PLAYER = ();
752our @CB_CLIENT = ();
121our @CB_TYPE = (); # registry for type (cf-object class) based events 753our @CB_TYPE = (); # registry for type (cf-object class) based events
122our @CB_MAP = (); 754our @CB_MAP = ();
123 755
756my %attachment;
757
758sub cf::attachable::thawer_merge {
759 # simply override everything except _meta
760 local $_[0]{_meta};
761 %{$_[0]} = %{$_[1]};
762}
763
124sub _attach_cb($\%$$$) { 764sub _attach_cb($$$$) {
125 my ($registry, $undo, $event, $prio, $cb) = @_; 765 my ($registry, $event, $prio, $cb) = @_;
126 766
127 use sort 'stable'; 767 use sort 'stable';
128 768
129 $cb = [$prio, $cb]; 769 $cb = [$prio, $cb];
130 770
131 @{$registry->[$event]} = sort 771 @{$registry->[$event]} = sort
132 { $a->[0] cmp $b->[0] } 772 { $a->[0] cmp $b->[0] }
133 @{$registry->[$event] || []}, $cb; 773 @{$registry->[$event] || []}, $cb;
134
135 push @{$undo->{cb}}, [$event, $cb];
136} 774}
775
776# hack
777my %attachable_klass = map +($_ => 1), KLASS_OBJECT, KLASS_CLIENT, KLASS_PLAYER, KLASS_MAP;
137 778
138# attach handles attaching event callbacks 779# attach handles attaching event callbacks
139# 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
140# registry (== where the callback attaches to). 781# registry (== where the callback attaches to).
141sub _attach(\@$\@) { 782sub _attach {
142 my ($registry, $klass, $arg) = @_; 783 my ($registry, $klass, @arg) = @_;
143 784
785 my $object_type;
144 my $prio = 0; 786 my $prio = 0;
145
146 my %undo = (
147 registry => $registry,
148 cb => [],
149 );
150
151 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;
152 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
153 while (@$arg) { 794 while (@arg) {
154 my $type = shift @$arg; 795 my $type = shift @arg;
155 796
156 if ($type eq "prio") { 797 if ($type eq "prio") {
157 $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] ||= [];
158 808
159 } elsif ($type eq "package") { 809 } elsif ($type eq "package") {
160 my $pkg = shift @$arg; 810 my $pkg = shift @arg;
161 811
162 while (my ($name, $id) = each %cb_id) { 812 while (my ($name, $id) = each %cb_id) {
163 if (my $cb = $pkg->can ($name)) { 813 if (my $cb = $pkg->can ($name)) {
164 _attach_cb $registry, %undo, $id, $prio, $cb; 814 _attach_cb $registry, $id, $prio, $cb;
165 } 815 }
166 } 816 }
167 817
168 } elsif (exists $cb_id{$type}) { 818 } elsif (exists $cb_id{$type}) {
169 _attach_cb $registry, %undo, $cb_id{$type}, $prio, shift @$arg; 819 _attach_cb $registry, $cb_id{$type}, $prio, shift @arg;
170 820
171 } elsif (ref $type) { 821 } elsif (ref $type) {
172 warn "attaching objects not supported, ignoring.\n"; 822 warn "attaching objects not supported, ignoring.\n";
173 823
174 } else { 824 } else {
175 shift @$arg; 825 shift @arg;
176 warn "attach argument '$type' not supported, ignoring.\n"; 826 warn "attach argument '$type' not supported, ignoring.\n";
177 } 827 }
178 } 828 }
179
180 \%undo
181} 829}
182 830
183sub cf::object::attach { 831sub _object_attach {
184 die; 832 my ($obj, $name, %arg) = @_;
185}
186 833
187sub attach_global { 834 return if exists $obj->{_attachment}{$name};
188 _attach @CB_GLOBAL, KLASS_GLOBAL, @_
189}
190 835
191sub attach_to_type { 836 if (my $attach = $attachment{$name}) {
192 my $type = shift; 837 my $registry = $obj->registry;
193 _attach @{$CB_TYPE[$type]}, KLASS_OBJECT, @_
194}
195 838
196sub attach_to_objects { 839 for (@$attach) {
197 _attach @CB_OBJECT, KLASS_OBJECT, @_ 840 my ($klass, @attach) = @$_;
198} 841 _attach $registry, $klass, @attach;
842 }
199 843
200sub attach_to_players { 844 $obj->{$name} = \%arg;
201 _attach @CB_PLAYER, KLASS_PLAYER, @_ 845 } else {
202} 846 warn "object uses attachment '$name' which is not available, postponing.\n";
847 }
203 848
204sub attach_to_maps { 849 $obj->{_attachment}{$name} = undef;
205 _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 $@;
206} 893}
207 894
208our $override; 895our $override;
896our @INVOKE_RESULTS = (); # referenced from .xs code. TODO: play tricks with reify and mortals?
209 897
210sub override() { 898sub override {
211 $override = 1 899 $override = 1;
900 @INVOKE_RESULTS = (@_);
212} 901}
213 902
214sub invoke { 903sub do_invoke {
215 my $event = shift; 904 my $event = shift;
216 my $callbacks = shift; 905 my $callbacks = shift;
217 906
907 @INVOKE_RESULTS = ();
908
218 local $override; 909 local $override;
219 910
220 for (@$callbacks) { 911 for (@$callbacks) {
221 eval { &{$_->[1]} }; 912 eval { &{$_->[1]} };
222 913
223 if ($@) { 914 if ($@) {
224 warn "$@"; 915 warn "$@";
225 warn "... while processing $EVENT[$event][0] event, skipping processing altogether.\n"; 916 warn "... while processing $EVENT[$event][0](@_) event, skipping processing altogether.\n";
226 override; 917 override;
227 } 918 }
228 919
229 return 1 if $override; 920 return 1 if $override;
230 } 921 }
231 922
232 0 923 0
233} 924}
234 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
235############################################################################# 940#############################################################################
236# old plug-in events 941# object support
942#
237 943
238sub inject_event { 944sub _can_merge {
239 my $extension = shift; 945 my ($ob1, $ob2) = @_;
240 my $event_code = shift;
241 946
242 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
243 or return; 1056 or return;
244 1057
245 &$cb 1058 unless (aio_stat "$filename.pst") {
246} 1059 (aio_load "$filename.pst", $av) >= 0
247
248sub inject_global_event {
249 my $event = shift;
250
251 my $cb = $hook[$event]
252 or return; 1060 or return;
253 1061 $av = eval { (Storable::thaw $av)->{objs} };
254 List::Util::max map &$_, values %$cb
255}
256
257sub inject_command {
258 my ($name, $obj, $params) = @_;
259
260 for my $cmd (@{ $command{$name} }) {
261 $cmd->[1]->($obj, $params);
262 } 1062 }
263 1063
264 -1 1064 warn sprintf "loading %s (%d)\n",
1065 $filename, length $data, scalar @{$av || []};
1066 return ($data, $av);
265} 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
266 1084
267sub register_command { 1085sub register_command {
268 my ($name, $time, $cb) = @_; 1086 my ($name, $cb) = @_;
269 1087
270 my $caller = caller; 1088 my $caller = caller;
271 #warn "registering command '$name/$time' to '$caller'"; 1089 #warn "registering command '$name/$time' to '$caller'";
272 1090
273 push @{ $command{$name} }, [$time, $cb, $caller]; 1091 push @{ $COMMAND{$name} }, [$caller, $cb];
274 $COMMAND{"$name\000"} = List::Util::max map $_->[0], @{ $command{$name} };
275} 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
276 1117
277sub register_extcmd { 1118sub register_extcmd {
278 my ($name, $cb) = @_; 1119 my ($name, $cb) = @_;
279 1120
280 my $caller = caller; 1121 $EXTCMD{$name} = $cb;
281 #warn "registering extcmd '$name' to '$caller'";
282
283 $extcmd{$name} = [$cb, $caller];
284} 1122}
285 1123
286sub register { 1124sub register_exticmd {
287 my ($base, $pkg) = @_; 1125 my ($name, $cb) = @_;
288 1126
289 for my $idx (0 .. $#PLUGIN_EVENT) { 1127 $EXTICMD{$name} = $cb;
290 if (my $ref = $pkg->can ("on_$PLUGIN_EVENT[$idx]")) {
291 #warn "registering $PLUGIN_EVENT[$idx] hook to '$pkg'\n";
292 $hook[$idx]{$base} = $ref;
293 }
294 }
295} 1128}
296 1129
297sub load_extension { 1130cf::player->attach (
298 my ($path) = @_; 1131 on_command => sub {
1132 my ($pl, $name, $params) = @_;
299 1133
300 $path =~ /([^\/\\]+)\.ext$/ or die "$path"; 1134 my $cb = $COMMAND{$name}
301 my $base = $1; 1135 or return;
302 my $pkg = $1;
303 $pkg =~ s/[^[:word:]]/_/g;
304 $pkg = "ext::$pkg";
305 1136
306 warn "loading '$path' into '$pkg'\n"; 1137 for my $cmd (@$cb) {
307 1138 $cmd->[1]->($pl->ob, $params);
308 open my $fh, "<:utf8", $path
309 or die "$path: $!";
310
311 my $source =
312 "package $pkg; use strict; use utf8;\n"
313 . "#line 1 \"$path\"\n{\n"
314 . (do { local $/; <$fh> })
315 . "\n};\n1";
316
317 eval $source
318 or die "$path: $@";
319
320 push @exts, $pkg;
321 $ext_pkg{$base} = $pkg;
322
323# no strict 'refs';
324# @{"$pkg\::ISA"} = ext::;
325
326 register $base, $pkg;
327}
328
329sub unload_extension {
330 my ($pkg) = @_;
331
332 warn "removing extension $pkg\n";
333
334 # remove hooks
335 for my $idx (0 .. $#PLUGIN_EVENT) {
336 delete $hook[$idx]{$pkg};
337 }
338
339 # remove commands
340 for my $name (keys %command) {
341 my @cb = grep $_->[2] ne $pkg, @{ $command{$name} };
342
343 if (@cb) {
344 $command{$name} = \@cb;
345 $COMMAND{"$name\000"} = List::Util::max map $_->[0], @cb;
346 } else {
347 delete $command{$name};
348 delete $COMMAND{"$name\000"};
349 }
350 }
351
352 # remove extcmds
353 for my $name (grep $extcmd{$_}[1] eq $pkg, keys %extcmd) {
354 delete $extcmd{$name};
355 }
356
357 if (my $cb = $pkg->can ("unload")) {
358 eval {
359 $cb->($pkg);
360 1
361 } or warn "$pkg unloaded, but with errors: $@";
362 }
363
364 Symbol::delete_package $pkg;
365}
366
367sub load_extensions {
368 my $LIBDIR = maps_directory "perl";
369
370 for my $ext (<$LIBDIR/*.ext>) {
371 next unless -r $ext;
372 eval {
373 load_extension $ext;
374 1
375 } or warn "$ext not loaded: $@";
376 }
377}
378
379sub _perl_reload(&) {
380 my ($msg) = @_;
381
382 $msg->("reloading...");
383
384 eval {
385 # 1. cancel all watchers
386 $_->cancel for Event::all_watchers;
387
388 # 2. unload all extensions
389 for (@exts) {
390 $msg->("unloading <$_>");
391 unload_extension $_;
392 }
393
394 # 3. unload all modules loaded from $LIBDIR
395 while (my ($k, $v) = each %INC) {
396 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
397
398 $msg->("removing <$k>");
399 delete $INC{$k};
400
401 $k =~ s/\.pm$//;
402 $k =~ s/\//::/g;
403
404 if (my $cb = $k->can ("unload_module")) {
405 $cb->();
406 }
407
408 Symbol::delete_package $k;
409 }
410
411 # 4. get rid of safe::, as good as possible
412 Symbol::delete_package "safe::$_"
413 for qw(cf::object cf::object::map cf::object::player cf::player cf::map cf::party cf::region);
414
415 # 5. remove register_script_function callbacks
416 # TODO
417
418 # 6. unload cf.pm "a bit"
419 delete $INC{"cf.pm"};
420
421 # don't, removes xs symbols, too,
422 # and global variables created in xs
423 #Symbol::delete_package __PACKAGE__;
424
425 # 7. reload cf.pm
426 $msg->("reloading cf.pm");
427 require cf;
428 };
429 $msg->($@) if $@;
430
431 $msg->("reloaded");
432};
433
434sub perl_reload() {
435 _perl_reload {
436 warn $_[0];
437 print "$_[0]\n";
438 };
439}
440
441register_command "perl-reload", 0, sub {
442 my ($who, $arg) = @_;
443
444 if ($who->flag (FLAG_WIZ)) {
445 _perl_reload {
446 warn $_[0];
447 $who->message ($_[0]);
448 }; 1139 }
1140
1141 cf::override;
449 } 1142 },
450};
451
452#############################################################################
453# utility functions
454
455use JSON::Syck (); # TODO# replace by JSON::PC once working
456
457sub from_json($) {
458 $JSON::Syck::ImplicitUnicode = 1; # work around JSON::Syck bugs
459 JSON::Syck::Load $_[0]
460}
461
462sub to_json($) {
463 $JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs
464 JSON::Syck::Dump $_[0]
465}
466
467#############################################################################
468# extcmd framework, basically convert ext <msg>
469# into pkg::->on_extcmd_arg1 (...) while shortcutting a few
470
471attach_global
472 on_extcmd => sub { 1143 on_extcmd => sub {
473 my ($pl, $buf) = @_; 1144 my ($pl, $buf) = @_;
474 1145
475 my $msg = eval { from_json $buf }; 1146 my $msg = eval { $pl->ns->{json_coder}->decode ($buf) };
476 1147
477 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
478 if (my $cb = $extcmd{$msg->{msgtype}}) { 1154 if (my $cb = $EXTCMD{$type}) {
479 if (my %reply = $cb->[0]->($pl, $msg)) { 1155 my @reply = $cb->($pl, @payload);
1156
480 $pl->ext_reply ($msg->{msgid}, %reply); 1157 $pl->ext_reply ($reply, @reply)
481 } 1158 if $reply;
482 } 1159 }
483 } else { 1160 } else {
484 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n"; 1161 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
485 } 1162 }
486 1163
487 cf::override; 1164 cf::override;
488 }, 1165 },
489; 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}
490 1240
491############################################################################# 1241#############################################################################
492# load/save/clean perl data associated with a map
493 1242
494*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_neighbours {
495 my ($map) = @_; 1922 my ($map) = @_;
496 1923
497 my $path = $map->tmpname; 1924 my @neigh; # diagonal neighbours
498 defined $path or return;
499 1925
500 unlink "$path.cfperl"; 1926 for (0 .. 3) {
501}; 1927 my $neigh = $map->tile_path ($_)
1928 or next;
1929 $neigh = find $neigh, $map
1930 or next;
1931 $neigh->load;
502 1932
503*cf::mapsupport::on_swapin = 1933 push @neigh,
504*cf::mapsupport::on_load = sub { 1934 [$neigh->tile_path (($_ + 3) % 4), $neigh],
1935 [$neigh->tile_path (($_ + 1) % 4), $neigh];
1936 }
1937
1938 for (grep defined $_->[0], @neigh) {
1939 my ($path, $origin) = @$_;
1940 my $neigh = find $path, $origin
1941 or next;
1942 $neigh->load;
1943 }
1944}
1945
1946sub find_sync {
1947 my ($path, $origin) = @_;
1948
1949 cf::sync_job { find $path, $origin }
1950}
1951
1952sub do_load_sync {
505 my ($map) = @_; 1953 my ($map) = @_;
506 1954
507 my $path = $map->tmpname; 1955 cf::sync_job { $map->load };
508 $path = $map->path unless defined $path; 1956}
509 1957
510 open my $fh, "<:raw", "$path.cfperl" 1958our %MAP_PREFETCH;
511 or return; # no perl data 1959our $MAP_PREFETCHER = undef;
512 1960
513 my $data = Storable::thaw do { local $/; <$fh> }; 1961sub find_async {
1962 my ($path, $origin) = @_;
514 1963
515 $data->{version} <= 1 1964 $path = normalise $path, $origin && $origin->{path};
516 or return; # too new
517 1965
518 $map->_set_obs ($data->{obs}); 1966 if (my $map = $cf::MAP{$path}) {
519}; 1967 return $map if $map->in_memory == cf::MAP_IN_MEMORY;
1968 }
520 1969
521*cf::mapsupport::on_swapout = sub { 1970 undef $MAP_PREFETCH{$path};
522 my ($map) = @_; 1971 $MAP_PREFETCHER ||= cf::async {
1972 while (%MAP_PREFETCH) {
1973 for my $path (keys %MAP_PREFETCH) {
1974 if (my $map = find $path) {
1975 $map->load;
1976 }
523 1977
524 my $path = $map->tmpname; 1978 delete $MAP_PREFETCH{$path};
525 $path = $map->path unless defined $path; 1979 }
526
527 my $obs = $map->_get_obs;
528
529 if (defined $obs) {
530 open my $fh, ">:raw", "$path.cfperl"
531 or die "$path.cfperl: $!";
532
533 stat $path;
534
535 print $fh Storable::nfreeze {
536 size => (stat _)[7],
537 time => (stat _)[9],
538 version => 1,
539 obs => $obs,
540 }; 1980 }
1981 undef $MAP_PREFETCHER;
1982 };
1983 $MAP_PREFETCHER->prio (6);
541 1984
542 chmod SAVE_MODE, "$path.cfperl"; # very racy, but cf-compatible *g* 1985 ()
1986}
1987
1988sub save {
1989 my ($self) = @_;
1990
1991 my $lock = cf::lock_acquire "map_data:" . $self->path;
1992
1993 $self->{last_save} = $cf::RUNTIME;
1994
1995 return unless $self->dirty;
1996
1997 my $save = $self->save_path; utf8::encode $save;
1998 my $uniq = $self->uniq_path; utf8::encode $uniq;
1999
2000 $self->{load_path} = $save;
2001
2002 return if $self->{deny_save};
2003
2004 local $self->{last_access} = $self->last_access;#d#
2005
2006 cf::async {
2007 $_->contr->save for $self->players;
2008 };
2009
2010 if ($uniq) {
2011 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS);
2012 $self->_save_objects ($uniq, cf::IO_UNIQUES);
543 } else { 2013 } else {
544 unlink "$path.cfperl"; 2014 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES);
545 }
546};
547
548attach_to_maps prio => -10000, package => cf::mapsupport::;
549
550#############################################################################
551# load/save perl data associated with player->ob objects
552
553sub all_objects(@) {
554 @_, map all_objects ($_->inv), @_
555}
556
557attach_to_players
558 on_load => sub {
559 my ($pl, $path) = @_;
560
561 for my $o (all_objects $pl->ob) {
562 if (my $value = $o->get_ob_key_value ("_perl_data")) {
563 $o->set_ob_key_value ("_perl_data");
564
565 %$o = %{ Storable::thaw pack "H*", $value };
566 }
567 }
568 }, 2015 }
569 on_save => sub { 2016}
570 my ($pl, $path) = @_;
571 2017
572 $_->set_ob_key_value (_perl_data => unpack "H*", Storable::nfreeze $_) 2018sub swap_out {
573 for grep %$_, all_objects $pl->ob; 2019 my ($self) = @_;
2020
2021 # save first because save cedes
2022 $self->save;
2023
2024 my $lock = cf::lock_acquire "map_data:" . $self->path;
2025
2026 return if $self->players;
2027 return if $self->in_memory != cf::MAP_IN_MEMORY;
2028 return if $self->{deny_save};
2029
2030 $self->clear;
2031 $self->in_memory (cf::MAP_SWAPPED);
2032}
2033
2034sub reset_at {
2035 my ($self) = @_;
2036
2037 # TODO: safety, remove and allow resettable per-player maps
2038 return 1e99 if $self->{deny_reset};
2039
2040 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
2041 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET;
2042
2043 $time + $to
2044}
2045
2046sub should_reset {
2047 my ($self) = @_;
2048
2049 $self->reset_at <= $cf::RUNTIME
2050}
2051
2052sub reset {
2053 my ($self) = @_;
2054
2055 my $lock = cf::lock_acquire "map_data:$self->{path}";
2056
2057 return if $self->players;
2058
2059 warn "resetting map ", $self->path;
2060
2061 $self->in_memory (cf::MAP_SWAPPED);
2062
2063 # need to save uniques path
2064 unless ($self->{deny_save}) {
2065 my $uniq = $self->uniq_path; utf8::encode $uniq;
2066
2067 $self->_save_objects ($uniq, cf::IO_UNIQUES)
2068 if $uniq;
574 }, 2069 }
575;
576 2070
577############################################################################# 2071 delete $cf::MAP{$self->path};
578# core extensions - in perl
579 2072
580=item cf::player::exists $login 2073 $self->clear;
581 2074
582Returns true when the given account exists. 2075 $_->clear_links_to ($self) for values %cf::MAP;
583 2076
584=cut 2077 $self->unlink_save;
585 2078 $self->destroy;
586sub cf::player::exists($) {
587 cf::player::find $_[0]
588 or -f sprintf "%s/%s/%s/%s.pl", cf::localdir, cf::playerdir, ($_[0]) x 2;
589} 2079}
590 2080
2081my $nuke_counter = "aaaa";
2082
2083sub nuke {
2084 my ($self) = @_;
2085
2086 delete $cf::MAP{$self->path};
2087
2088 $self->unlink_save;
2089
2090 bless $self, "cf::map";
2091 delete $self->{deny_reset};
2092 $self->{deny_save} = 1;
2093 $self->reset_timeout (1);
2094 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));
2095
2096 $cf::MAP{$self->path} = $self;
2097
2098 $self->reset; # polite request, might not happen
2099}
2100
2101=item $maps = cf::map::tmp_maps
2102
2103Returns an arrayref with all map paths of currently instantiated and saved
2104maps. May block.
2105
2106=cut
2107
2108sub tmp_maps() {
2109 [
2110 map {
2111 utf8::decode $_;
2112 /\.map$/
2113 ? normalise $_
2114 : ()
2115 } @{ aio_readdir $TMPDIR or [] }
2116 ]
2117}
2118
2119=item $maps = cf::map::random_maps
2120
2121Returns an arrayref with all map paths of currently instantiated and saved
2122random maps. May block.
2123
2124=cut
2125
2126sub random_maps() {
2127 [
2128 map {
2129 utf8::decode $_;
2130 /\.map$/
2131 ? normalise "?random/$_"
2132 : ()
2133 } @{ aio_readdir $RANDOMDIR or [] }
2134 ]
2135}
2136
2137=item cf::map::unique_maps
2138
2139Returns an arrayref of paths of all shared maps that have
2140instantiated unique items. May block.
2141
2142=cut
2143
2144sub unique_maps() {
2145 [
2146 map {
2147 utf8::decode $_;
2148 /\.map$/
2149 ? normalise $_
2150 : ()
2151 } @{ aio_readdir $UNIQUEDIR or [] }
2152 ]
2153}
2154
2155package cf;
2156
2157=back
2158
2159=head3 cf::object
2160
2161=cut
2162
2163package cf::object;
2164
2165=over 4
2166
2167=item $ob->inv_recursive
2168
2169Returns the inventory of the object _and_ their inventories, recursively.
2170
2171=cut
2172
2173sub inv_recursive_;
2174sub inv_recursive_ {
2175 map { $_, inv_recursive_ $_->inv } @_
2176}
2177
2178sub inv_recursive {
2179 inv_recursive_ inv $_[0]
2180}
2181
2182package cf;
2183
2184=back
2185
2186=head3 cf::object::player
2187
2188=over 4
2189
591=item $player->reply ($npc, $msg[, $flags]) 2190=item $player_object->reply ($npc, $msg[, $flags])
592 2191
593Sends a message to the player, as if the npc C<$npc> replied. C<$npc> 2192Sends a message to the player, as if the npc C<$npc> replied. C<$npc>
594can be C<undef>. Does the right thing when the player is currently in a 2193can be C<undef>. Does the right thing when the player is currently in a
595dialogue with the given NPC character. 2194dialogue with the given NPC character.
596 2195
597=cut 2196=cut
598 2197
599# rough implementation of a future "reply" method that works 2198# rough implementation of a future "reply" method that works
600# with dialog boxes. 2199# with dialog boxes.
2200#TODO: the first argument must go, split into a $npc->reply_to ( method
601sub cf::object::player::reply($$$;$) { 2201sub cf::object::player::reply($$$;$) {
602 my ($self, $npc, $msg, $flags) = @_; 2202 my ($self, $npc, $msg, $flags) = @_;
603 2203
604 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4; 2204 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4;
605 2205
606 if ($self->{record_replies}) { 2206 if ($self->{record_replies}) {
607 push @{ $self->{record_replies} }, [$npc, $msg, $flags]; 2207 push @{ $self->{record_replies} }, [$npc, $msg, $flags];
2208
608 } else { 2209 } else {
2210 my $pl = $self->contr;
2211
2212 if ($pl->{npc_dialog} && $pl->{npc_dialog}->{id}) {
2213 my $dialog = $pl->{npc_dialog};
2214 $dialog->{pl}->ext_msg ($dialog->{id}, update => msg => $dialog->{pl}->expand_cfpod ($msg));
2215
2216 } else {
609 $msg = $npc->name . " says: $msg" if $npc; 2217 $msg = $npc->name . " says: $msg" if $npc;
610 $self->message ($msg, $flags); 2218 $self->message ($msg, $flags);
2219 }
2220 }
2221}
2222
2223=item $object->send_msg ($channel, $msg, $color, [extra...])
2224
2225=cut
2226
2227sub cf::object::send_msg {
2228 my $pl = shift->contr
2229 or return;
2230 $pl->send_msg (@_);
2231}
2232
2233=item $player_object->may ("access")
2234
2235Returns wether the given player is authorized to access resource "access"
2236(e.g. "command_wizcast").
2237
2238=cut
2239
2240sub cf::object::player::may {
2241 my ($self, $access) = @_;
2242
2243 $self->flag (cf::FLAG_WIZ) ||
2244 (ref $cf::CFG{"may_$access"}
2245 ? scalar grep $self->name eq $_, @{$cf::CFG{"may_$access"}}
2246 : $cf::CFG{"may_$access"})
2247}
2248
2249=item $player_object->enter_link
2250
2251Freezes the player and moves him/her to a special map (C<{link}>).
2252
2253The player should be reasonably safe there for short amounts of time. You
2254I<MUST> call C<leave_link> as soon as possible, though.
2255
2256Will never block.
2257
2258=item $player_object->leave_link ($map, $x, $y)
2259
2260Moves the player out of the special C<{link}> map onto the specified
2261map. If the map is not valid (or omitted), the player will be moved back
2262to the location he/she was before the call to C<enter_link>, or, if that
2263fails, to the emergency map position.
2264
2265Might block.
2266
2267=cut
2268
2269sub link_map {
2270 unless ($LINK_MAP) {
2271 $LINK_MAP = cf::map::find "{link}"
2272 or cf::cleanup "FATAL: unable to provide {link} map, exiting.";
2273 $LINK_MAP->load;
2274 }
2275
2276 $LINK_MAP
2277}
2278
2279sub cf::object::player::enter_link {
2280 my ($self) = @_;
2281
2282 $self->deactivate_recursive;
2283
2284 return if UNIVERSAL::isa $self->map, "ext::map_link";
2285
2286 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y]
2287 if $self->map && $self->map->{path} ne "{link}";
2288
2289 $self->enter_map ($LINK_MAP || link_map, 10, 10);
2290}
2291
2292sub cf::object::player::leave_link {
2293 my ($self, $map, $x, $y) = @_;
2294
2295 return unless $self->contr->active;
2296
2297 my $link_pos = delete $self->{_link_pos};
2298
2299 unless ($map) {
2300 # restore original map position
2301 ($map, $x, $y) = @{ $link_pos || [] };
2302 $map = cf::map::find $map;
2303
2304 unless ($map) {
2305 ($map, $x, $y) = @$EMERGENCY_POSITION;
2306 $map = cf::map::find $map
2307 or die "FATAL: cannot load emergency map\n";
2308 }
2309 }
2310
2311 ($x, $y) = (-1, -1)
2312 unless (defined $x) && (defined $y);
2313
2314 # use -1 or undef as default coordinates, not 0, 0
2315 ($x, $y) = ($map->enter_x, $map->enter_y)
2316 if $x <=0 && $y <= 0;
2317
2318 $map->load;
2319 $map->load_neighbours;
2320
2321 return unless $self->contr->active;
2322 $self->activate_recursive;
2323
2324 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
2325 $self->enter_map ($map, $x, $y);
2326}
2327
2328=item $player_object->goto ($path, $x, $y[, $check->($map)[, $done->()]])
2329
2330Moves the player to the given map-path and coordinates by first freezing
2331her, loading and preparing them map, calling the provided $check callback
2332that has to return the map if sucecssful, and then unfreezes the player on
2333the new (success) or old (failed) map position. In either case, $done will
2334be called at the end of this process.
2335
2336=cut
2337
2338our $GOTOGEN;
2339
2340sub cf::object::player::goto {
2341 my ($self, $path, $x, $y, $check, $done) = @_;
2342
2343 # do generation counting so two concurrent goto's will be executed in-order
2344 my $gen = $self->{_goto_generation} = ++$GOTOGEN;
2345
2346 $self->enter_link;
2347
2348 (async {
2349 my $map = eval {
2350 my $map = cf::map::find $path;
2351
2352 if ($map) {
2353 $map = $map->customise_for ($self);
2354 $map = $check->($map) if $check && $map;
2355 } else {
2356 $self->message ("The exit to '$path' is closed", cf::NDI_UNIQUE | cf::NDI_RED);
2357 }
2358
2359 $map
2360 };
2361
2362 if ($@) {
2363 $self->message ("Something went wrong within the server, please report this incident!", cf::NDI_UNIQUE | cf::NDI_RED);
2364 LOG llevError | logBacktrace, Carp::longmess $@;
2365 }
2366
2367 if ($gen == $self->{_goto_generation}) {
2368 delete $self->{_goto_generation};
2369 $self->leave_link ($map, $x, $y);
2370 }
2371
2372 $done->() if $done;
2373 })->prio (1);
2374}
2375
2376=item $player_object->enter_exit ($exit_object)
2377
2378=cut
2379
2380sub parse_random_map_params {
2381 my ($spec) = @_;
2382
2383 my $rmp = { # defaults
2384 xsize => (cf::rndm 15, 40),
2385 ysize => (cf::rndm 15, 40),
2386 symmetry => (cf::rndm 1, cf::SYMMETRY_XY),
2387 #layout => string,
611 } 2388 };
612}
613 2389
614=item $player->ext_reply ($msgid, $msgtype, %msg) 2390 for (split /\n/, $spec) {
2391 my ($k, $v) = split /\s+/, $_, 2;
615 2392
2393 $rmp->{lc $k} = $v if (length $k) && (length $v);
2394 }
2395
2396 $rmp
2397}
2398
2399sub prepare_random_map {
2400 my ($exit) = @_;
2401
2402 my $guard = cf::lock_acquire "exit_prepare:$exit";
2403
2404 # all this does is basically replace the /! path by
2405 # a new random map path (?random/...) with a seed
2406 # that depends on the exit object
2407
2408 my $rmp = parse_random_map_params $exit->msg;
2409
2410 if ($exit->map) {
2411 $rmp->{region} = $exit->region->name;
2412 $rmp->{origin_map} = $exit->map->path;
2413 $rmp->{origin_x} = $exit->x;
2414 $rmp->{origin_y} = $exit->y;
2415 }
2416
2417 $rmp->{random_seed} ||= $exit->random_seed;
2418
2419 my $data = cf::to_json $rmp;
2420 my $md5 = Digest::MD5::md5_hex $data;
2421 my $meta = "$RANDOMDIR/$md5.meta";
2422
2423 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) {
2424 aio_write $fh, 0, (length $data), $data, 0;
2425 undef $fh;
2426 aio_rename "$meta~", $meta;
2427
2428 $exit->slaying ("?random/$md5");
2429 $exit->msg (undef);
2430 }
2431}
2432
2433sub cf::object::player::enter_exit {
2434 my ($self, $exit) = @_;
2435
2436 return unless $self->type == cf::PLAYER;
2437
2438 if ($exit->slaying eq "/!") {
2439 #TODO: this should de-fi-ni-te-ly not be a sync-job
2440 # the problem is that $exit might not survive long enough
2441 # so it needs to be done right now, right here
2442 cf::sync_job { prepare_random_map $exit };
2443 }
2444
2445 my $slaying = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path;
2446 my $hp = $exit->stats->hp;
2447 my $sp = $exit->stats->sp;
2448
2449 $self->enter_link;
2450
2451 # if exit is damned, update players death & WoR home-position
2452 $self->contr->savebed ($slaying, $hp, $sp)
2453 if $exit->flag (FLAG_DAMNED);
2454
2455 (async {
2456 $self->deactivate_recursive; # just to be sure
2457 unless (eval {
2458 $self->goto ($slaying, $hp, $sp);
2459
2460 1;
2461 }) {
2462 $self->message ("Something went wrong deep within the crossfire server. "
2463 . "I'll try to bring you back to the map you were before. "
2464 . "Please report this to the dungeon master!",
2465 cf::NDI_UNIQUE | cf::NDI_RED);
2466
2467 warn "ERROR in enter_exit: $@";
2468 $self->leave_link;
2469 }
2470 })->prio (1);
2471}
2472
2473=head3 cf::client
2474
2475=over 4
2476
2477=item $client->send_drawinfo ($text, $flags)
2478
2479Sends a drawinfo packet to the client. Circumvents output buffering so
2480should not be used under normal circumstances.
2481
2482=cut
2483
2484sub cf::client::send_drawinfo {
2485 my ($self, $text, $flags) = @_;
2486
2487 utf8::encode $text;
2488 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);
2489}
2490
2491=item $client->send_msg ($channel, $msg, $color, [extra...])
2492
2493Send a drawinfo or msg packet to the client, formatting the msg for the
2494client if neccessary. C<$type> should be a string identifying the type of
2495the message, with C<log> being the default. If C<$color> is negative, suppress
2496the message unless the client supports the msg packet.
2497
2498=cut
2499
2500sub cf::client::send_msg {
2501 my ($self, $channel, $msg, $color, @extra) = @_;
2502
2503 $msg = $self->pl->expand_cfpod ($msg);
2504
2505 $color &= cf::NDI_CLIENT_MASK; # just in case...
2506
2507 if (ref $channel) {
2508 # send meta info to client, if not yet sent
2509 unless (exists $self->{channel}{$channel->{id}}) {
2510 $self->{channel}{$channel->{id}} = $channel;
2511 $self->ext_msg (channel_info => $channel);
2512 }
2513
2514 $channel = $channel->{id};
2515 }
2516
2517 return unless @extra || length $msg;
2518
2519 if ($self->can_msg) {
2520 # default colour, mask it out
2521 $color &= ~(cf::NDI_COLOR_MASK | cf::NDI_DEF)
2522 if $color & cf::NDI_DEF;
2523
2524 $self->send_packet ("msg " . $self->{json_coder}->encode (
2525 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]));
2526 } else {
2527 if ($color >= 0) {
2528 # replace some tags by gcfclient-compatible ones
2529 for ($msg) {
2530 1 while
2531 s/<b>([^<]*)<\/b>/[b]${1}[\/b]/
2532 || s/<i>([^<]*)<\/i>/[i]${1}[\/i]/
2533 || s/<u>([^<]*)<\/u>/[ul]${1}[\/ul]/
2534 || s/<tt>([^<]*)<\/tt>/[fixed]${1}[\/fixed]/
2535 || s/<fg name=\"([^"]+)\">([^<]*)<\/fg>/[color=$1]${2}[\/color]/;
2536 }
2537
2538 $color &= cf::NDI_COLOR_MASK;
2539
2540 utf8::encode $msg;
2541
2542 if (0 && $msg =~ /\[/) {
2543 # COMMAND/INFO
2544 $self->send_packet ("drawextinfo $color 10 8 $msg")
2545 } else {
2546 $msg =~ s/\[\/?(?:b|i|u|fixed|color)[^\]]*\]//g;
2547 $self->send_packet ("drawinfo $color $msg")
2548 }
2549 }
2550 }
2551}
2552
2553=item $client->ext_msg ($type, @msg)
2554
616Sends an ext reply to the player. 2555Sends an ext event to the client.
617 2556
618=cut 2557=cut
619 2558
620sub cf::player::ext_reply($$$%) { 2559sub cf::client::ext_msg($$@) {
621 my ($self, $id, %msg) = @_; 2560 my ($self, $type, @msg) = @_;
622 2561
623 $msg{msgid} = $id; 2562 my $extcmd = $self->extcmd;
624 2563
625 $self->send ("ext " . to_json \%msg); 2564 if ($extcmd == 2) {
2565 $self->send_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
2566 } elsif ($extcmd == 1) { # TODO: remove
2567 push @msg, msgtype => "event_$type";
2568 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2569 }
626} 2570}
627 2571
628############################################################################# 2572=item $success = $client->query ($flags, "text", \&cb)
629# map scripting support 2573
2574Queues a query to the client, calling the given callback with
2575the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>,
2576C<cf::CS_QUERY_SINGLECHAR> or C<cf::CS_QUERY_HIDEINPUT> or C<0>.
2577
2578Queries can fail, so check the return code. Or don't, as queries will
2579become reliable at some point in the future.
2580
2581=cut
2582
2583sub cf::client::query {
2584 my ($self, $flags, $text, $cb) = @_;
2585
2586 return unless $self->state == ST_PLAYING
2587 || $self->state == ST_SETUP
2588 || $self->state == ST_CUSTOM;
2589
2590 $self->state (ST_CUSTOM);
2591
2592 utf8::encode $text;
2593 push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb];
2594
2595 $self->send_packet ($self->{query_queue}[0][0])
2596 if @{ $self->{query_queue} } == 1;
2597
2598 1
2599}
2600
2601cf::client->attach (
2602 on_connect => sub {
2603 my ($ns) = @_;
2604
2605 $ns->{json_coder} = JSON::XS->new->utf8->max_size (1e6)->convert_blessed;
2606 },
2607 on_reply => sub {
2608 my ($ns, $msg) = @_;
2609
2610 # this weird shuffling is so that direct followup queries
2611 # get handled first
2612 my $queue = delete $ns->{query_queue}
2613 or return; # be conservative, not sure how that can happen, but we saw a crash here
2614
2615 (shift @$queue)->[1]->($msg);
2616 return unless $ns->valid; # temporary(?) workaround for callback destroying socket
2617
2618 push @{ $ns->{query_queue} }, @$queue;
2619
2620 if (@{ $ns->{query_queue} } == @$queue) {
2621 if (@$queue) {
2622 $ns->send_packet ($ns->{query_queue}[0][0]);
2623 } else {
2624 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM;
2625 }
2626 }
2627 },
2628 on_exticmd => sub {
2629 my ($ns, $buf) = @_;
2630
2631 my $msg = eval { $ns->{json_coder}->decode ($buf) };
2632
2633 if (ref $msg) {
2634 my ($type, $reply, @payload) =
2635 "ARRAY" eq ref $msg
2636 ? @$msg
2637 : ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
2638
2639 if (my $cb = $EXTICMD{$type}) {
2640 my @reply = $cb->($ns, @payload);
2641
2642 $ns->ext_reply ($reply, @reply)
2643 if $reply;
2644 }
2645 } else {
2646 warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";
2647 }
2648
2649 cf::override;
2650 },
2651);
2652
2653=item $client->async (\&cb)
2654
2655Create a new coroutine, running the specified callback. The coroutine will
2656be automatically cancelled when the client gets destroyed (e.g. on logout,
2657or loss of connection).
2658
2659=cut
2660
2661sub cf::client::async {
2662 my ($self, $cb) = @_;
2663
2664 my $coro = &Coro::async ($cb);
2665
2666 $coro->on_destroy (sub {
2667 delete $self->{_coro}{$coro+0};
2668 });
2669
2670 $self->{_coro}{$coro+0} = $coro;
2671
2672 $coro
2673}
2674
2675cf::client->attach (
2676 on_destroy => sub {
2677 my ($ns) = @_;
2678
2679 $_->cancel for values %{ (delete $ns->{_coro}) || {} };
2680 },
2681);
2682
2683=back
2684
2685
2686=head2 SAFE SCRIPTING
2687
2688Functions that provide a safe environment to compile and execute
2689snippets of perl code without them endangering the safety of the server
2690itself. Looping constructs, I/O operators and other built-in functionality
2691is not available in the safe scripting environment, and the number of
2692functions and methods that can be called is greatly reduced.
2693
2694=cut
630 2695
631our $safe = new Safe "safe"; 2696our $safe = new Safe "safe";
632our $safe_hole = new Safe::Hole; 2697our $safe_hole = new Safe::Hole;
633 2698
634$SIG{FPE} = 'IGNORE'; 2699$SIG{FPE} = 'IGNORE';
635 2700
636$safe->permit_only (Opcode::opset qw(:base_core :base_mem :base_orig :base_math sort time)); 2701$safe->permit_only (Opcode::opset qw(
2702 :base_core :base_mem :base_orig :base_math
2703 grepstart grepwhile mapstart mapwhile
2704 sort time
2705));
637 2706
638# here we export the classes and methods available to script code 2707# here we export the classes and methods available to script code
639 2708
2709=pod
2710
2711The following functions and methods are available within a safe environment:
2712
2713 cf::object
2714 contr pay_amount pay_player map x y force_find force_add
2715 insert remove name archname title slaying race
2716
2717 cf::object::player
2718 player
2719
2720 cf::player
2721 peaceful
2722
2723 cf::map
2724 trigger
2725
2726=cut
2727
640for ( 2728for (
641 ["cf::object" => qw(contr pay_amount pay_player)], 2729 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y
2730 insert remove inv name archname title slaying race)],
642 ["cf::object::player" => qw(player)], 2731 ["cf::object::player" => qw(player)],
643 ["cf::player" => qw(peaceful)], 2732 ["cf::player" => qw(peaceful)],
2733 ["cf::map" => qw(trigger)],
644) { 2734) {
645 no strict 'refs'; 2735 no strict 'refs';
646 my ($pkg, @funs) = @$_; 2736 my ($pkg, @funs) = @$_;
647 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"}) 2737 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})
648 for @funs; 2738 for @funs;
649} 2739}
2740
2741=over 4
2742
2743=item @retval = safe_eval $code, [var => value, ...]
2744
2745Compiled and executes the given perl code snippet. additional var/value
2746pairs result in temporary local (my) scalar variables of the given name
2747that are available in the code snippet. Example:
2748
2749 my $five = safe_eval '$first + $second', first => 1, second => 4;
2750
2751=cut
650 2752
651sub safe_eval($;@) { 2753sub safe_eval($;@) {
652 my ($code, %vars) = @_; 2754 my ($code, %vars) = @_;
653 2755
654 my $qcode = $code; 2756 my $qcode = $code;
… …
677 } 2779 }
678 2780
679 wantarray ? @res : $res[0] 2781 wantarray ? @res : $res[0]
680} 2782}
681 2783
2784=item cf::register_script_function $function => $cb
2785
2786Register a function that can be called from within map/npc scripts. The
2787function should be reasonably secure and should be put into a package name
2788like the extension.
2789
2790Example: register a function that gets called whenever a map script calls
2791C<rent::overview>, as used by the C<rent> extension.
2792
2793 cf::register_script_function "rent::overview" => sub {
2794 ...
2795 };
2796
2797=cut
2798
682sub register_script_function { 2799sub register_script_function {
683 my ($fun, $cb) = @_; 2800 my ($fun, $cb) = @_;
684 2801
685 no strict 'refs'; 2802 no strict 'refs';
686 *{"safe::$fun"} = $safe_hole->wrap ($cb); 2803 *{"safe::$fun"} = $safe_hole->wrap ($cb);
687} 2804}
688 2805
2806=back
2807
2808=cut
2809
689############################################################################# 2810#############################################################################
690# the server's main() 2811# the server's init and main functions
2812
2813sub load_facedata($) {
2814 my ($path) = @_;
2815
2816 my $enc = JSON::XS->new->utf8->canonical;
2817
2818 warn "loading facedata from $path\n";
2819
2820 my $facedata;
2821 0 < aio_load $path, $facedata
2822 or die "$path: $!";
2823
2824 $facedata = Coro::Storable::thaw $facedata;
2825
2826 $facedata->{version} == 2
2827 or cf::cleanup "$path: version mismatch, cannot proceed.";
2828
2829 # patch in the exptable
2830 cf::cede_to_tick;
2831 $facedata->{resource}{"res/exp_table"} = {
2832 type => FT_RSRC,
2833 data => $enc->encode ([map cf::level_to_min_exp $_, 0 .. cf::settings->max_level]),
2834 };
2835 cf::cede_to_tick;
2836
2837 {
2838 my $faces = $facedata->{faceinfo};
2839
2840 while (my ($face, $info) = each %$faces) {
2841 my $idx = (cf::face::find $face) || cf::face::alloc $face;
2842 cf::face::set_visibility $idx, $info->{visibility};
2843 cf::face::set_magicmap $idx, $info->{magicmap};
2844 cf::face::set_data $idx, 0, $info->{data32}, Digest::MD5::md5 $info->{data32};
2845 cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64};
2846
2847 cf::cede_to_tick;
2848 }
2849
2850 while (my ($face, $info) = each %$faces) {
2851 next unless $info->{smooth};
2852 my $idx = cf::face::find $face
2853 or next;
2854 if (my $smooth = cf::face::find $info->{smooth}) {
2855 cf::face::set_smooth $idx, $smooth;
2856 cf::face::set_smoothlevel $idx, $info->{smoothlevel};
2857 } else {
2858 warn "smooth face '$info->{smooth}' not found for face '$face'";
2859 }
2860
2861 cf::cede_to_tick;
2862 }
2863 }
2864
2865 {
2866 my $anims = $facedata->{animinfo};
2867
2868 while (my ($anim, $info) = each %$anims) {
2869 cf::anim::set $anim, $info->{frames}, $info->{facings};
2870 cf::cede_to_tick;
2871 }
2872
2873 cf::anim::invalidate_all; # d'oh
2874 }
2875
2876 {
2877 # TODO: for gcfclient pleasure, we should give resources
2878 # that gcfclient doesn't grok a >10000 face index.
2879 my $res = $facedata->{resource};
2880
2881 my $soundconf = delete $res->{"res/sound.conf"};
2882
2883 while (my ($name, $info) = each %$res) {
2884 my $idx = (cf::face::find $name) || cf::face::alloc $name;
2885 my $data;
2886
2887 if ($info->{type} & 1) {
2888 # prepend meta info
2889
2890 my $meta = $enc->encode ({
2891 name => $name,
2892 %{ $info->{meta} || {} },
2893 });
2894
2895 $data = pack "(w/a*)*", $meta, $info->{data};
2896 }
2897
2898 cf::face::set_data $idx, 0, $data, Digest::MD5::md5 $data;
2899 cf::face::set_type $idx, $info->{type};
2900
2901 cf::cede_to_tick;
2902 }
2903
2904 if ($soundconf) {
2905 $soundconf = $enc->decode (delete $soundconf->{data});
2906
2907 for (0 .. SOUND_CAST_SPELL_0 - 1) {
2908 my $sound = $soundconf->{compat}[$_]
2909 or next;
2910
2911 my $face = cf::face::find "sound/$sound->[1]";
2912 cf::sound::set $sound->[0] => $face;
2913 cf::sound::old_sound_index $_, $face; # gcfclient-compat
2914 }
2915
2916 while (my ($k, $v) = each %{$soundconf->{event}}) {
2917 my $face = cf::face::find "sound/$v";
2918 cf::sound::set $k => $face;
2919 }
2920 }
2921 }
2922
2923 1
2924}
2925
2926register_exticmd fx_want => sub {
2927 my ($ns, $want) = @_;
2928
2929 while (my ($k, $v) = each %$want) {
2930 $ns->fx_want ($k, $v);
2931 }
2932};
2933
2934sub reload_regions {
2935 load_resource_file "$MAPDIR/regions"
2936 or die "unable to load regions file\n";
2937
2938 for (cf::region::list) {
2939 $_->{match} = qr/$_->{match}/
2940 if exists $_->{match};
2941 }
2942}
2943
2944sub reload_facedata {
2945 load_facedata "$DATADIR/facedata"
2946 or die "unable to load facedata\n";
2947}
2948
2949sub reload_archetypes {
2950 load_resource_file "$DATADIR/archetypes"
2951 or die "unable to load archetypes\n";
2952 #d# NEED to laod twice to resolve forward references
2953 # this really needs to be done in an extra post-pass
2954 # (which needs to be synchronous, so solve it differently)
2955 load_resource_file "$DATADIR/archetypes"
2956 or die "unable to load archetypes\n";
2957}
2958
2959sub reload_treasures {
2960 load_resource_file "$DATADIR/treasures"
2961 or die "unable to load treasurelists\n";
2962}
2963
2964sub reload_resources {
2965 warn "reloading resource files...\n";
2966
2967 reload_regions;
2968 reload_facedata;
2969 #reload_archetypes;#d#
2970 reload_archetypes;
2971 reload_treasures;
2972
2973 warn "finished reloading resource files\n";
2974}
2975
2976sub init {
2977 reload_resources;
2978}
2979
2980sub cfg_load {
2981 open my $fh, "<:utf8", "$CONFDIR/config"
2982 or return;
2983
2984 local $/;
2985 *CFG = YAML::Syck::Load <$fh>;
2986
2987 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37];
2988
2989 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset};
2990 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset};
2991
2992 if (exists $CFG{mlockall}) {
2993 eval {
2994 $CFG{mlockall} ? eval "mlockall()" : eval "munlockall()"
2995 and die "WARNING: m(un)lockall failed: $!\n";
2996 };
2997 warn $@ if $@;
2998 }
2999}
691 3000
692sub main { 3001sub main {
3002 # we must not ever block the main coroutine
3003 local $Coro::idle = sub {
3004 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
3005 (async {
3006 Event::one_event;
3007 })->prio (Coro::PRIO_MAX);
3008 };
3009
3010 cfg_load;
3011 db_init;
3012 load_extensions;
3013
3014 $TICK_WATCHER->start;
693 Event::loop; 3015 Event::loop;
694} 3016}
695 3017
696############################################################################# 3018#############################################################################
697# initialisation 3019# initialisation and cleanup
698 3020
699register "<global>", __PACKAGE__; 3021# install some emergency cleanup handlers
3022BEGIN {
3023 for my $signal (qw(INT HUP TERM)) {
3024 Event->signal (
3025 reentrant => 0,
3026 data => WF_AUTOCANCEL,
3027 signal => $signal,
3028 prio => 0,
3029 cb => sub {
3030 cf::cleanup "SIG$signal";
3031 },
3032 );
3033 }
3034}
3035
3036sub write_runtime {
3037 my $runtime = "$LOCALDIR/runtime";
3038
3039 # first touch the runtime file to show we are still running:
3040 # the fsync below can take a very very long time.
3041
3042 IO::AIO::aio_utime $runtime, undef, undef;
3043
3044 my $guard = cf::lock_acquire "write_runtime";
3045
3046 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644
3047 or return;
3048
3049 my $value = $cf::RUNTIME + 90 + 10;
3050 # 10 is the runtime save interval, for a monotonic clock
3051 # 60 allows for the watchdog to kill the server.
3052
3053 (aio_write $fh, 0, (length $value), $value, 0) <= 0
3054 and return;
3055
3056 # always fsync - this file is important
3057 aio_fsync $fh
3058 and return;
3059
3060 # touch it again to show we are up-to-date
3061 aio_utime $fh, undef, undef;
3062
3063 close $fh
3064 or return;
3065
3066 aio_rename "$runtime~", $runtime
3067 and return;
3068
3069 warn "runtime file written.\n";
3070
3071 1
3072}
3073
3074sub emergency_save() {
3075 my $freeze_guard = cf::freeze_mainloop;
3076
3077 warn "enter emergency perl save\n";
3078
3079 cf::sync_job {
3080 # use a peculiar iteration method to avoid tripping on perl
3081 # refcount bugs in for. also avoids problems with players
3082 # and maps saved/destroyed asynchronously.
3083 warn "begin emergency player save\n";
3084 for my $login (keys %cf::PLAYER) {
3085 my $pl = $cf::PLAYER{$login} or next;
3086 $pl->valid or next;
3087 $pl->save;
3088 }
3089 warn "end emergency player save\n";
3090
3091 warn "begin emergency map save\n";
3092 for my $path (keys %cf::MAP) {
3093 my $map = $cf::MAP{$path} or next;
3094 $map->valid or next;
3095 $map->save;
3096 }
3097 warn "end emergency map save\n";
3098
3099 warn "begin emergency database checkpoint\n";
3100 BDB::db_env_txn_checkpoint $DB_ENV;
3101 warn "end emergency database checkpoint\n";
3102 };
3103
3104 warn "leave emergency perl save\n";
3105}
3106
3107sub post_cleanup {
3108 my ($make_core) = @_;
3109
3110 warn Carp::longmess "post_cleanup backtrace"
3111 if $make_core;
3112}
3113
3114sub do_reload_perl() {
3115 # can/must only be called in main
3116 if ($Coro::current != $Coro::main) {
3117 warn "can only reload from main coroutine";
3118 return;
3119 }
3120
3121 warn "reloading...";
3122
3123 warn "entering sync_job";
3124
3125 cf::sync_job {
3126 cf::write_runtime; # external watchdog should not bark
3127 cf::emergency_save;
3128 cf::write_runtime; # external watchdog should not bark
3129
3130 warn "syncing database to disk";
3131 BDB::db_env_txn_checkpoint $DB_ENV;
3132
3133 # if anything goes wrong in here, we should simply crash as we already saved
3134
3135 warn "cancelling all WF_AUTOCANCEL watchers";
3136 for (Event::all_watchers) {
3137 $_->cancel if $_->data & WF_AUTOCANCEL;
3138 }
3139
3140 warn "flushing outstanding aio requests";
3141 for (;;) {
3142 BDB::flush;
3143 IO::AIO::flush;
3144 Coro::cede;
3145 last unless IO::AIO::nreqs || BDB::nreqs;
3146 warn "iterate...";
3147 }
3148
3149 ++$RELOAD;
3150
3151 warn "cancelling all extension coros";
3152 $_->cancel for values %EXT_CORO;
3153 %EXT_CORO = ();
3154
3155 warn "removing commands";
3156 %COMMAND = ();
3157
3158 warn "removing ext/exti commands";
3159 %EXTCMD = ();
3160 %EXTICMD = ();
3161
3162 warn "unloading/nuking all extensions";
3163 for my $pkg (@EXTS) {
3164 warn "... unloading $pkg";
3165
3166 if (my $cb = $pkg->can ("unload")) {
3167 eval {
3168 $cb->($pkg);
3169 1
3170 } or warn "$pkg unloaded, but with errors: $@";
3171 }
3172
3173 warn "... nuking $pkg";
3174 Symbol::delete_package $pkg;
3175 }
3176
3177 warn "unloading all perl modules loaded from $LIBDIR";
3178 while (my ($k, $v) = each %INC) {
3179 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
3180
3181 warn "... unloading $k";
3182 delete $INC{$k};
3183
3184 $k =~ s/\.pm$//;
3185 $k =~ s/\//::/g;
3186
3187 if (my $cb = $k->can ("unload_module")) {
3188 $cb->();
3189 }
3190
3191 Symbol::delete_package $k;
3192 }
3193
3194 warn "getting rid of safe::, as good as possible";
3195 Symbol::delete_package "safe::$_"
3196 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
3197
3198 warn "unloading cf.pm \"a bit\"";
3199 delete $INC{"cf.pm"};
3200 delete $INC{"cf/pod.pm"};
3201
3202 # don't, removes xs symbols, too,
3203 # and global variables created in xs
3204 #Symbol::delete_package __PACKAGE__;
3205
3206 warn "unload completed, starting to reload now";
3207
3208 warn "reloading cf.pm";
3209 require cf;
3210 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
3211
3212 warn "loading config and database again";
3213 cf::cfg_load;
3214
3215 warn "loading extensions";
3216 cf::load_extensions;
3217
3218 warn "reattaching attachments to objects/players";
3219 _global_reattach; # objects, sockets
3220 warn "reattaching attachments to maps";
3221 reattach $_ for values %MAP;
3222 warn "reattaching attachments to players";
3223 reattach $_ for values %PLAYER;
3224
3225 warn "leaving sync_job";
3226
3227 1
3228 } or do {
3229 warn $@;
3230 warn "error while reloading, exiting.";
3231 exit 1;
3232 };
3233
3234 warn "reloaded";
3235};
3236
3237our $RELOAD_WATCHER; # used only during reload
3238
3239sub reload_perl() {
3240 # doing reload synchronously and two reloads happen back-to-back,
3241 # coro crashes during coro_state_free->destroy here.
3242
3243 $RELOAD_WATCHER ||= Event->timer (
3244 reentrant => 0,
3245 after => 0,
3246 data => WF_AUTOCANCEL,
3247 cb => sub {
3248 do_reload_perl;
3249 undef $RELOAD_WATCHER;
3250 },
3251 );
3252}
3253
3254register_command "reload" => sub {
3255 my ($who, $arg) = @_;
3256
3257 if ($who->flag (FLAG_WIZ)) {
3258 $who->message ("reloading server.");
3259 async { reload_perl };
3260 }
3261};
700 3262
701unshift @INC, $LIBDIR; 3263unshift @INC, $LIBDIR;
702 3264
703load_extensions; 3265my $bug_warning = 0;
704 3266
3267our @WAIT_FOR_TICK;
3268our @WAIT_FOR_TICK_BEGIN;
3269
3270sub wait_for_tick {
3271 return unless $TICK_WATCHER->is_active;
3272 return if $Coro::current == $Coro::main;
3273
3274 my $signal = new Coro::Signal;
3275 push @WAIT_FOR_TICK, $signal;
3276 $signal->wait;
3277}
3278
3279sub wait_for_tick_begin {
3280 return unless $TICK_WATCHER->is_active;
3281 return if $Coro::current == $Coro::main;
3282
3283 my $signal = new Coro::Signal;
3284 push @WAIT_FOR_TICK_BEGIN, $signal;
3285 $signal->wait;
3286}
3287
3288 my $min = 1e6;#d#
3289 my $avg = 10;
705$TICK_WATCHER = Event->timer ( 3290$TICK_WATCHER = Event->timer (
3291 reentrant => 0,
3292 parked => 1,
706 prio => 1, 3293 prio => 0,
707 at => $NEXT_TICK || 1, 3294 at => $NEXT_TICK || $TICK,
3295 data => WF_AUTOCANCEL,
708 cb => sub { 3296 cb => sub {
3297 if ($Coro::current != $Coro::main) {
3298 Carp::cluck "major BUG: server tick called outside of main coro, skipping it"
3299 unless ++$bug_warning > 10;
3300 return;
3301 }
3302
3303 $NOW = $tick_start = Event::time;
3304
709 cf::server_tick; # one server iteration 3305 cf::server_tick; # one server iteration
710 3306
3307 0 && sync_job {#d#
3308 for(1..10) {
711 my $NOW = Event::time; 3309 my $t = Event::time;
3310 my $map = my $map = new_from_path cf::map "/tmp/x.map"
3311 or die;
3312
3313 $map->width (50);
3314 $map->height (50);
3315 $map->alloc;
3316 $map->_load_objects ("/tmp/x.map", 1);
3317 my $t = Event::time - $t;
3318
3319 #next unless $t < 0.0013;#d#
3320 if ($t < $min) {
3321 $min = $t;
3322 }
3323 $avg = $avg * 0.99 + $t * 0.01;
3324 }
3325 warn "XXXXXXXXXXXXXXXXXX min $min avg $avg\n";#d#
3326 exit 0;
3327 # 2007-05-22 02:33:04.569 min 0.00112509727478027 avg 0.0012259249572477
3328 };
3329
3330 $RUNTIME += $TICK;
712 $NEXT_TICK += $TICK; 3331 $NEXT_TICK += $TICK;
713 3332
3333 if ($NOW >= $NEXT_RUNTIME_WRITE) {
3334 $NEXT_RUNTIME_WRITE = $NOW + 10;
3335 Coro::async_pool {
3336 write_runtime
3337 or warn "ERROR: unable to write runtime file: $!";
3338 };
3339 }
3340
3341# my $AFTER = Event::time;
3342# warn $AFTER - $NOW;#d#
3343
3344 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
3345 $sig->send;
3346 }
3347 while (my $sig = shift @WAIT_FOR_TICK) {
3348 $sig->send;
3349 }
3350
3351 $NOW = Event::time;
3352
714 # if we are delayed by four ticks, skip them all 3353 # if we are delayed by four ticks or more, skip them all
715 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4; 3354 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
716 3355
717 $TICK_WATCHER->at ($NEXT_TICK); 3356 $TICK_WATCHER->at ($NEXT_TICK);
718 $TICK_WATCHER->start; 3357 $TICK_WATCHER->start;
3358
3359 $LOAD = ($NOW - $tick_start) / $TICK;
3360 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
3361
3362 _post_tick;
3363
3364
719 }, 3365 },
720); 3366);
721 3367
3368{
3369 BDB::max_poll_time $TICK * 0.1;
3370 $BDB_POLL_WATCHER = Event->io (
3371 reentrant => 0,
3372 fd => BDB::poll_fileno,
3373 poll => 'r',
3374 prio => 0,
3375 data => WF_AUTOCANCEL,
3376 cb => \&BDB::poll_cb,
3377 );
3378 BDB::min_parallel 8;
3379
3380 BDB::set_sync_prepare {
3381 my $status;
3382 my $current = $Coro::current;
3383 (
3384 sub {
3385 $status = $!;
3386 $current->ready; undef $current;
3387 },
3388 sub {
3389 Coro::schedule while defined $current;
3390 $! = $status;
3391 },
3392 )
3393 };
3394
3395 unless ($DB_ENV) {
3396 $DB_ENV = BDB::db_env_create;
3397
3398 cf::sync_job {
3399 eval {
3400 BDB::db_env_open
3401 $DB_ENV,
3402 $BDBDIR,
3403 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN
3404 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE,
3405 0666;
3406
3407 cf::cleanup "db_env_open($BDBDIR): $!" if $!;
3408
3409 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC, 1);
3410 $DB_ENV->set_lk_detect;
3411 };
3412
3413 cf::cleanup "db_env_open(db): $@" if $@;
3414 };
3415 }
3416}
3417
3418{
3419 IO::AIO::min_parallel 8;
3420
3421 undef $Coro::AIO::WATCHER;
3422 IO::AIO::max_poll_time $TICK * 0.1;
3423 $AIO_POLL_WATCHER = Event->io (
3424 reentrant => 0,
3425 data => WF_AUTOCANCEL,
3426 fd => IO::AIO::poll_fileno,
3427 poll => 'r',
3428 prio => 6,
3429 cb => \&IO::AIO::poll_cb,
3430 );
3431}
3432
3433my $_log_backtrace;
3434
3435sub _log_backtrace {
3436 my ($msg, @addr) = @_;
3437
3438 $msg =~ s/\n//;
3439
3440 # limit the # of concurrent backtraces
3441 if ($_log_backtrace < 2) {
3442 ++$_log_backtrace;
3443 async {
3444 my @bt = fork_call {
3445 @addr = map { sprintf "%x", $_ } @addr;
3446 my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X;
3447 open my $fh, "exec addr2line -C -f -i -e \Q$self\E @addr 2>&1 |"
3448 or die "addr2line: $!";
3449
3450 my @funcs;
3451 my @res = <$fh>;
3452 chomp for @res;
3453 while (@res) {
3454 my ($func, $line) = splice @res, 0, 2, ();
3455 push @funcs, "[$func] $line";
3456 }
3457
3458 @funcs
3459 };
3460
3461 LOG llevInfo, "[ABT] $msg\n";
3462 LOG llevInfo, "[ABT] $_\n" for @bt;
3463 --$_log_backtrace;
3464 };
3465 } else {
3466 LOG llevInfo, "[ABT] $msg\n";
3467 LOG llevInfo, "[ABT] [suppressed]\n";
3468 }
3469}
3470
3471# load additional modules
3472use cf::pod;
3473
3474END { cf::emergency_save }
3475
7221 34761
723 3477

Diff Legend

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