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.44 by root, Sat Aug 26 08:44:06 2006 UTC vs.
Revision 1.427 by root, Sat Apr 26 12:25:45 2008 UTC

1#
2# This file is part of Deliantra, the Roguelike Realtime MMORPG.
3#
4# Copyright (©) 2006,2007,2008 Marc Alexander Lehmann / Robin Redeker / the Deliantra team
5#
6# Deliantra is free software: you can redistribute it and/or modify
7# it under the terms of the GNU General Public License as published by
8# the Free Software Foundation, either version 3 of the License, or
9# (at your option) any later version.
10#
11# This program is distributed in the hope that it will be useful,
12# but WITHOUT ANY WARRANTY; without even the implied warranty of
13# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14# GNU General Public License for more details.
15#
16# You should have received a copy of the GNU General Public License
17# along with this program. If not, see <http://www.gnu.org/licenses/>.
18#
19# The authors can be reached via e-mail to <support@deliantra.net>
20#
21
1package cf; 22package cf;
23
24use utf8;
25use strict;
2 26
3use Symbol; 27use Symbol;
4use List::Util; 28use List::Util;
5use Storable; 29use Socket;
30use EV 3.2;
6use Opcode; 31use Opcode;
7use Safe; 32use Safe;
8use Safe::Hole; 33use Safe::Hole;
34use Storable ();
9 35
36use Coro 4.50 ();
37use Coro::State;
38use Coro::Handle;
39use Coro::EV;
40use Coro::Timer;
41use Coro::Signal;
42use Coro::Semaphore;
43use Coro::AIO;
44use Coro::BDB;
45use Coro::Storable;
46use Coro::Util ();
47
48use JSON::XS 2.01 ();
49use BDB ();
50use Data::Dumper;
51use Digest::MD5;
52use Fcntl;
53use YAML ();
54use IO::AIO 2.51 ();
10use Time::HiRes; 55use Time::HiRes;
11use Event; 56use Compress::LZF;
12$Event::Eval = 1; # no idea why this is required, but it is 57use Digest::MD5 ();
13 58
14use strict; 59# configure various modules to our taste
60#
61$Storable::canonical = 1; # reduce rsync transfers
62Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator
63Compress::LZF::sfreeze_cr { }; # prime Compress::LZF so it does not use require later
15 64
65$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority
66
67sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
68
16our %COMMAND = (); 69our %COMMAND = ();
70our %COMMAND_TIME = ();
71
72our @EXTS = (); # list of extension package names
73our %EXTCMD = ();
74our %EXTICMD = ();
75our %EXT_CORO = (); # coroutines bound to extensions
76our %EXT_MAP = (); # pluggable maps
77
78our $RELOAD; # number of reloads so far
17our @EVENT; 79our @EVENT;
18our @PLUGIN_EVENT;
19our %PROP_TYPE;
20our %PROP_IDX;
21our $LIBDIR = maps_directory "perl";
22 80
23our $TICK = MAX_TIME * 1e-6; 81our $CONFDIR = confdir;
82our $DATADIR = datadir;
83our $LIBDIR = "$DATADIR/ext";
84our $PODDIR = "$DATADIR/pod";
85our $MAPDIR = "$DATADIR/" . mapdir;
86our $LOCALDIR = localdir;
87our $TMPDIR = "$LOCALDIR/" . tmpdir;
88our $UNIQUEDIR = "$LOCALDIR/" . uniquedir;
89our $PLAYERDIR = "$LOCALDIR/" . playerdir;
90our $RANDOMDIR = "$LOCALDIR/random";
91our $BDBDIR = "$LOCALDIR/db";
92our %RESOURCE;
93
94our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!)
24our $TICK_WATCHER; 95our $AIO_POLL_WATCHER;
96our $NEXT_RUNTIME_WRITE; # when should the runtime file be written
25our $NEXT_TICK; 97our $NEXT_TICK;
98our $USE_FSYNC = 1; # use fsync to write maps - default off
99
100our $BDB_POLL_WATCHER;
101our $BDB_DEADLOCK_WATCHER;
102our $BDB_CHECKPOINT_WATCHER;
103our $BDB_TRICKLE_WATCHER;
104our $DB_ENV;
105
106our %CFG;
107
108our $UPTIME; $UPTIME ||= time;
109our $RUNTIME;
110our $NOW;
111
112our (%PLAYER, %PLAYER_LOADING); # all users
113our (%MAP, %MAP_LOADING ); # all maps
114our $LINK_MAP; # the special {link} map, which is always available
115
116# used to convert map paths into valid unix filenames by replacing / by ∕
117our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons
118
119our $LOAD; # a number between 0 (idle) and 1 (too many objects)
120our $LOADAVG; # same thing, but with alpha-smoothing
121our $JITTER; # average jitter
122our $TICK_START; # for load detecting purposes
123
124binmode STDOUT;
125binmode STDERR;
126
127# read virtual server time, if available
128unless ($RUNTIME || !-e "$LOCALDIR/runtime") {
129 open my $fh, "<", "$LOCALDIR/runtime"
130 or die "unable to read runtime file: $!";
131 $RUNTIME = <$fh> + 0.;
132}
133
134mkdir $_
135 for $LOCALDIR, $TMPDIR, $UNIQUEDIR, $PLAYERDIR, $RANDOMDIR, $BDBDIR;
136
137our $EMERGENCY_POSITION;
138
139sub cf::map::normalise;
140
141#############################################################################
142
143=head2 GLOBAL VARIABLES
144
145=over 4
146
147=item $cf::UPTIME
148
149The timestamp of the server start (so not actually an uptime).
150
151=item $cf::RUNTIME
152
153The time this server has run, starts at 0 and is increased by $cf::TICK on
154every server tick.
155
156=item $cf::CONFDIR $cf::DATADIR $cf::LIBDIR $cf::PODDIR
157$cf::MAPDIR $cf::LOCALDIR $cf::TMPDIR $cf::UNIQUEDIR
158$cf::PLAYERDIR $cf::RANDOMDIR $cf::BDBDIR
159
160Various directories - "/etc", read-only install directory, perl-library
161directory, pod-directory, read-only maps directory, "/var", "/var/tmp",
162unique-items directory, player file directory, random maps directory and
163database environment.
164
165=item $cf::NOW
166
167The time of the last (current) server tick.
168
169=item $cf::TICK
170
171The interval between server ticks, in seconds.
172
173=item $cf::LOADAVG
174
175The current CPU load on the server (alpha-smoothed), as a value between 0
176(none) and 1 (overloaded), indicating how much time is spent on processing
177objects per tick. Healthy values are < 0.5.
178
179=item $cf::LOAD
180
181The raw value load value from the last tick.
182
183=item %cf::CFG
184
185Configuration for the server, loaded from C</etc/deliantra-server/config>, or
186from wherever your confdir points to.
187
188=item cf::wait_for_tick, cf::wait_for_tick_begin
189
190These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only
191returns directly I<after> the tick processing (and consequently, can only wake one process
192per tick), while cf::wait_for_tick wakes up all waiters after tick processing.
193
194=item @cf::INVOKE_RESULTS
195
196This array contains the results of the last C<invoke ()> call. When
197C<cf::override> is called C<@cf::INVOKE_RESULTS> is set to the parameters of
198that call.
199
200=back
201
202=cut
26 203
27BEGIN { 204BEGIN {
28 @PLUGIN_EVENT = map lc, @PLUGIN_EVENT;
29
30 *CORE::GLOBAL::warn = sub { 205 *CORE::GLOBAL::warn = sub {
31 my $msg = join "", @_; 206 my $msg = join "", @_;
207
32 $msg .= "\n" 208 $msg .= "\n"
33 unless $msg =~ /\n$/; 209 unless $msg =~ /\n$/;
34 210
35 print STDERR "cfperl: $msg"; 211 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;
212
36 LOG llevError, "cfperl: $msg"; 213 LOG llevError, $msg;
37 }; 214 };
38} 215}
39 216
40my %ignore_set = (MAP_PROP_PATH => 1); # I hate the plug-in api. Deeply! 217$Coro::State::DIEHOOK = sub {
218 return unless $^S eq 0; # "eq", not "=="
41 219
42# generate property mutators 220 if ($Coro::current == $Coro::main) {#d#
43sub prop_gen { 221 warn "DIEHOOK called in main context, Coro bug?\n";#d#
44 my ($prefix, $class) = @_; 222 return;#d#
223 }#d#
45 224
46 no strict 'refs'; 225 # kill coroutine otherwise
226 warn Carp::longmess $_[0];
227 Coro::terminate
228};
47 229
48 for my $prop (keys %PROP_TYPE) { 230$SIG{__DIE__} = sub { }; #d#?
49 $prop =~ /^\Q$prefix\E_(.*$)/ or next;
50 my $sub = lc $1;
51 231
52 my $type = $PROP_TYPE{$prop}; 232@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
53 my $idx = $PROP_IDX {$prop}; 233@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';
54 234@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable';
55 *{"$class\::get_$sub"} = *{"$class\::$sub"} = sub { 235@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable';
56 $_[0]->get_property ($type, $idx) 236@safe::cf::map::ISA = @cf::map::ISA = 'cf::attachable';
57 }; 237@safe::cf::arch::ISA = @cf::arch::ISA = 'cf::object';
58
59 *{"$class\::set_$sub"} = sub {
60 $_[0]->set_property ($type, $idx, $_[1]);
61 } unless $ignore_set{$prop};
62 }
63}
64
65# auto-generate most of the API
66
67prop_gen OBJECT_PROP => "cf::object";
68# CFAPI_OBJECT_ANIMATION?
69prop_gen PLAYER_PROP => "cf::object::player";
70
71prop_gen MAP_PROP => "cf::map";
72prop_gen ARCH_PROP => "cf::arch";
73
74# guessed hierarchies
75
76@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object'; 238@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object'; # not really true (yet)
77@safe::cf::object::map::ISA = @cf::object::map::ISA = 'cf::object';
78 239
79# we bless all objects into (empty) derived classes to force a method lookup 240# we bless all objects into (empty) derived classes to force a method lookup
80# within the Safe compartment. 241# within the Safe compartment.
81for my $pkg (qw(cf::object cf::object::map cf::object::player cf::player cf::map cf::party cf::region cf::arch)) { 242for my $pkg (qw(
243 cf::global cf::attachable
244 cf::object cf::object::player
245 cf::client cf::player
246 cf::arch cf::living
247 cf::map cf::party cf::region
248)) {
82 no strict 'refs'; 249 no strict 'refs';
83 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg; 250 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
84} 251}
85 252
86$Event::DIED = sub { 253$EV::DIED = sub {
87 warn "error in event callback: @_"; 254 warn "error in event callback: @_";
88}; 255};
89 256
90my %ext_pkg;
91my @exts;
92my @hook;
93my %command;
94my %extcmd;
95
96############################################################################# 257#############################################################################
97# object support
98 258
99sub reattach { 259=head2 UTILITY FUNCTIONS
100 warn "reattach<@_>\n";
101}
102 260
103sub instantiate { 261=over 4
104 warn "instantiate<@_>\n";
105}
106 262
107sub clone { 263=item dumpval $ref
108 warn "clone<@_>\n"; 264
265=cut
266
267sub dumpval {
268 eval {
269 local $SIG{__DIE__};
270 my $d;
271 if (1) {
272 $d = new Data::Dumper([$_[0]], ["*var"]);
273 $d->Terse(1);
274 $d->Indent(2);
275 $d->Quotekeys(0);
276 $d->Useqq(1);
277 #$d->Bless(...);
278 $d->Seen($_[1]) if @_ > 1;
279 $d = $d->Dump();
280 }
281 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge;
282 $d
283 } || "[unable to dump $_[0]: '$@']";
109} 284}
285
286=item $ref = cf::decode_json $json
287
288Converts a JSON string into the corresponding perl data structure.
289
290=item $json = cf::encode_json $ref
291
292Converts a perl data structure into its JSON representation.
293
294=cut
295
296our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max
297
298sub encode_json($) { $json_coder->encode ($_[0]) }
299sub decode_json($) { $json_coder->decode ($_[0]) }
300
301=item cf::lock_wait $string
302
303Wait until the given lock is available. See cf::lock_acquire.
304
305=item my $lock = cf::lock_acquire $string
306
307Wait until the given lock is available and then acquires it and returns
308a Coro::guard object. If the guard object gets destroyed (goes out of scope,
309for example when the coroutine gets canceled), the lock is automatically
310returned.
311
312Locks are *not* recursive, locking from the same coro twice results in a
313deadlocked coro.
314
315Lock names should begin with a unique identifier (for example, cf::map::find
316uses map_find and cf::map::load uses map_load).
317
318=item $locked = cf::lock_active $string
319
320Return true if the lock is currently active, i.e. somebody has locked it.
321
322=cut
323
324our %LOCK;
325our %LOCKER;#d#
326
327sub lock_wait($) {
328 my ($key) = @_;
329
330 if ($LOCKER{$key} == $Coro::current) {#d#
331 Carp::cluck "lock_wait($key) for already-acquired lock";#d#
332 return;#d#
333 }#d#
334
335 # wait for lock, if any
336 while ($LOCK{$key}) {
337 push @{ $LOCK{$key} }, $Coro::current;
338 Coro::schedule;
339 }
340}
341
342sub lock_acquire($) {
343 my ($key) = @_;
344
345 # wait, to be sure we are not locked
346 lock_wait $key;
347
348 $LOCK{$key} = [];
349 $LOCKER{$key} = $Coro::current;#d#
350
351 Coro::guard {
352 delete $LOCKER{$key};#d#
353 # wake up all waiters, to be on the safe side
354 $_->ready for @{ delete $LOCK{$key} };
355 }
356}
357
358sub lock_active($) {
359 my ($key) = @_;
360
361 ! ! $LOCK{$key}
362}
363
364sub freeze_mainloop {
365 tick_inhibit_inc;
366
367 Coro::guard \&tick_inhibit_dec;
368}
369
370=item cf::periodic $interval, $cb
371
372Like EV::periodic, but randomly selects a starting point so that the actions
373get spread over timer.
374
375=cut
376
377sub periodic($$) {
378 my ($interval, $cb) = @_;
379
380 my $start = rand List::Util::min 180, $interval;
381
382 EV::periodic $start, $interval, 0, $cb
383}
384
385=item cf::get_slot $time[, $priority[, $name]]
386
387Allocate $time seconds of blocking CPU time at priority C<$priority>:
388This call blocks and returns only when you have at least C<$time> seconds
389of cpu time till the next tick. The slot is only valid till the next cede.
390
391The optional C<$name> can be used to identify the job to run. It might be
392used for statistical purposes and should identify the same time-class.
393
394Useful for short background jobs.
395
396=cut
397
398our @SLOT_QUEUE;
399our $SLOT_QUEUE;
400
401$SLOT_QUEUE->cancel if $SLOT_QUEUE;
402$SLOT_QUEUE = Coro::async {
403 $Coro::current->desc ("timeslot manager");
404
405 my $signal = new Coro::Signal;
406
407 while () {
408 next_job:
409 my $avail = cf::till_tick;
410 if ($avail > 0.01) {
411 for (0 .. $#SLOT_QUEUE) {
412 if ($SLOT_QUEUE[$_][0] < $avail) {
413 my $job = splice @SLOT_QUEUE, $_, 1, ();
414 $job->[2]->send;
415 Coro::cede;
416 goto next_job;
417 }
418 }
419 }
420
421 if (@SLOT_QUEUE) {
422 # we do not use wait_for_tick() as it returns immediately when tick is inactive
423 push @cf::WAIT_FOR_TICK, $signal;
424 $signal->wait;
425 } else {
426 Coro::schedule;
427 }
428 }
429};
430
431sub get_slot($;$$) {
432 return if tick_inhibit || $Coro::current == $Coro::main;
433
434 my ($time, $pri, $name) = @_;
435
436 $time = $TICK * .6 if $time > $TICK * .6;
437 my $sig = new Coro::Signal;
438
439 push @SLOT_QUEUE, [$time, $pri, $sig, $name];
440 @SLOT_QUEUE = sort { $b->[1] <=> $a->[1] } @SLOT_QUEUE;
441 $SLOT_QUEUE->ready;
442 $sig->wait;
443}
444
445=item cf::async { BLOCK }
446
447Currently the same as Coro::async_pool, meaning you cannot use
448C<on_destroy>, C<join> or other gimmicks on these coroutines. The only
449thing you are allowed to do is call C<prio> on it.
450
451=cut
452
453BEGIN { *async = \&Coro::async_pool }
454
455=item cf::sync_job { BLOCK }
456
457The design of Deliantra requires that the main coroutine ($Coro::main)
458is always able to handle events or runnable, as Deliantra is only
459partly reentrant. Thus "blocking" it by e.g. waiting for I/O is not
460acceptable.
461
462If it must be done, put the blocking parts into C<sync_job>. This will run
463the given BLOCK in another coroutine while waiting for the result. The
464server will be frozen during this time, so the block should either finish
465fast or be very important.
466
467=cut
468
469sub sync_job(&) {
470 my ($job) = @_;
471
472 if ($Coro::current == $Coro::main) {
473 my $time = EV::time;
474
475 # this is the main coro, too bad, we have to block
476 # till the operation succeeds, freezing the server :/
477
478 LOG llevError, Carp::longmess "sync job";#d#
479
480 my $freeze_guard = freeze_mainloop;
481
482 my $busy = 1;
483 my @res;
484
485 (async {
486 $Coro::current->desc ("sync job coro");
487 @res = eval { $job->() };
488 warn $@ if $@;
489 undef $busy;
490 })->prio (Coro::PRIO_MAX);
491
492 while ($busy) {
493 if (Coro::nready) {
494 Coro::cede_notself;
495 } else {
496 EV::loop EV::LOOP_ONESHOT;
497 }
498 }
499
500 my $time = EV::time - $time;
501
502 $TICK_START += $time; # do not account sync jobs to server load
503
504 wantarray ? @res : $res[0]
505 } else {
506 # we are in another coroutine, how wonderful, everything just works
507
508 $job->()
509 }
510}
511
512=item $coro = cf::async_ext { BLOCK }
513
514Like async, but this coro is automatically being canceled when the
515extension calling this is being unloaded.
516
517=cut
518
519sub async_ext(&) {
520 my $cb = shift;
521
522 my $coro = &Coro::async ($cb);
523
524 $coro->on_destroy (sub {
525 delete $EXT_CORO{$coro+0};
526 });
527 $EXT_CORO{$coro+0} = $coro;
528
529 $coro
530}
531
532=item fork_call { }, $args
533
534Executes the given code block with the given arguments in a seperate
535process, returning the results. Everything must be serialisable with
536Coro::Storable. May, of course, block. Note that the executed sub may
537never block itself or use any form of event handling.
538
539=cut
540
541sub fork_call(&@) {
542 my ($cb, @args) = @_;
543
544 # we seemingly have to make a local copy of the whole thing,
545 # otherwise perl prematurely frees the stuff :/
546 # TODO: investigate and fix (likely this will be rather laborious)
547
548 my @res = Coro::Util::fork_eval {
549 reset_signals;
550 &$cb
551 }, @args;
552
553 wantarray ? @res : $res[-1]
554}
555
556=item $coin = coin_from_name $name
557
558=cut
559
560our %coin_alias = (
561 "silver" => "silvercoin",
562 "silvercoin" => "silvercoin",
563 "silvercoins" => "silvercoin",
564 "gold" => "goldcoin",
565 "goldcoin" => "goldcoin",
566 "goldcoins" => "goldcoin",
567 "platinum" => "platinacoin",
568 "platinumcoin" => "platinacoin",
569 "platinumcoins" => "platinacoin",
570 "platina" => "platinacoin",
571 "platinacoin" => "platinacoin",
572 "platinacoins" => "platinacoin",
573 "royalty" => "royalty",
574 "royalties" => "royalty",
575);
576
577sub coin_from_name($) {
578 $coin_alias{$_[0]}
579 ? cf::arch::find $coin_alias{$_[0]}
580 : undef
581}
582
583=item $value = cf::db_get $family => $key
584
585Returns a single value from the environment database.
586
587=item cf::db_put $family => $key => $value
588
589Stores the given C<$value> in the family. It can currently store binary
590data only (use Compress::LZF::sfreeze_cr/sthaw to convert to/from binary).
591
592=item $db = cf::db_table "name"
593
594Create and/or open a new database table. The string must not be "db" and must be unique
595within each server.
596
597=cut
598
599sub db_table($) {
600 my ($name) = @_;
601 my $db = BDB::db_create $DB_ENV;
602
603 eval {
604 $db->set_flags (BDB::CHKSUM);
605
606 utf8::encode $name;
607 BDB::db_open $db, undef, $name, undef, BDB::BTREE,
608 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
609 cf::cleanup "db_open(db): $!" if $!;
610 };
611 cf::cleanup "db_open(db): $@" if $@;
612
613 $db
614}
615
616our $DB;
617
618sub db_init {
619 cf::sync_job {
620 $DB ||= db_table "db";
621 };
622}
623
624sub db_get($$) {
625 my $key = "$_[0]/$_[1]";
626
627 cf::sync_job {
628 BDB::db_get $DB, undef, $key, my $data;
629
630 $! ? ()
631 : $data
632 }
633}
634
635sub db_put($$$) {
636 BDB::dbreq_pri 4;
637 BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { };
638}
639
640=item cf::cache $id => [$paths...], $processversion => $process
641
642Generic caching function that returns the value of the resource $id,
643caching and regenerating as required.
644
645This function can block.
646
647=cut
648
649sub cache {
650 my ($id, $src, $processversion, $process) = @_;
651
652 my $meta =
653 join "\x00",
654 $processversion,
655 map {
656 aio_stat $_
657 and Carp::croak "$_: $!";
658
659 ($_, (stat _)[7,9])
660 } @$src;
661
662 my $dbmeta = db_get cache => "$id/meta";
663 if ($dbmeta ne $meta) {
664 # changed, we may need to process
665
666 my @data;
667 my $md5;
668
669 for (0 .. $#$src) {
670 0 <= aio_load $src->[$_], $data[$_]
671 or Carp::croak "$src->[$_]: $!";
672 }
673
674 # if processing is expensive, check
675 # checksum first
676 if (1) {
677 $md5 =
678 join "\x00",
679 $processversion,
680 map {
681 cf::cede_to_tick;
682 ($src->[$_], Digest::MD5::md5_hex $data[$_])
683 } 0.. $#$src;
684
685
686 my $dbmd5 = db_get cache => "$id/md5";
687 if ($dbmd5 eq $md5) {
688 db_put cache => "$id/meta", $meta;
689
690 return db_get cache => "$id/data";
691 }
692 }
693
694 my $t1 = Time::HiRes::time;
695 my $data = $process->(\@data);
696 my $t2 = Time::HiRes::time;
697
698 warn "cache: '$id' processed in ", $t2 - $t1, "s\n";
699
700 db_put cache => "$id/data", $data;
701 db_put cache => "$id/md5" , $md5;
702 db_put cache => "$id/meta", $meta;
703
704 return $data;
705 }
706
707 db_get cache => "$id/data"
708}
709
710=item cf::datalog type => key => value, ...
711
712Log a datalog packet of the given type with the given key-value pairs.
713
714=cut
715
716sub datalog($@) {
717 my ($type, %kv) = @_;
718 warn "DATALOG ", JSON::XS->new->ascii->encode ({ %kv, type => $type });
719}
720
721=back
722
723=cut
110 724
111############################################################################# 725#############################################################################
112# "new" plug-in system
113 726
114=item cf::object::attach ... # NYI 727=head2 ATTACHABLE OBJECTS
115 728
116=item cf::attach_global ... 729Many objects in crossfire are so-called attachable objects. That means you can
730attach callbacks/event handlers (a collection of which is called an "attachment")
731to it. All such attachable objects support the following methods.
117 732
118=item cf::attach_to_type ... 733In the following description, CLASS can be any of C<global>, C<object>
734C<player>, C<client> or C<map> (i.e. the attachable objects in
735Deliantra).
119 736
120=item cf::attach_to_objects ... 737=over 4
121 738
122=item cf::attach_to_players ... 739=item $attachable->attach ($attachment, key => $value...)
123 740
124=item cf::attach_to_maps ... 741=item $attachable->detach ($attachment)
125 742
126 prio => $number, # lower is earlier 743Attach/detach a pre-registered attachment to a specific object and give it
127 on_xxx => \&cb, 744the specified key/value pairs as arguments.
745
746Example, attach a minesweeper attachment to the given object, making it a
74710x10 minesweeper game:
748
749 $obj->attach (minesweeper => width => 10, height => 10);
750
751=item $bool = $attachable->attached ($name)
752
753Checks wether the named attachment is currently attached to the object.
754
755=item cf::CLASS->attach ...
756
757=item cf::CLASS->detach ...
758
759Define an anonymous attachment and attach it to all objects of the given
760CLASS. See the next function for an explanation of its arguments.
761
762You can attach to global events by using the C<cf::global> class.
763
764Example, log all player logins:
765
766 cf::player->attach (
767 on_login => sub {
768 my ($pl) = @_;
769 ...
770 },
771 );
772
773Example, attach to the jeweler skill:
774
775 cf::object->attach (
776 type => cf::SKILL,
777 subtype => cf::SK_JEWELER,
778 on_use_skill => sub {
779 my ($sk, $ob, $part, $dir, $msg) = @_;
780 ...
781 },
782 );
783
784=item cf::CLASS::attachment $name, ...
785
786Register an attachment by C<$name> through which attachable objects of the
787given CLASS can refer to this attachment.
788
789Some classes such as crossfire maps and objects can specify attachments
790that are attached at load/instantiate time, thus the need for a name.
791
792These calls expect any number of the following handler/hook descriptions:
793
794=over 4
795
796=item prio => $number
797
798Set the priority for all following handlers/hooks (unless overwritten
799by another C<prio> setting). Lower priority handlers get executed
800earlier. The default priority is C<0>, and many built-in handlers are
801registered at priority C<-1000>, so lower priorities should not be used
802unless you know what you are doing.
803
804=item type => $type
805
806(Only for C<< cf::object->attach >> calls), limits the attachment to the
807given type of objects only (the additional parameter C<subtype> can be
808used to further limit to the given subtype).
809
810=item on_I<event> => \&cb
811
812Call the given code reference whenever the named event happens (event is
813something like C<instantiate>, C<apply>, C<use_skill> and so on, and which
814handlers are recognised generally depends on the type of object these
815handlers attach to).
816
817See F<include/eventinc.h> for the full list of events supported, and their
818class.
819
128 package => package::, 820=item package => package::
821
822Look for sub functions of the name C<< on_I<event> >> in the given
823package and register them. Only handlers for eevents supported by the
824object/class are recognised.
825
826=back
827
828Example, define an attachment called "sockpuppet" that calls the given
829event handler when a monster attacks:
830
831 cf::object::attachment sockpuppet =>
832 on_skill_attack => sub {
833 my ($self, $victim) = @_;
834 ...
835 }
836 }
837
838=item $attachable->valid
839
840Just because you have a perl object does not mean that the corresponding
841C-level object still exists. If you try to access an object that has no
842valid C counterpart anymore you get an exception at runtime. This method
843can be used to test for existence of the C object part without causing an
844exception.
129 845
130=cut 846=cut
131 847
132# the following variables are defined in .xs and must not be re-created 848# the following variables are defined in .xs and must not be re-created
133our @CB_GLOBAL = (); # registry for all global events 849our @CB_GLOBAL = (); # registry for all global events
134our @CB_OBJECT = (); 850our @CB_ATTACHABLE = (); # registry for all attachables
851our @CB_OBJECT = (); # all objects (should not be used except in emergency)
135our @CB_PLAYER = (); 852our @CB_PLAYER = ();
853our @CB_CLIENT = ();
136our @CB_TYPE = (); # registry for type (cf-object class) based events 854our @CB_TYPE = (); # registry for type (cf-object class) based events
137our @CB_MAP = (); 855our @CB_MAP = ();
138 856
857my %attachment;
858
859sub cf::attachable::thawer_merge {
860 # simply override everything except _meta
861 local $_[0]{_meta};
862 %{$_[0]} = %{$_[1]};
863}
864
139sub _attach_cb($\%$$$) { 865sub _attach_cb($$$$) {
140 my ($registry, $undo, $event, $prio, $cb) = @_; 866 my ($registry, $event, $prio, $cb) = @_;
141 867
142 use sort 'stable'; 868 use sort 'stable';
143 869
144 $cb = [$prio, $cb]; 870 $cb = [$prio, $cb];
145 871
146 @{$registry->[$event]} = sort 872 @{$registry->[$event]} = sort
147 { $a->[0] cmp $b->[0] } 873 { $a->[0] cmp $b->[0] }
148 @{$registry->[$event] || []}, $cb; 874 @{$registry->[$event] || []}, $cb;
149
150 push @{$undo->{cb}}, [$event, $cb];
151} 875}
876
877# hack
878my %attachable_klass = map +($_ => 1), KLASS_OBJECT, KLASS_CLIENT, KLASS_PLAYER, KLASS_MAP;
152 879
153# attach handles attaching event callbacks 880# attach handles attaching event callbacks
154# the only thing the caller has to do is pass the correct 881# the only thing the caller has to do is pass the correct
155# registry (== where the callback attaches to). 882# registry (== where the callback attaches to).
156sub _attach(\@$\@) { 883sub _attach {
157 my ($registry, $klass, $arg) = @_; 884 my ($registry, $klass, @arg) = @_;
158 885
886 my $object_type;
159 my $prio = 0; 887 my $prio = 0;
160
161 my %undo = (
162 registry => $registry,
163 cb => [],
164 );
165
166 my %cb_id = map +("on_" . lc $EVENT[$_][0], $_) , grep $EVENT[$_][1] == $klass, 0 .. $#EVENT; 888 my %cb_id = map +("on_" . lc $EVENT[$_][0], $_) , grep $EVENT[$_][1] == $klass, 0 .. $#EVENT;
167 889
890 #TODO: get rid of this hack
891 if ($attachable_klass{$klass}) {
892 %cb_id = (%cb_id, map +("on_" . lc $EVENT[$_][0], $_) , grep $EVENT[$_][1] == KLASS_ATTACHABLE, 0 .. $#EVENT);
893 }
894
168 while (@$arg) { 895 while (@arg) {
169 my $type = shift @$arg; 896 my $type = shift @arg;
170 897
171 if ($type eq "prio") { 898 if ($type eq "prio") {
172 $prio = shift @$arg; 899 $prio = shift @arg;
900
901 } elsif ($type eq "type") {
902 $object_type = shift @arg;
903 $registry = $CB_TYPE[$object_type] ||= [];
904
905 } elsif ($type eq "subtype") {
906 defined $object_type or Carp::croak "subtype specified without type";
907 my $object_subtype = shift @arg;
908 $registry = $CB_TYPE[$object_type + $object_subtype * NUM_TYPES] ||= [];
173 909
174 } elsif ($type eq "package") { 910 } elsif ($type eq "package") {
175 my $pkg = shift @$arg; 911 my $pkg = shift @arg;
176 912
177 while (my ($name, $id) = each %cb_id) { 913 while (my ($name, $id) = each %cb_id) {
178 if (my $cb = $pkg->can ($name)) { 914 if (my $cb = $pkg->can ($name)) {
179 _attach_cb $registry, %undo, $id, $prio, $cb; 915 _attach_cb $registry, $id, $prio, $cb;
180 } 916 }
181 } 917 }
182 918
183 } elsif (exists $cb_id{$type}) { 919 } elsif (exists $cb_id{$type}) {
184 _attach_cb $registry, %undo, $cb_id{$type}, $prio, shift @$arg; 920 _attach_cb $registry, $cb_id{$type}, $prio, shift @arg;
185 921
186 } elsif (ref $type) { 922 } elsif (ref $type) {
187 warn "attaching objects not supported, ignoring.\n"; 923 warn "attaching objects not supported, ignoring.\n";
188 924
189 } else { 925 } else {
190 shift @$arg; 926 shift @arg;
191 warn "attach argument '$type' not supported, ignoring.\n"; 927 warn "attach argument '$type' not supported, ignoring.\n";
192 } 928 }
193 } 929 }
194
195 \%undo
196} 930}
197 931
198sub cf::object::attach { 932sub _object_attach {
199 die; 933 my ($obj, $name, %arg) = @_;
200}
201 934
202sub attach_global { 935 return if exists $obj->{_attachment}{$name};
203 _attach @CB_GLOBAL, KLASS_GLOBAL, @_
204}
205 936
206sub attach_to_type { 937 if (my $attach = $attachment{$name}) {
207 my $type = shift; 938 my $registry = $obj->registry;
208 _attach @{$CB_TYPE[$type]}, KLASS_OBJECT, @_
209}
210 939
211sub attach_to_objects { 940 for (@$attach) {
212 _attach @CB_OBJECT, KLASS_OBJECT, @_ 941 my ($klass, @attach) = @$_;
213} 942 _attach $registry, $klass, @attach;
943 }
214 944
215sub attach_to_players { 945 $obj->{$name} = \%arg;
216 _attach @CB_PLAYER, KLASS_PLAYER, @_ 946 } else {
217} 947 warn "object uses attachment '$name' which is not available, postponing.\n";
948 }
218 949
219sub attach_to_maps { 950 $obj->{_attachment}{$name} = undef;
220 _attach @CB_MAP, KLASS_MAP, @_ 951}
952
953sub cf::attachable::attach {
954 if (ref $_[0]) {
955 _object_attach @_;
956 } else {
957 _attach shift->_attach_registry, @_;
958 }
959 _recalc_want;
960};
961
962# all those should be optimised
963sub cf::attachable::detach {
964 my ($obj, $name) = @_;
965
966 if (ref $obj) {
967 delete $obj->{_attachment}{$name};
968 reattach ($obj);
969 } else {
970 Carp::croak "cannot, currently, detach class attachments";
971 }
972 _recalc_want;
973};
974
975sub cf::attachable::attached {
976 my ($obj, $name) = @_;
977
978 exists $obj->{_attachment}{$name}
979}
980
981for my $klass (qw(ATTACHABLE GLOBAL OBJECT PLAYER CLIENT MAP)) {
982 eval "#line " . __LINE__ . " 'cf.pm'
983 sub cf::\L$klass\E::_attach_registry {
984 (\\\@CB_$klass, KLASS_$klass)
985 }
986
987 sub cf::\L$klass\E::attachment {
988 my \$name = shift;
989
990 \$attachment{\$name} = [[KLASS_$klass, \@_]];
991 }
992 ";
993 die if $@;
221} 994}
222 995
223our $override; 996our $override;
997our @INVOKE_RESULTS = (); # referenced from .xs code. TODO: play tricks with reify and mortals?
224 998
225sub override() { 999sub override {
226 $override = 1 1000 $override = 1;
1001 @INVOKE_RESULTS = (@_);
227} 1002}
228 1003
229sub invoke { 1004sub do_invoke {
230 my $event = shift; 1005 my $event = shift;
231 my $callbacks = shift; 1006 my $callbacks = shift;
232 1007
1008 @INVOKE_RESULTS = ();
1009
233 local $override; 1010 local $override;
234 1011
235 for (@$callbacks) { 1012 for (@$callbacks) {
236 eval { &{$_->[1]} }; 1013 eval { &{$_->[1]} };
237 1014
238 if ($@) { 1015 if ($@) {
239 warn "$@"; 1016 warn "$@";
240 warn "... while processing $EVENT[$event][0] event, skipping processing altogether.\n"; 1017 warn "... while processing $EVENT[$event][0](@_) event, skipping processing altogether.\n";
241 override; 1018 override;
242 } 1019 }
243 1020
244 return 1 if $override; 1021 return 1 if $override;
245 } 1022 }
246 1023
247 0 1024 0
248} 1025}
249 1026
1027=item $bool = cf::global->invoke (EVENT_CLASS_XXX, ...)
1028
1029=item $bool = $attachable->invoke (EVENT_CLASS_XXX, ...)
1030
1031Generate an object-specific event with the given arguments.
1032
1033This API is preliminary (most likely, the EVENT_CLASS_xxx prefix will be
1034removed in future versions), and there is no public API to access override
1035results (if you must, access C<@cf::INVOKE_RESULTS> directly).
1036
1037=back
1038
1039=cut
1040
250############################################################################# 1041#############################################################################
251# old plug-in events 1042# object support
252 1043
253sub inject_event { 1044sub _object_equal($$);
254 my $extension = shift; 1045sub _object_equal($$) {
255 my $event_code = shift; 1046 my ($a, $b) = @_;
256 1047
257 my $cb = $hook[$event_code]{$extension} 1048 return 0 unless (ref $a) eq (ref $b);
1049
1050 if ("HASH" eq ref $a) {
1051 my @ka = keys %$a;
1052 my @kb = keys %$b;
1053
1054 return 0 if @ka != @kb;
1055
1056 for (0 .. $#ka) {
1057 return 0 unless $ka[$_] eq $kb[$_];
1058 return 0 unless _object_equal $a->{$ka[$_]}, $b->{$kb[$_]};
1059 }
1060
1061 } elsif ("ARRAY" eq ref $a) {
1062
1063 return 0 if @$a != @$b;
1064
1065 for (0 .. $#$a) {
1066 return 0 unless _object_equal $a->[$_], $b->[$_];
1067 }
1068
1069 } elsif ($a ne $b) {
1070 return 0;
1071 }
1072
1073 1
1074}
1075
1076our $SLOW_MERGES;#d#
1077sub _can_merge {
1078 my ($ob1, $ob2) = @_;
1079
1080 ++$SLOW_MERGES;#d#
1081
1082 # we do the slow way here
1083 return _object_equal $ob1, $ob2
1084}
1085
1086sub reattach {
1087 # basically do the same as instantiate, without calling instantiate
1088 my ($obj) = @_;
1089
1090 bless $obj, ref $obj; # re-bless in case extensions have been reloaded
1091
1092 my $registry = $obj->registry;
1093
1094 @$registry = ();
1095
1096 delete $obj->{_attachment} unless scalar keys %{ $obj->{_attachment} || {} };
1097
1098 for my $name (keys %{ $obj->{_attachment} || {} }) {
1099 if (my $attach = $attachment{$name}) {
1100 for (@$attach) {
1101 my ($klass, @attach) = @$_;
1102 _attach $registry, $klass, @attach;
1103 }
1104 } else {
1105 warn "object uses attachment '$name' that is not available, postponing.\n";
1106 }
1107 }
1108}
1109
1110cf::attachable->attach (
1111 prio => -1000000,
1112 on_instantiate => sub {
1113 my ($obj, $data) = @_;
1114
1115 $data = decode_json $data;
1116
1117 for (@$data) {
1118 my ($name, $args) = @$_;
1119
1120 $obj->attach ($name, %{$args || {} });
1121 }
1122 },
1123 on_reattach => \&reattach,
1124 on_clone => sub {
1125 my ($src, $dst) = @_;
1126
1127 @{$dst->registry} = @{$src->registry};
1128
1129 %$dst = %$src;
1130
1131 %{$dst->{_attachment}} = %{$src->{_attachment}}
1132 if exists $src->{_attachment};
1133 },
1134);
1135
1136sub object_freezer_save {
1137 my ($filename, $rdata, $objs) = @_;
1138
1139 sync_job {
1140 if (length $$rdata) {
1141 utf8::decode (my $decname = $filename);
1142 warn sprintf "saving %s (%d,%d)\n",
1143 $decname, length $$rdata, scalar @$objs;
1144
1145 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
1146 aio_chmod $fh, SAVE_MODE;
1147 aio_write $fh, 0, (length $$rdata), $$rdata, 0;
1148 aio_fsync $fh if $cf::USE_FSYNC;
1149 aio_close $fh;
1150
1151 if (@$objs) {
1152 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) {
1153 aio_chmod $fh, SAVE_MODE;
1154 my $data = Coro::Storable::nfreeze { version => 1, objs => $objs };
1155 aio_write $fh, 0, (length $data), $data, 0;
1156 aio_fsync $fh if $cf::USE_FSYNC;
1157 aio_close $fh;
1158 aio_rename "$filename.pst~", "$filename.pst";
1159 }
1160 } else {
1161 aio_unlink "$filename.pst";
1162 }
1163
1164 aio_rename "$filename~", $filename;
1165 } else {
1166 warn "FATAL: $filename~: $!\n";
1167 }
1168 } else {
1169 aio_unlink $filename;
1170 aio_unlink "$filename.pst";
1171 }
1172 };
1173}
1174
1175sub object_freezer_as_string {
1176 my ($rdata, $objs) = @_;
1177
1178 use Data::Dumper;
1179
1180 $$rdata . Dumper $objs
1181}
1182
1183sub object_thawer_load {
1184 my ($filename) = @_;
1185
1186 my ($data, $av);
1187
1188 (aio_load $filename, $data) >= 0
258 or return; 1189 or return;
259 1190
260 &$cb 1191 unless (aio_stat "$filename.pst") {
261} 1192 (aio_load "$filename.pst", $av) >= 0
262
263sub inject_global_event {
264 my $event = shift;
265
266 my $cb = $hook[$event]
267 or return; 1193 or return;
268 1194
269 List::Util::max map &$_, values %$cb 1195 my $st = eval { Coro::Storable::thaw $av };
270} 1196 $av = $st->{objs};
271
272sub inject_command {
273 my ($name, $obj, $params) = @_;
274
275 for my $cmd (@{ $command{$name} }) {
276 $cmd->[1]->($obj, $params);
277 } 1197 }
278 1198
279 -1 1199 utf8::decode (my $decname = $filename);
1200 warn sprintf "loading %s (%d,%d)\n",
1201 $decname, length $data, scalar @{$av || []};
1202
1203 ($data, $av)
280} 1204}
1205
1206=head2 COMMAND CALLBACKS
1207
1208=over 4
1209
1210=cut
1211
1212#############################################################################
1213# command handling &c
1214
1215=item cf::register_command $name => \&callback($ob,$args);
1216
1217Register a callback for execution when the client sends the user command
1218$name.
1219
1220=cut
281 1221
282sub register_command { 1222sub register_command {
283 my ($name, $time, $cb) = @_; 1223 my ($name, $cb) = @_;
284 1224
285 my $caller = caller; 1225 my $caller = caller;
286 #warn "registering command '$name/$time' to '$caller'"; 1226 #warn "registering command '$name/$time' to '$caller'";
287 1227
288 push @{ $command{$name} }, [$time, $cb, $caller]; 1228 push @{ $COMMAND{$name} }, [$caller, $cb];
289 $COMMAND{"$name\000"} = List::Util::max map $_->[0], @{ $command{$name} };
290} 1229}
1230
1231=item cf::register_extcmd $name => \&callback($pl,$packet);
1232
1233Register a callback for execution when the client sends an (synchronous)
1234extcmd packet. Ext commands will be processed in the order they are
1235received by the server, like other user commands. The first argument is
1236the logged-in player. Ext commands can only be processed after a player
1237has logged in successfully.
1238
1239If the callback returns something, it is sent back as if reply was being
1240called.
1241
1242=item cf::register_exticmd $name => \&callback($ns,$packet);
1243
1244Register a callback for execution when the client sends an (asynchronous)
1245exticmd packet. Exti commands are processed by the server as soon as they
1246are received, i.e. out of order w.r.t. other commands. The first argument
1247is a client socket. Exti commands can be received anytime, even before
1248log-in.
1249
1250If the callback returns something, it is sent back as if reply was being
1251called.
1252
1253=cut
291 1254
292sub register_extcmd { 1255sub register_extcmd {
293 my ($name, $cb) = @_; 1256 my ($name, $cb) = @_;
294 1257
295 my $caller = caller; 1258 $EXTCMD{$name} = $cb;
296 #warn "registering extcmd '$name' to '$caller'";
297
298 $extcmd{$name} = [$cb, $caller];
299} 1259}
300 1260
301sub register { 1261sub register_exticmd {
302 my ($base, $pkg) = @_; 1262 my ($name, $cb) = @_;
303 1263
304 for my $idx (0 .. $#PLUGIN_EVENT) { 1264 $EXTICMD{$name} = $cb;
305 if (my $ref = $pkg->can ("on_$PLUGIN_EVENT[$idx]")) {
306 #warn "registering $PLUGIN_EVENT[$idx] hook to '$pkg'\n";
307 $hook[$idx]{$base} = $ref;
308 }
309 }
310} 1265}
311 1266
312sub load_extension { 1267cf::player->attach (
313 my ($path) = @_; 1268 on_command => sub {
1269 my ($pl, $name, $params) = @_;
314 1270
315 $path =~ /([^\/\\]+)\.ext$/ or die "$path"; 1271 my $cb = $COMMAND{$name}
316 my $base = $1; 1272 or return;
317 my $pkg = $1;
318 $pkg =~ s/[^[:word:]]/_/g;
319 $pkg = "ext::$pkg";
320 1273
321 warn "loading '$path' into '$pkg'\n"; 1274 for my $cmd (@$cb) {
322 1275 $cmd->[1]->($pl->ob, $params);
323 open my $fh, "<:utf8", $path
324 or die "$path: $!";
325
326 my $source =
327 "package $pkg; use strict; use utf8;\n"
328 . "#line 1 \"$path\"\n{\n"
329 . (do { local $/; <$fh> })
330 . "\n};\n1";
331
332 eval $source
333 or die "$path: $@";
334
335 push @exts, $pkg;
336 $ext_pkg{$base} = $pkg;
337
338# no strict 'refs';
339# @{"$pkg\::ISA"} = ext::;
340
341 register $base, $pkg;
342}
343
344sub unload_extension {
345 my ($pkg) = @_;
346
347 warn "removing extension $pkg\n";
348
349 # remove hooks
350 for my $idx (0 .. $#PLUGIN_EVENT) {
351 delete $hook[$idx]{$pkg};
352 }
353
354 # remove commands
355 for my $name (keys %command) {
356 my @cb = grep $_->[2] ne $pkg, @{ $command{$name} };
357
358 if (@cb) {
359 $command{$name} = \@cb;
360 $COMMAND{"$name\000"} = List::Util::max map $_->[0], @cb;
361 } else {
362 delete $command{$name};
363 delete $COMMAND{"$name\000"};
364 }
365 }
366
367 # remove extcmds
368 for my $name (grep $extcmd{$_}[1] eq $pkg, keys %extcmd) {
369 delete $extcmd{$name};
370 }
371
372 if (my $cb = $pkg->can ("unload")) {
373 eval {
374 $cb->($pkg);
375 1
376 } or warn "$pkg unloaded, but with errors: $@";
377 }
378
379 Symbol::delete_package $pkg;
380}
381
382sub load_extensions {
383 my $LIBDIR = maps_directory "perl";
384
385 for my $ext (<$LIBDIR/*.ext>) {
386 next unless -r $ext;
387 eval {
388 load_extension $ext;
389 1
390 } or warn "$ext not loaded: $@";
391 }
392}
393
394sub _perl_reload(&) {
395 my ($msg) = @_;
396
397 $msg->("reloading...");
398
399 eval {
400 # 1. cancel all watchers
401 $_->cancel for Event::all_watchers;
402
403 # 2. unload all extensions
404 for (@exts) {
405 $msg->("unloading <$_>");
406 unload_extension $_;
407 }
408
409 # 3. unload all modules loaded from $LIBDIR
410 while (my ($k, $v) = each %INC) {
411 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
412
413 $msg->("removing <$k>");
414 delete $INC{$k};
415
416 $k =~ s/\.pm$//;
417 $k =~ s/\//::/g;
418
419 if (my $cb = $k->can ("unload_module")) {
420 $cb->();
421 }
422
423 Symbol::delete_package $k;
424 }
425
426 # 4. get rid of safe::, as good as possible
427 Symbol::delete_package "safe::$_"
428 for qw(cf::object cf::object::map cf::object::player cf::player cf::map cf::party cf::region);
429
430 # 5. remove register_script_function callbacks
431 # TODO
432
433 # 6. unload cf.pm "a bit"
434 delete $INC{"cf.pm"};
435
436 # don't, removes xs symbols, too,
437 # and global variables created in xs
438 #Symbol::delete_package __PACKAGE__;
439
440 # 7. reload cf.pm
441 $msg->("reloading cf.pm");
442 require cf;
443 };
444 $msg->($@) if $@;
445
446 $msg->("reloaded");
447};
448
449sub perl_reload() {
450 _perl_reload {
451 warn $_[0];
452 print "$_[0]\n";
453 };
454}
455
456register_command "perl-reload", 0, sub {
457 my ($who, $arg) = @_;
458
459 if ($who->flag (FLAG_WIZ)) {
460 _perl_reload {
461 warn $_[0];
462 $who->message ($_[0]);
463 }; 1276 }
1277
1278 cf::override;
464 } 1279 },
465};
466
467#############################################################################
468# utility functions
469
470use JSON::Syck (); # TODO# replace by JSON::PC once working
471
472sub from_json($) {
473 $JSON::Syck::ImplicitUnicode = 1; # work around JSON::Syck bugs
474 JSON::Syck::Load $_[0]
475}
476
477sub to_json($) {
478 $JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs
479 JSON::Syck::Dump $_[0]
480}
481
482#############################################################################
483# extcmd framework, basically convert ext <msg>
484# into pkg::->on_extcmd_arg1 (...) while shortcutting a few
485
486attach_to_players
487 on_extcmd => sub { 1280 on_extcmd => sub {
488 my ($pl, $buf) = @_; 1281 my ($pl, $buf) = @_;
489 1282
490 my $msg = eval { from_json $buf }; 1283 my $msg = eval { $pl->ns->{json_coder}->decode ($buf) };
491 1284
492 if (ref $msg) { 1285 if (ref $msg) {
1286 my ($type, $reply, @payload) =
1287 "ARRAY" eq ref $msg
1288 ? @$msg
1289 : ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
1290
1291 my @reply;
1292
493 if (my $cb = $extcmd{$msg->{msgtype}}) { 1293 if (my $cb = $EXTCMD{$type}) {
494 if (my %reply = $cb->[0]->($pl, $msg)) { 1294 @reply = $cb->($pl, @payload);
495 $pl->ext_reply ($msg->{msgid}, %reply); 1295 }
1296
1297 $pl->ext_reply ($reply, @reply)
1298 if $reply;
1299
1300 } else {
1301 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
1302 }
1303
1304 cf::override;
1305 },
1306);
1307
1308sub load_extensions {
1309 cf::sync_job {
1310 my %todo;
1311
1312 for my $path (<$LIBDIR/*.ext>) {
1313 next unless -r $path;
1314
1315 $path =~ /([^\/\\]+)\.ext$/ or die "$path";
1316 my $base = $1;
1317 my $pkg = $1;
1318 $pkg =~ s/[^[:word:]]/_/g;
1319 $pkg = "ext::$pkg";
1320
1321 open my $fh, "<:utf8", $path
1322 or die "$path: $!";
1323
1324 my $source = do { local $/; <$fh> };
1325
1326 my %ext = (
1327 path => $path,
1328 base => $base,
1329 pkg => $pkg,
1330 );
1331
1332 $ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 }
1333 if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m;
1334
1335 $ext{source} =
1336 "package $pkg; use strict; use utf8;\n"
1337 . "#line 1 \"$path\"\n{\n"
1338 . $source
1339 . "\n};\n1";
1340
1341 $todo{$base} = \%ext;
1342 }
1343
1344 my %done;
1345 while (%todo) {
1346 my $progress;
1347
1348 while (my ($k, $v) = each %todo) {
1349 for (split /,\s*/, $v->{meta}{depends}) {
1350 goto skip
1351 unless exists $done{$_};
1352 }
1353
1354 warn "... loading '$k' into '$v->{pkg}'\n";
1355
1356 unless (eval $v->{source}) {
1357 my $msg = $@ ? "$v->{path}: $@\n"
1358 : "$v->{base}: extension inactive.\n";
1359
1360 if (exists $v->{meta}{mandatory}) {
1361 warn $msg;
1362 cf::cleanup "mandatory extension failed to load, exiting.";
1363 }
1364
1365 warn $msg;
1366 }
1367
1368 $done{$k} = delete $todo{$k};
1369 push @EXTS, $v->{pkg};
1370 $progress = 1;
1371 }
1372
1373 skip:
1374 die "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n"
1375 unless $progress;
1376 }
1377 };
1378}
1379
1380#############################################################################
1381
1382=back
1383
1384=head2 CORE EXTENSIONS
1385
1386Functions and methods that extend core crossfire objects.
1387
1388=cut
1389
1390package cf::player;
1391
1392use Coro::AIO;
1393
1394=head3 cf::player
1395
1396=over 4
1397
1398=item cf::player::num_playing
1399
1400Returns the official number of playing players, as per the Crossfire metaserver rules.
1401
1402=cut
1403
1404sub num_playing {
1405 scalar grep
1406 $_->ob->map
1407 && !$_->hidden
1408 && !$_->ob->flag (cf::FLAG_WIZ),
1409 cf::player::list
1410}
1411
1412=item cf::player::find $login
1413
1414Returns the given player object, loading it if necessary (might block).
1415
1416=cut
1417
1418sub playerdir($) {
1419 "$PLAYERDIR/"
1420 . (ref $_[0] ? $_[0]->ob->name : $_[0])
1421}
1422
1423sub path($) {
1424 my $login = ref $_[0] ? $_[0]->ob->name : $_[0];
1425
1426 (playerdir $login) . "/playerdata"
1427}
1428
1429sub find_active($) {
1430 $cf::PLAYER{$_[0]}
1431 and $cf::PLAYER{$_[0]}->active
1432 and $cf::PLAYER{$_[0]}
1433}
1434
1435sub exists($) {
1436 my ($login) = @_;
1437
1438 $cf::PLAYER{$login}
1439 or cf::sync_job { !aio_stat path $login }
1440}
1441
1442sub find($) {
1443 return $cf::PLAYER{$_[0]} || do {
1444 my $login = $_[0];
1445
1446 my $guard = cf::lock_acquire "user_find:$login";
1447
1448 $cf::PLAYER{$_[0]} || do {
1449 # rename old playerfiles to new ones
1450 #TODO: remove when no longer required
1451 aio_link +(playerdir $login) . "/$login.pl.pst", (playerdir $login) . "/playerdata.pst";
1452 aio_link +(playerdir $login) . "/$login.pl" , (playerdir $login) . "/playerdata";
1453 aio_unlink +(playerdir $login) . "/$login.pl.pst";
1454 aio_unlink +(playerdir $login) . "/$login.pl";
1455
1456 my $f = new_from_file cf::object::thawer path $login
1457 or return;
1458
1459 my $pl = cf::player::load_pl $f
1460 or return;
1461
1462 local $cf::PLAYER_LOADING{$login} = $pl;
1463 $f->resolve_delayed_derefs;
1464 $cf::PLAYER{$login} = $pl
1465 }
1466 }
1467}
1468
1469sub save($) {
1470 my ($pl) = @_;
1471
1472 return if $pl->{deny_save};
1473
1474 my $path = path $pl;
1475 my $guard = cf::lock_acquire "user_save:$path";
1476
1477 return if $pl->{deny_save};
1478
1479 aio_mkdir playerdir $pl, 0770;
1480 $pl->{last_save} = $cf::RUNTIME;
1481
1482 cf::get_slot 0.01;
1483
1484 $pl->save_pl ($path);
1485 cf::cede_to_tick;
1486}
1487
1488sub new($) {
1489 my ($login) = @_;
1490
1491 my $self = create;
1492
1493 $self->ob->name ($login);
1494 $self->{deny_save} = 1;
1495
1496 $cf::PLAYER{$login} = $self;
1497
1498 $self
1499}
1500
1501=item $player->send_msg ($channel, $msg, $color, [extra...])
1502
1503=cut
1504
1505sub send_msg {
1506 my $ns = shift->ns
1507 or return;
1508 $ns->send_msg (@_);
1509}
1510
1511=item $pl->quit_character
1512
1513Nukes the player without looking back. If logged in, the connection will
1514be destroyed. May block for a long time.
1515
1516=cut
1517
1518sub quit_character {
1519 my ($pl) = @_;
1520
1521 my $name = $pl->ob->name;
1522
1523 $pl->{deny_save} = 1;
1524 $pl->password ("*"); # this should lock out the player until we nuked the dir
1525
1526 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active;
1527 $pl->deactivate;
1528 $pl->invoke (cf::EVENT_PLAYER_QUIT);
1529 $pl->ns->destroy if $pl->ns;
1530
1531 my $path = playerdir $pl;
1532 my $temp = "$path~$cf::RUNTIME~deleting~";
1533 aio_rename $path, $temp;
1534 delete $cf::PLAYER{$pl->ob->name};
1535 $pl->destroy;
1536
1537 my $prefix = qr<^~\Q$name\E/>;
1538
1539 # nuke player maps
1540 $cf::MAP{$_}->nuke for grep /$prefix/, keys %cf::MAP;
1541
1542 IO::AIO::aio_rmtree $temp;
1543}
1544
1545=item $pl->kick
1546
1547Kicks a player out of the game. This destroys the connection.
1548
1549=cut
1550
1551sub kick {
1552 my ($pl, $kicker) = @_;
1553
1554 $pl->invoke (cf::EVENT_PLAYER_KICK, $kicker);
1555 $pl->killer ("kicked");
1556 $pl->ns->destroy;
1557}
1558
1559=item cf::player::list_logins
1560
1561Returns am arrayref of all valid playernames in the system, can take a
1562while and may block, so not sync_job-capable, ever.
1563
1564=cut
1565
1566sub list_logins {
1567 my $dirs = aio_readdir $PLAYERDIR
1568 or return [];
1569
1570 my @logins;
1571
1572 for my $login (@$dirs) {
1573 my $path = path $login;
1574
1575 # a .pst is a dead give-away for a valid player
1576 # if no pst file found, open and chekc for blocked users
1577 if (aio_stat "$path.pst") {
1578 my $fh = aio_open $path, Fcntl::O_RDONLY, 0 or next;
1579 aio_read $fh, 0, 512, my $buf, 0 or next;
1580 $buf !~ /^password -------------$/m or next; # official not-valid tag
1581 }
1582
1583 utf8::decode $login;
1584 push @logins, $login;
1585 }
1586
1587 \@logins
1588}
1589
1590=item $player->maps
1591
1592Returns an arrayref of map paths that are private for this
1593player. May block.
1594
1595=cut
1596
1597sub maps($) {
1598 my ($pl) = @_;
1599
1600 $pl = ref $pl ? $pl->ob->name : $pl;
1601
1602 my $files = aio_readdir playerdir $pl
1603 or return;
1604
1605 my @paths;
1606
1607 for (@$files) {
1608 utf8::decode $_;
1609 next if /\.(?:pl|pst)$/;
1610 next unless /^$PATH_SEP/o;
1611
1612 push @paths, cf::map::normalise "~$pl/$_";
1613 }
1614
1615 \@paths
1616}
1617
1618=item $protocol_xml = $player->expand_cfpod ($crossfire_pod)
1619
1620Expand crossfire pod fragments into protocol xml.
1621
1622=cut
1623
1624use re 'eval';
1625
1626my $group;
1627my $interior; $interior = qr{
1628 # match a pod interior sequence sans C<< >>
1629 (?:
1630 \ (.*?)\ (?{ $group = $^N })
1631 | < (??{$interior}) >
1632 )
1633}x;
1634
1635sub expand_cfpod {
1636 my ($self, $pod) = @_;
1637
1638 my $xml;
1639
1640 while () {
1641 if ($pod =~ /\G( (?: [^BCGHITU]+ | .(?!<) )+ )/xgcs) {
1642 $group = $1;
1643
1644 $group =~ s/&/&amp;/g;
1645 $group =~ s/</&lt;/g;
1646
1647 $xml .= $group;
1648 } elsif ($pod =~ m%\G
1649 ([BCGHITU])
1650 <
1651 (?:
1652 ([^<>]*) (?{ $group = $^N })
1653 | < $interior >
1654 )
1655 >
1656 %gcsx
1657 ) {
1658 my ($code, $data) = ($1, $group);
1659
1660 if ($code eq "B") {
1661 $xml .= "<b>" . expand_cfpod ($self, $data) . "</b>";
1662 } elsif ($code eq "I") {
1663 $xml .= "<i>" . expand_cfpod ($self, $data) . "</i>";
1664 } elsif ($code eq "U") {
1665 $xml .= "<u>" . expand_cfpod ($self, $data) . "</u>";
1666 } elsif ($code eq "C") {
1667 $xml .= "<tt>" . expand_cfpod ($self, $data) . "</tt>";
1668 } elsif ($code eq "T") {
1669 $xml .= "<big><b>" . expand_cfpod ($self, $data) . "</b></big>";
1670 } elsif ($code eq "G") {
1671 my ($male, $female) = split /\|/, $data;
1672 $data = $self->gender ? $female : $male;
1673 $xml .= expand_cfpod ($self, $data);
1674 } elsif ($code eq "H") {
1675 $xml .= ("<fg name=\"lightblue\">[" . expand_cfpod ($self, $data) . " (Use hintmode to suppress hints)]</fg>",
1676 "<fg name=\"lightblue\">[Hint suppressed, see hintmode]</fg>",
1677 "")
1678 [$self->{hintmode}];
1679 } else {
1680 $xml .= "error processing '$code($data)' directive";
1681 }
1682 } else {
1683 if ($pod =~ /\G(.+)/) {
1684 warn "parse error while expanding $pod (at $1)";
1685 }
1686 last;
1687 }
1688 }
1689
1690 for ($xml) {
1691 # create single paragraphs (very hackish)
1692 s/(?<=\S)\n(?=\w)/ /g;
1693
1694 # compress some whitespace
1695 s/\s+\n/\n/g; # ws line-ends
1696 s/\n\n+/\n/g; # double lines
1697 s/^\n+//; # beginning lines
1698 s/\n+$//; # ending lines
1699 }
1700
1701 $xml
1702}
1703
1704no re 'eval';
1705
1706sub hintmode {
1707 $_[0]{hintmode} = $_[1] if @_ > 1;
1708 $_[0]{hintmode}
1709}
1710
1711=item $player->ext_reply ($msgid, @msg)
1712
1713Sends an ext reply to the player.
1714
1715=cut
1716
1717sub ext_reply($$@) {
1718 my ($self, $id, @msg) = @_;
1719
1720 $self->ns->ext_reply ($id, @msg)
1721}
1722
1723=item $player->ext_msg ($type, @msg)
1724
1725Sends an ext event to the client.
1726
1727=cut
1728
1729sub ext_msg($$@) {
1730 my ($self, $type, @msg) = @_;
1731
1732 $self->ns->ext_msg ($type, @msg);
1733}
1734
1735=head3 cf::region
1736
1737=over 4
1738
1739=cut
1740
1741package cf::region;
1742
1743=item cf::region::find_by_path $path
1744
1745Tries to decuce the likely region for a map knowing only its path.
1746
1747=cut
1748
1749sub find_by_path($) {
1750 my ($path) = @_;
1751
1752 my ($match, $specificity);
1753
1754 for my $region (list) {
1755 if ($region->{match} && $path =~ $region->{match}) {
1756 ($match, $specificity) = ($region, $region->specificity)
1757 if $region->specificity > $specificity;
1758 }
1759 }
1760
1761 $match
1762}
1763
1764=back
1765
1766=head3 cf::map
1767
1768=over 4
1769
1770=cut
1771
1772package cf::map;
1773
1774use Fcntl;
1775use Coro::AIO;
1776
1777use overload
1778 '""' => \&as_string,
1779 fallback => 1;
1780
1781our $MAX_RESET = 3600;
1782our $DEFAULT_RESET = 3000;
1783
1784sub generate_random_map {
1785 my ($self, $rmp) = @_;
1786
1787 my $lock = cf::lock_acquire "generate_random_map"; # the random map generator is NOT reentrant ATM
1788
1789 # mit "rum" bekleckern, nicht
1790 $self->_create_random_map (
1791 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle},
1792 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle},
1793 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map},
1794 $rmp->{exit_on_final_map},
1795 $rmp->{xsize}, $rmp->{ysize},
1796 $rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3},
1797 $rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase},
1798 $rmp->{dungeon_level}, $rmp->{dungeon_depth}, $rmp->{decoroptions}, $rmp->{orientation},
1799 $rmp->{origin_y}, $rmp->{origin_x}, $rmp->{random_seed}, $rmp->{total_map_hp},
1800 $rmp->{map_layout_style}, $rmp->{treasureoptions}, $rmp->{symmetry_used},
1801 (cf::region::find $rmp->{region}), $rmp->{custom}
1802 )
1803}
1804
1805=item cf::map->register ($regex, $prio)
1806
1807Register a handler for the map path matching the given regex at the
1808givne priority (higher is better, built-in handlers have priority 0, the
1809default).
1810
1811=cut
1812
1813sub register {
1814 my (undef, $regex, $prio) = @_;
1815 my $pkg = caller;
1816
1817 no strict;
1818 push @{"$pkg\::ISA"}, __PACKAGE__;
1819
1820 $EXT_MAP{$pkg} = [$prio, qr<$regex>];
1821}
1822
1823# also paths starting with '/'
1824$EXT_MAP{"cf::map"} = [0, qr{^(?=/)}];
1825
1826sub thawer_merge {
1827 my ($self, $merge) = @_;
1828
1829 # we have to keep some variables in memory intact
1830 local $self->{path};
1831 local $self->{load_path};
1832
1833 $self->SUPER::thawer_merge ($merge);
1834}
1835
1836sub normalise {
1837 my ($path, $base) = @_;
1838
1839 $path = "$path"; # make sure its a string
1840
1841 $path =~ s/\.map$//;
1842
1843 # map plan:
1844 #
1845 # /! non-realised random map exit (special hack!)
1846 # {... are special paths that are not being touched
1847 # ?xxx/... are special absolute paths
1848 # ?random/... random maps
1849 # /... normal maps
1850 # ~user/... per-player map of a specific user
1851
1852 $path =~ s/$PATH_SEP/\//go;
1853
1854 # treat it as relative path if it starts with
1855 # something that looks reasonable
1856 if ($path =~ m{^(?:\./|\.\./|\w)}) {
1857 $base or Carp::carp "normalise called with relative path and no base: '$path'";
1858
1859 $base =~ s{[^/]+/?$}{};
1860 $path = "$base/$path";
1861 }
1862
1863 for ($path) {
1864 redo if s{//}{/};
1865 redo if s{/\.?/}{/};
1866 redo if s{/[^/]+/\.\./}{/};
1867 }
1868
1869 $path
1870}
1871
1872sub new_from_path {
1873 my (undef, $path, $base) = @_;
1874
1875 return $path if UNIVERSAL::isa $path, "cf::map"; # already a map object
1876
1877 $path = normalise $path, $base;
1878
1879 for my $pkg (sort { $EXT_MAP{$b}[0] <=> $EXT_MAP{$a}[0] } keys %EXT_MAP) {
1880 if ($path =~ $EXT_MAP{$pkg}[1]) {
1881 my $self = bless cf::map::new, $pkg;
1882 $self->{path} = $path; $self->path ($path);
1883 $self->init; # pass $1 etc.
1884 return $self;
1885 }
1886 }
1887
1888 Carp::cluck "unable to resolve path '$path' (base '$base').";
1889 ()
1890}
1891
1892sub init {
1893 my ($self) = @_;
1894
1895 $self
1896}
1897
1898sub as_string {
1899 my ($self) = @_;
1900
1901 "$self->{path}"
1902}
1903
1904# the displayed name, this is a one way mapping
1905sub visible_name {
1906 &as_string
1907}
1908
1909# the original (read-only) location
1910sub load_path {
1911 my ($self) = @_;
1912
1913 "$MAPDIR/$self->{path}.map"
1914}
1915
1916# the temporary/swap location
1917sub save_path {
1918 my ($self) = @_;
1919
1920 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/go;
1921 "$TMPDIR/$path.map"
1922}
1923
1924# the unique path, undef == no special unique path
1925sub uniq_path {
1926 my ($self) = @_;
1927
1928 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/go;
1929 "$UNIQUEDIR/$path"
1930}
1931
1932# and all this just because we cannot iterate over
1933# all maps in C++...
1934sub change_all_map_light {
1935 my ($change) = @_;
1936
1937 $_->change_map_light ($change)
1938 for grep $_->outdoor, values %cf::MAP;
1939}
1940
1941sub decay_objects {
1942 my ($self) = @_;
1943
1944 return if $self->{deny_reset};
1945
1946 $self->do_decay_objects;
1947}
1948
1949sub unlink_save {
1950 my ($self) = @_;
1951
1952 utf8::encode (my $save = $self->save_path);
1953 IO::AIO::aioreq_pri 4; Coro::AIO::aio_unlink $save;
1954 IO::AIO::aioreq_pri 4; Coro::AIO::aio_unlink "$save.pst";
1955}
1956
1957sub load_header_from($) {
1958 my ($self, $path) = @_;
1959
1960 utf8::encode $path;
1961 my $f = new_from_file cf::object::thawer $path
1962 or return;
1963
1964 $self->_load_header ($f)
1965 or return;
1966
1967 local $MAP_LOADING{$self->{path}} = $self;
1968 $f->resolve_delayed_derefs;
1969
1970 $self->{load_path} = $path;
1971
1972 1
1973}
1974
1975sub load_header_orig {
1976 my ($self) = @_;
1977
1978 $self->load_header_from ($self->load_path)
1979}
1980
1981sub load_header_temp {
1982 my ($self) = @_;
1983
1984 $self->load_header_from ($self->save_path)
1985}
1986
1987sub prepare_temp {
1988 my ($self) = @_;
1989
1990 $self->last_access ((delete $self->{last_access})
1991 || $cf::RUNTIME); #d#
1992 # safety
1993 $self->{instantiate_time} = $cf::RUNTIME
1994 if $self->{instantiate_time} > $cf::RUNTIME;
1995}
1996
1997sub prepare_orig {
1998 my ($self) = @_;
1999
2000 $self->{load_original} = 1;
2001 $self->{instantiate_time} = $cf::RUNTIME;
2002 $self->last_access ($cf::RUNTIME);
2003 $self->instantiate;
2004}
2005
2006sub load_header {
2007 my ($self) = @_;
2008
2009 if ($self->load_header_temp) {
2010 $self->prepare_temp;
2011 } else {
2012 $self->load_header_orig
2013 or return;
2014 $self->prepare_orig;
2015 }
2016
2017 $self->{deny_reset} = 1
2018 if $self->no_reset;
2019
2020 $self->default_region (cf::region::find_by_path $self->{path})
2021 unless $self->default_region;
2022
2023 1
2024}
2025
2026sub find;
2027sub find {
2028 my ($path, $origin) = @_;
2029
2030 $path = normalise $path, $origin && $origin->path;
2031
2032 cf::lock_wait "map_data:$path";#d#remove
2033 cf::lock_wait "map_find:$path";
2034
2035 $cf::MAP{$path} || do {
2036 my $guard1 = cf::lock_acquire "map_find:$path";
2037 my $guard2 = cf::lock_acquire "map_data:$path"; # just for the fun of it
2038
2039 my $map = new_from_path cf::map $path
2040 or return;
2041
2042 $map->{last_save} = $cf::RUNTIME;
2043
2044 $map->load_header
2045 or return;
2046
2047 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?)
2048 # doing this can freeze the server in a sync job, obviously
2049 #$cf::WAIT_FOR_TICK->wait;
2050 undef $guard1;
2051 undef $guard2;
2052 $map->reset;
2053 return find $path;
2054 }
2055
2056 $cf::MAP{$path} = $map
2057 }
2058}
2059
2060sub pre_load { }
2061sub post_load { }
2062
2063sub load {
2064 my ($self) = @_;
2065
2066 local $self->{deny_reset} = 1; # loading can take a long time
2067
2068 my $path = $self->{path};
2069
2070 {
2071 my $guard = cf::lock_acquire "map_data:$path";
2072
2073 return unless $self->valid;
2074 return unless $self->in_memory == cf::MAP_SWAPPED;
2075
2076 $self->in_memory (cf::MAP_LOADING);
2077
2078 $self->alloc;
2079
2080 $self->pre_load;
2081 cf::cede_to_tick;
2082
2083 my $f = new_from_file cf::object::thawer $self->{load_path};
2084 $f->skip_block;
2085 $self->_load_objects ($f)
2086 or return;
2087
2088 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1)
2089 if delete $self->{load_original};
2090
2091 if (my $uniq = $self->uniq_path) {
2092 utf8::encode $uniq;
2093 unless (aio_stat $uniq) {
2094 if (my $f = new_from_file cf::object::thawer $uniq) {
2095 $self->clear_unique_items;
2096 $self->_load_objects ($f);
2097 $f->resolve_delayed_derefs;
496 } 2098 }
497 } 2099 }
498 } else {
499 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
500 } 2100 }
501 2101
502 cf::override; 2102 $f->resolve_delayed_derefs;
2103
2104 cf::cede_to_tick;
2105 # now do the right thing for maps
2106 $self->link_multipart_objects;
2107 $self->difficulty ($self->estimate_difficulty)
2108 unless $self->difficulty;
2109 cf::cede_to_tick;
2110
2111 unless ($self->{deny_activate}) {
2112 $self->decay_objects;
2113 $self->fix_auto_apply;
2114 $self->update_buttons;
2115 cf::cede_to_tick;
2116 $self->set_darkness_map;
2117 cf::cede_to_tick;
2118 $self->activate;
2119 }
2120
2121 $self->{last_save} = $cf::RUNTIME;
2122 $self->last_access ($cf::RUNTIME);
2123
2124 $self->in_memory (cf::MAP_ACTIVE);
503 }, 2125 }
504;
505 2126
506############################################################################# 2127 $self->post_load;
507# load/save/clean perl data associated with a map 2128}
508 2129
509*cf::mapsupport::on_clean = sub { 2130sub customise_for {
2131 my ($self, $ob) = @_;
2132
2133 return find "~" . $ob->name . "/" . $self->{path}
2134 if $self->per_player;
2135
2136# return find "?party/" . $ob->name . "/" . $self->{path}
2137# if $self->per_party;
2138
2139 $self
2140}
2141
2142# find and load all maps in the 3x3 area around a map
2143sub load_neighbours {
510 my ($map) = @_; 2144 my ($map) = @_;
511 2145
512 my $path = $map->tmpname; 2146 my @neigh; # diagonal neighbours
513 defined $path or return;
514 2147
515 unlink "$path.cfperl"; 2148 for (0 .. 3) {
516}; 2149 my $neigh = $map->tile_path ($_)
2150 or next;
2151 $neigh = find $neigh, $map
2152 or next;
2153 $neigh->load;
517 2154
518*cf::mapsupport::on_swapin = 2155 push @neigh,
519*cf::mapsupport::on_load = sub { 2156 [$neigh->tile_path (($_ + 3) % 4), $neigh],
2157 [$neigh->tile_path (($_ + 1) % 4), $neigh];
2158 }
2159
2160 for (grep defined $_->[0], @neigh) {
2161 my ($path, $origin) = @$_;
2162 my $neigh = find $path, $origin
2163 or next;
2164 $neigh->load;
2165 }
2166}
2167
2168sub find_sync {
2169 my ($path, $origin) = @_;
2170
2171 cf::sync_job { find $path, $origin }
2172}
2173
2174sub do_load_sync {
520 my ($map) = @_; 2175 my ($map) = @_;
521 2176
522 my $path = $map->tmpname; 2177 cf::LOG cf::llevDebug | cf::logBacktrace, "do_load_sync"
523 $path = $map->path unless defined $path; 2178 if $Coro::current == $Coro::main;
524 2179
525 open my $fh, "<:raw", "$path.cfperl" 2180 cf::sync_job { $map->load };
526 or return; # no perl data 2181}
527 2182
528 my $data = Storable::thaw do { local $/; <$fh> }; 2183our %MAP_PREFETCH;
2184our $MAP_PREFETCHER = undef;
529 2185
530 $data->{version} <= 1 2186sub find_async {
531 or return; # too new 2187 my ($path, $origin, $load) = @_;
532 2188
533 $map->_set_obs ($data->{obs}); 2189 $path = normalise $path, $origin && $origin->{path};
534};
535 2190
536*cf::mapsupport::on_swapout = sub { 2191 if (my $map = $cf::MAP{$path}) {
537 my ($map) = @_; 2192 return $map if !$load || $map->in_memory == cf::MAP_ACTIVE;
2193 }
538 2194
539 my $path = $map->tmpname; 2195 $MAP_PREFETCH{$path} |= $load;
540 $path = $map->path unless defined $path;
541 2196
542 my $obs = $map->_get_obs; 2197 $MAP_PREFETCHER ||= cf::async {
2198 $Coro::current->{desc} = "map prefetcher";
543 2199
544 if (defined $obs) { 2200 while (%MAP_PREFETCH) {
545 open my $fh, ">:raw", "$path.cfperl" 2201 while (my ($k, $v) = each %MAP_PREFETCH) {
546 or die "$path.cfperl: $!"; 2202 if (my $map = find $k) {
2203 $map->load if $v;
2204 }
547 2205
548 stat $path; 2206 delete $MAP_PREFETCH{$k};
549 2207 }
550 print $fh Storable::nfreeze {
551 size => (stat _)[7],
552 time => (stat _)[9],
553 version => 1,
554 obs => $obs,
555 }; 2208 }
2209 undef $MAP_PREFETCHER;
2210 };
2211 $MAP_PREFETCHER->prio (6);
556 2212
557 chmod SAVE_MODE, "$path.cfperl"; # very racy, but cf-compatible *g* 2213 ()
2214}
2215
2216sub save {
2217 my ($self) = @_;
2218
2219 my $lock = cf::lock_acquire "map_data:$self->{path}";
2220
2221 $self->{last_save} = $cf::RUNTIME;
2222
2223 return unless $self->dirty;
2224
2225 my $save = $self->save_path; utf8::encode $save;
2226 my $uniq = $self->uniq_path; utf8::encode $uniq;
2227
2228 $self->{load_path} = $save;
2229
2230 return if $self->{deny_save};
2231
2232 local $self->{last_access} = $self->last_access;#d#
2233
2234 cf::async {
2235 $Coro::current->{desc} = "map player save";
2236 $_->contr->save for $self->players;
2237 };
2238
2239 cf::get_slot 0.02;
2240
2241 if ($uniq) {
2242 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS);
2243 $self->_save_objects ($uniq, cf::IO_UNIQUES);
558 } else { 2244 } else {
559 unlink "$path.cfperl"; 2245 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES);
560 }
561};
562
563attach_to_maps prio => -10000, package => cf::mapsupport::;
564
565#############################################################################
566# load/save perl data associated with player->ob objects
567
568sub all_objects(@) {
569 @_, map all_objects ($_->inv), @_
570}
571
572attach_to_players
573 on_load => sub {
574 my ($pl, $path) = @_;
575
576 for my $o (all_objects $pl->ob) {
577 if (my $value = $o->get_ob_key_value ("_perl_data")) {
578 $o->set_ob_key_value ("_perl_data");
579
580 %$o = %{ Storable::thaw pack "H*", $value };
581 }
582 }
583 }, 2246 }
584 on_save => sub { 2247}
585 my ($pl, $path) = @_;
586 2248
587 $_->set_ob_key_value (_perl_data => unpack "H*", Storable::nfreeze $_) 2249sub swap_out {
588 for grep %$_, all_objects $pl->ob; 2250 my ($self) = @_;
2251
2252 # save first because save cedes
2253 $self->save;
2254
2255 my $lock = cf::lock_acquire "map_data:$self->{path}";
2256
2257 return if $self->players;
2258 return if $self->in_memory != cf::MAP_ACTIVE;
2259 return if $self->{deny_save};
2260
2261 $self->in_memory (cf::MAP_SWAPPED);
2262
2263 $self->deactivate;
2264 $_->clear_links_to ($self) for values %cf::MAP;
2265 $self->clear;
2266}
2267
2268sub reset_at {
2269 my ($self) = @_;
2270
2271 # TODO: safety, remove and allow resettable per-player maps
2272 return 1e99 if $self->{deny_reset};
2273
2274 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
2275 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET;
2276
2277 $time + $to
2278}
2279
2280sub should_reset {
2281 my ($self) = @_;
2282
2283 $self->reset_at <= $cf::RUNTIME
2284}
2285
2286sub reset {
2287 my ($self) = @_;
2288
2289 my $lock = cf::lock_acquire "map_data:$self->{path}";
2290
2291 return if $self->players;
2292
2293 warn "resetting map ", $self->path;
2294
2295 $self->in_memory (cf::MAP_SWAPPED);
2296
2297 # need to save uniques path
2298 unless ($self->{deny_save}) {
2299 my $uniq = $self->uniq_path; utf8::encode $uniq;
2300
2301 $self->_save_objects ($uniq, cf::IO_UNIQUES)
2302 if $uniq;
589 }, 2303 }
590;
591 2304
592############################################################################# 2305 delete $cf::MAP{$self->path};
593# core extensions - in perl
594 2306
595=item cf::player::exists $login 2307 $self->deactivate;
2308 $_->clear_links_to ($self) for values %cf::MAP;
2309 $self->clear;
596 2310
597Returns true when the given account exists. 2311 $self->unlink_save;
598 2312 $self->destroy;
599=cut
600
601sub cf::player::exists($) {
602 cf::player::find $_[0]
603 or -f sprintf "%s/%s/%s/%s.pl", cf::localdir, cf::playerdir, ($_[0]) x 2;
604} 2313}
605 2314
2315my $nuke_counter = "aaaa";
2316
2317sub nuke {
2318 my ($self) = @_;
2319
2320 {
2321 my $lock = cf::lock_acquire "map_data:$self->{path}";
2322
2323 delete $cf::MAP{$self->path};
2324
2325 $self->unlink_save;
2326
2327 bless $self, "cf::map";
2328 delete $self->{deny_reset};
2329 $self->{deny_save} = 1;
2330 $self->reset_timeout (1);
2331 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));
2332
2333 $cf::MAP{$self->path} = $self;
2334 }
2335
2336 $self->reset; # polite request, might not happen
2337}
2338
2339=item $maps = cf::map::tmp_maps
2340
2341Returns an arrayref with all map paths of currently instantiated and saved
2342maps. May block.
2343
2344=cut
2345
2346sub tmp_maps() {
2347 [
2348 map {
2349 utf8::decode $_;
2350 /\.map$/
2351 ? normalise $_
2352 : ()
2353 } @{ aio_readdir $TMPDIR or [] }
2354 ]
2355}
2356
2357=item $maps = cf::map::random_maps
2358
2359Returns an arrayref with all map paths of currently instantiated and saved
2360random maps. May block.
2361
2362=cut
2363
2364sub random_maps() {
2365 [
2366 map {
2367 utf8::decode $_;
2368 /\.map$/
2369 ? normalise "?random/$_"
2370 : ()
2371 } @{ aio_readdir $RANDOMDIR or [] }
2372 ]
2373}
2374
2375=item cf::map::unique_maps
2376
2377Returns an arrayref of paths of all shared maps that have
2378instantiated unique items. May block.
2379
2380=cut
2381
2382sub unique_maps() {
2383 [
2384 map {
2385 utf8::decode $_;
2386 s/\.map$//; # TODO future compatibility hack
2387 /\.pst$/ || !/^$PATH_SEP/o # TODO unique maps apparebntly lack the .map suffix :/
2388 ? ()
2389 : normalise $_
2390 } @{ aio_readdir $UNIQUEDIR or [] }
2391 ]
2392}
2393
2394=back
2395
2396=head3 cf::object
2397
2398=cut
2399
2400package cf::object;
2401
2402=over 4
2403
2404=item $ob->inv_recursive
2405
2406Returns the inventory of the object I<and> their inventories, recursively,
2407but I<not> the object itself.
2408
2409=cut
2410
2411sub inv_recursive_;
2412sub inv_recursive_ {
2413 map { $_, inv_recursive_ $_->inv } @_
2414}
2415
2416sub inv_recursive {
2417 inv_recursive_ inv $_[0]
2418}
2419
2420=item $ref = $ob->ref
2421
2422Creates and returns a persistent reference to an object that can be stored as a string.
2423
2424=item $ob = cf::object::deref ($refstring)
2425
2426returns the objetc referenced by refstring. may return undef when it cnanot find the object,
2427even if the object actually exists. May block.
2428
2429=cut
2430
2431sub deref {
2432 my ($ref) = @_;
2433
2434 if ($ref =~ m{^player\/(<1\.[0-9a-f]+>)/(.*)$}) {
2435 my ($uuid, $name) = ($1, $2);
2436 my $pl = $cf::PLAYER_LOADING{$name} || cf::player::find $name
2437 or return;
2438 $pl->ob->uuid eq $uuid
2439 or return;
2440
2441 $pl->ob
2442 } else {
2443 warn "$ref: cannot resolve object reference\n";
2444 undef
2445 }
2446}
2447
2448package cf;
2449
2450=back
2451
2452=head3 cf::object::player
2453
2454=over 4
2455
606=item $player->reply ($npc, $msg[, $flags]) 2456=item $player_object->reply ($npc, $msg[, $flags])
607 2457
608Sends a message to the player, as if the npc C<$npc> replied. C<$npc> 2458Sends a message to the player, as if the npc C<$npc> replied. C<$npc>
609can be C<undef>. Does the right thing when the player is currently in a 2459can be C<undef>. Does the right thing when the player is currently in a
610dialogue with the given NPC character. 2460dialogue with the given NPC character.
611 2461
612=cut 2462=cut
613 2463
614# rough implementation of a future "reply" method that works 2464# rough implementation of a future "reply" method that works
615# with dialog boxes. 2465# with dialog boxes.
2466#TODO: the first argument must go, split into a $npc->reply_to ( method
616sub cf::object::player::reply($$$;$) { 2467sub cf::object::player::reply($$$;$) {
617 my ($self, $npc, $msg, $flags) = @_; 2468 my ($self, $npc, $msg, $flags) = @_;
618 2469
619 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4; 2470 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4;
620 2471
621 if ($self->{record_replies}) { 2472 if ($self->{record_replies}) {
622 push @{ $self->{record_replies} }, [$npc, $msg, $flags]; 2473 push @{ $self->{record_replies} }, [$npc, $msg, $flags];
2474
623 } else { 2475 } else {
2476 my $pl = $self->contr;
2477
2478 if ($pl->{npc_dialog} && $pl->{npc_dialog}->{id}) {
2479 my $dialog = $pl->{npc_dialog};
2480 $dialog->{pl}->ext_msg ($dialog->{id}, update => msg => $dialog->{pl}->expand_cfpod ($msg));
2481
2482 } else {
624 $msg = $npc->name . " says: $msg" if $npc; 2483 $msg = $npc->name . " says: $msg" if $npc;
625 $self->message ($msg, $flags); 2484 $self->message ($msg, $flags);
2485 }
2486 }
2487}
2488
2489=item $object->send_msg ($channel, $msg, $color, [extra...])
2490
2491=cut
2492
2493sub cf::object::send_msg {
2494 my $pl = shift->contr
2495 or return;
2496 $pl->send_msg (@_);
2497}
2498
2499=item $player_object->may ("access")
2500
2501Returns wether the given player is authorized to access resource "access"
2502(e.g. "command_wizcast").
2503
2504=cut
2505
2506sub cf::object::player::may {
2507 my ($self, $access) = @_;
2508
2509 $self->flag (cf::FLAG_WIZ) ||
2510 (ref $cf::CFG{"may_$access"}
2511 ? scalar grep $self->name eq $_, @{$cf::CFG{"may_$access"}}
2512 : $cf::CFG{"may_$access"})
2513}
2514
2515=item $player_object->enter_link
2516
2517Freezes the player and moves him/her to a special map (C<{link}>).
2518
2519The player should be reasonably safe there for short amounts of time. You
2520I<MUST> call C<leave_link> as soon as possible, though.
2521
2522Will never block.
2523
2524=item $player_object->leave_link ($map, $x, $y)
2525
2526Moves the player out of the special C<{link}> map onto the specified
2527map. If the map is not valid (or omitted), the player will be moved back
2528to the location he/she was before the call to C<enter_link>, or, if that
2529fails, to the emergency map position.
2530
2531Might block.
2532
2533=cut
2534
2535sub link_map {
2536 unless ($LINK_MAP) {
2537 $LINK_MAP = cf::map::find "{link}"
2538 or cf::cleanup "FATAL: unable to provide {link} map, exiting.";
2539 $LINK_MAP->load;
2540 }
2541
2542 $LINK_MAP
2543}
2544
2545sub cf::object::player::enter_link {
2546 my ($self) = @_;
2547
2548 $self->deactivate_recursive;
2549
2550 return if UNIVERSAL::isa $self->map, "ext::map_link";
2551
2552 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y]
2553 if $self->map && $self->map->{path} ne "{link}";
2554
2555 $self->enter_map ($LINK_MAP || link_map, 10, 10);
2556}
2557
2558sub cf::object::player::leave_link {
2559 my ($self, $map, $x, $y) = @_;
2560
2561 return unless $self->contr->active;
2562
2563 my $link_pos = delete $self->{_link_pos};
2564
2565 unless ($map) {
2566 # restore original map position
2567 ($map, $x, $y) = @{ $link_pos || [] };
2568 $map = cf::map::find $map;
2569
2570 unless ($map) {
2571 ($map, $x, $y) = @$EMERGENCY_POSITION;
2572 $map = cf::map::find $map
2573 or die "FATAL: cannot load emergency map\n";
2574 }
2575 }
2576
2577 ($x, $y) = (-1, -1)
2578 unless (defined $x) && (defined $y);
2579
2580 # use -1 or undef as default coordinates, not 0, 0
2581 ($x, $y) = ($map->enter_x, $map->enter_y)
2582 if $x <=0 && $y <= 0;
2583
2584 $map->load;
2585 $map->load_neighbours;
2586
2587 return unless $self->contr->active;
2588 $self->activate_recursive;
2589
2590 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
2591 $self->enter_map ($map, $x, $y);
2592}
2593
2594=item $player_object->goto ($path, $x, $y[, $check->($map)[, $done->()]])
2595
2596Moves the player to the given map-path and coordinates by first freezing
2597her, loading and preparing them map, calling the provided $check callback
2598that has to return the map if sucecssful, and then unfreezes the player on
2599the new (success) or old (failed) map position. In either case, $done will
2600be called at the end of this process.
2601
2602=cut
2603
2604our $GOTOGEN;
2605
2606sub cf::object::player::goto {
2607 my ($self, $path, $x, $y, $check, $done) = @_;
2608
2609 # do generation counting so two concurrent goto's will be executed in-order
2610 my $gen = $self->{_goto_generation} = ++$GOTOGEN;
2611
2612 $self->enter_link;
2613
2614 (async {
2615 $Coro::current->{desc} = "player::goto $path $x $y";
2616
2617 # *tag paths override both path and x|y
2618 if ($path =~ /^\*(.*)$/) {
2619 if (my @obs = grep $_->map, ext::map_tags::find $1) {
2620 my $ob = $obs[rand @obs];
2621
2622 # see if we actually can go there
2623 if (@obs = grep !$self->blocked ($_->map, $_->x, $_->y), $ob, $ob->tail) {
2624 $ob = $obs[rand @obs];
2625 } else {
2626 $self->message ("Wow, it's pretty crowded in there.", cf::NDI_UNIQUE | cf::NDI_RED);
2627 }
2628 # else put us there anyways for now #d#
2629
2630 ($path, $x, $y) = ($ob->map, $ob->x, $ob->y);
2631 } else {
2632 ($path, $x, $y) = (undef, undef, undef);
2633 }
2634 }
2635
2636 my $map = eval {
2637 my $map = defined $path ? cf::map::find $path : undef;
2638
2639 if ($map) {
2640 $map = $map->customise_for ($self);
2641 $map = $check->($map) if $check && $map;
2642 } else {
2643 $self->message ("The exit to '$path' is closed.", cf::NDI_UNIQUE | cf::NDI_RED);
2644 }
2645
2646 $map
2647 };
2648
2649 if ($@) {
2650 $self->message ("Something went wrong within the server, please report this incident!", cf::NDI_UNIQUE | cf::NDI_RED);
2651 LOG llevError | logBacktrace, Carp::longmess $@;
2652 }
2653
2654 if ($gen == $self->{_goto_generation}) {
2655 delete $self->{_goto_generation};
2656 $self->leave_link ($map, $x, $y);
2657 }
2658
2659 $done->() if $done;
2660 })->prio (1);
2661}
2662
2663=item $player_object->enter_exit ($exit_object)
2664
2665=cut
2666
2667sub parse_random_map_params {
2668 my ($spec) = @_;
2669
2670 my $rmp = { # defaults
2671 xsize => (cf::rndm 15, 40),
2672 ysize => (cf::rndm 15, 40),
2673 symmetry => (cf::rndm 1, cf::SYMMETRY_XY),
2674 #layout => string,
626 } 2675 };
627}
628 2676
2677 for (split /\n/, $spec) {
2678 my ($k, $v) = split /\s+/, $_, 2;
2679
2680 $rmp->{lc $k} = $v if (length $k) && (length $v);
2681 }
2682
2683 $rmp
2684}
2685
2686sub prepare_random_map {
2687 my ($exit) = @_;
2688
2689 my $guard = cf::lock_acquire "exit_prepare:$exit";
2690
2691 # all this does is basically replace the /! path by
2692 # a new random map path (?random/...) with a seed
2693 # that depends on the exit object
2694
2695 my $rmp = parse_random_map_params $exit->msg;
2696
2697 if ($exit->map) {
2698 $rmp->{region} = $exit->region->name;
2699 $rmp->{origin_map} = $exit->map->path;
2700 $rmp->{origin_x} = $exit->x;
2701 $rmp->{origin_y} = $exit->y;
2702 }
2703
2704 $rmp->{random_seed} ||= $exit->random_seed;
2705
2706 my $data = JSON::XS->new->utf8->pretty->canonical->encode ($rmp);
2707 my $md5 = Digest::MD5::md5_hex $data;
2708 my $meta = "$RANDOMDIR/$md5.meta";
2709
2710 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) {
2711 aio_write $fh, 0, (length $data), $data, 0;
2712 undef $fh;
2713 aio_rename "$meta~", $meta;
2714
2715 $exit->slaying ("?random/$md5");
2716 $exit->msg (undef);
2717 }
2718}
2719
2720sub cf::object::player::enter_exit {
2721 my ($self, $exit) = @_;
2722
2723 return unless $self->type == cf::PLAYER;
2724
2725 if ($exit->slaying eq "/!") {
2726 #TODO: this should de-fi-ni-te-ly not be a sync-job
2727 # the problem is that $exit might not survive long enough
2728 # so it needs to be done right now, right here
2729 cf::sync_job { prepare_random_map $exit };
2730 }
2731
2732 my $slaying = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path;
2733 my $hp = $exit->stats->hp;
2734 my $sp = $exit->stats->sp;
2735
2736 $self->enter_link;
2737
2738 # if exit is damned, update players death & WoR home-position
2739 $self->contr->savebed ($slaying, $hp, $sp)
2740 if $exit->flag (FLAG_DAMNED);
2741
2742 (async {
2743 $Coro::current->{desc} = "enter_exit $slaying $hp $sp";
2744
2745 $self->deactivate_recursive; # just to be sure
2746 unless (eval {
2747 $self->goto ($slaying, $hp, $sp);
2748
2749 1;
2750 }) {
2751 $self->message ("Something went wrong deep within the crossfire server. "
2752 . "I'll try to bring you back to the map you were before. "
2753 . "Please report this to the dungeon master!",
2754 cf::NDI_UNIQUE | cf::NDI_RED);
2755
2756 warn "ERROR in enter_exit: $@";
2757 $self->leave_link;
2758 }
2759 })->prio (1);
2760}
2761
2762=head3 cf::client
2763
2764=over 4
2765
2766=item $client->send_drawinfo ($text, $flags)
2767
2768Sends a drawinfo packet to the client. Circumvents output buffering so
2769should not be used under normal circumstances.
2770
2771=cut
2772
2773sub cf::client::send_drawinfo {
2774 my ($self, $text, $flags) = @_;
2775
2776 utf8::encode $text;
2777 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);
2778}
2779
2780=item $client->send_msg ($channel, $msg, $color, [extra...])
2781
2782Send a drawinfo or msg packet to the client, formatting the msg for the
2783client if neccessary. C<$type> should be a string identifying the type of
2784the message, with C<log> being the default. If C<$color> is negative, suppress
2785the message unless the client supports the msg packet.
2786
2787=cut
2788
2789# non-persistent channels (usually the info channel)
2790our %CHANNEL = (
2791 "c/identify" => {
2792 id => "infobox",
2793 title => "Identify",
2794 reply => undef,
2795 tooltip => "Items recently identified",
2796 },
2797 "c/examine" => {
2798 id => "infobox",
2799 title => "Examine",
2800 reply => undef,
2801 tooltip => "Signs and other items you examined",
2802 },
2803 "c/book" => {
2804 id => "infobox",
2805 title => "Book",
2806 reply => undef,
2807 tooltip => "The contents of a note or book",
2808 },
2809 "c/lookat" => {
2810 id => "infobox",
2811 title => "Look",
2812 reply => undef,
2813 tooltip => "What you saw there",
2814 },
2815 "c/who" => {
2816 id => "infobox",
2817 title => "Players",
2818 reply => undef,
2819 tooltip => "Shows players who are currently online",
2820 },
2821 "c/body" => {
2822 id => "infobox",
2823 title => "Body Parts",
2824 reply => undef,
2825 tooltip => "Shows which body parts you posess and are available",
2826 },
2827 "c/uptime" => {
2828 id => "infobox",
2829 title => "Uptime",
2830 reply => undef,
2831 tooltip => "How long the server has been running since last restart",
2832 },
2833 "c/mapinfo" => {
2834 id => "infobox",
2835 title => "Map Info",
2836 reply => undef,
2837 tooltip => "Information related to the maps",
2838 },
2839 "c/party" => {
2840 id => "party",
2841 title => "Party",
2842 reply => "gsay ",
2843 tooltip => "Messages and chat related to your party",
2844 },
2845);
2846
2847sub cf::client::send_msg {
2848 my ($self, $channel, $msg, $color, @extra) = @_;
2849
2850 $msg = $self->pl->expand_cfpod ($msg);
2851
2852 $color &= cf::NDI_CLIENT_MASK; # just in case...
2853
2854 # check predefined channels, for the benefit of C
2855 if ($CHANNEL{$channel}) {
2856 $channel = $CHANNEL{$channel};
2857
2858 $self->ext_msg (channel_info => $channel)
2859 if $self->can_msg;
2860
2861 $channel = $channel->{id};
2862
2863 } elsif (ref $channel) {
2864 # send meta info to client, if not yet sent
2865 unless (exists $self->{channel}{$channel->{id}}) {
2866 $self->{channel}{$channel->{id}} = $channel;
2867 $self->ext_msg (channel_info => $channel)
2868 if $self->can_msg;
2869 }
2870
2871 $channel = $channel->{id};
2872 }
2873
2874 return unless @extra || length $msg;
2875
2876 if ($self->can_msg) {
2877 # default colour, mask it out
2878 $color &= ~(cf::NDI_COLOR_MASK | cf::NDI_DEF)
2879 if $color & cf::NDI_DEF;
2880
2881 $self->send_packet ("msg " . $self->{json_coder}->encode (
2882 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]));
2883 } else {
2884 if ($color >= 0) {
2885 # replace some tags by gcfclient-compatible ones
2886 for ($msg) {
2887 1 while
2888 s/<b>([^<]*)<\/b>/[b]${1}[\/b]/
2889 || s/<i>([^<]*)<\/i>/[i]${1}[\/i]/
2890 || s/<u>([^<]*)<\/u>/[ul]${1}[\/ul]/
2891 || s/<tt>([^<]*)<\/tt>/[fixed]${1}[\/fixed]/
2892 || s/<fg name=\"([^"]+)\">([^<]*)<\/fg>/[color=$1]${2}[\/color]/;
2893 }
2894
2895 $color &= cf::NDI_COLOR_MASK;
2896
2897 utf8::encode $msg;
2898
2899 if (0 && $msg =~ /\[/) {
2900 # COMMAND/INFO
2901 $self->send_packet ("drawextinfo $color 10 8 $msg")
2902 } else {
2903 $msg =~ s/\[\/?(?:b|i|u|fixed|color)[^\]]*\]//g;
2904 $self->send_packet ("drawinfo $color $msg")
2905 }
2906 }
2907 }
2908}
2909
2910=item $client->ext_msg ($type, @msg)
2911
2912Sends an ext event to the client.
2913
2914=cut
2915
2916sub cf::client::ext_msg($$@) {
2917 my ($self, $type, @msg) = @_;
2918
2919 if ($self->extcmd == 2) {
2920 $self->send_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
2921 } elsif ($self->extcmd == 1) { # TODO: remove
2922 push @msg, msgtype => "event_$type";
2923 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2924 }
2925}
2926
629=item $player->ext_reply ($msgid, $msgtype, %msg) 2927=item $client->ext_reply ($msgid, @msg)
630 2928
631Sends an ext reply to the player. 2929Sends an ext reply to the client.
632 2930
633=cut 2931=cut
634 2932
635sub cf::player::ext_reply($$$%) { 2933sub cf::client::ext_reply($$@) {
636 my ($self, $id, %msg) = @_; 2934 my ($self, $id, @msg) = @_;
637 2935
638 $msg{msgid} = $id; 2936 if ($self->extcmd == 2) {
639 2937 $self->send_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg]));
640 $self->send ("ext " . to_json \%msg); 2938 } elsif ($self->extcmd == 1) {
2939 #TODO: version 1, remove
2940 unshift @msg, msgtype => "reply", msgid => $id;
2941 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2942 }
641} 2943}
642 2944
643############################################################################# 2945=item $success = $client->query ($flags, "text", \&cb)
644# map scripting support 2946
2947Queues a query to the client, calling the given callback with
2948the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>,
2949C<cf::CS_QUERY_SINGLECHAR> or C<cf::CS_QUERY_HIDEINPUT> or C<0>.
2950
2951Queries can fail, so check the return code. Or don't, as queries will
2952become reliable at some point in the future.
2953
2954=cut
2955
2956sub cf::client::query {
2957 my ($self, $flags, $text, $cb) = @_;
2958
2959 return unless $self->state == ST_PLAYING
2960 || $self->state == ST_SETUP
2961 || $self->state == ST_CUSTOM;
2962
2963 $self->state (ST_CUSTOM);
2964
2965 utf8::encode $text;
2966 push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb];
2967
2968 $self->send_packet ($self->{query_queue}[0][0])
2969 if @{ $self->{query_queue} } == 1;
2970
2971 1
2972}
2973
2974cf::client->attach (
2975 on_connect => sub {
2976 my ($ns) = @_;
2977
2978 $ns->{json_coder} = JSON::XS->new->utf8->max_size (1e6)->convert_blessed;
2979 },
2980 on_reply => sub {
2981 my ($ns, $msg) = @_;
2982
2983 # this weird shuffling is so that direct followup queries
2984 # get handled first
2985 my $queue = delete $ns->{query_queue}
2986 or return; # be conservative, not sure how that can happen, but we saw a crash here
2987
2988 (shift @$queue)->[1]->($msg);
2989 return unless $ns->valid; # temporary(?) workaround for callback destroying socket
2990
2991 push @{ $ns->{query_queue} }, @$queue;
2992
2993 if (@{ $ns->{query_queue} } == @$queue) {
2994 if (@$queue) {
2995 $ns->send_packet ($ns->{query_queue}[0][0]);
2996 } else {
2997 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM;
2998 }
2999 }
3000 },
3001 on_exticmd => sub {
3002 my ($ns, $buf) = @_;
3003
3004 my $msg = eval { $ns->{json_coder}->decode ($buf) };
3005
3006 if (ref $msg) {
3007 my ($type, $reply, @payload) =
3008 "ARRAY" eq ref $msg
3009 ? @$msg
3010 : ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
3011
3012 my @reply;
3013
3014 if (my $cb = $EXTICMD{$type}) {
3015 @reply = $cb->($ns, @payload);
3016 }
3017
3018 $ns->ext_reply ($reply, @reply)
3019 if $reply;
3020
3021 } else {
3022 warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";
3023 }
3024
3025 cf::override;
3026 },
3027);
3028
3029=item $client->async (\&cb)
3030
3031Create a new coroutine, running the specified callback. The coroutine will
3032be automatically cancelled when the client gets destroyed (e.g. on logout,
3033or loss of connection).
3034
3035=cut
3036
3037sub cf::client::async {
3038 my ($self, $cb) = @_;
3039
3040 my $coro = &Coro::async ($cb);
3041
3042 $coro->on_destroy (sub {
3043 delete $self->{_coro}{$coro+0};
3044 });
3045
3046 $self->{_coro}{$coro+0} = $coro;
3047
3048 $coro
3049}
3050
3051cf::client->attach (
3052 on_destroy => sub {
3053 my ($ns) = @_;
3054
3055 $_->cancel for values %{ (delete $ns->{_coro}) || {} };
3056 },
3057);
3058
3059=back
3060
3061
3062=head2 SAFE SCRIPTING
3063
3064Functions that provide a safe environment to compile and execute
3065snippets of perl code without them endangering the safety of the server
3066itself. Looping constructs, I/O operators and other built-in functionality
3067is not available in the safe scripting environment, and the number of
3068functions and methods that can be called is greatly reduced.
3069
3070=cut
645 3071
646our $safe = new Safe "safe"; 3072our $safe = new Safe "safe";
647our $safe_hole = new Safe::Hole; 3073our $safe_hole = new Safe::Hole;
648 3074
649$SIG{FPE} = 'IGNORE'; 3075$SIG{FPE} = 'IGNORE';
650 3076
651$safe->permit_only (Opcode::opset qw(:base_core :base_mem :base_orig :base_math sort time)); 3077$safe->permit_only (Opcode::opset qw(
3078 :base_core :base_mem :base_orig :base_math
3079 grepstart grepwhile mapstart mapwhile
3080 sort time
3081));
652 3082
653# here we export the classes and methods available to script code 3083# here we export the classes and methods available to script code
654 3084
3085=pod
3086
3087The following functions and methods are available within a safe environment:
3088
3089 cf::object
3090 contr pay_amount pay_player map x y force_find force_add destroy
3091 insert remove name archname title slaying race decrease split
3092
3093 cf::object::player
3094 player
3095
3096 cf::player
3097 peaceful
3098
3099 cf::map
3100 trigger
3101
3102=cut
3103
655for ( 3104for (
656 ["cf::object" => qw(contr pay_amount pay_player)], 3105 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y
3106 insert remove inv name archname title slaying race
3107 decrease split destroy)],
657 ["cf::object::player" => qw(player)], 3108 ["cf::object::player" => qw(player)],
658 ["cf::player" => qw(peaceful)], 3109 ["cf::player" => qw(peaceful)],
3110 ["cf::map" => qw(trigger)],
659) { 3111) {
660 no strict 'refs'; 3112 no strict 'refs';
661 my ($pkg, @funs) = @$_; 3113 my ($pkg, @funs) = @$_;
662 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"}) 3114 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})
663 for @funs; 3115 for @funs;
664} 3116}
3117
3118=over 4
3119
3120=item @retval = safe_eval $code, [var => value, ...]
3121
3122Compiled and executes the given perl code snippet. additional var/value
3123pairs result in temporary local (my) scalar variables of the given name
3124that are available in the code snippet. Example:
3125
3126 my $five = safe_eval '$first + $second', first => 1, second => 4;
3127
3128=cut
665 3129
666sub safe_eval($;@) { 3130sub safe_eval($;@) {
667 my ($code, %vars) = @_; 3131 my ($code, %vars) = @_;
668 3132
669 my $qcode = $code; 3133 my $qcode = $code;
… …
692 } 3156 }
693 3157
694 wantarray ? @res : $res[0] 3158 wantarray ? @res : $res[0]
695} 3159}
696 3160
3161=item cf::register_script_function $function => $cb
3162
3163Register a function that can be called from within map/npc scripts. The
3164function should be reasonably secure and should be put into a package name
3165like the extension.
3166
3167Example: register a function that gets called whenever a map script calls
3168C<rent::overview>, as used by the C<rent> extension.
3169
3170 cf::register_script_function "rent::overview" => sub {
3171 ...
3172 };
3173
3174=cut
3175
697sub register_script_function { 3176sub register_script_function {
698 my ($fun, $cb) = @_; 3177 my ($fun, $cb) = @_;
699 3178
700 no strict 'refs'; 3179 no strict 'refs';
701 *{"safe::$fun"} = $safe_hole->wrap ($cb); 3180 *{"safe::$fun"} = $safe_hole->wrap ($cb);
702} 3181}
703 3182
3183=back
3184
3185=cut
3186
704############################################################################# 3187#############################################################################
705# the server's main() 3188# the server's init and main functions
3189
3190sub load_facedata($) {
3191 my ($path) = @_;
3192
3193 # HACK to clear player env face cache, we need some signal framework
3194 # for this (global event?)
3195 %ext::player_env::MUSIC_FACE_CACHE = ();
3196
3197 my $enc = JSON::XS->new->utf8->canonical->relaxed;
3198
3199 warn "loading facedata from $path\n";
3200
3201 my $facedata;
3202 0 < aio_load $path, $facedata
3203 or die "$path: $!";
3204
3205 $facedata = Coro::Storable::thaw $facedata;
3206
3207 $facedata->{version} == 2
3208 or cf::cleanup "$path: version mismatch, cannot proceed.";
3209
3210 # patch in the exptable
3211 $facedata->{resource}{"res/exp_table"} = {
3212 type => FT_RSRC,
3213 data => $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]),
3214 };
3215 cf::cede_to_tick;
3216
3217 {
3218 my $faces = $facedata->{faceinfo};
3219
3220 while (my ($face, $info) = each %$faces) {
3221 my $idx = (cf::face::find $face) || cf::face::alloc $face;
3222
3223 cf::face::set_visibility $idx, $info->{visibility};
3224 cf::face::set_magicmap $idx, $info->{magicmap};
3225 cf::face::set_data $idx, 0, $info->{data32}, Digest::MD5::md5 $info->{data32};
3226 cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64};
3227
3228 cf::cede_to_tick;
3229 }
3230
3231 while (my ($face, $info) = each %$faces) {
3232 next unless $info->{smooth};
3233
3234 my $idx = cf::face::find $face
3235 or next;
3236
3237 if (my $smooth = cf::face::find $info->{smooth}) {
3238 cf::face::set_smooth $idx, $smooth;
3239 cf::face::set_smoothlevel $idx, $info->{smoothlevel};
3240 } else {
3241 warn "smooth face '$info->{smooth}' not found for face '$face'";
3242 }
3243
3244 cf::cede_to_tick;
3245 }
3246 }
3247
3248 {
3249 my $anims = $facedata->{animinfo};
3250
3251 while (my ($anim, $info) = each %$anims) {
3252 cf::anim::set $anim, $info->{frames}, $info->{facings};
3253 cf::cede_to_tick;
3254 }
3255
3256 cf::anim::invalidate_all; # d'oh
3257 }
3258
3259 {
3260 # TODO: for gcfclient pleasure, we should give resources
3261 # that gcfclient doesn't grok a >10000 face index.
3262 my $res = $facedata->{resource};
3263
3264 while (my ($name, $info) = each %$res) {
3265 if (defined $info->{type}) {
3266 my $idx = (cf::face::find $name) || cf::face::alloc $name;
3267 my $data;
3268
3269 if ($info->{type} & 1) {
3270 # prepend meta info
3271
3272 my $meta = $enc->encode ({
3273 name => $name,
3274 %{ $info->{meta} || {} },
3275 });
3276
3277 $data = pack "(w/a*)*", $meta, $info->{data};
3278 } else {
3279 $data = $info->{data};
3280 }
3281
3282 cf::face::set_data $idx, 0, $data, Digest::MD5::md5 $data;
3283 cf::face::set_type $idx, $info->{type};
3284 } else {
3285 $RESOURCE{$name} = $info;
3286 }
3287
3288 cf::cede_to_tick;
3289 }
3290 }
3291
3292 cf::global->invoke (EVENT_GLOBAL_RESOURCE_UPDATE);
3293
3294 1
3295}
3296
3297cf::global->attach (on_resource_update => sub {
3298 if (my $soundconf = $RESOURCE{"res/sound.conf"}) {
3299 $soundconf = JSON::XS->new->utf8->relaxed->decode ($soundconf->{data});
3300
3301 for (0 .. SOUND_CAST_SPELL_0 - 1) {
3302 my $sound = $soundconf->{compat}[$_]
3303 or next;
3304
3305 my $face = cf::face::find "sound/$sound->[1]";
3306 cf::sound::set $sound->[0] => $face;
3307 cf::sound::old_sound_index $_, $face; # gcfclient-compat
3308 }
3309
3310 while (my ($k, $v) = each %{$soundconf->{event}}) {
3311 my $face = cf::face::find "sound/$v";
3312 cf::sound::set $k => $face;
3313 }
3314 }
3315});
3316
3317register_exticmd fx_want => sub {
3318 my ($ns, $want) = @_;
3319
3320 while (my ($k, $v) = each %$want) {
3321 $ns->fx_want ($k, $v);
3322 }
3323};
3324
3325sub load_resource_file($) {
3326 my $guard = lock_acquire "load_resource_file";
3327
3328 my $status = load_resource_file_ $_[0];
3329 get_slot 0.1, 100;
3330 cf::arch::commit_load;
3331
3332 $status
3333}
3334
3335sub reload_regions {
3336 # HACK to clear player env face cache, we need some signal framework
3337 # for this (global event?)
3338 %ext::player_env::MUSIC_FACE_CACHE = ();
3339
3340 load_resource_file "$MAPDIR/regions"
3341 or die "unable to load regions file\n";
3342
3343 for (cf::region::list) {
3344 $_->{match} = qr/$_->{match}/
3345 if exists $_->{match};
3346 }
3347}
3348
3349sub reload_facedata {
3350 load_facedata "$DATADIR/facedata"
3351 or die "unable to load facedata\n";
3352}
3353
3354sub reload_archetypes {
3355 load_resource_file "$DATADIR/archetypes"
3356 or die "unable to load archetypes\n";
3357}
3358
3359sub reload_treasures {
3360 load_resource_file "$DATADIR/treasures"
3361 or die "unable to load treasurelists\n";
3362}
3363
3364sub reload_resources {
3365 warn "reloading resource files...\n";
3366
3367 reload_facedata;
3368 reload_archetypes;
3369 reload_regions;
3370 reload_treasures;
3371
3372 warn "finished reloading resource files\n";
3373}
3374
3375sub init {
3376 my $guard = freeze_mainloop;
3377
3378 reload_resources;
3379}
3380
3381sub reload_config {
3382 open my $fh, "<:utf8", "$CONFDIR/config"
3383 or return;
3384
3385 local $/;
3386 *CFG = YAML::Load <$fh>;
3387
3388 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37];
3389
3390 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset};
3391 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset};
3392
3393 if (exists $CFG{mlockall}) {
3394 eval {
3395 $CFG{mlockall} ? eval "mlockall()" : eval "munlockall()"
3396 and die "WARNING: m(un)lockall failed: $!\n";
3397 };
3398 warn $@ if $@;
3399 }
3400}
706 3401
707sub main { 3402sub main {
3403 # we must not ever block the main coroutine
3404 local $Coro::idle = sub {
3405 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
3406 (async {
3407 $Coro::current->{desc} = "IDLE BUG HANDLER";
3408 EV::loop EV::LOOP_ONESHOT;
3409 })->prio (Coro::PRIO_MAX);
3410 };
3411
3412 {
3413 my $guard = freeze_mainloop;
3414 reload_config;
3415 db_init;
3416 load_extensions;
3417
3418 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority
3419 evthread_start IO::AIO::poll_fileno;
3420 }
3421
708 Event::loop; 3422 EV::loop;
709} 3423}
710 3424
711############################################################################# 3425#############################################################################
712# initialisation 3426# initialisation and cleanup
713 3427
714register "<global>", __PACKAGE__; 3428# install some emergency cleanup handlers
3429BEGIN {
3430 our %SIGWATCHER = ();
3431 for my $signal (qw(INT HUP TERM)) {
3432 $SIGWATCHER{$signal} = EV::signal $signal, sub {
3433 cf::cleanup "SIG$signal";
3434 };
3435 }
3436}
3437
3438sub write_runtime_sync {
3439 my $runtime = "$LOCALDIR/runtime";
3440
3441 # first touch the runtime file to show we are still running:
3442 # the fsync below can take a very very long time.
3443
3444 IO::AIO::aio_utime $runtime, undef, undef;
3445
3446 my $guard = cf::lock_acquire "write_runtime";
3447
3448 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644
3449 or return;
3450
3451 my $value = $cf::RUNTIME + 90 + 10;
3452 # 10 is the runtime save interval, for a monotonic clock
3453 # 60 allows for the watchdog to kill the server.
3454
3455 (aio_write $fh, 0, (length $value), $value, 0) <= 0
3456 and return;
3457
3458 # always fsync - this file is important
3459 aio_fsync $fh
3460 and return;
3461
3462 # touch it again to show we are up-to-date
3463 aio_utime $fh, undef, undef;
3464
3465 close $fh
3466 or return;
3467
3468 aio_rename "$runtime~", $runtime
3469 and return;
3470
3471 warn "runtime file written.\n";
3472
3473 1
3474}
3475
3476our $uuid_lock;
3477our $uuid_skip;
3478
3479sub write_uuid_sync($) {
3480 $uuid_skip ||= $_[0];
3481
3482 return if $uuid_lock;
3483 local $uuid_lock = 1;
3484
3485 my $uuid = "$LOCALDIR/uuid";
3486
3487 my $fh = aio_open "$uuid~", O_WRONLY | O_CREAT, 0644
3488 or return;
3489
3490 my $value = uuid_str $uuid_skip + uuid_seq uuid_cur;
3491 $uuid_skip = 0;
3492
3493 (aio_write $fh, 0, (length $value), $value, 0) <= 0
3494 and return;
3495
3496 # always fsync - this file is important
3497 aio_fsync $fh
3498 and return;
3499
3500 close $fh
3501 or return;
3502
3503 aio_rename "$uuid~", $uuid
3504 and return;
3505
3506 warn "uuid file written ($value).\n";
3507
3508 1
3509
3510}
3511
3512sub write_uuid($$) {
3513 my ($skip, $sync) = @_;
3514
3515 $sync ? write_uuid_sync $skip
3516 : async { write_uuid_sync $skip };
3517}
3518
3519sub emergency_save() {
3520 my $freeze_guard = cf::freeze_mainloop;
3521
3522 warn "enter emergency perl save\n";
3523
3524 cf::sync_job {
3525 # use a peculiar iteration method to avoid tripping on perl
3526 # refcount bugs in for. also avoids problems with players
3527 # and maps saved/destroyed asynchronously.
3528 warn "begin emergency player save\n";
3529 for my $login (keys %cf::PLAYER) {
3530 my $pl = $cf::PLAYER{$login} or next;
3531 $pl->valid or next;
3532 delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt
3533 $pl->save;
3534 }
3535 warn "end emergency player save\n";
3536
3537 warn "begin emergency map save\n";
3538 for my $path (keys %cf::MAP) {
3539 my $map = $cf::MAP{$path} or next;
3540 $map->valid or next;
3541 $map->save;
3542 }
3543 warn "end emergency map save\n";
3544
3545 warn "begin emergency database checkpoint\n";
3546 BDB::db_env_txn_checkpoint $DB_ENV;
3547 warn "end emergency database checkpoint\n";
3548
3549 warn "begin write uuid\n";
3550 write_uuid_sync 1;
3551 warn "end write uuid\n";
3552 };
3553
3554 warn "leave emergency perl save\n";
3555}
3556
3557sub post_cleanup {
3558 my ($make_core) = @_;
3559
3560 warn Carp::longmess "post_cleanup backtrace"
3561 if $make_core;
3562}
3563
3564sub do_reload_perl() {
3565 # can/must only be called in main
3566 if ($Coro::current != $Coro::main) {
3567 warn "can only reload from main coroutine";
3568 return;
3569 }
3570
3571 warn "reloading...";
3572
3573 warn "entering sync_job";
3574
3575 cf::sync_job {
3576 cf::write_runtime_sync; # external watchdog should not bark
3577 cf::emergency_save;
3578 cf::write_runtime_sync; # external watchdog should not bark
3579
3580 warn "syncing database to disk";
3581 BDB::db_env_txn_checkpoint $DB_ENV;
3582
3583 # if anything goes wrong in here, we should simply crash as we already saved
3584
3585 warn "flushing outstanding aio requests";
3586 for (;;) {
3587 BDB::flush;
3588 IO::AIO::flush;
3589 Coro::cede_notself;
3590 last unless IO::AIO::nreqs || BDB::nreqs;
3591 warn "iterate...";
3592 }
3593
3594 ++$RELOAD;
3595
3596 warn "cancelling all extension coros";
3597 $_->cancel for values %EXT_CORO;
3598 %EXT_CORO = ();
3599
3600 warn "removing commands";
3601 %COMMAND = ();
3602
3603 warn "removing ext/exti commands";
3604 %EXTCMD = ();
3605 %EXTICMD = ();
3606
3607 warn "unloading/nuking all extensions";
3608 for my $pkg (@EXTS) {
3609 warn "... unloading $pkg";
3610
3611 if (my $cb = $pkg->can ("unload")) {
3612 eval {
3613 $cb->($pkg);
3614 1
3615 } or warn "$pkg unloaded, but with errors: $@";
3616 }
3617
3618 warn "... nuking $pkg";
3619 Symbol::delete_package $pkg;
3620 }
3621
3622 warn "unloading all perl modules loaded from $LIBDIR";
3623 while (my ($k, $v) = each %INC) {
3624 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
3625
3626 warn "... unloading $k";
3627 delete $INC{$k};
3628
3629 $k =~ s/\.pm$//;
3630 $k =~ s/\//::/g;
3631
3632 if (my $cb = $k->can ("unload_module")) {
3633 $cb->();
3634 }
3635
3636 Symbol::delete_package $k;
3637 }
3638
3639 warn "getting rid of safe::, as good as possible";
3640 Symbol::delete_package "safe::$_"
3641 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
3642
3643 warn "unloading cf.pm \"a bit\"";
3644 delete $INC{"cf.pm"};
3645 delete $INC{"cf/pod.pm"};
3646
3647 # don't, removes xs symbols, too,
3648 # and global variables created in xs
3649 #Symbol::delete_package __PACKAGE__;
3650
3651 warn "unload completed, starting to reload now";
3652
3653 warn "reloading cf.pm";
3654 require cf;
3655 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
3656
3657 warn "loading config and database again";
3658 cf::reload_config;
3659
3660 warn "loading extensions";
3661 cf::load_extensions;
3662
3663 warn "reattaching attachments to objects/players";
3664 _global_reattach; # objects, sockets
3665 warn "reattaching attachments to maps";
3666 reattach $_ for values %MAP;
3667 warn "reattaching attachments to players";
3668 reattach $_ for values %PLAYER;
3669
3670 warn "leaving sync_job";
3671
3672 1
3673 } or do {
3674 warn $@;
3675 cf::cleanup "error while reloading, exiting.";
3676 };
3677
3678 warn "reloaded";
3679};
3680
3681our $RELOAD_WATCHER; # used only during reload
3682
3683sub reload_perl() {
3684 # doing reload synchronously and two reloads happen back-to-back,
3685 # coro crashes during coro_state_free->destroy here.
3686
3687 $RELOAD_WATCHER ||= EV::timer 0, 0, sub {
3688 do_reload_perl;
3689 undef $RELOAD_WATCHER;
3690 };
3691}
3692
3693register_command "reload" => sub {
3694 my ($who, $arg) = @_;
3695
3696 if ($who->flag (FLAG_WIZ)) {
3697 $who->message ("reloading server.");
3698 async {
3699 $Coro::current->{desc} = "perl_reload";
3700 reload_perl;
3701 };
3702 }
3703};
715 3704
716unshift @INC, $LIBDIR; 3705unshift @INC, $LIBDIR;
717 3706
718load_extensions; 3707my $bug_warning = 0;
719 3708
720$TICK_WATCHER = Event->timer ( 3709our @WAIT_FOR_TICK;
721 prio => 1, 3710our @WAIT_FOR_TICK_BEGIN;
722 at => $NEXT_TICK || 1, 3711
723 cb => sub { 3712sub wait_for_tick {
3713 return if tick_inhibit || $Coro::current == $Coro::main;
3714
3715 my $signal = new Coro::Signal;
3716 push @WAIT_FOR_TICK, $signal;
3717 $signal->wait;
3718}
3719
3720sub wait_for_tick_begin {
3721 return if tick_inhibit || $Coro::current == $Coro::main;
3722
3723 my $signal = new Coro::Signal;
3724 push @WAIT_FOR_TICK_BEGIN, $signal;
3725 $signal->wait;
3726}
3727
3728sub tick {
3729 if ($Coro::current != $Coro::main) {
3730 Carp::cluck "major BUG: server tick called outside of main coro, skipping it"
3731 unless ++$bug_warning > 10;
3732 return;
3733 }
3734
724 cf::server_tick; # one server iteration 3735 cf::server_tick; # one server iteration
725 3736
726 my $NOW = Event::time; 3737 if ($NOW >= $NEXT_RUNTIME_WRITE) {
727 $NEXT_TICK += $TICK; 3738 $NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.;
728 3739 Coro::async_pool {
729 # if we are delayed by four ticks, skip them all 3740 $Coro::current->{desc} = "runtime saver";
730 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4; 3741 write_runtime_sync
731 3742 or warn "ERROR: unable to write runtime file: $!";
732 $TICK_WATCHER->at ($NEXT_TICK); 3743 };
733 $TICK_WATCHER->start;
734 }, 3744 }
735); 3745
3746 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
3747 $sig->send;
3748 }
3749 while (my $sig = shift @WAIT_FOR_TICK) {
3750 $sig->send;
3751 }
3752
3753 $LOAD = ($NOW - $TICK_START) / $TICK;
3754 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
3755
3756 if (0) {
3757 if ($NEXT_TICK) {
3758 my $jitter = $TICK_START - $NEXT_TICK;
3759 $JITTER = $JITTER * 0.75 + $jitter * 0.25;
3760 warn "jitter $JITTER\n";#d#
3761 }
3762 }
3763}
3764
3765{
3766 # configure BDB
3767
3768 BDB::min_parallel 8;
3769 BDB::max_poll_reqs $TICK * 0.1;
3770 $Coro::BDB::WATCHER->priority (1);
3771
3772 unless ($DB_ENV) {
3773 $DB_ENV = BDB::db_env_create;
3774 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC
3775 | BDB::LOG_AUTOREMOVE, 1);
3776 $DB_ENV->set_timeout (30, BDB::SET_TXN_TIMEOUT);
3777 $DB_ENV->set_timeout (30, BDB::SET_LOCK_TIMEOUT);
3778
3779 cf::sync_job {
3780 eval {
3781 BDB::db_env_open
3782 $DB_ENV,
3783 $BDBDIR,
3784 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN
3785 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE,
3786 0666;
3787
3788 cf::cleanup "db_env_open($BDBDIR): $!" if $!;
3789 };
3790
3791 cf::cleanup "db_env_open(db): $@" if $@;
3792 };
3793 }
3794
3795 $BDB_DEADLOCK_WATCHER = EV::periodic 0, 3, 0, sub {
3796 BDB::db_env_lock_detect $DB_ENV, 0, BDB::LOCK_DEFAULT, 0, sub { };
3797 };
3798 $BDB_CHECKPOINT_WATCHER = EV::periodic 0, 60, 0, sub {
3799 BDB::db_env_txn_checkpoint $DB_ENV, 0, 0, 0, sub { };
3800 };
3801 $BDB_TRICKLE_WATCHER = EV::periodic 0, 10, 0, sub {
3802 BDB::db_env_memp_trickle $DB_ENV, 20, 0, sub { };
3803 };
3804}
3805
3806{
3807 # configure IO::AIO
3808
3809 IO::AIO::min_parallel 8;
3810 IO::AIO::max_poll_time $TICK * 0.1;
3811 $Coro::AIO::WATCHER->priority (1);
3812}
3813
3814my $_log_backtrace;
3815
3816sub _log_backtrace {
3817 my ($msg, @addr) = @_;
3818
3819 $msg =~ s/\n//;
3820
3821 # limit the # of concurrent backtraces
3822 if ($_log_backtrace < 2) {
3823 ++$_log_backtrace;
3824 async {
3825 $Coro::current->{desc} = "abt $msg";
3826
3827 my @bt = fork_call {
3828 @addr = map { sprintf "%x", $_ } @addr;
3829 my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X;
3830 open my $fh, "exec addr2line -C -f -i -e \Q$self\E @addr 2>&1 |"
3831 or die "addr2line: $!";
3832
3833 my @funcs;
3834 my @res = <$fh>;
3835 chomp for @res;
3836 while (@res) {
3837 my ($func, $line) = splice @res, 0, 2, ();
3838 push @funcs, "[$func] $line";
3839 }
3840
3841 @funcs
3842 };
3843
3844 LOG llevInfo, "[ABT] $msg\n";
3845 LOG llevInfo, "[ABT] $_\n" for @bt;
3846 --$_log_backtrace;
3847 };
3848 } else {
3849 LOG llevInfo, "[ABT] $msg\n";
3850 LOG llevInfo, "[ABT] [suppressed]\n";
3851 }
3852}
3853
3854# load additional modules
3855use cf::pod;
3856
3857END { cf::emergency_save }
736 3858
7371 38591
738 3860

Diff Legend

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