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.195 by root, Fri Jan 26 20:59:57 2007 UTC vs.
Revision 1.532 by root, Thu Apr 29 07:32:34 2010 UTC

1#
2# This file is part of Deliantra, the Roguelike Realtime MMORPG.
3#
4# Copyright (©) 2006,2007,2008,2009,2010 Marc Alexander Lehmann / Robin Redeker / the Deliantra team
5#
6# Deliantra is free software: you can redistribute it and/or modify it under
7# the terms of the Affero GNU General Public License as published by the
8# Free Software Foundation, either version 3 of the License, or (at your
9# option) any later version.
10#
11# This program is distributed in the hope that it will be useful,
12# but WITHOUT ANY WARRANTY; without even the implied warranty of
13# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14# GNU General Public License for more details.
15#
16# You should have received a copy of the Affero GNU General Public License
17# and the GNU General Public License along with this program. If not, see
18# <http://www.gnu.org/licenses/>.
19#
20# The authors can be reached via e-mail to <support@deliantra.net>
21#
22
1package cf; 23package cf;
2 24
25use 5.10.0;
3use utf8; 26use utf8;
4use strict; 27use strict qw(vars subs);
5 28
6use Symbol; 29use Symbol;
7use List::Util; 30use List::Util;
8use Storable; 31use Socket;
32use EV;
9use Opcode; 33use Opcode;
10use Safe; 34use Safe;
11use Safe::Hole; 35use Safe::Hole;
36use Storable ();
37use Carp ();
12 38
39use Guard ();
13use Coro 3.5 (); 40use Coro ();
41use Coro::State;
42use Coro::Handle;
43use Coro::EV;
14use Coro::Event; 44use Coro::AnyEvent;
15use Coro::Timer; 45use Coro::Timer;
16use Coro::Signal; 46use Coro::Signal;
17use Coro::Semaphore; 47use Coro::Semaphore;
48use Coro::SemaphoreSet;
49use Coro::AnyEvent;
18use Coro::AIO; 50use Coro::AIO;
51use Coro::BDB 1.6;
52use Coro::Storable;
53use Coro::Util ();
19 54
55use JSON::XS 2.01 ();
56use BDB ();
20use Data::Dumper; 57use Data::Dumper;
21use Digest::MD5;
22use Fcntl; 58use Fcntl;
23use IO::AIO 2.32 ();
24use YAML::Syck (); 59use YAML::XS ();
60use IO::AIO ();
25use Time::HiRes; 61use Time::HiRes;
62use Compress::LZF;
63use Digest::MD5 ();
26 64
27use Event; $Event::Eval = 1; # no idea why this is required, but it is 65AnyEvent::detect;
66
67# configure various modules to our taste
68#
69$Storable::canonical = 1; # reduce rsync transfers
70Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator
71
72$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority
73
74# make sure c-lzf reinitialises itself
75Compress::LZF::set_serializer "Storable", "Storable::net_mstore", "Storable::mretrieve";
76Compress::LZF::sfreeze_cr { }; # prime Compress::LZF so it does not use require later
77
78# strictly for debugging
79$SIG{QUIT} = sub { Carp::cluck "SIGQUIT" };
28 80
29sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload 81sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
30
31# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode?
32$YAML::Syck::ImplicitUnicode = 1;
33
34$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority
35 82
36our %COMMAND = (); 83our %COMMAND = ();
37our %COMMAND_TIME = (); 84our %COMMAND_TIME = ();
38 85
39our @EXTS = (); # list of extension package names 86our @EXTS = (); # list of extension package names
40our %EXTCMD = (); 87our %EXTCMD = ();
88our %EXTICMD = ();
41our %EXT_CORO = (); # coroutines bound to extensions 89our %EXT_CORO = (); # coroutines bound to extensions
42our %EXT_MAP = (); # pluggable maps 90our %EXT_MAP = (); # pluggable maps
43 91
92our $RELOAD; # number of reloads so far, non-zero while in reload
44our @EVENT; 93our @EVENT;
45our $LIBDIR = datadir . "/ext"; 94our @REFLECT; # set by XS
95our %REFLECT; # set by us
46 96
47our $TICK = MAX_TIME * 1e-6; 97our $CONFDIR = confdir;
48our $TICK_WATCHER; 98our $DATADIR = datadir;
49our $AIO_POLL_WATCHER; 99our $LIBDIR = "$DATADIR/ext";
50our $WRITE_RUNTIME_WATCHER; 100our $PODDIR = "$DATADIR/pod";
101our $MAPDIR = "$DATADIR/" . mapdir;
102our $LOCALDIR = localdir;
103our $TMPDIR = "$LOCALDIR/" . tmpdir;
104our $UNIQUEDIR = "$LOCALDIR/" . uniquedir;
105our $PLAYERDIR = "$LOCALDIR/" . playerdir;
106our $RANDOMDIR = "$LOCALDIR/random";
107our $BDBDIR = "$LOCALDIR/db";
108our $PIDFILE = "$LOCALDIR/pid";
109our $RUNTIMEFILE = "$LOCALDIR/runtime";
110
111our %RESOURCE; # 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(!)
120our $NEXT_RUNTIME_WRITE; # when should the runtime file be written
51our $NEXT_TICK; 121our $NEXT_TICK;
52our $NOW; 122our $USE_FSYNC = 1; # use fsync to write maps - default on
123
124our $BDB_DEADLOCK_WATCHER;
125our $BDB_CHECKPOINT_WATCHER;
126our $BDB_TRICKLE_WATCHER;
127our $DB_ENV;
128
129our @EXTRA_MODULES = qw(pod match mapscript);
53 130
54our %CFG; 131our %CFG;
55 132
56our $UPTIME; $UPTIME ||= time; 133our $UPTIME; $UPTIME ||= time;
57our $RUNTIME; 134our $RUNTIME;
135our $NOW;
58 136
59our %PLAYER; # all users 137our (%PLAYER, %PLAYER_LOADING); # all users
60our %MAP; # all maps 138our (%MAP, %MAP_LOADING ); # all maps
61our $LINK_MAP; # the special {link} map, which is always available 139our $LINK_MAP; # the special {link} map, which is always available
62our $RANDOM_MAPS = cf::localdir . "/random";
63
64our $WAIT_FOR_TICK; $WAIT_FOR_TICK ||= new Coro::Signal;
65our $WAIT_FOR_TICK_ONE; $WAIT_FOR_TICK_ONE ||= new Coro::Signal;
66 140
67# 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 ∕
68our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons 142our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons
69 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
70binmode STDOUT; 154binmode STDOUT;
71binmode STDERR; 155binmode STDERR;
72 156
73# read virtual server time, if available 157# read virtual server time, if available
74unless ($RUNTIME || !-e cf::localdir . "/runtime") { 158unless ($RUNTIME || !-e $RUNTIMEFILE) {
75 open my $fh, "<", cf::localdir . "/runtime" 159 open my $fh, "<", $RUNTIMEFILE
76 or die "unable to read runtime file: $!"; 160 or die "unable to read $RUNTIMEFILE file: $!";
77 $RUNTIME = <$fh> + 0.; 161 $RUNTIME = <$fh> + 0.;
78} 162}
79 163
80mkdir cf::localdir; 164eval "sub TICK() { $TICK } 1" or die;
81mkdir cf::localdir . "/" . cf::playerdir; 165
82mkdir cf::localdir . "/" . cf::tmpdir; 166mkdir $_
83mkdir cf::localdir . "/" . cf::uniquedir; 167 for $LOCALDIR, $TMPDIR, $UNIQUEDIR, $PLAYERDIR, $RANDOMDIR, $BDBDIR;
84mkdir $RANDOM_MAPS;
85 168
86our $EMERGENCY_POSITION; 169our $EMERGENCY_POSITION;
170
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::"} };
87 187
88############################################################################# 188#############################################################################
89 189
90=head2 GLOBAL VARIABLES 190=head2 GLOBAL VARIABLES
91 191
… …
98=item $cf::RUNTIME 198=item $cf::RUNTIME
99 199
100The 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
101every server tick. 201every server tick.
102 202
103=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
104 206
105The perl library directory, where extensions and cf-specific modules can 207Various directories - "/etc", read-only install directory, perl-library
106be 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.
107 211
108=item $cf::NOW 212=item $cf::NOW
109 213
110The time of the last (current) server tick. 214The time of the last (current) server tick.
111 215
112=item $cf::TICK 216=item $cf::TICK
113 217
114The interval between server ticks, in seconds. 218The interval between server ticks, in seconds.
115 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
116=item %cf::CFG 230=item %cf::CFG
117 231
118Configuration for the server, loaded from C</etc/crossfire/config>, or 232Configuration for the server, loaded from C</etc/deliantra-server/config>, or
119from wherever your confdir points to. 233from wherever your confdir points to.
120 234
121=item $cf::WAIT_FOR_TICK, $cf::WAIT_FOR_TICK_ONE 235=item cf::wait_for_tick, cf::wait_for_tick_begin
122 236
123These 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
124or 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
125processing 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.
126window 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.
127 252
128=back 253=back
129 254
130=cut 255=cut
131 256
132BEGIN { 257sub error(@) { LOG llevError, join "", @_ }
133 *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 {
134 my $msg = join "", @_; 264 my $msg = join "", @_;
135 utf8::encode $msg;
136 265
137 $msg .= "\n" 266 $msg .= "\n"
138 unless $msg =~ /\n$/; 267 unless $msg =~ /\n$/;
139 268
269 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;
270
140 LOG llevError, $msg; 271 LOG llevWarn, $msg;
141 }; 272};
142} 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};
143 287
144@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable'; 288@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
145@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable'; 289@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';
146@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable'; 290@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable';
147@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable'; 291@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable';
148@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';
149@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)
150 295
151# 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
152# within the Safe compartment. 297# within the Safe compartment.
153for my $pkg (qw( 298for my $pkg (qw(
154 cf::global cf::attachable 299 cf::global cf::attachable
155 cf::object cf::object::player 300 cf::object cf::object::player
156 cf::client cf::player 301 cf::client cf::player
157 cf::arch cf::living 302 cf::arch cf::living
303 cf::map cf::mapspace
158 cf::map cf::party cf::region 304 cf::party cf::region
159)) { 305)) {
160 no strict 'refs';
161 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg; 306 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
162} 307}
163 308
164$Event::DIED = sub { 309$EV::DIED = sub {
165 warn "error in event callback: @_"; 310 Carp::cluck "error in event callback: @_";
166}; 311};
312
313#############################################################################
167 314
168=head2 UTILITY FUNCTIONS 315=head2 UTILITY FUNCTIONS
169 316
170=over 4 317=over 4
171 318
… …
190 $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;
191 $d 338 $d
192 } || "[unable to dump $_[0]: '$@']"; 339 } || "[unable to dump $_[0]: '$@']";
193} 340}
194 341
195use JSON::Syck (); # TODO# replace by JSON::PC once working
196
197=item $ref = cf::from_json $json 342=item $ref = cf::decode_json $json
198 343
199Converts a JSON string into the corresponding perl data structure. 344Converts a JSON string into the corresponding perl data structure.
200 345
201=cut
202
203sub from_json($) {
204 $JSON::Syck::ImplicitUnicode = 1; # work around JSON::Syck bugs
205 JSON::Syck::Load $_[0]
206}
207
208=item $json = cf::to_json $ref 346=item $json = cf::encode_json $ref
209 347
210Converts a perl data structure into its JSON representation. 348Converts a perl data structure into its JSON representation.
211 349
212=cut 350=cut
213 351
214sub to_json($) { 352our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max
215 $JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs 353
216 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;
217} 369}
218 370
219=item cf::lock_wait $string 371=item cf::lock_wait $string
220 372
221Wait until the given lock is available. See cf::lock_acquire. 373Wait until the given lock is available. See cf::lock_acquire.
222 374
223=item my $lock = cf::lock_acquire $string 375=item my $lock = cf::lock_acquire $string
224 376
225Wait 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
226a 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,
227for example when the coroutine gets canceled), the lock is automatically 379for example when the coroutine gets canceled), the lock is automatically
228returned. 380returned.
229 381
382Locks are *not* recursive, locking from the same coro twice results in a
383deadlocked coro.
384
230Lock 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
231uses map_find and cf::map::load uses map_load). 386uses map_find and cf::map::load uses map_load).
232 387
233=cut 388=item $locked = cf::lock_active $string
234 389
235our %LOCK; 390Return true if the lock is currently active, i.e. somebody has locked it.
391
392=cut
393
394our $LOCKS = new Coro::SemaphoreSet;
236 395
237sub lock_wait($) { 396sub lock_wait($) {
238 my ($key) = @_; 397 $LOCKS->wait ($_[0]);
239
240 # wait for lock, if any
241 while ($LOCK{$key}) {
242 push @{ $LOCK{$key} }, $Coro::current;
243 Coro::schedule;
244 }
245} 398}
246 399
247sub lock_acquire($) { 400sub lock_acquire($) {
248 my ($key) = @_; 401 $LOCKS->guard ($_[0])
402}
249 403
250 # wait, to be sure we are not locked 404sub lock_active($) {
251 lock_wait $key; 405 $LOCKS->count ($_[0]) < 1
252
253 $LOCK{$key} = [];
254
255 Coro::guard {
256 # wake up all waiters, to be on the safe side
257 $_->ready for @{ delete $LOCK{$key} };
258 }
259} 406}
260 407
261sub freeze_mainloop { 408sub freeze_mainloop {
262 return unless $TICK_WATCHER->is_active; 409 tick_inhibit_inc;
263 410
264 my $guard = Coro::guard { 411 &Guard::guard (\&tick_inhibit_dec);
265 $TICK_WATCHER->start; 412}
266 $WRITE_RUNTIME_WATCHER->start; 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 }
267 }; 478 }
268 $WRITE_RUNTIME_WATCHER->stop; 479};
269 $TICK_WATCHER->stop; 480
270 $guard 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;
271} 494}
272 495
273=item cf::async { BLOCK } 496=item cf::async { BLOCK }
274 497
275Currently the same as Coro::async_pool, meaning you cannot use 498Currently the same as Coro::async_pool, meaning you cannot use
… …
280 503
281BEGIN { *async = \&Coro::async_pool } 504BEGIN { *async = \&Coro::async_pool }
282 505
283=item cf::sync_job { BLOCK } 506=item cf::sync_job { BLOCK }
284 507
285The design of crossfire+ requires that the main coro ($Coro::main) is 508The design of Deliantra requires that the main coroutine ($Coro::main)
286always able to handle events or runnable, as crossfire+ is only partly 509is always able to handle events or runnable, as Deliantra is only
287reentrant. Thus "blocking" it by e.g. waiting for I/O is not acceptable. 510partly reentrant. Thus "blocking" it by e.g. waiting for I/O is not
511acceptable.
288 512
289If 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
290the given BLOCK in another coroutine while waiting for the result. The 514the given BLOCK in another coroutine while waiting for the result. The
291server 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
292fast or be very important. 516fast or be very important.
… …
295 519
296sub sync_job(&) { 520sub sync_job(&) {
297 my ($job) = @_; 521 my ($job) = @_;
298 522
299 if ($Coro::current == $Coro::main) { 523 if ($Coro::current == $Coro::main) {
524 my $time = AE::time;
525
300 # this is the main coro, too bad, we have to block 526 # this is the main coro, too bad, we have to block
301 # till the operation succeeds, freezing the server :/ 527 # till the operation succeeds, freezing the server :/
302 528
303 # TODO: use suspend/resume instead 529 LOG llevError, Carp::longmess "sync job";#d#
304 # (but this is cancel-safe) 530
305 my $freeze_guard = freeze_mainloop; 531 my $freeze_guard = freeze_mainloop;
306 532
307 my $busy = 1; 533 my $busy = 1;
308 my @res; 534 my @res;
309 535
310 (async { 536 (async {
537 $Coro::current->desc ("sync job coro");
311 @res = eval { $job->() }; 538 @res = eval { $job->() };
312 warn $@ if $@; 539 error $@ if $@;
313 undef $busy; 540 undef $busy;
314 })->prio (Coro::PRIO_MAX); 541 })->prio (Coro::PRIO_MAX);
315 542
316 while ($busy) { 543 while ($busy) {
317 Coro::cede or Event::one_event; 544 if (Coro::nready) {
545 Coro::cede_notself;
546 } else {
547 EV::loop EV::LOOP_ONESHOT;
318 } 548 }
549 }
550
551 my $time = AE::time - $time;
552
553 $TICK_START += $time; # do not account sync jobs to server load
319 554
320 wantarray ? @res : $res[0] 555 wantarray ? @res : $res[0]
321 } else { 556 } else {
322 # we are in another coroutine, how wonderful, everything just works 557 # we are in another coroutine, how wonderful, everything just works
323 558
… …
343 $EXT_CORO{$coro+0} = $coro; 578 $EXT_CORO{$coro+0} = $coro;
344 579
345 $coro 580 $coro
346} 581}
347 582
348sub write_runtime { 583=item fork_call { }, $args
349 my $runtime = cf::localdir . "/runtime";
350 584
351 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644 585Executes the given code block with the given arguments in a seperate
352 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.
353 589
354 my $value = $cf::RUNTIME + 90 + 10; 590=cut
355 # 10 is the runtime save interval, for a monotonic clock
356 # 60 allows for the watchdog to kill the server.
357 591
358 (aio_write $fh, 0, (length $value), $value, 0) <= 0 592sub fork_call(&@) {
359 and return; 593 my ($cb, @args) = @_;
360 594
361 aio_fsync $fh 595 # we seemingly have to make a local copy of the whole thing,
362 and return; 596 # otherwise perl prematurely frees the stuff :/
597 # TODO: investigate and fix (likely this will be rather laborious)
363 598
364 close $fh 599 my @res = Coro::Util::fork_eval {
365 or return; 600 reset_signals;
601 &$cb
602 }, @args;
366 603
367 aio_rename "$runtime~", $runtime 604 wantarray ? @res : $res[-1]
368 and return; 605}
369 606
607sub objinfo {
370 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 });
371} 781}
372 782
373=back 783=back
374 784
375=cut 785=cut
376 786
377############################################################################# 787#############################################################################
378 788
379=head2 ATTACHABLE OBJECTS 789=head2 ATTACHABLE OBJECTS
380 790
381Many 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
382attach callbacks/event handlers (a collection of which is called an "attachment") 792attach callbacks/event handlers (a collection of which is called an "attachment")
383to it. All such attachable objects support the following methods. 793to it. All such attachable objects support the following methods.
384 794
385In 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>
386C<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
387crossfire+). 797Deliantra).
388 798
389=over 4 799=over 4
390 800
391=item $attachable->attach ($attachment, key => $value...) 801=item $attachable->attach ($attachment, key => $value...)
392 802
… …
436=item cf::CLASS::attachment $name, ... 846=item cf::CLASS::attachment $name, ...
437 847
438Register an attachment by C<$name> through which attachable objects of the 848Register an attachment by C<$name> through which attachable objects of the
439given CLASS can refer to this attachment. 849given CLASS can refer to this attachment.
440 850
441Some classes such as crossfire maps and objects can specify attachments 851Some classes such as deliantra maps and objects can specify attachments
442that 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.
443 853
444These calls expect any number of the following handler/hook descriptions: 854These calls expect any number of the following handler/hook descriptions:
445 855
446=over 4 856=over 4
… …
555 $registry = $CB_TYPE[$object_type] ||= []; 965 $registry = $CB_TYPE[$object_type] ||= [];
556 966
557 } elsif ($type eq "subtype") { 967 } elsif ($type eq "subtype") {
558 defined $object_type or Carp::croak "subtype specified without type"; 968 defined $object_type or Carp::croak "subtype specified without type";
559 my $object_subtype = shift @arg; 969 my $object_subtype = shift @arg;
560 $registry = $CB_TYPE[$object_type + $object_subtype * NUM_SUBTYPES] ||= []; 970 $registry = $CB_TYPE[$object_type + $object_subtype * NUM_TYPES] ||= [];
561 971
562 } elsif ($type eq "package") { 972 } elsif ($type eq "package") {
563 my $pkg = shift @arg; 973 my $pkg = shift @arg;
564 974
565 while (my ($name, $id) = each %cb_id) { 975 while (my ($name, $id) = each %cb_id) {
… …
570 980
571 } elsif (exists $cb_id{$type}) { 981 } elsif (exists $cb_id{$type}) {
572 _attach_cb $registry, $cb_id{$type}, $prio, shift @arg; 982 _attach_cb $registry, $cb_id{$type}, $prio, shift @arg;
573 983
574 } elsif (ref $type) { 984 } elsif (ref $type) {
575 warn "attaching objects not supported, ignoring.\n"; 985 error "attaching objects not supported, ignoring.\n";
576 986
577 } else { 987 } else {
578 shift @arg; 988 shift @arg;
579 warn "attach argument '$type' not supported, ignoring.\n"; 989 error "attach argument '$type' not supported, ignoring.\n";
580 } 990 }
581 } 991 }
582} 992}
583 993
584sub _object_attach { 994sub _object_attach {
… …
594 _attach $registry, $klass, @attach; 1004 _attach $registry, $klass, @attach;
595 } 1005 }
596 1006
597 $obj->{$name} = \%arg; 1007 $obj->{$name} = \%arg;
598 } else { 1008 } else {
599 warn "object uses attachment '$name' that is not available, postponing.\n"; 1009 info "object uses attachment '$name' which is not available, postponing.\n";
600 } 1010 }
601 1011
602 $obj->{_attachment}{$name} = undef; 1012 $obj->{_attachment}{$name} = undef;
603} 1013}
604 1014
… …
606 if (ref $_[0]) { 1016 if (ref $_[0]) {
607 _object_attach @_; 1017 _object_attach @_;
608 } else { 1018 } else {
609 _attach shift->_attach_registry, @_; 1019 _attach shift->_attach_registry, @_;
610 } 1020 }
1021 _recalc_want;
611}; 1022};
612 1023
613# all those should be optimised 1024# all those should be optimised
614sub cf::attachable::detach { 1025sub cf::attachable::detach {
615 my ($obj, $name) = @_; 1026 my ($obj, $name) = @_;
… …
618 delete $obj->{_attachment}{$name}; 1029 delete $obj->{_attachment}{$name};
619 reattach ($obj); 1030 reattach ($obj);
620 } else { 1031 } else {
621 Carp::croak "cannot, currently, detach class attachments"; 1032 Carp::croak "cannot, currently, detach class attachments";
622 } 1033 }
1034 _recalc_want;
623}; 1035};
624 1036
625sub cf::attachable::attached { 1037sub cf::attachable::attached {
626 my ($obj, $name) = @_; 1038 my ($obj, $name) = @_;
627 1039
… …
642 "; 1054 ";
643 die if $@; 1055 die if $@;
644} 1056}
645 1057
646our $override; 1058our $override;
647our @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?
648 1060
649sub override { 1061sub override {
650 $override = 1; 1062 $override = 1;
651 @invoke_results = (); 1063 @INVOKE_RESULTS = (@_);
652} 1064}
653 1065
654sub do_invoke { 1066sub do_invoke {
655 my $event = shift; 1067 my $event = shift;
656 my $callbacks = shift; 1068 my $callbacks = shift;
657 1069
658 @invoke_results = (); 1070 @INVOKE_RESULTS = ();
659 1071
660 local $override; 1072 local $override;
661 1073
662 for (@$callbacks) { 1074 for (@$callbacks) {
663 eval { &{$_->[1]} }; 1075 eval { &{$_->[1]} };
664 1076
665 if ($@) { 1077 if ($@) {
666 warn "$@";
667 warn "... while processing $EVENT[$event][0](@_) event, skipping processing altogether.\n"; 1078 error "$@", "... while processing $EVENT[$event][0](@_) event, skipping processing altogether.\n";
668 override; 1079 override;
669 } 1080 }
670 1081
671 return 1 if $override; 1082 return 1 if $override;
672 } 1083 }
673 1084
674 0 1085 0
675} 1086}
676 1087
677=item $bool = cf::global::invoke (EVENT_CLASS_XXX, ...) 1088=item $bool = cf::global->invoke (EVENT_CLASS_XXX, ...)
678 1089
679=item $bool = $attachable->invoke (EVENT_CLASS_XXX, ...) 1090=item $bool = $attachable->invoke (EVENT_CLASS_XXX, ...)
680 1091
681Generate an object-specific event with the given arguments. 1092Generate an object-specific event with the given arguments.
682 1093
683This 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
684removed 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
685results (if you must, access C<@cf::invoke_results> directly). 1096results (if you must, access C<@cf::INVOKE_RESULTS> directly).
686 1097
687=back 1098=back
688 1099
689=cut 1100=cut
690 1101
691############################################################################# 1102#############################################################################
692# 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}
693 1146
694sub reattach { 1147sub reattach {
695 # basically do the same as instantiate, without calling instantiate 1148 # basically do the same as instantiate, without calling instantiate
696 my ($obj) = @_; 1149 my ($obj) = @_;
697 1150
1151 # no longer needed after getting rid of delete_package?
698 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
699 1153
700 my $registry = $obj->registry; 1154 my $registry = $obj->registry;
701 1155
702 @$registry = (); 1156 @$registry = ();
703 1157
… …
708 for (@$attach) { 1162 for (@$attach) {
709 my ($klass, @attach) = @$_; 1163 my ($klass, @attach) = @$_;
710 _attach $registry, $klass, @attach; 1164 _attach $registry, $klass, @attach;
711 } 1165 }
712 } else { 1166 } else {
713 warn "object uses attachment '$name' that is not available, postponing.\n"; 1167 info "object uses attachment '$name' that is not available, postponing.\n";
714 } 1168 }
715 } 1169 }
716} 1170}
717 1171
718cf::attachable->attach ( 1172cf::attachable->attach (
719 prio => -1000000, 1173 prio => -1000000,
720 on_instantiate => sub { 1174 on_instantiate => sub {
721 my ($obj, $data) = @_; 1175 my ($obj, $data) = @_;
722 1176
723 $data = from_json $data; 1177 $data = decode_json $data;
724 1178
725 for (@$data) { 1179 for (@$data) {
726 my ($name, $args) = @$_; 1180 my ($name, $args) = @$_;
727 1181
728 $obj->attach ($name, %{$args || {} }); 1182 $obj->attach ($name, %{$args || {} });
… …
744sub object_freezer_save { 1198sub object_freezer_save {
745 my ($filename, $rdata, $objs) = @_; 1199 my ($filename, $rdata, $objs) = @_;
746 1200
747 sync_job { 1201 sync_job {
748 if (length $$rdata) { 1202 if (length $$rdata) {
1203 utf8::decode (my $decname = $filename);
749 warn sprintf "saving %s (%d,%d)\n", 1204 trace sprintf "saving %s (%d,%d)\n",
750 $filename, length $$rdata, scalar @$objs; 1205 $decname, length $$rdata, scalar @$objs
1206 if $VERBOSE_IO;
751 1207
752 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) { 1208 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
753 chmod SAVE_MODE, $fh; 1209 aio_chmod $fh, SAVE_MODE;
754 aio_write $fh, 0, (length $$rdata), $$rdata, 0; 1210 aio_write $fh, 0, (length $$rdata), $$rdata, 0;
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;
755 aio_fsync $fh; 1213 aio_fsync $fh;
1214 }
756 close $fh; 1215 aio_close $fh;
757 1216
758 if (@$objs) { 1217 if (@$objs) {
759 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) {
760 chmod SAVE_MODE, $fh; 1219 aio_chmod $fh, SAVE_MODE;
761 my $data = Storable::nfreeze { version => 1, objs => $objs }; 1220 my $data = Coro::Storable::nfreeze { version => 1, objs => $objs };
762 aio_write $fh, 0, (length $data), $data, 0; 1221 aio_write $fh, 0, (length $data), $data, 0;
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;
763 aio_fsync $fh; 1224 aio_fsync $fh;
1225 }
764 close $fh; 1226 aio_close $fh;
765 aio_rename "$filename.pst~", "$filename.pst"; 1227 aio_rename "$filename.pst~", "$filename.pst";
766 } 1228 }
767 } else { 1229 } else {
768 aio_unlink "$filename.pst"; 1230 aio_unlink "$filename.pst";
769 } 1231 }
770 1232
771 aio_rename "$filename~", $filename; 1233 aio_rename "$filename~", $filename;
1234
1235 $filename =~ s%/[^/]+$%%;
1236 aio_pathsync $filename if $cf::USE_FSYNC;
772 } else { 1237 } else {
773 warn "FATAL: $filename~: $!\n"; 1238 error "unable to save objects: $filename~: $!\n";
774 } 1239 }
775 } else { 1240 } else {
776 aio_unlink $filename; 1241 aio_unlink $filename;
777 aio_unlink "$filename.pst"; 1242 aio_unlink "$filename.pst";
778 } 1243 }
779 } 1244 };
780} 1245}
781 1246
782sub object_freezer_as_string { 1247sub object_freezer_as_string {
783 my ($rdata, $objs) = @_; 1248 my ($rdata, $objs) = @_;
784 1249
… …
796 or return; 1261 or return;
797 1262
798 unless (aio_stat "$filename.pst") { 1263 unless (aio_stat "$filename.pst") {
799 (aio_load "$filename.pst", $av) >= 0 1264 (aio_load "$filename.pst", $av) >= 0
800 or return; 1265 or return;
1266
801 $av = eval { (Storable::thaw $av)->{objs} }; 1267 my $st = eval { Coro::Storable::thaw $av };
1268 $av = $st->{objs};
802 } 1269 }
803 1270
1271 utf8::decode (my $decname = $filename);
804 warn sprintf "loading %s (%d)\n", 1272 trace sprintf "loading %s (%d,%d)\n",
805 $filename, length $data, scalar @{$av || []};#d# 1273 $decname, length $data, scalar @{$av || []}
1274 if $VERBOSE_IO;
1275
806 return ($data, $av); 1276 ($data, $av)
807} 1277}
1278
1279=head2 COMMAND CALLBACKS
1280
1281=over 4
1282
1283=cut
808 1284
809############################################################################# 1285#############################################################################
810# command handling &c 1286# command handling &c
811 1287
812=item cf::register_command $name => \&callback($ob,$args); 1288=item cf::register_command $name => \&callback($ob,$args);
… …
825 push @{ $COMMAND{$name} }, [$caller, $cb]; 1301 push @{ $COMMAND{$name} }, [$caller, $cb];
826} 1302}
827 1303
828=item cf::register_extcmd $name => \&callback($pl,$packet); 1304=item cf::register_extcmd $name => \&callback($pl,$packet);
829 1305
830Register 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.
831 1311
832If 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
833called. 1313called.
834 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
835=cut 1326=cut
836 1327
837sub register_extcmd { 1328sub register_extcmd {
838 my ($name, $cb) = @_; 1329 my ($name, $cb) = @_;
839 1330
840 $EXTCMD{$name} = $cb; 1331 $EXTCMD{$name} = $cb;
841} 1332}
842 1333
1334sub register_exticmd {
1335 my ($name, $cb) = @_;
1336
1337 $EXTICMD{$name} = $cb;
1338}
1339
1340use File::Glob ();
1341
843cf::player->attach ( 1342cf::player->attach (
844 on_command => sub { 1343 on_unknown_command => sub {
845 my ($pl, $name, $params) = @_; 1344 my ($pl, $name, $params) = @_;
846 1345
847 my $cb = $COMMAND{$name} 1346 my $cb = $COMMAND{$name}
848 or return; 1347 or return;
849 1348
… …
854 cf::override; 1353 cf::override;
855 }, 1354 },
856 on_extcmd => sub { 1355 on_extcmd => sub {
857 my ($pl, $buf) = @_; 1356 my ($pl, $buf) = @_;
858 1357
859 my $msg = eval { from_json $buf }; 1358 my $msg = eval { $pl->ns->{json_coder}->decode ($buf) };
860 1359
861 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
862 if (my $cb = $EXTCMD{$msg->{msgtype}}) { 1368 if (my $cb = $EXTCMD{$type}) {
863 if (my %reply = $cb->($pl, $msg)) { 1369 @reply = $cb->($pl, @payload);
864 $pl->ext_reply ($msg->{msgid}, %reply);
865 }
866 } 1370 }
1371
1372 $pl->ext_reply ($reply, @reply)
1373 if $reply;
1374
867 } else { 1375 } else {
868 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n"; 1376 error "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
869 } 1377 }
870 1378
871 cf::override; 1379 cf::override;
872 }, 1380 },
873); 1381);
874 1382
1383# "readahead" all extensions
875sub load_extension { 1384sub cache_extensions {
876 my ($path) = @_; 1385 my $grp = IO::AIO::aio_group;
877 1386
878 $path =~ /([^\/\\]+)\.ext$/ or die "$path"; 1387 add $grp IO::AIO::aio_readdirx $LIBDIR, IO::AIO::READDIR_STAT_ORDER, sub {
879 my $base = $1; 1388 for (grep /\.ext$/, @{$_[0]}) {
880 my $pkg = $1; 1389 add $grp IO::AIO::aio_load "$LIBDIR/$_", my $data;
881 $pkg =~ s/[^[:word:]]/_/g;
882 $pkg = "ext::$pkg";
883
884 warn "... loading '$path' into '$pkg'\n";
885
886 open my $fh, "<:utf8", $path
887 or die "$path: $!";
888
889 my $source =
890 "package $pkg; use strict; use utf8;\n"
891 . "#line 1 \"$path\"\n{\n"
892 . (do { local $/; <$fh> })
893 . "\n};\n1";
894
895 unless (eval $source) {
896 my $msg = $@ ? "$path: $@\n"
897 : "extension disabled.\n";
898 if ($source =~ /^#!.*perl.*#.*MANDATORY/m) { # ugly match
899 warn $@;
900 warn "mandatory extension failed to load, exiting.\n";
901 exit 1;
902 } 1390 }
903 die $@;
904 } 1391 };
905 1392
906 push @EXTS, $pkg; 1393 $grp
907} 1394}
908 1395
909sub load_extensions { 1396sub load_extensions {
1397 info "loading extensions...";
1398
1399 cf::sync_job {
1400 my %todo;
1401
910 for my $ext (<$LIBDIR/*.ext>) { 1402 for my $path (<$LIBDIR/*.ext>) {
911 next unless -r $ext; 1403 next unless -r $path;
912 eval { 1404
913 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 }
914 1 1468 }
915 } 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 }
916 } 1479 };
917} 1480}
918 1481
919############################################################################# 1482#############################################################################
920 1483
1484=back
1485
921=head2 CORE EXTENSIONS 1486=head2 CORE EXTENSIONS
922 1487
923Functions and methods that extend core crossfire objects. 1488Functions and methods that extend core deliantra objects.
924 1489
925=cut 1490=cut
926 1491
927package cf::player; 1492package cf::player;
928 1493
… …
930 1495
931=head3 cf::player 1496=head3 cf::player
932 1497
933=over 4 1498=over 4
934 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
935=item cf::player::find $login 1514=item cf::player::find $login
936 1515
937Returns the given player object, loading it if necessary (might block). 1516Returns the given player object, loading it if necessary (might block).
938 1517
939=cut 1518=cut
940 1519
941sub playerdir($) { 1520sub playerdir($) {
942 cf::localdir 1521 "$PLAYERDIR/"
943 . "/"
944 . cf::playerdir
945 . "/"
946 . (ref $_[0] ? $_[0]->ob->name : $_[0]) 1522 . (ref $_[0] ? $_[0]->ob->name : $_[0])
947} 1523}
948 1524
949sub path($) { 1525sub path($) {
950 my $login = ref $_[0] ? $_[0]->ob->name : $_[0]; 1526 my $login = ref $_[0] ? $_[0]->ob->name : $_[0];
951 1527
952 (playerdir $login) . "/$login.pl" 1528 (playerdir $login) . "/playerdata"
953} 1529}
954 1530
955sub find_active($) { 1531sub find_active($) {
956 $cf::PLAYER{$_[0]} 1532 $cf::PLAYER{$_[0]}
957 and $cf::PLAYER{$_[0]}->active 1533 and $cf::PLAYER{$_[0]}->active
… …
960 1536
961sub exists($) { 1537sub exists($) {
962 my ($login) = @_; 1538 my ($login) = @_;
963 1539
964 $cf::PLAYER{$login} 1540 $cf::PLAYER{$login}
965 or cf::sync_job { !aio_stat path $login } 1541 or !aio_stat path $login
966} 1542}
967 1543
968sub find($) { 1544sub find($) {
969 return $cf::PLAYER{$_[0]} || do { 1545 return $cf::PLAYER{$_[0]} || do {
970 my $login = $_[0]; 1546 my $login = $_[0];
971 1547
972 my $guard = cf::lock_acquire "user_find:$login"; 1548 my $guard = cf::lock_acquire "user_find:$login";
973 1549
974 $cf::PLAYER{$_[0]} || do { 1550 $cf::PLAYER{$_[0]} || do {
975 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
976 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;
977 $cf::PLAYER{$login} = $pl 1566 $cf::PLAYER{$login} = $pl
978 } 1567 }
979 } 1568 }
980} 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);
981 1583
982sub save($) { 1584sub save($) {
983 my ($pl) = @_; 1585 my ($pl) = @_;
984 1586
985 return if $pl->{deny_save}; 1587 return if $pl->{deny_save};
… …
990 return if $pl->{deny_save}; 1592 return if $pl->{deny_save};
991 1593
992 aio_mkdir playerdir $pl, 0770; 1594 aio_mkdir playerdir $pl, 0770;
993 $pl->{last_save} = $cf::RUNTIME; 1595 $pl->{last_save} = $cf::RUNTIME;
994 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
995 $pl->save_pl ($path); 1602 $pl->save_pl ($path);
996 Coro::cede; 1603 cf::cede_to_tick;
997} 1604}
998 1605
999sub new($) { 1606sub new($) {
1000 my ($login) = @_; 1607 my ($login) = @_;
1001 1608
… …
1007 $cf::PLAYER{$login} = $self; 1614 $cf::PLAYER{$login} = $self;
1008 1615
1009 $self 1616 $self
1010} 1617}
1011 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
1012=item $pl->quit_character 1629=item $pl->quit_character
1013 1630
1014Nukes the player without looking back. If logged in, the connection will 1631Nukes the player without looking back. If logged in, the connection will
1015be destroyed. May block for a long time. 1632be destroyed. May block for a long time.
1016 1633
1017=cut 1634=cut
1018 1635
1019sub quit_character { 1636sub quit_character {
1020 my ($pl) = @_; 1637 my ($pl) = @_;
1021 1638
1639 my $name = $pl->ob->name;
1640
1022 $pl->{deny_save} = 1; 1641 $pl->{deny_save} = 1;
1023 $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
1024 1643
1025 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active; 1644 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active;
1026 $pl->deactivate; 1645 $pl->deactivate;
1646 my $killer = cf::arch::get "killer_quit"; $pl->killer ($killer); $killer->destroy;
1027 $pl->invoke (cf::EVENT_PLAYER_QUIT); 1647 $pl->invoke (cf::EVENT_PLAYER_QUIT);
1028 $pl->ns->destroy if $pl->ns; 1648 $pl->ns->destroy if $pl->ns;
1029 1649
1030 my $path = playerdir $pl; 1650 my $path = playerdir $pl;
1031 my $temp = "$path~$cf::RUNTIME~deleting~"; 1651 my $temp = "$path~$cf::RUNTIME~deleting~";
1032 aio_rename $path, $temp; 1652 aio_rename $path, $temp;
1033 delete $cf::PLAYER{$pl->ob->name}; 1653 delete $cf::PLAYER{$pl->ob->name};
1034 $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
1035 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;
1036} 1676}
1037 1677
1038=item cf::player::list_logins 1678=item cf::player::list_logins
1039 1679
1040Returns 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
1041while and may block, so not sync_job-capable, ever. 1681while and may block, so not sync_job-capable, ever.
1042 1682
1043=cut 1683=cut
1044 1684
1045sub list_logins { 1685sub list_logins {
1046 my $dirs = aio_readdir cf::localdir . "/" . cf::playerdir 1686 my $dirs = aio_readdir $PLAYERDIR
1047 or return []; 1687 or return [];
1048 1688
1049 my @logins; 1689 my @logins;
1050 1690
1051 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") {
1052 my $fh = aio_open path $login, Fcntl::O_RDONLY, 0 or next; 1697 my $fh = aio_open $path, Fcntl::O_RDONLY, 0 or next;
1053 aio_read $fh, 0, 512, my $buf, 0 or next; 1698 aio_read $fh, 0, 512, my $buf, 0 or next;
1054 $buf !~ /^password -------------$/m or next; # official not-valid tag 1699 $buf !~ /^password -------------$/m or next; # official not-valid tag
1700 }
1055 1701
1056 utf8::decode $login; 1702 utf8::decode $login;
1057 push @logins, $login; 1703 push @logins, $login;
1058 } 1704 }
1059 1705
1060 \@logins 1706 \@logins
1061} 1707}
1062 1708
1063=item $player->maps 1709=item $player->maps
1064 1710
1711=item cf::player::maps $login
1712
1065Returns an arrayref of map paths that are private for this 1713Returns an arrayref of map paths that are private for this
1066player. May block. 1714player. May block.
1067 1715
1068=cut 1716=cut
1069 1717
1070sub maps($) { 1718sub maps($) {
1071 my ($pl) = @_; 1719 my ($pl) = @_;
1720
1721 $pl = ref $pl ? $pl->ob->name : $pl;
1072 1722
1073 my $files = aio_readdir playerdir $pl 1723 my $files = aio_readdir playerdir $pl
1074 or return; 1724 or return;
1075 1725
1076 my @paths; 1726 my @paths;
… …
1078 for (@$files) { 1728 for (@$files) {
1079 utf8::decode $_; 1729 utf8::decode $_;
1080 next if /\.(?:pl|pst)$/; 1730 next if /\.(?:pl|pst)$/;
1081 next unless /^$PATH_SEP/o; 1731 next unless /^$PATH_SEP/o;
1082 1732
1083 s/\.map$//; 1733 push @paths, cf::map::normalise "~$pl/$_";
1084 push @paths, "~" . $pl->ob->name . "/" . $_;
1085 } 1734 }
1086 1735
1087 \@paths 1736 \@paths
1088} 1737}
1089 1738
1739=item $protocol_xml = $player->expand_cfpod ($cfpod)
1740
1741Expand deliantra pod fragments into protocol xml.
1742
1090=item $player->ext_reply ($msgid, $msgtype, %msg) 1743=item $player->ext_reply ($msgid, @msg)
1091 1744
1092Sends an ext reply to the player. 1745Sends an ext reply to the player.
1093 1746
1094=cut 1747=cut
1095 1748
1096sub ext_reply($$$%) { 1749sub ext_reply($$@) {
1097 my ($self, $id, %msg) = @_; 1750 my ($self, $id, @msg) = @_;
1098 1751
1099 $msg{msgid} = $id; 1752 $self->ns->ext_reply ($id, @msg)
1100
1101 $self->send ("ext " . cf::to_json \%msg);
1102} 1753}
1103 1754
1104package 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}
1105 1797
1106=back 1798=back
1107
1108 1799
1109=head3 cf::map 1800=head3 cf::map
1110 1801
1111=over 4 1802=over 4
1112 1803
… …
1124our $MAX_RESET = 3600; 1815our $MAX_RESET = 3600;
1125our $DEFAULT_RESET = 3000; 1816our $DEFAULT_RESET = 3000;
1126 1817
1127sub generate_random_map { 1818sub generate_random_map {
1128 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
1129 # mit "rum" bekleckern, nicht 1823 # mit "rum" bekleckern, nicht
1130 $self->_create_random_map ( 1824 $self->_create_random_map (
1131 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle}, 1825 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle},
1132 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle}, 1826 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle}, $rmp->{miningstyle},
1133 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map}, 1827 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map},
1134 $rmp->{exit_on_final_map}, 1828 $rmp->{exit_on_final_map},
1135 $rmp->{xsize}, $rmp->{ysize}, 1829 $rmp->{xsize}, $rmp->{ysize},
1136 $rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3}, 1830 $rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3},
1137 $rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase}, 1831 $rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase},
… …
1159 1853
1160 $EXT_MAP{$pkg} = [$prio, qr<$regex>]; 1854 $EXT_MAP{$pkg} = [$prio, qr<$regex>];
1161} 1855}
1162 1856
1163# also paths starting with '/' 1857# also paths starting with '/'
1164$EXT_MAP{"cf::map"} = [0, qr{^(?=/)}]; 1858$EXT_MAP{"cf::map::wrap"} = [0, qr{^(?=/)}];
1165 1859
1166sub thawer_merge { 1860sub thawer_merge {
1167 my ($self, $merge) = @_; 1861 my ($self, $merge) = @_;
1168 1862
1169 # we have to keep some variables in memory intact 1863 # we have to keep some variables in memory intact
1170 local $self->{path}; 1864 local $self->{path};
1171 local $self->{load_path}; 1865 local $self->{load_path};
1172 local $self->{deny_save};
1173 local $self->{deny_reset};
1174 1866
1175 $self->SUPER::thawer_merge ($merge); 1867 $self->SUPER::thawer_merge ($merge);
1176} 1868}
1177 1869
1178sub normalise { 1870sub normalise {
1179 my ($path, $base) = @_; 1871 my ($path, $base) = @_;
1180 1872
1181 $path = "$path"; # make sure its a string 1873 $path = "$path"; # make sure its a string
1874
1875 $path =~ s/\.map$//;
1182 1876
1183 # map plan: 1877 # map plan:
1184 # 1878 #
1185 # /! non-realised random map exit (special hack!) 1879 # /! non-realised random map exit (special hack!)
1186 # {... are special paths that are not being touched 1880 # {... are special paths that are not being touched
… …
1223 $self->init; # pass $1 etc. 1917 $self->init; # pass $1 etc.
1224 return $self; 1918 return $self;
1225 } 1919 }
1226 } 1920 }
1227 1921
1228 Carp::carp "unable to resolve path '$path' (base '$base')."; 1922 Carp::cluck "unable to resolve path '$path' (base '$base').";
1229 () 1923 ()
1230} 1924}
1231 1925
1232sub init { 1926sub init {
1233 my ($self) = @_; 1927 my ($self) = @_;
… …
1248 1942
1249# the original (read-only) location 1943# the original (read-only) location
1250sub load_path { 1944sub load_path {
1251 my ($self) = @_; 1945 my ($self) = @_;
1252 1946
1253 sprintf "%s/%s/%s", cf::datadir, cf::mapdir, $self->{path} 1947 "$MAPDIR/$self->{path}.map"
1254} 1948}
1255 1949
1256# the temporary/swap location 1950# the temporary/swap location
1257sub save_path { 1951sub save_path {
1258 my ($self) = @_; 1952 my ($self) = @_;
1259 1953
1260 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g; 1954 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/go;
1261 sprintf "%s/%s/%s", cf::localdir, cf::tmpdir, $path 1955 "$TMPDIR/$path.map"
1262} 1956}
1263 1957
1264# the unique path, undef == no special unique path 1958# the unique path, undef == no special unique path
1265sub uniq_path { 1959sub uniq_path {
1266 my ($self) = @_; 1960 my ($self) = @_;
1267 1961
1268 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g; 1962 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/go;
1269 sprintf "%s/%s/%s", cf::localdir, cf::uniquedir, $path 1963 "$UNIQUEDIR/$path"
1270} 1964}
1271 1965
1272# and all this just because we cannot iterate over 1966sub decay_objects {
1273# all maps in C++...
1274sub change_all_map_light {
1275 my ($change) = @_; 1967 my ($self) = @_;
1276 1968
1277 $_->change_map_light ($change) 1969 return if $self->{deny_reset};
1278 for grep $_->outdoor, values %cf::MAP; 1970
1971 $self->do_decay_objects;
1279} 1972}
1280 1973
1281sub unlink_save { 1974sub unlink_save {
1282 my ($self) = @_; 1975 my ($self) = @_;
1283 1976
… …
1288 1981
1289sub load_header_from($) { 1982sub load_header_from($) {
1290 my ($self, $path) = @_; 1983 my ($self, $path) = @_;
1291 1984
1292 utf8::encode $path; 1985 utf8::encode $path;
1293 aio_open $path, O_RDONLY, 0 1986 my $f = new_from_file cf::object::thawer $path
1294 or return; 1987 or return;
1295 1988
1296 $self->_load_header ($path) 1989 $self->_load_header ($f)
1297 or return; 1990 or return;
1991
1992 local $MAP_LOADING{$self->{path}} = $self;
1993 $f->resolve_delayed_derefs;
1298 1994
1299 $self->{load_path} = $path; 1995 $self->{load_path} = $path;
1300 1996
1301 1 1997 1
1302} 1998}
… …
1341 $self->load_header_orig 2037 $self->load_header_orig
1342 or return; 2038 or return;
1343 $self->prepare_orig; 2039 $self->prepare_orig;
1344 } 2040 }
1345 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
1346 1 2048 1
1347} 2049}
1348 2050
1349sub find; 2051sub find;
1350sub find { 2052sub find {
1351 my ($path, $origin) = @_; 2053 my ($path, $origin) = @_;
1352 2054
1353 $path = normalise $path, $origin && $origin->path; 2055 $path = normalise $path, $origin && $origin->path;
1354 2056
2057 my $guard1 = cf::lock_acquire "map_data:$path";#d#remove
1355 cf::lock_wait "map_find:$path"; 2058 my $guard2 = cf::lock_acquire "map_find:$path";
1356 2059
1357 $cf::MAP{$path} || do { 2060 $cf::MAP{$path} || do {
1358 my $guard = cf::lock_acquire "map_find:$path";
1359 my $map = new_from_path cf::map $path 2061 my $map = new_from_path cf::map $path
1360 or return; 2062 or return;
1361 2063
1362 $map->{last_save} = $cf::RUNTIME; 2064 $map->{last_save} = $cf::RUNTIME;
1363 2065
1364 $map->load_header 2066 $map->load_header
1365 or return; 2067 or return;
1366 2068
1367 if ($map->should_reset && 0) {#d#TODO# disabled, crashy (locking issue?) 2069 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?)
1368 # doing this can freeze the server in a sync job, obviously 2070 # doing this can freeze the server in a sync job, obviously
1369 #$cf::WAIT_FOR_TICK->wait; 2071 #$cf::WAIT_FOR_TICK->wait;
2072 undef $guard2;
2073 undef $guard1;
1370 $map->reset; 2074 $map->reset;
1371 undef $guard;
1372 return find $path; 2075 return find $path;
1373 } 2076 }
1374 2077
1375 $cf::MAP{$path} = $map 2078 $cf::MAP{$path} = $map
1376 } 2079 }
1377} 2080}
1378 2081
1379sub pre_load { } 2082sub pre_load { }
1380sub post_load { } 2083#sub post_load { } # XS
1381 2084
1382sub load { 2085sub load {
1383 my ($self) = @_; 2086 my ($self) = @_;
1384 2087
2088 local $self->{deny_reset} = 1; # loading can take a long time
2089
1385 my $path = $self->{path}; 2090 my $path = $self->{path};
2091
2092 {
1386 my $guard = cf::lock_acquire "map_load:$path"; 2093 my $guard = cf::lock_acquire "map_data:$path";
1387 2094
2095 return unless $self->valid;
1388 return if $self->in_memory != cf::MAP_SWAPPED; 2096 return unless $self->in_memory == cf::MAP_SWAPPED;
1389 2097
1390 $self->in_memory (cf::MAP_LOADING); 2098 $self->in_memory (cf::MAP_LOADING);
1391 2099
1392 $self->alloc; 2100 $self->alloc;
1393 2101
1394 $self->pre_load; 2102 $self->pre_load;
2103 cf::cede_to_tick;
1395 2104
1396 $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)
1397 or return; 2108 or return;
1398 2109
1399 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1) 2110 $self->post_load_original
1400 if delete $self->{load_original}; 2111 if delete $self->{load_original};
1401 2112
1402 if (my $uniq = $self->uniq_path) { 2113 if (my $uniq = $self->uniq_path) {
1403 utf8::encode $uniq; 2114 utf8::encode $uniq;
1404 if (aio_open $uniq, O_RDONLY, 0) { 2115 unless (aio_stat $uniq) {
2116 if (my $f = new_from_file cf::object::thawer $uniq) {
1405 $self->clear_unique_items; 2117 $self->clear_unique_items;
1406 $self->_load_objects ($uniq, 0); 2118 $self->_load_objects ($f);
2119 $f->resolve_delayed_derefs;
2120 }
1407 } 2121 }
1408 } 2122 }
1409 2123
1410 Coro::cede; 2124 $f->resolve_delayed_derefs;
1411 2125
2126 cf::cede_to_tick;
1412 # now do the right thing for maps 2127 # now do the right thing for maps
1413 $self->link_multipart_objects; 2128 $self->link_multipart_objects;
1414
1415 unless ($self->{deny_activate}) {
1416 $self->decay_objects;
1417 $self->fix_auto_apply;
1418 $self->update_buttons;
1419 Coro::cede;
1420 $self->set_darkness_map;
1421 $self->difficulty ($self->estimate_difficulty) 2129 $self->difficulty ($self->estimate_difficulty)
1422 unless $self->difficulty; 2130 unless $self->difficulty;
1423 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;
1424 $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);
1425 } 2145 }
1426 2146
1427 $self->post_load; 2147 $self->post_load;
1428
1429 $self->in_memory (cf::MAP_IN_MEMORY);
1430} 2148}
1431 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
1432sub customise_for { 2153sub customise_for {
1433 my ($self, $ob) = @_; 2154 my ($self, $ob) = @_;
1434 2155
1435 return find "~" . $ob->name . "/" . $self->{path} 2156 return find "~" . $ob->name . "/" . $self->{path}
1436 if $self->per_player; 2157 if $self->per_player;
1437 2158
2159# return find "?party/" . $ob->name . "/" . $self->{path}
2160# if $self->per_party;
2161
1438 $self 2162 $self
1439} 2163}
1440 2164
1441# 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
1442sub load_diag { 2166sub load_neighbours {
1443 my ($map) = @_; 2167 my ($map) = @_;
1444 2168
1445 my @diag; # diagonal neighbours 2169 my @neigh; # diagonal neighbours
1446 2170
1447 for (0 .. 3) { 2171 for (0 .. 3) {
1448 my $neigh = $map->tile_path ($_) 2172 my $neigh = $map->tile_path ($_)
1449 or next; 2173 or next;
1450 $neigh = find $neigh, $map 2174 $neigh = find $neigh, $map
1451 or next; 2175 or next;
1452 $neigh->load; 2176 $neigh->load;
1453 2177
2178 # now find the diagonal neighbours
2179 push @neigh,
1454 push @diag, [$neigh->tile_path (($_ + 3) % 4), $neigh], 2180 [$neigh->tile_path (($_ + 3) % 4), $neigh],
1455 [$neigh->tile_path (($_ + 1) % 4), $neigh]; 2181 [$neigh->tile_path (($_ + 1) % 4), $neigh];
1456 } 2182 }
1457 2183
1458 for (@diag) { 2184 for (grep defined $_->[0], @neigh) {
2185 my ($path, $origin) = @$_;
1459 my $neigh = find @$_ 2186 my $neigh = find $path, $origin
1460 or next; 2187 or next;
1461 $neigh->load; 2188 $neigh->load;
1462 } 2189 }
1463} 2190}
1464 2191
… …
1469} 2196}
1470 2197
1471sub do_load_sync { 2198sub do_load_sync {
1472 my ($map) = @_; 2199 my ($map) = @_;
1473 2200
2201 cf::LOG cf::llevDebug | cf::logBacktrace, "do_load_sync"
2202 if $Coro::current == $Coro::main;
2203
1474 cf::sync_job { $map->load }; 2204 cf::sync_job { $map->load };
1475} 2205}
1476 2206
1477our %MAP_PREFETCH; 2207our %MAP_PREFETCH;
1478our $MAP_PREFETCHER = undef; 2208our $MAP_PREFETCHER = undef;
1479 2209
1480sub find_async { 2210sub find_async {
1481 my ($path, $origin) = @_; 2211 my ($path, $origin, $load) = @_;
1482 2212
1483 $path = normalise $path, $origin && $origin->{path}; 2213 $path = normalise $path, $origin && $origin->{path};
1484 2214
1485 if (my $map = $cf::MAP{$path}) { 2215 if (my $map = $cf::MAP{$path}) {
1486 return $map if $map->in_memory == cf::MAP_IN_MEMORY; 2216 return $map if !$load || $map->in_memory == cf::MAP_ACTIVE;
1487 } 2217 }
1488 2218
1489 undef $MAP_PREFETCH{$path}; 2219 $MAP_PREFETCH{$path} |= $load;
2220
1490 $MAP_PREFETCHER ||= cf::async { 2221 $MAP_PREFETCHER ||= cf::async {
2222 $Coro::current->{desc} = "map prefetcher";
2223
1491 while (%MAP_PREFETCH) { 2224 while (%MAP_PREFETCH) {
1492 for my $path (keys %MAP_PREFETCH) { 2225 while (my ($k, $v) = each %MAP_PREFETCH) {
1493 my $map = find $path 2226 if (my $map = find $k) {
1494 or next;
1495 $map->load; 2227 $map->load if $v;
2228 }
1496 2229
1497 delete $MAP_PREFETCH{$path}; 2230 delete $MAP_PREFETCH{$k};
1498 } 2231 }
1499 } 2232 }
1500 undef $MAP_PREFETCHER; 2233 undef $MAP_PREFETCHER;
1501 }; 2234 };
1502 $MAP_PREFETCHER->prio (6); 2235 $MAP_PREFETCHER->prio (6);
1503 2236
1504 () 2237 ()
1505} 2238}
1506 2239
2240# common code, used by both ->save and ->swapout
1507sub save { 2241sub _save {
1508 my ($self) = @_; 2242 my ($self) = @_;
1509
1510 my $lock = cf::lock_acquire "map_data:" . $self->path;
1511 2243
1512 $self->{last_save} = $cf::RUNTIME; 2244 $self->{last_save} = $cf::RUNTIME;
1513 2245
1514 return unless $self->dirty; 2246 return unless $self->dirty;
1515 2247
… …
1521 return if $self->{deny_save}; 2253 return if $self->{deny_save};
1522 2254
1523 local $self->{last_access} = $self->last_access;#d# 2255 local $self->{last_access} = $self->last_access;#d#
1524 2256
1525 cf::async { 2257 cf::async {
2258 $Coro::current->{desc} = "map player save";
1526 $_->contr->save for $self->players; 2259 $_->contr->save for $self->players;
1527 }; 2260 };
2261
2262 cf::get_slot 0.02;
1528 2263
1529 if ($uniq) { 2264 if ($uniq) {
1530 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS); 2265 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS);
1531 $self->_save_objects ($uniq, cf::IO_UNIQUES); 2266 $self->_save_objects ($uniq, cf::IO_UNIQUES);
1532 } else { 2267 } else {
1533 $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);
1534 } 2269 }
1535} 2270}
1536 2271
2272sub save {
2273 my ($self) = @_;
2274
2275 my $lock = cf::lock_acquire "map_data:$self->{path}";
2276
2277 $self->_save;
2278}
2279
1537sub swap_out { 2280sub swap_out {
1538 my ($self) = @_; 2281 my ($self) = @_;
1539 2282
1540 # save first because save cedes
1541 $self->save;
1542
1543 my $lock = cf::lock_acquire "map_data:" . $self->path; 2283 my $lock = cf::lock_acquire "map_data:$self->{path}";
1544 2284
2285 return if $self->in_memory != cf::MAP_ACTIVE;
2286 return if $self->{deny_save};
1545 return if $self->players; 2287 return if $self->players;
1546 return if $self->in_memory != cf::MAP_IN_MEMORY;
1547 return if $self->{deny_save};
1548 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
1549 $self->clear; 2298 $self->clear;
1550 $self->in_memory (cf::MAP_SWAPPED);
1551} 2299}
1552 2300
1553sub reset_at { 2301sub reset_at {
1554 my ($self) = @_; 2302 my ($self) = @_;
1555 2303
1556 # TODO: safety, remove and allow resettable per-player maps 2304 # TODO: safety, remove and allow resettable per-player maps
1557 return 1e99 if $self->isa ("ext::map_per_player");#d#
1558 return 1e99 if $self->{deny_reset}; 2305 return 1e99 if $self->{deny_reset};
1559 2306
1560 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access; 2307 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
1561 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;
1562 2309
… …
1573 my ($self) = @_; 2320 my ($self) = @_;
1574 2321
1575 my $lock = cf::lock_acquire "map_data:$self->{path}"; 2322 my $lock = cf::lock_acquire "map_data:$self->{path}";
1576 2323
1577 return if $self->players; 2324 return if $self->players;
1578 return if $self->isa ("ext::map_per_player");#d#
1579 2325
1580 warn "resetting map ", $self->path;#d# 2326 cf::trace "resetting map ", $self->path, "\n";
2327
2328 $self->in_memory (cf::MAP_SWAPPED);
2329
2330 # need to save uniques path
2331 unless ($self->{deny_save}) {
2332 my $uniq = $self->uniq_path; utf8::encode $uniq;
2333
2334 $self->_save_objects ($uniq, cf::IO_UNIQUES)
2335 if $uniq;
2336 }
1581 2337
1582 delete $cf::MAP{$self->path}; 2338 delete $cf::MAP{$self->path};
1583 2339
1584 $self->in_memory (cf::MAP_SWAPPED); 2340 $self->deactivate;
2341 $_->clear_links_to ($self) for values %cf::MAP;
1585 $self->clear; 2342 $self->clear;
1586
1587 $_->clear_links_to ($self) for values %cf::MAP;
1588 2343
1589 $self->unlink_save; 2344 $self->unlink_save;
1590 $self->destroy; 2345 $self->destroy;
1591} 2346}
1592 2347
1593my $nuke_counter = "aaaa"; 2348my $nuke_counter = "aaaa";
1594 2349
1595sub nuke { 2350sub nuke {
1596 my ($self) = @_; 2351 my ($self) = @_;
1597 2352
2353 {
2354 my $lock = cf::lock_acquire "map_data:$self->{path}";
2355
1598 delete $cf::MAP{$self->path}; 2356 delete $cf::MAP{$self->path};
1599 2357
1600 $self->unlink_save; 2358 $self->unlink_save;
1601 2359
1602 bless $self, "cf::map"; 2360 bless $self, "cf::map::wrap";
1603 delete $self->{deny_reset}; 2361 delete $self->{deny_reset};
1604 $self->{deny_save} = 1; 2362 $self->{deny_save} = 1;
1605 $self->reset_timeout (1); 2363 $self->reset_timeout (1);
1606 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++)); 2364 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));
1607 2365
1608 $cf::MAP{$self->path} = $self; 2366 $cf::MAP{$self->path} = $self;
2367 }
1609 2368
1610 $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 ]
1611} 2406}
1612 2407
1613=item cf::map::unique_maps 2408=item cf::map::unique_maps
1614 2409
1615Returns an arrayref of paths of all shared maps that have 2410Returns an arrayref of paths of all shared maps that have
1616instantiated unique items. May block. 2411instantiated unique items. May block.
1617 2412
1618=cut 2413=cut
1619 2414
1620sub unique_maps() { 2415sub unique_maps() {
1621 my $files = aio_readdir cf::localdir . "/" . cf::uniquedir 2416 [
1622 or return; 2417 map {
1623
1624 my @paths;
1625
1626 for (@$files) {
1627 utf8::decode $_; 2418 utf8::decode $_;
1628 next if /\.pst$/; 2419 s/\.map$//; # TODO future compatibility hack
1629 next unless /^$PATH_SEP/o; 2420 /\.pst$/ || !/^$PATH_SEP/o # TODO unique maps apparebntly lack the .map suffix :/
2421 ? ()
2422 : normalise $_
2423 } @{ aio_readdir $UNIQUEDIR or [] }
2424 ]
2425}
1630 2426
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) {
1631 s/\.map$//; 2448 s/\.map$// or next;
1632 push @paths, $_; 2449 utf8::decode $_;
1633 } 2450 push @maps, "$dir/$_";
2451 }
1634 2452
1635 \@paths 2453 push @dirs, map "$dir/$_", @$dirs;
1636} 2454 }
1637 2455
1638package cf; 2456 \@maps
2457}
1639 2458
1640=back 2459=back
1641 2460
1642=head3 cf::object 2461=head3 cf::object
1643 2462
… …
1647 2466
1648=over 4 2467=over 4
1649 2468
1650=item $ob->inv_recursive 2469=item $ob->inv_recursive
1651 2470
1652Returns 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.
1653 2473
1654=cut 2474=cut
1655 2475
1656sub inv_recursive_; 2476sub inv_recursive_;
1657sub inv_recursive_ { 2477sub inv_recursive_ {
… …
1660 2480
1661sub inv_recursive { 2481sub inv_recursive {
1662 inv_recursive_ inv $_[0] 2482 inv_recursive_ inv $_[0]
1663} 2483}
1664 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
1665package cf; 2513package cf;
1666 2514
1667=back 2515=back
1668 2516
1669=head3 cf::object::player 2517=head3 cf::object::player
… …
1675Sends 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>
1676can 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
1677dialogue with the given NPC character. 2525dialogue with the given NPC character.
1678 2526
1679=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};
1680 2542
1681# rough implementation of a future "reply" method that works 2543# rough implementation of a future "reply" method that works
1682# with dialog boxes. 2544# with dialog boxes.
1683#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
1684sub cf::object::player::reply($$$;$) { 2546sub cf::object::player::reply($$$;$) {
… …
1686 2548
1687 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4; 2549 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4;
1688 2550
1689 if ($self->{record_replies}) { 2551 if ($self->{record_replies}) {
1690 push @{ $self->{record_replies} }, [$npc, $msg, $flags]; 2552 push @{ $self->{record_replies} }, [$npc, $msg, $flags];
2553
1691 } 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 {
1692 $msg = $npc->name . " says: $msg" if $npc; 2562 $msg = $npc->name . " says: $msg" if $npc;
1693 $self->message ($msg, $flags); 2563 $self->send_msg ($SAY_CHANNEL => $msg, $flags);
2564 }
1694 } 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 (@_);
1695} 2576}
1696 2577
1697=item $player_object->may ("access") 2578=item $player_object->may ("access")
1698 2579
1699Returns wether the given player is authorized to access resource "access" 2580Returns wether the given player is authorized to access resource "access"
… …
1712 2593
1713=item $player_object->enter_link 2594=item $player_object->enter_link
1714 2595
1715Freezes 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}>).
1716 2597
1717The 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.
1718I<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.
1719 2602
1720Will never block. 2603Will never block.
1721 2604
1722=item $player_object->leave_link ($map, $x, $y) 2605=item $player_object->leave_link ($map, $x, $y)
1723 2606
… …
1731=cut 2614=cut
1732 2615
1733sub link_map { 2616sub link_map {
1734 unless ($LINK_MAP) { 2617 unless ($LINK_MAP) {
1735 $LINK_MAP = cf::map::find "{link}" 2618 $LINK_MAP = cf::map::find "{link}"
1736 or do { warn "FATAL: unable to provide {link} map, exiting."; exit 1 }; 2619 or cf::cleanup "FATAL: unable to provide {link} map, exiting.";
1737 $LINK_MAP->load; 2620 $LINK_MAP->load;
1738 } 2621 }
1739 2622
1740 $LINK_MAP 2623 $LINK_MAP
1741} 2624}
… …
1743sub cf::object::player::enter_link { 2626sub cf::object::player::enter_link {
1744 my ($self) = @_; 2627 my ($self) = @_;
1745 2628
1746 $self->deactivate_recursive; 2629 $self->deactivate_recursive;
1747 2630
2631 ++$self->{_link_recursion};
2632
1748 return if UNIVERSAL::isa $self->map, "ext::map_link"; 2633 return if UNIVERSAL::isa $self->map, "ext::map_link";
1749 2634
1750 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y] 2635 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y]
1751 if $self->map; 2636 if $self->map && $self->map->{path} ne "{link}";
1752 2637
1753 $self->enter_map ($LINK_MAP || link_map, 10, 10); 2638 $self->enter_map ($LINK_MAP || link_map, 3, 3);
1754} 2639}
1755 2640
1756sub cf::object::player::leave_link { 2641sub cf::object::player::leave_link {
1757 my ($self, $map, $x, $y) = @_; 2642 my ($self, $map, $x, $y) = @_;
2643
2644 return unless $self->contr->active;
1758 2645
1759 my $link_pos = delete $self->{_link_pos}; 2646 my $link_pos = delete $self->{_link_pos};
1760 2647
1761 unless ($map) { 2648 unless ($map) {
1762 # restore original map position 2649 # restore original map position
… …
1773 ($x, $y) = (-1, -1) 2660 ($x, $y) = (-1, -1)
1774 unless (defined $x) && (defined $y); 2661 unless (defined $x) && (defined $y);
1775 2662
1776 # use -1 or undef as default coordinates, not 0, 0 2663 # use -1 or undef as default coordinates, not 0, 0
1777 ($x, $y) = ($map->enter_x, $map->enter_y) 2664 ($x, $y) = ($map->enter_x, $map->enter_y)
1778 if $x <=0 && $y <= 0; 2665 if $x <= 0 && $y <= 0;
1779 2666
1780 $map->load; 2667 $map->load;
1781 $map->load_diag; 2668 $map->load_neighbours;
1782 2669
1783 return unless $self->contr->active; 2670 return unless $self->contr->active;
2671
2672 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
2673 if ($self->enter_map ($map, $x, $y)) {
2674 # entering was successful
2675 delete $self->{_link_recursion};
2676 # only activate afterwards, to support waiting in hooks
1784 $self->activate_recursive; 2677 $self->activate_recursive;
1785 $self->enter_map ($map, $x, $y);
1786}
1787
1788cf::player->attach (
1789 on_logout => sub {
1790 my ($pl) = @_;
1791
1792 # abort map switching before logout
1793 if ($pl->ob->{_link_pos}) {
1794 cf::sync_job {
1795 $pl->ob->leave_link
1796 };
1797 }
1798 }, 2678 }
1799 on_login => sub {
1800 my ($pl) = @_;
1801 2679
1802 # try to abort aborted map switching on player login :) 2680}
1803 # should happen only on crashes
1804 if ($pl->ob->{_link_pos}) {
1805 $pl->ob->enter_link;
1806 (async {
1807 # we need this sleep as the login has a concurrent enter_exit running
1808 # and this sleep increases chances of the player not ending up in scorn
1809 $pl->ob->reply (undef,
1810 "There was an internal problem at your last logout, "
1811 . "the server will try to bring you to your intended destination in a second.",
1812 cf::NDI_RED);
1813 Coro::Timer::sleep 1;
1814 $pl->ob->leave_link;
1815 })->prio (2);
1816 }
1817 },
1818);
1819 2681
1820=item $player_object->goto ($path, $x, $y) 2682=item $player_object->goto ($path, $x, $y[, $check->($map, $x, $y, $player)[, $done->($player)]])
1821 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
1822=cut 2693=cut
2694
2695our $GOTOGEN;
1823 2696
1824sub cf::object::player::goto { 2697sub cf::object::player::goto {
1825 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;
1826 2708
1827 $self->enter_link; 2709 $self->enter_link;
1828 2710
1829 (async { 2711 (async {
1830 my $map = cf::map::find $path; 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
2733 my $map = eval {
2734 my $map = defined $path ? cf::map::find $path : undef;
2735
2736 if ($map) {
1831 $map = $map->customise_for ($self) if $map; 2737 $map = $map->customise_for ($self);
1832 2738 $map = $check->($map, $x, $y, $self) if $check && $map;
1833# warn "entering ", $map->path, " at ($x, $y)\n" 2739 } else {
1834# if $map;
1835
1836 $map or $self->message ("The exit to '" . ($path->visible_name) . "' is closed", cf::NDI_UNIQUE | cf::NDI_RED); 2740 $self->message ("The exit to '$path' is closed.", cf::NDI_UNIQUE | cf::NDI_RED);
2741 }
1837 2742
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 $@;
2749 }
2750
2751 if ($gen == $self->{_goto_generation}) {
2752 delete $self->{_goto_generation};
1838 $self->leave_link ($map, $x, $y); 2753 $self->leave_link ($map, $x, $y);
2754 }
2755
2756 $done->($self) if $done;
1839 })->prio (1); 2757 })->prio (1);
1840} 2758}
1841 2759
1842=item $player_object->enter_exit ($exit_object) 2760=item $player_object->enter_exit ($exit_object)
1843 2761
… …
1863} 2781}
1864 2782
1865sub prepare_random_map { 2783sub prepare_random_map {
1866 my ($exit) = @_; 2784 my ($exit) = @_;
1867 2785
1868 my $guard = cf::lock_acquire "exit_prepare:$exit";
1869
1870 # all this does is basically replace the /! path by 2786 # all this does is basically replace the /! path by
1871 # a new random map path (?random/...) with a seed 2787 # a new random map path (?random/...) with a seed
1872 # that depends on the exit object 2788 # that depends on the exit object
1873 2789
1874 my $rmp = parse_random_map_params $exit->msg; 2790 my $rmp = parse_random_map_params $exit->msg;
1875 2791
1876 if ($exit->map) { 2792 if ($exit->map) {
1877 $rmp->{region} = $exit->map->region_name; 2793 $rmp->{region} = $exit->region->name;
1878 $rmp->{origin_map} = $exit->map->path; 2794 $rmp->{origin_map} = $exit->map->path;
1879 $rmp->{origin_x} = $exit->x; 2795 $rmp->{origin_x} = $exit->x;
1880 $rmp->{origin_y} = $exit->y; 2796 $rmp->{origin_y} = $exit->y;
2797
2798 $exit->map->touch;
1881 } 2799 }
1882 2800
1883 $rmp->{random_seed} ||= $exit->random_seed; 2801 $rmp->{random_seed} ||= $exit->random_seed;
1884 2802
1885 my $data = cf::to_json $rmp; 2803 my $data = JSON::XS->new->utf8->pretty->canonical->encode ($rmp);
1886 my $md5 = Digest::MD5::md5_hex $data; 2804 my $md5 = Digest::MD5::md5_hex $data;
1887 my $meta = "$cf::RANDOM_MAPS/$md5.meta"; 2805 my $meta = "$RANDOMDIR/$md5.meta";
1888 2806
1889 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) { 2807 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) {
1890 aio_write $fh, 0, (length $data), $data, 0; 2808 aio_write $fh, 0, (length $data), $data, 0;
1891 undef $fh; 2809 undef $fh;
1892 aio_rename "$meta~", $meta; 2810 aio_rename "$meta~", $meta;
1893 2811
2812 my $slaying = "?random/$md5";
2813
2814 if ($exit->valid) {
1894 $exit->slaying ("?random/$md5"); 2815 $exit->slaying ("?random/$md5");
1895 $exit->msg (undef); 2816 $exit->msg (undef);
2817 }
1896 } 2818 }
1897} 2819}
1898 2820
1899sub cf::object::player::enter_exit { 2821sub cf::object::player::enter_exit {
1900 my ($self, $exit) = @_; 2822 my ($self, $exit) = @_;
1901 2823
1902 return unless $self->type == cf::PLAYER; 2824 return unless $self->type == cf::PLAYER;
1903 2825
1904 if ($exit->slaying eq "/!") {
1905 #TODO: this should de-fi-ni-te-ly not be a sync-job
1906 cf::sync_job { prepare_random_map $exit };
1907 }
1908
1909 my $slaying = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path;
1910 my $hp = $exit->stats->hp;
1911 my $sp = $exit->stats->sp;
1912
1913 $self->enter_link; 2826 $self->enter_link;
1914 2827
1915 (async { 2828 (async {
1916 $self->deactivate_recursive; # just to be sure 2829 $Coro::current->{desc} = "enter_exit";
2830
1917 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
1918 $self->goto ($slaying, $hp, $sp); 2846 $self->goto ($map, $x, $y);
1919 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
1920 1; 2852 1
1921 }) { 2853 }) {
1922 $self->message ("Something went wrong deep within the crossfire server. " 2854 $self->message ("Something went wrong deep within the deliantra server. "
1923 . "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. "
1924 . "Please report this to the dungeon master!", 2856 . "Please report this to the dungeon master!",
1925 cf::NDI_UNIQUE | cf::NDI_RED); 2857 cf::NDI_UNIQUE | cf::NDI_RED);
1926 2858
1927 warn "ERROR in enter_exit: $@"; 2859 error "ERROR in enter_exit: $@";
1928 $self->leave_link; 2860 $self->leave_link;
1929 } 2861 }
1930 })->prio (1); 2862 })->prio (1);
1931} 2863}
1932 2864
… …
1943 2875
1944sub cf::client::send_drawinfo { 2876sub cf::client::send_drawinfo {
1945 my ($self, $text, $flags) = @_; 2877 my ($self, $text, $flags) = @_;
1946 2878
1947 utf8::encode $text; 2879 utf8::encode $text;
1948 $self->send_packet (sprintf "drawinfo %d %s", $flags, $text); 2880 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);
1949} 2881}
1950 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}
1951 3104
1952=item $success = $client->query ($flags, "text", \&cb) 3105=item $success = $client->query ($flags, "text", \&cb)
1953 3106
1954Queues a query to the client, calling the given callback with 3107Queues a query to the client, calling the given callback with
1955the 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>,
1956C<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>.
1957 3110
1958Queries 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
1959reliable at some point in the future. 3112become reliable at some point in the future.
1960 3113
1961=cut 3114=cut
1962 3115
1963sub cf::client::query { 3116sub cf::client::query {
1964 my ($self, $flags, $text, $cb) = @_; 3117 my ($self, $flags, $text, $cb) = @_;
… …
1972 utf8::encode $text; 3125 utf8::encode $text;
1973 push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb]; 3126 push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb];
1974 3127
1975 $self->send_packet ($self->{query_queue}[0][0]) 3128 $self->send_packet ($self->{query_queue}[0][0])
1976 if @{ $self->{query_queue} } == 1; 3129 if @{ $self->{query_queue} } == 1;
3130
3131 1
1977} 3132}
1978 3133
1979cf::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 },
1980 on_reply => sub { 3140 on_reply => sub {
1981 my ($ns, $msg) = @_; 3141 my ($ns, $msg) = @_;
1982 3142
1983 # this weird shuffling is so that direct followup queries 3143 # this weird shuffling is so that direct followup queries
1984 # get handled first 3144 # get handled first
1985 my $queue = delete $ns->{query_queue} 3145 my $queue = delete $ns->{query_queue}
1986 or return; # be conservative, not sure how that can happen, but we saw a crash here 3146 or return; # be conservative, not sure how that can happen, but we saw a crash here
1987 3147
1988 (shift @$queue)->[1]->($msg); 3148 (shift @$queue)->[1]->($msg);
3149 return unless $ns->valid; # temporary(?) workaround for callback destroying socket
1989 3150
1990 push @{ $ns->{query_queue} }, @$queue; 3151 push @{ $ns->{query_queue} }, @$queue;
1991 3152
1992 if (@{ $ns->{query_queue} } == @$queue) { 3153 if (@{ $ns->{query_queue} } == @$queue) {
1993 if (@$queue) { 3154 if (@$queue) {
… …
1995 } else { 3156 } else {
1996 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM; 3157 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM;
1997 } 3158 }
1998 } 3159 }
1999 }, 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 },
2000); 3187);
2001 3188
2002=item $client->async (\&cb) 3189=item $client->async (\&cb)
2003 3190
2004Create a new coroutine, running the specified callback. The coroutine will 3191Create a new coroutine, running the specified callback. The coroutine will
… …
2020 3207
2021 $coro 3208 $coro
2022} 3209}
2023 3210
2024cf::client->attach ( 3211cf::client->attach (
2025 on_destroy => sub { 3212 on_client_destroy => sub {
2026 my ($ns) = @_; 3213 my ($ns) = @_;
2027 3214
2028 $_->cancel for values %{ (delete $ns->{_coro}) || {} }; 3215 $_->cancel for values %{ (delete $ns->{_coro}) || {} };
2029 }, 3216 },
2030); 3217);
… …
2045our $safe = new Safe "safe"; 3232our $safe = new Safe "safe";
2046our $safe_hole = new Safe::Hole; 3233our $safe_hole = new Safe::Hole;
2047 3234
2048$SIG{FPE} = 'IGNORE'; 3235$SIG{FPE} = 'IGNORE';
2049 3236
2050$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));
2051 3242
2052# here we export the classes and methods available to script code 3243# here we export the classes and methods available to script code
2053 3244
2054=pod 3245=pod
2055 3246
2056The following fucntions and emthods are available within a safe environment: 3247The following functions and methods are available within a safe environment:
2057 3248
2058 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
2059 cf::object::player player 3254 cf::object::player
2060 cf::player peaceful 3255 player
2061 cf::map trigger 3256
3257 cf::player
3258 peaceful
3259
3260 cf::map
3261 trigger
2062 3262
2063=cut 3263=cut
2064 3264
2065for ( 3265for (
2066 ["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)],
2067 ["cf::object::player" => qw(player)], 3269 ["cf::object::player" => qw(player)],
2068 ["cf::player" => qw(peaceful)], 3270 ["cf::player" => qw(peaceful send_msg)],
2069 ["cf::map" => qw(trigger)], 3271 ["cf::map" => qw(trigger)],
2070) { 3272) {
2071 no strict 'refs'; 3273 no strict 'refs';
2072 my ($pkg, @funs) = @$_; 3274 my ($pkg, @funs) = @$_;
2073 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"}) 3275 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})
… …
2091 3293
2092 my $qcode = $code; 3294 my $qcode = $code;
2093 $qcode =~ s/"/‟/g; # not allowed in #line filenames 3295 $qcode =~ s/"/‟/g; # not allowed in #line filenames
2094 $qcode =~ s/\n/\\n/g; 3296 $qcode =~ s/\n/\\n/g;
2095 3297
3298 %vars = (_dummy => 0) unless %vars;
3299
3300 my @res;
2096 local $_; 3301 local $_;
2097 local @safe::cf::_safe_eval_args = values %vars;
2098 3302
2099 my $eval = 3303 my $eval =
2100 "do {\n" 3304 "do {\n"
2101 . "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n" 3305 . "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n"
2102 . "#line 0 \"{$qcode}\"\n" 3306 . "#line 0 \"{$qcode}\"\n"
2103 . $code 3307 . $code
2104 . "\n}" 3308 . "\n}"
2105 ; 3309 ;
2106 3310
3311 if ($CFG{safe_eval}) {
2107 sub_generation_inc; 3312 sub_generation_inc;
3313 local @safe::cf::_safe_eval_args = values %vars;
2108 my @res = wantarray ? $safe->reval ($eval) : scalar $safe->reval ($eval); 3314 @res = wantarray ? $safe->reval ($eval) : scalar $safe->reval ($eval);
2109 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 }
2110 3320
2111 if ($@) { 3321 if ($@) {
2112 warn "$@"; 3322 warn "$@",
2113 warn "while executing safe code '$code'\n"; 3323 "while executing safe code '$code'\n",
2114 warn "with arguments " . (join " ", %vars) . "\n"; 3324 "with arguments " . (join " ", %vars) . "\n";
2115 } 3325 }
2116 3326
2117 wantarray ? @res : $res[0] 3327 wantarray ? @res : $res[0]
2118} 3328}
2119 3329
… …
2133=cut 3343=cut
2134 3344
2135sub register_script_function { 3345sub register_script_function {
2136 my ($fun, $cb) = @_; 3346 my ($fun, $cb) = @_;
2137 3347
2138 no strict 'refs'; 3348 $fun = "safe::$fun" if $CFG{safe_eval};
2139 *{"safe::$fun"} = $safe_hole->wrap ($cb); 3349 *$fun = $safe_hole->wrap ($cb);
2140} 3350}
2141 3351
2142=back 3352=back
2143 3353
2144=cut 3354=cut
2145 3355
2146############################################################################# 3356#############################################################################
3357# the server's init and main functions
2147 3358
2148=head2 EXTENSION DATABASE SUPPORT 3359sub load_facedata($) {
3360 my ($path) = @_;
2149 3361
2150Crossfire maintains a very simple database for extension use. It can 3362 # HACK to clear player env face cache, we need some signal framework
2151currently store anything that can be serialised using Storable, which 3363 # for this (global event?)
2152excludes objects. 3364 %ext::player_env::MUSIC_FACE_CACHE = ();
2153 3365
2154The parameter C<$family> should best start with the name of the extension 3366 my $enc = JSON::XS->new->utf8->canonical->relaxed;
2155using it, it should be unique.
2156 3367
2157=over 4 3368 trace "loading facedata from $path\n";
2158 3369
2159=item $hashref = cf::db_get $family 3370 my $facedata;
3371 0 < aio_load $path, $facedata
3372 or die "$path: $!";
2160 3373
2161Return a hashref for use by the extension C<$family>, which can be 3374 $facedata = Coro::Storable::thaw $facedata;
2162modified. After modifications, you have to call C<cf::db_dirty> or
2163C<cf::db_sync>.
2164 3375
2165=item $value = cf::db_get $family => $key 3376 $facedata->{version} == 2
3377 or cf::cleanup "$path: version mismatch, cannot proceed.";
2166 3378
2167Returns a single value from the database 3379 # patch in the exptable
2168 3380 my $exp_table = $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]);
2169=item cf::db_put $family => $hashref 3381 $facedata->{resource}{"res/exp_table"} = {
2170 3382 type => FT_RSRC,
2171Stores the given family hashref into the database. Updates are delayed, if 3383 data => $exp_table,
2172you want the data to be synced to disk immediately, use C<cf::db_sync>. 3384 hash => (Digest::MD5::md5 $exp_table),
2173
2174=item cf::db_put $family => $key => $value
2175
2176Stores the given C<$value> in the family hash. Updates are delayed, if you
2177want the data to be synced to disk immediately, use C<cf::db_sync>.
2178
2179=item cf::db_dirty
2180
2181Marks the database as dirty, to be updated at a later time.
2182
2183=item cf::db_sync
2184
2185Immediately write the database to disk I<if it is dirty>.
2186
2187=cut
2188
2189our $DB;
2190
2191{
2192 my $path = cf::localdir . "/database.pst";
2193
2194 sub db_load() {
2195 $DB = stat $path ? Storable::retrieve $path : { };
2196 } 3385 };
3386 cf::cede_to_tick;
2197 3387
2198 my $pid;
2199
2200 sub db_save() {
2201 waitpid $pid, 0 if $pid;
2202 if (0 == ($pid = fork)) {
2203 $DB->{_meta}{version} = 1;
2204 Storable::nstore $DB, "$path~";
2205 rename "$path~", $path;
2206 cf::_exit 0 if defined $pid;
2207 }
2208 } 3388 {
3389 my $faces = $facedata->{faceinfo};
2209 3390
2210 my $dirty; 3391 while (my ($face, $info) = each %$faces) {
3392 my $idx = (cf::face::find $face) || cf::face::alloc $face;
2211 3393
2212 sub db_sync() { 3394 cf::face::set_visibility $idx, $info->{visibility};
2213 db_save if $dirty; 3395 cf::face::set_magicmap $idx, $info->{magicmap};
2214 undef $dirty; 3396 cf::face::set_data $idx, 0, $info->{data32}, $info->{hash32};
2215 } 3397 cf::face::set_data $idx, 1, $info->{data64}, $info->{hash64};
2216 3398
2217 my $idle = Event->idle ( 3399 cf::cede_to_tick;
2218 reentrant => 0,
2219 min => 10,
2220 max => 20,
2221 repeat => 0,
2222 data => WF_AUTOCANCEL,
2223 cb => \&db_sync,
2224 );
2225
2226 sub db_dirty() {
2227 $dirty = 1;
2228 $idle->start;
2229 }
2230
2231 sub db_get($;$) {
2232 @_ >= 2
2233 ? $DB->{$_[0]}{$_[1]}
2234 : ($DB->{$_[0]} ||= { })
2235 }
2236
2237 sub db_put($$;$) {
2238 if (@_ >= 3) {
2239 $DB->{$_[0]}{$_[1]} = $_[2];
2240 } else {
2241 $DB->{$_[0]} = $_[1];
2242 }
2243 db_dirty;
2244 }
2245
2246 cf::global->attach (
2247 prio => 10000,
2248 on_cleanup => sub {
2249 db_sync;
2250 }, 3400 }
2251 );
2252}
2253 3401
2254############################################################################# 3402 while (my ($face, $info) = each %$faces) {
2255# the server's main() 3403 next unless $info->{smooth};
2256 3404
2257sub cfg_load { 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"
3476 or die "unable to load regions file\n";
3477
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
2258 open my $fh, "<:utf8", cf::confdir . "/config" 3537 open my $fh, "<:utf8", "$CONFDIR/config"
2259 or return; 3538 or return;
2260 3539
2261 local $/; 3540 local $/;
2262 *CFG = YAML::Syck::Load <$fh>; 3541 *CFG = YAML::XS::Load scalar <$fh>;
2263 3542
2264 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37]; 3543 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_104_115", 49, 38];
2265 3544
2266 $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};
2267 $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};
2268 3547
2269 if (exists $CFG{mlockall}) { 3548 if (exists $CFG{mlockall}) {
… …
2271 $CFG{mlockall} ? eval "mlockall()" : eval "munlockall()" 3550 $CFG{mlockall} ? eval "mlockall()" : eval "munlockall()"
2272 and die "WARNING: m(un)lockall failed: $!\n"; 3551 and die "WARNING: m(un)lockall failed: $!\n";
2273 }; 3552 };
2274 warn $@ if $@; 3553 warn $@ if $@;
2275 } 3554 }
3555
3556 trace "finished reloading resource files\n";
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;
2276} 3585}
2277 3586
2278sub 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
2279 # we must not ever block the main coroutine 3597 # we must not ever block the main coroutine
2280 local $Coro::idle = sub { 3598 local $Coro::idle = sub {
2281 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#
2282 (async { 3600 (async {
2283 Event::one_event; 3601 $Coro::current->{desc} = "IDLE BUG HANDLER";
3602 EV::loop EV::LOOP_ONESHOT;
2284 })->prio (Coro::PRIO_MAX); 3603 })->prio (Coro::PRIO_MAX);
2285 }; 3604 };
2286 3605
2287 cfg_load; 3606 evthread_start IO::AIO::poll_fileno;
2288 db_load; 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;
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
2289 load_extensions; 3629 load_extensions;
2290 3630
2291 $TICK_WATCHER->start; 3631 utime time, time, $RUNTIMEFILE;
2292 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;
2293} 3644}
2294 3645
2295############################################################################# 3646#############################################################################
2296# initialisation and cleanup 3647# initialisation and cleanup
2297 3648
2298# install some emergency cleanup handlers 3649# install some emergency cleanup handlers
2299BEGIN { 3650BEGIN {
3651 our %SIGWATCHER = ();
2300 for my $signal (qw(INT HUP TERM)) { 3652 for my $signal (qw(INT HUP TERM)) {
2301 Event->signal ( 3653 $SIGWATCHER{$signal} = AE::signal $signal, sub {
2302 reentrant => 0,
2303 data => WF_AUTOCANCEL,
2304 signal => $signal,
2305 prio => 0,
2306 cb => sub {
2307 cf::cleanup "SIG$signal"; 3654 cf::cleanup "SIG$signal";
2308 },
2309 ); 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
2310 } 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 };
2311} 3745}
2312 3746
2313sub emergency_save() { 3747sub emergency_save() {
2314 my $freeze_guard = cf::freeze_mainloop; 3748 my $freeze_guard = cf::freeze_mainloop;
2315 3749
2316 warn "enter emergency perl save\n"; 3750 info "emergency_perl_save: enter\n";
2317 3751
2318 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
2319 # use a peculiar iteration method to avoid tripping on perl 3758 # use a peculiar iteration method to avoid tripping on perl
2320 # refcount bugs in for. also avoids problems with players 3759 # refcount bugs in for. also avoids problems with players
2321 # and maps saved/destroyed asynchronously. 3760 # and maps saved/destroyed asynchronously.
2322 warn "begin emergency player save\n"; 3761 info "emergency_perl_save: begin player save\n";
2323 for my $login (keys %cf::PLAYER) { 3762 for my $login (keys %cf::PLAYER) {
2324 my $pl = $cf::PLAYER{$login} or next; 3763 my $pl = $cf::PLAYER{$login} or next;
2325 $pl->valid or next; 3764 $pl->valid or next;
3765 delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt
2326 $pl->save; 3766 $pl->save;
2327 } 3767 }
2328 warn "end emergency player save\n"; 3768 info "emergency_perl_save: end player save\n";
2329 3769
2330 warn "begin emergency map save\n"; 3770 info "emergency_perl_save: begin map save\n";
2331 for my $path (keys %cf::MAP) { 3771 for my $path (keys %cf::MAP) {
2332 my $map = $cf::MAP{$path} or next; 3772 my $map = $cf::MAP{$path} or next;
2333 $map->valid or next; 3773 $map->valid or next;
2334 $map->save; 3774 $map->save;
2335 } 3775 }
2336 warn "end emergency map save\n"; 3776 info "emergency_perl_save: end map save\n";
3777
3778 info "emergency_perl_save: begin database checkpoint\n";
3779 BDB::db_env_txn_checkpoint $DB_ENV;
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";
2337 }; 3785 };
2338 3786
2339 warn "leave emergency perl save\n"; 3787 info "emergency_perl_save: starting sync()\n";
2340} 3788 IO::AIO::aio_sync sub {
3789 info "emergency_perl_save: finished sync()\n";
3790 };
2341 3791
3792 info "emergency_perl_save: leave\n";
3793}
3794
3795sub post_cleanup {
3796 my ($make_core) = @_;
3797
3798 error Carp::longmess "post_cleanup backtrace"
3799 if $make_core;
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
2342sub reload() { 3830sub do_reload_perl() {
2343 # can/must only be called in main 3831 # can/must only be called in main
2344 if ($Coro::current != $Coro::main) { 3832 if (in_main) {
2345 warn "can only reload from main coroutine"; 3833 error "can only reload from main coroutine";
2346 return; 3834 return;
2347 } 3835 }
2348 3836
3837 return if $RELOAD++;
3838
3839 my $t1 = AE::time;
3840
3841 while ($RELOAD) {
2349 warn "reloading..."; 3842 info "reloading...";
2350 3843
2351 warn "cancelling server ticker"; 3844 trace "entering sync_job";
2352 $TICK_WATCHER->cancel;
2353 3845
3846 cf::sync_job {
3847 cf::write_runtime_sync; # external watchdog should not bark
2354 cf::emergency_save; 3848 cf::emergency_save;
3849 cf::write_runtime_sync; # external watchdog should not bark
2355 3850
2356 eval { 3851 trace "syncing database to disk";
3852 BDB::db_env_txn_checkpoint $DB_ENV;
3853
2357 # 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
2358 3855
2359 warn "syncing database to disk";
2360 cf::db_sync;
2361
2362 warn "cancelling all WF_AUTOCANCEL watchers";
2363 for (Event::all_watchers) {
2364 $_->cancel if $_->data & WF_AUTOCANCEL;
2365 }
2366
2367 warn "flushing outstanding aio requests"; 3856 trace "flushing outstanding aio requests";
2368 for (;;) { 3857 while (IO::AIO::nreqs || BDB::nreqs) {
2369 IO::AIO::flush; 3858 Coro::EV::timer_once 0.01; # let the sync_job do it's thing
2370 Coro::cede;
2371 last unless IO::AIO::nreqs;
2372 warn "iterate...";
2373 }
2374
2375 warn "cancelling all extension coros";
2376 $_->cancel for values %EXT_CORO;
2377 %EXT_CORO = ();
2378
2379 warn "removing commands";
2380 %COMMAND = ();
2381
2382 warn "removing ext commands";
2383 %EXTCMD = ();
2384
2385 warn "unloading/nuking all extensions";
2386 for my $pkg (@EXTS) {
2387 warn "... unloading $pkg";
2388
2389 if (my $cb = $pkg->can ("unload")) {
2390 eval {
2391 $cb->($pkg);
2392 1
2393 } or warn "$pkg unloaded, but with errors: $@";
2394 } 3859 }
2395 3860
2396 warn "... nuking $pkg"; 3861 trace "cancelling all extension coros";
2397 Symbol::delete_package $pkg; 3862 $_->cancel for values %EXT_CORO;
2398 } 3863 %EXT_CORO = ();
2399 3864
2400 warn "unloading all perl modules loaded from $LIBDIR"; 3865 trace "removing commands";
2401 while (my ($k, $v) = each %INC) { 3866 %COMMAND = ();
2402 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
2403 3867
3868 trace "removing ext/exti commands";
3869 %EXTCMD = ();
3870 %EXTICMD = ();
3871
3872 trace "unloading/nuking all extensions";
3873 for my $pkg (@EXTS) {
2404 warn "... unloading $k"; 3874 trace "... unloading $pkg";
2405 delete $INC{$k};
2406 3875
2407 $k =~ s/\.pm$//;
2408 $k =~ s/\//::/g;
2409
2410 if (my $cb = $k->can ("unload_module")) { 3876 if (my $cb = $pkg->can ("unload")) {
3877 eval {
2411 $cb->(); 3878 $cb->($pkg);
3879 1
3880 } or error "$pkg unloaded, but with errors: $@";
3881 }
3882
3883 trace "... clearing $pkg";
3884 clear_package $pkg;
2412 } 3885 }
2413 3886
2414 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;
2415 } 3902 }
2416 3903
2417 warn "getting rid of safe::, as good as possible"; 3904 trace "getting rid of safe::, as good as possible";
2418 Symbol::delete_package "safe::$_" 3905 clear_package "safe::$_"
2419 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);
2420 3907
2421 warn "unloading cf.pm \"a bit\""; 3908 trace "unloading cf.pm \"a bit\"";
2422 delete $INC{"cf.pm"}; 3909 delete $INC{"cf.pm"};
3910 delete $INC{"cf/$_.pm"} for @EXTRA_MODULES;
2423 3911
2424 # don't, removes xs symbols, too, 3912 # don't, removes xs symbols, too,
2425 # and global variables created in xs 3913 # and global variables created in xs
2426 #Symbol::delete_package __PACKAGE__; 3914 #clear_package __PACKAGE__;
2427 3915
2428 warn "unload completed, starting to reload now"; 3916 info "unload completed, starting to reload now";
2429 3917
2430 warn "reloading cf.pm"; 3918 trace "reloading cf.pm";
2431 require cf; 3919 require cf;
2432 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 3920 cf::_connect_to_perl_1;
2433 3921
2434 warn "loading config and database again"; 3922 trace "loading config and database again";
2435 cf::cfg_load; 3923 cf::reload_config;
2436 cf::db_load;
2437 3924
2438 warn "loading extensions"; 3925 trace "loading extensions";
2439 cf::load_extensions; 3926 cf::load_extensions;
2440 3927
3928 if ($REATTACH_ON_RELOAD) {
2441 warn "reattaching attachments to objects/players"; 3929 trace "reattaching attachments to objects/players";
2442 _global_reattach; 3930 _global_reattach; # objects, sockets
2443 warn "reattaching attachments to maps"; 3931 trace "reattaching attachments to maps";
2444 reattach $_ for values %MAP; 3932 reattach $_ for values %MAP;
3933 trace "reattaching attachments to players";
3934 reattach $_ for values %PLAYER;
3935 }
2445 3936
2446 warn "restarting server ticker"; 3937 trace "running post_init jobs";
3938 (pop @POST_INIT)->(1) while @POST_INIT;
2447 3939
2448 $TICK_WATCHER->start; 3940 trace "leaving sync_job";
3941
3942 1
3943 } or do {
3944 error $@;
3945 cf::cleanup "error while reloading, exiting.";
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 };
2449 }; 3969 };
2450 3970}
2451 if ($@) {
2452 warn $@;
2453 warn "error while reloading, exiting.";
2454 exit 1;
2455 }
2456
2457 warn "reloaded";
2458};
2459
2460our $RELOAD_WATCHER; # used only during reload
2461 3971
2462register_command "reload" => sub { 3972register_command "reload" => sub {
2463 my ($who, $arg) = @_; 3973 my ($who, $arg) = @_;
2464 3974
2465 if ($who->flag (FLAG_WIZ)) { 3975 if ($who->flag (FLAG_WIZ)) {
2466 $who->message ("reloading server."); 3976 $who->message ("reloading server.");
2467 3977 async {
2468 # doing reload synchronously and two reloads happen back-to-back, 3978 $Coro::current->{desc} = "perl_reload";
2469 # coro crashes during coro_state_free->destroy here.
2470
2471 $RELOAD_WATCHER ||= Event->timer (
2472 reentrant => 0,
2473 after => 0,
2474 data => WF_AUTOCANCEL,
2475 cb => sub {
2476 reload; 3979 reload_perl;
2477 undef $RELOAD_WATCHER;
2478 },
2479 ); 3980 };
2480 } 3981 }
2481}; 3982};
2482 3983
2483unshift @INC, $LIBDIR; 3984unshift @INC, $LIBDIR;
2484 3985
2485my $bug_warning = 0; 3986my $bug_warning = 0;
2486 3987
2487$TICK_WATCHER = Event->timer ( 3988our @WAIT_FOR_TICK;
2488 reentrant => 0, 3989our @WAIT_FOR_TICK_BEGIN;
2489 parked => 1, 3990
2490 prio => 0, 3991sub wait_for_tick {
2491 at => $NEXT_TICK || $TICK, 3992 return Coro::cede if tick_inhibit || $Coro::current == $Coro::main;
2492 data => WF_AUTOCANCEL, 3993
2493 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 {
2494 if ($Coro::current != $Coro::main) { 4008 if ($Coro::current != $Coro::main) {
2495 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"
2496 unless ++$bug_warning > 10; 4010 unless ++$bug_warning > 10;
2497 return; 4011 return;
2498 } 4012 }
2499 4013
2500 $NOW = Event::time;
2501
2502 cf::server_tick; # one server iteration 4014 cf::server_tick; # one server iteration
2503 $RUNTIME += $TICK;
2504 $NEXT_TICK += $TICK;
2505 4015
2506 $WAIT_FOR_TICK->broadcast; 4016 #for(1..3e6){} AE::now_update; $NOW=AE::now; # generate load #d#
2507 $WAIT_FOR_TICK_ONE->send if $WAIT_FOR_TICK_ONE->awaited;
2508 4017
2509 Event::sweep; 4018 if ($NOW >= $NEXT_RUNTIME_WRITE) {
2510 Coro::cede_notself; 4019 $NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.;
4020 Coro::async_pool {
4021 $Coro::current->{desc} = "runtime saver";
4022 write_runtime_sync
4023 or error "ERROR: unable to write runtime file: $!";
4024 };
4025 }
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#
2511 4042 }
2512# my $AFTER = Event::time;
2513# warn $AFTER - $NOW;#d#
2514
2515 # if we are delayed by four ticks or more, skip them all
2516 $NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4;
2517
2518 $TICK_WATCHER->at ($NEXT_TICK);
2519 $TICK_WATCHER->start;
2520 }, 4043 }
2521); 4044}
2522 4045
4046{
4047 # configure BDB
4048
4049 BDB::min_parallel 16;
4050 BDB::max_poll_reqs $TICK * 0.1;
4051 $AnyEvent::BDB::WATCHER->priority (1);
4052
4053 unless ($DB_ENV) {
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);
4060
4061 cf::sync_job {
4062 eval {
4063 BDB::db_env_open
4064 $DB_ENV,
4065 $BDBDIR,
4066 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN
4067 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE,
4068 0666;
4069
4070 cf::cleanup "db_env_open($BDBDIR): $!" if $!;
4071 };
4072
4073 cf::cleanup "db_env_open(db): $@" if $@;
4074 };
4075 }
4076
4077 $BDB_DEADLOCK_WATCHER = EV::periodic 0, 3, 0, sub {
4078 BDB::db_env_lock_detect $DB_ENV, 0, BDB::LOCK_DEFAULT, 0, sub { };
4079 };
4080 $BDB_CHECKPOINT_WATCHER = EV::periodic 0, 60, 0, sub {
4081 BDB::db_env_txn_checkpoint $DB_ENV, 0, 0, 0, sub { };
4082 };
4083 $BDB_TRICKLE_WATCHER = EV::periodic 0, 10, 0, sub {
4084 BDB::db_env_memp_trickle $DB_ENV, 20, 0, sub { };
4085 };
4086}
4087
4088{
4089 # configure IO::AIO
4090
4091 IO::AIO::min_parallel 8;
2523IO::AIO::max_poll_time $TICK * 0.1; 4092 IO::AIO::max_poll_time $TICK * 0.1;
4093 undef $AnyEvent::AIO::WATCHER;
4094}
2524 4095
2525undef $Coro::AIO::WATCHER; 4096my $_log_backtrace;
2526$AIO_POLL_WATCHER = Event->io (
2527 reentrant => 0,
2528 fd => IO::AIO::poll_fileno,
2529 poll => 'r',
2530 prio => 6,
2531 data => WF_AUTOCANCEL,
2532 cb => \&IO::AIO::poll_cb,
2533);
2534 4097
2535$WRITE_RUNTIME_WATCHER = Event->timer ( 4098sub _log_backtrace {
2536 reentrant => 0, 4099 my ($msg, @addr) = @_;
2537 data => WF_AUTOCANCEL, 4100
2538 after => 1, 4101 $msg =~ s/\n//;
2539 interval => 10, 4102
2540 prio => 6, # keep it lowest so it acts like a watchdog 4103 # limit the # of concurrent backtraces
2541 cb => Coro::unblock_sub { 4104 if ($_log_backtrace < 2) {
2542 write_runtime 4105 ++$_log_backtrace;
2543 or warn "ERROR: unable to write runtime file: $!"; 4106 my $perl_bt = Carp::longmess $msg;
4107 async {
4108 $Coro::current->{desc} = "abt $msg";
4109
4110 my @bt = fork_call {
4111 @addr = map { sprintf "%x", $_ } @addr;
4112 my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X;
4113 open my $fh, "exec addr2line -C -f -i -e \Q$self\E @addr 2>&1 |"
4114 or die "addr2line: $!";
4115
4116 my @funcs;
4117 my @res = <$fh>;
4118 chomp for @res;
4119 while (@res) {
4120 my ($func, $line) = splice @res, 0, 2, ();
4121 push @funcs, "[$func] $line";
4122 }
4123
4124 @funcs
4125 };
4126
4127 LOG llevInfo, "[ABT] $perl_bt\n";
4128 LOG llevInfo, "[ABT] --- C backtrace follows ---\n";
4129 LOG llevInfo, "[ABT] $_\n" for @bt;
4130 --$_log_backtrace;
4131 };
4132 } else {
4133 LOG llevInfo, "[ABT] $msg\n";
4134 LOG llevInfo, "[ABT] [suppressed]\n";
2544 }, 4135 }
2545); 4136}
4137
4138# load additional modules
4139require "cf/$_.pm" for @EXTRA_MODULES;
4140cf::_connect_to_perl_2;
2546 4141
2547END { cf::emergency_save } 4142END { cf::emergency_save }
2548 4143
25491 41441
2550 4145

Diff Legend

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