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.92 by root, Thu Dec 21 06:42:28 2006 UTC vs.
Revision 1.131 by root, Thu Jan 4 00:53:54 2007 UTC

1package cf; 1package cf;
2
3use utf8;
4use strict;
2 5
3use Symbol; 6use Symbol;
4use List::Util; 7use List::Util;
5use Storable; 8use Storable;
6use Opcode; 9use Opcode;
7use Safe; 10use Safe;
8use Safe::Hole; 11use Safe::Hole;
9 12
13use Coro 3.3 ();
14use Coro::Event;
15use Coro::Timer;
16use Coro::Signal;
17use Coro::Semaphore;
18use Coro::AIO;
19
20use Digest::MD5;
21use Fcntl;
10use IO::AIO (); 22use IO::AIO 2.31 ();
11use YAML::Syck (); 23use YAML::Syck ();
12use Time::HiRes; 24use Time::HiRes;
13use Event; 25
14$Event::Eval = 1; # no idea why this is required, but it is 26use Event; $Event::Eval = 1; # no idea why this is required, but it is
15 27
16# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode? 28# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode?
17$YAML::Syck::ImplicitUnicode = 1; 29$YAML::Syck::ImplicitUnicode = 1;
18 30
19use strict; 31$Coro::main->prio (2); # run main coroutine ("the server") with very high priority
20 32
21sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload 33sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
22 34
23our %COMMAND = (); 35our %COMMAND = ();
24our %COMMAND_TIME = (); 36our %COMMAND_TIME = ();
25our %EXTCMD = (); 37our %EXTCMD = ();
26 38
27_init_vars;
28
29our @EVENT; 39our @EVENT;
30our $LIBDIR = datadir . "/ext"; 40our $LIBDIR = datadir . "/ext";
31 41
32our $TICK = MAX_TIME * 1e-6; 42our $TICK = MAX_TIME * 1e-6;
33our $TICK_WATCHER; 43our $TICK_WATCHER;
34our $NEXT_TICK; 44our $NEXT_TICK;
45our $NOW;
35 46
36our %CFG; 47our %CFG;
37 48
38our $UPTIME; $UPTIME ||= time; 49our $UPTIME; $UPTIME ||= time;
50our $RUNTIME;
51
52our %MAP; # all maps
53our $LINK_MAP; # the special {link} map
54our $FREEZE;
55our $RANDOM_MAPS = cf::localdir . "/random";
56our %EXT_CORO;
57
58binmode STDOUT;
59binmode STDERR;
60
61# read virtual server time, if available
62unless ($RUNTIME || !-e cf::localdir . "/runtime") {
63 open my $fh, "<", cf::localdir . "/runtime"
64 or die "unable to read runtime file: $!";
65 $RUNTIME = <$fh> + 0.;
66}
67
68mkdir cf::localdir;
69mkdir cf::localdir . "/" . cf::playerdir;
70mkdir cf::localdir . "/" . cf::tmpdir;
71mkdir cf::localdir . "/" . cf::uniquedir;
72mkdir $RANDOM_MAPS;
73
74# a special map that is always available
75our $LINK_MAP;
76our $EMERGENCY_POSITION;
39 77
40############################################################################# 78#############################################################################
41 79
42=head2 GLOBAL VARIABLES 80=head2 GLOBAL VARIABLES
43 81
44=over 4 82=over 4
45 83
46=item $cf::UPTIME 84=item $cf::UPTIME
47 85
48The timestamp of the server start (so not actually an uptime). 86The timestamp of the server start (so not actually an uptime).
87
88=item $cf::RUNTIME
89
90The time this server has run, starts at 0 and is increased by $cf::TICK on
91every server tick.
49 92
50=item $cf::LIBDIR 93=item $cf::LIBDIR
51 94
52The perl library directory, where extensions and cf-specific modules can 95The perl library directory, where extensions and cf-specific modules can
53be found. It will be added to C<@INC> automatically. 96be found. It will be added to C<@INC> automatically.
97
98=item $cf::NOW
99
100The time of the last (current) server tick.
54 101
55=item $cf::TICK 102=item $cf::TICK
56 103
57The interval between server ticks, in seconds. 104The interval between server ticks, in seconds.
58 105
66=cut 113=cut
67 114
68BEGIN { 115BEGIN {
69 *CORE::GLOBAL::warn = sub { 116 *CORE::GLOBAL::warn = sub {
70 my $msg = join "", @_; 117 my $msg = join "", @_;
118 utf8::encode $msg;
119
71 $msg .= "\n" 120 $msg .= "\n"
72 unless $msg =~ /\n$/; 121 unless $msg =~ /\n$/;
73 122
74 print STDERR "cfperl: $msg";
75 LOG llevError, "cfperl: $msg"; 123 LOG llevError, "cfperl: $msg";
76 }; 124 };
77} 125}
78 126
127@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
128@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';
129@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable';
130@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable';
131@safe::cf::map::ISA = @cf::map::ISA = 'cf::attachable';
79@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object'; 132@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object';
80 133
81# we bless all objects into (empty) derived classes to force a method lookup 134# we bless all objects into (empty) derived classes to force a method lookup
82# within the Safe compartment. 135# within the Safe compartment.
83for my $pkg (qw( 136for my $pkg (qw(
137 cf::global cf::attachable
84 cf::object cf::object::player 138 cf::object cf::object::player
85 cf::client cf::player 139 cf::client cf::player
86 cf::arch cf::living 140 cf::arch cf::living
87 cf::map cf::party cf::region 141 cf::map cf::party cf::region
88)) { 142)) {
126sub to_json($) { 180sub to_json($) {
127 $JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs 181 $JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs
128 JSON::Syck::Dump $_[0] 182 JSON::Syck::Dump $_[0]
129} 183}
130 184
185=item my $guard = cf::guard { BLOCK }
186
187Run the given callback when the guard object gets destroyed (useful for
188coroutine cancellations).
189
190You can call C<< ->cancel >> on the guard object to stop the block from
191being executed.
192
193=cut
194
195sub guard(&) {
196 bless \(my $cb = $_[0]), cf::guard::;
197}
198
199sub cf::guard::cancel {
200 ${$_[0]} = sub { };
201}
202
203sub cf::guard::DESTROY {
204 ${$_[0]}->();
205}
206
207=item cf::lock_wait $string
208
209Wait until the given lock is available. See cf::lock_acquire.
210
211=item my $lock = cf::lock_acquire $string
212
213Wait until the given lock is available and then acquires it and returns
214a guard object. If the guard object gets destroyed (goes out of scope,
215for example when the coroutine gets canceled), the lock is automatically
216returned.
217
218Lock names should begin with a unique identifier (for example, find_map
219uses map_find and load_map uses map_load).
220
221=cut
222
223our %LOCK;
224
225sub lock_wait($) {
226 my ($key) = @_;
227
228 # wait for lock, if any
229 while ($LOCK{$key}) {
230 push @{ $LOCK{$key} }, $Coro::current;
231 Coro::schedule;
232 }
233}
234
235sub lock_acquire($) {
236 my ($key) = @_;
237
238 # wait, to be sure we are not locked
239 lock_wait $key;
240
241 $LOCK{$key} = [];
242
243 cf::guard {
244 # wake up all waiters, to be on the safe side
245 $_->ready for @{ delete $LOCK{$key} };
246 }
247}
248
249=item cf::async { BLOCK }
250
251Like C<Coro::async>, but runs the given BLOCK in an eval and only logs the
252error instead of exiting the server in case of a problem.
253
254=cut
255
256sub async(&) {
257 my ($cb) = @_;
258
259 Coro::async {
260 eval { $cb->() };
261 warn $@ if $@;
262 }
263}
264
265=item cf::sync_job { BLOCK }
266
267The design of crossfire+ requires that the main coro ($Coro::main) is
268always able to handle events or runnable, as crossfire+ is only partly
269reentrant. Thus "blocking" it by e.g. waiting for I/O is not acceptable.
270
271If it must be done, put the blocking parts into C<sync_job>. This will run
272the given BLOCK in another coroutine while waiting for the result. The
273server will be frozen during this time, so the block should either finish
274fast or be very important.
275
276=cut
277
278sub sync_job(&) {
279 my ($job) = @_;
280
281 if ($Coro::current == $Coro::main) {
282 # this is the main coro, too bad, we have to block
283 # till the operation succeeds, freezing the server :/
284
285 # TODO: use suspend/resume instead
286 # (but this is cancel-safe)
287 local $FREEZE = 1;
288
289 my $busy = 1;
290 my @res;
291
292 (Coro::async {
293 @res = eval { $job->() };
294 warn $@ if $@;
295 undef $busy;
296 })->prio (Coro::PRIO_MAX);
297
298 while ($busy) {
299 Coro::cede_notself;
300 Event::one_event unless Coro::nready;
301 }
302
303 wantarray ? @res : $res[0]
304 } else {
305 # we are in another coroutine, how wonderful, everything just works
306
307 $job->()
308 }
309}
310
311=item $coro = cf::coro { BLOCK }
312
313Creates and returns a new coro. This coro is automcatially being canceled
314when the extension calling this is being unloaded.
315
316=cut
317
318sub coro(&) {
319 my $cb = shift;
320
321 my $coro = &cf::async ($cb);
322
323 $coro->on_destroy (sub {
324 delete $EXT_CORO{$coro+0};
325 });
326 $EXT_CORO{$coro+0} = $coro;
327
328 $coro
329}
330
331sub write_runtime {
332 my $runtime = cf::localdir . "/runtime";
333
334 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644
335 or return;
336
337 my $value = $cf::RUNTIME + 1 + 10; # 10 is the runtime save interval, for a monotonic clock
338 (aio_write $fh, 0, (length $value), $value, 0) <= 0
339 and return;
340
341 aio_fsync $fh
342 and return;
343
344 close $fh
345 or return;
346
347 aio_rename "$runtime~", $runtime
348 and return;
349
350 1
351}
352
131=back 353=back
132 354
133=cut 355=cut
134 356
135############################################################################# 357#############################################################################
136 358
137=head2 EVENTS AND OBJECT ATTACHMENTS 359package cf::path;
360
361sub new {
362 my ($class, $path, $base) = @_;
363
364 $path = $path->as_string if ref $path;
365
366 my $self = bless { }, $class;
367
368 # {... are special paths that are not touched
369 # ?xxx/... are special absolute paths
370 # ?random/... random maps
371 # /! non-realised random map exit
372 # /... normal maps
373 # ~/... per-player maps without a specific player (DO NOT USE)
374 # ~user/... per-player map of a specific user
375
376 if ($path =~ /^{/) {
377 # fine as it is
378 } elsif ($path =~ s{^\?random/}{}) {
379 Coro::AIO::aio_load "$cf::RANDOM_MAPS/$path.meta", my $data;
380 $self->{random} = cf::from_json $data;
381 } else {
382 if ($path =~ s{^~([^/]+)?}{}) {
383 $self->{user_rel} = 1;
384
385 if (defined $1) {
386 $self->{user} = $1;
387 } elsif ($base =~ m{^~([^/]+)/}) {
388 $self->{user} = $1;
389 } else {
390 warn "cannot resolve user-relative path without user <$path,$base>\n";
391 }
392 } elsif ($path =~ /^\//) {
393 # already absolute
394 } else {
395 $base =~ s{[^/]+/?$}{};
396 return $class->new ("$base/$path");
397 }
398
399 for ($path) {
400 redo if s{/\.?/}{/};
401 redo if s{/[^/]+/\.\./}{/};
402 }
403 }
404
405 $self->{path} = $path;
406
407 $self
408}
409
410# the name / primary key / in-game path
411sub as_string {
412 my ($self) = @_;
413
414 $self->{user_rel} ? "~$self->{user}$self->{path}"
415 : $self->{random} ? "?random/$self->{path}"
416 : $self->{path}
417}
418
419# the displayed name, this is a one way mapping
420sub visible_name {
421 my ($self) = @_;
422
423# if (my $rmp = $self->{random}) {
424# # todo: be more intelligent about this
425# "?random/$rmp->{origin_map}+$rmp->{origin_x}+$rmp->{origin_y}/$rmp->{dungeon_level}"
426# } else {
427 $self->as_string
428# }
429}
430
431# escape the /'s in the path
432sub _escaped_path {
433 # ∕ is U+2215
434 (my $path = $_[0]{path}) =~ s/\//∕/g;
435 $path
436}
437
438# the original (read-only) location
439sub load_path {
440 my ($self) = @_;
441
442 sprintf "%s/%s/%s", cf::datadir, cf::mapdir, $self->{path}
443}
444
445# the temporary/swap location
446sub save_path {
447 my ($self) = @_;
448
449 $self->{user_rel} ? sprintf "%s/%s/%s/%s", cf::localdir, cf::playerdir, $self->{user}, $self->_escaped_path
450 : $self->{random} ? sprintf "%s/%s", $RANDOM_MAPS, $self->{path}
451 : sprintf "%s/%s/%s", cf::localdir, cf::tmpdir, $self->_escaped_path
452}
453
454# the unique path, might be eq to save_path
455sub uniq_path {
456 my ($self) = @_;
457
458 $self->{user_rel} || $self->{random}
459 ? undef
460 : sprintf "%s/%s/%s", cf::localdir, cf::uniquedir, $self->_escaped_path
461}
462
463# return random map parameters, or undef
464sub random_map_params {
465 my ($self) = @_;
466
467 $self->{random}
468}
469
470# this is somewhat ugly, but style maps do need special treatment
471sub is_style_map {
472 $_[0]{path} =~ m{^/styles/}
473}
474
475package cf;
476
477#############################################################################
478
479=head2 ATTACHABLE OBJECTS
480
481Many objects in crossfire are so-called attachable objects. That means you can
482attach callbacks/event handlers (a collection of which is called an "attachment")
483to it. All such attachable objects support the following methods.
484
485In the following description, CLASS can be any of C<global>, C<object>
486C<player>, C<client> or C<map> (i.e. the attachable objects in
487crossfire+).
138 488
139=over 4 489=over 4
140 490
141=item $object->attach ($attachment, key => $value...)
142
143=item $object->detach ($attachment)
144
145Attach/detach a pre-registered attachment to an object.
146
147=item $player->attach ($attachment, key => $value...)
148
149=item $player->detach ($attachment)
150
151Attach/detach a pre-registered attachment to a player.
152
153=item $map->attach ($attachment, key => $value...)
154
155=item $map->detach ($attachment)
156
157Attach/detach a pre-registered attachment to a client.
158
159=item $client->attach ($attachment, key => $value...) 491=item $attachable->attach ($attachment, key => $value...)
160 492
161=item $client->detach ($attachment) 493=item $attachable->detach ($attachment)
162 494
163Attach/detach a pre-registered attachment to a map. 495Attach/detach a pre-registered attachment to a specific object and give it
496the specified key/value pairs as arguments.
164 497
165=item $bool = $object->attached ($name) 498Example, attach a minesweeper attachment to the given object, making it a
49910x10 minesweeper game:
166 500
167=item $bool = $player->attached ($name) 501 $obj->attach (minesweeper => width => 10, height => 10);
168 502
169=item $bool = $client->attached ($name) 503=item $bool = $attachable->attached ($name)
170
171=item $bool = $map->attached ($name)
172 504
173Checks wether the named attachment is currently attached to the object. 505Checks wether the named attachment is currently attached to the object.
174 506
175=item cf::attach_global ... 507=item cf::CLASS->attach ...
176 508
177Attach handlers for global events. 509=item cf::CLASS->detach ...
178 510
179This and all following C<attach_*>-functions expect any number of the 511Define an anonymous attachment and attach it to all objects of the given
180following handler/hook descriptions: 512CLASS. See the next function for an explanation of its arguments.
513
514You can attach to global events by using the C<cf::global> class.
515
516Example, log all player logins:
517
518 cf::player->attach (
519 on_login => sub {
520 my ($pl) = @_;
521 ...
522 },
523 );
524
525Example, attach to the jeweler skill:
526
527 cf::object->attach (
528 type => cf::SKILL,
529 subtype => cf::SK_JEWELER,
530 on_use_skill => sub {
531 my ($sk, $ob, $part, $dir, $msg) = @_;
532 ...
533 },
534 );
535
536=item cf::CLASS::attachment $name, ...
537
538Register an attachment by C<$name> through which attachable objects of the
539given CLASS can refer to this attachment.
540
541Some classes such as crossfire maps and objects can specify attachments
542that are attached at load/instantiate time, thus the need for a name.
543
544These calls expect any number of the following handler/hook descriptions:
181 545
182=over 4 546=over 4
183 547
184=item prio => $number 548=item prio => $number
185 549
187by another C<prio> setting). Lower priority handlers get executed 551by another C<prio> setting). Lower priority handlers get executed
188earlier. The default priority is C<0>, and many built-in handlers are 552earlier. The default priority is C<0>, and many built-in handlers are
189registered at priority C<-1000>, so lower priorities should not be used 553registered at priority C<-1000>, so lower priorities should not be used
190unless you know what you are doing. 554unless you know what you are doing.
191 555
556=item type => $type
557
558(Only for C<< cf::object->attach >> calls), limits the attachment to the
559given type of objects only (the additional parameter C<subtype> can be
560used to further limit to the given subtype).
561
192=item on_I<event> => \&cb 562=item on_I<event> => \&cb
193 563
194Call the given code reference whenever the named event happens (event is 564Call the given code reference whenever the named event happens (event is
195something like C<instantiate>, C<apply>, C<use_skill> and so on, and which 565something like C<instantiate>, C<apply>, C<use_skill> and so on, and which
196handlers are recognised generally depends on the type of object these 566handlers are recognised generally depends on the type of object these
205package and register them. Only handlers for eevents supported by the 575package and register them. Only handlers for eevents supported by the
206object/class are recognised. 576object/class are recognised.
207 577
208=back 578=back
209 579
210=item cf::attach_to_type $object_type, $subtype, ... 580Example, define an attachment called "sockpuppet" that calls the given
581event handler when a monster attacks:
211 582
212Attach handlers for a specific object type (e.g. TRANSPORT) and 583 cf::object::attachment sockpuppet =>
213subtype. If C<$subtype> is zero or undef, matches all objects of the given 584 on_skill_attack => sub {
214type. 585 my ($self, $victim) = @_;
215 586 ...
216=item cf::attach_to_objects ...
217
218Attach handlers to all objects. Do not use this except for debugging or
219very rare events, as handlers are (obviously) called for I<all> objects in
220the game.
221
222=item cf::attach_to_players ...
223
224Attach handlers to all players.
225
226=item cf::attach_to_clients ...
227
228Attach handlers to all players.
229
230=item cf::attach_to_maps ...
231
232Attach handlers to all maps.
233
234=item cf:register_attachment $name, ...
235
236Register an attachment by name through which objects can refer to this
237attachment.
238
239=item cf:register_player_attachment $name, ...
240
241Register an attachment by name through which players can refer to this
242attachment.
243
244=item cf:register_map_attachment $name, ...
245
246Register an attachment by name through which maps can refer to this
247attachment.
248
249=cut
250
251# the following variables are defined in .xs and must not be re-created
252our @CB_GLOBAL = (); # registry for all global events
253our @CB_OBJECT = (); # all objects (should not be used except in emergency)
254our @CB_PLAYER = ();
255our @CB_CLIENT = ();
256our @CB_TYPE = (); # registry for type (cf-object class) based events
257our @CB_MAP = ();
258
259my %attachment;
260
261sub _attach_cb($\%$$$) {
262 my ($registry, $undo, $event, $prio, $cb) = @_;
263
264 use sort 'stable';
265
266 $cb = [$prio, $cb];
267
268 @{$registry->[$event]} = sort
269 { $a->[0] cmp $b->[0] }
270 @{$registry->[$event] || []}, $cb;
271
272 push @{$undo->{cb}}, [$event, $cb];
273}
274
275# attach handles attaching event callbacks
276# the only thing the caller has to do is pass the correct
277# registry (== where the callback attaches to).
278sub _attach(\@$@) {
279 my ($registry, $klass, @arg) = @_;
280
281 my $prio = 0;
282
283 my %undo = (
284 registry => $registry,
285 cb => [],
286 );
287
288 my %cb_id = map +("on_" . lc $EVENT[$_][0], $_) , grep $EVENT[$_][1] == $klass, 0 .. $#EVENT;
289
290 while (@arg) {
291 my $type = shift @arg;
292
293 if ($type eq "prio") {
294 $prio = shift @arg;
295
296 } elsif ($type eq "package") {
297 my $pkg = shift @arg;
298
299 while (my ($name, $id) = each %cb_id) {
300 if (my $cb = $pkg->can ($name)) {
301 _attach_cb $registry, %undo, $id, $prio, $cb;
302 }
303 } 587 }
304
305 } elsif (exists $cb_id{$type}) {
306 _attach_cb $registry, %undo, $cb_id{$type}, $prio, shift @arg;
307
308 } elsif (ref $type) {
309 warn "attaching objects not supported, ignoring.\n";
310
311 } else {
312 shift @arg;
313 warn "attach argument '$type' not supported, ignoring.\n";
314 }
315 }
316
317 \%undo
318}
319
320sub _attach_attachment {
321 my ($obj, $name, %arg) = @_;
322
323 return if exists $obj->{_attachment}{$name};
324
325 my $res;
326
327 if (my $attach = $attachment{$name}) {
328 my $registry = $obj->registry;
329
330 for (@$attach) {
331 my ($klass, @attach) = @$_;
332 $res = _attach @$registry, $klass, @attach;
333 }
334
335 $obj->{$name} = \%arg;
336 } else {
337 warn "object uses attachment '$name' that is not available, postponing.\n";
338 }
339
340 $obj->{_attachment}{$name} = undef;
341
342 $res->{attachment} = $name;
343 $res
344}
345
346*cf::object::attach =
347*cf::player::attach =
348*cf::client::attach =
349*cf::map::attach = sub {
350 my ($obj, $name, %arg) = @_;
351
352 _attach_attachment $obj, $name, %arg;
353};
354
355# all those should be optimised
356*cf::object::detach =
357*cf::player::detach =
358*cf::client::detach =
359*cf::map::detach = sub {
360 my ($obj, $name) = @_;
361
362 delete $obj->{_attachment}{$name};
363 reattach ($obj);
364};
365
366*cf::object::attached =
367*cf::player::attached =
368*cf::client::attached =
369*cf::map::attached = sub {
370 my ($obj, $name) = @_;
371
372 exists $obj->{_attachment}{$name}
373};
374
375sub attach_global {
376 _attach @CB_GLOBAL, KLASS_GLOBAL, @_
377}
378
379sub attach_to_type {
380 my $type = shift;
381 my $subtype = shift;
382
383 _attach @{$CB_TYPE[$type + $subtype * NUM_SUBTYPES]}, KLASS_OBJECT, @_
384}
385
386sub attach_to_objects {
387 _attach @CB_OBJECT, KLASS_OBJECT, @_
388}
389
390sub attach_to_players {
391 _attach @CB_PLAYER, KLASS_PLAYER, @_
392}
393
394sub attach_to_clients {
395 _attach @CB_CLIENT, KLASS_CLIENT, @_
396}
397
398sub attach_to_maps {
399 _attach @CB_MAP, KLASS_MAP, @_
400}
401
402sub register_attachment {
403 my $name = shift;
404
405 $attachment{$name} = [[KLASS_OBJECT, @_]];
406}
407
408sub register_player_attachment {
409 my $name = shift;
410
411 $attachment{$name} = [[KLASS_PLAYER, @_]];
412}
413
414sub register_client_attachment {
415 my $name = shift;
416
417 $attachment{$name} = [[KLASS_CLIENT, @_]];
418}
419
420sub register_map_attachment {
421 my $name = shift;
422
423 $attachment{$name} = [[KLASS_MAP, @_]];
424}
425
426our $override;
427our @invoke_results = (); # referenced from .xs code. TODO: play tricks with reify and mortals?
428
429sub override {
430 $override = 1;
431 @invoke_results = ();
432}
433
434sub do_invoke {
435 my $event = shift;
436 my $callbacks = shift;
437
438 @invoke_results = ();
439
440 local $override;
441
442 for (@$callbacks) {
443 eval { &{$_->[1]} };
444
445 if ($@) {
446 warn "$@";
447 warn "... while processing $EVENT[$event][0](@_) event, skipping processing altogether.\n";
448 override;
449 }
450
451 return 1 if $override;
452 }
453
454 0 588 }
455}
456 589
457=item $bool = cf::invoke EVENT_GLOBAL_XXX, ... 590=item $attachable->valid
458
459=item $bool = $object->invoke (EVENT_OBJECT_XXX, ...)
460
461=item $bool = $player->invoke (EVENT_PLAYER_XXX, ...)
462
463=item $bool = $client->invoke (EVENT_CLIENT_XXX, ...)
464
465=item $bool = $map->invoke (EVENT_MAP_XXX, ...)
466
467Generate a global/object/player/map-specific event with the given arguments.
468
469This API is preliminary (most likely, the EVENT_KLASS_xxx prefix will be
470removed in future versions), and there is no public API to access override
471results (if you must, access C<@cf::invoke_results> directly).
472
473=back
474
475=cut
476
477#############################################################################
478
479=head2 METHODS VALID FOR ALL CORE OBJECTS
480
481=over 4
482
483=item $object->valid, $player->valid, $client->valid, $map->valid
484 591
485Just because you have a perl object does not mean that the corresponding 592Just because you have a perl object does not mean that the corresponding
486C-level object still exists. If you try to access an object that has no 593C-level object still exists. If you try to access an object that has no
487valid C counterpart anymore you get an exception at runtime. This method 594valid C counterpart anymore you get an exception at runtime. This method
488can be used to test for existence of the C object part without causing an 595can be used to test for existence of the C object part without causing an
489exception. 596exception.
490 597
598=cut
599
600# the following variables are defined in .xs and must not be re-created
601our @CB_GLOBAL = (); # registry for all global events
602our @CB_ATTACHABLE = (); # registry for all attachables
603our @CB_OBJECT = (); # all objects (should not be used except in emergency)
604our @CB_PLAYER = ();
605our @CB_CLIENT = ();
606our @CB_TYPE = (); # registry for type (cf-object class) based events
607our @CB_MAP = ();
608
609my %attachment;
610
611sub _attach_cb($$$$) {
612 my ($registry, $event, $prio, $cb) = @_;
613
614 use sort 'stable';
615
616 $cb = [$prio, $cb];
617
618 @{$registry->[$event]} = sort
619 { $a->[0] cmp $b->[0] }
620 @{$registry->[$event] || []}, $cb;
621}
622
623# hack
624my %attachable_klass = map +($_ => 1), KLASS_OBJECT, KLASS_CLIENT, KLASS_PLAYER, KLASS_MAP;
625
626# attach handles attaching event callbacks
627# the only thing the caller has to do is pass the correct
628# registry (== where the callback attaches to).
629sub _attach {
630 my ($registry, $klass, @arg) = @_;
631
632 my $object_type;
633 my $prio = 0;
634 my %cb_id = map +("on_" . lc $EVENT[$_][0], $_) , grep $EVENT[$_][1] == $klass, 0 .. $#EVENT;
635
636 #TODO: get rid of this hack
637 if ($attachable_klass{$klass}) {
638 %cb_id = (%cb_id, map +("on_" . lc $EVENT[$_][0], $_) , grep $EVENT[$_][1] == KLASS_ATTACHABLE, 0 .. $#EVENT);
639 }
640
641 while (@arg) {
642 my $type = shift @arg;
643
644 if ($type eq "prio") {
645 $prio = shift @arg;
646
647 } elsif ($type eq "type") {
648 $object_type = shift @arg;
649 $registry = $CB_TYPE[$object_type] ||= [];
650
651 } elsif ($type eq "subtype") {
652 defined $object_type or Carp::croak "subtype specified without type";
653 my $object_subtype = shift @arg;
654 $registry = $CB_TYPE[$object_type + $object_subtype * NUM_SUBTYPES] ||= [];
655
656 } elsif ($type eq "package") {
657 my $pkg = shift @arg;
658
659 while (my ($name, $id) = each %cb_id) {
660 if (my $cb = $pkg->can ($name)) {
661 _attach_cb $registry, $id, $prio, $cb;
662 }
663 }
664
665 } elsif (exists $cb_id{$type}) {
666 _attach_cb $registry, $cb_id{$type}, $prio, shift @arg;
667
668 } elsif (ref $type) {
669 warn "attaching objects not supported, ignoring.\n";
670
671 } else {
672 shift @arg;
673 warn "attach argument '$type' not supported, ignoring.\n";
674 }
675 }
676}
677
678sub _object_attach {
679 my ($obj, $name, %arg) = @_;
680
681 return if exists $obj->{_attachment}{$name};
682
683 if (my $attach = $attachment{$name}) {
684 my $registry = $obj->registry;
685
686 for (@$attach) {
687 my ($klass, @attach) = @$_;
688 _attach $registry, $klass, @attach;
689 }
690
691 $obj->{$name} = \%arg;
692 } else {
693 warn "object uses attachment '$name' that is not available, postponing.\n";
694 }
695
696 $obj->{_attachment}{$name} = undef;
697}
698
699sub cf::attachable::attach {
700 if (ref $_[0]) {
701 _object_attach @_;
702 } else {
703 _attach shift->_attach_registry, @_;
704 }
705};
706
707# all those should be optimised
708sub cf::attachable::detach {
709 my ($obj, $name) = @_;
710
711 if (ref $obj) {
712 delete $obj->{_attachment}{$name};
713 reattach ($obj);
714 } else {
715 Carp::croak "cannot, currently, detach class attachments";
716 }
717};
718
719sub cf::attachable::attached {
720 my ($obj, $name) = @_;
721
722 exists $obj->{_attachment}{$name}
723}
724
725for my $klass (qw(ATTACHABLE GLOBAL OBJECT PLAYER CLIENT MAP)) {
726 eval "#line " . __LINE__ . " 'cf.pm'
727 sub cf::\L$klass\E::_attach_registry {
728 (\\\@CB_$klass, KLASS_$klass)
729 }
730
731 sub cf::\L$klass\E::attachment {
732 my \$name = shift;
733
734 \$attachment{\$name} = [[KLASS_$klass, \@_]];
735 }
736 ";
737 die if $@;
738}
739
740our $override;
741our @invoke_results = (); # referenced from .xs code. TODO: play tricks with reify and mortals?
742
743sub override {
744 $override = 1;
745 @invoke_results = ();
746}
747
748sub do_invoke {
749 my $event = shift;
750 my $callbacks = shift;
751
752 @invoke_results = ();
753
754 local $override;
755
756 for (@$callbacks) {
757 eval { &{$_->[1]} };
758
759 if ($@) {
760 warn "$@";
761 warn "... while processing $EVENT[$event][0](@_) event, skipping processing altogether.\n";
762 override;
763 }
764
765 return 1 if $override;
766 }
767
768 0
769}
770
771=item $bool = cf::global::invoke (EVENT_CLASS_XXX, ...)
772
773=item $bool = $attachable->invoke (EVENT_CLASS_XXX, ...)
774
775Generate an object-specific event with the given arguments.
776
777This API is preliminary (most likely, the EVENT_CLASS_xxx prefix will be
778removed in future versions), and there is no public API to access override
779results (if you must, access C<@cf::invoke_results> directly).
780
491=back 781=back
492 782
493=cut 783=cut
494
495*cf::object::valid =
496*cf::player::valid =
497*cf::client::valid =
498*cf::map::valid = \&cf::_valid;
499 784
500############################################################################# 785#############################################################################
501# object support 786# object support
502 787
503sub instantiate {
504 my ($obj, $data) = @_;
505
506 $data = from_json $data;
507
508 for (@$data) {
509 my ($name, $args) = @$_;
510
511 $obj->attach ($name, %{$args || {} });
512 }
513}
514
515# basically do the same as instantiate, without calling instantiate
516sub reattach { 788sub reattach {
789 # basically do the same as instantiate, without calling instantiate
517 my ($obj) = @_; 790 my ($obj) = @_;
791
518 my $registry = $obj->registry; 792 my $registry = $obj->registry;
519 793
520 @$registry = (); 794 @$registry = ();
521 795
522 delete $obj->{_attachment} unless scalar keys %{ $obj->{_attachment} || {} }; 796 delete $obj->{_attachment} unless scalar keys %{ $obj->{_attachment} || {} };
523 797
524 for my $name (keys %{ $obj->{_attachment} || {} }) { 798 for my $name (keys %{ $obj->{_attachment} || {} }) {
525 if (my $attach = $attachment{$name}) { 799 if (my $attach = $attachment{$name}) {
526 for (@$attach) { 800 for (@$attach) {
527 my ($klass, @attach) = @$_; 801 my ($klass, @attach) = @$_;
528 _attach @$registry, $klass, @attach; 802 _attach $registry, $klass, @attach;
529 } 803 }
530 } else { 804 } else {
531 warn "object uses attachment '$name' that is not available, postponing.\n"; 805 warn "object uses attachment '$name' that is not available, postponing.\n";
532 } 806 }
533 } 807 }
534} 808}
535 809
536sub object_freezer_save { 810cf::attachable->attach (
537 my ($filename, $rdata, $objs) = @_;
538
539 if (length $$rdata) {
540 warn sprintf "saving %s (%d,%d)\n",
541 $filename, length $$rdata, scalar @$objs;
542
543 if (open my $fh, ">:raw", "$filename~") {
544 chmod SAVE_MODE, $fh;
545 syswrite $fh, $$rdata;
546 close $fh;
547
548 if (@$objs && open my $fh, ">:raw", "$filename.pst~") {
549 chmod SAVE_MODE, $fh;
550 syswrite $fh, Storable::nfreeze { version => 1, objs => $objs };
551 close $fh;
552 rename "$filename.pst~", "$filename.pst";
553 } else {
554 unlink "$filename.pst";
555 }
556
557 rename "$filename~", $filename;
558 } else {
559 warn "FATAL: $filename~: $!\n";
560 }
561 } else {
562 unlink $filename;
563 unlink "$filename.pst";
564 }
565}
566
567sub object_freezer_as_string {
568 my ($rdata, $objs) = @_;
569
570 use Data::Dumper;
571
572 $$rdata . Dumper $objs
573}
574
575sub object_thawer_load {
576 my ($filename) = @_;
577
578 local $/;
579
580 my $av;
581
582 #TODO: use sysread etc.
583 if (open my $data, "<:raw:perlio", $filename) {
584 $data = <$data>;
585 if (open my $pst, "<:raw:perlio", "$filename.pst") {
586 $av = eval { (Storable::thaw <$pst>)->{objs} };
587 }
588 return ($data, $av);
589 }
590
591 ()
592}
593
594attach_to_objects
595 prio => -1000000, 811 prio => -1000000,
812 on_instantiate => sub {
813 my ($obj, $data) = @_;
814
815 $data = from_json $data;
816
817 for (@$data) {
818 my ($name, $args) = @$_;
819
820 $obj->attach ($name, %{$args || {} });
821 }
822 },
823 on_reattach => \&reattach,
596 on_clone => sub { 824 on_clone => sub {
597 my ($src, $dst) = @_; 825 my ($src, $dst) = @_;
598 826
599 @{$dst->registry} = @{$src->registry}; 827 @{$dst->registry} = @{$src->registry};
600 828
601 %$dst = %$src; 829 %$dst = %$src;
602 830
603 %{$dst->{_attachment}} = %{$src->{_attachment}} 831 %{$dst->{_attachment}} = %{$src->{_attachment}}
604 if exists $src->{_attachment}; 832 if exists $src->{_attachment};
605 }, 833 },
606; 834);
835
836sub object_freezer_save {
837 my ($filename, $rdata, $objs) = @_;
838
839 sync_job {
840 if (length $$rdata) {
841 warn sprintf "saving %s (%d,%d)\n",
842 $filename, length $$rdata, scalar @$objs;
843
844 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
845 chmod SAVE_MODE, $fh;
846 aio_write $fh, 0, (length $$rdata), $$rdata, 0;
847 aio_fsync $fh;
848 close $fh;
849
850 if (@$objs) {
851 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) {
852 chmod SAVE_MODE, $fh;
853 my $data = Storable::nfreeze { version => 1, objs => $objs };
854 aio_write $fh, 0, (length $data), $data, 0;
855 aio_fsync $fh;
856 close $fh;
857 aio_rename "$filename.pst~", "$filename.pst";
858 }
859 } else {
860 aio_unlink "$filename.pst";
861 }
862
863 aio_rename "$filename~", $filename;
864 } else {
865 warn "FATAL: $filename~: $!\n";
866 }
867 } else {
868 aio_unlink $filename;
869 aio_unlink "$filename.pst";
870 }
871 }
872}
873
874sub object_freezer_as_string {
875 my ($rdata, $objs) = @_;
876
877 use Data::Dumper;
878
879 $$rdata . Dumper $objs
880}
881
882sub object_thawer_load {
883 my ($filename) = @_;
884
885 my ($data, $av);
886
887 (aio_load $filename, $data) >= 0
888 or return;
889
890 unless (aio_stat "$filename.pst") {
891 (aio_load "$filename.pst", $av) >= 0
892 or return;
893 $av = eval { (Storable::thaw $av)->{objs} };
894 }
895
896 warn sprintf "loading %s (%d)\n",
897 $filename, length $data, scalar @{$av || []};#d#
898 return ($data, $av);
899}
607 900
608############################################################################# 901#############################################################################
609# command handling &c 902# command handling &c
610 903
611=item cf::register_command $name => \&callback($ob,$args); 904=item cf::register_command $name => \&callback($ob,$args);
640 #warn "registering extcmd '$name' to '$caller'"; 933 #warn "registering extcmd '$name' to '$caller'";
641 934
642 $EXTCMD{$name} = [$cb, $caller]; 935 $EXTCMD{$name} = [$cb, $caller];
643} 936}
644 937
645attach_to_players 938cf::player->attach (
646 on_command => sub { 939 on_command => sub {
647 my ($pl, $name, $params) = @_; 940 my ($pl, $name, $params) = @_;
648 941
649 my $cb = $COMMAND{$name} 942 my $cb = $COMMAND{$name}
650 or return; 943 or return;
670 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n"; 963 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
671 } 964 }
672 965
673 cf::override; 966 cf::override;
674 }, 967 },
675; 968);
676 969
677sub register { 970sub register {
678 my ($base, $pkg) = @_; 971 my ($base, $pkg) = @_;
679 972
680 #TODO 973 #TODO
770 defined $path or return; 1063 defined $path or return;
771 1064
772 unlink "$path.pst"; 1065 unlink "$path.pst";
773}; 1066};
774 1067
775attach_to_maps prio => -10000, package => cf::mapsupport::; 1068cf::map->attach (prio => -10000, package => cf::mapsupport::);
776 1069
777############################################################################# 1070#############################################################################
778# load/save perl data associated with player->ob objects 1071# load/save perl data associated with player->ob objects
779 1072
780sub all_objects(@) { 1073sub all_objects(@) {
781 @_, map all_objects ($_->inv), @_ 1074 @_, map all_objects ($_->inv), @_
782} 1075}
783 1076
784# TODO: compatibility cruft, remove when no longer needed 1077# TODO: compatibility cruft, remove when no longer needed
785attach_to_players 1078cf::player->attach (
786 on_load => sub { 1079 on_load => sub {
787 my ($pl, $path) = @_; 1080 my ($pl, $path) = @_;
788 1081
789 for my $o (all_objects $pl->ob) { 1082 for my $o (all_objects $pl->ob) {
790 if (my $value = $o->get_ob_key_value ("_perl_data")) { 1083 if (my $value = $o->get_ob_key_value ("_perl_data")) {
792 1085
793 %$o = %{ Storable::thaw pack "H*", $value }; 1086 %$o = %{ Storable::thaw pack "H*", $value };
794 } 1087 }
795 } 1088 }
796 }, 1089 },
797; 1090);
798 1091
799############################################################################# 1092#############################################################################
800 1093
801=head2 CORE EXTENSIONS 1094=head2 CORE EXTENSIONS
802 1095
803Functions and methods that extend core crossfire objects. 1096Functions and methods that extend core crossfire objects.
1097
1098=head3 cf::player
804 1099
805=over 4 1100=over 4
806 1101
807=item cf::player::exists $login 1102=item cf::player::exists $login
808 1103
813sub cf::player::exists($) { 1108sub cf::player::exists($) {
814 cf::player::find $_[0] 1109 cf::player::find $_[0]
815 or -f sprintf "%s/%s/%s/%s.pl", cf::localdir, cf::playerdir, ($_[0]) x 2; 1110 or -f sprintf "%s/%s/%s/%s.pl", cf::localdir, cf::playerdir, ($_[0]) x 2;
816} 1111}
817 1112
1113=item $player->ext_reply ($msgid, $msgtype, %msg)
1114
1115Sends an ext reply to the player.
1116
1117=cut
1118
1119sub cf::player::ext_reply($$$%) {
1120 my ($self, $id, %msg) = @_;
1121
1122 $msg{msgid} = $id;
1123
1124 $self->send ("ext " . to_json \%msg);
1125}
1126
1127=back
1128
1129
1130=head3 cf::map
1131
1132=over 4
1133
1134=cut
1135
1136package cf::map;
1137
1138use Fcntl;
1139use Coro::AIO;
1140
1141our $MAX_RESET = 7200;
1142our $DEFAULT_RESET = 3600;
1143
1144sub generate_random_map {
1145 my ($path, $rmp) = @_;
1146
1147 # mit "rum" bekleckern, nicht
1148 cf::map::_create_random_map
1149 $path,
1150 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle},
1151 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle},
1152 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map},
1153 $rmp->{exit_on_final_map},
1154 $rmp->{xsize}, $rmp->{ysize},
1155 $rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3},
1156 $rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase},
1157 $rmp->{dungeon_level}, $rmp->{dungeon_depth}, $rmp->{decoroptions}, $rmp->{orientation},
1158 $rmp->{origin_y}, $rmp->{origin_x}, $rmp->{random_seed}, $rmp->{total_map_hp},
1159 $rmp->{map_layout_style}, $rmp->{treasureoptions}, $rmp->{symmetry_used},
1160 (cf::region::find $rmp->{region})
1161}
1162
1163# and all this just because we cannot iterate over
1164# all maps in C++...
1165sub change_all_map_light {
1166 my ($change) = @_;
1167
1168 $_->change_map_light ($change)
1169 for grep $_->outdoor, values %cf::MAP;
1170}
1171
1172sub try_load_header($) {
1173 my ($path) = @_;
1174
1175 utf8::encode $path;
1176 aio_open $path, O_RDONLY, 0
1177 or return;
1178
1179 my $map = cf::map::new
1180 or return;
1181
1182 $map->load_header ($path)
1183 or return;
1184
1185 $map->{load_path} = $path;
1186
1187 $map
1188}
1189
1190sub find_map;
1191sub find_map {
1192 my ($path, $origin) = @_;
1193
1194 #warn "find_map<$path,$origin>\n";#d#
1195
1196 $path = new cf::path $path, $origin && $origin->path;
1197 my $key = $path->as_string;
1198
1199 cf::lock_wait "map_find:$key";
1200
1201 $cf::MAP{$key} || do {
1202 my $guard = cf::lock_acquire "map_find:$key";
1203
1204 # do it the slow way
1205 my $map = try_load_header $path->save_path;
1206
1207 if ($map) {
1208 # safety
1209 $map->{instantiate_time} = $cf::RUNTIME
1210 if $map->{instantiate_time} > $cf::RUNTIME;
1211 } else {
1212 if (my $rmp = $path->random_map_params) {
1213 $map = generate_random_map $key, $rmp;
1214 } else {
1215 $map = try_load_header $path->load_path;
1216 }
1217
1218 $map or return;
1219
1220 $map->{load_original} = 1;
1221 $map->{instantiate_time} = $cf::RUNTIME;
1222 $map->instantiate;
1223
1224 # per-player maps become, after loading, normal maps
1225 $map->per_player (0) if $path->{user_rel};
1226 }
1227
1228 $map->path ($key);
1229 $map->{path} = $path;
1230 $map->{last_save} = $cf::RUNTIME;
1231 $map->last_access ($cf::RUNTIME);
1232
1233 if ($map->should_reset) {
1234 $map->reset;
1235 undef $guard;
1236 $map = find_map $path
1237 or return;
1238 }
1239
1240 $cf::MAP{$key} = $map
1241 }
1242}
1243
1244sub load {
1245 my ($self) = @_;
1246
1247 my $path = $self->{path};
1248 my $guard = cf::lock_acquire "map_load:" . $path->as_string;
1249
1250 return if $self->in_memory != cf::MAP_SWAPPED;
1251
1252 $self->in_memory (cf::MAP_LOADING);
1253
1254 $self->alloc;
1255 $self->load_objects ($self->{load_path}, 1)
1256 or return;
1257
1258 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1)
1259 if delete $self->{load_original};
1260
1261 if (my $uniq = $path->uniq_path) {
1262 utf8::encode $uniq;
1263 if (aio_open $uniq, O_RDONLY, 0) {
1264 $self->clear_unique_items;
1265 $self->load_objects ($uniq, 0);
1266 }
1267 }
1268
1269 # now do the right thing for maps
1270 $self->link_multipart_objects;
1271
1272 if ($self->{path}->is_style_map) {
1273 $self->{deny_save} = 1;
1274 $self->{deny_reset} = 1;
1275 } else {
1276 $self->fix_auto_apply;
1277 $self->decay_objects;
1278 $self->update_buttons;
1279 $self->set_darkness_map;
1280 $self->difficulty ($self->estimate_difficulty)
1281 unless $self->difficulty;
1282 $self->activate;
1283 }
1284
1285 $self->in_memory (cf::MAP_IN_MEMORY);
1286}
1287
1288sub load_map_sync {
1289 my ($path, $origin) = @_;
1290
1291 #warn "load_map_sync<$path, $origin>\n";#d#
1292
1293 cf::sync_job {
1294 my $map = cf::map::find_map $path, $origin
1295 or return;
1296 $map->load;
1297 $map
1298 }
1299}
1300
1301sub save {
1302 my ($self) = @_;
1303
1304 $self->{last_save} = $cf::RUNTIME;
1305
1306 return unless $self->dirty;
1307
1308 my $save = $self->{path}->save_path; utf8::encode $save;
1309 my $uniq = $self->{path}->uniq_path; utf8::encode $uniq;
1310
1311 $self->{load_path} = $save;
1312
1313 return if $self->{deny_save};
1314
1315 if ($uniq) {
1316 $self->save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS);
1317 $self->save_objects ($uniq, cf::IO_UNIQUES);
1318 } else {
1319 $self->save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES);
1320 }
1321}
1322
1323sub swap_out {
1324 my ($self) = @_;
1325
1326 # save first because save cedes
1327 $self->save;
1328
1329 return if $self->players;
1330 return if $self->in_memory != cf::MAP_IN_MEMORY;
1331 return if $self->{deny_save};
1332
1333 $self->clear;
1334 $self->in_memory (cf::MAP_SWAPPED);
1335}
1336
1337sub reset_at {
1338 my ($self) = @_;
1339
1340 # TODO: safety, remove and allow resettable per-player maps
1341 return 1e99 if $self->{path}{user_rel};
1342 return 1e99 if $self->{deny_reset};
1343
1344 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
1345 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET;
1346
1347 $time + $to
1348}
1349
1350sub should_reset {
1351 my ($self) = @_;
1352
1353 $self->reset_at <= $cf::RUNTIME
1354}
1355
1356sub unlink_save {
1357 my ($self) = @_;
1358
1359 utf8::encode (my $save = $self->{path}->save_path);
1360 aioreq_pri 3; IO::AIO::aio_unlink $save;
1361 aioreq_pri 3; IO::AIO::aio_unlink "$save.pst";
1362}
1363
1364sub rename {
1365 my ($self, $new_path) = @_;
1366
1367 $self->unlink_save;
1368
1369 delete $cf::MAP{$self->path};
1370 $self->{path} = new cf::path $new_path;
1371 $self->path ($self->{path}->as_string);
1372 $cf::MAP{$self->path} = $self;
1373
1374 $self->save;
1375}
1376
1377sub reset {
1378 my ($self) = @_;
1379
1380 return if $self->players;
1381 return if $self->{path}{user_rel};#d#
1382
1383 warn "resetting map ", $self->path;#d#
1384
1385 delete $cf::MAP{$self->path};
1386
1387 $_->clear_links_to ($self) for values %cf::MAP;
1388
1389 $self->unlink_save;
1390 $self->destroy;
1391}
1392
1393my $nuke_counter = "aaaa";
1394
1395sub nuke {
1396 my ($self) = @_;
1397
1398 $self->{deny_save} = 1;
1399 $self->reset_timeout (1);
1400 $self->rename ("{nuke}/" . ($nuke_counter++));
1401 $self->reset; # polite request, might not happen
1402}
1403
1404sub customise_for {
1405 my ($map, $ob) = @_;
1406
1407 if ($map->per_player) {
1408 return cf::map::find_map "~" . $ob->name . "/" . $map->{path}{path};
1409 }
1410
1411 $map
1412}
1413
1414sub emergency_save {
1415 local $cf::FREEZE = 1;
1416
1417 warn "enter emergency map save\n";
1418
1419 cf::sync_job {
1420 warn "begin emergency map save\n";
1421 $_->save for values %cf::MAP;
1422 };
1423
1424 warn "end emergency map save\n";
1425}
1426
1427package cf;
1428
1429=back
1430
1431
1432=head3 cf::object::player
1433
1434=over 4
1435
818=item $player_object->reply ($npc, $msg[, $flags]) 1436=item $player_object->reply ($npc, $msg[, $flags])
819 1437
820Sends a message to the player, as if the npc C<$npc> replied. C<$npc> 1438Sends a message to the player, as if the npc C<$npc> replied. C<$npc>
821can be C<undef>. Does the right thing when the player is currently in a 1439can be C<undef>. Does the right thing when the player is currently in a
822dialogue with the given NPC character. 1440dialogue with the given NPC character.
823 1441
824=cut 1442=cut
825 1443
826# rough implementation of a future "reply" method that works 1444# rough implementation of a future "reply" method that works
827# with dialog boxes. 1445# with dialog boxes.
1446#TODO: the first argument must go, split into a $npc->reply_to ( method
828sub cf::object::player::reply($$$;$) { 1447sub cf::object::player::reply($$$;$) {
829 my ($self, $npc, $msg, $flags) = @_; 1448 my ($self, $npc, $msg, $flags) = @_;
830 1449
831 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4; 1450 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4;
832 1451
836 $msg = $npc->name . " says: $msg" if $npc; 1455 $msg = $npc->name . " says: $msg" if $npc;
837 $self->message ($msg, $flags); 1456 $self->message ($msg, $flags);
838 } 1457 }
839} 1458}
840 1459
841=item $player->ext_reply ($msgid, $msgtype, %msg)
842
843Sends an ext reply to the player.
844
845=cut
846
847sub cf::player::ext_reply($$$%) {
848 my ($self, $id, %msg) = @_;
849
850 $msg{msgid} = $id;
851
852 $self->send ("ext " . to_json \%msg);
853}
854
855=item $player_object->may ("access") 1460=item $player_object->may ("access")
856 1461
857Returns wether the given player is authorized to access resource "access" 1462Returns wether the given player is authorized to access resource "access"
858(e.g. "command_wizcast"). 1463(e.g. "command_wizcast").
859 1464
866 (ref $cf::CFG{"may_$access"} 1471 (ref $cf::CFG{"may_$access"}
867 ? scalar grep $self->name eq $_, @{$cf::CFG{"may_$access"}} 1472 ? scalar grep $self->name eq $_, @{$cf::CFG{"may_$access"}}
868 : $cf::CFG{"may_$access"}) 1473 : $cf::CFG{"may_$access"})
869} 1474}
870 1475
871=cut 1476=item $player_object->enter_link
872 1477
873############################################################################# 1478Freezes the player and moves him/her to a special map (C<{link}>).
1479
1480The player should be reaosnably safe there for short amounts of time. You
1481I<MUST> call C<leave_link> as soon as possible, though.
1482
1483=item $player_object->leave_link ($map, $x, $y)
1484
1485Moves the player out of the specila link map onto the given map. If the
1486map is not valid (or omitted), the player will be moved back to the
1487location he/she was before the call to C<enter_link>, or, if that fails,
1488to the emergency map position.
1489
1490Might block.
1491
1492=cut
1493
1494sub cf::object::player::enter_link {
1495 my ($self) = @_;
1496
1497 $self->deactivate_recursive;
1498
1499 return if $self->map == $LINK_MAP;
1500
1501 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y]
1502 if $self->map;
1503
1504 $self->enter_map ($LINK_MAP, 20, 20);
1505}
1506
1507sub cf::object::player::leave_link {
1508 my ($self, $map, $x, $y) = @_;
1509
1510 my $link_pos = delete $self->{_link_pos};
1511
1512 unless ($map) {
1513 # restore original map position
1514 ($map, $x, $y) = @{ $link_pos || [] };
1515 $map = cf::map::find_map $map;
1516
1517 unless ($map) {
1518 ($map, $x, $y) = @$EMERGENCY_POSITION;
1519 $map = cf::map::find_map $map
1520 or die "FATAL: cannot load emergency map\n";
1521 }
1522 }
1523
1524 ($x, $y) = (-1, -1)
1525 unless (defined $x) && (defined $y);
1526
1527 # use -1 or undef as default coordinates, not 0, 0
1528 ($x, $y) = ($map->enter_x, $map->enter_y)
1529 if $x <=0 && $y <= 0;
1530
1531 $map->load;
1532
1533 $self->activate_recursive;
1534 $self->enter_map ($map, $x, $y);
1535}
1536
1537cf::player->attach (
1538 on_logout => sub {
1539 my ($pl) = @_;
1540
1541 # abort map switching before logout
1542 if ($pl->ob->{_link_pos}) {
1543 cf::sync_job {
1544 $pl->ob->leave_link
1545 };
1546 }
1547 },
1548 on_login => sub {
1549 my ($pl) = @_;
1550
1551 # try to abort aborted map switching on player login :)
1552 # should happen only on crashes
1553 if ($pl->ob->{_link_pos}) {
1554 $pl->ob->enter_link;
1555 cf::async {
1556 # we need this sleep as the login has a concurrent enter_exit running
1557 # and this sleep increases chances of the player not ending up in scorn
1558 Coro::Timer::sleep 1;
1559 $pl->ob->leave_link;
1560 };
1561 }
1562 },
1563);
1564
1565=item $player_object->goto_map ($path, $x, $y)
1566
1567=cut
1568
1569sub cf::object::player::goto_map {
1570 my ($self, $path, $x, $y) = @_;
1571
1572 $self->enter_link;
1573
1574 (cf::async {
1575 $path = new cf::path $path;
1576
1577 my $map = cf::map::find_map $path->as_string;
1578 $map = $map->customise_for ($self) if $map;
1579
1580# warn "entering ", $map->path, " at ($x, $y)\n"
1581# if $map;
1582
1583 $map or $self->message ("The exit is closed", cf::NDI_UNIQUE | cf::NDI_RED);
1584
1585 $self->leave_link ($map, $x, $y);
1586 })->prio (1);
1587}
1588
1589=item $player_object->enter_exit ($exit_object)
1590
1591=cut
1592
1593sub parse_random_map_params {
1594 my ($spec) = @_;
1595
1596 my $rmp = { # defaults
1597 xsize => 10,
1598 ysize => 10,
1599 };
1600
1601 for (split /\n/, $spec) {
1602 my ($k, $v) = split /\s+/, $_, 2;
1603
1604 $rmp->{lc $k} = $v if (length $k) && (length $v);
1605 }
1606
1607 $rmp
1608}
1609
1610sub prepare_random_map {
1611 my ($exit) = @_;
1612
1613 # all this does is basically replace the /! path by
1614 # a new random map path (?random/...) with a seed
1615 # that depends on the exit object
1616
1617 my $rmp = parse_random_map_params $exit->msg;
1618
1619 if ($exit->map) {
1620 $rmp->{region} = $exit->map->region_name;
1621 $rmp->{origin_map} = $exit->map->path;
1622 $rmp->{origin_x} = $exit->x;
1623 $rmp->{origin_y} = $exit->y;
1624 }
1625
1626 $rmp->{random_seed} ||= $exit->random_seed;
1627
1628 my $data = cf::to_json $rmp;
1629 my $md5 = Digest::MD5::md5_hex $data;
1630
1631 if (my $fh = aio_open "$cf::RANDOM_MAPS/$md5.meta", O_WRONLY | O_CREAT, 0666) {
1632 aio_write $fh, 0, (length $data), $data, 0;
1633
1634 $exit->slaying ("?random/$md5");
1635 $exit->msg (undef);
1636 }
1637}
1638
1639sub cf::object::player::enter_exit {
1640 my ($self, $exit) = @_;
1641
1642 return unless $self->type == cf::PLAYER;
1643
1644 $self->enter_link;
1645
1646 (cf::async {
1647 unless (eval {
1648 prepare_random_map $exit
1649 if $exit->slaying eq "/!";
1650
1651 my $path = new cf::path $exit->slaying, $exit->map && $exit->map->path;
1652 $self->goto_map ($path, $exit->stats->hp, $exit->stats->sp);
1653
1654 1;
1655 }) {
1656 $self->message ("Something went wrong deep within the crossfire server. "
1657 . "I'll try to bring you back to the map you were before. "
1658 . "Please report this to the dungeon master",
1659 cf::NDI_UNIQUE | cf::NDI_RED);
1660
1661 warn "ERROR in enter_exit: $@";
1662 $self->leave_link;
1663 }
1664 })->prio (1);
1665}
1666
1667=head3 cf::client
1668
1669=over 4
1670
1671=item $client->send_drawinfo ($text, $flags)
1672
1673Sends a drawinfo packet to the client. Circumvents output buffering so
1674should not be used under normal circumstances.
1675
1676=cut
1677
1678sub cf::client::send_drawinfo {
1679 my ($self, $text, $flags) = @_;
1680
1681 utf8::encode $text;
1682 $self->send_packet (sprintf "drawinfo %d %s", $flags, $text);
1683}
1684
1685
1686=item $success = $client->query ($flags, "text", \&cb)
1687
1688Queues a query to the client, calling the given callback with
1689the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>,
1690C<cf::CS_QUERY_SINGLECHAR> or C<cf::CS_QUERY_HIDEINPUT> or C<0>.
1691
1692Queries can fail, so check the return code. Or don't, as queries will become
1693reliable at some point in the future.
1694
1695=cut
1696
1697sub cf::client::query {
1698 my ($self, $flags, $text, $cb) = @_;
1699
1700 return unless $self->state == ST_PLAYING
1701 || $self->state == ST_SETUP
1702 || $self->state == ST_CUSTOM;
1703
1704 $self->state (ST_CUSTOM);
1705
1706 utf8::encode $text;
1707 push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb];
1708
1709 $self->send_packet ($self->{query_queue}[0][0])
1710 if @{ $self->{query_queue} } == 1;
1711}
1712
1713cf::client->attach (
1714 on_reply => sub {
1715 my ($ns, $msg) = @_;
1716
1717 # this weird shuffling is so that direct followup queries
1718 # get handled first
1719 my $queue = delete $ns->{query_queue}
1720 or return; # be conservative, not sure how that can happen, but we saw a crash here
1721
1722 (shift @$queue)->[1]->($msg);
1723
1724 push @{ $ns->{query_queue} }, @$queue;
1725
1726 if (@{ $ns->{query_queue} } == @$queue) {
1727 if (@$queue) {
1728 $ns->send_packet ($ns->{query_queue}[0][0]);
1729 } else {
1730 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM;
1731 }
1732 }
1733 },
1734);
1735
1736=item $client->coro (\&cb)
1737
1738Create a new coroutine, running the specified callback. The coroutine will
1739be automatically cancelled when the client gets destroyed (e.g. on logout,
1740or loss of connection).
1741
1742=cut
1743
1744sub cf::client::coro {
1745 my ($self, $cb) = @_;
1746
1747 my $coro = &cf::async ($cb);
1748
1749 $coro->on_destroy (sub {
1750 delete $self->{_coro}{$coro+0};
1751 });
1752
1753 $self->{_coro}{$coro+0} = $coro;
1754
1755 $coro
1756}
1757
1758cf::client->attach (
1759 on_destroy => sub {
1760 my ($ns) = @_;
1761
1762 $_->cancel for values %{ (delete $ns->{_coro}) || {} };
1763 },
1764);
1765
1766=back
1767
874 1768
875=head2 SAFE SCRIPTING 1769=head2 SAFE SCRIPTING
876 1770
877Functions that provide a safe environment to compile and execute 1771Functions that provide a safe environment to compile and execute
878snippets of perl code without them endangering the safety of the server 1772snippets of perl code without them endangering the safety of the server
1030 1924
1031{ 1925{
1032 my $path = cf::localdir . "/database.pst"; 1926 my $path = cf::localdir . "/database.pst";
1033 1927
1034 sub db_load() { 1928 sub db_load() {
1035 warn "loading database $path\n";#d# remove later
1036 $DB = stat $path ? Storable::retrieve $path : { }; 1929 $DB = stat $path ? Storable::retrieve $path : { };
1037 } 1930 }
1038 1931
1039 my $pid; 1932 my $pid;
1040 1933
1041 sub db_save() { 1934 sub db_save() {
1042 warn "saving database $path\n";#d# remove later
1043 waitpid $pid, 0 if $pid; 1935 waitpid $pid, 0 if $pid;
1044 if (0 == ($pid = fork)) { 1936 if (0 == ($pid = fork)) {
1045 $DB->{_meta}{version} = 1; 1937 $DB->{_meta}{version} = 1;
1046 Storable::nstore $DB, "$path~"; 1938 Storable::nstore $DB, "$path~";
1047 rename "$path~", $path; 1939 rename "$path~", $path;
1078 $DB->{$_[0]} = $_[1]; 1970 $DB->{$_[0]} = $_[1];
1079 } 1971 }
1080 db_dirty; 1972 db_dirty;
1081 } 1973 }
1082 1974
1083 attach_global 1975 cf::global->attach (
1084 prio => 10000, 1976 prio => 10000,
1085 on_cleanup => sub { 1977 on_cleanup => sub {
1086 db_sync; 1978 db_sync;
1087 }, 1979 },
1088 ; 1980 );
1089} 1981}
1090 1982
1091############################################################################# 1983#############################################################################
1092# the server's main() 1984# the server's main()
1093 1985
1095 open my $fh, "<:utf8", cf::confdir . "/config" 1987 open my $fh, "<:utf8", cf::confdir . "/config"
1096 or return; 1988 or return;
1097 1989
1098 local $/; 1990 local $/;
1099 *CFG = YAML::Syck::Load <$fh>; 1991 *CFG = YAML::Syck::Load <$fh>;
1992
1993 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37];
1994
1995 if (exists $CFG{mlockall}) {
1996 eval {
1997 $CFG{mlockall} ? &mlockall : &munlockall
1998 and die "WARNING: m(un)lockall failed: $!\n";
1999 };
2000 warn $@ if $@;
2001 }
1100} 2002}
1101 2003
1102sub main { 2004sub main {
2005 # we must not ever block the main coroutine
2006 local $Coro::idle = sub {
2007 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
2008 (Coro::unblock_sub {
2009 Event::one_event;
2010 })->();
2011 };
2012
1103 cfg_load; 2013 cfg_load;
1104 db_load; 2014 db_load;
1105 load_extensions; 2015 load_extensions;
1106 Event::loop; 2016 Event::loop;
1107} 2017}
1108 2018
1109############################################################################# 2019#############################################################################
1110# initialisation 2020# initialisation
1111 2021
1112sub _perl_reload(&) { 2022sub reload() {
1113 my ($msg) = @_; 2023 # can/must only be called in main
2024 if ($Coro::current != $Coro::main) {
2025 warn "can only reload from main coroutine\n";
2026 return;
2027 }
1114 2028
1115 $msg->("reloading..."); 2029 warn "reloading...";
2030
2031 local $FREEZE = 1;
2032 cf::emergency_save;
1116 2033
1117 eval { 2034 eval {
2035 # if anything goes wrong in here, we should simply crash as we already saved
2036
1118 # cancel all watchers 2037 # cancel all watchers
1119 for (Event::all_watchers) { 2038 for (Event::all_watchers) {
1120 $_->cancel if $_->data & WF_AUTOCANCEL; 2039 $_->cancel if $_->data & WF_AUTOCANCEL;
1121 } 2040 }
1122 2041
2042 # cancel all extension coros
2043 $_->cancel for values %EXT_CORO;
2044 %EXT_CORO = ();
2045
1123 # unload all extensions 2046 # unload all extensions
1124 for (@exts) { 2047 for (@exts) {
1125 $msg->("unloading <$_>"); 2048 warn "unloading <$_>";
1126 unload_extension $_; 2049 unload_extension $_;
1127 } 2050 }
1128 2051
1129 # unload all modules loaded from $LIBDIR 2052 # unload all modules loaded from $LIBDIR
1130 while (my ($k, $v) = each %INC) { 2053 while (my ($k, $v) = each %INC) {
1131 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/; 2054 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
1132 2055
1133 $msg->("removing <$k>"); 2056 warn "removing <$k>";
1134 delete $INC{$k}; 2057 delete $INC{$k};
1135 2058
1136 $k =~ s/\.pm$//; 2059 $k =~ s/\.pm$//;
1137 $k =~ s/\//::/g; 2060 $k =~ s/\//::/g;
1138 2061
1143 Symbol::delete_package $k; 2066 Symbol::delete_package $k;
1144 } 2067 }
1145 2068
1146 # sync database to disk 2069 # sync database to disk
1147 cf::db_sync; 2070 cf::db_sync;
2071 IO::AIO::flush;
1148 2072
1149 # get rid of safe::, as good as possible 2073 # get rid of safe::, as good as possible
1150 Symbol::delete_package "safe::$_" 2074 Symbol::delete_package "safe::$_"
1151 for qw(cf::object cf::object::player cf::player cf::map cf::party cf::region); 2075 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
1152 2076
1153 # remove register_script_function callbacks 2077 # remove register_script_function callbacks
1154 # TODO 2078 # TODO
1155 2079
1156 # unload cf.pm "a bit" 2080 # unload cf.pm "a bit"
1159 # don't, removes xs symbols, too, 2083 # don't, removes xs symbols, too,
1160 # and global variables created in xs 2084 # and global variables created in xs
1161 #Symbol::delete_package __PACKAGE__; 2085 #Symbol::delete_package __PACKAGE__;
1162 2086
1163 # reload cf.pm 2087 # reload cf.pm
1164 $msg->("reloading cf.pm"); 2088 warn "reloading cf.pm";
1165 require cf; 2089 require cf;
2090 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
1166 2091
1167 # load config and database again 2092 # load config and database again
1168 cf::cfg_load; 2093 cf::cfg_load;
1169 cf::db_load; 2094 cf::db_load;
1170 2095
1171 # load extensions 2096 # load extensions
1172 $msg->("load extensions"); 2097 warn "load extensions";
1173 cf::load_extensions; 2098 cf::load_extensions;
1174 2099
1175 # reattach attachments to objects 2100 # reattach attachments to objects
1176 $msg->("reattach"); 2101 warn "reattach";
1177 _global_reattach; 2102 _global_reattach;
1178 }; 2103 };
1179 $msg->($@) if $@;
1180 2104
1181 $msg->("reloaded"); 2105 if ($@) {
2106 warn $@;
2107 warn "error while reloading, exiting.";
2108 exit 1;
2109 }
2110
2111 warn "reloaded successfully";
1182}; 2112};
1183 2113
1184sub perl_reload() { 2114#############################################################################
1185 _perl_reload { 2115
1186 warn $_[0]; 2116unless ($LINK_MAP) {
1187 print "$_[0]\n"; 2117 $LINK_MAP = cf::map::new;
1188 }; 2118
2119 $LINK_MAP->width (41);
2120 $LINK_MAP->height (41);
2121 $LINK_MAP->alloc;
2122 $LINK_MAP->path ("{link}");
2123 $LINK_MAP->{path} = bless { path => "{link}" }, "cf::path";
2124 $LINK_MAP->in_memory (MAP_IN_MEMORY);
2125
2126 # dirty hack because... archetypes are not yet loaded
2127 Event->timer (
2128 after => 2,
2129 cb => sub {
2130 $_[0]->w->cancel;
2131
2132 # provide some exits "home"
2133 my $exit = cf::object::new "exit";
2134
2135 $exit->slaying ($EMERGENCY_POSITION->[0]);
2136 $exit->stats->hp ($EMERGENCY_POSITION->[1]);
2137 $exit->stats->sp ($EMERGENCY_POSITION->[2]);
2138
2139 $LINK_MAP->insert ($exit->clone, 19, 19);
2140 $LINK_MAP->insert ($exit->clone, 19, 20);
2141 $LINK_MAP->insert ($exit->clone, 19, 21);
2142 $LINK_MAP->insert ($exit->clone, 20, 19);
2143 $LINK_MAP->insert ($exit->clone, 20, 21);
2144 $LINK_MAP->insert ($exit->clone, 21, 19);
2145 $LINK_MAP->insert ($exit->clone, 21, 20);
2146 $LINK_MAP->insert ($exit->clone, 21, 21);
2147
2148 $exit->destroy;
2149 });
2150
2151 $LINK_MAP->{deny_save} = 1;
2152 $LINK_MAP->{deny_reset} = 1;
2153
2154 $cf::MAP{$LINK_MAP->path} = $LINK_MAP;
1189} 2155}
1190 2156
1191register "<global>", __PACKAGE__; 2157register "<global>", __PACKAGE__;
1192 2158
1193register_command "perl-reload" => sub { 2159register_command "reload" => sub {
1194 my ($who, $arg) = @_; 2160 my ($who, $arg) = @_;
1195 2161
1196 if ($who->flag (FLAG_WIZ)) { 2162 if ($who->flag (FLAG_WIZ)) {
1197 _perl_reload { 2163 $who->message ("start of reload.");
1198 warn $_[0]; 2164 reload;
1199 $who->message ($_[0]); 2165 $who->message ("end of reload.");
1200 };
1201 } 2166 }
1202}; 2167};
1203 2168
1204unshift @INC, $LIBDIR; 2169unshift @INC, $LIBDIR;
1205 2170
1206$TICK_WATCHER = Event->timer ( 2171$TICK_WATCHER = Event->timer (
2172 reentrant => 0,
1207 prio => 0, 2173 prio => 0,
1208 at => $NEXT_TICK || 1, 2174 at => $NEXT_TICK || $TICK,
1209 data => WF_AUTOCANCEL, 2175 data => WF_AUTOCANCEL,
1210 cb => sub { 2176 cb => sub {
2177 unless ($FREEZE) {
1211 cf::server_tick; # one server iteration 2178 cf::server_tick; # one server iteration
2179 $RUNTIME += $TICK;
2180 }
1212 2181
1213 my $NOW = Event::time;
1214 $NEXT_TICK += $TICK; 2182 $NEXT_TICK += $TICK;
1215 2183
1216 # if we are delayed by four ticks or more, skip them all 2184 # if we are delayed by four ticks or more, skip them all
1217 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4; 2185 $NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4;
1218 2186
1219 $TICK_WATCHER->at ($NEXT_TICK); 2187 $TICK_WATCHER->at ($NEXT_TICK);
1220 $TICK_WATCHER->start; 2188 $TICK_WATCHER->start;
1221 }, 2189 },
1222); 2190);
1223 2191
1224IO::AIO::max_poll_time $TICK * 0.2; 2192IO::AIO::max_poll_time $TICK * 0.2;
1225 2193
2194Event->io (
1226Event->io (fd => IO::AIO::poll_fileno, 2195 fd => IO::AIO::poll_fileno,
1227 poll => 'r', 2196 poll => 'r',
1228 prio => 5, 2197 prio => 5,
1229 data => WF_AUTOCANCEL, 2198 data => WF_AUTOCANCEL,
1230 cb => \&IO::AIO::poll_cb); 2199 cb => \&IO::AIO::poll_cb,
2200);
2201
2202Event->timer (
2203 data => WF_AUTOCANCEL,
2204 after => 0,
2205 interval => 10,
2206 cb => sub {
2207 (Coro::unblock_sub {
2208 write_runtime
2209 or warn "ERROR: unable to write runtime file: $!";
2210 })->();
2211 },
2212);
2213
2214END { cf::emergency_save }
1231 2215
12321 22161
1233 2217

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines