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.161 by root, Thu Jan 11 00:16:58 2007 UTC vs.
Revision 1.410 by root, Tue Jan 15 12:02:24 2008 UTC

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

Diff Legend

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