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.165 by root, Fri Jan 12 22:09:22 2007 UTC vs.
Revision 1.522 by root, Sat Apr 17 02:22:14 2010 UTC

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

Diff Legend

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