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.126 by root, Tue Jan 2 23:12:47 2007 UTC vs.
Revision 1.237 by root, Fri Apr 13 05:08:51 2007 UTC

… …
4use strict; 4use strict;
5 5
6use Symbol; 6use Symbol;
7use List::Util; 7use List::Util;
8use Storable; 8use Storable;
9use Event;
9use Opcode; 10use Opcode;
10use Safe; 11use Safe;
11use Safe::Hole; 12use Safe::Hole;
12 13
13use Coro 3.3; 14use Coro 3.52 ();
15use Coro::State;
14use Coro::Event; 16use Coro::Event;
15use Coro::Timer; 17use Coro::Timer;
16use Coro::Signal; 18use Coro::Signal;
17use Coro::Semaphore; 19use Coro::Semaphore;
18use Coro::AIO; 20use Coro::AIO;
21use Coro::Storable;
19 22
23use BDB ();
24use Data::Dumper;
20use Digest::MD5; 25use Digest::MD5;
21use Fcntl; 26use Fcntl;
22use IO::AIO 2.31 ();
23use YAML::Syck (); 27use YAML::Syck ();
28use IO::AIO 2.32 ();
24use Time::HiRes; 29use Time::HiRes;
30use Compress::LZF;
25 31
32# configure various modules to our taste
33#
34$Storable::canonical = 1; # reduce rsync transfers
35Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator
36Compress::LZF::sfreeze_cr { }; # prime Compress::LZF so it does not use require later
37
26use Event; $Event::Eval = 1; # no idea why this is required, but it is 38$Event::Eval = 1; # no idea why this is required, but it is
27 39
28# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode? 40# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode?
29$YAML::Syck::ImplicitUnicode = 1; 41$YAML::Syck::ImplicitUnicode = 1;
30 42
31$Coro::main->prio (2); # run main coroutine ("the server") with very high priority 43$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority
32 44
33sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload 45sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
34 46
35our %COMMAND = (); 47our %COMMAND = ();
36our %COMMAND_TIME = (); 48our %COMMAND_TIME = ();
49
50our @EXTS = (); # list of extension package names
37our %EXTCMD = (); 51our %EXTCMD = ();
52our %EXT_CORO = (); # coroutines bound to extensions
53our %EXT_MAP = (); # pluggable maps
38 54
55our $RELOAD; # number of reloads so far
39our @EVENT; 56our @EVENT;
40our $LIBDIR = datadir . "/ext"; 57our $LIBDIR = datadir . "/ext";
41 58
42our $TICK = MAX_TIME * 1e-6; 59our $TICK = MAX_TIME * 1e-6;
43our $TICK_WATCHER; 60our $TICK_WATCHER;
61our $AIO_POLL_WATCHER;
62our $NEXT_RUNTIME_WRITE; # when should the runtime file be written
44our $NEXT_TICK; 63our $NEXT_TICK;
45our $NOW; 64our $NOW;
65our $USE_FSYNC = 1; # use fsync to write maps - default off
66
67our $BDB_POLL_WATCHER;
68our $DB_ENV;
46 69
47our %CFG; 70our %CFG;
48 71
49our $UPTIME; $UPTIME ||= time; 72our $UPTIME; $UPTIME ||= time;
50our $RUNTIME; 73our $RUNTIME;
51 74
75our %PLAYER; # all users
52our %MAP; # all maps 76our %MAP; # all maps
53our $LINK_MAP; # the special {link} map 77our $LINK_MAP; # the special {link} map, which is always available
54our $FREEZE;
55our $RANDOM_MAPS = cf::localdir . "/random"; 78our $RANDOM_MAPS = cf::localdir . "/random";
56our %EXT_CORO; 79our $BDB_ENV_DIR = cf::localdir . "/db";
80
81our $WAIT_FOR_TICK; $WAIT_FOR_TICK ||= new Coro::Signal;
82our $WAIT_FOR_TICK_ONE; $WAIT_FOR_TICK_ONE ||= new Coro::Signal;
83
84# used to convert map paths into valid unix filenames by replacing / by ∕
85our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons
57 86
58binmode STDOUT; 87binmode STDOUT;
59binmode STDERR; 88binmode STDERR;
60 89
61# read virtual server time, if available 90# read virtual server time, if available
… …
68mkdir cf::localdir; 97mkdir cf::localdir;
69mkdir cf::localdir . "/" . cf::playerdir; 98mkdir cf::localdir . "/" . cf::playerdir;
70mkdir cf::localdir . "/" . cf::tmpdir; 99mkdir cf::localdir . "/" . cf::tmpdir;
71mkdir cf::localdir . "/" . cf::uniquedir; 100mkdir cf::localdir . "/" . cf::uniquedir;
72mkdir $RANDOM_MAPS; 101mkdir $RANDOM_MAPS;
102mkdir $BDB_ENV_DIR;
73 103
74# a special map that is always available 104our $EMERGENCY_POSITION;
75our $LINK_MAP;
76 105
77our $EMERGENCY_POSITION = $cf::CFG{emergency_position} || ["/world/world_105_115", 5, 37]; 106sub cf::map::normalise;
78 107
79############################################################################# 108#############################################################################
80 109
81=head2 GLOBAL VARIABLES 110=head2 GLOBAL VARIABLES
82 111
… …
106 135
107=item %cf::CFG 136=item %cf::CFG
108 137
109Configuration for the server, loaded from C</etc/crossfire/config>, or 138Configuration for the server, loaded from C</etc/crossfire/config>, or
110from wherever your confdir points to. 139from wherever your confdir points to.
140
141=item $cf::WAIT_FOR_TICK, $cf::WAIT_FOR_TICK_ONE
142
143These are Coro::Signal objects that are C<< ->broadcast >> (WAIT_FOR_TICK)
144or C<< ->send >> (WAIT_FOR_TICK_ONE) on after normal server tick
145processing has been done. Call C<< ->wait >> on them to maximise the
146window of cpu time available, or simply to synchronise to the server tick.
111 147
112=back 148=back
113 149
114=cut 150=cut
115 151
… …
119 utf8::encode $msg; 155 utf8::encode $msg;
120 156
121 $msg .= "\n" 157 $msg .= "\n"
122 unless $msg =~ /\n$/; 158 unless $msg =~ /\n$/;
123 159
124 LOG llevError, "cfperl: $msg"; 160 LOG llevError, $msg;
125 }; 161 };
126} 162}
127 163
128@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable'; 164@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
129@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable'; 165@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';
… …
147 183
148$Event::DIED = sub { 184$Event::DIED = sub {
149 warn "error in event callback: @_"; 185 warn "error in event callback: @_";
150}; 186};
151 187
152my %ext_pkg;
153my @exts;
154my @hook;
155
156=head2 UTILITY FUNCTIONS 188=head2 UTILITY FUNCTIONS
157 189
158=over 4 190=over 4
159 191
160=cut 192=item dumpval $ref
161 193
194=cut
195
196sub dumpval {
197 eval {
198 local $SIG{__DIE__};
199 my $d;
200 if (1) {
201 $d = new Data::Dumper([$_[0]], ["*var"]);
202 $d->Terse(1);
203 $d->Indent(2);
204 $d->Quotekeys(0);
205 $d->Useqq(1);
206 #$d->Bless(...);
207 $d->Seen($_[1]) if @_ > 1;
208 $d = $d->Dump();
209 }
210 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge;
211 $d
212 } || "[unable to dump $_[0]: '$@']";
213}
214
162use JSON::Syck (); # TODO# replace by JSON::PC once working 215use JSON::XS qw(to_json from_json); # TODO# replace by JSON::PC once working
163 216
164=item $ref = cf::from_json $json 217=item $ref = cf::from_json $json
165 218
166Converts a JSON string into the corresponding perl data structure. 219Converts a JSON string into the corresponding perl data structure.
167 220
168=cut
169
170sub from_json($) {
171 $JSON::Syck::ImplicitUnicode = 1; # work around JSON::Syck bugs
172 JSON::Syck::Load $_[0]
173}
174
175=item $json = cf::to_json $ref 221=item $json = cf::to_json $ref
176 222
177Converts a perl data structure into its JSON representation. 223Converts a perl data structure into its JSON representation.
178 224
179=cut
180
181sub to_json($) {
182 $JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs
183 JSON::Syck::Dump $_[0]
184}
185
186=item my $guard = cf::guard { BLOCK }
187
188Run the given callback when the guard object gets destroyed (useful for
189coroutine cancellations).
190
191You can call C<< ->cancel >> on the guard object to stop the block from
192being executed.
193
194=cut
195
196sub guard(&) {
197 bless \(my $cb = $_[0]), cf::guard::;
198}
199
200sub cf::guard::cancel {
201 ${$_[0]} = sub { };
202}
203
204sub cf::guard::DESTROY {
205 ${$_[0]}->();
206}
207
208=item cf::lock_wait $string 225=item cf::lock_wait $string
209 226
210Wait until the given lock is available. See cf::lock_acquire. 227Wait until the given lock is available. See cf::lock_acquire.
211 228
212=item my $lock = cf::lock_acquire $string 229=item my $lock = cf::lock_acquire $string
213 230
214Wait until the given lock is available and then acquires it and returns 231Wait until the given lock is available and then acquires it and returns
215a guard object. If the guard object gets destroyed (goes out of scope, 232a Coro::guard object. If the guard object gets destroyed (goes out of scope,
216for example when the coroutine gets canceled), the lock is automatically 233for example when the coroutine gets canceled), the lock is automatically
217returned. 234returned.
218 235
219Lock names should begin with a unique identifier (for example, find_map 236Lock names should begin with a unique identifier (for example, cf::map::find
220uses map_find and load_map uses map_load). 237uses map_find and cf::map::load uses map_load).
221 238
222=cut 239=cut
223 240
224our %LOCK; 241our %LOCK;
225 242
… …
239 # wait, to be sure we are not locked 256 # wait, to be sure we are not locked
240 lock_wait $key; 257 lock_wait $key;
241 258
242 $LOCK{$key} = []; 259 $LOCK{$key} = [];
243 260
244 cf::guard { 261 Coro::guard {
245 # wake up all waiters, to be on the safe side 262 # wake up all waiters, to be on the safe side
246 $_->ready for @{ delete $LOCK{$key} }; 263 $_->ready for @{ delete $LOCK{$key} };
247 } 264 }
248} 265}
266
267sub freeze_mainloop {
268 return unless $TICK_WATCHER->is_active;
269
270 my $guard = Coro::guard {
271 $TICK_WATCHER->start;
272 };
273 $TICK_WATCHER->stop;
274 $guard
275}
276
277=item cf::async { BLOCK }
278
279Currently the same as Coro::async_pool, meaning you cannot use
280C<on_destroy>, C<join> or other gimmicks on these coroutines. The only
281thing you are allowed to do is call C<prio> on it.
282
283=cut
284
285BEGIN { *async = \&Coro::async_pool }
249 286
250=item cf::sync_job { BLOCK } 287=item cf::sync_job { BLOCK }
251 288
252The design of crossfire+ requires that the main coro ($Coro::main) is 289The design of crossfire+ requires that the main coro ($Coro::main) is
253always able to handle events or runnable, as crossfire+ is only partly 290always able to handle events or runnable, as crossfire+ is only partly
… …
267 # this is the main coro, too bad, we have to block 304 # this is the main coro, too bad, we have to block
268 # till the operation succeeds, freezing the server :/ 305 # till the operation succeeds, freezing the server :/
269 306
270 # TODO: use suspend/resume instead 307 # TODO: use suspend/resume instead
271 # (but this is cancel-safe) 308 # (but this is cancel-safe)
272 local $FREEZE = 1; 309 my $freeze_guard = freeze_mainloop;
273 310
274 my $busy = 1; 311 my $busy = 1;
275 my @res; 312 my @res;
276 313
277 (Coro::async { 314 (async {
278 @res = eval { $job->() }; 315 @res = eval { $job->() };
279 warn $@ if $@; 316 warn $@ if $@;
280 undef $busy; 317 undef $busy;
281 })->prio (Coro::PRIO_MAX); 318 })->prio (Coro::PRIO_MAX);
282 319
283 while ($busy) { 320 while ($busy) {
284 Coro::cede_notself; 321 Coro::cede or Event::one_event;
285 Event::one_event unless Coro::nready;
286 } 322 }
287 323
288 wantarray ? @res : $res[0] 324 wantarray ? @res : $res[0]
289 } else { 325 } else {
290 # we are in another coroutine, how wonderful, everything just works 326 # we are in another coroutine, how wonderful, everything just works
291 327
292 $job->() 328 $job->()
293 } 329 }
294} 330}
295 331
296=item $coro = cf::coro { BLOCK } 332=item $coro = cf::async_ext { BLOCK }
297 333
298Creates and returns a new coro. This coro is automcatially being canceled 334Like async, but this coro is automatically being canceled when the
299when the extension calling this is being unloaded. 335extension calling this is being unloaded.
300 336
301=cut 337=cut
302 338
303sub coro(&) { 339sub async_ext(&) {
304 my $cb = shift; 340 my $cb = shift;
305 341
306 my $coro; $coro = async { 342 my $coro = &Coro::async ($cb);
307 eval {
308 $cb->();
309 };
310 warn $@ if $@;
311 };
312 343
313 $coro->on_destroy (sub { 344 $coro->on_destroy (sub {
314 delete $EXT_CORO{$coro+0}; 345 delete $EXT_CORO{$coro+0};
315 }); 346 });
316 $EXT_CORO{$coro+0} = $coro; 347 $EXT_CORO{$coro+0} = $coro;
317 348
318 $coro 349 $coro
319} 350}
320 351
321sub write_runtime { 352sub write_runtime {
353 my $guard = cf::lock_acquire "write_runtime";
354
322 my $runtime = cf::localdir . "/runtime"; 355 my $runtime = cf::localdir . "/runtime";
323 356
324 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644 357 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644
325 or return; 358 or return;
326 359
360 my $value = $cf::RUNTIME + 90 + 10;
327 my $value = $cf::RUNTIME + 1 + 10; # 10 is the runtime save interval, for a monotonic clock 361 # 10 is the runtime save interval, for a monotonic clock
362 # 60 allows for the watchdog to kill the server.
363
328 (aio_write $fh, 0, (length $value), $value, 0) <= 0 364 (aio_write $fh, 0, (length $value), $value, 0) <= 0
329 and return; 365 and return;
330 366
367 # always fsync - this file is important
331 aio_fsync $fh 368 aio_fsync $fh
332 and return; 369 and return;
333 370
334 close $fh 371 close $fh
335 or return; 372 or return;
… …
338 and return; 375 and return;
339 376
340 1 377 1
341} 378}
342 379
380=item cf::datalog type => key => value, ...
381
382Log a datalog packet of the given type with the given key-value pairs.
383
384=cut
385
386sub datalog($@) {
387 my ($type, %kv) = @_;
388 warn "DATALOG ", JSON::XS->new->ascii->encode ({ %kv, type => $type });
389}
390
343=back 391=back
344 392
345=cut 393=cut
346
347#############################################################################
348
349package cf::path;
350
351sub new {
352 my ($class, $path, $base) = @_;
353
354 $path = $path->as_string if ref $path;
355
356 my $self = bless { }, $class;
357
358 # {... are special paths that are not touched
359 # ?xxx/... are special absolute paths
360 # ?random/... random maps
361 # /! non-realised random map exit
362 # /... normal maps
363 # ~/... per-player maps without a specific player (DO NOT USE)
364 # ~user/... per-player map of a specific user
365
366 if ($path =~ /^{/) {
367 # fine as it is
368 } elsif ($path =~ s{^\?random/}{}) {
369 Coro::AIO::aio_load "$cf::RANDOM_MAPS/$path.meta", my $data;
370 $self->{random} = cf::from_json $data;
371 } else {
372 if ($path =~ s{^~([^/]+)?}{}) {
373 $self->{user_rel} = 1;
374
375 if (defined $1) {
376 $self->{user} = $1;
377 } elsif ($base =~ m{^~([^/]+)/}) {
378 $self->{user} = $1;
379 } else {
380 warn "cannot resolve user-relative path without user <$path,$base>\n";
381 }
382 } elsif ($path =~ /^\//) {
383 # already absolute
384 } else {
385 $base =~ s{[^/]+/?$}{};
386 return $class->new ("$base/$path");
387 }
388
389 for ($path) {
390 redo if s{/\.?/}{/};
391 redo if s{/[^/]+/\.\./}{/};
392 }
393 }
394
395 $self->{path} = $path;
396
397 $self
398}
399
400# the name / primary key / in-game path
401sub as_string {
402 my ($self) = @_;
403
404 $self->{user_rel} ? "~$self->{user}$self->{path}"
405 : $self->{random} ? "?random/$self->{path}"
406 : $self->{path}
407}
408
409# the displayed name, this is a one way mapping
410sub visible_name {
411 my ($self) = @_;
412
413# if (my $rmp = $self->{random}) {
414# # todo: be more intelligent about this
415# "?random/$rmp->{origin_map}+$rmp->{origin_x}+$rmp->{origin_y}/$rmp->{dungeon_level}"
416# } else {
417 $self->as_string
418# }
419}
420
421# escape the /'s in the path
422sub _escaped_path {
423 # ∕ is U+2215
424 (my $path = $_[0]{path}) =~ s/\//∕/g;
425 $path
426}
427
428# the original (read-only) location
429sub load_path {
430 my ($self) = @_;
431
432 sprintf "%s/%s/%s", cf::datadir, cf::mapdir, $self->{path}
433}
434
435# the temporary/swap location
436sub save_path {
437 my ($self) = @_;
438
439 $self->{user_rel} ? sprintf "%s/%s/%s/%s", cf::localdir, cf::playerdir, $self->{user}, $self->_escaped_path
440 : $self->{random} ? sprintf "%s/%s", $RANDOM_MAPS, $self->{path}
441 : sprintf "%s/%s/%s", cf::localdir, cf::tmpdir, $self->_escaped_path
442}
443
444# the unique path, might be eq to save_path
445sub uniq_path {
446 my ($self) = @_;
447
448 $self->{user_rel} || $self->{random}
449 ? undef
450 : sprintf "%s/%s/%s", cf::localdir, cf::uniquedir, $self->_escaped_path
451}
452
453# return random map parameters, or undef
454sub random_map_params {
455 my ($self) = @_;
456
457 $self->{random}
458}
459
460# this is somewhat ugly, but style maps do need special treatment
461sub is_style_map {
462 $_[0]{path} =~ m{^/styles/}
463}
464
465package cf;
466 394
467############################################################################# 395#############################################################################
468 396
469=head2 ATTACHABLE OBJECTS 397=head2 ATTACHABLE OBJECTS
470 398
… …
596our @CB_TYPE = (); # registry for type (cf-object class) based events 524our @CB_TYPE = (); # registry for type (cf-object class) based events
597our @CB_MAP = (); 525our @CB_MAP = ();
598 526
599my %attachment; 527my %attachment;
600 528
529sub cf::attachable::thawer_merge {
530 # simply override everything except _meta
531 local $_[0]{_meta};
532 %{$_[0]} = %{$_[1]};
533}
534
601sub _attach_cb($$$$) { 535sub _attach_cb($$$$) {
602 my ($registry, $event, $prio, $cb) = @_; 536 my ($registry, $event, $prio, $cb) = @_;
603 537
604 use sort 'stable'; 538 use sort 'stable';
605 539
… …
776# object support 710# object support
777 711
778sub reattach { 712sub reattach {
779 # basically do the same as instantiate, without calling instantiate 713 # basically do the same as instantiate, without calling instantiate
780 my ($obj) = @_; 714 my ($obj) = @_;
715
716 bless $obj, ref $obj; # re-bless in case extensions have been reloaded
781 717
782 my $registry = $obj->registry; 718 my $registry = $obj->registry;
783 719
784 @$registry = (); 720 @$registry = ();
785 721
… …
832 $filename, length $$rdata, scalar @$objs; 768 $filename, length $$rdata, scalar @$objs;
833 769
834 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) { 770 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
835 chmod SAVE_MODE, $fh; 771 chmod SAVE_MODE, $fh;
836 aio_write $fh, 0, (length $$rdata), $$rdata, 0; 772 aio_write $fh, 0, (length $$rdata), $$rdata, 0;
837 aio_fsync $fh; 773 aio_fsync $fh if $cf::USE_FSYNC;
838 close $fh; 774 close $fh;
839 775
840 if (@$objs) { 776 if (@$objs) {
841 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) { 777 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) {
842 chmod SAVE_MODE, $fh; 778 chmod SAVE_MODE, $fh;
843 my $data = Storable::nfreeze { version => 1, objs => $objs }; 779 my $data = Storable::nfreeze { version => 1, objs => $objs };
844 aio_write $fh, 0, (length $data), $data, 0; 780 aio_write $fh, 0, (length $data), $data, 0;
845 aio_fsync $fh; 781 aio_fsync $fh if $cf::USE_FSYNC;
846 close $fh; 782 close $fh;
847 aio_rename "$filename.pst~", "$filename.pst"; 783 aio_rename "$filename.pst~", "$filename.pst";
848 } 784 }
849 } else { 785 } else {
850 aio_unlink "$filename.pst"; 786 aio_unlink "$filename.pst";
… …
917=cut 853=cut
918 854
919sub register_extcmd { 855sub register_extcmd {
920 my ($name, $cb) = @_; 856 my ($name, $cb) = @_;
921 857
922 my $caller = caller;
923 #warn "registering extcmd '$name' to '$caller'";
924
925 $EXTCMD{$name} = [$cb, $caller]; 858 $EXTCMD{$name} = $cb;
926} 859}
927 860
928cf::player->attach ( 861cf::player->attach (
929 on_command => sub { 862 on_command => sub {
930 my ($pl, $name, $params) = @_; 863 my ($pl, $name, $params) = @_;
… …
943 876
944 my $msg = eval { from_json $buf }; 877 my $msg = eval { from_json $buf };
945 878
946 if (ref $msg) { 879 if (ref $msg) {
947 if (my $cb = $EXTCMD{$msg->{msgtype}}) { 880 if (my $cb = $EXTCMD{$msg->{msgtype}}) {
948 if (my %reply = $cb->[0]->($pl, $msg)) { 881 if (my %reply = $cb->($pl, $msg)) {
949 $pl->ext_reply ($msg->{msgid}, %reply); 882 $pl->ext_reply ($msg->{msgid}, %reply);
950 } 883 }
951 } 884 }
952 } else { 885 } else {
953 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n"; 886 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
… …
955 888
956 cf::override; 889 cf::override;
957 }, 890 },
958); 891);
959 892
960sub register {
961 my ($base, $pkg) = @_;
962
963 #TODO
964}
965
966sub load_extension { 893sub load_extension {
967 my ($path) = @_; 894 my ($path) = @_;
968 895
969 $path =~ /([^\/\\]+)\.ext$/ or die "$path"; 896 $path =~ /([^\/\\]+)\.ext$/ or die "$path";
970 my $base = $1; 897 my $base = $1;
971 my $pkg = $1; 898 my $pkg = $1;
972 $pkg =~ s/[^[:word:]]/_/g; 899 $pkg =~ s/[^[:word:]]/_/g;
973 $pkg = "ext::$pkg"; 900 $pkg = "ext::$pkg";
974 901
975 warn "loading '$path' into '$pkg'\n"; 902 warn "... loading '$path' into '$pkg'\n";
976 903
977 open my $fh, "<:utf8", $path 904 open my $fh, "<:utf8", $path
978 or die "$path: $!"; 905 or die "$path: $!";
979 906
980 my $source = 907 my $source =
981 "package $pkg; use strict; use utf8;\n" 908 "package $pkg; use strict; use utf8;\n"
982 . "#line 1 \"$path\"\n{\n" 909 . "#line 1 \"$path\"\n{\n"
983 . (do { local $/; <$fh> }) 910 . (do { local $/; <$fh> })
984 . "\n};\n1"; 911 . "\n};\n1";
985 912
986 eval $source 913 unless (eval $source) {
987 or die $@ ? "$path: $@\n" 914 my $msg = $@ ? "$path: $@\n"
988 : "extension disabled.\n"; 915 : "extension disabled.\n";
989 916 if ($source =~ /^#!.*perl.*#.*MANDATORY/m) { # ugly match
990 push @exts, $pkg; 917 warn $@;
991 $ext_pkg{$base} = $pkg; 918 warn "mandatory extension failed to load, exiting.\n";
992 919 exit 1;
993# no strict 'refs'; 920 }
994# @{"$pkg\::ISA"} = ext::; 921 die $@;
995
996 register $base, $pkg;
997}
998
999sub unload_extension {
1000 my ($pkg) = @_;
1001
1002 warn "removing extension $pkg\n";
1003
1004 # remove hooks
1005 #TODO
1006# for my $idx (0 .. $#PLUGIN_EVENT) {
1007# delete $hook[$idx]{$pkg};
1008# } 922 }
1009 923
1010 # remove commands 924 push @EXTS, $pkg;
1011 for my $name (keys %COMMAND) {
1012 my @cb = grep $_->[0] ne $pkg, @{ $COMMAND{$name} };
1013
1014 if (@cb) {
1015 $COMMAND{$name} = \@cb;
1016 } else {
1017 delete $COMMAND{$name};
1018 }
1019 }
1020
1021 # remove extcmds
1022 for my $name (grep $EXTCMD{$_}[1] eq $pkg, keys %EXTCMD) {
1023 delete $EXTCMD{$name};
1024 }
1025
1026 if (my $cb = $pkg->can ("unload")) {
1027 eval {
1028 $cb->($pkg);
1029 1
1030 } or warn "$pkg unloaded, but with errors: $@";
1031 }
1032
1033 Symbol::delete_package $pkg;
1034} 925}
1035 926
1036sub load_extensions { 927sub load_extensions {
1037 for my $ext (<$LIBDIR/*.ext>) { 928 for my $ext (<$LIBDIR/*.ext>) {
1038 next unless -r $ext; 929 next unless -r $ext;
… …
1042 } or warn "$ext not loaded: $@"; 933 } or warn "$ext not loaded: $@";
1043 } 934 }
1044} 935}
1045 936
1046############################################################################# 937#############################################################################
1047# load/save/clean perl data associated with a map
1048
1049*cf::mapsupport::on_clean = sub {
1050 my ($map) = @_;
1051
1052 my $path = $map->tmpname;
1053 defined $path or return;
1054
1055 unlink "$path.pst";
1056};
1057
1058cf::map->attach (prio => -10000, package => cf::mapsupport::);
1059
1060#############################################################################
1061# load/save perl data associated with player->ob objects
1062
1063sub all_objects(@) {
1064 @_, map all_objects ($_->inv), @_
1065}
1066
1067# TODO: compatibility cruft, remove when no longer needed
1068cf::player->attach (
1069 on_load => sub {
1070 my ($pl, $path) = @_;
1071
1072 for my $o (all_objects $pl->ob) {
1073 if (my $value = $o->get_ob_key_value ("_perl_data")) {
1074 $o->set_ob_key_value ("_perl_data");
1075
1076 %$o = %{ Storable::thaw pack "H*", $value };
1077 }
1078 }
1079 },
1080);
1081
1082#############################################################################
1083 938
1084=head2 CORE EXTENSIONS 939=head2 CORE EXTENSIONS
1085 940
1086Functions and methods that extend core crossfire objects. 941Functions and methods that extend core crossfire objects.
1087 942
943=cut
944
945package cf::player;
946
947use Coro::AIO;
948
1088=head3 cf::player 949=head3 cf::player
1089 950
1090=over 4 951=over 4
1091 952
1092=item cf::player::exists $login 953=item cf::player::find $login
1093 954
1094Returns true when the given account exists. 955Returns the given player object, loading it if necessary (might block).
1095 956
1096=cut 957=cut
1097 958
1098sub cf::player::exists($) { 959sub playerdir($) {
1099 cf::player::find $_[0] 960 cf::localdir
1100 or -f sprintf "%s/%s/%s/%s.pl", cf::localdir, cf::playerdir, ($_[0]) x 2; 961 . "/"
962 . cf::playerdir
963 . "/"
964 . (ref $_[0] ? $_[0]->ob->name : $_[0])
1101} 965}
1102 966
967sub path($) {
968 my $login = ref $_[0] ? $_[0]->ob->name : $_[0];
969
970 (playerdir $login) . "/playerdata"
971}
972
973sub find_active($) {
974 $cf::PLAYER{$_[0]}
975 and $cf::PLAYER{$_[0]}->active
976 and $cf::PLAYER{$_[0]}
977}
978
979sub exists($) {
980 my ($login) = @_;
981
982 $cf::PLAYER{$login}
983 or cf::sync_job { !aio_stat path $login }
984}
985
986sub find($) {
987 return $cf::PLAYER{$_[0]} || do {
988 my $login = $_[0];
989
990 my $guard = cf::lock_acquire "user_find:$login";
991
992 $cf::PLAYER{$_[0]} || do {
993 # rename old playerfiles to new ones
994 #TODO: remove when no longer required
995 aio_link +(playerdir $login) . "/$login.pl.pst", (playerdir $login) . "/playerdata.pst";
996 aio_link +(playerdir $login) . "/$login.pl" , (playerdir $login) . "/playerdata";
997 aio_unlink +(playerdir $login) . "/$login.pl.pst";
998 aio_unlink +(playerdir $login) . "/$login.pl";
999
1000 my $pl = load_pl path $login
1001 or return;
1002 $cf::PLAYER{$login} = $pl
1003 }
1004 }
1005}
1006
1007sub save($) {
1008 my ($pl) = @_;
1009
1010 return if $pl->{deny_save};
1011
1012 my $path = path $pl;
1013 my $guard = cf::lock_acquire "user_save:$path";
1014
1015 return if $pl->{deny_save};
1016
1017 aio_mkdir playerdir $pl, 0770;
1018 $pl->{last_save} = $cf::RUNTIME;
1019
1020 $pl->save_pl ($path);
1021 Coro::cede;
1022}
1023
1024sub new($) {
1025 my ($login) = @_;
1026
1027 my $self = create;
1028
1029 $self->ob->name ($login);
1030 $self->{deny_save} = 1;
1031
1032 $cf::PLAYER{$login} = $self;
1033
1034 $self
1035}
1036
1037=item $pl->quit_character
1038
1039Nukes the player without looking back. If logged in, the connection will
1040be destroyed. May block for a long time.
1041
1042=cut
1043
1044sub quit_character {
1045 my ($pl) = @_;
1046
1047 my $name = $pl->ob->name;
1048
1049 $pl->{deny_save} = 1;
1050 $pl->password ("*"); # this should lock out the player until we nuked the dir
1051
1052 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active;
1053 $pl->deactivate;
1054 $pl->invoke (cf::EVENT_PLAYER_QUIT);
1055 $pl->ns->destroy if $pl->ns;
1056
1057 my $path = playerdir $pl;
1058 my $temp = "$path~$cf::RUNTIME~deleting~";
1059 aio_rename $path, $temp;
1060 delete $cf::PLAYER{$pl->ob->name};
1061 $pl->destroy;
1062
1063 my $prefix = qr<^~\Q$name\E/>;
1064
1065 # nuke player maps
1066 $cf::MAP{$_}->nuke for grep /$prefix/, keys %cf::MAP;
1067
1068 IO::AIO::aio_rmtree $temp;
1069}
1070
1071=item $pl->kick
1072
1073Kicks a player out of the game. This destroys the connection.
1074
1075=cut
1076
1077sub kick {
1078 my ($pl, $kicker) = @_;
1079
1080 $pl->invoke (cf::EVENT_PLAYER_KICK, $kicker);
1081 $pl->killer ("kicked");
1082 $pl->ns->destroy;
1083}
1084
1085=item cf::player::list_logins
1086
1087Returns am arrayref of all valid playernames in the system, can take a
1088while and may block, so not sync_job-capable, ever.
1089
1090=cut
1091
1092sub list_logins {
1093 my $dirs = aio_readdir cf::localdir . "/" . cf::playerdir
1094 or return [];
1095
1096 my @logins;
1097
1098 for my $login (@$dirs) {
1099 my $fh = aio_open path $login, Fcntl::O_RDONLY, 0 or next;
1100 aio_read $fh, 0, 512, my $buf, 0 or next;
1101 $buf !~ /^password -------------$/m or next; # official not-valid tag
1102
1103 utf8::decode $login;
1104 push @logins, $login;
1105 }
1106
1107 \@logins
1108}
1109
1110=item $player->maps
1111
1112Returns an arrayref of map paths that are private for this
1113player. May block.
1114
1115=cut
1116
1117sub maps($) {
1118 my ($pl) = @_;
1119
1120 $pl = ref $pl ? $pl->ob->name : $pl;
1121
1122 my $files = aio_readdir playerdir $pl
1123 or return;
1124
1125 my @paths;
1126
1127 for (@$files) {
1128 utf8::decode $_;
1129 next if /\.(?:pl|pst)$/;
1130 next unless /^$PATH_SEP/o;
1131
1132 push @paths, cf::map::normalise "~$pl/$_";
1133 }
1134
1135 \@paths
1136}
1137
1103=item $player->ext_reply ($msgid, $msgtype, %msg) 1138=item $player->ext_reply ($msgid, %msg)
1104 1139
1105Sends an ext reply to the player. 1140Sends an ext reply to the player.
1106 1141
1107=cut 1142=cut
1108 1143
1109sub cf::player::ext_reply($$$%) { 1144sub ext_reply($$%) {
1110 my ($self, $id, %msg) = @_; 1145 my ($self, $id, %msg) = @_;
1111 1146
1112 $msg{msgid} = $id; 1147 $msg{msgid} = $id;
1113 1148
1114 $self->send ("ext " . to_json \%msg); 1149 $self->send ("ext " . cf::to_json \%msg);
1115} 1150}
1151
1152=item $player->ext_event ($type, %msg)
1153
1154Sends an ext event to the client.
1155
1156=cut
1157
1158sub ext_event($$%) {
1159 my ($self, $type, %msg) = @_;
1160
1161 $self->ns->ext_event ($type, %msg);
1162}
1163
1164package cf;
1116 1165
1117=back 1166=back
1118 1167
1119 1168
1120=head3 cf::map 1169=head3 cf::map
… …
1126package cf::map; 1175package cf::map;
1127 1176
1128use Fcntl; 1177use Fcntl;
1129use Coro::AIO; 1178use Coro::AIO;
1130 1179
1180use overload
1181 '""' => \&as_string,
1182 fallback => 1;
1183
1131our $MAX_RESET = 7200; 1184our $MAX_RESET = 3600;
1132our $DEFAULT_RESET = 3600; 1185our $DEFAULT_RESET = 3000;
1133 1186
1134sub generate_random_map { 1187sub generate_random_map {
1135 my ($path, $rmp) = @_; 1188 my ($self, $rmp) = @_;
1136
1137 # mit "rum" bekleckern, nicht 1189 # mit "rum" bekleckern, nicht
1138 cf::map::_create_random_map 1190 $self->_create_random_map (
1139 $path,
1140 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle}, 1191 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle},
1141 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle}, 1192 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle},
1142 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map}, 1193 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map},
1143 $rmp->{exit_on_final_map}, 1194 $rmp->{exit_on_final_map},
1144 $rmp->{xsize}, $rmp->{ysize}, 1195 $rmp->{xsize}, $rmp->{ysize},
1145 $rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3}, 1196 $rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3},
1146 $rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase}, 1197 $rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase},
1147 $rmp->{dungeon_level}, $rmp->{dungeon_depth}, $rmp->{decoroptions}, $rmp->{orientation}, 1198 $rmp->{dungeon_level}, $rmp->{dungeon_depth}, $rmp->{decoroptions}, $rmp->{orientation},
1148 $rmp->{origin_y}, $rmp->{origin_x}, $rmp->{random_seed}, $rmp->{total_map_hp}, 1199 $rmp->{origin_y}, $rmp->{origin_x}, $rmp->{random_seed}, $rmp->{total_map_hp},
1149 $rmp->{map_layout_style}, $rmp->{treasureoptions}, $rmp->{symmetry_used}, 1200 $rmp->{map_layout_style}, $rmp->{treasureoptions}, $rmp->{symmetry_used},
1150 (cf::region::find $rmp->{region}) 1201 (cf::region::find $rmp->{region}), $rmp->{custom}
1202 )
1203}
1204
1205=item cf::map->register ($regex, $prio)
1206
1207Register a handler for the map path matching the given regex at the
1208givne priority (higher is better, built-in handlers have priority 0, the
1209default).
1210
1211=cut
1212
1213sub register {
1214 my (undef, $regex, $prio) = @_;
1215 my $pkg = caller;
1216
1217 no strict;
1218 push @{"$pkg\::ISA"}, __PACKAGE__;
1219
1220 $EXT_MAP{$pkg} = [$prio, qr<$regex>];
1221}
1222
1223# also paths starting with '/'
1224$EXT_MAP{"cf::map"} = [0, qr{^(?=/)}];
1225
1226sub thawer_merge {
1227 my ($self, $merge) = @_;
1228
1229 # we have to keep some variables in memory intact
1230 local $self->{path};
1231 local $self->{load_path};
1232 local $self->{deny_save};
1233 local $self->{deny_reset};
1234
1235 $self->SUPER::thawer_merge ($merge);
1236}
1237
1238sub normalise {
1239 my ($path, $base) = @_;
1240
1241 $path = "$path"; # make sure its a string
1242
1243 $path =~ s/\.map$//;
1244
1245 # map plan:
1246 #
1247 # /! non-realised random map exit (special hack!)
1248 # {... are special paths that are not being touched
1249 # ?xxx/... are special absolute paths
1250 # ?random/... random maps
1251 # /... normal maps
1252 # ~user/... per-player map of a specific user
1253
1254 $path =~ s/$PATH_SEP/\//go;
1255
1256 # treat it as relative path if it starts with
1257 # something that looks reasonable
1258 if ($path =~ m{^(?:\./|\.\./|\w)}) {
1259 $base or Carp::carp "normalise called with relative path and no base: '$path'";
1260
1261 $base =~ s{[^/]+/?$}{};
1262 $path = "$base/$path";
1263 }
1264
1265 for ($path) {
1266 redo if s{//}{/};
1267 redo if s{/\.?/}{/};
1268 redo if s{/[^/]+/\.\./}{/};
1269 }
1270
1271 $path
1272}
1273
1274sub new_from_path {
1275 my (undef, $path, $base) = @_;
1276
1277 return $path if UNIVERSAL::isa $path, "cf::map"; # already a map object
1278
1279 $path = normalise $path, $base;
1280
1281 for my $pkg (sort { $EXT_MAP{$b}[0] <=> $EXT_MAP{$a}[0] } keys %EXT_MAP) {
1282 if ($path =~ $EXT_MAP{$pkg}[1]) {
1283 my $self = bless cf::map::new, $pkg;
1284 $self->{path} = $path; $self->path ($path);
1285 $self->init; # pass $1 etc.
1286 return $self;
1287 }
1288 }
1289
1290 Carp::carp "unable to resolve path '$path' (base '$base').";
1291 ()
1292}
1293
1294sub init {
1295 my ($self) = @_;
1296
1297 $self
1298}
1299
1300sub as_string {
1301 my ($self) = @_;
1302
1303 "$self->{path}"
1304}
1305
1306# the displayed name, this is a one way mapping
1307sub visible_name {
1308 &as_string
1309}
1310
1311# the original (read-only) location
1312sub load_path {
1313 my ($self) = @_;
1314
1315 sprintf "%s/%s/%s.map", cf::datadir, cf::mapdir, $self->{path}
1316}
1317
1318# the temporary/swap location
1319sub save_path {
1320 my ($self) = @_;
1321
1322 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g;
1323 sprintf "%s/%s/%s.map", cf::localdir, cf::tmpdir, $path
1324}
1325
1326# the unique path, undef == no special unique path
1327sub uniq_path {
1328 my ($self) = @_;
1329
1330 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g;
1331 sprintf "%s/%s/%s", cf::localdir, cf::uniquedir, $path
1151} 1332}
1152 1333
1153# and all this just because we cannot iterate over 1334# and all this just because we cannot iterate over
1154# all maps in C++... 1335# all maps in C++...
1155sub change_all_map_light { 1336sub change_all_map_light {
… …
1157 1338
1158 $_->change_map_light ($change) 1339 $_->change_map_light ($change)
1159 for grep $_->outdoor, values %cf::MAP; 1340 for grep $_->outdoor, values %cf::MAP;
1160} 1341}
1161 1342
1343sub unlink_save {
1344 my ($self) = @_;
1345
1346 utf8::encode (my $save = $self->save_path);
1347 IO::AIO::aioreq_pri 4; Coro::AIO::aio_unlink $save;
1348 IO::AIO::aioreq_pri 4; Coro::AIO::aio_unlink "$save.pst";
1349}
1350
1162sub try_load_header($) { 1351sub load_header_from($) {
1163 my ($path) = @_; 1352 my ($self, $path) = @_;
1164 1353
1165 utf8::encode $path; 1354 utf8::encode $path;
1166 aio_open $path, O_RDONLY, 0 1355 #aio_open $path, O_RDONLY, 0
1356 # or return;
1357
1358 $self->_load_header ($path)
1167 or return; 1359 or return;
1168 1360
1169 my $map = cf::map::new 1361 $self->{load_path} = $path;
1362
1363 1
1364}
1365
1366sub load_header_orig {
1367 my ($self) = @_;
1368
1369 $self->load_header_from ($self->load_path)
1370}
1371
1372sub load_header_temp {
1373 my ($self) = @_;
1374
1375 $self->load_header_from ($self->save_path)
1376}
1377
1378sub prepare_temp {
1379 my ($self) = @_;
1380
1381 $self->last_access ((delete $self->{last_access})
1382 || $cf::RUNTIME); #d#
1383 # safety
1384 $self->{instantiate_time} = $cf::RUNTIME
1385 if $self->{instantiate_time} > $cf::RUNTIME;
1386}
1387
1388sub prepare_orig {
1389 my ($self) = @_;
1390
1391 $self->{load_original} = 1;
1392 $self->{instantiate_time} = $cf::RUNTIME;
1393 $self->last_access ($cf::RUNTIME);
1394 $self->instantiate;
1395}
1396
1397sub load_header {
1398 my ($self) = @_;
1399
1400 if ($self->load_header_temp) {
1401 $self->prepare_temp;
1402 } else {
1403 $self->load_header_orig
1170 or return; 1404 or return;
1405 $self->prepare_orig;
1406 }
1171 1407
1172 $map->load_header ($path) 1408 1
1173 or return;
1174
1175 $map->{load_path} = $path;
1176
1177 $map
1178} 1409}
1179 1410
1180sub find_map; 1411sub find;
1181sub find_map { 1412sub find {
1182 my ($path, $origin) = @_; 1413 my ($path, $origin) = @_;
1183 1414
1184 #warn "find_map<$path,$origin>\n";#d#
1185
1186 $path = new cf::path $path, $origin && $origin->path; 1415 $path = normalise $path, $origin && $origin->path;
1187 my $key = $path->as_string;
1188 1416
1189 cf::lock_wait "map_find:$key"; 1417 cf::lock_wait "map_find:$path";
1190 1418
1191 $cf::MAP{$key} || do { 1419 $cf::MAP{$path} || do {
1192 my $guard = cf::lock_acquire "map_find:$key"; 1420 my $guard = cf::lock_acquire "map_find:$path";
1193 1421 my $map = new_from_path cf::map $path
1194 # do it the slow way
1195 my $map = try_load_header $path->save_path;
1196
1197 if ($map) {
1198 # safety
1199 $map->{instantiate_time} = $cf::RUNTIME
1200 if $map->{instantiate_time} > $cf::RUNTIME;
1201 } else {
1202 if (my $rmp = $path->random_map_params) {
1203 $map = generate_random_map $key, $rmp;
1204 } else {
1205 $map = try_load_header $path->load_path;
1206 }
1207
1208 $map or return; 1422 or return;
1209 1423
1210 $map->{load_original} = 1;
1211 $map->{instantiate_time} = $cf::RUNTIME;
1212 $map->instantiate;
1213
1214 # per-player maps become, after loading, normal maps
1215 $map->per_player (0) if $path->{user_rel};
1216 }
1217
1218 $map->path ($key);
1219 $map->{path} = $path;
1220 $map->{last_save} = $cf::RUNTIME; 1424 $map->{last_save} = $cf::RUNTIME;
1221 $map->last_access ($cf::RUNTIME);
1222 1425
1223 if ($map->should_reset) { 1426 $map->load_header
1427 or return;
1428
1429 if ($map->should_reset && 0) {#d#TODO# disabled, crashy (locking issue?)
1430 # doing this can freeze the server in a sync job, obviously
1431 #$cf::WAIT_FOR_TICK->wait;
1224 $map->reset; 1432 $map->reset;
1225 undef $guard; 1433 undef $guard;
1226 $map = find_map $path 1434 return find $path;
1227 or return;
1228 } 1435 }
1229 1436
1230 $cf::MAP{$key} = $map 1437 $cf::MAP{$path} = $map
1231 } 1438 }
1232} 1439}
1440
1441sub pre_load { }
1442sub post_load { }
1233 1443
1234sub load { 1444sub load {
1235 my ($self) = @_; 1445 my ($self) = @_;
1236 1446
1447 local $self->{deny_reset} = 1; # loading can take a long time
1448
1237 my $path = $self->{path}; 1449 my $path = $self->{path};
1238 my $guard = cf::lock_acquire "map_load:" . $path->as_string; 1450 my $guard = cf::lock_acquire "map_load:$path";
1239 1451
1240 return if $self->in_memory != cf::MAP_SWAPPED; 1452 return if $self->in_memory != cf::MAP_SWAPPED;
1241 1453
1242 $self->in_memory (cf::MAP_LOADING); 1454 $self->in_memory (cf::MAP_LOADING);
1243 1455
1244 $self->alloc; 1456 $self->alloc;
1457
1458 $self->pre_load;
1459
1245 $self->load_objects ($self->{load_path}, 1) 1460 $self->_load_objects ($self->{load_path}, 1)
1246 or return; 1461 or return;
1247 1462
1248 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1) 1463 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1)
1249 if delete $self->{load_original}; 1464 if delete $self->{load_original};
1250 1465
1251 if (my $uniq = $path->uniq_path) { 1466 if (my $uniq = $self->uniq_path) {
1252 utf8::encode $uniq; 1467 utf8::encode $uniq;
1253 if (aio_open $uniq, O_RDONLY, 0) { 1468 if (aio_open $uniq, O_RDONLY, 0) {
1254 $self->clear_unique_items; 1469 $self->clear_unique_items;
1255 $self->load_objects ($uniq, 0); 1470 $self->_load_objects ($uniq, 0);
1256 } 1471 }
1257 } 1472 }
1473
1474 Coro::cede;
1258 1475
1259 # now do the right thing for maps 1476 # now do the right thing for maps
1260 $self->link_multipart_objects; 1477 $self->link_multipart_objects;
1261 1478
1262 if ($self->{path}->is_style_map) { 1479 unless ($self->{deny_activate}) {
1263 $self->{deny_save} = 1; 1480 $self->decay_objects;
1264 $self->{deny_reset} = 1;
1265 } else {
1266 $self->fix_auto_apply; 1481 $self->fix_auto_apply;
1267 $self->decay_objects;
1268 $self->update_buttons; 1482 $self->update_buttons;
1483 Coro::cede;
1269 $self->set_darkness_map; 1484 $self->set_darkness_map;
1270 $self->difficulty ($self->estimate_difficulty) 1485 $self->difficulty ($self->estimate_difficulty)
1271 unless $self->difficulty; 1486 unless $self->difficulty;
1487 Coro::cede;
1272 $self->activate; 1488 $self->activate;
1273 } 1489 }
1274 1490
1491 $self->post_load;
1492
1275 $self->in_memory (cf::MAP_IN_MEMORY); 1493 $self->in_memory (cf::MAP_IN_MEMORY);
1276} 1494}
1277 1495
1278sub load_map_sync { 1496sub customise_for {
1497 my ($self, $ob) = @_;
1498
1499 return find "~" . $ob->name . "/" . $self->{path}
1500 if $self->per_player;
1501
1502 $self
1503}
1504
1505# find and load all maps in the 3x3 area around a map
1506sub load_diag {
1507 my ($map) = @_;
1508
1509 my @diag; # diagonal neighbours
1510
1511 for (0 .. 3) {
1512 my $neigh = $map->tile_path ($_)
1513 or next;
1514 $neigh = find $neigh, $map
1515 or next;
1516 $neigh->load;
1517
1518 push @diag, [$neigh->tile_path (($_ + 3) % 4), $neigh],
1519 [$neigh->tile_path (($_ + 1) % 4), $neigh];
1520 }
1521
1522 for (@diag) {
1523 my $neigh = find @$_
1524 or next;
1525 $neigh->load;
1526 }
1527}
1528
1529sub find_sync {
1279 my ($path, $origin) = @_; 1530 my ($path, $origin) = @_;
1280 1531
1281 #warn "load_map_sync<$path, $origin>\n";#d# 1532 cf::sync_job { find $path, $origin }
1533}
1282 1534
1283 cf::sync_job { 1535sub do_load_sync {
1284 my $map = cf::map::find_map $path, $origin 1536 my ($map) = @_;
1285 or return; 1537
1538 cf::sync_job { $map->load };
1539}
1540
1541our %MAP_PREFETCH;
1542our $MAP_PREFETCHER = undef;
1543
1544sub find_async {
1545 my ($path, $origin) = @_;
1546
1547 $path = normalise $path, $origin && $origin->{path};
1548
1549 if (my $map = $cf::MAP{$path}) {
1550 return $map if $map->in_memory == cf::MAP_IN_MEMORY;
1551 }
1552
1553 undef $MAP_PREFETCH{$path};
1554 $MAP_PREFETCHER ||= cf::async {
1555 while (%MAP_PREFETCH) {
1556 for my $path (keys %MAP_PREFETCH) {
1557 my $map = find $path
1558 or next;
1286 $map->load; 1559 $map->load;
1287 $map 1560
1561 delete $MAP_PREFETCH{$path};
1562 }
1563 }
1564 undef $MAP_PREFETCHER;
1288 } 1565 };
1566 $MAP_PREFETCHER->prio (6);
1567
1568 ()
1289} 1569}
1290 1570
1291sub save { 1571sub save {
1292 my ($self) = @_; 1572 my ($self) = @_;
1293 1573
1574 my $lock = cf::lock_acquire "map_data:" . $self->path;
1575
1294 $self->{last_save} = $cf::RUNTIME; 1576 $self->{last_save} = $cf::RUNTIME;
1295 1577
1296 return unless $self->dirty; 1578 return unless $self->dirty;
1297 1579
1298 my $save = $self->{path}->save_path; utf8::encode $save; 1580 my $save = $self->save_path; utf8::encode $save;
1299 my $uniq = $self->{path}->uniq_path; utf8::encode $uniq; 1581 my $uniq = $self->uniq_path; utf8::encode $uniq;
1300 1582
1301 $self->{load_path} = $save; 1583 $self->{load_path} = $save;
1302 1584
1303 return if $self->{deny_save}; 1585 return if $self->{deny_save};
1304 1586
1587 local $self->{last_access} = $self->last_access;#d#
1588
1589 cf::async {
1590 $_->contr->save for $self->players;
1591 };
1592
1305 if ($uniq) { 1593 if ($uniq) {
1306 $self->save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS); 1594 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS);
1307 $self->save_objects ($uniq, cf::IO_UNIQUES); 1595 $self->_save_objects ($uniq, cf::IO_UNIQUES);
1308 } else { 1596 } else {
1309 $self->save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES); 1597 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES);
1310 } 1598 }
1311} 1599}
1312 1600
1313sub swap_out { 1601sub swap_out {
1314 my ($self) = @_; 1602 my ($self) = @_;
1603
1604 # save first because save cedes
1605 $self->save;
1606
1607 my $lock = cf::lock_acquire "map_data:" . $self->path;
1315 1608
1316 return if $self->players; 1609 return if $self->players;
1317 return if $self->in_memory != cf::MAP_IN_MEMORY; 1610 return if $self->in_memory != cf::MAP_IN_MEMORY;
1318 return if $self->{deny_save}; 1611 return if $self->{deny_save};
1319 1612
1320 $self->save;
1321 $self->clear; 1613 $self->clear;
1322 $self->in_memory (cf::MAP_SWAPPED); 1614 $self->in_memory (cf::MAP_SWAPPED);
1323} 1615}
1324 1616
1325sub reset_at { 1617sub reset_at {
1326 my ($self) = @_; 1618 my ($self) = @_;
1327 1619
1328 # TODO: safety, remove and allow resettable per-player maps 1620 # TODO: safety, remove and allow resettable per-player maps
1329 return 1e99 if $self->{path}{user_rel}; 1621 return 1e99 if $self->isa ("ext::map_per_player");#d#
1330 return 1e99 if $self->{deny_reset}; 1622 return 1e99 if $self->{deny_reset};
1331 1623
1332 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access; 1624 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
1333 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET; 1625 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET;
1334 1626
… …
1339 my ($self) = @_; 1631 my ($self) = @_;
1340 1632
1341 $self->reset_at <= $cf::RUNTIME 1633 $self->reset_at <= $cf::RUNTIME
1342} 1634}
1343 1635
1344sub unlink_save {
1345 my ($self) = @_;
1346
1347 utf8::encode (my $save = $self->{path}->save_path);
1348 aioreq_pri 3; IO::AIO::aio_unlink $save;
1349 aioreq_pri 3; IO::AIO::aio_unlink "$save.pst";
1350}
1351
1352sub rename {
1353 my ($self, $new_path) = @_;
1354
1355 $self->unlink_save;
1356
1357 delete $cf::MAP{$self->path};
1358 $self->{path} = new cf::path $new_path;
1359 $self->path ($self->{path}->as_string);
1360 $cf::MAP{$self->path} = $self;
1361
1362 $self->save;
1363}
1364
1365sub reset { 1636sub reset {
1366 my ($self) = @_; 1637 my ($self) = @_;
1367 1638
1639 my $lock = cf::lock_acquire "map_data:$self->{path}";
1640
1368 return if $self->players; 1641 return if $self->players;
1369 return if $self->{path}{user_rel};#d# 1642 return if $self->isa ("ext::map_per_player");#d#
1370 1643
1371 warn "resetting map ", $self->path;#d# 1644 warn "resetting map ", $self->path;#d#
1372 1645
1646 $self->in_memory (cf::MAP_SWAPPED);
1647
1648 # need to save uniques path
1649 unless ($self->{deny_save}) {
1650 my $uniq = $self->uniq_path; utf8::encode $uniq;
1651
1652 $self->_save_objects ($uniq, cf::IO_UNIQUES)
1653 if $uniq;
1654 }
1655
1373 delete $cf::MAP{$self->path}; 1656 delete $cf::MAP{$self->path};
1657
1658 $self->clear;
1374 1659
1375 $_->clear_links_to ($self) for values %cf::MAP; 1660 $_->clear_links_to ($self) for values %cf::MAP;
1376 1661
1377 $self->unlink_save; 1662 $self->unlink_save;
1378 $self->destroy; 1663 $self->destroy;
… …
1381my $nuke_counter = "aaaa"; 1666my $nuke_counter = "aaaa";
1382 1667
1383sub nuke { 1668sub nuke {
1384 my ($self) = @_; 1669 my ($self) = @_;
1385 1670
1671 delete $cf::MAP{$self->path};
1672
1673 $self->unlink_save;
1674
1675 bless $self, "cf::map";
1676 delete $self->{deny_reset};
1386 $self->{deny_save} = 1; 1677 $self->{deny_save} = 1;
1387 $self->reset_timeout (1); 1678 $self->reset_timeout (1);
1388 $self->rename ("{nuke}/" . ($nuke_counter++)); 1679 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));
1680
1681 $cf::MAP{$self->path} = $self;
1682
1389 $self->reset; # polite request, might not happen 1683 $self->reset; # polite request, might not happen
1390} 1684}
1391 1685
1392sub customise_for { 1686=item cf::map::unique_maps
1393 my ($map, $ob) = @_;
1394 1687
1395 if ($map->per_player) { 1688Returns an arrayref of paths of all shared maps that have
1396 return cf::map::find_map "~" . $ob->name . "/" . $map->{path}{path}; 1689instantiated unique items. May block.
1397 }
1398 1690
1399 $map 1691=cut
1400}
1401 1692
1402sub emergency_save { 1693sub unique_maps() {
1403 local $cf::FREEZE = 1; 1694 my $files = aio_readdir cf::localdir . "/" . cf::uniquedir
1695 or return;
1404 1696
1405 warn "enter emergency map save\n"; 1697 my @paths;
1406 1698
1407 cf::sync_job { 1699 for (@$files) {
1408 warn "begin emergency map save\n"; 1700 utf8::decode $_;
1409 $_->save for values %cf::MAP; 1701 next if /\.pst$/;
1702 next unless /^$PATH_SEP/o;
1703
1704 push @paths, cf::map::normalise $_;
1410 }; 1705 }
1411 1706
1412 warn "end emergency map save\n"; 1707 \@paths
1413} 1708}
1414 1709
1415package cf; 1710package cf;
1416 1711
1417=back 1712=back
1418 1713
1714=head3 cf::object
1715
1716=cut
1717
1718package cf::object;
1719
1720=over 4
1721
1722=item $ob->inv_recursive
1723
1724Returns the inventory of the object _and_ their inventories, recursively.
1725
1726=cut
1727
1728sub inv_recursive_;
1729sub inv_recursive_ {
1730 map { $_, inv_recursive_ $_->inv } @_
1731}
1732
1733sub inv_recursive {
1734 inv_recursive_ inv $_[0]
1735}
1736
1737package cf;
1738
1739=back
1419 1740
1420=head3 cf::object::player 1741=head3 cf::object::player
1421 1742
1422=over 4 1743=over 4
1423 1744
… …
1463 1784
1464=item $player_object->enter_link 1785=item $player_object->enter_link
1465 1786
1466Freezes the player and moves him/her to a special map (C<{link}>). 1787Freezes the player and moves him/her to a special map (C<{link}>).
1467 1788
1468The player should be reaosnably safe there for short amounts of time. You 1789The player should be reasonably safe there for short amounts of time. You
1469I<MUST> call C<leave_link> as soon as possible, though. 1790I<MUST> call C<leave_link> as soon as possible, though.
1470 1791
1792Will never block.
1793
1471=item $player_object->leave_link ($map, $x, $y) 1794=item $player_object->leave_link ($map, $x, $y)
1472 1795
1473Moves the player out of the specila link map onto the given map. If the 1796Moves the player out of the special C<{link}> map onto the specified
1474map is not valid (or omitted), the player will be moved back to the 1797map. If the map is not valid (or omitted), the player will be moved back
1475location he/she was before the call to C<enter_link>, or, if that fails, 1798to the location he/she was before the call to C<enter_link>, or, if that
1476to the emergency map position. 1799fails, to the emergency map position.
1477 1800
1478Might block. 1801Might block.
1479 1802
1480=cut 1803=cut
1804
1805sub link_map {
1806 unless ($LINK_MAP) {
1807 $LINK_MAP = cf::map::find "{link}"
1808 or cf::cleanup "FATAL: unable to provide {link} map, exiting.";
1809 $LINK_MAP->load;
1810 }
1811
1812 $LINK_MAP
1813}
1481 1814
1482sub cf::object::player::enter_link { 1815sub cf::object::player::enter_link {
1483 my ($self) = @_; 1816 my ($self) = @_;
1484 1817
1485 $self->deactivate_recursive; 1818 $self->deactivate_recursive;
1486 1819
1487 return if $self->map == $LINK_MAP; 1820 return if UNIVERSAL::isa $self->map, "ext::map_link";
1488 1821
1489 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y] 1822 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y]
1490 if $self->map; 1823 if $self->map;
1491 1824
1492 $self->enter_map ($LINK_MAP, 20, 20); 1825 $self->enter_map ($LINK_MAP || link_map, 10, 10);
1493} 1826}
1494 1827
1495sub cf::object::player::leave_link { 1828sub cf::object::player::leave_link {
1496 my ($self, $map, $x, $y) = @_; 1829 my ($self, $map, $x, $y) = @_;
1497 1830
1498 my $link_pos = delete $self->{_link_pos}; 1831 my $link_pos = delete $self->{_link_pos};
1499 1832
1500 unless ($map) { 1833 unless ($map) {
1501 # restore original map position 1834 # restore original map position
1502 ($map, $x, $y) = @{ $link_pos || [] }; 1835 ($map, $x, $y) = @{ $link_pos || [] };
1503 $map = cf::map::find_map $map; 1836 $map = cf::map::find $map;
1504 1837
1505 unless ($map) { 1838 unless ($map) {
1506 ($map, $x, $y) = @$EMERGENCY_POSITION; 1839 ($map, $x, $y) = @$EMERGENCY_POSITION;
1507 $map = cf::map::find_map $map 1840 $map = cf::map::find $map
1508 or die "FATAL: cannot load emergency map\n"; 1841 or die "FATAL: cannot load emergency map\n";
1509 } 1842 }
1510 } 1843 }
1511 1844
1512 ($x, $y) = (-1, -1) 1845 ($x, $y) = (-1, -1)
… …
1515 # use -1 or undef as default coordinates, not 0, 0 1848 # use -1 or undef as default coordinates, not 0, 0
1516 ($x, $y) = ($map->enter_x, $map->enter_y) 1849 ($x, $y) = ($map->enter_x, $map->enter_y)
1517 if $x <=0 && $y <= 0; 1850 if $x <=0 && $y <= 0;
1518 1851
1519 $map->load; 1852 $map->load;
1853 $map->load_diag;
1520 1854
1855 return unless $self->contr->active;
1521 $self->activate_recursive; 1856 $self->activate_recursive;
1857
1858 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
1522 $self->enter_map ($map, $x, $y); 1859 $self->enter_map ($map, $x, $y);
1523} 1860}
1524 1861
1525cf::player->attach ( 1862cf::player->attach (
1526 on_logout => sub { 1863 on_logout => sub {
… …
1538 1875
1539 # try to abort aborted map switching on player login :) 1876 # try to abort aborted map switching on player login :)
1540 # should happen only on crashes 1877 # should happen only on crashes
1541 if ($pl->ob->{_link_pos}) { 1878 if ($pl->ob->{_link_pos}) {
1542 $pl->ob->enter_link; 1879 $pl->ob->enter_link;
1543 Coro::async { 1880 (async {
1881 $pl->ob->reply (undef,
1882 "There was an internal problem at your last logout, "
1883 . "the server will try to bring you to your intended destination in a second.",
1884 cf::NDI_RED);
1544 # we need this sleep as the login has a concurrent enter_exit running 1885 # we need this sleep as the login has a concurrent enter_exit running
1545 # and this sleep increases chances of the player not ending up in scorn 1886 # and this sleep increases chances of the player not ending up in scorn
1546 Coro::Timer::sleep 1; 1887 Coro::Timer::sleep 1;
1547 $pl->ob->leave_link; 1888 $pl->ob->leave_link;
1548 }; 1889 })->prio (2);
1549 } 1890 }
1550 }, 1891 },
1551); 1892);
1552 1893
1553=item $player_object->goto_map ($path, $x, $y) 1894=item $player_object->goto ($path, $x, $y)
1554 1895
1555=cut 1896=cut
1556 1897
1557sub cf::object::player::goto_map { 1898sub cf::object::player::goto {
1558 my ($self, $path, $x, $y) = @_; 1899 my ($self, $path, $x, $y) = @_;
1559 1900
1560 $self->enter_link; 1901 $self->enter_link;
1561 1902
1562 (Coro::async { 1903 (async {
1563 $path = new cf::path $path; 1904 my $map = eval {
1564
1565 my $map = cf::map::find_map $path->as_string; 1905 my $map = cf::map::find $path;
1566 $map = $map->customise_for ($self) if $map; 1906 $map = $map->customise_for ($self) if $map;
1567 1907 $map
1568# warn "entering ", $map->path, " at ($x, $y)\n" 1908 } or
1569# if $map;
1570
1571 $map or $self->message ("The exit is closed", cf::NDI_UNIQUE | cf::NDI_RED); 1909 $self->message ("The exit to '$path' is closed", cf::NDI_UNIQUE | cf::NDI_RED);
1572 1910
1573 $self->leave_link ($map, $x, $y); 1911 $self->leave_link ($map, $x, $y);
1574 })->prio (1); 1912 })->prio (1);
1575} 1913}
1576 1914
… …
1580 1918
1581sub parse_random_map_params { 1919sub parse_random_map_params {
1582 my ($spec) = @_; 1920 my ($spec) = @_;
1583 1921
1584 my $rmp = { # defaults 1922 my $rmp = { # defaults
1585 xsize => 10, 1923 xsize => (cf::rndm 15, 40),
1586 ysize => 10, 1924 ysize => (cf::rndm 15, 40),
1925 symmetry => (cf::rndm 1, cf::SYMMETRY_XY),
1926 #layout => string,
1587 }; 1927 };
1588 1928
1589 for (split /\n/, $spec) { 1929 for (split /\n/, $spec) {
1590 my ($k, $v) = split /\s+/, $_, 2; 1930 my ($k, $v) = split /\s+/, $_, 2;
1591 1931
… …
1595 $rmp 1935 $rmp
1596} 1936}
1597 1937
1598sub prepare_random_map { 1938sub prepare_random_map {
1599 my ($exit) = @_; 1939 my ($exit) = @_;
1940
1941 my $guard = cf::lock_acquire "exit_prepare:$exit";
1600 1942
1601 # all this does is basically replace the /! path by 1943 # all this does is basically replace the /! path by
1602 # a new random map path (?random/...) with a seed 1944 # a new random map path (?random/...) with a seed
1603 # that depends on the exit object 1945 # that depends on the exit object
1604 1946
1605 my $rmp = parse_random_map_params $exit->msg; 1947 my $rmp = parse_random_map_params $exit->msg;
1606 1948
1607 if ($exit->map) { 1949 if ($exit->map) {
1608 $rmp->{region} = $exit->map->region_name; 1950 $rmp->{region} = $exit->region->name;
1609 $rmp->{origin_map} = $exit->map->path; 1951 $rmp->{origin_map} = $exit->map->path;
1610 $rmp->{origin_x} = $exit->x; 1952 $rmp->{origin_x} = $exit->x;
1611 $rmp->{origin_y} = $exit->y; 1953 $rmp->{origin_y} = $exit->y;
1612 } 1954 }
1613 1955
1614 $rmp->{random_seed} ||= $exit->random_seed; 1956 $rmp->{random_seed} ||= $exit->random_seed;
1615 1957
1616 my $data = cf::to_json $rmp; 1958 my $data = cf::to_json $rmp;
1617 my $md5 = Digest::MD5::md5_hex $data; 1959 my $md5 = Digest::MD5::md5_hex $data;
1960 my $meta = "$cf::RANDOM_MAPS/$md5.meta";
1618 1961
1619 if (my $fh = aio_open "$cf::RANDOM_MAPS/$md5.meta", O_WRONLY | O_CREAT, 0666) { 1962 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) {
1620 aio_write $fh, 0, (length $data), $data, 0; 1963 aio_write $fh, 0, (length $data), $data, 0;
1964 undef $fh;
1965 aio_rename "$meta~", $meta;
1621 1966
1622 $exit->slaying ("?random/$md5"); 1967 $exit->slaying ("?random/$md5");
1623 $exit->msg (undef); 1968 $exit->msg (undef);
1624 } 1969 }
1625} 1970}
… …
1627sub cf::object::player::enter_exit { 1972sub cf::object::player::enter_exit {
1628 my ($self, $exit) = @_; 1973 my ($self, $exit) = @_;
1629 1974
1630 return unless $self->type == cf::PLAYER; 1975 return unless $self->type == cf::PLAYER;
1631 1976
1977 if ($exit->slaying eq "/!") {
1978 #TODO: this should de-fi-ni-te-ly not be a sync-job
1979 # the problem is that $exit might not survive long enough
1980 # so it needs to be done right now, right here
1981 cf::sync_job { prepare_random_map $exit };
1982 }
1983
1984 my $slaying = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path;
1985 my $hp = $exit->stats->hp;
1986 my $sp = $exit->stats->sp;
1987
1632 $self->enter_link; 1988 $self->enter_link;
1633 1989
1634 (Coro::async { 1990 (async {
1991 $self->deactivate_recursive; # just to be sure
1635 unless (eval { 1992 unless (eval {
1636 1993 $self->goto ($slaying, $hp, $sp);
1637 prepare_random_map $exit
1638 if $exit->slaying eq "/!";
1639
1640 my $path = new cf::path $exit->slaying, $exit->map && $exit->map->path;
1641 $self->goto_map ($path, $exit->stats->hp, $exit->stats->sp);
1642 1994
1643 1; 1995 1;
1644 }) { 1996 }) {
1645 $self->message ("Something went wrong deep within the crossfire server. " 1997 $self->message ("Something went wrong deep within the crossfire server. "
1646 . "I'll try to bring you back to the map you were before. " 1998 . "I'll try to bring you back to the map you were before. "
1647 . "Please report this to the dungeon master", 1999 . "Please report this to the dungeon master!",
1648 cf::NDI_UNIQUE | cf::NDI_RED); 2000 cf::NDI_UNIQUE | cf::NDI_RED);
1649 2001
1650 warn "ERROR in enter_exit: $@"; 2002 warn "ERROR in enter_exit: $@";
1651 $self->leave_link; 2003 $self->leave_link;
1652 } 2004 }
1653 })->prio (1); 2005 })->prio (1);
… …
1666 2018
1667sub cf::client::send_drawinfo { 2019sub cf::client::send_drawinfo {
1668 my ($self, $text, $flags) = @_; 2020 my ($self, $text, $flags) = @_;
1669 2021
1670 utf8::encode $text; 2022 utf8::encode $text;
1671 $self->send_packet (sprintf "drawinfo %d %s", $flags, $text); 2023 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);
1672} 2024}
1673 2025
2026=item $client->ext_event ($type, %msg)
2027
2028Sends an exti event to the client.
2029
2030=cut
2031
2032sub cf::client::ext_event($$%) {
2033 my ($self, $type, %msg) = @_;
2034
2035 $msg{msgtype} = "event_$type";
2036 $self->send_packet ("ext " . cf::to_json \%msg);
2037}
1674 2038
1675=item $success = $client->query ($flags, "text", \&cb) 2039=item $success = $client->query ($flags, "text", \&cb)
1676 2040
1677Queues a query to the client, calling the given callback with 2041Queues a query to the client, calling the given callback with
1678the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>, 2042the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>,
… …
1703 on_reply => sub { 2067 on_reply => sub {
1704 my ($ns, $msg) = @_; 2068 my ($ns, $msg) = @_;
1705 2069
1706 # this weird shuffling is so that direct followup queries 2070 # this weird shuffling is so that direct followup queries
1707 # get handled first 2071 # get handled first
1708 my $queue = delete $ns->{query_queue}; 2072 my $queue = delete $ns->{query_queue}
2073 or return; # be conservative, not sure how that can happen, but we saw a crash here
1709 2074
1710 (shift @$queue)->[1]->($msg); 2075 (shift @$queue)->[1]->($msg);
2076 return unless $ns->valid; # temporary(?) workaround for callback destroying socket
1711 2077
1712 push @{ $ns->{query_queue} }, @$queue; 2078 push @{ $ns->{query_queue} }, @$queue;
1713 2079
1714 if (@{ $ns->{query_queue} } == @$queue) { 2080 if (@{ $ns->{query_queue} } == @$queue) {
1715 if (@$queue) { 2081 if (@$queue) {
… …
1719 } 2085 }
1720 } 2086 }
1721 }, 2087 },
1722); 2088);
1723 2089
1724=item $client->coro (\&cb) 2090=item $client->async (\&cb)
1725 2091
1726Create a new coroutine, running the specified callback. The coroutine will 2092Create a new coroutine, running the specified callback. The coroutine will
1727be automatically cancelled when the client gets destroyed (e.g. on logout, 2093be automatically cancelled when the client gets destroyed (e.g. on logout,
1728or loss of connection). 2094or loss of connection).
1729 2095
1730=cut 2096=cut
1731 2097
1732sub cf::client::coro { 2098sub cf::client::async {
1733 my ($self, $cb) = @_; 2099 my ($self, $cb) = @_;
1734 2100
1735 my $coro; $coro = async { 2101 my $coro = &Coro::async ($cb);
1736 eval {
1737 $cb->();
1738 };
1739 warn $@ if $@;
1740 };
1741 2102
1742 $coro->on_destroy (sub { 2103 $coro->on_destroy (sub {
1743 delete $self->{_coro}{$coro+0}; 2104 delete $self->{_coro}{$coro+0};
1744 }); 2105 });
1745 2106
… …
1778 2139
1779# here we export the classes and methods available to script code 2140# here we export the classes and methods available to script code
1780 2141
1781=pod 2142=pod
1782 2143
1783The following fucntions and emthods are available within a safe environment: 2144The following functions and methods are available within a safe environment:
1784 2145
1785 cf::object contr pay_amount pay_player map 2146 cf::object contr pay_amount pay_player map
1786 cf::object::player player 2147 cf::object::player player
1787 cf::player peaceful 2148 cf::player peaceful
1788 cf::map trigger 2149 cf::map trigger
… …
1881The parameter C<$family> should best start with the name of the extension 2242The parameter C<$family> should best start with the name of the extension
1882using it, it should be unique. 2243using it, it should be unique.
1883 2244
1884=over 4 2245=over 4
1885 2246
1886=item $hashref = cf::db_get $family
1887
1888Return a hashref for use by the extension C<$family>, which can be
1889modified. After modifications, you have to call C<cf::db_dirty> or
1890C<cf::db_sync>.
1891
1892=item $value = cf::db_get $family => $key 2247=item $value = cf::db_get $family => $key
1893 2248
1894Returns a single value from the database 2249Returns a single value from the database.
1895
1896=item cf::db_put $family => $hashref
1897
1898Stores the given family hashref into the database. Updates are delayed, if
1899you want the data to be synced to disk immediately, use C<cf::db_sync>.
1900 2250
1901=item cf::db_put $family => $key => $value 2251=item cf::db_put $family => $key => $value
1902 2252
1903Stores the given C<$value> in the family hash. Updates are delayed, if you 2253Stores the given C<$value> in the family.
1904want the data to be synced to disk immediately, use C<cf::db_sync>.
1905
1906=item cf::db_dirty
1907
1908Marks the database as dirty, to be updated at a later time.
1909
1910=item cf::db_sync
1911
1912Immediately write the database to disk I<if it is dirty>.
1913 2254
1914=cut 2255=cut
1915 2256
1916our $DB; 2257our $DB;
1917 2258
1918{ 2259sub db_init {
2260 unless ($DB) {
2261 $DB = BDB::db_create $DB_ENV;
2262
2263 cf::sync_job {
2264 eval {
2265 $DB->set_flags (BDB::CHKSUM);
2266
2267 BDB::db_open $DB, undef, "db", undef, BDB::BTREE,
2268 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
2269 cf::cleanup "db_open(db): $!" if $!;
2270 };
2271 cf::cleanup "db_open(db): $@" if $@;
2272 };
2273
1919 my $path = cf::localdir . "/database.pst"; 2274 my $path = cf::localdir . "/database.pst";
2275 if (stat $path) {
2276 cf::sync_job {
2277 my $pst = Storable::retrieve $path;
1920 2278
1921 sub db_load() { 2279 cf::db_put (board => data => $pst->{board});
1922 $DB = stat $path ? Storable::retrieve $path : { }; 2280 cf::db_put (guildrules => data => $pst->{guildrules});
1923 } 2281 cf::db_put (rent => balance => $pst->{rent}{balance});
2282 BDB::db_env_txn_checkpoint $DB_ENV;
1924 2283
1925 my $pid; 2284 unlink $path;
1926
1927 sub db_save() {
1928 waitpid $pid, 0 if $pid;
1929 if (0 == ($pid = fork)) {
1930 $DB->{_meta}{version} = 1;
1931 Storable::nstore $DB, "$path~";
1932 rename "$path~", $path;
1933 cf::_exit 0 if defined $pid;
1934 } 2285 };
1935 }
1936
1937 my $dirty;
1938
1939 sub db_sync() {
1940 db_save if $dirty;
1941 undef $dirty;
1942 }
1943
1944 my $idle = Event->idle (min => $TICK * 2.8, max => 10, repeat => 0, data => WF_AUTOCANCEL, cb => sub {
1945 db_sync;
1946 });
1947
1948 sub db_dirty() {
1949 $dirty = 1;
1950 $idle->start;
1951 }
1952
1953 sub db_get($;$) {
1954 @_ >= 2
1955 ? $DB->{$_[0]}{$_[1]}
1956 : ($DB->{$_[0]} ||= { })
1957 }
1958
1959 sub db_put($$;$) {
1960 if (@_ >= 3) {
1961 $DB->{$_[0]}{$_[1]} = $_[2];
1962 } else {
1963 $DB->{$_[0]} = $_[1];
1964 }
1965 db_dirty;
1966 }
1967
1968 cf::global->attach (
1969 prio => 10000,
1970 on_cleanup => sub {
1971 db_sync;
1972 }, 2286 }
1973 ); 2287 }
2288}
2289
2290sub db_get($$) {
2291 my $key = "$_[0]/$_[1]";
2292
2293 cf::sync_job {
2294 BDB::db_get $DB, undef, $key, my $data;
2295
2296 $! ? ()
2297 : Compress::LZF::sthaw $data
2298 }
2299}
2300
2301sub db_put($$$) {
2302 BDB::dbreq_pri 4;
2303 BDB::db_put $DB, undef, "$_[0]/$_[1]", Compress::LZF::sfreeze_cr $_[2], 0, sub { };
1974} 2304}
1975 2305
1976############################################################################# 2306#############################################################################
1977# the server's main() 2307# the server's init and main functions
2308
2309sub load_facedata {
2310 my $path = sprintf "%s/facedata", cf::datadir;
2311
2312 warn "loading facedata from $path\n";
2313
2314 my $facedata;
2315 0 < aio_load $path, $facedata
2316 or die "$path: $!";
2317
2318 $facedata = Coro::Storable::thaw $facedata;
2319
2320 $facedata->{version} == 2
2321 or cf::cleanup "$path: version mismatch, cannot proceed.";
2322
2323 {
2324 my $faces = $facedata->{faceinfo};
2325
2326 while (my ($face, $info) = each %$faces) {
2327 my $idx = (cf::face::find $face) || cf::face::alloc $face;
2328 cf::face::set $idx, $info->{visibility}, $info->{magicmap};
2329 cf::face::set_data $idx, 0, $info->{data32}, $info->{chksum32};
2330 cf::face::set_data $idx, 1, $info->{data64}, $info->{chksum64};
2331 Coro::cede;
2332 }
2333
2334 while (my ($face, $info) = each %$faces) {
2335 next unless $info->{smooth};
2336 my $idx = cf::face::find $face
2337 or next;
2338 if (my $smooth = cf::face::find $info->{smooth}) {
2339 cf::face::set_smooth $idx, $smooth, $info->{smoothlevel};
2340 } else {
2341 warn "smooth face '$info->{smooth}' not found for face '$face'";
2342 }
2343 Coro::cede;
2344 }
2345 }
2346
2347 {
2348 my $anims = $facedata->{animinfo};
2349
2350 while (my ($anim, $info) = each %$anims) {
2351 cf::anim::set $anim, $info->{frames}, $info->{facings};
2352 Coro::cede;
2353 }
2354
2355 cf::anim::invalidate_all; # d'oh
2356 }
2357
2358 1
2359}
2360
2361sub reload_resources {
2362 load_resource_file sprintf "%s/%s/regions", cf::datadir, cf::mapdir
2363 or die "unable to load regions file\n";#d#
2364 load_facedata
2365 or die "unable to load facedata\n";#d#
2366}
2367
2368sub init {
2369 reload_resources;
2370}
1978 2371
1979sub cfg_load { 2372sub cfg_load {
1980 open my $fh, "<:utf8", cf::confdir . "/config" 2373 open my $fh, "<:utf8", cf::confdir . "/config"
1981 or return; 2374 or return;
1982 2375
1983 local $/; 2376 local $/;
1984 *CFG = YAML::Syck::Load <$fh>; 2377 *CFG = YAML::Syck::Load <$fh>;
2378
2379 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37];
2380
2381 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset};
2382 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset};
2383
2384 if (exists $CFG{mlockall}) {
2385 eval {
2386 $CFG{mlockall} ? eval "mlockall()" : eval "munlockall()"
2387 and die "WARNING: m(un)lockall failed: $!\n";
2388 };
2389 warn $@ if $@;
2390 }
1985} 2391}
1986 2392
1987sub main { 2393sub main {
1988 # we must not ever block the main coroutine 2394 # we must not ever block the main coroutine
1989 local $Coro::idle = sub { 2395 local $Coro::idle = sub {
1990 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d# 2396 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
1991 (Coro::unblock_sub { 2397 (async {
1992 Event::one_event; 2398 Event::one_event;
1993 })->(); 2399 })->prio (Coro::PRIO_MAX);
1994 }; 2400 };
1995 2401
1996 cfg_load; 2402 cfg_load;
1997 db_load; 2403 db_init;
1998 load_extensions; 2404 load_extensions;
2405
2406 $TICK_WATCHER->start;
1999 Event::loop; 2407 Event::loop;
2000} 2408}
2001 2409
2002############################################################################# 2410#############################################################################
2003# initialisation 2411# initialisation and cleanup
2412
2413# install some emergency cleanup handlers
2414BEGIN {
2415 for my $signal (qw(INT HUP TERM)) {
2416 Event->signal (
2417 reentrant => 0,
2418 data => WF_AUTOCANCEL,
2419 signal => $signal,
2420 prio => 0,
2421 cb => sub {
2422 cf::cleanup "SIG$signal";
2423 },
2424 );
2425 }
2426}
2427
2428sub emergency_save() {
2429 my $freeze_guard = cf::freeze_mainloop;
2430
2431 warn "enter emergency perl save\n";
2432
2433 cf::sync_job {
2434 # use a peculiar iteration method to avoid tripping on perl
2435 # refcount bugs in for. also avoids problems with players
2436 # and maps saved/destroyed asynchronously.
2437 warn "begin emergency player save\n";
2438 for my $login (keys %cf::PLAYER) {
2439 my $pl = $cf::PLAYER{$login} or next;
2440 $pl->valid or next;
2441 $pl->save;
2442 }
2443 warn "end emergency player save\n";
2444
2445 warn "begin emergency map save\n";
2446 for my $path (keys %cf::MAP) {
2447 my $map = $cf::MAP{$path} or next;
2448 $map->valid or next;
2449 $map->save;
2450 }
2451 warn "end emergency map save\n";
2452
2453 warn "begin emergency database checkpoint\n";
2454 BDB::db_env_txn_checkpoint $DB_ENV;
2455 warn "end emergency database checkpoint\n";
2456 };
2457
2458 warn "leave emergency perl save\n";
2459}
2460
2461sub post_cleanup {
2462 my ($make_core) = @_;
2463
2464 warn Carp::longmess "post_cleanup backtrace"
2465 if $make_core;
2466}
2004 2467
2005sub reload() { 2468sub reload() {
2006 # can/must only be called in main 2469 # can/must only be called in main
2007 if ($Coro::current != $Coro::main) { 2470 if ($Coro::current != $Coro::main) {
2008 warn "can only reload from main coroutine\n"; 2471 warn "can only reload from main coroutine";
2009 return; 2472 return;
2010 } 2473 }
2011 2474
2012 warn "reloading..."; 2475 warn "reloading...";
2013 2476
2014 local $FREEZE = 1; 2477 warn "entering sync_job";
2478
2479 cf::sync_job {
2480 cf::write_runtime; # external watchdog should not bark
2015 cf::emergency_save; 2481 cf::emergency_save;
2482 cf::write_runtime; # external watchdog should not bark
2016 2483
2017 eval { 2484 warn "syncing database to disk";
2485 BDB::db_env_txn_checkpoint $DB_ENV;
2486
2018 # if anything goes wrong in here, we should simply crash as we already saved 2487 # if anything goes wrong in here, we should simply crash as we already saved
2019 2488
2020 # cancel all watchers 2489 warn "cancelling all WF_AUTOCANCEL watchers";
2021 for (Event::all_watchers) { 2490 for (Event::all_watchers) {
2022 $_->cancel if $_->data & WF_AUTOCANCEL; 2491 $_->cancel if $_->data & WF_AUTOCANCEL;
2023 } 2492 }
2024 2493
2494 warn "flushing outstanding aio requests";
2495 for (;;) {
2496 BDB::flush;
2497 IO::AIO::flush;
2498 Coro::cede;
2499 last unless IO::AIO::nreqs || BDB::nreqs;
2500 warn "iterate...";
2501 }
2502
2503 ++$RELOAD;
2504
2025 # cancel all extension coros 2505 warn "cancelling all extension coros";
2026 $_->cancel for values %EXT_CORO; 2506 $_->cancel for values %EXT_CORO;
2027 %EXT_CORO = (); 2507 %EXT_CORO = ();
2028 2508
2029 # unload all extensions 2509 warn "removing commands";
2030 for (@exts) { 2510 %COMMAND = ();
2511
2512 warn "removing ext commands";
2513 %EXTCMD = ();
2514
2515 warn "unloading/nuking all extensions";
2516 for my $pkg (@EXTS) {
2031 warn "unloading <$_>"; 2517 warn "... unloading $pkg";
2032 unload_extension $_; 2518
2519 if (my $cb = $pkg->can ("unload")) {
2520 eval {
2521 $cb->($pkg);
2522 1
2523 } or warn "$pkg unloaded, but with errors: $@";
2033 } 2524 }
2034 2525
2526 warn "... nuking $pkg";
2527 Symbol::delete_package $pkg;
2528 }
2529
2035 # unload all modules loaded from $LIBDIR 2530 warn "unloading all perl modules loaded from $LIBDIR";
2036 while (my ($k, $v) = each %INC) { 2531 while (my ($k, $v) = each %INC) {
2037 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/; 2532 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
2038 2533
2039 warn "removing <$k>"; 2534 warn "... unloading $k";
2040 delete $INC{$k}; 2535 delete $INC{$k};
2041 2536
2042 $k =~ s/\.pm$//; 2537 $k =~ s/\.pm$//;
2043 $k =~ s/\//::/g; 2538 $k =~ s/\//::/g;
2044 2539
… …
2047 } 2542 }
2048 2543
2049 Symbol::delete_package $k; 2544 Symbol::delete_package $k;
2050 } 2545 }
2051 2546
2052 # sync database to disk
2053 cf::db_sync;
2054 IO::AIO::flush;
2055
2056 # get rid of safe::, as good as possible 2547 warn "getting rid of safe::, as good as possible";
2057 Symbol::delete_package "safe::$_" 2548 Symbol::delete_package "safe::$_"
2058 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region); 2549 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
2059 2550
2060 # remove register_script_function callbacks
2061 # TODO
2062
2063 # unload cf.pm "a bit" 2551 warn "unloading cf.pm \"a bit\"";
2064 delete $INC{"cf.pm"}; 2552 delete $INC{"cf.pm"};
2065 2553
2066 # don't, removes xs symbols, too, 2554 # don't, removes xs symbols, too,
2067 # and global variables created in xs 2555 # and global variables created in xs
2068 #Symbol::delete_package __PACKAGE__; 2556 #Symbol::delete_package __PACKAGE__;
2069 2557
2070 # reload cf.pm 2558 warn "unload completed, starting to reload now";
2559
2071 warn "reloading cf.pm"; 2560 warn "reloading cf.pm";
2072 require cf; 2561 require cf;
2073 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 2562 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
2074 2563
2075 # load config and database again 2564 warn "loading config and database again";
2076 cf::cfg_load; 2565 cf::cfg_load;
2077 cf::db_load;
2078 2566
2079 # load extensions
2080 warn "load extensions"; 2567 warn "loading extensions";
2081 cf::load_extensions; 2568 cf::load_extensions;
2082 2569
2083 # reattach attachments to objects 2570 warn "reattaching attachments to objects/players";
2084 warn "reattach"; 2571 _global_reattach; # objects, sockets
2085 _global_reattach; 2572 warn "reattaching attachments to maps";
2086 }; 2573 reattach $_ for values %MAP;
2574 warn "reattaching attachments to players";
2575 reattach $_ for values %PLAYER;
2087 2576
2088 if ($@) { 2577 warn "loading reloadable resources";
2578 reload_resources;
2579
2580 warn "leaving sync_job";
2581
2582 1
2583 } or do {
2089 warn $@; 2584 warn $@;
2090 warn "error while reloading, exiting."; 2585 warn "error while reloading, exiting.";
2091 exit 1; 2586 exit 1;
2092 } 2587 };
2093 2588
2094 warn "reloaded successfully"; 2589 warn "reloaded";
2095}; 2590};
2096 2591
2097############################################################################# 2592our $RELOAD_WATCHER; # used only during reload
2098
2099unless ($LINK_MAP) {
2100 $LINK_MAP = cf::map::new;
2101
2102 $LINK_MAP->width (41);
2103 $LINK_MAP->height (41);
2104 $LINK_MAP->alloc;
2105 $LINK_MAP->path ("{link}");
2106 $LINK_MAP->{path} = bless { path => "{link}" }, "cf::path";
2107 $LINK_MAP->in_memory (MAP_IN_MEMORY);
2108
2109 # dirty hack because... archetypes are not yet loaded
2110 Event->timer (
2111 after => 2,
2112 cb => sub {
2113 $_[0]->w->cancel;
2114
2115 # provide some exits "home"
2116 my $exit = cf::object::new "exit";
2117
2118 $exit->slaying ($EMERGENCY_POSITION->[0]);
2119 $exit->stats->hp ($EMERGENCY_POSITION->[1]);
2120 $exit->stats->sp ($EMERGENCY_POSITION->[2]);
2121
2122 $LINK_MAP->insert ($exit->clone, 19, 19);
2123 $LINK_MAP->insert ($exit->clone, 19, 20);
2124 $LINK_MAP->insert ($exit->clone, 19, 21);
2125 $LINK_MAP->insert ($exit->clone, 20, 19);
2126 $LINK_MAP->insert ($exit->clone, 20, 21);
2127 $LINK_MAP->insert ($exit->clone, 21, 19);
2128 $LINK_MAP->insert ($exit->clone, 21, 20);
2129 $LINK_MAP->insert ($exit->clone, 21, 21);
2130
2131 $exit->destroy;
2132 });
2133
2134 $LINK_MAP->{deny_save} = 1;
2135 $LINK_MAP->{deny_reset} = 1;
2136
2137 $cf::MAP{$LINK_MAP->path} = $LINK_MAP;
2138}
2139
2140register "<global>", __PACKAGE__;
2141 2593
2142register_command "reload" => sub { 2594register_command "reload" => sub {
2143 my ($who, $arg) = @_; 2595 my ($who, $arg) = @_;
2144 2596
2145 if ($who->flag (FLAG_WIZ)) { 2597 if ($who->flag (FLAG_WIZ)) {
2146 $who->message ("start of reload."); 2598 $who->message ("reloading server.");
2599
2600 # doing reload synchronously and two reloads happen back-to-back,
2601 # coro crashes during coro_state_free->destroy here.
2602
2603 $RELOAD_WATCHER ||= Event->timer (
2604 reentrant => 0,
2605 after => 0,
2606 data => WF_AUTOCANCEL,
2607 cb => sub {
2147 reload; 2608 reload;
2148 $who->message ("end of reload."); 2609 undef $RELOAD_WATCHER;
2610 },
2611 );
2149 } 2612 }
2150}; 2613};
2151 2614
2152unshift @INC, $LIBDIR; 2615unshift @INC, $LIBDIR;
2616
2617my $bug_warning = 0;
2153 2618
2154$TICK_WATCHER = Event->timer ( 2619$TICK_WATCHER = Event->timer (
2155 reentrant => 0, 2620 reentrant => 0,
2621 parked => 1,
2156 prio => 0, 2622 prio => 0,
2157 at => $NEXT_TICK || $TICK, 2623 at => $NEXT_TICK || $TICK,
2158 data => WF_AUTOCANCEL, 2624 data => WF_AUTOCANCEL,
2159 cb => sub { 2625 cb => sub {
2160 unless ($FREEZE) { 2626 if ($Coro::current != $Coro::main) {
2627 Carp::cluck "major BUG: server tick called outside of main coro, skipping it"
2628 unless ++$bug_warning > 10;
2629 return;
2630 }
2631
2632 $NOW = Event::time;
2633
2161 cf::server_tick; # one server iteration 2634 cf::server_tick; # one server iteration
2162 $RUNTIME += $TICK; 2635 $RUNTIME += $TICK;
2163 }
2164
2165 $NEXT_TICK += $TICK; 2636 $NEXT_TICK += $TICK;
2637
2638 if ($NOW >= $NEXT_RUNTIME_WRITE) {
2639 $NEXT_RUNTIME_WRITE = $NOW + 10;
2640 Coro::async_pool {
2641 write_runtime
2642 or warn "ERROR: unable to write runtime file: $!";
2643 };
2644 }
2645
2646 $WAIT_FOR_TICK->broadcast;
2647 $WAIT_FOR_TICK_ONE->send if $WAIT_FOR_TICK_ONE->awaited;
2648
2649# my $AFTER = Event::time;
2650# warn $AFTER - $NOW;#d#
2166 2651
2167 # if we are delayed by four ticks or more, skip them all 2652 # if we are delayed by four ticks or more, skip them all
2168 $NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4; 2653 $NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4;
2169 2654
2170 $TICK_WATCHER->at ($NEXT_TICK); 2655 $TICK_WATCHER->at ($NEXT_TICK);
2171 $TICK_WATCHER->start; 2656 $TICK_WATCHER->start;
2172 }, 2657 },
2173); 2658);
2174 2659
2660{
2175IO::AIO::max_poll_time $TICK * 0.2; 2661 BDB::max_poll_time $TICK * 0.1;
2176 2662 $BDB_POLL_WATCHER = Event->io (
2177Event->io ( 2663 reentrant => 0,
2178 fd => IO::AIO::poll_fileno, 2664 fd => BDB::poll_fileno,
2179 poll => 'r', 2665 poll => 'r',
2180 prio => 5, 2666 prio => 0,
2181 data => WF_AUTOCANCEL,
2182 cb => \&IO::AIO::poll_cb,
2183);
2184
2185Event->timer (
2186 data => WF_AUTOCANCEL, 2667 data => WF_AUTOCANCEL,
2187 after => 0, 2668 cb => \&BDB::poll_cb,
2188 interval => 10, 2669 );
2189 cb => sub { 2670 BDB::min_parallel 8;
2190 (Coro::unblock_sub { 2671
2191 write_runtime 2672 BDB::set_sync_prepare {
2192 or warn "ERROR: unable to write runtime file: $!"; 2673 my $status;
2674 my $current = $Coro::current;
2675 (
2676 sub {
2677 $status = $!;
2678 $current->ready; undef $current;
2679 },
2680 sub {
2681 Coro::schedule while defined $current;
2682 $! = $status;
2683 },
2684 )
2685 };
2686
2687 unless ($DB_ENV) {
2688 $DB_ENV = BDB::db_env_create;
2689
2690 cf::sync_job {
2691 eval {
2692 BDB::db_env_open
2693 $DB_ENV,
2694 $BDB_ENV_DIR,
2695 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN
2696 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE,
2697 0666;
2698
2699 cf::cleanup "db_env_open($BDB_ENV_DIR): $!" if $!;
2700
2701 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC, 1);
2702 $DB_ENV->set_lk_detect;
2703 };
2704
2705 cf::cleanup "db_env_open(db): $@" if $@;
2193 })->(); 2706 };
2194 }, 2707 }
2195); 2708}
2709
2710{
2711 IO::AIO::min_parallel 8;
2712
2713 undef $Coro::AIO::WATCHER;
2714 IO::AIO::max_poll_time $TICK * 0.1;
2715 $AIO_POLL_WATCHER = Event->io (
2716 reentrant => 0,
2717 data => WF_AUTOCANCEL,
2718 fd => IO::AIO::poll_fileno,
2719 poll => 'r',
2720 prio => 6,
2721 cb => \&IO::AIO::poll_cb,
2722 );
2723}
2196 2724
2197END { cf::emergency_save } 2725END { cf::emergency_save }
2198 2726
21991 27271
2200 2728

Diff Legend

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