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

Diff Legend

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