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.157 by root, Wed Jan 10 01:16:54 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
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';
139@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable'; 188@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';
140@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable'; 189@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable';
141@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable'; 190@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable';
142@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';
143@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)
144 194
145# 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
146# within the Safe compartment. 196# within the Safe compartment.
147for my $pkg (qw( 197for my $pkg (qw(
148 cf::global cf::attachable 198 cf::global cf::attachable
156} 206}
157 207
158$Event::DIED = sub { 208$Event::DIED = sub {
159 warn "error in event callback: @_"; 209 warn "error in event callback: @_";
160}; 210};
161
162my %ext_pkg;
163my @exts;
164my @hook;
165 211
166=head2 UTILITY FUNCTIONS 212=head2 UTILITY FUNCTIONS
167 213
168=over 4 214=over 4
169 215
188 $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;
189 $d 235 $d
190 } || "[unable to dump $_[0]: '$@']"; 236 } || "[unable to dump $_[0]: '$@']";
191} 237}
192 238
193use JSON::Syck (); # TODO# replace by JSON::PC once working 239use JSON::XS qw(to_json from_json); # TODO# replace by JSON::PC once working
194 240
195=item $ref = cf::from_json $json 241=item $ref = cf::from_json $json
196 242
197Converts a JSON string into the corresponding perl data structure. 243Converts a JSON string into the corresponding perl data structure.
198 244
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 245=item $json = cf::to_json $ref
207 246
208Converts a perl data structure into its JSON representation. 247Converts 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 248
217=item cf::lock_wait $string 249=item cf::lock_wait $string
218 250
219Wait until the given lock is available. See cf::lock_acquire. 251Wait until the given lock is available. See cf::lock_acquire.
220 252
226returned. 258returned.
227 259
228Lock 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
229uses map_find and cf::map::load uses map_load). 261uses map_find and cf::map::load uses map_load).
230 262
263=item $locked = cf::lock_active $string
264
265Return true if the lock is currently active, i.e. somebody has locked it.
266
231=cut 267=cut
232 268
233our %LOCK; 269our %LOCK;
234 270
235sub lock_wait($) { 271sub lock_wait($) {
254 # wake up all waiters, to be on the safe side 290 # wake up all waiters, to be on the safe side
255 $_->ready for @{ delete $LOCK{$key} }; 291 $_->ready for @{ delete $LOCK{$key} };
256 } 292 }
257} 293}
258 294
295sub lock_active($) {
296 my ($key) = @_;
297
298 ! ! $LOCK{$key}
299}
300
259sub freeze_mainloop { 301sub freeze_mainloop {
260 return unless $TICK_WATCHER->is_active; 302 return unless $TICK_WATCHER->is_active;
261 303
262 my $guard = Coro::guard { $TICK_WATCHER->start }; 304 my $guard = Coro::guard {
305 $TICK_WATCHER->start;
306 };
263 $TICK_WATCHER->stop; 307 $TICK_WATCHER->stop;
264 $guard 308 $guard
265} 309}
266 310
267=item cf::async { BLOCK } 311=item cf::async { BLOCK }
289 333
290sub sync_job(&) { 334sub sync_job(&) {
291 my ($job) = @_; 335 my ($job) = @_;
292 336
293 if ($Coro::current == $Coro::main) { 337 if ($Coro::current == $Coro::main) {
338 my $time = Event::time;
339
294 # this is the main coro, too bad, we have to block 340 # this is the main coro, too bad, we have to block
295 # till the operation succeeds, freezing the server :/ 341 # till the operation succeeds, freezing the server :/
296 342
297 # TODO: use suspend/resume instead 343 # TODO: use suspend/resume instead
298 # (but this is cancel-safe) 344 # (but this is cancel-safe)
309 355
310 while ($busy) { 356 while ($busy) {
311 Coro::cede or Event::one_event; 357 Coro::cede or Event::one_event;
312 } 358 }
313 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
314 wantarray ? @res : $res[0] 367 wantarray ? @res : $res[0]
315 } else { 368 } else {
316 # we are in another coroutine, how wonderful, everything just works 369 # we are in another coroutine, how wonderful, everything just works
317 370
318 $job->() 371 $job->()
319 } 372 }
320} 373}
321 374
322=item $coro = cf::async_ext { BLOCK } 375=item $coro = cf::async_ext { BLOCK }
323 376
324Like async, but this coro is automcatially being canceled when the 377Like async, but this coro is automatically being canceled when the
325extension calling this is being unloaded. 378extension calling this is being unloaded.
326 379
327=cut 380=cut
328 381
329sub async_ext(&) { 382sub async_ext(&) {
338 391
339 $coro 392 $coro
340} 393}
341 394
342sub write_runtime { 395sub write_runtime {
343 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";
344 404
345 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644 405 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644
346 or return; 406 or return;
347 407
408 my $value = $cf::RUNTIME + 90 + 10;
348 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
349 (aio_write $fh, 0, (length $value), $value, 0) <= 0 412 (aio_write $fh, 0, (length $value), $value, 0) <= 0
350 and return; 413 and return;
351 414
415 # always fsync - this file is important
352 aio_fsync $fh 416 aio_fsync $fh
353 and return; 417 and return;
354 418
419 # touch it again to show we are up-to-date
420 aio_utime $fh, undef, undef;
421
355 close $fh 422 close $fh
356 or return; 423 or return;
357 424
358 aio_rename "$runtime~", $runtime 425 aio_rename "$runtime~", $runtime
359 and return; 426 and return;
360 427
428 warn "runtime file written.\n";
429
361 1 430 1
362} 431}
363 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
364=back 444=back
365 445
366=cut 446=cut
367
368#############################################################################
369
370package cf::path;
371
372# used to convert map paths into valid unix filenames by repalcing / by ∕
373our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons
374
375sub new {
376 my ($class, $path, $base) = @_;
377
378 $path = $path->as_string if ref $path;
379
380 my $self = bless { }, $class;
381
382 # {... are special paths that are not touched
383 # ?xxx/... are special absolute paths
384 # ?random/... random maps
385 # /! non-realised random map exit
386 # /... normal maps
387 # ~/... per-player maps without a specific player (DO NOT USE)
388 # ~user/... per-player map of a specific user
389
390 if ($path =~ /^{/) {
391 # fine as it is
392 } elsif ($path =~ s{^\?random/}{}) {
393 Coro::AIO::aio_load "$cf::RANDOM_MAPS/$path.meta", my $data;
394 $self->{random} = cf::from_json $data;
395 } else {
396 if ($path =~ s{^~([^/]+)?}{}) {
397 $self->{user_rel} = 1;
398
399 if (defined $1) {
400 $self->{user} = $1;
401 } elsif ($base =~ m{^~([^/]+)/}) {
402 $self->{user} = $1;
403 } else {
404 warn "cannot resolve user-relative path without user <$path,$base>\n";
405 }
406 } elsif ($path =~ /^\//) {
407 # already absolute
408 } else {
409 $base =~ s{[^/]+/?$}{};
410 return $class->new ("$base/$path");
411 }
412
413 for ($path) {
414 redo if s{/\.?/}{/};
415 redo if s{/[^/]+/\.\./}{/};
416 }
417 }
418
419 $self->{path} = $path;
420
421 $self
422}
423
424# the name / primary key / in-game path
425sub as_string {
426 my ($self) = @_;
427
428 $self->{user_rel} ? "~$self->{user}$self->{path}"
429 : $self->{random} ? "?random/$self->{path}"
430 : $self->{path}
431}
432
433# the displayed name, this is a one way mapping
434sub visible_name {
435 my ($self) = @_;
436
437# if (my $rmp = $self->{random}) {
438# # todo: be more intelligent about this
439# "?random/$rmp->{origin_map}+$rmp->{origin_x}+$rmp->{origin_y}/$rmp->{dungeon_level}"
440# } else {
441 $self->as_string
442# }
443}
444
445# escape the /'s in the path
446sub _escaped_path {
447 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g;
448 $path
449}
450
451# the original (read-only) location
452sub load_path {
453 my ($self) = @_;
454
455 sprintf "%s/%s/%s", cf::datadir, cf::mapdir, $self->{path}
456}
457
458# the temporary/swap location
459sub save_path {
460 my ($self) = @_;
461
462 $self->{user_rel} ? sprintf "%s/%s/%s/%s", cf::localdir, cf::playerdir, $self->{user}, $self->_escaped_path
463 : $self->{random} ? sprintf "%s/%s", $RANDOM_MAPS, $self->{path}
464 : sprintf "%s/%s/%s", cf::localdir, cf::tmpdir, $self->_escaped_path
465}
466
467# the unique path, might be eq to save_path
468sub uniq_path {
469 my ($self) = @_;
470
471 $self->{user_rel} || $self->{random}
472 ? undef
473 : sprintf "%s/%s/%s", cf::localdir, cf::uniquedir, $self->_escaped_path
474}
475
476# return random map parameters, or undef
477sub random_map_params {
478 my ($self) = @_;
479
480 $self->{random}
481}
482
483# this is somewhat ugly, but style maps do need special treatment
484sub is_style_map {
485 $_[0]{path} =~ m{^/styles/}
486}
487
488package cf;
489 447
490############################################################################# 448#############################################################################
491 449
492=head2 ATTACHABLE OBJECTS 450=head2 ATTACHABLE OBJECTS
493 451
619our @CB_TYPE = (); # registry for type (cf-object class) based events 577our @CB_TYPE = (); # registry for type (cf-object class) based events
620our @CB_MAP = (); 578our @CB_MAP = ();
621 579
622my %attachment; 580my %attachment;
623 581
582sub cf::attachable::thawer_merge {
583 # simply override everything except _meta
584 local $_[0]{_meta};
585 %{$_[0]} = %{$_[1]};
586}
587
624sub _attach_cb($$$$) { 588sub _attach_cb($$$$) {
625 my ($registry, $event, $prio, $cb) = @_; 589 my ($registry, $event, $prio, $cb) = @_;
626 590
627 use sort 'stable'; 591 use sort 'stable';
628 592
662 $registry = $CB_TYPE[$object_type] ||= []; 626 $registry = $CB_TYPE[$object_type] ||= [];
663 627
664 } elsif ($type eq "subtype") { 628 } elsif ($type eq "subtype") {
665 defined $object_type or Carp::croak "subtype specified without type"; 629 defined $object_type or Carp::croak "subtype specified without type";
666 my $object_subtype = shift @arg; 630 my $object_subtype = shift @arg;
667 $registry = $CB_TYPE[$object_type + $object_subtype * NUM_SUBTYPES] ||= []; 631 $registry = $CB_TYPE[$object_type + $object_subtype * NUM_TYPES] ||= [];
668 632
669 } elsif ($type eq "package") { 633 } elsif ($type eq "package") {
670 my $pkg = shift @arg; 634 my $pkg = shift @arg;
671 635
672 while (my ($name, $id) = each %cb_id) { 636 while (my ($name, $id) = each %cb_id) {
713 if (ref $_[0]) { 677 if (ref $_[0]) {
714 _object_attach @_; 678 _object_attach @_;
715 } else { 679 } else {
716 _attach shift->_attach_registry, @_; 680 _attach shift->_attach_registry, @_;
717 } 681 }
682 _recalc_want;
718}; 683};
719 684
720# all those should be optimised 685# all those should be optimised
721sub cf::attachable::detach { 686sub cf::attachable::detach {
722 my ($obj, $name) = @_; 687 my ($obj, $name) = @_;
725 delete $obj->{_attachment}{$name}; 690 delete $obj->{_attachment}{$name};
726 reattach ($obj); 691 reattach ($obj);
727 } else { 692 } else {
728 Carp::croak "cannot, currently, detach class attachments"; 693 Carp::croak "cannot, currently, detach class attachments";
729 } 694 }
695 _recalc_want;
730}; 696};
731 697
732sub cf::attachable::attached { 698sub cf::attachable::attached {
733 my ($obj, $name) = @_; 699 my ($obj, $name) = @_;
734 700
799# object support 765# object support
800 766
801sub reattach { 767sub reattach {
802 # basically do the same as instantiate, without calling instantiate 768 # basically do the same as instantiate, without calling instantiate
803 my ($obj) = @_; 769 my ($obj) = @_;
770
771 bless $obj, ref $obj; # re-bless in case extensions have been reloaded
804 772
805 my $registry = $obj->registry; 773 my $registry = $obj->registry;
806 774
807 @$registry = (); 775 @$registry = ();
808 776
855 $filename, length $$rdata, scalar @$objs; 823 $filename, length $$rdata, scalar @$objs;
856 824
857 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) { 825 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
858 chmod SAVE_MODE, $fh; 826 chmod SAVE_MODE, $fh;
859 aio_write $fh, 0, (length $$rdata), $$rdata, 0; 827 aio_write $fh, 0, (length $$rdata), $$rdata, 0;
860 aio_fsync $fh; 828 aio_fsync $fh if $cf::USE_FSYNC;
861 close $fh; 829 close $fh;
862 830
863 if (@$objs) { 831 if (@$objs) {
864 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) {
865 chmod SAVE_MODE, $fh; 833 chmod SAVE_MODE, $fh;
866 my $data = Storable::nfreeze { version => 1, objs => $objs }; 834 my $data = Storable::nfreeze { version => 1, objs => $objs };
867 aio_write $fh, 0, (length $data), $data, 0; 835 aio_write $fh, 0, (length $data), $data, 0;
868 aio_fsync $fh; 836 aio_fsync $fh if $cf::USE_FSYNC;
869 close $fh; 837 close $fh;
870 aio_rename "$filename.pst~", "$filename.pst"; 838 aio_rename "$filename.pst~", "$filename.pst";
871 } 839 }
872 } else { 840 } else {
873 aio_unlink "$filename.pst"; 841 aio_unlink "$filename.pst";
905 or return; 873 or return;
906 $av = eval { (Storable::thaw $av)->{objs} }; 874 $av = eval { (Storable::thaw $av)->{objs} };
907 } 875 }
908 876
909 warn sprintf "loading %s (%d)\n", 877 warn sprintf "loading %s (%d)\n",
910 $filename, length $data, scalar @{$av || []};#d# 878 $filename, length $data, scalar @{$av || []};
911 return ($data, $av); 879 return ($data, $av);
912} 880}
913 881
914############################################################################# 882#############################################################################
915# command handling &c 883# command handling &c
940=cut 908=cut
941 909
942sub register_extcmd { 910sub register_extcmd {
943 my ($name, $cb) = @_; 911 my ($name, $cb) = @_;
944 912
945 my $caller = caller;
946 #warn "registering extcmd '$name' to '$caller'";
947
948 $EXTCMD{$name} = [$cb, $caller]; 913 $EXTCMD{$name} = $cb;
949} 914}
950 915
951cf::player->attach ( 916cf::player->attach (
952 on_command => sub { 917 on_command => sub {
953 my ($pl, $name, $params) = @_; 918 my ($pl, $name, $params) = @_;
966 931
967 my $msg = eval { from_json $buf }; 932 my $msg = eval { from_json $buf };
968 933
969 if (ref $msg) { 934 if (ref $msg) {
970 if (my $cb = $EXTCMD{$msg->{msgtype}}) { 935 if (my $cb = $EXTCMD{$msg->{msgtype}}) {
971 if (my %reply = $cb->[0]->($pl, $msg)) { 936 if (my %reply = $cb->($pl, $msg)) {
972 $pl->ext_reply ($msg->{msgid}, %reply); 937 $pl->ext_reply ($msg->{msgid}, %reply);
973 } 938 }
974 } 939 }
975 } else { 940 } else {
976 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n"; 941 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
978 943
979 cf::override; 944 cf::override;
980 }, 945 },
981); 946);
982 947
983sub register {
984 my ($base, $pkg) = @_;
985
986 #TODO
987}
988
989sub load_extension { 948sub load_extension {
990 my ($path) = @_; 949 my ($path) = @_;
991 950
992 $path =~ /([^\/\\]+)\.ext$/ or die "$path"; 951 $path =~ /([^\/\\]+)\.ext$/ or die "$path";
993 my $base = $1; 952 my $base = $1;
994 my $pkg = $1; 953 my $pkg = $1;
995 $pkg =~ s/[^[:word:]]/_/g; 954 $pkg =~ s/[^[:word:]]/_/g;
996 $pkg = "ext::$pkg"; 955 $pkg = "ext::$pkg";
997 956
998 warn "loading '$path' into '$pkg'\n"; 957 warn "... loading '$path' into '$pkg'\n";
999 958
1000 open my $fh, "<:utf8", $path 959 open my $fh, "<:utf8", $path
1001 or die "$path: $!"; 960 or die "$path: $!";
1002 961
1003 my $source = 962 my $source =
1004 "package $pkg; use strict; use utf8;\n" 963 "package $pkg; use strict; use utf8;\n"
1005 . "#line 1 \"$path\"\n{\n" 964 . "#line 1 \"$path\"\n{\n"
1006 . (do { local $/; <$fh> }) 965 . (do { local $/; <$fh> })
1007 . "\n};\n1"; 966 . "\n};\n1";
1008 967
1009 eval $source 968 unless (eval $source) {
1010 or die $@ ? "$path: $@\n" 969 my $msg = $@ ? "$path: $@\n"
1011 : "extension disabled.\n"; 970 : "extension disabled.\n";
1012 971 if ($source =~ /^#!.*perl.*#.*MANDATORY/m) { # ugly match
1013 push @exts, $pkg; 972 warn $@;
1014 $ext_pkg{$base} = $pkg; 973 warn "mandatory extension failed to load, exiting.\n";
1015 974 exit 1;
1016# no strict 'refs'; 975 }
1017# @{"$pkg\::ISA"} = ext::; 976 die $@;
1018
1019 register $base, $pkg;
1020}
1021
1022sub unload_extension {
1023 my ($pkg) = @_;
1024
1025 warn "removing extension $pkg\n";
1026
1027 # remove hooks
1028 #TODO
1029# for my $idx (0 .. $#PLUGIN_EVENT) {
1030# delete $hook[$idx]{$pkg};
1031# } 977 }
1032 978
1033 # remove commands 979 push @EXTS, $pkg;
1034 for my $name (keys %COMMAND) {
1035 my @cb = grep $_->[0] ne $pkg, @{ $COMMAND{$name} };
1036
1037 if (@cb) {
1038 $COMMAND{$name} = \@cb;
1039 } else {
1040 delete $COMMAND{$name};
1041 }
1042 }
1043
1044 # remove extcmds
1045 for my $name (grep $EXTCMD{$_}[1] eq $pkg, keys %EXTCMD) {
1046 delete $EXTCMD{$name};
1047 }
1048
1049 if (my $cb = $pkg->can ("unload")) {
1050 eval {
1051 $cb->($pkg);
1052 1
1053 } or warn "$pkg unloaded, but with errors: $@";
1054 }
1055
1056 Symbol::delete_package $pkg;
1057} 980}
1058 981
1059sub load_extensions { 982sub load_extensions {
1060 for my $ext (<$LIBDIR/*.ext>) { 983 for my $ext (<$LIBDIR/*.ext>) {
1061 next unless -r $ext; 984 next unless -r $ext;
1065 } or warn "$ext not loaded: $@"; 988 } or warn "$ext not loaded: $@";
1066 } 989 }
1067} 990}
1068 991
1069############################################################################# 992#############################################################################
1070# load/save/clean perl data associated with a map
1071
1072*cf::mapsupport::on_clean = sub {
1073 my ($map) = @_;
1074
1075 my $path = $map->tmpname;
1076 defined $path or return;
1077
1078 unlink "$path.pst";
1079};
1080
1081cf::map->attach (prio => -10000, package => cf::mapsupport::);
1082
1083#############################################################################
1084 993
1085=head2 CORE EXTENSIONS 994=head2 CORE EXTENSIONS
1086 995
1087Functions and methods that extend core crossfire objects. 996Functions and methods that extend core crossfire objects.
1088 997
1101Returns the given player object, loading it if necessary (might block). 1010Returns the given player object, loading it if necessary (might block).
1102 1011
1103=cut 1012=cut
1104 1013
1105sub playerdir($) { 1014sub playerdir($) {
1106 cf::localdir 1015 "$PLAYERDIR/"
1107 . "/"
1108 . cf::playerdir
1109 . "/"
1110 . (ref $_[0] ? $_[0]->ob->name : $_[0]) 1016 . (ref $_[0] ? $_[0]->ob->name : $_[0])
1111} 1017}
1112 1018
1113sub path($) { 1019sub path($) {
1114 my $login = ref $_[0] ? $_[0]->ob->name : $_[0]; 1020 my $login = ref $_[0] ? $_[0]->ob->name : $_[0];
1115 1021
1116 (playerdir $login) . "/$login.pl" 1022 (playerdir $login) . "/playerdata"
1117} 1023}
1118 1024
1119sub find_active($) { 1025sub find_active($) {
1120 $cf::PLAYER{$_[0]} 1026 $cf::PLAYER{$_[0]}
1121 and $cf::PLAYER{$_[0]}->active 1027 and $cf::PLAYER{$_[0]}->active
1124 1030
1125sub exists($) { 1031sub exists($) {
1126 my ($login) = @_; 1032 my ($login) = @_;
1127 1033
1128 $cf::PLAYER{$login} 1034 $cf::PLAYER{$login}
1129 or cf::sync_job { !aio_stat $login } 1035 or cf::sync_job { !aio_stat path $login }
1130} 1036}
1131 1037
1132sub find($) { 1038sub find($) {
1133 return $cf::PLAYER{$_[0]} || do { 1039 return $cf::PLAYER{$_[0]} || do {
1134 my $login = $_[0]; 1040 my $login = $_[0];
1135 1041
1136 my $guard = cf::lock_acquire "user_find:$login"; 1042 my $guard = cf::lock_acquire "user_find:$login";
1137 1043
1138 $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
1139 my $pl = load_pl path $login 1052 my $pl = load_pl path $login
1140 or return; 1053 or return;
1141 $cf::PLAYER{$login} = $pl 1054 $cf::PLAYER{$login} = $pl
1142 } 1055 }
1143 } 1056 }
1180 1093
1181=cut 1094=cut
1182 1095
1183sub quit_character { 1096sub quit_character {
1184 my ($pl) = @_; 1097 my ($pl) = @_;
1098
1099 my $name = $pl->ob->name;
1185 1100
1186 $pl->{deny_save} = 1; 1101 $pl->{deny_save} = 1;
1187 $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
1188 1103
1189 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active; 1104 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active;
1194 my $path = playerdir $pl; 1109 my $path = playerdir $pl;
1195 my $temp = "$path~$cf::RUNTIME~deleting~"; 1110 my $temp = "$path~$cf::RUNTIME~deleting~";
1196 aio_rename $path, $temp; 1111 aio_rename $path, $temp;
1197 delete $cf::PLAYER{$pl->ob->name}; 1112 delete $cf::PLAYER{$pl->ob->name};
1198 $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
1199 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;
1200} 1135}
1201 1136
1202=item cf::player::list_logins 1137=item cf::player::list_logins
1203 1138
1204Returns 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
1205while and may block, so not sync_job-capable, ever. 1140while and may block, so not sync_job-capable, ever.
1206 1141
1207=cut 1142=cut
1208 1143
1209sub list_logins { 1144sub list_logins {
1210 my $dirs = aio_readdir cf::localdir . "/" . cf::playerdir 1145 my $dirs = aio_readdir $PLAYERDIR
1211 or return []; 1146 or return [];
1212 1147
1213 my @logins; 1148 my @logins;
1214 1149
1215 for my $login (@$dirs) { 1150 for my $login (@$dirs) {
1224 \@logins 1159 \@logins
1225} 1160}
1226 1161
1227=item $player->maps 1162=item $player->maps
1228 1163
1229Returns 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
1230player. May block. 1165player. May block.
1231 1166
1232=cut 1167=cut
1233 1168
1234sub maps($) { 1169sub maps($) {
1235 my ($pl) = @_; 1170 my ($pl) = @_;
1171
1172 $pl = ref $pl ? $pl->ob->name : $pl;
1236 1173
1237 my $files = aio_readdir playerdir $pl 1174 my $files = aio_readdir playerdir $pl
1238 or return; 1175 or return;
1239 1176
1240 my @paths; 1177 my @paths;
1241 1178
1242 for (@$files) { 1179 for (@$files) {
1243 utf8::decode $_; 1180 utf8::decode $_;
1244 next if /\.(?:pl|pst)$/; 1181 next if /\.(?:pl|pst)$/;
1245 next unless /^$PATH_SEP/; 1182 next unless /^$PATH_SEP/o;
1246 1183
1247 s/$PATH_SEP/\//g; 1184 push @paths, cf::map::normalise "~$pl/$_";
1248 push @paths, new cf::path "~" . $pl->ob->name . "/" . $_;
1249 } 1185 }
1250 1186
1251 \@paths 1187 \@paths
1252} 1188}
1253 1189
1254=item $player->ext_reply ($msgid, $msgtype, %msg) 1190=item $player->ext_reply ($msgid, %msg)
1255 1191
1256Sends an ext reply to the player. 1192Sends an ext reply to the player.
1257 1193
1258=cut 1194=cut
1259 1195
1260sub ext_reply($$$%) { 1196sub ext_reply($$%) {
1261 my ($self, $id, %msg) = @_; 1197 my ($self, $id, %msg) = @_;
1262 1198
1263 $msg{msgid} = $id; 1199 $msg{msgid} = $id;
1264 1200
1265 $self->send ("ext " . cf::to_json \%msg); 1201 $self->send ("ext " . cf::to_json \%msg);
1266} 1202}
1267 1203
1268package 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}
1269 1244
1270=back 1245=back
1271
1272 1246
1273=head3 cf::map 1247=head3 cf::map
1274 1248
1275=over 4 1249=over 4
1276 1250
1279package cf::map; 1253package cf::map;
1280 1254
1281use Fcntl; 1255use Fcntl;
1282use Coro::AIO; 1256use Coro::AIO;
1283 1257
1258use overload
1259 '""' => \&as_string,
1260 fallback => 1;
1261
1284our $MAX_RESET = 3600; 1262our $MAX_RESET = 3600;
1285our $DEFAULT_RESET = 3000; 1263our $DEFAULT_RESET = 3000;
1286 1264
1287sub generate_random_map { 1265sub generate_random_map {
1288 my ($path, $rmp) = @_; 1266 my ($self, $rmp) = @_;
1289
1290 # mit "rum" bekleckern, nicht 1267 # mit "rum" bekleckern, nicht
1291 cf::map::_create_random_map 1268 $self->_create_random_map (
1292 $path,
1293 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle}, 1269 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle},
1294 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle}, 1270 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle},
1295 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map}, 1271 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map},
1296 $rmp->{exit_on_final_map}, 1272 $rmp->{exit_on_final_map},
1297 $rmp->{xsize}, $rmp->{ysize}, 1273 $rmp->{xsize}, $rmp->{ysize},
1298 $rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3}, 1274 $rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3},
1299 $rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase}, 1275 $rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase},
1300 $rmp->{dungeon_level}, $rmp->{dungeon_depth}, $rmp->{decoroptions}, $rmp->{orientation}, 1276 $rmp->{dungeon_level}, $rmp->{dungeon_depth}, $rmp->{decoroptions}, $rmp->{orientation},
1301 $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},
1302 $rmp->{map_layout_style}, $rmp->{treasureoptions}, $rmp->{symmetry_used}, 1278 $rmp->{map_layout_style}, $rmp->{treasureoptions}, $rmp->{symmetry_used},
1303 (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"
1304} 1408}
1305 1409
1306# and all this just because we cannot iterate over 1410# and all this just because we cannot iterate over
1307# all maps in C++... 1411# all maps in C++...
1308sub change_all_map_light { 1412sub change_all_map_light {
1310 1414
1311 $_->change_map_light ($change) 1415 $_->change_map_light ($change)
1312 for grep $_->outdoor, values %cf::MAP; 1416 for grep $_->outdoor, values %cf::MAP;
1313} 1417}
1314 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
1315sub try_load_header($) { 1435sub load_header_from($) {
1316 my ($path) = @_; 1436 my ($self, $path) = @_;
1317 1437
1318 utf8::encode $path; 1438 utf8::encode $path;
1319 aio_open $path, O_RDONLY, 0 1439 #aio_open $path, O_RDONLY, 0
1440 # or return;
1441
1442 $self->_load_header ($path)
1320 or return; 1443 or return;
1321 1444
1322 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
1323 or return; 1488 or return;
1489 $self->prepare_orig;
1490 }
1324 1491
1325 # for better error messages only, will be overwritten 1492 $self->{deny_reset} = 1
1326 $map->path ($path); 1493 if $self->no_reset;
1327 1494
1328 $map->load_header ($path) 1495 $self->default_region (cf::region::find_by_path $self->{path})
1329 or return; 1496 unless $self->default_region;
1330 1497
1331 $map->{load_path} = $path; 1498 1
1332
1333 $map
1334} 1499}
1335 1500
1336sub find; 1501sub find;
1337sub find { 1502sub find {
1338 my ($path, $origin) = @_; 1503 my ($path, $origin) = @_;
1339 1504
1340 #warn "find<$path,$origin>\n";#d#
1341
1342 $path = new cf::path $path, $origin && $origin->path; 1505 $path = normalise $path, $origin && $origin->path;
1343 my $key = $path->as_string;
1344 1506
1345 cf::lock_wait "map_find:$key"; 1507 cf::lock_wait "map_find:$path";
1346 1508
1347 $cf::MAP{$key} || do { 1509 $cf::MAP{$path} || do {
1348 my $guard = cf::lock_acquire "map_find:$key"; 1510 my $guard = cf::lock_acquire "map_find:$path";
1349 1511 my $map = new_from_path cf::map $path
1350 # do it the slow way
1351 my $map = try_load_header $path->save_path;
1352
1353 Coro::cede;
1354
1355 if ($map) {
1356 $map->last_access ((delete $map->{last_access})
1357 || $cf::RUNTIME); #d#
1358 # safety
1359 $map->{instantiate_time} = $cf::RUNTIME
1360 if $map->{instantiate_time} > $cf::RUNTIME;
1361 } else {
1362 if (my $rmp = $path->random_map_params) {
1363 $map = generate_random_map $key, $rmp;
1364 } else {
1365 $map = try_load_header $path->load_path;
1366 }
1367
1368 $map or return; 1512 or return;
1369 1513
1370 $map->{load_original} = 1;
1371 $map->{instantiate_time} = $cf::RUNTIME;
1372 $map->last_access ($cf::RUNTIME);
1373 $map->instantiate;
1374
1375 # per-player maps become, after loading, normal maps
1376 $map->per_player (0) if $path->{user_rel};
1377 }
1378
1379 $map->path ($key);
1380 $map->{path} = $path;
1381 $map->{last_save} = $cf::RUNTIME; 1514 $map->{last_save} = $cf::RUNTIME;
1382 1515
1383 Coro::cede; 1516 $map->load_header
1517 or return;
1384 1518
1385 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;
1386 $map->reset; 1522 $map->reset;
1387 undef $guard; 1523 undef $guard;
1388 $map = find $path 1524 return find $path;
1389 or return;
1390 } 1525 }
1391 1526
1392 $cf::MAP{$key} = $map 1527 $cf::MAP{$path} = $map
1393 } 1528 }
1394} 1529}
1530
1531sub pre_load { }
1532sub post_load { }
1395 1533
1396sub load { 1534sub load {
1397 my ($self) = @_; 1535 my ($self) = @_;
1398 1536
1537 local $self->{deny_reset} = 1; # loading can take a long time
1538
1399 my $path = $self->{path}; 1539 my $path = $self->{path};
1540
1541 {
1400 my $guard = cf::lock_acquire "map_load:" . $path->as_string; 1542 my $guard = cf::lock_acquire "map_load:$path";
1401 1543
1402 return if $self->in_memory != cf::MAP_SWAPPED; 1544 return if $self->in_memory != cf::MAP_SWAPPED;
1403 1545
1404 $self->in_memory (cf::MAP_LOADING); 1546 $self->in_memory (cf::MAP_LOADING);
1405 1547
1406 $self->alloc; 1548 $self->alloc;
1549
1550 $self->pre_load;
1551 Coro::cede;
1552
1407 $self->load_objects ($self->{load_path}, 1) 1553 $self->_load_objects ($self->{load_path}, 1)
1408 or return; 1554 or return;
1409 1555
1410 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1) 1556 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1)
1411 if delete $self->{load_original}; 1557 if delete $self->{load_original};
1412 1558
1413 if (my $uniq = $path->uniq_path) { 1559 if (my $uniq = $self->uniq_path) {
1414 utf8::encode $uniq; 1560 utf8::encode $uniq;
1415 if (aio_open $uniq, O_RDONLY, 0) { 1561 if (aio_open $uniq, O_RDONLY, 0) {
1416 $self->clear_unique_items; 1562 $self->clear_unique_items;
1417 $self->load_objects ($uniq, 0); 1563 $self->_load_objects ($uniq, 0);
1418 } 1564 }
1419 } 1565 }
1420 1566
1421 Coro::cede; 1567 Coro::cede;
1422
1423 # now do the right thing for maps 1568 # now do the right thing for maps
1424 $self->link_multipart_objects; 1569 $self->link_multipart_objects;
1425
1426 if ($self->{path}->is_style_map) {
1427 $self->{deny_save} = 1;
1428 $self->{deny_reset} = 1;
1429 } else {
1430 $self->fix_auto_apply;
1431 $self->decay_objects;
1432 $self->update_buttons;
1433 $self->set_darkness_map;
1434 $self->difficulty ($self->estimate_difficulty) 1570 $self->difficulty ($self->estimate_difficulty)
1435 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;
1436 $self->activate; 1581 $self->activate;
1437 } 1582 }
1438 1583
1439 Coro::cede;
1440
1441 $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
1442} 1600}
1443 1601
1444# 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
1445sub load_diag { 1603sub load_diag {
1446 my ($map) = @_; 1604 my ($map) = @_;
1476 1634
1477 cf::sync_job { $map->load }; 1635 cf::sync_job { $map->load };
1478} 1636}
1479 1637
1480our %MAP_PREFETCH; 1638our %MAP_PREFETCH;
1481our $MAP_PREFETCHER = Coro::async { 1639our $MAP_PREFETCHER = undef;
1482 while () {
1483 while (%MAP_PREFETCH) {
1484 my $key = each %MAP_PREFETCH
1485 or next;
1486 my $path = delete $MAP_PREFETCH{$key};
1487
1488 my $map = find $path
1489 or next;
1490 $map->load;
1491 }
1492 Coro::schedule;
1493 }
1494};
1495 1640
1496sub find_async { 1641sub find_async {
1497 my ($path, $origin) = @_; 1642 my ($path, $origin) = @_;
1498 1643
1499 $path = new cf::path $path, $origin && $origin->path; 1644 $path = normalise $path, $origin && $origin->{path};
1500 my $key = $path->as_string;
1501 1645
1502 if (my $map = $cf::MAP{$key}) { 1646 if (my $map = $cf::MAP{$path}) {
1503 return $map if $map->in_memory == cf::MAP_IN_MEMORY; 1647 return $map if $map->in_memory == cf::MAP_IN_MEMORY;
1504 } 1648 }
1505 1649
1506 $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 };
1507 $MAP_PREFETCHER->ready; 1663 $MAP_PREFETCHER->prio (6);
1508 1664
1509 () 1665 ()
1510} 1666}
1511 1667
1512sub save { 1668sub save {
1516 1672
1517 $self->{last_save} = $cf::RUNTIME; 1673 $self->{last_save} = $cf::RUNTIME;
1518 1674
1519 return unless $self->dirty; 1675 return unless $self->dirty;
1520 1676
1521 my $save = $self->{path}->save_path; utf8::encode $save; 1677 my $save = $self->save_path; utf8::encode $save;
1522 my $uniq = $self->{path}->uniq_path; utf8::encode $uniq; 1678 my $uniq = $self->uniq_path; utf8::encode $uniq;
1523 1679
1524 $self->{load_path} = $save; 1680 $self->{load_path} = $save;
1525 1681
1526 return if $self->{deny_save}; 1682 return if $self->{deny_save};
1527 1683
1530 cf::async { 1686 cf::async {
1531 $_->contr->save for $self->players; 1687 $_->contr->save for $self->players;
1532 }; 1688 };
1533 1689
1534 if ($uniq) { 1690 if ($uniq) {
1535 $self->save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS); 1691 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS);
1536 $self->save_objects ($uniq, cf::IO_UNIQUES); 1692 $self->_save_objects ($uniq, cf::IO_UNIQUES);
1537 } else { 1693 } else {
1538 $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);
1539 } 1695 }
1540} 1696}
1541 1697
1542sub swap_out { 1698sub swap_out {
1543 my ($self) = @_; 1699 my ($self) = @_;
1557 1713
1558sub reset_at { 1714sub reset_at {
1559 my ($self) = @_; 1715 my ($self) = @_;
1560 1716
1561 # TODO: safety, remove and allow resettable per-player maps 1717 # TODO: safety, remove and allow resettable per-player maps
1562 return 1e99 if $self->{path}{user_rel};
1563 return 1e99 if $self->{deny_reset}; 1718 return 1e99 if $self->{deny_reset};
1564 1719
1565 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access; 1720 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
1566 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;
1567 1722
1572 my ($self) = @_; 1727 my ($self) = @_;
1573 1728
1574 $self->reset_at <= $cf::RUNTIME 1729 $self->reset_at <= $cf::RUNTIME
1575} 1730}
1576 1731
1577sub unlink_save {
1578 my ($self) = @_;
1579
1580 utf8::encode (my $save = $self->{path}->save_path);
1581 aioreq_pri 3; IO::AIO::aio_unlink $save;
1582 aioreq_pri 3; IO::AIO::aio_unlink "$save.pst";
1583}
1584
1585sub rename {
1586 my ($self, $new_path) = @_;
1587
1588 $self->unlink_save;
1589
1590 delete $cf::MAP{$self->path};
1591 $self->{path} = new cf::path $new_path;
1592 $self->path ($self->{path}->as_string);
1593 $cf::MAP{$self->path} = $self;
1594
1595 $self->save;
1596}
1597
1598sub reset { 1732sub reset {
1599 my ($self) = @_; 1733 my ($self) = @_;
1600 1734
1601 my $lock = cf::lock_acquire "map_data:" . $self->path; 1735 my $lock = cf::lock_acquire "map_data:$self->{path}";
1602 1736
1603 return if $self->players; 1737 return if $self->players;
1604 return if $self->{path}{user_rel};#d#
1605 1738
1606 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 }
1607 1750
1608 delete $cf::MAP{$self->path}; 1751 delete $cf::MAP{$self->path};
1752
1753 $self->clear;
1609 1754
1610 $_->clear_links_to ($self) for values %cf::MAP; 1755 $_->clear_links_to ($self) for values %cf::MAP;
1611 1756
1612 $self->unlink_save; 1757 $self->unlink_save;
1613 $self->destroy; 1758 $self->destroy;
1616my $nuke_counter = "aaaa"; 1761my $nuke_counter = "aaaa";
1617 1762
1618sub nuke { 1763sub nuke {
1619 my ($self) = @_; 1764 my ($self) = @_;
1620 1765
1766 delete $cf::MAP{$self->path};
1767
1768 $self->unlink_save;
1769
1770 bless $self, "cf::map";
1771 delete $self->{deny_reset};
1621 $self->{deny_save} = 1; 1772 $self->{deny_save} = 1;
1622 $self->reset_timeout (1); 1773 $self->reset_timeout (1);
1623 $self->rename ("{nuke}/" . ($nuke_counter++)); 1774 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));
1775
1776 $cf::MAP{$self->path} = $self;
1777
1624 $self->reset; # polite request, might not happen 1778 $self->reset; # polite request, might not happen
1625} 1779}
1626 1780
1627sub customise_for { 1781=item $maps = cf::map::tmp_maps
1628 my ($map, $ob) = @_;
1629 1782
1630 if ($map->per_player) { 1783Returns an arrayref with all map paths of currently instantiated and saved
1631 return cf::map::find "~" . $ob->name . "/" . $map->{path}{path}; 1784maps.
1785
1786=cut
1787
1788sub tmp_maps() {
1632 } 1789 [
1790 map {
1791 utf8::decode $_;
1792 !/\.(?:pst|meta)$/ && /^$PATH_SEP/o
1793 ? normalise $_
1794 : ()
1795 } @{ aio_readdir $TMPDIR or [] }
1796 ]
1797}
1633 1798
1634 $map 1799=item cf::map::unique_maps
1800
1801Returns an arrayref of paths of all shared maps that have
1802instantiated unique items. May block.
1803
1804=cut
1805
1806sub unique_maps() {
1807 [
1808 map {
1809 utf8::decode $_;
1810 !/\.(?:pst|meta)$/ && /^$PATH_SEP/o
1811 ? normalise $_
1812 : ()
1813 } @{ aio_readdir $UNIQUEDIR or [] }
1814 ]
1635} 1815}
1636 1816
1637package cf; 1817package cf;
1638 1818
1639=back 1819=back
1711 1891
1712=item $player_object->enter_link 1892=item $player_object->enter_link
1713 1893
1714Freezes 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}>).
1715 1895
1716The 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
1717I<MUST> call C<leave_link> as soon as possible, though. 1897I<MUST> call C<leave_link> as soon as possible, though.
1718 1898
1899Will never block.
1900
1719=item $player_object->leave_link ($map, $x, $y) 1901=item $player_object->leave_link ($map, $x, $y)
1720 1902
1721Moves 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
1722map 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
1723location 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
1724to the emergency map position. 1906fails, to the emergency map position.
1725 1907
1726Might block. 1908Might block.
1727 1909
1728=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}
1729 1921
1730sub cf::object::player::enter_link { 1922sub cf::object::player::enter_link {
1731 my ($self) = @_; 1923 my ($self) = @_;
1732 1924
1733 $self->deactivate_recursive; 1925 $self->deactivate_recursive;
1734 1926
1735 return if $self->map == $LINK_MAP; 1927 return if UNIVERSAL::isa $self->map, "ext::map_link";
1736 1928
1737 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y] 1929 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y]
1738 if $self->map; 1930 if $self->map && $self->map->{path} ne "{link}";
1739 1931
1740 $self->enter_map ($LINK_MAP, 20, 20); 1932 $self->enter_map ($LINK_MAP || link_map, 10, 10);
1741} 1933}
1742 1934
1743sub cf::object::player::leave_link { 1935sub cf::object::player::leave_link {
1744 my ($self, $map, $x, $y) = @_; 1936 my ($self, $map, $x, $y) = @_;
1937
1938 return unless $self->contr->active;
1745 1939
1746 my $link_pos = delete $self->{_link_pos}; 1940 my $link_pos = delete $self->{_link_pos};
1747 1941
1748 unless ($map) { 1942 unless ($map) {
1749 # restore original map position 1943 # restore original map position
1767 $map->load; 1961 $map->load;
1768 $map->load_diag; 1962 $map->load_diag;
1769 1963
1770 return unless $self->contr->active; 1964 return unless $self->contr->active;
1771 $self->activate_recursive; 1965 $self->activate_recursive;
1966
1967 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
1772 $self->enter_map ($map, $x, $y); 1968 $self->enter_map ($map, $x, $y);
1773} 1969}
1774 1970
1775cf::player->attach (
1776 on_logout => sub {
1777 my ($pl) = @_;
1778
1779 # abort map switching before logout
1780 if ($pl->ob->{_link_pos}) {
1781 cf::sync_job {
1782 $pl->ob->leave_link
1783 };
1784 }
1785 },
1786 on_login => sub {
1787 my ($pl) = @_;
1788
1789 # try to abort aborted map switching on player login :)
1790 # should happen only on crashes
1791 if ($pl->ob->{_link_pos}) {
1792 $pl->ob->enter_link;
1793 (async {
1794 # we need this sleep as the login has a concurrent enter_exit running
1795 # and this sleep increases chances of the player not ending up in scorn
1796 $pl->ob->reply (undef,
1797 "There was an internal problem at your last logout, "
1798 . "the server will try to bring you to your intended destination in a second.",
1799 cf::NDI_RED);
1800 Coro::Timer::sleep 1;
1801 $pl->ob->leave_link;
1802 })->prio (2);
1803 }
1804 },
1805);
1806
1807=item $player_object->goto ($path, $x, $y) 1971=item $player_object->goto ($path, $x, $y[, $check->($map)])
1808 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
1809=cut 1978=cut
1979
1980our $GOTOGEN;
1810 1981
1811sub cf::object::player::goto { 1982sub cf::object::player::goto {
1812 my ($self, $path, $x, $y) = @_; 1983 my ($self, $path, $x, $y, $check) = @_;
1813 1984
1814 $path = new cf::path $path; 1985 # do generation counting so two concurrent goto's will be executed in-order
1815 $path ne "/" or Carp::cluck ("oy");#d# 1986 my $gen = $self->{_goto_generation} = ++$GOTOGEN;
1816 1987
1817 $self->enter_link; 1988 $self->enter_link;
1818 1989
1819 (async { 1990 (async {
1991 my $map = eval {
1820 my $map = cf::map::find $path->as_string; 1992 my $map = cf::map::find $path;
1993
1994 if ($map) {
1821 $map = $map->customise_for ($self) if $map; 1995 $map = $map->customise_for ($self);
1822 1996 $map = $check->($map) if $check && $map;
1823# warn "entering ", $map->path, " at ($x, $y)\n" 1997 } else {
1824# if $map;
1825
1826 $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 }
1827 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};
1828 $self->leave_link ($map, $x, $y); 2011 $self->leave_link ($map, $x, $y);
2012 }
1829 })->prio (1); 2013 })->prio (1);
1830} 2014}
1831 2015
1832=item $player_object->enter_exit ($exit_object) 2016=item $player_object->enter_exit ($exit_object)
1833 2017
1835 2019
1836sub parse_random_map_params { 2020sub parse_random_map_params {
1837 my ($spec) = @_; 2021 my ($spec) = @_;
1838 2022
1839 my $rmp = { # defaults 2023 my $rmp = { # defaults
1840 xsize => 10, 2024 xsize => (cf::rndm 15, 40),
1841 ysize => 10, 2025 ysize => (cf::rndm 15, 40),
2026 symmetry => (cf::rndm 1, cf::SYMMETRY_XY),
2027 #layout => string,
1842 }; 2028 };
1843 2029
1844 for (split /\n/, $spec) { 2030 for (split /\n/, $spec) {
1845 my ($k, $v) = split /\s+/, $_, 2; 2031 my ($k, $v) = split /\s+/, $_, 2;
1846 2032
1850 $rmp 2036 $rmp
1851} 2037}
1852 2038
1853sub prepare_random_map { 2039sub prepare_random_map {
1854 my ($exit) = @_; 2040 my ($exit) = @_;
2041
2042 my $guard = cf::lock_acquire "exit_prepare:$exit";
1855 2043
1856 # all this does is basically replace the /! path by 2044 # all this does is basically replace the /! path by
1857 # a new random map path (?random/...) with a seed 2045 # a new random map path (?random/...) with a seed
1858 # that depends on the exit object 2046 # that depends on the exit object
1859 2047
1860 my $rmp = parse_random_map_params $exit->msg; 2048 my $rmp = parse_random_map_params $exit->msg;
1861 2049
1862 if ($exit->map) { 2050 if ($exit->map) {
1863 $rmp->{region} = $exit->map->region_name; 2051 $rmp->{region} = $exit->region->name;
1864 $rmp->{origin_map} = $exit->map->path; 2052 $rmp->{origin_map} = $exit->map->path;
1865 $rmp->{origin_x} = $exit->x; 2053 $rmp->{origin_x} = $exit->x;
1866 $rmp->{origin_y} = $exit->y; 2054 $rmp->{origin_y} = $exit->y;
1867 } 2055 }
1868 2056
1869 $rmp->{random_seed} ||= $exit->random_seed; 2057 $rmp->{random_seed} ||= $exit->random_seed;
1870 2058
1871 my $data = cf::to_json $rmp; 2059 my $data = cf::to_json $rmp;
1872 my $md5 = Digest::MD5::md5_hex $data; 2060 my $md5 = Digest::MD5::md5_hex $data;
2061 my $meta = "$RANDOMDIR/$md5.meta";
1873 2062
1874 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) {
1875 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;
1876 2067
1877 $exit->slaying ("?random/$md5"); 2068 $exit->slaying ("?random/$md5");
1878 $exit->msg (undef); 2069 $exit->msg (undef);
1879 } 2070 }
1880} 2071}
1881 2072
1882sub cf::object::player::enter_exit { 2073sub cf::object::player::enter_exit {
1883 my ($self, $exit) = @_; 2074 my ($self, $exit) = @_;
1884 2075
1885 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;
1886 2088
1887 $self->enter_link; 2089 $self->enter_link;
1888 2090
1889 (async { 2091 (async {
1890 $self->deactivate_recursive; # just to be sure 2092 $self->deactivate_recursive; # just to be sure
1891 unless (eval { 2093 unless (eval {
1892 prepare_random_map $exit 2094 $self->goto ($slaying, $hp, $sp);
1893 if $exit->slaying eq "/!";
1894
1895 my $path = new cf::path $exit->slaying, $exit->map && $exit->map->path;
1896 $self->goto ($path, $exit->stats->hp, $exit->stats->sp);
1897 2095
1898 1; 2096 1;
1899 }) { 2097 }) {
1900 $self->message ("Something went wrong deep within the crossfire server. " 2098 $self->message ("Something went wrong deep within the crossfire server. "
1901 . "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. "
1902 . "Please report this to the dungeon master", 2100 . "Please report this to the dungeon master!",
1903 cf::NDI_UNIQUE | cf::NDI_RED); 2101 cf::NDI_UNIQUE | cf::NDI_RED);
1904 2102
1905 warn "ERROR in enter_exit: $@"; 2103 warn "ERROR in enter_exit: $@";
1906 $self->leave_link; 2104 $self->leave_link;
1907 } 2105 }
1908 })->prio (1); 2106 })->prio (1);
1921 2119
1922sub cf::client::send_drawinfo { 2120sub cf::client::send_drawinfo {
1923 my ($self, $text, $flags) = @_; 2121 my ($self, $text, $flags) = @_;
1924 2122
1925 utf8::encode $text; 2123 utf8::encode $text;
1926 $self->send_packet (sprintf "drawinfo %d %s", $flags, $text); 2124 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);
1927} 2125}
1928 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}
1929 2139
1930=item $success = $client->query ($flags, "text", \&cb) 2140=item $success = $client->query ($flags, "text", \&cb)
1931 2141
1932Queues a query to the client, calling the given callback with 2142Queues a query to the client, calling the given callback with
1933the 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>,
1962 # get handled first 2172 # get handled first
1963 my $queue = delete $ns->{query_queue} 2173 my $queue = delete $ns->{query_queue}
1964 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
1965 2175
1966 (shift @$queue)->[1]->($msg); 2176 (shift @$queue)->[1]->($msg);
2177 return unless $ns->valid; # temporary(?) workaround for callback destroying socket
1967 2178
1968 push @{ $ns->{query_queue} }, @$queue; 2179 push @{ $ns->{query_queue} }, @$queue;
1969 2180
1970 if (@{ $ns->{query_queue} } == @$queue) { 2181 if (@{ $ns->{query_queue} } == @$queue) {
1971 if (@$queue) { 2182 if (@$queue) {
2029 2240
2030# here we export the classes and methods available to script code 2241# here we export the classes and methods available to script code
2031 2242
2032=pod 2243=pod
2033 2244
2034The following fucntions and emthods are available within a safe environment: 2245The following functions and methods are available within a safe environment:
2035 2246
2036 cf::object contr pay_amount pay_player map 2247 cf::object contr pay_amount pay_player map
2037 cf::object::player player 2248 cf::object::player player
2038 cf::player peaceful 2249 cf::player peaceful
2039 cf::map trigger 2250 cf::map trigger
2124############################################################################# 2335#############################################################################
2125 2336
2126=head2 EXTENSION DATABASE SUPPORT 2337=head2 EXTENSION DATABASE SUPPORT
2127 2338
2128Crossfire maintains a very simple database for extension use. It can 2339Crossfire maintains a very simple database for extension use. It can
2129currently store anything that can be serialised using Storable, which 2340currently store binary data only (use Compress::LZF::sfreeze_cr/sthaw to
2130excludes objects. 2341convert to/from binary).
2131 2342
2132The 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
2133using it, it should be unique. 2344using it, it should be unique.
2134 2345
2135=over 4 2346=over 4
2136 2347
2137=item $hashref = cf::db_get $family
2138
2139Return a hashref for use by the extension C<$family>, which can be
2140modified. After modifications, you have to call C<cf::db_dirty> or
2141C<cf::db_sync>.
2142
2143=item $value = cf::db_get $family => $key 2348=item $value = cf::db_get $family => $key
2144 2349
2145Returns a single value from the database 2350Returns a single value from the database.
2146
2147=item cf::db_put $family => $hashref
2148
2149Stores the given family hashref into the database. Updates are delayed, if
2150you want the data to be synced to disk immediately, use C<cf::db_sync>.
2151 2351
2152=item cf::db_put $family => $key => $value 2352=item cf::db_put $family => $key => $value
2153 2353
2154Stores the given C<$value> in the family hash. Updates are delayed, if you 2354Stores the given C<$value> in the family.
2155want the data to be synced to disk immediately, use C<cf::db_sync>.
2156
2157=item cf::db_dirty
2158
2159Marks the database as dirty, to be updated at a later time.
2160
2161=item cf::db_sync
2162
2163Immediately write the database to disk I<if it is dirty>.
2164 2355
2165=cut 2356=cut
2166 2357
2167our $DB; 2358our $DB;
2168 2359
2169{ 2360sub db_init {
2170 my $path = cf::localdir . "/database.pst"; 2361 unless ($DB) {
2362 $DB = BDB::db_create $DB_ENV;
2171 2363
2172 sub db_load() { 2364 cf::sync_job {
2173 $DB = stat $path ? Storable::retrieve $path : { }; 2365 eval {
2174 } 2366 $DB->set_flags (BDB::CHKSUM);
2175 2367
2176 my $pid; 2368 BDB::db_open $DB, undef, "db", undef, BDB::BTREE,
2177 2369 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
2178 sub db_save() { 2370 cf::cleanup "db_open(db): $!" if $!;
2179 waitpid $pid, 0 if $pid; 2371 };
2180 if (0 == ($pid = fork)) { 2372 cf::cleanup "db_open(db): $@" if $@;
2181 $DB->{_meta}{version} = 1;
2182 Storable::nstore $DB, "$path~";
2183 rename "$path~", $path;
2184 cf::_exit 0 if defined $pid;
2185 } 2373 };
2186 }
2187
2188 my $dirty;
2189
2190 sub db_sync() {
2191 db_save if $dirty;
2192 undef $dirty;
2193 }
2194
2195 my $idle = Event->idle (min => $TICK * 2.8, max => 10, repeat => 0, data => WF_AUTOCANCEL, cb => sub {
2196 db_sync;
2197 }); 2374 }
2375}
2198 2376
2199 sub db_dirty() {
2200 $dirty = 1;
2201 $idle->start;
2202 }
2203
2204 sub db_get($;$) { 2377sub db_get($$) {
2205 @_ >= 2 2378 my $key = "$_[0]/$_[1]";
2206 ? $DB->{$_[0]}{$_[1]}
2207 : ($DB->{$_[0]} ||= { })
2208 }
2209 2379
2380 cf::sync_job {
2381 BDB::db_get $DB, undef, $key, my $data;
2382
2383 $! ? ()
2384 : $data
2385 }
2386}
2387
2210 sub db_put($$;$) { 2388sub db_put($$$) {
2211 if (@_ >= 3) { 2389 BDB::dbreq_pri 4;
2212 $DB->{$_[0]}{$_[1]} = $_[2]; 2390 BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { };
2213 } else { 2391}
2214 $DB->{$_[0]} = $_[1];
2215 }
2216 db_dirty;
2217 }
2218 2392
2219 cf::global->attach ( 2393=item cf::cache $id => [$paths...], $processversion => $process
2220 prio => 10000, 2394
2221 on_cleanup => sub { 2395Generic caching function that returns the value of the resource $id,
2222 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->[$_]: $!";
2223 }, 2425 }
2224 ); 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 }
2225} 2505}
2226 2506
2227############################################################################# 2507#############################################################################
2228# 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}
2229 2597
2230sub cfg_load { 2598sub cfg_load {
2231 open my $fh, "<:utf8", cf::confdir . "/config" 2599 open my $fh, "<:utf8", "$CONFDIR/config"
2232 or return; 2600 or return;
2233 2601
2234 local $/; 2602 local $/;
2235 *CFG = YAML::Syck::Load <$fh>; 2603 *CFG = YAML::Syck::Load <$fh>;
2236 2604
2250 2618
2251sub main { 2619sub main {
2252 # we must not ever block the main coroutine 2620 # we must not ever block the main coroutine
2253 local $Coro::idle = sub { 2621 local $Coro::idle = sub {
2254 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 {
2255 async { Event::one_event }; 2624 Event::one_event;
2625 })->prio (Coro::PRIO_MAX);
2256 }; 2626 };
2257 2627
2258 cfg_load; 2628 cfg_load;
2259 db_load; 2629 db_init;
2260 load_extensions; 2630 load_extensions;
2631
2632 $TICK_WATCHER->start;
2261 Event::loop; 2633 Event::loop;
2262} 2634}
2263 2635
2264############################################################################# 2636#############################################################################
2265# initialisation and cleanup 2637# initialisation and cleanup
2266 2638
2267# install some emergency cleanup handlers 2639# install some emergency cleanup handlers
2268BEGIN { 2640BEGIN {
2269 for my $signal (qw(INT HUP TERM)) { 2641 for my $signal (qw(INT HUP TERM)) {
2270 Event->signal ( 2642 Event->signal (
2643 reentrant => 0,
2271 data => WF_AUTOCANCEL, 2644 data => WF_AUTOCANCEL,
2272 signal => $signal, 2645 signal => $signal,
2646 prio => 0,
2273 cb => sub { 2647 cb => sub {
2274 cf::cleanup "SIG$signal"; 2648 cf::cleanup "SIG$signal";
2275 }, 2649 },
2276 ); 2650 );
2277 } 2651 }
2278} 2652}
2283 warn "enter emergency perl save\n"; 2657 warn "enter emergency perl save\n";
2284 2658
2285 cf::sync_job { 2659 cf::sync_job {
2286 # use a peculiar iteration method to avoid tripping on perl 2660 # use a peculiar iteration method to avoid tripping on perl
2287 # refcount bugs in for. also avoids problems with players 2661 # refcount bugs in for. also avoids problems with players
2288 # and maps saved/Destroyed asynchronously. 2662 # and maps saved/destroyed asynchronously.
2289 warn "begin emergency player save\n"; 2663 warn "begin emergency player save\n";
2290 for my $login (keys %cf::PLAYER) { 2664 for my $login (keys %cf::PLAYER) {
2291 my $pl = $cf::PLAYER{$login} or next; 2665 my $pl = $cf::PLAYER{$login} or next;
2292 $pl->valid or next; 2666 $pl->valid or next;
2293 $pl->save; 2667 $pl->save;
2299 my $map = $cf::MAP{$path} or next; 2673 my $map = $cf::MAP{$path} or next;
2300 $map->valid or next; 2674 $map->valid or next;
2301 $map->save; 2675 $map->save;
2302 } 2676 }
2303 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";
2304 }; 2682 };
2305 2683
2306 warn "leave emergency perl save\n"; 2684 warn "leave emergency perl save\n";
2307} 2685}
2308 2686
2687sub post_cleanup {
2688 my ($make_core) = @_;
2689
2690 warn Carp::longmess "post_cleanup backtrace"
2691 if $make_core;
2692}
2693
2309sub reload() { 2694sub do_reload_perl() {
2310 # can/must only be called in main 2695 # can/must only be called in main
2311 if ($Coro::current != $Coro::main) { 2696 if ($Coro::current != $Coro::main) {
2312 warn "can only reload from main coroutine\n"; 2697 warn "can only reload from main coroutine";
2313 return; 2698 return;
2314 } 2699 }
2315 2700
2316 warn "reloading..."; 2701 warn "reloading...";
2317 2702
2318 my $guard = freeze_mainloop; 2703 warn "entering sync_job";
2704
2705 cf::sync_job {
2706 cf::write_runtime; # external watchdog should not bark
2319 cf::emergency_save; 2707 cf::emergency_save;
2708 cf::write_runtime; # external watchdog should not bark
2320 2709
2321 eval { 2710 warn "syncing database to disk";
2711 BDB::db_env_txn_checkpoint $DB_ENV;
2712
2322 # 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
2323 2714
2324 # cancel all watchers 2715 warn "cancelling all WF_AUTOCANCEL watchers";
2325 for (Event::all_watchers) { 2716 for (Event::all_watchers) {
2326 $_->cancel if $_->data & WF_AUTOCANCEL; 2717 $_->cancel if $_->data & WF_AUTOCANCEL;
2327 } 2718 }
2328 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
2329 # cancel all extension coros 2731 warn "cancelling all extension coros";
2330 $_->cancel for values %EXT_CORO; 2732 $_->cancel for values %EXT_CORO;
2331 %EXT_CORO = (); 2733 %EXT_CORO = ();
2332 2734
2333 # unload all extensions 2735 warn "removing commands";
2334 for (@exts) { 2736 %COMMAND = ();
2737
2738 warn "removing ext commands";
2739 %EXTCMD = ();
2740
2741 warn "unloading/nuking all extensions";
2742 for my $pkg (@EXTS) {
2335 warn "unloading <$_>"; 2743 warn "... unloading $pkg";
2336 unload_extension $_; 2744
2745 if (my $cb = $pkg->can ("unload")) {
2746 eval {
2747 $cb->($pkg);
2748 1
2749 } or warn "$pkg unloaded, but with errors: $@";
2337 } 2750 }
2338 2751
2752 warn "... nuking $pkg";
2753 Symbol::delete_package $pkg;
2754 }
2755
2339 # unload all modules loaded from $LIBDIR 2756 warn "unloading all perl modules loaded from $LIBDIR";
2340 while (my ($k, $v) = each %INC) { 2757 while (my ($k, $v) = each %INC) {
2341 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/; 2758 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
2342 2759
2343 warn "removing <$k>"; 2760 warn "... unloading $k";
2344 delete $INC{$k}; 2761 delete $INC{$k};
2345 2762
2346 $k =~ s/\.pm$//; 2763 $k =~ s/\.pm$//;
2347 $k =~ s/\//::/g; 2764 $k =~ s/\//::/g;
2348 2765
2351 } 2768 }
2352 2769
2353 Symbol::delete_package $k; 2770 Symbol::delete_package $k;
2354 } 2771 }
2355 2772
2356 # sync database to disk
2357 cf::db_sync;
2358 IO::AIO::flush;
2359
2360 # get rid of safe::, as good as possible 2773 warn "getting rid of safe::, as good as possible";
2361 Symbol::delete_package "safe::$_" 2774 Symbol::delete_package "safe::$_"
2362 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);
2363 2776
2364 # remove register_script_function callbacks
2365 # TODO
2366
2367 # unload cf.pm "a bit" 2777 warn "unloading cf.pm \"a bit\"";
2368 delete $INC{"cf.pm"}; 2778 delete $INC{"cf.pm"};
2779 delete $INC{"cf/pod.pm"};
2369 2780
2370 # don't, removes xs symbols, too, 2781 # don't, removes xs symbols, too,
2371 # and global variables created in xs 2782 # and global variables created in xs
2372 #Symbol::delete_package __PACKAGE__; 2783 #Symbol::delete_package __PACKAGE__;
2373 2784
2374 # reload cf.pm 2785 warn "unload completed, starting to reload now";
2786
2375 warn "reloading cf.pm"; 2787 warn "reloading cf.pm";
2376 require cf; 2788 require cf;
2377 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 2789 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
2378 2790
2379 # load config and database again 2791 warn "loading config and database again";
2380 cf::cfg_load; 2792 cf::cfg_load;
2381 cf::db_load;
2382 2793
2383 # load extensions
2384 warn "load extensions"; 2794 warn "loading extensions";
2385 cf::load_extensions; 2795 cf::load_extensions;
2386 2796
2387 # reattach attachments to objects 2797 warn "reattaching attachments to objects/players";
2388 warn "reattach"; 2798 _global_reattach; # objects, sockets
2389 _global_reattach; 2799 warn "reattaching attachments to maps";
2390 reattach $_ for values %MAP; 2800 reattach $_ for values %MAP;
2391 }; 2801 warn "reattaching attachments to players";
2802 reattach $_ for values %PLAYER;
2392 2803
2393 if ($@) { 2804 warn "leaving sync_job";
2805
2806 1
2807 } or do {
2394 warn $@; 2808 warn $@;
2395 warn "error while reloading, exiting."; 2809 warn "error while reloading, exiting.";
2396 exit 1; 2810 exit 1;
2397 } 2811 };
2398 2812
2399 warn "reloaded successfully"; 2813 warn "reloaded";
2400}; 2814};
2401 2815
2402############################################################################# 2816our $RELOAD_WATCHER; # used only during reload
2403 2817
2404unless ($LINK_MAP) { 2818sub reload_perl() {
2405 $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.
2406 2821
2407 $LINK_MAP->width (41); 2822 $RELOAD_WATCHER ||= Event->timer (
2408 $LINK_MAP->height (41); 2823 reentrant => 0,
2409 $LINK_MAP->alloc;
2410 $LINK_MAP->path ("{link}");
2411 $LINK_MAP->{path} = bless { path => "{link}" }, "cf::path";
2412 $LINK_MAP->in_memory (MAP_IN_MEMORY);
2413
2414 # dirty hack because... archetypes are not yet loaded
2415 Event->timer (
2416 after => 10, 2824 after => 0,
2825 data => WF_AUTOCANCEL,
2417 cb => sub { 2826 cb => sub {
2418 $_[0]->w->cancel; 2827 do_reload_perl;
2419 2828 undef $RELOAD_WATCHER;
2420 # provide some exits "home"
2421 my $exit = cf::object::new "exit";
2422
2423 $exit->slaying ($EMERGENCY_POSITION->[0]);
2424 $exit->stats->hp ($EMERGENCY_POSITION->[1]);
2425 $exit->stats->sp ($EMERGENCY_POSITION->[2]);
2426
2427 $LINK_MAP->insert ($exit->clone, 19, 19);
2428 $LINK_MAP->insert ($exit->clone, 19, 20);
2429 $LINK_MAP->insert ($exit->clone, 19, 21);
2430 $LINK_MAP->insert ($exit->clone, 20, 19);
2431 $LINK_MAP->insert ($exit->clone, 20, 21);
2432 $LINK_MAP->insert ($exit->clone, 21, 19);
2433 $LINK_MAP->insert ($exit->clone, 21, 20);
2434 $LINK_MAP->insert ($exit->clone, 21, 21);
2435
2436 $exit->destroy;
2437 }); 2829 },
2438 2830 );
2439 $LINK_MAP->{deny_save} = 1;
2440 $LINK_MAP->{deny_reset} = 1;
2441
2442 $cf::MAP{$LINK_MAP->path} = $LINK_MAP;
2443} 2831}
2444
2445register "<global>", __PACKAGE__;
2446 2832
2447register_command "reload" => sub { 2833register_command "reload" => sub {
2448 my ($who, $arg) = @_; 2834 my ($who, $arg) = @_;
2449 2835
2450 if ($who->flag (FLAG_WIZ)) { 2836 if ($who->flag (FLAG_WIZ)) {
2451 $who->message ("start of reload.");
2452 reload;
2453 $who->message ("end of reload."); 2837 $who->message ("reloading server.");
2838 async { reload_perl };
2454 } 2839 }
2455}; 2840};
2456 2841
2457unshift @INC, $LIBDIR; 2842unshift @INC, $LIBDIR;
2458 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;
2459$TICK_WATCHER = Event->timer ( 2869$TICK_WATCHER = Event->timer (
2460 reentrant => 0, 2870 reentrant => 0,
2871 parked => 1,
2461 prio => 0, 2872 prio => 0,
2462 at => $NEXT_TICK || $TICK, 2873 at => $NEXT_TICK || $TICK,
2463 data => WF_AUTOCANCEL, 2874 data => WF_AUTOCANCEL,
2464 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
2465 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
2466 $RUNTIME += $TICK; 2909 $RUNTIME += $TICK;
2467 $NEXT_TICK += $TICK; 2910 $NEXT_TICK += $TICK;
2468 2911
2469 $WAIT_FOR_TICK->broadcast; 2912 if ($NOW >= $NEXT_RUNTIME_WRITE) {
2470 $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;
2471 2931
2472 # 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
2473 $NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4; 2933 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
2474 2934
2475 $TICK_WATCHER->at ($NEXT_TICK); 2935 $TICK_WATCHER->at ($NEXT_TICK);
2476 $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
2477 }, 2944 },
2478); 2945);
2479 2946
2947{
2480IO::AIO::max_poll_time $TICK * 0.2; 2948 BDB::max_poll_time $TICK * 0.1;
2481 2949 $BDB_POLL_WATCHER = Event->io (
2482Event->io ( 2950 reentrant => 0,
2483 fd => IO::AIO::poll_fileno, 2951 fd => BDB::poll_fileno,
2484 poll => 'r', 2952 poll => 'r',
2485 prio => 5, 2953 prio => 0,
2486 data => WF_AUTOCANCEL,
2487 cb => \&IO::AIO::poll_cb,
2488);
2489
2490Event->timer (
2491 data => WF_AUTOCANCEL, 2954 data => WF_AUTOCANCEL,
2492 after => 0, 2955 cb => \&BDB::poll_cb,
2493 interval => 10, 2956 );
2494 cb => sub { 2957 BDB::min_parallel 8;
2495 (Coro::unblock_sub { 2958
2496 write_runtime 2959 BDB::set_sync_prepare {
2497 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 $@;
2498 })->(); 2993 };
2499 }, 2994 }
2500); 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;
2501 3052
2502END { cf::emergency_save } 3053END { cf::emergency_save }
2503 3054
25041 30551
2505 3056

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines