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.217 by root, Thu Feb 15 21:07:49 2007 UTC vs.
Revision 1.533 by root, Thu Apr 29 07:59:17 2010 UTC

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

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines