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.115 by root, Mon Jan 1 16:50:10 2007 UTC vs.
Revision 1.600 by root, Sun Nov 11 04:31: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 3.3; 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;
18use Coro::AIO; 51use Coro::AIO;
52use Coro::BDB 1.6;
53use Coro::Storable;
54use Coro::Util ();
19 55
20use Digest::MD5; 56use Guard ();
57use JSON::XS 2.01 ();
58use BDB ();
59use Data::Dumper;
21use Fcntl; 60use Fcntl;
22use IO::AIO 2.31 ();
23use YAML::Syck (); 61use YAML::XS ();
24use Time::HiRes; 62use IO::AIO ();
63use Compress::LZF;
64use Digest::MD5 ();
25 65
26use Event; $Event::Eval = 1; # no idea why this is required, but it is 66AnyEvent::detect;
27 67
28# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode? 68# configure various modules to our taste
29$YAML::Syck::ImplicitUnicode = 1; 69#
70$Storable::canonical = 1; # reduce rsync transfers
71Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator
30 72
31$Coro::main->prio (2); # run main coroutine ("the server") with very high priority 73$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority
74
75# make sure c-lzf reinitialises itself
76Compress::LZF::set_serializer "Storable", "Storable::net_mstore", "Storable::mretrieve";
77Compress::LZF::sfreeze_cr { }; # prime Compress::LZF so it does not use require later
78
79# strictly for debugging
80$SIG{QUIT} = sub { Carp::cluck "SIGQUIT" };
32 81
33sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload 82sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
83
84our @ORIG_INC;
34 85
35our %COMMAND = (); 86our %COMMAND = ();
36our %COMMAND_TIME = (); 87our %COMMAND_TIME = ();
88
89our @EXTS = (); # list of extension package names
37our %EXTCMD = (); 90our %EXTCMD = ();
91our %EXTACMD = ();
92our %EXTICMD = ();
93our %EXTIACMD = ();
94our %EXT_CORO = (); # coroutines bound to extensions
95our %EXT_MAP = (); # pluggable maps
38 96
97our $RELOAD; # number of reloads so far, non-zero while in reload
39our @EVENT; 98our @EVENT;
40our $LIBDIR = datadir . "/ext"; 99our @REFLECT; # set by XS
100our %REFLECT; # set by us
41 101
42our $TICK = MAX_TIME * 1e-6; 102our $CONFDIR = confdir;
43our $TICK_WATCHER; 103
104our $DATADIR = datadir;
105our $LIBDIR = "$DATADIR/ext";
106our $PODDIR = "$DATADIR/pod";
107our $MAPDIR = "$DATADIR/" . mapdir;
108
109our $LOCALDIR = localdir;
110our $TMPDIR = "$LOCALDIR/" . tmpdir;
111our $UNIQUEDIR = "$LOCALDIR/" . uniquedir;
112our $PLAYERDIR = "$LOCALDIR/" . playerdir;
113our $RANDOMDIR = "$LOCALDIR/random";
114our $BDBDIR = "$LOCALDIR/db";
115our $PIDFILE = "$LOCALDIR/pid";
116our $RUNTIMEFILE = "$LOCALDIR/runtime";
117
118#our %RESOURCE; # unused
119
120our $OUTPUT_RATE_MIN = 3000;
121our $OUTPUT_RATE_MAX = 1000000;
122
123our $MAX_LINKS = 32; # how many chained exits to follow
124our $VERBOSE_IO = 1;
125
126our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!)
127our $NEXT_RUNTIME_WRITE; # when should the runtime file be written
44our $NEXT_TICK; 128our $NEXT_TICK;
129our $USE_FSYNC = 1; # use fsync to write maps - default on
130
131our $BDB_DEADLOCK_WATCHER;
132our $BDB_CHECKPOINT_WATCHER;
133our $BDB_TRICKLE_WATCHER;
134our $DB_ENV;
135
136our @EXTRA_MODULES = qw(pod match mapscript incloader);
137
138our %CFG;
139our %EXT_CFG; # cfgkeyname => [var-ref, defaultvalue]
140
141our $UPTIME; $UPTIME ||= time;
142our $RUNTIME = 0;
143our $SERVER_TICK = 0;
45our $NOW; 144our $NOW;
46 145
47our %CFG; 146our (%PLAYER, %PLAYER_LOADING); # all users
147our (%MAP, %MAP_LOADING ); # all maps
148our $LINK_MAP; # the special {link} map, which is always available
48 149
49our $UPTIME; $UPTIME ||= time; 150# used to convert map paths into valid unix filenames by replacing / by ∕
50our $RUNTIME; 151our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons
51 152
52our %MAP; # all maps 153our $LOAD; # a number between 0 (idle) and 1 (too many objects)
53our $LINK_MAP; # the special {link} map 154our $LOADAVG; # same thing, but with alpha-smoothing
54our $FREEZE; 155our $JITTER; # average jitter
55our $RANDOM_MAPS = cf::localdir . "/random"; 156our $TICK_START; # for load detecting purposes
56our %EXT_CORO; 157
158our @POST_INIT;
159
160our $REATTACH_ON_RELOAD; # set to true to force object reattach on reload (slow)
161our $REALLY_UNLOOP; # never set to true, please :)
162
163our $WAIT_FOR_TICK = new Coro::Signal;
164our @WAIT_FOR_TICK_BEGIN;
57 165
58binmode STDOUT; 166binmode STDOUT;
59binmode STDERR; 167binmode STDERR;
60 168
61# read virtual server time, if available 169# read virtual server time, if available
62unless ($RUNTIME || !-e cf::localdir . "/runtime") { 170unless ($RUNTIME || !-e $RUNTIMEFILE) {
63 open my $fh, "<", cf::localdir . "/runtime" 171 open my $fh, "<", $RUNTIMEFILE
64 or die "unable to read runtime file: $!"; 172 or die "unable to read $RUNTIMEFILE file: $!";
65 $RUNTIME = <$fh> + 0.; 173 $RUNTIME = <$fh> + 0.;
66} 174}
67 175
68mkdir cf::localdir; 176eval "sub TICK() { $TICK } 1" or die;
69mkdir cf::localdir . "/" . cf::playerdir;
70mkdir cf::localdir . "/" . cf::tmpdir;
71mkdir cf::localdir . "/" . cf::uniquedir;
72mkdir $RANDOM_MAPS;
73 177
74# a special map that is always available 178mkdir $_
75our $LINK_MAP; 179 for $LOCALDIR, $TMPDIR, $UNIQUEDIR, $PLAYERDIR, $RANDOMDIR, $BDBDIR;
76 180
77our $EMERGENCY_POSITION = $cf::CFG{emergency_position} || ["/world/world_105_115", 5, 37]; 181our $EMERGENCY_POSITION;
182
183sub cf::map::normalise;
184
185sub in_main() {
186 $Coro::current == $Coro::main
187}
78 188
79############################################################################# 189#############################################################################
80 190
191%REFLECT = ();
192for (@REFLECT) {
193 my $reflect = JSON::XS::decode_json $_;
194 $REFLECT{$reflect->{class}} = $reflect;
195}
196
197# this is decidedly evil
198$REFLECT{object}{flags} = { map +($_ => undef), grep $_, map /^FLAG_([A-Z0-9_]+)$/ && lc $1, keys %{"cf::"} };
199
200#############################################################################
201
81=head2 GLOBAL VARIABLES 202=head2 GLOBAL VARIABLES
82 203
83=over 4 204=over 4
84 205
85=item $cf::UPTIME 206=item $cf::UPTIME
86 207
87The timestamp of the server start (so not actually an uptime). 208The timestamp of the server start (so not actually an "uptime").
209
210=item $cf::SERVER_TICK
211
212An unsigned integer that starts at zero when the server is started and is
213incremented on every tick.
214
215=item $cf::NOW
216
217The (real) time of the last (current) server tick - updated before and
218after tick processing, so this is useful only as a rough "what time is it
219now" estimate.
220
221=item $cf::TICK
222
223The interval between each server tick, in seconds.
88 224
89=item $cf::RUNTIME 225=item $cf::RUNTIME
90 226
91The time this server has run, starts at 0 and is increased by $cf::TICK on 227The time this server has run, starts at 0 and is increased by $cf::TICK on
92every server tick. 228every server tick.
93 229
94=item $cf::LIBDIR 230=item $cf::CONFDIR $cf::DATADIR $cf::LIBDIR $cf::PODDIR
231$cf::MAPDIR $cf::LOCALDIR $cf::TMPDIR $cf::UNIQUEDIR
232$cf::PLAYERDIR $cf::RANDOMDIR $cf::BDBDIR
95 233
96The perl library directory, where extensions and cf-specific modules can 234Various directories - "/etc", read-only install directory, perl-library
97be found. It will be added to C<@INC> automatically. 235directory, pod-directory, read-only maps directory, "/var", "/var/tmp",
236unique-items directory, player file directory, random maps directory and
237database environment.
98 238
239=item $cf::LOADAVG
240
241The current CPU load on the server (alpha-smoothed), as a value between 0
242(none) and 1 (overloaded), indicating how much time is spent on processing
243objects per tick. Healthy values are < 0.5.
244
99=item $cf::NOW 245=item $cf::LOAD
100 246
101The time of the last (current) server tick. 247The raw value load value from the last tick.
102
103=item $cf::TICK
104
105The interval between server ticks, in seconds.
106 248
107=item %cf::CFG 249=item %cf::CFG
108 250
109Configuration for the server, loaded from C</etc/crossfire/config>, or 251Configuration for the server, loaded from C</etc/deliantra-server/config>, or
110from wherever your confdir points to. 252from wherever your confdir points to.
111 253
254=item cf::wait_for_tick, cf::wait_for_tick_begin
255
256These are functions that inhibit the current coroutine one tick.
257cf::wait_for_tick_begin only returns directly I<after> the tick
258processing (and consequently, can only wake one thread per tick), while
259cf::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
112=back 290=back
113 291
114=cut 292=cut
115 293
116BEGIN { 294sub error(@) { LOG llevError, join "", @_ }
117 *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 {
118 my $msg = join "", @_; 301 my $msg = join "", @_;
119 utf8::encode $msg;
120 302
121 $msg .= "\n" 303 $msg .= "\n"
122 unless $msg =~ /\n$/; 304 unless $msg =~ /\n$/;
123 305
124 LOG llevError, "cfperl: $msg"; 306 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;
125 }; 307
126} 308 LOG llevWarn, $msg;
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};
127 324
128@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable'; 325@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
129@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable'; 326@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';
130@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable'; 327@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable';
131@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable'; 328@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable';
132@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';
133@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)
134 332
135# 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
136# within the Safe compartment. 334# within the Safe compartment.
137for my $pkg (qw( 335for my $pkg (qw(
138 cf::global cf::attachable 336 cf::global cf::attachable
139 cf::object cf::object::player 337 cf::object cf::object::player
140 cf::client cf::player 338 cf::client cf::player
141 cf::arch cf::living 339 cf::arch cf::living
340 cf::map cf::mapspace
142 cf::map cf::party cf::region 341 cf::party cf::region
143)) { 342)) {
144 no strict 'refs';
145 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg; 343 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
146} 344}
147 345
148$Event::DIED = sub { 346$EV::DIED = sub {
149 warn "error in event callback: @_"; 347 warn "error in event callback: $@";
150}; 348};
151 349
152my %ext_pkg; 350#############################################################################
153my @exts; 351
154my @hook; 352sub fork_call(&@);
353sub get_slot($;$$);
354
355#############################################################################
155 356
156=head2 UTILITY FUNCTIONS 357=head2 UTILITY FUNCTIONS
157 358
158=over 4 359=over 4
159 360
160=cut 361=item dumpval $ref
161 362
162use JSON::Syck (); # TODO# replace by JSON::PC once working 363=cut
163 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
164=item $ref = cf::from_json $json 436=item $ref = cf::decode_json $json
165 437
166Converts a JSON string into the corresponding perl data structure. 438Converts a JSON string into the corresponding perl data structure.
167 439
168=cut
169
170sub from_json($) {
171 $JSON::Syck::ImplicitUnicode = 1; # work around JSON::Syck bugs
172 JSON::Syck::Load $_[0]
173}
174
175=item $json = cf::to_json $ref 440=item $json = cf::encode_json $ref
176 441
177Converts a perl data structure into its JSON representation. 442Converts a perl data structure into its JSON representation.
178 443
179=cut 444=cut
180 445
181sub to_json($) { 446our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max
182 $JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs 447
183 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] } @_
184} 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 }
185 650
186=item cf::sync_job { BLOCK } 651=item cf::sync_job { BLOCK }
187 652
188The design of crossfire+ requires that the main coro ($Coro::main) is 653The design of Deliantra requires that the main coroutine ($Coro::main)
189always able to handle events or runnable, as crossfire+ is only partly 654is always able to handle events or runnable, as Deliantra is only
190reentrant. Thus "blocking" it by e.g. waiting for I/O is not acceptable. 655partly reentrant. Thus "blocking" it by e.g. waiting for I/O is not
656acceptable.
191 657
192If it must be done, put the blocking parts into C<sync_job>. This will run 658If it must be done, put the blocking parts into C<sync_job>. This will run
193the given BLOCK in another coroutine while waiting for the result. The 659the given BLOCK in another coroutine while waiting for the result. The
194server will be frozen during this time, so the block should either finish 660server will be frozen during this time, so the block should either finish
195fast or be very important. 661fast or be very important.
197=cut 663=cut
198 664
199sub sync_job(&) { 665sub sync_job(&) {
200 my ($job) = @_; 666 my ($job) = @_;
201 667
202 if ($Coro::current == $Coro::main) { 668 if (in_main) {
669 my $time = AE::time;
670
203 # this is the main coro, too bad, we have to block 671 # this is the main coro, too bad, we have to block
204 # till the operation succeeds, freezing the server :/ 672 # till the operation succeeds, freezing the server :/
205 673
206 # TODO: use suspend/resume instead 674 #LOG llevError, Carp::longmess "sync job";#d#
207 # (but this is cancel-safe) 675
208 local $FREEZE = 1; 676 my $freeze_guard = freeze_mainloop;
209 677
210 my $busy = 1; 678 my $busy = 1;
211 my @res; 679 my @res;
212 680
213 (Coro::async { 681 (async {
682 $Coro::current->desc ("sync job coro");
214 @res = eval { $job->() }; 683 @res = eval { $job->() };
215 warn $@ if $@; 684 error $@ if $@;
216 undef $busy; 685 undef $busy;
217 })->prio (Coro::PRIO_MAX); 686 })->prio (Coro::PRIO_MAX);
218 687
219 while ($busy) { 688 while ($busy) {
689 if (Coro::nready) {
220 Coro::cede_notself; 690 Coro::cede_notself;
221 Event::one_event unless Coro::nready; 691 } else {
692 EV::loop EV::LOOP_ONESHOT;
222 } 693 }
694 }
695
696 my $time = AE::time - $time;
697
698 $TICK_START += $time; # do not account sync jobs to server load
223 699
224 wantarray ? @res : $res[0] 700 wantarray ? @res : $res[0]
225 } else { 701 } else {
226 # we are in another coroutine, how wonderful, everything just works 702 # we are in another coroutine, how wonderful, everything just works
227 703
228 $job->() 704 $job->()
229 } 705 }
230} 706}
231 707
232=item $coro = cf::coro { BLOCK } 708=item $coro = cf::async_ext { BLOCK }
233 709
234Creates and returns a new coro. This coro is automcatially being canceled 710Like async, but this coro is automatically being canceled when the
235when the extension calling this is being unloaded. 711extension calling this is being unloaded.
236 712
237=cut 713=cut
238 714
239sub coro(&) { 715sub async_ext(&) {
240 my $cb = shift; 716 my $cb = shift;
241 717
242 my $coro; $coro = async { 718 my $coro = &Coro::async ($cb);
243 eval {
244 $cb->();
245 };
246 warn $@ if $@;
247 };
248 719
249 $coro->on_destroy (sub { 720 $coro->on_destroy (sub {
250 delete $EXT_CORO{$coro+0}; 721 delete $EXT_CORO{$coro+0};
251 }); 722 });
252 $EXT_CORO{$coro+0} = $coro; 723 $EXT_CORO{$coro+0} = $coro;
253 724
254 $coro 725 $coro
255} 726}
256 727
257sub write_runtime { 728=item fork_call { }, @args
258 my $runtime = cf::localdir . "/runtime";
259 729
260 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644 730Executes the given code block with the given arguments in a seperate
261 or return; 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.
262 734
263 my $value = $cf::RUNTIME + 1 + 10; # 10 is the runtime save interval, for a monotonic clock 735=cut
264 (aio_write $fh, 0, (length $value), $value, 0) <= 0
265 and return;
266 736
267 aio_fsync $fh 737sub post_fork {
268 and return; 738 reset_signals;
739}
269 740
270 close $fh 741sub fork_call(&@) {
271 or return; 742 my ($cb, @args) = @_;
272 743
273 aio_rename "$runtime~", $runtime 744 # we seemingly have to make a local copy of the whole thing,
274 and return; 745 # otherwise perl prematurely frees the stuff :/
746 # TODO: investigate and fix (likely this will be rather laborious)
275 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 {
276 1 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 = EV::time;
907 my $data = $process->(\@data);
908 my $t2 = EV::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 });
277} 931}
278 932
279=back 933=back
280 934
281=cut 935=cut
282 936
283############################################################################# 937#############################################################################
284 938
285package cf::path;
286
287sub new {
288 my ($class, $path, $base) = @_;
289
290 $path = $path->as_string if ref $path;
291
292 my $self = bless { }, $class;
293
294 # {... are special paths that are not touched
295 # ?xxx/... are special absolute paths
296 # ?random/... random maps
297 # /! non-realised random map exit
298 # /... normal maps
299 # ~/... per-player maps without a specific player (DO NOT USE)
300 # ~user/... per-player map of a specific user
301
302 if ($path =~ /^{/) {
303 # fine as it is
304 } elsif ($path =~ s{^\?random/}{}) {
305 Coro::AIO::aio_load "$cf::RANDOM_MAPS/$path.meta", my $data;
306 $self->{random} = cf::from_json $data;
307 } else {
308 if ($path =~ s{^~([^/]+)?}{}) {
309 $self->{user_rel} = 1;
310
311 if (defined $1) {
312 $self->{user} = $1;
313 } elsif ($base =~ m{^~([^/]+)/}) {
314 $self->{user} = $1;
315 } else {
316 warn "cannot resolve user-relative path without user <$path,$base>\n";
317 }
318 } elsif ($path =~ /^\//) {
319 # already absolute
320 } else {
321 $base =~ s{[^/]+/?$}{};
322 return $class->new ("$base/$path");
323 }
324
325 for ($path) {
326 redo if s{/\.?/}{/};
327 redo if s{/[^/]+/\.\./}{/};
328 }
329 }
330
331 $self->{path} = $path;
332
333 $self
334}
335
336# the name / primary key / in-game path
337sub as_string {
338 my ($self) = @_;
339
340 $self->{user_rel} ? "~$self->{user}$self->{path}"
341 : $self->{random} ? "?random/$self->{path}"
342 : $self->{path}
343}
344
345# the displayed name, this is a one way mapping
346sub visible_name {
347 my ($self) = @_;
348
349# if (my $rmp = $self->{random}) {
350# # todo: be more intelligent about this
351# "?random/$rmp->{origin_map}+$rmp->{origin_x}+$rmp->{origin_y}/$rmp->{dungeon_level}"
352# } else {
353 $self->as_string
354# }
355}
356
357# escape the /'s in the path
358sub _escaped_path {
359 # ∕ is U+2215
360 (my $path = $_[0]{path}) =~ s/\//∕/g;
361 $path
362}
363
364# the original (read-only) location
365sub load_path {
366 my ($self) = @_;
367
368 sprintf "%s/%s/%s", cf::datadir, cf::mapdir, $self->{path}
369}
370
371# the temporary/swap location
372sub save_path {
373 my ($self) = @_;
374
375 $self->{user_rel} ? sprintf "%s/%s/%s/%s", cf::localdir, cf::playerdir, $self->{user}, $self->_escaped_path
376 : $self->{random} ? sprintf "%s/%s", $RANDOM_MAPS, $self->{path}
377 : sprintf "%s/%s/%s", cf::localdir, cf::tmpdir, $self->_escaped_path
378}
379
380# the unique path, might be eq to save_path
381sub uniq_path {
382 my ($self) = @_;
383
384 $self->{user_rel} || $self->{random}
385 ? undef
386 : sprintf "%s/%s/%s", cf::localdir, cf::uniquedir, $self->_escaped_path
387}
388
389# return random map parameters, or undef
390sub random_map_params {
391 my ($self) = @_;
392
393 $self->{random}
394}
395
396# this is somewhat ugly, but style maps do need special treatment
397sub is_style_map {
398 $_[0]{path} =~ m{^/styles/}
399}
400
401package cf;
402
403#############################################################################
404
405=head2 ATTACHABLE OBJECTS 939=head2 ATTACHABLE OBJECTS
406 940
407Many 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
408attach callbacks/event handlers (a collection of which is called an "attachment") 942attach callbacks/event handlers (a collection of which is called an "attachment")
409to it. All such attachable objects support the following methods. 943to it. All such attachable objects support the following methods.
410 944
411In 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>
412C<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
413crossfire+). 947Deliantra).
414 948
415=over 4 949=over 4
416 950
417=item $attachable->attach ($attachment, key => $value...) 951=item $attachable->attach ($attachment, key => $value...)
418 952
462=item cf::CLASS::attachment $name, ... 996=item cf::CLASS::attachment $name, ...
463 997
464Register an attachment by C<$name> through which attachable objects of the 998Register an attachment by C<$name> through which attachable objects of the
465given CLASS can refer to this attachment. 999given CLASS can refer to this attachment.
466 1000
467Some classes such as crossfire maps and objects can specify attachments 1001Some classes such as deliantra maps and objects can specify attachments
468that 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.
469 1003
470These calls expect any number of the following handler/hook descriptions: 1004These calls expect any number of the following handler/hook descriptions:
471 1005
472=over 4 1006=over 4
532our @CB_TYPE = (); # registry for type (cf-object class) based events 1066our @CB_TYPE = (); # registry for type (cf-object class) based events
533our @CB_MAP = (); 1067our @CB_MAP = ();
534 1068
535my %attachment; 1069my %attachment;
536 1070
1071sub cf::attachable::thawer_merge {
1072 # simply override everything except _meta
1073 local $_[0]{_meta};
1074 %{$_[0]} = %{$_[1]};
1075}
1076
537sub _attach_cb($$$$) { 1077sub _attach_cb($$$$) {
538 my ($registry, $event, $prio, $cb) = @_; 1078 my ($registry, $event, $prio, $cb) = @_;
539 1079
540 use sort 'stable'; 1080 use sort 'stable';
541 1081
575 $registry = $CB_TYPE[$object_type] ||= []; 1115 $registry = $CB_TYPE[$object_type] ||= [];
576 1116
577 } elsif ($type eq "subtype") { 1117 } elsif ($type eq "subtype") {
578 defined $object_type or Carp::croak "subtype specified without type"; 1118 defined $object_type or Carp::croak "subtype specified without type";
579 my $object_subtype = shift @arg; 1119 my $object_subtype = shift @arg;
580 $registry = $CB_TYPE[$object_type + $object_subtype * NUM_SUBTYPES] ||= []; 1120 $registry = $CB_TYPE[$object_type + $object_subtype * NUM_TYPES] ||= [];
581 1121
582 } elsif ($type eq "package") { 1122 } elsif ($type eq "package") {
583 my $pkg = shift @arg; 1123 my $pkg = shift @arg;
584 1124
585 while (my ($name, $id) = each %cb_id) { 1125 while (my ($name, $id) = each %cb_id) {
590 1130
591 } elsif (exists $cb_id{$type}) { 1131 } elsif (exists $cb_id{$type}) {
592 _attach_cb $registry, $cb_id{$type}, $prio, shift @arg; 1132 _attach_cb $registry, $cb_id{$type}, $prio, shift @arg;
593 1133
594 } elsif (ref $type) { 1134 } elsif (ref $type) {
595 warn "attaching objects not supported, ignoring.\n"; 1135 error "attaching objects not supported, ignoring.\n";
596 1136
597 } else { 1137 } else {
598 shift @arg; 1138 shift @arg;
599 warn "attach argument '$type' not supported, ignoring.\n"; 1139 error "attach argument '$type' not supported, ignoring.\n";
600 } 1140 }
601 } 1141 }
602} 1142}
603 1143
604sub _object_attach { 1144sub _object_attach {
614 _attach $registry, $klass, @attach; 1154 _attach $registry, $klass, @attach;
615 } 1155 }
616 1156
617 $obj->{$name} = \%arg; 1157 $obj->{$name} = \%arg;
618 } else { 1158 } else {
619 warn "object uses attachment '$name' that is not available, postponing.\n"; 1159 info "object uses attachment '$name' which is not available, postponing.\n";
620 } 1160 }
621 1161
622 $obj->{_attachment}{$name} = undef; 1162 $obj->{_attachment}{$name} = undef;
623} 1163}
624 1164
626 if (ref $_[0]) { 1166 if (ref $_[0]) {
627 _object_attach @_; 1167 _object_attach @_;
628 } else { 1168 } else {
629 _attach shift->_attach_registry, @_; 1169 _attach shift->_attach_registry, @_;
630 } 1170 }
1171 _recalc_want;
631}; 1172};
632 1173
633# all those should be optimised 1174# all those should be optimised
634sub cf::attachable::detach { 1175sub cf::attachable::detach {
635 my ($obj, $name) = @_; 1176 my ($obj, $name) = @_;
638 delete $obj->{_attachment}{$name}; 1179 delete $obj->{_attachment}{$name};
639 reattach ($obj); 1180 reattach ($obj);
640 } else { 1181 } else {
641 Carp::croak "cannot, currently, detach class attachments"; 1182 Carp::croak "cannot, currently, detach class attachments";
642 } 1183 }
1184 _recalc_want;
643}; 1185};
644 1186
645sub cf::attachable::attached { 1187sub cf::attachable::attached {
646 my ($obj, $name) = @_; 1188 my ($obj, $name) = @_;
647 1189
662 "; 1204 ";
663 die if $@; 1205 die if $@;
664} 1206}
665 1207
666our $override; 1208our $override;
667our @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?
668 1210
669sub override { 1211sub override {
670 $override = 1; 1212 $override = 1;
671 @invoke_results = (); 1213 @INVOKE_RESULTS = (@_);
672} 1214}
673 1215
674sub do_invoke { 1216sub do_invoke {
675 my $event = shift; 1217 my $event = shift;
676 my $callbacks = shift; 1218 my $callbacks = shift;
677 1219
678 @invoke_results = (); 1220 @INVOKE_RESULTS = ();
679 1221
680 local $override; 1222 local $override;
681 1223
682 for (@$callbacks) { 1224 for (@$callbacks) {
683 eval { &{$_->[1]} }; 1225 eval { &{$_->[1]} };
684 1226
685 if ($@) { 1227 if ($@) {
686 warn "$@";
687 warn "... while processing $EVENT[$event][0](@_) event, skipping processing altogether.\n"; 1228 error "$@", "... while processing $EVENT[$event][0](@_) event, skipping processing altogether.\n";
688 override; 1229 override;
689 } 1230 }
690 1231
691 return 1 if $override; 1232 return 1 if $override;
692 } 1233 }
693 1234
694 0 1235 0
695} 1236}
696 1237
697=item $bool = cf::global::invoke (EVENT_CLASS_XXX, ...) 1238=item $bool = cf::global->invoke (EVENT_CLASS_XXX, ...)
698 1239
699=item $bool = $attachable->invoke (EVENT_CLASS_XXX, ...) 1240=item $bool = $attachable->invoke (EVENT_CLASS_XXX, ...)
700 1241
701Generate an object-specific event with the given arguments. 1242Generate an object-specific event with the given arguments.
702 1243
703This 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
704removed 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
705results (if you must, access C<@cf::invoke_results> directly). 1246results (if you must, access C<@cf::INVOKE_RESULTS> directly).
706 1247
707=back 1248=back
708 1249
709=cut 1250=cut
710 1251
711############################################################################# 1252#############################################################################
712# 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}
713 1296
714sub reattach { 1297sub reattach {
715 # basically do the same as instantiate, without calling instantiate 1298 # basically do the same as instantiate, without calling instantiate
716 my ($obj) = @_; 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
717 1303
718 my $registry = $obj->registry; 1304 my $registry = $obj->registry;
719 1305
720 @$registry = (); 1306 @$registry = ();
721 1307
726 for (@$attach) { 1312 for (@$attach) {
727 my ($klass, @attach) = @$_; 1313 my ($klass, @attach) = @$_;
728 _attach $registry, $klass, @attach; 1314 _attach $registry, $klass, @attach;
729 } 1315 }
730 } else { 1316 } else {
731 warn "object uses attachment '$name' that is not available, postponing.\n"; 1317 info "object uses attachment '$name' that is not available, postponing.\n";
732 } 1318 }
733 } 1319 }
734} 1320}
735 1321
736cf::attachable->attach ( 1322cf::attachable->attach (
737 prio => -1000000, 1323 prio => -1000000,
738 on_instantiate => sub { 1324 on_instantiate => sub {
739 my ($obj, $data) = @_; 1325 my ($obj, $data) = @_;
740 1326
741 $data = from_json $data; 1327 $data = decode_json $data;
742 1328
743 for (@$data) { 1329 for (@$data) {
744 my ($name, $args) = @$_; 1330 my ($name, $args) = @$_;
745 1331
746 $obj->attach ($name, %{$args || {} }); 1332 $obj->attach ($name, %{$args || {} });
762sub object_freezer_save { 1348sub object_freezer_save {
763 my ($filename, $rdata, $objs) = @_; 1349 my ($filename, $rdata, $objs) = @_;
764 1350
765 sync_job { 1351 sync_job {
766 if (length $$rdata) { 1352 if (length $$rdata) {
1353 utf8::decode (my $decname = $filename);
767 warn sprintf "saving %s (%d,%d)\n", 1354 trace sprintf "saving %s (%d,%d)\n",
768 $filename, length $$rdata, scalar @$objs; 1355 $decname, length $$rdata, scalar @$objs
1356 if $VERBOSE_IO;
769 1357
770 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) { 1358 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
771 chmod SAVE_MODE, $fh; 1359 aio_chmod $fh, SAVE_MODE;
772 aio_write $fh, 0, (length $$rdata), $$rdata, 0; 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;
773 aio_fsync $fh; 1363 aio_fsync $fh;
1364 }
774 close $fh; 1365 aio_close $fh;
775 1366
776 if (@$objs) { 1367 if (@$objs) {
777 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) { 1368 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) {
778 chmod SAVE_MODE, $fh; 1369 aio_chmod $fh, SAVE_MODE;
779 my $data = Storable::nfreeze { version => 1, objs => $objs }; 1370 my $data = Coro::Storable::nfreeze { version => 1, objs => $objs };
780 aio_write $fh, 0, (length $data), $data, 0; 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;
781 aio_fsync $fh; 1374 aio_fsync $fh;
1375 }
782 close $fh; 1376 aio_close $fh;
783 aio_rename "$filename.pst~", "$filename.pst"; 1377 aio_rename "$filename.pst~", "$filename.pst";
784 } 1378 }
785 } else { 1379 } else {
786 aio_unlink "$filename.pst"; 1380 aio_unlink "$filename.pst";
787 } 1381 }
788 1382
789 aio_rename "$filename~", $filename; 1383 aio_rename "$filename~", $filename;
1384
1385 $filename =~ s%/[^/]+$%%;
1386 aio_pathsync $filename if $cf::USE_FSYNC;
790 } else { 1387 } else {
791 warn "FATAL: $filename~: $!\n"; 1388 error "unable to save objects: $filename~: $!\n";
792 } 1389 }
793 } else { 1390 } else {
794 aio_unlink $filename; 1391 aio_unlink $filename;
795 aio_unlink "$filename.pst"; 1392 aio_unlink "$filename.pst";
796 } 1393 }
797 } 1394 };
798} 1395}
799 1396
800sub object_freezer_as_string { 1397sub object_freezer_as_string {
801 my ($rdata, $objs) = @_; 1398 my ($rdata, $objs) = @_;
802 1399
814 or return; 1411 or return;
815 1412
816 unless (aio_stat "$filename.pst") { 1413 unless (aio_stat "$filename.pst") {
817 (aio_load "$filename.pst", $av) >= 0 1414 (aio_load "$filename.pst", $av) >= 0
818 or return; 1415 or return;
1416
819 $av = eval { (Storable::thaw $av)->{objs} }; 1417 my $st = eval { Coro::Storable::thaw $av };
1418 $av = $st->{objs};
820 } 1419 }
821 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
822 return ($data, $av); 1426 ($data, $av)
823} 1427}
1428
1429=head2 COMMAND CALLBACKS
1430
1431=over 4
1432
1433=cut
824 1434
825############################################################################# 1435#############################################################################
826# command handling &c 1436# command handling &c
827 1437
828=item cf::register_command $name => \&callback($ob,$args); 1438=item cf::register_command $name => \&callback($ob,$args)
829 1439
830Register a callback for execution when the client sends the user command 1440Register a callback for execution when the client sends the user command
831$name. 1441$name.
832 1442
833=cut 1443=cut
839 #warn "registering command '$name/$time' to '$caller'"; 1449 #warn "registering command '$name/$time' to '$caller'";
840 1450
841 push @{ $COMMAND{$name} }, [$caller, $cb]; 1451 push @{ $COMMAND{$name} }, [$caller, $cb];
842} 1452}
843 1453
844=item cf::register_extcmd $name => \&callback($pl,$packet); 1454=item cf::register_extcmd $name => \&callback($pl,@args)
845 1455
846Register 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.
847 1461
848If the callback returns something, it is sent back as if reply was being 1462The values will be sent back to the client.
849called.
850 1463
851=cut 1464=item cf::register_async_extcmd $name => \&callback($pl,$reply->(...),@args)
852 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
853sub register_extcmd { 1486sub register_extcmd($$) {
854 my ($name, $cb) = @_; 1487 my ($name, $cb) = @_;
855 1488
856 my $caller = caller;
857 #warn "registering extcmd '$name' to '$caller'";
858
859 $EXTCMD{$name} = [$cb, $caller]; 1489 $EXTCMD{$name} = $cb;
860} 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 ();
861 1511
862cf::player->attach ( 1512cf::player->attach (
863 on_command => sub { 1513 on_unknown_command => sub {
864 my ($pl, $name, $params) = @_; 1514 my ($pl, $name, $params) = @_;
865 1515
866 my $cb = $COMMAND{$name} 1516 my $cb = $COMMAND{$name}
867 or return; 1517 or return;
868 1518
873 cf::override; 1523 cf::override;
874 }, 1524 },
875 on_extcmd => sub { 1525 on_extcmd => sub {
876 my ($pl, $buf) = @_; 1526 my ($pl, $buf) = @_;
877 1527
878 my $msg = eval { from_json $buf }; 1528 my $msg = eval { $pl->ns->{json_coder}->decode ($buf) };
879 1529
880 if (ref $msg) { 1530 if (ref $msg) {
1531 my ($type, $reply, @payload) = @$msg; # version 1 used %type, $id, %$hash
1532
881 if (my $cb = $EXTCMD{$msg->{msgtype}}) { 1533 if (my $cb = $EXTACMD{$type}) {
882 if (my %reply = $cb->[0]->($pl, $msg)) { 1534 $cb->(
883 $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);
884 } 1547 }
1548
1549 $pl->ext_msg ("reply-$reply", @reply)
1550 if $reply;
885 } 1551 }
1552
886 } else { 1553 } else {
887 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n"; 1554 error "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
888 } 1555 }
889 1556
890 cf::override; 1557 cf::override;
891 }, 1558 },
892); 1559);
893 1560
894sub register { 1561# "readahead" all extensions
895 my ($base, $pkg) = @_;
896
897 #TODO
898}
899
900sub load_extension { 1562sub cache_extensions {
901 my ($path) = @_; 1563 my $grp = IO::AIO::aio_group;
902 1564
903 $path =~ /([^\/\\]+)\.ext$/ or die "$path"; 1565 add $grp IO::AIO::aio_readdirx $LIBDIR, IO::AIO::READDIR_STAT_ORDER, sub {
904 my $base = $1; 1566 for (grep /\.ext$/, @{$_[0]}) {
905 my $pkg = $1; 1567 add $grp IO::AIO::aio_load "$LIBDIR/$_", my $data;
906 $pkg =~ s/[^[:word:]]/_/g;
907 $pkg = "ext::$pkg";
908
909 warn "loading '$path' into '$pkg'\n";
910
911 open my $fh, "<:utf8", $path
912 or die "$path: $!";
913
914 my $source =
915 "package $pkg; use strict; use utf8;\n"
916 . "#line 1 \"$path\"\n{\n"
917 . (do { local $/; <$fh> })
918 . "\n};\n1";
919
920 eval $source
921 or die $@ ? "$path: $@\n"
922 : "extension disabled.\n";
923
924 push @exts, $pkg;
925 $ext_pkg{$base} = $pkg;
926
927# no strict 'refs';
928# @{"$pkg\::ISA"} = ext::;
929
930 register $base, $pkg;
931}
932
933sub unload_extension {
934 my ($pkg) = @_;
935
936 warn "removing extension $pkg\n";
937
938 # remove hooks
939 #TODO
940# for my $idx (0 .. $#PLUGIN_EVENT) {
941# delete $hook[$idx]{$pkg};
942# }
943
944 # remove commands
945 for my $name (keys %COMMAND) {
946 my @cb = grep $_->[0] ne $pkg, @{ $COMMAND{$name} };
947
948 if (@cb) {
949 $COMMAND{$name} = \@cb;
950 } else {
951 delete $COMMAND{$name};
952 } 1568 }
953 } 1569 };
954 1570
955 # remove extcmds 1571 $grp
956 for my $name (grep $EXTCMD{$_}[1] eq $pkg, keys %EXTCMD) { 1572}
957 delete $EXTCMD{$name};
958 }
959 1573
960 if (my $cb = $pkg->can ("unload")) { 1574sub _ext_cfg_reg($$$$) {
961 eval { 1575 my ($rvar, $varname, $cfgname, $default) = @_;
962 $cb->($pkg);
963 1
964 } or warn "$pkg unloaded, but with errors: $@";
965 }
966 1576
967 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;
968} 1583}
969 1584
970sub load_extensions { 1585sub load_extensions {
1586 info "loading extensions...";
1587
1588 %EXT_CFG = ();
1589
1590 cf::sync_job {
1591 my %todo;
1592
971 for my $ext (<$LIBDIR/*.ext>) { 1593 for my $path (<$LIBDIR/*.ext>) {
972 next unless -r $ext; 1594 next unless -r $path;
973 eval { 1595
974 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 }
975 1 1668 }
976 } 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 }
977 } 1681 };
978} 1682}
979 1683
980############################################################################# 1684#############################################################################
981# load/save/clean perl data associated with a map
982 1685
983*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($) {
984 my ($map) = @_; 1740 my ($login) = @_;
985 1741
986 my $path = $map->tmpname; 1742 $cf::PLAYER{$login}
987 defined $path or return; 1743 or !aio_stat path $login
988
989 unlink "$path.pst";
990};
991
992cf::map->attach (prio => -10000, package => cf::mapsupport::);
993
994#############################################################################
995# load/save perl data associated with player->ob objects
996
997sub all_objects(@) {
998 @_, map all_objects ($_->inv), @_
999} 1744}
1000 1745
1001# 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
1002cf::player->attach ( 1773cf::player->attach (
1003 on_load => sub { 1774 on_load => sub {
1004 my ($pl, $path) = @_; 1775 my ($pl, $path) = @_;
1005 1776
1006 for my $o (all_objects $pl->ob) { 1777 # restore slots saved in save, below
1007 if (my $value = $o->get_ob_key_value ("_perl_data")) { 1778 my $slots = delete $pl->{_slots};
1008 $o->set_ob_key_value ("_perl_data");
1009 1779
1010 %$o = %{ Storable::thaw pack "H*", $value }; 1780 $pl->ob->current_weapon ($slots->[0]);
1011 } 1781 $pl->combat_ob ($slots->[1]);
1012 } 1782 $pl->ranged_ob ($slots->[2]);
1013 }, 1783 },
1014); 1784);
1015 1785
1016############################################################################# 1786sub save($) {
1787 my ($pl) = @_;
1017 1788
1018=head2 CORE EXTENSIONS 1789 return if $pl->{deny_save};
1019 1790
1020Functions and methods that extend core crossfire objects. 1791 my $path = path $pl;
1792 my $guard = cf::lock_acquire "user_save:$path";
1021 1793
1022=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
1023 1961
1024=over 4 1962=over 4
1025 1963
1026=item cf::player::exists $login
1027
1028Returns true when the given account exists.
1029
1030=cut 1964=cut
1031 1965
1032sub cf::player::exists($) { 1966package cf::region;
1033 cf::player::find $_[0]
1034 or -f sprintf "%s/%s/%s/%s.pl", cf::localdir, cf::playerdir, ($_[0]) x 2;
1035}
1036 1967
1037=item $player->ext_reply ($msgid, $msgtype, %msg) 1968=item cf::region::find_by_path $path
1038 1969
1039Sends an ext reply to the player. 1970Tries to decuce the likely region for a map knowing only its path.
1040 1971
1041=cut 1972=cut
1042 1973
1043sub cf::player::ext_reply($$$%) { 1974sub find_by_path($) {
1044 my ($self, $id, %msg) = @_; 1975 my ($path) = @_;
1045 1976
1046 $msg{msgid} = $id; 1977 $path =~ s/^~[^\/]*//; # skip ~login
1047 1978
1048 $self->send ("ext " . to_json \%msg); 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
1049} 1989}
1050 1990
1051=back 1991=back
1052
1053 1992
1054=head3 cf::map 1993=head3 cf::map
1055 1994
1056=over 4 1995=over 4
1057 1996
1060package cf::map; 1999package cf::map;
1061 2000
1062use Fcntl; 2001use Fcntl;
1063use Coro::AIO; 2002use Coro::AIO;
1064 2003
2004use overload
2005 '""' => \&as_string,
2006 fallback => 1;
2007
1065our $MAX_RESET = 7200; 2008our $MAX_RESET = 3600;
1066our $DEFAULT_RESET = 3600; 2009our $DEFAULT_RESET = 3000;
1067 2010
1068sub generate_random_map { 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 {
2040 my ($self, $merge) = @_;
2041
2042 # we have to keep some variables in memory intact
2043 local $self->{path};
2044 local $self->{load_path};
2045
2046 $self->SUPER::thawer_merge ($merge);
2047}
2048
2049sub normalise {
1069 my ($path, $rmp) = @_; 2050 my ($path, $base) = @_;
1070 2051
1071 # mit "rum" bekleckern, nicht 2052 $path = "$path"; # make sure it's a string
1072 cf::map::_create_random_map 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
1073 $path, 2081 $path
1074 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle},
1075 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle},
1076 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map},
1077 $rmp->{exit_on_final_map},
1078 $rmp->{xsize}, $rmp->{ysize},
1079 $rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3},
1080 $rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase},
1081 $rmp->{dungeon_level}, $rmp->{dungeon_depth}, $rmp->{decoroptions}, $rmp->{orientation},
1082 $rmp->{origin_y}, $rmp->{origin_x}, $rmp->{random_seed}, $rmp->{total_map_hp},
1083 $rmp->{map_layout_style}, $rmp->{treasureoptions}, $rmp->{symmetry_used},
1084 (cf::region::find $rmp->{region})
1085} 2082}
1086 2083
1087# and all this just because we cannot iterate over 2084sub new_from_path {
1088# all maps in C++... 2085 my (undef, $path, $base) = @_;
1089sub change_all_map_light { 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 {
1090 my ($change) = @_; 2106 my ($self) = @_;
1091 2107
1092 $_->change_map_light ($change) for values %cf::MAP; 2108 $self
1093} 2109}
1094 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
1095sub try_load_header($) { 2161sub load_header_from($) {
1096 my ($path) = @_; 2162 my ($self, $path) = @_;
1097 2163
1098 utf8::encode $path; 2164 utf8::encode $path;
1099 aio_open $path, O_RDONLY, 0 2165 my $f = new_from_file cf::object::thawer $path
1100 or return; 2166 or return;
1101 2167
1102 my $map = cf::map::new 2168 $self->_load_header ($f)
1103 or return; 2169 or return;
1104 2170
1105 $map->load_header ($path) 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
1106 or return; 2221 or return;
2222 $self->prepare_orig;
2223 }
1107 2224
1108 $map->{load_path} = $path; 2225 $self->{deny_reset} = 1
2226 if $self->no_reset;
1109 2227
1110 $map 2228 $self->default_region (cf::region::find_by_path $self->{path})
1111} 2229 unless $self->default_region;
1112 2230
2231 1
2232}
2233
2234sub find;
1113sub find_map { 2235sub find {
1114 my ($path, $origin) = @_; 2236 my ($path, $origin) = @_;
1115 2237
1116 #warn "find_map<$path,$origin>\n";#d# 2238 cf::cede_to_tick;
1117 2239
1118 $path = new cf::path $path, $origin && $origin->path; 2240 $path = normalise $path, $origin;
1119 my $key = $path->as_string;
1120 2241
2242 my $guard1 = cf::lock_acquire "map_data:$path";#d#remove
2243 my $guard2 = cf::lock_acquire "map_find:$path";
2244
1121 $cf::MAP{$key} || do { 2245 $cf::MAP{$path} || do {
1122 # do it the slow way 2246 my $map = new_from_path cf::map $path
1123 my $map = try_load_header $path->save_path;
1124
1125 if ($map) {
1126 # safety
1127 $map->{instantiate_time} = $cf::RUNTIME
1128 if $map->{instantiate_time} > $cf::RUNTIME;
1129 } else {
1130 if (my $rmp = $path->random_map_params) {
1131 $map = generate_random_map $key, $rmp;
1132 } else {
1133 $map = try_load_header $path->load_path;
1134 }
1135
1136 $map or return; 2247 or return;
1137 2248
1138 $map->{load_original} = 1;
1139 $map->{instantiate_time} = $cf::RUNTIME;
1140 $map->instantiate;
1141
1142 # per-player maps become, after loading, normal maps
1143 $map->per_player (0) if $path->{user_rel};
1144 }
1145
1146 $map->path ($key);
1147 $map->{path} = $path;
1148 $map->last_access ($cf::RUNTIME); 2249 $map->{last_save} = $cf::RUNTIME;
1149 2250
1150 if ($map->should_reset) { 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;
1151 $map->reset; 2259 $map->reset;
1152 $map = find_map $path; 2260 return find $path;
1153 } 2261 }
1154 2262
1155 $cf::MAP{$key} = $map 2263 $cf::MAP{$path} = $map
1156 } 2264 }
1157} 2265}
2266
2267sub pre_load { }
2268#sub post_load { } # XS
1158 2269
1159sub load { 2270sub load {
1160 my ($self) = @_; 2271 my ($self) = @_;
1161 2272
1162 return if $self->in_memory != cf::MAP_SWAPPED; 2273 local $self->{deny_reset} = 1; # loading can take a long time
1163
1164 $self->in_memory (cf::MAP_LOADING);
1165 2274
1166 my $path = $self->{path}; 2275 my $path = $self->{path};
1167 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
1168 $self->alloc; 2283 $self->alloc;
1169 $self->load_objects ($self->{load_path}, 1) 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)
1170 or return; 2292 or return;
1171 2293
1172 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1) 2294 $self->post_load_original
1173 if delete $self->{load_original}; 2295 if delete $self->{load_original};
1174 2296
1175 if (my $uniq = $path->uniq_path) { 2297 if (my $uniq = $self->uniq_path) {
1176 utf8::encode $uniq; 2298 utf8::encode $uniq;
1177 if (aio_open $uniq, O_RDONLY, 0) { 2299 unless (aio_stat $uniq) {
2300 if (my $f = new_from_file cf::object::thawer $uniq) {
1178 $self->clear_unique_items; 2301 $self->clear_unique_items;
1179 $self->load_objects ($uniq, 0); 2302 $self->_load_objects ($f);
2303 $f->resolve_delayed_derefs;
2304 }
2305 }
1180 } 2306 }
1181 }
1182 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;
1183 # now do the right thing for maps 2317 # now do the right thing for maps
1184 $self->link_multipart_objects; 2318 $self->link_multipart_objects;
1185
1186 if ($self->{path}->is_style_map) {
1187 $self->{deny_save} = 1;
1188 $self->{deny_reset} = 1;
1189 } else {
1190 $self->fix_auto_apply;
1191 $self->decay_objects;
1192 $self->update_buttons;
1193 $self->set_darkness_map;
1194 $self->difficulty ($self->estimate_difficulty) 2319 $self->difficulty ($self->estimate_difficulty)
1195 unless $self->difficulty; 2320 unless $self->difficulty;
1196 $self->activate; 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
1197 } 2337 1
1198
1199 $self->in_memory (cf::MAP_IN_MEMORY);
1200} 2338}
1201 2339
1202sub load_map_sync { 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 {
1203 my ($path, $origin) = @_; 2356 my ($path, $origin) = @_;
1204 2357
1205 #warn "load_map_sync<$path, $origin>\n";#d# 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;
1206 2361
1207 cf::sync_job { 2362 find $path, $origin
1208 my $map = cf::map::find_map $path, $origin 2363}
1209 or return; 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
1210 $map->load; 2372 $map->load;
1211 $map 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);
1212 } 2437 }
1213} 2438}
1214 2439
1215sub save { 2440sub save {
1216 my ($self) = @_; 2441 my ($self) = @_;
1217 2442
1218 my $save = $self->{path}->save_path; utf8::encode $save; 2443 my $lock = cf::lock_acquire "map_data:$self->{path}";
1219 my $uniq = $self->{path}->uniq_path; utf8::encode $uniq;
1220 2444
1221 $self->{last_save} = $cf::RUNTIME; 2445 $self->_save;
1222
1223 return unless $self->dirty;
1224
1225 $self->{load_path} = $save;
1226
1227 return if $self->{deny_save};
1228
1229 if ($uniq) {
1230 $self->save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS);
1231 $self->save_objects ($uniq, cf::IO_UNIQUES);
1232 } else {
1233 $self->save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES);
1234 }
1235} 2446}
1236 2447
1237sub swap_out { 2448sub swap_out {
1238 my ($self) = @_; 2449 my ($self) = @_;
1239 2450
2451 my $lock = cf::lock_acquire "map_data:$self->{path}";
2452
2453 return if !$self->linkable;
2454 return if $self->{deny_save};
1240 return if $self->players; 2455 return if $self->players;
1241 return if $self->in_memory != cf::MAP_IN_MEMORY;
1242 return if $self->{deny_save};
1243 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
1244 $self->save; 2463 $self->_save;
2464
2465 # then free the map
1245 $self->clear; 2466 $self->clear;
1246 $self->in_memory (cf::MAP_SWAPPED);
1247} 2467}
1248 2468
1249sub reset_at { 2469sub reset_at {
1250 my ($self) = @_; 2470 my ($self) = @_;
1251 2471
1252 # TODO: safety, remove and allow resettable per-player maps 2472 # TODO: safety, remove and allow resettable per-player maps
1253 return 1e99 if $self->{path}{user_rel};
1254 return 1e99 if $self->{deny_reset}; 2473 return 1e99 if $self->{deny_reset};
1255 2474
1256 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access; 2475 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
1257 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET; 2476 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET;
1258 2477
1263 my ($self) = @_; 2482 my ($self) = @_;
1264 2483
1265 $self->reset_at <= $cf::RUNTIME 2484 $self->reset_at <= $cf::RUNTIME
1266} 2485}
1267 2486
1268sub unlink_save {
1269 my ($self) = @_;
1270
1271 utf8::encode (my $save = $self->{path}->save_path);
1272 aioreq_pri 3; IO::AIO::aio_unlink $save;
1273 aioreq_pri 3; IO::AIO::aio_unlink "$save.pst";
1274}
1275
1276sub rename {
1277 my ($self, $new_path) = @_;
1278
1279 $self->unlink_save;
1280
1281 delete $cf::MAP{$self->path};
1282 $self->{path} = new cf::path $new_path;
1283 $self->path ($self->{path}->as_string);
1284 $cf::MAP{$self->path} = $self;
1285
1286 $self->save;
1287}
1288
1289sub reset { 2487sub reset {
1290 my ($self) = @_; 2488 my ($self) = @_;
1291 2489
2490 my $lock = cf::lock_acquire "map_data:$self->{path}";
2491
1292 return if $self->players; 2492 return if $self->players;
1293 return if $self->{path}{user_rel};#d#
1294 2493
1295 warn "resetting map ", $self->path;#d# 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 }
1296 2505
1297 delete $cf::MAP{$self->path}; 2506 delete $cf::MAP{$self->path};
1298 2507
2508 $self->deactivate;
1299 $_->clear_links_to ($self) for values %cf::MAP; 2509 $_->clear_links_to ($self) for values %cf::MAP;
2510 $self->clear;
1300 2511
1301 $self->unlink_save; 2512 $self->unlink_save;
1302 $self->destroy; 2513 $self->destroy;
1303} 2514}
1304 2515
1305my $nuke_counter = "aaaa"; 2516my $nuke_counter = "aaaa";
1306 2517
1307sub nuke { 2518sub nuke {
1308 my ($self) = @_; 2519 my ($self) = @_;
1309 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};
1310 $self->{deny_save} = 1; 2530 $self->{deny_save} = 1;
1311 $self->reset_timeout (1); 2531 $self->reset_timeout (1);
1312 $self->rename ("{nuke}/" . ($nuke_counter++)); 2532 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));
2533
2534 $cf::MAP{$self->path} = $self;
2535 }
2536
1313 $self->reset; # polite request, might not happen 2537 $self->reset; # polite request, might not happen
1314} 2538}
1315 2539
1316sub customise_for { 2540=item $maps = cf::map::tmp_maps
1317 my ($map, $ob) = @_;
1318 2541
1319 if ($map->per_player) { 2542Returns an arrayref with all map paths of currently instantiated and saved
1320 return cf::map::find_map "~" . $ob->name . "/" . $map->{path}{path}; 2543maps. May block.
2544
2545=cut
2546
2547sub tmp_maps() {
1321 } 2548 [
1322 2549 map {
1323 $map 2550 utf8::decode $_;
2551 /\.map$/
2552 ? normalise $_
2553 : ()
2554 } @{ aio_readdir $TMPDIR or [] }
2555 ]
1324} 2556}
1325 2557
1326sub emergency_save { 2558=item $maps = cf::map::random_maps
1327 local $cf::FREEZE = 1;
1328 2559
1329 warn "enter emergency map save\n"; 2560Returns an arrayref with all map paths of currently instantiated and saved
2561random maps. May block.
1330 2562
1331 cf::sync_job { 2563=cut
1332 warn "begin emergency map save\n"; 2564
1333 $_->save for values %cf::MAP; 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;
1334 }; 2622 }
1335 2623
1336 warn "end emergency map save\n"; 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 }
1337} 2679}
1338 2680
1339package cf; 2681package cf;
1340 2682
1341=back 2683=back
1342
1343 2684
1344=head3 cf::object::player 2685=head3 cf::object::player
1345 2686
1346=over 4 2687=over 4
1347 2688
1350Sends 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>
1351can 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
1352dialogue with the given NPC character. 2693dialogue with the given NPC character.
1353 2694
1354=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};
1355 2710
1356# rough implementation of a future "reply" method that works 2711# rough implementation of a future "reply" method that works
1357# with dialog boxes. 2712# with dialog boxes.
1358#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
1359sub cf::object::player::reply($$$;$) { 2714sub cf::object::player::reply($$$;$) {
1361 2716
1362 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4; 2717 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4;
1363 2718
1364 if ($self->{record_replies}) { 2719 if ($self->{record_replies}) {
1365 push @{ $self->{record_replies} }, [$npc, $msg, $flags]; 2720 push @{ $self->{record_replies} }, [$npc, $msg, $flags];
2721
1366 } 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 {
1367 $msg = $npc->name . " says: $msg" if $npc; 2730 $msg = $npc->name . " says: $msg" if $npc;
1368 $self->message ($msg, $flags); 2731 $self->send_msg ($SAY_CHANNEL => $msg, $flags);
2732 }
1369 } 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 (@_);
1370} 2744}
1371 2745
1372=item $player_object->may ("access") 2746=item $player_object->may ("access")
1373 2747
1374Returns wether the given player is authorized to access resource "access" 2748Returns wether the given player is authorized to access resource "access"
1387 2761
1388=item $player_object->enter_link 2762=item $player_object->enter_link
1389 2763
1390Freezes the player and moves him/her to a special map (C<{link}>). 2764Freezes the player and moves him/her to a special map (C<{link}>).
1391 2765
1392The player should be reaosnably safe there for short amounts of time. You 2766The player should be reasonably safe there for short amounts of time (e.g.
1393I<MUST> call C<leave_link> as soon as possible, though. 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.
1394 2772
1395=item $player_object->leave_link ($map, $x, $y) 2773=item $player_object->leave_link ($map, $x, $y)
1396 2774
1397Moves the player out of the specila link map onto the given map. If the 2775Moves the player out of the special C<{link}> map onto the specified
1398map is not valid (or omitted), the player will be moved back to the 2776map. If the map is not valid (or omitted), the player will be moved back
1399location he/she was before the call to C<enter_link>, or, if that fails, 2777to the location he/she was before the call to C<enter_link>, or, if that
1400to the emergency map position. 2778fails, to the emergency map position.
1401 2779
1402Might block. 2780Might block.
1403 2781
1404=cut 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}
1405 2793
1406sub cf::object::player::enter_link { 2794sub cf::object::player::enter_link {
1407 my ($self) = @_; 2795 my ($self) = @_;
1408 2796
1409 return if $self->map == $LINK_MAP;
1410
1411 $self->{_link_pos} = [$self->map->{path}, $self->x, $self->y]
1412 if $self->map;
1413
1414 $self->enter_map ($LINK_MAP, 20, 20);
1415 $self->deactivate_recursive; 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);
1416} 2807}
1417 2808
1418sub cf::object::player::leave_link { 2809sub cf::object::player::leave_link {
1419 my ($self, $map, $x, $y) = @_; 2810 my ($self, $map, $x, $y) = @_;
2811
2812 return unless $self->contr->active;
1420 2813
1421 my $link_pos = delete $self->{_link_pos}; 2814 my $link_pos = delete $self->{_link_pos};
1422 2815
1423 unless ($map) { 2816 unless ($map) {
1424 # restore original map position 2817 # restore original map position
1425 ($map, $x, $y) = @{ $link_pos || [] }; 2818 ($map, $x, $y) = @{ $link_pos || [] };
1426 $map = cf::map::find_map $map; 2819 $map = cf::map::find $map;
1427 2820
1428 unless ($map) { 2821 unless ($map) {
1429 ($map, $x, $y) = @$EMERGENCY_POSITION; 2822 ($map, $x, $y) = @$EMERGENCY_POSITION;
1430 $map = cf::map::find_map $map 2823 $map = cf::map::find $map
1431 or die "FATAL: cannot load emergency map\n"; 2824 or die "FATAL: cannot load emergency map\n";
1432 } 2825 }
1433 } 2826 }
1434 2827
1435 ($x, $y) = (-1, -1) 2828 ($x, $y) = (-1, -1)
1436 unless (defined $x) && (defined $y); 2829 unless (defined $x) && (defined $y);
1437 2830
1438 # use -1 or undef as default coordinates, not 0, 0 2831 # use -1 or undef as default coordinates, not 0, 0
1439 ($x, $y) = ($map->enter_x, $map->enter_y) 2832 ($x, $y) = ($map->enter_x, $map->enter_y)
1440 if $x <=0 && $y <= 0; 2833 if $x <= 0 && $y <= 0;
1441 2834
1442 $map->load; 2835 $map->load;
1443 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
1444 $self->activate_recursive; 2844 $self->activate_recursive;
1445 $self->enter_map ($map, $x, $y); 2845 }
1446}
1447 2846
1448=item $player_object->goto_map ($map, $x, $y) 2847}
1449 2848
1450=cut 2849=item $player_object->goto ($path, $x, $y[, $check->($map, $x, $y, $player)[, $done->($player)]])
1451 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
1452sub cf::object::player::goto_map { 2864sub cf::object::player::goto {
1453 my ($self, $path, $x, $y) = @_; 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;
1454 2875
1455 $self->enter_link; 2876 $self->enter_link;
1456 2877
1457 (Coro::async { 2878 (async {
1458 $path = new cf::path $path; 2879 $Coro::current->{desc} = "player::goto $path $x $y";
1459 2880
1460 my $map = cf::map::find_map $path->as_string; 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) {
1461 $map = $map->customise_for ($self) 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 }
1462 2909
1463 warn "entering ", $map->path, " at ($x, $y)\n"
1464 if $map; 2910 $map
2911 };
1465 2912
1466 $map or $self->message ("The exit is closed", cf::NDI_UNIQUE | cf::NDI_RED); 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 }
1467 2917
2918 if ($gen == $self->{_goto_generation}) {
2919 delete $self->{_goto_generation};
1468 $self->leave_link ($map, $x, $y); 2920 $self->leave_link ($map, $x, $y);
2921 }
2922
2923 $done->($self) if $done;
1469 })->prio (1); 2924 })->prio (1);
1470} 2925}
1471 2926
1472=item $player_object->enter_exit ($exit_object) 2927=item $player_object->enter_exit ($exit_object)
1473 2928
1475 2930
1476sub parse_random_map_params { 2931sub parse_random_map_params {
1477 my ($spec) = @_; 2932 my ($spec) = @_;
1478 2933
1479 my $rmp = { # defaults 2934 my $rmp = { # defaults
1480 xsize => 10, 2935 xsize => (cf::rndm 15, 40),
1481 ysize => 10, 2936 ysize => (cf::rndm 15, 40),
2937 symmetry => (cf::rndm 1, cf::SYMMETRY_XY),
2938 #layout => string,
1482 }; 2939 };
1483 2940
1484 for (split /\n/, $spec) { 2941 for (split /\n/, $spec) {
1485 my ($k, $v) = split /\s+/, $_, 2; 2942 my ($k, $v) = split /\s+/, $_, 2;
1486 2943
1498 # that depends on the exit object 2955 # that depends on the exit object
1499 2956
1500 my $rmp = parse_random_map_params $exit->msg; 2957 my $rmp = parse_random_map_params $exit->msg;
1501 2958
1502 if ($exit->map) { 2959 if ($exit->map) {
1503 $rmp->{region} = $exit->map->region_name; 2960 $rmp->{region} = $exit->region->name;
1504 $rmp->{origin_map} = $exit->map->path; 2961 $rmp->{origin_map} = $exit->map->path;
1505 $rmp->{origin_x} = $exit->x; 2962 $rmp->{origin_x} = $exit->x;
1506 $rmp->{origin_y} = $exit->y; 2963 $rmp->{origin_y} = $exit->y;
2964
2965 $exit->map->touch;
1507 } 2966 }
1508 2967
1509 $rmp->{random_seed} ||= $exit->random_seed; 2968 $rmp->{random_seed} ||= $exit->random_seed;
1510 2969
1511 my $data = cf::to_json $rmp; 2970 my $data = JSON::XS->new->utf8->pretty->canonical->encode ($rmp);
1512 my $md5 = Digest::MD5::md5_hex $data; 2971 my $md5 = Digest::MD5::md5_hex $data;
2972 my $meta = "$RANDOMDIR/$md5.meta";
1513 2973
1514 if (my $fh = aio_open "$cf::RANDOM_MAPS/$md5.meta", O_WRONLY | O_CREAT, 0666) { 2974 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) {
1515 aio_write $fh, 0, (length $data), $data, 0; 2975 aio_write $fh, 0, (length $data), $data, 0;
2976 undef $fh;
2977 aio_rename "$meta~", $meta;
1516 2978
2979 my $slaying = "?random/$md5";
2980
2981 if ($exit->valid) {
1517 $exit->slaying ("?random/$md5"); 2982 $exit->slaying ("?random/$md5");
1518 $exit->msg (undef); 2983 $exit->msg (undef);
2984 }
1519 } 2985 }
1520} 2986}
1521 2987
1522sub cf::object::player::enter_exit { 2988sub cf::object::player::enter_exit {
1523 my ($self, $exit) = @_; 2989 my ($self, $exit) = @_;
1524 2990
1525 return unless $self->type == cf::PLAYER; 2991 return unless $self->type == cf::PLAYER;
1526 2992
1527 $self->enter_link; 2993 $self->enter_link;
1528 2994
1529 (Coro::async { 2995 (async {
2996 $Coro::current->{desc} = "enter_exit";
2997
1530 unless (eval { 2998 unless (eval {
2999 $self->deactivate_recursive; # just to be sure
1531 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
1532 prepare_random_map $exit 3012 prepare_random_map $exit
3013 if $exit->slaying eq "/!"; # need to re-check after getting the lock
3014
1533 if $exit->slaying eq "/!"; 3015 $map = $exit->slaying;
1534 3016
1535 my $path = new cf::path $exit->slaying, $exit->map && $exit->map->path; 3017 } elsif ($slaying eq '!up') {
1536 $self->goto_map ($path, $exit->stats->hp, $exit->stats->sp); 3018 $map = $exit->map->tile_path (cf::TILE_UP);
3019 $x = $exit->x;
3020 $y = $exit->y;
1537 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
1538 1; 3034 1
1539 }) { 3035 }) {
1540 $self->message ("Something went wrong deep within the crossfire server. " 3036 $self->message ("Something went wrong deep within the deliantra server. "
1541 . "I'll try to bring you back to the map you were before. " 3037 . "I'll try to bring you back to the map you were before. "
1542 . "Please report this to the dungeon master", 3038 . "Please report this to the dungeon master!",
1543 cf::NDI_UNIQUE | cf::NDI_RED); 3039 cf::NDI_UNIQUE | cf::NDI_RED);
1544 3040
1545 warn "ERROR in enter_exit: $@"; 3041 error "ERROR in enter_exit: $@";
1546 $self->leave_link; 3042 $self->leave_link;
1547 } 3043 }
1548 })->prio (1); 3044 })->prio (1);
1549} 3045}
1550 3046
1561 3057
1562sub cf::client::send_drawinfo { 3058sub cf::client::send_drawinfo {
1563 my ($self, $text, $flags) = @_; 3059 my ($self, $text, $flags) = @_;
1564 3060
1565 utf8::encode $text; 3061 utf8::encode $text;
1566 $self->send_packet (sprintf "drawinfo %d %s", $flags, $text); 3062 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);
1567} 3063}
1568 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}
1569 3263
1570=item $success = $client->query ($flags, "text", \&cb) 3264=item $success = $client->query ($flags, "text", \&cb)
1571 3265
1572Queues a query to the client, calling the given callback with 3266Queues a query to the client, calling the given callback with
1573the 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>,
1574C<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>.
1575 3269
1576Queries 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
1577reliable at some point in the future. 3271become reliable at some point in the future.
1578 3272
1579=cut 3273=cut
1580 3274
1581sub cf::client::query { 3275sub cf::client::query {
1582 my ($self, $flags, $text, $cb) = @_; 3276 my ($self, $flags, $text, $cb) = @_;
1590 utf8::encode $text; 3284 utf8::encode $text;
1591 push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb]; 3285 push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb];
1592 3286
1593 $self->send_packet ($self->{query_queue}[0][0]) 3287 $self->send_packet ($self->{query_queue}[0][0])
1594 if @{ $self->{query_queue} } == 1; 3288 if @{ $self->{query_queue} } == 1;
3289
3290 1
1595} 3291}
1596 3292
1597cf::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 },
1598 on_reply => sub { 3299 on_reply => sub {
1599 my ($ns, $msg) = @_; 3300 my ($ns, $msg) = @_;
1600 3301
1601 # this weird shuffling is so that direct followup queries 3302 # this weird shuffling is so that direct followup queries
1602 # get handled first 3303 # get handled first
1603 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
1604 3306
1605 (shift @$queue)->[1]->($msg); 3307 (shift @$queue)->[1]->($msg);
3308 return unless $ns->valid; # temporary(?) workaround for callback destroying socket
1606 3309
1607 push @{ $ns->{query_queue} }, @$queue; 3310 push @{ $ns->{query_queue} }, @$queue;
1608 3311
1609 if (@{ $ns->{query_queue} } == @$queue) { 3312 if (@{ $ns->{query_queue} } == @$queue) {
1610 if (@$queue) { 3313 if (@$queue) {
1612 } else { 3315 } else {
1613 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM; 3316 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM;
1614 } 3317 }
1615 } 3318 }
1616 }, 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 },
1617); 3353);
1618 3354
1619=item $client->coro (\&cb) 3355=item $client->async (\&cb)
1620 3356
1621Create a new coroutine, running the specified callback. The coroutine will 3357Create a new coroutine, running the specified callback. The coroutine will
1622be automatically cancelled when the client gets destroyed (e.g. on logout, 3358be automatically cancelled when the client gets destroyed (e.g. on logout,
1623or loss of connection). 3359or loss of connection).
1624 3360
1625=cut 3361=cut
1626 3362
1627sub cf::client::coro { 3363sub cf::client::async {
1628 my ($self, $cb) = @_; 3364 my ($self, $cb) = @_;
1629 3365
1630 my $coro; $coro = async { 3366 my $coro = &Coro::async ($cb);
1631 eval {
1632 $cb->();
1633 };
1634 warn $@ if $@;
1635 };
1636 3367
1637 $coro->on_destroy (sub { 3368 $coro->on_destroy (sub {
1638 delete $self->{_coro}{$coro+0}; 3369 delete $self->{_coro}{$coro+0};
1639 }); 3370 });
1640 3371
1642 3373
1643 $coro 3374 $coro
1644} 3375}
1645 3376
1646cf::client->attach ( 3377cf::client->attach (
1647 on_destroy => sub { 3378 on_client_destroy => sub {
1648 my ($ns) = @_; 3379 my ($ns) = @_;
1649 3380
1650 $_->cancel for values %{ (delete $ns->{_coro}) || {} }; 3381 $_->cancel for values %{ (delete $ns->{_coro}) || {} };
1651 }, 3382 },
1652); 3383);
1667our $safe = new Safe "safe"; 3398our $safe = new Safe "safe";
1668our $safe_hole = new Safe::Hole; 3399our $safe_hole = new Safe::Hole;
1669 3400
1670$SIG{FPE} = 'IGNORE'; 3401$SIG{FPE} = 'IGNORE';
1671 3402
1672$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));
1673 3408
1674# here we export the classes and methods available to script code 3409# here we export the classes and methods available to script code
1675 3410
1676=pod 3411=pod
1677 3412
1678The following fucntions and emthods are available within a safe environment: 3413The following functions and methods are available within a safe environment:
1679 3414
1680 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
1681 cf::object::player player 3420 cf::object::player
1682 cf::player peaceful 3421 player
1683 cf::map trigger 3422
3423 cf::player
3424 peaceful
3425
3426 cf::map
3427 trigger
1684 3428
1685=cut 3429=cut
1686 3430
1687for ( 3431for (
1688 ["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)],
1689 ["cf::object::player" => qw(player)], 3435 ["cf::object::player" => qw(player)],
1690 ["cf::player" => qw(peaceful)], 3436 ["cf::player" => qw(peaceful send_msg)],
1691 ["cf::map" => qw(trigger)], 3437 ["cf::map" => qw(trigger)],
1692) { 3438) {
1693 no strict 'refs';
1694 my ($pkg, @funs) = @$_; 3439 my ($pkg, @funs) = @$_;
1695 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"}) 3440 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})
1696 for @funs; 3441 for @funs;
1697} 3442}
1698 3443
1713 3458
1714 my $qcode = $code; 3459 my $qcode = $code;
1715 $qcode =~ s/"/‟/g; # not allowed in #line filenames 3460 $qcode =~ s/"/‟/g; # not allowed in #line filenames
1716 $qcode =~ s/\n/\\n/g; 3461 $qcode =~ s/\n/\\n/g;
1717 3462
3463 %vars = (_dummy => 0) unless %vars;
3464
3465 my @res;
1718 local $_; 3466 local $_;
1719 local @safe::cf::_safe_eval_args = values %vars;
1720 3467
1721 my $eval = 3468 my $eval =
1722 "do {\n" 3469 "do {\n"
1723 . "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n" 3470 . "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n"
1724 . "#line 0 \"{$qcode}\"\n" 3471 . "#line 0 \"{$qcode}\"\n"
1725 . $code 3472 . $code
1726 . "\n}" 3473 . "\n}"
1727 ; 3474 ;
1728 3475
3476 if ($CFG{safe_eval}) {
1729 sub_generation_inc; 3477 sub_generation_inc;
3478 local @safe::cf::_safe_eval_args = values %vars;
1730 my @res = wantarray ? $safe->reval ($eval) : scalar $safe->reval ($eval); 3479 @res = wantarray ? $safe->reval ($eval) : scalar $safe->reval ($eval);
1731 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 }
1732 3485
1733 if ($@) { 3486 if ($@) {
1734 warn "$@"; 3487 warn "$@",
1735 warn "while executing safe code '$code'\n"; 3488 "while executing safe code '$code'\n",
1736 warn "with arguments " . (join " ", %vars) . "\n"; 3489 "with arguments " . (join " ", %vars) . "\n";
1737 } 3490 }
1738 3491
1739 wantarray ? @res : $res[0] 3492 wantarray ? @res : $res[0]
1740} 3493}
1741 3494
1755=cut 3508=cut
1756 3509
1757sub register_script_function { 3510sub register_script_function {
1758 my ($fun, $cb) = @_; 3511 my ($fun, $cb) = @_;
1759 3512
1760 no strict 'refs'; 3513 $fun = "safe::$fun" if $CFG{safe_eval};
1761 *{"safe::$fun"} = $safe_hole->wrap ($cb); 3514 *$fun = $safe_hole->wrap ($cb);
1762} 3515}
1763 3516
1764=back 3517=back
1765 3518
1766=cut 3519=cut
1767 3520
1768############################################################################# 3521#############################################################################
3522# the server's init and main functions
1769 3523
1770=head2 EXTENSION DATABASE SUPPORT 3524our %FACEHASH; # hash => idx, #d# HACK for http server
3525our @FACEDATA; # dynamically-created facedata
1771 3526
1772Crossfire maintains a very simple database for extension use. It can 3527# internal api, not fianlised
1773currently store anything that can be serialised using Storable, which 3528sub set_face {
1774excludes objects. 3529 my ($name, $type, $data) = @_;
1775 3530
1776The parameter C<$family> should best start with the name of the extension 3531 my $idx = cf::face::find $name;
1777using it, it should be unique.
1778 3532
1779=over 4 3533 if ($idx) {
1780 3534 delete $FACEHASH{cf::face::get_chksum $idx};
1781=item $hashref = cf::db_get $family 3535 } else {
1782 3536 $idx = cf::face::alloc $name;
1783Return a hashref for use by the extension C<$family>, which can be
1784modified. After modifications, you have to call C<cf::db_dirty> or
1785C<cf::db_sync>.
1786
1787=item $value = cf::db_get $family => $key
1788
1789Returns a single value from the database
1790
1791=item cf::db_put $family => $hashref
1792
1793Stores the given family hashref into the database. Updates are delayed, if
1794you want the data to be synced to disk immediately, use C<cf::db_sync>.
1795
1796=item cf::db_put $family => $key => $value
1797
1798Stores the given C<$value> in the family hash. Updates are delayed, if you
1799want the data to be synced to disk immediately, use C<cf::db_sync>.
1800
1801=item cf::db_dirty
1802
1803Marks the database as dirty, to be updated at a later time.
1804
1805=item cf::db_sync
1806
1807Immediately write the database to disk I<if it is dirty>.
1808
1809=cut
1810
1811our $DB;
1812
1813{
1814 my $path = cf::localdir . "/database.pst";
1815
1816 sub db_load() {
1817 warn "loading database $path\n";#d# remove later
1818 $DB = stat $path ? Storable::retrieve $path : { };
1819 } 3537 }
1820 3538
1821 my $pid; 3539 my $hash = cf::face::mangle_chksum Digest::MD5::md5 $data;
1822 3540
1823 sub db_save() { 3541 cf::face::set_type $idx, $type;
1824 warn "saving database $path\n";#d# remove later 3542 cf::face::set_data $idx, 0, (length $data), 0, $hash;
1825 waitpid $pid, 0 if $pid; 3543 cf::face::set_meta $idx, $type & 1 ? undef : undef;
1826 if (0 == ($pid = fork)) { 3544
1827 $DB->{_meta}{version} = 1; 3545 # we need to destroy the SV itself, not just overwrite,
1828 Storable::nstore $DB, "$path~"; 3546 # as a running ix might hold a reference to it.
1829 rename "$path~", $path; 3547 # delete achieves that.
1830 cf::_exit 0 if defined $pid; 3548 delete $FACEDATA[$idx];
3549 $FACEDATA[$idx] = $data;
3550 $FACEHASH{$hash} = $idx;#d#
3551
3552 $idx
3553}
3554
3555our $FACEDATA; # facedata filehandle
3556
3557sub _face_get_data($$$$) {
3558 my ($idx, $size, $fofs, $cb) = @_;
3559
3560 if (defined $FACEDATA[$idx]) {
3561 $cb->($FACEDATA[$idx]);
3562 } elsif ($fofs) {
3563 my $buf;
3564 IO::AIO::aio_read $FACEDATA, $fofs, $size, $buf, 0, sub {
3565 if ($_[0] == $size) {
3566 #cf::debug "read face $idx, $size from $fofs as ", length $buf;#d#
3567 $cb->($buf);
3568 } else {
3569 cf::error "INTERNAL ERROR: unable to read facedata for face $idx ($size, $fofs), ignoring request.";
3570 }
1831 } 3571 };
3572 } else {
3573 cf::error "requested facedata for unknown face $idx ($size, $fofs), ignoring.";
1832 } 3574 }
3575}
1833 3576
1834 my $dirty; 3577# rather ineffient
3578sub cf::face::get_data($;$) {
3579 my ($idx, $faceset) = @_;
1835 3580
1836 sub db_sync() { 3581 my $size = cf::face::get_size $idx, $faceset;
1837 db_save if $dirty; 3582 my $fofs = cf::face::get_fofs $idx, $faceset;
1838 undef $dirty;
1839 }
1840 3583
1841 my $idle = Event->idle (min => $TICK * 2.8, max => 10, repeat => 0, data => WF_AUTOCANCEL, cb => sub { 3584 _face_get_data $idx, $size, $fofs, Coro::rouse_cb;
1842 db_sync; 3585 Coro::rouse_wait
3586}
3587
3588sub cf::face::ix {
3589 my ($ns, $idx, $pri, $size, $fofs) = @_;
3590
3591 _face_get_data $idx, $size, $fofs, sub {
3592 $ns->ix_send ($idx, $pri, $_[0]);
1843 }); 3593 };
3594}
1844 3595
1845 sub db_dirty() { 3596sub load_facedata($) {
1846 $dirty = 1; 3597 my ($path) = @_;
1847 $idle->start; 3598
3599 my $enc = JSON::XS->new->utf8->canonical->relaxed;
3600
3601 trace "loading facedata from $path\n";
3602
3603 my $facedata = decode_storable load_file "$path/faceinfo";
3604
3605 $facedata->{version} == 2
3606 or cf::cleanup "$path/faceinfo: version mismatch, cannot proceed.";
3607
3608 my $fh = aio_open "$DATADIR/facedata", IO::AIO::O_RDONLY, 0
3609 or cf::cleanup "$path/facedata: $!, cnanot proceed.";
3610
3611 get_slot 1, -100, "load_facedata"; # make sure we get a very big slot
3612
3613 # BEGIN ATOMIC
3614 # from here on, everything must be atomic - no thread switch allowed
3615 my $t1 = EV::time;
3616
1848 } 3617 {
3618 my $faces = $facedata->{faceinfo};
1849 3619
1850 sub db_get($;$) { 3620 for my $face (sort keys %$faces) {
1851 @_ >= 2 3621 my $info = $faces->{$face};
1852 ? $DB->{$_[0]}{$_[1]} 3622 my $idx = (cf::face::find $face) || cf::face::alloc $face;
1853 : ($DB->{$_[0]} ||= { })
1854 }
1855 3623
1856 sub db_put($$;$) { 3624 cf::face::set_visibility $idx, $info->{visibility};
1857 if (@_ >= 3) { 3625 cf::face::set_magicmap $idx, $info->{magicmap};
1858 $DB->{$_[0]}{$_[1]} = $_[2]; 3626 cf::face::set_data $idx, 0, $info->{size32}, $info->{fofs32}, $info->{hash32};
1859 } else { 3627 cf::face::set_data $idx, 1, $info->{size64}, $info->{fofs64}, $info->{hash64};
1860 $DB->{$_[0]} = $_[1]; 3628 #cf::face::set_data $idx, 2, $info->{glyph} , $info->{glyph}; # glyphs no longer downloadable via ix
1861 } 3629 $FACEHASH{$info->{hash64}} = $idx;#d#
1862 db_dirty;
1863 }
1864
1865 cf::global->attach (
1866 prio => 10000,
1867 on_cleanup => sub {
1868 db_sync;
1869 }, 3630 }
3631
3632 while (my ($face, $info) = each %$faces) {
3633 next unless $info->{smooth};
3634
3635 my $idx = cf::face::find $face
3636 or next;
3637
3638 if (my $smooth = cf::face::find $info->{smooth}) {
3639 cf::face::set_smooth $idx, $smooth;
3640 cf::face::set_smoothlevel $idx, $info->{smoothlevel};
3641 } else {
3642 error "smooth face '$info->{smooth}' not found for face '$face'";
3643 }
3644 }
3645 }
3646
3647 {
3648 my $anims = $facedata->{animinfo};
3649
3650 while (my ($anim, $info) = each %$anims) {
3651 cf::anim::set $anim, $info->{frames}, $info->{facings};
3652 }
3653
3654 cf::anim::invalidate_all; # d'oh
3655 }
3656
3657 {
3658 my $res = $facedata->{resource};
3659
3660 while (my ($name, $info) = each %$res) {
3661 if (defined (my $type = $info->{type})) {
3662 # TODO: different hash - must free and use new index, or cache ixface data queue
3663 my $idx = (cf::face::find $name) || cf::face::alloc $name;
3664
3665 cf::face::set_type $idx, $type;
3666 cf::face::set_data $idx, 0, $info->{size}, $info->{fofs}, $info->{hash};
3667 cf::face::set_meta $idx, $type & 1 ? undef : $info->{meta}; # preserve meta unless prepended already
3668 $FACEHASH{$info->{hash}} = $idx;#d#
3669 } else {
3670# $RESOURCE{$name} = $info; # unused
3671 }
3672 }
3673 }
3674
3675 ($fh, $FACEDATA) = ($FACEDATA, $fh);
3676
3677 # HACK to clear player env face cache, we need some signal framework
3678 # for this (global event?)
3679 %ext::player_env::MUSIC_FACE_CACHE = ();
3680
3681 # END ATOMIC
3682
3683 cf::debug "facedata atomic update time ", EV::time - $t1;
3684
3685 cf::global->invoke (EVENT_GLOBAL_RESOURCE_UPDATE);
3686
3687 aio_close $fh if $fh; # close old facedata
3688
3689 1
3690}
3691
3692register_exticmd fx_want => sub {
3693 my ($ns, $want) = @_;
3694
3695 while (my ($k, $v) = each %$want) {
3696 $ns->fx_want ($k, $v);
3697 }
3698};
3699
3700sub load_resource_file($) {
3701 my $guard = lock_acquire "load_resource_file";
3702
3703 my $status = load_resource_file_ $_[0];
3704 get_slot 0.1, 100;
3705 cf::arch::commit_load;
3706
3707 $status
3708}
3709
3710sub reload_exp_table {
3711 _reload_exp_table;
3712
3713 set_face "res/exp_table" => FT_RSRC,
3714 JSON::XS->new->utf8->canonical->encode (
3715 [map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]
3716 );
3717}
3718
3719sub reload_materials {
3720 _reload_materials;
3721}
3722
3723sub reload_regions {
3724 # HACK to clear player env face cache, we need some signal framework
3725 # for this (global event?)
3726 %ext::player_env::MUSIC_FACE_CACHE = ();
3727
3728 load_resource_file "$MAPDIR/regions"
3729 or die "unable to load regions file\n";
3730
3731 for (cf::region::list) {
3732 $_->{match} = qr/$_->{match}/
3733 if exists $_->{match};
3734 }
3735}
3736
3737sub reload_facedata {
3738 load_facedata $DATADIR
3739 or die "unable to load facedata\n";
3740}
3741
3742sub reload_archetypes {
3743 load_resource_file "$DATADIR/archetypes"
3744 or die "unable to load archetypes\n";
3745
3746 set_face "res/skill_info" => FT_RSRC,
3747 JSON::XS->new->utf8->canonical->encode (
3748 [map [cf::arch::skillvec ($_)->name], 0 .. cf::arch::skillvec_size - 1]
3749 );
3750 set_face "res/spell_paths" => FT_RSRC,
3751 JSON::XS->new->utf8->canonical->encode (
3752 [map [cf::spellpathnames ($_)], 0 .. NRSPELLPATHS - 1]
3753 );
3754}
3755
3756sub reload_treasures {
3757 load_resource_file "$DATADIR/treasures"
3758 or die "unable to load treasurelists\n";
3759}
3760
3761sub reload_sound {
3762 trace "loading sound config from $DATADIR/sound\n";
3763
3764 my $soundconf = JSON::XS->new->utf8->relaxed->decode (load_file "$DATADIR/sound");
3765
3766 for (0 .. SOUND_CAST_SPELL_0 - 1) {
3767 my $sound = $soundconf->{compat}[$_]
3768 or next;
3769
3770 my $face = cf::face::find "sound/$sound->[1]";
3771 cf::sound::set $sound->[0] => $face;
3772 cf::sound::old_sound_index $_, $face; # gcfclient-compat
3773 }
3774
3775 while (my ($k, $v) = each %{$soundconf->{event}}) {
3776 my $face = cf::face::find "sound/$v";
3777 cf::sound::set $k => $face;
3778 }
3779}
3780
3781sub reload_resources {
3782 trace "reloading resource files...\n";
3783
3784 reload_materials;
3785 reload_facedata;
3786 reload_exp_table;
3787 reload_sound;
3788 reload_archetypes;
3789 reload_regions;
3790 reload_treasures;
3791
3792 trace "finished reloading resource files\n";
3793}
3794
3795sub reload_config {
3796 trace "reloading config file...\n";
3797
3798 my $config = load_file "$CONFDIR/config";
3799 utf8::decode $config;
3800 *CFG = decode_yaml $config;
3801
3802 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_104_115", 49, 38];
3803
3804 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset};
3805 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset};
3806
3807 if (exists $CFG{mlockall}) {
3808 eval {
3809 $CFG{mlockall} ? eval "mlockall()" : eval "munlockall()"
3810 and die "WARNING: m(un)lockall failed: $!\n";
3811 };
3812 warn $@ if $@;
3813 }
3814}
3815
3816sub pidfile() {
3817 sysopen my $fh, $PIDFILE, O_RDWR | O_CREAT
3818 or die "$PIDFILE: $!";
3819 flock $fh, &Fcntl::LOCK_EX
3820 or die "$PIDFILE: flock: $!";
3821 $fh
3822}
3823
3824# make sure only one server instance is running at any one time
3825sub atomic {
3826 my $fh = pidfile;
3827
3828 my $pid = <$fh>;
3829 kill 9, $pid if $pid > 0;
3830
3831 seek $fh, 0, 0;
3832 print $fh $$;
3833}
3834
3835sub main_loop {
3836 trace "EV::loop starting\n";
3837 if (1) {
3838 EV::loop;
3839 }
3840 trace "EV::loop returned\n";
3841 goto &main_loop unless $REALLY_UNLOOP;
3842}
3843
3844sub main {
3845 cf::init_globals; # initialise logging
3846
3847 LOG llevInfo, "Welcome to Deliantra, v" . VERSION;
3848 LOG llevInfo, "Copyright (C) 2005-2012 Marc Alexander Lehmann / Robin Redeker / the Deliantra team.";
3849 LOG llevInfo, "Copyright (C) 1994 Mark Wedel.";
3850 LOG llevInfo, "Copyright (C) 1992 Frank Tore Johansen.";
3851
3852 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority
3853
3854 # we must not ever block the main coroutine
3855 $Coro::idle = sub {
3856 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
3857 (async {
3858 $Coro::current->{desc} = "IDLE BUG HANDLER";
3859 EV::loop EV::LOOP_ONESHOT;
3860 })->prio (Coro::PRIO_MAX);
1870 ); 3861 };
3862
3863 evthread_start IO::AIO::poll_fileno;
3864
3865 cf::sync_job {
3866 cf::incloader::init ();
3867
3868 db_init;
3869
3870 cf::init_anim;
3871 cf::init_attackmess;
3872 cf::init_dynamic;
3873
3874 cf::load_settings;
3875
3876 reload_resources;
3877 reload_config;
3878
3879 cf::init_uuid;
3880 cf::init_signals;
3881 cf::init_skills;
3882
3883 cf::init_beforeplay;
3884
3885 atomic;
3886
3887 load_extensions;
3888
3889 utime time, time, $RUNTIMEFILE;
3890
3891 # no (long-running) fork's whatsoever before this point(!)
3892 use POSIX ();
3893 POSIX::close delete $ENV{LOCKUTIL_LOCK_FD} if exists $ENV{LOCKUTIL_LOCK_FD};
3894
3895 cf::_post_init 0;
3896 };
3897
3898 cf::object::thawer::errors_are_fatal 0;
3899 info "parse errors in files are no longer fatal from this point on.\n";
3900
3901 AE::postpone {
3902 undef &main; # free gobs of memory :)
3903 };
3904
3905 goto &main_loop;
1871} 3906}
1872 3907
1873############################################################################# 3908#############################################################################
1874# the server's main() 3909# initialisation and cleanup
1875 3910
1876sub cfg_load { 3911# install some emergency cleanup handlers
1877 open my $fh, "<:utf8", cf::confdir . "/config" 3912BEGIN {
3913 our %SIGWATCHER = ();
3914 for my $signal (qw(INT HUP TERM)) {
3915 $SIGWATCHER{$signal} = AE::signal $signal, sub {
3916 cf::cleanup "SIG$signal";
3917 };
3918 }
3919}
3920
3921sub write_runtime_sync {
3922 my $t0 = AE::time;
3923
3924 # first touch the runtime file to show we are still running:
3925 # the fsync below can take a very very long time.
3926
3927 IO::AIO::aio_utime $RUNTIMEFILE, undef, undef;
3928
3929 my $guard = cf::lock_acquire "write_runtime";
3930
3931 my $fh = aio_open "$RUNTIMEFILE~", O_WRONLY | O_CREAT | O_TRUNC, 0644
1878 or return; 3932 or return;
1879 3933
1880 local $/; 3934 my $value = $cf::RUNTIME + 90 + 10;
1881 *CFG = YAML::Syck::Load <$fh>; 3935 # 10 is the runtime save interval, for a monotonic clock
1882} 3936 # 60 allows for the watchdog to kill the server.
1883 3937
1884sub main { 3938 (aio_write $fh, 0, (length $value), $value, 0) <= 0
1885 # we must not ever block the main coroutine 3939 and return;
1886 local $Coro::idle = sub { 3940
1887 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d# 3941 # always fsync - this file is important
1888 (Coro::unblock_sub { 3942 aio_fsync $fh
1889 Event::one_event; 3943 and return;
3944
3945 # touch it again to show we are up-to-date
3946 aio_utime $fh, undef, undef;
3947
3948 close $fh
3949 or return;
3950
3951 aio_rename "$RUNTIMEFILE~", $RUNTIMEFILE
3952 and return;
3953
3954 trace sprintf "runtime file written (%gs).\n", AE::time - $t0;
3955
3956 1
3957}
3958
3959our $uuid_lock;
3960our $uuid_skip;
3961
3962sub write_uuid_sync($) {
3963 $uuid_skip ||= $_[0];
3964
3965 return if $uuid_lock;
3966 local $uuid_lock = 1;
3967
3968 my $uuid = "$LOCALDIR/uuid";
3969
3970 my $fh = aio_open "$uuid~", O_WRONLY | O_CREAT, 0644
3971 or return;
3972
3973 my $value = uuid_seq uuid_cur;
3974
3975 unless ($value) {
3976 info "cowardly refusing to write zero uuid value!\n";
3977 return;
3978 }
3979
3980 my $value = uuid_str $value + $uuid_skip;
3981 $uuid_skip = 0;
3982
3983 (aio_write $fh, 0, (length $value), $value, 0) <= 0
3984 and return;
3985
3986 # always fsync - this file is important
3987 aio_fsync $fh
3988 and return;
3989
3990 close $fh
3991 or return;
3992
3993 aio_rename "$uuid~", $uuid
3994 and return;
3995
3996 trace "uuid file written ($value).\n";
3997
3998 1
3999
4000}
4001
4002sub write_uuid($$) {
4003 my ($skip, $sync) = @_;
4004
4005 $sync ? write_uuid_sync $skip
4006 : async { write_uuid_sync $skip };
4007}
4008
4009sub emergency_save() {
4010 my $freeze_guard = cf::freeze_mainloop;
4011
4012 info "emergency_perl_save: enter\n";
4013
4014 # this is a trade-off: we want to be very quick here, so
4015 # save all maps without fsync, and later call a global sync
4016 # (which in turn might be very very slow)
4017 local $USE_FSYNC = 0;
4018
4019 cf::sync_job {
4020 cf::write_runtime_sync; # external watchdog should not bark
4021
4022 # use a peculiar iteration method to avoid tripping on perl
4023 # refcount bugs in for. also avoids problems with players
4024 # and maps saved/destroyed asynchronously.
4025 info "emergency_perl_save: begin player save\n";
4026 for my $login (keys %cf::PLAYER) {
4027 my $pl = $cf::PLAYER{$login} or next;
4028 $pl->valid or next;
4029 delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt
4030 $pl->save;
4031 }
4032 info "emergency_perl_save: end player save\n";
4033
4034 cf::write_runtime_sync; # external watchdog should not bark
4035
4036 info "emergency_perl_save: begin map save\n";
4037 for my $path (keys %cf::MAP) {
4038 my $map = $cf::MAP{$path} or next;
4039 $map->valid or next;
4040 $map->save;
4041 }
4042 info "emergency_perl_save: end map save\n";
4043
4044 cf::write_runtime_sync; # external watchdog should not bark
4045
4046 info "emergency_perl_save: begin database checkpoint\n";
4047 BDB::db_env_txn_checkpoint $DB_ENV;
4048 info "emergency_perl_save: end database checkpoint\n";
4049
4050 info "emergency_perl_save: begin write uuid\n";
4051 write_uuid_sync 1;
4052 info "emergency_perl_save: end write uuid\n";
4053
4054 cf::write_runtime_sync; # external watchdog should not bark
4055
4056 trace "emergency_perl_save: syncing database to disk";
4057 BDB::db_env_txn_checkpoint $DB_ENV;
4058
4059 info "emergency_perl_save: starting sync\n";
4060 IO::AIO::aio_sync sub {
4061 info "emergency_perl_save: finished sync\n";
1890 })->(); 4062 };
4063
4064 cf::write_runtime_sync; # external watchdog should not bark
4065
4066 trace "emergency_perl_save: flushing outstanding aio requests";
4067 while (IO::AIO::nreqs || BDB::nreqs) {
4068 Coro::AnyEvent::sleep 0.01; # let the sync_job do it's thing
4069 }
4070
4071 cf::write_runtime_sync; # external watchdog should not bark
1891 }; 4072 };
1892 4073
1893 cfg_load; 4074 info "emergency_perl_save: leave\n";
1894 db_load;
1895 load_extensions;
1896 Event::loop;
1897} 4075}
1898 4076
1899############################################################################# 4077sub post_cleanup {
1900# initialisation 4078 my ($make_core) = @_;
1901 4079
4080 IO::AIO::flush;
4081
4082 error Carp::longmess "post_cleanup backtrace"
4083 if $make_core;
4084
4085 my $fh = pidfile;
4086 unlink $PIDFILE if <$fh> == $$;
4087}
4088
4089# a safer delete_package, copied from Symbol
4090sub clear_package($) {
4091 my $pkg = shift;
4092
4093 # expand to full symbol table name if needed
4094 unless ($pkg =~ /^main::.*::$/) {
4095 $pkg = "main$pkg" if $pkg =~ /^::/;
4096 $pkg = "main::$pkg" unless $pkg =~ /^main::/;
4097 $pkg .= '::' unless $pkg =~ /::$/;
4098 }
4099
4100 my($stem, $leaf) = $pkg =~ m/(.*::)(\w+::)$/;
4101 my $stem_symtab = *{$stem}{HASH};
4102
4103 defined $stem_symtab and exists $stem_symtab->{$leaf}
4104 or return;
4105
4106 # clear all symbols
4107 my $leaf_symtab = *{$stem_symtab->{$leaf}}{HASH};
4108 for my $name (keys %$leaf_symtab) {
4109 _gv_clear *{"$pkg$name"};
4110# use PApp::Util; PApp::Util::sv_dump *{"$pkg$name"};
4111 }
4112}
4113
1902sub reload() { 4114sub do_reload_perl() {
1903 # can/must only be called in main 4115 # can/must only be called in main
1904 if ($Coro::current != $Coro::main) { 4116 unless (in_main) {
1905 warn "can only reload from main coroutine\n"; 4117 error "can only reload from main coroutine";
1906 return; 4118 return;
1907 } 4119 }
1908 4120
1909 warn "reloading..."; 4121 return if $RELOAD++;
1910 4122
1911 local $FREEZE = 1; 4123 my $t1 = AE::time;
4124
4125 while ($RELOAD) {
4126 cf::get_slot 0.1, -1, "reload_perl";
4127 info "perl_reload: reloading...";
4128
4129 trace "perl_reload: entering sync_job";
4130
4131 cf::sync_job {
1912 cf::emergency_save; 4132 #cf::emergency_save;
1913 4133
1914 eval { 4134 trace "perl_reload: cancelling all extension coros";
1915 # if anything goes wrong in here, we should simply crash as we already saved
1916
1917 # cancel all watchers
1918 for (Event::all_watchers) {
1919 $_->cancel if $_->data & WF_AUTOCANCEL;
1920 }
1921
1922 # cancel all extension coros
1923 $_->cancel for values %EXT_CORO; 4135 $_->cancel for values %EXT_CORO;
1924 %EXT_CORO = (); 4136 %EXT_CORO = ();
1925 4137
1926 # unload all extensions 4138 trace "perl_reload: removing commands";
1927 for (@exts) { 4139 %COMMAND = ();
1928 warn "unloading <$_>";
1929 unload_extension $_;
1930 }
1931 4140
1932 # unload all modules loaded from $LIBDIR 4141 trace "perl_reload: removing ext/exti commands";
1933 while (my ($k, $v) = each %INC) { 4142 %EXTCMD = ();
1934 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/; 4143 %EXTICMD = ();
1935 4144
1936 warn "removing <$k>"; 4145 trace "perl_reload: unloading/nuking all extensions";
1937 delete $INC{$k}; 4146 for my $pkg (@EXTS) {
4147 trace "... unloading $pkg";
1938 4148
1939 $k =~ s/\.pm$//;
1940 $k =~ s/\//::/g;
1941
1942 if (my $cb = $k->can ("unload_module")) { 4149 if (my $cb = $pkg->can ("unload")) {
4150 eval {
1943 $cb->(); 4151 $cb->($pkg);
4152 1
4153 } or error "$pkg unloaded, but with errors: $@";
4154 }
4155
4156 trace "... clearing $pkg";
4157 clear_package $pkg;
1944 } 4158 }
1945 4159
1946 Symbol::delete_package $k; 4160 trace "perl_reload: unloading all perl modules loaded from $LIBDIR";
4161 while (my ($k, $v) = each %INC) {
4162 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
4163
4164 trace "... unloading $k";
4165 delete $INC{$k};
4166
4167 $k =~ s/\.pm$//;
4168 $k =~ s/\//::/g;
4169
4170 if (my $cb = $k->can ("unload_module")) {
4171 $cb->();
4172 }
4173
4174 clear_package $k;
1947 } 4175 }
1948 4176
1949 # sync database to disk
1950 cf::db_sync;
1951 IO::AIO::flush;
1952
1953 # get rid of safe::, as good as possible 4177 trace "perl_reload: getting rid of safe::, as good as possible";
1954 Symbol::delete_package "safe::$_" 4178 clear_package "safe::$_"
1955 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region); 4179 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
1956 4180
1957 # remove register_script_function callbacks 4181 trace "perl_reload: unloading cf.pm \"a bit\"";
1958 # TODO
1959
1960 # unload cf.pm "a bit"
1961 delete $INC{"cf.pm"}; 4182 delete $INC{"cf.pm"};
4183 delete $INC{"cf/$_.pm"} for @EXTRA_MODULES;
1962 4184
1963 # don't, removes xs symbols, too, 4185 # don't, removes xs symbols, too,
1964 # and global variables created in xs 4186 # and global variables created in xs
1965 #Symbol::delete_package __PACKAGE__; 4187 #clear_package __PACKAGE__;
1966 4188
1967 # reload cf.pm 4189 info "perl_reload: unload completed, starting to reload now";
1968 warn "reloading cf.pm"; 4190
4191 trace "perl_reload: reloading cf.pm";
1969 require cf; 4192 require cf;
1970 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 4193 cf::_connect_to_perl_1;
1971 4194
1972 # load config and database again 4195 trace "perl_reload: loading config and database again";
1973 cf::cfg_load; 4196 cf::reload_config;
1974 cf::db_load;
1975 4197
1976 # load extensions 4198 trace "perl_reload: loading extensions";
1977 warn "load extensions";
1978 cf::load_extensions; 4199 cf::load_extensions;
1979 4200
1980 # reattach attachments to objects 4201 if ($REATTACH_ON_RELOAD) {
1981 warn "reattach"; 4202 trace "perl_reload: reattaching attachments to objects/players";
1982 _global_reattach; 4203 _global_reattach; # objects, sockets
4204 trace "perl_reload: reattaching attachments to maps";
4205 reattach $_ for values %MAP;
4206 trace "perl_reload: reattaching attachments to players";
4207 reattach $_ for values %PLAYER;
4208 }
4209
4210 cf::_post_init 1;
4211
4212 trace "perl_reload: leaving sync_job";
4213
4214 1
4215 } or do {
4216 error $@;
4217 cf::cleanup "perl_reload: error, exiting.";
4218 };
4219
4220 --$RELOAD;
4221 }
4222
4223 $t1 = AE::time - $t1;
4224 info "perl_reload: completed in ${t1}s\n";
4225};
4226
4227our $RELOAD_WATCHER; # used only during reload
4228
4229sub reload_perl() {
4230 # doing reload synchronously and two reloads happen back-to-back,
4231 # coro crashes during coro_state_free->destroy here.
4232
4233 $RELOAD_WATCHER ||= cf::async {
4234 Coro::AIO::aio_wait cache_extensions;
4235
4236 $RELOAD_WATCHER = AE::timer $TICK * 1.5, 0, sub {
4237 do_reload_perl;
4238 undef $RELOAD_WATCHER;
4239 };
1983 }; 4240 };
1984
1985 if ($@) {
1986 warn $@;
1987 warn "error while reloading, exiting.";
1988 exit 1;
1989 }
1990
1991 warn "reloaded successfully";
1992};
1993
1994#############################################################################
1995
1996unless ($LINK_MAP) {
1997 $LINK_MAP = cf::map::new;
1998
1999 $LINK_MAP->width (41);
2000 $LINK_MAP->height (41);
2001 $LINK_MAP->alloc;
2002 $LINK_MAP->path ("{link}");
2003 $LINK_MAP->{path} = bless { path => "{link}" }, "cf::path";
2004 $LINK_MAP->in_memory (MAP_IN_MEMORY);
2005
2006 # dirty hack because... archetypes are not yet loaded
2007 Event->timer (
2008 after => 2,
2009 cb => sub {
2010 $_[0]->w->cancel;
2011
2012 # provide some exits "home"
2013 my $exit = cf::object::new "exit";
2014
2015 $exit->slaying ($EMERGENCY_POSITION->[0]);
2016 $exit->stats->hp ($EMERGENCY_POSITION->[1]);
2017 $exit->stats->sp ($EMERGENCY_POSITION->[2]);
2018
2019 $LINK_MAP->insert ($exit->clone, 19, 19);
2020 $LINK_MAP->insert ($exit->clone, 19, 20);
2021 $LINK_MAP->insert ($exit->clone, 19, 21);
2022 $LINK_MAP->insert ($exit->clone, 20, 19);
2023 $LINK_MAP->insert ($exit->clone, 20, 21);
2024 $LINK_MAP->insert ($exit->clone, 21, 19);
2025 $LINK_MAP->insert ($exit->clone, 21, 20);
2026 $LINK_MAP->insert ($exit->clone, 21, 21);
2027
2028 $exit->destroy;
2029 });
2030
2031 $LINK_MAP->{deny_save} = 1;
2032 $LINK_MAP->{deny_reset} = 1;
2033
2034 $cf::MAP{$LINK_MAP->path} = $LINK_MAP;
2035} 4241}
2036
2037register "<global>", __PACKAGE__;
2038 4242
2039register_command "reload" => sub { 4243register_command "reload" => sub {
2040 my ($who, $arg) = @_; 4244 my ($who, $arg) = @_;
2041 4245
2042 if ($who->flag (FLAG_WIZ)) { 4246 if ($who->flag (FLAG_WIZ)) {
2043 $who->message ("start of reload.");
2044 reload;
2045 $who->message ("end of reload."); 4247 $who->message ("reloading server.");
4248 async {
4249 $Coro::current->{desc} = "perl_reload";
4250 reload_perl;
4251 };
2046 } 4252 }
2047}; 4253};
2048 4254
2049unshift @INC, $LIBDIR; 4255#############################################################################
2050 4256
2051$TICK_WATCHER = Event->timer ( 4257my $bug_warning = 0;
2052 reentrant => 0,
2053 prio => 0,
2054 at => $NEXT_TICK || $TICK,
2055 data => WF_AUTOCANCEL,
2056 cb => sub {
2057 unless ($FREEZE) {
2058 cf::server_tick; # one server iteration
2059 $RUNTIME += $TICK;
2060 }
2061 4258
2062 $NEXT_TICK += $TICK; 4259sub wait_for_tick() {
4260 return Coro::AnyEvent::poll if tick_inhibit || $Coro::current == $Coro::main;
2063 4261
2064 # if we are delayed by four ticks or more, skip them all 4262 $WAIT_FOR_TICK->wait;
2065 $NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4; 4263}
2066 4264
2067 $TICK_WATCHER->at ($NEXT_TICK); 4265sub wait_for_tick_begin() {
2068 $TICK_WATCHER->start; 4266 return Coro::AnyEvent::poll if tick_inhibit || $Coro::current == $Coro::main;
4267
4268 my $signal = new Coro::Signal;
4269 push @WAIT_FOR_TICK_BEGIN, $signal;
4270 $signal->wait;
4271}
4272
4273sub tick {
4274 if ($Coro::current != $Coro::main) {
4275 Carp::cluck "major BUG: server tick called outside of main coro, skipping it"
4276 unless ++$bug_warning > 10;
4277 return;
2069 }, 4278 }
2070);
2071 4279
2072IO::AIO::max_poll_time $TICK * 0.2; 4280 cf::one_tick; # one server iteration
2073 4281
2074Event->io ( 4282 #for(1..3e6){} AE::now_update; $NOW=AE::now; # generate load #d#
2075 fd => IO::AIO::poll_fileno,
2076 poll => 'r',
2077 prio => 5,
2078 data => WF_AUTOCANCEL,
2079 cb => \&IO::AIO::poll_cb,
2080);
2081 4283
2082Event->timer ( 4284 if ($NOW >= $NEXT_RUNTIME_WRITE) {
2083 data => WF_AUTOCANCEL, 4285 $NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.;
2084 after => 0, 4286 Coro::async_pool {
2085 interval => 10, 4287 $Coro::current->{desc} = "runtime saver";
2086 cb => sub {
2087 (Coro::unblock_sub {
2088 write_runtime 4288 write_runtime_sync
2089 or warn "ERROR: unable to write runtime file: $!"; 4289 or error "ERROR: unable to write runtime file: $!";
2090 })->(); 4290 };
2091 }, 4291 }
2092); 4292
4293 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
4294 $sig->send;
4295 }
4296 $WAIT_FOR_TICK->broadcast;
4297
4298 $LOAD = ($NOW - $TICK_START) / $TICK;
4299 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
4300
4301 if (0) {
4302 if ($NEXT_TICK) {
4303 my $jitter = $TICK_START - $NEXT_TICK;
4304 $JITTER = $JITTER * 0.75 + $jitter * 0.25;
4305 debug "jitter $JITTER\n";#d#
4306 }
4307 }
4308}
4309
4310{
4311 # configure BDB
4312 info "initialising database";
4313
4314 BDB::min_parallel 16;
4315 BDB::max_poll_reqs $TICK * 0.1;
4316 #$AnyEvent::BDB::WATCHER->priority (1);
4317
4318 unless ($DB_ENV) {
4319 $DB_ENV = BDB::db_env_create;
4320 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT);
4321 $DB_ENV->set_flags (&BDB::LOG_AUTOREMOVE ) if BDB::VERSION v0, v4.7;
4322 $DB_ENV->log_set_config (&BDB::LOG_AUTO_REMOVE) if BDB::VERSION v4.7;
4323 $DB_ENV->set_timeout (30, BDB::SET_TXN_TIMEOUT);
4324 $DB_ENV->set_timeout (30, BDB::SET_LOCK_TIMEOUT);
4325
4326 cf::sync_job {
4327 eval {
4328 BDB::db_env_open
4329 $DB_ENV,
4330 $BDBDIR,
4331 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN
4332 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE,
4333 0666;
4334
4335 cf::cleanup "db_env_open($BDBDIR): $!" if $!;
4336 };
4337
4338 cf::cleanup "db_env_open(db): $@" if $@;
4339 };
4340 }
4341
4342 $BDB_DEADLOCK_WATCHER = EV::periodic 0, 3, 0, sub {
4343 BDB::db_env_lock_detect $DB_ENV, 0, BDB::LOCK_DEFAULT, 0, sub { };
4344 };
4345 $BDB_CHECKPOINT_WATCHER = EV::periodic 0, 60, 0, sub {
4346 BDB::db_env_txn_checkpoint $DB_ENV, 0, 0, 0, sub { };
4347 };
4348 $BDB_TRICKLE_WATCHER = EV::periodic 0, 10, 0, sub {
4349 BDB::db_env_memp_trickle $DB_ENV, 20, 0, sub { };
4350 };
4351
4352 info "database initialised";
4353}
4354
4355{
4356 # configure IO::AIO
4357
4358 info "initialising aio";
4359 IO::AIO::min_parallel 8;
4360 IO::AIO::max_poll_time $TICK * 0.1;
4361 undef $AnyEvent::AIO::WATCHER;
4362 info "aio initialised";
4363}
4364
4365our $_log_backtrace;
4366our $_log_backtrace_last;
4367
4368sub _log_backtrace {
4369 my ($msg, @addr) = @_;
4370
4371 $msg =~ s/\n$//;
4372
4373 if ($_log_backtrace_last eq $msg) {
4374 LOG llevInfo, "[ABT] $msg\n";
4375 LOG llevInfo, "[ABT] [duplicate, suppressed]\n";
4376 # limit the # of concurrent backtraces
4377 } elsif ($_log_backtrace < 2) {
4378 $_log_backtrace_last = $msg;
4379 ++$_log_backtrace;
4380 my $perl_bt = Carp::longmess $msg;
4381 async {
4382 $Coro::current->{desc} = "abt $msg";
4383
4384 my @bt = fork_call {
4385 @addr = map { sprintf "%x", $_ } @addr;
4386 my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X;
4387 open my $fh, "exec addr2line -C -f -i -e \Q$self\E @addr 2>&1 |"
4388 or die "addr2line: $!";
4389
4390 my @funcs;
4391 my @res = <$fh>;
4392 chomp for @res;
4393 while (@res) {
4394 my ($func, $line) = splice @res, 0, 2, ();
4395 push @funcs, "[$func] $line";
4396 }
4397
4398 @funcs
4399 };
4400
4401 LOG llevInfo, "[ABT] $perl_bt\n";
4402 LOG llevInfo, "[ABT] --- C backtrace follows ---\n";
4403 LOG llevInfo, "[ABT] $_\n" for @bt;
4404 --$_log_backtrace;
4405 };
4406 } else {
4407 LOG llevInfo, "[ABT] $msg\n";
4408 LOG llevInfo, "[ABT] [overload, suppressed]\n";
4409 }
4410}
4411
4412# load additional modules
4413require "cf/$_.pm" for @EXTRA_MODULES;
4414cf::_connect_to_perl_2;
4415
4416END { cf::emergency_save }
2093 4417
20941 44181
2095 4419

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines