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.223 by root, Sun Mar 11 02:12:44 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;
32use EV;
9use Opcode; 33use Opcode;
10use Safe; 34use Safe;
11use Safe::Hole; 35use Safe::Hole;
36use Storable ();
37use Carp ();
12 38
39use Guard ();
13use Coro 3.5 (); 40use Coro ();
41use Coro::State;
42use Coro::Handle;
43use Coro::EV;
14use Coro::Event; 44use Coro::AnyEvent;
15use Coro::Timer; 45use Coro::Timer;
16use Coro::Signal; 46use Coro::Signal;
17use Coro::Semaphore; 47use Coro::Semaphore;
48use Coro::SemaphoreSet;
49use Coro::AnyEvent;
18use Coro::AIO; 50use Coro::AIO;
51use Coro::BDB 1.6;
52use Coro::Storable;
53use Coro::Util ();
19 54
55use JSON::XS 2.01 ();
20use BDB (); 56use BDB ();
21use Data::Dumper; 57use Data::Dumper;
22use Digest::MD5;
23use Fcntl; 58use Fcntl;
24use IO::AIO 2.32 ();
25use YAML::Syck (); 59use YAML::XS ();
60use IO::AIO ();
26use Time::HiRes; 61use Time::HiRes;
27use Compress::LZF; 62use Compress::LZF;
63use Digest::MD5 ();
28 64
65AnyEvent::detect;
66
67# configure various modules to our taste
68#
69$Storable::canonical = 1; # reduce rsync transfers
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";
29Compress::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
30 77
31use Event; $Event::Eval = 1; # no idea why this is required, but it is 78# strictly for debugging
79$SIG{QUIT} = sub { Carp::cluck "SIGQUIT" };
32 80
33sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload 81sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
34
35# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode?
36$YAML::Syck::ImplicitUnicode = 1;
37
38$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority
39 82
40our %COMMAND = (); 83our %COMMAND = ();
41our %COMMAND_TIME = (); 84our %COMMAND_TIME = ();
42 85
43our @EXTS = (); # list of extension package names 86our @EXTS = (); # list of extension package names
44our %EXTCMD = (); 87our %EXTCMD = ();
88our %EXTICMD = ();
45our %EXT_CORO = (); # coroutines bound to extensions 89our %EXT_CORO = (); # coroutines bound to extensions
46our %EXT_MAP = (); # pluggable maps 90our %EXT_MAP = (); # pluggable maps
47 91
48our $RELOAD; # number of reloads so far 92our $RELOAD; # number of reloads so far, non-zero while in reload
49our @EVENT; 93our @EVENT;
50our $LIBDIR = datadir . "/ext"; 94our @REFLECT; # set by XS
95our %REFLECT; # set by us
51 96
52our $TICK = MAX_TIME * 1e-6; 97our $CONFDIR = confdir;
53our $TICK_WATCHER; 98our $DATADIR = datadir;
54our $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(!)
55our $NEXT_RUNTIME_WRITE; # when should the runtime file be written 120our $NEXT_RUNTIME_WRITE; # when should the runtime file be written
56our $NEXT_TICK; 121our $NEXT_TICK;
57our $NOW;
58our $USE_FSYNC = 1; # use fsync to write maps - default off 122our $USE_FSYNC = 1; # use fsync to write maps - default on
59 123
124our $BDB_DEADLOCK_WATCHER;
125our $BDB_CHECKPOINT_WATCHER;
60our $BDB_POLL_WATCHER; 126our $BDB_TRICKLE_WATCHER;
61our $DB_ENV; 127our $DB_ENV;
128
129our @EXTRA_MODULES = qw(pod match mapscript);
62 130
63our %CFG; 131our %CFG;
64 132
65our $UPTIME; $UPTIME ||= time; 133our $UPTIME; $UPTIME ||= time;
66our $RUNTIME; 134our $RUNTIME;
135our $NOW;
67 136
68our %PLAYER; # all users 137our (%PLAYER, %PLAYER_LOADING); # all users
69our %MAP; # all maps 138our (%MAP, %MAP_LOADING ); # all maps
70our $LINK_MAP; # the special {link} map, which is always available 139our $LINK_MAP; # the special {link} map, which is always available
71our $RANDOM_MAPS = cf::localdir . "/random";
72our $BDB_ENV_DIR = cf::localdir . "/db";
73
74our $WAIT_FOR_TICK; $WAIT_FOR_TICK ||= new Coro::Signal;
75our $WAIT_FOR_TICK_ONE; $WAIT_FOR_TICK_ONE ||= new Coro::Signal;
76 140
77# 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 ∕
78our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons 142our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons
79 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
80binmode STDOUT; 154binmode STDOUT;
81binmode STDERR; 155binmode STDERR;
82 156
83# read virtual server time, if available 157# read virtual server time, if available
84unless ($RUNTIME || !-e cf::localdir . "/runtime") { 158unless ($RUNTIME || !-e $RUNTIMEFILE) {
85 open my $fh, "<", cf::localdir . "/runtime" 159 open my $fh, "<", $RUNTIMEFILE
86 or die "unable to read runtime file: $!"; 160 or die "unable to read $RUNTIMEFILE file: $!";
87 $RUNTIME = <$fh> + 0.; 161 $RUNTIME = <$fh> + 0.;
88} 162}
89 163
90mkdir cf::localdir; 164eval "sub TICK() { $TICK } 1" or die;
91mkdir cf::localdir . "/" . cf::playerdir; 165
92mkdir cf::localdir . "/" . cf::tmpdir; 166mkdir $_
93mkdir cf::localdir . "/" . cf::uniquedir; 167 for $LOCALDIR, $TMPDIR, $UNIQUEDIR, $PLAYERDIR, $RANDOMDIR, $BDBDIR;
94mkdir $RANDOM_MAPS;
95mkdir $BDB_ENV_DIR;
96 168
97our $EMERGENCY_POSITION; 169our $EMERGENCY_POSITION;
98 170
99sub 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::"} };
100 187
101############################################################################# 188#############################################################################
102 189
103=head2 GLOBAL VARIABLES 190=head2 GLOBAL VARIABLES
104 191
111=item $cf::RUNTIME 198=item $cf::RUNTIME
112 199
113The 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
114every server tick. 201every server tick.
115 202
116=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
117 206
118The perl library directory, where extensions and cf-specific modules can 207Various directories - "/etc", read-only install directory, perl-library
119be 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.
120 211
121=item $cf::NOW 212=item $cf::NOW
122 213
123The time of the last (current) server tick. 214The time of the last (current) server tick.
124 215
125=item $cf::TICK 216=item $cf::TICK
126 217
127The interval between server ticks, in seconds. 218The interval between server ticks, in seconds.
128 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
129=item %cf::CFG 230=item %cf::CFG
130 231
131Configuration for the server, loaded from C</etc/crossfire/config>, or 232Configuration for the server, loaded from C</etc/deliantra-server/config>, or
132from wherever your confdir points to. 233from wherever your confdir points to.
133 234
134=item $cf::WAIT_FOR_TICK, $cf::WAIT_FOR_TICK_ONE 235=item cf::wait_for_tick, cf::wait_for_tick_begin
135 236
136These 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
137or 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
138processing 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.
139window 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.
140 252
141=back 253=back
142 254
143=cut 255=cut
144 256
145BEGIN { 257$Coro::State::WARNHOOK = sub {
146 *CORE::GLOBAL::warn = sub {
147 my $msg = join "", @_; 258 my $msg = join "", @_;
148 utf8::encode $msg;
149 259
150 $msg .= "\n" 260 $msg .= "\n"
151 unless $msg =~ /\n$/; 261 unless $msg =~ /\n$/;
152 262
263 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;
264
153 LOG llevError, $msg; 265 LOG llevError, $msg;
154 }; 266};
155} 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};
156 281
157@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable'; 282@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
158@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable'; 283@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';
159@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable'; 284@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable';
160@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable'; 285@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable';
161@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';
162@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)
163 289
164# 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
165# within the Safe compartment. 291# within the Safe compartment.
166for my $pkg (qw( 292for my $pkg (qw(
167 cf::global cf::attachable 293 cf::global cf::attachable
168 cf::object cf::object::player 294 cf::object cf::object::player
169 cf::client cf::player 295 cf::client cf::player
170 cf::arch cf::living 296 cf::arch cf::living
297 cf::map cf::mapspace
171 cf::map cf::party cf::region 298 cf::party cf::region
172)) { 299)) {
173 no strict 'refs';
174 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg; 300 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
175} 301}
176 302
177$Event::DIED = sub { 303$EV::DIED = sub {
178 warn "error in event callback: @_"; 304 Carp::cluck "error in event callback: @_";
179}; 305};
306
307#############################################################################
180 308
181=head2 UTILITY FUNCTIONS 309=head2 UTILITY FUNCTIONS
182 310
183=over 4 311=over 4
184 312
203 $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;
204 $d 332 $d
205 } || "[unable to dump $_[0]: '$@']"; 333 } || "[unable to dump $_[0]: '$@']";
206} 334}
207 335
208use JSON::Syck (); # TODO# replace by JSON::PC once working
209
210=item $ref = cf::from_json $json 336=item $ref = cf::decode_json $json
211 337
212Converts a JSON string into the corresponding perl data structure. 338Converts a JSON string into the corresponding perl data structure.
213 339
214=cut
215
216sub from_json($) {
217 $JSON::Syck::ImplicitUnicode = 1; # work around JSON::Syck bugs
218 JSON::Syck::Load $_[0]
219}
220
221=item $json = cf::to_json $ref 340=item $json = cf::encode_json $ref
222 341
223Converts a perl data structure into its JSON representation. 342Converts a perl data structure into its JSON representation.
224 343
225=cut 344=cut
226 345
227sub to_json($) { 346our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max
228 $JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs 347
229 JSON::Syck::Dump $_[0] 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;
230} 363}
231 364
232=item cf::lock_wait $string 365=item cf::lock_wait $string
233 366
234Wait until the given lock is available. See cf::lock_acquire. 367Wait until the given lock is available. See cf::lock_acquire.
235 368
236=item my $lock = cf::lock_acquire $string 369=item my $lock = cf::lock_acquire $string
237 370
238Wait 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
239a 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,
240for example when the coroutine gets canceled), the lock is automatically 373for example when the coroutine gets canceled), the lock is automatically
241returned. 374returned.
242 375
376Locks are *not* recursive, locking from the same coro twice results in a
377deadlocked coro.
378
243Lock 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
244uses map_find and cf::map::load uses map_load). 380uses map_find and cf::map::load uses map_load).
245 381
246=cut 382=item $locked = cf::lock_active $string
247 383
248our %LOCK; 384Return true if the lock is currently active, i.e. somebody has locked it.
385
386=cut
387
388our $LOCKS = new Coro::SemaphoreSet;
249 389
250sub lock_wait($) { 390sub lock_wait($) {
251 my ($key) = @_; 391 $LOCKS->wait ($_[0]);
252
253 # wait for lock, if any
254 while ($LOCK{$key}) {
255 push @{ $LOCK{$key} }, $Coro::current;
256 Coro::schedule;
257 }
258} 392}
259 393
260sub lock_acquire($) { 394sub lock_acquire($) {
261 my ($key) = @_; 395 $LOCKS->guard ($_[0])
396}
262 397
263 # wait, to be sure we are not locked 398sub lock_active($) {
264 lock_wait $key; 399 $LOCKS->count ($_[0]) < 1
265
266 $LOCK{$key} = [];
267
268 Coro::guard {
269 # wake up all waiters, to be on the safe side
270 $_->ready for @{ delete $LOCK{$key} };
271 }
272} 400}
273 401
274sub freeze_mainloop { 402sub freeze_mainloop {
275 return unless $TICK_WATCHER->is_active; 403 tick_inhibit_inc;
276 404
277 my $guard = Coro::guard { 405 &Guard::guard (\&tick_inhibit_dec);
278 $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 }
279 }; 472 }
280 $TICK_WATCHER->stop; 473};
281 $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;
282} 488}
283 489
284=item cf::async { BLOCK } 490=item cf::async { BLOCK }
285 491
286Currently the same as Coro::async_pool, meaning you cannot use 492Currently the same as Coro::async_pool, meaning you cannot use
291 497
292BEGIN { *async = \&Coro::async_pool } 498BEGIN { *async = \&Coro::async_pool }
293 499
294=item cf::sync_job { BLOCK } 500=item cf::sync_job { BLOCK }
295 501
296The design of crossfire+ requires that the main coro ($Coro::main) is 502The design of Deliantra requires that the main coroutine ($Coro::main)
297always able to handle events or runnable, as crossfire+ is only partly 503is always able to handle events or runnable, as Deliantra is only
298reentrant. 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.
299 506
300If 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
301the given BLOCK in another coroutine while waiting for the result. The 508the given BLOCK in another coroutine while waiting for the result. The
302server 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
303fast or be very important. 510fast or be very important.
306 513
307sub sync_job(&) { 514sub sync_job(&) {
308 my ($job) = @_; 515 my ($job) = @_;
309 516
310 if ($Coro::current == $Coro::main) { 517 if ($Coro::current == $Coro::main) {
518 my $time = AE::time;
519
311 # this is the main coro, too bad, we have to block 520 # this is the main coro, too bad, we have to block
312 # till the operation succeeds, freezing the server :/ 521 # till the operation succeeds, freezing the server :/
313 522
314 # TODO: use suspend/resume instead 523 LOG llevError, Carp::longmess "sync job";#d#
315 # (but this is cancel-safe) 524
316 my $freeze_guard = freeze_mainloop; 525 my $freeze_guard = freeze_mainloop;
317 526
318 my $busy = 1; 527 my $busy = 1;
319 my @res; 528 my @res;
320 529
321 (async { 530 (async {
531 $Coro::current->desc ("sync job coro");
322 @res = eval { $job->() }; 532 @res = eval { $job->() };
323 warn $@ if $@; 533 warn $@ if $@;
324 undef $busy; 534 undef $busy;
325 })->prio (Coro::PRIO_MAX); 535 })->prio (Coro::PRIO_MAX);
326 536
327 while ($busy) { 537 while ($busy) {
328 Coro::cede or Event::one_event; 538 if (Coro::nready) {
539 Coro::cede_notself;
540 } else {
541 EV::loop EV::LOOP_ONESHOT;
329 } 542 }
543 }
544
545 my $time = AE::time - $time;
546
547 $TICK_START += $time; # do not account sync jobs to server load
330 548
331 wantarray ? @res : $res[0] 549 wantarray ? @res : $res[0]
332 } else { 550 } else {
333 # we are in another coroutine, how wonderful, everything just works 551 # we are in another coroutine, how wonderful, everything just works
334 552
354 $EXT_CORO{$coro+0} = $coro; 572 $EXT_CORO{$coro+0} = $coro;
355 573
356 $coro 574 $coro
357} 575}
358 576
359sub write_runtime { 577=item fork_call { }, $args
360 my $guard = cf::lock_acquire "write_runtime";
361 578
362 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.
363 583
364 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644 584=cut
365 or return;
366 585
367 my $value = $cf::RUNTIME + 90 + 10; 586sub fork_call(&@) {
368 # 10 is the runtime save interval, for a monotonic clock 587 my ($cb, @args) = @_;
369 # 60 allows for the watchdog to kill the server.
370 588
371 (aio_write $fh, 0, (length $value), $value, 0) <= 0 589 # we seemingly have to make a local copy of the whole thing,
372 and return; 590 # otherwise perl prematurely frees the stuff :/
591 # TODO: investigate and fix (likely this will be rather laborious)
373 592
374 # always fsync - this file is important 593 my @res = Coro::Util::fork_eval {
375 aio_fsync $fh 594 reset_signals;
376 and return; 595 &$cb
596 }, @args;
377 597
378 close $fh 598 wantarray ? @res : $res[-1]
379 or return; 599}
380 600
381 aio_rename "$runtime~", $runtime 601sub objinfo {
382 and return;
383
384 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"
764}
765
766=item cf::datalog type => key => value, ...
767
768Log a datalog packet of the given type with the given key-value pairs.
769
770=cut
771
772sub datalog($@) {
773 my ($type, %kv) = @_;
774 warn "DATALOG ", JSON::XS->new->ascii->encode ({ %kv, type => $type });
385} 775}
386 776
387=back 777=back
388 778
389=cut 779=cut
390 780
391############################################################################# 781#############################################################################
392 782
393=head2 ATTACHABLE OBJECTS 783=head2 ATTACHABLE OBJECTS
394 784
395Many 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
396attach callbacks/event handlers (a collection of which is called an "attachment") 786attach callbacks/event handlers (a collection of which is called an "attachment")
397to it. All such attachable objects support the following methods. 787to it. All such attachable objects support the following methods.
398 788
399In 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>
400C<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
401crossfire+). 791Deliantra).
402 792
403=over 4 793=over 4
404 794
405=item $attachable->attach ($attachment, key => $value...) 795=item $attachable->attach ($attachment, key => $value...)
406 796
450=item cf::CLASS::attachment $name, ... 840=item cf::CLASS::attachment $name, ...
451 841
452Register an attachment by C<$name> through which attachable objects of the 842Register an attachment by C<$name> through which attachable objects of the
453given CLASS can refer to this attachment. 843given CLASS can refer to this attachment.
454 844
455Some classes such as crossfire maps and objects can specify attachments 845Some classes such as deliantra maps and objects can specify attachments
456that 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.
457 847
458These calls expect any number of the following handler/hook descriptions: 848These calls expect any number of the following handler/hook descriptions:
459 849
460=over 4 850=over 4
569 $registry = $CB_TYPE[$object_type] ||= []; 959 $registry = $CB_TYPE[$object_type] ||= [];
570 960
571 } elsif ($type eq "subtype") { 961 } elsif ($type eq "subtype") {
572 defined $object_type or Carp::croak "subtype specified without type"; 962 defined $object_type or Carp::croak "subtype specified without type";
573 my $object_subtype = shift @arg; 963 my $object_subtype = shift @arg;
574 $registry = $CB_TYPE[$object_type + $object_subtype * NUM_SUBTYPES] ||= []; 964 $registry = $CB_TYPE[$object_type + $object_subtype * NUM_TYPES] ||= [];
575 965
576 } elsif ($type eq "package") { 966 } elsif ($type eq "package") {
577 my $pkg = shift @arg; 967 my $pkg = shift @arg;
578 968
579 while (my ($name, $id) = each %cb_id) { 969 while (my ($name, $id) = each %cb_id) {
608 _attach $registry, $klass, @attach; 998 _attach $registry, $klass, @attach;
609 } 999 }
610 1000
611 $obj->{$name} = \%arg; 1001 $obj->{$name} = \%arg;
612 } else { 1002 } else {
613 warn "object uses attachment '$name' that is not available, postponing.\n"; 1003 warn "object uses attachment '$name' which is not available, postponing.\n";
614 } 1004 }
615 1005
616 $obj->{_attachment}{$name} = undef; 1006 $obj->{_attachment}{$name} = undef;
617} 1007}
618 1008
620 if (ref $_[0]) { 1010 if (ref $_[0]) {
621 _object_attach @_; 1011 _object_attach @_;
622 } else { 1012 } else {
623 _attach shift->_attach_registry, @_; 1013 _attach shift->_attach_registry, @_;
624 } 1014 }
1015 _recalc_want;
625}; 1016};
626 1017
627# all those should be optimised 1018# all those should be optimised
628sub cf::attachable::detach { 1019sub cf::attachable::detach {
629 my ($obj, $name) = @_; 1020 my ($obj, $name) = @_;
632 delete $obj->{_attachment}{$name}; 1023 delete $obj->{_attachment}{$name};
633 reattach ($obj); 1024 reattach ($obj);
634 } else { 1025 } else {
635 Carp::croak "cannot, currently, detach class attachments"; 1026 Carp::croak "cannot, currently, detach class attachments";
636 } 1027 }
1028 _recalc_want;
637}; 1029};
638 1030
639sub cf::attachable::attached { 1031sub cf::attachable::attached {
640 my ($obj, $name) = @_; 1032 my ($obj, $name) = @_;
641 1033
656 "; 1048 ";
657 die if $@; 1049 die if $@;
658} 1050}
659 1051
660our $override; 1052our $override;
661our @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?
662 1054
663sub override { 1055sub override {
664 $override = 1; 1056 $override = 1;
665 @invoke_results = (); 1057 @INVOKE_RESULTS = (@_);
666} 1058}
667 1059
668sub do_invoke { 1060sub do_invoke {
669 my $event = shift; 1061 my $event = shift;
670 my $callbacks = shift; 1062 my $callbacks = shift;
671 1063
672 @invoke_results = (); 1064 @INVOKE_RESULTS = ();
673 1065
674 local $override; 1066 local $override;
675 1067
676 for (@$callbacks) { 1068 for (@$callbacks) {
677 eval { &{$_->[1]} }; 1069 eval { &{$_->[1]} };
686 } 1078 }
687 1079
688 0 1080 0
689} 1081}
690 1082
691=item $bool = cf::global::invoke (EVENT_CLASS_XXX, ...) 1083=item $bool = cf::global->invoke (EVENT_CLASS_XXX, ...)
692 1084
693=item $bool = $attachable->invoke (EVENT_CLASS_XXX, ...) 1085=item $bool = $attachable->invoke (EVENT_CLASS_XXX, ...)
694 1086
695Generate an object-specific event with the given arguments. 1087Generate an object-specific event with the given arguments.
696 1088
697This 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
698removed 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
699results (if you must, access C<@cf::invoke_results> directly). 1091results (if you must, access C<@cf::INVOKE_RESULTS> directly).
700 1092
701=back 1093=back
702 1094
703=cut 1095=cut
704 1096
705############################################################################# 1097#############################################################################
706# 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}
707 1141
708sub reattach { 1142sub reattach {
709 # basically do the same as instantiate, without calling instantiate 1143 # basically do the same as instantiate, without calling instantiate
710 my ($obj) = @_; 1144 my ($obj) = @_;
711 1145
1146 # no longer needed after getting rid of delete_package?
712 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
713 1148
714 my $registry = $obj->registry; 1149 my $registry = $obj->registry;
715 1150
716 @$registry = (); 1151 @$registry = ();
717 1152
732cf::attachable->attach ( 1167cf::attachable->attach (
733 prio => -1000000, 1168 prio => -1000000,
734 on_instantiate => sub { 1169 on_instantiate => sub {
735 my ($obj, $data) = @_; 1170 my ($obj, $data) = @_;
736 1171
737 $data = from_json $data; 1172 $data = decode_json $data;
738 1173
739 for (@$data) { 1174 for (@$data) {
740 my ($name, $args) = @$_; 1175 my ($name, $args) = @$_;
741 1176
742 $obj->attach ($name, %{$args || {} }); 1177 $obj->attach ($name, %{$args || {} });
758sub object_freezer_save { 1193sub object_freezer_save {
759 my ($filename, $rdata, $objs) = @_; 1194 my ($filename, $rdata, $objs) = @_;
760 1195
761 sync_job { 1196 sync_job {
762 if (length $$rdata) { 1197 if (length $$rdata) {
1198 utf8::decode (my $decname = $filename);
763 warn sprintf "saving %s (%d,%d)\n", 1199 warn sprintf "saving %s (%d,%d)\n",
764 $filename, length $$rdata, scalar @$objs; 1200 $decname, length $$rdata, scalar @$objs
1201 if $VERBOSE_IO;
765 1202
766 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) { 1203 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
767 chmod SAVE_MODE, $fh; 1204 aio_chmod $fh, SAVE_MODE;
768 aio_write $fh, 0, (length $$rdata), $$rdata, 0; 1205 aio_write $fh, 0, (length $$rdata), $$rdata, 0;
769 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 }
770 close $fh; 1210 aio_close $fh;
771 1211
772 if (@$objs) { 1212 if (@$objs) {
773 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) {
774 chmod SAVE_MODE, $fh; 1214 aio_chmod $fh, SAVE_MODE;
775 my $data = Storable::nfreeze { version => 1, objs => $objs }; 1215 my $data = Coro::Storable::nfreeze { version => 1, objs => $objs };
776 aio_write $fh, 0, (length $data), $data, 0; 1216 aio_write $fh, 0, (length $data), $data, 0;
777 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 }
778 close $fh; 1221 aio_close $fh;
779 aio_rename "$filename.pst~", "$filename.pst"; 1222 aio_rename "$filename.pst~", "$filename.pst";
780 } 1223 }
781 } else { 1224 } else {
782 aio_unlink "$filename.pst"; 1225 aio_unlink "$filename.pst";
783 } 1226 }
784 1227
785 aio_rename "$filename~", $filename; 1228 aio_rename "$filename~", $filename;
1229
1230 $filename =~ s%/[^/]+$%%;
1231 aio_pathsync $filename if $cf::USE_FSYNC;
786 } else { 1232 } else {
787 warn "FATAL: $filename~: $!\n"; 1233 warn "unable to save objects: $filename~: $!\n";
788 } 1234 }
789 } else { 1235 } else {
790 aio_unlink $filename; 1236 aio_unlink $filename;
791 aio_unlink "$filename.pst"; 1237 aio_unlink "$filename.pst";
792 } 1238 }
793 } 1239 };
794} 1240}
795 1241
796sub object_freezer_as_string { 1242sub object_freezer_as_string {
797 my ($rdata, $objs) = @_; 1243 my ($rdata, $objs) = @_;
798 1244
810 or return; 1256 or return;
811 1257
812 unless (aio_stat "$filename.pst") { 1258 unless (aio_stat "$filename.pst") {
813 (aio_load "$filename.pst", $av) >= 0 1259 (aio_load "$filename.pst", $av) >= 0
814 or return; 1260 or return;
1261
815 $av = eval { (Storable::thaw $av)->{objs} }; 1262 my $st = eval { Coro::Storable::thaw $av };
1263 $av = $st->{objs};
816 } 1264 }
817 1265
1266 utf8::decode (my $decname = $filename);
818 warn sprintf "loading %s (%d)\n", 1267 warn sprintf "loading %s (%d,%d)\n",
819 $filename, length $data, scalar @{$av || []};#d# 1268 $decname, length $data, scalar @{$av || []}
1269 if $VERBOSE_IO;
1270
820 return ($data, $av); 1271 ($data, $av)
821} 1272}
1273
1274=head2 COMMAND CALLBACKS
1275
1276=over 4
1277
1278=cut
822 1279
823############################################################################# 1280#############################################################################
824# command handling &c 1281# command handling &c
825 1282
826=item cf::register_command $name => \&callback($ob,$args); 1283=item cf::register_command $name => \&callback($ob,$args);
839 push @{ $COMMAND{$name} }, [$caller, $cb]; 1296 push @{ $COMMAND{$name} }, [$caller, $cb];
840} 1297}
841 1298
842=item cf::register_extcmd $name => \&callback($pl,$packet); 1299=item cf::register_extcmd $name => \&callback($pl,$packet);
843 1300
844Register 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.
845 1306
846If 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
847called. 1308called.
848 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
849=cut 1321=cut
850 1322
851sub register_extcmd { 1323sub register_extcmd {
852 my ($name, $cb) = @_; 1324 my ($name, $cb) = @_;
853 1325
854 $EXTCMD{$name} = $cb; 1326 $EXTCMD{$name} = $cb;
855} 1327}
856 1328
1329sub register_exticmd {
1330 my ($name, $cb) = @_;
1331
1332 $EXTICMD{$name} = $cb;
1333}
1334
1335use File::Glob ();
1336
857cf::player->attach ( 1337cf::player->attach (
858 on_command => sub { 1338 on_unknown_command => sub {
859 my ($pl, $name, $params) = @_; 1339 my ($pl, $name, $params) = @_;
860 1340
861 my $cb = $COMMAND{$name} 1341 my $cb = $COMMAND{$name}
862 or return; 1342 or return;
863 1343
868 cf::override; 1348 cf::override;
869 }, 1349 },
870 on_extcmd => sub { 1350 on_extcmd => sub {
871 my ($pl, $buf) = @_; 1351 my ($pl, $buf) = @_;
872 1352
873 my $msg = eval { from_json $buf }; 1353 my $msg = eval { $pl->ns->{json_coder}->decode ($buf) };
874 1354
875 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
876 if (my $cb = $EXTCMD{$msg->{msgtype}}) { 1363 if (my $cb = $EXTCMD{$type}) {
877 if (my %reply = $cb->($pl, $msg)) { 1364 @reply = $cb->($pl, @payload);
878 $pl->ext_reply ($msg->{msgid}, %reply);
879 }
880 } 1365 }
1366
1367 $pl->ext_reply ($reply, @reply)
1368 if $reply;
1369
881 } else { 1370 } else {
882 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n"; 1371 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
883 } 1372 }
884 1373
885 cf::override; 1374 cf::override;
886 }, 1375 },
887); 1376);
888 1377
1378# "readahead" all extensions
889sub load_extension { 1379sub cache_extensions {
890 my ($path) = @_; 1380 my $grp = IO::AIO::aio_group;
891 1381
892 $path =~ /([^\/\\]+)\.ext$/ or die "$path"; 1382 add $grp IO::AIO::aio_readdirx $LIBDIR, IO::AIO::READDIR_STAT_ORDER, sub {
893 my $base = $1; 1383 for (grep /\.ext$/, @{$_[0]}) {
894 my $pkg = $1; 1384 add $grp IO::AIO::aio_load "$LIBDIR/$_", my $data;
895 $pkg =~ s/[^[:word:]]/_/g;
896 $pkg = "ext::$pkg";
897
898 warn "... loading '$path' into '$pkg'\n";
899
900 open my $fh, "<:utf8", $path
901 or die "$path: $!";
902
903 my $source =
904 "package $pkg; use strict; use utf8;\n"
905 . "#line 1 \"$path\"\n{\n"
906 . (do { local $/; <$fh> })
907 . "\n};\n1";
908
909 unless (eval $source) {
910 my $msg = $@ ? "$path: $@\n"
911 : "extension disabled.\n";
912 if ($source =~ /^#!.*perl.*#.*MANDATORY/m) { # ugly match
913 warn $@;
914 warn "mandatory extension failed to load, exiting.\n";
915 exit 1;
916 } 1385 }
917 die $@;
918 } 1386 };
919 1387
920 push @EXTS, $pkg; 1388 $grp
921} 1389}
922 1390
923sub load_extensions { 1391sub load_extensions {
1392 cf::sync_job {
1393 my %todo;
1394
924 for my $ext (<$LIBDIR/*.ext>) { 1395 for my $path (<$LIBDIR/*.ext>) {
925 next unless -r $ext; 1396 next unless -r $path;
926 eval { 1397
927 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 }
928 1 1461 }
929 } 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 }
930 } 1472 };
931} 1473}
932 1474
933############################################################################# 1475#############################################################################
934 1476
1477=back
1478
935=head2 CORE EXTENSIONS 1479=head2 CORE EXTENSIONS
936 1480
937Functions and methods that extend core crossfire objects. 1481Functions and methods that extend core deliantra objects.
938 1482
939=cut 1483=cut
940 1484
941package cf::player; 1485package cf::player;
942 1486
944 1488
945=head3 cf::player 1489=head3 cf::player
946 1490
947=over 4 1491=over 4
948 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
949=item cf::player::find $login 1507=item cf::player::find $login
950 1508
951Returns the given player object, loading it if necessary (might block). 1509Returns the given player object, loading it if necessary (might block).
952 1510
953=cut 1511=cut
954 1512
955sub playerdir($) { 1513sub playerdir($) {
956 cf::localdir 1514 "$PLAYERDIR/"
957 . "/"
958 . cf::playerdir
959 . "/"
960 . (ref $_[0] ? $_[0]->ob->name : $_[0]) 1515 . (ref $_[0] ? $_[0]->ob->name : $_[0])
961} 1516}
962 1517
963sub path($) { 1518sub path($) {
964 my $login = ref $_[0] ? $_[0]->ob->name : $_[0]; 1519 my $login = ref $_[0] ? $_[0]->ob->name : $_[0];
965 1520
966 (playerdir $login) . "/$login.pl" 1521 (playerdir $login) . "/playerdata"
967} 1522}
968 1523
969sub find_active($) { 1524sub find_active($) {
970 $cf::PLAYER{$_[0]} 1525 $cf::PLAYER{$_[0]}
971 and $cf::PLAYER{$_[0]}->active 1526 and $cf::PLAYER{$_[0]}->active
974 1529
975sub exists($) { 1530sub exists($) {
976 my ($login) = @_; 1531 my ($login) = @_;
977 1532
978 $cf::PLAYER{$login} 1533 $cf::PLAYER{$login}
979 or cf::sync_job { !aio_stat path $login } 1534 or !aio_stat path $login
980} 1535}
981 1536
982sub find($) { 1537sub find($) {
983 return $cf::PLAYER{$_[0]} || do { 1538 return $cf::PLAYER{$_[0]} || do {
984 my $login = $_[0]; 1539 my $login = $_[0];
985 1540
986 my $guard = cf::lock_acquire "user_find:$login"; 1541 my $guard = cf::lock_acquire "user_find:$login";
987 1542
988 $cf::PLAYER{$_[0]} || do { 1543 $cf::PLAYER{$_[0]} || do {
989 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
990 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;
991 $cf::PLAYER{$login} = $pl 1559 $cf::PLAYER{$login} = $pl
992 } 1560 }
993 } 1561 }
994} 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);
995 1576
996sub save($) { 1577sub save($) {
997 my ($pl) = @_; 1578 my ($pl) = @_;
998 1579
999 return if $pl->{deny_save}; 1580 return if $pl->{deny_save};
1004 return if $pl->{deny_save}; 1585 return if $pl->{deny_save};
1005 1586
1006 aio_mkdir playerdir $pl, 0770; 1587 aio_mkdir playerdir $pl, 0770;
1007 $pl->{last_save} = $cf::RUNTIME; 1588 $pl->{last_save} = $cf::RUNTIME;
1008 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
1009 $pl->save_pl ($path); 1595 $pl->save_pl ($path);
1010 Coro::cede; 1596 cf::cede_to_tick;
1011} 1597}
1012 1598
1013sub new($) { 1599sub new($) {
1014 my ($login) = @_; 1600 my ($login) = @_;
1015 1601
1021 $cf::PLAYER{$login} = $self; 1607 $cf::PLAYER{$login} = $self;
1022 1608
1023 $self 1609 $self
1024} 1610}
1025 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
1026=item $pl->quit_character 1622=item $pl->quit_character
1027 1623
1028Nukes the player without looking back. If logged in, the connection will 1624Nukes the player without looking back. If logged in, the connection will
1029be destroyed. May block for a long time. 1625be destroyed. May block for a long time.
1030 1626
1034 my ($pl) = @_; 1630 my ($pl) = @_;
1035 1631
1036 my $name = $pl->ob->name; 1632 my $name = $pl->ob->name;
1037 1633
1038 $pl->{deny_save} = 1; 1634 $pl->{deny_save} = 1;
1039 $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
1040 1636
1041 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active; 1637 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active;
1042 $pl->deactivate; 1638 $pl->deactivate;
1639 my $killer = cf::arch::get "killer_quit"; $pl->killer ($killer); $killer->destroy;
1043 $pl->invoke (cf::EVENT_PLAYER_QUIT); 1640 $pl->invoke (cf::EVENT_PLAYER_QUIT);
1044 $pl->ns->destroy if $pl->ns; 1641 $pl->ns->destroy if $pl->ns;
1045 1642
1046 my $path = playerdir $pl; 1643 my $path = playerdir $pl;
1047 my $temp = "$path~$cf::RUNTIME~deleting~"; 1644 my $temp = "$path~$cf::RUNTIME~deleting~";
1077while and may block, so not sync_job-capable, ever. 1674while and may block, so not sync_job-capable, ever.
1078 1675
1079=cut 1676=cut
1080 1677
1081sub list_logins { 1678sub list_logins {
1082 my $dirs = aio_readdir cf::localdir . "/" . cf::playerdir 1679 my $dirs = aio_readdir $PLAYERDIR
1083 or return []; 1680 or return [];
1084 1681
1085 my @logins; 1682 my @logins;
1086 1683
1087 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") {
1088 my $fh = aio_open path $login, Fcntl::O_RDONLY, 0 or next; 1690 my $fh = aio_open $path, Fcntl::O_RDONLY, 0 or next;
1089 aio_read $fh, 0, 512, my $buf, 0 or next; 1691 aio_read $fh, 0, 512, my $buf, 0 or next;
1090 $buf !~ /^password -------------$/m or next; # official not-valid tag 1692 $buf !~ /^password -------------$/m or next; # official not-valid tag
1693 }
1091 1694
1092 utf8::decode $login; 1695 utf8::decode $login;
1093 push @logins, $login; 1696 push @logins, $login;
1094 } 1697 }
1095 1698
1096 \@logins 1699 \@logins
1097} 1700}
1098 1701
1099=item $player->maps 1702=item $player->maps
1703
1704=item cf::player::maps $login
1100 1705
1101Returns an arrayref of map paths that are private for this 1706Returns an arrayref of map paths that are private for this
1102player. May block. 1707player. May block.
1103 1708
1104=cut 1709=cut
1122 } 1727 }
1123 1728
1124 \@paths 1729 \@paths
1125} 1730}
1126 1731
1732=item $protocol_xml = $player->expand_cfpod ($cfpod)
1733
1734Expand deliantra pod fragments into protocol xml.
1735
1127=item $player->ext_reply ($msgid, $msgtype, %msg) 1736=item $player->ext_reply ($msgid, @msg)
1128 1737
1129Sends an ext reply to the player. 1738Sends an ext reply to the player.
1130 1739
1131=cut 1740=cut
1132 1741
1133sub ext_reply($$$%) { 1742sub ext_reply($$@) {
1134 my ($self, $id, %msg) = @_; 1743 my ($self, $id, @msg) = @_;
1135 1744
1136 $msg{msgid} = $id; 1745 $self->ns->ext_reply ($id, @msg)
1137
1138 $self->send ("ext " . cf::to_json \%msg);
1139} 1746}
1140 1747
1141package cf; 1748=item $player->ext_msg ($type, @msg)
1749
1750Sends an ext event to the client.
1751
1752=cut
1753
1754sub ext_msg($$@) {
1755 my ($self, $type, @msg) = @_;
1756
1757 $self->ns->ext_msg ($type, @msg);
1758}
1759
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}
1142 1790
1143=back 1791=back
1144
1145 1792
1146=head3 cf::map 1793=head3 cf::map
1147 1794
1148=over 4 1795=over 4
1149 1796
1161our $MAX_RESET = 3600; 1808our $MAX_RESET = 3600;
1162our $DEFAULT_RESET = 3000; 1809our $DEFAULT_RESET = 3000;
1163 1810
1164sub generate_random_map { 1811sub generate_random_map {
1165 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
1166 # mit "rum" bekleckern, nicht 1816 # mit "rum" bekleckern, nicht
1167 $self->_create_random_map ( 1817 $self->_create_random_map (
1168 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle}, 1818 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle},
1169 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle}, 1819 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle}, $rmp->{miningstyle},
1170 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map}, 1820 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map},
1171 $rmp->{exit_on_final_map}, 1821 $rmp->{exit_on_final_map},
1172 $rmp->{xsize}, $rmp->{ysize}, 1822 $rmp->{xsize}, $rmp->{ysize},
1173 $rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3}, 1823 $rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3},
1174 $rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase}, 1824 $rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase},
1196 1846
1197 $EXT_MAP{$pkg} = [$prio, qr<$regex>]; 1847 $EXT_MAP{$pkg} = [$prio, qr<$regex>];
1198} 1848}
1199 1849
1200# also paths starting with '/' 1850# also paths starting with '/'
1201$EXT_MAP{"cf::map"} = [0, qr{^(?=/)}]; 1851$EXT_MAP{"cf::map::wrap"} = [0, qr{^(?=/)}];
1202 1852
1203sub thawer_merge { 1853sub thawer_merge {
1204 my ($self, $merge) = @_; 1854 my ($self, $merge) = @_;
1205 1855
1206 # we have to keep some variables in memory intact 1856 # we have to keep some variables in memory intact
1207 local $self->{path}; 1857 local $self->{path};
1208 local $self->{load_path}; 1858 local $self->{load_path};
1209 local $self->{deny_save};
1210 local $self->{deny_reset};
1211 1859
1212 $self->SUPER::thawer_merge ($merge); 1860 $self->SUPER::thawer_merge ($merge);
1213} 1861}
1214 1862
1215sub normalise { 1863sub normalise {
1262 $self->init; # pass $1 etc. 1910 $self->init; # pass $1 etc.
1263 return $self; 1911 return $self;
1264 } 1912 }
1265 } 1913 }
1266 1914
1267 Carp::carp "unable to resolve path '$path' (base '$base')."; 1915 Carp::cluck "unable to resolve path '$path' (base '$base').";
1268 () 1916 ()
1269} 1917}
1270 1918
1271sub init { 1919sub init {
1272 my ($self) = @_; 1920 my ($self) = @_;
1287 1935
1288# the original (read-only) location 1936# the original (read-only) location
1289sub load_path { 1937sub load_path {
1290 my ($self) = @_; 1938 my ($self) = @_;
1291 1939
1292 sprintf "%s/%s/%s.map", cf::datadir, cf::mapdir, $self->{path} 1940 "$MAPDIR/$self->{path}.map"
1293} 1941}
1294 1942
1295# the temporary/swap location 1943# the temporary/swap location
1296sub save_path { 1944sub save_path {
1297 my ($self) = @_; 1945 my ($self) = @_;
1298 1946
1299 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g; 1947 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/go;
1300 sprintf "%s/%s/%s.map", cf::localdir, cf::tmpdir, $path 1948 "$TMPDIR/$path.map"
1301} 1949}
1302 1950
1303# the unique path, undef == no special unique path 1951# the unique path, undef == no special unique path
1304sub uniq_path { 1952sub uniq_path {
1305 my ($self) = @_; 1953 my ($self) = @_;
1306 1954
1307 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g; 1955 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/go;
1308 sprintf "%s/%s/%s", cf::localdir, cf::uniquedir, $path 1956 "$UNIQUEDIR/$path"
1309} 1957}
1310 1958
1311# and all this just because we cannot iterate over 1959sub decay_objects {
1312# all maps in C++...
1313sub change_all_map_light {
1314 my ($change) = @_; 1960 my ($self) = @_;
1315 1961
1316 $_->change_map_light ($change) 1962 return if $self->{deny_reset};
1317 for grep $_->outdoor, values %cf::MAP; 1963
1964 $self->do_decay_objects;
1318} 1965}
1319 1966
1320sub unlink_save { 1967sub unlink_save {
1321 my ($self) = @_; 1968 my ($self) = @_;
1322 1969
1327 1974
1328sub load_header_from($) { 1975sub load_header_from($) {
1329 my ($self, $path) = @_; 1976 my ($self, $path) = @_;
1330 1977
1331 utf8::encode $path; 1978 utf8::encode $path;
1332 #aio_open $path, O_RDONLY, 0 1979 my $f = new_from_file cf::object::thawer $path
1333 # or return;
1334
1335 $self->_load_header ($path)
1336 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;
1337 1987
1338 $self->{load_path} = $path; 1988 $self->{load_path} = $path;
1339 1989
1340 1 1990 1
1341} 1991}
1380 $self->load_header_orig 2030 $self->load_header_orig
1381 or return; 2031 or return;
1382 $self->prepare_orig; 2032 $self->prepare_orig;
1383 } 2033 }
1384 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
1385 1 2041 1
1386} 2042}
1387 2043
1388sub find; 2044sub find;
1389sub find { 2045sub find {
1390 my ($path, $origin) = @_; 2046 my ($path, $origin) = @_;
1391 2047
1392 $path = normalise $path, $origin && $origin->path; 2048 $path = normalise $path, $origin && $origin->path;
1393 2049
2050 my $guard1 = cf::lock_acquire "map_data:$path";#d#remove
1394 cf::lock_wait "map_find:$path"; 2051 my $guard2 = cf::lock_acquire "map_find:$path";
1395 2052
1396 $cf::MAP{$path} || do { 2053 $cf::MAP{$path} || do {
1397 my $guard = cf::lock_acquire "map_find:$path";
1398 my $map = new_from_path cf::map $path 2054 my $map = new_from_path cf::map $path
1399 or return; 2055 or return;
1400 2056
1401 $map->{last_save} = $cf::RUNTIME; 2057 $map->{last_save} = $cf::RUNTIME;
1402 2058
1403 $map->load_header 2059 $map->load_header
1404 or return; 2060 or return;
1405 2061
1406 if ($map->should_reset && 0) {#d#TODO# disabled, crashy (locking issue?) 2062 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?)
1407 # doing this can freeze the server in a sync job, obviously 2063 # doing this can freeze the server in a sync job, obviously
1408 #$cf::WAIT_FOR_TICK->wait; 2064 #$cf::WAIT_FOR_TICK->wait;
2065 undef $guard2;
2066 undef $guard1;
1409 $map->reset; 2067 $map->reset;
1410 undef $guard;
1411 return find $path; 2068 return find $path;
1412 } 2069 }
1413 2070
1414 $cf::MAP{$path} = $map 2071 $cf::MAP{$path} = $map
1415 } 2072 }
1416} 2073}
1417 2074
1418sub pre_load { } 2075sub pre_load { }
1419sub post_load { } 2076#sub post_load { } # XS
1420 2077
1421sub load { 2078sub load {
1422 my ($self) = @_; 2079 my ($self) = @_;
1423 2080
1424 local $self->{deny_reset} = 1; # loading can take a long time 2081 local $self->{deny_reset} = 1; # loading can take a long time
1425 2082
1426 my $path = $self->{path}; 2083 my $path = $self->{path};
2084
2085 {
1427 my $guard = cf::lock_acquire "map_load:$path"; 2086 my $guard = cf::lock_acquire "map_data:$path";
1428 2087
2088 return unless $self->valid;
1429 return if $self->in_memory != cf::MAP_SWAPPED; 2089 return unless $self->in_memory == cf::MAP_SWAPPED;
1430 2090
1431 $self->in_memory (cf::MAP_LOADING); 2091 $self->in_memory (cf::MAP_LOADING);
1432 2092
1433 $self->alloc; 2093 $self->alloc;
1434 2094
1435 $self->pre_load; 2095 $self->pre_load;
2096 cf::cede_to_tick;
1436 2097
1437 $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)
1438 or return; 2101 or return;
1439 2102
1440 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1) 2103 $self->post_load_original
1441 if delete $self->{load_original}; 2104 if delete $self->{load_original};
1442 2105
1443 if (my $uniq = $self->uniq_path) { 2106 if (my $uniq = $self->uniq_path) {
1444 utf8::encode $uniq; 2107 utf8::encode $uniq;
1445 if (aio_open $uniq, O_RDONLY, 0) { 2108 unless (aio_stat $uniq) {
2109 if (my $f = new_from_file cf::object::thawer $uniq) {
1446 $self->clear_unique_items; 2110 $self->clear_unique_items;
1447 $self->_load_objects ($uniq, 0); 2111 $self->_load_objects ($f);
2112 $f->resolve_delayed_derefs;
2113 }
1448 } 2114 }
1449 } 2115 }
1450 2116
1451 Coro::cede; 2117 $f->resolve_delayed_derefs;
1452 2118
2119 cf::cede_to_tick;
1453 # now do the right thing for maps 2120 # now do the right thing for maps
1454 $self->link_multipart_objects; 2121 $self->link_multipart_objects;
1455
1456 unless ($self->{deny_activate}) {
1457 $self->decay_objects;
1458 $self->fix_auto_apply;
1459 $self->update_buttons;
1460 Coro::cede;
1461 $self->set_darkness_map;
1462 $self->difficulty ($self->estimate_difficulty) 2122 $self->difficulty ($self->estimate_difficulty)
1463 unless $self->difficulty; 2123 unless $self->difficulty;
1464 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;
1465 $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);
1466 } 2138 }
1467 2139
1468 $self->post_load; 2140 $self->post_load;
1469
1470 $self->in_memory (cf::MAP_IN_MEMORY);
1471} 2141}
1472 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
1473sub customise_for { 2146sub customise_for {
1474 my ($self, $ob) = @_; 2147 my ($self, $ob) = @_;
1475 2148
1476 return find "~" . $ob->name . "/" . $self->{path} 2149 return find "~" . $ob->name . "/" . $self->{path}
1477 if $self->per_player; 2150 if $self->per_player;
1478 2151
2152# return find "?party/" . $ob->name . "/" . $self->{path}
2153# if $self->per_party;
2154
1479 $self 2155 $self
1480} 2156}
1481 2157
1482# 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
1483sub load_diag { 2159sub load_neighbours {
1484 my ($map) = @_; 2160 my ($map) = @_;
1485 2161
1486 my @diag; # diagonal neighbours 2162 my @neigh; # diagonal neighbours
1487 2163
1488 for (0 .. 3) { 2164 for (0 .. 3) {
1489 my $neigh = $map->tile_path ($_) 2165 my $neigh = $map->tile_path ($_)
1490 or next; 2166 or next;
1491 $neigh = find $neigh, $map 2167 $neigh = find $neigh, $map
1492 or next; 2168 or next;
1493 $neigh->load; 2169 $neigh->load;
1494 2170
2171 # now find the diagonal neighbours
2172 push @neigh,
1495 push @diag, [$neigh->tile_path (($_ + 3) % 4), $neigh], 2173 [$neigh->tile_path (($_ + 3) % 4), $neigh],
1496 [$neigh->tile_path (($_ + 1) % 4), $neigh]; 2174 [$neigh->tile_path (($_ + 1) % 4), $neigh];
1497 } 2175 }
1498 2176
1499 for (@diag) { 2177 for (grep defined $_->[0], @neigh) {
2178 my ($path, $origin) = @$_;
1500 my $neigh = find @$_ 2179 my $neigh = find $path, $origin
1501 or next; 2180 or next;
1502 $neigh->load; 2181 $neigh->load;
1503 } 2182 }
1504} 2183}
1505 2184
1510} 2189}
1511 2190
1512sub do_load_sync { 2191sub do_load_sync {
1513 my ($map) = @_; 2192 my ($map) = @_;
1514 2193
2194 cf::LOG cf::llevDebug | cf::logBacktrace, "do_load_sync"
2195 if $Coro::current == $Coro::main;
2196
1515 cf::sync_job { $map->load }; 2197 cf::sync_job { $map->load };
1516} 2198}
1517 2199
1518our %MAP_PREFETCH; 2200our %MAP_PREFETCH;
1519our $MAP_PREFETCHER = undef; 2201our $MAP_PREFETCHER = undef;
1520 2202
1521sub find_async { 2203sub find_async {
1522 my ($path, $origin) = @_; 2204 my ($path, $origin, $load) = @_;
1523 2205
1524 $path = normalise $path, $origin && $origin->{path}; 2206 $path = normalise $path, $origin && $origin->{path};
1525 2207
1526 if (my $map = $cf::MAP{$path}) { 2208 if (my $map = $cf::MAP{$path}) {
1527 return $map if $map->in_memory == cf::MAP_IN_MEMORY; 2209 return $map if !$load || $map->in_memory == cf::MAP_ACTIVE;
1528 } 2210 }
1529 2211
1530 undef $MAP_PREFETCH{$path}; 2212 $MAP_PREFETCH{$path} |= $load;
2213
1531 $MAP_PREFETCHER ||= cf::async { 2214 $MAP_PREFETCHER ||= cf::async {
2215 $Coro::current->{desc} = "map prefetcher";
2216
1532 while (%MAP_PREFETCH) { 2217 while (%MAP_PREFETCH) {
1533 for my $path (keys %MAP_PREFETCH) { 2218 while (my ($k, $v) = each %MAP_PREFETCH) {
1534 my $map = find $path 2219 if (my $map = find $k) {
1535 or next;
1536 $map->load; 2220 $map->load if $v;
2221 }
1537 2222
1538 delete $MAP_PREFETCH{$path}; 2223 delete $MAP_PREFETCH{$k};
1539 } 2224 }
1540 } 2225 }
1541 undef $MAP_PREFETCHER; 2226 undef $MAP_PREFETCHER;
1542 }; 2227 };
1543 $MAP_PREFETCHER->prio (6); 2228 $MAP_PREFETCHER->prio (6);
1544 2229
1545 () 2230 ()
1546} 2231}
1547 2232
2233# common code, used by both ->save and ->swapout
1548sub save { 2234sub _save {
1549 my ($self) = @_; 2235 my ($self) = @_;
1550
1551 my $lock = cf::lock_acquire "map_data:" . $self->path;
1552 2236
1553 $self->{last_save} = $cf::RUNTIME; 2237 $self->{last_save} = $cf::RUNTIME;
1554 2238
1555 return unless $self->dirty; 2239 return unless $self->dirty;
1556 2240
1562 return if $self->{deny_save}; 2246 return if $self->{deny_save};
1563 2247
1564 local $self->{last_access} = $self->last_access;#d# 2248 local $self->{last_access} = $self->last_access;#d#
1565 2249
1566 cf::async { 2250 cf::async {
2251 $Coro::current->{desc} = "map player save";
1567 $_->contr->save for $self->players; 2252 $_->contr->save for $self->players;
1568 }; 2253 };
2254
2255 cf::get_slot 0.02;
1569 2256
1570 if ($uniq) { 2257 if ($uniq) {
1571 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS); 2258 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS);
1572 $self->_save_objects ($uniq, cf::IO_UNIQUES); 2259 $self->_save_objects ($uniq, cf::IO_UNIQUES);
1573 } else { 2260 } else {
1574 $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);
1575 } 2262 }
1576} 2263}
1577 2264
2265sub save {
2266 my ($self) = @_;
2267
2268 my $lock = cf::lock_acquire "map_data:$self->{path}";
2269
2270 $self->_save;
2271}
2272
1578sub swap_out { 2273sub swap_out {
1579 my ($self) = @_; 2274 my ($self) = @_;
1580 2275
1581 # save first because save cedes
1582 $self->save;
1583
1584 my $lock = cf::lock_acquire "map_data:" . $self->path; 2276 my $lock = cf::lock_acquire "map_data:$self->{path}";
1585 2277
2278 return if $self->in_memory != cf::MAP_ACTIVE;
2279 return if $self->{deny_save};
1586 return if $self->players; 2280 return if $self->players;
1587 return if $self->in_memory != cf::MAP_IN_MEMORY;
1588 return if $self->{deny_save};
1589 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
1590 $self->clear; 2291 $self->clear;
1591 $self->in_memory (cf::MAP_SWAPPED);
1592} 2292}
1593 2293
1594sub reset_at { 2294sub reset_at {
1595 my ($self) = @_; 2295 my ($self) = @_;
1596 2296
1597 # TODO: safety, remove and allow resettable per-player maps 2297 # TODO: safety, remove and allow resettable per-player maps
1598 return 1e99 if $self->isa ("ext::map_per_player");#d#
1599 return 1e99 if $self->{deny_reset}; 2298 return 1e99 if $self->{deny_reset};
1600 2299
1601 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access; 2300 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
1602 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;
1603 2302
1614 my ($self) = @_; 2313 my ($self) = @_;
1615 2314
1616 my $lock = cf::lock_acquire "map_data:$self->{path}"; 2315 my $lock = cf::lock_acquire "map_data:$self->{path}";
1617 2316
1618 return if $self->players; 2317 return if $self->players;
1619 return if $self->isa ("ext::map_per_player");#d#
1620 2318
1621 warn "resetting map ", $self->path;#d# 2319 warn "resetting map ", $self->path, "\n";
1622 2320
1623 $self->in_memory (cf::MAP_SWAPPED); 2321 $self->in_memory (cf::MAP_SWAPPED);
1624 2322
1625 # need to save uniques path 2323 # need to save uniques path
1626 unless ($self->{deny_save}) { 2324 unless ($self->{deny_save}) {
1630 if $uniq; 2328 if $uniq;
1631 } 2329 }
1632 2330
1633 delete $cf::MAP{$self->path}; 2331 delete $cf::MAP{$self->path};
1634 2332
2333 $self->deactivate;
2334 $_->clear_links_to ($self) for values %cf::MAP;
1635 $self->clear; 2335 $self->clear;
1636
1637 $_->clear_links_to ($self) for values %cf::MAP;
1638 2336
1639 $self->unlink_save; 2337 $self->unlink_save;
1640 $self->destroy; 2338 $self->destroy;
1641} 2339}
1642 2340
1643my $nuke_counter = "aaaa"; 2341my $nuke_counter = "aaaa";
1644 2342
1645sub nuke { 2343sub nuke {
1646 my ($self) = @_; 2344 my ($self) = @_;
1647 2345
2346 {
2347 my $lock = cf::lock_acquire "map_data:$self->{path}";
2348
1648 delete $cf::MAP{$self->path}; 2349 delete $cf::MAP{$self->path};
1649 2350
1650 $self->unlink_save; 2351 $self->unlink_save;
1651 2352
1652 bless $self, "cf::map"; 2353 bless $self, "cf::map::wrap";
1653 delete $self->{deny_reset}; 2354 delete $self->{deny_reset};
1654 $self->{deny_save} = 1; 2355 $self->{deny_save} = 1;
1655 $self->reset_timeout (1); 2356 $self->reset_timeout (1);
1656 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++)); 2357 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));
1657 2358
1658 $cf::MAP{$self->path} = $self; 2359 $cf::MAP{$self->path} = $self;
2360 }
1659 2361
1660 $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 ]
1661} 2399}
1662 2400
1663=item cf::map::unique_maps 2401=item cf::map::unique_maps
1664 2402
1665Returns an arrayref of paths of all shared maps that have 2403Returns an arrayref of paths of all shared maps that have
1666instantiated unique items. May block. 2404instantiated unique items. May block.
1667 2405
1668=cut 2406=cut
1669 2407
1670sub unique_maps() { 2408sub unique_maps() {
1671 my $files = aio_readdir cf::localdir . "/" . cf::uniquedir 2409 [
1672 or return; 2410 map {
1673
1674 my @paths;
1675
1676 for (@$files) {
1677 utf8::decode $_; 2411 utf8::decode $_;
1678 next if /\.pst$/; 2412 s/\.map$//; # TODO future compatibility hack
1679 next unless /^$PATH_SEP/o; 2413 /\.pst$/ || !/^$PATH_SEP/o # TODO unique maps apparebntly lack the .map suffix :/
1680 2414 ? ()
1681 push @paths, cf::map::normalise $_; 2415 : normalise $_
2416 } @{ aio_readdir $UNIQUEDIR or [] }
1682 } 2417 ]
1683
1684 \@paths
1685} 2418}
1686 2419
1687package 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}
1688 2451
1689=back 2452=back
1690 2453
1691=head3 cf::object 2454=head3 cf::object
1692 2455
1696 2459
1697=over 4 2460=over 4
1698 2461
1699=item $ob->inv_recursive 2462=item $ob->inv_recursive
1700 2463
1701Returns 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.
1702 2466
1703=cut 2467=cut
1704 2468
1705sub inv_recursive_; 2469sub inv_recursive_;
1706sub inv_recursive_ { 2470sub inv_recursive_ {
1709 2473
1710sub inv_recursive { 2474sub inv_recursive {
1711 inv_recursive_ inv $_[0] 2475 inv_recursive_ inv $_[0]
1712} 2476}
1713 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
1714package cf; 2506package cf;
1715 2507
1716=back 2508=back
1717 2509
1718=head3 cf::object::player 2510=head3 cf::object::player
1724Sends 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>
1725can 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
1726dialogue with the given NPC character. 2518dialogue with the given NPC character.
1727 2519
1728=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};
1729 2535
1730# rough implementation of a future "reply" method that works 2536# rough implementation of a future "reply" method that works
1731# with dialog boxes. 2537# with dialog boxes.
1732#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
1733sub cf::object::player::reply($$$;$) { 2539sub cf::object::player::reply($$$;$) {
1735 2541
1736 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4; 2542 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4;
1737 2543
1738 if ($self->{record_replies}) { 2544 if ($self->{record_replies}) {
1739 push @{ $self->{record_replies} }, [$npc, $msg, $flags]; 2545 push @{ $self->{record_replies} }, [$npc, $msg, $flags];
2546
1740 } 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 {
1741 $msg = $npc->name . " says: $msg" if $npc; 2555 $msg = $npc->name . " says: $msg" if $npc;
1742 $self->message ($msg, $flags); 2556 $self->send_msg ($SAY_CHANNEL => $msg, $flags);
2557 }
1743 } 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 (@_);
1744} 2569}
1745 2570
1746=item $player_object->may ("access") 2571=item $player_object->may ("access")
1747 2572
1748Returns wether the given player is authorized to access resource "access" 2573Returns wether the given player is authorized to access resource "access"
1761 2586
1762=item $player_object->enter_link 2587=item $player_object->enter_link
1763 2588
1764Freezes 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}>).
1765 2590
1766The 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.
1767I<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.
1768 2595
1769Will never block. 2596Will never block.
1770 2597
1771=item $player_object->leave_link ($map, $x, $y) 2598=item $player_object->leave_link ($map, $x, $y)
1772 2599
1792sub cf::object::player::enter_link { 2619sub cf::object::player::enter_link {
1793 my ($self) = @_; 2620 my ($self) = @_;
1794 2621
1795 $self->deactivate_recursive; 2622 $self->deactivate_recursive;
1796 2623
2624 ++$self->{_link_recursion};
2625
1797 return if UNIVERSAL::isa $self->map, "ext::map_link"; 2626 return if UNIVERSAL::isa $self->map, "ext::map_link";
1798 2627
1799 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y] 2628 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y]
1800 if $self->map; 2629 if $self->map && $self->map->{path} ne "{link}";
1801 2630
1802 $self->enter_map ($LINK_MAP || link_map, 10, 10); 2631 $self->enter_map ($LINK_MAP || link_map, 3, 3);
1803} 2632}
1804 2633
1805sub cf::object::player::leave_link { 2634sub cf::object::player::leave_link {
1806 my ($self, $map, $x, $y) = @_; 2635 my ($self, $map, $x, $y) = @_;
2636
2637 return unless $self->contr->active;
1807 2638
1808 my $link_pos = delete $self->{_link_pos}; 2639 my $link_pos = delete $self->{_link_pos};
1809 2640
1810 unless ($map) { 2641 unless ($map) {
1811 # restore original map position 2642 # restore original map position
1822 ($x, $y) = (-1, -1) 2653 ($x, $y) = (-1, -1)
1823 unless (defined $x) && (defined $y); 2654 unless (defined $x) && (defined $y);
1824 2655
1825 # use -1 or undef as default coordinates, not 0, 0 2656 # use -1 or undef as default coordinates, not 0, 0
1826 ($x, $y) = ($map->enter_x, $map->enter_y) 2657 ($x, $y) = ($map->enter_x, $map->enter_y)
1827 if $x <=0 && $y <= 0; 2658 if $x <= 0 && $y <= 0;
1828 2659
1829 $map->load; 2660 $map->load;
1830 $map->load_diag; 2661 $map->load_neighbours;
1831 2662
1832 return unless $self->contr->active; 2663 return unless $self->contr->active;
1833 $self->activate_recursive;
1834 2664
1835 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext 2665 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
1836 $self->enter_map ($map, $x, $y); 2666 if ($self->enter_map ($map, $x, $y)) {
1837} 2667 # entering was successful
1838 2668 delete $self->{_link_recursion};
1839cf::player->attach ( 2669 # only activate afterwards, to support waiting in hooks
1840 on_logout => sub { 2670 $self->activate_recursive;
1841 my ($pl) = @_;
1842
1843 # abort map switching before logout
1844 if ($pl->ob->{_link_pos}) {
1845 cf::sync_job {
1846 $pl->ob->leave_link
1847 };
1848 }
1849 }, 2671 }
1850 on_login => sub {
1851 my ($pl) = @_;
1852 2672
1853 # try to abort aborted map switching on player login :) 2673}
1854 # should happen only on crashes
1855 if ($pl->ob->{_link_pos}) {
1856 $pl->ob->enter_link;
1857 (async {
1858 $pl->ob->reply (undef,
1859 "There was an internal problem at your last logout, "
1860 . "the server will try to bring you to your intended destination in a second.",
1861 cf::NDI_RED);
1862 # we need this sleep as the login has a concurrent enter_exit running
1863 # and this sleep increases chances of the player not ending up in scorn
1864 Coro::Timer::sleep 1;
1865 $pl->ob->leave_link;
1866 })->prio (2);
1867 }
1868 },
1869);
1870 2674
1871=item $player_object->goto ($path, $x, $y) 2675=item $player_object->goto ($path, $x, $y[, $check->($map, $x, $y, $player)[, $done->($player)]])
1872 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
1873=cut 2686=cut
2687
2688our $GOTOGEN;
1874 2689
1875sub cf::object::player::goto { 2690sub cf::object::player::goto {
1876 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;
1877 2701
1878 $self->enter_link; 2702 $self->enter_link;
1879 2703
1880 (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
1881 my $map = eval { 2726 my $map = eval {
1882 my $map = cf::map::find $path; 2727 my $map = defined $path ? cf::map::find $path : undef;
2728
2729 if ($map) {
1883 $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
1884 $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 $@;
1885 } or 2742 }
1886 $self->message ("The exit to '$path' is closed", cf::NDI_UNIQUE | cf::NDI_RED);
1887 2743
2744 if ($gen == $self->{_goto_generation}) {
2745 delete $self->{_goto_generation};
1888 $self->leave_link ($map, $x, $y); 2746 $self->leave_link ($map, $x, $y);
2747 }
2748
2749 $done->($self) if $done;
1889 })->prio (1); 2750 })->prio (1);
1890} 2751}
1891 2752
1892=item $player_object->enter_exit ($exit_object) 2753=item $player_object->enter_exit ($exit_object)
1893 2754
1913} 2774}
1914 2775
1915sub prepare_random_map { 2776sub prepare_random_map {
1916 my ($exit) = @_; 2777 my ($exit) = @_;
1917 2778
1918 my $guard = cf::lock_acquire "exit_prepare:$exit";
1919
1920 # all this does is basically replace the /! path by 2779 # all this does is basically replace the /! path by
1921 # a new random map path (?random/...) with a seed 2780 # a new random map path (?random/...) with a seed
1922 # that depends on the exit object 2781 # that depends on the exit object
1923 2782
1924 my $rmp = parse_random_map_params $exit->msg; 2783 my $rmp = parse_random_map_params $exit->msg;
1926 if ($exit->map) { 2785 if ($exit->map) {
1927 $rmp->{region} = $exit->region->name; 2786 $rmp->{region} = $exit->region->name;
1928 $rmp->{origin_map} = $exit->map->path; 2787 $rmp->{origin_map} = $exit->map->path;
1929 $rmp->{origin_x} = $exit->x; 2788 $rmp->{origin_x} = $exit->x;
1930 $rmp->{origin_y} = $exit->y; 2789 $rmp->{origin_y} = $exit->y;
2790
2791 $exit->map->touch;
1931 } 2792 }
1932 2793
1933 $rmp->{random_seed} ||= $exit->random_seed; 2794 $rmp->{random_seed} ||= $exit->random_seed;
1934 2795
1935 my $data = cf::to_json $rmp; 2796 my $data = JSON::XS->new->utf8->pretty->canonical->encode ($rmp);
1936 my $md5 = Digest::MD5::md5_hex $data; 2797 my $md5 = Digest::MD5::md5_hex $data;
1937 my $meta = "$cf::RANDOM_MAPS/$md5.meta"; 2798 my $meta = "$RANDOMDIR/$md5.meta";
1938 2799
1939 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) { 2800 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) {
1940 aio_write $fh, 0, (length $data), $data, 0; 2801 aio_write $fh, 0, (length $data), $data, 0;
1941 undef $fh; 2802 undef $fh;
1942 aio_rename "$meta~", $meta; 2803 aio_rename "$meta~", $meta;
1943 2804
2805 my $slaying = "?random/$md5";
2806
2807 if ($exit->valid) {
1944 $exit->slaying ("?random/$md5"); 2808 $exit->slaying ("?random/$md5");
1945 $exit->msg (undef); 2809 $exit->msg (undef);
2810 }
1946 } 2811 }
1947} 2812}
1948 2813
1949sub cf::object::player::enter_exit { 2814sub cf::object::player::enter_exit {
1950 my ($self, $exit) = @_; 2815 my ($self, $exit) = @_;
1951 2816
1952 return unless $self->type == cf::PLAYER; 2817 return unless $self->type == cf::PLAYER;
1953 2818
1954 if ($exit->slaying eq "/!") {
1955 #TODO: this should de-fi-ni-te-ly not be a sync-job
1956 cf::sync_job { prepare_random_map $exit };
1957 }
1958
1959 my $slaying = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path;
1960 my $hp = $exit->stats->hp;
1961 my $sp = $exit->stats->sp;
1962
1963 $self->enter_link; 2819 $self->enter_link;
1964 2820
1965 (async { 2821 (async {
1966 $self->deactivate_recursive; # just to be sure 2822 $Coro::current->{desc} = "enter_exit";
2823
1967 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
1968 $self->goto ($slaying, $hp, $sp); 2839 $self->goto ($map, $x, $y);
1969 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
1970 1; 2845 1
1971 }) { 2846 }) {
1972 $self->message ("Something went wrong deep within the crossfire server. " 2847 $self->message ("Something went wrong deep within the deliantra server. "
1973 . "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. "
1974 . "Please report this to the dungeon master!", 2849 . "Please report this to the dungeon master!",
1975 cf::NDI_UNIQUE | cf::NDI_RED); 2850 cf::NDI_UNIQUE | cf::NDI_RED);
1976 2851
1977 warn "ERROR in enter_exit: $@"; 2852 warn "ERROR in enter_exit: $@";
1978 $self->leave_link; 2853 $self->leave_link;
1979 } 2854 }
1980 })->prio (1); 2855 })->prio (1);
1993 2868
1994sub cf::client::send_drawinfo { 2869sub cf::client::send_drawinfo {
1995 my ($self, $text, $flags) = @_; 2870 my ($self, $text, $flags) = @_;
1996 2871
1997 utf8::encode $text; 2872 utf8::encode $text;
1998 $self->send_packet (sprintf "drawinfo %d %s", $flags, $text); 2873 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);
1999} 2874}
2000 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}
2001 3097
2002=item $success = $client->query ($flags, "text", \&cb) 3098=item $success = $client->query ($flags, "text", \&cb)
2003 3099
2004Queues a query to the client, calling the given callback with 3100Queues a query to the client, calling the given callback with
2005the 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>,
2006C<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>.
2007 3103
2008Queries 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
2009reliable at some point in the future. 3105become reliable at some point in the future.
2010 3106
2011=cut 3107=cut
2012 3108
2013sub cf::client::query { 3109sub cf::client::query {
2014 my ($self, $flags, $text, $cb) = @_; 3110 my ($self, $flags, $text, $cb) = @_;
2022 utf8::encode $text; 3118 utf8::encode $text;
2023 push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb]; 3119 push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb];
2024 3120
2025 $self->send_packet ($self->{query_queue}[0][0]) 3121 $self->send_packet ($self->{query_queue}[0][0])
2026 if @{ $self->{query_queue} } == 1; 3122 if @{ $self->{query_queue} } == 1;
3123
3124 1
2027} 3125}
2028 3126
2029cf::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 },
2030 on_reply => sub { 3133 on_reply => sub {
2031 my ($ns, $msg) = @_; 3134 my ($ns, $msg) = @_;
2032 3135
2033 # this weird shuffling is so that direct followup queries 3136 # this weird shuffling is so that direct followup queries
2034 # get handled first 3137 # get handled first
2046 } else { 3149 } else {
2047 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM; 3150 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM;
2048 } 3151 }
2049 } 3152 }
2050 }, 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 },
2051); 3180);
2052 3181
2053=item $client->async (\&cb) 3182=item $client->async (\&cb)
2054 3183
2055Create a new coroutine, running the specified callback. The coroutine will 3184Create a new coroutine, running the specified callback. The coroutine will
2071 3200
2072 $coro 3201 $coro
2073} 3202}
2074 3203
2075cf::client->attach ( 3204cf::client->attach (
2076 on_destroy => sub { 3205 on_client_destroy => sub {
2077 my ($ns) = @_; 3206 my ($ns) = @_;
2078 3207
2079 $_->cancel for values %{ (delete $ns->{_coro}) || {} }; 3208 $_->cancel for values %{ (delete $ns->{_coro}) || {} };
2080 }, 3209 },
2081); 3210);
2096our $safe = new Safe "safe"; 3225our $safe = new Safe "safe";
2097our $safe_hole = new Safe::Hole; 3226our $safe_hole = new Safe::Hole;
2098 3227
2099$SIG{FPE} = 'IGNORE'; 3228$SIG{FPE} = 'IGNORE';
2100 3229
2101$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));
2102 3235
2103# here we export the classes and methods available to script code 3236# here we export the classes and methods available to script code
2104 3237
2105=pod 3238=pod
2106 3239
2107The following fucntions and emthods are available within a safe environment: 3240The following functions and methods are available within a safe environment:
2108 3241
2109 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
2110 cf::object::player player 3247 cf::object::player
2111 cf::player peaceful 3248 player
2112 cf::map trigger 3249
3250 cf::player
3251 peaceful
3252
3253 cf::map
3254 trigger
2113 3255
2114=cut 3256=cut
2115 3257
2116for ( 3258for (
2117 ["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)],
2118 ["cf::object::player" => qw(player)], 3262 ["cf::object::player" => qw(player)],
2119 ["cf::player" => qw(peaceful)], 3263 ["cf::player" => qw(peaceful send_msg)],
2120 ["cf::map" => qw(trigger)], 3264 ["cf::map" => qw(trigger)],
2121) { 3265) {
2122 no strict 'refs'; 3266 no strict 'refs';
2123 my ($pkg, @funs) = @$_; 3267 my ($pkg, @funs) = @$_;
2124 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"}) 3268 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})
2142 3286
2143 my $qcode = $code; 3287 my $qcode = $code;
2144 $qcode =~ s/"/‟/g; # not allowed in #line filenames 3288 $qcode =~ s/"/‟/g; # not allowed in #line filenames
2145 $qcode =~ s/\n/\\n/g; 3289 $qcode =~ s/\n/\\n/g;
2146 3290
3291 %vars = (_dummy => 0) unless %vars;
3292
3293 my @res;
2147 local $_; 3294 local $_;
2148 local @safe::cf::_safe_eval_args = values %vars;
2149 3295
2150 my $eval = 3296 my $eval =
2151 "do {\n" 3297 "do {\n"
2152 . "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n" 3298 . "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n"
2153 . "#line 0 \"{$qcode}\"\n" 3299 . "#line 0 \"{$qcode}\"\n"
2154 . $code 3300 . $code
2155 . "\n}" 3301 . "\n}"
2156 ; 3302 ;
2157 3303
3304 if ($CFG{safe_eval}) {
2158 sub_generation_inc; 3305 sub_generation_inc;
3306 local @safe::cf::_safe_eval_args = values %vars;
2159 my @res = wantarray ? $safe->reval ($eval) : scalar $safe->reval ($eval); 3307 @res = wantarray ? $safe->reval ($eval) : scalar $safe->reval ($eval);
2160 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 }
2161 3313
2162 if ($@) { 3314 if ($@) {
2163 warn "$@"; 3315 warn "$@";
2164 warn "while executing safe code '$code'\n"; 3316 warn "while executing safe code '$code'\n";
2165 warn "with arguments " . (join " ", %vars) . "\n"; 3317 warn "with arguments " . (join " ", %vars) . "\n";
2184=cut 3336=cut
2185 3337
2186sub register_script_function { 3338sub register_script_function {
2187 my ($fun, $cb) = @_; 3339 my ($fun, $cb) = @_;
2188 3340
2189 no strict 'refs'; 3341 $fun = "safe::$fun" if $CFG{safe_eval};
2190 *{"safe::$fun"} = $safe_hole->wrap ($cb); 3342 *$fun = $safe_hole->wrap ($cb);
2191} 3343}
2192 3344
2193=back 3345=back
2194 3346
2195=cut 3347=cut
2196
2197#############################################################################
2198
2199=head2 EXTENSION DATABASE SUPPORT
2200
2201Crossfire maintains a very simple database for extension use. It can
2202currently store anything that can be serialised using Storable, which
2203excludes objects.
2204
2205The parameter C<$family> should best start with the name of the extension
2206using it, it should be unique.
2207
2208=over 4
2209
2210=item $value = cf::db_get $family => $key
2211
2212Returns a single value from the database.
2213
2214=item cf::db_put $family => $key => $value
2215
2216Stores the given C<$value> in the family.
2217
2218=cut
2219
2220our $DB;
2221
2222sub db_init {
2223 unless ($DB) {
2224 $DB = BDB::db_create $DB_ENV;
2225
2226 cf::sync_job {
2227 eval {
2228 $DB->set_flags (BDB::CHKSUM);
2229
2230 BDB::db_open $DB, undef, "db", undef, BDB::BTREE,
2231 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
2232 cf::cleanup "db_open(db): $!" if $!;
2233 };
2234 cf::cleanup "db_open(db): $@" if $@;
2235 };
2236
2237 my $path = cf::localdir . "/database.pst";
2238 if (stat $path) {
2239 cf::sync_job {
2240 my $pst = Storable::retrieve $path;
2241
2242 cf::db_put (board => data => $pst->{board});
2243 cf::db_put (guildrules => data => $pst->{guildrules});
2244 cf::db_put (rent => balance => $pst->{rent}{balance});
2245 BDB::db_env_txn_checkpoint $DB_ENV;
2246
2247 unlink $path;
2248 };
2249 }
2250 }
2251}
2252
2253sub db_get($$) {
2254 my $key = "$_[0]/$_[1]";
2255
2256 cf::sync_job {
2257 BDB::db_get $DB, undef, $key, my $data;
2258
2259 $! ? ()
2260 : Compress::LZF::sthaw $data
2261 }
2262}
2263
2264sub db_put($$$) {
2265 BDB::dbreq_pri 4;
2266 BDB::db_put $DB, undef, "$_[0]/$_[1]", Compress::LZF::sfreeze_cr $_[2], 0, sub { };
2267}
2268 3348
2269############################################################################# 3349#############################################################################
2270# the server's init and main functions 3350# the server's init and main functions
2271 3351
2272sub load_faces { 3352sub load_facedata($) {
2273 my $path = sprintf "%s/faces", cf::datadir; 3353 my ($path) = @_;
2274 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;
3360
2275 warn "loading faces from $path\n"; 3361 warn "loading facedata from $path\n";
2276 3362
2277 my $faces; 3363 my $facedata;
2278 0 < aio_load $path, $faces 3364 0 < aio_load $path, $facedata
2279 or die "$path: $!"; 3365 or die "$path: $!";
2280 3366
2281 Coro::cede;
2282 $faces = Storable::thaw $faces; 3367 $facedata = Coro::Storable::thaw $facedata;
2283 Coro::cede;
2284 3368
3369 $facedata->{version} == 2
3370 or cf::cleanup "$path: version mismatch, cannot proceed.";
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
2285 while (my ($face, $info) = each %$faces) { 3384 while (my ($face, $info) = each %$faces) {
2286 my $idx = (cf::face::find $face) || cf::face::alloc $face; 3385 my $idx = (cf::face::find $face) || cf::face::alloc $face;
2287 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};
2288 cf::face::set_data $idx, 0, $info->{data32}, $info->{chksum32}; 3389 cf::face::set_data $idx, 0, $info->{data32}, $info->{hash32};
2289 Coro::cede; 3390 cf::face::set_data $idx, 1, $info->{data64}, $info->{hash64};
3391
3392 cf::cede_to_tick;
3393 }
3394
3395 while (my ($face, $info) = each %$faces) {
3396 next unless $info->{smooth};
3397
3398 my $idx = cf::face::find $face
3399 or next;
3400
3401 if (my $smooth = cf::face::find $info->{smooth}) {
3402 cf::face::set_smooth $idx, $smooth;
3403 cf::face::set_smoothlevel $idx, $info->{smoothlevel};
3404 } else {
3405 warn "smooth face '$info->{smooth}' not found for face '$face'";
3406 }
3407
3408 cf::cede_to_tick;
3409 }
3410 }
3411
2290 } 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);
2291 3441
2292 1 3442 1
2293} 3443}
2294 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
2295sub reload_resources { 3512sub reload_resources {
2296 load_resource_file sprintf "%s/%s/regions", cf::datadir, cf::mapdir 3513 warn "reloading resource files...\n";
2297 or die "unable to load regions file\n";#d# 3514
2298 load_faces 3515 reload_facedata;
2299 or die "unable to load faces\n";#d# 3516 reload_archetypes;
2300}
2301
2302sub init {
2303 reload_resources; 3517 reload_regions;
2304} 3518 reload_treasures;
2305 3519
2306sub cfg_load { 3520 warn "finished reloading resource files\n";
3521}
3522
3523sub reload_config {
3524 warn "reloading config file...\n";
3525
2307 open my $fh, "<:utf8", cf::confdir . "/config" 3526 open my $fh, "<:utf8", "$CONFDIR/config"
2308 or return; 3527 or return;
2309 3528
2310 local $/; 3529 local $/;
2311 *CFG = YAML::Syck::Load <$fh>; 3530 *CFG = YAML::XS::Load scalar <$fh>;
2312 3531
2313 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37]; 3532 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_104_115", 49, 38];
2314 3533
2315 $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};
2316 $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};
2317 3536
2318 if (exists $CFG{mlockall}) { 3537 if (exists $CFG{mlockall}) {
2320 $CFG{mlockall} ? eval "mlockall()" : eval "munlockall()" 3539 $CFG{mlockall} ? eval "mlockall()" : eval "munlockall()"
2321 and die "WARNING: m(un)lockall failed: $!\n"; 3540 and die "WARNING: m(un)lockall failed: $!\n";
2322 }; 3541 };
2323 warn $@ if $@; 3542 warn $@ if $@;
2324 } 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;
2325} 3574}
2326 3575
2327sub 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
2328 # we must not ever block the main coroutine 3586 # we must not ever block the main coroutine
2329 local $Coro::idle = sub { 3587 local $Coro::idle = sub {
2330 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#
2331 (async { 3589 (async {
2332 Event::one_event; 3590 $Coro::current->{desc} = "IDLE BUG HANDLER";
3591 EV::loop EV::LOOP_ONESHOT;
2333 })->prio (Coro::PRIO_MAX); 3592 })->prio (Coro::PRIO_MAX);
2334 }; 3593 };
2335 3594
2336 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;
2337 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
2338 load_extensions; 3618 load_extensions;
2339 3619
2340 $TICK_WATCHER->start; 3620 utime time, time, $RUNTIMEFILE;
2341 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;
2342} 3633}
2343 3634
2344############################################################################# 3635#############################################################################
2345# initialisation and cleanup 3636# initialisation and cleanup
2346 3637
2347# install some emergency cleanup handlers 3638# install some emergency cleanup handlers
2348BEGIN { 3639BEGIN {
3640 our %SIGWATCHER = ();
2349 for my $signal (qw(INT HUP TERM)) { 3641 for my $signal (qw(INT HUP TERM)) {
2350 Event->signal ( 3642 $SIGWATCHER{$signal} = AE::signal $signal, sub {
2351 reentrant => 0,
2352 data => WF_AUTOCANCEL,
2353 signal => $signal,
2354 prio => 0,
2355 cb => sub {
2356 cf::cleanup "SIG$signal"; 3643 cf::cleanup "SIG$signal";
2357 },
2358 ); 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
2359 } 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 };
2360} 3734}
2361 3735
2362sub emergency_save() { 3736sub emergency_save() {
2363 my $freeze_guard = cf::freeze_mainloop; 3737 my $freeze_guard = cf::freeze_mainloop;
2364 3738
2365 warn "enter emergency perl save\n"; 3739 warn "emergency_perl_save: enter\n";
2366 3740
2367 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
2368 # use a peculiar iteration method to avoid tripping on perl 3747 # use a peculiar iteration method to avoid tripping on perl
2369 # refcount bugs in for. also avoids problems with players 3748 # refcount bugs in for. also avoids problems with players
2370 # and maps saved/destroyed asynchronously. 3749 # and maps saved/destroyed asynchronously.
2371 warn "begin emergency player save\n"; 3750 warn "emergency_perl_save: begin player save\n";
2372 for my $login (keys %cf::PLAYER) { 3751 for my $login (keys %cf::PLAYER) {
2373 my $pl = $cf::PLAYER{$login} or next; 3752 my $pl = $cf::PLAYER{$login} or next;
2374 $pl->valid or next; 3753 $pl->valid or next;
3754 delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt
2375 $pl->save; 3755 $pl->save;
2376 } 3756 }
2377 warn "end emergency player save\n"; 3757 warn "emergency_perl_save: end player save\n";
2378 3758
2379 warn "begin emergency map save\n"; 3759 warn "emergency_perl_save: begin map save\n";
2380 for my $path (keys %cf::MAP) { 3760 for my $path (keys %cf::MAP) {
2381 my $map = $cf::MAP{$path} or next; 3761 my $map = $cf::MAP{$path} or next;
2382 $map->valid or next; 3762 $map->valid or next;
2383 $map->save; 3763 $map->save;
2384 } 3764 }
2385 warn "end emergency map save\n"; 3765 warn "emergency_perl_save: end map save\n";
2386 3766
2387 warn "begin emergency database checkpoint\n"; 3767 warn "emergency_perl_save: begin database checkpoint\n";
2388 BDB::db_env_txn_checkpoint $DB_ENV; 3768 BDB::db_env_txn_checkpoint $DB_ENV;
2389 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";
2390 }; 3774 };
2391 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
2392 warn "leave emergency perl save\n"; 3781 warn "emergency_perl_save: leave\n";
2393} 3782}
2394 3783
2395sub post_cleanup { 3784sub post_cleanup {
2396 my ($make_core) = @_; 3785 my ($make_core) = @_;
2397 3786
2398 warn Carp::longmess "post_cleanup backtrace" 3787 warn Carp::longmess "post_cleanup backtrace"
2399 if $make_core; 3788 if $make_core;
2400}
2401 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
2402sub reload() { 3819sub do_reload_perl() {
2403 # can/must only be called in main 3820 # can/must only be called in main
2404 if ($Coro::current != $Coro::main) { 3821 if (in_main) {
2405 warn "can only reload from main coroutine"; 3822 warn "can only reload from main coroutine";
2406 return; 3823 return;
2407 } 3824 }
2408 3825
3826 return if $RELOAD++;
3827
3828 my $t1 = AE::time;
3829
3830 while ($RELOAD) {
2409 warn "reloading..."; 3831 warn "reloading...";
2410 3832
2411 warn "entering sync_job"; 3833 warn "entering sync_job";
2412 3834
2413 cf::sync_job { 3835 cf::sync_job {
2414 cf::write_runtime; # external watchdog should not bark 3836 cf::write_runtime_sync; # external watchdog should not bark
2415 cf::emergency_save; 3837 cf::emergency_save;
2416 cf::write_runtime; # external watchdog should not bark 3838 cf::write_runtime_sync; # external watchdog should not bark
2417 3839
2418 warn "syncing database to disk"; 3840 warn "syncing database to disk";
2419 BDB::db_env_txn_checkpoint $DB_ENV; 3841 BDB::db_env_txn_checkpoint $DB_ENV;
2420 3842
2421 # 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
2422 3844
2423 warn "cancelling all WF_AUTOCANCEL watchers";
2424 for (Event::all_watchers) {
2425 $_->cancel if $_->data & WF_AUTOCANCEL;
2426 }
2427
2428 warn "flushing outstanding aio requests"; 3845 warn "flushing outstanding aio requests";
2429 for (;;) {
2430 BDB::flush;
2431 IO::AIO::flush;
2432 Coro::cede;
2433 last unless IO::AIO::nreqs || BDB::nreqs; 3846 while (IO::AIO::nreqs || BDB::nreqs) {
2434 warn "iterate..."; 3847 Coro::EV::timer_once 0.01; # let the sync_job do it's thing
2435 }
2436
2437 ++$RELOAD;
2438
2439 warn "cancelling all extension coros";
2440 $_->cancel for values %EXT_CORO;
2441 %EXT_CORO = ();
2442
2443 warn "removing commands";
2444 %COMMAND = ();
2445
2446 warn "removing ext commands";
2447 %EXTCMD = ();
2448
2449 warn "unloading/nuking all extensions";
2450 for my $pkg (@EXTS) {
2451 warn "... unloading $pkg";
2452
2453 if (my $cb = $pkg->can ("unload")) {
2454 eval {
2455 $cb->($pkg);
2456 1
2457 } or warn "$pkg unloaded, but with errors: $@";
2458 } 3848 }
2459 3849
2460 warn "... nuking $pkg"; 3850 warn "cancelling all extension coros";
2461 Symbol::delete_package $pkg; 3851 $_->cancel for values %EXT_CORO;
2462 } 3852 %EXT_CORO = ();
2463 3853
2464 warn "unloading all perl modules loaded from $LIBDIR"; 3854 warn "removing commands";
2465 while (my ($k, $v) = each %INC) { 3855 %COMMAND = ();
2466 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
2467 3856
3857 warn "removing ext/exti commands";
3858 %EXTCMD = ();
3859 %EXTICMD = ();
3860
3861 warn "unloading/nuking all extensions";
3862 for my $pkg (@EXTS) {
2468 warn "... unloading $k"; 3863 warn "... unloading $pkg";
2469 delete $INC{$k};
2470 3864
2471 $k =~ s/\.pm$//;
2472 $k =~ s/\//::/g;
2473
2474 if (my $cb = $k->can ("unload_module")) { 3865 if (my $cb = $pkg->can ("unload")) {
3866 eval {
2475 $cb->(); 3867 $cb->($pkg);
3868 1
3869 } or warn "$pkg unloaded, but with errors: $@";
3870 }
3871
3872 warn "... clearing $pkg";
3873 clear_package $pkg;
2476 } 3874 }
2477 3875
2478 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;
2479 } 3891 }
2480 3892
2481 warn "getting rid of safe::, as good as possible"; 3893 warn "getting rid of safe::, as good as possible";
2482 Symbol::delete_package "safe::$_" 3894 clear_package "safe::$_"
2483 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);
2484 3896
2485 warn "unloading cf.pm \"a bit\""; 3897 warn "unloading cf.pm \"a bit\"";
2486 delete $INC{"cf.pm"}; 3898 delete $INC{"cf.pm"};
3899 delete $INC{"cf/$_.pm"} for @EXTRA_MODULES;
2487 3900
2488 # don't, removes xs symbols, too, 3901 # don't, removes xs symbols, too,
2489 # and global variables created in xs 3902 # and global variables created in xs
2490 #Symbol::delete_package __PACKAGE__; 3903 #clear_package __PACKAGE__;
2491 3904
2492 warn "unload completed, starting to reload now"; 3905 warn "unload completed, starting to reload now";
2493 3906
2494 warn "reloading cf.pm"; 3907 warn "reloading cf.pm";
2495 require cf; 3908 require cf;
2496 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 3909 cf::_connect_to_perl_1;
2497 3910
2498 warn "loading config and database again"; 3911 warn "loading config and database again";
2499 cf::cfg_load; 3912 cf::reload_config;
2500 3913
2501 warn "loading extensions"; 3914 warn "loading extensions";
2502 cf::load_extensions; 3915 cf::load_extensions;
2503 3916
3917 if ($REATTACH_ON_RELOAD) {
2504 warn "reattaching attachments to objects/players"; 3918 warn "reattaching attachments to objects/players";
2505 _global_reattach; # objects, sockets 3919 _global_reattach; # objects, sockets
2506 warn "reattaching attachments to maps"; 3920 warn "reattaching attachments to maps";
2507 reattach $_ for values %MAP; 3921 reattach $_ for values %MAP;
2508 warn "reattaching attachments to players"; 3922 warn "reattaching attachments to players";
2509 reattach $_ for values %PLAYER; 3923 reattach $_ for values %PLAYER;
3924 }
2510 3925
2511 warn "loading reloadable resources"; 3926 warn "running post_init jobs";
2512 reload_resources; 3927 (pop @POST_INIT)->(1) while @POST_INIT;
2513 3928
2514 warn "leaving sync_job"; 3929 warn "leaving sync_job";
2515 3930
2516 1 3931 1
2517 } or do { 3932 } or do {
2518 warn $@; 3933 warn $@;
2519 warn "error while reloading, exiting."; 3934 cf::cleanup "error while reloading, exiting.";
2520 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 };
2521 }; 3958 };
2522 3959}
2523 warn "reloaded";
2524};
2525
2526our $RELOAD_WATCHER; # used only during reload
2527 3960
2528register_command "reload" => sub { 3961register_command "reload" => sub {
2529 my ($who, $arg) = @_; 3962 my ($who, $arg) = @_;
2530 3963
2531 if ($who->flag (FLAG_WIZ)) { 3964 if ($who->flag (FLAG_WIZ)) {
2532 $who->message ("reloading server."); 3965 $who->message ("reloading server.");
2533 3966 async {
2534 # doing reload synchronously and two reloads happen back-to-back, 3967 $Coro::current->{desc} = "perl_reload";
2535 # coro crashes during coro_state_free->destroy here.
2536
2537 $RELOAD_WATCHER ||= Event->timer (
2538 reentrant => 0,
2539 after => 0,
2540 data => WF_AUTOCANCEL,
2541 cb => sub {
2542 reload; 3968 reload_perl;
2543 undef $RELOAD_WATCHER;
2544 },
2545 ); 3969 };
2546 } 3970 }
2547}; 3971};
2548 3972
2549unshift @INC, $LIBDIR; 3973unshift @INC, $LIBDIR;
2550 3974
2551my $bug_warning = 0; 3975my $bug_warning = 0;
2552 3976
2553$TICK_WATCHER = Event->timer ( 3977our @WAIT_FOR_TICK;
2554 reentrant => 0, 3978our @WAIT_FOR_TICK_BEGIN;
2555 parked => 1, 3979
2556 prio => 0, 3980sub wait_for_tick {
2557 at => $NEXT_TICK || $TICK, 3981 return Coro::cede if tick_inhibit || $Coro::current == $Coro::main;
2558 data => WF_AUTOCANCEL, 3982
2559 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 {
2560 if ($Coro::current != $Coro::main) { 3997 if ($Coro::current != $Coro::main) {
2561 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"
2562 unless ++$bug_warning > 10; 3999 unless ++$bug_warning > 10;
2563 return; 4000 return;
2564 } 4001 }
2565 4002
2566 $NOW = Event::time;
2567
2568 cf::server_tick; # one server iteration 4003 cf::server_tick; # one server iteration
2569 $RUNTIME += $TICK;
2570 $NEXT_TICK += $TICK;
2571 4004
4005 #for(1..3e6){} AE::now_update; $NOW=AE::now; # generate load #d#
4006
2572 if ($NOW >= $NEXT_RUNTIME_WRITE) { 4007 if ($NOW >= $NEXT_RUNTIME_WRITE) {
2573 $NEXT_RUNTIME_WRITE = $NOW + 10; 4008 $NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.;
2574 Coro::async_pool { 4009 Coro::async_pool {
4010 $Coro::current->{desc} = "runtime saver";
2575 write_runtime 4011 write_runtime_sync
2576 or warn "ERROR: unable to write runtime file: $!"; 4012 or warn "ERROR: unable to write runtime file: $!";
2577 };
2578 } 4013 };
2579
2580 $WAIT_FOR_TICK->broadcast;
2581 $WAIT_FOR_TICK_ONE->send if $WAIT_FOR_TICK_ONE->awaited;
2582
2583# my $AFTER = Event::time;
2584# warn $AFTER - $NOW;#d#
2585
2586 # if we are delayed by four ticks or more, skip them all
2587 $NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4;
2588
2589 $TICK_WATCHER->at ($NEXT_TICK);
2590 $TICK_WATCHER->start;
2591 }, 4014 }
2592); 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}
2593 4034
2594{ 4035{
2595 BDB::max_poll_time $TICK * 0.1; 4036 # configure BDB
2596 $BDB_POLL_WATCHER = Event->io ( 4037
2597 reentrant => 0,
2598 fd => BDB::poll_fileno,
2599 poll => 'r',
2600 prio => 0,
2601 data => WF_AUTOCANCEL,
2602 cb => \&BDB::poll_cb,
2603 );
2604 BDB::min_parallel 8; 4038 BDB::min_parallel 16;
2605 4039 BDB::max_poll_reqs $TICK * 0.1;
2606 BDB::set_sync_prepare { 4040 $AnyEvent::BDB::WATCHER->priority (1);
2607 my $status;
2608 my $current = $Coro::current;
2609 (
2610 sub {
2611 $status = $!;
2612 $current->ready; undef $current;
2613 },
2614 sub {
2615 Coro::schedule while defined $current;
2616 $! = $status;
2617 },
2618 )
2619 };
2620 4041
2621 unless ($DB_ENV) { 4042 unless ($DB_ENV) {
2622 $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);
2623 4049
2624 cf::sync_job { 4050 cf::sync_job {
2625 eval { 4051 eval {
2626 BDB::db_env_open 4052 BDB::db_env_open
2627 $DB_ENV, 4053 $DB_ENV,
2628 $BDB_ENV_DIR, 4054 $BDBDIR,
2629 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
2630 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE, 4056 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE,
2631 0666; 4057 0666;
2632 4058
2633 cf::cleanup "db_env_open($BDB_ENV_DIR): $!" if $!; 4059 cf::cleanup "db_env_open($BDBDIR): $!" if $!;
2634
2635 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC, 1);
2636 $DB_ENV->set_lk_detect;
2637 }; 4060 };
2638 4061
2639 cf::cleanup "db_env_open(db): $@" if $@; 4062 cf::cleanup "db_env_open(db): $@" if $@;
2640 }; 4063 };
2641 } 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 };
2642} 4075}
2643 4076
2644{ 4077{
4078 # configure IO::AIO
4079
2645 IO::AIO::min_parallel 8; 4080 IO::AIO::min_parallel 8;
2646
2647 undef $Coro::AIO::WATCHER;
2648 IO::AIO::max_poll_time $TICK * 0.1; 4081 IO::AIO::max_poll_time $TICK * 0.1;
2649 $AIO_POLL_WATCHER = Event->io ( 4082 undef $AnyEvent::AIO::WATCHER;
2650 reentrant => 0,
2651 data => WF_AUTOCANCEL,
2652 fd => IO::AIO::poll_fileno,
2653 poll => 'r',
2654 prio => 6,
2655 cb => \&IO::AIO::poll_cb,
2656 );
2657} 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;
2658 4130
2659END { cf::emergency_save } 4131END { cf::emergency_save }
2660 4132
26611 41331
2662 4134

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines