ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/deliantra/server/lib/cf.pm
(Generate patch)

Comparing deliantra/server/lib/cf.pm (file contents):
Revision 1.158 by root, Wed Jan 10 19:52:43 2007 UTC vs.
Revision 1.527 by root, Fri Apr 23 04:32:47 2010 UTC

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

Diff Legend

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