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.110 by root, Mon Jan 1 11:21:55 2007 UTC vs.
Revision 1.523 by root, Sat Apr 17 02:39:46 2010 UTC

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

Diff Legend

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