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.189 by root, Sun Jan 21 21:28:27 2007 UTC vs.
Revision 1.522 by root, Sat Apr 17 02:22:14 2010 UTC

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

Diff Legend

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