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.200 by root, Mon Jan 29 17:57:22 2007 UTC vs.
Revision 1.566 by root, Sun May 1 16:58:16 2011 UTC

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

Diff Legend

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