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.158 by root, Wed Jan 10 19:52:43 2007 UTC vs.
Revision 1.524 by root, Sun Apr 18 07:08:07 2010 UTC

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

Diff Legend

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