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

Diff Legend

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