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

Diff Legend

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