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.134 by root, Thu Jan 4 17:28:49 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 Coro::cede;
1215
1216 if ($map) {
1217 $map->last_access ((delete $map->{last_access})
1218 || $cf::RUNTIME); #d#
1219 # safety
1220 $map->{instantiate_time} = $cf::RUNTIME
1221 if $map->{instantiate_time} > $cf::RUNTIME;
1222 } else {
1223 if (my $rmp = $path->random_map_params) {
1224 $map = generate_random_map $key, $rmp;
1225 } else {
1226 $map = try_load_header $path->load_path;
1227 }
1228
1229 $map or return; 1983 or return;
1230 1984
1231 $map->{load_original} = 1;
1232 $map->{instantiate_time} = $cf::RUNTIME;
1233 $map->last_access ($cf::RUNTIME);
1234 $map->instantiate;
1235
1236 # per-player maps become, after loading, normal maps
1237 $map->per_player (0) if $path->{user_rel};
1238 }
1239
1240 $map->path ($key);
1241 $map->{path} = $path;
1242 $map->{last_save} = $cf::RUNTIME; 1985 $map->{last_save} = $cf::RUNTIME;
1243 1986
1244 Coro::cede; 1987 $map->load_header
1988 or return;
1245 1989
1246 if ($map->should_reset) { 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;
1247 $map->reset; 1995 $map->reset;
1248 undef $guard;
1249 $map = find $path 1996 return find $path;
1250 or return;
1251 } 1997 }
1252 1998
1253 $cf::MAP{$key} = $map 1999 $cf::MAP{$path} = $map
1254 } 2000 }
1255} 2001}
2002
2003sub pre_load { }
2004sub post_load { }
1256 2005
1257sub load { 2006sub load {
1258 my ($self) = @_; 2007 my ($self) = @_;
1259 2008
2009 local $self->{deny_reset} = 1; # loading can take a long time
2010
1260 my $path = $self->{path}; 2011 my $path = $self->{path};
2012
2013 {
1261 my $guard = cf::lock_acquire "map_load:" . $path->as_string; 2014 my $guard = cf::lock_acquire "map_data:$path";
1262 2015
2016 return unless $self->valid;
1263 return if $self->in_memory != cf::MAP_SWAPPED; 2017 return unless $self->in_memory == cf::MAP_SWAPPED;
1264 2018
1265 $self->in_memory (cf::MAP_LOADING); 2019 $self->in_memory (cf::MAP_LOADING);
1266 2020
1267 $self->alloc; 2021 $self->alloc;
1268 $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)
1269 or return; 2029 or return;
1270 2030
1271 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1) 2031 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1)
1272 if delete $self->{load_original}; 2032 if delete $self->{load_original};
1273 2033
1274 if (my $uniq = $path->uniq_path) { 2034 if (my $uniq = $self->uniq_path) {
1275 utf8::encode $uniq; 2035 utf8::encode $uniq;
1276 if (aio_open $uniq, O_RDONLY, 0) { 2036 unless (aio_stat $uniq) {
2037 if (my $f = new_from_file cf::object::thawer $uniq) {
1277 $self->clear_unique_items; 2038 $self->clear_unique_items;
1278 $self->load_objects ($uniq, 0); 2039 $self->_load_objects ($f);
2040 $f->resolve_delayed_derefs;
2041 }
1279 } 2042 }
1280 } 2043 }
1281 2044
1282 Coro::cede; 2045 $f->resolve_delayed_derefs;
1283 2046
2047 cf::cede_to_tick;
1284 # now do the right thing for maps 2048 # now do the right thing for maps
1285 $self->link_multipart_objects; 2049 $self->link_multipart_objects;
1286
1287 if ($self->{path}->is_style_map) {
1288 $self->{deny_save} = 1;
1289 $self->{deny_reset} = 1;
1290 } else {
1291 $self->fix_auto_apply;
1292 $self->decay_objects;
1293 $self->update_buttons;
1294 $self->set_darkness_map;
1295 $self->difficulty ($self->estimate_difficulty) 2050 $self->difficulty ($self->estimate_difficulty)
1296 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;
1297 $self->activate; 2061 $self->activate;
1298 } 2062 }
1299 2063
1300 Coro::cede; 2064 $self->{last_save} = $cf::RUNTIME;
2065 $self->last_access ($cf::RUNTIME);
1301 2066
1302 $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 }
1303} 2109}
1304 2110
1305sub find_sync { 2111sub find_sync {
1306 my ($path, $origin) = @_; 2112 my ($path, $origin) = @_;
1307 2113
1308 cf::sync_job { cf::map::find $path, $origin } 2114 cf::sync_job { find $path, $origin }
1309} 2115}
1310 2116
1311sub do_load_sync { 2117sub do_load_sync {
1312 my ($map) = @_; 2118 my ($map) = @_;
1313 2119
2120 cf::LOG cf::llevDebug | cf::logBacktrace, "do_load_sync"
2121 if $Coro::current == $Coro::main;
2122
1314 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 ()
1315} 2157}
1316 2158
1317sub save { 2159sub save {
1318 my ($self) = @_; 2160 my ($self) = @_;
1319 2161
2162 my $lock = cf::lock_acquire "map_data:$self->{path}";
2163
1320 $self->{last_save} = $cf::RUNTIME; 2164 $self->{last_save} = $cf::RUNTIME;
1321 2165
1322 return unless $self->dirty; 2166 return unless $self->dirty;
1323 2167
1324 my $save = $self->{path}->save_path; utf8::encode $save; 2168 my $save = $self->save_path; utf8::encode $save;
1325 my $uniq = $self->{path}->uniq_path; utf8::encode $uniq; 2169 my $uniq = $self->uniq_path; utf8::encode $uniq;
1326 2170
1327 $self->{load_path} = $save; 2171 $self->{load_path} = $save;
1328 2172
1329 return if $self->{deny_save}; 2173 return if $self->{deny_save};
1330 2174
1331 local $self->{last_access} = $self->last_access;#d# 2175 local $self->{last_access} = $self->last_access;#d#
1332 2176
2177 cf::async {
2178 $Coro::current->{desc} = "map player save";
2179 $_->contr->save for $self->players;
2180 };
2181
1333 if ($uniq) { 2182 if ($uniq) {
1334 $self->save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS); 2183 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS);
1335 $self->save_objects ($uniq, cf::IO_UNIQUES); 2184 $self->_save_objects ($uniq, cf::IO_UNIQUES);
1336 } else { 2185 } else {
1337 $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);
1338 } 2187 }
1339} 2188}
1340 2189
1341sub swap_out { 2190sub swap_out {
1342 my ($self) = @_; 2191 my ($self) = @_;
1343 2192
1344 # save first because save cedes 2193 # save first because save cedes
1345 $self->save; 2194 $self->save;
2195
2196 my $lock = cf::lock_acquire "map_data:$self->{path}";
1346 2197
1347 return if $self->players; 2198 return if $self->players;
1348 return if $self->in_memory != cf::MAP_IN_MEMORY; 2199 return if $self->in_memory != cf::MAP_IN_MEMORY;
1349 return if $self->{deny_save}; 2200 return if $self->{deny_save};
1350 2201
2202 $self->in_memory (cf::MAP_SWAPPED);
2203
2204 $self->deactivate;
2205 $_->clear_links_to ($self) for values %cf::MAP;
1351 $self->clear; 2206 $self->clear;
1352 $self->in_memory (cf::MAP_SWAPPED);
1353} 2207}
1354 2208
1355sub reset_at { 2209sub reset_at {
1356 my ($self) = @_; 2210 my ($self) = @_;
1357 2211
1358 # TODO: safety, remove and allow resettable per-player maps 2212 # TODO: safety, remove and allow resettable per-player maps
1359 return 1e99 if $self->{path}{user_rel};
1360 return 1e99 if $self->{deny_reset}; 2213 return 1e99 if $self->{deny_reset};
1361 2214
1362 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access; 2215 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
1363 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;
1364 2217
… …
1369 my ($self) = @_; 2222 my ($self) = @_;
1370 2223
1371 $self->reset_at <= $cf::RUNTIME 2224 $self->reset_at <= $cf::RUNTIME
1372} 2225}
1373 2226
1374sub unlink_save {
1375 my ($self) = @_;
1376
1377 utf8::encode (my $save = $self->{path}->save_path);
1378 aioreq_pri 3; IO::AIO::aio_unlink $save;
1379 aioreq_pri 3; IO::AIO::aio_unlink "$save.pst";
1380}
1381
1382sub rename {
1383 my ($self, $new_path) = @_;
1384
1385 $self->unlink_save;
1386
1387 delete $cf::MAP{$self->path};
1388 $self->{path} = new cf::path $new_path;
1389 $self->path ($self->{path}->as_string);
1390 $cf::MAP{$self->path} = $self;
1391
1392 $self->save;
1393}
1394
1395sub reset { 2227sub reset {
1396 my ($self) = @_; 2228 my ($self) = @_;
1397 2229
2230 my $lock = cf::lock_acquire "map_data:$self->{path}";
2231
1398 return if $self->players; 2232 return if $self->players;
1399 return if $self->{path}{user_rel};#d#
1400 2233
1401 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 }
1402 2245
1403 delete $cf::MAP{$self->path}; 2246 delete $cf::MAP{$self->path};
1404 2247
2248 $self->deactivate;
1405 $_->clear_links_to ($self) for values %cf::MAP; 2249 $_->clear_links_to ($self) for values %cf::MAP;
2250 $self->clear;
1406 2251
1407 $self->unlink_save; 2252 $self->unlink_save;
1408 $self->destroy; 2253 $self->destroy;
1409} 2254}
1410 2255
1411my $nuke_counter = "aaaa"; 2256my $nuke_counter = "aaaa";
1412 2257
1413sub nuke { 2258sub nuke {
1414 my ($self) = @_; 2259 my ($self) = @_;
1415 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};
1416 $self->{deny_save} = 1; 2270 $self->{deny_save} = 1;
1417 $self->reset_timeout (1); 2271 $self->reset_timeout (1);
1418 $self->rename ("{nuke}/" . ($nuke_counter++)); 2272 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));
2273
2274 $cf::MAP{$self->path} = $self;
2275 }
2276
1419 $self->reset; # polite request, might not happen 2277 $self->reset; # polite request, might not happen
1420} 2278}
1421 2279
1422sub customise_for { 2280=item $maps = cf::map::tmp_maps
1423 my ($map, $ob) = @_;
1424 2281
1425 if ($map->per_player) { 2282Returns an arrayref with all map paths of currently instantiated and saved
1426 return cf::map::find "~" . $ob->name . "/" . $map->{path}{path}; 2283maps. May block.
2284
2285=cut
2286
2287sub tmp_maps() {
1427 } 2288 [
1428 2289 map {
1429 $map 2290 utf8::decode $_;
2291 /\.map$/
2292 ? normalise $_
2293 : ()
2294 } @{ aio_readdir $TMPDIR or [] }
2295 ]
1430} 2296}
1431 2297
1432sub emergency_save { 2298=item $maps = cf::map::random_maps
1433 my $freeze_guard = cf::freeze_mainloop;
1434 2299
1435 warn "enter emergency map save\n"; 2300Returns an arrayref with all map paths of currently instantiated and saved
2301random maps. May block.
1436 2302
1437 cf::sync_job { 2303=cut
1438 warn "begin emergency map save\n";
1439 $_->save for values %cf::MAP;
1440 };
1441 2304
1442 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 ]
1443} 2332}
1444 2333
1445package cf; 2334package cf;
1446 2335
1447=back 2336=back
1448 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
1449 2392
1450=head3 cf::object::player 2393=head3 cf::object::player
1451 2394
1452=over 4 2395=over 4
1453 2396
… …
1467 2410
1468 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4; 2411 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4;
1469 2412
1470 if ($self->{record_replies}) { 2413 if ($self->{record_replies}) {
1471 push @{ $self->{record_replies} }, [$npc, $msg, $flags]; 2414 push @{ $self->{record_replies} }, [$npc, $msg, $flags];
2415
1472 } 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 {
1473 $msg = $npc->name . " says: $msg" if $npc; 2424 $msg = $npc->name . " says: $msg" if $npc;
1474 $self->message ($msg, $flags); 2425 $self->message ($msg, $flags);
2426 }
1475 } 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 (@_);
1476} 2438}
1477 2439
1478=item $player_object->may ("access") 2440=item $player_object->may ("access")
1479 2441
1480Returns wether the given player is authorized to access resource "access" 2442Returns wether the given player is authorized to access resource "access"
… …
1493 2455
1494=item $player_object->enter_link 2456=item $player_object->enter_link
1495 2457
1496Freezes 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}>).
1497 2459
1498The 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
1499I<MUST> call C<leave_link> as soon as possible, though. 2461I<MUST> call C<leave_link> as soon as possible, though.
1500 2462
2463Will never block.
2464
1501=item $player_object->leave_link ($map, $x, $y) 2465=item $player_object->leave_link ($map, $x, $y)
1502 2466
1503Moves 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
1504map 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
1505location 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
1506to the emergency map position. 2470fails, to the emergency map position.
1507 2471
1508Might block. 2472Might block.
1509 2473
1510=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}
1511 2485
1512sub cf::object::player::enter_link { 2486sub cf::object::player::enter_link {
1513 my ($self) = @_; 2487 my ($self) = @_;
1514 2488
1515 $self->deactivate_recursive; 2489 $self->deactivate_recursive;
1516 2490
1517 return if $self->map == $LINK_MAP; 2491 return if UNIVERSAL::isa $self->map, "ext::map_link";
1518 2492
1519 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y] 2493 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y]
1520 if $self->map; 2494 if $self->map && $self->map->{path} ne "{link}";
1521 2495
1522 $self->enter_map ($LINK_MAP, 20, 20); 2496 $self->enter_map ($LINK_MAP || link_map, 10, 10);
1523} 2497}
1524 2498
1525sub cf::object::player::leave_link { 2499sub cf::object::player::leave_link {
1526 my ($self, $map, $x, $y) = @_; 2500 my ($self, $map, $x, $y) = @_;
2501
2502 return unless $self->contr->active;
1527 2503
1528 my $link_pos = delete $self->{_link_pos}; 2504 my $link_pos = delete $self->{_link_pos};
1529 2505
1530 unless ($map) { 2506 unless ($map) {
1531 # restore original map position 2507 # restore original map position
… …
1545 # use -1 or undef as default coordinates, not 0, 0 2521 # use -1 or undef as default coordinates, not 0, 0
1546 ($x, $y) = ($map->enter_x, $map->enter_y) 2522 ($x, $y) = ($map->enter_x, $map->enter_y)
1547 if $x <=0 && $y <= 0; 2523 if $x <=0 && $y <= 0;
1548 2524
1549 $map->load; 2525 $map->load;
2526 $map->load_neighbours;
1550 2527
2528 return unless $self->contr->active;
1551 $self->activate_recursive; 2529 $self->activate_recursive;
2530
2531 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
1552 $self->enter_map ($map, $x, $y); 2532 $self->enter_map ($map, $x, $y);
1553} 2533}
1554 2534
1555cf::player->attach ( 2535=item $player_object->goto ($path, $x, $y[, $check->($map)[, $done->()]])
1556 on_logout => sub {
1557 my ($pl) = @_;
1558 2536
1559 # abort map switching before logout 2537Moves the player to the given map-path and coordinates by first freezing
1560 if ($pl->ob->{_link_pos}) { 2538her, loading and preparing them map, calling the provided $check callback
1561 cf::sync_job { 2539that has to return the map if sucecssful, and then unfreezes the player on
1562 $pl->ob->leave_link 2540the new (success) or old (failed) map position. In either case, $done will
1563 }; 2541be called at the end of this process.
1564 }
1565 },
1566 on_login => sub {
1567 my ($pl) = @_;
1568 2542
1569 # try to abort aborted map switching on player login :)
1570 # should happen only on crashes
1571 if ($pl->ob->{_link_pos}) {
1572 $pl->ob->enter_link;
1573 cf::async {
1574 # we need this sleep as the login has a concurrent enter_exit running
1575 # and this sleep increases chances of the player not ending up in scorn
1576 Coro::Timer::sleep 1;
1577 $pl->ob->leave_link;
1578 };
1579 }
1580 },
1581);
1582
1583=item $player_object->goto_map ($path, $x, $y)
1584
1585=cut 2543=cut
1586 2544
2545our $GOTOGEN;
2546
1587sub cf::object::player::goto_map { 2547sub cf::object::player::goto {
1588 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;
1589 2552
1590 $self->enter_link; 2553 $self->enter_link;
1591 2554
1592 (cf::async { 2555 (async {
1593 $path = new cf::path $path; 2556 $Coro::current->{desc} = "player::goto $path $x $y";
1594 2557
1595 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) {
1596 $map = $map->customise_for ($self) if $map; 2581 $map = $map->customise_for ($self);
1597 2582 $map = $check->($map) if $check && $map;
1598# warn "entering ", $map->path, " at ($x, $y)\n" 2583 } else {
1599# if $map;
1600
1601 $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 }
1602 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};
1603 $self->leave_link ($map, $x, $y); 2597 $self->leave_link ($map, $x, $y);
2598 }
2599
2600 $done->() if $done;
1604 })->prio (1); 2601 })->prio (1);
1605} 2602}
1606 2603
1607=item $player_object->enter_exit ($exit_object) 2604=item $player_object->enter_exit ($exit_object)
1608 2605
… …
1610 2607
1611sub parse_random_map_params { 2608sub parse_random_map_params {
1612 my ($spec) = @_; 2609 my ($spec) = @_;
1613 2610
1614 my $rmp = { # defaults 2611 my $rmp = { # defaults
1615 xsize => 10, 2612 xsize => (cf::rndm 15, 40),
1616 ysize => 10, 2613 ysize => (cf::rndm 15, 40),
2614 symmetry => (cf::rndm 1, cf::SYMMETRY_XY),
2615 #layout => string,
1617 }; 2616 };
1618 2617
1619 for (split /\n/, $spec) { 2618 for (split /\n/, $spec) {
1620 my ($k, $v) = split /\s+/, $_, 2; 2619 my ($k, $v) = split /\s+/, $_, 2;
1621 2620
… …
1625 $rmp 2624 $rmp
1626} 2625}
1627 2626
1628sub prepare_random_map { 2627sub prepare_random_map {
1629 my ($exit) = @_; 2628 my ($exit) = @_;
2629
2630 my $guard = cf::lock_acquire "exit_prepare:$exit";
1630 2631
1631 # all this does is basically replace the /! path by 2632 # all this does is basically replace the /! path by
1632 # a new random map path (?random/...) with a seed 2633 # a new random map path (?random/...) with a seed
1633 # that depends on the exit object 2634 # that depends on the exit object
1634 2635
1635 my $rmp = parse_random_map_params $exit->msg; 2636 my $rmp = parse_random_map_params $exit->msg;
1636 2637
1637 if ($exit->map) { 2638 if ($exit->map) {
1638 $rmp->{region} = $exit->map->region_name; 2639 $rmp->{region} = $exit->region->name;
1639 $rmp->{origin_map} = $exit->map->path; 2640 $rmp->{origin_map} = $exit->map->path;
1640 $rmp->{origin_x} = $exit->x; 2641 $rmp->{origin_x} = $exit->x;
1641 $rmp->{origin_y} = $exit->y; 2642 $rmp->{origin_y} = $exit->y;
1642 } 2643 }
1643 2644
1644 $rmp->{random_seed} ||= $exit->random_seed; 2645 $rmp->{random_seed} ||= $exit->random_seed;
1645 2646
1646 my $data = cf::to_json $rmp; 2647 my $data = cf::encode_json $rmp;
1647 my $md5 = Digest::MD5::md5_hex $data; 2648 my $md5 = Digest::MD5::md5_hex $data;
2649 my $meta = "$RANDOMDIR/$md5.meta";
1648 2650
1649 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) {
1650 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;
1651 2655
1652 $exit->slaying ("?random/$md5"); 2656 $exit->slaying ("?random/$md5");
1653 $exit->msg (undef); 2657 $exit->msg (undef);
1654 } 2658 }
1655} 2659}
… …
1657sub cf::object::player::enter_exit { 2661sub cf::object::player::enter_exit {
1658 my ($self, $exit) = @_; 2662 my ($self, $exit) = @_;
1659 2663
1660 return unless $self->type == cf::PLAYER; 2664 return unless $self->type == cf::PLAYER;
1661 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
1662 $self->enter_link; 2677 $self->enter_link;
1663 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
1664 (cf::async { 2683 (async {
2684 $Coro::current->{desc} = "enter_exit $slaying $hp $sp";
2685
1665 $self->deactivate_recursive; # just to be sure 2686 $self->deactivate_recursive; # just to be sure
1666 unless (eval { 2687 unless (eval {
1667 prepare_random_map $exit 2688 $self->goto ($slaying, $hp, $sp);
1668 if $exit->slaying eq "/!";
1669
1670 my $path = new cf::path $exit->slaying, $exit->map && $exit->map->path;
1671 $self->goto_map ($path, $exit->stats->hp, $exit->stats->sp);
1672 2689
1673 1; 2690 1;
1674 }) { 2691 }) {
1675 $self->message ("Something went wrong deep within the crossfire server. " 2692 $self->message ("Something went wrong deep within the crossfire server. "
1676 . "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. "
1677 . "Please report this to the dungeon master", 2694 . "Please report this to the dungeon master!",
1678 cf::NDI_UNIQUE | cf::NDI_RED); 2695 cf::NDI_UNIQUE | cf::NDI_RED);
1679 2696
1680 warn "ERROR in enter_exit: $@"; 2697 warn "ERROR in enter_exit: $@";
1681 $self->leave_link; 2698 $self->leave_link;
1682 } 2699 }
1683 })->prio (1); 2700 })->prio (1);
… …
1696 2713
1697sub cf::client::send_drawinfo { 2714sub cf::client::send_drawinfo {
1698 my ($self, $text, $flags) = @_; 2715 my ($self, $text, $flags) = @_;
1699 2716
1700 utf8::encode $text; 2717 utf8::encode $text;
1701 $self->send_packet (sprintf "drawinfo %d %s", $flags, $text); 2718 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);
1702} 2719}
1703 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}
1704 2879
1705=item $success = $client->query ($flags, "text", \&cb) 2880=item $success = $client->query ($flags, "text", \&cb)
1706 2881
1707Queues a query to the client, calling the given callback with 2882Queues a query to the client, calling the given callback with
1708the 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>,
1709C<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>.
1710 2885
1711Queries 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
1712reliable at some point in the future. 2887become reliable at some point in the future.
1713 2888
1714=cut 2889=cut
1715 2890
1716sub cf::client::query { 2891sub cf::client::query {
1717 my ($self, $flags, $text, $cb) = @_; 2892 my ($self, $flags, $text, $cb) = @_;
… …
1725 utf8::encode $text; 2900 utf8::encode $text;
1726 push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb]; 2901 push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb];
1727 2902
1728 $self->send_packet ($self->{query_queue}[0][0]) 2903 $self->send_packet ($self->{query_queue}[0][0])
1729 if @{ $self->{query_queue} } == 1; 2904 if @{ $self->{query_queue} } == 1;
2905
2906 1
1730} 2907}
1731 2908
1732cf::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 },
1733 on_reply => sub { 2915 on_reply => sub {
1734 my ($ns, $msg) = @_; 2916 my ($ns, $msg) = @_;
1735 2917
1736 # this weird shuffling is so that direct followup queries 2918 # this weird shuffling is so that direct followup queries
1737 # get handled first 2919 # get handled first
1738 my $queue = delete $ns->{query_queue} 2920 my $queue = delete $ns->{query_queue}
1739 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
1740 2922
1741 (shift @$queue)->[1]->($msg); 2923 (shift @$queue)->[1]->($msg);
2924 return unless $ns->valid; # temporary(?) workaround for callback destroying socket
1742 2925
1743 push @{ $ns->{query_queue} }, @$queue; 2926 push @{ $ns->{query_queue} }, @$queue;
1744 2927
1745 if (@{ $ns->{query_queue} } == @$queue) { 2928 if (@{ $ns->{query_queue} } == @$queue) {
1746 if (@$queue) { 2929 if (@$queue) {
… …
1748 } else { 2931 } else {
1749 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM; 2932 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM;
1750 } 2933 }
1751 } 2934 }
1752 }, 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 },
1753); 2962);
1754 2963
1755=item $client->coro (\&cb) 2964=item $client->async (\&cb)
1756 2965
1757Create a new coroutine, running the specified callback. The coroutine will 2966Create a new coroutine, running the specified callback. The coroutine will
1758be automatically cancelled when the client gets destroyed (e.g. on logout, 2967be automatically cancelled when the client gets destroyed (e.g. on logout,
1759or loss of connection). 2968or loss of connection).
1760 2969
1761=cut 2970=cut
1762 2971
1763sub cf::client::coro { 2972sub cf::client::async {
1764 my ($self, $cb) = @_; 2973 my ($self, $cb) = @_;
1765 2974
1766 my $coro = &cf::async ($cb); 2975 my $coro = &Coro::async ($cb);
1767 2976
1768 $coro->on_destroy (sub { 2977 $coro->on_destroy (sub {
1769 delete $self->{_coro}{$coro+0}; 2978 delete $self->{_coro}{$coro+0};
1770 }); 2979 });
1771 2980
… …
1798our $safe = new Safe "safe"; 3007our $safe = new Safe "safe";
1799our $safe_hole = new Safe::Hole; 3008our $safe_hole = new Safe::Hole;
1800 3009
1801$SIG{FPE} = 'IGNORE'; 3010$SIG{FPE} = 'IGNORE';
1802 3011
1803$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));
1804 3017
1805# here we export the classes and methods available to script code 3018# here we export the classes and methods available to script code
1806 3019
1807=pod 3020=pod
1808 3021
1809The following fucntions and emthods are available within a safe environment: 3022The following functions and methods are available within a safe environment:
1810 3023
1811 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
1812 cf::object::player player 3028 cf::object::player
1813 cf::player peaceful 3029 player
1814 cf::map trigger 3030
3031 cf::player
3032 peaceful
3033
3034 cf::map
3035 trigger
1815 3036
1816=cut 3037=cut
1817 3038
1818for ( 3039for (
1819 ["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)],
1820 ["cf::object::player" => qw(player)], 3043 ["cf::object::player" => qw(player)],
1821 ["cf::player" => qw(peaceful)], 3044 ["cf::player" => qw(peaceful)],
1822 ["cf::map" => qw(trigger)], 3045 ["cf::map" => qw(trigger)],
1823) { 3046) {
1824 no strict 'refs'; 3047 no strict 'refs';
… …
1895=back 3118=back
1896 3119
1897=cut 3120=cut
1898 3121
1899############################################################################# 3122#############################################################################
3123# the server's init and main functions
1900 3124
1901=head2 EXTENSION DATABASE SUPPORT 3125sub load_facedata($) {
3126 my ($path) = @_;
1902 3127
1903Crossfire maintains a very simple database for extension use. It can 3128 # HACK to clear player env face cache, we need some signal framework
1904currently store anything that can be serialised using Storable, which 3129 # for this (global event?)
1905excludes objects. 3130 %ext::player_env::MUSIC_FACE_CACHE = ();
1906 3131
1907The parameter C<$family> should best start with the name of the extension 3132 my $enc = JSON::XS->new->utf8->canonical->relaxed;
1908using it, it should be unique.
1909 3133
1910=over 4 3134 warn "loading facedata from $path\n";
1911 3135
1912=item $hashref = cf::db_get $family 3136 my $facedata;
3137 0 < aio_load $path, $facedata
3138 or die "$path: $!";
1913 3139
1914Return a hashref for use by the extension C<$family>, which can be 3140 $facedata = Coro::Storable::thaw $facedata;
1915modified. After modifications, you have to call C<cf::db_dirty> or
1916C<cf::db_sync>.
1917 3141
1918=item $value = cf::db_get $family => $key 3142 $facedata->{version} == 2
3143 or cf::cleanup "$path: version mismatch, cannot proceed.";
1919 3144
1920Returns a single value from the database 3145 # patch in the exptable
1921 3146 $facedata->{resource}{"res/exp_table"} = {
1922=item cf::db_put $family => $hashref 3147 type => FT_RSRC,
1923 3148 data => $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]),
1924Stores the given family hashref into the database. Updates are delayed, if
1925you want the data to be synced to disk immediately, use C<cf::db_sync>.
1926
1927=item cf::db_put $family => $key => $value
1928
1929Stores the given C<$value> in the family hash. Updates are delayed, if you
1930want the data to be synced to disk immediately, use C<cf::db_sync>.
1931
1932=item cf::db_dirty
1933
1934Marks the database as dirty, to be updated at a later time.
1935
1936=item cf::db_sync
1937
1938Immediately write the database to disk I<if it is dirty>.
1939
1940=cut
1941
1942our $DB;
1943
1944{
1945 my $path = cf::localdir . "/database.pst";
1946
1947 sub db_load() {
1948 $DB = stat $path ? Storable::retrieve $path : { };
1949 }
1950
1951 my $pid;
1952
1953 sub db_save() {
1954 waitpid $pid, 0 if $pid;
1955 if (0 == ($pid = fork)) {
1956 $DB->{_meta}{version} = 1;
1957 Storable::nstore $DB, "$path~";
1958 rename "$path~", $path;
1959 cf::_exit 0 if defined $pid;
1960 }
1961 }
1962
1963 my $dirty;
1964
1965 sub db_sync() {
1966 db_save if $dirty;
1967 undef $dirty;
1968 }
1969
1970 my $idle = Event->idle (min => $TICK * 2.8, max => 10, repeat => 0, data => WF_AUTOCANCEL, cb => sub {
1971 db_sync;
1972 }); 3149 };
3150 cf::cede_to_tick;
1973 3151
1974 sub db_dirty() {
1975 $dirty = 1;
1976 $idle->start;
1977 } 3152 {
3153 my $faces = $facedata->{faceinfo};
1978 3154
1979 sub db_get($;$) { 3155 while (my ($face, $info) = each %$faces) {
1980 @_ >= 2 3156 my $idx = (cf::face::find $face) || cf::face::alloc $face;
1981 ? $DB->{$_[0]}{$_[1]}
1982 : ($DB->{$_[0]} ||= { })
1983 }
1984 3157
1985 sub db_put($$;$) { 3158 cf::face::set_visibility $idx, $info->{visibility};
1986 if (@_ >= 3) { 3159 cf::face::set_magicmap $idx, $info->{magicmap};
1987 $DB->{$_[0]}{$_[1]} = $_[2]; 3160 cf::face::set_data $idx, 0, $info->{data32}, Digest::MD5::md5 $info->{data32};
1988 } else { 3161 cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64};
1989 $DB->{$_[0]} = $_[1];
1990 }
1991 db_dirty;
1992 }
1993 3162
1994 cf::global->attach ( 3163 cf::cede_to_tick;
1995 prio => 10000,
1996 on_cleanup => sub {
1997 db_sync;
1998 }, 3164 }
1999 );
2000}
2001 3165
2002############################################################################# 3166 while (my ($face, $info) = each %$faces) {
2003# the server's main() 3167 next unless $info->{smooth};
2004 3168
2005sub 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 {
2006 open my $fh, "<:utf8", cf::confdir . "/config" 3311 open my $fh, "<:utf8", "$CONFDIR/config"
2007 or return; 3312 or return;
2008 3313
2009 local $/; 3314 local $/;
2010 *CFG = YAML::Syck::Load <$fh>; 3315 *CFG = YAML::Load <$fh>;
2011 3316
2012 $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};
2013 3321
2014 if (exists $CFG{mlockall}) { 3322 if (exists $CFG{mlockall}) {
2015 eval { 3323 eval {
2016 $CFG{mlockall} ? &mlockall : &munlockall 3324 $CFG{mlockall} ? eval "mlockall()" : eval "munlockall()"
2017 and die "WARNING: m(un)lockall failed: $!\n"; 3325 and die "WARNING: m(un)lockall failed: $!\n";
2018 }; 3326 };
2019 warn $@ if $@; 3327 warn $@ if $@;
2020 } 3328 }
2021} 3329}
2022 3330
2023sub main { 3331sub main {
2024 # we must not ever block the main coroutine 3332 # we must not ever block the main coroutine
2025 local $Coro::idle = sub { 3333 local $Coro::idle = sub {
2026 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#
2027 (Coro::unblock_sub { 3335 (async {
2028 Event::one_event; 3336 $Coro::current->{desc} = "IDLE BUG HANDLER";
2029 })->(); 3337 EV::loop EV::LOOP_ONESHOT;
3338 })->prio (Coro::PRIO_MAX);
2030 }; 3339 };
2031 3340
2032 cfg_load; 3341 reload_config;
2033 db_load; 3342 db_init;
2034 load_extensions; 3343 load_extensions;
3344
3345 $TICK_WATCHER->start;
3346 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority
2035 Event::loop; 3347 EV::loop;
2036} 3348}
2037 3349
2038############################################################################# 3350#############################################################################
2039# initialisation 3351# initialisation and cleanup
2040 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
2041sub reload() { 3442sub do_reload_perl() {
2042 # can/must only be called in main 3443 # can/must only be called in main
2043 if ($Coro::current != $Coro::main) { 3444 if ($Coro::current != $Coro::main) {
2044 warn "can only reload from main coroutine\n"; 3445 warn "can only reload from main coroutine";
2045 return; 3446 return;
2046 } 3447 }
2047 3448
2048 warn "reloading..."; 3449 warn "reloading...";
2049 3450
2050 my $guard = freeze_mainloop; 3451 warn "entering sync_job";
3452
3453 cf::sync_job {
3454 cf::write_runtime; # external watchdog should not bark
2051 cf::emergency_save; 3455 cf::emergency_save;
3456 cf::write_runtime; # external watchdog should not bark
2052 3457
2053 eval { 3458 warn "syncing database to disk";
3459 BDB::db_env_txn_checkpoint $DB_ENV;
3460
2054 # 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
2055 3462
2056 # cancel all watchers 3463 warn "flushing outstanding aio requests";
2057 for (Event::all_watchers) { 3464 for (;;) {
2058 $_->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...";
2059 } 3470 }
2060 3471
3472 ++$RELOAD;
3473
2061 # cancel all extension coros 3474 warn "cancelling all extension coros";
2062 $_->cancel for values %EXT_CORO; 3475 $_->cancel for values %EXT_CORO;
2063 %EXT_CORO = (); 3476 %EXT_CORO = ();
2064 3477
2065 # unload all extensions 3478 warn "removing commands";
2066 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) {
2067 warn "unloading <$_>"; 3487 warn "... unloading $pkg";
2068 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: $@";
2069 } 3494 }
2070 3495
3496 warn "... nuking $pkg";
3497 Symbol::delete_package $pkg;
3498 }
3499
2071 # unload all modules loaded from $LIBDIR 3500 warn "unloading all perl modules loaded from $LIBDIR";
2072 while (my ($k, $v) = each %INC) { 3501 while (my ($k, $v) = each %INC) {
2073 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/; 3502 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
2074 3503
2075 warn "removing <$k>"; 3504 warn "... unloading $k";
2076 delete $INC{$k}; 3505 delete $INC{$k};
2077 3506
2078 $k =~ s/\.pm$//; 3507 $k =~ s/\.pm$//;
2079 $k =~ s/\//::/g; 3508 $k =~ s/\//::/g;
2080 3509
… …
2083 } 3512 }
2084 3513
2085 Symbol::delete_package $k; 3514 Symbol::delete_package $k;
2086 } 3515 }
2087 3516
2088 # sync database to disk
2089 cf::db_sync;
2090 IO::AIO::flush;
2091
2092 # get rid of safe::, as good as possible 3517 warn "getting rid of safe::, as good as possible";
2093 Symbol::delete_package "safe::$_" 3518 Symbol::delete_package "safe::$_"
2094 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);
2095 3520
2096 # remove register_script_function callbacks
2097 # TODO
2098
2099 # unload cf.pm "a bit" 3521 warn "unloading cf.pm \"a bit\"";
2100 delete $INC{"cf.pm"}; 3522 delete $INC{"cf.pm"};
3523 delete $INC{"cf/pod.pm"};
2101 3524
2102 # don't, removes xs symbols, too, 3525 # don't, removes xs symbols, too,
2103 # and global variables created in xs 3526 # and global variables created in xs
2104 #Symbol::delete_package __PACKAGE__; 3527 #Symbol::delete_package __PACKAGE__;
2105 3528
2106 # reload cf.pm 3529 warn "unload completed, starting to reload now";
3530
2107 warn "reloading cf.pm"; 3531 warn "reloading cf.pm";
2108 require cf; 3532 require cf;
2109 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 3533 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
2110 3534
2111 # load config and database again 3535 warn "loading config and database again";
2112 cf::cfg_load; 3536 cf::reload_config;
2113 cf::db_load;
2114 3537
2115 # load extensions
2116 warn "load extensions"; 3538 warn "loading extensions";
2117 cf::load_extensions; 3539 cf::load_extensions;
2118 3540
2119 # reattach attachments to objects 3541 warn "reattaching attachments to objects/players";
2120 warn "reattach"; 3542 _global_reattach; # objects, sockets
2121 _global_reattach; 3543 warn "reattaching attachments to maps";
2122 }; 3544 reattach $_ for values %MAP;
3545 warn "reattaching attachments to players";
3546 reattach $_ for values %PLAYER;
2123 3547
2124 if ($@) { 3548 warn "leaving sync_job";
3549
3550 1
3551 } or do {
2125 warn $@; 3552 warn $@;
2126 warn "error while reloading, exiting."; 3553 warn "error while reloading, exiting.";
2127 exit 1; 3554 exit 1;
2128 } 3555 };
2129 3556
2130 warn "reloaded successfully"; 3557 warn "reloaded";
2131}; 3558};
2132 3559
2133############################################################################# 3560our $RELOAD_WATCHER; # used only during reload
2134 3561
2135unless ($LINK_MAP) { 3562sub reload_perl() {
2136 $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.
2137 3565
2138 $LINK_MAP->width (41); 3566 $RELOAD_WATCHER ||= EV::timer 0, 0, sub {
2139 $LINK_MAP->height (41); 3567 undef $RELOAD_WATCHER;
2140 $LINK_MAP->alloc; 3568 do_reload_perl;
2141 $LINK_MAP->path ("{link}"); 3569 };
2142 $LINK_MAP->{path} = bless { path => "{link}" }, "cf::path";
2143 $LINK_MAP->in_memory (MAP_IN_MEMORY);
2144
2145 # dirty hack because... archetypes are not yet loaded
2146 Event->timer (
2147 after => 2,
2148 cb => sub {
2149 $_[0]->w->cancel;
2150
2151 # provide some exits "home"
2152 my $exit = cf::object::new "exit";
2153
2154 $exit->slaying ($EMERGENCY_POSITION->[0]);
2155 $exit->stats->hp ($EMERGENCY_POSITION->[1]);
2156 $exit->stats->sp ($EMERGENCY_POSITION->[2]);
2157
2158 $LINK_MAP->insert ($exit->clone, 19, 19);
2159 $LINK_MAP->insert ($exit->clone, 19, 20);
2160 $LINK_MAP->insert ($exit->clone, 19, 21);
2161 $LINK_MAP->insert ($exit->clone, 20, 19);
2162 $LINK_MAP->insert ($exit->clone, 20, 21);
2163 $LINK_MAP->insert ($exit->clone, 21, 19);
2164 $LINK_MAP->insert ($exit->clone, 21, 20);
2165 $LINK_MAP->insert ($exit->clone, 21, 21);
2166
2167 $exit->destroy;
2168 });
2169
2170 $LINK_MAP->{deny_save} = 1;
2171 $LINK_MAP->{deny_reset} = 1;
2172
2173 $cf::MAP{$LINK_MAP->path} = $LINK_MAP;
2174} 3570}
2175
2176register "<global>", __PACKAGE__;
2177 3571
2178register_command "reload" => sub { 3572register_command "reload" => sub {
2179 my ($who, $arg) = @_; 3573 my ($who, $arg) = @_;
2180 3574
2181 if ($who->flag (FLAG_WIZ)) { 3575 if ($who->flag (FLAG_WIZ)) {
2182 $who->message ("start of reload.");
2183 reload;
2184 $who->message ("end of reload."); 3576 $who->message ("reloading server.");
3577 async {
3578 $Coro::current->{desc} = "perl_reload";
3579 reload_perl;
3580 };
2185 } 3581 }
2186}; 3582};
2187 3583
2188unshift @INC, $LIBDIR; 3584unshift @INC, $LIBDIR;
2189 3585
2190$TICK_WATCHER = Event->timer ( 3586my $bug_warning = 0;
2191 reentrant => 0, 3587
2192 prio => 0, 3588our @WAIT_FOR_TICK;
2193 at => $NEXT_TICK || $TICK, 3589our @WAIT_FOR_TICK_BEGIN;
2194 data => WF_AUTOCANCEL, 3590
2195 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
2196 cf::server_tick; # one server iteration 3618 cf::server_tick; # one server iteration
3619
2197 $RUNTIME += $TICK; 3620 $RUNTIME += $TICK;
2198 $NEXT_TICK += $TICK; 3621 $NEXT_TICK = $_[0]->at;
2199 3622
2200 # if we are delayed by four ticks or more, skip them all 3623 if ($NOW >= $NEXT_RUNTIME_WRITE) {
2201 $NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4; 3624 $NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.;
2202 3625 Coro::async_pool {
2203 $TICK_WATCHER->at ($NEXT_TICK); 3626 $Coro::current->{desc} = "runtime saver";
2204 $TICK_WATCHER->start;
2205 },
2206);
2207
2208IO::AIO::max_poll_time $TICK * 0.2;
2209
2210Event->io (
2211 fd => IO::AIO::poll_fileno,
2212 poll => 'r',
2213 prio => 5,
2214 data => WF_AUTOCANCEL,
2215 cb => \&IO::AIO::poll_cb,
2216);
2217
2218Event->timer (
2219 data => WF_AUTOCANCEL,
2220 after => 0,
2221 interval => 10,
2222 cb => sub {
2223 (Coro::unblock_sub {
2224 write_runtime 3627 write_runtime
2225 or warn "ERROR: unable to write runtime file: $!"; 3628 or warn "ERROR: unable to write runtime file: $!";
2226 })->(); 3629 };
2227 }, 3630 }
2228); 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;
2229 3737
2230END { cf::emergency_save } 3738END { cf::emergency_save }
2231 3739
22321 37401
2233 3741

Diff Legend

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