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

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines