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

Diff Legend

– Removed lines
+ Added lines
< Changed lines
> Changed lines