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.158 by root, Wed Jan 10 19:52:43 2007 UTC vs.
Revision 1.271 by root, Fri Jun 1 06:04:08 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
372use overload
373 '""' => \&as_string;
374
375# used to convert map paths into valid unix filenames by repalcing / by ∕
376our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons
377
378sub new {
379 my ($class, $path, $base) = @_;
380
381 $path = $path->as_string if ref $path;
382
383 my $self = bless { }, $class;
384
385 # {... are special paths that are not touched
386 # ?xxx/... are special absolute paths
387 # ?random/... random maps
388 # /! non-realised random map exit
389 # /... normal maps
390 # ~/... per-player maps without a specific player (DO NOT USE)
391 # ~user/... per-player map of a specific user
392
393 $path =~ s/$PATH_SEP/\//go;
394
395 if ($path =~ /^{/) {
396 # fine as it is
397 } elsif ($path =~ s{^\?random/}{}) {
398 Coro::AIO::aio_load "$cf::RANDOM_MAPS/$path.meta", my $data;
399 $self->{random} = cf::from_json $data;
400 } else {
401 if ($path =~ s{^~([^/]+)?}{}) {
402 $self->{user_rel} = 1;
403
404 if (defined $1) {
405 $self->{user} = $1;
406 } elsif ($base =~ m{^~([^/]+)/}) {
407 $self->{user} = $1;
408 } else {
409 warn "cannot resolve user-relative path without user <$path,$base>\n";
410 }
411 } elsif ($path =~ /^\//) {
412 # already absolute
413 } else {
414 $base =~ s{[^/]+/?$}{};
415 return $class->new ("$base/$path");
416 }
417
418 for ($path) {
419 redo if s{/\.?/}{/};
420 redo if s{/[^/]+/\.\./}{/};
421 }
422 }
423
424 $self->{path} = $path;
425
426 $self
427}
428
429# the name / primary key / in-game path
430sub as_string {
431 my ($self) = @_;
432
433 $self->{user_rel} ? "~$self->{user}$self->{path}"
434 : $self->{random} ? "?random/$self->{path}"
435 : $self->{path}
436}
437
438# the displayed name, this is a one way mapping
439sub visible_name {
440 my ($self) = @_;
441
442# if (my $rmp = $self->{random}) {
443# # todo: be more intelligent about this
444# "?random/$rmp->{origin_map}+$rmp->{origin_x}+$rmp->{origin_y}/$rmp->{dungeon_level}"
445# } else {
446 $self->as_string
447# }
448}
449
450# escape the /'s in the path
451sub _escaped_path {
452 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g;
453 $path
454}
455
456# the original (read-only) location
457sub load_path {
458 my ($self) = @_;
459
460 sprintf "%s/%s/%s", cf::datadir, cf::mapdir, $self->{path}
461}
462
463# the temporary/swap location
464sub save_path {
465 my ($self) = @_;
466
467 $self->{user_rel} ? sprintf "%s/%s/%s/%s", cf::localdir, cf::playerdir, $self->{user}, $self->_escaped_path
468 : $self->{random} ? sprintf "%s/%s", $RANDOM_MAPS, $self->{path}
469 : sprintf "%s/%s/%s", cf::localdir, cf::tmpdir, $self->_escaped_path
470}
471
472# the unique path, might be eq to save_path
473sub uniq_path {
474 my ($self) = @_;
475
476 $self->{user_rel} || $self->{random}
477 ? undef
478 : sprintf "%s/%s/%s", cf::localdir, cf::uniquedir, $self->_escaped_path
479}
480
481# return random map parameters, or undef
482sub random_map_params {
483 my ($self) = @_;
484
485 $self->{random}
486}
487
488# this is somewhat ugly, but style maps do need special treatment
489sub is_style_map {
490 $_[0]{path} =~ m{^/styles/}
491}
492
493package cf;
494 446
495############################################################################# 447#############################################################################
496 448
497=head2 ATTACHABLE OBJECTS 449=head2 ATTACHABLE OBJECTS
498 450
… …
624our @CB_TYPE = (); # registry for type (cf-object class) based events 576our @CB_TYPE = (); # registry for type (cf-object class) based events
625our @CB_MAP = (); 577our @CB_MAP = ();
626 578
627my %attachment; 579my %attachment;
628 580
581sub cf::attachable::thawer_merge {
582 # simply override everything except _meta
583 local $_[0]{_meta};
584 %{$_[0]} = %{$_[1]};
585}
586
629sub _attach_cb($$$$) { 587sub _attach_cb($$$$) {
630 my ($registry, $event, $prio, $cb) = @_; 588 my ($registry, $event, $prio, $cb) = @_;
631 589
632 use sort 'stable'; 590 use sort 'stable';
633 591
… …
667 $registry = $CB_TYPE[$object_type] ||= []; 625 $registry = $CB_TYPE[$object_type] ||= [];
668 626
669 } elsif ($type eq "subtype") { 627 } elsif ($type eq "subtype") {
670 defined $object_type or Carp::croak "subtype specified without type"; 628 defined $object_type or Carp::croak "subtype specified without type";
671 my $object_subtype = shift @arg; 629 my $object_subtype = shift @arg;
672 $registry = $CB_TYPE[$object_type + $object_subtype * NUM_SUBTYPES] ||= []; 630 $registry = $CB_TYPE[$object_type + $object_subtype * NUM_TYPES] ||= [];
673 631
674 } elsif ($type eq "package") { 632 } elsif ($type eq "package") {
675 my $pkg = shift @arg; 633 my $pkg = shift @arg;
676 634
677 while (my ($name, $id) = each %cb_id) { 635 while (my ($name, $id) = each %cb_id) {
… …
718 if (ref $_[0]) { 676 if (ref $_[0]) {
719 _object_attach @_; 677 _object_attach @_;
720 } else { 678 } else {
721 _attach shift->_attach_registry, @_; 679 _attach shift->_attach_registry, @_;
722 } 680 }
681 _recalc_want;
723}; 682};
724 683
725# all those should be optimised 684# all those should be optimised
726sub cf::attachable::detach { 685sub cf::attachable::detach {
727 my ($obj, $name) = @_; 686 my ($obj, $name) = @_;
… …
730 delete $obj->{_attachment}{$name}; 689 delete $obj->{_attachment}{$name};
731 reattach ($obj); 690 reattach ($obj);
732 } else { 691 } else {
733 Carp::croak "cannot, currently, detach class attachments"; 692 Carp::croak "cannot, currently, detach class attachments";
734 } 693 }
694 _recalc_want;
735}; 695};
736 696
737sub cf::attachable::attached { 697sub cf::attachable::attached {
738 my ($obj, $name) = @_; 698 my ($obj, $name) = @_;
739 699
… …
804# object support 764# object support
805 765
806sub reattach { 766sub reattach {
807 # basically do the same as instantiate, without calling instantiate 767 # basically do the same as instantiate, without calling instantiate
808 my ($obj) = @_; 768 my ($obj) = @_;
769
770 bless $obj, ref $obj; # re-bless in case extensions have been reloaded
809 771
810 my $registry = $obj->registry; 772 my $registry = $obj->registry;
811 773
812 @$registry = (); 774 @$registry = ();
813 775
… …
860 $filename, length $$rdata, scalar @$objs; 822 $filename, length $$rdata, scalar @$objs;
861 823
862 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) { 824 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
863 chmod SAVE_MODE, $fh; 825 chmod SAVE_MODE, $fh;
864 aio_write $fh, 0, (length $$rdata), $$rdata, 0; 826 aio_write $fh, 0, (length $$rdata), $$rdata, 0;
865 aio_fsync $fh; 827 aio_fsync $fh if $cf::USE_FSYNC;
866 close $fh; 828 close $fh;
867 829
868 if (@$objs) { 830 if (@$objs) {
869 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) {
870 chmod SAVE_MODE, $fh; 832 chmod SAVE_MODE, $fh;
871 my $data = Storable::nfreeze { version => 1, objs => $objs }; 833 my $data = Storable::nfreeze { version => 1, objs => $objs };
872 aio_write $fh, 0, (length $data), $data, 0; 834 aio_write $fh, 0, (length $data), $data, 0;
873 aio_fsync $fh; 835 aio_fsync $fh if $cf::USE_FSYNC;
874 close $fh; 836 close $fh;
875 aio_rename "$filename.pst~", "$filename.pst"; 837 aio_rename "$filename.pst~", "$filename.pst";
876 } 838 }
877 } else { 839 } else {
878 aio_unlink "$filename.pst"; 840 aio_unlink "$filename.pst";
… …
945=cut 907=cut
946 908
947sub register_extcmd { 909sub register_extcmd {
948 my ($name, $cb) = @_; 910 my ($name, $cb) = @_;
949 911
950 my $caller = caller;
951 #warn "registering extcmd '$name' to '$caller'";
952
953 $EXTCMD{$name} = [$cb, $caller]; 912 $EXTCMD{$name} = $cb;
954} 913}
955 914
956cf::player->attach ( 915cf::player->attach (
957 on_command => sub { 916 on_command => sub {
958 my ($pl, $name, $params) = @_; 917 my ($pl, $name, $params) = @_;
… …
971 930
972 my $msg = eval { from_json $buf }; 931 my $msg = eval { from_json $buf };
973 932
974 if (ref $msg) { 933 if (ref $msg) {
975 if (my $cb = $EXTCMD{$msg->{msgtype}}) { 934 if (my $cb = $EXTCMD{$msg->{msgtype}}) {
976 if (my %reply = $cb->[0]->($pl, $msg)) { 935 if (my %reply = $cb->($pl, $msg)) {
977 $pl->ext_reply ($msg->{msgid}, %reply); 936 $pl->ext_reply ($msg->{msgid}, %reply);
978 } 937 }
979 } 938 }
980 } else { 939 } else {
981 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n"; 940 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
… …
983 942
984 cf::override; 943 cf::override;
985 }, 944 },
986); 945);
987 946
988sub register {
989 my ($base, $pkg) = @_;
990
991 #TODO
992}
993
994sub load_extension { 947sub load_extension {
995 my ($path) = @_; 948 my ($path) = @_;
996 949
997 $path =~ /([^\/\\]+)\.ext$/ or die "$path"; 950 $path =~ /([^\/\\]+)\.ext$/ or die "$path";
998 my $base = $1; 951 my $base = $1;
999 my $pkg = $1; 952 my $pkg = $1;
1000 $pkg =~ s/[^[:word:]]/_/g; 953 $pkg =~ s/[^[:word:]]/_/g;
1001 $pkg = "ext::$pkg"; 954 $pkg = "ext::$pkg";
1002 955
1003 warn "loading '$path' into '$pkg'\n"; 956 warn "... loading '$path' into '$pkg'\n";
1004 957
1005 open my $fh, "<:utf8", $path 958 open my $fh, "<:utf8", $path
1006 or die "$path: $!"; 959 or die "$path: $!";
1007 960
1008 my $source = 961 my $source =
1009 "package $pkg; use strict; use utf8;\n" 962 "package $pkg; use strict; use utf8;\n"
1010 . "#line 1 \"$path\"\n{\n" 963 . "#line 1 \"$path\"\n{\n"
1011 . (do { local $/; <$fh> }) 964 . (do { local $/; <$fh> })
1012 . "\n};\n1"; 965 . "\n};\n1";
1013 966
1014 eval $source 967 unless (eval $source) {
1015 or die $@ ? "$path: $@\n" 968 my $msg = $@ ? "$path: $@\n"
1016 : "extension disabled.\n"; 969 : "extension disabled.\n";
1017 970 if ($source =~ /^#!.*perl.*#.*MANDATORY/m) { # ugly match
1018 push @exts, $pkg; 971 warn $@;
1019 $ext_pkg{$base} = $pkg; 972 warn "mandatory extension failed to load, exiting.\n";
1020 973 exit 1;
1021# no strict 'refs'; 974 }
1022# @{"$pkg\::ISA"} = ext::; 975 die $@;
1023
1024 register $base, $pkg;
1025}
1026
1027sub unload_extension {
1028 my ($pkg) = @_;
1029
1030 warn "removing extension $pkg\n";
1031
1032 # remove hooks
1033 #TODO
1034# for my $idx (0 .. $#PLUGIN_EVENT) {
1035# delete $hook[$idx]{$pkg};
1036# } 976 }
1037 977
1038 # remove commands 978 push @EXTS, $pkg;
1039 for my $name (keys %COMMAND) {
1040 my @cb = grep $_->[0] ne $pkg, @{ $COMMAND{$name} };
1041
1042 if (@cb) {
1043 $COMMAND{$name} = \@cb;
1044 } else {
1045 delete $COMMAND{$name};
1046 }
1047 }
1048
1049 # remove extcmds
1050 for my $name (grep $EXTCMD{$_}[1] eq $pkg, keys %EXTCMD) {
1051 delete $EXTCMD{$name};
1052 }
1053
1054 if (my $cb = $pkg->can ("unload")) {
1055 eval {
1056 $cb->($pkg);
1057 1
1058 } or warn "$pkg unloaded, but with errors: $@";
1059 }
1060
1061 Symbol::delete_package $pkg;
1062} 979}
1063 980
1064sub load_extensions { 981sub load_extensions {
1065 for my $ext (<$LIBDIR/*.ext>) { 982 for my $ext (<$LIBDIR/*.ext>) {
1066 next unless -r $ext; 983 next unless -r $ext;
… …
1070 } or warn "$ext not loaded: $@"; 987 } or warn "$ext not loaded: $@";
1071 } 988 }
1072} 989}
1073 990
1074############################################################################# 991#############################################################################
1075# load/save/clean perl data associated with a map
1076
1077*cf::mapsupport::on_clean = sub {
1078 my ($map) = @_;
1079
1080 my $path = $map->tmpname;
1081 defined $path or return;
1082
1083 unlink "$path.pst";
1084};
1085
1086cf::map->attach (prio => -10000, package => cf::mapsupport::);
1087
1088#############################################################################
1089 992
1090=head2 CORE EXTENSIONS 993=head2 CORE EXTENSIONS
1091 994
1092Functions and methods that extend core crossfire objects. 995Functions and methods that extend core crossfire objects.
1093 996
… …
1106Returns the given player object, loading it if necessary (might block). 1009Returns the given player object, loading it if necessary (might block).
1107 1010
1108=cut 1011=cut
1109 1012
1110sub playerdir($) { 1013sub playerdir($) {
1111 cf::localdir 1014 "$PLAYERDIR/"
1112 . "/"
1113 . cf::playerdir
1114 . "/"
1115 . (ref $_[0] ? $_[0]->ob->name : $_[0]) 1015 . (ref $_[0] ? $_[0]->ob->name : $_[0])
1116} 1016}
1117 1017
1118sub path($) { 1018sub path($) {
1119 my $login = ref $_[0] ? $_[0]->ob->name : $_[0]; 1019 my $login = ref $_[0] ? $_[0]->ob->name : $_[0];
1120 1020
1121 (playerdir $login) . "/$login.pl" 1021 (playerdir $login) . "/playerdata"
1122} 1022}
1123 1023
1124sub find_active($) { 1024sub find_active($) {
1125 $cf::PLAYER{$_[0]} 1025 $cf::PLAYER{$_[0]}
1126 and $cf::PLAYER{$_[0]}->active 1026 and $cf::PLAYER{$_[0]}->active
… …
1129 1029
1130sub exists($) { 1030sub exists($) {
1131 my ($login) = @_; 1031 my ($login) = @_;
1132 1032
1133 $cf::PLAYER{$login} 1033 $cf::PLAYER{$login}
1134 or cf::sync_job { !aio_stat $login } 1034 or cf::sync_job { !aio_stat path $login }
1135} 1035}
1136 1036
1137sub find($) { 1037sub find($) {
1138 return $cf::PLAYER{$_[0]} || do { 1038 return $cf::PLAYER{$_[0]} || do {
1139 my $login = $_[0]; 1039 my $login = $_[0];
1140 1040
1141 my $guard = cf::lock_acquire "user_find:$login"; 1041 my $guard = cf::lock_acquire "user_find:$login";
1142 1042
1143 $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
1144 my $pl = load_pl path $login 1051 my $pl = load_pl path $login
1145 or return; 1052 or return;
1146 $cf::PLAYER{$login} = $pl 1053 $cf::PLAYER{$login} = $pl
1147 } 1054 }
1148 } 1055 }
… …
1185 1092
1186=cut 1093=cut
1187 1094
1188sub quit_character { 1095sub quit_character {
1189 my ($pl) = @_; 1096 my ($pl) = @_;
1097
1098 my $name = $pl->ob->name;
1190 1099
1191 $pl->{deny_save} = 1; 1100 $pl->{deny_save} = 1;
1192 $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
1193 1102
1194 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active; 1103 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active;
… …
1199 my $path = playerdir $pl; 1108 my $path = playerdir $pl;
1200 my $temp = "$path~$cf::RUNTIME~deleting~"; 1109 my $temp = "$path~$cf::RUNTIME~deleting~";
1201 aio_rename $path, $temp; 1110 aio_rename $path, $temp;
1202 delete $cf::PLAYER{$pl->ob->name}; 1111 delete $cf::PLAYER{$pl->ob->name};
1203 $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
1204 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;
1205} 1134}
1206 1135
1207=item cf::player::list_logins 1136=item cf::player::list_logins
1208 1137
1209Returns 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
1210while and may block, so not sync_job-capable, ever. 1139while and may block, so not sync_job-capable, ever.
1211 1140
1212=cut 1141=cut
1213 1142
1214sub list_logins { 1143sub list_logins {
1215 my $dirs = aio_readdir cf::localdir . "/" . cf::playerdir 1144 my $dirs = aio_readdir $PLAYERDIR
1216 or return []; 1145 or return [];
1217 1146
1218 my @logins; 1147 my @logins;
1219 1148
1220 for my $login (@$dirs) { 1149 for my $login (@$dirs) {
… …
1229 \@logins 1158 \@logins
1230} 1159}
1231 1160
1232=item $player->maps 1161=item $player->maps
1233 1162
1234Returns 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
1235player. May block. 1164player. May block.
1236 1165
1237=cut 1166=cut
1238 1167
1239sub maps($) { 1168sub maps($) {
1240 my ($pl) = @_; 1169 my ($pl) = @_;
1170
1171 $pl = ref $pl ? $pl->ob->name : $pl;
1241 1172
1242 my $files = aio_readdir playerdir $pl 1173 my $files = aio_readdir playerdir $pl
1243 or return; 1174 or return;
1244 1175
1245 my @paths; 1176 my @paths;
… …
1247 for (@$files) { 1178 for (@$files) {
1248 utf8::decode $_; 1179 utf8::decode $_;
1249 next if /\.(?:pl|pst)$/; 1180 next if /\.(?:pl|pst)$/;
1250 next unless /^$PATH_SEP/o; 1181 next unless /^$PATH_SEP/o;
1251 1182
1252 push @paths, new cf::path "~" . $pl->ob->name . "/" . $_; 1183 push @paths, cf::map::normalise "~$pl/$_";
1253 } 1184 }
1254 1185
1255 \@paths 1186 \@paths
1256} 1187}
1257 1188
1258=item $player->ext_reply ($msgid, $msgtype, %msg) 1189=item $player->ext_reply ($msgid, %msg)
1259 1190
1260Sends an ext reply to the player. 1191Sends an ext reply to the player.
1261 1192
1262=cut 1193=cut
1263 1194
1264sub ext_reply($$$%) { 1195sub ext_reply($$%) {
1265 my ($self, $id, %msg) = @_; 1196 my ($self, $id, %msg) = @_;
1266 1197
1267 $msg{msgid} = $id; 1198 $msg{msgid} = $id;
1268 1199
1269 $self->send ("ext " . cf::to_json \%msg); 1200 $self->send ("ext " . cf::to_json \%msg);
1270} 1201}
1271 1202
1272package 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}
1273 1243
1274=back 1244=back
1275
1276 1245
1277=head3 cf::map 1246=head3 cf::map
1278 1247
1279=over 4 1248=over 4
1280 1249
… …
1283package cf::map; 1252package cf::map;
1284 1253
1285use Fcntl; 1254use Fcntl;
1286use Coro::AIO; 1255use Coro::AIO;
1287 1256
1257use overload
1258 '""' => \&as_string,
1259 fallback => 1;
1260
1288our $MAX_RESET = 3600; 1261our $MAX_RESET = 3600;
1289our $DEFAULT_RESET = 3000; 1262our $DEFAULT_RESET = 3000;
1290 1263
1291sub generate_random_map { 1264sub generate_random_map {
1292 my ($path, $rmp) = @_; 1265 my ($self, $rmp) = @_;
1293
1294 # mit "rum" bekleckern, nicht 1266 # mit "rum" bekleckern, nicht
1295 cf::map::_create_random_map 1267 $self->_create_random_map (
1296 $path,
1297 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle}, 1268 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle},
1298 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle}, 1269 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle},
1299 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map}, 1270 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map},
1300 $rmp->{exit_on_final_map}, 1271 $rmp->{exit_on_final_map},
1301 $rmp->{xsize}, $rmp->{ysize}, 1272 $rmp->{xsize}, $rmp->{ysize},
1302 $rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3}, 1273 $rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3},
1303 $rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase}, 1274 $rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase},
1304 $rmp->{dungeon_level}, $rmp->{dungeon_depth}, $rmp->{decoroptions}, $rmp->{orientation}, 1275 $rmp->{dungeon_level}, $rmp->{dungeon_depth}, $rmp->{decoroptions}, $rmp->{orientation},
1305 $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},
1306 $rmp->{map_layout_style}, $rmp->{treasureoptions}, $rmp->{symmetry_used}, 1277 $rmp->{map_layout_style}, $rmp->{treasureoptions}, $rmp->{symmetry_used},
1307 (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"
1308} 1409}
1309 1410
1310# and all this just because we cannot iterate over 1411# and all this just because we cannot iterate over
1311# all maps in C++... 1412# all maps in C++...
1312sub change_all_map_light { 1413sub change_all_map_light {
… …
1314 1415
1315 $_->change_map_light ($change) 1416 $_->change_map_light ($change)
1316 for grep $_->outdoor, values %cf::MAP; 1417 for grep $_->outdoor, values %cf::MAP;
1317} 1418}
1318 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
1319sub try_load_header($) { 1428sub load_header_from($) {
1320 my ($path) = @_; 1429 my ($self, $path) = @_;
1321 1430
1322 utf8::encode $path; 1431 utf8::encode $path;
1323 aio_open $path, O_RDONLY, 0 1432 #aio_open $path, O_RDONLY, 0
1433 # or return;
1434
1435 $self->_load_header ($path)
1324 or return; 1436 or return;
1325 1437
1326 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
1327 or return; 1481 or return;
1482 $self->prepare_orig;
1483 }
1328 1484
1329 # for better error messages only, will be overwritten 1485 $self->default_region (cf::region::find_by_path $self->{path})
1330 $map->path ($path); 1486 unless $self->default_region;
1331 1487
1332 $map->load_header ($path) 1488 1
1333 or return;
1334
1335 $map->{load_path} = $path;
1336
1337 $map
1338} 1489}
1339 1490
1340sub find; 1491sub find;
1341sub find { 1492sub find {
1342 my ($path, $origin) = @_; 1493 my ($path, $origin) = @_;
1343 1494
1344 #warn "find<$path,$origin>\n";#d#
1345
1346 $path = new cf::path $path, $origin && $origin->path; 1495 $path = normalise $path, $origin && $origin->path;
1347 my $key = $path->as_string;
1348 1496
1349 cf::lock_wait "map_find:$key"; 1497 cf::lock_wait "map_find:$path";
1350 1498
1351 $cf::MAP{$key} || do { 1499 $cf::MAP{$path} || do {
1352 my $guard = cf::lock_acquire "map_find:$key"; 1500 my $guard = cf::lock_acquire "map_find:$path";
1353 1501 my $map = new_from_path cf::map $path
1354 # do it the slow way
1355 my $map = try_load_header $path->save_path;
1356
1357 Coro::cede;
1358
1359 if ($map) {
1360 $map->last_access ((delete $map->{last_access})
1361 || $cf::RUNTIME); #d#
1362 # safety
1363 $map->{instantiate_time} = $cf::RUNTIME
1364 if $map->{instantiate_time} > $cf::RUNTIME;
1365 } else {
1366 if (my $rmp = $path->random_map_params) {
1367 $map = generate_random_map $key, $rmp;
1368 } else {
1369 $map = try_load_header $path->load_path;
1370 }
1371
1372 $map or return; 1502 or return;
1373 1503
1374 $map->{load_original} = 1;
1375 $map->{instantiate_time} = $cf::RUNTIME;
1376 $map->last_access ($cf::RUNTIME);
1377 $map->instantiate;
1378
1379 # per-player maps become, after loading, normal maps
1380 $map->per_player (0) if $path->{user_rel};
1381 }
1382
1383 $map->path ($key);
1384 $map->{path} = $path;
1385 $map->{last_save} = $cf::RUNTIME; 1504 $map->{last_save} = $cf::RUNTIME;
1386 1505
1387 Coro::cede; 1506 $map->load_header
1507 or return;
1388 1508
1389 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;
1390 $map->reset; 1512 $map->reset;
1391 undef $guard; 1513 undef $guard;
1392 $map = find $path 1514 return find $path;
1393 or return;
1394 } 1515 }
1395 1516
1396 $cf::MAP{$key} = $map 1517 $cf::MAP{$path} = $map
1397 } 1518 }
1398} 1519}
1520
1521sub pre_load { }
1522sub post_load { }
1399 1523
1400sub load { 1524sub load {
1401 my ($self) = @_; 1525 my ($self) = @_;
1402 1526
1527 local $self->{deny_reset} = 1; # loading can take a long time
1528
1403 my $path = $self->{path}; 1529 my $path = $self->{path};
1530
1531 {
1404 my $guard = cf::lock_acquire "map_load:" . $path->as_string; 1532 my $guard = cf::lock_acquire "map_load:$path";
1405 1533
1406 return if $self->in_memory != cf::MAP_SWAPPED; 1534 return if $self->in_memory != cf::MAP_SWAPPED;
1407 1535
1408 $self->in_memory (cf::MAP_LOADING); 1536 $self->in_memory (cf::MAP_LOADING);
1409 1537
1410 $self->alloc; 1538 $self->alloc;
1539
1540 $self->pre_load;
1541 Coro::cede;
1542
1411 $self->load_objects ($self->{load_path}, 1) 1543 $self->_load_objects ($self->{load_path}, 1)
1412 or return; 1544 or return;
1413 1545
1414 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1) 1546 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1)
1415 if delete $self->{load_original}; 1547 if delete $self->{load_original};
1416 1548
1417 if (my $uniq = $path->uniq_path) { 1549 if (my $uniq = $self->uniq_path) {
1418 utf8::encode $uniq; 1550 utf8::encode $uniq;
1419 if (aio_open $uniq, O_RDONLY, 0) { 1551 if (aio_open $uniq, O_RDONLY, 0) {
1420 $self->clear_unique_items; 1552 $self->clear_unique_items;
1421 $self->load_objects ($uniq, 0); 1553 $self->_load_objects ($uniq, 0);
1422 } 1554 }
1423 } 1555 }
1424 1556
1425 Coro::cede; 1557 Coro::cede;
1426
1427 # now do the right thing for maps 1558 # now do the right thing for maps
1428 $self->link_multipart_objects; 1559 $self->link_multipart_objects;
1429
1430 if ($self->{path}->is_style_map) {
1431 $self->{deny_save} = 1;
1432 $self->{deny_reset} = 1;
1433 } else {
1434 $self->fix_auto_apply;
1435 $self->decay_objects;
1436 $self->update_buttons;
1437 $self->set_darkness_map;
1438 $self->difficulty ($self->estimate_difficulty) 1560 $self->difficulty ($self->estimate_difficulty)
1439 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;
1440 $self->activate; 1571 $self->activate;
1441 } 1572 }
1442 1573
1443 Coro::cede;
1444
1445 $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
1446} 1587}
1447 1588
1448# find and load all maps in the 3x3 area around a map 1589# find and load all maps in the 3x3 area around a map
1449sub load_diag { 1590sub load_diag {
1450 my ($map) = @_; 1591 my ($map) = @_;
… …
1480 1621
1481 cf::sync_job { $map->load }; 1622 cf::sync_job { $map->load };
1482} 1623}
1483 1624
1484our %MAP_PREFETCH; 1625our %MAP_PREFETCH;
1485our $MAP_PREFETCHER = Coro::async { 1626our $MAP_PREFETCHER = undef;
1486 while () {
1487 while (%MAP_PREFETCH) {
1488 my $key = each %MAP_PREFETCH
1489 or next;
1490 my $path = delete $MAP_PREFETCH{$key};
1491
1492 my $map = find $path
1493 or next;
1494 $map->load;
1495 }
1496 Coro::schedule;
1497 }
1498};
1499 1627
1500sub find_async { 1628sub find_async {
1501 my ($path, $origin) = @_; 1629 my ($path, $origin) = @_;
1502 1630
1503 $path = new cf::path $path, $origin && $origin->path; 1631 $path = normalise $path, $origin && $origin->{path};
1504 my $key = $path->as_string;
1505 1632
1506 if (my $map = $cf::MAP{$key}) { 1633 if (my $map = $cf::MAP{$path}) {
1507 return $map if $map->in_memory == cf::MAP_IN_MEMORY; 1634 return $map if $map->in_memory == cf::MAP_IN_MEMORY;
1508 } 1635 }
1509 1636
1510 $MAP_PREFETCH{$key} = $path; 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 };
1511 $MAP_PREFETCHER->ready; 1650 $MAP_PREFETCHER->prio (6);
1512 1651
1513 () 1652 ()
1514} 1653}
1515 1654
1516sub save { 1655sub save {
… …
1520 1659
1521 $self->{last_save} = $cf::RUNTIME; 1660 $self->{last_save} = $cf::RUNTIME;
1522 1661
1523 return unless $self->dirty; 1662 return unless $self->dirty;
1524 1663
1525 my $save = $self->{path}->save_path; utf8::encode $save; 1664 my $save = $self->save_path; utf8::encode $save;
1526 my $uniq = $self->{path}->uniq_path; utf8::encode $uniq; 1665 my $uniq = $self->uniq_path; utf8::encode $uniq;
1527 1666
1528 $self->{load_path} = $save; 1667 $self->{load_path} = $save;
1529 1668
1530 return if $self->{deny_save}; 1669 return if $self->{deny_save};
1531 1670
… …
1534 cf::async { 1673 cf::async {
1535 $_->contr->save for $self->players; 1674 $_->contr->save for $self->players;
1536 }; 1675 };
1537 1676
1538 if ($uniq) { 1677 if ($uniq) {
1539 $self->save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS); 1678 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS);
1540 $self->save_objects ($uniq, cf::IO_UNIQUES); 1679 $self->_save_objects ($uniq, cf::IO_UNIQUES);
1541 } else { 1680 } else {
1542 $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);
1543 } 1682 }
1544} 1683}
1545 1684
1546sub swap_out { 1685sub swap_out {
1547 my ($self) = @_; 1686 my ($self) = @_;
… …
1561 1700
1562sub reset_at { 1701sub reset_at {
1563 my ($self) = @_; 1702 my ($self) = @_;
1564 1703
1565 # TODO: safety, remove and allow resettable per-player maps 1704 # TODO: safety, remove and allow resettable per-player maps
1566 return 1e99 if $self->{path}{user_rel}; 1705 return 1e99 if $self->isa ("ext::map_per_player");#d#
1567 return 1e99 if $self->{deny_reset}; 1706 return 1e99 if $self->{deny_reset};
1568 1707
1569 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access; 1708 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
1570 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;
1571 1710
… …
1576 my ($self) = @_; 1715 my ($self) = @_;
1577 1716
1578 $self->reset_at <= $cf::RUNTIME 1717 $self->reset_at <= $cf::RUNTIME
1579} 1718}
1580 1719
1581sub unlink_save {
1582 my ($self) = @_;
1583
1584 utf8::encode (my $save = $self->{path}->save_path);
1585 aioreq_pri 3; IO::AIO::aio_unlink $save;
1586 aioreq_pri 3; IO::AIO::aio_unlink "$save.pst";
1587}
1588
1589sub rename {
1590 my ($self, $new_path) = @_;
1591
1592 $self->unlink_save;
1593
1594 delete $cf::MAP{$self->path};
1595 $self->{path} = new cf::path $new_path;
1596 $self->path ($self->{path}->as_string);
1597 $cf::MAP{$self->path} = $self;
1598
1599 $self->save;
1600}
1601
1602sub reset { 1720sub reset {
1603 my ($self) = @_; 1721 my ($self) = @_;
1604 1722
1605 my $lock = cf::lock_acquire "map_data:" . $self->path; 1723 my $lock = cf::lock_acquire "map_data:$self->{path}";
1606 1724
1607 return if $self->players; 1725 return if $self->players;
1608 return if $self->{path}{user_rel};#d# 1726 return if $self->isa ("ext::map_per_player");#d#
1609 1727
1610 warn "resetting map ", $self->path;#d# 1728 warn "resetting map ", $self->path;#d#
1611 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
1612 delete $cf::MAP{$self->path}; 1740 delete $cf::MAP{$self->path};
1741
1742 $self->clear;
1613 1743
1614 $_->clear_links_to ($self) for values %cf::MAP; 1744 $_->clear_links_to ($self) for values %cf::MAP;
1615 1745
1616 $self->unlink_save; 1746 $self->unlink_save;
1617 $self->destroy; 1747 $self->destroy;
… …
1620my $nuke_counter = "aaaa"; 1750my $nuke_counter = "aaaa";
1621 1751
1622sub nuke { 1752sub nuke {
1623 my ($self) = @_; 1753 my ($self) = @_;
1624 1754
1755 delete $cf::MAP{$self->path};
1756
1757 $self->unlink_save;
1758
1759 bless $self, "cf::map";
1760 delete $self->{deny_reset};
1625 $self->{deny_save} = 1; 1761 $self->{deny_save} = 1;
1626 $self->reset_timeout (1); 1762 $self->reset_timeout (1);
1627 $self->rename ("{nuke}/" . ($nuke_counter++)); 1763 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));
1764
1765 $cf::MAP{$self->path} = $self;
1766
1628 $self->reset; # polite request, might not happen 1767 $self->reset; # polite request, might not happen
1629} 1768}
1630 1769
1631sub customise_for {
1632 my ($map, $ob) = @_;
1633
1634 if ($map->per_player) {
1635 return cf::map::find "~" . $ob->name . "/" . $map->{path}{path};
1636 }
1637
1638 $map
1639}
1640
1641=item cf::map::unique_maps 1770=item cf::map::unique_maps
1642 1771
1643Returns an arrayref of cf::path's of all shared maps that have 1772Returns an arrayref of paths of all shared maps that have
1644instantiated unique items. May block. 1773instantiated unique items. May block.
1645 1774
1646=cut 1775=cut
1647 1776
1648sub unique_maps() { 1777sub unique_maps() {
1649 my $files = aio_readdir cf::localdir . "/" . cf::uniquedir 1778 my $files = aio_readdir $UNIQUEDIR
1650 or return; 1779 or return;
1651 1780
1652 my @paths; 1781 my @paths;
1653 1782
1654 for (@$files) { 1783 for (@$files) {
1655 utf8::decode $_; 1784 utf8::decode $_;
1656 next if /\.pst$/; 1785 next if /\.pst$/;
1657 next unless /^$PATH_SEP/o; 1786 next unless /^$PATH_SEP/o;
1658 1787
1659 push @paths, new cf::path $_; 1788 push @paths, cf::map::normalise $_;
1660 } 1789 }
1661 1790
1662 \@paths 1791 \@paths
1663} 1792}
1664 1793
… …
1739 1868
1740=item $player_object->enter_link 1869=item $player_object->enter_link
1741 1870
1742Freezes 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}>).
1743 1872
1744The 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
1745I<MUST> call C<leave_link> as soon as possible, though. 1874I<MUST> call C<leave_link> as soon as possible, though.
1746 1875
1876Will never block.
1877
1747=item $player_object->leave_link ($map, $x, $y) 1878=item $player_object->leave_link ($map, $x, $y)
1748 1879
1749Moves 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
1750map 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
1751location 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
1752to the emergency map position. 1883fails, to the emergency map position.
1753 1884
1754Might block. 1885Might block.
1755 1886
1756=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}
1757 1898
1758sub cf::object::player::enter_link { 1899sub cf::object::player::enter_link {
1759 my ($self) = @_; 1900 my ($self) = @_;
1760 1901
1761 $self->deactivate_recursive; 1902 $self->deactivate_recursive;
1762 1903
1763 return if $self->map == $LINK_MAP; 1904 return if UNIVERSAL::isa $self->map, "ext::map_link";
1764 1905
1765 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y] 1906 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y]
1766 if $self->map; 1907 if $self->map && $self->map->{path} ne "{link}";
1767 1908
1768 $self->enter_map ($LINK_MAP, 20, 20); 1909 $self->enter_map ($LINK_MAP || link_map, 10, 10);
1769} 1910}
1770 1911
1771sub cf::object::player::leave_link { 1912sub cf::object::player::leave_link {
1772 my ($self, $map, $x, $y) = @_; 1913 my ($self, $map, $x, $y) = @_;
1914
1915 return unless $self->contr->active;
1773 1916
1774 my $link_pos = delete $self->{_link_pos}; 1917 my $link_pos = delete $self->{_link_pos};
1775 1918
1776 unless ($map) { 1919 unless ($map) {
1777 # restore original map position 1920 # restore original map position
… …
1795 $map->load; 1938 $map->load;
1796 $map->load_diag; 1939 $map->load_diag;
1797 1940
1798 return unless $self->contr->active; 1941 return unless $self->contr->active;
1799 $self->activate_recursive; 1942 $self->activate_recursive;
1943
1944 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
1800 $self->enter_map ($map, $x, $y); 1945 $self->enter_map ($map, $x, $y);
1801} 1946}
1802 1947
1803cf::player->attach (
1804 on_logout => sub {
1805 my ($pl) = @_;
1806
1807 # abort map switching before logout
1808 if ($pl->ob->{_link_pos}) {
1809 cf::sync_job {
1810 $pl->ob->leave_link
1811 };
1812 }
1813 },
1814 on_login => sub {
1815 my ($pl) = @_;
1816
1817 # try to abort aborted map switching on player login :)
1818 # should happen only on crashes
1819 if ($pl->ob->{_link_pos}) {
1820 $pl->ob->enter_link;
1821 (async {
1822 # we need this sleep as the login has a concurrent enter_exit running
1823 # and this sleep increases chances of the player not ending up in scorn
1824 $pl->ob->reply (undef,
1825 "There was an internal problem at your last logout, "
1826 . "the server will try to bring you to your intended destination in a second.",
1827 cf::NDI_RED);
1828 Coro::Timer::sleep 1;
1829 $pl->ob->leave_link;
1830 })->prio (2);
1831 }
1832 },
1833);
1834
1835=item $player_object->goto ($path, $x, $y) 1948=item $player_object->goto ($path, $x, $y[, $check->($map)])
1836 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
1837=cut 1955=cut
1956
1957our $GOTOGEN;
1838 1958
1839sub cf::object::player::goto { 1959sub cf::object::player::goto {
1840 my ($self, $path, $x, $y) = @_; 1960 my ($self, $path, $x, $y, $check) = @_;
1841 1961
1842 $path = new cf::path $path; 1962 # do generation counting so two concurrent goto's will be executed in-order
1963 my $gen = $self->{_goto_generation} = ++$GOTOGEN;
1843 1964
1844 $self->enter_link; 1965 $self->enter_link;
1845 1966
1846 (async { 1967 (async {
1968 my $map = eval {
1847 my $map = cf::map::find $path->as_string; 1969 my $map = cf::map::find $path;
1970
1971 if ($map) {
1848 $map = $map->customise_for ($self) if $map; 1972 $map = $map->customise_for ($self);
1849 1973 $map = $check->($map) if $check && $map;
1850# warn "entering ", $map->path, " at ($x, $y)\n" 1974 } else {
1851# if $map;
1852
1853 $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 }
1854 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};
1855 $self->leave_link ($map, $x, $y); 1988 $self->leave_link ($map, $x, $y);
1989 }
1856 })->prio (1); 1990 })->prio (1);
1857} 1991}
1858 1992
1859=item $player_object->enter_exit ($exit_object) 1993=item $player_object->enter_exit ($exit_object)
1860 1994
… …
1862 1996
1863sub parse_random_map_params { 1997sub parse_random_map_params {
1864 my ($spec) = @_; 1998 my ($spec) = @_;
1865 1999
1866 my $rmp = { # defaults 2000 my $rmp = { # defaults
1867 xsize => 10, 2001 xsize => (cf::rndm 15, 40),
1868 ysize => 10, 2002 ysize => (cf::rndm 15, 40),
2003 symmetry => (cf::rndm 1, cf::SYMMETRY_XY),
2004 #layout => string,
1869 }; 2005 };
1870 2006
1871 for (split /\n/, $spec) { 2007 for (split /\n/, $spec) {
1872 my ($k, $v) = split /\s+/, $_, 2; 2008 my ($k, $v) = split /\s+/, $_, 2;
1873 2009
… …
1877 $rmp 2013 $rmp
1878} 2014}
1879 2015
1880sub prepare_random_map { 2016sub prepare_random_map {
1881 my ($exit) = @_; 2017 my ($exit) = @_;
2018
2019 my $guard = cf::lock_acquire "exit_prepare:$exit";
1882 2020
1883 # all this does is basically replace the /! path by 2021 # all this does is basically replace the /! path by
1884 # a new random map path (?random/...) with a seed 2022 # a new random map path (?random/...) with a seed
1885 # that depends on the exit object 2023 # that depends on the exit object
1886 2024
1887 my $rmp = parse_random_map_params $exit->msg; 2025 my $rmp = parse_random_map_params $exit->msg;
1888 2026
1889 if ($exit->map) { 2027 if ($exit->map) {
1890 $rmp->{region} = $exit->map->region_name; 2028 $rmp->{region} = $exit->region->name;
1891 $rmp->{origin_map} = $exit->map->path; 2029 $rmp->{origin_map} = $exit->map->path;
1892 $rmp->{origin_x} = $exit->x; 2030 $rmp->{origin_x} = $exit->x;
1893 $rmp->{origin_y} = $exit->y; 2031 $rmp->{origin_y} = $exit->y;
1894 } 2032 }
1895 2033
1896 $rmp->{random_seed} ||= $exit->random_seed; 2034 $rmp->{random_seed} ||= $exit->random_seed;
1897 2035
1898 my $data = cf::to_json $rmp; 2036 my $data = cf::to_json $rmp;
1899 my $md5 = Digest::MD5::md5_hex $data; 2037 my $md5 = Digest::MD5::md5_hex $data;
2038 my $meta = "$RANDOMDIR/$md5.meta";
1900 2039
1901 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) {
1902 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;
1903 2044
1904 $exit->slaying ("?random/$md5"); 2045 $exit->slaying ("?random/$md5");
1905 $exit->msg (undef); 2046 $exit->msg (undef);
1906 } 2047 }
1907} 2048}
1908 2049
1909sub cf::object::player::enter_exit { 2050sub cf::object::player::enter_exit {
1910 my ($self, $exit) = @_; 2051 my ($self, $exit) = @_;
1911 2052
1912 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;
1913 2065
1914 $self->enter_link; 2066 $self->enter_link;
1915 2067
1916 (async { 2068 (async {
1917 $self->deactivate_recursive; # just to be sure 2069 $self->deactivate_recursive; # just to be sure
1918 unless (eval { 2070 unless (eval {
1919 prepare_random_map $exit 2071 $self->goto ($slaying, $hp, $sp);
1920 if $exit->slaying eq "/!";
1921
1922 my $path = new cf::path $exit->slaying, $exit->map && $exit->map->path;
1923 $self->goto ($path, $exit->stats->hp, $exit->stats->sp);
1924 2072
1925 1; 2073 1;
1926 }) { 2074 }) {
1927 $self->message ("Something went wrong deep within the crossfire server. " 2075 $self->message ("Something went wrong deep within the crossfire server. "
1928 . "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. "
1929 . "Please report this to the dungeon master!", 2077 . "Please report this to the dungeon master!",
1930 cf::NDI_UNIQUE | cf::NDI_RED); 2078 cf::NDI_UNIQUE | cf::NDI_RED);
1931 2079
1932 warn "ERROR in enter_exit: $@"; 2080 warn "ERROR in enter_exit: $@";
1933 $self->leave_link; 2081 $self->leave_link;
1934 } 2082 }
1935 })->prio (1); 2083 })->prio (1);
… …
1948 2096
1949sub cf::client::send_drawinfo { 2097sub cf::client::send_drawinfo {
1950 my ($self, $text, $flags) = @_; 2098 my ($self, $text, $flags) = @_;
1951 2099
1952 utf8::encode $text; 2100 utf8::encode $text;
1953 $self->send_packet (sprintf "drawinfo %d %s", $flags, $text); 2101 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);
1954} 2102}
1955 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}
1956 2116
1957=item $success = $client->query ($flags, "text", \&cb) 2117=item $success = $client->query ($flags, "text", \&cb)
1958 2118
1959Queues a query to the client, calling the given callback with 2119Queues a query to the client, calling the given callback with
1960the 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>,
… …
1989 # get handled first 2149 # get handled first
1990 my $queue = delete $ns->{query_queue} 2150 my $queue = delete $ns->{query_queue}
1991 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
1992 2152
1993 (shift @$queue)->[1]->($msg); 2153 (shift @$queue)->[1]->($msg);
2154 return unless $ns->valid; # temporary(?) workaround for callback destroying socket
1994 2155
1995 push @{ $ns->{query_queue} }, @$queue; 2156 push @{ $ns->{query_queue} }, @$queue;
1996 2157
1997 if (@{ $ns->{query_queue} } == @$queue) { 2158 if (@{ $ns->{query_queue} } == @$queue) {
1998 if (@$queue) { 2159 if (@$queue) {
… …
2056 2217
2057# here we export the classes and methods available to script code 2218# here we export the classes and methods available to script code
2058 2219
2059=pod 2220=pod
2060 2221
2061The following fucntions and emthods are available within a safe environment: 2222The following functions and methods are available within a safe environment:
2062 2223
2063 cf::object contr pay_amount pay_player map 2224 cf::object contr pay_amount pay_player map
2064 cf::object::player player 2225 cf::object::player player
2065 cf::player peaceful 2226 cf::player peaceful
2066 cf::map trigger 2227 cf::map trigger
… …
2151############################################################################# 2312#############################################################################
2152 2313
2153=head2 EXTENSION DATABASE SUPPORT 2314=head2 EXTENSION DATABASE SUPPORT
2154 2315
2155Crossfire maintains a very simple database for extension use. It can 2316Crossfire maintains a very simple database for extension use. It can
2156currently store anything that can be serialised using Storable, which 2317currently store binary data only (use Compress::LZF::sfreeze_cr/sthaw to
2157excludes objects. 2318convert to/from binary).
2158 2319
2159The 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
2160using it, it should be unique. 2321using it, it should be unique.
2161 2322
2162=over 4 2323=over 4
2163 2324
2164=item $hashref = cf::db_get $family
2165
2166Return a hashref for use by the extension C<$family>, which can be
2167modified. After modifications, you have to call C<cf::db_dirty> or
2168C<cf::db_sync>.
2169
2170=item $value = cf::db_get $family => $key 2325=item $value = cf::db_get $family => $key
2171 2326
2172Returns a single value from the database 2327Returns a single value from the database.
2173
2174=item cf::db_put $family => $hashref
2175
2176Stores the given family hashref into the database. Updates are delayed, if
2177you want the data to be synced to disk immediately, use C<cf::db_sync>.
2178 2328
2179=item cf::db_put $family => $key => $value 2329=item cf::db_put $family => $key => $value
2180 2330
2181Stores the given C<$value> in the family hash. Updates are delayed, if you 2331Stores the given C<$value> in the family.
2182want the data to be synced to disk immediately, use C<cf::db_sync>.
2183
2184=item cf::db_dirty
2185
2186Marks the database as dirty, to be updated at a later time.
2187
2188=item cf::db_sync
2189
2190Immediately write the database to disk I<if it is dirty>.
2191 2332
2192=cut 2333=cut
2193 2334
2194our $DB; 2335our $DB;
2195 2336
2196{ 2337sub db_init {
2197 my $path = cf::localdir . "/database.pst"; 2338 unless ($DB) {
2339 $DB = BDB::db_create $DB_ENV;
2198 2340
2199 sub db_load() { 2341 cf::sync_job {
2200 $DB = stat $path ? Storable::retrieve $path : { }; 2342 eval {
2201 } 2343 $DB->set_flags (BDB::CHKSUM);
2202 2344
2203 my $pid; 2345 BDB::db_open $DB, undef, "db", undef, BDB::BTREE,
2204 2346 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
2205 sub db_save() { 2347 cf::cleanup "db_open(db): $!" if $!;
2206 waitpid $pid, 0 if $pid; 2348 };
2207 if (0 == ($pid = fork)) { 2349 cf::cleanup "db_open(db): $@" if $@;
2208 $DB->{_meta}{version} = 1;
2209 Storable::nstore $DB, "$path~";
2210 rename "$path~", $path;
2211 cf::_exit 0 if defined $pid;
2212 } 2350 };
2213 }
2214
2215 my $dirty;
2216
2217 sub db_sync() {
2218 db_save if $dirty;
2219 undef $dirty;
2220 }
2221
2222 my $idle = Event->idle (min => $TICK * 2.8, max => 10, repeat => 0, data => WF_AUTOCANCEL, cb => sub {
2223 db_sync;
2224 }); 2351 }
2352}
2225 2353
2226 sub db_dirty() {
2227 $dirty = 1;
2228 $idle->start;
2229 }
2230
2231 sub db_get($;$) { 2354sub db_get($$) {
2232 @_ >= 2 2355 my $key = "$_[0]/$_[1]";
2233 ? $DB->{$_[0]}{$_[1]}
2234 : ($DB->{$_[0]} ||= { })
2235 }
2236 2356
2357 cf::sync_job {
2358 BDB::db_get $DB, undef, $key, my $data;
2359
2360 $! ? ()
2361 : $data
2362 }
2363}
2364
2237 sub db_put($$;$) { 2365sub db_put($$$) {
2238 if (@_ >= 3) { 2366 BDB::dbreq_pri 4;
2239 $DB->{$_[0]}{$_[1]} = $_[2]; 2367 BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { };
2240 } else { 2368}
2241 $DB->{$_[0]} = $_[1];
2242 }
2243 db_dirty;
2244 }
2245 2369
2246 cf::global->attach ( 2370=item cf::cache $id => [$paths...], $processversion => $process
2247 prio => 10000, 2371
2248 on_cleanup => sub { 2372Generic caching function that returns the value of the resource $id,
2249 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->[$_]: $!";
2250 }, 2402 }
2251 ); 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 }
2252} 2482}
2253 2483
2254############################################################################# 2484#############################################################################
2255# 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 cf::face::set $idx, $info->{visibility}, $info->{magicmap};
2507 cf::face::set_data $idx, 0, $info->{data32}, $info->{chksum32};
2508 cf::face::set_data $idx, 1, $info->{data64}, $info->{chksum64};
2509 Coro::cede;
2510 }
2511
2512 while (my ($face, $info) = each %$faces) {
2513 next unless $info->{smooth};
2514 my $idx = cf::face::find $face
2515 or next;
2516 if (my $smooth = cf::face::find $info->{smooth}) {
2517 cf::face::set_smooth $idx, $smooth, $info->{smoothlevel};
2518 } else {
2519 warn "smooth face '$info->{smooth}' not found for face '$face'";
2520 }
2521 Coro::cede;
2522 }
2523 }
2524
2525 {
2526 my $anims = $facedata->{animinfo};
2527
2528 while (my ($anim, $info) = each %$anims) {
2529 cf::anim::set $anim, $info->{frames}, $info->{facings};
2530 Coro::cede;
2531 }
2532
2533 cf::anim::invalidate_all; # d'oh
2534 }
2535
2536 1
2537}
2538
2539sub reload_regions {
2540 load_resource_file "$MAPDIR/regions"
2541 or die "unable to load regions file\n";
2542}
2543
2544sub reload_facedata {
2545 load_facedata "$DATADIR/facedata"
2546 or die "unable to load facedata\n";
2547}
2548
2549sub reload_archetypes {
2550 load_resource_file "$DATADIR/archetypes"
2551 or die "unable to load archetypes\n";
2552}
2553
2554sub reload_treasures {
2555 load_resource_file "$DATADIR/treasures"
2556 or die "unable to load treasurelists\n";
2557}
2558
2559sub reload_resources {
2560 warn "reloading resource files...\n";
2561
2562 reload_regions;
2563 reload_facedata;
2564 reload_archetypes;
2565 reload_treasures;
2566
2567 warn "finished reloading resource files\n";
2568}
2569
2570sub init {
2571 reload_resources;
2572}
2256 2573
2257sub cfg_load { 2574sub cfg_load {
2258 open my $fh, "<:utf8", cf::confdir . "/config" 2575 open my $fh, "<:utf8", "$CONFDIR/config"
2259 or return; 2576 or return;
2260 2577
2261 local $/; 2578 local $/;
2262 *CFG = YAML::Syck::Load <$fh>; 2579 *CFG = YAML::Syck::Load <$fh>;
2263 2580
… …
2277 2594
2278sub main { 2595sub main {
2279 # we must not ever block the main coroutine 2596 # we must not ever block the main coroutine
2280 local $Coro::idle = sub { 2597 local $Coro::idle = sub {
2281 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d# 2598 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
2599 (async {
2282 async { Event::one_event }; 2600 Event::one_event;
2601 })->prio (Coro::PRIO_MAX);
2283 }; 2602 };
2284 2603
2285 cfg_load; 2604 cfg_load;
2286 db_load; 2605 db_init;
2287 load_extensions; 2606 load_extensions;
2607
2608 $TICK_WATCHER->start;
2288 Event::loop; 2609 Event::loop;
2289} 2610}
2290 2611
2291############################################################################# 2612#############################################################################
2292# initialisation and cleanup 2613# initialisation and cleanup
2293 2614
2294# install some emergency cleanup handlers 2615# install some emergency cleanup handlers
2295BEGIN { 2616BEGIN {
2296 for my $signal (qw(INT HUP TERM)) { 2617 for my $signal (qw(INT HUP TERM)) {
2297 Event->signal ( 2618 Event->signal (
2619 reentrant => 0,
2298 data => WF_AUTOCANCEL, 2620 data => WF_AUTOCANCEL,
2299 signal => $signal, 2621 signal => $signal,
2622 prio => 0,
2300 cb => sub { 2623 cb => sub {
2301 cf::cleanup "SIG$signal"; 2624 cf::cleanup "SIG$signal";
2302 }, 2625 },
2303 ); 2626 );
2304 } 2627 }
2305} 2628}
… …
2310 warn "enter emergency perl save\n"; 2633 warn "enter emergency perl save\n";
2311 2634
2312 cf::sync_job { 2635 cf::sync_job {
2313 # use a peculiar iteration method to avoid tripping on perl 2636 # use a peculiar iteration method to avoid tripping on perl
2314 # refcount bugs in for. also avoids problems with players 2637 # refcount bugs in for. also avoids problems with players
2315 # and maps saved/Destroyed asynchronously. 2638 # and maps saved/destroyed asynchronously.
2316 warn "begin emergency player save\n"; 2639 warn "begin emergency player save\n";
2317 for my $login (keys %cf::PLAYER) { 2640 for my $login (keys %cf::PLAYER) {
2318 my $pl = $cf::PLAYER{$login} or next; 2641 my $pl = $cf::PLAYER{$login} or next;
2319 $pl->valid or next; 2642 $pl->valid or next;
2320 $pl->save; 2643 $pl->save;
… …
2326 my $map = $cf::MAP{$path} or next; 2649 my $map = $cf::MAP{$path} or next;
2327 $map->valid or next; 2650 $map->valid or next;
2328 $map->save; 2651 $map->save;
2329 } 2652 }
2330 warn "end emergency map save\n"; 2653 warn "end emergency map save\n";
2654
2655 warn "begin emergency database checkpoint\n";
2656 BDB::db_env_txn_checkpoint $DB_ENV;
2657 warn "end emergency database checkpoint\n";
2331 }; 2658 };
2332 2659
2333 warn "leave emergency perl save\n"; 2660 warn "leave emergency perl save\n";
2334} 2661}
2335 2662
2663sub post_cleanup {
2664 my ($make_core) = @_;
2665
2666 warn Carp::longmess "post_cleanup backtrace"
2667 if $make_core;
2668}
2669
2336sub reload() { 2670sub do_reload_perl() {
2337 # can/must only be called in main 2671 # can/must only be called in main
2338 if ($Coro::current != $Coro::main) { 2672 if ($Coro::current != $Coro::main) {
2339 warn "can only reload from main coroutine\n"; 2673 warn "can only reload from main coroutine";
2340 return; 2674 return;
2341 } 2675 }
2342 2676
2343 warn "reloading..."; 2677 warn "reloading...";
2344 2678
2345 my $guard = freeze_mainloop; 2679 warn "entering sync_job";
2680
2681 cf::sync_job {
2682 cf::write_runtime; # external watchdog should not bark
2346 cf::emergency_save; 2683 cf::emergency_save;
2684 cf::write_runtime; # external watchdog should not bark
2347 2685
2348 eval { 2686 warn "syncing database to disk";
2687 BDB::db_env_txn_checkpoint $DB_ENV;
2688
2349 # if anything goes wrong in here, we should simply crash as we already saved 2689 # if anything goes wrong in here, we should simply crash as we already saved
2350 2690
2351 # cancel all watchers 2691 warn "cancelling all WF_AUTOCANCEL watchers";
2352 for (Event::all_watchers) { 2692 for (Event::all_watchers) {
2353 $_->cancel if $_->data & WF_AUTOCANCEL; 2693 $_->cancel if $_->data & WF_AUTOCANCEL;
2354 } 2694 }
2355 2695
2696 warn "flushing outstanding aio requests";
2697 for (;;) {
2698 BDB::flush;
2699 IO::AIO::flush;
2700 Coro::cede;
2701 last unless IO::AIO::nreqs || BDB::nreqs;
2702 warn "iterate...";
2703 }
2704
2705 ++$RELOAD;
2706
2356 # cancel all extension coros 2707 warn "cancelling all extension coros";
2357 $_->cancel for values %EXT_CORO; 2708 $_->cancel for values %EXT_CORO;
2358 %EXT_CORO = (); 2709 %EXT_CORO = ();
2359 2710
2360 # unload all extensions 2711 warn "removing commands";
2361 for (@exts) { 2712 %COMMAND = ();
2713
2714 warn "removing ext commands";
2715 %EXTCMD = ();
2716
2717 warn "unloading/nuking all extensions";
2718 for my $pkg (@EXTS) {
2362 warn "unloading <$_>"; 2719 warn "... unloading $pkg";
2363 unload_extension $_; 2720
2721 if (my $cb = $pkg->can ("unload")) {
2722 eval {
2723 $cb->($pkg);
2724 1
2725 } or warn "$pkg unloaded, but with errors: $@";
2364 } 2726 }
2365 2727
2728 warn "... nuking $pkg";
2729 Symbol::delete_package $pkg;
2730 }
2731
2366 # unload all modules loaded from $LIBDIR 2732 warn "unloading all perl modules loaded from $LIBDIR";
2367 while (my ($k, $v) = each %INC) { 2733 while (my ($k, $v) = each %INC) {
2368 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/; 2734 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
2369 2735
2370 warn "removing <$k>"; 2736 warn "... unloading $k";
2371 delete $INC{$k}; 2737 delete $INC{$k};
2372 2738
2373 $k =~ s/\.pm$//; 2739 $k =~ s/\.pm$//;
2374 $k =~ s/\//::/g; 2740 $k =~ s/\//::/g;
2375 2741
… …
2378 } 2744 }
2379 2745
2380 Symbol::delete_package $k; 2746 Symbol::delete_package $k;
2381 } 2747 }
2382 2748
2383 # sync database to disk
2384 cf::db_sync;
2385 IO::AIO::flush;
2386
2387 # get rid of safe::, as good as possible 2749 warn "getting rid of safe::, as good as possible";
2388 Symbol::delete_package "safe::$_" 2750 Symbol::delete_package "safe::$_"
2389 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region); 2751 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
2390 2752
2391 # remove register_script_function callbacks
2392 # TODO
2393
2394 # unload cf.pm "a bit" 2753 warn "unloading cf.pm \"a bit\"";
2395 delete $INC{"cf.pm"}; 2754 delete $INC{"cf.pm"};
2755 delete $INC{"cf/pod.pm"};
2396 2756
2397 # don't, removes xs symbols, too, 2757 # don't, removes xs symbols, too,
2398 # and global variables created in xs 2758 # and global variables created in xs
2399 #Symbol::delete_package __PACKAGE__; 2759 #Symbol::delete_package __PACKAGE__;
2400 2760
2401 # reload cf.pm 2761 warn "unload completed, starting to reload now";
2762
2402 warn "reloading cf.pm"; 2763 warn "reloading cf.pm";
2403 require cf; 2764 require cf;
2404 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 2765 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
2405 2766
2406 # load config and database again 2767 warn "loading config and database again";
2407 cf::cfg_load; 2768 cf::cfg_load;
2408 cf::db_load;
2409 2769
2410 # load extensions
2411 warn "load extensions"; 2770 warn "loading extensions";
2412 cf::load_extensions; 2771 cf::load_extensions;
2413 2772
2414 # reattach attachments to objects 2773 warn "reattaching attachments to objects/players";
2415 warn "reattach"; 2774 _global_reattach; # objects, sockets
2416 _global_reattach; 2775 warn "reattaching attachments to maps";
2417 reattach $_ for values %MAP; 2776 reattach $_ for values %MAP;
2418 }; 2777 warn "reattaching attachments to players";
2778 reattach $_ for values %PLAYER;
2419 2779
2420 if ($@) { 2780 warn "leaving sync_job";
2781
2782 1
2783 } or do {
2421 warn $@; 2784 warn $@;
2422 warn "error while reloading, exiting."; 2785 warn "error while reloading, exiting.";
2423 exit 1; 2786 exit 1;
2424 } 2787 };
2425 2788
2426 warn "reloaded successfully"; 2789 warn "reloaded";
2427}; 2790};
2428 2791
2429############################################################################# 2792our $RELOAD_WATCHER; # used only during reload
2430 2793
2431unless ($LINK_MAP) { 2794sub reload_perl() {
2432 $LINK_MAP = cf::map::new; 2795 # doing reload synchronously and two reloads happen back-to-back,
2796 # coro crashes during coro_state_free->destroy here.
2433 2797
2434 $LINK_MAP->width (41); 2798 $RELOAD_WATCHER ||= Event->timer (
2435 $LINK_MAP->height (41); 2799 reentrant => 0,
2436 $LINK_MAP->alloc;
2437 $LINK_MAP->path ("{link}");
2438 $LINK_MAP->{path} = bless { path => "{link}" }, "cf::path";
2439 $LINK_MAP->in_memory (MAP_IN_MEMORY);
2440
2441 # dirty hack because... archetypes are not yet loaded
2442 Event->timer (
2443 after => 10, 2800 after => 0,
2801 data => WF_AUTOCANCEL,
2444 cb => sub { 2802 cb => sub {
2445 $_[0]->w->cancel; 2803 do_reload_perl;
2446 2804 undef $RELOAD_WATCHER;
2447 # provide some exits "home"
2448 my $exit = cf::object::new "exit";
2449
2450 $exit->slaying ($EMERGENCY_POSITION->[0]);
2451 $exit->stats->hp ($EMERGENCY_POSITION->[1]);
2452 $exit->stats->sp ($EMERGENCY_POSITION->[2]);
2453
2454 $LINK_MAP->insert ($exit->clone, 19, 19);
2455 $LINK_MAP->insert ($exit->clone, 19, 20);
2456 $LINK_MAP->insert ($exit->clone, 19, 21);
2457 $LINK_MAP->insert ($exit->clone, 20, 19);
2458 $LINK_MAP->insert ($exit->clone, 20, 21);
2459 $LINK_MAP->insert ($exit->clone, 21, 19);
2460 $LINK_MAP->insert ($exit->clone, 21, 20);
2461 $LINK_MAP->insert ($exit->clone, 21, 21);
2462
2463 $exit->destroy;
2464 }); 2805 },
2465 2806 );
2466 $LINK_MAP->{deny_save} = 1;
2467 $LINK_MAP->{deny_reset} = 1;
2468
2469 $cf::MAP{$LINK_MAP->path} = $LINK_MAP;
2470} 2807}
2471
2472register "<global>", __PACKAGE__;
2473 2808
2474register_command "reload" => sub { 2809register_command "reload" => sub {
2475 my ($who, $arg) = @_; 2810 my ($who, $arg) = @_;
2476 2811
2477 if ($who->flag (FLAG_WIZ)) { 2812 if ($who->flag (FLAG_WIZ)) {
2478 $who->message ("start of reload.");
2479 reload;
2480 $who->message ("end of reload."); 2813 $who->message ("reloading server.");
2814 async { reload_perl };
2481 } 2815 }
2482}; 2816};
2483 2817
2484unshift @INC, $LIBDIR; 2818unshift @INC, $LIBDIR;
2485 2819
2820my $bug_warning = 0;
2821
2822our @WAIT_FOR_TICK;
2823our @WAIT_FOR_TICK_BEGIN;
2824
2825sub wait_for_tick {
2826 return unless $TICK_WATCHER->is_active;
2827 return if $Coro::current == $Coro::main;
2828
2829 my $signal = new Coro::Signal;
2830 push @WAIT_FOR_TICK, $signal;
2831 $signal->wait;
2832}
2833
2834sub wait_for_tick_begin {
2835 return unless $TICK_WATCHER->is_active;
2836 return if $Coro::current == $Coro::main;
2837
2838 my $signal = new Coro::Signal;
2839 push @WAIT_FOR_TICK_BEGIN, $signal;
2840 $signal->wait;
2841}
2842
2843 my $min = 1e6;#d#
2844 my $avg = 10;
2486$TICK_WATCHER = Event->timer ( 2845$TICK_WATCHER = Event->timer (
2487 reentrant => 0, 2846 reentrant => 0,
2847 parked => 1,
2488 prio => 0, 2848 prio => 0,
2489 at => $NEXT_TICK || $TICK, 2849 at => $NEXT_TICK || $TICK,
2490 data => WF_AUTOCANCEL, 2850 data => WF_AUTOCANCEL,
2491 cb => sub { 2851 cb => sub {
2852 if ($Coro::current != $Coro::main) {
2853 Carp::cluck "major BUG: server tick called outside of main coro, skipping it"
2854 unless ++$bug_warning > 10;
2855 return;
2856 }
2857
2858 $NOW = $tick_start = Event::time;
2859
2492 cf::server_tick; # one server iteration 2860 cf::server_tick; # one server iteration
2861
2862 0 && sync_job {#d#
2863 for(1..10) {
2864 my $t = Event::time;
2865 my $map = my $map = new_from_path cf::map "/tmp/x.map"
2866 or die;
2867
2868 $map->width (50);
2869 $map->height (50);
2870 $map->alloc;
2871 $map->_load_objects ("/tmp/x.map", 1);
2872 my $t = Event::time - $t;
2873
2874 #next unless $t < 0.0013;#d#
2875 if ($t < $min) {
2876 $min = $t;
2877 }
2878 $avg = $avg * 0.99 + $t * 0.01;
2879 }
2880 warn "XXXXXXXXXXXXXXXXXX min $min avg $avg\n";#d#
2881 exit 0;
2882 # 2007-05-22 02:33:04.569 min 0.00112509727478027 avg 0.0012259249572477
2883 };
2884
2493 $RUNTIME += $TICK; 2885 $RUNTIME += $TICK;
2494 $NEXT_TICK += $TICK; 2886 $NEXT_TICK += $TICK;
2495 2887
2496 $WAIT_FOR_TICK->broadcast; 2888 if ($NOW >= $NEXT_RUNTIME_WRITE) {
2497 $WAIT_FOR_TICK_ONE->send if $WAIT_FOR_TICK_ONE->awaited; 2889 $NEXT_RUNTIME_WRITE = $NOW + 10;
2890 Coro::async_pool {
2891 write_runtime
2892 or warn "ERROR: unable to write runtime file: $!";
2893 };
2894 }
2895
2896# my $AFTER = Event::time;
2897# warn $AFTER - $NOW;#d#
2898
2899 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
2900 $sig->send;
2901 }
2902 while (my $sig = shift @WAIT_FOR_TICK) {
2903 $sig->send;
2904 }
2905
2906 $NOW = Event::time;
2498 2907
2499 # if we are delayed by four ticks or more, skip them all 2908 # if we are delayed by four ticks or more, skip them all
2500 $NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4; 2909 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
2501 2910
2502 $TICK_WATCHER->at ($NEXT_TICK); 2911 $TICK_WATCHER->at ($NEXT_TICK);
2503 $TICK_WATCHER->start; 2912 $TICK_WATCHER->start;
2913
2914 $LOAD = ($NOW - $tick_start) / $TICK;
2915 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
2916
2917 _post_tick;
2918
2919
2504 }, 2920 },
2505); 2921);
2506 2922
2923{
2507IO::AIO::max_poll_time $TICK * 0.2; 2924 BDB::max_poll_time $TICK * 0.1;
2508 2925 $BDB_POLL_WATCHER = Event->io (
2509Event->io ( 2926 reentrant => 0,
2510 fd => IO::AIO::poll_fileno, 2927 fd => BDB::poll_fileno,
2511 poll => 'r', 2928 poll => 'r',
2512 prio => 5, 2929 prio => 0,
2513 data => WF_AUTOCANCEL,
2514 cb => \&IO::AIO::poll_cb,
2515);
2516
2517Event->timer (
2518 data => WF_AUTOCANCEL, 2930 data => WF_AUTOCANCEL,
2519 after => 0, 2931 cb => \&BDB::poll_cb,
2520 interval => 10, 2932 );
2521 cb => sub { 2933 BDB::min_parallel 8;
2522 (Coro::unblock_sub { 2934
2523 write_runtime 2935 BDB::set_sync_prepare {
2524 or warn "ERROR: unable to write runtime file: $!"; 2936 my $status;
2937 my $current = $Coro::current;
2938 (
2939 sub {
2940 $status = $!;
2941 $current->ready; undef $current;
2942 },
2943 sub {
2944 Coro::schedule while defined $current;
2945 $! = $status;
2946 },
2947 )
2948 };
2949
2950 unless ($DB_ENV) {
2951 $DB_ENV = BDB::db_env_create;
2952
2953 cf::sync_job {
2954 eval {
2955 BDB::db_env_open
2956 $DB_ENV,
2957 $BDBDIR,
2958 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN
2959 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE,
2960 0666;
2961
2962 cf::cleanup "db_env_open($BDBDIR): $!" if $!;
2963
2964 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC, 1);
2965 $DB_ENV->set_lk_detect;
2966 };
2967
2968 cf::cleanup "db_env_open(db): $@" if $@;
2525 })->(); 2969 };
2526 }, 2970 }
2527); 2971}
2972
2973{
2974 IO::AIO::min_parallel 8;
2975
2976 undef $Coro::AIO::WATCHER;
2977 IO::AIO::max_poll_time $TICK * 0.1;
2978 $AIO_POLL_WATCHER = Event->io (
2979 reentrant => 0,
2980 data => WF_AUTOCANCEL,
2981 fd => IO::AIO::poll_fileno,
2982 poll => 'r',
2983 prio => 6,
2984 cb => \&IO::AIO::poll_cb,
2985 );
2986}
2987
2988my $_log_backtrace;
2989
2990sub _log_backtrace {
2991 my ($msg, @addr) = @_;
2992
2993 $msg =~ s/\n//;
2994
2995 # limit the # of concurrent backtraces
2996 if ($_log_backtrace < 2) {
2997 ++$_log_backtrace;
2998 async {
2999 my @bt = fork_call {
3000 @addr = map { sprintf "%x", $_ } @addr;
3001 my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X;
3002 open my $fh, "exec addr2line -C -f -i -e \Q$self\E @addr 2>&1 |"
3003 or die "addr2line: $!";
3004
3005 my @funcs;
3006 my @res = <$fh>;
3007 chomp for @res;
3008 while (@res) {
3009 my ($func, $line) = splice @res, 0, 2, ();
3010 push @funcs, "[$func] $line";
3011 }
3012
3013 @funcs
3014 };
3015
3016 LOG llevInfo, "[ABT] $msg\n";
3017 LOG llevInfo, "[ABT] $_\n" for @bt;
3018 --$_log_backtrace;
3019 };
3020 } else {
3021 LOG llevInfo, "[ABT] $msg\n";
3022 LOG llevInfo, "[ABT] [suppressed]\n";
3023 }
3024}
3025
3026# load additional modules
3027use cf::pod;
2528 3028
2529END { cf::emergency_save } 3029END { cf::emergency_save }
2530 3030
25311 30311
2532 3032

Diff Legend

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