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

Diff Legend

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