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.104 by root, Sat Dec 30 16:56:16 2006 UTC vs.
Revision 1.291 by root, Tue Jul 3 00:54:44 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;
22use Coro::AIO;
23use Coro::Storable;
18 24
19use IO::AIO 2.3; 25use JSON::XS 1.4 ();
26use BDB ();
27use Data::Dumper;
28use Digest::MD5;
29use Fcntl;
20use YAML::Syck (); 30use YAML::Syck ();
31use IO::AIO 2.32 ();
21use Time::HiRes; 32use Time::HiRes;
33use Compress::LZF;
22 34
35# configure various modules to our taste
36#
37$Storable::canonical = 1; # reduce rsync transfers
38Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator
39Compress::LZF::sfreeze_cr { }; # prime Compress::LZF so it does not use require later
40
23use Event; $Event::Eval = 1; # no idea why this is required, but it is 41$Event::Eval = 1; # no idea why this is required, but it is
24 42
25# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode? 43# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode?
26$YAML::Syck::ImplicitUnicode = 1; 44$YAML::Syck::ImplicitUnicode = 1;
27 45
28$Coro::main->prio (2); # run main coroutine ("the server") with very high priority 46$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority
29 47
30sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload 48sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
31 49
32our %COMMAND = (); 50our %COMMAND = ();
33our %COMMAND_TIME = (); 51our %COMMAND_TIME = ();
52
53our @EXTS = (); # list of extension package names
34our %EXTCMD = (); 54our %EXTCMD = ();
55our %EXTICMD = ();
56our %EXT_CORO = (); # coroutines bound to extensions
57our %EXT_MAP = (); # pluggable maps
35 58
59our $RELOAD; # number of reloads so far
36our @EVENT; 60our @EVENT;
37our $LIBDIR = datadir . "/ext";
38 61
39our $TICK = MAX_TIME * 1e-6; 62our $CONFDIR = confdir;
63our $DATADIR = datadir;
64our $LIBDIR = "$DATADIR/ext";
65our $PODDIR = "$DATADIR/pod";
66our $MAPDIR = "$DATADIR/" . mapdir;
67our $LOCALDIR = localdir;
68our $TMPDIR = "$LOCALDIR/" . tmpdir;
69our $UNIQUEDIR = "$LOCALDIR/" . uniquedir;
70our $PLAYERDIR = "$LOCALDIR/" . playerdir;
71our $RANDOMDIR = "$LOCALDIR/random";
72our $BDBDIR = "$LOCALDIR/db";
73
74our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!)
40our $TICK_WATCHER; 75our $TICK_WATCHER;
76our $AIO_POLL_WATCHER;
77our $NEXT_RUNTIME_WRITE; # when should the runtime file be written
41our $NEXT_TICK; 78our $NEXT_TICK;
42our $NOW; 79our $NOW;
80our $USE_FSYNC = 1; # use fsync to write maps - default off
81
82our $BDB_POLL_WATCHER;
83our $DB_ENV;
43 84
44our %CFG; 85our %CFG;
45 86
46our $UPTIME; $UPTIME ||= time; 87our $UPTIME; $UPTIME ||= time;
47our $RUNTIME; 88our $RUNTIME;
48 89
90our %PLAYER; # all users
49our %MAP; # all maps 91our %MAP; # all maps
50our $LINK_MAP; # the special {link} map 92our $LINK_MAP; # the special {link} map, which is always available
51our $FREEZE; 93
94# used to convert map paths into valid unix filenames by replacing / by ∕
95our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons
96
97our $LOAD; # a number between 0 (idle) and 1 (too many objects)
98our $LOADAVG; # same thing, but with alpha-smoothing
99our $tick_start; # for load detecting purposes
52 100
53binmode STDOUT; 101binmode STDOUT;
54binmode STDERR; 102binmode STDERR;
55 103
56# read virtual server time, if available 104# read virtual server time, if available
57unless ($RUNTIME || !-e cf::localdir . "/runtime") { 105unless ($RUNTIME || !-e "$LOCALDIR/runtime") {
58 open my $fh, "<", cf::localdir . "/runtime" 106 open my $fh, "<", "$LOCALDIR/runtime"
59 or die "unable to read runtime file: $!"; 107 or die "unable to read runtime file: $!";
60 $RUNTIME = <$fh> + 0.; 108 $RUNTIME = <$fh> + 0.;
61} 109}
62 110
63mkdir cf::localdir; 111mkdir $_
64mkdir cf::localdir . "/" . cf::playerdir; 112 for $LOCALDIR, $TMPDIR, $UNIQUEDIR, $PLAYERDIR, $RANDOMDIR, $BDBDIR;
65mkdir cf::localdir . "/" . cf::tmpdir;
66mkdir cf::localdir . "/" . cf::uniquedir;
67 113
68our %EXT_CORO; 114our $EMERGENCY_POSITION;
115
116sub cf::map::normalise;
69 117
70############################################################################# 118#############################################################################
71 119
72=head2 GLOBAL VARIABLES 120=head2 GLOBAL VARIABLES
73 121
80=item $cf::RUNTIME 128=item $cf::RUNTIME
81 129
82The time this server has run, starts at 0 and is increased by $cf::TICK on 130The time this server has run, starts at 0 and is increased by $cf::TICK on
83every server tick. 131every server tick.
84 132
85=item $cf::LIBDIR 133=item $cf::CONFDIR $cf::DATADIR $cf::LIBDIR $cf::PODDIR
134$cf::MAPDIR $cf::LOCALDIR $cf::TMPDIR $cf::UNIQUEDIR
135$cf::PLAYERDIR $cf::RANDOMDIR $cf::BDBDIR
86 136
87The perl library directory, where extensions and cf-specific modules can 137Various directories - "/etc", read-only install directory, perl-library
88be found. It will be added to C<@INC> automatically. 138directory, pod-directory, read-only maps directory, "/var", "/var/tmp",
139unique-items directory, player file directory, random maps directory and
140database environment.
89 141
90=item $cf::NOW 142=item $cf::NOW
91 143
92The time of the last (current) server tick. 144The time of the last (current) server tick.
93 145
94=item $cf::TICK 146=item $cf::TICK
95 147
96The interval between server ticks, in seconds. 148The interval between server ticks, in seconds.
149
150=item $cf::LOADAVG
151
152The current CPU load on the server (alpha-smoothed), as a value between 0
153(none) and 1 (overloaded), indicating how much time is spent on processing
154objects per tick. Healthy values are < 0.5.
155
156=item $cf::LOAD
157
158The raw value load value from the last tick.
97 159
98=item %cf::CFG 160=item %cf::CFG
99 161
100Configuration for the server, loaded from C</etc/crossfire/config>, or 162Configuration for the server, loaded from C</etc/crossfire/config>, or
101from wherever your confdir points to. 163from wherever your confdir points to.
164
165=item cf::wait_for_tick, cf::wait_for_tick_begin
166
167These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only
168returns directly I<after> the tick processing (and consequently, can only wake one process
169per tick), while cf::wait_for_tick wakes up all waiters after tick processing.
102 170
103=back 171=back
104 172
105=cut 173=cut
106 174
107BEGIN { 175BEGIN {
108 *CORE::GLOBAL::warn = sub { 176 *CORE::GLOBAL::warn = sub {
109 my $msg = join "", @_; 177 my $msg = join "", @_;
110 utf8::encode $msg;
111 178
112 $msg .= "\n" 179 $msg .= "\n"
113 unless $msg =~ /\n$/; 180 unless $msg =~ /\n$/;
114 181
182 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;
183
184 utf8::encode $msg;
115 LOG llevError, "cfperl: $msg"; 185 LOG llevError, $msg;
116 }; 186 };
117} 187}
118 188
119@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable'; 189@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
120@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable'; 190@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';
121@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable'; 191@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable';
122@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable'; 192@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable';
123@safe::cf::map::ISA = @cf::map::ISA = 'cf::attachable'; 193@safe::cf::map::ISA = @cf::map::ISA = 'cf::attachable';
194@safe::cf::arch::ISA = @cf::arch::ISA = 'cf::object';
124@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object'; 195@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object'; # not really true (yet)
125 196
126# we bless all objects into (empty) derived classes to force a method lookup 197# we bless all objects into (empty) derived classes to force a method lookup
127# within the Safe compartment. 198# within the Safe compartment.
128for my $pkg (qw( 199for my $pkg (qw(
129 cf::global cf::attachable 200 cf::global cf::attachable
138 209
139$Event::DIED = sub { 210$Event::DIED = sub {
140 warn "error in event callback: @_"; 211 warn "error in event callback: @_";
141}; 212};
142 213
143my %ext_pkg; 214#############################################################################
144my @exts;
145my @hook;
146 215
147=head2 UTILITY FUNCTIONS 216=head2 UTILITY FUNCTIONS
148 217
149=over 4 218=over 4
150 219
151=cut 220=item dumpval $ref
152 221
153use JSON::Syck (); # TODO# replace by JSON::PC once working 222=cut
223
224sub dumpval {
225 eval {
226 local $SIG{__DIE__};
227 my $d;
228 if (1) {
229 $d = new Data::Dumper([$_[0]], ["*var"]);
230 $d->Terse(1);
231 $d->Indent(2);
232 $d->Quotekeys(0);
233 $d->Useqq(1);
234 #$d->Bless(...);
235 $d->Seen($_[1]) if @_ > 1;
236 $d = $d->Dump();
237 }
238 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge;
239 $d
240 } || "[unable to dump $_[0]: '$@']";
241}
154 242
155=item $ref = cf::from_json $json 243=item $ref = cf::from_json $json
156 244
157Converts a JSON string into the corresponding perl data structure. 245Converts a JSON string into the corresponding perl data structure.
158 246
159=cut
160
161sub from_json($) {
162 $JSON::Syck::ImplicitUnicode = 1; # work around JSON::Syck bugs
163 JSON::Syck::Load $_[0]
164}
165
166=item $json = cf::to_json $ref 247=item $json = cf::to_json $ref
167 248
168Converts a perl data structure into its JSON representation. 249Converts a perl data structure into its JSON representation.
169 250
170=cut 251=cut
171 252
172sub to_json($) { 253our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max
173 $JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs
174 JSON::Syck::Dump $_[0]
175}
176 254
255sub to_json ($) { $json_coder->encode ($_[0]) }
256sub from_json ($) { $json_coder->decode ($_[0]) }
257
258=item cf::lock_wait $string
259
260Wait until the given lock is available. See cf::lock_acquire.
261
262=item my $lock = cf::lock_acquire $string
263
264Wait until the given lock is available and then acquires it and returns
265a Coro::guard object. If the guard object gets destroyed (goes out of scope,
266for example when the coroutine gets canceled), the lock is automatically
267returned.
268
269Lock names should begin with a unique identifier (for example, cf::map::find
270uses map_find and cf::map::load uses map_load).
271
272=item $locked = cf::lock_active $string
273
274Return true if the lock is currently active, i.e. somebody has locked it.
275
276=cut
277
278our %LOCK;
279
280sub lock_wait($) {
281 my ($key) = @_;
282
283 # wait for lock, if any
284 while ($LOCK{$key}) {
285 push @{ $LOCK{$key} }, $Coro::current;
286 Coro::schedule;
287 }
288}
289
290sub lock_acquire($) {
291 my ($key) = @_;
292
293 # wait, to be sure we are not locked
294 lock_wait $key;
295
296 $LOCK{$key} = [];
297
298 Coro::guard {
299 # wake up all waiters, to be on the safe side
300 $_->ready for @{ delete $LOCK{$key} };
301 }
302}
303
304sub lock_active($) {
305 my ($key) = @_;
306
307 ! ! $LOCK{$key}
308}
309
310sub freeze_mainloop {
311 return unless $TICK_WATCHER->is_active;
312
313 my $guard = Coro::guard {
314 $TICK_WATCHER->start;
315 };
316 $TICK_WATCHER->stop;
317 $guard
318}
319
320=item cf::async { BLOCK }
321
322Currently the same as Coro::async_pool, meaning you cannot use
323C<on_destroy>, C<join> or other gimmicks on these coroutines. The only
324thing you are allowed to do is call C<prio> on it.
325
326=cut
327
328BEGIN { *async = \&Coro::async_pool }
329
330=item cf::sync_job { BLOCK }
331
332The design of Crossfire TRT requires that the main coroutine ($Coro::main)
333is always able to handle events or runnable, as Crossfire TRT is only
334partly reentrant. Thus "blocking" it by e.g. waiting for I/O is not
335acceptable.
336
337If it must be done, put the blocking parts into C<sync_job>. This will run
338the given BLOCK in another coroutine while waiting for the result. The
339server will be frozen during this time, so the block should either finish
340fast or be very important.
341
342=cut
343
344sub sync_job(&) {
345 my ($job) = @_;
346
347 if ($Coro::current == $Coro::main) {
348 my $time = Event::time;
349
350 # this is the main coro, too bad, we have to block
351 # till the operation succeeds, freezing the server :/
352
353 # TODO: use suspend/resume instead
354 # (but this is cancel-safe)
355 my $freeze_guard = freeze_mainloop;
356
357 my $busy = 1;
358 my @res;
359
360 (async {
361 @res = eval { $job->() };
362 warn $@ if $@;
363 undef $busy;
364 })->prio (Coro::PRIO_MAX);
365
366 while ($busy) {
367 Coro::cede or Event::one_event;
368 }
369
370 $time = Event::time - $time;
371
372 LOG llevError | logBacktrace, Carp::longmess "long sync job"
373 if $time > $TICK * 0.5 && $TICK_WATCHER->is_active;
374
375 $tick_start += $time; # do not account sync jobs to server load
376
377 wantarray ? @res : $res[0]
378 } else {
379 # we are in another coroutine, how wonderful, everything just works
380
381 $job->()
382 }
383}
384
177=item $coro = cf::coro { BLOCK } 385=item $coro = cf::async_ext { BLOCK }
178 386
179Creates and returns a new coro. This coro is automcatially being canceled 387Like async, but this coro is automatically being canceled when the
180when the extension calling this is being unloaded. 388extension calling this is being unloaded.
181 389
182=cut 390=cut
183 391
184sub coro(&) { 392sub async_ext(&) {
185 my $cb = shift; 393 my $cb = shift;
186 394
187 my $coro; $coro = async { 395 my $coro = &Coro::async ($cb);
188 eval {
189 $cb->();
190 };
191 warn $@ if $@;
192 };
193 396
194 $coro->on_destroy (sub { 397 $coro->on_destroy (sub {
195 delete $EXT_CORO{$coro+0}; 398 delete $EXT_CORO{$coro+0};
196 }); 399 });
197 $EXT_CORO{$coro+0} = $coro; 400 $EXT_CORO{$coro+0} = $coro;
198 401
199 $coro 402 $coro
200} 403}
201 404
405=item fork_call { }, $args
406
407Executes the given code block with the given arguments in a seperate
408process, returning the results. Everything must be serialisable with
409Coro::Storable. May, of course, block. Note that the executed sub may
410never block itself or use any form of Event handling.
411
412=cut
413
414sub fork_call(&@) {
415 my ($cb, @args) = @_;
416
417# socketpair my $fh1, my $fh2, Socket::AF_UNIX, Socket::SOCK_STREAM, Socket::PF_UNSPEC
418# or die "socketpair: $!";
419 pipe my $fh1, my $fh2
420 or die "pipe: $!";
421
422 if (my $pid = fork) {
423 close $fh2;
424
425 my $res = (Coro::Handle::unblock $fh1)->readline (undef);
426 $res = Coro::Storable::thaw $res;
427
428 waitpid $pid, 0; # should not block anymore, we expect the child to simply behave
429
430 die $$res unless "ARRAY" eq ref $res;
431
432 return wantarray ? @$res : $res->[-1];
433 } else {
434 reset_signals;
435 local $SIG{__WARN__};
436 local $SIG{__DIE__};
437 eval {
438 close $fh1;
439
440 my @res = eval { $cb->(@args) };
441 syswrite $fh2, Coro::Storable::freeze +($@ ? \"$@" : \@res);
442 };
443
444 warn $@ if $@;
445 _exit 0;
446 }
447}
448
449=item $value = cf::db_get $family => $key
450
451Returns a single value from the environment database.
452
453=item cf::db_put $family => $key => $value
454
455Stores the given C<$value> in the family. It can currently store binary
456data only (use Compress::LZF::sfreeze_cr/sthaw to convert to/from binary).
457
458=cut
459
460our $DB;
461
462sub db_init {
463 unless ($DB) {
464 $DB = BDB::db_create $DB_ENV;
465
466 cf::sync_job {
467 eval {
468 $DB->set_flags (BDB::CHKSUM);
469
470 BDB::db_open $DB, undef, "db", undef, BDB::BTREE,
471 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
472 cf::cleanup "db_open(db): $!" if $!;
473 };
474 cf::cleanup "db_open(db): $@" if $@;
475 };
476 }
477}
478
479sub db_get($$) {
480 my $key = "$_[0]/$_[1]";
481
482 cf::sync_job {
483 BDB::db_get $DB, undef, $key, my $data;
484
485 $! ? ()
486 : $data
487 }
488}
489
490sub db_put($$$) {
491 BDB::dbreq_pri 4;
492 BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { };
493}
494
495=item cf::cache $id => [$paths...], $processversion => $process
496
497Generic caching function that returns the value of the resource $id,
498caching and regenerating as required.
499
500This function can block.
501
502=cut
503
504sub cache {
505 my ($id, $src, $processversion, $process) = @_;
506
507 my $meta =
508 join "\x00",
509 $processversion,
510 map {
511 aio_stat $_
512 and Carp::croak "$_: $!";
513
514 ($_, (stat _)[7,9])
515 } @$src;
516
517 my $dbmeta = db_get cache => "$id/meta";
518 if ($dbmeta ne $meta) {
519 # changed, we may need to process
520
521 my @data;
522 my $md5;
523
524 for (0 .. $#$src) {
525 0 <= aio_load $src->[$_], $data[$_]
526 or Carp::croak "$src->[$_]: $!";
527 }
528
529 # if processing is expensive, check
530 # checksum first
531 if (1) {
532 $md5 =
533 join "\x00",
534 $processversion,
535 map {
536 Coro::cede;
537 ($src->[$_], Digest::MD5::md5_hex $data[$_])
538 } 0.. $#$src;
539
540
541 my $dbmd5 = db_get cache => "$id/md5";
542 if ($dbmd5 eq $md5) {
543 db_put cache => "$id/meta", $meta;
544
545 return db_get cache => "$id/data";
546 }
547 }
548
549 my $t1 = Time::HiRes::time;
550 my $data = $process->(\@data);
551 my $t2 = Time::HiRes::time;
552
553 warn "cache: '$id' processed in ", $t2 - $t1, "s\n";
554
555 db_put cache => "$id/data", $data;
556 db_put cache => "$id/md5" , $md5;
557 db_put cache => "$id/meta", $meta;
558
559 return $data;
560 }
561
562 db_get cache => "$id/data"
563}
564
565=item cf::datalog type => key => value, ...
566
567Log a datalog packet of the given type with the given key-value pairs.
568
569=cut
570
571sub datalog($@) {
572 my ($type, %kv) = @_;
573 warn "DATALOG ", JSON::XS->new->ascii->encode ({ %kv, type => $type });
574}
575
202=back 576=back
203 577
204=cut 578=cut
205 579
206############################################################################# 580#############################################################################
211attach callbacks/event handlers (a collection of which is called an "attachment") 585attach callbacks/event handlers (a collection of which is called an "attachment")
212to it. All such attachable objects support the following methods. 586to it. All such attachable objects support the following methods.
213 587
214In the following description, CLASS can be any of C<global>, C<object> 588In the following description, CLASS can be any of C<global>, C<object>
215C<player>, C<client> or C<map> (i.e. the attachable objects in 589C<player>, C<client> or C<map> (i.e. the attachable objects in
216crossfire+). 590Crossfire TRT).
217 591
218=over 4 592=over 4
219 593
220=item $attachable->attach ($attachment, key => $value...) 594=item $attachable->attach ($attachment, key => $value...)
221 595
335our @CB_TYPE = (); # registry for type (cf-object class) based events 709our @CB_TYPE = (); # registry for type (cf-object class) based events
336our @CB_MAP = (); 710our @CB_MAP = ();
337 711
338my %attachment; 712my %attachment;
339 713
714sub cf::attachable::thawer_merge {
715 # simply override everything except _meta
716 local $_[0]{_meta};
717 %{$_[0]} = %{$_[1]};
718}
719
340sub _attach_cb($$$$) { 720sub _attach_cb($$$$) {
341 my ($registry, $event, $prio, $cb) = @_; 721 my ($registry, $event, $prio, $cb) = @_;
342 722
343 use sort 'stable'; 723 use sort 'stable';
344 724
378 $registry = $CB_TYPE[$object_type] ||= []; 758 $registry = $CB_TYPE[$object_type] ||= [];
379 759
380 } elsif ($type eq "subtype") { 760 } elsif ($type eq "subtype") {
381 defined $object_type or Carp::croak "subtype specified without type"; 761 defined $object_type or Carp::croak "subtype specified without type";
382 my $object_subtype = shift @arg; 762 my $object_subtype = shift @arg;
383 $registry = $CB_TYPE[$object_type + $object_subtype * NUM_SUBTYPES] ||= []; 763 $registry = $CB_TYPE[$object_type + $object_subtype * NUM_TYPES] ||= [];
384 764
385 } elsif ($type eq "package") { 765 } elsif ($type eq "package") {
386 my $pkg = shift @arg; 766 my $pkg = shift @arg;
387 767
388 while (my ($name, $id) = each %cb_id) { 768 while (my ($name, $id) = each %cb_id) {
417 _attach $registry, $klass, @attach; 797 _attach $registry, $klass, @attach;
418 } 798 }
419 799
420 $obj->{$name} = \%arg; 800 $obj->{$name} = \%arg;
421 } else { 801 } else {
422 warn "object uses attachment '$name' that is not available, postponing.\n"; 802 warn "object uses attachment '$name' which is not available, postponing.\n";
423 } 803 }
424 804
425 $obj->{_attachment}{$name} = undef; 805 $obj->{_attachment}{$name} = undef;
426} 806}
427 807
429 if (ref $_[0]) { 809 if (ref $_[0]) {
430 _object_attach @_; 810 _object_attach @_;
431 } else { 811 } else {
432 _attach shift->_attach_registry, @_; 812 _attach shift->_attach_registry, @_;
433 } 813 }
814 _recalc_want;
434}; 815};
435 816
436# all those should be optimised 817# all those should be optimised
437sub cf::attachable::detach { 818sub cf::attachable::detach {
438 my ($obj, $name) = @_; 819 my ($obj, $name) = @_;
441 delete $obj->{_attachment}{$name}; 822 delete $obj->{_attachment}{$name};
442 reattach ($obj); 823 reattach ($obj);
443 } else { 824 } else {
444 Carp::croak "cannot, currently, detach class attachments"; 825 Carp::croak "cannot, currently, detach class attachments";
445 } 826 }
827 _recalc_want;
446}; 828};
447 829
448sub cf::attachable::attached { 830sub cf::attachable::attached {
449 my ($obj, $name) = @_; 831 my ($obj, $name) = @_;
450 832
515# object support 897# object support
516 898
517sub reattach { 899sub reattach {
518 # basically do the same as instantiate, without calling instantiate 900 # basically do the same as instantiate, without calling instantiate
519 my ($obj) = @_; 901 my ($obj) = @_;
902
903 bless $obj, ref $obj; # re-bless in case extensions have been reloaded
520 904
521 my $registry = $obj->registry; 905 my $registry = $obj->registry;
522 906
523 @$registry = (); 907 @$registry = ();
524 908
563); 947);
564 948
565sub object_freezer_save { 949sub object_freezer_save {
566 my ($filename, $rdata, $objs) = @_; 950 my ($filename, $rdata, $objs) = @_;
567 951
952 sync_job {
568 if (length $$rdata) { 953 if (length $$rdata) {
569 warn sprintf "saving %s (%d,%d)\n", 954 warn sprintf "saving %s (%d,%d)\n",
570 $filename, length $$rdata, scalar @$objs; 955 $filename, length $$rdata, scalar @$objs;
571 956
572 if (open my $fh, ">:raw", "$filename~") { 957 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
573 chmod SAVE_MODE, $fh;
574 syswrite $fh, $$rdata;
575 close $fh;
576
577 if (@$objs && open my $fh, ">:raw", "$filename.pst~") {
578 chmod SAVE_MODE, $fh; 958 chmod SAVE_MODE, $fh;
579 syswrite $fh, Storable::nfreeze { version => 1, objs => $objs }; 959 aio_write $fh, 0, (length $$rdata), $$rdata, 0;
960 aio_fsync $fh if $cf::USE_FSYNC;
580 close $fh; 961 close $fh;
962
963 if (@$objs) {
964 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) {
965 chmod SAVE_MODE, $fh;
966 my $data = Storable::nfreeze { version => 1, objs => $objs };
967 aio_write $fh, 0, (length $data), $data, 0;
968 aio_fsync $fh if $cf::USE_FSYNC;
969 close $fh;
581 rename "$filename.pst~", "$filename.pst"; 970 aio_rename "$filename.pst~", "$filename.pst";
971 }
972 } else {
973 aio_unlink "$filename.pst";
974 }
975
976 aio_rename "$filename~", $filename;
582 } else { 977 } else {
583 unlink "$filename.pst"; 978 warn "FATAL: $filename~: $!\n";
584 } 979 }
585
586 rename "$filename~", $filename;
587 } else { 980 } else {
588 warn "FATAL: $filename~: $!\n";
589 }
590 } else {
591 unlink $filename; 981 aio_unlink $filename;
592 unlink "$filename.pst"; 982 aio_unlink "$filename.pst";
983 }
593 } 984 }
594} 985}
595 986
596sub object_freezer_as_string { 987sub object_freezer_as_string {
597 my ($rdata, $objs) = @_; 988 my ($rdata, $objs) = @_;
602} 993}
603 994
604sub object_thawer_load { 995sub object_thawer_load {
605 my ($filename) = @_; 996 my ($filename) = @_;
606 997
607 local $/; 998 my ($data, $av);
608 999
609 my $av; 1000 (aio_load $filename, $data) >= 0
1001 or return;
610 1002
611 #TODO: use sysread etc. 1003 unless (aio_stat "$filename.pst") {
612 if (open my $data, "<:raw:perlio", $filename) { 1004 (aio_load "$filename.pst", $av) >= 0
613 $data = <$data>; 1005 or return;
614 if (open my $pst, "<:raw:perlio", "$filename.pst") {
615 $av = eval { (Storable::thaw <$pst>)->{objs} }; 1006 $av = eval { (Storable::thaw $av)->{objs} };
616 } 1007 }
1008
1009 warn sprintf "loading %s (%d)\n",
1010 $filename, length $data, scalar @{$av || []};
617 return ($data, $av); 1011 return ($data, $av);
618 }
619
620 ()
621} 1012}
1013
1014=head2 COMMAND CALLBACKS
1015
1016=over 4
1017
1018=cut
622 1019
623############################################################################# 1020#############################################################################
624# command handling &c 1021# command handling &c
625 1022
626=item cf::register_command $name => \&callback($ob,$args); 1023=item cf::register_command $name => \&callback($ob,$args);
639 push @{ $COMMAND{$name} }, [$caller, $cb]; 1036 push @{ $COMMAND{$name} }, [$caller, $cb];
640} 1037}
641 1038
642=item cf::register_extcmd $name => \&callback($pl,$packet); 1039=item cf::register_extcmd $name => \&callback($pl,$packet);
643 1040
644Register a callbackf ro execution when the client sends an extcmd packet. 1041Register a callback for execution when the client sends an (synchronous)
1042extcmd packet. Ext commands will be processed in the order they are
1043received by the server, like other user commands. The first argument is
1044the logged-in player. Ext commands can only be processed after a player
1045has logged in successfully.
645 1046
646If the callback returns something, it is sent back as if reply was being 1047If the callback returns something, it is sent back as if reply was being
647called. 1048called.
648 1049
1050=item cf::register_exticmd $name => \&callback($ns,$packet);
1051
1052Register a callback for execution when the client sends an (asynchronous)
1053exticmd packet. Exti commands are processed by the server as soon as they
1054are received, i.e. out of order w.r.t. other commands. The first argument
1055is a client socket. Exti commands can be received anytime, even before
1056log-in.
1057
1058If the callback returns something, it is sent back as if reply was being
1059called.
1060
649=cut 1061=cut
650 1062
651sub register_extcmd { 1063sub register_extcmd {
652 my ($name, $cb) = @_; 1064 my ($name, $cb) = @_;
653 1065
654 my $caller = caller;
655 #warn "registering extcmd '$name' to '$caller'";
656
657 $EXTCMD{$name} = [$cb, $caller]; 1066 $EXTCMD{$name} = $cb;
1067}
1068
1069sub register_exticmd {
1070 my ($name, $cb) = @_;
1071
1072 $EXTICMD{$name} = $cb;
658} 1073}
659 1074
660cf::player->attach ( 1075cf::player->attach (
661 on_command => sub { 1076 on_command => sub {
662 my ($pl, $name, $params) = @_; 1077 my ($pl, $name, $params) = @_;
671 cf::override; 1086 cf::override;
672 }, 1087 },
673 on_extcmd => sub { 1088 on_extcmd => sub {
674 my ($pl, $buf) = @_; 1089 my ($pl, $buf) = @_;
675 1090
676 my $msg = eval { from_json $buf }; 1091 my $msg = eval { $pl->ns->{json_coder}->decode ($buf) };
677 1092
678 if (ref $msg) { 1093 if (ref $msg) {
679 if (my $cb = $EXTCMD{$msg->{msgtype}}) { 1094 if (my $cb = $EXTCMD{$msg->{msgtype}}) {
680 if (my %reply = $cb->[0]->($pl, $msg)) { 1095 if (my %reply = $cb->($pl, $msg)) {
681 $pl->ext_reply ($msg->{msgid}, %reply); 1096 $pl->ext_reply ($msg->{msgid}, %reply);
682 } 1097 }
683 } 1098 }
684 } else { 1099 } else {
685 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n"; 1100 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
687 1102
688 cf::override; 1103 cf::override;
689 }, 1104 },
690); 1105);
691 1106
1107sub load_extensions {
1108 cf::sync_job {
1109 my %todo;
1110
1111 for my $path (<$LIBDIR/*.ext>) {
1112 next unless -r $path;
1113
1114 $path =~ /([^\/\\]+)\.ext$/ or die "$path";
1115 my $base = $1;
1116 my $pkg = $1;
1117 $pkg =~ s/[^[:word:]]/_/g;
1118 $pkg = "ext::$pkg";
1119
1120 open my $fh, "<:utf8", $path
1121 or die "$path: $!";
1122
1123 my $source = do { local $/; <$fh> };
1124
1125 my %ext = (
1126 path => $path,
1127 base => $base,
1128 pkg => $pkg,
1129 );
1130
1131 $ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 }
1132 if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m;
1133
1134 $ext{source} =
1135 "package $pkg; use strict; use utf8;\n"
1136 . "#line 1 \"$path\"\n{\n"
1137 . $source
1138 . "\n};\n1";
1139
1140 $todo{$base} = \%ext;
1141 }
1142
1143 my %done;
1144 while (%todo) {
1145 my $progress;
1146
1147 while (my ($k, $v) = each %todo) {
1148 for (split /,\s*/, $v->{meta}{depends}) {
1149 goto skip
1150 unless exists $done{$_};
1151 }
1152
1153 warn "... loading '$k' into '$v->{pkg}'\n";
1154
1155 unless (eval $v->{source}) {
1156 my $msg = $@ ? "$v->{path}: $@\n"
1157 : "$v->{base}: extension inactive.\n";
1158
1159 if (exists $v->{meta}{mandatory}) {
1160 warn $msg;
1161 warn "mandatory extension failed to load, exiting.\n";
1162 exit 1;
1163 }
1164
1165 warn $msg;
1166 }
1167
1168 $done{$k} = delete $todo{$k};
1169 push @EXTS, $v->{pkg};
1170 $progress = 1;
1171 }
1172
1173 skip:
1174 die "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n"
1175 unless $progress;
1176 }
1177 };
1178}
1179
1180#############################################################################
1181
1182=back
1183
1184=head2 CORE EXTENSIONS
1185
1186Functions and methods that extend core crossfire objects.
1187
1188=cut
1189
1190package cf::player;
1191
1192use Coro::AIO;
1193
1194=head3 cf::player
1195
1196=over 4
1197
1198=item cf::player::find $login
1199
1200Returns the given player object, loading it if necessary (might block).
1201
1202=cut
1203
1204sub playerdir($) {
1205 "$PLAYERDIR/"
1206 . (ref $_[0] ? $_[0]->ob->name : $_[0])
1207}
1208
1209sub path($) {
1210 my $login = ref $_[0] ? $_[0]->ob->name : $_[0];
1211
1212 (playerdir $login) . "/playerdata"
1213}
1214
1215sub find_active($) {
1216 $cf::PLAYER{$_[0]}
1217 and $cf::PLAYER{$_[0]}->active
1218 and $cf::PLAYER{$_[0]}
1219}
1220
1221sub exists($) {
1222 my ($login) = @_;
1223
1224 $cf::PLAYER{$login}
1225 or cf::sync_job { !aio_stat path $login }
1226}
1227
1228sub find($) {
1229 return $cf::PLAYER{$_[0]} || do {
1230 my $login = $_[0];
1231
1232 my $guard = cf::lock_acquire "user_find:$login";
1233
1234 $cf::PLAYER{$_[0]} || do {
1235 # rename old playerfiles to new ones
1236 #TODO: remove when no longer required
1237 aio_link +(playerdir $login) . "/$login.pl.pst", (playerdir $login) . "/playerdata.pst";
1238 aio_link +(playerdir $login) . "/$login.pl" , (playerdir $login) . "/playerdata";
1239 aio_unlink +(playerdir $login) . "/$login.pl.pst";
1240 aio_unlink +(playerdir $login) . "/$login.pl";
1241
1242 my $pl = load_pl path $login
1243 or return;
1244 $cf::PLAYER{$login} = $pl
1245 }
1246 }
1247}
1248
1249sub save($) {
1250 my ($pl) = @_;
1251
1252 return if $pl->{deny_save};
1253
1254 my $path = path $pl;
1255 my $guard = cf::lock_acquire "user_save:$path";
1256
1257 return if $pl->{deny_save};
1258
1259 aio_mkdir playerdir $pl, 0770;
1260 $pl->{last_save} = $cf::RUNTIME;
1261
1262 $pl->save_pl ($path);
1263 Coro::cede;
1264}
1265
1266sub new($) {
1267 my ($login) = @_;
1268
1269 my $self = create;
1270
1271 $self->ob->name ($login);
1272 $self->{deny_save} = 1;
1273
1274 $cf::PLAYER{$login} = $self;
1275
1276 $self
1277}
1278
1279=item $pl->quit_character
1280
1281Nukes the player without looking back. If logged in, the connection will
1282be destroyed. May block for a long time.
1283
1284=cut
1285
1286sub quit_character {
1287 my ($pl) = @_;
1288
1289 my $name = $pl->ob->name;
1290
1291 $pl->{deny_save} = 1;
1292 $pl->password ("*"); # this should lock out the player until we nuked the dir
1293
1294 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active;
1295 $pl->deactivate;
1296 $pl->invoke (cf::EVENT_PLAYER_QUIT);
1297 $pl->ns->destroy if $pl->ns;
1298
1299 my $path = playerdir $pl;
1300 my $temp = "$path~$cf::RUNTIME~deleting~";
1301 aio_rename $path, $temp;
1302 delete $cf::PLAYER{$pl->ob->name};
1303 $pl->destroy;
1304
1305 my $prefix = qr<^~\Q$name\E/>;
1306
1307 # nuke player maps
1308 $cf::MAP{$_}->nuke for grep /$prefix/, keys %cf::MAP;
1309
1310 IO::AIO::aio_rmtree $temp;
1311}
1312
1313=item $pl->kick
1314
1315Kicks a player out of the game. This destroys the connection.
1316
1317=cut
1318
1319sub kick {
1320 my ($pl, $kicker) = @_;
1321
1322 $pl->invoke (cf::EVENT_PLAYER_KICK, $kicker);
1323 $pl->killer ("kicked");
1324 $pl->ns->destroy;
1325}
1326
1327=item cf::player::list_logins
1328
1329Returns am arrayref of all valid playernames in the system, can take a
1330while and may block, so not sync_job-capable, ever.
1331
1332=cut
1333
1334sub list_logins {
1335 my $dirs = aio_readdir $PLAYERDIR
1336 or return [];
1337
1338 my @logins;
1339
1340 for my $login (@$dirs) {
1341 my $fh = aio_open path $login, Fcntl::O_RDONLY, 0 or next;
1342 aio_read $fh, 0, 512, my $buf, 0 or next;
1343 $buf !~ /^password -------------$/m or next; # official not-valid tag
1344
1345 utf8::decode $login;
1346 push @logins, $login;
1347 }
1348
1349 \@logins
1350}
1351
1352=item $player->maps
1353
1354Returns an arrayref of map paths that are private for this
1355player. May block.
1356
1357=cut
1358
1359sub maps($) {
1360 my ($pl) = @_;
1361
1362 $pl = ref $pl ? $pl->ob->name : $pl;
1363
1364 my $files = aio_readdir playerdir $pl
1365 or return;
1366
1367 my @paths;
1368
1369 for (@$files) {
1370 utf8::decode $_;
1371 next if /\.(?:pl|pst)$/;
1372 next unless /^$PATH_SEP/o;
1373
1374 push @paths, cf::map::normalise "~$pl/$_";
1375 }
1376
1377 \@paths
1378}
1379
1380=item $protocol_xml = $player->expand_cfpod ($crossfire_pod)
1381
1382Expand crossfire pod fragments into protocol xml.
1383
1384=cut
1385
1386sub expand_cfpod {
1387 ((my $self), (local $_)) = @_;
1388
1389 # escape & and <
1390 s/&/&amp;/g;
1391 s/(?<![BIUGH])</&lt;/g;
1392
1393 # this is buggy, it needs to properly take care of nested <'s
1394
1395 1 while
1396 # replace B<>, I<>, U<> etc.
1397 s/B<([^\>]*)>/<b>$1<\/b>/
1398 || s/I<([^\>]*)>/<i>$1<\/i>/
1399 || s/U<([^\>]*)>/<u>$1<\/u>/
1400 # replace G<male|female> tags
1401 || s{G<([^>|]*)\|([^>]*)>}{
1402 $self->gender ? $2 : $1
1403 }ge
1404 # replace H<hint text>
1405 || s{H<([^\>]*)>}
1406 {
1407 ("<fg name=\"lightblue\">[$1 (Use hintmode to suppress hints)]</fg>",
1408 "<fg name=\"lightblue\">[Hint suppressed, see hintmode]</fg>",
1409 "")
1410 [$self->{hintmode}]
1411 }ge;
1412
1413 # create single paragraphs (very hackish)
1414 s/(?<=\S)\n(?=\w)/ /g;
1415
1416 # compress some whitespace
1417 1 while s/\s*\n\s*\n\s*/\n/;
1418
1419 $_
1420}
1421
1422sub hintmode {
1423 warn "hm<$_[0] $_[1]>\n";#d#
1424 $_[0]{hintmode} = $_[1] if @_ > 1;
1425 $_[0]{hintmode}
1426}
1427
1428=item $player->ext_reply ($msgid, %msg)
1429
1430Sends an ext reply to the player.
1431
1432=cut
1433
1434sub ext_reply($$%) {
1435 my ($self, $id, %msg) = @_;
1436
1437 $msg{msgid} = $id;
1438 $self->send ("ext " . $self->ns->{json_coder}->encode (\%msg));
1439}
1440
1441=item $player->ext_event ($type, %msg)
1442
1443Sends an ext event to the client.
1444
1445=cut
1446
1447sub ext_event($$%) {
1448 my ($self, $type, %msg) = @_;
1449
1450 $self->ns->ext_event ($type, %msg);
1451}
1452
1453=head3 cf::region
1454
1455=over 4
1456
1457=cut
1458
1459package cf::region;
1460
1461=item cf::region::find_by_path $path
1462
1463Tries to decuce the likely region for a map knowing only its path.
1464
1465=cut
1466
1467sub find_by_path($) {
1468 my ($path) = @_;
1469
1470 my ($match, $specificity);
1471
1472 for my $region (list) {
1473 if ($region->match && $path =~ $region->match) {
1474 ($match, $specificity) = ($region, $region->specificity)
1475 if $region->specificity > $specificity;
1476 }
1477 }
1478
1479 $match
1480}
1481
1482=back
1483
1484=head3 cf::map
1485
1486=over 4
1487
1488=cut
1489
1490package cf::map;
1491
1492use Fcntl;
1493use Coro::AIO;
1494
1495use overload
1496 '""' => \&as_string,
1497 fallback => 1;
1498
1499our $MAX_RESET = 3600;
1500our $DEFAULT_RESET = 3000;
1501
1502sub generate_random_map {
1503 my ($self, $rmp) = @_;
1504 # mit "rum" bekleckern, nicht
1505 $self->_create_random_map (
1506 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle},
1507 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle},
1508 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map},
1509 $rmp->{exit_on_final_map},
1510 $rmp->{xsize}, $rmp->{ysize},
1511 $rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3},
1512 $rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase},
1513 $rmp->{dungeon_level}, $rmp->{dungeon_depth}, $rmp->{decoroptions}, $rmp->{orientation},
1514 $rmp->{origin_y}, $rmp->{origin_x}, $rmp->{random_seed}, $rmp->{total_map_hp},
1515 $rmp->{map_layout_style}, $rmp->{treasureoptions}, $rmp->{symmetry_used},
1516 (cf::region::find $rmp->{region}), $rmp->{custom}
1517 )
1518}
1519
1520=item cf::map->register ($regex, $prio)
1521
1522Register a handler for the map path matching the given regex at the
1523givne priority (higher is better, built-in handlers have priority 0, the
1524default).
1525
1526=cut
1527
692sub register { 1528sub register {
1529 my (undef, $regex, $prio) = @_;
1530 my $pkg = caller;
1531
1532 no strict;
1533 push @{"$pkg\::ISA"}, __PACKAGE__;
1534
1535 $EXT_MAP{$pkg} = [$prio, qr<$regex>];
1536}
1537
1538# also paths starting with '/'
1539$EXT_MAP{"cf::map"} = [0, qr{^(?=/)}];
1540
1541sub thawer_merge {
693 my ($base, $pkg) = @_; 1542 my ($self, $merge) = @_;
694 1543
695 #TODO 1544 # we have to keep some variables in memory intact
696} 1545 local $self->{path};
1546 local $self->{load_path};
697 1547
698sub load_extension { 1548 $self->SUPER::thawer_merge ($merge);
1549}
1550
1551sub normalise {
699 my ($path) = @_; 1552 my ($path, $base) = @_;
700 1553
701 $path =~ /([^\/\\]+)\.ext$/ or die "$path"; 1554 $path = "$path"; # make sure its a string
702 my $base = $1;
703 my $pkg = $1;
704 $pkg =~ s/[^[:word:]]/_/g;
705 $pkg = "ext::$pkg";
706 1555
707 warn "loading '$path' into '$pkg'\n"; 1556 $path =~ s/\.map$//;
708 1557
709 open my $fh, "<:utf8", $path 1558 # map plan:
710 or die "$path: $!"; 1559 #
1560 # /! non-realised random map exit (special hack!)
1561 # {... are special paths that are not being touched
1562 # ?xxx/... are special absolute paths
1563 # ?random/... random maps
1564 # /... normal maps
1565 # ~user/... per-player map of a specific user
711 1566
712 my $source = 1567 $path =~ s/$PATH_SEP/\//go;
713 "package $pkg; use strict; use utf8;\n"
714 . "#line 1 \"$path\"\n{\n"
715 . (do { local $/; <$fh> })
716 . "\n};\n1";
717 1568
718 eval $source 1569 # treat it as relative path if it starts with
719 or die $@ ? "$path: $@\n" 1570 # something that looks reasonable
720 : "extension disabled.\n"; 1571 if ($path =~ m{^(?:\./|\.\./|\w)}) {
1572 $base or Carp::carp "normalise called with relative path and no base: '$path'";
721 1573
722 push @exts, $pkg; 1574 $base =~ s{[^/]+/?$}{};
723 $ext_pkg{$base} = $pkg; 1575 $path = "$base/$path";
724
725# no strict 'refs';
726# @{"$pkg\::ISA"} = ext::;
727
728 register $base, $pkg;
729}
730
731sub unload_extension {
732 my ($pkg) = @_;
733
734 warn "removing extension $pkg\n";
735
736 # remove hooks
737 #TODO
738# for my $idx (0 .. $#PLUGIN_EVENT) {
739# delete $hook[$idx]{$pkg};
740# } 1576 }
741 1577
742 # remove commands 1578 for ($path) {
743 for my $name (keys %COMMAND) { 1579 redo if s{//}{/};
744 my @cb = grep $_->[0] ne $pkg, @{ $COMMAND{$name} }; 1580 redo if s{/\.?/}{/};
1581 redo if s{/[^/]+/\.\./}{/};
1582 }
745 1583
746 if (@cb) { 1584 $path
747 $COMMAND{$name} = \@cb; 1585}
1586
1587sub new_from_path {
1588 my (undef, $path, $base) = @_;
1589
1590 return $path if UNIVERSAL::isa $path, "cf::map"; # already a map object
1591
1592 $path = normalise $path, $base;
1593
1594 for my $pkg (sort { $EXT_MAP{$b}[0] <=> $EXT_MAP{$a}[0] } keys %EXT_MAP) {
1595 if ($path =~ $EXT_MAP{$pkg}[1]) {
1596 my $self = bless cf::map::new, $pkg;
1597 $self->{path} = $path; $self->path ($path);
1598 $self->init; # pass $1 etc.
1599 return $self;
1600 }
1601 }
1602
1603 Carp::carp "unable to resolve path '$path' (base '$base').";
1604 ()
1605}
1606
1607sub init {
1608 my ($self) = @_;
1609
1610 $self
1611}
1612
1613sub as_string {
1614 my ($self) = @_;
1615
1616 "$self->{path}"
1617}
1618
1619# the displayed name, this is a one way mapping
1620sub visible_name {
1621 &as_string
1622}
1623
1624# the original (read-only) location
1625sub load_path {
1626 my ($self) = @_;
1627
1628 "$MAPDIR/$self->{path}.map"
1629}
1630
1631# the temporary/swap location
1632sub save_path {
1633 my ($self) = @_;
1634
1635 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g;
1636 "$TMPDIR/$path.map"
1637}
1638
1639# the unique path, undef == no special unique path
1640sub uniq_path {
1641 my ($self) = @_;
1642
1643 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g;
1644 "$UNIQUEDIR/$path"
1645}
1646
1647# and all this just because we cannot iterate over
1648# all maps in C++...
1649sub change_all_map_light {
1650 my ($change) = @_;
1651
1652 $_->change_map_light ($change)
1653 for grep $_->outdoor, values %cf::MAP;
1654}
1655
1656sub decay_objects {
1657 my ($self) = @_;
1658
1659 return if $self->{deny_reset};
1660
1661 $self->do_decay_objects;
1662}
1663
1664sub unlink_save {
1665 my ($self) = @_;
1666
1667 utf8::encode (my $save = $self->save_path);
1668 IO::AIO::aioreq_pri 4; Coro::AIO::aio_unlink $save;
1669 IO::AIO::aioreq_pri 4; Coro::AIO::aio_unlink "$save.pst";
1670}
1671
1672sub load_header_from($) {
1673 my ($self, $path) = @_;
1674
1675 utf8::encode $path;
1676 #aio_open $path, O_RDONLY, 0
1677 # or return;
1678
1679 $self->_load_header ($path)
1680 or return;
1681
1682 $self->{load_path} = $path;
1683
1684 1
1685}
1686
1687sub load_header_orig {
1688 my ($self) = @_;
1689
1690 $self->load_header_from ($self->load_path)
1691}
1692
1693sub load_header_temp {
1694 my ($self) = @_;
1695
1696 $self->load_header_from ($self->save_path)
1697}
1698
1699sub prepare_temp {
1700 my ($self) = @_;
1701
1702 $self->last_access ((delete $self->{last_access})
1703 || $cf::RUNTIME); #d#
1704 # safety
1705 $self->{instantiate_time} = $cf::RUNTIME
1706 if $self->{instantiate_time} > $cf::RUNTIME;
1707}
1708
1709sub prepare_orig {
1710 my ($self) = @_;
1711
1712 $self->{load_original} = 1;
1713 $self->{instantiate_time} = $cf::RUNTIME;
1714 $self->last_access ($cf::RUNTIME);
1715 $self->instantiate;
1716}
1717
1718sub load_header {
1719 my ($self) = @_;
1720
1721 if ($self->load_header_temp) {
1722 $self->prepare_temp;
748 } else { 1723 } else {
749 delete $COMMAND{$name}; 1724 $self->load_header_orig
750 } 1725 or return;
1726 $self->prepare_orig;
1727 }
1728
1729 $self->{deny_reset} = 1
1730 if $self->no_reset;
1731
1732 $self->default_region (cf::region::find_by_path $self->{path})
1733 unless $self->default_region;
1734
751 } 1735 1
1736}
752 1737
753 # remove extcmds 1738sub find;
754 for my $name (grep $EXTCMD{$_}[1] eq $pkg, keys %EXTCMD) { 1739sub find {
755 delete $EXTCMD{$name}; 1740 my ($path, $origin) = @_;
1741
1742 $path = normalise $path, $origin && $origin->path;
1743
1744 cf::lock_wait "map_find:$path";
1745
1746 $cf::MAP{$path} || do {
1747 my $guard = cf::lock_acquire "map_find:$path";
1748 my $map = new_from_path cf::map $path
1749 or return;
1750
1751 $map->{last_save} = $cf::RUNTIME;
1752
1753 $map->load_header
1754 or return;
1755
1756 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?)
1757 # doing this can freeze the server in a sync job, obviously
1758 #$cf::WAIT_FOR_TICK->wait;
1759 $map->reset;
1760 undef $guard;
1761 return find $path;
1762 }
1763
1764 $cf::MAP{$path} = $map
1765 }
1766}
1767
1768sub pre_load { }
1769sub post_load { }
1770
1771sub load {
1772 my ($self) = @_;
1773
1774 local $self->{deny_reset} = 1; # loading can take a long time
1775
1776 my $path = $self->{path};
1777
756 } 1778 {
1779 my $guard = cf::lock_acquire "map_load:$path";
757 1780
758 if (my $cb = $pkg->can ("unload")) { 1781 return if $self->in_memory != cf::MAP_SWAPPED;
759 eval { 1782
760 $cb->($pkg); 1783 $self->in_memory (cf::MAP_LOADING);
1784
1785 $self->alloc;
1786
1787 $self->pre_load;
1788 Coro::cede;
1789
1790 $self->_load_objects ($self->{load_path}, 1)
1791 or return;
1792
1793 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1)
1794 if delete $self->{load_original};
1795
1796 if (my $uniq = $self->uniq_path) {
1797 utf8::encode $uniq;
1798 if (aio_open $uniq, O_RDONLY, 0) {
1799 $self->clear_unique_items;
1800 $self->_load_objects ($uniq, 0);
761 1 1801 }
762 } or warn "$pkg unloaded, but with errors: $@"; 1802 }
763 }
764 1803
765 Symbol::delete_package $pkg; 1804 Coro::cede;
766} 1805 # now do the right thing for maps
1806 $self->link_multipart_objects;
1807 $self->difficulty ($self->estimate_difficulty)
1808 unless $self->difficulty;
1809 Coro::cede;
767 1810
768sub load_extensions { 1811 unless ($self->{deny_activate}) {
769 for my $ext (<$LIBDIR/*.ext>) { 1812 $self->decay_objects;
770 next unless -r $ext; 1813 $self->fix_auto_apply;
771 eval { 1814 $self->update_buttons;
772 load_extension $ext; 1815 Coro::cede;
773 1 1816 $self->set_darkness_map;
774 } or warn "$ext not loaded: $@"; 1817 Coro::cede;
775 } 1818 $self->activate;
776} 1819 }
777 1820
778############################################################################# 1821 $self->in_memory (cf::MAP_IN_MEMORY);
779# load/save/clean perl data associated with a map 1822 }
780 1823
781*cf::mapsupport::on_clean = sub { 1824 $self->post_load;
1825}
1826
1827sub customise_for {
1828 my ($self, $ob) = @_;
1829
1830 return find "~" . $ob->name . "/" . $self->{path}
1831 if $self->per_player;
1832
1833# return find "?party/" . $ob->name . "/" . $self->{path}
1834# if $self->per_party;
1835
1836 $self
1837}
1838
1839# find and load all maps in the 3x3 area around a map
1840sub load_diag {
782 my ($map) = @_; 1841 my ($map) = @_;
783 1842
784 my $path = $map->tmpname; 1843 my @diag; # diagonal neighbours
785 defined $path or return;
786 1844
787 unlink "$path.pst"; 1845 for (0 .. 3) {
788}; 1846 my $neigh = $map->tile_path ($_)
1847 or next;
1848 $neigh = find $neigh, $map
1849 or next;
1850 $neigh->load;
789 1851
790cf::map->attach (prio => -10000, package => cf::mapsupport::); 1852 push @diag, [$neigh->tile_path (($_ + 3) % 4), $neigh],
1853 [$neigh->tile_path (($_ + 1) % 4), $neigh];
1854 }
791 1855
792############################################################################# 1856 for (@diag) {
793# load/save perl data associated with player->ob objects 1857 my $neigh = find @$_
794 1858 or next;
795sub all_objects(@) { 1859 $neigh->load;
796 @_, map all_objects ($_->inv), @_ 1860 }
797} 1861}
798 1862
799# TODO: compatibility cruft, remove when no longer needed 1863sub find_sync {
800cf::player->attach ( 1864 my ($path, $origin) = @_;
801 on_load => sub {
802 my ($pl, $path) = @_;
803 1865
804 for my $o (all_objects $pl->ob) { 1866 cf::sync_job { find $path, $origin }
805 if (my $value = $o->get_ob_key_value ("_perl_data")) { 1867}
806 $o->set_ob_key_value ("_perl_data");
807 1868
808 %$o = %{ Storable::thaw pack "H*", $value }; 1869sub do_load_sync {
1870 my ($map) = @_;
1871
1872 cf::sync_job { $map->load };
1873}
1874
1875our %MAP_PREFETCH;
1876our $MAP_PREFETCHER = undef;
1877
1878sub find_async {
1879 my ($path, $origin) = @_;
1880
1881 $path = normalise $path, $origin && $origin->{path};
1882
1883 if (my $map = $cf::MAP{$path}) {
1884 return $map if $map->in_memory == cf::MAP_IN_MEMORY;
1885 }
1886
1887 undef $MAP_PREFETCH{$path};
1888 $MAP_PREFETCHER ||= cf::async {
1889 while (%MAP_PREFETCH) {
1890 for my $path (keys %MAP_PREFETCH) {
1891 my $map = find $path
1892 or next;
1893 $map->load;
1894
1895 delete $MAP_PREFETCH{$path};
809 } 1896 }
810 } 1897 }
1898 undef $MAP_PREFETCHER;
1899 };
1900 $MAP_PREFETCHER->prio (6);
1901
1902 ()
1903}
1904
1905sub save {
1906 my ($self) = @_;
1907
1908 my $lock = cf::lock_acquire "map_data:" . $self->path;
1909
1910 $self->{last_save} = $cf::RUNTIME;
1911
1912 return unless $self->dirty;
1913
1914 my $save = $self->save_path; utf8::encode $save;
1915 my $uniq = $self->uniq_path; utf8::encode $uniq;
1916
1917 $self->{load_path} = $save;
1918
1919 return if $self->{deny_save};
1920
1921 local $self->{last_access} = $self->last_access;#d#
1922
1923 cf::async {
1924 $_->contr->save for $self->players;
1925 };
1926
1927 if ($uniq) {
1928 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS);
1929 $self->_save_objects ($uniq, cf::IO_UNIQUES);
1930 } else {
1931 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES);
811 }, 1932 }
812); 1933}
813 1934
814############################################################################# 1935sub swap_out {
1936 my ($self) = @_;
815 1937
816=head2 CORE EXTENSIONS 1938 # save first because save cedes
1939 $self->save;
817 1940
818Functions and methods that extend core crossfire objects. 1941 my $lock = cf::lock_acquire "map_data:" . $self->path;
819 1942
820=head3 cf::player 1943 return if $self->players;
1944 return if $self->in_memory != cf::MAP_IN_MEMORY;
1945 return if $self->{deny_save};
1946
1947 $self->clear;
1948 $self->in_memory (cf::MAP_SWAPPED);
1949}
1950
1951sub reset_at {
1952 my ($self) = @_;
1953
1954 # TODO: safety, remove and allow resettable per-player maps
1955 return 1e99 if $self->{deny_reset};
1956
1957 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
1958 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET;
1959
1960 $time + $to
1961}
1962
1963sub should_reset {
1964 my ($self) = @_;
1965
1966 $self->reset_at <= $cf::RUNTIME
1967}
1968
1969sub reset {
1970 my ($self) = @_;
1971
1972 my $lock = cf::lock_acquire "map_data:$self->{path}";
1973
1974 return if $self->players;
1975
1976 warn "resetting map ", $self->path;
1977
1978 $self->in_memory (cf::MAP_SWAPPED);
1979
1980 # need to save uniques path
1981 unless ($self->{deny_save}) {
1982 my $uniq = $self->uniq_path; utf8::encode $uniq;
1983
1984 $self->_save_objects ($uniq, cf::IO_UNIQUES)
1985 if $uniq;
1986 }
1987
1988 delete $cf::MAP{$self->path};
1989
1990 $self->clear;
1991
1992 $_->clear_links_to ($self) for values %cf::MAP;
1993
1994 $self->unlink_save;
1995 $self->destroy;
1996}
1997
1998my $nuke_counter = "aaaa";
1999
2000sub nuke {
2001 my ($self) = @_;
2002
2003 delete $cf::MAP{$self->path};
2004
2005 $self->unlink_save;
2006
2007 bless $self, "cf::map";
2008 delete $self->{deny_reset};
2009 $self->{deny_save} = 1;
2010 $self->reset_timeout (1);
2011 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));
2012
2013 $cf::MAP{$self->path} = $self;
2014
2015 $self->reset; # polite request, might not happen
2016}
2017
2018=item $maps = cf::map::tmp_maps
2019
2020Returns an arrayref with all map paths of currently instantiated and saved
2021maps. May block.
2022
2023=cut
2024
2025sub tmp_maps() {
2026 [
2027 map {
2028 utf8::decode $_;
2029 /\.map$/
2030 ? normalise $_
2031 : ()
2032 } @{ aio_readdir $TMPDIR or [] }
2033 ]
2034}
2035
2036=item $maps = cf::map::random_maps
2037
2038Returns an arrayref with all map paths of currently instantiated and saved
2039random maps. May block.
2040
2041=cut
2042
2043sub random_maps() {
2044 [
2045 map {
2046 utf8::decode $_;
2047 /\.map$/
2048 ? normalise "?random/$_"
2049 : ()
2050 } @{ aio_readdir $RANDOMDIR or [] }
2051 ]
2052}
2053
2054=item cf::map::unique_maps
2055
2056Returns an arrayref of paths of all shared maps that have
2057instantiated unique items. May block.
2058
2059=cut
2060
2061sub unique_maps() {
2062 [
2063 map {
2064 utf8::decode $_;
2065 /\.map$/
2066 ? normalise $_
2067 : ()
2068 } @{ aio_readdir $UNIQUEDIR or [] }
2069 ]
2070}
2071
2072package cf;
2073
2074=back
2075
2076=head3 cf::object
2077
2078=cut
2079
2080package cf::object;
821 2081
822=over 4 2082=over 4
823 2083
824=item cf::player::exists $login 2084=item $ob->inv_recursive
825 2085
826Returns true when the given account exists. 2086Returns the inventory of the object _and_ their inventories, recursively.
827 2087
828=cut 2088=cut
829 2089
830sub cf::player::exists($) { 2090sub inv_recursive_;
831 cf::player::find $_[0] 2091sub inv_recursive_ {
832 or -f sprintf "%s/%s/%s/%s.pl", cf::localdir, cf::playerdir, ($_[0]) x 2; 2092 map { $_, inv_recursive_ $_->inv } @_
833} 2093}
834 2094
835=item $player->ext_reply ($msgid, $msgtype, %msg) 2095sub inv_recursive {
836 2096 inv_recursive_ inv $_[0]
837Sends an ext reply to the player.
838
839=cut
840
841sub cf::player::ext_reply($$$%) {
842 my ($self, $id, %msg) = @_;
843
844 $msg{msgid} = $id;
845
846 $self->send ("ext " . to_json \%msg);
847} 2097}
2098
2099package cf;
848 2100
849=back 2101=back
850 2102
851=head3 cf::object::player 2103=head3 cf::object::player
852 2104
868 2120
869 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4; 2121 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4;
870 2122
871 if ($self->{record_replies}) { 2123 if ($self->{record_replies}) {
872 push @{ $self->{record_replies} }, [$npc, $msg, $flags]; 2124 push @{ $self->{record_replies} }, [$npc, $msg, $flags];
2125
873 } else { 2126 } else {
2127 my $pl = $self->contr;
2128
2129 if ($pl->{npc_dialog} && $pl->{npc_dialog}->{id}) {
2130 my $diag = $pl->{npc_dialog};
2131 $diag->{pl}->ext_reply (
2132 $diag->{id},
2133 msgtype => "reply",
2134 msg => $diag->{pl}->expand_cfpod ($msg),
2135 add_topics => []
2136 );
2137
2138 } else {
874 $msg = $npc->name . " says: $msg" if $npc; 2139 $msg = $npc->name . " says: $msg" if $npc;
875 $self->message ($msg, $flags); 2140 $self->message ($msg, $flags);
2141 }
876 } 2142 }
877} 2143}
878 2144
879=item $player_object->may ("access") 2145=item $player_object->may ("access")
880 2146
890 (ref $cf::CFG{"may_$access"} 2156 (ref $cf::CFG{"may_$access"}
891 ? scalar grep $self->name eq $_, @{$cf::CFG{"may_$access"}} 2157 ? scalar grep $self->name eq $_, @{$cf::CFG{"may_$access"}}
892 : $cf::CFG{"may_$access"}) 2158 : $cf::CFG{"may_$access"})
893} 2159}
894 2160
2161=item $player_object->enter_link
2162
2163Freezes the player and moves him/her to a special map (C<{link}>).
2164
2165The player should be reasonably safe there for short amounts of time. You
2166I<MUST> call C<leave_link> as soon as possible, though.
2167
2168Will never block.
2169
2170=item $player_object->leave_link ($map, $x, $y)
2171
2172Moves the player out of the special C<{link}> map onto the specified
2173map. If the map is not valid (or omitted), the player will be moved back
2174to the location he/she was before the call to C<enter_link>, or, if that
2175fails, to the emergency map position.
2176
2177Might block.
2178
2179=cut
2180
2181sub link_map {
2182 unless ($LINK_MAP) {
2183 $LINK_MAP = cf::map::find "{link}"
2184 or cf::cleanup "FATAL: unable to provide {link} map, exiting.";
2185 $LINK_MAP->load;
2186 }
2187
2188 $LINK_MAP
2189}
2190
2191sub cf::object::player::enter_link {
2192 my ($self) = @_;
2193
2194 $self->deactivate_recursive;
2195
2196 return if UNIVERSAL::isa $self->map, "ext::map_link";
2197
2198 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y]
2199 if $self->map && $self->map->{path} ne "{link}";
2200
2201 $self->enter_map ($LINK_MAP || link_map, 10, 10);
2202}
2203
2204sub cf::object::player::leave_link {
2205 my ($self, $map, $x, $y) = @_;
2206
2207 return unless $self->contr->active;
2208
2209 my $link_pos = delete $self->{_link_pos};
2210
2211 unless ($map) {
2212 # restore original map position
2213 ($map, $x, $y) = @{ $link_pos || [] };
2214 $map = cf::map::find $map;
2215
2216 unless ($map) {
2217 ($map, $x, $y) = @$EMERGENCY_POSITION;
2218 $map = cf::map::find $map
2219 or die "FATAL: cannot load emergency map\n";
2220 }
2221 }
2222
2223 ($x, $y) = (-1, -1)
2224 unless (defined $x) && (defined $y);
2225
2226 # use -1 or undef as default coordinates, not 0, 0
2227 ($x, $y) = ($map->enter_x, $map->enter_y)
2228 if $x <=0 && $y <= 0;
2229
2230 $map->load;
2231 $map->load_diag;
2232
2233 return unless $self->contr->active;
2234 $self->activate_recursive;
2235
2236 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
2237 $self->enter_map ($map, $x, $y);
2238}
2239
2240=item $player_object->goto ($path, $x, $y[, $check->($map)])
2241
2242Moves the player to the given map-path and coordinates by first freezing
2243her, loading and preparing them map, calling the provided $check callback
2244that has to return the map if sucecssful, and then unfreezes the player on
2245the new (success) or old (failed) map position.
2246
2247=cut
2248
2249our $GOTOGEN;
2250
2251sub cf::object::player::goto {
2252 my ($self, $path, $x, $y, $check) = @_;
2253
2254 # do generation counting so two concurrent goto's will be executed in-order
2255 my $gen = $self->{_goto_generation} = ++$GOTOGEN;
2256
2257 $self->enter_link;
2258
2259 (async {
2260 my $map = eval {
2261 my $map = cf::map::find $path;
2262
2263 if ($map) {
2264 $map = $map->customise_for ($self);
2265 $map = $check->($map) if $check && $map;
2266 } else {
2267 $self->message ("The exit to '$path' is closed", cf::NDI_UNIQUE | cf::NDI_RED);
2268 }
2269
2270 $map
2271 };
2272
2273 if ($@) {
2274 $self->message ("Something went wrong within the server, please report this incident!", cf::NDI_UNIQUE | cf::NDI_RED);
2275 LOG llevError | logBacktrace, Carp::longmess $@;
2276 }
2277
2278 if ($gen == $self->{_goto_generation}) {
2279 delete $self->{_goto_generation};
2280 $self->leave_link ($map, $x, $y);
2281 }
2282 })->prio (1);
2283}
2284
2285=item $player_object->enter_exit ($exit_object)
2286
2287=cut
2288
2289sub parse_random_map_params {
2290 my ($spec) = @_;
2291
2292 my $rmp = { # defaults
2293 xsize => (cf::rndm 15, 40),
2294 ysize => (cf::rndm 15, 40),
2295 symmetry => (cf::rndm 1, cf::SYMMETRY_XY),
2296 #layout => string,
2297 };
2298
2299 for (split /\n/, $spec) {
2300 my ($k, $v) = split /\s+/, $_, 2;
2301
2302 $rmp->{lc $k} = $v if (length $k) && (length $v);
2303 }
2304
2305 $rmp
2306}
2307
2308sub prepare_random_map {
2309 my ($exit) = @_;
2310
2311 my $guard = cf::lock_acquire "exit_prepare:$exit";
2312
2313 # all this does is basically replace the /! path by
2314 # a new random map path (?random/...) with a seed
2315 # that depends on the exit object
2316
2317 my $rmp = parse_random_map_params $exit->msg;
2318
2319 if ($exit->map) {
2320 $rmp->{region} = $exit->region->name;
2321 $rmp->{origin_map} = $exit->map->path;
2322 $rmp->{origin_x} = $exit->x;
2323 $rmp->{origin_y} = $exit->y;
2324 }
2325
2326 $rmp->{random_seed} ||= $exit->random_seed;
2327
2328 my $data = cf::to_json $rmp;
2329 my $md5 = Digest::MD5::md5_hex $data;
2330 my $meta = "$RANDOMDIR/$md5.meta";
2331
2332 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) {
2333 aio_write $fh, 0, (length $data), $data, 0;
2334 undef $fh;
2335 aio_rename "$meta~", $meta;
2336
2337 $exit->slaying ("?random/$md5");
2338 $exit->msg (undef);
2339 }
2340}
2341
2342sub cf::object::player::enter_exit {
2343 my ($self, $exit) = @_;
2344
2345 return unless $self->type == cf::PLAYER;
2346
2347 if ($exit->slaying eq "/!") {
2348 #TODO: this should de-fi-ni-te-ly not be a sync-job
2349 # the problem is that $exit might not survive long enough
2350 # so it needs to be done right now, right here
2351 cf::sync_job { prepare_random_map $exit };
2352 }
2353
2354 my $slaying = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path;
2355 my $hp = $exit->stats->hp;
2356 my $sp = $exit->stats->sp;
2357
2358 $self->enter_link;
2359
2360 (async {
2361 $self->deactivate_recursive; # just to be sure
2362 unless (eval {
2363 $self->goto ($slaying, $hp, $sp);
2364
2365 1;
2366 }) {
2367 $self->message ("Something went wrong deep within the crossfire server. "
2368 . "I'll try to bring you back to the map you were before. "
2369 . "Please report this to the dungeon master!",
2370 cf::NDI_UNIQUE | cf::NDI_RED);
2371
2372 warn "ERROR in enter_exit: $@";
2373 $self->leave_link;
2374 }
2375 })->prio (1);
2376}
2377
895=head3 cf::client 2378=head3 cf::client
896 2379
897=over 4 2380=over 4
898 2381
899=item $client->send_drawinfo ($text, $flags) 2382=item $client->send_drawinfo ($text, $flags)
905 2388
906sub cf::client::send_drawinfo { 2389sub cf::client::send_drawinfo {
907 my ($self, $text, $flags) = @_; 2390 my ($self, $text, $flags) = @_;
908 2391
909 utf8::encode $text; 2392 utf8::encode $text;
910 $self->send_packet (sprintf "drawinfo %d %s", $flags, $text); 2393 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);
911} 2394}
912 2395
2396=item $client->send_msg ($color, $type, $msg, [extra...])
2397
2398Send a drawinfo or msg packet to the client, formatting the msg for the
2399client if neccessary. C<$type> should be a string identifying the type of
2400the message, with C<log> being the default. If C<$color> is negative, suppress
2401the message unless the client supports the msg packet.
2402
2403=cut
2404
2405sub cf::client::send_msg {
2406 my ($self, $color, $type, $msg, @extra) = @_;
2407
2408 $msg = $self->pl->expand_cfpod ($msg);
2409
2410 if ($self->can_msg) {
2411 $self->send_packet ("msg " . $self->{json_coder}->encode ([$color, $type, $msg, @extra]));
2412 } else {
2413 # replace some tags by gcfclient-compatible ones
2414 for ($msg) {
2415 1 while
2416 s/<b>([^<]*)<\/b>/[b]${1}[\/b]/
2417 || s/<i>([^<]*)<\/i>/[i]${1}[\/i]/
2418 || s/<u>([^<]*)<\/u>/[ul]${1}[\/ul]/
2419 || s/<tt>([^<]*)<\/tt>/[fixed]${1}[\/fixed]/
2420 || s/<fg name=\"([^"]+)\">([^<]*)<\/fg>/[color=$1]${2}[\/color]/;
2421 }
2422
2423 if ($color >= 0) {
2424 if (0 && $msg =~ /\[/) {
2425 $self->send_packet ("drawextinfo $color 4 0 $msg")
2426 } else {
2427 $msg =~ s/\[\/?(?:b|i|u|fixed|color)[^\]]*\]//g;
2428 $self->send_packet ("drawinfo $color $msg")
2429 }
2430 }
2431 }
2432}
2433
2434=item $client->ext_event ($type, %msg)
2435
2436Sends an ext event to the client.
2437
2438=cut
2439
2440sub cf::client::ext_event($$%) {
2441 my ($self, $type, %msg) = @_;
2442
2443 $msg{msgtype} = "event_$type";
2444 $self->send_packet ("ext " . $self->{json_coder}->encode (\%msg));
2445}
913 2446
914=item $success = $client->query ($flags, "text", \&cb) 2447=item $success = $client->query ($flags, "text", \&cb)
915 2448
916Queues a query to the client, calling the given callback with 2449Queues a query to the client, calling the given callback with
917the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>, 2450the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>,
918C<cf::CS_QUERY_SINGLECHAR> or C<cf::CS_QUERY_HIDEINPUT> or C<0>. 2451C<cf::CS_QUERY_SINGLECHAR> or C<cf::CS_QUERY_HIDEINPUT> or C<0>.
919 2452
920Queries can fail, so check the return code. Or don't, as queries will become 2453Queries can fail, so check the return code. Or don't, as queries will
921reliable at some point in the future. 2454become reliable at some point in the future.
922 2455
923=cut 2456=cut
924 2457
925sub cf::client::query { 2458sub cf::client::query {
926 my ($self, $flags, $text, $cb) = @_; 2459 my ($self, $flags, $text, $cb) = @_;
934 utf8::encode $text; 2467 utf8::encode $text;
935 push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb]; 2468 push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb];
936 2469
937 $self->send_packet ($self->{query_queue}[0][0]) 2470 $self->send_packet ($self->{query_queue}[0][0])
938 if @{ $self->{query_queue} } == 1; 2471 if @{ $self->{query_queue} } == 1;
2472
2473 1
939} 2474}
940 2475
941cf::client->attach ( 2476cf::client->attach (
2477 on_connect => sub {
2478 my ($ns) = @_;
2479
2480 $ns->{json_coder} = JSON::XS->new->utf8->max_size (1e6)->convert_blessed;
2481 },
942 on_reply => sub { 2482 on_reply => sub {
943 my ($ns, $msg) = @_; 2483 my ($ns, $msg) = @_;
944 2484
945 # this weird shuffling is so that direct followup queries 2485 # this weird shuffling is so that direct followup queries
946 # get handled first 2486 # get handled first
947 my $queue = delete $ns->{query_queue}; 2487 my $queue = delete $ns->{query_queue}
2488 or return; # be conservative, not sure how that can happen, but we saw a crash here
948 2489
949 (shift @$queue)->[1]->($msg); 2490 (shift @$queue)->[1]->($msg);
2491 return unless $ns->valid; # temporary(?) workaround for callback destroying socket
950 2492
951 push @{ $ns->{query_queue} }, @$queue; 2493 push @{ $ns->{query_queue} }, @$queue;
952 2494
953 if (@{ $ns->{query_queue} } == @$queue) { 2495 if (@{ $ns->{query_queue} } == @$queue) {
954 if (@$queue) { 2496 if (@$queue) {
956 } else { 2498 } else {
957 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM; 2499 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM;
958 } 2500 }
959 } 2501 }
960 }, 2502 },
2503 on_exticmd => sub {
2504 my ($ns, $buf) = @_;
2505
2506 my $msg = eval { $ns->{json_coder}->decode ($buf) };
2507
2508 if (ref $msg) {
2509 if (my $cb = $EXTICMD{$msg->{msgtype}}) {
2510 if (my %reply = $cb->($ns, $msg)) {
2511 $reply{msgid} = $msg->{msgid};
2512 $ns->send ("ext " . $ns->{json_coder}->encode (\%reply));
2513 }
2514 }
2515 } else {
2516 warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";
2517 }
2518
2519 cf::override;
2520 },
961); 2521);
962 2522
963=item $client->coro (\&cb) 2523=item $client->async (\&cb)
964 2524
965Create a new coroutine, running the specified callback. The coroutine will 2525Create a new coroutine, running the specified callback. The coroutine will
966be automatically cancelled when the client gets destroyed (e.g. on logout, 2526be automatically cancelled when the client gets destroyed (e.g. on logout,
967or loss of connection). 2527or loss of connection).
968 2528
969=cut 2529=cut
970 2530
971sub cf::client::coro { 2531sub cf::client::async {
972 my ($self, $cb) = @_; 2532 my ($self, $cb) = @_;
973 2533
974 my $coro; $coro = async { 2534 my $coro = &Coro::async ($cb);
975 eval {
976 $cb->();
977 };
978 warn $@ if $@;
979 };
980 2535
981 $coro->on_destroy (sub { 2536 $coro->on_destroy (sub {
982 delete $self->{_coro}{$coro+0}; 2537 delete $self->{_coro}{$coro+0};
983 }); 2538 });
984 2539
1017 2572
1018# here we export the classes and methods available to script code 2573# here we export the classes and methods available to script code
1019 2574
1020=pod 2575=pod
1021 2576
1022The following fucntions and emthods are available within a safe environment: 2577The following functions and methods are available within a safe environment:
1023 2578
1024 cf::object contr pay_amount pay_player map 2579 cf::object contr pay_amount pay_player map
1025 cf::object::player player 2580 cf::object::player player
1026 cf::player peaceful 2581 cf::player peaceful
1027 cf::map trigger 2582 cf::map trigger
1108=back 2663=back
1109 2664
1110=cut 2665=cut
1111 2666
1112############################################################################# 2667#############################################################################
2668# the server's init and main functions
1113 2669
1114=head2 EXTENSION DATABASE SUPPORT 2670sub load_facedata($) {
2671 my ($path) = @_;
1115 2672
1116Crossfire maintains a very simple database for extension use. It can 2673 warn "loading facedata from $path\n";
1117currently store anything that can be serialised using Storable, which
1118excludes objects.
1119 2674
1120The parameter C<$family> should best start with the name of the extension 2675 my $facedata;
1121using it, it should be unique. 2676 0 < aio_load $path, $facedata
2677 or die "$path: $!";
1122 2678
1123=over 4 2679 $facedata = Coro::Storable::thaw $facedata;
1124 2680
1125=item $hashref = cf::db_get $family 2681 $facedata->{version} == 2
2682 or cf::cleanup "$path: version mismatch, cannot proceed.";
1126 2683
1127Return a hashref for use by the extension C<$family>, which can be
1128modified. After modifications, you have to call C<cf::db_dirty> or
1129C<cf::db_sync>.
1130
1131=item $value = cf::db_get $family => $key
1132
1133Returns a single value from the database
1134
1135=item cf::db_put $family => $hashref
1136
1137Stores the given family hashref into the database. Updates are delayed, if
1138you want the data to be synced to disk immediately, use C<cf::db_sync>.
1139
1140=item cf::db_put $family => $key => $value
1141
1142Stores the given C<$value> in the family hash. Updates are delayed, if you
1143want the data to be synced to disk immediately, use C<cf::db_sync>.
1144
1145=item cf::db_dirty
1146
1147Marks the database as dirty, to be updated at a later time.
1148
1149=item cf::db_sync
1150
1151Immediately write the database to disk I<if it is dirty>.
1152
1153=cut
1154
1155our $DB;
1156
1157{
1158 my $path = cf::localdir . "/database.pst";
1159
1160 sub db_load() {
1161 warn "loading database $path\n";#d# remove later
1162 $DB = stat $path ? Storable::retrieve $path : { };
1163 } 2684 {
2685 my $faces = $facedata->{faceinfo};
1164 2686
1165 my $pid; 2687 while (my ($face, $info) = each %$faces) {
1166 2688 my $idx = (cf::face::find $face) || cf::face::alloc $face;
1167 sub db_save() { 2689 cf::face::set $idx, $info->{visibility}, $info->{magicmap};
1168 warn "saving database $path\n";#d# remove later 2690 cf::face::set_data $idx, 0, $info->{data32}, $info->{chksum32};
1169 waitpid $pid, 0 if $pid; 2691 cf::face::set_data $idx, 1, $info->{data64}, $info->{chksum64};
1170 if (0 == ($pid = fork)) { 2692 Coro::cede;
1171 $DB->{_meta}{version} = 1;
1172 Storable::nstore $DB, "$path~";
1173 rename "$path~", $path;
1174 cf::_exit 0 if defined $pid;
1175 }
1176 }
1177
1178 my $dirty;
1179
1180 sub db_sync() {
1181 db_save if $dirty;
1182 undef $dirty;
1183 }
1184
1185 my $idle = Event->idle (min => $TICK * 2.8, max => 10, repeat => 0, data => WF_AUTOCANCEL, cb => sub {
1186 db_sync;
1187 });
1188
1189 sub db_dirty() {
1190 $dirty = 1;
1191 $idle->start;
1192 }
1193
1194 sub db_get($;$) {
1195 @_ >= 2
1196 ? $DB->{$_[0]}{$_[1]}
1197 : ($DB->{$_[0]} ||= { })
1198 }
1199
1200 sub db_put($$;$) {
1201 if (@_ >= 3) {
1202 $DB->{$_[0]}{$_[1]} = $_[2];
1203 } else {
1204 $DB->{$_[0]} = $_[1];
1205 }
1206 db_dirty;
1207 }
1208
1209 cf::global->attach (
1210 prio => 10000,
1211 on_cleanup => sub {
1212 db_sync;
1213 }, 2693 }
1214 );
1215}
1216 2694
1217############################################################################# 2695 while (my ($face, $info) = each %$faces) {
1218# the server's main() 2696 next unless $info->{smooth};
2697 my $idx = cf::face::find $face
2698 or next;
2699 if (my $smooth = cf::face::find $info->{smooth}) {
2700 cf::face::set_smooth $idx, $smooth, $info->{smoothlevel};
2701 } else {
2702 warn "smooth face '$info->{smooth}' not found for face '$face'";
2703 }
2704 Coro::cede;
2705 }
2706 }
2707
2708 {
2709 my $anims = $facedata->{animinfo};
2710
2711 while (my ($anim, $info) = each %$anims) {
2712 cf::anim::set $anim, $info->{frames}, $info->{facings};
2713 Coro::cede;
2714 }
2715
2716 cf::anim::invalidate_all; # d'oh
2717 }
2718
2719 1
2720}
2721
2722sub reload_regions {
2723 load_resource_file "$MAPDIR/regions"
2724 or die "unable to load regions file\n";
2725}
2726
2727sub reload_facedata {
2728 load_facedata "$DATADIR/facedata"
2729 or die "unable to load facedata\n";
2730}
2731
2732sub reload_archetypes {
2733 load_resource_file "$DATADIR/archetypes"
2734 or die "unable to load archetypes\n";
2735 #d# NEED to laod twice to resolve forward references
2736 # this really needs to be done in an extra post-pass
2737 # (which needs to be synchronous, so solve it differently)
2738 load_resource_file "$DATADIR/archetypes"
2739 or die "unable to load archetypes\n";
2740}
2741
2742sub reload_treasures {
2743 load_resource_file "$DATADIR/treasures"
2744 or die "unable to load treasurelists\n";
2745}
2746
2747sub reload_resources {
2748 warn "reloading resource files...\n";
2749
2750 reload_regions;
2751 reload_facedata;
2752 #reload_archetypes;#d#
2753 reload_archetypes;
2754 reload_treasures;
2755
2756 warn "finished reloading resource files\n";
2757}
2758
2759sub init {
2760 reload_resources;
2761}
1219 2762
1220sub cfg_load { 2763sub cfg_load {
1221 open my $fh, "<:utf8", cf::confdir . "/config" 2764 open my $fh, "<:utf8", "$CONFDIR/config"
1222 or return; 2765 or return;
1223 2766
1224 local $/; 2767 local $/;
1225 *CFG = YAML::Syck::Load <$fh>; 2768 *CFG = YAML::Syck::Load <$fh>;
2769
2770 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37];
2771
2772 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset};
2773 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset};
2774
2775 if (exists $CFG{mlockall}) {
2776 eval {
2777 $CFG{mlockall} ? eval "mlockall()" : eval "munlockall()"
2778 and die "WARNING: m(un)lockall failed: $!\n";
2779 };
2780 warn $@ if $@;
2781 }
1226} 2782}
1227 2783
1228sub main { 2784sub main {
2785 # we must not ever block the main coroutine
2786 local $Coro::idle = sub {
2787 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
2788 (async {
2789 Event::one_event;
2790 })->prio (Coro::PRIO_MAX);
2791 };
2792
1229 cfg_load; 2793 cfg_load;
1230 db_load; 2794 db_init;
1231 load_extensions; 2795 load_extensions;
2796
2797 $TICK_WATCHER->start;
1232 Event::loop; 2798 Event::loop;
1233} 2799}
1234 2800
1235############################################################################# 2801#############################################################################
1236# initialisation 2802# initialisation and cleanup
1237 2803
1238sub _perl_reload() { 2804# install some emergency cleanup handlers
2805BEGIN {
2806 for my $signal (qw(INT HUP TERM)) {
2807 Event->signal (
2808 reentrant => 0,
2809 data => WF_AUTOCANCEL,
2810 signal => $signal,
2811 prio => 0,
2812 cb => sub {
2813 cf::cleanup "SIG$signal";
2814 },
2815 );
2816 }
2817}
2818
2819sub write_runtime {
2820 my $runtime = "$LOCALDIR/runtime";
2821
2822 # first touch the runtime file to show we are still running:
2823 # the fsync below can take a very very long time.
2824
2825 IO::AIO::aio_utime $runtime, undef, undef;
2826
2827 my $guard = cf::lock_acquire "write_runtime";
2828
2829 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644
2830 or return;
2831
2832 my $value = $cf::RUNTIME + 90 + 10;
2833 # 10 is the runtime save interval, for a monotonic clock
2834 # 60 allows for the watchdog to kill the server.
2835
2836 (aio_write $fh, 0, (length $value), $value, 0) <= 0
2837 and return;
2838
2839 # always fsync - this file is important
2840 aio_fsync $fh
2841 and return;
2842
2843 # touch it again to show we are up-to-date
2844 aio_utime $fh, undef, undef;
2845
2846 close $fh
2847 or return;
2848
2849 aio_rename "$runtime~", $runtime
2850 and return;
2851
2852 warn "runtime file written.\n";
2853
2854 1
2855}
2856
2857sub emergency_save() {
2858 my $freeze_guard = cf::freeze_mainloop;
2859
2860 warn "enter emergency perl save\n";
2861
2862 cf::sync_job {
2863 # use a peculiar iteration method to avoid tripping on perl
2864 # refcount bugs in for. also avoids problems with players
2865 # and maps saved/destroyed asynchronously.
2866 warn "begin emergency player save\n";
2867 for my $login (keys %cf::PLAYER) {
2868 my $pl = $cf::PLAYER{$login} or next;
2869 $pl->valid or next;
2870 $pl->save;
2871 }
2872 warn "end emergency player save\n";
2873
2874 warn "begin emergency map save\n";
2875 for my $path (keys %cf::MAP) {
2876 my $map = $cf::MAP{$path} or next;
2877 $map->valid or next;
2878 $map->save;
2879 }
2880 warn "end emergency map save\n";
2881
2882 warn "begin emergency database checkpoint\n";
2883 BDB::db_env_txn_checkpoint $DB_ENV;
2884 warn "end emergency database checkpoint\n";
2885 };
2886
2887 warn "leave emergency perl save\n";
2888}
2889
2890sub post_cleanup {
2891 my ($make_core) = @_;
2892
2893 warn Carp::longmess "post_cleanup backtrace"
2894 if $make_core;
2895}
2896
2897sub do_reload_perl() {
2898 # can/must only be called in main
2899 if ($Coro::current != $Coro::main) {
2900 warn "can only reload from main coroutine";
2901 return;
2902 }
2903
1239 warn "reloading..."; 2904 warn "reloading...";
1240 2905
1241 eval { 2906 warn "entering sync_job";
1242 local $FREEZE = 1;
1243 2907
2908 cf::sync_job {
2909 cf::write_runtime; # external watchdog should not bark
1244 cf::emergency_save; 2910 cf::emergency_save;
2911 cf::write_runtime; # external watchdog should not bark
1245 2912
1246 # cancel all watchers 2913 warn "syncing database to disk";
2914 BDB::db_env_txn_checkpoint $DB_ENV;
2915
2916 # if anything goes wrong in here, we should simply crash as we already saved
2917
2918 warn "cancelling all WF_AUTOCANCEL watchers";
1247 for (Event::all_watchers) { 2919 for (Event::all_watchers) {
1248 $_->cancel if $_->data & WF_AUTOCANCEL; 2920 $_->cancel if $_->data & WF_AUTOCANCEL;
1249 } 2921 }
1250 2922
2923 warn "flushing outstanding aio requests";
2924 for (;;) {
2925 BDB::flush;
2926 IO::AIO::flush;
2927 Coro::cede;
2928 last unless IO::AIO::nreqs || BDB::nreqs;
2929 warn "iterate...";
2930 }
2931
2932 ++$RELOAD;
2933
1251 # cancel all extension coros 2934 warn "cancelling all extension coros";
1252 $_->cancel for values %EXT_CORO; 2935 $_->cancel for values %EXT_CORO;
1253 %EXT_CORO = (); 2936 %EXT_CORO = ();
1254 2937
1255 # unload all extensions 2938 warn "removing commands";
1256 for (@exts) { 2939 %COMMAND = ();
2940
2941 warn "removing ext/exti commands";
2942 %EXTCMD = ();
2943 %EXTICMD = ();
2944
2945 warn "unloading/nuking all extensions";
2946 for my $pkg (@EXTS) {
1257 warn "unloading <$_>"; 2947 warn "... unloading $pkg";
1258 unload_extension $_; 2948
2949 if (my $cb = $pkg->can ("unload")) {
2950 eval {
2951 $cb->($pkg);
2952 1
2953 } or warn "$pkg unloaded, but with errors: $@";
1259 } 2954 }
1260 2955
2956 warn "... nuking $pkg";
2957 Symbol::delete_package $pkg;
2958 }
2959
1261 # unload all modules loaded from $LIBDIR 2960 warn "unloading all perl modules loaded from $LIBDIR";
1262 while (my ($k, $v) = each %INC) { 2961 while (my ($k, $v) = each %INC) {
1263 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/; 2962 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
1264 2963
1265 warn "removing <$k>"; 2964 warn "... unloading $k";
1266 delete $INC{$k}; 2965 delete $INC{$k};
1267 2966
1268 $k =~ s/\.pm$//; 2967 $k =~ s/\.pm$//;
1269 $k =~ s/\//::/g; 2968 $k =~ s/\//::/g;
1270 2969
1273 } 2972 }
1274 2973
1275 Symbol::delete_package $k; 2974 Symbol::delete_package $k;
1276 } 2975 }
1277 2976
1278 # sync database to disk
1279 cf::db_sync;
1280 IO::AIO::flush;
1281
1282 # get rid of safe::, as good as possible 2977 warn "getting rid of safe::, as good as possible";
1283 Symbol::delete_package "safe::$_" 2978 Symbol::delete_package "safe::$_"
1284 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region); 2979 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
1285 2980
1286 # remove register_script_function callbacks
1287 # TODO
1288
1289 # unload cf.pm "a bit" 2981 warn "unloading cf.pm \"a bit\"";
1290 delete $INC{"cf.pm"}; 2982 delete $INC{"cf.pm"};
2983 delete $INC{"cf/pod.pm"};
1291 2984
1292 # don't, removes xs symbols, too, 2985 # don't, removes xs symbols, too,
1293 # and global variables created in xs 2986 # and global variables created in xs
1294 #Symbol::delete_package __PACKAGE__; 2987 #Symbol::delete_package __PACKAGE__;
1295 2988
1296 # reload cf.pm 2989 warn "unload completed, starting to reload now";
2990
1297 warn "reloading cf.pm"; 2991 warn "reloading cf.pm";
1298 require cf; 2992 require cf;
1299 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 2993 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
1300 2994
1301 # load config and database again 2995 warn "loading config and database again";
1302 cf::cfg_load; 2996 cf::cfg_load;
1303 cf::db_load;
1304 2997
1305 # load extensions
1306 warn "load extensions"; 2998 warn "loading extensions";
1307 cf::load_extensions; 2999 cf::load_extensions;
1308 3000
1309 # reattach attachments to objects 3001 warn "reattaching attachments to objects/players";
1310 warn "reattach"; 3002 _global_reattach; # objects, sockets
1311 _global_reattach; 3003 warn "reattaching attachments to maps";
3004 reattach $_ for values %MAP;
3005 warn "reattaching attachments to players";
3006 reattach $_ for values %PLAYER;
3007
3008 warn "leaving sync_job";
3009
3010 1
3011 } or do {
3012 warn $@;
3013 warn "error while reloading, exiting.";
3014 exit 1;
1312 }; 3015 };
1313 warn $@ if $@;
1314 3016
1315 warn "reloaded"; 3017 warn "reloaded";
1316}; 3018};
1317 3019
1318sub perl_reload() { 3020our $RELOAD_WATCHER; # used only during reload
1319 _perl_reload;
1320}
1321 3021
1322register "<global>", __PACKAGE__; 3022sub reload_perl() {
3023 # doing reload synchronously and two reloads happen back-to-back,
3024 # coro crashes during coro_state_free->destroy here.
1323 3025
3026 $RELOAD_WATCHER ||= Event->timer (
3027 reentrant => 0,
3028 after => 0,
3029 data => WF_AUTOCANCEL,
3030 cb => sub {
3031 do_reload_perl;
3032 undef $RELOAD_WATCHER;
3033 },
3034 );
3035}
3036
1324register_command "perl-reload" => sub { 3037register_command "reload" => sub {
1325 my ($who, $arg) = @_; 3038 my ($who, $arg) = @_;
1326 3039
1327 if ($who->flag (FLAG_WIZ)) { 3040 if ($who->flag (FLAG_WIZ)) {
1328 $who->message ("reloading..."); 3041 $who->message ("reloading server.");
1329 _perl_reload; 3042 async { reload_perl };
1330 } 3043 }
1331}; 3044};
1332 3045
1333unshift @INC, $LIBDIR; 3046unshift @INC, $LIBDIR;
1334 3047
3048my $bug_warning = 0;
3049
3050our @WAIT_FOR_TICK;
3051our @WAIT_FOR_TICK_BEGIN;
3052
3053sub wait_for_tick {
3054 return unless $TICK_WATCHER->is_active;
3055 return if $Coro::current == $Coro::main;
3056
3057 my $signal = new Coro::Signal;
3058 push @WAIT_FOR_TICK, $signal;
3059 $signal->wait;
3060}
3061
3062sub wait_for_tick_begin {
3063 return unless $TICK_WATCHER->is_active;
3064 return if $Coro::current == $Coro::main;
3065
3066 my $signal = new Coro::Signal;
3067 push @WAIT_FOR_TICK_BEGIN, $signal;
3068 $signal->wait;
3069}
3070
3071 my $min = 1e6;#d#
3072 my $avg = 10;
1335$TICK_WATCHER = Event->timer ( 3073$TICK_WATCHER = Event->timer (
1336 reentrant => 0, 3074 reentrant => 0,
3075 parked => 1,
1337 prio => 0, 3076 prio => 0,
1338 at => $NEXT_TICK || $TICK, 3077 at => $NEXT_TICK || $TICK,
1339 data => WF_AUTOCANCEL, 3078 data => WF_AUTOCANCEL,
1340 cb => sub { 3079 cb => sub {
1341 unless ($FREEZE) { 3080 if ($Coro::current != $Coro::main) {
3081 Carp::cluck "major BUG: server tick called outside of main coro, skipping it"
3082 unless ++$bug_warning > 10;
3083 return;
3084 }
3085
3086 $NOW = $tick_start = Event::time;
3087
1342 cf::server_tick; # one server iteration 3088 cf::server_tick; # one server iteration
1343 $RUNTIME += $TICK; 3089
3090 0 && sync_job {#d#
3091 for(1..10) {
3092 my $t = Event::time;
3093 my $map = my $map = new_from_path cf::map "/tmp/x.map"
3094 or die;
3095
3096 $map->width (50);
3097 $map->height (50);
3098 $map->alloc;
3099 $map->_load_objects ("/tmp/x.map", 1);
3100 my $t = Event::time - $t;
3101
3102 #next unless $t < 0.0013;#d#
3103 if ($t < $min) {
3104 $min = $t;
3105 }
3106 $avg = $avg * 0.99 + $t * 0.01;
3107 }
3108 warn "XXXXXXXXXXXXXXXXXX min $min avg $avg\n";#d#
3109 exit 0;
3110 # 2007-05-22 02:33:04.569 min 0.00112509727478027 avg 0.0012259249572477
1344 } 3111 };
1345 3112
3113 $RUNTIME += $TICK;
1346 $NEXT_TICK += $TICK; 3114 $NEXT_TICK += $TICK;
1347 3115
3116 if ($NOW >= $NEXT_RUNTIME_WRITE) {
3117 $NEXT_RUNTIME_WRITE = $NOW + 10;
3118 Coro::async_pool {
3119 write_runtime
3120 or warn "ERROR: unable to write runtime file: $!";
3121 };
3122 }
3123
3124# my $AFTER = Event::time;
3125# warn $AFTER - $NOW;#d#
3126
3127 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
3128 $sig->send;
3129 }
3130 while (my $sig = shift @WAIT_FOR_TICK) {
3131 $sig->send;
3132 }
3133
3134 $NOW = Event::time;
3135
1348 # if we are delayed by four ticks or more, skip them all 3136 # if we are delayed by four ticks or more, skip them all
1349 $NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4; 3137 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
1350 3138
1351 $TICK_WATCHER->at ($NEXT_TICK); 3139 $TICK_WATCHER->at ($NEXT_TICK);
1352 $TICK_WATCHER->start; 3140 $TICK_WATCHER->start;
3141
3142 $LOAD = ($NOW - $tick_start) / $TICK;
3143 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
3144
3145 _post_tick;
3146
3147
1353 }, 3148 },
1354); 3149);
1355 3150
3151{
3152 BDB::max_poll_time $TICK * 0.1;
3153 $BDB_POLL_WATCHER = Event->io (
3154 reentrant => 0,
3155 fd => BDB::poll_fileno,
3156 poll => 'r',
3157 prio => 0,
3158 data => WF_AUTOCANCEL,
3159 cb => \&BDB::poll_cb,
3160 );
3161 BDB::min_parallel 8;
3162
3163 BDB::set_sync_prepare {
3164 my $status;
3165 my $current = $Coro::current;
3166 (
3167 sub {
3168 $status = $!;
3169 $current->ready; undef $current;
3170 },
3171 sub {
3172 Coro::schedule while defined $current;
3173 $! = $status;
3174 },
3175 )
3176 };
3177
3178 unless ($DB_ENV) {
3179 $DB_ENV = BDB::db_env_create;
3180
3181 cf::sync_job {
3182 eval {
3183 BDB::db_env_open
3184 $DB_ENV,
3185 $BDBDIR,
3186 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN
3187 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE,
3188 0666;
3189
3190 cf::cleanup "db_env_open($BDBDIR): $!" if $!;
3191
3192 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC, 1);
3193 $DB_ENV->set_lk_detect;
3194 };
3195
3196 cf::cleanup "db_env_open(db): $@" if $@;
3197 };
3198 }
3199}
3200
3201{
3202 IO::AIO::min_parallel 8;
3203
3204 undef $Coro::AIO::WATCHER;
1356IO::AIO::max_poll_time $TICK * 0.2; 3205 IO::AIO::max_poll_time $TICK * 0.1;
1357 3206 $AIO_POLL_WATCHER = Event->io (
1358Event->io (fd => IO::AIO::poll_fileno, 3207 reentrant => 0,
1359 poll => 'r',
1360 prio => 5,
1361 data => WF_AUTOCANCEL, 3208 data => WF_AUTOCANCEL,
3209 fd => IO::AIO::poll_fileno,
3210 poll => 'r',
3211 prio => 6,
1362 cb => \&IO::AIO::poll_cb); 3212 cb => \&IO::AIO::poll_cb,
3213 );
3214}
1363 3215
1364# we must not ever block the main coroutine 3216my $_log_backtrace;
1365$Coro::idle = sub { 3217
1366 #Carp::cluck "FATAL: Coro::idle was called, major BUG\n";#d# 3218sub _log_backtrace {
1367 warn "FATAL: Coro::idle was called, major BUG\n"; 3219 my ($msg, @addr) = @_;
1368 (Coro::unblock_sub { 3220
1369 Event::one_event; 3221 $msg =~ s/\n//;
1370 })->(); 3222
1371}; 3223 # limit the # of concurrent backtraces
3224 if ($_log_backtrace < 2) {
3225 ++$_log_backtrace;
3226 async {
3227 my @bt = fork_call {
3228 @addr = map { sprintf "%x", $_ } @addr;
3229 my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X;
3230 open my $fh, "exec addr2line -C -f -i -e \Q$self\E @addr 2>&1 |"
3231 or die "addr2line: $!";
3232
3233 my @funcs;
3234 my @res = <$fh>;
3235 chomp for @res;
3236 while (@res) {
3237 my ($func, $line) = splice @res, 0, 2, ();
3238 push @funcs, "[$func] $line";
3239 }
3240
3241 @funcs
3242 };
3243
3244 LOG llevInfo, "[ABT] $msg\n";
3245 LOG llevInfo, "[ABT] $_\n" for @bt;
3246 --$_log_backtrace;
3247 };
3248 } else {
3249 LOG llevInfo, "[ABT] $msg\n";
3250 LOG llevInfo, "[ABT] [suppressed]\n";
3251 }
3252}
3253
3254# load additional modules
3255use cf::pod;
3256
3257END { cf::emergency_save }
1372 3258
13731 32591
1374 3260

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines