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.162 by root, Thu Jan 11 00:41:08 2007 UTC vs.
Revision 1.523 by root, Sat Apr 17 02:39:46 2010 UTC

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

Diff Legend

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