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.166 by root, Sat Jan 13 23:06:13 2007 UTC vs.
Revision 1.557 by root, Tue Oct 5 21:40:05 2010 UTC

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

Diff Legend

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