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.100 by root, Mon Dec 25 11:25:49 2006 UTC vs.
Revision 1.596 by root, Fri Nov 9 20:37:57 2012 UTC

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

Diff Legend

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