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

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines