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

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines