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

Diff Legend

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