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.277 by root, Sun Jun 10 04:24:50 2007 UTC vs.
Revision 1.593 by root, Fri Nov 9 01:59:33 2012 UTC

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

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines