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

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

Diff Legend

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