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

Diff Legend

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