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.198 by root, Sun Jan 28 01:58:37 2007 UTC vs.
Revision 1.521 by root, Fri Apr 16 23:28:42 2010 UTC

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

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines