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.155 by root, Tue Jan 9 21:32:42 2007 UTC vs.
Revision 1.272 by root, Sun Jun 3 15:32:50 2007 UTC

… …
3use utf8; 3use utf8;
4use strict; 4use strict;
5 5
6use Symbol; 6use Symbol;
7use List::Util; 7use List::Util;
8use Socket;
8use Storable; 9use Storable;
10use Event;
9use Opcode; 11use Opcode;
10use Safe; 12use Safe;
11use Safe::Hole; 13use Safe::Hole;
12 14
13use Coro 3.3 (); 15use Coro 3.61 ();
16use Coro::State;
17use Coro::Handle;
14use Coro::Event; 18use Coro::Event;
15use Coro::Timer; 19use Coro::Timer;
16use Coro::Signal; 20use Coro::Signal;
17use Coro::Semaphore; 21use Coro::Semaphore;
18use Coro::AIO; 22use Coro::AIO;
23use Coro::Storable;
19 24
25use BDB ();
20use Data::Dumper; 26use Data::Dumper;
21use Digest::MD5; 27use Digest::MD5;
22use Fcntl; 28use Fcntl;
29use YAML::Syck ();
23use IO::AIO 2.32 (); 30use IO::AIO 2.32 ();
24use YAML::Syck ();
25use Time::HiRes; 31use Time::HiRes;
32use Compress::LZF;
26 33
34# configure various modules to our taste
35#
36$Storable::canonical = 1; # reduce rsync transfers
37Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator
38Compress::LZF::sfreeze_cr { }; # prime Compress::LZF so it does not use require later
39
27use Event; $Event::Eval = 1; # no idea why this is required, but it is 40$Event::Eval = 1; # no idea why this is required, but it is
28
29sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
30 41
31# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode? 42# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode?
32$YAML::Syck::ImplicitUnicode = 1; 43$YAML::Syck::ImplicitUnicode = 1;
33 44
34$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority 45$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority
35 46
47sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
48
36our %COMMAND = (); 49our %COMMAND = ();
37our %COMMAND_TIME = (); 50our %COMMAND_TIME = ();
51
52our @EXTS = (); # list of extension package names
38our %EXTCMD = (); 53our %EXTCMD = ();
54our %EXT_CORO = (); # coroutines bound to extensions
55our %EXT_MAP = (); # pluggable maps
39 56
57our $RELOAD; # number of reloads so far
40our @EVENT; 58our @EVENT;
41our $LIBDIR = datadir . "/ext";
42 59
43our $TICK = MAX_TIME * 1e-6; 60our $CONFDIR = confdir;
61our $DATADIR = datadir;
62our $LIBDIR = "$DATADIR/ext";
63our $PODDIR = "$DATADIR/pod";
64our $MAPDIR = "$DATADIR/" . mapdir;
65our $LOCALDIR = localdir;
66our $TMPDIR = "$LOCALDIR/" . tmpdir;
67our $UNIQUEDIR = "$LOCALDIR/" . uniquedir;
68our $PLAYERDIR = "$LOCALDIR/" . playerdir;
69our $RANDOMDIR = "$LOCALDIR/random";
70our $BDBDIR = "$LOCALDIR/db";
71
72our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!)
44our $TICK_WATCHER; 73our $TICK_WATCHER;
74our $AIO_POLL_WATCHER;
75our $NEXT_RUNTIME_WRITE; # when should the runtime file be written
45our $NEXT_TICK; 76our $NEXT_TICK;
46our $NOW; 77our $NOW;
78our $USE_FSYNC = 1; # use fsync to write maps - default off
79
80our $BDB_POLL_WATCHER;
81our $DB_ENV;
47 82
48our %CFG; 83our %CFG;
49 84
50our $UPTIME; $UPTIME ||= time; 85our $UPTIME; $UPTIME ||= time;
51our $RUNTIME; 86our $RUNTIME;
52 87
53our %PLAYER; # all users 88our %PLAYER; # all users
54our %MAP; # all maps 89our %MAP; # all maps
55our $LINK_MAP; # the special {link} map 90our $LINK_MAP; # the special {link} map, which is always available
56our $RANDOM_MAPS = cf::localdir . "/random";
57our %EXT_CORO; # coroutines bound to extensions
58 91
59our $WAIT_FOR_TICK; $WAIT_FOR_TICK ||= new Coro::Signal; 92# used to convert map paths into valid unix filenames by replacing / by ∕
60our $WAIT_FOR_TICK_ONE; $WAIT_FOR_TICK_ONE ||= new Coro::Signal; 93our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons
94
95our $LOAD; # a number between 0 (idle) and 1 (too many objects)
96our $LOADAVG; # same thing, but with alpha-smoothing
97our $tick_start; # for load detecting purposes
61 98
62binmode STDOUT; 99binmode STDOUT;
63binmode STDERR; 100binmode STDERR;
64 101
65# read virtual server time, if available 102# read virtual server time, if available
66unless ($RUNTIME || !-e cf::localdir . "/runtime") { 103unless ($RUNTIME || !-e "$LOCALDIR/runtime") {
67 open my $fh, "<", cf::localdir . "/runtime" 104 open my $fh, "<", "$LOCALDIR/runtime"
68 or die "unable to read runtime file: $!"; 105 or die "unable to read runtime file: $!";
69 $RUNTIME = <$fh> + 0.; 106 $RUNTIME = <$fh> + 0.;
70} 107}
71 108
72mkdir cf::localdir; 109mkdir $_
73mkdir cf::localdir . "/" . cf::playerdir; 110 for $LOCALDIR, $TMPDIR, $UNIQUEDIR, $PLAYERDIR, $RANDOMDIR, $BDBDIR;
74mkdir cf::localdir . "/" . cf::tmpdir;
75mkdir cf::localdir . "/" . cf::uniquedir;
76mkdir $RANDOM_MAPS;
77 111
78# a special map that is always available
79our $LINK_MAP;
80our $EMERGENCY_POSITION; 112our $EMERGENCY_POSITION;
113
114sub cf::map::normalise;
81 115
82############################################################################# 116#############################################################################
83 117
84=head2 GLOBAL VARIABLES 118=head2 GLOBAL VARIABLES
85 119
… …
92=item $cf::RUNTIME 126=item $cf::RUNTIME
93 127
94The time this server has run, starts at 0 and is increased by $cf::TICK on 128The time this server has run, starts at 0 and is increased by $cf::TICK on
95every server tick. 129every server tick.
96 130
97=item $cf::LIBDIR 131=item $cf::CONFDIR $cf::DATADIR $cf::LIBDIR $cf::PODDIR
132$cf::MAPDIR $cf::LOCALDIR $cf::TMPDIR $cf::UNIQUEDIR
133$cf::PLAYERDIR $cf::RANDOMDIR $cf::BDBDIR
98 134
99The perl library directory, where extensions and cf-specific modules can 135Various directories - "/etc", read-only install directory, perl-library
100be found. It will be added to C<@INC> automatically. 136directory, pod-directory, read-only maps directory, "/var", "/var/tmp",
137unique-items directory, player file directory, random maps directory and
138database environment.
101 139
102=item $cf::NOW 140=item $cf::NOW
103 141
104The time of the last (current) server tick. 142The time of the last (current) server tick.
105 143
106=item $cf::TICK 144=item $cf::TICK
107 145
108The interval between server ticks, in seconds. 146The interval between server ticks, in seconds.
147
148=item $cf::LOADAVG
149
150The current CPU load on the server (alpha-smoothed), as a value between 0
151(none) and 1 (overloaded), indicating how much time is spent on processing
152objects per tick. Healthy values are < 0.5.
153
154=item $cf::LOAD
155
156The raw value load value from the last tick.
109 157
110=item %cf::CFG 158=item %cf::CFG
111 159
112Configuration for the server, loaded from C</etc/crossfire/config>, or 160Configuration for the server, loaded from C</etc/crossfire/config>, or
113from wherever your confdir points to. 161from wherever your confdir points to.
114 162
115=item $cf::WAIT_FOR_TICK, $cf::WAIT_FOR_TICK_ONE 163=item cf::wait_for_tick, cf::wait_for_tick_begin
116 164
117These are Coro::Signal objects that are C<< ->broadcast >> (WAIT_FOR_TICK) 165These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only
118or C<< ->send >> (WAIT_FOR_TICK_ONE) on after normal server tick 166returns directly I<after> the tick processing (and consequently, can only wake one process
119processing has been done. Call C<< ->wait >> on them to maximise the 167per tick), while cf::wait_for_tick wakes up all waiters after tick processing.
120window of cpu time available, or simply to synchronise to the server tick.
121 168
122=back 169=back
123 170
124=cut 171=cut
125 172
126BEGIN { 173BEGIN {
127 *CORE::GLOBAL::warn = sub { 174 *CORE::GLOBAL::warn = sub {
128 my $msg = join "", @_; 175 my $msg = join "", @_;
129 utf8::encode $msg;
130 176
131 $msg .= "\n" 177 $msg .= "\n"
132 unless $msg =~ /\n$/; 178 unless $msg =~ /\n$/;
133 179
180 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;
181
182 utf8::encode $msg;
134 LOG llevError, $msg; 183 LOG llevError, $msg;
135 }; 184 };
136} 185}
137 186
138@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable'; 187@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
… …
156} 205}
157 206
158$Event::DIED = sub { 207$Event::DIED = sub {
159 warn "error in event callback: @_"; 208 warn "error in event callback: @_";
160}; 209};
161
162my %ext_pkg;
163my @exts;
164my @hook;
165 210
166=head2 UTILITY FUNCTIONS 211=head2 UTILITY FUNCTIONS
167 212
168=over 4 213=over 4
169 214
… …
188 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge; 233 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge;
189 $d 234 $d
190 } || "[unable to dump $_[0]: '$@']"; 235 } || "[unable to dump $_[0]: '$@']";
191} 236}
192 237
193use JSON::Syck (); # TODO# replace by JSON::PC once working 238use JSON::XS qw(to_json from_json); # TODO# replace by JSON::PC once working
194 239
195=item $ref = cf::from_json $json 240=item $ref = cf::from_json $json
196 241
197Converts a JSON string into the corresponding perl data structure. 242Converts a JSON string into the corresponding perl data structure.
198 243
199=cut
200
201sub from_json($) {
202 $JSON::Syck::ImplicitUnicode = 1; # work around JSON::Syck bugs
203 JSON::Syck::Load $_[0]
204}
205
206=item $json = cf::to_json $ref 244=item $json = cf::to_json $ref
207 245
208Converts a perl data structure into its JSON representation. 246Converts a perl data structure into its JSON representation.
209
210=cut
211
212sub to_json($) {
213 $JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs
214 JSON::Syck::Dump $_[0]
215}
216 247
217=item cf::lock_wait $string 248=item cf::lock_wait $string
218 249
219Wait until the given lock is available. See cf::lock_acquire. 250Wait until the given lock is available. See cf::lock_acquire.
220 251
… …
226returned. 257returned.
227 258
228Lock names should begin with a unique identifier (for example, cf::map::find 259Lock names should begin with a unique identifier (for example, cf::map::find
229uses map_find and cf::map::load uses map_load). 260uses map_find and cf::map::load uses map_load).
230 261
262=item $locked = cf::lock_active $string
263
264Return true if the lock is currently active, i.e. somebody has locked it.
265
231=cut 266=cut
232 267
233our %LOCK; 268our %LOCK;
234 269
235sub lock_wait($) { 270sub lock_wait($) {
… …
254 # wake up all waiters, to be on the safe side 289 # wake up all waiters, to be on the safe side
255 $_->ready for @{ delete $LOCK{$key} }; 290 $_->ready for @{ delete $LOCK{$key} };
256 } 291 }
257} 292}
258 293
294sub lock_active($) {
295 my ($key) = @_;
296
297 ! ! $LOCK{$key}
298}
299
259sub freeze_mainloop { 300sub freeze_mainloop {
260 return unless $TICK_WATCHER->is_active; 301 return unless $TICK_WATCHER->is_active;
261 302
262 my $guard = Coro::guard { $TICK_WATCHER->start }; 303 my $guard = Coro::guard {
304 $TICK_WATCHER->start;
305 };
263 $TICK_WATCHER->stop; 306 $TICK_WATCHER->stop;
264 $guard 307 $guard
265} 308}
266 309
267=item cf::async { BLOCK } 310=item cf::async { BLOCK }
… …
289 332
290sub sync_job(&) { 333sub sync_job(&) {
291 my ($job) = @_; 334 my ($job) = @_;
292 335
293 if ($Coro::current == $Coro::main) { 336 if ($Coro::current == $Coro::main) {
337 my $time = Event::time;
338
294 # this is the main coro, too bad, we have to block 339 # this is the main coro, too bad, we have to block
295 # till the operation succeeds, freezing the server :/ 340 # till the operation succeeds, freezing the server :/
296 341
297 # TODO: use suspend/resume instead 342 # TODO: use suspend/resume instead
298 # (but this is cancel-safe) 343 # (but this is cancel-safe)
… …
309 354
310 while ($busy) { 355 while ($busy) {
311 Coro::cede or Event::one_event; 356 Coro::cede or Event::one_event;
312 } 357 }
313 358
359 $time = Event::time - $time;
360
361 LOG llevError | logBacktrace, Carp::longmess "long sync job"
362 if $time > $TICK * 0.5 && $TICK_WATCHER->is_active;
363
364 $tick_start += $time; # do not account sync jobs to server load
365
314 wantarray ? @res : $res[0] 366 wantarray ? @res : $res[0]
315 } else { 367 } else {
316 # we are in another coroutine, how wonderful, everything just works 368 # we are in another coroutine, how wonderful, everything just works
317 369
318 $job->() 370 $job->()
319 } 371 }
320} 372}
321 373
322=item $coro = cf::async_ext { BLOCK } 374=item $coro = cf::async_ext { BLOCK }
323 375
324Like async, but this coro is automcatially being canceled when the 376Like async, but this coro is automatically being canceled when the
325extension calling this is being unloaded. 377extension calling this is being unloaded.
326 378
327=cut 379=cut
328 380
329sub async_ext(&) { 381sub async_ext(&) {
… …
338 390
339 $coro 391 $coro
340} 392}
341 393
342sub write_runtime { 394sub write_runtime {
343 my $runtime = cf::localdir . "/runtime"; 395 my $runtime = "$LOCALDIR/runtime";
396
397 # first touch the runtime file to show we are still running:
398 # the fsync below can take a very very long time.
399
400 IO::AIO::aio_utime $runtime, undef, undef;
401
402 my $guard = cf::lock_acquire "write_runtime";
344 403
345 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644 404 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644
346 or return; 405 or return;
347 406
407 my $value = $cf::RUNTIME + 90 + 10;
348 my $value = $cf::RUNTIME + 1 + 10; # 10 is the runtime save interval, for a monotonic clock 408 # 10 is the runtime save interval, for a monotonic clock
409 # 60 allows for the watchdog to kill the server.
410
349 (aio_write $fh, 0, (length $value), $value, 0) <= 0 411 (aio_write $fh, 0, (length $value), $value, 0) <= 0
350 and return; 412 and return;
351 413
414 # always fsync - this file is important
352 aio_fsync $fh 415 aio_fsync $fh
353 and return; 416 and return;
354 417
418 # touch it again to show we are up-to-date
419 aio_utime $fh, undef, undef;
420
355 close $fh 421 close $fh
356 or return; 422 or return;
357 423
358 aio_rename "$runtime~", $runtime 424 aio_rename "$runtime~", $runtime
359 and return; 425 and return;
360 426
427 warn "runtime file written.\n";#d#
428
361 1 429 1
362} 430}
363 431
432=item cf::datalog type => key => value, ...
433
434Log a datalog packet of the given type with the given key-value pairs.
435
436=cut
437
438sub datalog($@) {
439 my ($type, %kv) = @_;
440 warn "DATALOG ", JSON::XS->new->ascii->encode ({ %kv, type => $type });
441}
442
364=back 443=back
365 444
366=cut 445=cut
367
368#############################################################################
369
370package cf::path;
371
372# used to convert map paths into valid unix filenames by repalcing / by ∕
373our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons
374
375sub new {
376 my ($class, $path, $base) = @_;
377
378 $path = $path->as_string if ref $path;
379
380 my $self = bless { }, $class;
381
382 # {... are special paths that are not touched
383 # ?xxx/... are special absolute paths
384 # ?random/... random maps
385 # /! non-realised random map exit
386 # /... normal maps
387 # ~/... per-player maps without a specific player (DO NOT USE)
388 # ~user/... per-player map of a specific user
389
390 if ($path =~ /^{/) {
391 # fine as it is
392 } elsif ($path =~ s{^\?random/}{}) {
393 Coro::AIO::aio_load "$cf::RANDOM_MAPS/$path.meta", my $data;
394 $self->{random} = cf::from_json $data;
395 } else {
396 if ($path =~ s{^~([^/]+)?}{}) {
397 $self->{user_rel} = 1;
398
399 if (defined $1) {
400 $self->{user} = $1;
401 } elsif ($base =~ m{^~([^/]+)/}) {
402 $self->{user} = $1;
403 } else {
404 warn "cannot resolve user-relative path without user <$path,$base>\n";
405 }
406 } elsif ($path =~ /^\//) {
407 # already absolute
408 } else {
409 $base =~ s{[^/]+/?$}{};
410 return $class->new ("$base/$path");
411 }
412
413 for ($path) {
414 redo if s{/\.?/}{/};
415 redo if s{/[^/]+/\.\./}{/};
416 }
417 }
418
419 $self->{path} = $path;
420
421 $self
422}
423
424# the name / primary key / in-game path
425sub as_string {
426 my ($self) = @_;
427
428 $self->{user_rel} ? "~$self->{user}$self->{path}"
429 : $self->{random} ? "?random/$self->{path}"
430 : $self->{path}
431}
432
433# the displayed name, this is a one way mapping
434sub visible_name {
435 my ($self) = @_;
436
437# if (my $rmp = $self->{random}) {
438# # todo: be more intelligent about this
439# "?random/$rmp->{origin_map}+$rmp->{origin_x}+$rmp->{origin_y}/$rmp->{dungeon_level}"
440# } else {
441 $self->as_string
442# }
443}
444
445# escape the /'s in the path
446sub _escaped_path {
447 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g;
448 $path
449}
450
451# the original (read-only) location
452sub load_path {
453 my ($self) = @_;
454
455 sprintf "%s/%s/%s", cf::datadir, cf::mapdir, $self->{path}
456}
457
458# the temporary/swap location
459sub save_path {
460 my ($self) = @_;
461
462 $self->{user_rel} ? sprintf "%s/%s/%s/%s", cf::localdir, cf::playerdir, $self->{user}, $self->_escaped_path
463 : $self->{random} ? sprintf "%s/%s", $RANDOM_MAPS, $self->{path}
464 : sprintf "%s/%s/%s", cf::localdir, cf::tmpdir, $self->_escaped_path
465}
466
467# the unique path, might be eq to save_path
468sub uniq_path {
469 my ($self) = @_;
470
471 $self->{user_rel} || $self->{random}
472 ? undef
473 : sprintf "%s/%s/%s", cf::localdir, cf::uniquedir, $self->_escaped_path
474}
475
476# return random map parameters, or undef
477sub random_map_params {
478 my ($self) = @_;
479
480 $self->{random}
481}
482
483# this is somewhat ugly, but style maps do need special treatment
484sub is_style_map {
485 $_[0]{path} =~ m{^/styles/}
486}
487
488package cf;
489 446
490############################################################################# 447#############################################################################
491 448
492=head2 ATTACHABLE OBJECTS 449=head2 ATTACHABLE OBJECTS
493 450
… …
619our @CB_TYPE = (); # registry for type (cf-object class) based events 576our @CB_TYPE = (); # registry for type (cf-object class) based events
620our @CB_MAP = (); 577our @CB_MAP = ();
621 578
622my %attachment; 579my %attachment;
623 580
581sub cf::attachable::thawer_merge {
582 # simply override everything except _meta
583 local $_[0]{_meta};
584 %{$_[0]} = %{$_[1]};
585}
586
624sub _attach_cb($$$$) { 587sub _attach_cb($$$$) {
625 my ($registry, $event, $prio, $cb) = @_; 588 my ($registry, $event, $prio, $cb) = @_;
626 589
627 use sort 'stable'; 590 use sort 'stable';
628 591
… …
662 $registry = $CB_TYPE[$object_type] ||= []; 625 $registry = $CB_TYPE[$object_type] ||= [];
663 626
664 } elsif ($type eq "subtype") { 627 } elsif ($type eq "subtype") {
665 defined $object_type or Carp::croak "subtype specified without type"; 628 defined $object_type or Carp::croak "subtype specified without type";
666 my $object_subtype = shift @arg; 629 my $object_subtype = shift @arg;
667 $registry = $CB_TYPE[$object_type + $object_subtype * NUM_SUBTYPES] ||= []; 630 $registry = $CB_TYPE[$object_type + $object_subtype * NUM_TYPES] ||= [];
668 631
669 } elsif ($type eq "package") { 632 } elsif ($type eq "package") {
670 my $pkg = shift @arg; 633 my $pkg = shift @arg;
671 634
672 while (my ($name, $id) = each %cb_id) { 635 while (my ($name, $id) = each %cb_id) {
… …
713 if (ref $_[0]) { 676 if (ref $_[0]) {
714 _object_attach @_; 677 _object_attach @_;
715 } else { 678 } else {
716 _attach shift->_attach_registry, @_; 679 _attach shift->_attach_registry, @_;
717 } 680 }
681 _recalc_want;
718}; 682};
719 683
720# all those should be optimised 684# all those should be optimised
721sub cf::attachable::detach { 685sub cf::attachable::detach {
722 my ($obj, $name) = @_; 686 my ($obj, $name) = @_;
… …
725 delete $obj->{_attachment}{$name}; 689 delete $obj->{_attachment}{$name};
726 reattach ($obj); 690 reattach ($obj);
727 } else { 691 } else {
728 Carp::croak "cannot, currently, detach class attachments"; 692 Carp::croak "cannot, currently, detach class attachments";
729 } 693 }
694 _recalc_want;
730}; 695};
731 696
732sub cf::attachable::attached { 697sub cf::attachable::attached {
733 my ($obj, $name) = @_; 698 my ($obj, $name) = @_;
734 699
… …
799# object support 764# object support
800 765
801sub reattach { 766sub reattach {
802 # basically do the same as instantiate, without calling instantiate 767 # basically do the same as instantiate, without calling instantiate
803 my ($obj) = @_; 768 my ($obj) = @_;
769
770 bless $obj, ref $obj; # re-bless in case extensions have been reloaded
804 771
805 my $registry = $obj->registry; 772 my $registry = $obj->registry;
806 773
807 @$registry = (); 774 @$registry = ();
808 775
… …
855 $filename, length $$rdata, scalar @$objs; 822 $filename, length $$rdata, scalar @$objs;
856 823
857 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) { 824 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
858 chmod SAVE_MODE, $fh; 825 chmod SAVE_MODE, $fh;
859 aio_write $fh, 0, (length $$rdata), $$rdata, 0; 826 aio_write $fh, 0, (length $$rdata), $$rdata, 0;
860 aio_fsync $fh; 827 aio_fsync $fh if $cf::USE_FSYNC;
861 close $fh; 828 close $fh;
862 829
863 if (@$objs) { 830 if (@$objs) {
864 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) { 831 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) {
865 chmod SAVE_MODE, $fh; 832 chmod SAVE_MODE, $fh;
866 my $data = Storable::nfreeze { version => 1, objs => $objs }; 833 my $data = Storable::nfreeze { version => 1, objs => $objs };
867 aio_write $fh, 0, (length $data), $data, 0; 834 aio_write $fh, 0, (length $data), $data, 0;
868 aio_fsync $fh; 835 aio_fsync $fh if $cf::USE_FSYNC;
869 close $fh; 836 close $fh;
870 aio_rename "$filename.pst~", "$filename.pst"; 837 aio_rename "$filename.pst~", "$filename.pst";
871 } 838 }
872 } else { 839 } else {
873 aio_unlink "$filename.pst"; 840 aio_unlink "$filename.pst";
… …
940=cut 907=cut
941 908
942sub register_extcmd { 909sub register_extcmd {
943 my ($name, $cb) = @_; 910 my ($name, $cb) = @_;
944 911
945 my $caller = caller;
946 #warn "registering extcmd '$name' to '$caller'";
947
948 $EXTCMD{$name} = [$cb, $caller]; 912 $EXTCMD{$name} = $cb;
949} 913}
950 914
951cf::player->attach ( 915cf::player->attach (
952 on_command => sub { 916 on_command => sub {
953 my ($pl, $name, $params) = @_; 917 my ($pl, $name, $params) = @_;
… …
966 930
967 my $msg = eval { from_json $buf }; 931 my $msg = eval { from_json $buf };
968 932
969 if (ref $msg) { 933 if (ref $msg) {
970 if (my $cb = $EXTCMD{$msg->{msgtype}}) { 934 if (my $cb = $EXTCMD{$msg->{msgtype}}) {
971 if (my %reply = $cb->[0]->($pl, $msg)) { 935 if (my %reply = $cb->($pl, $msg)) {
972 $pl->ext_reply ($msg->{msgid}, %reply); 936 $pl->ext_reply ($msg->{msgid}, %reply);
973 } 937 }
974 } 938 }
975 } else { 939 } else {
976 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n"; 940 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
… …
978 942
979 cf::override; 943 cf::override;
980 }, 944 },
981); 945);
982 946
983sub register {
984 my ($base, $pkg) = @_;
985
986 #TODO
987}
988
989sub load_extension { 947sub load_extension {
990 my ($path) = @_; 948 my ($path) = @_;
991 949
992 $path =~ /([^\/\\]+)\.ext$/ or die "$path"; 950 $path =~ /([^\/\\]+)\.ext$/ or die "$path";
993 my $base = $1; 951 my $base = $1;
994 my $pkg = $1; 952 my $pkg = $1;
995 $pkg =~ s/[^[:word:]]/_/g; 953 $pkg =~ s/[^[:word:]]/_/g;
996 $pkg = "ext::$pkg"; 954 $pkg = "ext::$pkg";
997 955
998 warn "loading '$path' into '$pkg'\n"; 956 warn "... loading '$path' into '$pkg'\n";
999 957
1000 open my $fh, "<:utf8", $path 958 open my $fh, "<:utf8", $path
1001 or die "$path: $!"; 959 or die "$path: $!";
1002 960
1003 my $source = 961 my $source =
1004 "package $pkg; use strict; use utf8;\n" 962 "package $pkg; use strict; use utf8;\n"
1005 . "#line 1 \"$path\"\n{\n" 963 . "#line 1 \"$path\"\n{\n"
1006 . (do { local $/; <$fh> }) 964 . (do { local $/; <$fh> })
1007 . "\n};\n1"; 965 . "\n};\n1";
1008 966
1009 eval $source 967 unless (eval $source) {
1010 or die $@ ? "$path: $@\n" 968 my $msg = $@ ? "$path: $@\n"
1011 : "extension disabled.\n"; 969 : "extension disabled.\n";
1012 970 if ($source =~ /^#!.*perl.*#.*MANDATORY/m) { # ugly match
1013 push @exts, $pkg; 971 warn $@;
1014 $ext_pkg{$base} = $pkg; 972 warn "mandatory extension failed to load, exiting.\n";
1015 973 exit 1;
1016# no strict 'refs'; 974 }
1017# @{"$pkg\::ISA"} = ext::; 975 die $@;
1018
1019 register $base, $pkg;
1020}
1021
1022sub unload_extension {
1023 my ($pkg) = @_;
1024
1025 warn "removing extension $pkg\n";
1026
1027 # remove hooks
1028 #TODO
1029# for my $idx (0 .. $#PLUGIN_EVENT) {
1030# delete $hook[$idx]{$pkg};
1031# } 976 }
1032 977
1033 # remove commands 978 push @EXTS, $pkg;
1034 for my $name (keys %COMMAND) {
1035 my @cb = grep $_->[0] ne $pkg, @{ $COMMAND{$name} };
1036
1037 if (@cb) {
1038 $COMMAND{$name} = \@cb;
1039 } else {
1040 delete $COMMAND{$name};
1041 }
1042 }
1043
1044 # remove extcmds
1045 for my $name (grep $EXTCMD{$_}[1] eq $pkg, keys %EXTCMD) {
1046 delete $EXTCMD{$name};
1047 }
1048
1049 if (my $cb = $pkg->can ("unload")) {
1050 eval {
1051 $cb->($pkg);
1052 1
1053 } or warn "$pkg unloaded, but with errors: $@";
1054 }
1055
1056 Symbol::delete_package $pkg;
1057} 979}
1058 980
1059sub load_extensions { 981sub load_extensions {
1060 for my $ext (<$LIBDIR/*.ext>) { 982 for my $ext (<$LIBDIR/*.ext>) {
1061 next unless -r $ext; 983 next unless -r $ext;
… …
1065 } or warn "$ext not loaded: $@"; 987 } or warn "$ext not loaded: $@";
1066 } 988 }
1067} 989}
1068 990
1069############################################################################# 991#############################################################################
1070# load/save/clean perl data associated with a map
1071
1072*cf::mapsupport::on_clean = sub {
1073 my ($map) = @_;
1074
1075 my $path = $map->tmpname;
1076 defined $path or return;
1077
1078 unlink "$path.pst";
1079};
1080
1081cf::map->attach (prio => -10000, package => cf::mapsupport::);
1082
1083#############################################################################
1084 992
1085=head2 CORE EXTENSIONS 993=head2 CORE EXTENSIONS
1086 994
1087Functions and methods that extend core crossfire objects. 995Functions and methods that extend core crossfire objects.
1088 996
… …
1101Returns the given player object, loading it if necessary (might block). 1009Returns the given player object, loading it if necessary (might block).
1102 1010
1103=cut 1011=cut
1104 1012
1105sub playerdir($) { 1013sub playerdir($) {
1106 cf::localdir 1014 "$PLAYERDIR/"
1107 . "/"
1108 . cf::playerdir
1109 . "/"
1110 . (ref $_[0] ? $_[0]->ob->name : $_[0]) 1015 . (ref $_[0] ? $_[0]->ob->name : $_[0])
1111} 1016}
1112 1017
1113sub path($) { 1018sub path($) {
1114 my $login = ref $_[0] ? $_[0]->ob->name : $_[0]; 1019 my $login = ref $_[0] ? $_[0]->ob->name : $_[0];
1115 1020
1116 (playerdir $login) . "/$login.pl" 1021 (playerdir $login) . "/playerdata"
1117} 1022}
1118 1023
1119sub find_active($) { 1024sub find_active($) {
1120 $cf::PLAYER{$_[0]} 1025 $cf::PLAYER{$_[0]}
1121 and $cf::PLAYER{$_[0]}->active 1026 and $cf::PLAYER{$_[0]}->active
… …
1124 1029
1125sub exists($) { 1030sub exists($) {
1126 my ($login) = @_; 1031 my ($login) = @_;
1127 1032
1128 $cf::PLAYER{$login} 1033 $cf::PLAYER{$login}
1129 or cf::sync_job { !aio_stat $login } 1034 or cf::sync_job { !aio_stat path $login }
1130} 1035}
1131 1036
1132sub find($) { 1037sub find($) {
1133 return $cf::PLAYER{$_[0]} || do { 1038 return $cf::PLAYER{$_[0]} || do {
1134 my $login = $_[0]; 1039 my $login = $_[0];
1135 1040
1136 my $guard = cf::lock_acquire "user_find:$login"; 1041 my $guard = cf::lock_acquire "user_find:$login";
1137 1042
1138 $cf::PLAYER{$_[0]} || do { 1043 $cf::PLAYER{$_[0]} || do {
1044 # rename old playerfiles to new ones
1045 #TODO: remove when no longer required
1046 aio_link +(playerdir $login) . "/$login.pl.pst", (playerdir $login) . "/playerdata.pst";
1047 aio_link +(playerdir $login) . "/$login.pl" , (playerdir $login) . "/playerdata";
1048 aio_unlink +(playerdir $login) . "/$login.pl.pst";
1049 aio_unlink +(playerdir $login) . "/$login.pl";
1050
1139 my $pl = load_pl path $login 1051 my $pl = load_pl path $login
1140 or return; 1052 or return;
1141 $cf::PLAYER{$login} = $pl 1053 $cf::PLAYER{$login} = $pl
1142 } 1054 }
1143 } 1055 }
… …
1180 1092
1181=cut 1093=cut
1182 1094
1183sub quit_character { 1095sub quit_character {
1184 my ($pl) = @_; 1096 my ($pl) = @_;
1097
1098 my $name = $pl->ob->name;
1185 1099
1186 $pl->{deny_save} = 1; 1100 $pl->{deny_save} = 1;
1187 $pl->password ("*"); # this should lock out the player until we nuked the dir 1101 $pl->password ("*"); # this should lock out the player until we nuked the dir
1188 1102
1189 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active; 1103 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active;
… …
1194 my $path = playerdir $pl; 1108 my $path = playerdir $pl;
1195 my $temp = "$path~$cf::RUNTIME~deleting~"; 1109 my $temp = "$path~$cf::RUNTIME~deleting~";
1196 aio_rename $path, $temp; 1110 aio_rename $path, $temp;
1197 delete $cf::PLAYER{$pl->ob->name}; 1111 delete $cf::PLAYER{$pl->ob->name};
1198 $pl->destroy; 1112 $pl->destroy;
1113
1114 my $prefix = qr<^~\Q$name\E/>;
1115
1116 # nuke player maps
1117 $cf::MAP{$_}->nuke for grep /$prefix/, keys %cf::MAP;
1118
1199 IO::AIO::aio_rmtree $temp; 1119 IO::AIO::aio_rmtree $temp;
1120}
1121
1122=item $pl->kick
1123
1124Kicks a player out of the game. This destroys the connection.
1125
1126=cut
1127
1128sub kick {
1129 my ($pl, $kicker) = @_;
1130
1131 $pl->invoke (cf::EVENT_PLAYER_KICK, $kicker);
1132 $pl->killer ("kicked");
1133 $pl->ns->destroy;
1200} 1134}
1201 1135
1202=item cf::player::list_logins 1136=item cf::player::list_logins
1203 1137
1204Returns am arrayref of all valid playernames in the system, can take a 1138Returns am arrayref of all valid playernames in the system, can take a
1205while and may block, so not sync_job-capable, ever. 1139while and may block, so not sync_job-capable, ever.
1206 1140
1207=cut 1141=cut
1208 1142
1209sub list_logins { 1143sub list_logins {
1210 my $dirs = aio_readdir cf::localdir . "/" . cf::playerdir 1144 my $dirs = aio_readdir $PLAYERDIR
1211 or return []; 1145 or return [];
1212 1146
1213 my @logins; 1147 my @logins;
1214 1148
1215 for my $login (@$dirs) { 1149 for my $login (@$dirs) {
… …
1224 \@logins 1158 \@logins
1225} 1159}
1226 1160
1227=item $player->maps 1161=item $player->maps
1228 1162
1229Returns an arrayref of cf::path's of all maps that are private for this 1163Returns an arrayref of map paths that are private for this
1230player. May block. 1164player. May block.
1231 1165
1232=cut 1166=cut
1233 1167
1234sub maps($) { 1168sub maps($) {
1235 my ($pl) = @_; 1169 my ($pl) = @_;
1170
1171 $pl = ref $pl ? $pl->ob->name : $pl;
1236 1172
1237 my $files = aio_readdir playerdir $pl 1173 my $files = aio_readdir playerdir $pl
1238 or return; 1174 or return;
1239 1175
1240 my @paths; 1176 my @paths;
1241 1177
1242 for (@$files) { 1178 for (@$files) {
1243 utf8::decode $_; 1179 utf8::decode $_;
1244 next if /\.(?:pl|pst)$/; 1180 next if /\.(?:pl|pst)$/;
1245 next unless /^$PATH_SEP/; 1181 next unless /^$PATH_SEP/o;
1246 1182
1247 s/$PATH_SEP/\//g; 1183 push @paths, cf::map::normalise "~$pl/$_";
1248 push @paths, new cf::path "~" . $pl->ob->name . "/" . $_;
1249 } 1184 }
1250 1185
1251 \@paths 1186 \@paths
1252} 1187}
1253 1188
1254=item $player->ext_reply ($msgid, $msgtype, %msg) 1189=item $player->ext_reply ($msgid, %msg)
1255 1190
1256Sends an ext reply to the player. 1191Sends an ext reply to the player.
1257 1192
1258=cut 1193=cut
1259 1194
1260sub ext_reply($$$%) { 1195sub ext_reply($$%) {
1261 my ($self, $id, %msg) = @_; 1196 my ($self, $id, %msg) = @_;
1262 1197
1263 $msg{msgid} = $id; 1198 $msg{msgid} = $id;
1264 1199
1265 $self->send ("ext " . cf::to_json \%msg); 1200 $self->send ("ext " . cf::to_json \%msg);
1266} 1201}
1267 1202
1268package cf; 1203=item $player->ext_event ($type, %msg)
1204
1205Sends an ext event to the client.
1206
1207=cut
1208
1209sub ext_event($$%) {
1210 my ($self, $type, %msg) = @_;
1211
1212 $self->ns->ext_event ($type, %msg);
1213}
1214
1215=head3 cf::region
1216
1217=over 4
1218
1219=cut
1220
1221package cf::region;
1222
1223=item cf::region::find_by_path $path
1224
1225Tries to decuce the probable region for a map knowing only its path.
1226
1227=cut
1228
1229sub find_by_path($) {
1230 my ($path) = @_;
1231
1232 my ($match, $specificity);
1233
1234 for my $region (list) {
1235 if ($region->match && $path =~ $region->match) {
1236 ($match, $specificity) = ($region, $region->specificity)
1237 if $region->specificity > $specificity;
1238 }
1239 }
1240
1241 $match
1242}
1269 1243
1270=back 1244=back
1271
1272 1245
1273=head3 cf::map 1246=head3 cf::map
1274 1247
1275=over 4 1248=over 4
1276 1249
… …
1279package cf::map; 1252package cf::map;
1280 1253
1281use Fcntl; 1254use Fcntl;
1282use Coro::AIO; 1255use Coro::AIO;
1283 1256
1257use overload
1258 '""' => \&as_string,
1259 fallback => 1;
1260
1284our $MAX_RESET = 3600; 1261our $MAX_RESET = 3600;
1285our $DEFAULT_RESET = 3000; 1262our $DEFAULT_RESET = 3000;
1286 1263
1287sub generate_random_map { 1264sub generate_random_map {
1288 my ($path, $rmp) = @_; 1265 my ($self, $rmp) = @_;
1289
1290 # mit "rum" bekleckern, nicht 1266 # mit "rum" bekleckern, nicht
1291 cf::map::_create_random_map 1267 $self->_create_random_map (
1292 $path,
1293 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle}, 1268 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle},
1294 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle}, 1269 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle},
1295 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map}, 1270 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map},
1296 $rmp->{exit_on_final_map}, 1271 $rmp->{exit_on_final_map},
1297 $rmp->{xsize}, $rmp->{ysize}, 1272 $rmp->{xsize}, $rmp->{ysize},
1298 $rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3}, 1273 $rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3},
1299 $rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase}, 1274 $rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase},
1300 $rmp->{dungeon_level}, $rmp->{dungeon_depth}, $rmp->{decoroptions}, $rmp->{orientation}, 1275 $rmp->{dungeon_level}, $rmp->{dungeon_depth}, $rmp->{decoroptions}, $rmp->{orientation},
1301 $rmp->{origin_y}, $rmp->{origin_x}, $rmp->{random_seed}, $rmp->{total_map_hp}, 1276 $rmp->{origin_y}, $rmp->{origin_x}, $rmp->{random_seed}, $rmp->{total_map_hp},
1302 $rmp->{map_layout_style}, $rmp->{treasureoptions}, $rmp->{symmetry_used}, 1277 $rmp->{map_layout_style}, $rmp->{treasureoptions}, $rmp->{symmetry_used},
1303 (cf::region::find $rmp->{region}) 1278 (cf::region::find $rmp->{region}), $rmp->{custom}
1279 )
1280}
1281
1282=item cf::map->register ($regex, $prio)
1283
1284Register a handler for the map path matching the given regex at the
1285givne priority (higher is better, built-in handlers have priority 0, the
1286default).
1287
1288=cut
1289
1290sub register {
1291 my (undef, $regex, $prio) = @_;
1292 my $pkg = caller;
1293
1294 no strict;
1295 push @{"$pkg\::ISA"}, __PACKAGE__;
1296
1297 $EXT_MAP{$pkg} = [$prio, qr<$regex>];
1298}
1299
1300# also paths starting with '/'
1301$EXT_MAP{"cf::map"} = [0, qr{^(?=/)}];
1302
1303sub thawer_merge {
1304 my ($self, $merge) = @_;
1305
1306 # we have to keep some variables in memory intact
1307 local $self->{path};
1308 local $self->{load_path};
1309 local $self->{deny_save};
1310 local $self->{deny_reset};
1311
1312 $self->SUPER::thawer_merge ($merge);
1313}
1314
1315sub normalise {
1316 my ($path, $base) = @_;
1317
1318 $path = "$path"; # make sure its a string
1319
1320 $path =~ s/\.map$//;
1321
1322 # map plan:
1323 #
1324 # /! non-realised random map exit (special hack!)
1325 # {... are special paths that are not being touched
1326 # ?xxx/... are special absolute paths
1327 # ?random/... random maps
1328 # /... normal maps
1329 # ~user/... per-player map of a specific user
1330
1331 $path =~ s/$PATH_SEP/\//go;
1332
1333 # treat it as relative path if it starts with
1334 # something that looks reasonable
1335 if ($path =~ m{^(?:\./|\.\./|\w)}) {
1336 $base or Carp::carp "normalise called with relative path and no base: '$path'";
1337
1338 $base =~ s{[^/]+/?$}{};
1339 $path = "$base/$path";
1340 }
1341
1342 for ($path) {
1343 redo if s{//}{/};
1344 redo if s{/\.?/}{/};
1345 redo if s{/[^/]+/\.\./}{/};
1346 }
1347
1348 $path
1349}
1350
1351sub new_from_path {
1352 my (undef, $path, $base) = @_;
1353
1354 return $path if UNIVERSAL::isa $path, "cf::map"; # already a map object
1355
1356 $path = normalise $path, $base;
1357
1358 for my $pkg (sort { $EXT_MAP{$b}[0] <=> $EXT_MAP{$a}[0] } keys %EXT_MAP) {
1359 if ($path =~ $EXT_MAP{$pkg}[1]) {
1360 my $self = bless cf::map::new, $pkg;
1361 $self->{path} = $path; $self->path ($path);
1362 $self->init; # pass $1 etc.
1363 return $self;
1364 }
1365 }
1366
1367 Carp::carp "unable to resolve path '$path' (base '$base').";
1368 ()
1369}
1370
1371sub init {
1372 my ($self) = @_;
1373
1374 $self
1375}
1376
1377sub as_string {
1378 my ($self) = @_;
1379
1380 "$self->{path}"
1381}
1382
1383# the displayed name, this is a one way mapping
1384sub visible_name {
1385 &as_string
1386}
1387
1388# the original (read-only) location
1389sub load_path {
1390 my ($self) = @_;
1391
1392 "$MAPDIR/$self->{path}.map"
1393}
1394
1395# the temporary/swap location
1396sub save_path {
1397 my ($self) = @_;
1398
1399 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g;
1400 "$TMPDIR/$path.map"
1401}
1402
1403# the unique path, undef == no special unique path
1404sub uniq_path {
1405 my ($self) = @_;
1406
1407 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g;
1408 "$UNIQUEDIR/$path"
1304} 1409}
1305 1410
1306# and all this just because we cannot iterate over 1411# and all this just because we cannot iterate over
1307# all maps in C++... 1412# all maps in C++...
1308sub change_all_map_light { 1413sub change_all_map_light {
… …
1310 1415
1311 $_->change_map_light ($change) 1416 $_->change_map_light ($change)
1312 for grep $_->outdoor, values %cf::MAP; 1417 for grep $_->outdoor, values %cf::MAP;
1313} 1418}
1314 1419
1420sub unlink_save {
1421 my ($self) = @_;
1422
1423 utf8::encode (my $save = $self->save_path);
1424 IO::AIO::aioreq_pri 4; Coro::AIO::aio_unlink $save;
1425 IO::AIO::aioreq_pri 4; Coro::AIO::aio_unlink "$save.pst";
1426}
1427
1315sub try_load_header($) { 1428sub load_header_from($) {
1316 my ($path) = @_; 1429 my ($self, $path) = @_;
1317 1430
1318 utf8::encode $path; 1431 utf8::encode $path;
1319 aio_open $path, O_RDONLY, 0 1432 #aio_open $path, O_RDONLY, 0
1433 # or return;
1434
1435 $self->_load_header ($path)
1320 or return; 1436 or return;
1321 1437
1322 my $map = cf::map::new 1438 $self->{load_path} = $path;
1439
1440 1
1441}
1442
1443sub load_header_orig {
1444 my ($self) = @_;
1445
1446 $self->load_header_from ($self->load_path)
1447}
1448
1449sub load_header_temp {
1450 my ($self) = @_;
1451
1452 $self->load_header_from ($self->save_path)
1453}
1454
1455sub prepare_temp {
1456 my ($self) = @_;
1457
1458 $self->last_access ((delete $self->{last_access})
1459 || $cf::RUNTIME); #d#
1460 # safety
1461 $self->{instantiate_time} = $cf::RUNTIME
1462 if $self->{instantiate_time} > $cf::RUNTIME;
1463}
1464
1465sub prepare_orig {
1466 my ($self) = @_;
1467
1468 $self->{load_original} = 1;
1469 $self->{instantiate_time} = $cf::RUNTIME;
1470 $self->last_access ($cf::RUNTIME);
1471 $self->instantiate;
1472}
1473
1474sub load_header {
1475 my ($self) = @_;
1476
1477 if ($self->load_header_temp) {
1478 $self->prepare_temp;
1479 } else {
1480 $self->load_header_orig
1323 or return; 1481 or return;
1482 $self->prepare_orig;
1483 }
1324 1484
1325 # for better error messages only, will be overwritten 1485 $self->default_region (cf::region::find_by_path $self->{path})
1326 $map->path ($path); 1486 unless $self->default_region;
1327 1487
1328 $map->load_header ($path) 1488 1
1329 or return;
1330
1331 $map->{load_path} = $path;
1332
1333 $map
1334} 1489}
1335 1490
1336sub find; 1491sub find;
1337sub find { 1492sub find {
1338 my ($path, $origin) = @_; 1493 my ($path, $origin) = @_;
1339 1494
1340 #warn "find<$path,$origin>\n";#d#
1341
1342 $path = new cf::path $path, $origin && $origin->path; 1495 $path = normalise $path, $origin && $origin->path;
1343 my $key = $path->as_string;
1344 1496
1345 cf::lock_wait "map_find:$key"; 1497 cf::lock_wait "map_find:$path";
1346 1498
1347 $cf::MAP{$key} || do { 1499 $cf::MAP{$path} || do {
1348 my $guard = cf::lock_acquire "map_find:$key"; 1500 my $guard = cf::lock_acquire "map_find:$path";
1349 1501 my $map = new_from_path cf::map $path
1350 # do it the slow way
1351 my $map = try_load_header $path->save_path;
1352
1353 Coro::cede;
1354
1355 if ($map) {
1356 $map->last_access ((delete $map->{last_access})
1357 || $cf::RUNTIME); #d#
1358 # safety
1359 $map->{instantiate_time} = $cf::RUNTIME
1360 if $map->{instantiate_time} > $cf::RUNTIME;
1361 } else {
1362 if (my $rmp = $path->random_map_params) {
1363 $map = generate_random_map $key, $rmp;
1364 } else {
1365 $map = try_load_header $path->load_path;
1366 }
1367
1368 $map or return; 1502 or return;
1369 1503
1370 $map->{load_original} = 1;
1371 $map->{instantiate_time} = $cf::RUNTIME;
1372 $map->last_access ($cf::RUNTIME);
1373 $map->instantiate;
1374
1375 # per-player maps become, after loading, normal maps
1376 $map->per_player (0) if $path->{user_rel};
1377 }
1378
1379 $map->path ($key);
1380 $map->{path} = $path;
1381 $map->{last_save} = $cf::RUNTIME; 1504 $map->{last_save} = $cf::RUNTIME;
1382 1505
1383 Coro::cede; 1506 $map->load_header
1507 or return;
1384 1508
1385 if ($map->should_reset) { 1509 if ($map->should_reset && 0) {#d#TODO# disabled, crashy (locking issue?)
1510 # doing this can freeze the server in a sync job, obviously
1511 #$cf::WAIT_FOR_TICK->wait;
1386 $map->reset; 1512 $map->reset;
1387 undef $guard; 1513 undef $guard;
1388 $map = find $path 1514 return find $path;
1389 or return;
1390 } 1515 }
1391 1516
1392 $cf::MAP{$key} = $map 1517 $cf::MAP{$path} = $map
1393 } 1518 }
1394} 1519}
1520
1521sub pre_load { }
1522sub post_load { }
1395 1523
1396sub load { 1524sub load {
1397 my ($self) = @_; 1525 my ($self) = @_;
1398 1526
1527 local $self->{deny_reset} = 1; # loading can take a long time
1528
1399 my $path = $self->{path}; 1529 my $path = $self->{path};
1530
1531 {
1400 my $guard = cf::lock_acquire "map_load:" . $path->as_string; 1532 my $guard = cf::lock_acquire "map_load:$path";
1401 1533
1402 return if $self->in_memory != cf::MAP_SWAPPED; 1534 return if $self->in_memory != cf::MAP_SWAPPED;
1403 1535
1404 $self->in_memory (cf::MAP_LOADING); 1536 $self->in_memory (cf::MAP_LOADING);
1405 1537
1406 $self->alloc; 1538 $self->alloc;
1539
1540 $self->pre_load;
1541 Coro::cede;
1542
1407 $self->load_objects ($self->{load_path}, 1) 1543 $self->_load_objects ($self->{load_path}, 1)
1408 or return; 1544 or return;
1409 1545
1410 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1) 1546 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1)
1411 if delete $self->{load_original}; 1547 if delete $self->{load_original};
1412 1548
1413 if (my $uniq = $path->uniq_path) { 1549 if (my $uniq = $self->uniq_path) {
1414 utf8::encode $uniq; 1550 utf8::encode $uniq;
1415 if (aio_open $uniq, O_RDONLY, 0) { 1551 if (aio_open $uniq, O_RDONLY, 0) {
1416 $self->clear_unique_items; 1552 $self->clear_unique_items;
1417 $self->load_objects ($uniq, 0); 1553 $self->_load_objects ($uniq, 0);
1418 } 1554 }
1419 } 1555 }
1420 1556
1421 Coro::cede; 1557 Coro::cede;
1422
1423 # now do the right thing for maps 1558 # now do the right thing for maps
1424 $self->link_multipart_objects; 1559 $self->link_multipart_objects;
1425
1426 if ($self->{path}->is_style_map) {
1427 $self->{deny_save} = 1;
1428 $self->{deny_reset} = 1;
1429 } else {
1430 $self->fix_auto_apply;
1431 $self->decay_objects;
1432 $self->update_buttons;
1433 $self->set_darkness_map;
1434 $self->difficulty ($self->estimate_difficulty) 1560 $self->difficulty ($self->estimate_difficulty)
1435 unless $self->difficulty; 1561 unless $self->difficulty;
1562 Coro::cede;
1563
1564 unless ($self->{deny_activate}) {
1565 $self->decay_objects;
1566 $self->fix_auto_apply;
1567 $self->update_buttons;
1568 Coro::cede;
1569 $self->set_darkness_map;
1570 Coro::cede;
1436 $self->activate; 1571 $self->activate;
1437 } 1572 }
1438 1573
1439 Coro::cede;
1440
1441 $self->in_memory (cf::MAP_IN_MEMORY); 1574 $self->in_memory (cf::MAP_IN_MEMORY);
1575 }
1576
1577 $self->post_load;
1578}
1579
1580sub customise_for {
1581 my ($self, $ob) = @_;
1582
1583 return find "~" . $ob->name . "/" . $self->{path}
1584 if $self->per_player;
1585
1586 $self
1587}
1588
1589# find and load all maps in the 3x3 area around a map
1590sub load_diag {
1591 my ($map) = @_;
1592
1593 my @diag; # diagonal neighbours
1594
1595 for (0 .. 3) {
1596 my $neigh = $map->tile_path ($_)
1597 or next;
1598 $neigh = find $neigh, $map
1599 or next;
1600 $neigh->load;
1601
1602 push @diag, [$neigh->tile_path (($_ + 3) % 4), $neigh],
1603 [$neigh->tile_path (($_ + 1) % 4), $neigh];
1604 }
1605
1606 for (@diag) {
1607 my $neigh = find @$_
1608 or next;
1609 $neigh->load;
1610 }
1442} 1611}
1443 1612
1444sub find_sync { 1613sub find_sync {
1445 my ($path, $origin) = @_; 1614 my ($path, $origin) = @_;
1446 1615
1447 cf::sync_job { cf::map::find $path, $origin } 1616 cf::sync_job { find $path, $origin }
1448} 1617}
1449 1618
1450sub do_load_sync { 1619sub do_load_sync {
1451 my ($map) = @_; 1620 my ($map) = @_;
1452 1621
1453 cf::sync_job { $map->load }; 1622 cf::sync_job { $map->load };
1454} 1623}
1455 1624
1625our %MAP_PREFETCH;
1626our $MAP_PREFETCHER = undef;
1627
1628sub find_async {
1629 my ($path, $origin) = @_;
1630
1631 $path = normalise $path, $origin && $origin->{path};
1632
1633 if (my $map = $cf::MAP{$path}) {
1634 return $map if $map->in_memory == cf::MAP_IN_MEMORY;
1635 }
1636
1637 undef $MAP_PREFETCH{$path};
1638 $MAP_PREFETCHER ||= cf::async {
1639 while (%MAP_PREFETCH) {
1640 for my $path (keys %MAP_PREFETCH) {
1641 my $map = find $path
1642 or next;
1643 $map->load;
1644
1645 delete $MAP_PREFETCH{$path};
1646 }
1647 }
1648 undef $MAP_PREFETCHER;
1649 };
1650 $MAP_PREFETCHER->prio (6);
1651
1652 ()
1653}
1654
1456sub save { 1655sub save {
1457 my ($self) = @_; 1656 my ($self) = @_;
1458 1657
1459 my $lock = cf::lock_acquire "map_data:" . $self->path; 1658 my $lock = cf::lock_acquire "map_data:" . $self->path;
1460 1659
1461 $self->{last_save} = $cf::RUNTIME; 1660 $self->{last_save} = $cf::RUNTIME;
1462 1661
1463 return unless $self->dirty; 1662 return unless $self->dirty;
1464 1663
1465 my $save = $self->{path}->save_path; utf8::encode $save; 1664 my $save = $self->save_path; utf8::encode $save;
1466 my $uniq = $self->{path}->uniq_path; utf8::encode $uniq; 1665 my $uniq = $self->uniq_path; utf8::encode $uniq;
1467 1666
1468 $self->{load_path} = $save; 1667 $self->{load_path} = $save;
1469 1668
1470 return if $self->{deny_save}; 1669 return if $self->{deny_save};
1471 1670
… …
1474 cf::async { 1673 cf::async {
1475 $_->contr->save for $self->players; 1674 $_->contr->save for $self->players;
1476 }; 1675 };
1477 1676
1478 if ($uniq) { 1677 if ($uniq) {
1479 $self->save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS); 1678 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS);
1480 $self->save_objects ($uniq, cf::IO_UNIQUES); 1679 $self->_save_objects ($uniq, cf::IO_UNIQUES);
1481 } else { 1680 } else {
1482 $self->save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES); 1681 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES);
1483 } 1682 }
1484} 1683}
1485 1684
1486sub swap_out { 1685sub swap_out {
1487 my ($self) = @_; 1686 my ($self) = @_;
… …
1501 1700
1502sub reset_at { 1701sub reset_at {
1503 my ($self) = @_; 1702 my ($self) = @_;
1504 1703
1505 # TODO: safety, remove and allow resettable per-player maps 1704 # TODO: safety, remove and allow resettable per-player maps
1506 return 1e99 if $self->{path}{user_rel}; 1705 return 1e99 if $self->isa ("ext::map_per_player");#d#
1507 return 1e99 if $self->{deny_reset}; 1706 return 1e99 if $self->{deny_reset};
1508 1707
1509 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access; 1708 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
1510 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET; 1709 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET;
1511 1710
… …
1516 my ($self) = @_; 1715 my ($self) = @_;
1517 1716
1518 $self->reset_at <= $cf::RUNTIME 1717 $self->reset_at <= $cf::RUNTIME
1519} 1718}
1520 1719
1521sub unlink_save {
1522 my ($self) = @_;
1523
1524 utf8::encode (my $save = $self->{path}->save_path);
1525 aioreq_pri 3; IO::AIO::aio_unlink $save;
1526 aioreq_pri 3; IO::AIO::aio_unlink "$save.pst";
1527}
1528
1529sub rename {
1530 my ($self, $new_path) = @_;
1531
1532 $self->unlink_save;
1533
1534 delete $cf::MAP{$self->path};
1535 $self->{path} = new cf::path $new_path;
1536 $self->path ($self->{path}->as_string);
1537 $cf::MAP{$self->path} = $self;
1538
1539 $self->save;
1540}
1541
1542sub reset { 1720sub reset {
1543 my ($self) = @_; 1721 my ($self) = @_;
1544 1722
1545 my $lock = cf::lock_acquire "map_data:" . $self->path; 1723 my $lock = cf::lock_acquire "map_data:$self->{path}";
1546 1724
1547 return if $self->players; 1725 return if $self->players;
1548 return if $self->{path}{user_rel};#d# 1726 return if $self->isa ("ext::map_per_player");#d#
1549 1727
1550 warn "resetting map ", $self->path;#d# 1728 warn "resetting map ", $self->path;#d#
1551 1729
1730 $self->in_memory (cf::MAP_SWAPPED);
1731
1732 # need to save uniques path
1733 unless ($self->{deny_save}) {
1734 my $uniq = $self->uniq_path; utf8::encode $uniq;
1735
1736 $self->_save_objects ($uniq, cf::IO_UNIQUES)
1737 if $uniq;
1738 }
1739
1552 delete $cf::MAP{$self->path}; 1740 delete $cf::MAP{$self->path};
1741
1742 $self->clear;
1553 1743
1554 $_->clear_links_to ($self) for values %cf::MAP; 1744 $_->clear_links_to ($self) for values %cf::MAP;
1555 1745
1556 $self->unlink_save; 1746 $self->unlink_save;
1557 $self->destroy; 1747 $self->destroy;
… …
1560my $nuke_counter = "aaaa"; 1750my $nuke_counter = "aaaa";
1561 1751
1562sub nuke { 1752sub nuke {
1563 my ($self) = @_; 1753 my ($self) = @_;
1564 1754
1755 delete $cf::MAP{$self->path};
1756
1757 $self->unlink_save;
1758
1759 bless $self, "cf::map";
1760 delete $self->{deny_reset};
1565 $self->{deny_save} = 1; 1761 $self->{deny_save} = 1;
1566 $self->reset_timeout (1); 1762 $self->reset_timeout (1);
1567 $self->rename ("{nuke}/" . ($nuke_counter++)); 1763 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));
1764
1765 $cf::MAP{$self->path} = $self;
1766
1568 $self->reset; # polite request, might not happen 1767 $self->reset; # polite request, might not happen
1569} 1768}
1570 1769
1571sub customise_for { 1770=item cf::map::unique_maps
1572 my ($map, $ob) = @_;
1573 1771
1574 if ($map->per_player) { 1772Returns an arrayref of paths of all shared maps that have
1575 return cf::map::find "~" . $ob->name . "/" . $map->{path}{path}; 1773instantiated unique items. May block.
1576 }
1577 1774
1578 $map 1775=cut
1776
1777sub unique_maps() {
1778 my $files = aio_readdir $UNIQUEDIR
1779 or return;
1780
1781 my @paths;
1782
1783 for (@$files) {
1784 utf8::decode $_;
1785 next if /\.pst$/;
1786 next unless /^$PATH_SEP/o;
1787
1788 push @paths, cf::map::normalise $_;
1789 }
1790
1791 \@paths
1579} 1792}
1580 1793
1581package cf; 1794package cf;
1582 1795
1583=back 1796=back
… …
1655 1868
1656=item $player_object->enter_link 1869=item $player_object->enter_link
1657 1870
1658Freezes the player and moves him/her to a special map (C<{link}>). 1871Freezes the player and moves him/her to a special map (C<{link}>).
1659 1872
1660The player should be reaosnably safe there for short amounts of time. You 1873The player should be reasonably safe there for short amounts of time. You
1661I<MUST> call C<leave_link> as soon as possible, though. 1874I<MUST> call C<leave_link> as soon as possible, though.
1662 1875
1876Will never block.
1877
1663=item $player_object->leave_link ($map, $x, $y) 1878=item $player_object->leave_link ($map, $x, $y)
1664 1879
1665Moves the player out of the specila link map onto the given map. If the 1880Moves the player out of the special C<{link}> map onto the specified
1666map is not valid (or omitted), the player will be moved back to the 1881map. If the map is not valid (or omitted), the player will be moved back
1667location he/she was before the call to C<enter_link>, or, if that fails, 1882to the location he/she was before the call to C<enter_link>, or, if that
1668to the emergency map position. 1883fails, to the emergency map position.
1669 1884
1670Might block. 1885Might block.
1671 1886
1672=cut 1887=cut
1888
1889sub link_map {
1890 unless ($LINK_MAP) {
1891 $LINK_MAP = cf::map::find "{link}"
1892 or cf::cleanup "FATAL: unable to provide {link} map, exiting.";
1893 $LINK_MAP->load;
1894 }
1895
1896 $LINK_MAP
1897}
1673 1898
1674sub cf::object::player::enter_link { 1899sub cf::object::player::enter_link {
1675 my ($self) = @_; 1900 my ($self) = @_;
1676 1901
1677 $self->deactivate_recursive; 1902 $self->deactivate_recursive;
1678 1903
1679 return if $self->map == $LINK_MAP; 1904 return if UNIVERSAL::isa $self->map, "ext::map_link";
1680 1905
1681 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y] 1906 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y]
1682 if $self->map; 1907 if $self->map && $self->map->{path} ne "{link}";
1683 1908
1684 $self->enter_map ($LINK_MAP, 20, 20); 1909 $self->enter_map ($LINK_MAP || link_map, 10, 10);
1685} 1910}
1686 1911
1687sub cf::object::player::leave_link { 1912sub cf::object::player::leave_link {
1688 my ($self, $map, $x, $y) = @_; 1913 my ($self, $map, $x, $y) = @_;
1914
1915 return unless $self->contr->active;
1689 1916
1690 my $link_pos = delete $self->{_link_pos}; 1917 my $link_pos = delete $self->{_link_pos};
1691 1918
1692 unless ($map) { 1919 unless ($map) {
1693 # restore original map position 1920 # restore original map position
… …
1707 # use -1 or undef as default coordinates, not 0, 0 1934 # use -1 or undef as default coordinates, not 0, 0
1708 ($x, $y) = ($map->enter_x, $map->enter_y) 1935 ($x, $y) = ($map->enter_x, $map->enter_y)
1709 if $x <=0 && $y <= 0; 1936 if $x <=0 && $y <= 0;
1710 1937
1711 $map->load; 1938 $map->load;
1939 $map->load_diag;
1712 1940
1713 return unless $self->contr->active; 1941 return unless $self->contr->active;
1714 $self->activate_recursive; 1942 $self->activate_recursive;
1943
1944 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
1715 $self->enter_map ($map, $x, $y); 1945 $self->enter_map ($map, $x, $y);
1716} 1946}
1717 1947
1718cf::player->attach (
1719 on_logout => sub {
1720 my ($pl) = @_;
1721
1722 # abort map switching before logout
1723 if ($pl->ob->{_link_pos}) {
1724 cf::sync_job {
1725 $pl->ob->leave_link
1726 };
1727 }
1728 },
1729 on_login => sub {
1730 my ($pl) = @_;
1731
1732 # try to abort aborted map switching on player login :)
1733 # should happen only on crashes
1734 if ($pl->ob->{_link_pos}) {
1735 $pl->ob->enter_link;
1736 (async {
1737 # we need this sleep as the login has a concurrent enter_exit running
1738 # and this sleep increases chances of the player not ending up in scorn
1739 $pl->ob->reply (undef,
1740 "There was an internal problem at your last logout, "
1741 . "the server will try to bring you to your intended destination in a second.",
1742 cf::NDI_RED);
1743 Coro::Timer::sleep 1;
1744 $pl->ob->leave_link;
1745 })->prio (2);
1746 }
1747 },
1748);
1749
1750=item $player_object->goto ($path, $x, $y) 1948=item $player_object->goto ($path, $x, $y[, $check->($map)])
1751 1949
1950Moves the player to the given map-path and coordinates by first freezing
1951her, loading and preparing them map, calling the provided $check callback
1952that has to return the map if sucecssful, and then unfreezes the player on
1953the new (success) or old (failed) map position.
1954
1752=cut 1955=cut
1956
1957our $GOTOGEN;
1753 1958
1754sub cf::object::player::goto { 1959sub cf::object::player::goto {
1755 my ($self, $path, $x, $y) = @_; 1960 my ($self, $path, $x, $y, $check) = @_;
1756 1961
1757 $path = new cf::path $path; 1962 # do generation counting so two concurrent goto's will be executed in-order
1758 $path ne "/" or Carp::cluck ("oy");#d# 1963 my $gen = $self->{_goto_generation} = ++$GOTOGEN;
1759 1964
1760 $self->enter_link; 1965 $self->enter_link;
1761 1966
1762 (async { 1967 (async {
1968 my $map = eval {
1763 my $map = cf::map::find $path->as_string; 1969 my $map = cf::map::find $path;
1970
1971 if ($map) {
1764 $map = $map->customise_for ($self) if $map; 1972 $map = $map->customise_for ($self);
1765 1973 $map = $check->($map) if $check && $map;
1766# warn "entering ", $map->path, " at ($x, $y)\n" 1974 } else {
1767# if $map;
1768
1769 $map or $self->message ("The exit to '" . ($path->visible_name) . "' is closed", cf::NDI_UNIQUE | cf::NDI_RED); 1975 $self->message ("The exit to '$path' is closed", cf::NDI_UNIQUE | cf::NDI_RED);
1976 }
1770 1977
1978 $map
1979 };
1980
1981 if ($@) {
1982 $self->message ("Something went wrong within the server, please report this incident!", cf::NDI_UNIQUE | cf::NDI_RED);
1983 LOG llevError | logBacktrace, Carp::longmess $@;
1984 }
1985
1986 if ($gen == $self->{_goto_generation}) {
1987 delete $self->{_goto_generation};
1771 $self->leave_link ($map, $x, $y); 1988 $self->leave_link ($map, $x, $y);
1989 }
1772 })->prio (1); 1990 })->prio (1);
1773} 1991}
1774 1992
1775=item $player_object->enter_exit ($exit_object) 1993=item $player_object->enter_exit ($exit_object)
1776 1994
… …
1778 1996
1779sub parse_random_map_params { 1997sub parse_random_map_params {
1780 my ($spec) = @_; 1998 my ($spec) = @_;
1781 1999
1782 my $rmp = { # defaults 2000 my $rmp = { # defaults
1783 xsize => 10, 2001 xsize => (cf::rndm 15, 40),
1784 ysize => 10, 2002 ysize => (cf::rndm 15, 40),
2003 symmetry => (cf::rndm 1, cf::SYMMETRY_XY),
2004 #layout => string,
1785 }; 2005 };
1786 2006
1787 for (split /\n/, $spec) { 2007 for (split /\n/, $spec) {
1788 my ($k, $v) = split /\s+/, $_, 2; 2008 my ($k, $v) = split /\s+/, $_, 2;
1789 2009
… …
1793 $rmp 2013 $rmp
1794} 2014}
1795 2015
1796sub prepare_random_map { 2016sub prepare_random_map {
1797 my ($exit) = @_; 2017 my ($exit) = @_;
2018
2019 my $guard = cf::lock_acquire "exit_prepare:$exit";
1798 2020
1799 # all this does is basically replace the /! path by 2021 # all this does is basically replace the /! path by
1800 # a new random map path (?random/...) with a seed 2022 # a new random map path (?random/...) with a seed
1801 # that depends on the exit object 2023 # that depends on the exit object
1802 2024
1803 my $rmp = parse_random_map_params $exit->msg; 2025 my $rmp = parse_random_map_params $exit->msg;
1804 2026
1805 if ($exit->map) { 2027 if ($exit->map) {
1806 $rmp->{region} = $exit->map->region_name; 2028 $rmp->{region} = $exit->region->name;
1807 $rmp->{origin_map} = $exit->map->path; 2029 $rmp->{origin_map} = $exit->map->path;
1808 $rmp->{origin_x} = $exit->x; 2030 $rmp->{origin_x} = $exit->x;
1809 $rmp->{origin_y} = $exit->y; 2031 $rmp->{origin_y} = $exit->y;
1810 } 2032 }
1811 2033
1812 $rmp->{random_seed} ||= $exit->random_seed; 2034 $rmp->{random_seed} ||= $exit->random_seed;
1813 2035
1814 my $data = cf::to_json $rmp; 2036 my $data = cf::to_json $rmp;
1815 my $md5 = Digest::MD5::md5_hex $data; 2037 my $md5 = Digest::MD5::md5_hex $data;
2038 my $meta = "$RANDOMDIR/$md5.meta";
1816 2039
1817 if (my $fh = aio_open "$cf::RANDOM_MAPS/$md5.meta", O_WRONLY | O_CREAT, 0666) { 2040 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) {
1818 aio_write $fh, 0, (length $data), $data, 0; 2041 aio_write $fh, 0, (length $data), $data, 0;
2042 undef $fh;
2043 aio_rename "$meta~", $meta;
1819 2044
1820 $exit->slaying ("?random/$md5"); 2045 $exit->slaying ("?random/$md5");
1821 $exit->msg (undef); 2046 $exit->msg (undef);
1822 } 2047 }
1823} 2048}
1824 2049
1825sub cf::object::player::enter_exit { 2050sub cf::object::player::enter_exit {
1826 my ($self, $exit) = @_; 2051 my ($self, $exit) = @_;
1827 2052
1828 return unless $self->type == cf::PLAYER; 2053 return unless $self->type == cf::PLAYER;
2054
2055 if ($exit->slaying eq "/!") {
2056 #TODO: this should de-fi-ni-te-ly not be a sync-job
2057 # the problem is that $exit might not survive long enough
2058 # so it needs to be done right now, right here
2059 cf::sync_job { prepare_random_map $exit };
2060 }
2061
2062 my $slaying = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path;
2063 my $hp = $exit->stats->hp;
2064 my $sp = $exit->stats->sp;
1829 2065
1830 $self->enter_link; 2066 $self->enter_link;
1831 2067
1832 (async { 2068 (async {
1833 $self->deactivate_recursive; # just to be sure 2069 $self->deactivate_recursive; # just to be sure
1834 unless (eval { 2070 unless (eval {
1835 prepare_random_map $exit 2071 $self->goto ($slaying, $hp, $sp);
1836 if $exit->slaying eq "/!";
1837
1838 my $path = new cf::path $exit->slaying, $exit->map && $exit->map->path;
1839 $self->goto ($path, $exit->stats->hp, $exit->stats->sp);
1840 2072
1841 1; 2073 1;
1842 }) { 2074 }) {
1843 $self->message ("Something went wrong deep within the crossfire server. " 2075 $self->message ("Something went wrong deep within the crossfire server. "
1844 . "I'll try to bring you back to the map you were before. " 2076 . "I'll try to bring you back to the map you were before. "
1845 . "Please report this to the dungeon master", 2077 . "Please report this to the dungeon master!",
1846 cf::NDI_UNIQUE | cf::NDI_RED); 2078 cf::NDI_UNIQUE | cf::NDI_RED);
1847 2079
1848 warn "ERROR in enter_exit: $@"; 2080 warn "ERROR in enter_exit: $@";
1849 $self->leave_link; 2081 $self->leave_link;
1850 } 2082 }
1851 })->prio (1); 2083 })->prio (1);
… …
1864 2096
1865sub cf::client::send_drawinfo { 2097sub cf::client::send_drawinfo {
1866 my ($self, $text, $flags) = @_; 2098 my ($self, $text, $flags) = @_;
1867 2099
1868 utf8::encode $text; 2100 utf8::encode $text;
1869 $self->send_packet (sprintf "drawinfo %d %s", $flags, $text); 2101 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);
1870} 2102}
1871 2103
2104=item $client->ext_event ($type, %msg)
2105
2106Sends an exti event to the client.
2107
2108=cut
2109
2110sub cf::client::ext_event($$%) {
2111 my ($self, $type, %msg) = @_;
2112
2113 $msg{msgtype} = "event_$type";
2114 $self->send_packet ("ext " . cf::to_json \%msg);
2115}
1872 2116
1873=item $success = $client->query ($flags, "text", \&cb) 2117=item $success = $client->query ($flags, "text", \&cb)
1874 2118
1875Queues a query to the client, calling the given callback with 2119Queues a query to the client, calling the given callback with
1876the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>, 2120the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>,
… …
1905 # get handled first 2149 # get handled first
1906 my $queue = delete $ns->{query_queue} 2150 my $queue = delete $ns->{query_queue}
1907 or return; # be conservative, not sure how that can happen, but we saw a crash here 2151 or return; # be conservative, not sure how that can happen, but we saw a crash here
1908 2152
1909 (shift @$queue)->[1]->($msg); 2153 (shift @$queue)->[1]->($msg);
2154 return unless $ns->valid; # temporary(?) workaround for callback destroying socket
1910 2155
1911 push @{ $ns->{query_queue} }, @$queue; 2156 push @{ $ns->{query_queue} }, @$queue;
1912 2157
1913 if (@{ $ns->{query_queue} } == @$queue) { 2158 if (@{ $ns->{query_queue} } == @$queue) {
1914 if (@$queue) { 2159 if (@$queue) {
… …
1972 2217
1973# here we export the classes and methods available to script code 2218# here we export the classes and methods available to script code
1974 2219
1975=pod 2220=pod
1976 2221
1977The following fucntions and emthods are available within a safe environment: 2222The following functions and methods are available within a safe environment:
1978 2223
1979 cf::object contr pay_amount pay_player map 2224 cf::object contr pay_amount pay_player map
1980 cf::object::player player 2225 cf::object::player player
1981 cf::player peaceful 2226 cf::player peaceful
1982 cf::map trigger 2227 cf::map trigger
… …
2067############################################################################# 2312#############################################################################
2068 2313
2069=head2 EXTENSION DATABASE SUPPORT 2314=head2 EXTENSION DATABASE SUPPORT
2070 2315
2071Crossfire maintains a very simple database for extension use. It can 2316Crossfire maintains a very simple database for extension use. It can
2072currently store anything that can be serialised using Storable, which 2317currently store binary data only (use Compress::LZF::sfreeze_cr/sthaw to
2073excludes objects. 2318convert to/from binary).
2074 2319
2075The parameter C<$family> should best start with the name of the extension 2320The parameter C<$family> should best start with the name of the extension
2076using it, it should be unique. 2321using it, it should be unique.
2077 2322
2078=over 4 2323=over 4
2079 2324
2080=item $hashref = cf::db_get $family
2081
2082Return a hashref for use by the extension C<$family>, which can be
2083modified. After modifications, you have to call C<cf::db_dirty> or
2084C<cf::db_sync>.
2085
2086=item $value = cf::db_get $family => $key 2325=item $value = cf::db_get $family => $key
2087 2326
2088Returns a single value from the database 2327Returns a single value from the database.
2089
2090=item cf::db_put $family => $hashref
2091
2092Stores the given family hashref into the database. Updates are delayed, if
2093you want the data to be synced to disk immediately, use C<cf::db_sync>.
2094 2328
2095=item cf::db_put $family => $key => $value 2329=item cf::db_put $family => $key => $value
2096 2330
2097Stores the given C<$value> in the family hash. Updates are delayed, if you 2331Stores the given C<$value> in the family.
2098want the data to be synced to disk immediately, use C<cf::db_sync>.
2099
2100=item cf::db_dirty
2101
2102Marks the database as dirty, to be updated at a later time.
2103
2104=item cf::db_sync
2105
2106Immediately write the database to disk I<if it is dirty>.
2107 2332
2108=cut 2333=cut
2109 2334
2110our $DB; 2335our $DB;
2111 2336
2112{ 2337sub db_init {
2113 my $path = cf::localdir . "/database.pst"; 2338 unless ($DB) {
2339 $DB = BDB::db_create $DB_ENV;
2114 2340
2115 sub db_load() { 2341 cf::sync_job {
2116 $DB = stat $path ? Storable::retrieve $path : { }; 2342 eval {
2117 } 2343 $DB->set_flags (BDB::CHKSUM);
2118 2344
2119 my $pid; 2345 BDB::db_open $DB, undef, "db", undef, BDB::BTREE,
2120 2346 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
2121 sub db_save() { 2347 cf::cleanup "db_open(db): $!" if $!;
2122 waitpid $pid, 0 if $pid; 2348 };
2123 if (0 == ($pid = fork)) { 2349 cf::cleanup "db_open(db): $@" if $@;
2124 $DB->{_meta}{version} = 1;
2125 Storable::nstore $DB, "$path~";
2126 rename "$path~", $path;
2127 cf::_exit 0 if defined $pid;
2128 } 2350 };
2129 }
2130
2131 my $dirty;
2132
2133 sub db_sync() {
2134 db_save if $dirty;
2135 undef $dirty;
2136 }
2137
2138 my $idle = Event->idle (min => $TICK * 2.8, max => 10, repeat => 0, data => WF_AUTOCANCEL, cb => sub {
2139 db_sync;
2140 }); 2351 }
2352}
2141 2353
2142 sub db_dirty() {
2143 $dirty = 1;
2144 $idle->start;
2145 }
2146
2147 sub db_get($;$) { 2354sub db_get($$) {
2148 @_ >= 2 2355 my $key = "$_[0]/$_[1]";
2149 ? $DB->{$_[0]}{$_[1]}
2150 : ($DB->{$_[0]} ||= { })
2151 }
2152 2356
2357 cf::sync_job {
2358 BDB::db_get $DB, undef, $key, my $data;
2359
2360 $! ? ()
2361 : $data
2362 }
2363}
2364
2153 sub db_put($$;$) { 2365sub db_put($$$) {
2154 if (@_ >= 3) { 2366 BDB::dbreq_pri 4;
2155 $DB->{$_[0]}{$_[1]} = $_[2]; 2367 BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { };
2156 } else { 2368}
2157 $DB->{$_[0]} = $_[1];
2158 }
2159 db_dirty;
2160 }
2161 2369
2162 cf::global->attach ( 2370=item cf::cache $id => [$paths...], $processversion => $process
2163 prio => 10000, 2371
2164 on_cleanup => sub { 2372Generic caching function that returns the value of the resource $id,
2165 db_sync; 2373caching and regenerating as required.
2374
2375This function can block.
2376
2377=cut
2378
2379sub cache {
2380 my ($id, $src, $processversion, $process) = @_;
2381
2382 my $meta =
2383 join "\x00",
2384 $processversion,
2385 map {
2386 aio_stat $_
2387 and Carp::croak "$_: $!";
2388
2389 ($_, (stat _)[7,9])
2390 } @$src;
2391
2392 my $dbmeta = db_get cache => "$id/meta";
2393 if ($dbmeta ne $meta) {
2394 # changed, we may need to process
2395
2396 my @data;
2397 my $md5;
2398
2399 for (0 .. $#$src) {
2400 0 <= aio_load $src->[$_], $data[$_]
2401 or Carp::croak "$src->[$_]: $!";
2166 }, 2402 }
2167 ); 2403
2404 # if processing is expensive, check
2405 # checksum first
2406 if (1) {
2407 $md5 =
2408 join "\x00",
2409 $processversion,
2410 map {
2411 Coro::cede;
2412 ($src->[$_], Digest::MD5::md5_hex $data[$_])
2413 } 0.. $#$src;
2414
2415
2416 my $dbmd5 = db_get cache => "$id/md5";
2417 if ($dbmd5 eq $md5) {
2418 db_put cache => "$id/meta", $meta;
2419
2420 return db_get cache => "$id/data";
2421 }
2422 }
2423
2424 my $t1 = Time::HiRes::time;
2425 my $data = $process->(\@data);
2426 my $t2 = Time::HiRes::time;
2427
2428 warn "cache: '$id' processed in ", $t2 - $t1, "s\n";
2429
2430 db_put cache => "$id/data", $data;
2431 db_put cache => "$id/md5" , $md5;
2432 db_put cache => "$id/meta", $meta;
2433
2434 return $data;
2435 }
2436
2437 db_get cache => "$id/data"
2438}
2439
2440=item fork_call { }, $args
2441
2442Executes the given code block with the given arguments in a seperate
2443process, returning the results. Everything must be serialisable with
2444Coro::Storable. May, of course, block. Note that the executed sub may
2445never block itself or use any form of Event handling.
2446
2447=cut
2448
2449sub fork_call(&@) {
2450 my ($cb, @args) = @_;
2451
2452# socketpair my $fh1, my $fh2, Socket::AF_UNIX, Socket::SOCK_STREAM, Socket::PF_UNSPEC
2453# or die "socketpair: $!";
2454 pipe my $fh1, my $fh2
2455 or die "pipe: $!";
2456
2457 if (my $pid = fork) {
2458 close $fh2;
2459
2460 my $res = (Coro::Handle::unblock $fh1)->readline (undef);
2461 $res = Coro::Storable::thaw $res;
2462
2463 waitpid $pid, 0; # should not block anymore, we expect the child to simply behave
2464
2465 die $$res unless "ARRAY" eq ref $res;
2466
2467 return wantarray ? @$res : $res->[-1];
2468 } else {
2469 reset_signals;
2470 local $SIG{__WARN__};
2471 local $SIG{__DIE__};
2472 eval {
2473 close $fh1;
2474
2475 my @res = eval { $cb->(@args) };
2476 syswrite $fh2, Coro::Storable::freeze +($@ ? \"$@" : \@res);
2477 };
2478
2479 warn $@ if $@;
2480 _exit 0;
2481 }
2168} 2482}
2169 2483
2170############################################################################# 2484#############################################################################
2171# the server's main() 2485# the server's init and main functions
2486
2487sub load_facedata($) {
2488 my ($path) = @_;
2489
2490 warn "loading facedata from $path\n";
2491
2492 my $facedata;
2493 0 < aio_load $path, $facedata
2494 or die "$path: $!";
2495
2496 $facedata = Coro::Storable::thaw $facedata;
2497
2498 $facedata->{version} == 2
2499 or cf::cleanup "$path: version mismatch, cannot proceed.";
2500
2501 {
2502 my $faces = $facedata->{faceinfo};
2503
2504 while (my ($face, $info) = each %$faces) {
2505 my $idx = (cf::face::find $face) || cf::face::alloc $face;
2506 warn "$face $info->{magicmap}\n" if $face =~ /obol/;#d#
2507 cf::face::set $idx, $info->{visibility}, $info->{magicmap};
2508 cf::face::set_data $idx, 0, $info->{data32}, $info->{chksum32};
2509 cf::face::set_data $idx, 1, $info->{data64}, $info->{chksum64};
2510 Coro::cede;
2511 }
2512
2513 while (my ($face, $info) = each %$faces) {
2514 next unless $info->{smooth};
2515 my $idx = cf::face::find $face
2516 or next;
2517 if (my $smooth = cf::face::find $info->{smooth}) {
2518 cf::face::set_smooth $idx, $smooth, $info->{smoothlevel};
2519 } else {
2520 warn "smooth face '$info->{smooth}' not found for face '$face'";
2521 }
2522 Coro::cede;
2523 }
2524 }
2525
2526 {
2527 my $anims = $facedata->{animinfo};
2528
2529 while (my ($anim, $info) = each %$anims) {
2530 cf::anim::set $anim, $info->{frames}, $info->{facings};
2531 Coro::cede;
2532 }
2533
2534 cf::anim::invalidate_all; # d'oh
2535 }
2536
2537 1
2538}
2539
2540sub reload_regions {
2541 load_resource_file "$MAPDIR/regions"
2542 or die "unable to load regions file\n";
2543}
2544
2545sub reload_facedata {
2546 load_facedata "$DATADIR/facedata"
2547 or die "unable to load facedata\n";
2548}
2549
2550sub reload_archetypes {
2551 load_resource_file "$DATADIR/archetypes"
2552 or die "unable to load archetypes\n";
2553}
2554
2555sub reload_treasures {
2556 load_resource_file "$DATADIR/treasures"
2557 or die "unable to load treasurelists\n";
2558}
2559
2560sub reload_resources {
2561 warn "reloading resource files...\n";
2562
2563 reload_regions;
2564 reload_facedata;
2565 reload_archetypes;
2566 reload_treasures;
2567
2568 warn "finished reloading resource files\n";
2569}
2570
2571sub init {
2572 reload_resources;
2573}
2172 2574
2173sub cfg_load { 2575sub cfg_load {
2174 open my $fh, "<:utf8", cf::confdir . "/config" 2576 open my $fh, "<:utf8", "$CONFDIR/config"
2175 or return; 2577 or return;
2176 2578
2177 local $/; 2579 local $/;
2178 *CFG = YAML::Syck::Load <$fh>; 2580 *CFG = YAML::Syck::Load <$fh>;
2179 2581
… …
2193 2595
2194sub main { 2596sub main {
2195 # we must not ever block the main coroutine 2597 # we must not ever block the main coroutine
2196 local $Coro::idle = sub { 2598 local $Coro::idle = sub {
2197 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d# 2599 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
2600 (async {
2198 async { Event::one_event }; 2601 Event::one_event;
2602 })->prio (Coro::PRIO_MAX);
2199 }; 2603 };
2200 2604
2201 cfg_load; 2605 cfg_load;
2202 db_load; 2606 db_init;
2203 load_extensions; 2607 load_extensions;
2608
2609 $TICK_WATCHER->start;
2204 Event::loop; 2610 Event::loop;
2205} 2611}
2206 2612
2207############################################################################# 2613#############################################################################
2208# initialisation and cleanup 2614# initialisation and cleanup
2209 2615
2210# install some emergency cleanup handlers 2616# install some emergency cleanup handlers
2211BEGIN { 2617BEGIN {
2212 for my $signal (qw(INT HUP TERM)) { 2618 for my $signal (qw(INT HUP TERM)) {
2213 Event->signal ( 2619 Event->signal (
2620 reentrant => 0,
2214 data => WF_AUTOCANCEL, 2621 data => WF_AUTOCANCEL,
2215 signal => $signal, 2622 signal => $signal,
2623 prio => 0,
2216 cb => sub { 2624 cb => sub {
2217 cf::cleanup "SIG$signal"; 2625 cf::cleanup "SIG$signal";
2218 }, 2626 },
2219 ); 2627 );
2220 } 2628 }
2221} 2629}
2222 2630
2223sub emergency_save { 2631sub emergency_save() {
2224 my $freeze_guard = cf::freeze_mainloop; 2632 my $freeze_guard = cf::freeze_mainloop;
2225 2633
2226 warn "enter emergency perl save\n"; 2634 warn "enter emergency perl save\n";
2227 2635
2228 cf::sync_job { 2636 cf::sync_job {
2229 # use a peculiar iteration method to avoid tripping on perl 2637 # use a peculiar iteration method to avoid tripping on perl
2230 # refcount bugs in for. also avoids problems with players 2638 # refcount bugs in for. also avoids problems with players
2231 # and maps saved/Destroyed asynchronously. 2639 # and maps saved/destroyed asynchronously.
2232 warn "begin emergency player save\n"; 2640 warn "begin emergency player save\n";
2233 for my $login (keys %cf::PLAYER) { 2641 for my $login (keys %cf::PLAYER) {
2234 my $pl = $cf::PLAYER{$login} or next; 2642 my $pl = $cf::PLAYER{$login} or next;
2235 $pl->valid or next; 2643 $pl->valid or next;
2236 $pl->save; 2644 $pl->save;
… …
2242 my $map = $cf::MAP{$path} or next; 2650 my $map = $cf::MAP{$path} or next;
2243 $map->valid or next; 2651 $map->valid or next;
2244 $map->save; 2652 $map->save;
2245 } 2653 }
2246 warn "end emergency map save\n"; 2654 warn "end emergency map save\n";
2655
2656 warn "begin emergency database checkpoint\n";
2657 BDB::db_env_txn_checkpoint $DB_ENV;
2658 warn "end emergency database checkpoint\n";
2247 }; 2659 };
2248 2660
2249 warn "leave emergency perl save\n"; 2661 warn "leave emergency perl save\n";
2250} 2662}
2251 2663
2664sub post_cleanup {
2665 my ($make_core) = @_;
2666
2667 warn Carp::longmess "post_cleanup backtrace"
2668 if $make_core;
2669}
2670
2252sub reload() { 2671sub do_reload_perl() {
2253 # can/must only be called in main 2672 # can/must only be called in main
2254 if ($Coro::current != $Coro::main) { 2673 if ($Coro::current != $Coro::main) {
2255 warn "can only reload from main coroutine\n"; 2674 warn "can only reload from main coroutine";
2256 return; 2675 return;
2257 } 2676 }
2258 2677
2259 warn "reloading..."; 2678 warn "reloading...";
2260 2679
2261 my $guard = freeze_mainloop; 2680 warn "entering sync_job";
2681
2682 cf::sync_job {
2683 cf::write_runtime; # external watchdog should not bark
2262 cf::emergency_save; 2684 cf::emergency_save;
2685 cf::write_runtime; # external watchdog should not bark
2263 2686
2264 eval { 2687 warn "syncing database to disk";
2688 BDB::db_env_txn_checkpoint $DB_ENV;
2689
2265 # if anything goes wrong in here, we should simply crash as we already saved 2690 # if anything goes wrong in here, we should simply crash as we already saved
2266 2691
2267 # cancel all watchers 2692 warn "cancelling all WF_AUTOCANCEL watchers";
2268 for (Event::all_watchers) { 2693 for (Event::all_watchers) {
2269 $_->cancel if $_->data & WF_AUTOCANCEL; 2694 $_->cancel if $_->data & WF_AUTOCANCEL;
2270 } 2695 }
2271 2696
2697 warn "flushing outstanding aio requests";
2698 for (;;) {
2699 BDB::flush;
2700 IO::AIO::flush;
2701 Coro::cede;
2702 last unless IO::AIO::nreqs || BDB::nreqs;
2703 warn "iterate...";
2704 }
2705
2706 ++$RELOAD;
2707
2272 # cancel all extension coros 2708 warn "cancelling all extension coros";
2273 $_->cancel for values %EXT_CORO; 2709 $_->cancel for values %EXT_CORO;
2274 %EXT_CORO = (); 2710 %EXT_CORO = ();
2275 2711
2276 # unload all extensions 2712 warn "removing commands";
2277 for (@exts) { 2713 %COMMAND = ();
2714
2715 warn "removing ext commands";
2716 %EXTCMD = ();
2717
2718 warn "unloading/nuking all extensions";
2719 for my $pkg (@EXTS) {
2278 warn "unloading <$_>"; 2720 warn "... unloading $pkg";
2279 unload_extension $_; 2721
2722 if (my $cb = $pkg->can ("unload")) {
2723 eval {
2724 $cb->($pkg);
2725 1
2726 } or warn "$pkg unloaded, but with errors: $@";
2280 } 2727 }
2281 2728
2729 warn "... nuking $pkg";
2730 Symbol::delete_package $pkg;
2731 }
2732
2282 # unload all modules loaded from $LIBDIR 2733 warn "unloading all perl modules loaded from $LIBDIR";
2283 while (my ($k, $v) = each %INC) { 2734 while (my ($k, $v) = each %INC) {
2284 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/; 2735 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
2285 2736
2286 warn "removing <$k>"; 2737 warn "... unloading $k";
2287 delete $INC{$k}; 2738 delete $INC{$k};
2288 2739
2289 $k =~ s/\.pm$//; 2740 $k =~ s/\.pm$//;
2290 $k =~ s/\//::/g; 2741 $k =~ s/\//::/g;
2291 2742
… …
2294 } 2745 }
2295 2746
2296 Symbol::delete_package $k; 2747 Symbol::delete_package $k;
2297 } 2748 }
2298 2749
2299 # sync database to disk
2300 cf::db_sync;
2301 IO::AIO::flush;
2302
2303 # get rid of safe::, as good as possible 2750 warn "getting rid of safe::, as good as possible";
2304 Symbol::delete_package "safe::$_" 2751 Symbol::delete_package "safe::$_"
2305 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region); 2752 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
2306 2753
2307 # remove register_script_function callbacks
2308 # TODO
2309
2310 # unload cf.pm "a bit" 2754 warn "unloading cf.pm \"a bit\"";
2311 delete $INC{"cf.pm"}; 2755 delete $INC{"cf.pm"};
2756 delete $INC{"cf/pod.pm"};
2312 2757
2313 # don't, removes xs symbols, too, 2758 # don't, removes xs symbols, too,
2314 # and global variables created in xs 2759 # and global variables created in xs
2315 #Symbol::delete_package __PACKAGE__; 2760 #Symbol::delete_package __PACKAGE__;
2316 2761
2317 # reload cf.pm 2762 warn "unload completed, starting to reload now";
2763
2318 warn "reloading cf.pm"; 2764 warn "reloading cf.pm";
2319 require cf; 2765 require cf;
2320 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 2766 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
2321 2767
2322 # load config and database again 2768 warn "loading config and database again";
2323 cf::cfg_load; 2769 cf::cfg_load;
2324 cf::db_load;
2325 2770
2326 # load extensions
2327 warn "load extensions"; 2771 warn "loading extensions";
2328 cf::load_extensions; 2772 cf::load_extensions;
2329 2773
2330 # reattach attachments to objects 2774 warn "reattaching attachments to objects/players";
2331 warn "reattach"; 2775 _global_reattach; # objects, sockets
2332 _global_reattach; 2776 warn "reattaching attachments to maps";
2333 reattach $_ for values %MAP; 2777 reattach $_ for values %MAP;
2334 }; 2778 warn "reattaching attachments to players";
2779 reattach $_ for values %PLAYER;
2335 2780
2336 if ($@) { 2781 warn "leaving sync_job";
2782
2783 1
2784 } or do {
2337 warn $@; 2785 warn $@;
2338 warn "error while reloading, exiting."; 2786 warn "error while reloading, exiting.";
2339 exit 1; 2787 exit 1;
2340 } 2788 };
2341 2789
2342 warn "reloaded successfully"; 2790 warn "reloaded";
2343}; 2791};
2344 2792
2345############################################################################# 2793our $RELOAD_WATCHER; # used only during reload
2346 2794
2347unless ($LINK_MAP) { 2795sub reload_perl() {
2348 $LINK_MAP = cf::map::new; 2796 # doing reload synchronously and two reloads happen back-to-back,
2797 # coro crashes during coro_state_free->destroy here.
2349 2798
2350 $LINK_MAP->width (41); 2799 $RELOAD_WATCHER ||= Event->timer (
2351 $LINK_MAP->height (41); 2800 reentrant => 0,
2352 $LINK_MAP->alloc;
2353 $LINK_MAP->path ("{link}");
2354 $LINK_MAP->{path} = bless { path => "{link}" }, "cf::path";
2355 $LINK_MAP->in_memory (MAP_IN_MEMORY);
2356
2357 # dirty hack because... archetypes are not yet loaded
2358 Event->timer (
2359 after => 10, 2801 after => 0,
2802 data => WF_AUTOCANCEL,
2360 cb => sub { 2803 cb => sub {
2361 $_[0]->w->cancel; 2804 do_reload_perl;
2362 2805 undef $RELOAD_WATCHER;
2363 # provide some exits "home"
2364 my $exit = cf::object::new "exit";
2365
2366 $exit->slaying ($EMERGENCY_POSITION->[0]);
2367 $exit->stats->hp ($EMERGENCY_POSITION->[1]);
2368 $exit->stats->sp ($EMERGENCY_POSITION->[2]);
2369
2370 $LINK_MAP->insert ($exit->clone, 19, 19);
2371 $LINK_MAP->insert ($exit->clone, 19, 20);
2372 $LINK_MAP->insert ($exit->clone, 19, 21);
2373 $LINK_MAP->insert ($exit->clone, 20, 19);
2374 $LINK_MAP->insert ($exit->clone, 20, 21);
2375 $LINK_MAP->insert ($exit->clone, 21, 19);
2376 $LINK_MAP->insert ($exit->clone, 21, 20);
2377 $LINK_MAP->insert ($exit->clone, 21, 21);
2378
2379 $exit->destroy;
2380 }); 2806 },
2381 2807 );
2382 $LINK_MAP->{deny_save} = 1;
2383 $LINK_MAP->{deny_reset} = 1;
2384
2385 $cf::MAP{$LINK_MAP->path} = $LINK_MAP;
2386} 2808}
2387
2388register "<global>", __PACKAGE__;
2389 2809
2390register_command "reload" => sub { 2810register_command "reload" => sub {
2391 my ($who, $arg) = @_; 2811 my ($who, $arg) = @_;
2392 2812
2393 if ($who->flag (FLAG_WIZ)) { 2813 if ($who->flag (FLAG_WIZ)) {
2394 $who->message ("start of reload.");
2395 reload;
2396 $who->message ("end of reload."); 2814 $who->message ("reloading server.");
2815 async { reload_perl };
2397 } 2816 }
2398}; 2817};
2399 2818
2400unshift @INC, $LIBDIR; 2819unshift @INC, $LIBDIR;
2401 2820
2821my $bug_warning = 0;
2822
2823our @WAIT_FOR_TICK;
2824our @WAIT_FOR_TICK_BEGIN;
2825
2826sub wait_for_tick {
2827 return unless $TICK_WATCHER->is_active;
2828 return if $Coro::current == $Coro::main;
2829
2830 my $signal = new Coro::Signal;
2831 push @WAIT_FOR_TICK, $signal;
2832 $signal->wait;
2833}
2834
2835sub wait_for_tick_begin {
2836 return unless $TICK_WATCHER->is_active;
2837 return if $Coro::current == $Coro::main;
2838
2839 my $signal = new Coro::Signal;
2840 push @WAIT_FOR_TICK_BEGIN, $signal;
2841 $signal->wait;
2842}
2843
2844 my $min = 1e6;#d#
2845 my $avg = 10;
2402$TICK_WATCHER = Event->timer ( 2846$TICK_WATCHER = Event->timer (
2403 reentrant => 0, 2847 reentrant => 0,
2848 parked => 1,
2404 prio => 0, 2849 prio => 0,
2405 at => $NEXT_TICK || $TICK, 2850 at => $NEXT_TICK || $TICK,
2406 data => WF_AUTOCANCEL, 2851 data => WF_AUTOCANCEL,
2407 cb => sub { 2852 cb => sub {
2853 if ($Coro::current != $Coro::main) {
2854 Carp::cluck "major BUG: server tick called outside of main coro, skipping it"
2855 unless ++$bug_warning > 10;
2856 return;
2857 }
2858
2859 $NOW = $tick_start = Event::time;
2860
2408 cf::server_tick; # one server iteration 2861 cf::server_tick; # one server iteration
2862
2863 0 && sync_job {#d#
2864 for(1..10) {
2865 my $t = Event::time;
2866 my $map = my $map = new_from_path cf::map "/tmp/x.map"
2867 or die;
2868
2869 $map->width (50);
2870 $map->height (50);
2871 $map->alloc;
2872 $map->_load_objects ("/tmp/x.map", 1);
2873 my $t = Event::time - $t;
2874
2875 #next unless $t < 0.0013;#d#
2876 if ($t < $min) {
2877 $min = $t;
2878 }
2879 $avg = $avg * 0.99 + $t * 0.01;
2880 }
2881 warn "XXXXXXXXXXXXXXXXXX min $min avg $avg\n";#d#
2882 exit 0;
2883 # 2007-05-22 02:33:04.569 min 0.00112509727478027 avg 0.0012259249572477
2884 };
2885
2409 $RUNTIME += $TICK; 2886 $RUNTIME += $TICK;
2410 $NEXT_TICK += $TICK; 2887 $NEXT_TICK += $TICK;
2411 2888
2412 $WAIT_FOR_TICK->broadcast; 2889 if ($NOW >= $NEXT_RUNTIME_WRITE) {
2413 $WAIT_FOR_TICK_ONE->send if $WAIT_FOR_TICK_ONE->awaited; 2890 $NEXT_RUNTIME_WRITE = $NOW + 10;
2891 Coro::async_pool {
2892 write_runtime
2893 or warn "ERROR: unable to write runtime file: $!";
2894 };
2895 }
2896
2897# my $AFTER = Event::time;
2898# warn $AFTER - $NOW;#d#
2899
2900 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
2901 $sig->send;
2902 }
2903 while (my $sig = shift @WAIT_FOR_TICK) {
2904 $sig->send;
2905 }
2906
2907 $NOW = Event::time;
2414 2908
2415 # if we are delayed by four ticks or more, skip them all 2909 # if we are delayed by four ticks or more, skip them all
2416 $NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4; 2910 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
2417 2911
2418 $TICK_WATCHER->at ($NEXT_TICK); 2912 $TICK_WATCHER->at ($NEXT_TICK);
2419 $TICK_WATCHER->start; 2913 $TICK_WATCHER->start;
2914
2915 $LOAD = ($NOW - $tick_start) / $TICK;
2916 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
2917
2918 _post_tick;
2919
2920
2420 }, 2921 },
2421); 2922);
2422 2923
2924{
2423IO::AIO::max_poll_time $TICK * 0.2; 2925 BDB::max_poll_time $TICK * 0.1;
2424 2926 $BDB_POLL_WATCHER = Event->io (
2425Event->io ( 2927 reentrant => 0,
2426 fd => IO::AIO::poll_fileno, 2928 fd => BDB::poll_fileno,
2427 poll => 'r', 2929 poll => 'r',
2428 prio => 5, 2930 prio => 0,
2429 data => WF_AUTOCANCEL,
2430 cb => \&IO::AIO::poll_cb,
2431);
2432
2433Event->timer (
2434 data => WF_AUTOCANCEL, 2931 data => WF_AUTOCANCEL,
2435 after => 0, 2932 cb => \&BDB::poll_cb,
2436 interval => 10, 2933 );
2437 cb => sub { 2934 BDB::min_parallel 8;
2438 (Coro::unblock_sub { 2935
2439 write_runtime 2936 BDB::set_sync_prepare {
2440 or warn "ERROR: unable to write runtime file: $!"; 2937 my $status;
2938 my $current = $Coro::current;
2939 (
2940 sub {
2941 $status = $!;
2942 $current->ready; undef $current;
2943 },
2944 sub {
2945 Coro::schedule while defined $current;
2946 $! = $status;
2947 },
2948 )
2949 };
2950
2951 unless ($DB_ENV) {
2952 $DB_ENV = BDB::db_env_create;
2953
2954 cf::sync_job {
2955 eval {
2956 BDB::db_env_open
2957 $DB_ENV,
2958 $BDBDIR,
2959 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN
2960 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE,
2961 0666;
2962
2963 cf::cleanup "db_env_open($BDBDIR): $!" if $!;
2964
2965 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC, 1);
2966 $DB_ENV->set_lk_detect;
2967 };
2968
2969 cf::cleanup "db_env_open(db): $@" if $@;
2441 })->(); 2970 };
2442 }, 2971 }
2443); 2972}
2973
2974{
2975 IO::AIO::min_parallel 8;
2976
2977 undef $Coro::AIO::WATCHER;
2978 IO::AIO::max_poll_time $TICK * 0.1;
2979 $AIO_POLL_WATCHER = Event->io (
2980 reentrant => 0,
2981 data => WF_AUTOCANCEL,
2982 fd => IO::AIO::poll_fileno,
2983 poll => 'r',
2984 prio => 6,
2985 cb => \&IO::AIO::poll_cb,
2986 );
2987}
2988
2989my $_log_backtrace;
2990
2991sub _log_backtrace {
2992 my ($msg, @addr) = @_;
2993
2994 $msg =~ s/\n//;
2995
2996 # limit the # of concurrent backtraces
2997 if ($_log_backtrace < 2) {
2998 ++$_log_backtrace;
2999 async {
3000 my @bt = fork_call {
3001 @addr = map { sprintf "%x", $_ } @addr;
3002 my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X;
3003 open my $fh, "exec addr2line -C -f -i -e \Q$self\E @addr 2>&1 |"
3004 or die "addr2line: $!";
3005
3006 my @funcs;
3007 my @res = <$fh>;
3008 chomp for @res;
3009 while (@res) {
3010 my ($func, $line) = splice @res, 0, 2, ();
3011 push @funcs, "[$func] $line";
3012 }
3013
3014 @funcs
3015 };
3016
3017 LOG llevInfo, "[ABT] $msg\n";
3018 LOG llevInfo, "[ABT] $_\n" for @bt;
3019 --$_log_backtrace;
3020 };
3021 } else {
3022 LOG llevInfo, "[ABT] $msg\n";
3023 LOG llevInfo, "[ABT] [suppressed]\n";
3024 }
3025}
3026
3027# load additional modules
3028use cf::pod;
2444 3029
2445END { cf::emergency_save } 3030END { cf::emergency_save }
2446 3031
24471 30321
2448 3033

Diff Legend

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