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

Diff Legend

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