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.133 by root, Thu Jan 4 16:19:32 2007 UTC vs.
Revision 1.408 by root, Mon Jan 14 10:12:12 2008 UTC

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

Diff Legend

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