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.248 by root, Tue Apr 17 18:40:32 2007 UTC vs.
Revision 1.527 by root, Fri Apr 23 04:32:47 2010 UTC

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

Diff Legend

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