ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/cf.schmorp.de/server/lib/cf.pm
(Generate patch)

Comparing cf.schmorp.de/server/lib/cf.pm (file contents):
Revision 1.223 by root, Sun Mar 11 02:12:44 2007 UTC vs.
Revision 1.407 by root, Sun Jan 13 09:53:53 2008 UTC

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

Diff Legend

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