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

Diff Legend

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