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.97 by root, Fri Dec 22 06:03:20 2006 UTC vs.
Revision 1.533 by root, Thu Apr 29 07:59:17 2010 UTC

1#
2# This file is part of Deliantra, the Roguelike Realtime MMORPG.
3#
4# Copyright (©) 2006,2007,2008,2009,2010 Marc Alexander Lehmann / Robin Redeker / the Deliantra team
5#
6# Deliantra is free software: you can redistribute it and/or modify it under
7# the terms of the Affero GNU General Public License as published by the
8# Free Software Foundation, either version 3 of the License, or (at your
9# option) any later version.
10#
11# This program is distributed in the hope that it will be useful,
12# but WITHOUT ANY WARRANTY; without even the implied warranty of
13# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14# GNU General Public License for more details.
15#
16# You should have received a copy of the Affero GNU General Public License
17# and the GNU General Public License along with this program. If not, see
18# <http://www.gnu.org/licenses/>.
19#
20# The authors can be reached via e-mail to <support@deliantra.net>
21#
22
1package cf; 23package cf;
2 24
25use 5.10.0;
3use utf8; 26use utf8;
4use strict; 27use strict qw(vars subs);
5 28
6use Symbol; 29use Symbol;
7use List::Util; 30use List::Util;
8use Storable; 31use Socket;
32use EV;
9use Opcode; 33use Opcode;
10use Safe; 34use Safe;
11use Safe::Hole; 35use Safe::Hole;
36use Storable ();
37use Carp ();
12 38
39use Guard ();
13use Coro; 40use Coro ();
41use Coro::State;
42use Coro::Handle;
43use Coro::EV;
14use Coro::Event; 44use Coro::AnyEvent;
15use Coro::Timer; 45use Coro::Timer;
16use Coro::Signal; 46use Coro::Signal;
17use Coro::Semaphore; 47use Coro::Semaphore;
48use Coro::SemaphoreSet;
49use Coro::AnyEvent;
50use Coro::AIO;
51use Coro::BDB 1.6;
52use Coro::Storable;
53use Coro::Util ();
18 54
55use JSON::XS 2.01 ();
56use BDB ();
57use Data::Dumper;
58use Fcntl;
59use YAML::XS ();
19use IO::AIO; 60use IO::AIO ();
20use YAML::Syck ();
21use Time::HiRes; 61use Time::HiRes;
62use Compress::LZF;
63use Digest::MD5 ();
22 64
23use Event; $Event::Eval = 1; # no idea why this is required, but it is 65AnyEvent::detect;
24 66
25# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode? 67# configure various modules to our taste
26$YAML::Syck::ImplicitUnicode = 1; 68#
69$Storable::canonical = 1; # reduce rsync transfers
70Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator
27 71
28$Coro::main->prio (Coro::PRIO_MIN); 72$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority
73
74# make sure c-lzf reinitialises itself
75Compress::LZF::set_serializer "Storable", "Storable::net_mstore", "Storable::mretrieve";
76Compress::LZF::sfreeze_cr { }; # prime Compress::LZF so it does not use require later
77
78# strictly for debugging
79$SIG{QUIT} = sub { Carp::cluck "SIGQUIT" };
29 80
30sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload 81sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
31 82
32our %COMMAND = (); 83our %COMMAND = ();
33our %COMMAND_TIME = (); 84our %COMMAND_TIME = ();
85
86our @EXTS = (); # list of extension package names
34our %EXTCMD = (); 87our %EXTCMD = ();
88our %EXTICMD = ();
89our %EXT_CORO = (); # coroutines bound to extensions
90our %EXT_MAP = (); # pluggable maps
35 91
36_init_vars; 92our $RELOAD; # number of reloads so far, non-zero while in reload
37
38our @EVENT; 93our @EVENT;
39our $LIBDIR = datadir . "/ext"; 94our @REFLECT; # set by XS
95our %REFLECT; # set by us
40 96
41our $TICK = MAX_TIME * 1e-6; 97our $CONFDIR = confdir;
42our $TICK_WATCHER; 98our $DATADIR = datadir;
99our $LIBDIR = "$DATADIR/ext";
100our $PODDIR = "$DATADIR/pod";
101our $MAPDIR = "$DATADIR/" . mapdir;
102our $LOCALDIR = localdir;
103our $TMPDIR = "$LOCALDIR/" . tmpdir;
104our $UNIQUEDIR = "$LOCALDIR/" . uniquedir;
105our $PLAYERDIR = "$LOCALDIR/" . playerdir;
106our $RANDOMDIR = "$LOCALDIR/random";
107our $BDBDIR = "$LOCALDIR/db";
108our $PIDFILE = "$LOCALDIR/pid";
109our $RUNTIMEFILE = "$LOCALDIR/runtime";
110
111our %RESOURCE; # unused
112
113our $OUTPUT_RATE_MIN = 3000;
114our $OUTPUT_RATE_MAX = 1000000;
115
116our $MAX_LINKS = 32; # how many chained exits to follow
117our $VERBOSE_IO = 1;
118
119our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!)
120our $NEXT_RUNTIME_WRITE; # when should the runtime file be written
43our $NEXT_TICK; 121our $NEXT_TICK;
122our $USE_FSYNC = 1; # use fsync to write maps - default on
123
124our $BDB_DEADLOCK_WATCHER;
125our $BDB_CHECKPOINT_WATCHER;
126our $BDB_TRICKLE_WATCHER;
127our $DB_ENV;
128
129our @EXTRA_MODULES = qw(pod match mapscript);
44 130
45our %CFG; 131our %CFG;
46 132
47our $UPTIME; $UPTIME ||= time; 133our $UPTIME; $UPTIME ||= time;
134our $RUNTIME;
135our $NOW;
136
137our (%PLAYER, %PLAYER_LOADING); # all users
138our (%MAP, %MAP_LOADING ); # all maps
139our $LINK_MAP; # the special {link} map, which is always available
140
141# used to convert map paths into valid unix filenames by replacing / by ∕
142our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons
143
144our $LOAD; # a number between 0 (idle) and 1 (too many objects)
145our $LOADAVG; # same thing, but with alpha-smoothing
146our $JITTER; # average jitter
147our $TICK_START; # for load detecting purposes
148
149our @POST_INIT;
150
151our $REATTACH_ON_RELOAD; # set to true to force object reattach on reload (slow)
152our $REALLY_UNLOOP; # never set to true, please :)
153
154binmode STDOUT;
155binmode STDERR;
156
157# read virtual server time, if available
158unless ($RUNTIME || !-e $RUNTIMEFILE) {
159 open my $fh, "<", $RUNTIMEFILE
160 or die "unable to read $RUNTIMEFILE file: $!";
161 $RUNTIME = <$fh> + 0.;
162}
163
164eval "sub TICK() { $TICK } 1" or die;
165
166mkdir $_
167 for $LOCALDIR, $TMPDIR, $UNIQUEDIR, $PLAYERDIR, $RANDOMDIR, $BDBDIR;
168
169our $EMERGENCY_POSITION;
170
171sub cf::map::normalise;
172
173sub in_main() {
174 $Coro::current == $Coro::main
175}
48 176
49############################################################################# 177#############################################################################
50 178
179%REFLECT = ();
180for (@REFLECT) {
181 my $reflect = JSON::XS::decode_json $_;
182 $REFLECT{$reflect->{class}} = $reflect;
183}
184
185# this is decidedly evil
186$REFLECT{object}{flags} = { map +($_ => undef), grep $_, map /^FLAG_([A-Z0-9_]+)$/ && lc $1, keys %{"cf::"} };
187
188#############################################################################
189
51=head2 GLOBAL VARIABLES 190=head2 GLOBAL VARIABLES
52 191
53=over 4 192=over 4
54 193
55=item $cf::UPTIME 194=item $cf::UPTIME
56 195
57The timestamp of the server start (so not actually an uptime). 196The timestamp of the server start (so not actually an uptime).
58 197
59=item $cf::LIBDIR 198=item $cf::RUNTIME
60 199
61The perl library directory, where extensions and cf-specific modules can 200The time this server has run, starts at 0 and is increased by $cf::TICK on
62be found. It will be added to C<@INC> automatically. 201every server tick.
202
203=item $cf::CONFDIR $cf::DATADIR $cf::LIBDIR $cf::PODDIR
204$cf::MAPDIR $cf::LOCALDIR $cf::TMPDIR $cf::UNIQUEDIR
205$cf::PLAYERDIR $cf::RANDOMDIR $cf::BDBDIR
206
207Various directories - "/etc", read-only install directory, perl-library
208directory, pod-directory, read-only maps directory, "/var", "/var/tmp",
209unique-items directory, player file directory, random maps directory and
210database environment.
211
212=item $cf::NOW
213
214The time of the last (current) server tick.
63 215
64=item $cf::TICK 216=item $cf::TICK
65 217
66The interval between server ticks, in seconds. 218The interval between server ticks, in seconds.
67 219
220=item $cf::LOADAVG
221
222The current CPU load on the server (alpha-smoothed), as a value between 0
223(none) and 1 (overloaded), indicating how much time is spent on processing
224objects per tick. Healthy values are < 0.5.
225
226=item $cf::LOAD
227
228The raw value load value from the last tick.
229
68=item %cf::CFG 230=item %cf::CFG
69 231
70Configuration for the server, loaded from C</etc/crossfire/config>, or 232Configuration for the server, loaded from C</etc/deliantra-server/config>, or
71from wherever your confdir points to. 233from wherever your confdir points to.
72 234
235=item cf::wait_for_tick, cf::wait_for_tick_begin
236
237These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only
238returns directly I<after> the tick processing (and consequently, can only wake one process
239per tick), while cf::wait_for_tick wakes up all waiters after tick processing.
240
241=item @cf::INVOKE_RESULTS
242
243This array contains the results of the last C<invoke ()> call. When
244C<cf::override> is called C<@cf::INVOKE_RESULTS> is set to the parameters of
245that call.
246
247=item %cf::REFLECT
248
249Contains, for each (C++) class name, a hash reference with information
250about object members (methods, scalars, arrays and flags) and other
251metadata, which is useful for introspection.
252
73=back 253=back
74 254
75=cut 255=cut
76 256
77BEGIN { 257sub error(@) { LOG llevError, join "", @_ }
78 *CORE::GLOBAL::warn = sub { 258sub warn (@) { LOG llevWarn , join "", @_ }
259sub info (@) { LOG llevInfo , join "", @_ }
260sub debug(@) { LOG llevDebug, join "", @_ }
261sub trace(@) { LOG llevTrace, join "", @_ }
262
263$Coro::State::WARNHOOK = sub {
79 my $msg = join "", @_; 264 my $msg = join "", @_;
265
80 $msg .= "\n" 266 $msg .= "\n"
81 unless $msg =~ /\n$/; 267 unless $msg =~ /\n$/;
82 268
83 print STDERR "cfperl: $msg"; 269 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;
84 LOG llevError, "cfperl: $msg"; 270
85 }; 271 LOG llevWarn, $msg;
86} 272};
273
274$Coro::State::DIEHOOK = sub {
275 return unless $^S eq 0; # "eq", not "=="
276
277 error Carp::longmess $_[0];
278
279 if (in_main) {#d#
280 error "DIEHOOK called in main context, Coro bug?\n";#d#
281 return;#d#
282 }#d#
283
284 # kill coroutine otherwise
285 Coro::terminate
286};
87 287
88@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable'; 288@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
89@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable'; 289@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';
90@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable'; 290@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable';
91@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable'; 291@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable';
92@safe::cf::map::ISA = @cf::map::ISA = 'cf::attachable'; 292@safe::cf::map::ISA = @cf::map::ISA = 'cf::attachable';
293@safe::cf::arch::ISA = @cf::arch::ISA = 'cf::object';
93@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object'; 294@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object'; # not really true (yet)
94 295
95# we bless all objects into (empty) derived classes to force a method lookup 296# we bless all objects into (empty) derived classes to force a method lookup
96# within the Safe compartment. 297# within the Safe compartment.
97for my $pkg (qw( 298for my $pkg (qw(
98 cf::global 299 cf::global cf::attachable
99 cf::object cf::object::player 300 cf::object cf::object::player
100 cf::client cf::player 301 cf::client cf::player
101 cf::arch cf::living 302 cf::arch cf::living
303 cf::map cf::mapspace
102 cf::map cf::party cf::region 304 cf::party cf::region
103)) { 305)) {
104 no strict 'refs';
105 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg; 306 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
106} 307}
107 308
108$Event::DIED = sub { 309$EV::DIED = sub {
109 warn "error in event callback: @_"; 310 Carp::cluck "error in event callback: @_";
110}; 311};
111 312
112my %ext_pkg; 313#############################################################################
113my @exts;
114my @hook;
115 314
116=head2 UTILITY FUNCTIONS 315=head2 UTILITY FUNCTIONS
117 316
118=over 4 317=over 4
119 318
120=cut 319=item dumpval $ref
121 320
122use JSON::Syck (); # TODO# replace by JSON::PC once working 321=cut
123 322
323sub dumpval {
324 eval {
325 local $SIG{__DIE__};
326 my $d;
327 if (1) {
328 $d = new Data::Dumper([$_[0]], ["*var"]);
329 $d->Terse(1);
330 $d->Indent(2);
331 $d->Quotekeys(0);
332 $d->Useqq(1);
333 #$d->Bless(...);
334 $d->Seen($_[1]) if @_ > 1;
335 $d = $d->Dump();
336 }
337 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge;
338 $d
339 } || "[unable to dump $_[0]: '$@']";
340}
341
124=item $ref = cf::from_json $json 342=item $ref = cf::decode_json $json
125 343
126Converts a JSON string into the corresponding perl data structure. 344Converts a JSON string into the corresponding perl data structure.
127 345
128=cut
129
130sub from_json($) {
131 $JSON::Syck::ImplicitUnicode = 1; # work around JSON::Syck bugs
132 JSON::Syck::Load $_[0]
133}
134
135=item $json = cf::to_json $ref 346=item $json = cf::encode_json $ref
136 347
137Converts a perl data structure into its JSON representation. 348Converts a perl data structure into its JSON representation.
138 349
139=cut 350=cut
140 351
141sub to_json($) { 352our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max
142 $JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs 353
143 JSON::Syck::Dump $_[0] 354sub encode_json($) { $json_coder->encode ($_[0]) }
355sub decode_json($) { $json_coder->decode ($_[0]) }
356
357=item cf::post_init { BLOCK }
358
359Execute the given codeblock, I<after> all extensions have been (re-)loaded,
360but I<before> the server starts ticking again.
361
362The cdoeblock will have a single boolean argument to indicate whether this
363is a reload or not.
364
365=cut
366
367sub post_init(&) {
368 push @POST_INIT, shift;
369}
370
371=item cf::lock_wait $string
372
373Wait until the given lock is available. See cf::lock_acquire.
374
375=item my $lock = cf::lock_acquire $string
376
377Wait until the given lock is available and then acquires it and returns
378a L<Guard> object. If the guard object gets destroyed (goes out of scope,
379for example when the coroutine gets canceled), the lock is automatically
380returned.
381
382Locks are *not* recursive, locking from the same coro twice results in a
383deadlocked coro.
384
385Lock names should begin with a unique identifier (for example, cf::map::find
386uses map_find and cf::map::load uses map_load).
387
388=item $locked = cf::lock_active $string
389
390Return true if the lock is currently active, i.e. somebody has locked it.
391
392=cut
393
394our $LOCKS = new Coro::SemaphoreSet;
395
396sub lock_wait($) {
397 $LOCKS->wait ($_[0]);
398}
399
400sub lock_acquire($) {
401 $LOCKS->guard ($_[0])
402}
403
404sub lock_active($) {
405 $LOCKS->count ($_[0]) < 1
406}
407
408sub freeze_mainloop {
409 tick_inhibit_inc;
410
411 &Guard::guard (\&tick_inhibit_dec);
412}
413
414=item cf::periodic $interval, $cb
415
416Like EV::periodic, but randomly selects a starting point so that the actions
417get spread over time.
418
419=cut
420
421sub periodic($$) {
422 my ($interval, $cb) = @_;
423
424 my $start = rand List::Util::min 180, $interval;
425
426 EV::periodic $start, $interval, 0, $cb
427}
428
429=item cf::get_slot $time[, $priority[, $name]]
430
431Allocate $time seconds of blocking CPU time at priority C<$priority>:
432This call blocks and returns only when you have at least C<$time> seconds
433of cpu time till the next tick. The slot is only valid till the next cede.
434
435The optional C<$name> can be used to identify the job to run. It might be
436used for statistical purposes and should identify the same time-class.
437
438Useful for short background jobs.
439
440=cut
441
442our @SLOT_QUEUE;
443our $SLOT_QUEUE;
444our $SLOT_DECAY = 0.9;
445
446$SLOT_QUEUE->cancel if $SLOT_QUEUE;
447$SLOT_QUEUE = Coro::async {
448 $Coro::current->desc ("timeslot manager");
449
450 my $signal = new Coro::Signal;
451 my $busy;
452
453 while () {
454 next_job:
455
456 my $avail = cf::till_tick;
457
458 for (0 .. $#SLOT_QUEUE) {
459 if ($SLOT_QUEUE[$_][0] <= $avail) {
460 $busy = 0;
461 my $job = splice @SLOT_QUEUE, $_, 1, ();
462 $job->[2]->send;
463 Coro::cede;
464 goto next_job;
465 } else {
466 $SLOT_QUEUE[$_][0] *= $SLOT_DECAY;
467 }
468 }
469
470 if (@SLOT_QUEUE) {
471 # we do not use wait_for_tick() as it returns immediately when tick is inactive
472 push @cf::WAIT_FOR_TICK, $signal;
473 $signal->wait;
474 } else {
475 $busy = 0;
476 Coro::schedule;
477 }
478 }
479};
480
481sub get_slot($;$$) {
482 return if tick_inhibit || $Coro::current == $Coro::main;
483
484 my ($time, $pri, $name) = @_;
485
486 $time = clamp $time, 0.01, $TICK * .6;
487
488 my $sig = new Coro::Signal;
489
490 push @SLOT_QUEUE, [$time, $pri, $sig, $name];
491 @SLOT_QUEUE = sort { $b->[1] <=> $a->[1] } @SLOT_QUEUE;
492 $SLOT_QUEUE->ready;
493 $sig->wait;
494}
495
496=item cf::async { BLOCK }
497
498Currently the same as Coro::async_pool, meaning you cannot use
499C<on_destroy>, C<join> or other gimmicks on these coroutines. The only
500thing you are allowed to do is call C<prio> on it.
501
502=cut
503
504BEGIN { *async = \&Coro::async_pool }
505
506=item cf::sync_job { BLOCK }
507
508The design of Deliantra requires that the main coroutine ($Coro::main)
509is always able to handle events or runnable, as Deliantra is only
510partly reentrant. Thus "blocking" it by e.g. waiting for I/O is not
511acceptable.
512
513If it must be done, put the blocking parts into C<sync_job>. This will run
514the given BLOCK in another coroutine while waiting for the result. The
515server will be frozen during this time, so the block should either finish
516fast or be very important.
517
518=cut
519
520sub sync_job(&) {
521 my ($job) = @_;
522
523 if ($Coro::current == $Coro::main) {
524 my $time = AE::time;
525
526 # this is the main coro, too bad, we have to block
527 # till the operation succeeds, freezing the server :/
528
529 LOG llevError, Carp::longmess "sync job";#d#
530
531 my $freeze_guard = freeze_mainloop;
532
533 my $busy = 1;
534 my @res;
535
536 (async {
537 $Coro::current->desc ("sync job coro");
538 @res = eval { $job->() };
539 error $@ if $@;
540 undef $busy;
541 })->prio (Coro::PRIO_MAX);
542
543 while ($busy) {
544 if (Coro::nready) {
545 Coro::cede_notself;
546 } else {
547 EV::loop EV::LOOP_ONESHOT;
548 }
549 }
550
551 my $time = AE::time - $time;
552
553 $TICK_START += $time; # do not account sync jobs to server load
554
555 wantarray ? @res : $res[0]
556 } else {
557 # we are in another coroutine, how wonderful, everything just works
558
559 $job->()
560 }
561}
562
563=item $coro = cf::async_ext { BLOCK }
564
565Like async, but this coro is automatically being canceled when the
566extension calling this is being unloaded.
567
568=cut
569
570sub async_ext(&) {
571 my $cb = shift;
572
573 my $coro = &Coro::async ($cb);
574
575 $coro->on_destroy (sub {
576 delete $EXT_CORO{$coro+0};
577 });
578 $EXT_CORO{$coro+0} = $coro;
579
580 $coro
581}
582
583=item fork_call { }, $args
584
585Executes the given code block with the given arguments in a seperate
586process, returning the results. Everything must be serialisable with
587Coro::Storable. May, of course, block. Note that the executed sub may
588never block itself or use any form of event handling.
589
590=cut
591
592sub fork_call(&@) {
593 my ($cb, @args) = @_;
594
595 # we seemingly have to make a local copy of the whole thing,
596 # otherwise perl prematurely frees the stuff :/
597 # TODO: investigate and fix (likely this will be rather laborious)
598
599 my @res = Coro::Util::fork_eval {
600 reset_signals;
601 &$cb
602 }, @args;
603
604 wantarray ? @res : $res[-1]
605}
606
607sub objinfo {
608 (
609 "counter value" => cf::object::object_count,
610 "objects created" => cf::object::create_count,
611 "objects destroyed" => cf::object::destroy_count,
612 "freelist size" => cf::object::free_count,
613 "allocated objects" => cf::object::objects_size,
614 "active objects" => cf::object::actives_size,
615 )
616}
617
618=item $coin = coin_from_name $name
619
620=cut
621
622our %coin_alias = (
623 "silver" => "silvercoin",
624 "silvercoin" => "silvercoin",
625 "silvercoins" => "silvercoin",
626 "gold" => "goldcoin",
627 "goldcoin" => "goldcoin",
628 "goldcoins" => "goldcoin",
629 "platinum" => "platinacoin",
630 "platinumcoin" => "platinacoin",
631 "platinumcoins" => "platinacoin",
632 "platina" => "platinacoin",
633 "platinacoin" => "platinacoin",
634 "platinacoins" => "platinacoin",
635 "royalty" => "royalty",
636 "royalties" => "royalty",
637);
638
639sub coin_from_name($) {
640 $coin_alias{$_[0]}
641 ? cf::arch::find $coin_alias{$_[0]}
642 : undef
643}
644
645=item $value = cf::db_get $family => $key
646
647Returns a single value from the environment database.
648
649=item cf::db_put $family => $key => $value
650
651Stores the given C<$value> in the family. It can currently store binary
652data only (use Compress::LZF::sfreeze_cr/sthaw to convert to/from binary).
653
654=item $db = cf::db_table "name"
655
656Create and/or open a new database table. The string must not be "db" and must be unique
657within each server.
658
659=cut
660
661sub db_table($) {
662 my ($name) = @_;
663 my $db = BDB::db_create $DB_ENV;
664
665 eval {
666 $db->set_flags (BDB::CHKSUM);
667
668 utf8::encode $name;
669 BDB::db_open $db, undef, $name, undef, BDB::BTREE,
670 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
671 cf::cleanup "db_open(db): $!" if $!;
672 };
673 cf::cleanup "db_open(db): $@" if $@;
674
675 $db
676}
677
678our $DB;
679
680sub db_init {
681 cf::sync_job {
682 $DB ||= db_table "db";
683 };
684}
685
686sub db_get($$) {
687 my $key = "$_[0]/$_[1]";
688
689 cf::sync_job {
690 BDB::db_get $DB, undef, $key, my $data;
691
692 $! ? ()
693 : $data
694 }
695}
696
697sub db_put($$$) {
698 BDB::dbreq_pri 4;
699 BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { };
700}
701
702=item cf::cache $id => [$paths...], $processversion => $process
703
704Generic caching function that returns the value of the resource $id,
705caching and regenerating as required.
706
707This function can block.
708
709=cut
710
711sub cache {
712 my ($id, $src, $processversion, $process) = @_;
713
714 my $meta =
715 join "\x00",
716 $processversion,
717 map {
718 aio_stat $_
719 and Carp::croak "$_: $!";
720
721 ($_, (stat _)[7,9])
722 } @$src;
723
724 my $dbmeta = db_get cache => "$id/meta";
725 if ($dbmeta ne $meta) {
726 # changed, we may need to process
727
728 my @data;
729 my $md5;
730
731 for (0 .. $#$src) {
732 0 <= aio_load $src->[$_], $data[$_]
733 or Carp::croak "$src->[$_]: $!";
734 }
735
736 # if processing is expensive, check
737 # checksum first
738 if (1) {
739 $md5 =
740 join "\x00",
741 $processversion,
742 map {
743 cf::cede_to_tick;
744 ($src->[$_], Digest::MD5::md5_hex $data[$_])
745 } 0.. $#$src;
746
747
748 my $dbmd5 = db_get cache => "$id/md5";
749 if ($dbmd5 eq $md5) {
750 db_put cache => "$id/meta", $meta;
751
752 return db_get cache => "$id/data";
753 }
754 }
755
756 my $t1 = Time::HiRes::time;
757 my $data = $process->(\@data);
758 my $t2 = Time::HiRes::time;
759
760 info "cache: '$id' processed in ", $t2 - $t1, "s\n";
761
762 db_put cache => "$id/data", $data;
763 db_put cache => "$id/md5" , $md5;
764 db_put cache => "$id/meta", $meta;
765
766 return $data;
767 }
768
769 db_get cache => "$id/data"
770}
771
772=item cf::datalog type => key => value, ...
773
774Log a datalog packet of the given type with the given key-value pairs.
775
776=cut
777
778sub datalog($@) {
779 my ($type, %kv) = @_;
780 info "DATALOG ", JSON::XS->new->ascii->encode ({ %kv, type => $type });
144} 781}
145 782
146=back 783=back
147 784
148=cut 785=cut
149 786
150############################################################################# 787#############################################################################
151 788
152=head2 ATTACHABLE OBJECTS 789=head2 ATTACHABLE OBJECTS
153 790
154Many objects in crossfire are so-called attachable objects. That means you can 791Many objects in deliantra are so-called attachable objects. That means you can
155attach callbacks/event handlers (a collection of which is called an "attachment") 792attach callbacks/event handlers (a collection of which is called an "attachment")
156to it. All such attachable objects support the following methods. 793to it. All such attachable objects support the following methods.
157 794
158In the following description, CLASS can be any of C<global>, C<object> 795In the following description, CLASS can be any of C<global>, C<object>
159C<player>, C<client> or C<map> (i.e. the attachable objects in 796C<player>, C<client> or C<map> (i.e. the attachable objects in
160crossfire+). 797Deliantra).
161 798
162=over 4 799=over 4
163 800
164=item $attachable->attach ($attachment, key => $value...) 801=item $attachable->attach ($attachment, key => $value...)
165 802
… …
209=item cf::CLASS::attachment $name, ... 846=item cf::CLASS::attachment $name, ...
210 847
211Register an attachment by C<$name> through which attachable objects of the 848Register an attachment by C<$name> through which attachable objects of the
212given CLASS can refer to this attachment. 849given CLASS can refer to this attachment.
213 850
214Some classes such as crossfire maps and objects can specify attachments 851Some classes such as deliantra maps and objects can specify attachments
215that are attached at load/instantiate time, thus the need for a name. 852that are attached at load/instantiate time, thus the need for a name.
216 853
217These calls expect any number of the following handler/hook descriptions: 854These calls expect any number of the following handler/hook descriptions:
218 855
219=over 4 856=over 4
… …
269exception. 906exception.
270 907
271=cut 908=cut
272 909
273# the following variables are defined in .xs and must not be re-created 910# the following variables are defined in .xs and must not be re-created
274our @CB_GLOBAL = (); # registry for all global events 911our @CB_GLOBAL = (); # registry for all global events
912our @CB_ATTACHABLE = (); # registry for all attachables
275our @CB_OBJECT = (); # all objects (should not be used except in emergency) 913our @CB_OBJECT = (); # all objects (should not be used except in emergency)
276our @CB_PLAYER = (); 914our @CB_PLAYER = ();
277our @CB_CLIENT = (); 915our @CB_CLIENT = ();
278our @CB_TYPE = (); # registry for type (cf-object class) based events 916our @CB_TYPE = (); # registry for type (cf-object class) based events
279our @CB_MAP = (); 917our @CB_MAP = ();
280 918
281my %attachment; 919my %attachment;
920
921sub cf::attachable::thawer_merge {
922 # simply override everything except _meta
923 local $_[0]{_meta};
924 %{$_[0]} = %{$_[1]};
925}
282 926
283sub _attach_cb($$$$) { 927sub _attach_cb($$$$) {
284 my ($registry, $event, $prio, $cb) = @_; 928 my ($registry, $event, $prio, $cb) = @_;
285 929
286 use sort 'stable'; 930 use sort 'stable';
… …
289 933
290 @{$registry->[$event]} = sort 934 @{$registry->[$event]} = sort
291 { $a->[0] cmp $b->[0] } 935 { $a->[0] cmp $b->[0] }
292 @{$registry->[$event] || []}, $cb; 936 @{$registry->[$event] || []}, $cb;
293} 937}
938
939# hack
940my %attachable_klass = map +($_ => 1), KLASS_OBJECT, KLASS_CLIENT, KLASS_PLAYER, KLASS_MAP;
294 941
295# attach handles attaching event callbacks 942# attach handles attaching event callbacks
296# the only thing the caller has to do is pass the correct 943# the only thing the caller has to do is pass the correct
297# registry (== where the callback attaches to). 944# registry (== where the callback attaches to).
298sub _attach { 945sub _attach {
… …
300 947
301 my $object_type; 948 my $object_type;
302 my $prio = 0; 949 my $prio = 0;
303 my %cb_id = map +("on_" . lc $EVENT[$_][0], $_) , grep $EVENT[$_][1] == $klass, 0 .. $#EVENT; 950 my %cb_id = map +("on_" . lc $EVENT[$_][0], $_) , grep $EVENT[$_][1] == $klass, 0 .. $#EVENT;
304 951
952 #TODO: get rid of this hack
953 if ($attachable_klass{$klass}) {
954 %cb_id = (%cb_id, map +("on_" . lc $EVENT[$_][0], $_) , grep $EVENT[$_][1] == KLASS_ATTACHABLE, 0 .. $#EVENT);
955 }
956
305 while (@arg) { 957 while (@arg) {
306 my $type = shift @arg; 958 my $type = shift @arg;
307 959
308 if ($type eq "prio") { 960 if ($type eq "prio") {
309 $prio = shift @arg; 961 $prio = shift @arg;
… …
313 $registry = $CB_TYPE[$object_type] ||= []; 965 $registry = $CB_TYPE[$object_type] ||= [];
314 966
315 } elsif ($type eq "subtype") { 967 } elsif ($type eq "subtype") {
316 defined $object_type or Carp::croak "subtype specified without type"; 968 defined $object_type or Carp::croak "subtype specified without type";
317 my $object_subtype = shift @arg; 969 my $object_subtype = shift @arg;
318 $registry = $CB_TYPE[$object_type + $object_subtype * NUM_SUBTYPES] ||= []; 970 $registry = $CB_TYPE[$object_type + $object_subtype * NUM_TYPES] ||= [];
319 971
320 } elsif ($type eq "package") { 972 } elsif ($type eq "package") {
321 my $pkg = shift @arg; 973 my $pkg = shift @arg;
322 974
323 while (my ($name, $id) = each %cb_id) { 975 while (my ($name, $id) = each %cb_id) {
… …
328 980
329 } elsif (exists $cb_id{$type}) { 981 } elsif (exists $cb_id{$type}) {
330 _attach_cb $registry, $cb_id{$type}, $prio, shift @arg; 982 _attach_cb $registry, $cb_id{$type}, $prio, shift @arg;
331 983
332 } elsif (ref $type) { 984 } elsif (ref $type) {
333 warn "attaching objects not supported, ignoring.\n"; 985 error "attaching objects not supported, ignoring.\n";
334 986
335 } else { 987 } else {
336 shift @arg; 988 shift @arg;
337 warn "attach argument '$type' not supported, ignoring.\n"; 989 error "attach argument '$type' not supported, ignoring.\n";
338 } 990 }
339 } 991 }
340} 992}
341 993
342sub _object_attach { 994sub _object_attach {
… …
352 _attach $registry, $klass, @attach; 1004 _attach $registry, $klass, @attach;
353 } 1005 }
354 1006
355 $obj->{$name} = \%arg; 1007 $obj->{$name} = \%arg;
356 } else { 1008 } else {
357 warn "object uses attachment '$name' that is not available, postponing.\n"; 1009 info "object uses attachment '$name' which is not available, postponing.\n";
358 } 1010 }
359 1011
360 $obj->{_attachment}{$name} = undef; 1012 $obj->{_attachment}{$name} = undef;
361} 1013}
362 1014
… …
364 if (ref $_[0]) { 1016 if (ref $_[0]) {
365 _object_attach @_; 1017 _object_attach @_;
366 } else { 1018 } else {
367 _attach shift->_attach_registry, @_; 1019 _attach shift->_attach_registry, @_;
368 } 1020 }
1021 _recalc_want;
369}; 1022};
370 1023
371# all those should be optimised 1024# all those should be optimised
372sub cf::attachable::detach { 1025sub cf::attachable::detach {
373 my ($obj, $name) = @_; 1026 my ($obj, $name) = @_;
… …
376 delete $obj->{_attachment}{$name}; 1029 delete $obj->{_attachment}{$name};
377 reattach ($obj); 1030 reattach ($obj);
378 } else { 1031 } else {
379 Carp::croak "cannot, currently, detach class attachments"; 1032 Carp::croak "cannot, currently, detach class attachments";
380 } 1033 }
1034 _recalc_want;
381}; 1035};
382 1036
383sub cf::attachable::attached { 1037sub cf::attachable::attached {
384 my ($obj, $name) = @_; 1038 my ($obj, $name) = @_;
385 1039
386 exists $obj->{_attachment}{$name} 1040 exists $obj->{_attachment}{$name}
387} 1041}
388 1042
389for my $klass (qw(GLOBAL OBJECT PLAYER CLIENT MAP)) { 1043for my $klass (qw(ATTACHABLE GLOBAL OBJECT PLAYER CLIENT MAP)) {
390 eval "#line " . __LINE__ . " 'cf.pm' 1044 eval "#line " . __LINE__ . " 'cf.pm'
391 sub cf::\L$klass\E::_attach_registry { 1045 sub cf::\L$klass\E::_attach_registry {
392 (\\\@CB_$klass, KLASS_$klass) 1046 (\\\@CB_$klass, KLASS_$klass)
393 } 1047 }
394 1048
… …
400 "; 1054 ";
401 die if $@; 1055 die if $@;
402} 1056}
403 1057
404our $override; 1058our $override;
405our @invoke_results = (); # referenced from .xs code. TODO: play tricks with reify and mortals? 1059our @INVOKE_RESULTS = (); # referenced from .xs code. TODO: play tricks with reify and mortals?
406 1060
407sub override { 1061sub override {
408 $override = 1; 1062 $override = 1;
409 @invoke_results = (); 1063 @INVOKE_RESULTS = (@_);
410} 1064}
411 1065
412sub do_invoke { 1066sub do_invoke {
413 my $event = shift; 1067 my $event = shift;
414 my $callbacks = shift; 1068 my $callbacks = shift;
415 1069
416 @invoke_results = (); 1070 @INVOKE_RESULTS = ();
417 1071
418 local $override; 1072 local $override;
419 1073
420 for (@$callbacks) { 1074 for (@$callbacks) {
421 eval { &{$_->[1]} }; 1075 eval { &{$_->[1]} };
422 1076
423 if ($@) { 1077 if ($@) {
424 warn "$@";
425 warn "... while processing $EVENT[$event][0](@_) event, skipping processing altogether.\n"; 1078 error "$@", "... while processing $EVENT[$event][0](@_) event, skipping processing altogether.\n";
426 override; 1079 override;
427 } 1080 }
428 1081
429 return 1 if $override; 1082 return 1 if $override;
430 } 1083 }
431 1084
432 0 1085 0
433} 1086}
434 1087
435=item $bool = cf::global::invoke (EVENT_CLASS_XXX, ...) 1088=item $bool = cf::global->invoke (EVENT_CLASS_XXX, ...)
436 1089
437=item $bool = $attachable->invoke (EVENT_CLASS_XXX, ...) 1090=item $bool = $attachable->invoke (EVENT_CLASS_XXX, ...)
438 1091
439Generate an object-specific event with the given arguments. 1092Generate an object-specific event with the given arguments.
440 1093
441This API is preliminary (most likely, the EVENT_CLASS_xxx prefix will be 1094This API is preliminary (most likely, the EVENT_CLASS_xxx prefix will be
442removed in future versions), and there is no public API to access override 1095removed in future versions), and there is no public API to access override
443results (if you must, access C<@cf::invoke_results> directly). 1096results (if you must, access C<@cf::INVOKE_RESULTS> directly).
444 1097
445=back 1098=back
446 1099
447=cut 1100=cut
448 1101
449############################################################################# 1102#############################################################################
450# object support 1103# object support
451 1104
452sub instantiate { 1105sub _object_equal($$);
1106sub _object_equal($$) {
1107 my ($a, $b) = @_;
1108
1109 return 0 unless (ref $a) eq (ref $b);
1110
1111 if ("HASH" eq ref $a) {
1112 my @ka = keys %$a;
1113 my @kb = keys %$b;
1114
1115 return 0 if @ka != @kb;
1116
1117 for (0 .. $#ka) {
1118 return 0 unless $ka[$_] eq $kb[$_];
1119 return 0 unless _object_equal $a->{$ka[$_]}, $b->{$kb[$_]};
1120 }
1121
1122 } elsif ("ARRAY" eq ref $a) {
1123
1124 return 0 if @$a != @$b;
1125
1126 for (0 .. $#$a) {
1127 return 0 unless _object_equal $a->[$_], $b->[$_];
1128 }
1129
1130 } elsif ($a ne $b) {
1131 return 0;
1132 }
1133
1134 1
1135}
1136
1137our $SLOW_MERGES;#d#
1138sub _can_merge {
453 my ($obj, $data) = @_; 1139 my ($ob1, $ob2) = @_;
454 1140
455 $data = from_json $data; 1141 ++$SLOW_MERGES;#d#
456 1142
457 for (@$data) { 1143 # we do the slow way here
458 my ($name, $args) = @$_; 1144 return _object_equal $ob1, $ob2
459
460 $obj->attach ($name, %{$args || {} });
461 }
462} 1145}
463 1146
464# basically do the same as instantiate, without calling instantiate
465sub reattach { 1147sub reattach {
1148 # basically do the same as instantiate, without calling instantiate
466 my ($obj) = @_; 1149 my ($obj) = @_;
1150
1151 # no longer needed after getting rid of delete_package?
1152 #bless $obj, ref $obj; # re-bless in case extensions have been reloaded
1153
467 my $registry = $obj->registry; 1154 my $registry = $obj->registry;
468 1155
469 @$registry = (); 1156 @$registry = ();
470 1157
471 delete $obj->{_attachment} unless scalar keys %{ $obj->{_attachment} || {} }; 1158 delete $obj->{_attachment} unless scalar keys %{ $obj->{_attachment} || {} };
… …
475 for (@$attach) { 1162 for (@$attach) {
476 my ($klass, @attach) = @$_; 1163 my ($klass, @attach) = @$_;
477 _attach $registry, $klass, @attach; 1164 _attach $registry, $klass, @attach;
478 } 1165 }
479 } else { 1166 } else {
480 warn "object uses attachment '$name' that is not available, postponing.\n"; 1167 info "object uses attachment '$name' that is not available, postponing.\n";
481 }
482 }
483}
484
485sub object_freezer_save {
486 my ($filename, $rdata, $objs) = @_;
487
488 if (length $$rdata) {
489 warn sprintf "saving %s (%d,%d)\n",
490 $filename, length $$rdata, scalar @$objs;
491
492 if (open my $fh, ">:raw", "$filename~") {
493 chmod SAVE_MODE, $fh;
494 syswrite $fh, $$rdata;
495 close $fh;
496
497 if (@$objs && open my $fh, ">:raw", "$filename.pst~") {
498 chmod SAVE_MODE, $fh;
499 syswrite $fh, Storable::nfreeze { version => 1, objs => $objs };
500 close $fh;
501 rename "$filename.pst~", "$filename.pst";
502 } else {
503 unlink "$filename.pst";
504 } 1168 }
505
506 rename "$filename~", $filename;
507 } else {
508 warn "FATAL: $filename~: $!\n";
509 }
510 } else {
511 unlink $filename;
512 unlink "$filename.pst";
513 } 1169 }
514} 1170}
515 1171
516sub object_freezer_as_string { 1172cf::attachable->attach (
517 my ($rdata, $objs) = @_;
518
519 use Data::Dumper;
520
521 $$rdata . Dumper $objs
522}
523
524sub object_thawer_load {
525 my ($filename) = @_;
526
527 local $/;
528
529 my $av;
530
531 #TODO: use sysread etc.
532 if (open my $data, "<:raw:perlio", $filename) {
533 $data = <$data>;
534 if (open my $pst, "<:raw:perlio", "$filename.pst") {
535 $av = eval { (Storable::thaw <$pst>)->{objs} };
536 }
537 return ($data, $av);
538 }
539
540 ()
541}
542
543cf::object->attach (
544 prio => -1000000, 1173 prio => -1000000,
1174 on_instantiate => sub {
1175 my ($obj, $data) = @_;
1176
1177 $data = decode_json $data;
1178
1179 for (@$data) {
1180 my ($name, $args) = @$_;
1181
1182 $obj->attach ($name, %{$args || {} });
1183 }
1184 },
1185 on_reattach => \&reattach,
545 on_clone => sub { 1186 on_clone => sub {
546 my ($src, $dst) = @_; 1187 my ($src, $dst) = @_;
547 1188
548 @{$dst->registry} = @{$src->registry}; 1189 @{$dst->registry} = @{$src->registry};
549 1190
… …
552 %{$dst->{_attachment}} = %{$src->{_attachment}} 1193 %{$dst->{_attachment}} = %{$src->{_attachment}}
553 if exists $src->{_attachment}; 1194 if exists $src->{_attachment};
554 }, 1195 },
555); 1196);
556 1197
1198sub object_freezer_save {
1199 my ($filename, $rdata, $objs) = @_;
1200
1201 sync_job {
1202 if (length $$rdata) {
1203 utf8::decode (my $decname = $filename);
1204 trace sprintf "saving %s (%d,%d)\n",
1205 $decname, length $$rdata, scalar @$objs
1206 if $VERBOSE_IO;
1207
1208 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
1209 aio_chmod $fh, SAVE_MODE;
1210 aio_write $fh, 0, (length $$rdata), $$rdata, 0;
1211 if ($cf::USE_FSYNC) {
1212 aio_sync_file_range $fh, 0, 0, IO::AIO::SYNC_FILE_RANGE_WAIT_BEFORE | IO::AIO::SYNC_FILE_RANGE_WRITE | IO::AIO::SYNC_FILE_RANGE_WAIT_AFTER;
1213 aio_fsync $fh;
1214 }
1215 aio_close $fh;
1216
1217 if (@$objs) {
1218 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) {
1219 aio_chmod $fh, SAVE_MODE;
1220 my $data = Coro::Storable::nfreeze { version => 1, objs => $objs };
1221 aio_write $fh, 0, (length $data), $data, 0;
1222 if ($cf::USE_FSYNC) {
1223 aio_sync_file_range $fh, 0, 0, IO::AIO::SYNC_FILE_RANGE_WAIT_BEFORE | IO::AIO::SYNC_FILE_RANGE_WRITE | IO::AIO::SYNC_FILE_RANGE_WAIT_AFTER;
1224 aio_fsync $fh;
1225 }
1226 aio_close $fh;
1227 aio_rename "$filename.pst~", "$filename.pst";
1228 }
1229 } else {
1230 aio_unlink "$filename.pst";
1231 }
1232
1233 aio_rename "$filename~", $filename;
1234
1235 $filename =~ s%/[^/]+$%%;
1236 aio_pathsync $filename if $cf::USE_FSYNC;
1237 } else {
1238 error "unable to save objects: $filename~: $!\n";
1239 }
1240 } else {
1241 aio_unlink $filename;
1242 aio_unlink "$filename.pst";
1243 }
1244 };
1245}
1246
1247sub object_freezer_as_string {
1248 my ($rdata, $objs) = @_;
1249
1250 use Data::Dumper;
1251
1252 $$rdata . Dumper $objs
1253}
1254
1255sub object_thawer_load {
1256 my ($filename) = @_;
1257
1258 my ($data, $av);
1259
1260 (aio_load $filename, $data) >= 0
1261 or return;
1262
1263 unless (aio_stat "$filename.pst") {
1264 (aio_load "$filename.pst", $av) >= 0
1265 or return;
1266
1267 my $st = eval { Coro::Storable::thaw $av };
1268 $av = $st->{objs};
1269 }
1270
1271 utf8::decode (my $decname = $filename);
1272 trace sprintf "loading %s (%d,%d)\n",
1273 $decname, length $data, scalar @{$av || []}
1274 if $VERBOSE_IO;
1275
1276 ($data, $av)
1277}
1278
1279=head2 COMMAND CALLBACKS
1280
1281=over 4
1282
1283=cut
1284
557############################################################################# 1285#############################################################################
558# command handling &c 1286# command handling &c
559 1287
560=item cf::register_command $name => \&callback($ob,$args); 1288=item cf::register_command $name => \&callback($ob,$args);
561 1289
… …
573 push @{ $COMMAND{$name} }, [$caller, $cb]; 1301 push @{ $COMMAND{$name} }, [$caller, $cb];
574} 1302}
575 1303
576=item cf::register_extcmd $name => \&callback($pl,$packet); 1304=item cf::register_extcmd $name => \&callback($pl,$packet);
577 1305
578Register a callbackf ro execution when the client sends an extcmd packet. 1306Register a callback for execution when the client sends an (synchronous)
1307extcmd packet. Ext commands will be processed in the order they are
1308received by the server, like other user commands. The first argument is
1309the logged-in player. Ext commands can only be processed after a player
1310has logged in successfully.
579 1311
580If the callback returns something, it is sent back as if reply was being 1312If the callback returns something, it is sent back as if reply was being
581called. 1313called.
582 1314
1315=item cf::register_exticmd $name => \&callback($ns,$packet);
1316
1317Register a callback for execution when the client sends an (asynchronous)
1318exticmd packet. Exti commands are processed by the server as soon as they
1319are received, i.e. out of order w.r.t. other commands. The first argument
1320is a client socket. Exti commands can be received anytime, even before
1321log-in.
1322
1323If the callback returns something, it is sent back as if reply was being
1324called.
1325
583=cut 1326=cut
584 1327
585sub register_extcmd { 1328sub register_extcmd {
586 my ($name, $cb) = @_; 1329 my ($name, $cb) = @_;
587 1330
588 my $caller = caller;
589 #warn "registering extcmd '$name' to '$caller'";
590
591 $EXTCMD{$name} = [$cb, $caller]; 1331 $EXTCMD{$name} = $cb;
592} 1332}
1333
1334sub register_exticmd {
1335 my ($name, $cb) = @_;
1336
1337 $EXTICMD{$name} = $cb;
1338}
1339
1340use File::Glob ();
593 1341
594cf::player->attach ( 1342cf::player->attach (
595 on_command => sub { 1343 on_unknown_command => sub {
596 my ($pl, $name, $params) = @_; 1344 my ($pl, $name, $params) = @_;
597 1345
598 my $cb = $COMMAND{$name} 1346 my $cb = $COMMAND{$name}
599 or return; 1347 or return;
600 1348
… …
605 cf::override; 1353 cf::override;
606 }, 1354 },
607 on_extcmd => sub { 1355 on_extcmd => sub {
608 my ($pl, $buf) = @_; 1356 my ($pl, $buf) = @_;
609 1357
610 my $msg = eval { from_json $buf }; 1358 my $msg = eval { $pl->ns->{json_coder}->decode ($buf) };
611 1359
612 if (ref $msg) { 1360 if (ref $msg) {
1361 my ($type, $reply, @payload) =
1362 "ARRAY" eq ref $msg
1363 ? @$msg
1364 : ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
1365
1366 my @reply;
1367
613 if (my $cb = $EXTCMD{$msg->{msgtype}}) { 1368 if (my $cb = $EXTCMD{$type}) {
614 if (my %reply = $cb->[0]->($pl, $msg)) { 1369 @reply = $cb->($pl, @payload);
615 $pl->ext_reply ($msg->{msgid}, %reply);
616 }
617 } 1370 }
1371
1372 $pl->ext_reply ($reply, @reply)
1373 if $reply;
1374
618 } else { 1375 } else {
619 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n"; 1376 error "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
620 } 1377 }
621 1378
622 cf::override; 1379 cf::override;
623 }, 1380 },
624); 1381);
625 1382
626sub register { 1383# "readahead" all extensions
627 my ($base, $pkg) = @_;
628
629 #TODO
630}
631
632sub load_extension { 1384sub cache_extensions {
633 my ($path) = @_; 1385 my $grp = IO::AIO::aio_group;
634 1386
635 $path =~ /([^\/\\]+)\.ext$/ or die "$path"; 1387 add $grp IO::AIO::aio_readdirx $LIBDIR, IO::AIO::READDIR_STAT_ORDER, sub {
636 my $base = $1; 1388 for (grep /\.ext$/, @{$_[0]}) {
637 my $pkg = $1; 1389 add $grp IO::AIO::aio_load "$LIBDIR/$_", my $data;
638 $pkg =~ s/[^[:word:]]/_/g;
639 $pkg = "ext::$pkg";
640
641 warn "loading '$path' into '$pkg'\n";
642
643 open my $fh, "<:utf8", $path
644 or die "$path: $!";
645
646 my $source =
647 "package $pkg; use strict; use utf8;\n"
648 . "#line 1 \"$path\"\n{\n"
649 . (do { local $/; <$fh> })
650 . "\n};\n1";
651
652 eval $source
653 or die $@ ? "$path: $@\n"
654 : "extension disabled.\n";
655
656 push @exts, $pkg;
657 $ext_pkg{$base} = $pkg;
658
659# no strict 'refs';
660# @{"$pkg\::ISA"} = ext::;
661
662 register $base, $pkg;
663}
664
665sub unload_extension {
666 my ($pkg) = @_;
667
668 warn "removing extension $pkg\n";
669
670 # remove hooks
671 #TODO
672# for my $idx (0 .. $#PLUGIN_EVENT) {
673# delete $hook[$idx]{$pkg};
674# }
675
676 # remove commands
677 for my $name (keys %COMMAND) {
678 my @cb = grep $_->[0] ne $pkg, @{ $COMMAND{$name} };
679
680 if (@cb) {
681 $COMMAND{$name} = \@cb;
682 } else {
683 delete $COMMAND{$name};
684 } 1390 }
685 } 1391 };
686 1392
687 # remove extcmds 1393 $grp
688 for my $name (grep $EXTCMD{$_}[1] eq $pkg, keys %EXTCMD) {
689 delete $EXTCMD{$name};
690 }
691
692 if (my $cb = $pkg->can ("unload")) {
693 eval {
694 $cb->($pkg);
695 1
696 } or warn "$pkg unloaded, but with errors: $@";
697 }
698
699 Symbol::delete_package $pkg;
700} 1394}
701 1395
702sub load_extensions { 1396sub load_extensions {
1397 info "loading extensions...";
1398
1399 cf::sync_job {
1400 my %todo;
1401
703 for my $ext (<$LIBDIR/*.ext>) { 1402 for my $path (<$LIBDIR/*.ext>) {
704 next unless -r $ext; 1403 next unless -r $path;
705 eval { 1404
706 load_extension $ext; 1405 $path =~ /([^\/\\]+)\.ext$/ or die "$path";
1406 my $base = $1;
1407 my $pkg = $1;
1408 $pkg =~ s/[^[:word:]]/_/g;
1409 $pkg = "ext::$pkg";
1410
1411 open my $fh, "<:utf8", $path
1412 or die "$path: $!";
1413
1414 my $source = do { local $/; <$fh> };
1415
1416 my %ext = (
1417 path => $path,
1418 base => $base,
1419 pkg => $pkg,
1420 );
1421
1422 $ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 }
1423 if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m;
1424
1425 $ext{source} =
1426 "package $pkg; use 5.10.0; use strict 'vars', 'subs'; use utf8;\n"
1427 . "#line 1 \"$path\"\n{\n"
1428 . $source
1429 . "\n};\n1";
1430
1431 $todo{$base} = \%ext;
1432 }
1433
1434 my $pass = 0;
1435 my %done;
1436 while (%todo) {
1437 my $progress;
1438
1439 ++$pass;
1440
1441 ext:
1442 while (my ($k, $v) = each %todo) {
1443 for (split /,\s*/, $v->{meta}{depends}) {
1444 next ext
1445 unless exists $done{$_};
1446 }
1447
1448 trace "... pass $pass, loading '$k' into '$v->{pkg}'\n";
1449
1450 my $active = eval $v->{source};
1451
1452 if (length $@) {
1453 error "$v->{path}: $@\n";
1454
1455 cf::cleanup "mandatory extension '$k' failed to load, exiting."
1456 if exists $v->{meta}{mandatory};
1457
1458 warn "$v->{base}: optional extension cannot be loaded, skipping.\n";
1459 delete $todo{$k};
1460 } else {
1461 $done{$k} = delete $todo{$k};
1462 push @EXTS, $v->{pkg};
1463 $progress = 1;
1464
1465 info "$v->{base}: extension inactive.\n"
1466 unless $active;
1467 }
707 1 1468 }
708 } or warn "$ext not loaded: $@"; 1469
1470 unless ($progress) {
1471 warn "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n";
1472
1473 while (my ($k, $v) = each %todo) {
1474 cf::cleanup "mandatory extension '$k' has unresolved dependencies, exiting."
1475 if exists $v->{meta}{mandatory};
1476 }
1477 }
1478 }
709 } 1479 };
710} 1480}
711 1481
712############################################################################# 1482#############################################################################
713# load/save/clean perl data associated with a map
714 1483
715*cf::mapsupport::on_clean = sub { 1484=back
1485
1486=head2 CORE EXTENSIONS
1487
1488Functions and methods that extend core deliantra objects.
1489
1490=cut
1491
1492package cf::player;
1493
1494use Coro::AIO;
1495
1496=head3 cf::player
1497
1498=over 4
1499
1500=item cf::player::num_playing
1501
1502Returns the official number of playing players, as per the Crossfire metaserver rules.
1503
1504=cut
1505
1506sub num_playing {
1507 scalar grep
1508 $_->ob->map
1509 && !$_->hidden
1510 && !$_->ob->flag (cf::FLAG_WIZ),
1511 cf::player::list
1512}
1513
1514=item cf::player::find $login
1515
1516Returns the given player object, loading it if necessary (might block).
1517
1518=cut
1519
1520sub playerdir($) {
1521 "$PLAYERDIR/"
1522 . (ref $_[0] ? $_[0]->ob->name : $_[0])
1523}
1524
1525sub path($) {
1526 my $login = ref $_[0] ? $_[0]->ob->name : $_[0];
1527
1528 (playerdir $login) . "/playerdata"
1529}
1530
1531sub find_active($) {
1532 $cf::PLAYER{$_[0]}
1533 and $cf::PLAYER{$_[0]}->active
1534 and $cf::PLAYER{$_[0]}
1535}
1536
1537sub exists($) {
716 my ($map) = @_; 1538 my ($login) = @_;
717 1539
718 my $path = $map->tmpname; 1540 $cf::PLAYER{$login}
719 defined $path or return; 1541 or !aio_stat path $login
720
721 unlink "$path.pst";
722};
723
724cf::map->attach (prio => -10000, package => cf::mapsupport::);
725
726#############################################################################
727# load/save perl data associated with player->ob objects
728
729sub all_objects(@) {
730 @_, map all_objects ($_->inv), @_
731} 1542}
732 1543
733# TODO: compatibility cruft, remove when no longer needed 1544sub find($) {
1545 return $cf::PLAYER{$_[0]} || do {
1546 my $login = $_[0];
1547
1548 my $guard = cf::lock_acquire "user_find:$login";
1549
1550 $cf::PLAYER{$_[0]} || do {
1551 # rename old playerfiles to new ones
1552 #TODO: remove when no longer required
1553 aio_link +(playerdir $login) . "/$login.pl.pst", (playerdir $login) . "/playerdata.pst";
1554 aio_link +(playerdir $login) . "/$login.pl" , (playerdir $login) . "/playerdata";
1555 aio_unlink +(playerdir $login) . "/$login.pl.pst";
1556 aio_unlink +(playerdir $login) . "/$login.pl";
1557
1558 my $f = new_from_file cf::object::thawer path $login
1559 or return;
1560
1561 my $pl = cf::player::load_pl $f
1562 or return;
1563
1564 local $cf::PLAYER_LOADING{$login} = $pl;
1565 $f->resolve_delayed_derefs;
1566 $cf::PLAYER{$login} = $pl
1567 }
1568 }
1569}
1570
734cf::player->attach ( 1571cf::player->attach (
735 on_load => sub { 1572 on_load => sub {
736 my ($pl, $path) = @_; 1573 my ($pl, $path) = @_;
737 1574
738 for my $o (all_objects $pl->ob) { 1575 # restore slots saved in save, below
739 if (my $value = $o->get_ob_key_value ("_perl_data")) { 1576 my $slots = delete $pl->{_slots};
740 $o->set_ob_key_value ("_perl_data");
741 1577
742 %$o = %{ Storable::thaw pack "H*", $value }; 1578 $pl->ob->current_weapon ($slots->[0]);
743 } 1579 $pl->combat_ob ($slots->[1]);
744 } 1580 $pl->ranged_ob ($slots->[2]);
745 }, 1581 },
746); 1582);
747 1583
748############################################################################# 1584sub save($) {
1585 my ($pl) = @_;
749 1586
750=head2 CORE EXTENSIONS 1587 return if $pl->{deny_save};
751 1588
752Functions and methods that extend core crossfire objects. 1589 my $path = path $pl;
1590 my $guard = cf::lock_acquire "user_save:$path";
753 1591
754=head3 cf::player 1592 return if $pl->{deny_save};
1593
1594 aio_mkdir playerdir $pl, 0770;
1595 $pl->{last_save} = $cf::RUNTIME;
1596
1597 cf::get_slot 0.01;
1598
1599 # save slots, to be restored later
1600 local $pl->{_slots} = [$pl->ob->current_weapon, $pl->combat_ob, $pl->ranged_ob];
1601
1602 $pl->save_pl ($path);
1603 cf::cede_to_tick;
1604}
1605
1606sub new($) {
1607 my ($login) = @_;
1608
1609 my $self = create;
1610
1611 $self->ob->name ($login);
1612 $self->{deny_save} = 1;
1613
1614 $cf::PLAYER{$login} = $self;
1615
1616 $self
1617}
1618
1619=item $player->send_msg ($channel, $msg, $color, [extra...])
1620
1621=cut
1622
1623sub send_msg {
1624 my $ns = shift->ns
1625 or return;
1626 $ns->send_msg (@_);
1627}
1628
1629=item $pl->quit_character
1630
1631Nukes the player without looking back. If logged in, the connection will
1632be destroyed. May block for a long time.
1633
1634=cut
1635
1636sub quit_character {
1637 my ($pl) = @_;
1638
1639 my $name = $pl->ob->name;
1640
1641 $pl->{deny_save} = 1;
1642 $pl->password ("*"); # this should lock out the player until we have nuked the dir
1643
1644 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active;
1645 $pl->deactivate;
1646 my $killer = cf::arch::get "killer_quit"; $pl->killer ($killer); $killer->destroy;
1647 $pl->invoke (cf::EVENT_PLAYER_QUIT);
1648 $pl->ns->destroy if $pl->ns;
1649
1650 my $path = playerdir $pl;
1651 my $temp = "$path~$cf::RUNTIME~deleting~";
1652 aio_rename $path, $temp;
1653 delete $cf::PLAYER{$pl->ob->name};
1654 $pl->destroy;
1655
1656 my $prefix = qr<^~\Q$name\E/>;
1657
1658 # nuke player maps
1659 $cf::MAP{$_}->nuke for grep /$prefix/, keys %cf::MAP;
1660
1661 IO::AIO::aio_rmtree $temp;
1662}
1663
1664=item $pl->kick
1665
1666Kicks a player out of the game. This destroys the connection.
1667
1668=cut
1669
1670sub kick {
1671 my ($pl, $kicker) = @_;
1672
1673 $pl->invoke (cf::EVENT_PLAYER_KICK, $kicker);
1674 $pl->killer ("kicked");
1675 $pl->ns->destroy;
1676}
1677
1678=item cf::player::list_logins
1679
1680Returns am arrayref of all valid playernames in the system, can take a
1681while and may block, so not sync_job-capable, ever.
1682
1683=cut
1684
1685sub list_logins {
1686 my $dirs = aio_readdir $PLAYERDIR
1687 or return [];
1688
1689 my @logins;
1690
1691 for my $login (@$dirs) {
1692 my $path = path $login;
1693
1694 # a .pst is a dead give-away for a valid player
1695 # if no pst file found, open and chekc for blocked users
1696 if (aio_stat "$path.pst") {
1697 my $fh = aio_open $path, Fcntl::O_RDONLY, 0 or next;
1698 aio_read $fh, 0, 512, my $buf, 0 or next;
1699 $buf !~ /^password -------------$/m or next; # official not-valid tag
1700 }
1701
1702 utf8::decode $login;
1703 push @logins, $login;
1704 }
1705
1706 \@logins
1707}
1708
1709=item $player->maps
1710
1711=item cf::player::maps $login
1712
1713Returns an arrayref of map paths that are private for this
1714player. May block.
1715
1716=cut
1717
1718sub maps($) {
1719 my ($pl) = @_;
1720
1721 $pl = ref $pl ? $pl->ob->name : $pl;
1722
1723 my $files = aio_readdir playerdir $pl
1724 or return;
1725
1726 my @paths;
1727
1728 for (@$files) {
1729 utf8::decode $_;
1730 next if /\.(?:pl|pst)$/;
1731 next unless /^$PATH_SEP/o;
1732
1733 push @paths, cf::map::normalise "~$pl/$_";
1734 }
1735
1736 \@paths
1737}
1738
1739=item $protocol_xml = $player->expand_cfpod ($cfpod)
1740
1741Expand deliantra pod fragments into protocol xml.
1742
1743=item $player->ext_reply ($msgid, @msg)
1744
1745Sends an ext reply to the player.
1746
1747=cut
1748
1749sub ext_reply($$@) {
1750 my ($self, $id, @msg) = @_;
1751
1752 $self->ns->ext_reply ($id, @msg)
1753}
1754
1755=item $player->ext_msg ($type, @msg)
1756
1757Sends an ext event to the client.
1758
1759=cut
1760
1761sub ext_msg($$@) {
1762 my ($self, $type, @msg) = @_;
1763
1764 $self->ns->ext_msg ($type, @msg);
1765}
1766
1767=head3 cf::region
755 1768
756=over 4 1769=over 4
757 1770
758=item cf::player::exists $login
759
760Returns true when the given account exists.
761
762=cut 1771=cut
763 1772
764sub cf::player::exists($) { 1773package cf::region;
765 cf::player::find $_[0]
766 or -f sprintf "%s/%s/%s/%s.pl", cf::localdir, cf::playerdir, ($_[0]) x 2;
767}
768 1774
769=item $player->ext_reply ($msgid, $msgtype, %msg) 1775=item cf::region::find_by_path $path
770 1776
771Sends an ext reply to the player. 1777Tries to decuce the likely region for a map knowing only its path.
772 1778
773=cut 1779=cut
774 1780
775sub cf::player::ext_reply($$$%) { 1781sub find_by_path($) {
1782 my ($path) = @_;
1783
1784 $path =~ s/^~[^\/]*//; # skip ~login
1785
1786 my ($match, $specificity);
1787
1788 for my $region (list) {
1789 if ($region->{match} && $path =~ $region->{match}) {
1790 ($match, $specificity) = ($region, $region->specificity)
1791 if $region->specificity > $specificity;
1792 }
1793 }
1794
1795 $match
1796}
1797
1798=back
1799
1800=head3 cf::map
1801
1802=over 4
1803
1804=cut
1805
1806package cf::map;
1807
1808use Fcntl;
1809use Coro::AIO;
1810
1811use overload
1812 '""' => \&as_string,
1813 fallback => 1;
1814
1815our $MAX_RESET = 3600;
1816our $DEFAULT_RESET = 3000;
1817
1818sub generate_random_map {
1819 my ($self, $rmp) = @_;
1820
1821 my $lock = cf::lock_acquire "generate_random_map"; # the random map generator is NOT reentrant ATM
1822
1823 # mit "rum" bekleckern, nicht
1824 $self->_create_random_map (
1825 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle},
1826 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle}, $rmp->{miningstyle},
1827 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map},
1828 $rmp->{exit_on_final_map},
1829 $rmp->{xsize}, $rmp->{ysize},
1830 $rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3},
1831 $rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase},
1832 $rmp->{dungeon_level}, $rmp->{dungeon_depth}, $rmp->{decoroptions}, $rmp->{orientation},
1833 $rmp->{origin_y}, $rmp->{origin_x}, $rmp->{random_seed}, $rmp->{total_map_hp},
1834 $rmp->{map_layout_style}, $rmp->{treasureoptions}, $rmp->{symmetry_used},
1835 (cf::region::find $rmp->{region}), $rmp->{custom}
1836 )
1837}
1838
1839=item cf::map->register ($regex, $prio)
1840
1841Register a handler for the map path matching the given regex at the
1842givne priority (higher is better, built-in handlers have priority 0, the
1843default).
1844
1845=cut
1846
1847sub register {
1848 my (undef, $regex, $prio) = @_;
1849 my $pkg = caller;
1850
1851 no strict;
1852 push @{"$pkg\::ISA"}, __PACKAGE__;
1853
1854 $EXT_MAP{$pkg} = [$prio, qr<$regex>];
1855}
1856
1857# also paths starting with '/'
1858$EXT_MAP{"cf::map::wrap"} = [0, qr{^(?=/)}];
1859
1860sub thawer_merge {
776 my ($self, $id, %msg) = @_; 1861 my ($self, $merge) = @_;
777 1862
778 $msg{msgid} = $id; 1863 # we have to keep some variables in memory intact
1864 local $self->{path};
1865 local $self->{load_path};
779 1866
780 $self->send ("ext " . to_json \%msg); 1867 $self->SUPER::thawer_merge ($merge);
781} 1868}
1869
1870sub normalise {
1871 my ($path, $base) = @_;
1872
1873 $path = "$path"; # make sure its a string
1874
1875 $path =~ s/\.map$//;
1876
1877 # map plan:
1878 #
1879 # /! non-realised random map exit (special hack!)
1880 # {... are special paths that are not being touched
1881 # ?xxx/... are special absolute paths
1882 # ?random/... random maps
1883 # /... normal maps
1884 # ~user/... per-player map of a specific user
1885
1886 $path =~ s/$PATH_SEP/\//go;
1887
1888 # treat it as relative path if it starts with
1889 # something that looks reasonable
1890 if ($path =~ m{^(?:\./|\.\./|\w)}) {
1891 $base or Carp::carp "normalise called with relative path and no base: '$path'";
1892
1893 $base =~ s{[^/]+/?$}{};
1894 $path = "$base/$path";
1895 }
1896
1897 for ($path) {
1898 redo if s{//}{/};
1899 redo if s{/\.?/}{/};
1900 redo if s{/[^/]+/\.\./}{/};
1901 }
1902
1903 $path
1904}
1905
1906sub new_from_path {
1907 my (undef, $path, $base) = @_;
1908
1909 return $path if UNIVERSAL::isa $path, "cf::map"; # already a map object
1910
1911 $path = normalise $path, $base;
1912
1913 for my $pkg (sort { $EXT_MAP{$b}[0] <=> $EXT_MAP{$a}[0] } keys %EXT_MAP) {
1914 if ($path =~ $EXT_MAP{$pkg}[1]) {
1915 my $self = bless cf::map::new, $pkg;
1916 $self->{path} = $path; $self->path ($path);
1917 $self->init; # pass $1 etc.
1918 return $self;
1919 }
1920 }
1921
1922 Carp::cluck "unable to resolve path '$path' (base '$base').";
1923 ()
1924}
1925
1926sub init {
1927 my ($self) = @_;
1928
1929 $self
1930}
1931
1932sub as_string {
1933 my ($self) = @_;
1934
1935 "$self->{path}"
1936}
1937
1938# the displayed name, this is a one way mapping
1939sub visible_name {
1940 &as_string
1941}
1942
1943# the original (read-only) location
1944sub load_path {
1945 my ($self) = @_;
1946
1947 "$MAPDIR/$self->{path}.map"
1948}
1949
1950# the temporary/swap location
1951sub save_path {
1952 my ($self) = @_;
1953
1954 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/go;
1955 "$TMPDIR/$path.map"
1956}
1957
1958# the unique path, undef == no special unique path
1959sub uniq_path {
1960 my ($self) = @_;
1961
1962 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/go;
1963 "$UNIQUEDIR/$path"
1964}
1965
1966sub decay_objects {
1967 my ($self) = @_;
1968
1969 return if $self->{deny_reset};
1970
1971 $self->do_decay_objects;
1972}
1973
1974sub unlink_save {
1975 my ($self) = @_;
1976
1977 utf8::encode (my $save = $self->save_path);
1978 IO::AIO::aioreq_pri 4; Coro::AIO::aio_unlink $save;
1979 IO::AIO::aioreq_pri 4; Coro::AIO::aio_unlink "$save.pst";
1980}
1981
1982sub load_header_from($) {
1983 my ($self, $path) = @_;
1984
1985 utf8::encode $path;
1986 my $f = new_from_file cf::object::thawer $path
1987 or return;
1988
1989 $self->_load_header ($f)
1990 or return;
1991
1992 local $MAP_LOADING{$self->{path}} = $self;
1993 $f->resolve_delayed_derefs;
1994
1995 $self->{load_path} = $path;
1996
1997 1
1998}
1999
2000sub load_header_orig {
2001 my ($self) = @_;
2002
2003 $self->load_header_from ($self->load_path)
2004}
2005
2006sub load_header_temp {
2007 my ($self) = @_;
2008
2009 $self->load_header_from ($self->save_path)
2010}
2011
2012sub prepare_temp {
2013 my ($self) = @_;
2014
2015 $self->last_access ((delete $self->{last_access})
2016 || $cf::RUNTIME); #d#
2017 # safety
2018 $self->{instantiate_time} = $cf::RUNTIME
2019 if $self->{instantiate_time} > $cf::RUNTIME;
2020}
2021
2022sub prepare_orig {
2023 my ($self) = @_;
2024
2025 $self->{load_original} = 1;
2026 $self->{instantiate_time} = $cf::RUNTIME;
2027 $self->last_access ($cf::RUNTIME);
2028 $self->instantiate;
2029}
2030
2031sub load_header {
2032 my ($self) = @_;
2033
2034 if ($self->load_header_temp) {
2035 $self->prepare_temp;
2036 } else {
2037 $self->load_header_orig
2038 or return;
2039 $self->prepare_orig;
2040 }
2041
2042 $self->{deny_reset} = 1
2043 if $self->no_reset;
2044
2045 $self->default_region (cf::region::find_by_path $self->{path})
2046 unless $self->default_region;
2047
2048 1
2049}
2050
2051sub find;
2052sub find {
2053 my ($path, $origin) = @_;
2054
2055 $path = normalise $path, $origin && $origin->path;
2056
2057 my $guard1 = cf::lock_acquire "map_data:$path";#d#remove
2058 my $guard2 = cf::lock_acquire "map_find:$path";
2059
2060 $cf::MAP{$path} || do {
2061 my $map = new_from_path cf::map $path
2062 or return;
2063
2064 $map->{last_save} = $cf::RUNTIME;
2065
2066 $map->load_header
2067 or return;
2068
2069 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?)
2070 # doing this can freeze the server in a sync job, obviously
2071 #$cf::WAIT_FOR_TICK->wait;
2072 undef $guard2;
2073 undef $guard1;
2074 $map->reset;
2075 return find $path;
2076 }
2077
2078 $cf::MAP{$path} = $map
2079 }
2080}
2081
2082sub pre_load { }
2083#sub post_load { } # XS
2084
2085sub load {
2086 my ($self) = @_;
2087
2088 local $self->{deny_reset} = 1; # loading can take a long time
2089
2090 my $path = $self->{path};
2091
2092 {
2093 my $guard = cf::lock_acquire "map_data:$path";
2094
2095 return unless $self->valid;
2096 return unless $self->in_memory == cf::MAP_SWAPPED;
2097
2098 $self->in_memory (cf::MAP_LOADING);
2099
2100 $self->alloc;
2101
2102 $self->pre_load;
2103 cf::cede_to_tick;
2104
2105 my $f = new_from_file cf::object::thawer $self->{load_path};
2106 $f->skip_block;
2107 $self->_load_objects ($f)
2108 or return;
2109
2110 $self->post_load_original
2111 if delete $self->{load_original};
2112
2113 if (my $uniq = $self->uniq_path) {
2114 utf8::encode $uniq;
2115 unless (aio_stat $uniq) {
2116 if (my $f = new_from_file cf::object::thawer $uniq) {
2117 $self->clear_unique_items;
2118 $self->_load_objects ($f);
2119 $f->resolve_delayed_derefs;
2120 }
2121 }
2122 }
2123
2124 $f->resolve_delayed_derefs;
2125
2126 cf::cede_to_tick;
2127 # now do the right thing for maps
2128 $self->link_multipart_objects;
2129 $self->difficulty ($self->estimate_difficulty)
2130 unless $self->difficulty;
2131 cf::cede_to_tick;
2132
2133 unless ($self->{deny_activate}) {
2134 $self->decay_objects;
2135 $self->fix_auto_apply;
2136 $self->update_buttons;
2137 cf::cede_to_tick;
2138 $self->activate;
2139 }
2140
2141 $self->{last_save} = $cf::RUNTIME;
2142 $self->last_access ($cf::RUNTIME);
2143
2144 $self->in_memory (cf::MAP_ACTIVE);
2145 }
2146
2147 $self->post_load;
2148}
2149
2150# customize the map for a given player, i.e.
2151# return the _real_ map. used by e.g. per-player
2152# maps to change the path to ~playername/mappath
2153sub customise_for {
2154 my ($self, $ob) = @_;
2155
2156 return find "~" . $ob->name . "/" . $self->{path}
2157 if $self->per_player;
2158
2159# return find "?party/" . $ob->name . "/" . $self->{path}
2160# if $self->per_party;
2161
2162 $self
2163}
2164
2165# find and load all maps in the 3x3 area around a map
2166sub load_neighbours {
2167 my ($map) = @_;
2168
2169 my @neigh; # diagonal neighbours
2170
2171 for (0 .. 3) {
2172 my $neigh = $map->tile_path ($_)
2173 or next;
2174 $neigh = find $neigh, $map
2175 or next;
2176 $neigh->load;
2177
2178 # now find the diagonal neighbours
2179 push @neigh,
2180 [$neigh->tile_path (($_ + 3) % 4), $neigh],
2181 [$neigh->tile_path (($_ + 1) % 4), $neigh];
2182 }
2183
2184 for (grep defined $_->[0], @neigh) {
2185 my ($path, $origin) = @$_;
2186 my $neigh = find $path, $origin
2187 or next;
2188 $neigh->load;
2189 }
2190}
2191
2192sub find_sync {
2193 my ($path, $origin) = @_;
2194
2195 cf::sync_job { find $path, $origin }
2196}
2197
2198sub do_load_sync {
2199 my ($map) = @_;
2200
2201 cf::LOG cf::llevDebug | cf::logBacktrace, "do_load_sync"
2202 if $Coro::current == $Coro::main;
2203
2204 cf::sync_job { $map->load };
2205}
2206
2207our %MAP_PREFETCH;
2208our $MAP_PREFETCHER = undef;
2209
2210sub find_async {
2211 my ($path, $origin, $load) = @_;
2212
2213 $path = normalise $path, $origin && $origin->{path};
2214
2215 if (my $map = $cf::MAP{$path}) {
2216 return $map if !$load || $map->in_memory == cf::MAP_ACTIVE;
2217 }
2218
2219 $MAP_PREFETCH{$path} |= $load;
2220
2221 $MAP_PREFETCHER ||= cf::async {
2222 $Coro::current->{desc} = "map prefetcher";
2223
2224 while (%MAP_PREFETCH) {
2225 while (my ($k, $v) = each %MAP_PREFETCH) {
2226 if (my $map = find $k) {
2227 $map->load if $v;
2228 }
2229
2230 delete $MAP_PREFETCH{$k};
2231 }
2232 }
2233 undef $MAP_PREFETCHER;
2234 };
2235 $MAP_PREFETCHER->prio (6);
2236
2237 ()
2238}
2239
2240# common code, used by both ->save and ->swapout
2241sub _save {
2242 my ($self) = @_;
2243
2244 $self->{last_save} = $cf::RUNTIME;
2245
2246 return unless $self->dirty;
2247
2248 my $save = $self->save_path; utf8::encode $save;
2249 my $uniq = $self->uniq_path; utf8::encode $uniq;
2250
2251 $self->{load_path} = $save;
2252
2253 return if $self->{deny_save};
2254
2255 local $self->{last_access} = $self->last_access;#d#
2256
2257 cf::async {
2258 $Coro::current->{desc} = "map player save";
2259 $_->contr->save for $self->players;
2260 };
2261
2262 cf::get_slot 0.02;
2263
2264 if ($uniq) {
2265 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS);
2266 $self->_save_objects ($uniq, cf::IO_UNIQUES);
2267 } else {
2268 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES);
2269 }
2270}
2271
2272sub save {
2273 my ($self) = @_;
2274
2275 my $lock = cf::lock_acquire "map_data:$self->{path}";
2276
2277 $self->_save;
2278}
2279
2280sub swap_out {
2281 my ($self) = @_;
2282
2283 my $lock = cf::lock_acquire "map_data:$self->{path}";
2284
2285 return if $self->in_memory != cf::MAP_ACTIVE;
2286 return if $self->{deny_save};
2287 return if $self->players;
2288
2289 # first deactivate the map and "unlink" it from the core
2290 $self->deactivate;
2291 $_->clear_links_to ($self) for values %cf::MAP;
2292 $self->in_memory (cf::MAP_SWAPPED);
2293
2294 # then atomically save
2295 $self->_save;
2296
2297 # then free the map
2298 $self->clear;
2299}
2300
2301sub reset_at {
2302 my ($self) = @_;
2303
2304 # TODO: safety, remove and allow resettable per-player maps
2305 return 1e99 if $self->{deny_reset};
2306
2307 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
2308 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET;
2309
2310 $time + $to
2311}
2312
2313sub should_reset {
2314 my ($self) = @_;
2315
2316 $self->reset_at <= $cf::RUNTIME
2317}
2318
2319sub reset {
2320 my ($self) = @_;
2321
2322 my $lock = cf::lock_acquire "map_data:$self->{path}";
2323
2324 return if $self->players;
2325
2326 cf::trace "resetting map ", $self->path, "\n";
2327
2328 $self->in_memory (cf::MAP_SWAPPED);
2329
2330 # need to save uniques path
2331 unless ($self->{deny_save}) {
2332 my $uniq = $self->uniq_path; utf8::encode $uniq;
2333
2334 $self->_save_objects ($uniq, cf::IO_UNIQUES)
2335 if $uniq;
2336 }
2337
2338 delete $cf::MAP{$self->path};
2339
2340 $self->deactivate;
2341 $_->clear_links_to ($self) for values %cf::MAP;
2342 $self->clear;
2343
2344 $self->unlink_save;
2345 $self->destroy;
2346}
2347
2348my $nuke_counter = "aaaa";
2349
2350sub nuke {
2351 my ($self) = @_;
2352
2353 {
2354 my $lock = cf::lock_acquire "map_data:$self->{path}";
2355
2356 delete $cf::MAP{$self->path};
2357
2358 $self->unlink_save;
2359
2360 bless $self, "cf::map::wrap";
2361 delete $self->{deny_reset};
2362 $self->{deny_save} = 1;
2363 $self->reset_timeout (1);
2364 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));
2365
2366 $cf::MAP{$self->path} = $self;
2367 }
2368
2369 $self->reset; # polite request, might not happen
2370}
2371
2372=item $maps = cf::map::tmp_maps
2373
2374Returns an arrayref with all map paths of currently instantiated and saved
2375maps. May block.
2376
2377=cut
2378
2379sub tmp_maps() {
2380 [
2381 map {
2382 utf8::decode $_;
2383 /\.map$/
2384 ? normalise $_
2385 : ()
2386 } @{ aio_readdir $TMPDIR or [] }
2387 ]
2388}
2389
2390=item $maps = cf::map::random_maps
2391
2392Returns an arrayref with all map paths of currently instantiated and saved
2393random maps. May block.
2394
2395=cut
2396
2397sub random_maps() {
2398 [
2399 map {
2400 utf8::decode $_;
2401 /\.map$/
2402 ? normalise "?random/$_"
2403 : ()
2404 } @{ aio_readdir $RANDOMDIR or [] }
2405 ]
2406}
2407
2408=item cf::map::unique_maps
2409
2410Returns an arrayref of paths of all shared maps that have
2411instantiated unique items. May block.
2412
2413=cut
2414
2415sub unique_maps() {
2416 [
2417 map {
2418 utf8::decode $_;
2419 s/\.map$//; # TODO future compatibility hack
2420 /\.pst$/ || !/^$PATH_SEP/o # TODO unique maps apparebntly lack the .map suffix :/
2421 ? ()
2422 : normalise $_
2423 } @{ aio_readdir $UNIQUEDIR or [] }
2424 ]
2425}
2426
2427=item cf::map::static_maps
2428
2429Returns an arrayref if paths of all static maps (all preinstalled F<.map>
2430file in the shared directory excluding F</styles> and F</editor>). May
2431block.
2432
2433=cut
2434
2435sub static_maps() {
2436 my @dirs = "";
2437 my @maps;
2438
2439 while (@dirs) {
2440 my $dir = shift @dirs;
2441
2442 next if $dir eq "/styles" || $dir eq "/editor";
2443
2444 my ($dirs, $files) = Coro::AIO::aio_scandir "$MAPDIR$dir", 2
2445 or return;
2446
2447 for (@$files) {
2448 s/\.map$// or next;
2449 utf8::decode $_;
2450 push @maps, "$dir/$_";
2451 }
2452
2453 push @dirs, map "$dir/$_", @$dirs;
2454 }
2455
2456 \@maps
2457}
2458
2459=back
2460
2461=head3 cf::object
2462
2463=cut
2464
2465package cf::object;
2466
2467=over 4
2468
2469=item $ob->inv_recursive
2470
2471Returns the inventory of the object I<and> their inventories, recursively,
2472but I<not> the object itself.
2473
2474=cut
2475
2476sub inv_recursive_;
2477sub inv_recursive_ {
2478 map { $_, inv_recursive_ $_->inv } @_
2479}
2480
2481sub inv_recursive {
2482 inv_recursive_ inv $_[0]
2483}
2484
2485=item $ref = $ob->ref
2486
2487Creates and returns a persistent reference to an object that can be stored as a string.
2488
2489=item $ob = cf::object::deref ($refstring)
2490
2491returns the objetc referenced by refstring. may return undef when it cnanot find the object,
2492even if the object actually exists. May block.
2493
2494=cut
2495
2496sub deref {
2497 my ($ref) = @_;
2498
2499 if ($ref =~ m{^player\/(<1\.[0-9a-f]+>)/(.*)$}) {
2500 my ($uuid, $name) = ($1, $2);
2501 my $pl = $cf::PLAYER_LOADING{$name} || cf::player::find $name
2502 or return;
2503 $pl->ob->uuid eq $uuid
2504 or return;
2505
2506 $pl->ob
2507 } else {
2508 warn "$ref: cannot resolve object reference\n";
2509 undef
2510 }
2511}
2512
2513package cf;
782 2514
783=back 2515=back
784 2516
785=head3 cf::object::player 2517=head3 cf::object::player
786 2518
… …
791Sends a message to the player, as if the npc C<$npc> replied. C<$npc> 2523Sends a message to the player, as if the npc C<$npc> replied. C<$npc>
792can be C<undef>. Does the right thing when the player is currently in a 2524can be C<undef>. Does the right thing when the player is currently in a
793dialogue with the given NPC character. 2525dialogue with the given NPC character.
794 2526
795=cut 2527=cut
2528
2529our $SAY_CHANNEL = {
2530 id => "say",
2531 title => "Map",
2532 reply => "say ",
2533 tooltip => "Things said to and replied from NPCs near you and other players on the same map only.",
2534};
2535
2536our $CHAT_CHANNEL = {
2537 id => "chat",
2538 title => "Chat",
2539 reply => "chat ",
2540 tooltip => "Player chat and shouts, global to the server.",
2541};
796 2542
797# rough implementation of a future "reply" method that works 2543# rough implementation of a future "reply" method that works
798# with dialog boxes. 2544# with dialog boxes.
799#TODO: the first argument must go, split into a $npc->reply_to ( method 2545#TODO: the first argument must go, split into a $npc->reply_to ( method
800sub cf::object::player::reply($$$;$) { 2546sub cf::object::player::reply($$$;$) {
… …
802 2548
803 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4; 2549 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4;
804 2550
805 if ($self->{record_replies}) { 2551 if ($self->{record_replies}) {
806 push @{ $self->{record_replies} }, [$npc, $msg, $flags]; 2552 push @{ $self->{record_replies} }, [$npc, $msg, $flags];
2553
807 } else { 2554 } else {
2555 my $pl = $self->contr;
2556
2557 if ($pl->{npc_dialog} && $pl->{npc_dialog}->{id}) {
2558 my $dialog = $pl->{npc_dialog};
2559 $dialog->{pl}->ext_msg ($dialog->{id}, update => msg => $dialog->{pl}->expand_cfpod ($msg));
2560
2561 } else {
808 $msg = $npc->name . " says: $msg" if $npc; 2562 $msg = $npc->name . " says: $msg" if $npc;
809 $self->message ($msg, $flags); 2563 $self->send_msg ($SAY_CHANNEL => $msg, $flags);
2564 }
810 } 2565 }
2566}
2567
2568=item $object->send_msg ($channel, $msg, $color, [extra...])
2569
2570=cut
2571
2572sub cf::object::send_msg {
2573 my $pl = shift->contr
2574 or return;
2575 $pl->send_msg (@_);
811} 2576}
812 2577
813=item $player_object->may ("access") 2578=item $player_object->may ("access")
814 2579
815Returns wether the given player is authorized to access resource "access" 2580Returns wether the given player is authorized to access resource "access"
… …
824 (ref $cf::CFG{"may_$access"} 2589 (ref $cf::CFG{"may_$access"}
825 ? scalar grep $self->name eq $_, @{$cf::CFG{"may_$access"}} 2590 ? scalar grep $self->name eq $_, @{$cf::CFG{"may_$access"}}
826 : $cf::CFG{"may_$access"}) 2591 : $cf::CFG{"may_$access"})
827} 2592}
828 2593
2594=item $player_object->enter_link
2595
2596Freezes the player and moves him/her to a special map (C<{link}>).
2597
2598The player should be reasonably safe there for short amounts of time (e.g.
2599for loading a map). You I<MUST> call C<leave_link> as soon as possible,
2600though, as the player cannot control the character while it is on the link
2601map.
2602
2603Will never block.
2604
2605=item $player_object->leave_link ($map, $x, $y)
2606
2607Moves the player out of the special C<{link}> map onto the specified
2608map. If the map is not valid (or omitted), the player will be moved back
2609to the location he/she was before the call to C<enter_link>, or, if that
2610fails, to the emergency map position.
2611
2612Might block.
2613
2614=cut
2615
2616sub link_map {
2617 unless ($LINK_MAP) {
2618 $LINK_MAP = cf::map::find "{link}"
2619 or cf::cleanup "FATAL: unable to provide {link} map, exiting.";
2620 $LINK_MAP->load;
2621 }
2622
2623 $LINK_MAP
2624}
2625
2626sub cf::object::player::enter_link {
2627 my ($self) = @_;
2628
2629 $self->deactivate_recursive;
2630
2631 ++$self->{_link_recursion};
2632
2633 return if UNIVERSAL::isa $self->map, "ext::map_link";
2634
2635 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y]
2636 if $self->map && $self->map->{path} ne "{link}";
2637
2638 $self->enter_map ($LINK_MAP || link_map, 3, 3);
2639}
2640
2641sub cf::object::player::leave_link {
2642 my ($self, $map, $x, $y) = @_;
2643
2644 return unless $self->contr->active;
2645
2646 my $link_pos = delete $self->{_link_pos};
2647
2648 unless ($map) {
2649 # restore original map position
2650 ($map, $x, $y) = @{ $link_pos || [] };
2651 $map = cf::map::find $map;
2652
2653 unless ($map) {
2654 ($map, $x, $y) = @$EMERGENCY_POSITION;
2655 $map = cf::map::find $map
2656 or die "FATAL: cannot load emergency map\n";
2657 }
2658 }
2659
2660 ($x, $y) = (-1, -1)
2661 unless (defined $x) && (defined $y);
2662
2663 # use -1 or undef as default coordinates, not 0, 0
2664 ($x, $y) = ($map->enter_x, $map->enter_y)
2665 if $x <= 0 && $y <= 0;
2666
2667 $map->load;
2668 $map->load_neighbours;
2669
2670 return unless $self->contr->active;
2671
2672 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
2673 if ($self->enter_map ($map, $x, $y)) {
2674 # entering was successful
2675 delete $self->{_link_recursion};
2676 # only activate afterwards, to support waiting in hooks
2677 $self->activate_recursive;
2678 }
2679
2680}
2681
2682=item $player_object->goto ($path, $x, $y[, $check->($map, $x, $y, $player)[, $done->($player)]])
2683
2684Moves the player to the given map-path and coordinates by first freezing
2685her, loading and preparing them map, calling the provided $check callback
2686that has to return the map if sucecssful, and then unfreezes the player on
2687the new (success) or old (failed) map position. In either case, $done will
2688be called at the end of this process.
2689
2690Note that $check will be called with a potentially non-loaded map, so if
2691it needs a loaded map it has to call C<< ->load >>.
2692
2693=cut
2694
2695our $GOTOGEN;
2696
2697sub cf::object::player::goto {
2698 my ($self, $path, $x, $y, $check, $done) = @_;
2699
2700 if ($self->{_link_recursion} >= $MAX_LINKS) {
2701 error "FATAL: link recursion exceeded, ", $self->name, " goto $path $x $y, redirecting.";
2702 $self->failmsg ("Something went wrong inside the server - please contact an administrator!");
2703 ($path, $x, $y) = @$EMERGENCY_POSITION;
2704 }
2705
2706 # do generation counting so two concurrent goto's will be executed in-order
2707 my $gen = $self->{_goto_generation} = ++$GOTOGEN;
2708
2709 $self->enter_link;
2710
2711 (async {
2712 $Coro::current->{desc} = "player::goto $path $x $y";
2713
2714 # *tag paths override both path and x|y
2715 if ($path =~ /^\*(.*)$/) {
2716 if (my @obs = grep $_->map, ext::map_tags::find $1) {
2717 my $ob = $obs[rand @obs];
2718
2719 # see if we actually can go there
2720 if (@obs = grep !$self->blocked ($_->map, $_->x, $_->y), $ob, $ob->tail) {
2721 $ob = $obs[rand @obs];
2722 } else {
2723 $self->message ("Wow, it's pretty crowded in there.", cf::NDI_UNIQUE | cf::NDI_RED);
2724 }
2725 # else put us there anyways for now #d#
2726
2727 ($path, $x, $y) = ($ob->map, $ob->x, $ob->y);
2728 } else {
2729 ($path, $x, $y) = (undef, undef, undef);
2730 }
2731 }
2732
2733 my $map = eval {
2734 my $map = defined $path ? cf::map::find $path : undef;
2735
2736 if ($map) {
2737 $map = $map->customise_for ($self);
2738 $map = $check->($map, $x, $y, $self) if $check && $map;
2739 } else {
2740 $self->message ("The exit to '$path' is closed.", cf::NDI_UNIQUE | cf::NDI_RED);
2741 }
2742
2743 $map
2744 };
2745
2746 if ($@) {
2747 $self->message ("Something went wrong within the server, please report this incident!", cf::NDI_UNIQUE | cf::NDI_RED);
2748 LOG llevError | logBacktrace, Carp::longmess $@;
2749 }
2750
2751 if ($gen == $self->{_goto_generation}) {
2752 delete $self->{_goto_generation};
2753 $self->leave_link ($map, $x, $y);
2754 }
2755
2756 $done->($self) if $done;
2757 })->prio (1);
2758}
2759
2760=item $player_object->enter_exit ($exit_object)
2761
2762=cut
2763
2764sub parse_random_map_params {
2765 my ($spec) = @_;
2766
2767 my $rmp = { # defaults
2768 xsize => (cf::rndm 15, 40),
2769 ysize => (cf::rndm 15, 40),
2770 symmetry => (cf::rndm 1, cf::SYMMETRY_XY),
2771 #layout => string,
2772 };
2773
2774 for (split /\n/, $spec) {
2775 my ($k, $v) = split /\s+/, $_, 2;
2776
2777 $rmp->{lc $k} = $v if (length $k) && (length $v);
2778 }
2779
2780 $rmp
2781}
2782
2783sub prepare_random_map {
2784 my ($exit) = @_;
2785
2786 # all this does is basically replace the /! path by
2787 # a new random map path (?random/...) with a seed
2788 # that depends on the exit object
2789
2790 my $rmp = parse_random_map_params $exit->msg;
2791
2792 if ($exit->map) {
2793 $rmp->{region} = $exit->region->name;
2794 $rmp->{origin_map} = $exit->map->path;
2795 $rmp->{origin_x} = $exit->x;
2796 $rmp->{origin_y} = $exit->y;
2797
2798 $exit->map->touch;
2799 }
2800
2801 $rmp->{random_seed} ||= $exit->random_seed;
2802
2803 my $data = JSON::XS->new->utf8->pretty->canonical->encode ($rmp);
2804 my $md5 = Digest::MD5::md5_hex $data;
2805 my $meta = "$RANDOMDIR/$md5.meta";
2806
2807 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) {
2808 aio_write $fh, 0, (length $data), $data, 0;
2809 undef $fh;
2810 aio_rename "$meta~", $meta;
2811
2812 my $slaying = "?random/$md5";
2813
2814 if ($exit->valid) {
2815 $exit->slaying ("?random/$md5");
2816 $exit->msg (undef);
2817 }
2818 }
2819}
2820
2821sub cf::object::player::enter_exit {
2822 my ($self, $exit) = @_;
2823
2824 return unless $self->type == cf::PLAYER;
2825
2826 $self->enter_link;
2827
2828 (async {
2829 $Coro::current->{desc} = "enter_exit";
2830
2831 unless (eval {
2832 $self->deactivate_recursive; # just to be sure
2833
2834 # random map handling
2835 {
2836 my $guard = cf::lock_acquire "exit_prepare:$exit";
2837
2838 prepare_random_map $exit
2839 if $exit->slaying eq "/!";
2840 }
2841
2842 my $map = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path;
2843 my $x = $exit->stats->hp;
2844 my $y = $exit->stats->sp;
2845
2846 $self->goto ($map, $x, $y);
2847
2848 # if exit is damned, update players death & WoR home-position
2849 $self->contr->savebed ($map, $x, $y)
2850 if $exit->flag (cf::FLAG_DAMNED);
2851
2852 1
2853 }) {
2854 $self->message ("Something went wrong deep within the deliantra server. "
2855 . "I'll try to bring you back to the map you were before. "
2856 . "Please report this to the dungeon master!",
2857 cf::NDI_UNIQUE | cf::NDI_RED);
2858
2859 error "ERROR in enter_exit: $@";
2860 $self->leave_link;
2861 }
2862 })->prio (1);
2863}
2864
829=head3 cf::client 2865=head3 cf::client
830 2866
831=over 4 2867=over 4
832 2868
833=item $client->send_drawinfo ($text, $flags) 2869=item $client->send_drawinfo ($text, $flags)
… …
839 2875
840sub cf::client::send_drawinfo { 2876sub cf::client::send_drawinfo {
841 my ($self, $text, $flags) = @_; 2877 my ($self, $text, $flags) = @_;
842 2878
843 utf8::encode $text; 2879 utf8::encode $text;
844 $self->send_packet (sprintf "drawinfo %d %s", $flags, $text); 2880 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);
845} 2881}
846 2882
2883=item $client->send_big_packet ($pkt)
2884
2885Like C<send_packet>, but tries to compress large packets, and fragments
2886them as required.
2887
2888=cut
2889
2890our $MAXFRAGSIZE = cf::MAXSOCKBUF - 64;
2891
2892sub cf::client::send_big_packet {
2893 my ($self, $pkt) = @_;
2894
2895 # try lzf for large packets
2896 $pkt = "lzf " . Compress::LZF::compress $pkt
2897 if 1024 <= length $pkt and $self->{can_lzf};
2898
2899 # split very large packets
2900 if ($MAXFRAGSIZE < length $pkt and $self->{can_lzf}) {
2901 $self->send_packet ("frag $_") for unpack "(a$MAXFRAGSIZE)*", $pkt;
2902 $pkt = "frag";
2903 }
2904
2905 $self->send_packet ($pkt);
2906}
2907
2908=item $client->send_msg ($channel, $msg, $color, [extra...])
2909
2910Send a drawinfo or msg packet to the client, formatting the msg for the
2911client if neccessary. C<$type> should be a string identifying the type of
2912the message, with C<log> being the default. If C<$color> is negative, suppress
2913the message unless the client supports the msg packet.
2914
2915=cut
2916
2917# non-persistent channels (usually the info channel)
2918our %CHANNEL = (
2919 "c/motd" => {
2920 id => "infobox",
2921 title => "MOTD",
2922 reply => undef,
2923 tooltip => "The message of the day",
2924 },
2925 "c/identify" => {
2926 id => "infobox",
2927 title => "Identify",
2928 reply => undef,
2929 tooltip => "Items recently identified",
2930 },
2931 "c/examine" => {
2932 id => "infobox",
2933 title => "Examine",
2934 reply => undef,
2935 tooltip => "Signs and other items you examined",
2936 },
2937 "c/shopinfo" => {
2938 id => "infobox",
2939 title => "Shop Info",
2940 reply => undef,
2941 tooltip => "What your bargaining skill tells you about the shop",
2942 },
2943 "c/book" => {
2944 id => "infobox",
2945 title => "Book",
2946 reply => undef,
2947 tooltip => "The contents of a note or book",
2948 },
2949 "c/lookat" => {
2950 id => "infobox",
2951 title => "Look",
2952 reply => undef,
2953 tooltip => "What you saw there",
2954 },
2955 "c/who" => {
2956 id => "infobox",
2957 title => "Players",
2958 reply => undef,
2959 tooltip => "Shows players who are currently online",
2960 },
2961 "c/body" => {
2962 id => "infobox",
2963 title => "Body Parts",
2964 reply => undef,
2965 tooltip => "Shows which body parts you posess and are available",
2966 },
2967 "c/statistics" => {
2968 id => "infobox",
2969 title => "Statistics",
2970 reply => undef,
2971 tooltip => "Shows your primary statistics",
2972 },
2973 "c/skills" => {
2974 id => "infobox",
2975 title => "Skills",
2976 reply => undef,
2977 tooltip => "Shows your experience per skill and item power",
2978 },
2979 "c/shopitems" => {
2980 id => "infobox",
2981 title => "Shop Items",
2982 reply => undef,
2983 tooltip => "Shows the items currently for sale in this shop",
2984 },
2985 "c/resistances" => {
2986 id => "infobox",
2987 title => "Resistances",
2988 reply => undef,
2989 tooltip => "Shows your resistances",
2990 },
2991 "c/pets" => {
2992 id => "infobox",
2993 title => "Pets",
2994 reply => undef,
2995 tooltip => "Shows information abotu your pets/a specific pet",
2996 },
2997 "c/perceiveself" => {
2998 id => "infobox",
2999 title => "Perceive Self",
3000 reply => undef,
3001 tooltip => "You gained detailed knowledge about yourself",
3002 },
3003 "c/uptime" => {
3004 id => "infobox",
3005 title => "Uptime",
3006 reply => undef,
3007 tooltip => "How long the server has been running since last restart",
3008 },
3009 "c/mapinfo" => {
3010 id => "infobox",
3011 title => "Map Info",
3012 reply => undef,
3013 tooltip => "Information related to the maps",
3014 },
3015 "c/party" => {
3016 id => "party",
3017 title => "Party",
3018 reply => "gsay ",
3019 tooltip => "Messages and chat related to your party",
3020 },
3021 "c/death" => {
3022 id => "death",
3023 title => "Death",
3024 reply => undef,
3025 tooltip => "Reason for and more info about your most recent death",
3026 },
3027 "c/say" => $SAY_CHANNEL,
3028 "c/chat" => $CHAT_CHANNEL,
3029);
3030
3031sub cf::client::send_msg {
3032 my ($self, $channel, $msg, $color, @extra) = @_;
3033
3034 $msg = $self->pl->expand_cfpod ($msg)
3035 unless $color & cf::NDI_VERBATIM;
3036
3037 $color &= cf::NDI_CLIENT_MASK; # just in case...
3038
3039 # check predefined channels, for the benefit of C
3040 if ($CHANNEL{$channel}) {
3041 $channel = $CHANNEL{$channel};
3042
3043 $self->ext_msg (channel_info => $channel);
3044 $channel = $channel->{id};
3045
3046 } elsif (ref $channel) {
3047 # send meta info to client, if not yet sent
3048 unless (exists $self->{channel}{$channel->{id}}) {
3049 $self->{channel}{$channel->{id}} = $channel;
3050 $self->ext_msg (channel_info => $channel);
3051 }
3052
3053 $channel = $channel->{id};
3054 }
3055
3056 return unless @extra || length $msg;
3057
3058 # default colour, mask it out
3059 $color &= ~(cf::NDI_COLOR_MASK | cf::NDI_DEF)
3060 if $color & cf::NDI_DEF;
3061
3062 my $pkt = "msg "
3063 . $self->{json_coder}->encode (
3064 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]
3065 );
3066
3067 $self->send_big_packet ($pkt);
3068}
3069
3070=item $client->ext_msg ($type, @msg)
3071
3072Sends an ext event to the client.
3073
3074=cut
3075
3076sub cf::client::ext_msg($$@) {
3077 my ($self, $type, @msg) = @_;
3078
3079 if ($self->extcmd == 2) {
3080 $self->send_big_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
3081 } elsif ($self->extcmd == 1) { # TODO: remove
3082 push @msg, msgtype => "event_$type";
3083 $self->send_big_packet ("ext " . $self->{json_coder}->encode ({@msg}));
3084 }
3085}
3086
3087=item $client->ext_reply ($msgid, @msg)
3088
3089Sends an ext reply to the client.
3090
3091=cut
3092
3093sub cf::client::ext_reply($$@) {
3094 my ($self, $id, @msg) = @_;
3095
3096 if ($self->extcmd == 2) {
3097 $self->send_big_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg]));
3098 } elsif ($self->extcmd == 1) {
3099 #TODO: version 1, remove
3100 unshift @msg, msgtype => "reply", msgid => $id;
3101 $self->send_big_packet ("ext " . $self->{json_coder}->encode ({@msg}));
3102 }
3103}
847 3104
848=item $success = $client->query ($flags, "text", \&cb) 3105=item $success = $client->query ($flags, "text", \&cb)
849 3106
850Queues a query to the client, calling the given callback with 3107Queues a query to the client, calling the given callback with
851the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>, 3108the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>,
852C<cf::CS_QUERY_SINGLECHAR> or C<cf::CS_QUERY_HIDEINPUT> or C<0>. 3109C<cf::CS_QUERY_SINGLECHAR> or C<cf::CS_QUERY_HIDEINPUT> or C<0>.
853 3110
854Queries can fail, so check the return code. Or don't, as queries will become 3111Queries can fail, so check the return code. Or don't, as queries will
855reliable at some point in the future. 3112become reliable at some point in the future.
856 3113
857=cut 3114=cut
858 3115
859sub cf::client::query { 3116sub cf::client::query {
860 my ($self, $flags, $text, $cb) = @_; 3117 my ($self, $flags, $text, $cb) = @_;
… …
868 utf8::encode $text; 3125 utf8::encode $text;
869 push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb]; 3126 push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb];
870 3127
871 $self->send_packet ($self->{query_queue}[0][0]) 3128 $self->send_packet ($self->{query_queue}[0][0])
872 if @{ $self->{query_queue} } == 1; 3129 if @{ $self->{query_queue} } == 1;
3130
3131 1
873} 3132}
874 3133
875cf::client->attach ( 3134cf::client->attach (
3135 on_connect => sub {
3136 my ($ns) = @_;
3137
3138 $ns->{json_coder} = JSON::XS->new->utf8->max_size (1e6)->convert_blessed;
3139 },
876 on_reply => sub { 3140 on_reply => sub {
877 my ($ns, $msg) = @_; 3141 my ($ns, $msg) = @_;
878 3142
879 # this weird shuffling is so that direct followup queries 3143 # this weird shuffling is so that direct followup queries
880 # get handled first 3144 # get handled first
881 my $queue = delete $ns->{query_queue}; 3145 my $queue = delete $ns->{query_queue}
3146 or return; # be conservative, not sure how that can happen, but we saw a crash here
882 3147
883 (shift @$queue)->[1]->($msg); 3148 (shift @$queue)->[1]->($msg);
3149 return unless $ns->valid; # temporary(?) workaround for callback destroying socket
884 3150
885 push @{ $ns->{query_queue} }, @$queue; 3151 push @{ $ns->{query_queue} }, @$queue;
886 3152
887 if (@{ $ns->{query_queue} } == @$queue) { 3153 if (@{ $ns->{query_queue} } == @$queue) {
888 if (@$queue) { 3154 if (@$queue) {
889 $ns->send_packet ($ns->{query_queue}[0][0]); 3155 $ns->send_packet ($ns->{query_queue}[0][0]);
890 } else { 3156 } else {
891 $ns->state (ST_PLAYING); 3157 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM;
892 } 3158 }
893 } 3159 }
3160 },
3161 on_exticmd => sub {
3162 my ($ns, $buf) = @_;
3163
3164 my $msg = eval { $ns->{json_coder}->decode ($buf) };
3165
3166 if (ref $msg) {
3167 my ($type, $reply, @payload) =
3168 "ARRAY" eq ref $msg
3169 ? @$msg
3170 : ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
3171
3172 my @reply;
3173
3174 if (my $cb = $EXTICMD{$type}) {
3175 @reply = $cb->($ns, @payload);
3176 }
3177
3178 $ns->ext_reply ($reply, @reply)
3179 if $reply;
3180
3181 } else {
3182 error "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";
3183 }
3184
3185 cf::override;
894 }, 3186 },
895); 3187);
896 3188
897=item $client->coro (\&cb) 3189=item $client->async (\&cb)
898 3190
899Create a new coroutine, running the specified callback. The coroutine will 3191Create a new coroutine, running the specified callback. The coroutine will
900be automatically cancelled when the client gets destroyed (e.g. on logout, 3192be automatically cancelled when the client gets destroyed (e.g. on logout,
901or loss of connection). 3193or loss of connection).
902 3194
903=cut 3195=cut
904 3196
905sub cf::client::coro { 3197sub cf::client::async {
906 my ($self, $cb) = @_; 3198 my ($self, $cb) = @_;
907 3199
908 my $coro; $coro = async { 3200 my $coro = &Coro::async ($cb);
909 eval { 3201
910 $cb->(); 3202 $coro->on_destroy (sub {
911 };
912 warn $@ if $@;
913 delete $self->{_coro}{$coro+0}; 3203 delete $self->{_coro}{$coro+0};
914 }; 3204 });
915 3205
916 $self->{_coro}{$coro+0} = $coro; 3206 $self->{_coro}{$coro+0} = $coro;
3207
3208 $coro
917} 3209}
918 3210
919cf::client->attach ( 3211cf::client->attach (
920 on_destroy => sub { 3212 on_client_destroy => sub {
921 my ($ns) = @_; 3213 my ($ns) = @_;
922 3214
923 $_->cancel for values %{ (delete $ns->{_coro}) || {} }; 3215 $_->cancel for values %{ (delete $ns->{_coro}) || {} };
924 }, 3216 },
925); 3217);
… …
940our $safe = new Safe "safe"; 3232our $safe = new Safe "safe";
941our $safe_hole = new Safe::Hole; 3233our $safe_hole = new Safe::Hole;
942 3234
943$SIG{FPE} = 'IGNORE'; 3235$SIG{FPE} = 'IGNORE';
944 3236
945$safe->permit_only (Opcode::opset qw(:base_core :base_mem :base_orig :base_math sort time)); 3237$safe->permit_only (Opcode::opset qw(
3238 :base_core :base_mem :base_orig :base_math :base_loop
3239 grepstart grepwhile mapstart mapwhile
3240 sort time
3241));
946 3242
947# here we export the classes and methods available to script code 3243# here we export the classes and methods available to script code
948 3244
949=pod 3245=pod
950 3246
951The following fucntions and emthods are available within a safe environment: 3247The following functions and methods are available within a safe environment:
952 3248
953 cf::object contr pay_amount pay_player map 3249 cf::object
3250 contr pay_amount pay_player map x y force_find force_add destroy
3251 insert remove name archname title slaying race decrease split
3252 value
3253
954 cf::object::player player 3254 cf::object::player
955 cf::player peaceful 3255 player
956 cf::map trigger 3256
3257 cf::player
3258 peaceful
3259
3260 cf::map
3261 trigger
957 3262
958=cut 3263=cut
959 3264
960for ( 3265for (
961 ["cf::object" => qw(contr pay_amount pay_player map)], 3266 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y
3267 insert remove inv nrof name archname title slaying race
3268 decrease split destroy change_exp value msg lore send_msg)],
962 ["cf::object::player" => qw(player)], 3269 ["cf::object::player" => qw(player)],
963 ["cf::player" => qw(peaceful)], 3270 ["cf::player" => qw(peaceful send_msg)],
964 ["cf::map" => qw(trigger)], 3271 ["cf::map" => qw(trigger)],
965) { 3272) {
966 no strict 'refs'; 3273 no strict 'refs';
967 my ($pkg, @funs) = @$_; 3274 my ($pkg, @funs) = @$_;
968 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"}) 3275 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})
… …
986 3293
987 my $qcode = $code; 3294 my $qcode = $code;
988 $qcode =~ s/"/‟/g; # not allowed in #line filenames 3295 $qcode =~ s/"/‟/g; # not allowed in #line filenames
989 $qcode =~ s/\n/\\n/g; 3296 $qcode =~ s/\n/\\n/g;
990 3297
3298 %vars = (_dummy => 0) unless %vars;
3299
3300 my @res;
991 local $_; 3301 local $_;
992 local @safe::cf::_safe_eval_args = values %vars;
993 3302
994 my $eval = 3303 my $eval =
995 "do {\n" 3304 "do {\n"
996 . "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n" 3305 . "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n"
997 . "#line 0 \"{$qcode}\"\n" 3306 . "#line 0 \"{$qcode}\"\n"
998 . $code 3307 . $code
999 . "\n}" 3308 . "\n}"
1000 ; 3309 ;
1001 3310
3311 if ($CFG{safe_eval}) {
1002 sub_generation_inc; 3312 sub_generation_inc;
3313 local @safe::cf::_safe_eval_args = values %vars;
1003 my @res = wantarray ? $safe->reval ($eval) : scalar $safe->reval ($eval); 3314 @res = wantarray ? $safe->reval ($eval) : scalar $safe->reval ($eval);
1004 sub_generation_inc; 3315 sub_generation_inc;
3316 } else {
3317 local @cf::_safe_eval_args = values %vars;
3318 @res = wantarray ? eval eval : scalar eval $eval;
3319 }
1005 3320
1006 if ($@) { 3321 if ($@) {
1007 warn "$@"; 3322 warn "$@",
1008 warn "while executing safe code '$code'\n"; 3323 "while executing safe code '$code'\n",
1009 warn "with arguments " . (join " ", %vars) . "\n"; 3324 "with arguments " . (join " ", %vars) . "\n";
1010 } 3325 }
1011 3326
1012 wantarray ? @res : $res[0] 3327 wantarray ? @res : $res[0]
1013} 3328}
1014 3329
… …
1028=cut 3343=cut
1029 3344
1030sub register_script_function { 3345sub register_script_function {
1031 my ($fun, $cb) = @_; 3346 my ($fun, $cb) = @_;
1032 3347
1033 no strict 'refs'; 3348 $fun = "safe::$fun" if $CFG{safe_eval};
1034 *{"safe::$fun"} = $safe_hole->wrap ($cb); 3349 *$fun = $safe_hole->wrap ($cb);
1035} 3350}
1036 3351
1037=back 3352=back
1038 3353
1039=cut 3354=cut
1040 3355
1041############################################################################# 3356#############################################################################
3357# the server's init and main functions
1042 3358
1043=head2 EXTENSION DATABASE SUPPORT 3359sub load_facedata($) {
3360 my ($path) = @_;
1044 3361
1045Crossfire maintains a very simple database for extension use. It can 3362 # HACK to clear player env face cache, we need some signal framework
1046currently store anything that can be serialised using Storable, which 3363 # for this (global event?)
1047excludes objects. 3364 %ext::player_env::MUSIC_FACE_CACHE = ();
1048 3365
1049The parameter C<$family> should best start with the name of the extension 3366 my $enc = JSON::XS->new->utf8->canonical->relaxed;
1050using it, it should be unique.
1051 3367
1052=over 4 3368 trace "loading facedata from $path\n";
1053 3369
1054=item $hashref = cf::db_get $family 3370 my $facedata;
3371 0 < aio_load $path, $facedata
3372 or die "$path: $!";
1055 3373
1056Return a hashref for use by the extension C<$family>, which can be 3374 $facedata = Coro::Storable::thaw $facedata;
1057modified. After modifications, you have to call C<cf::db_dirty> or
1058C<cf::db_sync>.
1059 3375
1060=item $value = cf::db_get $family => $key 3376 $facedata->{version} == 2
3377 or cf::cleanup "$path: version mismatch, cannot proceed.";
1061 3378
1062Returns a single value from the database 3379 # patch in the exptable
3380 my $exp_table = $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]);
3381 $facedata->{resource}{"res/exp_table"} = {
3382 type => FT_RSRC,
3383 data => $exp_table,
3384 hash => (Digest::MD5::md5 $exp_table),
3385 };
3386 cf::cede_to_tick;
1063 3387
1064=item cf::db_put $family => $hashref 3388 {
3389 my $faces = $facedata->{faceinfo};
1065 3390
1066Stores the given family hashref into the database. Updates are delayed, if 3391 while (my ($face, $info) = each %$faces) {
1067you want the data to be synced to disk immediately, use C<cf::db_sync>. 3392 my $idx = (cf::face::find $face) || cf::face::alloc $face;
1068 3393
1069=item cf::db_put $family => $key => $value 3394 cf::face::set_visibility $idx, $info->{visibility};
3395 cf::face::set_magicmap $idx, $info->{magicmap};
3396 cf::face::set_data $idx, 0, $info->{data32}, $info->{hash32};
3397 cf::face::set_data $idx, 1, $info->{data64}, $info->{hash64};
1070 3398
1071Stores the given C<$value> in the family hash. Updates are delayed, if you 3399 cf::cede_to_tick;
1072want the data to be synced to disk immediately, use C<cf::db_sync>. 3400 }
1073 3401
1074=item cf::db_dirty 3402 while (my ($face, $info) = each %$faces) {
3403 next unless $info->{smooth};
1075 3404
1076Marks the database as dirty, to be updated at a later time. 3405 my $idx = cf::face::find $face
3406 or next;
1077 3407
1078=item cf::db_sync 3408 if (my $smooth = cf::face::find $info->{smooth}) {
3409 cf::face::set_smooth $idx, $smooth;
3410 cf::face::set_smoothlevel $idx, $info->{smoothlevel};
3411 } else {
3412 error "smooth face '$info->{smooth}' not found for face '$face'";
3413 }
1079 3414
1080Immediately write the database to disk I<if it is dirty>. 3415 cf::cede_to_tick;
3416 }
3417 }
1081 3418
1082=cut 3419 {
3420 my $anims = $facedata->{animinfo};
1083 3421
1084our $DB; 3422 while (my ($anim, $info) = each %$anims) {
3423 cf::anim::set $anim, $info->{frames}, $info->{facings};
3424 cf::cede_to_tick;
3425 }
3426
3427 cf::anim::invalidate_all; # d'oh
3428 }
3429
3430 {
3431 my $res = $facedata->{resource};
3432
3433 while (my ($name, $info) = each %$res) {
3434 if (defined $info->{type}) {
3435 my $idx = (cf::face::find $name) || cf::face::alloc $name;
3436
3437 cf::face::set_data $idx, 0, $info->{data}, $info->{hash};
3438 cf::face::set_type $idx, $info->{type};
3439 } else {
3440 $RESOURCE{$name} = $info; # unused
3441 }
3442
3443 cf::cede_to_tick;
3444 }
3445 }
3446
3447 cf::global->invoke (EVENT_GLOBAL_RESOURCE_UPDATE);
3448
3449 1
3450}
3451
3452register_exticmd fx_want => sub {
3453 my ($ns, $want) = @_;
3454
3455 while (my ($k, $v) = each %$want) {
3456 $ns->fx_want ($k, $v);
3457 }
3458};
3459
3460sub load_resource_file($) {
3461 my $guard = lock_acquire "load_resource_file";
3462
3463 my $status = load_resource_file_ $_[0];
3464 get_slot 0.1, 100;
3465 cf::arch::commit_load;
3466
3467 $status
3468}
3469
3470sub reload_regions {
3471 # HACK to clear player env face cache, we need some signal framework
3472 # for this (global event?)
3473 %ext::player_env::MUSIC_FACE_CACHE = ();
3474
3475 load_resource_file "$MAPDIR/regions"
3476 or die "unable to load regions file\n";
3477
3478 for (cf::region::list) {
3479 $_->{match} = qr/$_->{match}/
3480 if exists $_->{match};
3481 }
3482}
3483
3484sub reload_facedata {
3485 load_facedata "$DATADIR/facedata"
3486 or die "unable to load facedata\n";
3487}
3488
3489sub reload_archetypes {
3490 load_resource_file "$DATADIR/archetypes"
3491 or die "unable to load archetypes\n";
3492}
3493
3494sub reload_treasures {
3495 load_resource_file "$DATADIR/treasures"
3496 or die "unable to load treasurelists\n";
3497}
3498
3499sub reload_sound {
3500 trace "loading sound config from $DATADIR/sound\n";
3501
3502 0 < Coro::AIO::aio_load "$DATADIR/sound", my $data
3503 or die "$DATADIR/sound $!";
3504
3505 my $soundconf = JSON::XS->new->utf8->relaxed->decode ($data);
3506
3507 for (0 .. SOUND_CAST_SPELL_0 - 1) {
3508 my $sound = $soundconf->{compat}[$_]
3509 or next;
3510
3511 my $face = cf::face::find "sound/$sound->[1]";
3512 cf::sound::set $sound->[0] => $face;
3513 cf::sound::old_sound_index $_, $face; # gcfclient-compat
3514 }
3515
3516 while (my ($k, $v) = each %{$soundconf->{event}}) {
3517 my $face = cf::face::find "sound/$v";
3518 cf::sound::set $k => $face;
3519 }
3520}
3521
3522sub reload_resources {
3523 trace "reloading resource files...\n";
3524
3525 reload_facedata;
3526 reload_sound;
3527 reload_archetypes;
3528 reload_regions;
3529 reload_treasures;
3530
3531 trace "finished reloading resource files\n";
3532}
3533
3534sub reload_config {
3535 trace "reloading config file...\n";
3536
3537 open my $fh, "<:utf8", "$CONFDIR/config"
3538 or return;
3539
3540 local $/;
3541 *CFG = YAML::XS::Load scalar <$fh>;
3542
3543 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_104_115", 49, 38];
3544
3545 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset};
3546 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset};
3547
3548 if (exists $CFG{mlockall}) {
3549 eval {
3550 $CFG{mlockall} ? eval "mlockall()" : eval "munlockall()"
3551 and die "WARNING: m(un)lockall failed: $!\n";
3552 };
3553 warn $@ if $@;
3554 }
3555
3556 trace "finished reloading resource files\n";
3557}
3558
3559sub pidfile() {
3560 sysopen my $fh, $PIDFILE, O_RDWR | O_CREAT
3561 or die "$PIDFILE: $!";
3562 flock $fh, &Fcntl::LOCK_EX
3563 or die "$PIDFILE: flock: $!";
3564 $fh
3565}
3566
3567# make sure only one server instance is running at any one time
3568sub atomic {
3569 my $fh = pidfile;
3570
3571 my $pid = <$fh>;
3572 kill 9, $pid if $pid > 0;
3573
3574 seek $fh, 0, 0;
3575 print $fh $$;
3576}
3577
3578sub main_loop {
3579 trace "EV::loop starting\n";
3580 if (1) {
3581 EV::loop;
3582 }
3583 trace "EV::loop returned\n";
3584 goto &main_loop unless $REALLY_UNLOOP;
3585}
3586
3587sub main {
3588 cf::init_globals; # initialise logging
3589
3590 LOG llevInfo, "Welcome to Deliantra, v" . VERSION;
3591 LOG llevInfo, "Copyright (C) 2005-2008 Marc Alexander Lehmann / Robin Redeker / the Deliantra team.";
3592 LOG llevInfo, "Copyright (C) 1994 Mark Wedel.";
3593 LOG llevInfo, "Copyright (C) 1992 Frank Tore Johansen.";
3594
3595 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority
3596
3597 # we must not ever block the main coroutine
3598 local $Coro::idle = sub {
3599 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
3600 (async {
3601 $Coro::current->{desc} = "IDLE BUG HANDLER";
3602 EV::loop EV::LOOP_ONESHOT;
3603 })->prio (Coro::PRIO_MAX);
3604 };
3605
3606 evthread_start IO::AIO::poll_fileno;
3607
3608 cf::sync_job {
3609 cf::init_experience;
3610 cf::init_anim;
3611 cf::init_attackmess;
3612 cf::init_dynamic;
3613
3614 cf::load_settings;
3615 cf::load_materials;
3616
3617 reload_resources;
3618 reload_config;
3619 db_init;
3620
3621 cf::init_uuid;
3622 cf::init_signals;
3623 cf::init_skills;
3624
3625 cf::init_beforeplay;
3626
3627 atomic;
3628
3629 load_extensions;
3630
3631 utime time, time, $RUNTIMEFILE;
3632
3633 # no (long-running) fork's whatsoever before this point(!)
3634 use POSIX ();
3635 POSIX::close delete $ENV{LOCKUTIL_LOCK_FD} if exists $ENV{LOCKUTIL_LOCK_FD};
3636
3637 (pop @POST_INIT)->(0) while @POST_INIT;
3638 };
3639
3640 cf::object::thawer::errors_are_fatal 0;
3641 info "parse errors in files are no longer fatal from this point on.\n";
3642
3643 main_loop;
3644}
3645
3646#############################################################################
3647# initialisation and cleanup
3648
3649# install some emergency cleanup handlers
3650BEGIN {
3651 our %SIGWATCHER = ();
3652 for my $signal (qw(INT HUP TERM)) {
3653 $SIGWATCHER{$signal} = AE::signal $signal, sub {
3654 cf::cleanup "SIG$signal";
3655 };
3656 }
3657}
3658
3659sub write_runtime_sync {
3660 my $t0 = AE::time;
3661
3662 # first touch the runtime file to show we are still running:
3663 # the fsync below can take a very very long time.
3664
3665 IO::AIO::aio_utime $RUNTIMEFILE, undef, undef;
3666
3667 my $guard = cf::lock_acquire "write_runtime";
3668
3669 my $fh = aio_open "$RUNTIMEFILE~", O_WRONLY | O_CREAT | O_TRUNC, 0644
3670 or return;
3671
3672 my $value = $cf::RUNTIME + 90 + 10;
3673 # 10 is the runtime save interval, for a monotonic clock
3674 # 60 allows for the watchdog to kill the server.
3675
3676 (aio_write $fh, 0, (length $value), $value, 0) <= 0
3677 and return;
3678
3679 # always fsync - this file is important
3680 aio_fsync $fh
3681 and return;
3682
3683 # touch it again to show we are up-to-date
3684 aio_utime $fh, undef, undef;
3685
3686 close $fh
3687 or return;
3688
3689 aio_rename "$RUNTIMEFILE~", $RUNTIMEFILE
3690 and return;
3691
3692 trace sprintf "runtime file written (%gs).\n", AE::time - $t0;
3693
3694 1
3695}
3696
3697our $uuid_lock;
3698our $uuid_skip;
3699
3700sub write_uuid_sync($) {
3701 $uuid_skip ||= $_[0];
3702
3703 return if $uuid_lock;
3704 local $uuid_lock = 1;
3705
3706 my $uuid = "$LOCALDIR/uuid";
3707
3708 my $fh = aio_open "$uuid~", O_WRONLY | O_CREAT, 0644
3709 or return;
3710
3711 my $value = uuid_seq uuid_cur;
3712
3713 unless ($value) {
3714 info "cowardly refusing to write zero uuid value!\n";
3715 return;
3716 }
3717
3718 my $value = uuid_str $value + $uuid_skip;
3719 $uuid_skip = 0;
3720
3721 (aio_write $fh, 0, (length $value), $value, 0) <= 0
3722 and return;
3723
3724 # always fsync - this file is important
3725 aio_fsync $fh
3726 and return;
3727
3728 close $fh
3729 or return;
3730
3731 aio_rename "$uuid~", $uuid
3732 and return;
3733
3734 trace "uuid file written ($value).\n";
3735
3736 1
3737
3738}
3739
3740sub write_uuid($$) {
3741 my ($skip, $sync) = @_;
3742
3743 $sync ? write_uuid_sync $skip
3744 : async { write_uuid_sync $skip };
3745}
3746
3747sub emergency_save() {
3748 my $freeze_guard = cf::freeze_mainloop;
3749
3750 info "emergency_perl_save: enter\n";
3751
3752 cf::sync_job {
3753 # this is a trade-off: we want to be very quick here, so
3754 # save all maps without fsync, and later call a global sync
3755 # (which in turn might be very very slow)
3756 local $USE_FSYNC = 0;
3757
3758 # use a peculiar iteration method to avoid tripping on perl
3759 # refcount bugs in for. also avoids problems with players
3760 # and maps saved/destroyed asynchronously.
3761 info "emergency_perl_save: begin player save\n";
3762 for my $login (keys %cf::PLAYER) {
3763 my $pl = $cf::PLAYER{$login} or next;
3764 $pl->valid or next;
3765 delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt
3766 $pl->save;
3767 }
3768 info "emergency_perl_save: end player save\n";
3769
3770 info "emergency_perl_save: begin map save\n";
3771 for my $path (keys %cf::MAP) {
3772 my $map = $cf::MAP{$path} or next;
3773 $map->valid or next;
3774 $map->save;
3775 }
3776 info "emergency_perl_save: end map save\n";
3777
3778 info "emergency_perl_save: begin database checkpoint\n";
3779 BDB::db_env_txn_checkpoint $DB_ENV;
3780 info "emergency_perl_save: end database checkpoint\n";
3781
3782 info "emergency_perl_save: begin write uuid\n";
3783 write_uuid_sync 1;
3784 info "emergency_perl_save: end write uuid\n";
3785 };
3786
3787 info "emergency_perl_save: starting sync()\n";
3788 IO::AIO::aio_sync sub {
3789 info "emergency_perl_save: finished sync()\n";
3790 };
3791
3792 info "emergency_perl_save: leave\n";
3793}
3794
3795sub post_cleanup {
3796 my ($make_core) = @_;
3797
3798 error Carp::longmess "post_cleanup backtrace"
3799 if $make_core;
3800
3801 my $fh = pidfile;
3802 unlink $PIDFILE if <$fh> == $$;
3803}
3804
3805# a safer delete_package, copied from Symbol
3806sub clear_package($) {
3807 my $pkg = shift;
3808
3809 # expand to full symbol table name if needed
3810 unless ($pkg =~ /^main::.*::$/) {
3811 $pkg = "main$pkg" if $pkg =~ /^::/;
3812 $pkg = "main::$pkg" unless $pkg =~ /^main::/;
3813 $pkg .= '::' unless $pkg =~ /::$/;
3814 }
3815
3816 my($stem, $leaf) = $pkg =~ m/(.*::)(\w+::)$/;
3817 my $stem_symtab = *{$stem}{HASH};
3818
3819 defined $stem_symtab and exists $stem_symtab->{$leaf}
3820 or return;
3821
3822 # clear all symbols
3823 my $leaf_symtab = *{$stem_symtab->{$leaf}}{HASH};
3824 for my $name (keys %$leaf_symtab) {
3825 _gv_clear *{"$pkg$name"};
3826# use PApp::Util; PApp::Util::sv_dump *{"$pkg$name"};
3827 }
3828}
3829
3830sub do_reload_perl() {
3831 # can/must only be called in main
3832 if (in_main) {
3833 error "can only reload from main coroutine";
3834 return;
3835 }
3836
3837 return if $RELOAD++;
3838
3839 my $t1 = AE::time;
3840
3841 while ($RELOAD) {
3842 info "reloading...";
3843
3844 trace "entering sync_job";
3845
3846 cf::sync_job {
3847 cf::write_runtime_sync; # external watchdog should not bark
3848 cf::emergency_save;
3849 cf::write_runtime_sync; # external watchdog should not bark
3850
3851 trace "syncing database to disk";
3852 BDB::db_env_txn_checkpoint $DB_ENV;
3853
3854 # if anything goes wrong in here, we should simply crash as we already saved
3855
3856 trace "flushing outstanding aio requests";
3857 while (IO::AIO::nreqs || BDB::nreqs) {
3858 Coro::EV::timer_once 0.01; # let the sync_job do it's thing
3859 }
3860
3861 trace "cancelling all extension coros";
3862 $_->cancel for values %EXT_CORO;
3863 %EXT_CORO = ();
3864
3865 trace "removing commands";
3866 %COMMAND = ();
3867
3868 trace "removing ext/exti commands";
3869 %EXTCMD = ();
3870 %EXTICMD = ();
3871
3872 trace "unloading/nuking all extensions";
3873 for my $pkg (@EXTS) {
3874 trace "... unloading $pkg";
3875
3876 if (my $cb = $pkg->can ("unload")) {
3877 eval {
3878 $cb->($pkg);
3879 1
3880 } or error "$pkg unloaded, but with errors: $@";
3881 }
3882
3883 trace "... clearing $pkg";
3884 clear_package $pkg;
3885 }
3886
3887 trace "unloading all perl modules loaded from $LIBDIR";
3888 while (my ($k, $v) = each %INC) {
3889 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
3890
3891 trace "... unloading $k";
3892 delete $INC{$k};
3893
3894 $k =~ s/\.pm$//;
3895 $k =~ s/\//::/g;
3896
3897 if (my $cb = $k->can ("unload_module")) {
3898 $cb->();
3899 }
3900
3901 clear_package $k;
3902 }
3903
3904 trace "getting rid of safe::, as good as possible";
3905 clear_package "safe::$_"
3906 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
3907
3908 trace "unloading cf.pm \"a bit\"";
3909 delete $INC{"cf.pm"};
3910 delete $INC{"cf/$_.pm"} for @EXTRA_MODULES;
3911
3912 # don't, removes xs symbols, too,
3913 # and global variables created in xs
3914 #clear_package __PACKAGE__;
3915
3916 info "unload completed, starting to reload now";
3917
3918 trace "reloading cf.pm";
3919 require cf;
3920 cf::_connect_to_perl_1;
3921
3922 trace "loading config and database again";
3923 cf::reload_config;
3924
3925 trace "loading extensions";
3926 cf::load_extensions;
3927
3928 if ($REATTACH_ON_RELOAD) {
3929 trace "reattaching attachments to objects/players";
3930 _global_reattach; # objects, sockets
3931 trace "reattaching attachments to maps";
3932 reattach $_ for values %MAP;
3933 trace "reattaching attachments to players";
3934 reattach $_ for values %PLAYER;
3935 }
3936
3937 trace "running post_init jobs";
3938 (pop @POST_INIT)->(1) while @POST_INIT;
3939
3940 trace "leaving sync_job";
3941
3942 1
3943 } or do {
3944 error $@;
3945 cf::cleanup "error while reloading, exiting.";
3946 };
3947
3948 info "reloaded";
3949 --$RELOAD;
3950 }
3951
3952 $t1 = AE::time - $t1;
3953 info "reload completed in ${t1}s\n";
3954};
3955
3956our $RELOAD_WATCHER; # used only during reload
3957
3958sub reload_perl() {
3959 # doing reload synchronously and two reloads happen back-to-back,
3960 # coro crashes during coro_state_free->destroy here.
3961
3962 $RELOAD_WATCHER ||= cf::async {
3963 Coro::AIO::aio_wait cache_extensions;
3964
3965 $RELOAD_WATCHER = AE::timer $TICK * 1.5, 0, sub {
3966 do_reload_perl;
3967 undef $RELOAD_WATCHER;
3968 };
3969 };
3970}
3971
3972register_command "reload" => sub {
3973 my ($who, $arg) = @_;
3974
3975 if ($who->flag (FLAG_WIZ)) {
3976 $who->message ("reloading server.");
3977 async {
3978 $Coro::current->{desc} = "perl_reload";
3979 reload_perl;
3980 };
3981 }
3982};
3983
3984unshift @INC, $LIBDIR;
3985
3986my $bug_warning = 0;
3987
3988our @WAIT_FOR_TICK;
3989our @WAIT_FOR_TICK_BEGIN;
3990
3991sub wait_for_tick {
3992 return Coro::cede if tick_inhibit || $Coro::current == $Coro::main;
3993
3994 my $signal = new Coro::Signal;
3995 push @WAIT_FOR_TICK, $signal;
3996 $signal->wait;
3997}
3998
3999sub wait_for_tick_begin {
4000 return Coro::cede if tick_inhibit || $Coro::current == $Coro::main;
4001
4002 my $signal = new Coro::Signal;
4003 push @WAIT_FOR_TICK_BEGIN, $signal;
4004 $signal->wait;
4005}
4006
4007sub tick {
4008 if ($Coro::current != $Coro::main) {
4009 Carp::cluck "major BUG: server tick called outside of main coro, skipping it"
4010 unless ++$bug_warning > 10;
4011 return;
4012 }
4013
4014 cf::server_tick; # one server iteration
4015
4016 #for(1..3e6){} AE::now_update; $NOW=AE::now; # generate load #d#
4017
4018 if ($NOW >= $NEXT_RUNTIME_WRITE) {
4019 $NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.;
4020 Coro::async_pool {
4021 $Coro::current->{desc} = "runtime saver";
4022 write_runtime_sync
4023 or error "ERROR: unable to write runtime file: $!";
4024 };
4025 }
4026
4027 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
4028 $sig->send;
4029 }
4030 while (my $sig = shift @WAIT_FOR_TICK) {
4031 $sig->send;
4032 }
4033
4034 $LOAD = ($NOW - $TICK_START) / $TICK;
4035 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
4036
4037 if (0) {
4038 if ($NEXT_TICK) {
4039 my $jitter = $TICK_START - $NEXT_TICK;
4040 $JITTER = $JITTER * 0.75 + $jitter * 0.25;
4041 debug "jitter $JITTER\n";#d#
4042 }
4043 }
4044}
1085 4045
1086{ 4046{
1087 my $path = cf::localdir . "/database.pst"; 4047 # configure BDB
1088 4048
1089 sub db_load() { 4049 BDB::min_parallel 16;
1090 warn "loading database $path\n";#d# remove later 4050 BDB::max_poll_reqs $TICK * 0.1;
1091 $DB = stat $path ? Storable::retrieve $path : { }; 4051 $AnyEvent::BDB::WATCHER->priority (1);
1092 }
1093 4052
1094 my $pid; 4053 unless ($DB_ENV) {
4054 $DB_ENV = BDB::db_env_create;
4055 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT);
4056 $DB_ENV->set_flags (&BDB::LOG_AUTOREMOVE ) if BDB::VERSION v0, v4.7;
4057 $DB_ENV->log_set_config (&BDB::LOG_AUTO_REMOVE) if BDB::VERSION v4.7;
4058 $DB_ENV->set_timeout (30, BDB::SET_TXN_TIMEOUT);
4059 $DB_ENV->set_timeout (30, BDB::SET_LOCK_TIMEOUT);
1095 4060
1096 sub db_save() { 4061 (Coro::async { # async to keep sync_job from complaining
1097 warn "saving database $path\n";#d# remove later 4062 cf::sync_job {
1098 waitpid $pid, 0 if $pid; 4063 eval {
1099 if (0 == ($pid = fork)) { 4064 BDB::db_env_open
1100 $DB->{_meta}{version} = 1; 4065 $DB_ENV,
1101 Storable::nstore $DB, "$path~"; 4066 $BDBDIR,
1102 rename "$path~", $path; 4067 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN
1103 cf::_exit 0 if defined $pid; 4068 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE,
1104 } 4069 0666;
1105 }
1106 4070
1107 my $dirty; 4071 cf::cleanup "db_env_open($BDBDIR): $!" if $!;
1108
1109 sub db_sync() {
1110 db_save if $dirty;
1111 undef $dirty;
1112 }
1113
1114 my $idle = Event->idle (min => $TICK * 2.8, max => 10, repeat => 0, data => WF_AUTOCANCEL, cb => sub {
1115 db_sync;
1116 });
1117
1118 sub db_dirty() {
1119 $dirty = 1;
1120 $idle->start;
1121 }
1122
1123 sub db_get($;$) {
1124 @_ >= 2
1125 ? $DB->{$_[0]}{$_[1]}
1126 : ($DB->{$_[0]} ||= { })
1127 }
1128
1129 sub db_put($$;$) {
1130 if (@_ >= 3) {
1131 $DB->{$_[0]}{$_[1]} = $_[2];
1132 } else {
1133 $DB->{$_[0]} = $_[1];
1134 }
1135 db_dirty;
1136 }
1137
1138 cf::global->attach (
1139 prio => 10000,
1140 on_cleanup => sub {
1141 db_sync;
1142 },
1143 );
1144}
1145
1146#############################################################################
1147# the server's main()
1148
1149sub cfg_load {
1150 open my $fh, "<:utf8", cf::confdir . "/config"
1151 or return;
1152
1153 local $/;
1154 *CFG = YAML::Syck::Load <$fh>;
1155}
1156
1157sub main {
1158 cfg_load;
1159 db_load;
1160 load_extensions;
1161 Event::loop;
1162}
1163
1164#############################################################################
1165# initialisation
1166
1167sub _perl_reload(&) {
1168 my ($msg) = @_;
1169
1170 $msg->("reloading...");
1171
1172 eval {
1173 # cancel all watchers
1174 for (Event::all_watchers) {
1175 $_->cancel if $_->data & WF_AUTOCANCEL;
1176 }
1177
1178 # unload all extensions
1179 for (@exts) {
1180 $msg->("unloading <$_>");
1181 unload_extension $_;
1182 }
1183
1184 # unload all modules loaded from $LIBDIR
1185 while (my ($k, $v) = each %INC) {
1186 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
1187
1188 $msg->("removing <$k>");
1189 delete $INC{$k};
1190
1191 $k =~ s/\.pm$//;
1192 $k =~ s/\//::/g;
1193
1194 if (my $cb = $k->can ("unload_module")) {
1195 $cb->(); 4072 };
4073
4074 cf::cleanup "db_env_open(db): $@" if $@;
1196 } 4075 };
4076 })->join;
4077 }
1197 4078
1198 Symbol::delete_package $k; 4079 $BDB_DEADLOCK_WATCHER = EV::periodic 0, 3, 0, sub {
1199 } 4080 BDB::db_env_lock_detect $DB_ENV, 0, BDB::LOCK_DEFAULT, 0, sub { };
1200
1201 # sync database to disk
1202 cf::db_sync;
1203
1204 # get rid of safe::, as good as possible
1205 Symbol::delete_package "safe::$_"
1206 for qw(cf::object cf::object::player cf::player cf::map cf::party cf::region);
1207
1208 # remove register_script_function callbacks
1209 # TODO
1210
1211 # unload cf.pm "a bit"
1212 delete $INC{"cf.pm"};
1213
1214 # don't, removes xs symbols, too,
1215 # and global variables created in xs
1216 #Symbol::delete_package __PACKAGE__;
1217
1218 # reload cf.pm
1219 $msg->("reloading cf.pm");
1220 require cf;
1221
1222 # load config and database again
1223 cf::cfg_load;
1224 cf::db_load;
1225
1226 # load extensions
1227 $msg->("load extensions");
1228 cf::load_extensions;
1229
1230 # reattach attachments to objects
1231 $msg->("reattach");
1232 _global_reattach;
1233 }; 4081 };
1234 $msg->($@) if $@; 4082 $BDB_CHECKPOINT_WATCHER = EV::periodic 0, 60, 0, sub {
1235 4083 BDB::db_env_txn_checkpoint $DB_ENV, 0, 0, 0, sub { };
1236 $msg->("reloaded");
1237};
1238
1239sub perl_reload() {
1240 _perl_reload {
1241 warn $_[0];
1242 print "$_[0]\n";
1243 }; 4084 };
4085 $BDB_TRICKLE_WATCHER = EV::periodic 0, 10, 0, sub {
4086 BDB::db_env_memp_trickle $DB_ENV, 20, 0, sub { };
4087 };
1244} 4088}
1245 4089
1246register "<global>", __PACKAGE__; 4090{
4091 # configure IO::AIO
1247 4092
1248register_command "perl-reload" => sub { 4093 IO::AIO::min_parallel 8;
4094 IO::AIO::max_poll_time $TICK * 0.1;
4095 undef $AnyEvent::AIO::WATCHER;
4096}
4097
4098my $_log_backtrace;
4099
4100sub _log_backtrace {
1249 my ($who, $arg) = @_; 4101 my ($msg, @addr) = @_;
1250 4102
1251 if ($who->flag (FLAG_WIZ)) { 4103 $msg =~ s/\n//;
1252 _perl_reload { 4104
1253 warn $_[0]; 4105 # limit the # of concurrent backtraces
1254 $who->message ($_[0]); 4106 if ($_log_backtrace < 2) {
4107 ++$_log_backtrace;
4108 my $perl_bt = Carp::longmess $msg;
4109 async {
4110 $Coro::current->{desc} = "abt $msg";
4111
4112 my @bt = fork_call {
4113 @addr = map { sprintf "%x", $_ } @addr;
4114 my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X;
4115 open my $fh, "exec addr2line -C -f -i -e \Q$self\E @addr 2>&1 |"
4116 or die "addr2line: $!";
4117
4118 my @funcs;
4119 my @res = <$fh>;
4120 chomp for @res;
4121 while (@res) {
4122 my ($func, $line) = splice @res, 0, 2, ();
4123 push @funcs, "[$func] $line";
4124 }
4125
4126 @funcs
4127 };
4128
4129 LOG llevInfo, "[ABT] $perl_bt\n";
4130 LOG llevInfo, "[ABT] --- C backtrace follows ---\n";
4131 LOG llevInfo, "[ABT] $_\n" for @bt;
4132 --$_log_backtrace;
1255 }; 4133 };
1256 } 4134 } else {
1257}; 4135 LOG llevInfo, "[ABT] $msg\n";
1258 4136 LOG llevInfo, "[ABT] [suppressed]\n";
1259unshift @INC, $LIBDIR;
1260
1261$TICK_WATCHER = Event->timer (
1262 prio => 0,
1263 at => $NEXT_TICK || 1,
1264 data => WF_AUTOCANCEL,
1265 cb => sub {
1266 cf::server_tick; # one server iteration
1267
1268 my $NOW = Event::time;
1269 $NEXT_TICK += $TICK;
1270
1271 # if we are delayed by four ticks or more, skip them all
1272 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
1273
1274 $TICK_WATCHER->at ($NEXT_TICK);
1275 $TICK_WATCHER->start;
1276 }, 4137 }
1277); 4138}
1278 4139
1279IO::AIO::max_poll_time $TICK * 0.2; 4140# load additional modules
4141require "cf/$_.pm" for @EXTRA_MODULES;
4142cf::_connect_to_perl_2;
1280 4143
1281Event->io (fd => IO::AIO::poll_fileno, 4144END { cf::emergency_save }
1282 poll => 'r',
1283 prio => 5,
1284 data => WF_AUTOCANCEL,
1285 cb => \&IO::AIO::poll_cb);
1286 4145
12871 41461
1288 4147

Diff Legend

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