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

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines