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.27 by root, Fri Jul 21 00:51:39 2006 UTC vs.
Revision 1.539 by root, Tue May 4 22:49:21 2010 UTC

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

Diff Legend

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