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

Diff Legend

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