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.385 by root, Fri Oct 12 19:13:26 2007 UTC vs.
Revision 1.496 by root, Sun Nov 15 18:03:59 2009 UTC

1#
2# This file is part of Deliantra, the Roguelike Realtime MMORPG.
3#
4# Copyright (©) 2006,2007,2008 Marc Alexander Lehmann / Robin Redeker / the Deliantra team
5#
6# Deliantra is free software: you can redistribute it and/or modify it under
7# the terms of the Affero GNU General Public License as published by the
8# Free Software Foundation, either version 3 of the License, or (at your
9# option) any later version.
10#
11# This program is distributed in the hope that it will be useful,
12# but WITHOUT ANY WARRANTY; without even the implied warranty of
13# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14# GNU General Public License for more details.
15#
16# You should have received a copy of the Affero GNU General Public License
17# and the GNU General Public License along with this program. If not, see
18# <http://www.gnu.org/licenses/>.
19#
20# The authors can be reached via e-mail to <support@deliantra.net>
21#
22
1package cf; 23package cf;
2 24
25use 5.10.0;
3use utf8; 26use utf8;
4use strict; 27use strict qw(vars subs);
5 28
6use Symbol; 29use Symbol;
7use List::Util; 30use List::Util;
8use Socket; 31use Socket;
9use Event; 32use EV;
10use Opcode; 33use Opcode;
11use Safe; 34use Safe;
12use Safe::Hole; 35use Safe::Hole;
13use Storable (); 36use Storable ();
37use Carp ();
14 38
39use Guard ();
15use Coro 4.1 (); 40use Coro ();
16use Coro::State; 41use Coro::State;
17use Coro::Handle; 42use Coro::Handle;
43use Coro::EV;
18use Coro::Event; 44use Coro::AnyEvent;
19use Coro::Timer; 45use Coro::Timer;
20use Coro::Signal; 46use Coro::Signal;
21use Coro::Semaphore; 47use Coro::Semaphore;
48use Coro::SemaphoreSet;
49use Coro::AnyEvent;
22use Coro::AIO; 50use Coro::AIO;
51use Coro::BDB 1.6;
23use Coro::Storable; 52use Coro::Storable;
24use Coro::Util (); 53use Coro::Util ();
25 54
26use JSON::XS (); 55use JSON::XS 2.01 ();
27use BDB (); 56use BDB ();
28use Data::Dumper; 57use Data::Dumper;
29use Digest::MD5;
30use Fcntl; 58use Fcntl;
31use YAML::Syck (); 59use YAML::XS ();
32use IO::AIO 2.51 (); 60use IO::AIO ();
33use Time::HiRes; 61use Time::HiRes;
34use Compress::LZF; 62use Compress::LZF;
35use Digest::MD5 (); 63use Digest::MD5 ();
64
65AnyEvent::detect;
36 66
37# configure various modules to our taste 67# configure various modules to our taste
38# 68#
39$Storable::canonical = 1; # reduce rsync transfers 69$Storable::canonical = 1; # reduce rsync transfers
40Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator 70Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator
71
72$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority
73
74# make sure c-lzf reinitialises itself
75Compress::LZF::set_serializer "Storable", "Storable::net_mstore", "Storable::mretrieve";
41Compress::LZF::sfreeze_cr { }; # prime Compress::LZF so it does not use require later 76Compress::LZF::sfreeze_cr { }; # prime Compress::LZF so it does not use require later
42 77
43$Event::Eval = 1; # no idea why this is required, but it is 78# strictly for debugging
44 79$SIG{QUIT} = sub { Carp::cluck "SIGQUIT" };
45# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode?
46$YAML::Syck::ImplicitUnicode = 1;
47
48$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority
49 80
50sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload 81sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
51 82
52our %COMMAND = (); 83our %COMMAND = ();
53our %COMMAND_TIME = (); 84our %COMMAND_TIME = ();
… …
56our %EXTCMD = (); 87our %EXTCMD = ();
57our %EXTICMD = (); 88our %EXTICMD = ();
58our %EXT_CORO = (); # coroutines bound to extensions 89our %EXT_CORO = (); # coroutines bound to extensions
59our %EXT_MAP = (); # pluggable maps 90our %EXT_MAP = (); # pluggable maps
60 91
61our $RELOAD; # number of reloads so far 92our $RELOAD; # number of reloads so far, non-zero while in reload
62our @EVENT; 93our @EVENT;
94our @REFLECT; # set by XS
95our %REFLECT; # set by us
63 96
64our $CONFDIR = confdir; 97our $CONFDIR = confdir;
65our $DATADIR = datadir; 98our $DATADIR = datadir;
66our $LIBDIR = "$DATADIR/ext"; 99our $LIBDIR = "$DATADIR/ext";
67our $PODDIR = "$DATADIR/pod"; 100our $PODDIR = "$DATADIR/pod";
68our $MAPDIR = "$DATADIR/" . mapdir; 101our $MAPDIR = "$DATADIR/" . mapdir;
69our $LOCALDIR = localdir; 102our $LOCALDIR = localdir;
70our $TMPDIR = "$LOCALDIR/" . tmpdir; 103our $TMPDIR = "$LOCALDIR/" . tmpdir;
71our $UNIQUEDIR = "$LOCALDIR/" . uniquedir; 104our $UNIQUEDIR = "$LOCALDIR/" . uniquedir;
72our $PLAYERDIR = "$LOCALDIR/" . playerdir; 105our $PLAYERDIR = "$LOCALDIR/" . playerdir;
73our $RANDOMDIR = "$LOCALDIR/random"; 106our $RANDOMDIR = "$LOCALDIR/random";
74our $BDBDIR = "$LOCALDIR/db"; 107our $BDBDIR = "$LOCALDIR/db";
108our $PIDFILE = "$LOCALDIR/pid";
109our $RUNTIMEFILE = "$LOCALDIR/runtime";
110
111our %RESOURCE;
75 112
76our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!) 113our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!)
77our $TICK_WATCHER;
78our $AIO_POLL_WATCHER;
79our $NEXT_RUNTIME_WRITE; # when should the runtime file be written 114our $NEXT_RUNTIME_WRITE; # when should the runtime file be written
80our $NEXT_TICK; 115our $NEXT_TICK;
81our $NOW;
82our $USE_FSYNC = 1; # use fsync to write maps - default off 116our $USE_FSYNC = 1; # use fsync to write maps - default on
83 117
84our $BDB_POLL_WATCHER;
85our $BDB_DEADLOCK_WATCHER; 118our $BDB_DEADLOCK_WATCHER;
86our $BDB_CHECKPOINT_WATCHER; 119our $BDB_CHECKPOINT_WATCHER;
87our $BDB_TRICKLE_WATCHER; 120our $BDB_TRICKLE_WATCHER;
88our $DB_ENV; 121our $DB_ENV;
89 122
123our @EXTRA_MODULES = qw(pod match mapscript);
124
90our %CFG; 125our %CFG;
91 126
92our $UPTIME; $UPTIME ||= time; 127our $UPTIME; $UPTIME ||= time;
93our $RUNTIME; 128our $RUNTIME;
129our $NOW;
94 130
95our (%PLAYER, %PLAYER_LOADING); # all users 131our (%PLAYER, %PLAYER_LOADING); # all users
96our (%MAP, %MAP_LOADING ); # all maps 132our (%MAP, %MAP_LOADING ); # all maps
97our $LINK_MAP; # the special {link} map, which is always available 133our $LINK_MAP; # the special {link} map, which is always available
98 134
99# used to convert map paths into valid unix filenames by replacing / by ∕ 135# used to convert map paths into valid unix filenames by replacing / by ∕
100our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons 136our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons
101 137
102our $LOAD; # a number between 0 (idle) and 1 (too many objects) 138our $LOAD; # a number between 0 (idle) and 1 (too many objects)
103our $LOADAVG; # same thing, but with alpha-smoothing 139our $LOADAVG; # same thing, but with alpha-smoothing
140our $JITTER; # average jitter
104our $tick_start; # for load detecting purposes 141our $TICK_START; # for load detecting purposes
142
143our @POST_INIT;
144
145our $REATTACH_ON_RELOAD; # set to true to force object reattach on reload (slow)
146our $REALLY_UNLOOP; # never set to true, please :)
105 147
106binmode STDOUT; 148binmode STDOUT;
107binmode STDERR; 149binmode STDERR;
108 150
109# read virtual server time, if available 151# read virtual server time, if available
110unless ($RUNTIME || !-e "$LOCALDIR/runtime") { 152unless ($RUNTIME || !-e $RUNTIMEFILE) {
111 open my $fh, "<", "$LOCALDIR/runtime" 153 open my $fh, "<", $RUNTIMEFILE
112 or die "unable to read runtime file: $!"; 154 or die "unable to read $RUNTIMEFILE file: $!";
113 $RUNTIME = <$fh> + 0.; 155 $RUNTIME = <$fh> + 0.;
114} 156}
157
158eval "sub TICK() { $TICK } 1" or die;
115 159
116mkdir $_ 160mkdir $_
117 for $LOCALDIR, $TMPDIR, $UNIQUEDIR, $PLAYERDIR, $RANDOMDIR, $BDBDIR; 161 for $LOCALDIR, $TMPDIR, $UNIQUEDIR, $PLAYERDIR, $RANDOMDIR, $BDBDIR;
118 162
119our $EMERGENCY_POSITION; 163our $EMERGENCY_POSITION;
120 164
121sub cf::map::normalise; 165sub cf::map::normalise;
166
167#############################################################################
168
169%REFLECT = ();
170for (@REFLECT) {
171 my $reflect = JSON::XS::decode_json $_;
172 $REFLECT{$reflect->{class}} = $reflect;
173}
174
175# this is decidedly evil
176$REFLECT{object}{flags} = { map +($_ => undef), grep $_, map /^FLAG_([A-Z0-9_]+)$/ && lc $1, keys %{"cf::"} };
122 177
123############################################################################# 178#############################################################################
124 179
125=head2 GLOBAL VARIABLES 180=head2 GLOBAL VARIABLES
126 181
… …
162 217
163The raw value load value from the last tick. 218The raw value load value from the last tick.
164 219
165=item %cf::CFG 220=item %cf::CFG
166 221
167Configuration for the server, loaded from C</etc/crossfire/config>, or 222Configuration for the server, loaded from C</etc/deliantra-server/config>, or
168from wherever your confdir points to. 223from wherever your confdir points to.
169 224
170=item cf::wait_for_tick, cf::wait_for_tick_begin 225=item cf::wait_for_tick, cf::wait_for_tick_begin
171 226
172These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only 227These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only
173returns directly I<after> the tick processing (and consequently, can only wake one process 228returns directly I<after> the tick processing (and consequently, can only wake one process
174per tick), while cf::wait_for_tick wakes up all waiters after tick processing. 229per tick), while cf::wait_for_tick wakes up all waiters after tick processing.
175 230
176=item @cf::INVOKE_RESULTS 231=item @cf::INVOKE_RESULTS
177 232
178This array contains the results of the last C<invoke ()> call. When 233This array contains the results of the last C<invoke ()> call. When
179C<cf::override> is called C<@cf::INVOKE_RESULTS> is set to the parameters of 234C<cf::override> is called C<@cf::INVOKE_RESULTS> is set to the parameters of
180that call. 235that call.
181 236
237=item %cf::REFLECT
238
239Contains, for each (C++) class name, a hash reference with information
240about object members (methods, scalars, arrays and flags) and other
241metadata, which is useful for introspection.
242
182=back 243=back
183 244
184=cut 245=cut
185 246
186BEGIN { 247$Coro::State::WARNHOOK = sub {
187 *CORE::GLOBAL::warn = sub {
188 my $msg = join "", @_; 248 my $msg = join "", @_;
189 249
190 $msg .= "\n" 250 $msg .= "\n"
191 unless $msg =~ /\n$/; 251 unless $msg =~ /\n$/;
192 252
193 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge; 253 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;
194 254
195 LOG llevError, $msg; 255 LOG llevError, $msg;
196 }; 256};
197} 257
258$Coro::State::DIEHOOK = sub {
259 return unless $^S eq 0; # "eq", not "=="
260
261 warn Carp::longmess $_[0];
262
263 if ($Coro::current == $Coro::main) {#d#
264 warn "DIEHOOK called in main context, Coro bug?\n";#d#
265 return;#d#
266 }#d#
267
268 # kill coroutine otherwise
269 Coro::terminate
270};
198 271
199@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable'; 272@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
200@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable'; 273@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';
201@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable'; 274@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable';
202@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable'; 275@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable';
… …
209for my $pkg (qw( 282for my $pkg (qw(
210 cf::global cf::attachable 283 cf::global cf::attachable
211 cf::object cf::object::player 284 cf::object cf::object::player
212 cf::client cf::player 285 cf::client cf::player
213 cf::arch cf::living 286 cf::arch cf::living
287 cf::map cf::mapspace
214 cf::map cf::party cf::region 288 cf::party cf::region
215)) { 289)) {
216 no strict 'refs';
217 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg; 290 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
218} 291}
219 292
220$Event::DIED = sub { 293$EV::DIED = sub {
221 warn "error in event callback: @_"; 294 Carp::cluck "error in event callback: @_";
222}; 295};
223 296
224############################################################################# 297#############################################################################
225 298
226=head2 UTILITY FUNCTIONS 299=head2 UTILITY FUNCTIONS
… …
248 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge; 321 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge;
249 $d 322 $d
250 } || "[unable to dump $_[0]: '$@']"; 323 } || "[unable to dump $_[0]: '$@']";
251} 324}
252 325
253=item $ref = cf::from_json $json 326=item $ref = cf::decode_json $json
254 327
255Converts a JSON string into the corresponding perl data structure. 328Converts a JSON string into the corresponding perl data structure.
256 329
257=item $json = cf::to_json $ref 330=item $json = cf::encode_json $ref
258 331
259Converts a perl data structure into its JSON representation. 332Converts a perl data structure into its JSON representation.
260 333
261=cut 334=cut
262 335
263our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max 336our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max
264 337
265sub to_json ($) { $json_coder->encode ($_[0]) } 338sub encode_json($) { $json_coder->encode ($_[0]) }
266sub from_json ($) { $json_coder->decode ($_[0]) } 339sub decode_json($) { $json_coder->decode ($_[0]) }
340
341=item cf::post_init { BLOCK }
342
343Execute the given codeblock, I<after> all extensions have been (re-)loaded,
344but I<before> the server starts ticking again.
345
346The cdoeblock will have a single boolean argument to indicate whether this
347is a reload or not.
348
349=cut
350
351sub post_init(&) {
352 push @POST_INIT, shift;
353}
267 354
268=item cf::lock_wait $string 355=item cf::lock_wait $string
269 356
270Wait until the given lock is available. See cf::lock_acquire. 357Wait until the given lock is available. See cf::lock_acquire.
271 358
272=item my $lock = cf::lock_acquire $string 359=item my $lock = cf::lock_acquire $string
273 360
274Wait until the given lock is available and then acquires it and returns 361Wait until the given lock is available and then acquires it and returns
275a Coro::guard object. If the guard object gets destroyed (goes out of scope, 362a L<Guard> object. If the guard object gets destroyed (goes out of scope,
276for example when the coroutine gets canceled), the lock is automatically 363for example when the coroutine gets canceled), the lock is automatically
277returned. 364returned.
278 365
279Locks are *not* recursive, locking from the same coro twice results in a 366Locks are *not* recursive, locking from the same coro twice results in a
280deadlocked coro. 367deadlocked coro.
… …
286 373
287Return true if the lock is currently active, i.e. somebody has locked it. 374Return true if the lock is currently active, i.e. somebody has locked it.
288 375
289=cut 376=cut
290 377
291our %LOCK; 378our $LOCKS = new Coro::SemaphoreSet;
292our %LOCKER;#d#
293 379
294sub lock_wait($) { 380sub lock_wait($) {
295 my ($key) = @_; 381 $LOCKS->wait ($_[0]);
296
297 if ($LOCKER{$key} == $Coro::current) {#d#
298 Carp::cluck "lock_wait($key) for already-acquired lock";#d#
299 return;#d#
300 }#d#
301
302 # wait for lock, if any
303 while ($LOCK{$key}) {
304 push @{ $LOCK{$key} }, $Coro::current;
305 Coro::schedule;
306 }
307} 382}
308 383
309sub lock_acquire($) { 384sub lock_acquire($) {
310 my ($key) = @_; 385 $LOCKS->guard ($_[0])
311
312 # wait, to be sure we are not locked
313 lock_wait $key;
314
315 $LOCK{$key} = [];
316 $LOCKER{$key} = $Coro::current;#d#
317
318 Coro::guard {
319 delete $LOCKER{$key};#d#
320 # wake up all waiters, to be on the safe side
321 $_->ready for @{ delete $LOCK{$key} };
322 }
323} 386}
324 387
325sub lock_active($) { 388sub lock_active($) {
326 my ($key) = @_; 389 $LOCKS->count ($_[0]) < 1
327
328 ! ! $LOCK{$key}
329} 390}
330 391
331sub freeze_mainloop { 392sub freeze_mainloop {
332 return unless $TICK_WATCHER->is_active; 393 tick_inhibit_inc;
333 394
334 my $guard = Coro::guard { 395 &Guard::guard (\&tick_inhibit_dec);
335 $TICK_WATCHER->start; 396}
336 }; 397
337 $TICK_WATCHER->stop; 398=item cf::periodic $interval, $cb
338 $guard 399
400Like EV::periodic, but randomly selects a starting point so that the actions
401get spread over timer.
402
403=cut
404
405sub periodic($$) {
406 my ($interval, $cb) = @_;
407
408 my $start = rand List::Util::min 180, $interval;
409
410 EV::periodic $start, $interval, 0, $cb
339} 411}
340 412
341=item cf::get_slot $time[, $priority[, $name]] 413=item cf::get_slot $time[, $priority[, $name]]
342 414
343Allocate $time seconds of blocking CPU time at priority C<$priority>: 415Allocate $time seconds of blocking CPU time at priority C<$priority>:
… …
383 } 455 }
384 } 456 }
385}; 457};
386 458
387sub get_slot($;$$) { 459sub get_slot($;$$) {
460 return if tick_inhibit || $Coro::current == $Coro::main;
461
388 my ($time, $pri, $name) = @_; 462 my ($time, $pri, $name) = @_;
389 463
390 $time = $TICK * .6 if $time > $TICK * .6; 464 $time = $TICK * .6 if $time > $TICK * .6;
391 my $sig = new Coro::Signal; 465 my $sig = new Coro::Signal;
392 466
… …
406 480
407BEGIN { *async = \&Coro::async_pool } 481BEGIN { *async = \&Coro::async_pool }
408 482
409=item cf::sync_job { BLOCK } 483=item cf::sync_job { BLOCK }
410 484
411The design of Crossfire TRT requires that the main coroutine ($Coro::main) 485The design of Deliantra requires that the main coroutine ($Coro::main)
412is always able to handle events or runnable, as Crossfire TRT is only 486is always able to handle events or runnable, as Deliantra is only
413partly reentrant. Thus "blocking" it by e.g. waiting for I/O is not 487partly reentrant. Thus "blocking" it by e.g. waiting for I/O is not
414acceptable. 488acceptable.
415 489
416If it must be done, put the blocking parts into C<sync_job>. This will run 490If it must be done, put the blocking parts into C<sync_job>. This will run
417the given BLOCK in another coroutine while waiting for the result. The 491the given BLOCK in another coroutine while waiting for the result. The
… …
422 496
423sub sync_job(&) { 497sub sync_job(&) {
424 my ($job) = @_; 498 my ($job) = @_;
425 499
426 if ($Coro::current == $Coro::main) { 500 if ($Coro::current == $Coro::main) {
427 my $time = Event::time; 501 my $time = EV::time;
428 502
429 # this is the main coro, too bad, we have to block 503 # this is the main coro, too bad, we have to block
430 # till the operation succeeds, freezing the server :/ 504 # till the operation succeeds, freezing the server :/
431 505
432 LOG llevError, Carp::longmess "sync job";#d# 506 LOG llevError, Carp::longmess "sync job";#d#
433 507
434 # TODO: use suspend/resume instead
435 # (but this is cancel-safe)
436 my $freeze_guard = freeze_mainloop; 508 my $freeze_guard = freeze_mainloop;
437 509
438 my $busy = 1; 510 my $busy = 1;
439 my @res; 511 my @res;
440 512
… …
444 warn $@ if $@; 516 warn $@ if $@;
445 undef $busy; 517 undef $busy;
446 })->prio (Coro::PRIO_MAX); 518 })->prio (Coro::PRIO_MAX);
447 519
448 while ($busy) { 520 while ($busy) {
449 Coro::cede or Event::one_event; 521 if (Coro::nready) {
522 Coro::cede_notself;
523 } else {
524 EV::loop EV::LOOP_ONESHOT;
450 } 525 }
526 }
451 527
452 $time = Event::time - $time; 528 my $time = EV::time - $time;
453 529
454 LOG llevError | logBacktrace, Carp::longmess "long sync job"
455 if $time > $TICK * 0.5 && $TICK_WATCHER->is_active;
456
457 $tick_start += $time; # do not account sync jobs to server load 530 $TICK_START += $time; # do not account sync jobs to server load
458 531
459 wantarray ? @res : $res[0] 532 wantarray ? @res : $res[0]
460 } else { 533 } else {
461 # we are in another coroutine, how wonderful, everything just works 534 # we are in another coroutine, how wonderful, everything just works
462 535
… …
487=item fork_call { }, $args 560=item fork_call { }, $args
488 561
489Executes the given code block with the given arguments in a seperate 562Executes the given code block with the given arguments in a seperate
490process, returning the results. Everything must be serialisable with 563process, returning the results. Everything must be serialisable with
491Coro::Storable. May, of course, block. Note that the executed sub may 564Coro::Storable. May, of course, block. Note that the executed sub may
492never block itself or use any form of Event handling. 565never block itself or use any form of event handling.
493 566
494=cut 567=cut
495 568
496sub fork_call(&@) { 569sub fork_call(&@) {
497 my ($cb, @args) = @_; 570 my ($cb, @args) = @_;
… …
504 reset_signals; 577 reset_signals;
505 &$cb 578 &$cb
506 }, @args; 579 }, @args;
507 580
508 wantarray ? @res : $res[-1] 581 wantarray ? @res : $res[-1]
582}
583
584=item $coin = coin_from_name $name
585
586=cut
587
588our %coin_alias = (
589 "silver" => "silvercoin",
590 "silvercoin" => "silvercoin",
591 "silvercoins" => "silvercoin",
592 "gold" => "goldcoin",
593 "goldcoin" => "goldcoin",
594 "goldcoins" => "goldcoin",
595 "platinum" => "platinacoin",
596 "platinumcoin" => "platinacoin",
597 "platinumcoins" => "platinacoin",
598 "platina" => "platinacoin",
599 "platinacoin" => "platinacoin",
600 "platinacoins" => "platinacoin",
601 "royalty" => "royalty",
602 "royalties" => "royalty",
603);
604
605sub coin_from_name($) {
606 $coin_alias{$_[0]}
607 ? cf::arch::find $coin_alias{$_[0]}
608 : undef
509} 609}
510 610
511=item $value = cf::db_get $family => $key 611=item $value = cf::db_get $family => $key
512 612
513Returns a single value from the environment database. 613Returns a single value from the environment database.
… …
652 752
653############################################################################# 753#############################################################################
654 754
655=head2 ATTACHABLE OBJECTS 755=head2 ATTACHABLE OBJECTS
656 756
657Many objects in crossfire are so-called attachable objects. That means you can 757Many objects in deliantra are so-called attachable objects. That means you can
658attach callbacks/event handlers (a collection of which is called an "attachment") 758attach callbacks/event handlers (a collection of which is called an "attachment")
659to it. All such attachable objects support the following methods. 759to it. All such attachable objects support the following methods.
660 760
661In the following description, CLASS can be any of C<global>, C<object> 761In the following description, CLASS can be any of C<global>, C<object>
662C<player>, C<client> or C<map> (i.e. the attachable objects in 762C<player>, C<client> or C<map> (i.e. the attachable objects in
663Crossfire TRT). 763Deliantra).
664 764
665=over 4 765=over 4
666 766
667=item $attachable->attach ($attachment, key => $value...) 767=item $attachable->attach ($attachment, key => $value...)
668 768
… …
712=item cf::CLASS::attachment $name, ... 812=item cf::CLASS::attachment $name, ...
713 813
714Register an attachment by C<$name> through which attachable objects of the 814Register an attachment by C<$name> through which attachable objects of the
715given CLASS can refer to this attachment. 815given CLASS can refer to this attachment.
716 816
717Some classes such as crossfire maps and objects can specify attachments 817Some classes such as deliantra maps and objects can specify attachments
718that are attached at load/instantiate time, thus the need for a name. 818that are attached at load/instantiate time, thus the need for a name.
719 819
720These calls expect any number of the following handler/hook descriptions: 820These calls expect any number of the following handler/hook descriptions:
721 821
722=over 4 822=over 4
… …
950 } 1050 }
951 1051
952 0 1052 0
953} 1053}
954 1054
955=item $bool = cf::global::invoke (EVENT_CLASS_XXX, ...) 1055=item $bool = cf::global->invoke (EVENT_CLASS_XXX, ...)
956 1056
957=item $bool = $attachable->invoke (EVENT_CLASS_XXX, ...) 1057=item $bool = $attachable->invoke (EVENT_CLASS_XXX, ...)
958 1058
959Generate an object-specific event with the given arguments. 1059Generate an object-specific event with the given arguments.
960 1060
… …
966 1066
967=cut 1067=cut
968 1068
969############################################################################# 1069#############################################################################
970# object support 1070# object support
971#
972 1071
1072sub _object_equal($$);
1073sub _object_equal($$) {
1074 my ($a, $b) = @_;
1075
1076 return 0 unless (ref $a) eq (ref $b);
1077
1078 if ("HASH" eq ref $a) {
1079 my @ka = keys %$a;
1080 my @kb = keys %$b;
1081
1082 return 0 if @ka != @kb;
1083
1084 for (0 .. $#ka) {
1085 return 0 unless $ka[$_] eq $kb[$_];
1086 return 0 unless _object_equal $a->{$ka[$_]}, $b->{$kb[$_]};
1087 }
1088
1089 } elsif ("ARRAY" eq ref $a) {
1090
1091 return 0 if @$a != @$b;
1092
1093 for (0 .. $#$a) {
1094 return 0 unless _object_equal $a->[$_], $b->[$_];
1095 }
1096
1097 } elsif ($a ne $b) {
1098 return 0;
1099 }
1100
1101 1
1102}
1103
1104our $SLOW_MERGES;#d#
973sub _can_merge { 1105sub _can_merge {
974 my ($ob1, $ob2) = @_; 1106 my ($ob1, $ob2) = @_;
975 1107
976 return 1;#d# 1108 ++$SLOW_MERGES;#d#
977 1109
978 #todo#d# kill yourself and do some recursive checking manually without storable 1110 # we do the slow way here
979 sync_job { 1111 return _object_equal $ob1, $ob2
980 my $guard = Coro::Storable::guard;
981 local $Storable::canonical = 1;
982 my $fob1 = Storable::freeze $ob1;
983 my $fob2 = Storable::freeze $ob2;
984 $fob1 eq $fob2
985 }
986} 1112}
987 1113
988sub reattach { 1114sub reattach {
989 # basically do the same as instantiate, without calling instantiate 1115 # basically do the same as instantiate, without calling instantiate
990 my ($obj) = @_; 1116 my ($obj) = @_;
991 1117
1118 # no longer needed after getting rid of delete_package?
992 bless $obj, ref $obj; # re-bless in case extensions have been reloaded 1119 #bless $obj, ref $obj; # re-bless in case extensions have been reloaded
993 1120
994 my $registry = $obj->registry; 1121 my $registry = $obj->registry;
995 1122
996 @$registry = (); 1123 @$registry = ();
997 1124
… …
1012cf::attachable->attach ( 1139cf::attachable->attach (
1013 prio => -1000000, 1140 prio => -1000000,
1014 on_instantiate => sub { 1141 on_instantiate => sub {
1015 my ($obj, $data) = @_; 1142 my ($obj, $data) = @_;
1016 1143
1017 $data = from_json $data; 1144 $data = decode_json $data;
1018 1145
1019 for (@$data) { 1146 for (@$data) {
1020 my ($name, $args) = @$_; 1147 my ($name, $args) = @$_;
1021 1148
1022 $obj->attach ($name, %{$args || {} }); 1149 $obj->attach ($name, %{$args || {} });
… …
1043 utf8::decode (my $decname = $filename); 1170 utf8::decode (my $decname = $filename);
1044 warn sprintf "saving %s (%d,%d)\n", 1171 warn sprintf "saving %s (%d,%d)\n",
1045 $decname, length $$rdata, scalar @$objs; 1172 $decname, length $$rdata, scalar @$objs;
1046 1173
1047 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) { 1174 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
1048 chmod SAVE_MODE, $fh; 1175 aio_chmod $fh, SAVE_MODE;
1049 aio_write $fh, 0, (length $$rdata), $$rdata, 0; 1176 aio_write $fh, 0, (length $$rdata), $$rdata, 0;
1050 aio_fsync $fh if $cf::USE_FSYNC; 1177 if ($cf::USE_FSYNC) {
1178 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;
1179 aio_fsync $fh;
1180 }
1051 close $fh; 1181 aio_close $fh;
1052 1182
1053 if (@$objs) { 1183 if (@$objs) {
1054 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) { 1184 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) {
1055 chmod SAVE_MODE, $fh; 1185 aio_chmod $fh, SAVE_MODE;
1056 my $data = Coro::Storable::blocking_nfreeze { version => 1, objs => $objs }; 1186 my $data = Coro::Storable::nfreeze { version => 1, objs => $objs };
1057 aio_write $fh, 0, (length $data), $data, 0; 1187 aio_write $fh, 0, (length $data), $data, 0;
1058 aio_fsync $fh if $cf::USE_FSYNC; 1188 if ($cf::USE_FSYNC) {
1189 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;
1190 aio_fsync $fh;
1191 }
1059 close $fh; 1192 aio_close $fh;
1060 aio_rename "$filename.pst~", "$filename.pst"; 1193 aio_rename "$filename.pst~", "$filename.pst";
1061 } 1194 }
1062 } else { 1195 } else {
1063 aio_unlink "$filename.pst"; 1196 aio_unlink "$filename.pst";
1064 } 1197 }
1065 1198
1066 aio_rename "$filename~", $filename; 1199 aio_rename "$filename~", $filename;
1200
1201 $filename =~ s%/[^/]+$%%;
1202 aio_pathsync $filename if $cf::USE_FSYNC;
1067 } else { 1203 } else {
1068 warn "FATAL: $filename~: $!\n"; 1204 warn "unable to save objects: $filename~: $!\n";
1069 } 1205 }
1070 } else { 1206 } else {
1071 aio_unlink $filename; 1207 aio_unlink $filename;
1072 aio_unlink "$filename.pst"; 1208 aio_unlink "$filename.pst";
1073 } 1209 }
… …
1092 1228
1093 unless (aio_stat "$filename.pst") { 1229 unless (aio_stat "$filename.pst") {
1094 (aio_load "$filename.pst", $av) >= 0 1230 (aio_load "$filename.pst", $av) >= 0
1095 or return; 1231 or return;
1096 1232
1097 my $st = eval { Coro::Storable::thaw $av } 1233 my $st = eval { Coro::Storable::thaw $av };
1098 || eval { my $guard = Coro::Storable::guard; Storable::thaw $av }; #d# compatibility, remove
1099 $av = $st->{objs}; 1234 $av = $st->{objs};
1100 } 1235 }
1101 1236
1102 utf8::decode (my $decname = $filename); 1237 utf8::decode (my $decname = $filename);
1103 warn sprintf "loading %s (%d,%d)\n", 1238 warn sprintf "loading %s (%d,%d)\n",
… …
1165 my ($name, $cb) = @_; 1300 my ($name, $cb) = @_;
1166 1301
1167 $EXTICMD{$name} = $cb; 1302 $EXTICMD{$name} = $cb;
1168} 1303}
1169 1304
1305use File::Glob ();
1306
1170cf::player->attach ( 1307cf::player->attach (
1171 on_command => sub { 1308 on_command => sub {
1172 my ($pl, $name, $params) = @_; 1309 my ($pl, $name, $params) = @_;
1173 1310
1174 my $cb = $COMMAND{$name} 1311 my $cb = $COMMAND{$name}
… …
1206 1343
1207 cf::override; 1344 cf::override;
1208 }, 1345 },
1209); 1346);
1210 1347
1348# "readahead" all extensions
1349sub cache_extensions {
1350 my $grp = IO::AIO::aio_group;
1351
1352 add $grp IO::AIO::aio_readdirx $LIBDIR, IO::AIO::READDIR_STAT_ORDER, sub {
1353 for (grep /\.ext$/, @{$_[0]}) {
1354 add $grp IO::AIO::aio_load "$LIBDIR/$_", my $data;
1355 }
1356 };
1357
1358 $grp
1359}
1360
1211sub load_extensions { 1361sub load_extensions {
1212 cf::sync_job { 1362 cf::sync_job {
1213 my %todo; 1363 my %todo;
1214 1364
1215 for my $path (<$LIBDIR/*.ext>) { 1365 for my $path (<$LIBDIR/*.ext>) {
… …
1234 1384
1235 $ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 } 1385 $ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 }
1236 if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m; 1386 if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m;
1237 1387
1238 $ext{source} = 1388 $ext{source} =
1239 "package $pkg; use strict; use utf8;\n" 1389 "package $pkg; use 5.10.0; use strict 'vars', 'subs'; use utf8;\n"
1240 . "#line 1 \"$path\"\n{\n" 1390 . "#line 1 \"$path\"\n{\n"
1241 . $source 1391 . $source
1242 . "\n};\n1"; 1392 . "\n};\n1";
1243 1393
1244 $todo{$base} = \%ext; 1394 $todo{$base} = \%ext;
… …
1260 my $msg = $@ ? "$v->{path}: $@\n" 1410 my $msg = $@ ? "$v->{path}: $@\n"
1261 : "$v->{base}: extension inactive.\n"; 1411 : "$v->{base}: extension inactive.\n";
1262 1412
1263 if (exists $v->{meta}{mandatory}) { 1413 if (exists $v->{meta}{mandatory}) {
1264 warn $msg; 1414 warn $msg;
1265 warn "mandatory extension failed to load, exiting.\n"; 1415 cf::cleanup "mandatory extension failed to load, exiting.";
1266 exit 1;
1267 } 1416 }
1268 1417
1269 warn $msg; 1418 warn $msg;
1270 } 1419 }
1271 1420
… …
1285 1434
1286=back 1435=back
1287 1436
1288=head2 CORE EXTENSIONS 1437=head2 CORE EXTENSIONS
1289 1438
1290Functions and methods that extend core crossfire objects. 1439Functions and methods that extend core deliantra objects.
1291 1440
1292=cut 1441=cut
1293 1442
1294package cf::player; 1443package cf::player;
1295 1444
… …
1338 1487
1339sub exists($) { 1488sub exists($) {
1340 my ($login) = @_; 1489 my ($login) = @_;
1341 1490
1342 $cf::PLAYER{$login} 1491 $cf::PLAYER{$login}
1343 or cf::sync_job { !aio_stat path $login } 1492 or !aio_stat path $login
1344} 1493}
1345 1494
1346sub find($) { 1495sub find($) {
1347 return $cf::PLAYER{$_[0]} || do { 1496 return $cf::PLAYER{$_[0]} || do {
1348 my $login = $_[0]; 1497 my $login = $_[0];
… …
1360 my $f = new_from_file cf::object::thawer path $login 1509 my $f = new_from_file cf::object::thawer path $login
1361 or return; 1510 or return;
1362 1511
1363 my $pl = cf::player::load_pl $f 1512 my $pl = cf::player::load_pl $f
1364 or return; 1513 or return;
1514
1365 local $cf::PLAYER_LOADING{$login} = $pl; 1515 local $cf::PLAYER_LOADING{$login} = $pl;
1366 $f->resolve_delayed_derefs; 1516 $f->resolve_delayed_derefs;
1367 $cf::PLAYER{$login} = $pl 1517 $cf::PLAYER{$login} = $pl
1368 } 1518 }
1369 } 1519 }
… …
1379 1529
1380 return if $pl->{deny_save}; 1530 return if $pl->{deny_save};
1381 1531
1382 aio_mkdir playerdir $pl, 0770; 1532 aio_mkdir playerdir $pl, 0770;
1383 $pl->{last_save} = $cf::RUNTIME; 1533 $pl->{last_save} = $cf::RUNTIME;
1534
1535 cf::get_slot 0.01;
1384 1536
1385 $pl->save_pl ($path); 1537 $pl->save_pl ($path);
1386 cf::cede_to_tick; 1538 cf::cede_to_tick;
1387} 1539}
1388 1540
… …
1420 my ($pl) = @_; 1572 my ($pl) = @_;
1421 1573
1422 my $name = $pl->ob->name; 1574 my $name = $pl->ob->name;
1423 1575
1424 $pl->{deny_save} = 1; 1576 $pl->{deny_save} = 1;
1425 $pl->password ("*"); # this should lock out the player until we nuked the dir 1577 $pl->password ("*"); # this should lock out the player until we have nuked the dir
1426 1578
1427 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active; 1579 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active;
1428 $pl->deactivate; 1580 $pl->deactivate;
1581 my $killer = cf::arch::get "killer_quit"; $pl->killer ($killer); $killer->destroy;
1582 $pl->ob->check_score;
1429 $pl->invoke (cf::EVENT_PLAYER_QUIT); 1583 $pl->invoke (cf::EVENT_PLAYER_QUIT);
1430 $pl->ns->destroy if $pl->ns; 1584 $pl->ns->destroy if $pl->ns;
1431 1585
1432 my $path = playerdir $pl; 1586 my $path = playerdir $pl;
1433 my $temp = "$path~$cf::RUNTIME~deleting~"; 1587 my $temp = "$path~$cf::RUNTIME~deleting~";
… …
1472 1626
1473 for my $login (@$dirs) { 1627 for my $login (@$dirs) {
1474 my $path = path $login; 1628 my $path = path $login;
1475 1629
1476 # a .pst is a dead give-away for a valid player 1630 # a .pst is a dead give-away for a valid player
1477 unless (-e "$path.pst") { 1631 # if no pst file found, open and chekc for blocked users
1632 if (aio_stat "$path.pst") {
1478 my $fh = aio_open $path, Fcntl::O_RDONLY, 0 or next; 1633 my $fh = aio_open $path, Fcntl::O_RDONLY, 0 or next;
1479 aio_read $fh, 0, 512, my $buf, 0 or next; 1634 aio_read $fh, 0, 512, my $buf, 0 or next;
1480 $buf !~ /^password -------------$/m or next; # official not-valid tag 1635 $buf !~ /^password -------------$/m or next; # official not-valid tag
1481 } 1636 }
1482 1637
… …
1513 } 1668 }
1514 1669
1515 \@paths 1670 \@paths
1516} 1671}
1517 1672
1518=item $protocol_xml = $player->expand_cfpod ($crossfire_pod) 1673=item $protocol_xml = $player->expand_cfpod ($cfpod)
1519 1674
1520Expand crossfire pod fragments into protocol xml. 1675Expand deliantra pod fragments into protocol xml.
1521
1522=cut
1523
1524sub expand_cfpod {
1525 ((my $self), (local $_)) = @_;
1526
1527 # escape & and <
1528 s/&/&amp;/g;
1529 s/(?<![BIUGHT])</&lt;/g;
1530
1531 # this is buggy, it needs to properly take care of nested <'s
1532
1533 1 while
1534 # replace B<>, I<>, U<> etc.
1535 s/B<([^\>]*)>/<b>$1<\/b>/
1536 || s/I<([^\>]*)>/<i>$1<\/i>/
1537 || s/U<([^\>]*)>/<u>$1<\/u>/
1538 || s/T<([^\>]*)>/<big><b>$1<\/b><\/big>/
1539 # replace G<male|female> tags
1540 || s{G<([^>|]*)\|([^>]*)>}{
1541 $self->gender ? $2 : $1
1542 }ge
1543 # replace H<hint text>
1544 || s{H<([^\>]*)>}
1545 {
1546 ("<fg name=\"lightblue\">[$1 (Use hintmode to suppress hints)]</fg>",
1547 "<fg name=\"lightblue\">[Hint suppressed, see hintmode]</fg>",
1548 "")
1549 [$self->{hintmode}]
1550 }ge;
1551
1552 # create single paragraphs (very hackish)
1553 s/(?<=\S)\n(?=\w)/ /g;
1554
1555 # compress some whitespace
1556 s/\s+\n/\n/g; # ws line-ends
1557 s/\n\n+/\n/g; # double lines
1558 s/^\n+//; # beginning lines
1559 s/\n+$//; # ending lines
1560
1561 $_
1562}
1563
1564sub hintmode {
1565 $_[0]{hintmode} = $_[1] if @_ > 1;
1566 $_[0]{hintmode}
1567}
1568 1676
1569=item $player->ext_reply ($msgid, @msg) 1677=item $player->ext_reply ($msgid, @msg)
1570 1678
1571Sends an ext reply to the player. 1679Sends an ext reply to the player.
1572 1680
… …
1639our $MAX_RESET = 3600; 1747our $MAX_RESET = 3600;
1640our $DEFAULT_RESET = 3000; 1748our $DEFAULT_RESET = 3000;
1641 1749
1642sub generate_random_map { 1750sub generate_random_map {
1643 my ($self, $rmp) = @_; 1751 my ($self, $rmp) = @_;
1752
1753 my $lock = cf::lock_acquire "generate_random_map"; # the random map generator is NOT reentrant ATM
1754
1644 # mit "rum" bekleckern, nicht 1755 # mit "rum" bekleckern, nicht
1645 $self->_create_random_map ( 1756 $self->_create_random_map (
1646 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle}, 1757 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle},
1647 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle}, 1758 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle},
1648 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map}, 1759 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map},
… …
1770 1881
1771# the temporary/swap location 1882# the temporary/swap location
1772sub save_path { 1883sub save_path {
1773 my ($self) = @_; 1884 my ($self) = @_;
1774 1885
1775 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g; 1886 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/go;
1776 "$TMPDIR/$path.map" 1887 "$TMPDIR/$path.map"
1777} 1888}
1778 1889
1779# the unique path, undef == no special unique path 1890# the unique path, undef == no special unique path
1780sub uniq_path { 1891sub uniq_path {
1781 my ($self) = @_; 1892 my ($self) = @_;
1782 1893
1783 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g; 1894 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/go;
1784 "$UNIQUEDIR/$path" 1895 "$UNIQUEDIR/$path"
1785}
1786
1787# and all this just because we cannot iterate over
1788# all maps in C++...
1789sub change_all_map_light {
1790 my ($change) = @_;
1791
1792 $_->change_map_light ($change)
1793 for grep $_->outdoor, values %cf::MAP;
1794} 1896}
1795 1897
1796sub decay_objects { 1898sub decay_objects {
1797 my ($self) = @_; 1899 my ($self) = @_;
1798 1900
… …
1882sub find { 1984sub find {
1883 my ($path, $origin) = @_; 1985 my ($path, $origin) = @_;
1884 1986
1885 $path = normalise $path, $origin && $origin->path; 1987 $path = normalise $path, $origin && $origin->path;
1886 1988
1887 cf::lock_wait "map_data:$path";#d#remove 1989 my $guard1 = cf::lock_acquire "map_data:$path";#d#remove
1888 cf::lock_wait "map_find:$path"; 1990 my $guard2 = cf::lock_acquire "map_find:$path";
1889 1991
1890 $cf::MAP{$path} || do { 1992 $cf::MAP{$path} || do {
1891 my $guard1 = cf::lock_acquire "map_find:$path";
1892 my $guard2 = cf::lock_acquire "map_data:$path"; # just for the fun of it
1893
1894 my $map = new_from_path cf::map $path 1993 my $map = new_from_path cf::map $path
1895 or return; 1994 or return;
1896 1995
1897 $map->{last_save} = $cf::RUNTIME; 1996 $map->{last_save} = $cf::RUNTIME;
1898 1997
… …
1900 or return; 1999 or return;
1901 2000
1902 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?) 2001 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?)
1903 # doing this can freeze the server in a sync job, obviously 2002 # doing this can freeze the server in a sync job, obviously
1904 #$cf::WAIT_FOR_TICK->wait; 2003 #$cf::WAIT_FOR_TICK->wait;
2004 undef $guard2;
1905 undef $guard1; 2005 undef $guard1;
1906 undef $guard2;
1907 $map->reset; 2006 $map->reset;
1908 return find $path; 2007 return find $path;
1909 } 2008 }
1910 2009
1911 $cf::MAP{$path} = $map 2010 $cf::MAP{$path} = $map
… …
1938 my $f = new_from_file cf::object::thawer $self->{load_path}; 2037 my $f = new_from_file cf::object::thawer $self->{load_path};
1939 $f->skip_block; 2038 $f->skip_block;
1940 $self->_load_objects ($f) 2039 $self->_load_objects ($f)
1941 or return; 2040 or return;
1942 2041
1943 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1) 2042 $self->post_load_original
1944 if delete $self->{load_original}; 2043 if delete $self->{load_original};
1945 2044
1946 if (my $uniq = $self->uniq_path) { 2045 if (my $uniq = $self->uniq_path) {
1947 utf8::encode $uniq; 2046 utf8::encode $uniq;
1948 unless (aio_stat $uniq) { 2047 unless (aio_stat $uniq) {
… …
1966 unless ($self->{deny_activate}) { 2065 unless ($self->{deny_activate}) {
1967 $self->decay_objects; 2066 $self->decay_objects;
1968 $self->fix_auto_apply; 2067 $self->fix_auto_apply;
1969 $self->update_buttons; 2068 $self->update_buttons;
1970 cf::cede_to_tick; 2069 cf::cede_to_tick;
1971 $self->set_darkness_map;
1972 cf::cede_to_tick;
1973 $self->activate; 2070 $self->activate;
1974 } 2071 }
1975 2072
1976 $self->{last_save} = $cf::RUNTIME; 2073 $self->{last_save} = $cf::RUNTIME;
1977 $self->last_access ($cf::RUNTIME); 2074 $self->last_access ($cf::RUNTIME);
1978 2075
1979 $self->in_memory (cf::MAP_IN_MEMORY); 2076 $self->in_memory (cf::MAP_ACTIVE);
1980 } 2077 }
1981 2078
1982 $self->post_load; 2079 $self->post_load;
1983} 2080}
1984 2081
… …
2042 my ($path, $origin, $load) = @_; 2139 my ($path, $origin, $load) = @_;
2043 2140
2044 $path = normalise $path, $origin && $origin->{path}; 2141 $path = normalise $path, $origin && $origin->{path};
2045 2142
2046 if (my $map = $cf::MAP{$path}) { 2143 if (my $map = $cf::MAP{$path}) {
2047 return $map if !$load || $map->in_memory == cf::MAP_IN_MEMORY; 2144 return $map if !$load || $map->in_memory == cf::MAP_ACTIVE;
2048 } 2145 }
2049 2146
2050 $MAP_PREFETCH{$path} |= $load; 2147 $MAP_PREFETCH{$path} |= $load;
2051 2148
2052 $MAP_PREFETCHER ||= cf::async { 2149 $MAP_PREFETCHER ||= cf::async {
… …
2089 cf::async { 2186 cf::async {
2090 $Coro::current->{desc} = "map player save"; 2187 $Coro::current->{desc} = "map player save";
2091 $_->contr->save for $self->players; 2188 $_->contr->save for $self->players;
2092 }; 2189 };
2093 2190
2191 cf::get_slot 0.02;
2192
2094 if ($uniq) { 2193 if ($uniq) {
2095 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS); 2194 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS);
2096 $self->_save_objects ($uniq, cf::IO_UNIQUES); 2195 $self->_save_objects ($uniq, cf::IO_UNIQUES);
2097 } else { 2196 } else {
2098 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES); 2197 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES);
… …
2106 $self->save; 2205 $self->save;
2107 2206
2108 my $lock = cf::lock_acquire "map_data:$self->{path}"; 2207 my $lock = cf::lock_acquire "map_data:$self->{path}";
2109 2208
2110 return if $self->players; 2209 return if $self->players;
2111 return if $self->in_memory != cf::MAP_IN_MEMORY; 2210 return if $self->in_memory != cf::MAP_ACTIVE;
2112 return if $self->{deny_save}; 2211 return if $self->{deny_save};
2113 2212
2114 $self->in_memory (cf::MAP_SWAPPED); 2213 $self->in_memory (cf::MAP_SWAPPED);
2115 2214
2116 $self->deactivate; 2215 $self->deactivate;
… …
2141 2240
2142 my $lock = cf::lock_acquire "map_data:$self->{path}"; 2241 my $lock = cf::lock_acquire "map_data:$self->{path}";
2143 2242
2144 return if $self->players; 2243 return if $self->players;
2145 2244
2146 warn "resetting map ", $self->path; 2245 warn "resetting map ", $self->path, "\n";
2147 2246
2148 $self->in_memory (cf::MAP_SWAPPED); 2247 $self->in_memory (cf::MAP_SWAPPED);
2149 2248
2150 # need to save uniques path 2249 # need to save uniques path
2151 unless ($self->{deny_save}) { 2250 unless ($self->{deny_save}) {
… …
2234 2333
2235sub unique_maps() { 2334sub unique_maps() {
2236 [ 2335 [
2237 map { 2336 map {
2238 utf8::decode $_; 2337 utf8::decode $_;
2239 /\.map$/ 2338 s/\.map$//; # TODO future compatibility hack
2339 /\.pst$/ || !/^$PATH_SEP/o # TODO unique maps apparebntly lack the .map suffix :/
2340 ? ()
2240 ? normalise $_ 2341 : normalise $_
2241 : ()
2242 } @{ aio_readdir $UNIQUEDIR or [] } 2342 } @{ aio_readdir $UNIQUEDIR or [] }
2243 ] 2343 ]
2244} 2344}
2245 2345
2246package cf; 2346=item cf::map::static_maps
2347
2348Returns an arrayref if paths of all static maps (all preinstalled F<.map>
2349file in the shared directory excluding F</styles> and F</editor>). May
2350block.
2351
2352=cut
2353
2354sub static_maps() {
2355 my @dirs = "";
2356 my @maps;
2357
2358 while (@dirs) {
2359 my $dir = shift @dirs;
2360
2361 next if $dir eq "/styles" || $dir eq "/editor";
2362
2363 my ($dirs, $files) = Coro::AIO::aio_scandir "$MAPDIR$dir", 2
2364 or return;
2365
2366 for (@$files) {
2367 s/\.map$// or next;
2368 utf8::decode $_;
2369 push @maps, "$dir/$_";
2370 }
2371
2372 push @dirs, map "$dir/$_", @$dirs;
2373 }
2374
2375 \@maps
2376}
2247 2377
2248=back 2378=back
2249 2379
2250=head3 cf::object 2380=head3 cf::object
2251 2381
… …
2255 2385
2256=over 4 2386=over 4
2257 2387
2258=item $ob->inv_recursive 2388=item $ob->inv_recursive
2259 2389
2260Returns the inventory of the object _and_ their inventories, recursively. 2390Returns the inventory of the object I<and> their inventories, recursively,
2391but I<not> the object itself.
2261 2392
2262=cut 2393=cut
2263 2394
2264sub inv_recursive_; 2395sub inv_recursive_;
2265sub inv_recursive_ { 2396sub inv_recursive_ {
… …
2270 inv_recursive_ inv $_[0] 2401 inv_recursive_ inv $_[0]
2271} 2402}
2272 2403
2273=item $ref = $ob->ref 2404=item $ref = $ob->ref
2274 2405
2275creates and returns a persistent reference to an objetc that can be stored as a string. 2406Creates and returns a persistent reference to an object that can be stored as a string.
2276 2407
2277=item $ob = cf::object::deref ($refstring) 2408=item $ob = cf::object::deref ($refstring)
2278 2409
2279returns the objetc referenced by refstring. may return undef when it cnanot find the object, 2410returns the objetc referenced by refstring. may return undef when it cnanot find the object,
2280even if the object actually exists. May block. 2411even if the object actually exists. May block.
… …
2312can be C<undef>. Does the right thing when the player is currently in a 2443can be C<undef>. Does the right thing when the player is currently in a
2313dialogue with the given NPC character. 2444dialogue with the given NPC character.
2314 2445
2315=cut 2446=cut
2316 2447
2448our $SAY_CHANNEL = {
2449 id => "say",
2450 title => "Map",
2451 reply => "say ",
2452 tooltip => "Things said to and replied from NPCs near you and other players on the same map only.",
2453};
2454
2455our $CHAT_CHANNEL = {
2456 id => "chat",
2457 title => "Chat",
2458 reply => "chat ",
2459 tooltip => "Player chat and shouts, global to the server.",
2460};
2461
2317# rough implementation of a future "reply" method that works 2462# rough implementation of a future "reply" method that works
2318# with dialog boxes. 2463# with dialog boxes.
2319#TODO: the first argument must go, split into a $npc->reply_to ( method 2464#TODO: the first argument must go, split into a $npc->reply_to ( method
2320sub cf::object::player::reply($$$;$) { 2465sub cf::object::player::reply($$$;$) {
2321 my ($self, $npc, $msg, $flags) = @_; 2466 my ($self, $npc, $msg, $flags) = @_;
… …
2332 my $dialog = $pl->{npc_dialog}; 2477 my $dialog = $pl->{npc_dialog};
2333 $dialog->{pl}->ext_msg ($dialog->{id}, update => msg => $dialog->{pl}->expand_cfpod ($msg)); 2478 $dialog->{pl}->ext_msg ($dialog->{id}, update => msg => $dialog->{pl}->expand_cfpod ($msg));
2334 2479
2335 } else { 2480 } else {
2336 $msg = $npc->name . " says: $msg" if $npc; 2481 $msg = $npc->name . " says: $msg" if $npc;
2337 $self->message ($msg, $flags); 2482 $self->send_msg ($SAY_CHANNEL => $msg, $flags);
2338 } 2483 }
2339 } 2484 }
2340} 2485}
2341 2486
2342=item $object->send_msg ($channel, $msg, $color, [extra...]) 2487=item $object->send_msg ($channel, $msg, $color, [extra...])
… …
2367 2512
2368=item $player_object->enter_link 2513=item $player_object->enter_link
2369 2514
2370Freezes the player and moves him/her to a special map (C<{link}>). 2515Freezes the player and moves him/her to a special map (C<{link}>).
2371 2516
2372The player should be reasonably safe there for short amounts of time. You 2517The player should be reasonably safe there for short amounts of time (e.g.
2373I<MUST> call C<leave_link> as soon as possible, though. 2518for loading a map). You I<MUST> call C<leave_link> as soon as possible,
2519though, as the palyer cannot control the character while it is on the link
2520map.
2374 2521
2375Will never block. 2522Will never block.
2376 2523
2377=item $player_object->leave_link ($map, $x, $y) 2524=item $player_object->leave_link ($map, $x, $y)
2378 2525
… …
2430 ($x, $y) = (-1, -1) 2577 ($x, $y) = (-1, -1)
2431 unless (defined $x) && (defined $y); 2578 unless (defined $x) && (defined $y);
2432 2579
2433 # use -1 or undef as default coordinates, not 0, 0 2580 # use -1 or undef as default coordinates, not 0, 0
2434 ($x, $y) = ($map->enter_x, $map->enter_y) 2581 ($x, $y) = ($map->enter_x, $map->enter_y)
2435 if $x <=0 && $y <= 0; 2582 if $x <= 0 && $y <= 0;
2436 2583
2437 $map->load; 2584 $map->load;
2438 $map->load_neighbours; 2585 $map->load_neighbours;
2439 2586
2440 return unless $self->contr->active; 2587 return unless $self->contr->active;
2441 $self->activate_recursive;
2442 2588
2443 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext 2589 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
2444 $self->enter_map ($map, $x, $y); 2590 $self->enter_map ($map, $x, $y);
2591
2592 # only activate afterwards, to support waiting in hooks
2593 $self->activate_recursive;
2445} 2594}
2446 2595
2447=item $player_object->goto ($path, $x, $y[, $check->($map)[, $done->()]]) 2596=item $player_object->goto ($path, $x, $y[, $check->($map)[, $done->()]])
2448 2597
2449Moves the player to the given map-path and coordinates by first freezing 2598Moves the player to the given map-path and coordinates by first freezing
2450her, loading and preparing them map, calling the provided $check callback 2599her, loading and preparing them map, calling the provided $check callback
2451that has to return the map if sucecssful, and then unfreezes the player on 2600that has to return the map if sucecssful, and then unfreezes the player on
2452the new (success) or old (failed) map position. In either case, $done will 2601the new (success) or old (failed) map position. In either case, $done will
2453be called at the end of this process. 2602be called at the end of this process.
2603
2604Note that $check will be called with a potentially non-loaded map, so if
2605it needs a loaded map it has to call C<< ->load >>.
2454 2606
2455=cut 2607=cut
2456 2608
2457our $GOTOGEN; 2609our $GOTOGEN;
2458 2610
… …
2537} 2689}
2538 2690
2539sub prepare_random_map { 2691sub prepare_random_map {
2540 my ($exit) = @_; 2692 my ($exit) = @_;
2541 2693
2542 my $guard = cf::lock_acquire "exit_prepare:$exit";
2543
2544 # all this does is basically replace the /! path by 2694 # all this does is basically replace the /! path by
2545 # a new random map path (?random/...) with a seed 2695 # a new random map path (?random/...) with a seed
2546 # that depends on the exit object 2696 # that depends on the exit object
2547 2697
2548 my $rmp = parse_random_map_params $exit->msg; 2698 my $rmp = parse_random_map_params $exit->msg;
… …
2550 if ($exit->map) { 2700 if ($exit->map) {
2551 $rmp->{region} = $exit->region->name; 2701 $rmp->{region} = $exit->region->name;
2552 $rmp->{origin_map} = $exit->map->path; 2702 $rmp->{origin_map} = $exit->map->path;
2553 $rmp->{origin_x} = $exit->x; 2703 $rmp->{origin_x} = $exit->x;
2554 $rmp->{origin_y} = $exit->y; 2704 $rmp->{origin_y} = $exit->y;
2705
2706 $exit->map->touch;
2555 } 2707 }
2556 2708
2557 $rmp->{random_seed} ||= $exit->random_seed; 2709 $rmp->{random_seed} ||= $exit->random_seed;
2558 2710
2559 my $data = cf::to_json $rmp; 2711 my $data = JSON::XS->new->utf8->pretty->canonical->encode ($rmp);
2560 my $md5 = Digest::MD5::md5_hex $data; 2712 my $md5 = Digest::MD5::md5_hex $data;
2561 my $meta = "$RANDOMDIR/$md5.meta"; 2713 my $meta = "$RANDOMDIR/$md5.meta";
2562 2714
2563 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) { 2715 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) {
2564 aio_write $fh, 0, (length $data), $data, 0; 2716 aio_write $fh, 0, (length $data), $data, 0;
2565 undef $fh; 2717 undef $fh;
2566 aio_rename "$meta~", $meta; 2718 aio_rename "$meta~", $meta;
2567 2719
2720 my $slaying = "?random/$md5";
2721
2722 if ($exit->valid) {
2568 $exit->slaying ("?random/$md5"); 2723 $exit->slaying ("?random/$md5");
2569 $exit->msg (undef); 2724 $exit->msg (undef);
2725 }
2570 } 2726 }
2571} 2727}
2572 2728
2573sub cf::object::player::enter_exit { 2729sub cf::object::player::enter_exit {
2574 my ($self, $exit) = @_; 2730 my ($self, $exit) = @_;
2575 2731
2576 return unless $self->type == cf::PLAYER; 2732 return unless $self->type == cf::PLAYER;
2577 2733
2578 if ($exit->slaying eq "/!") {
2579 #TODO: this should de-fi-ni-te-ly not be a sync-job
2580 # the problem is that $exit might not survive long enough
2581 # so it needs to be done right now, right here
2582 cf::sync_job { prepare_random_map $exit };
2583 }
2584
2585 my $slaying = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path;
2586 my $hp = $exit->stats->hp;
2587 my $sp = $exit->stats->sp;
2588
2589 $self->enter_link; 2734 $self->enter_link;
2590 2735
2591 # if exit is damned, update players death & WoR home-position
2592 $self->contr->savebed ($slaying, $hp, $sp)
2593 if $exit->flag (FLAG_DAMNED);
2594
2595 (async { 2736 (async {
2596 $Coro::current->{desc} = "enter_exit $slaying $hp $sp"; 2737 $Coro::current->{desc} = "enter_exit";
2597 2738
2598 $self->deactivate_recursive; # just to be sure
2599 unless (eval { 2739 unless (eval {
2740 $self->deactivate_recursive; # just to be sure
2741
2742 # random map handling
2743 {
2744 my $guard = cf::lock_acquire "exit_prepare:$exit";
2745
2746 prepare_random_map $exit
2747 if $exit->slaying eq "/!";
2748 }
2749
2750 my $map = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path;
2751 my $x = $exit->stats->hp;
2752 my $y = $exit->stats->sp;
2753
2600 $self->goto ($slaying, $hp, $sp); 2754 $self->goto ($map, $x, $y);
2601 2755
2756 # if exit is damned, update players death & WoR home-position
2757 $self->contr->savebed ($map, $x, $y)
2758 if $exit->flag (cf::FLAG_DAMNED);
2759
2602 1; 2760 1
2603 }) { 2761 }) {
2604 $self->message ("Something went wrong deep within the crossfire server. " 2762 $self->message ("Something went wrong deep within the deliantra server. "
2605 . "I'll try to bring you back to the map you were before. " 2763 . "I'll try to bring you back to the map you were before. "
2606 . "Please report this to the dungeon master!", 2764 . "Please report this to the dungeon master!",
2607 cf::NDI_UNIQUE | cf::NDI_RED); 2765 cf::NDI_UNIQUE | cf::NDI_RED);
2608 2766
2609 warn "ERROR in enter_exit: $@"; 2767 warn "ERROR in enter_exit: $@";
… …
2626sub cf::client::send_drawinfo { 2784sub cf::client::send_drawinfo {
2627 my ($self, $text, $flags) = @_; 2785 my ($self, $text, $flags) = @_;
2628 2786
2629 utf8::encode $text; 2787 utf8::encode $text;
2630 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text); 2788 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);
2789}
2790
2791=item $client->send_big_packet ($pkt)
2792
2793Like C<send_packet>, but tries to compress large packets, and fragments
2794them as required.
2795
2796=cut
2797
2798our $MAXFRAGSIZE = cf::MAXSOCKBUF - 64;
2799
2800sub cf::client::send_big_packet {
2801 my ($self, $pkt) = @_;
2802
2803 # try lzf for large packets
2804 $pkt = "lzf " . Compress::LZF::compress $pkt
2805 if 1024 <= length $pkt and $self->{can_lzf};
2806
2807 # split very large packets
2808 if ($MAXFRAGSIZE < length $pkt and $self->{can_lzf}) {
2809 $self->send_packet ("frag $_") for unpack "(a$MAXFRAGSIZE)*", $pkt;
2810 $pkt = "frag";
2811 }
2812
2813 $self->send_packet ($pkt);
2631} 2814}
2632 2815
2633=item $client->send_msg ($channel, $msg, $color, [extra...]) 2816=item $client->send_msg ($channel, $msg, $color, [extra...])
2634 2817
2635Send a drawinfo or msg packet to the client, formatting the msg for the 2818Send a drawinfo or msg packet to the client, formatting the msg for the
… …
2637the message, with C<log> being the default. If C<$color> is negative, suppress 2820the message, with C<log> being the default. If C<$color> is negative, suppress
2638the message unless the client supports the msg packet. 2821the message unless the client supports the msg packet.
2639 2822
2640=cut 2823=cut
2641 2824
2825# non-persistent channels (usually the info channel)
2642our %CHANNEL = ( 2826our %CHANNEL = (
2827 "c/motd" => {
2828 id => "infobox",
2829 title => "MOTD",
2830 reply => undef,
2831 tooltip => "The message of the day",
2832 },
2643 "c/identify" => { 2833 "c/identify" => {
2644 id => "infobox", 2834 id => "infobox",
2645 title => "Identify", 2835 title => "Identify",
2646 reply => undef, 2836 reply => undef,
2647 tooltip => "Items recently identified", 2837 tooltip => "Items recently identified",
… …
2650 id => "infobox", 2840 id => "infobox",
2651 title => "Examine", 2841 title => "Examine",
2652 reply => undef, 2842 reply => undef,
2653 tooltip => "Signs and other items you examined", 2843 tooltip => "Signs and other items you examined",
2654 }, 2844 },
2845 "c/shopinfo" => {
2846 id => "infobox",
2847 title => "Shop Info",
2848 reply => undef,
2849 tooltip => "What your bargaining skill tells you about the shop",
2850 },
2851 "c/book" => {
2852 id => "infobox",
2853 title => "Book",
2854 reply => undef,
2855 tooltip => "The contents of a note or book",
2856 },
2655 "c/lookat" => { 2857 "c/lookat" => {
2656 id => "infobox", 2858 id => "infobox",
2657 title => "Look", 2859 title => "Look",
2658 reply => undef, 2860 reply => undef,
2659 tooltip => "What you saw there", 2861 tooltip => "What you saw there",
2660 }, 2862 },
2863 "c/who" => {
2864 id => "infobox",
2865 title => "Players",
2866 reply => undef,
2867 tooltip => "Shows players who are currently online",
2868 },
2869 "c/body" => {
2870 id => "infobox",
2871 title => "Body Parts",
2872 reply => undef,
2873 tooltip => "Shows which body parts you posess and are available",
2874 },
2875 "c/statistics" => {
2876 id => "infobox",
2877 title => "Statistics",
2878 reply => undef,
2879 tooltip => "Shows your primary statistics",
2880 },
2881 "c/skills" => {
2882 id => "infobox",
2883 title => "Skills",
2884 reply => undef,
2885 tooltip => "Shows your experience per skill and item power",
2886 },
2887 "c/shopitems" => {
2888 id => "infobox",
2889 title => "Shop Items",
2890 reply => undef,
2891 tooltip => "Shows the items currently for sale in this shop",
2892 },
2893 "c/resistances" => {
2894 id => "infobox",
2895 title => "Resistances",
2896 reply => undef,
2897 tooltip => "Shows your resistances",
2898 },
2899 "c/pets" => {
2900 id => "infobox",
2901 title => "Pets",
2902 reply => undef,
2903 tooltip => "Shows information abotu your pets/a specific pet",
2904 },
2905 "c/perceiveself" => {
2906 id => "infobox",
2907 title => "Perceive Self",
2908 reply => undef,
2909 tooltip => "You gained detailed knowledge about yourself",
2910 },
2911 "c/uptime" => {
2912 id => "infobox",
2913 title => "Uptime",
2914 reply => undef,
2915 tooltip => "How long the server has been running since last restart",
2916 },
2917 "c/mapinfo" => {
2918 id => "infobox",
2919 title => "Map Info",
2920 reply => undef,
2921 tooltip => "Information related to the maps",
2922 },
2923 "c/party" => {
2924 id => "party",
2925 title => "Party",
2926 reply => "gsay ",
2927 tooltip => "Messages and chat related to your party",
2928 },
2929 "c/death" => {
2930 id => "death",
2931 title => "Death",
2932 reply => undef,
2933 tooltip => "Reason for and more info about your most recent death",
2934 },
2935 "c/say" => $SAY_CHANNEL,
2936 "c/chat" => $CHAT_CHANNEL,
2661); 2937);
2662 2938
2663sub cf::client::send_msg { 2939sub cf::client::send_msg {
2664 my ($self, $channel, $msg, $color, @extra) = @_; 2940 my ($self, $channel, $msg, $color, @extra) = @_;
2665 2941
2666 $msg = $self->pl->expand_cfpod ($msg); 2942 $msg = $self->pl->expand_cfpod ($msg)
2943 unless $color & cf::NDI_VERBATIM;
2667 2944
2668 $color &= cf::NDI_CLIENT_MASK; # just in case... 2945 $color &= cf::NDI_CLIENT_MASK; # just in case...
2669 2946
2670 # check predefined channels, for the benefit of C 2947 # check predefined channels, for the benefit of C
2671 if ($CHANNEL{$channel}) { 2948 if ($CHANNEL{$channel}) {
2672 $channel = $CHANNEL{$channel}; 2949 $channel = $CHANNEL{$channel};
2673 2950
2674 $self->ext_msg (channel_info => $channel) 2951 $self->ext_msg (channel_info => $channel);
2675 if $self->can_msg;
2676
2677 $channel = $channel->{id}; 2952 $channel = $channel->{id};
2678 2953
2679 } elsif (ref $channel) { 2954 } elsif (ref $channel) {
2680 # send meta info to client, if not yet sent 2955 # send meta info to client, if not yet sent
2681 unless (exists $self->{channel}{$channel->{id}}) { 2956 unless (exists $self->{channel}{$channel->{id}}) {
2682 $self->{channel}{$channel->{id}} = $channel; 2957 $self->{channel}{$channel->{id}} = $channel;
2683 $self->ext_msg (channel_info => $channel) 2958 $self->ext_msg (channel_info => $channel);
2684 if $self->can_msg;
2685 } 2959 }
2686 2960
2687 $channel = $channel->{id}; 2961 $channel = $channel->{id};
2688 } 2962 }
2689 2963
2690 return unless @extra || length $msg; 2964 return unless @extra || length $msg;
2691 2965
2692 if ($self->can_msg) {
2693 # default colour, mask it out 2966 # default colour, mask it out
2694 $color &= ~(cf::NDI_COLOR_MASK | cf::NDI_DEF) 2967 $color &= ~(cf::NDI_COLOR_MASK | cf::NDI_DEF)
2695 if $color & cf::NDI_DEF; 2968 if $color & cf::NDI_DEF;
2696 2969
2697 $self->send_packet ("msg " . $self->{json_coder}->encode ( 2970 my $pkt = "msg "
2971 . $self->{json_coder}->encode (
2698 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra])); 2972 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]
2699 } else { 2973 );
2700 if ($color >= 0) {
2701 # replace some tags by gcfclient-compatible ones
2702 for ($msg) {
2703 1 while
2704 s/<b>([^<]*)<\/b>/[b]${1}[\/b]/
2705 || s/<i>([^<]*)<\/i>/[i]${1}[\/i]/
2706 || s/<u>([^<]*)<\/u>/[ul]${1}[\/ul]/
2707 || s/<tt>([^<]*)<\/tt>/[fixed]${1}[\/fixed]/
2708 || s/<fg name=\"([^"]+)\">([^<]*)<\/fg>/[color=$1]${2}[\/color]/;
2709 }
2710 2974
2711 $color &= cf::NDI_COLOR_MASK; 2975 $self->send_big_packet ($pkt);
2712
2713 utf8::encode $msg;
2714
2715 if (0 && $msg =~ /\[/) {
2716 # COMMAND/INFO
2717 $self->send_packet ("drawextinfo $color 10 8 $msg")
2718 } else {
2719 $msg =~ s/\[\/?(?:b|i|u|fixed|color)[^\]]*\]//g;
2720 $self->send_packet ("drawinfo $color $msg")
2721 }
2722 }
2723 }
2724} 2976}
2725 2977
2726=item $client->ext_msg ($type, @msg) 2978=item $client->ext_msg ($type, @msg)
2727 2979
2728Sends an ext event to the client. 2980Sends an ext event to the client.
… …
2731 2983
2732sub cf::client::ext_msg($$@) { 2984sub cf::client::ext_msg($$@) {
2733 my ($self, $type, @msg) = @_; 2985 my ($self, $type, @msg) = @_;
2734 2986
2735 if ($self->extcmd == 2) { 2987 if ($self->extcmd == 2) {
2736 $self->send_packet ("ext " . $self->{json_coder}->encode ([$type, @msg])); 2988 $self->send_big_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
2737 } elsif ($self->extcmd == 1) { # TODO: remove 2989 } elsif ($self->extcmd == 1) { # TODO: remove
2738 push @msg, msgtype => "event_$type"; 2990 push @msg, msgtype => "event_$type";
2739 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg})); 2991 $self->send_big_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2740 } 2992 }
2741} 2993}
2742 2994
2743=item $client->ext_reply ($msgid, @msg) 2995=item $client->ext_reply ($msgid, @msg)
2744 2996
… …
2748 3000
2749sub cf::client::ext_reply($$@) { 3001sub cf::client::ext_reply($$@) {
2750 my ($self, $id, @msg) = @_; 3002 my ($self, $id, @msg) = @_;
2751 3003
2752 if ($self->extcmd == 2) { 3004 if ($self->extcmd == 2) {
2753 $self->send_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg])); 3005 $self->send_big_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg]));
2754 } elsif ($self->extcmd == 1) { 3006 } elsif ($self->extcmd == 1) {
2755 #TODO: version 1, remove 3007 #TODO: version 1, remove
2756 unshift @msg, msgtype => "reply", msgid => $id; 3008 unshift @msg, msgtype => "reply", msgid => $id;
2757 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg})); 3009 $self->send_big_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2758 } 3010 }
2759} 3011}
2760 3012
2761=item $success = $client->query ($flags, "text", \&cb) 3013=item $success = $client->query ($flags, "text", \&cb)
2762 3014
… …
2902 3154
2903The following functions and methods are available within a safe environment: 3155The following functions and methods are available within a safe environment:
2904 3156
2905 cf::object 3157 cf::object
2906 contr pay_amount pay_player map x y force_find force_add destroy 3158 contr pay_amount pay_player map x y force_find force_add destroy
2907 insert remove name archname title slaying race decrease_ob_nr 3159 insert remove name archname title slaying race decrease split
3160 value
2908 3161
2909 cf::object::player 3162 cf::object::player
2910 player 3163 player
2911 3164
2912 cf::player 3165 cf::player
… …
2917 3170
2918=cut 3171=cut
2919 3172
2920for ( 3173for (
2921 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y 3174 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y
2922 insert remove inv name archname title slaying race 3175 insert remove inv nrof name archname title slaying race
2923 decrease_ob_nr destroy)], 3176 decrease split destroy change_exp value msg lore send_msg)],
2924 ["cf::object::player" => qw(player)], 3177 ["cf::object::player" => qw(player)],
2925 ["cf::player" => qw(peaceful)], 3178 ["cf::player" => qw(peaceful send_msg)],
2926 ["cf::map" => qw(trigger)], 3179 ["cf::map" => qw(trigger)],
2927) { 3180) {
2928 no strict 'refs'; 3181 no strict 'refs';
2929 my ($pkg, @funs) = @$_; 3182 my ($pkg, @funs) = @$_;
2930 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"}) 3183 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})
… …
2947 my ($code, %vars) = @_; 3200 my ($code, %vars) = @_;
2948 3201
2949 my $qcode = $code; 3202 my $qcode = $code;
2950 $qcode =~ s/"/‟/g; # not allowed in #line filenames 3203 $qcode =~ s/"/‟/g; # not allowed in #line filenames
2951 $qcode =~ s/\n/\\n/g; 3204 $qcode =~ s/\n/\\n/g;
3205
3206 %vars = (_dummy => 0) unless %vars;
2952 3207
2953 local $_; 3208 local $_;
2954 local @safe::cf::_safe_eval_args = values %vars; 3209 local @safe::cf::_safe_eval_args = values %vars;
2955 3210
2956 my $eval = 3211 my $eval =
… …
3033 { 3288 {
3034 my $faces = $facedata->{faceinfo}; 3289 my $faces = $facedata->{faceinfo};
3035 3290
3036 while (my ($face, $info) = each %$faces) { 3291 while (my ($face, $info) = each %$faces) {
3037 my $idx = (cf::face::find $face) || cf::face::alloc $face; 3292 my $idx = (cf::face::find $face) || cf::face::alloc $face;
3293
3038 cf::face::set_visibility $idx, $info->{visibility}; 3294 cf::face::set_visibility $idx, $info->{visibility};
3039 cf::face::set_magicmap $idx, $info->{magicmap}; 3295 cf::face::set_magicmap $idx, $info->{magicmap};
3040 cf::face::set_data $idx, 0, $info->{data32}, Digest::MD5::md5 $info->{data32}; 3296 cf::face::set_data $idx, 0, $info->{data32}, $info->{hash32};
3041 cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64}; 3297 cf::face::set_data $idx, 1, $info->{data64}, $info->{hash64};
3042 3298
3043 cf::cede_to_tick; 3299 cf::cede_to_tick;
3044 } 3300 }
3045 3301
3046 while (my ($face, $info) = each %$faces) { 3302 while (my ($face, $info) = each %$faces) {
3047 next unless $info->{smooth}; 3303 next unless $info->{smooth};
3304
3048 my $idx = cf::face::find $face 3305 my $idx = cf::face::find $face
3049 or next; 3306 or next;
3307
3050 if (my $smooth = cf::face::find $info->{smooth}) { 3308 if (my $smooth = cf::face::find $info->{smooth}) {
3051 cf::face::set_smooth $idx, $smooth; 3309 cf::face::set_smooth $idx, $smooth;
3052 cf::face::set_smoothlevel $idx, $info->{smoothlevel}; 3310 cf::face::set_smoothlevel $idx, $info->{smoothlevel};
3053 } else { 3311 } else {
3054 warn "smooth face '$info->{smooth}' not found for face '$face'"; 3312 warn "smooth face '$info->{smooth}' not found for face '$face'";
… …
3068 3326
3069 cf::anim::invalidate_all; # d'oh 3327 cf::anim::invalidate_all; # d'oh
3070 } 3328 }
3071 3329
3072 { 3330 {
3073 # TODO: for gcfclient pleasure, we should give resources
3074 # that gcfclient doesn't grok a >10000 face index.
3075 my $res = $facedata->{resource}; 3331 my $res = $facedata->{resource};
3076 3332
3077 my $soundconf = delete $res->{"res/sound.conf"};
3078
3079 while (my ($name, $info) = each %$res) { 3333 while (my ($name, $info) = each %$res) {
3334 if (defined $info->{type}) {
3080 my $idx = (cf::face::find $name) || cf::face::alloc $name; 3335 my $idx = (cf::face::find $name) || cf::face::alloc $name;
3081 my $data;
3082 3336
3083 if ($info->{type} & 1) { 3337 cf::face::set_data $idx, 0, $info->{data}, $info->{hash};
3084 # prepend meta info 3338 cf::face::set_type $idx, $info->{type};
3085
3086 my $meta = $enc->encode ({
3087 name => $name,
3088 %{ $info->{meta} || {} },
3089 });
3090
3091 $data = pack "(w/a*)*", $meta, $info->{data};
3092 } else { 3339 } else {
3093 $data = $info->{data}; 3340 $RESOURCE{$name} = $info;
3094 } 3341 }
3095 3342
3096 cf::face::set_data $idx, 0, $data, Digest::MD5::md5 $data;
3097 cf::face::set_type $idx, $info->{type};
3098
3099 cf::cede_to_tick; 3343 cf::cede_to_tick;
3100 } 3344 }
3101
3102 if ($soundconf) {
3103 $soundconf = $enc->decode (delete $soundconf->{data});
3104
3105 for (0 .. SOUND_CAST_SPELL_0 - 1) {
3106 my $sound = $soundconf->{compat}[$_]
3107 or next;
3108
3109 my $face = cf::face::find "sound/$sound->[1]";
3110 cf::sound::set $sound->[0] => $face;
3111 cf::sound::old_sound_index $_, $face; # gcfclient-compat
3112 }
3113
3114 while (my ($k, $v) = each %{$soundconf->{event}}) {
3115 my $face = cf::face::find "sound/$v";
3116 cf::sound::set $k => $face;
3117 }
3118 }
3119 } 3345 }
3346
3347 cf::global->invoke (EVENT_GLOBAL_RESOURCE_UPDATE);
3120 3348
3121 1 3349 1
3122} 3350}
3351
3352cf::global->attach (on_resource_update => sub {
3353 if (my $soundconf = $RESOURCE{"res/sound.conf"}) {
3354 $soundconf = JSON::XS->new->utf8->relaxed->decode ($soundconf->{data});
3355
3356 for (0 .. SOUND_CAST_SPELL_0 - 1) {
3357 my $sound = $soundconf->{compat}[$_]
3358 or next;
3359
3360 my $face = cf::face::find "sound/$sound->[1]";
3361 cf::sound::set $sound->[0] => $face;
3362 cf::sound::old_sound_index $_, $face; # gcfclient-compat
3363 }
3364
3365 while (my ($k, $v) = each %{$soundconf->{event}}) {
3366 my $face = cf::face::find "sound/$v";
3367 cf::sound::set $k => $face;
3368 }
3369 }
3370});
3123 3371
3124register_exticmd fx_want => sub { 3372register_exticmd fx_want => sub {
3125 my ($ns, $want) = @_; 3373 my ($ns, $want) = @_;
3126 3374
3127 while (my ($k, $v) = each %$want) { 3375 while (my ($k, $v) = each %$want) {
3128 $ns->fx_want ($k, $v); 3376 $ns->fx_want ($k, $v);
3129 } 3377 }
3130}; 3378};
3379
3380sub load_resource_file($) {
3381 my $guard = lock_acquire "load_resource_file";
3382
3383 my $status = load_resource_file_ $_[0];
3384 get_slot 0.1, 100;
3385 cf::arch::commit_load;
3386
3387 $status
3388}
3131 3389
3132sub reload_regions { 3390sub reload_regions {
3133 # HACK to clear player env face cache, we need some signal framework 3391 # HACK to clear player env face cache, we need some signal framework
3134 # for this (global event?) 3392 # for this (global event?)
3135 %ext::player_env::MUSIC_FACE_CACHE = (); 3393 %ext::player_env::MUSIC_FACE_CACHE = ();
… …
3149} 3407}
3150 3408
3151sub reload_archetypes { 3409sub reload_archetypes {
3152 load_resource_file "$DATADIR/archetypes" 3410 load_resource_file "$DATADIR/archetypes"
3153 or die "unable to load archetypes\n"; 3411 or die "unable to load archetypes\n";
3154 #d# NEED to laod twice to resolve forward references
3155 # this really needs to be done in an extra post-pass
3156 # (which needs to be synchronous, so solve it differently)
3157 load_resource_file "$DATADIR/archetypes"
3158 or die "unable to load archetypes\n";
3159} 3412}
3160 3413
3161sub reload_treasures { 3414sub reload_treasures {
3162 load_resource_file "$DATADIR/treasures" 3415 load_resource_file "$DATADIR/treasures"
3163 or die "unable to load treasurelists\n"; 3416 or die "unable to load treasurelists\n";
3164} 3417}
3165 3418
3166sub reload_resources { 3419sub reload_resources {
3167 warn "reloading resource files...\n"; 3420 warn "reloading resource files...\n";
3168 3421
3422 reload_facedata;
3423 reload_archetypes;
3169 reload_regions; 3424 reload_regions;
3170 reload_facedata;
3171 #reload_archetypes;#d#
3172 reload_archetypes;
3173 reload_treasures; 3425 reload_treasures;
3174 3426
3175 warn "finished reloading resource files\n"; 3427 warn "finished reloading resource files\n";
3176} 3428}
3177 3429
3178sub init {
3179 reload_resources;
3180}
3181
3182sub reload_config { 3430sub reload_config {
3431 warn "reloading config file...\n";
3432
3183 open my $fh, "<:utf8", "$CONFDIR/config" 3433 open my $fh, "<:utf8", "$CONFDIR/config"
3184 or return; 3434 or return;
3185 3435
3186 local $/; 3436 local $/;
3187 *CFG = YAML::Syck::Load <$fh>; 3437 *CFG = YAML::XS::Load scalar <$fh>;
3188 3438
3189 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37]; 3439 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37];
3190 3440
3191 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset}; 3441 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset};
3192 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset}; 3442 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset};
… …
3196 $CFG{mlockall} ? eval "mlockall()" : eval "munlockall()" 3446 $CFG{mlockall} ? eval "mlockall()" : eval "munlockall()"
3197 and die "WARNING: m(un)lockall failed: $!\n"; 3447 and die "WARNING: m(un)lockall failed: $!\n";
3198 }; 3448 };
3199 warn $@ if $@; 3449 warn $@ if $@;
3200 } 3450 }
3451
3452 warn "finished reloading resource files\n";
3453}
3454
3455sub pidfile() {
3456 sysopen my $fh, $PIDFILE, O_RDWR | O_CREAT
3457 or die "$PIDFILE: $!";
3458 flock $fh, &Fcntl::LOCK_EX
3459 or die "$PIDFILE: flock: $!";
3460 $fh
3461}
3462
3463# make sure only one server instance is running at any one time
3464sub atomic {
3465 my $fh = pidfile;
3466
3467 my $pid = <$fh>;
3468 kill 9, $pid if $pid > 0;
3469
3470 seek $fh, 0, 0;
3471 print $fh $$;
3472}
3473
3474sub main_loop {
3475 warn "EV::loop starting\n";
3476 if (1) {
3477 EV::loop;
3478 }
3479 warn "EV::loop returned\n";
3480 goto &main_loop unless $REALLY_UNLOOP;
3201} 3481}
3202 3482
3203sub main { 3483sub main {
3484 cf::init_globals; # initialise logging
3485
3486 LOG llevInfo, "Welcome to Deliantra, v" . VERSION;
3487 LOG llevInfo, "Copyright (C) 2005-2008 Marc Alexander Lehmann / Robin Redeker / the Deliantra team.";
3488 LOG llevInfo, "Copyright (C) 1994 Mark Wedel.";
3489 LOG llevInfo, "Copyright (C) 1992 Frank Tore Johansen.";
3490
3491 cf::init_experience;
3492 cf::init_anim;
3493 cf::init_attackmess;
3494 cf::init_dynamic;
3495
3496 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority
3497
3204 # we must not ever block the main coroutine 3498 # we must not ever block the main coroutine
3205 local $Coro::idle = sub { 3499 local $Coro::idle = sub {
3206 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d# 3500 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
3207 (async { 3501 (async {
3208 $Coro::current->{desc} = "IDLE BUG HANDLER"; 3502 $Coro::current->{desc} = "IDLE BUG HANDLER";
3209 Event::one_event; 3503 EV::loop EV::LOOP_ONESHOT;
3210 })->prio (Coro::PRIO_MAX); 3504 })->prio (Coro::PRIO_MAX);
3211 }; 3505 };
3212 3506
3507 evthread_start IO::AIO::poll_fileno;
3508
3509 cf::sync_job {
3510 cf::load_settings;
3511 cf::load_materials;
3512
3513 reload_resources;
3213 reload_config; 3514 reload_config;
3214 db_init; 3515 db_init;
3516
3517 cf::init_uuid;
3518 cf::init_signals;
3519 cf::init_commands;
3520 cf::init_skills;
3521
3522 cf::init_beforeplay;
3523
3524 atomic;
3525
3215 load_extensions; 3526 load_extensions;
3216 3527
3217 $TICK_WATCHER->start; 3528 utime time, time, $RUNTIMEFILE;
3218 Event::loop; 3529
3530 # no (long-running) fork's whatsoever before this point(!)
3531 use POSIX ();
3532 POSIX::close delete $ENV{LOCKUTIL_LOCK_FD} if exists $ENV{LOCKUTIL_LOCK_FD};
3533
3534 (pop @POST_INIT)->(0) while @POST_INIT;
3535 };
3536
3537 main_loop;
3219} 3538}
3220 3539
3221############################################################################# 3540#############################################################################
3222# initialisation and cleanup 3541# initialisation and cleanup
3223 3542
3224# install some emergency cleanup handlers 3543# install some emergency cleanup handlers
3225BEGIN { 3544BEGIN {
3545 our %SIGWATCHER = ();
3226 for my $signal (qw(INT HUP TERM)) { 3546 for my $signal (qw(INT HUP TERM)) {
3227 Event->signal ( 3547 $SIGWATCHER{$signal} = EV::signal $signal, sub {
3228 reentrant => 0,
3229 data => WF_AUTOCANCEL,
3230 signal => $signal,
3231 prio => 0,
3232 cb => sub {
3233 cf::cleanup "SIG$signal"; 3548 cf::cleanup "SIG$signal";
3234 },
3235 ); 3549 };
3236 } 3550 }
3237} 3551}
3238 3552
3239sub write_runtime { 3553sub write_runtime_sync {
3240 my $runtime = "$LOCALDIR/runtime";
3241
3242 # first touch the runtime file to show we are still running: 3554 # first touch the runtime file to show we are still running:
3243 # the fsync below can take a very very long time. 3555 # the fsync below can take a very very long time.
3244 3556
3245 IO::AIO::aio_utime $runtime, undef, undef; 3557 IO::AIO::aio_utime $RUNTIMEFILE, undef, undef;
3246 3558
3247 my $guard = cf::lock_acquire "write_runtime"; 3559 my $guard = cf::lock_acquire "write_runtime";
3248 3560
3249 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644 3561 my $fh = aio_open "$RUNTIMEFILE~", O_WRONLY | O_CREAT, 0644
3250 or return; 3562 or return;
3251 3563
3252 my $value = $cf::RUNTIME + 90 + 10; 3564 my $value = $cf::RUNTIME + 90 + 10;
3253 # 10 is the runtime save interval, for a monotonic clock 3565 # 10 is the runtime save interval, for a monotonic clock
3254 # 60 allows for the watchdog to kill the server. 3566 # 60 allows for the watchdog to kill the server.
… …
3264 aio_utime $fh, undef, undef; 3576 aio_utime $fh, undef, undef;
3265 3577
3266 close $fh 3578 close $fh
3267 or return; 3579 or return;
3268 3580
3269 aio_rename "$runtime~", $runtime 3581 aio_rename "$RUNTIMEFILE~", $RUNTIMEFILE
3270 and return; 3582 and return;
3271 3583
3272 warn "runtime file written.\n"; 3584 warn "runtime file written.\n";
3273 3585
3274 1 3586 1
3587}
3588
3589our $uuid_lock;
3590our $uuid_skip;
3591
3592sub write_uuid_sync($) {
3593 $uuid_skip ||= $_[0];
3594
3595 return if $uuid_lock;
3596 local $uuid_lock = 1;
3597
3598 my $uuid = "$LOCALDIR/uuid";
3599
3600 my $fh = aio_open "$uuid~", O_WRONLY | O_CREAT, 0644
3601 or return;
3602
3603 my $value = uuid_seq uuid_cur;
3604
3605 unless ($value) {
3606 warn "cowardly refusing to write zero uuid value!\n";
3607 return;
3608 }
3609
3610 my $value = uuid_str $value + $uuid_skip;
3611 $uuid_skip = 0;
3612
3613 (aio_write $fh, 0, (length $value), $value, 0) <= 0
3614 and return;
3615
3616 # always fsync - this file is important
3617 aio_fsync $fh
3618 and return;
3619
3620 close $fh
3621 or return;
3622
3623 aio_rename "$uuid~", $uuid
3624 and return;
3625
3626 warn "uuid file written ($value).\n";
3627
3628 1
3629
3630}
3631
3632sub write_uuid($$) {
3633 my ($skip, $sync) = @_;
3634
3635 $sync ? write_uuid_sync $skip
3636 : async { write_uuid_sync $skip };
3275} 3637}
3276 3638
3277sub emergency_save() { 3639sub emergency_save() {
3278 my $freeze_guard = cf::freeze_mainloop; 3640 my $freeze_guard = cf::freeze_mainloop;
3279 3641
3280 warn "enter emergency perl save\n"; 3642 warn "emergency_perl_save: enter\n";
3281 3643
3282 cf::sync_job { 3644 cf::sync_job {
3645 # this is a trade-off: we want to be very quick here, so
3646 # save all maps without fsync, and later call a global sync
3647 # (which in turn might be very very slow)
3648 local $USE_FSYNC = 0;
3649
3283 # use a peculiar iteration method to avoid tripping on perl 3650 # use a peculiar iteration method to avoid tripping on perl
3284 # refcount bugs in for. also avoids problems with players 3651 # refcount bugs in for. also avoids problems with players
3285 # and maps saved/destroyed asynchronously. 3652 # and maps saved/destroyed asynchronously.
3286 warn "begin emergency player save\n"; 3653 warn "emergency_perl_save: begin player save\n";
3287 for my $login (keys %cf::PLAYER) { 3654 for my $login (keys %cf::PLAYER) {
3288 my $pl = $cf::PLAYER{$login} or next; 3655 my $pl = $cf::PLAYER{$login} or next;
3289 $pl->valid or next; 3656 $pl->valid or next;
3290 delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt 3657 delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt
3291 $pl->save; 3658 $pl->save;
3292 } 3659 }
3293 warn "end emergency player save\n"; 3660 warn "emergency_perl_save: end player save\n";
3294 3661
3295 warn "begin emergency map save\n"; 3662 warn "emergency_perl_save: begin map save\n";
3296 for my $path (keys %cf::MAP) { 3663 for my $path (keys %cf::MAP) {
3297 my $map = $cf::MAP{$path} or next; 3664 my $map = $cf::MAP{$path} or next;
3298 $map->valid or next; 3665 $map->valid or next;
3299 $map->save; 3666 $map->save;
3300 } 3667 }
3301 warn "end emergency map save\n"; 3668 warn "emergency_perl_save: end map save\n";
3302 3669
3303 warn "begin emergency database checkpoint\n"; 3670 warn "emergency_perl_save: begin database checkpoint\n";
3304 BDB::db_env_txn_checkpoint $DB_ENV; 3671 BDB::db_env_txn_checkpoint $DB_ENV;
3305 warn "end emergency database checkpoint\n"; 3672 warn "emergency_perl_save: end database checkpoint\n";
3673
3674 warn "emergency_perl_save: begin write uuid\n";
3675 write_uuid_sync 1;
3676 warn "emergency_perl_save: end write uuid\n";
3306 }; 3677 };
3307 3678
3679 warn "emergency_perl_save: starting sync()\n";
3680 IO::AIO::aio_sync sub {
3681 warn "emergency_perl_save: finished sync()\n";
3682 };
3683
3308 warn "leave emergency perl save\n"; 3684 warn "emergency_perl_save: leave\n";
3309} 3685}
3310 3686
3311sub post_cleanup { 3687sub post_cleanup {
3312 my ($make_core) = @_; 3688 my ($make_core) = @_;
3313 3689
3314 warn Carp::longmess "post_cleanup backtrace" 3690 warn Carp::longmess "post_cleanup backtrace"
3315 if $make_core; 3691 if $make_core;
3692
3693 my $fh = pidfile;
3694 unlink $PIDFILE if <$fh> == $$;
3695}
3696
3697# a safer delete_package, copied from Symbol
3698sub clear_package($) {
3699 my $pkg = shift;
3700
3701 # expand to full symbol table name if needed
3702 unless ($pkg =~ /^main::.*::$/) {
3703 $pkg = "main$pkg" if $pkg =~ /^::/;
3704 $pkg = "main::$pkg" unless $pkg =~ /^main::/;
3705 $pkg .= '::' unless $pkg =~ /::$/;
3706 }
3707
3708 my($stem, $leaf) = $pkg =~ m/(.*::)(\w+::)$/;
3709 my $stem_symtab = *{$stem}{HASH};
3710
3711 defined $stem_symtab and exists $stem_symtab->{$leaf}
3712 or return;
3713
3714 # clear all symbols
3715 my $leaf_symtab = *{$stem_symtab->{$leaf}}{HASH};
3716 for my $name (keys %$leaf_symtab) {
3717 _gv_clear *{"$pkg$name"};
3718# use PApp::Util; PApp::Util::sv_dump *{"$pkg$name"};
3719 }
3720 warn "cleared package $pkg\n";#d#
3316} 3721}
3317 3722
3318sub do_reload_perl() { 3723sub do_reload_perl() {
3319 # can/must only be called in main 3724 # can/must only be called in main
3320 if ($Coro::current != $Coro::main) { 3725 if ($Coro::current != $Coro::main) {
3321 warn "can only reload from main coroutine"; 3726 warn "can only reload from main coroutine";
3322 return; 3727 return;
3323 } 3728 }
3324 3729
3730 return if $RELOAD++;
3731
3732 my $t1 = EV::time;
3733
3734 while ($RELOAD) {
3325 warn "reloading..."; 3735 warn "reloading...";
3326 3736
3327 warn "entering sync_job"; 3737 warn "entering sync_job";
3328 3738
3329 cf::sync_job { 3739 cf::sync_job {
3330 cf::write_runtime; # external watchdog should not bark 3740 cf::write_runtime_sync; # external watchdog should not bark
3331 cf::emergency_save; 3741 cf::emergency_save;
3332 cf::write_runtime; # external watchdog should not bark 3742 cf::write_runtime_sync; # external watchdog should not bark
3333 3743
3334 warn "syncing database to disk"; 3744 warn "syncing database to disk";
3335 BDB::db_env_txn_checkpoint $DB_ENV; 3745 BDB::db_env_txn_checkpoint $DB_ENV;
3336 3746
3337 # if anything goes wrong in here, we should simply crash as we already saved 3747 # if anything goes wrong in here, we should simply crash as we already saved
3338 3748
3339 warn "cancelling all WF_AUTOCANCEL watchers";
3340 for (Event::all_watchers) {
3341 $_->cancel if $_->data & WF_AUTOCANCEL;
3342 }
3343
3344 warn "flushing outstanding aio requests"; 3749 warn "flushing outstanding aio requests";
3345 for (;;) {
3346 BDB::flush;
3347 IO::AIO::flush;
3348 Coro::cede;
3349 last unless IO::AIO::nreqs || BDB::nreqs; 3750 while (IO::AIO::nreqs || BDB::nreqs) {
3350 warn "iterate..."; 3751 Coro::EV::timer_once 0.01; # let the sync_job do it's thing
3351 }
3352
3353 ++$RELOAD;
3354
3355 warn "cancelling all extension coros";
3356 $_->cancel for values %EXT_CORO;
3357 %EXT_CORO = ();
3358
3359 warn "removing commands";
3360 %COMMAND = ();
3361
3362 warn "removing ext/exti commands";
3363 %EXTCMD = ();
3364 %EXTICMD = ();
3365
3366 warn "unloading/nuking all extensions";
3367 for my $pkg (@EXTS) {
3368 warn "... unloading $pkg";
3369
3370 if (my $cb = $pkg->can ("unload")) {
3371 eval {
3372 $cb->($pkg);
3373 1
3374 } or warn "$pkg unloaded, but with errors: $@";
3375 } 3752 }
3376 3753
3377 warn "... nuking $pkg"; 3754 warn "cancelling all extension coros";
3378 Symbol::delete_package $pkg; 3755 $_->cancel for values %EXT_CORO;
3379 } 3756 %EXT_CORO = ();
3380 3757
3381 warn "unloading all perl modules loaded from $LIBDIR"; 3758 warn "removing commands";
3382 while (my ($k, $v) = each %INC) { 3759 %COMMAND = ();
3383 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
3384 3760
3761 warn "removing ext/exti commands";
3762 %EXTCMD = ();
3763 %EXTICMD = ();
3764
3765 warn "unloading/nuking all extensions";
3766 for my $pkg (@EXTS) {
3385 warn "... unloading $k"; 3767 warn "... unloading $pkg";
3386 delete $INC{$k};
3387 3768
3388 $k =~ s/\.pm$//;
3389 $k =~ s/\//::/g;
3390
3391 if (my $cb = $k->can ("unload_module")) { 3769 if (my $cb = $pkg->can ("unload")) {
3770 eval {
3392 $cb->(); 3771 $cb->($pkg);
3772 1
3773 } or warn "$pkg unloaded, but with errors: $@";
3774 }
3775
3776 warn "... clearing $pkg";
3777 clear_package $pkg;
3393 } 3778 }
3394 3779
3395 Symbol::delete_package $k; 3780 warn "unloading all perl modules loaded from $LIBDIR";
3781 while (my ($k, $v) = each %INC) {
3782 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
3783
3784 warn "... unloading $k";
3785 delete $INC{$k};
3786
3787 $k =~ s/\.pm$//;
3788 $k =~ s/\//::/g;
3789
3790 if (my $cb = $k->can ("unload_module")) {
3791 $cb->();
3792 }
3793
3794 clear_package $k;
3396 } 3795 }
3397 3796
3398 warn "getting rid of safe::, as good as possible"; 3797 warn "getting rid of safe::, as good as possible";
3399 Symbol::delete_package "safe::$_" 3798 clear_package "safe::$_"
3400 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region); 3799 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
3401 3800
3402 warn "unloading cf.pm \"a bit\""; 3801 warn "unloading cf.pm \"a bit\"";
3403 delete $INC{"cf.pm"}; 3802 delete $INC{"cf.pm"};
3404 delete $INC{"cf/pod.pm"}; 3803 delete $INC{"cf/$_.pm"} for @EXTRA_MODULES;
3405 3804
3406 # don't, removes xs symbols, too, 3805 # don't, removes xs symbols, too,
3407 # and global variables created in xs 3806 # and global variables created in xs
3408 #Symbol::delete_package __PACKAGE__; 3807 #clear_package __PACKAGE__;
3409 3808
3410 warn "unload completed, starting to reload now"; 3809 warn "unload completed, starting to reload now";
3411 3810
3412 warn "reloading cf.pm"; 3811 warn "reloading cf.pm";
3413 require cf; 3812 require cf;
3414 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 3813 cf::_connect_to_perl_1;
3415 3814
3416 warn "loading config and database again"; 3815 warn "loading config and database again";
3417 cf::reload_config; 3816 cf::reload_config;
3418 3817
3419 warn "loading extensions"; 3818 warn "loading extensions";
3420 cf::load_extensions; 3819 cf::load_extensions;
3421 3820
3821 if ($REATTACH_ON_RELOAD) {
3422 warn "reattaching attachments to objects/players"; 3822 warn "reattaching attachments to objects/players";
3423 _global_reattach; # objects, sockets 3823 _global_reattach; # objects, sockets
3424 warn "reattaching attachments to maps"; 3824 warn "reattaching attachments to maps";
3425 reattach $_ for values %MAP; 3825 reattach $_ for values %MAP;
3426 warn "reattaching attachments to players"; 3826 warn "reattaching attachments to players";
3427 reattach $_ for values %PLAYER; 3827 reattach $_ for values %PLAYER;
3828 }
3428 3829
3830 warn "running post_init jobs";
3831 (pop @POST_INIT)->(1) while @POST_INIT;
3832
3429 warn "leaving sync_job"; 3833 warn "leaving sync_job";
3430 3834
3431 1 3835 1
3432 } or do { 3836 } or do {
3433 warn $@; 3837 warn $@;
3434 warn "error while reloading, exiting."; 3838 cf::cleanup "error while reloading, exiting.";
3435 exit 1;
3436 }; 3839 };
3437 3840
3438 warn "reloaded"; 3841 warn "reloaded";
3842 --$RELOAD;
3843 }
3844
3845 $t1 = EV::time - $t1;
3846 warn "reload completed in ${t1}s\n";
3439}; 3847};
3440 3848
3441our $RELOAD_WATCHER; # used only during reload 3849our $RELOAD_WATCHER; # used only during reload
3442 3850
3443sub reload_perl() { 3851sub reload_perl() {
3444 # doing reload synchronously and two reloads happen back-to-back, 3852 # doing reload synchronously and two reloads happen back-to-back,
3445 # coro crashes during coro_state_free->destroy here. 3853 # coro crashes during coro_state_free->destroy here.
3446 3854
3447 $RELOAD_WATCHER ||= Event->timer ( 3855 $RELOAD_WATCHER ||= cf::async {
3448 reentrant => 0, 3856 Coro::AIO::aio_wait cache_extensions;
3449 after => 0, 3857
3450 data => WF_AUTOCANCEL, 3858 $RELOAD_WATCHER = EV::timer $TICK * 1.5, 0, sub {
3451 cb => sub {
3452 do_reload_perl; 3859 do_reload_perl;
3453 undef $RELOAD_WATCHER; 3860 undef $RELOAD_WATCHER;
3454 }, 3861 };
3455 ); 3862 };
3456} 3863}
3457 3864
3458register_command "reload" => sub { 3865register_command "reload" => sub {
3459 my ($who, $arg) = @_; 3866 my ($who, $arg) = @_;
3460 3867
… …
3473 3880
3474our @WAIT_FOR_TICK; 3881our @WAIT_FOR_TICK;
3475our @WAIT_FOR_TICK_BEGIN; 3882our @WAIT_FOR_TICK_BEGIN;
3476 3883
3477sub wait_for_tick { 3884sub wait_for_tick {
3478 return unless $TICK_WATCHER->is_active;
3479 return if $Coro::current == $Coro::main; 3885 return if tick_inhibit || $Coro::current == $Coro::main;
3480 3886
3481 my $signal = new Coro::Signal; 3887 my $signal = new Coro::Signal;
3482 push @WAIT_FOR_TICK, $signal; 3888 push @WAIT_FOR_TICK, $signal;
3483 $signal->wait; 3889 $signal->wait;
3484} 3890}
3485 3891
3486sub wait_for_tick_begin { 3892sub wait_for_tick_begin {
3487 return unless $TICK_WATCHER->is_active;
3488 return if $Coro::current == $Coro::main; 3893 return if tick_inhibit || $Coro::current == $Coro::main;
3489 3894
3490 my $signal = new Coro::Signal; 3895 my $signal = new Coro::Signal;
3491 push @WAIT_FOR_TICK_BEGIN, $signal; 3896 push @WAIT_FOR_TICK_BEGIN, $signal;
3492 $signal->wait; 3897 $signal->wait;
3493} 3898}
3494 3899
3495$TICK_WATCHER = Event->timer ( 3900sub tick {
3496 reentrant => 0,
3497 parked => 1,
3498 prio => 0,
3499 at => $NEXT_TICK || $TICK,
3500 data => WF_AUTOCANCEL,
3501 cb => sub {
3502 if ($Coro::current != $Coro::main) { 3901 if ($Coro::current != $Coro::main) {
3503 Carp::cluck "major BUG: server tick called outside of main coro, skipping it" 3902 Carp::cluck "major BUG: server tick called outside of main coro, skipping it"
3504 unless ++$bug_warning > 10; 3903 unless ++$bug_warning > 10;
3505 return; 3904 return;
3506 } 3905 }
3507 3906
3508 $NOW = $tick_start = Event::time;
3509
3510 cf::server_tick; # one server iteration 3907 cf::server_tick; # one server iteration
3511 3908
3512 $RUNTIME += $TICK;
3513 $NEXT_TICK += $TICK;
3514
3515 if ($NOW >= $NEXT_RUNTIME_WRITE) { 3909 if ($NOW >= $NEXT_RUNTIME_WRITE) {
3516 $NEXT_RUNTIME_WRITE = $NOW + 10; 3910 $NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.;
3517 Coro::async_pool { 3911 Coro::async_pool {
3518 $Coro::current->{desc} = "runtime saver"; 3912 $Coro::current->{desc} = "runtime saver";
3519 write_runtime 3913 write_runtime_sync
3520 or warn "ERROR: unable to write runtime file: $!"; 3914 or warn "ERROR: unable to write runtime file: $!";
3521 };
3522 } 3915 };
3916 }
3523 3917
3524 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) { 3918 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
3525 $sig->send; 3919 $sig->send;
3526 } 3920 }
3527 while (my $sig = shift @WAIT_FOR_TICK) { 3921 while (my $sig = shift @WAIT_FOR_TICK) {
3528 $sig->send; 3922 $sig->send;
3529 } 3923 }
3530 3924
3531 $NOW = Event::time; 3925 $LOAD = ($NOW - $TICK_START) / $TICK;
3532
3533 # if we are delayed by four ticks or more, skip them all
3534 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
3535
3536 $TICK_WATCHER->at ($NEXT_TICK);
3537 $TICK_WATCHER->start;
3538
3539 $LOAD = ($NOW - $tick_start) / $TICK;
3540 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25; 3926 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
3541 3927
3542 _post_tick; 3928 if (0) {
3929 if ($NEXT_TICK) {
3930 my $jitter = $TICK_START - $NEXT_TICK;
3931 $JITTER = $JITTER * 0.75 + $jitter * 0.25;
3932 warn "jitter $JITTER\n";#d#
3933 }
3543 }, 3934 }
3544); 3935}
3545 3936
3546{ 3937{
3938 # configure BDB
3939
3547 BDB::min_parallel 8; 3940 BDB::min_parallel 8;
3548 BDB::max_poll_time $TICK * 0.1; 3941 BDB::max_poll_reqs $TICK * 0.1;
3549 $BDB_POLL_WATCHER = Event->io ( 3942 $AnyEvent::BDB::WATCHER->priority (1);
3550 reentrant => 0,
3551 fd => BDB::poll_fileno,
3552 poll => 'r',
3553 prio => 0,
3554 data => WF_AUTOCANCEL,
3555 cb => \&BDB::poll_cb,
3556 );
3557
3558 BDB::set_sync_prepare {
3559 my $status;
3560 my $current = $Coro::current;
3561 (
3562 sub {
3563 $status = $!;
3564 $current->ready; undef $current;
3565 },
3566 sub {
3567 Coro::schedule while defined $current;
3568 $! = $status;
3569 },
3570 )
3571 };
3572 3943
3573 unless ($DB_ENV) { 3944 unless ($DB_ENV) {
3574 $DB_ENV = BDB::db_env_create; 3945 $DB_ENV = BDB::db_env_create;
3575 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC 3946 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT);
3576 | BDB::LOG_AUTOREMOVE, 1); 3947 $DB_ENV->set_flags (&BDB::LOG_AUTOREMOVE ) if BDB::VERSION v0, v4.7;
3948 $DB_ENV->log_set_config (&BDB::LOG_AUTO_REMOVE) if BDB::VERSION v4.7;
3577 $DB_ENV->set_timeout (30, BDB::SET_TXN_TIMEOUT); 3949 $DB_ENV->set_timeout (30, BDB::SET_TXN_TIMEOUT);
3578 $DB_ENV->set_timeout (30, BDB::SET_LOCK_TIMEOUT); 3950 $DB_ENV->set_timeout (30, BDB::SET_LOCK_TIMEOUT);
3579 3951
3580 cf::sync_job { 3952 cf::sync_job {
3581 eval { 3953 eval {
… …
3591 3963
3592 cf::cleanup "db_env_open(db): $@" if $@; 3964 cf::cleanup "db_env_open(db): $@" if $@;
3593 }; 3965 };
3594 } 3966 }
3595 3967
3596 $BDB_DEADLOCK_WATCHER = Event->timer ( 3968 $BDB_DEADLOCK_WATCHER = EV::periodic 0, 3, 0, sub {
3597 after => 3,
3598 interval => 1,
3599 hard => 1,
3600 prio => 0,
3601 data => WF_AUTOCANCEL,
3602 cb => sub {
3603 BDB::db_env_lock_detect $DB_ENV, 0, BDB::LOCK_DEFAULT, 0, sub { }; 3969 BDB::db_env_lock_detect $DB_ENV, 0, BDB::LOCK_DEFAULT, 0, sub { };
3604 },
3605 ); 3970 };
3606 $BDB_CHECKPOINT_WATCHER = Event->timer ( 3971 $BDB_CHECKPOINT_WATCHER = EV::periodic 0, 60, 0, sub {
3607 after => 11,
3608 interval => 60,
3609 hard => 1,
3610 prio => 0,
3611 data => WF_AUTOCANCEL,
3612 cb => sub {
3613 BDB::db_env_txn_checkpoint $DB_ENV, 0, 0, 0, sub { }; 3972 BDB::db_env_txn_checkpoint $DB_ENV, 0, 0, 0, sub { };
3614 },
3615 ); 3973 };
3616 $BDB_TRICKLE_WATCHER = Event->timer ( 3974 $BDB_TRICKLE_WATCHER = EV::periodic 0, 10, 0, sub {
3617 after => 5,
3618 interval => 10,
3619 hard => 1,
3620 prio => 0,
3621 data => WF_AUTOCANCEL,
3622 cb => sub {
3623 BDB::db_env_memp_trickle $DB_ENV, 20, 0, sub { }; 3975 BDB::db_env_memp_trickle $DB_ENV, 20, 0, sub { };
3624 },
3625 ); 3976 };
3626} 3977}
3627 3978
3628{ 3979{
3980 # configure IO::AIO
3981
3629 IO::AIO::min_parallel 8; 3982 IO::AIO::min_parallel 8;
3630
3631 undef $Coro::AIO::WATCHER;
3632 IO::AIO::max_poll_time $TICK * 0.1; 3983 IO::AIO::max_poll_time $TICK * 0.1;
3633 $AIO_POLL_WATCHER = Event->io ( 3984 undef $AnyEvent::AIO::WATCHER;
3634 reentrant => 0,
3635 data => WF_AUTOCANCEL,
3636 fd => IO::AIO::poll_fileno,
3637 poll => 'r',
3638 prio => 0,
3639 cb => \&IO::AIO::poll_cb,
3640 );
3641} 3985}
3642 3986
3643my $_log_backtrace; 3987my $_log_backtrace;
3644 3988
3645sub _log_backtrace { 3989sub _log_backtrace {
… …
3648 $msg =~ s/\n//; 3992 $msg =~ s/\n//;
3649 3993
3650 # limit the # of concurrent backtraces 3994 # limit the # of concurrent backtraces
3651 if ($_log_backtrace < 2) { 3995 if ($_log_backtrace < 2) {
3652 ++$_log_backtrace; 3996 ++$_log_backtrace;
3997 my $perl_bt = Carp::longmess $msg;
3653 async { 3998 async {
3654 $Coro::current->{desc} = "abt $msg"; 3999 $Coro::current->{desc} = "abt $msg";
3655 4000
3656 my @bt = fork_call { 4001 my @bt = fork_call {
3657 @addr = map { sprintf "%x", $_ } @addr; 4002 @addr = map { sprintf "%x", $_ } @addr;
… …
3668 } 4013 }
3669 4014
3670 @funcs 4015 @funcs
3671 }; 4016 };
3672 4017
3673 LOG llevInfo, "[ABT] $msg\n"; 4018 LOG llevInfo, "[ABT] $perl_bt\n";
4019 LOG llevInfo, "[ABT] --- C backtrace follows ---\n";
3674 LOG llevInfo, "[ABT] $_\n" for @bt; 4020 LOG llevInfo, "[ABT] $_\n" for @bt;
3675 --$_log_backtrace; 4021 --$_log_backtrace;
3676 }; 4022 };
3677 } else { 4023 } else {
3678 LOG llevInfo, "[ABT] $msg\n"; 4024 LOG llevInfo, "[ABT] $msg\n";
3679 LOG llevInfo, "[ABT] [suppressed]\n"; 4025 LOG llevInfo, "[ABT] [suppressed]\n";
3680 } 4026 }
3681} 4027}
3682 4028
3683# load additional modules 4029# load additional modules
3684use cf::pod; 4030require "cf/$_.pm" for @EXTRA_MODULES;
4031cf::_connect_to_perl_2;
3685 4032
3686END { cf::emergency_save } 4033END { cf::emergency_save }
3687 4034
36881 40351
3689 4036

Diff Legend

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