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.268 by root, Tue May 22 10:50:00 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
1389=item $player_object->goto_map ($map, $x, $y) 1948cf::player->attach (
1949 on_logout => sub {
1950 my ($pl) = @_;
1390 1951
1391=cut 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) = @_;
1392 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
1980=item $player_object->goto ($path, $x, $y[, $check->($map)])
1981
1982Moves the player to the given map-path and coordinates by first freezing
1983her, loading and preparing them map, calling the provided $check callback
1984that has to return the map if sucecssful, and then unfreezes the player on
1985the new (success) or old (failed) map position.
1986
1987=cut
1988
1393sub cf::object::player::goto_map { 1989sub cf::object::player::goto {
1394 my ($self, $path, $x, $y) = @_; 1990 my ($self, $path, $x, $y, $check) = @_;
1991
1992 #d# #TODO#
1993 if ($check && !ref $check) {
1994 warn Carp::longmess "goto called with non-ref check argument";#d#
1995 undef $check;
1996 }
1395 1997
1396 $self->enter_link; 1998 $self->enter_link;
1397 1999
1398 (Coro::async { 2000 (async {
1399 $path = new cf::path $path; 2001 my $map = eval {
1400
1401 my $map = cf::map::find_map $path->as_string; 2002 my $map = cf::map::find $path;
2003
2004 if ($map) {
1402 $map = $map->customise_for ($self) if $map; 2005 $map = $map->customise_for ($self);
2006 $map = $check->($map) if $check && $map;
2007 } else {
2008 $self->message ("The exit to '$path' is closed", cf::NDI_UNIQUE | cf::NDI_RED);
2009 }
1403 2010
1404 warn "entering ", $map->path, " at ($x, $y)\n"
1405 if $map; 2011 $map
2012 };
2013
2014 if ($@) {
2015 $self->message ("Something went wrong within the server, please report this incident!", cf::NDI_UNIQUE | cf::NDI_RED);
2016 LOG llevError | logBacktrace, Carp::longmess $@;
2017 }
1406 2018
1407 $self->leave_link ($map, $x, $y); 2019 $self->leave_link ($map, $x, $y);
1408 })->prio (1); 2020 })->prio (1);
1409} 2021}
1410 2022
1414 2026
1415sub parse_random_map_params { 2027sub parse_random_map_params {
1416 my ($spec) = @_; 2028 my ($spec) = @_;
1417 2029
1418 my $rmp = { # defaults 2030 my $rmp = { # defaults
1419 xsize => 10, 2031 xsize => (cf::rndm 15, 40),
1420 ysize => 10, 2032 ysize => (cf::rndm 15, 40),
2033 symmetry => (cf::rndm 1, cf::SYMMETRY_XY),
2034 #layout => string,
1421 }; 2035 };
1422 2036
1423 for (split /\n/, $spec) { 2037 for (split /\n/, $spec) {
1424 my ($k, $v) = split /\s+/, $_, 2; 2038 my ($k, $v) = split /\s+/, $_, 2;
1425 2039
1429 $rmp 2043 $rmp
1430} 2044}
1431 2045
1432sub prepare_random_map { 2046sub prepare_random_map {
1433 my ($exit) = @_; 2047 my ($exit) = @_;
2048
2049 my $guard = cf::lock_acquire "exit_prepare:$exit";
1434 2050
1435 # all this does is basically replace the /! path by 2051 # all this does is basically replace the /! path by
1436 # a new random map path (?random/...) with a seed 2052 # a new random map path (?random/...) with a seed
1437 # that depends on the exit object 2053 # that depends on the exit object
1438 2054
1439 my $rmp = parse_random_map_params $exit->msg; 2055 my $rmp = parse_random_map_params $exit->msg;
1440 2056
1441 if ($exit->map) { 2057 if ($exit->map) {
1442 $rmp->{region} = $exit->map->region_name; 2058 $rmp->{region} = $exit->region->name;
1443 $rmp->{origin_map} = $exit->map->path; 2059 $rmp->{origin_map} = $exit->map->path;
1444 $rmp->{origin_x} = $exit->x; 2060 $rmp->{origin_x} = $exit->x;
1445 $rmp->{origin_y} = $exit->y; 2061 $rmp->{origin_y} = $exit->y;
1446 } 2062 }
1447 2063
1448 $rmp->{random_seed} ||= $exit->random_seed; 2064 $rmp->{random_seed} ||= $exit->random_seed;
1449 2065
1450 my $data = cf::to_json $rmp; 2066 my $data = cf::to_json $rmp;
1451 my $md5 = Digest::MD5::md5_hex $data; 2067 my $md5 = Digest::MD5::md5_hex $data;
2068 my $meta = "$RANDOMDIR/$md5.meta";
1452 2069
1453 if (my $fh = aio_open "$cf::RANDOM_MAPS/$md5.meta", O_WRONLY | O_CREAT, 0666) { 2070 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) {
1454 aio_write $fh, 0, (length $data), $data, 0; 2071 aio_write $fh, 0, (length $data), $data, 0;
2072 undef $fh;
2073 aio_rename "$meta~", $meta;
1455 2074
1456 $exit->slaying ("?random/$md5"); 2075 $exit->slaying ("?random/$md5");
1457 $exit->msg (undef); 2076 $exit->msg (undef);
1458 } 2077 }
1459} 2078}
1461sub cf::object::player::enter_exit { 2080sub cf::object::player::enter_exit {
1462 my ($self, $exit) = @_; 2081 my ($self, $exit) = @_;
1463 2082
1464 return unless $self->type == cf::PLAYER; 2083 return unless $self->type == cf::PLAYER;
1465 2084
2085 if ($exit->slaying eq "/!") {
2086 #TODO: this should de-fi-ni-te-ly not be a sync-job
2087 # the problem is that $exit might not survive long enough
2088 # so it needs to be done right now, right here
2089 cf::sync_job { prepare_random_map $exit };
2090 }
2091
2092 my $slaying = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path;
2093 my $hp = $exit->stats->hp;
2094 my $sp = $exit->stats->sp;
2095
1466 $self->enter_link; 2096 $self->enter_link;
1467 2097
1468 (Coro::async { 2098 (async {
2099 $self->deactivate_recursive; # just to be sure
1469 unless (eval { 2100 unless (eval {
1470 2101 $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 2102
1477 1; 2103 1;
1478 }) { 2104 }) {
1479 $self->message ("Something went wrong deep within the crossfire server. " 2105 $self->message ("Something went wrong deep within the crossfire server. "
1480 . "I'll try to bring you back to the map you were before. " 2106 . "I'll try to bring you back to the map you were before. "
1481 . "Please report this to the dungeon master", 2107 . "Please report this to the dungeon master!",
1482 cf::NDI_UNIQUE | cf::NDI_RED); 2108 cf::NDI_UNIQUE | cf::NDI_RED);
1483 2109
1484 warn "ERROR in enter_exit: $@"; 2110 warn "ERROR in enter_exit: $@";
1485 $self->leave_link; 2111 $self->leave_link;
1486 } 2112 }
1487 })->prio (1); 2113 })->prio (1);
1500 2126
1501sub cf::client::send_drawinfo { 2127sub cf::client::send_drawinfo {
1502 my ($self, $text, $flags) = @_; 2128 my ($self, $text, $flags) = @_;
1503 2129
1504 utf8::encode $text; 2130 utf8::encode $text;
1505 $self->send_packet (sprintf "drawinfo %d %s", $flags, $text); 2131 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);
1506} 2132}
1507 2133
2134=item $client->ext_event ($type, %msg)
2135
2136Sends an exti event to the client.
2137
2138=cut
2139
2140sub cf::client::ext_event($$%) {
2141 my ($self, $type, %msg) = @_;
2142
2143 $msg{msgtype} = "event_$type";
2144 $self->send_packet ("ext " . cf::to_json \%msg);
2145}
1508 2146
1509=item $success = $client->query ($flags, "text", \&cb) 2147=item $success = $client->query ($flags, "text", \&cb)
1510 2148
1511Queues a query to the client, calling the given callback with 2149Queues a query to the client, calling the given callback with
1512the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>, 2150the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>,
1537 on_reply => sub { 2175 on_reply => sub {
1538 my ($ns, $msg) = @_; 2176 my ($ns, $msg) = @_;
1539 2177
1540 # this weird shuffling is so that direct followup queries 2178 # this weird shuffling is so that direct followup queries
1541 # get handled first 2179 # get handled first
1542 my $queue = delete $ns->{query_queue}; 2180 my $queue = delete $ns->{query_queue}
2181 or return; # be conservative, not sure how that can happen, but we saw a crash here
1543 2182
1544 (shift @$queue)->[1]->($msg); 2183 (shift @$queue)->[1]->($msg);
2184 return unless $ns->valid; # temporary(?) workaround for callback destroying socket
1545 2185
1546 push @{ $ns->{query_queue} }, @$queue; 2186 push @{ $ns->{query_queue} }, @$queue;
1547 2187
1548 if (@{ $ns->{query_queue} } == @$queue) { 2188 if (@{ $ns->{query_queue} } == @$queue) {
1549 if (@$queue) { 2189 if (@$queue) {
1553 } 2193 }
1554 } 2194 }
1555 }, 2195 },
1556); 2196);
1557 2197
1558=item $client->coro (\&cb) 2198=item $client->async (\&cb)
1559 2199
1560Create a new coroutine, running the specified callback. The coroutine will 2200Create a new coroutine, running the specified callback. The coroutine will
1561be automatically cancelled when the client gets destroyed (e.g. on logout, 2201be automatically cancelled when the client gets destroyed (e.g. on logout,
1562or loss of connection). 2202or loss of connection).
1563 2203
1564=cut 2204=cut
1565 2205
1566sub cf::client::coro { 2206sub cf::client::async {
1567 my ($self, $cb) = @_; 2207 my ($self, $cb) = @_;
1568 2208
1569 my $coro; $coro = async { 2209 my $coro = &Coro::async ($cb);
1570 eval {
1571 $cb->();
1572 };
1573 warn $@ if $@;
1574 };
1575 2210
1576 $coro->on_destroy (sub { 2211 $coro->on_destroy (sub {
1577 delete $self->{_coro}{$coro+0}; 2212 delete $self->{_coro}{$coro+0};
1578 }); 2213 });
1579 2214
1612 2247
1613# here we export the classes and methods available to script code 2248# here we export the classes and methods available to script code
1614 2249
1615=pod 2250=pod
1616 2251
1617The following fucntions and emthods are available within a safe environment: 2252The following functions and methods are available within a safe environment:
1618 2253
1619 cf::object contr pay_amount pay_player map 2254 cf::object contr pay_amount pay_player map
1620 cf::object::player player 2255 cf::object::player player
1621 cf::player peaceful 2256 cf::player peaceful
1622 cf::map trigger 2257 cf::map trigger
1707############################################################################# 2342#############################################################################
1708 2343
1709=head2 EXTENSION DATABASE SUPPORT 2344=head2 EXTENSION DATABASE SUPPORT
1710 2345
1711Crossfire maintains a very simple database for extension use. It can 2346Crossfire maintains a very simple database for extension use. It can
1712currently store anything that can be serialised using Storable, which 2347currently store binary data only (use Compress::LZF::sfreeze_cr/sthaw to
1713excludes objects. 2348convert to/from binary).
1714 2349
1715The parameter C<$family> should best start with the name of the extension 2350The parameter C<$family> should best start with the name of the extension
1716using it, it should be unique. 2351using it, it should be unique.
1717 2352
1718=over 4 2353=over 4
1719 2354
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 2355=item $value = cf::db_get $family => $key
1727 2356
1728Returns a single value from the database 2357Returns 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 2358
1735=item cf::db_put $family => $key => $value 2359=item cf::db_put $family => $key => $value
1736 2360
1737Stores the given C<$value> in the family hash. Updates are delayed, if you 2361Stores 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 2362
1748=cut 2363=cut
1749 2364
1750our $DB; 2365our $DB;
1751 2366
1752{ 2367sub db_init {
1753 my $path = cf::localdir . "/database.pst"; 2368 unless ($DB) {
2369 $DB = BDB::db_create $DB_ENV;
1754 2370
1755 sub db_load() { 2371 cf::sync_job {
1756 warn "loading database $path\n";#d# remove later 2372 eval {
1757 $DB = stat $path ? Storable::retrieve $path : { }; 2373 $DB->set_flags (BDB::CHKSUM);
1758 }
1759 2374
1760 my $pid; 2375 BDB::db_open $DB, undef, "db", undef, BDB::BTREE,
1761 2376 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
1762 sub db_save() { 2377 cf::cleanup "db_open(db): $!" if $!;
1763 warn "saving database $path\n";#d# remove later 2378 };
1764 waitpid $pid, 0 if $pid; 2379 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 } 2380 };
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 }); 2381 }
2382}
1783 2383
1784 sub db_dirty() {
1785 $dirty = 1;
1786 $idle->start;
1787 }
1788
1789 sub db_get($;$) { 2384sub db_get($$) {
1790 @_ >= 2 2385 my $key = "$_[0]/$_[1]";
1791 ? $DB->{$_[0]}{$_[1]}
1792 : ($DB->{$_[0]} ||= { })
1793 }
1794 2386
2387 cf::sync_job {
2388 BDB::db_get $DB, undef, $key, my $data;
2389
2390 $! ? ()
2391 : $data
2392 }
2393}
2394
1795 sub db_put($$;$) { 2395sub db_put($$$) {
1796 if (@_ >= 3) { 2396 BDB::dbreq_pri 4;
1797 $DB->{$_[0]}{$_[1]} = $_[2]; 2397 BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { };
1798 } else { 2398}
1799 $DB->{$_[0]} = $_[1];
1800 }
1801 db_dirty;
1802 }
1803 2399
1804 cf::global->attach ( 2400=item cf::cache $id => [$paths...], $processversion => $process
1805 prio => 10000, 2401
1806 on_cleanup => sub { 2402Generic caching function that returns the value of the resource $id,
1807 db_sync; 2403caching and regenerating as required.
2404
2405This function can block.
2406
2407=cut
2408
2409sub cache {
2410 my ($id, $src, $processversion, $process) = @_;
2411
2412 my $meta =
2413 join "\x00",
2414 $processversion,
2415 map {
2416 aio_stat $_
2417 and Carp::croak "$_: $!";
2418
2419 ($_, (stat _)[7,9])
2420 } @$src;
2421
2422 my $dbmeta = db_get cache => "$id/meta";
2423 if ($dbmeta ne $meta) {
2424 # changed, we may need to process
2425
2426 my @data;
2427 my $md5;
2428
2429 for (0 .. $#$src) {
2430 0 <= aio_load $src->[$_], $data[$_]
2431 or Carp::croak "$src->[$_]: $!";
1808 }, 2432 }
1809 ); 2433
2434 # if processing is expensive, check
2435 # checksum first
2436 if (1) {
2437 $md5 =
2438 join "\x00",
2439 $processversion,
2440 map {
2441 Coro::cede;
2442 ($src->[$_], Digest::MD5::md5_hex $data[$_])
2443 } 0.. $#$src;
2444
2445
2446 my $dbmd5 = db_get cache => "$id/md5";
2447 if ($dbmd5 eq $md5) {
2448 db_put cache => "$id/meta", $meta;
2449
2450 return db_get cache => "$id/data";
2451 }
2452 }
2453
2454 my $t1 = Time::HiRes::time;
2455 my $data = $process->(\@data);
2456 my $t2 = Time::HiRes::time;
2457
2458 warn "cache: '$id' processed in ", $t2 - $t1, "s\n";
2459
2460 db_put cache => "$id/data", $data;
2461 db_put cache => "$id/md5" , $md5;
2462 db_put cache => "$id/meta", $meta;
2463
2464 return $data;
2465 }
2466
2467 db_get cache => "$id/data"
1810} 2468}
2469
2470=item fork_call { }, $args
2471
2472Executes the given code block with the given arguments in a seperate
2473process, returning the results. Everything must be serialisable with
2474Coro::Storable. May, of course, block. Note that the executed sub may
2475never block itself or use any form of Event handling.
2476
2477=cut
2478
2479sub fork_call(&@) {
2480 my ($cb, @args) = @_;
2481
2482# socketpair my $fh1, my $fh2, Socket::AF_UNIX, Socket::SOCK_STREAM, Socket::PF_UNSPEC
2483# or die "socketpair: $!";
2484 pipe my $fh1, my $fh2
2485 or die "pipe: $!";
2486
2487 if (my $pid = fork) {
2488 close $fh2;
2489
2490 my $res = (Coro::Handle::unblock $fh1)->readline (undef);
2491 $res = Coro::Storable::thaw $res;
2492
2493 waitpid $pid, 0; # should not block anymore, we expect the child to simply behave
2494
2495 die $$res unless "ARRAY" eq ref $res;
2496
2497 return wantarray ? @$res : $res->[-1];
2498 } else {
2499 reset_signals;
2500 local $SIG{__WARN__};
2501 local $SIG{__DIE__};
2502 eval {
2503 close $fh1;
2504
2505 my @res = eval { $cb->(@args) };
2506 syswrite $fh2, Coro::Storable::freeze +($@ ? \"$@" : \@res);
2507 };
2508
2509 warn $@ if $@;
2510 _exit 0;
2511 }
2512}
2513
2514
1811 2515
1812############################################################################# 2516#############################################################################
1813# the server's main() 2517# the server's init and main functions
2518
2519sub load_facedata($) {
2520 my ($path) = @_;
2521
2522 warn "loading facedata from $path\n";
2523
2524 my $facedata;
2525 0 < aio_load $path, $facedata
2526 or die "$path: $!";
2527
2528 $facedata = Coro::Storable::thaw $facedata;
2529
2530 $facedata->{version} == 2
2531 or cf::cleanup "$path: version mismatch, cannot proceed.";
2532
2533 {
2534 my $faces = $facedata->{faceinfo};
2535
2536 while (my ($face, $info) = each %$faces) {
2537 my $idx = (cf::face::find $face) || cf::face::alloc $face;
2538 cf::face::set $idx, $info->{visibility}, $info->{magicmap};
2539 cf::face::set_data $idx, 0, $info->{data32}, $info->{chksum32};
2540 cf::face::set_data $idx, 1, $info->{data64}, $info->{chksum64};
2541 Coro::cede;
2542 }
2543
2544 while (my ($face, $info) = each %$faces) {
2545 next unless $info->{smooth};
2546 my $idx = cf::face::find $face
2547 or next;
2548 if (my $smooth = cf::face::find $info->{smooth}) {
2549 cf::face::set_smooth $idx, $smooth, $info->{smoothlevel};
2550 } else {
2551 warn "smooth face '$info->{smooth}' not found for face '$face'";
2552 }
2553 Coro::cede;
2554 }
2555 }
2556
2557 {
2558 my $anims = $facedata->{animinfo};
2559
2560 while (my ($anim, $info) = each %$anims) {
2561 cf::anim::set $anim, $info->{frames}, $info->{facings};
2562 Coro::cede;
2563 }
2564
2565 cf::anim::invalidate_all; # d'oh
2566 }
2567
2568 1
2569}
2570
2571sub reload_regions {
2572 load_resource_file "$MAPDIR/regions"
2573 or die "unable to load regions file\n";
2574}
2575
2576sub reload_facedata {
2577 load_facedata "$DATADIR/facedata"
2578 or die "unable to load facedata\n";
2579}
2580
2581sub reload_archetypes {
2582 load_resource_file "$DATADIR/archetypes"
2583 or die "unable to load archetypes\n";
2584}
2585
2586sub reload_treasures {
2587 load_resource_file "$DATADIR/treasures"
2588 or die "unable to load treasurelists\n";
2589}
2590
2591sub reload_resources {
2592 warn "reloading resource files...\n";
2593
2594 reload_regions;
2595 reload_facedata;
2596 reload_archetypes;
2597 reload_treasures;
2598
2599 warn "finished reloading resource files\n";
2600}
2601
2602sub init {
2603 reload_resources;
2604}
1814 2605
1815sub cfg_load { 2606sub cfg_load {
1816 open my $fh, "<:utf8", cf::confdir . "/config" 2607 open my $fh, "<:utf8", "$CONFDIR/config"
1817 or return; 2608 or return;
1818 2609
1819 local $/; 2610 local $/;
1820 *CFG = YAML::Syck::Load <$fh>; 2611 *CFG = YAML::Syck::Load <$fh>;
2612
2613 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37];
2614
2615 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset};
2616 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset};
2617
2618 if (exists $CFG{mlockall}) {
2619 eval {
2620 $CFG{mlockall} ? eval "mlockall()" : eval "munlockall()"
2621 and die "WARNING: m(un)lockall failed: $!\n";
2622 };
2623 warn $@ if $@;
2624 }
1821} 2625}
1822 2626
1823sub main { 2627sub main {
1824 # we must not ever block the main coroutine 2628 # we must not ever block the main coroutine
1825 local $Coro::idle = sub { 2629 local $Coro::idle = sub {
1826 Carp::cluck "FATAL: Coro::idle was called, major BUG\n";#d# 2630 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
1827 (Coro::unblock_sub { 2631 (async {
1828 Event::one_event; 2632 Event::one_event;
1829 })->(); 2633 })->prio (Coro::PRIO_MAX);
1830 }; 2634 };
1831 2635
1832 cfg_load; 2636 cfg_load;
1833 db_load; 2637 db_init;
1834 load_extensions; 2638 load_extensions;
2639
2640 $TICK_WATCHER->start;
1835 Event::loop; 2641 Event::loop;
1836} 2642}
1837 2643
1838############################################################################# 2644#############################################################################
1839# initialisation 2645# initialisation and cleanup
1840 2646
2647# install some emergency cleanup handlers
2648BEGIN {
2649 for my $signal (qw(INT HUP TERM)) {
2650 Event->signal (
2651 reentrant => 0,
2652 data => WF_AUTOCANCEL,
2653 signal => $signal,
2654 prio => 0,
2655 cb => sub {
2656 cf::cleanup "SIG$signal";
2657 },
2658 );
2659 }
2660}
2661
2662sub emergency_save() {
2663 my $freeze_guard = cf::freeze_mainloop;
2664
2665 warn "enter emergency perl save\n";
2666
2667 cf::sync_job {
2668 # use a peculiar iteration method to avoid tripping on perl
2669 # refcount bugs in for. also avoids problems with players
2670 # and maps saved/destroyed asynchronously.
2671 warn "begin emergency player save\n";
2672 for my $login (keys %cf::PLAYER) {
2673 my $pl = $cf::PLAYER{$login} or next;
2674 $pl->valid or next;
2675 $pl->save;
2676 }
2677 warn "end emergency player save\n";
2678
2679 warn "begin emergency map save\n";
2680 for my $path (keys %cf::MAP) {
2681 my $map = $cf::MAP{$path} or next;
2682 $map->valid or next;
2683 $map->save;
2684 }
2685 warn "end emergency map save\n";
2686
2687 warn "begin emergency database checkpoint\n";
2688 BDB::db_env_txn_checkpoint $DB_ENV;
2689 warn "end emergency database checkpoint\n";
2690 };
2691
2692 warn "leave emergency perl save\n";
2693}
2694
2695sub post_cleanup {
2696 my ($make_core) = @_;
2697
2698 warn Carp::longmess "post_cleanup backtrace"
2699 if $make_core;
2700}
2701
1841sub reload() { 2702sub do_reload_perl() {
1842 # can/must only be called in main 2703 # can/must only be called in main
1843 if ($Coro::current != $Coro::main) { 2704 if ($Coro::current != $Coro::main) {
1844 warn "can only reload from main coroutine\n"; 2705 warn "can only reload from main coroutine";
1845 return; 2706 return;
1846 } 2707 }
1847 2708
1848 warn "reloading..."; 2709 warn "reloading...";
1849 2710
1850 local $FREEZE = 1; 2711 warn "entering sync_job";
2712
2713 cf::sync_job {
2714 cf::write_runtime; # external watchdog should not bark
1851 cf::emergency_save; 2715 cf::emergency_save;
2716 cf::write_runtime; # external watchdog should not bark
1852 2717
1853 eval { 2718 warn "syncing database to disk";
2719 BDB::db_env_txn_checkpoint $DB_ENV;
2720
1854 # if anything goes wrong in here, we should simply crash as we already saved 2721 # if anything goes wrong in here, we should simply crash as we already saved
1855 2722
1856 # cancel all watchers 2723 warn "cancelling all WF_AUTOCANCEL watchers";
1857 for (Event::all_watchers) { 2724 for (Event::all_watchers) {
1858 $_->cancel if $_->data & WF_AUTOCANCEL; 2725 $_->cancel if $_->data & WF_AUTOCANCEL;
1859 } 2726 }
1860 2727
2728 warn "flushing outstanding aio requests";
2729 for (;;) {
2730 BDB::flush;
2731 IO::AIO::flush;
2732 Coro::cede;
2733 last unless IO::AIO::nreqs || BDB::nreqs;
2734 warn "iterate...";
2735 }
2736
2737 ++$RELOAD;
2738
1861 # cancel all extension coros 2739 warn "cancelling all extension coros";
1862 $_->cancel for values %EXT_CORO; 2740 $_->cancel for values %EXT_CORO;
1863 %EXT_CORO = (); 2741 %EXT_CORO = ();
1864 2742
1865 # unload all extensions 2743 warn "removing commands";
1866 for (@exts) { 2744 %COMMAND = ();
2745
2746 warn "removing ext commands";
2747 %EXTCMD = ();
2748
2749 warn "unloading/nuking all extensions";
2750 for my $pkg (@EXTS) {
1867 warn "unloading <$_>"; 2751 warn "... unloading $pkg";
1868 unload_extension $_; 2752
2753 if (my $cb = $pkg->can ("unload")) {
2754 eval {
2755 $cb->($pkg);
2756 1
2757 } or warn "$pkg unloaded, but with errors: $@";
1869 } 2758 }
1870 2759
2760 warn "... nuking $pkg";
2761 Symbol::delete_package $pkg;
2762 }
2763
1871 # unload all modules loaded from $LIBDIR 2764 warn "unloading all perl modules loaded from $LIBDIR";
1872 while (my ($k, $v) = each %INC) { 2765 while (my ($k, $v) = each %INC) {
1873 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/; 2766 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
1874 2767
1875 warn "removing <$k>"; 2768 warn "... unloading $k";
1876 delete $INC{$k}; 2769 delete $INC{$k};
1877 2770
1878 $k =~ s/\.pm$//; 2771 $k =~ s/\.pm$//;
1879 $k =~ s/\//::/g; 2772 $k =~ s/\//::/g;
1880 2773
1883 } 2776 }
1884 2777
1885 Symbol::delete_package $k; 2778 Symbol::delete_package $k;
1886 } 2779 }
1887 2780
1888 # sync database to disk
1889 cf::db_sync;
1890 IO::AIO::flush;
1891
1892 # get rid of safe::, as good as possible 2781 warn "getting rid of safe::, as good as possible";
1893 Symbol::delete_package "safe::$_" 2782 Symbol::delete_package "safe::$_"
1894 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region); 2783 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
1895 2784
1896 # remove register_script_function callbacks
1897 # TODO
1898
1899 # unload cf.pm "a bit" 2785 warn "unloading cf.pm \"a bit\"";
1900 delete $INC{"cf.pm"}; 2786 delete $INC{"cf.pm"};
2787 delete $INC{"cf/pod.pm"};
1901 2788
1902 # don't, removes xs symbols, too, 2789 # don't, removes xs symbols, too,
1903 # and global variables created in xs 2790 # and global variables created in xs
1904 #Symbol::delete_package __PACKAGE__; 2791 #Symbol::delete_package __PACKAGE__;
1905 2792
1906 # reload cf.pm 2793 warn "unload completed, starting to reload now";
2794
1907 warn "reloading cf.pm"; 2795 warn "reloading cf.pm";
1908 require cf; 2796 require cf;
1909 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 2797 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
1910 2798
1911 # load config and database again 2799 warn "loading config and database again";
1912 cf::cfg_load; 2800 cf::cfg_load;
1913 cf::db_load;
1914 2801
1915 # load extensions
1916 warn "load extensions"; 2802 warn "loading extensions";
1917 cf::load_extensions; 2803 cf::load_extensions;
1918 2804
1919 # reattach attachments to objects 2805 warn "reattaching attachments to objects/players";
1920 warn "reattach"; 2806 _global_reattach; # objects, sockets
1921 _global_reattach; 2807 warn "reattaching attachments to maps";
1922 }; 2808 reattach $_ for values %MAP;
2809 warn "reattaching attachments to players";
2810 reattach $_ for values %PLAYER;
1923 2811
1924 if ($@) { 2812 warn "leaving sync_job";
2813
2814 1
2815 } or do {
1925 warn $@; 2816 warn $@;
1926 warn "error while reloading, exiting."; 2817 warn "error while reloading, exiting.";
1927 exit 1; 2818 exit 1;
1928 } 2819 };
1929 2820
1930 warn "reloaded successfully"; 2821 warn "reloaded";
1931}; 2822};
1932 2823
1933############################################################################# 2824our $RELOAD_WATCHER; # used only during reload
1934 2825
1935unless ($LINK_MAP) { 2826sub reload_perl() {
1936 $LINK_MAP = cf::map::new; 2827 # doing reload synchronously and two reloads happen back-to-back,
2828 # coro crashes during coro_state_free->destroy here.
1937 2829
1938 $LINK_MAP->width (41); 2830 $RELOAD_WATCHER ||= Event->timer (
1939 $LINK_MAP->height (41); 2831 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, 2832 after => 0,
2833 data => WF_AUTOCANCEL,
1948 cb => sub { 2834 cb => sub {
1949 $_[0]->w->cancel; 2835 do_reload_perl;
1950 2836 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 }); 2837 },
1969 2838 );
1970 $LINK_MAP->{deny_save} = 1;
1971 $LINK_MAP->{deny_reset} = 1;
1972
1973 $cf::MAP{$LINK_MAP->path} = $LINK_MAP;
1974} 2839}
1975
1976register "<global>", __PACKAGE__;
1977 2840
1978register_command "reload" => sub { 2841register_command "reload" => sub {
1979 my ($who, $arg) = @_; 2842 my ($who, $arg) = @_;
1980 2843
1981 if ($who->flag (FLAG_WIZ)) { 2844 if ($who->flag (FLAG_WIZ)) {
1982 $who->message ("start of reload.");
1983 reload;
1984 $who->message ("end of reload."); 2845 $who->message ("reloading server.");
2846 async { reload_perl };
1985 } 2847 }
1986}; 2848};
1987 2849
1988unshift @INC, $LIBDIR; 2850unshift @INC, $LIBDIR;
1989 2851
2852my $bug_warning = 0;
2853
2854our @WAIT_FOR_TICK;
2855our @WAIT_FOR_TICK_BEGIN;
2856
2857sub wait_for_tick {
2858 return unless $TICK_WATCHER->is_active;
2859 return if $Coro::current == $Coro::main;
2860
2861 my $signal = new Coro::Signal;
2862 push @WAIT_FOR_TICK, $signal;
2863 $signal->wait;
2864}
2865
2866sub wait_for_tick_begin {
2867 return unless $TICK_WATCHER->is_active;
2868 return if $Coro::current == $Coro::main;
2869
2870 my $signal = new Coro::Signal;
2871 push @WAIT_FOR_TICK_BEGIN, $signal;
2872 $signal->wait;
2873}
2874
2875 my $min = 1e6;#d#
2876 my $avg = 10;
1990$TICK_WATCHER = Event->timer ( 2877$TICK_WATCHER = Event->timer (
1991 reentrant => 0, 2878 reentrant => 0,
2879 parked => 1,
1992 prio => 0, 2880 prio => 0,
1993 at => $NEXT_TICK || $TICK, 2881 at => $NEXT_TICK || $TICK,
1994 data => WF_AUTOCANCEL, 2882 data => WF_AUTOCANCEL,
1995 cb => sub { 2883 cb => sub {
1996 unless ($FREEZE) { 2884 if ($Coro::current != $Coro::main) {
2885 Carp::cluck "major BUG: server tick called outside of main coro, skipping it"
2886 unless ++$bug_warning > 10;
2887 return;
2888 }
2889
2890 $NOW = $tick_start = Event::time;
2891
1997 cf::server_tick; # one server iteration 2892 cf::server_tick; # one server iteration
1998 $RUNTIME += $TICK; 2893
2894 0 && sync_job {#d#
2895 for(1..10) {
2896 my $t = Event::time;
2897 my $map = my $map = new_from_path cf::map "/tmp/x.map"
2898 or die;
2899
2900 $map->width (50);
2901 $map->height (50);
2902 $map->alloc;
2903 $map->_load_objects ("/tmp/x.map", 1);
2904 my $t = Event::time - $t;
2905
2906 #next unless $t < 0.0013;#d#
2907 if ($t < $min) {
2908 $min = $t;
2909 }
2910 $avg = $avg * 0.99 + $t * 0.01;
2911 }
2912 warn "XXXXXXXXXXXXXXXXXX min $min avg $avg\n";#d#
2913 exit 0;
2914 # 2007-05-22 02:33:04.569 min 0.00112509727478027 avg 0.0012259249572477
1999 } 2915 };
2000 2916
2917 $RUNTIME += $TICK;
2001 $NEXT_TICK += $TICK; 2918 $NEXT_TICK += $TICK;
2002 2919
2920 if ($NOW >= $NEXT_RUNTIME_WRITE) {
2921 $NEXT_RUNTIME_WRITE = $NOW + 10;
2922 Coro::async_pool {
2923 write_runtime
2924 or warn "ERROR: unable to write runtime file: $!";
2925 };
2926 }
2927
2928# my $AFTER = Event::time;
2929# warn $AFTER - $NOW;#d#
2930
2931 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
2932 $sig->send;
2933 }
2934 while (my $sig = shift @WAIT_FOR_TICK) {
2935 $sig->send;
2936 }
2937
2938 $NOW = Event::time;
2939
2003 # if we are delayed by four ticks or more, skip them all 2940 # if we are delayed by four ticks or more, skip them all
2004 $NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4; 2941 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
2005 2942
2006 $TICK_WATCHER->at ($NEXT_TICK); 2943 $TICK_WATCHER->at ($NEXT_TICK);
2007 $TICK_WATCHER->start; 2944 $TICK_WATCHER->start;
2945
2946 $LOAD = ($NOW - $tick_start) / $TICK;
2947 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
2948
2949 _post_tick;
2950
2951
2008 }, 2952 },
2009); 2953);
2010 2954
2955{
2011IO::AIO::max_poll_time $TICK * 0.2; 2956 BDB::max_poll_time $TICK * 0.1;
2012 2957 $BDB_POLL_WATCHER = Event->io (
2013Event->io ( 2958 reentrant => 0,
2014 fd => IO::AIO::poll_fileno, 2959 fd => BDB::poll_fileno,
2015 poll => 'r', 2960 poll => 'r',
2016 prio => 5, 2961 prio => 0,
2017 data => WF_AUTOCANCEL,
2018 cb => \&IO::AIO::poll_cb,
2019);
2020
2021Event->timer (
2022 data => WF_AUTOCANCEL, 2962 data => WF_AUTOCANCEL,
2023 after => 0, 2963 cb => \&BDB::poll_cb,
2024 interval => 10, 2964 );
2025 cb => sub { 2965 BDB::min_parallel 8;
2026 (Coro::unblock_sub { 2966
2027 write_runtime 2967 BDB::set_sync_prepare {
2028 or warn "ERROR: unable to write runtime file: $!"; 2968 my $status;
2969 my $current = $Coro::current;
2970 (
2971 sub {
2972 $status = $!;
2973 $current->ready; undef $current;
2974 },
2975 sub {
2976 Coro::schedule while defined $current;
2977 $! = $status;
2978 },
2979 )
2980 };
2981
2982 unless ($DB_ENV) {
2983 $DB_ENV = BDB::db_env_create;
2984
2985 cf::sync_job {
2986 eval {
2987 BDB::db_env_open
2988 $DB_ENV,
2989 $BDBDIR,
2990 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN
2991 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE,
2992 0666;
2993
2994 cf::cleanup "db_env_open($BDBDIR): $!" if $!;
2995
2996 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC, 1);
2997 $DB_ENV->set_lk_detect;
2998 };
2999
3000 cf::cleanup "db_env_open(db): $@" if $@;
2029 })->(); 3001 };
2030 }, 3002 }
2031); 3003}
3004
3005{
3006 IO::AIO::min_parallel 8;
3007
3008 undef $Coro::AIO::WATCHER;
3009 IO::AIO::max_poll_time $TICK * 0.1;
3010 $AIO_POLL_WATCHER = Event->io (
3011 reentrant => 0,
3012 data => WF_AUTOCANCEL,
3013 fd => IO::AIO::poll_fileno,
3014 poll => 'r',
3015 prio => 6,
3016 cb => \&IO::AIO::poll_cb,
3017 );
3018}
3019
3020my $_log_backtrace;
3021
3022sub _log_backtrace {
3023 my ($msg, @addr) = @_;
3024
3025 $msg =~ s/\n//;
3026
3027 # limit the # of concurrent backtraces
3028 if ($_log_backtrace < 2) {
3029 ++$_log_backtrace;
3030 async {
3031 my @bt = fork_call {
3032 @addr = map { sprintf "%x", $_ } @addr;
3033 my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X;
3034 open my $fh, "exec addr2line -C -f -i -e \Q$self\E @addr 2>&1 |"
3035 or die "addr2line: $!";
3036
3037 my @funcs;
3038 my @res = <$fh>;
3039 chomp for @res;
3040 while (@res) {
3041 my ($func, $line) = splice @res, 0, 2, ();
3042 push @funcs, "[$func] $line";
3043 }
3044
3045 @funcs
3046 };
3047
3048 LOG llevInfo, "[ABT] $msg\n";
3049 LOG llevInfo, "[ABT] $_\n" for @bt;
3050 --$_log_backtrace;
3051 };
3052 } else {
3053 LOG llevInfo, "[ABT] $msg\n";
3054 LOG llevInfo, "[ABT] [suppressed]\n";
3055 }
3056}
3057
3058# load additional modules
3059use cf::pod;
3060
3061END { cf::emergency_save }
2032 3062
20331 30631
2034 3064

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines