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

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines