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.158 by root, Wed Jan 10 19:52:43 2007 UTC vs.
Revision 1.475 by root, Tue Jul 21 06:17:00 2009 UTC

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

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines