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.226 by root, Wed Mar 14 04:12:29 2007 UTC vs.
Revision 1.360 by root, Sun Sep 9 06:25:46 2007 UTC

3use utf8; 3use utf8;
4use strict; 4use strict;
5 5
6use Symbol; 6use Symbol;
7use List::Util; 7use List::Util;
8use Socket;
8use Storable; 9use Storable;
9use Event; 10use Event;
10use Opcode; 11use Opcode;
11use Safe; 12use Safe;
12use Safe::Hole; 13use Safe::Hole;
13 14
14use Coro 3.52 (); 15use Coro 3.64 ();
15use Coro::State; 16use Coro::State;
17use Coro::Handle;
16use Coro::Event; 18use Coro::Event;
17use Coro::Timer; 19use Coro::Timer;
18use Coro::Signal; 20use Coro::Signal;
19use Coro::Semaphore; 21use Coro::Semaphore;
20use Coro::AIO; 22use Coro::AIO;
23use Coro::Storable;
24use Coro::Util ();
21 25
26use JSON::XS ();
22use BDB (); 27use BDB ();
23use Data::Dumper; 28use Data::Dumper;
24use Digest::MD5; 29use Digest::MD5;
25use Fcntl; 30use Fcntl;
31use YAML::Syck ();
26use IO::AIO 2.32 (); 32use IO::AIO 2.32 ();
27use YAML::Syck ();
28use Time::HiRes; 33use Time::HiRes;
29use Compress::LZF; 34use Compress::LZF;
35use Digest::MD5 ();
30 36
37# configure various modules to our taste
38#
39$Storable::canonical = 1; # reduce rsync transfers
31Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator 40Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator
32Compress::LZF::sfreeze_cr { }; # prime Compress::LZF so it does not use require later 41Compress::LZF::sfreeze_cr { }; # prime Compress::LZF so it does not use require later
42
33$Event::Eval = 1; # no idea why this is required, but it is 43$Event::Eval = 1; # no idea why this is required, but it is
34
35sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
36 44
37# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode? 45# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode?
38$YAML::Syck::ImplicitUnicode = 1; 46$YAML::Syck::ImplicitUnicode = 1;
39 47
40$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority 48$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority
41 49
50sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
51
42our %COMMAND = (); 52our %COMMAND = ();
43our %COMMAND_TIME = (); 53our %COMMAND_TIME = ();
44 54
45our @EXTS = (); # list of extension package names 55our @EXTS = (); # list of extension package names
46our %EXTCMD = (); 56our %EXTCMD = ();
57our %EXTICMD = ();
47our %EXT_CORO = (); # coroutines bound to extensions 58our %EXT_CORO = (); # coroutines bound to extensions
48our %EXT_MAP = (); # pluggable maps 59our %EXT_MAP = (); # pluggable maps
49 60
50our $RELOAD; # number of reloads so far 61our $RELOAD; # number of reloads so far
51our @EVENT; 62our @EVENT;
52our $LIBDIR = datadir . "/ext";
53 63
54our $TICK = MAX_TIME * 1e-6; 64our $CONFDIR = confdir;
65our $DATADIR = datadir;
66our $LIBDIR = "$DATADIR/ext";
67our $PODDIR = "$DATADIR/pod";
68our $MAPDIR = "$DATADIR/" . mapdir;
69our $LOCALDIR = localdir;
70our $TMPDIR = "$LOCALDIR/" . tmpdir;
71our $UNIQUEDIR = "$LOCALDIR/" . uniquedir;
72our $PLAYERDIR = "$LOCALDIR/" . playerdir;
73our $RANDOMDIR = "$LOCALDIR/random";
74our $BDBDIR = "$LOCALDIR/db";
75
76our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!)
55our $TICK_WATCHER; 77our $TICK_WATCHER;
56our $AIO_POLL_WATCHER; 78our $AIO_POLL_WATCHER;
57our $NEXT_RUNTIME_WRITE; # when should the runtime file be written 79our $NEXT_RUNTIME_WRITE; # when should the runtime file be written
58our $NEXT_TICK; 80our $NEXT_TICK;
59our $NOW; 81our $NOW;
65our %CFG; 87our %CFG;
66 88
67our $UPTIME; $UPTIME ||= time; 89our $UPTIME; $UPTIME ||= time;
68our $RUNTIME; 90our $RUNTIME;
69 91
70our %PLAYER; # all users 92our (%PLAYER, %PLAYER_LOADING); # all users
71our %MAP; # all maps 93our (%MAP, %MAP_LOADING ); # all maps
72our $LINK_MAP; # the special {link} map, which is always available 94our $LINK_MAP; # the special {link} map, which is always available
73our $RANDOM_MAPS = cf::localdir . "/random";
74our $BDB_ENV_DIR = cf::localdir . "/db";
75
76our $WAIT_FOR_TICK; $WAIT_FOR_TICK ||= new Coro::Signal;
77our $WAIT_FOR_TICK_ONE; $WAIT_FOR_TICK_ONE ||= new Coro::Signal;
78 95
79# used to convert map paths into valid unix filenames by replacing / by ∕ 96# used to convert map paths into valid unix filenames by replacing / by ∕
80our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons 97our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons
81 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
102
82binmode STDOUT; 103binmode STDOUT;
83binmode STDERR; 104binmode STDERR;
84 105
85# read virtual server time, if available 106# read virtual server time, if available
86unless ($RUNTIME || !-e cf::localdir . "/runtime") { 107unless ($RUNTIME || !-e "$LOCALDIR/runtime") {
87 open my $fh, "<", cf::localdir . "/runtime" 108 open my $fh, "<", "$LOCALDIR/runtime"
88 or die "unable to read runtime file: $!"; 109 or die "unable to read runtime file: $!";
89 $RUNTIME = <$fh> + 0.; 110 $RUNTIME = <$fh> + 0.;
90} 111}
91 112
92mkdir cf::localdir; 113mkdir $_
93mkdir cf::localdir . "/" . cf::playerdir; 114 for $LOCALDIR, $TMPDIR, $UNIQUEDIR, $PLAYERDIR, $RANDOMDIR, $BDBDIR;
94mkdir cf::localdir . "/" . cf::tmpdir;
95mkdir cf::localdir . "/" . cf::uniquedir;
96mkdir $RANDOM_MAPS;
97mkdir $BDB_ENV_DIR;
98 115
99our $EMERGENCY_POSITION; 116our $EMERGENCY_POSITION;
100 117
101sub cf::map::normalise; 118sub cf::map::normalise;
102 119
113=item $cf::RUNTIME 130=item $cf::RUNTIME
114 131
115The 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
116every server tick. 133every server tick.
117 134
118=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
119 138
120The perl library directory, where extensions and cf-specific modules can 139Various directories - "/etc", read-only install directory, perl-library
121be 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.
122 143
123=item $cf::NOW 144=item $cf::NOW
124 145
125The time of the last (current) server tick. 146The time of the last (current) server tick.
126 147
127=item $cf::TICK 148=item $cf::TICK
128 149
129The interval between server ticks, in seconds. 150The interval between server ticks, in seconds.
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.
130 161
131=item %cf::CFG 162=item %cf::CFG
132 163
133Configuration for the server, loaded from C</etc/crossfire/config>, or 164Configuration for the server, loaded from C</etc/crossfire/config>, or
134from wherever your confdir points to. 165from wherever your confdir points to.
135 166
136=item $cf::WAIT_FOR_TICK, $cf::WAIT_FOR_TICK_ONE 167=item cf::wait_for_tick, cf::wait_for_tick_begin
137 168
138These 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
139or 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
140processing 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.
141window 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.
142 178
143=back 179=back
144 180
145=cut 181=cut
146 182
147BEGIN { 183BEGIN {
148 *CORE::GLOBAL::warn = sub { 184 *CORE::GLOBAL::warn = sub {
149 my $msg = join "", @_; 185 my $msg = join "", @_;
150 utf8::encode $msg;
151 186
152 $msg .= "\n" 187 $msg .= "\n"
153 unless $msg =~ /\n$/; 188 unless $msg =~ /\n$/;
154 189
190 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;
191
192 utf8::encode $msg;
155 LOG llevError, $msg; 193 LOG llevError, $msg;
156 }; 194 };
157} 195}
158 196
159@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable'; 197@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
160@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable'; 198@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';
161@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable'; 199@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable';
162@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable'; 200@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable';
163@safe::cf::map::ISA = @cf::map::ISA = 'cf::attachable'; 201@safe::cf::map::ISA = @cf::map::ISA = 'cf::attachable';
202@safe::cf::arch::ISA = @cf::arch::ISA = 'cf::object';
164@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object'; 203@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object'; # not really true (yet)
165 204
166# we bless all objects into (empty) derived classes to force a method lookup 205# we bless all objects into (empty) derived classes to force a method lookup
167# within the Safe compartment. 206# within the Safe compartment.
168for my $pkg (qw( 207for my $pkg (qw(
169 cf::global cf::attachable 208 cf::global cf::attachable
177} 216}
178 217
179$Event::DIED = sub { 218$Event::DIED = sub {
180 warn "error in event callback: @_"; 219 warn "error in event callback: @_";
181}; 220};
221
222#############################################################################
182 223
183=head2 UTILITY FUNCTIONS 224=head2 UTILITY FUNCTIONS
184 225
185=over 4 226=over 4
186 227
205 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge; 246 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge;
206 $d 247 $d
207 } || "[unable to dump $_[0]: '$@']"; 248 } || "[unable to dump $_[0]: '$@']";
208} 249}
209 250
210use JSON::Syck (); # TODO# replace by JSON::PC once working
211
212=item $ref = cf::from_json $json 251=item $ref = cf::from_json $json
213 252
214Converts a JSON string into the corresponding perl data structure. 253Converts a JSON string into the corresponding perl data structure.
215 254
216=cut
217
218sub from_json($) {
219 $JSON::Syck::ImplicitUnicode = 1; # work around JSON::Syck bugs
220 JSON::Syck::Load $_[0]
221}
222
223=item $json = cf::to_json $ref 255=item $json = cf::to_json $ref
224 256
225Converts a perl data structure into its JSON representation. 257Converts a perl data structure into its JSON representation.
226 258
227=cut 259=cut
228 260
229sub to_json($) { 261our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max
230 $JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs 262
231 JSON::Syck::Dump $_[0] 263sub to_json ($) { $json_coder->encode ($_[0]) }
232} 264sub from_json ($) { $json_coder->decode ($_[0]) }
233 265
234=item cf::lock_wait $string 266=item cf::lock_wait $string
235 267
236Wait until the given lock is available. See cf::lock_acquire. 268Wait until the given lock is available. See cf::lock_acquire.
237 269
240Wait until the given lock is available and then acquires it and returns 272Wait until the given lock is available and then acquires it and returns
241a Coro::guard object. If the guard object gets destroyed (goes out of scope, 273a Coro::guard object. If the guard object gets destroyed (goes out of scope,
242for example when the coroutine gets canceled), the lock is automatically 274for example when the coroutine gets canceled), the lock is automatically
243returned. 275returned.
244 276
277Locks are *not* recursive, locking from the same coro twice results in a
278deadlocked coro.
279
245Lock names should begin with a unique identifier (for example, cf::map::find 280Lock names should begin with a unique identifier (for example, cf::map::find
246uses map_find and cf::map::load uses map_load). 281uses map_find and cf::map::load uses map_load).
247 282
283=item $locked = cf::lock_active $string
284
285Return true if the lock is currently active, i.e. somebody has locked it.
286
248=cut 287=cut
249 288
250our %LOCK; 289our %LOCK;
290our %LOCKER;#d#
251 291
252sub lock_wait($) { 292sub lock_wait($) {
253 my ($key) = @_; 293 my ($key) = @_;
294
295 if ($LOCKER{$key} == $Coro::current) {#d#
296 Carp::cluck "lock_wait($key) for already-acquired lock";#d#
297 return;#d#
298 }#d#
254 299
255 # wait for lock, if any 300 # wait for lock, if any
256 while ($LOCK{$key}) { 301 while ($LOCK{$key}) {
257 push @{ $LOCK{$key} }, $Coro::current; 302 push @{ $LOCK{$key} }, $Coro::current;
258 Coro::schedule; 303 Coro::schedule;
264 309
265 # wait, to be sure we are not locked 310 # wait, to be sure we are not locked
266 lock_wait $key; 311 lock_wait $key;
267 312
268 $LOCK{$key} = []; 313 $LOCK{$key} = [];
314 $LOCKER{$key} = $Coro::current;#d#
269 315
270 Coro::guard { 316 Coro::guard {
317 delete $LOCKER{$key};#d#
271 # wake up all waiters, to be on the safe side 318 # wake up all waiters, to be on the safe side
272 $_->ready for @{ delete $LOCK{$key} }; 319 $_->ready for @{ delete $LOCK{$key} };
273 } 320 }
321}
322
323sub lock_active($) {
324 my ($key) = @_;
325
326 ! ! $LOCK{$key}
274} 327}
275 328
276sub freeze_mainloop { 329sub freeze_mainloop {
277 return unless $TICK_WATCHER->is_active; 330 return unless $TICK_WATCHER->is_active;
278 331
281 }; 334 };
282 $TICK_WATCHER->stop; 335 $TICK_WATCHER->stop;
283 $guard 336 $guard
284} 337}
285 338
339=item cf::get_slot $time[, $priority[, $name]]
340
341Allocate $time seconds of blocking CPU time at priority C<$priority>:
342This call blocks and returns only when you have at least C<$time> seconds
343of cpu time till the next tick. The slot is only valid till the next cede.
344
345The optional C<$name> can be used to identify the job to run. It might be
346used for statistical purposes and should identify the same time-class.
347
348Useful for short background jobs.
349
350=cut
351
352our @SLOT_QUEUE;
353our $SLOT_QUEUE;
354
355$SLOT_QUEUE->cancel if $SLOT_QUEUE;
356$SLOT_QUEUE = Coro::async {
357 my $signal = new Coro::Signal;
358
359 while () {
360 next_job:
361 my $avail = cf::till_tick;
362 if ($avail > 0.01) {
363 for (0 .. $#SLOT_QUEUE) {
364 if ($SLOT_QUEUE[$_][0] < $avail) {
365 my $job = splice @SLOT_QUEUE, $_, 1, ();
366 $job->[2]->send;
367 Coro::cede;
368 goto next_job;
369 }
370 }
371 }
372
373 if (@SLOT_QUEUE) {
374 # we do not use wait_For_tick() as it returns immediately when tick is inactive
375 push @cf::WAIT_FOR_TICK, $signal;
376 $signal->wait;
377 } else {
378 Coro::schedule;
379 }
380 }
381};
382
383sub get_slot($;$$) {
384 my ($time, $pri, $name) = @_;
385
386 $time = $TICK * .6 if $time > $TICK * .6;
387 my $sig = new Coro::Signal;
388
389 push @SLOT_QUEUE, [$time, $pri, $sig, $name];
390 @SLOT_QUEUE = sort { $b->[1] <=> $a->[1] } @SLOT_QUEUE;
391 $SLOT_QUEUE->ready;
392 $sig->wait;
393}
394
286=item cf::async { BLOCK } 395=item cf::async { BLOCK }
287 396
288Currently the same as Coro::async_pool, meaning you cannot use 397Currently the same as Coro::async_pool, meaning you cannot use
289C<on_destroy>, C<join> or other gimmicks on these coroutines. The only 398C<on_destroy>, C<join> or other gimmicks on these coroutines. The only
290thing you are allowed to do is call C<prio> on it. 399thing you are allowed to do is call C<prio> on it.
293 402
294BEGIN { *async = \&Coro::async_pool } 403BEGIN { *async = \&Coro::async_pool }
295 404
296=item cf::sync_job { BLOCK } 405=item cf::sync_job { BLOCK }
297 406
298The design of crossfire+ requires that the main coro ($Coro::main) is 407The design of Crossfire TRT requires that the main coroutine ($Coro::main)
299always able to handle events or runnable, as crossfire+ is only partly 408is always able to handle events or runnable, as Crossfire TRT is only
300reentrant. Thus "blocking" it by e.g. waiting for I/O is not acceptable. 409partly reentrant. Thus "blocking" it by e.g. waiting for I/O is not
410acceptable.
301 411
302If it must be done, put the blocking parts into C<sync_job>. This will run 412If it must be done, put the blocking parts into C<sync_job>. This will run
303the given BLOCK in another coroutine while waiting for the result. The 413the given BLOCK in another coroutine while waiting for the result. The
304server will be frozen during this time, so the block should either finish 414server will be frozen during this time, so the block should either finish
305fast or be very important. 415fast or be very important.
308 418
309sub sync_job(&) { 419sub sync_job(&) {
310 my ($job) = @_; 420 my ($job) = @_;
311 421
312 if ($Coro::current == $Coro::main) { 422 if ($Coro::current == $Coro::main) {
423 my $time = Event::time;
424
313 # this is the main coro, too bad, we have to block 425 # this is the main coro, too bad, we have to block
314 # till the operation succeeds, freezing the server :/ 426 # till the operation succeeds, freezing the server :/
315 427
316 # TODO: use suspend/resume instead 428 # TODO: use suspend/resume instead
317 # (but this is cancel-safe) 429 # (but this is cancel-safe)
328 440
329 while ($busy) { 441 while ($busy) {
330 Coro::cede or Event::one_event; 442 Coro::cede or Event::one_event;
331 } 443 }
332 444
445 $time = Event::time - $time;
446
447 LOG llevError | logBacktrace, Carp::longmess "long sync job"
448 if $time > $TICK * 0.5 && $TICK_WATCHER->is_active;
449
450 $tick_start += $time; # do not account sync jobs to server load
451
333 wantarray ? @res : $res[0] 452 wantarray ? @res : $res[0]
334 } else { 453 } else {
335 # we are in another coroutine, how wonderful, everything just works 454 # we are in another coroutine, how wonderful, everything just works
336 455
337 $job->() 456 $job->()
356 $EXT_CORO{$coro+0} = $coro; 475 $EXT_CORO{$coro+0} = $coro;
357 476
358 $coro 477 $coro
359} 478}
360 479
361sub write_runtime { 480=item fork_call { }, $args
362 my $guard = cf::lock_acquire "write_runtime";
363 481
364 my $runtime = cf::localdir . "/runtime"; 482Executes the given code block with the given arguments in a seperate
483process, returning the results. Everything must be serialisable with
484Coro::Storable. May, of course, block. Note that the executed sub may
485never block itself or use any form of Event handling.
365 486
366 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644 487=cut
367 or return;
368 488
369 my $value = $cf::RUNTIME + 90 + 10; 489sub fork_call(&@) {
370 # 10 is the runtime save interval, for a monotonic clock 490 my ($cb, @args) = @_;
371 # 60 allows for the watchdog to kill the server.
372 491
373 (aio_write $fh, 0, (length $value), $value, 0) <= 0 492 # we seemingly have to make a local copy of the whole thing,
374 and return; 493 # otherwise perl prematurely frees the stuff :/
494 # TODO: investigate and fix (likely this will be rather laborious)
375 495
376 # always fsync - this file is important 496 my @res = Coro::Util::fork_eval {
377 aio_fsync $fh 497 reset_signals;
378 and return; 498 &$cb
499 }, @args;
379 500
380 close $fh 501 wantarray ? @res : $res[-1]
381 or return; 502}
382 503
383 aio_rename "$runtime~", $runtime 504=item $value = cf::db_get $family => $key
384 and return;
385 505
506Returns a single value from the environment database.
507
508=item cf::db_put $family => $key => $value
509
510Stores the given C<$value> in the family. It can currently store binary
511data only (use Compress::LZF::sfreeze_cr/sthaw to convert to/from binary).
512
513=cut
514
515our $DB;
516
517sub db_init {
518 unless ($DB) {
519 $DB = BDB::db_create $DB_ENV;
520
521 cf::sync_job {
522 eval {
523 $DB->set_flags (BDB::CHKSUM);
524
525 BDB::db_open $DB, undef, "db", undef, BDB::BTREE,
526 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
527 cf::cleanup "db_open(db): $!" if $!;
528 };
529 cf::cleanup "db_open(db): $@" if $@;
530 };
386 1 531 }
532}
533
534sub db_get($$) {
535 my $key = "$_[0]/$_[1]";
536
537 cf::sync_job {
538 BDB::db_get $DB, undef, $key, my $data;
539
540 $! ? ()
541 : $data
542 }
543}
544
545sub db_put($$$) {
546 BDB::dbreq_pri 4;
547 BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { };
548}
549
550=item cf::cache $id => [$paths...], $processversion => $process
551
552Generic caching function that returns the value of the resource $id,
553caching and regenerating as required.
554
555This function can block.
556
557=cut
558
559sub cache {
560 my ($id, $src, $processversion, $process) = @_;
561
562 my $meta =
563 join "\x00",
564 $processversion,
565 map {
566 aio_stat $_
567 and Carp::croak "$_: $!";
568
569 ($_, (stat _)[7,9])
570 } @$src;
571
572 my $dbmeta = db_get cache => "$id/meta";
573 if ($dbmeta ne $meta) {
574 # changed, we may need to process
575
576 my @data;
577 my $md5;
578
579 for (0 .. $#$src) {
580 0 <= aio_load $src->[$_], $data[$_]
581 or Carp::croak "$src->[$_]: $!";
582 }
583
584 # if processing is expensive, check
585 # checksum first
586 if (1) {
587 $md5 =
588 join "\x00",
589 $processversion,
590 map {
591 cf::cede_to_tick;
592 ($src->[$_], Digest::MD5::md5_hex $data[$_])
593 } 0.. $#$src;
594
595
596 my $dbmd5 = db_get cache => "$id/md5";
597 if ($dbmd5 eq $md5) {
598 db_put cache => "$id/meta", $meta;
599
600 return db_get cache => "$id/data";
601 }
602 }
603
604 my $t1 = Time::HiRes::time;
605 my $data = $process->(\@data);
606 my $t2 = Time::HiRes::time;
607
608 warn "cache: '$id' processed in ", $t2 - $t1, "s\n";
609
610 db_put cache => "$id/data", $data;
611 db_put cache => "$id/md5" , $md5;
612 db_put cache => "$id/meta", $meta;
613
614 return $data;
615 }
616
617 db_get cache => "$id/data"
618}
619
620=item cf::datalog type => key => value, ...
621
622Log a datalog packet of the given type with the given key-value pairs.
623
624=cut
625
626sub datalog($@) {
627 my ($type, %kv) = @_;
628 warn "DATALOG ", JSON::XS->new->ascii->encode ({ %kv, type => $type });
387} 629}
388 630
389=back 631=back
390 632
391=cut 633=cut
398attach callbacks/event handlers (a collection of which is called an "attachment") 640attach callbacks/event handlers (a collection of which is called an "attachment")
399to it. All such attachable objects support the following methods. 641to it. All such attachable objects support the following methods.
400 642
401In the following description, CLASS can be any of C<global>, C<object> 643In the following description, CLASS can be any of C<global>, C<object>
402C<player>, C<client> or C<map> (i.e. the attachable objects in 644C<player>, C<client> or C<map> (i.e. the attachable objects in
403crossfire+). 645Crossfire TRT).
404 646
405=over 4 647=over 4
406 648
407=item $attachable->attach ($attachment, key => $value...) 649=item $attachable->attach ($attachment, key => $value...)
408 650
571 $registry = $CB_TYPE[$object_type] ||= []; 813 $registry = $CB_TYPE[$object_type] ||= [];
572 814
573 } elsif ($type eq "subtype") { 815 } elsif ($type eq "subtype") {
574 defined $object_type or Carp::croak "subtype specified without type"; 816 defined $object_type or Carp::croak "subtype specified without type";
575 my $object_subtype = shift @arg; 817 my $object_subtype = shift @arg;
576 $registry = $CB_TYPE[$object_type + $object_subtype * NUM_SUBTYPES] ||= []; 818 $registry = $CB_TYPE[$object_type + $object_subtype * NUM_TYPES] ||= [];
577 819
578 } elsif ($type eq "package") { 820 } elsif ($type eq "package") {
579 my $pkg = shift @arg; 821 my $pkg = shift @arg;
580 822
581 while (my ($name, $id) = each %cb_id) { 823 while (my ($name, $id) = each %cb_id) {
610 _attach $registry, $klass, @attach; 852 _attach $registry, $klass, @attach;
611 } 853 }
612 854
613 $obj->{$name} = \%arg; 855 $obj->{$name} = \%arg;
614 } else { 856 } else {
615 warn "object uses attachment '$name' that is not available, postponing.\n"; 857 warn "object uses attachment '$name' which is not available, postponing.\n";
616 } 858 }
617 859
618 $obj->{_attachment}{$name} = undef; 860 $obj->{_attachment}{$name} = undef;
619} 861}
620 862
622 if (ref $_[0]) { 864 if (ref $_[0]) {
623 _object_attach @_; 865 _object_attach @_;
624 } else { 866 } else {
625 _attach shift->_attach_registry, @_; 867 _attach shift->_attach_registry, @_;
626 } 868 }
869 _recalc_want;
627}; 870};
628 871
629# all those should be optimised 872# all those should be optimised
630sub cf::attachable::detach { 873sub cf::attachable::detach {
631 my ($obj, $name) = @_; 874 my ($obj, $name) = @_;
634 delete $obj->{_attachment}{$name}; 877 delete $obj->{_attachment}{$name};
635 reattach ($obj); 878 reattach ($obj);
636 } else { 879 } else {
637 Carp::croak "cannot, currently, detach class attachments"; 880 Carp::croak "cannot, currently, detach class attachments";
638 } 881 }
882 _recalc_want;
639}; 883};
640 884
641sub cf::attachable::attached { 885sub cf::attachable::attached {
642 my ($obj, $name) = @_; 886 my ($obj, $name) = @_;
643 887
658 "; 902 ";
659 die if $@; 903 die if $@;
660} 904}
661 905
662our $override; 906our $override;
663our @invoke_results = (); # referenced from .xs code. TODO: play tricks with reify and mortals? 907our @INVOKE_RESULTS = (); # referenced from .xs code. TODO: play tricks with reify and mortals?
664 908
665sub override { 909sub override {
666 $override = 1; 910 $override = 1;
667 @invoke_results = (); 911 @INVOKE_RESULTS = (@_);
668} 912}
669 913
670sub do_invoke { 914sub do_invoke {
671 my $event = shift; 915 my $event = shift;
672 my $callbacks = shift; 916 my $callbacks = shift;
673 917
674 @invoke_results = (); 918 @INVOKE_RESULTS = ();
675 919
676 local $override; 920 local $override;
677 921
678 for (@$callbacks) { 922 for (@$callbacks) {
679 eval { &{$_->[1]} }; 923 eval { &{$_->[1]} };
696 940
697Generate an object-specific event with the given arguments. 941Generate an object-specific event with the given arguments.
698 942
699This API is preliminary (most likely, the EVENT_CLASS_xxx prefix will be 943This API is preliminary (most likely, the EVENT_CLASS_xxx prefix will be
700removed in future versions), and there is no public API to access override 944removed in future versions), and there is no public API to access override
701results (if you must, access C<@cf::invoke_results> directly). 945results (if you must, access C<@cf::INVOKE_RESULTS> directly).
702 946
703=back 947=back
704 948
705=cut 949=cut
706 950
707############################################################################# 951#############################################################################
708# object support 952# object support
953#
954
955sub _can_merge {
956 my ($ob1, $ob2) = @_;
957
958 local $Storable::canonical = 1;
959 my $fob1 = Storable::freeze $ob1;
960 my $fob2 = Storable::freeze $ob2;
961
962 $fob1 eq $fob2
963}
709 964
710sub reattach { 965sub reattach {
711 # basically do the same as instantiate, without calling instantiate 966 # basically do the same as instantiate, without calling instantiate
712 my ($obj) = @_; 967 my ($obj) = @_;
713 968
757 }, 1012 },
758); 1013);
759 1014
760sub object_freezer_save { 1015sub object_freezer_save {
761 my ($filename, $rdata, $objs) = @_; 1016 my ($filename, $rdata, $objs) = @_;
1017
1018 my $guard = cf::lock_acquire "io";
762 1019
763 sync_job { 1020 sync_job {
764 if (length $$rdata) { 1021 if (length $$rdata) {
765 warn sprintf "saving %s (%d,%d)\n", 1022 warn sprintf "saving %s (%d,%d)\n",
766 $filename, length $$rdata, scalar @$objs; 1023 $filename, length $$rdata, scalar @$objs;
790 } 1047 }
791 } else { 1048 } else {
792 aio_unlink $filename; 1049 aio_unlink $filename;
793 aio_unlink "$filename.pst"; 1050 aio_unlink "$filename.pst";
794 } 1051 }
795 } 1052 };
1053
1054 undef $guard;
796} 1055}
797 1056
798sub object_freezer_as_string { 1057sub object_freezer_as_string {
799 my ($rdata, $objs) = @_; 1058 my ($rdata, $objs) = @_;
800 1059
805 1064
806sub object_thawer_load { 1065sub object_thawer_load {
807 my ($filename) = @_; 1066 my ($filename) = @_;
808 1067
809 my ($data, $av); 1068 my ($data, $av);
1069
1070 my $guard = cf::lock_acquire "io";
810 1071
811 (aio_load $filename, $data) >= 0 1072 (aio_load $filename, $data) >= 0
812 or return; 1073 or return;
813 1074
814 unless (aio_stat "$filename.pst") { 1075 unless (aio_stat "$filename.pst") {
815 (aio_load "$filename.pst", $av) >= 0 1076 (aio_load "$filename.pst", $av) >= 0
816 or return; 1077 or return;
1078
1079 undef $guard;
817 $av = eval { (Storable::thaw $av)->{objs} }; 1080 $av = eval { (Storable::thaw $av)->{objs} };
818 } 1081 }
819 1082
820 warn sprintf "loading %s (%d)\n", 1083 warn sprintf "loading %s (%d)\n",
821 $filename, length $data, scalar @{$av || []};#d# 1084 $filename, length $data, scalar @{$av || []};
1085
822 return ($data, $av); 1086 ($data, $av)
823} 1087}
1088
1089=head2 COMMAND CALLBACKS
1090
1091=over 4
1092
1093=cut
824 1094
825############################################################################# 1095#############################################################################
826# command handling &c 1096# command handling &c
827 1097
828=item cf::register_command $name => \&callback($ob,$args); 1098=item cf::register_command $name => \&callback($ob,$args);
841 push @{ $COMMAND{$name} }, [$caller, $cb]; 1111 push @{ $COMMAND{$name} }, [$caller, $cb];
842} 1112}
843 1113
844=item cf::register_extcmd $name => \&callback($pl,$packet); 1114=item cf::register_extcmd $name => \&callback($pl,$packet);
845 1115
846Register a callbackf ro execution when the client sends an extcmd packet. 1116Register a callback for execution when the client sends an (synchronous)
1117extcmd packet. Ext commands will be processed in the order they are
1118received by the server, like other user commands. The first argument is
1119the logged-in player. Ext commands can only be processed after a player
1120has logged in successfully.
847 1121
848If the callback returns something, it is sent back as if reply was being 1122If the callback returns something, it is sent back as if reply was being
849called. 1123called.
850 1124
1125=item cf::register_exticmd $name => \&callback($ns,$packet);
1126
1127Register a callback for execution when the client sends an (asynchronous)
1128exticmd packet. Exti commands are processed by the server as soon as they
1129are received, i.e. out of order w.r.t. other commands. The first argument
1130is a client socket. Exti commands can be received anytime, even before
1131log-in.
1132
1133If the callback returns something, it is sent back as if reply was being
1134called.
1135
851=cut 1136=cut
852 1137
853sub register_extcmd { 1138sub register_extcmd {
854 my ($name, $cb) = @_; 1139 my ($name, $cb) = @_;
855 1140
856 $EXTCMD{$name} = $cb; 1141 $EXTCMD{$name} = $cb;
1142}
1143
1144sub register_exticmd {
1145 my ($name, $cb) = @_;
1146
1147 $EXTICMD{$name} = $cb;
857} 1148}
858 1149
859cf::player->attach ( 1150cf::player->attach (
860 on_command => sub { 1151 on_command => sub {
861 my ($pl, $name, $params) = @_; 1152 my ($pl, $name, $params) = @_;
870 cf::override; 1161 cf::override;
871 }, 1162 },
872 on_extcmd => sub { 1163 on_extcmd => sub {
873 my ($pl, $buf) = @_; 1164 my ($pl, $buf) = @_;
874 1165
875 my $msg = eval { from_json $buf }; 1166 my $msg = eval { $pl->ns->{json_coder}->decode ($buf) };
876 1167
877 if (ref $msg) { 1168 if (ref $msg) {
1169 my ($type, $reply, @payload) =
1170 "ARRAY" eq ref $msg
1171 ? @$msg
1172 : ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
1173
1174 my @reply;
1175
878 if (my $cb = $EXTCMD{$msg->{msgtype}}) { 1176 if (my $cb = $EXTCMD{$type}) {
879 if (my %reply = $cb->($pl, $msg)) { 1177 @reply = $cb->($pl, @payload);
880 $pl->ext_reply ($msg->{msgid}, %reply);
881 }
882 } 1178 }
1179
1180 $pl->ext_reply ($reply, @reply)
1181 if $reply;
1182
883 } else { 1183 } else {
884 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n"; 1184 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
885 } 1185 }
886 1186
887 cf::override; 1187 cf::override;
888 }, 1188 },
889); 1189);
890 1190
891sub load_extension {
892 my ($path) = @_;
893
894 $path =~ /([^\/\\]+)\.ext$/ or die "$path";
895 my $base = $1;
896 my $pkg = $1;
897 $pkg =~ s/[^[:word:]]/_/g;
898 $pkg = "ext::$pkg";
899
900 warn "... loading '$path' into '$pkg'\n";
901
902 open my $fh, "<:utf8", $path
903 or die "$path: $!";
904
905 my $source =
906 "package $pkg; use strict; use utf8;\n"
907 . "#line 1 \"$path\"\n{\n"
908 . (do { local $/; <$fh> })
909 . "\n};\n1";
910
911 unless (eval $source) {
912 my $msg = $@ ? "$path: $@\n"
913 : "extension disabled.\n";
914 if ($source =~ /^#!.*perl.*#.*MANDATORY/m) { # ugly match
915 warn $@;
916 warn "mandatory extension failed to load, exiting.\n";
917 exit 1;
918 }
919 die $@;
920 }
921
922 push @EXTS, $pkg;
923}
924
925sub load_extensions { 1191sub load_extensions {
1192 cf::sync_job {
1193 my %todo;
1194
926 for my $ext (<$LIBDIR/*.ext>) { 1195 for my $path (<$LIBDIR/*.ext>) {
927 next unless -r $ext; 1196 next unless -r $path;
928 eval { 1197
929 load_extension $ext; 1198 $path =~ /([^\/\\]+)\.ext$/ or die "$path";
1199 my $base = $1;
1200 my $pkg = $1;
1201 $pkg =~ s/[^[:word:]]/_/g;
1202 $pkg = "ext::$pkg";
1203
1204 open my $fh, "<:utf8", $path
1205 or die "$path: $!";
1206
1207 my $source = do { local $/; <$fh> };
1208
1209 my %ext = (
1210 path => $path,
1211 base => $base,
1212 pkg => $pkg,
1213 );
1214
1215 $ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 }
1216 if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m;
1217
1218 $ext{source} =
1219 "package $pkg; use strict; use utf8;\n"
1220 . "#line 1 \"$path\"\n{\n"
1221 . $source
1222 . "\n};\n1";
1223
1224 $todo{$base} = \%ext;
1225 }
1226
1227 my %done;
1228 while (%todo) {
1229 my $progress;
1230
1231 while (my ($k, $v) = each %todo) {
1232 for (split /,\s*/, $v->{meta}{depends}) {
1233 goto skip
1234 unless exists $done{$_};
1235 }
1236
1237 warn "... loading '$k' into '$v->{pkg}'\n";
1238
1239 unless (eval $v->{source}) {
1240 my $msg = $@ ? "$v->{path}: $@\n"
1241 : "$v->{base}: extension inactive.\n";
1242
1243 if (exists $v->{meta}{mandatory}) {
1244 warn $msg;
1245 warn "mandatory extension failed to load, exiting.\n";
1246 exit 1;
1247 }
1248
1249 warn $msg;
1250 }
1251
1252 $done{$k} = delete $todo{$k};
1253 push @EXTS, $v->{pkg};
1254 $progress = 1;
930 1 1255 }
931 } or warn "$ext not loaded: $@"; 1256
1257 skip:
1258 die "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n"
1259 unless $progress;
1260 }
932 } 1261 };
933} 1262}
934 1263
935############################################################################# 1264#############################################################################
936 1265
1266=back
1267
937=head2 CORE EXTENSIONS 1268=head2 CORE EXTENSIONS
938 1269
939Functions and methods that extend core crossfire objects. 1270Functions and methods that extend core crossfire objects.
940 1271
941=cut 1272=cut
953Returns the given player object, loading it if necessary (might block). 1284Returns the given player object, loading it if necessary (might block).
954 1285
955=cut 1286=cut
956 1287
957sub playerdir($) { 1288sub playerdir($) {
958 cf::localdir 1289 "$PLAYERDIR/"
959 . "/"
960 . cf::playerdir
961 . "/"
962 . (ref $_[0] ? $_[0]->ob->name : $_[0]) 1290 . (ref $_[0] ? $_[0]->ob->name : $_[0])
963} 1291}
964 1292
965sub path($) { 1293sub path($) {
966 my $login = ref $_[0] ? $_[0]->ob->name : $_[0]; 1294 my $login = ref $_[0] ? $_[0]->ob->name : $_[0];
967 1295
968 (playerdir $login) . "/$login.pl" 1296 (playerdir $login) . "/playerdata"
969} 1297}
970 1298
971sub find_active($) { 1299sub find_active($) {
972 $cf::PLAYER{$_[0]} 1300 $cf::PLAYER{$_[0]}
973 and $cf::PLAYER{$_[0]}->active 1301 and $cf::PLAYER{$_[0]}->active
986 my $login = $_[0]; 1314 my $login = $_[0];
987 1315
988 my $guard = cf::lock_acquire "user_find:$login"; 1316 my $guard = cf::lock_acquire "user_find:$login";
989 1317
990 $cf::PLAYER{$_[0]} || do { 1318 $cf::PLAYER{$_[0]} || do {
991 my $pl = load_pl path $login 1319 # rename old playerfiles to new ones
1320 #TODO: remove when no longer required
1321 aio_link +(playerdir $login) . "/$login.pl.pst", (playerdir $login) . "/playerdata.pst";
1322 aio_link +(playerdir $login) . "/$login.pl" , (playerdir $login) . "/playerdata";
1323 aio_unlink +(playerdir $login) . "/$login.pl.pst";
1324 aio_unlink +(playerdir $login) . "/$login.pl";
1325
1326 my $f = new_from_file cf::object::thawer path $login
992 or return; 1327 or return;
1328
1329 $f->next;
1330 my $pl = cf::player::load_pl $f
1331 or return;
1332 local $cf::PLAYER_LOADING{$login} = $pl;
1333 $f->resolve_delayed_derefs;
993 $cf::PLAYER{$login} = $pl 1334 $cf::PLAYER{$login} = $pl
994 } 1335 }
995 } 1336 }
996} 1337}
997 1338
1007 1348
1008 aio_mkdir playerdir $pl, 0770; 1349 aio_mkdir playerdir $pl, 0770;
1009 $pl->{last_save} = $cf::RUNTIME; 1350 $pl->{last_save} = $cf::RUNTIME;
1010 1351
1011 $pl->save_pl ($path); 1352 $pl->save_pl ($path);
1012 Coro::cede; 1353 cf::cede_to_tick;
1013} 1354}
1014 1355
1015sub new($) { 1356sub new($) {
1016 my ($login) = @_; 1357 my ($login) = @_;
1017 1358
1021 $self->{deny_save} = 1; 1362 $self->{deny_save} = 1;
1022 1363
1023 $cf::PLAYER{$login} = $self; 1364 $cf::PLAYER{$login} = $self;
1024 1365
1025 $self 1366 $self
1367}
1368
1369=item $player->send_msg ($channel, $msg, $color, [extra...])
1370
1371=cut
1372
1373sub send_msg {
1374 my $ns = shift->ns
1375 or return;
1376 $ns->send_msg (@_);
1026} 1377}
1027 1378
1028=item $pl->quit_character 1379=item $pl->quit_character
1029 1380
1030Nukes the player without looking back. If logged in, the connection will 1381Nukes the player without looking back. If logged in, the connection will
1079while and may block, so not sync_job-capable, ever. 1430while and may block, so not sync_job-capable, ever.
1080 1431
1081=cut 1432=cut
1082 1433
1083sub list_logins { 1434sub list_logins {
1084 my $dirs = aio_readdir cf::localdir . "/" . cf::playerdir 1435 my $dirs = aio_readdir $PLAYERDIR
1085 or return []; 1436 or return [];
1086 1437
1087 my @logins; 1438 my @logins;
1088 1439
1089 for my $login (@$dirs) { 1440 for my $login (@$dirs) {
1441 my $path = path $login;
1442
1443 # a .pst is a dead give-away for a valid player
1444 unless (-e "$path.pst") {
1090 my $fh = aio_open path $login, Fcntl::O_RDONLY, 0 or next; 1445 my $fh = aio_open $path, Fcntl::O_RDONLY, 0 or next;
1091 aio_read $fh, 0, 512, my $buf, 0 or next; 1446 aio_read $fh, 0, 512, my $buf, 0 or next;
1092 $buf !~ /^password -------------$/m or next; # official not-valid tag 1447 $buf !~ /^password -------------$/m or next; # official not-valid tag
1448 }
1093 1449
1094 utf8::decode $login; 1450 utf8::decode $login;
1095 push @logins, $login; 1451 push @logins, $login;
1096 } 1452 }
1097 1453
1124 } 1480 }
1125 1481
1126 \@paths 1482 \@paths
1127} 1483}
1128 1484
1485=item $protocol_xml = $player->expand_cfpod ($crossfire_pod)
1486
1487Expand crossfire pod fragments into protocol xml.
1488
1489=cut
1490
1491sub expand_cfpod {
1492 ((my $self), (local $_)) = @_;
1493
1494 # escape & and <
1495 s/&/&amp;/g;
1496 s/(?<![BIUGHT])</&lt;/g;
1497
1498 # this is buggy, it needs to properly take care of nested <'s
1499
1500 1 while
1501 # replace B<>, I<>, U<> etc.
1502 s/B<([^\>]*)>/<b>$1<\/b>/
1503 || s/I<([^\>]*)>/<i>$1<\/i>/
1504 || s/U<([^\>]*)>/<u>$1<\/u>/
1505 || s/T<([^\>]*)>/<big><b>$1<\/b><\/big>/
1506 # replace G<male|female> tags
1507 || s{G<([^>|]*)\|([^>]*)>}{
1508 $self->gender ? $2 : $1
1509 }ge
1510 # replace H<hint text>
1511 || s{H<([^\>]*)>}
1512 {
1513 ("<fg name=\"lightblue\">[$1 (Use hintmode to suppress hints)]</fg>",
1514 "<fg name=\"lightblue\">[Hint suppressed, see hintmode]</fg>",
1515 "")
1516 [$self->{hintmode}]
1517 }ge;
1518
1519 # create single paragraphs (very hackish)
1520 s/(?<=\S)\n(?=\w)/ /g;
1521
1522 # compress some whitespace
1523 s/\s+\n/\n/g; # ws line-ends
1524 s/\n\n+/\n/g; # double lines
1525 s/^\n+//; # beginning lines
1526 s/\n+$//; # ending lines
1527
1528 $_
1529}
1530
1531sub hintmode {
1532 $_[0]{hintmode} = $_[1] if @_ > 1;
1533 $_[0]{hintmode}
1534}
1535
1129=item $player->ext_reply ($msgid, $msgtype, %msg) 1536=item $player->ext_reply ($msgid, @msg)
1130 1537
1131Sends an ext reply to the player. 1538Sends an ext reply to the player.
1132 1539
1133=cut 1540=cut
1134 1541
1135sub ext_reply($$$%) { 1542sub ext_reply($$@) {
1136 my ($self, $id, %msg) = @_; 1543 my ($self, $id, @msg) = @_;
1137 1544
1138 $msg{msgid} = $id; 1545 $self->ns->ext_reply ($id, @msg)
1139
1140 $self->send ("ext " . cf::to_json \%msg);
1141} 1546}
1142 1547
1143package cf; 1548=item $player->ext_msg ($type, @msg)
1549
1550Sends an ext event to the client.
1551
1552=cut
1553
1554sub ext_msg($$@) {
1555 my ($self, $type, @msg) = @_;
1556
1557 $self->ns->ext_msg ($type, @msg);
1558}
1559
1560=head3 cf::region
1561
1562=over 4
1563
1564=cut
1565
1566package cf::region;
1567
1568=item cf::region::find_by_path $path
1569
1570Tries to decuce the likely region for a map knowing only its path.
1571
1572=cut
1573
1574sub find_by_path($) {
1575 my ($path) = @_;
1576
1577 my ($match, $specificity);
1578
1579 for my $region (list) {
1580 if ($region->{match} && $path =~ $region->{match}) {
1581 ($match, $specificity) = ($region, $region->specificity)
1582 if $region->specificity > $specificity;
1583 }
1584 }
1585
1586 $match
1587}
1144 1588
1145=back 1589=back
1146
1147 1590
1148=head3 cf::map 1591=head3 cf::map
1149 1592
1150=over 4 1593=over 4
1151 1594
1206 my ($self, $merge) = @_; 1649 my ($self, $merge) = @_;
1207 1650
1208 # we have to keep some variables in memory intact 1651 # we have to keep some variables in memory intact
1209 local $self->{path}; 1652 local $self->{path};
1210 local $self->{load_path}; 1653 local $self->{load_path};
1211 local $self->{deny_save};
1212 local $self->{deny_reset};
1213 1654
1214 $self->SUPER::thawer_merge ($merge); 1655 $self->SUPER::thawer_merge ($merge);
1215} 1656}
1216 1657
1217sub normalise { 1658sub normalise {
1264 $self->init; # pass $1 etc. 1705 $self->init; # pass $1 etc.
1265 return $self; 1706 return $self;
1266 } 1707 }
1267 } 1708 }
1268 1709
1269 Carp::carp "unable to resolve path '$path' (base '$base')."; 1710 Carp::cluck "unable to resolve path '$path' (base '$base').";
1270 () 1711 ()
1271} 1712}
1272 1713
1273sub init { 1714sub init {
1274 my ($self) = @_; 1715 my ($self) = @_;
1289 1730
1290# the original (read-only) location 1731# the original (read-only) location
1291sub load_path { 1732sub load_path {
1292 my ($self) = @_; 1733 my ($self) = @_;
1293 1734
1294 sprintf "%s/%s/%s.map", cf::datadir, cf::mapdir, $self->{path} 1735 "$MAPDIR/$self->{path}.map"
1295} 1736}
1296 1737
1297# the temporary/swap location 1738# the temporary/swap location
1298sub save_path { 1739sub save_path {
1299 my ($self) = @_; 1740 my ($self) = @_;
1300 1741
1301 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g; 1742 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g;
1302 sprintf "%s/%s/%s.map", cf::localdir, cf::tmpdir, $path 1743 "$TMPDIR/$path.map"
1303} 1744}
1304 1745
1305# the unique path, undef == no special unique path 1746# the unique path, undef == no special unique path
1306sub uniq_path { 1747sub uniq_path {
1307 my ($self) = @_; 1748 my ($self) = @_;
1308 1749
1309 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g; 1750 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g;
1310 sprintf "%s/%s/%s", cf::localdir, cf::uniquedir, $path 1751 "$UNIQUEDIR/$path"
1311} 1752}
1312 1753
1313# and all this just because we cannot iterate over 1754# and all this just because we cannot iterate over
1314# all maps in C++... 1755# all maps in C++...
1315sub change_all_map_light { 1756sub change_all_map_light {
1317 1758
1318 $_->change_map_light ($change) 1759 $_->change_map_light ($change)
1319 for grep $_->outdoor, values %cf::MAP; 1760 for grep $_->outdoor, values %cf::MAP;
1320} 1761}
1321 1762
1763sub decay_objects {
1764 my ($self) = @_;
1765
1766 return if $self->{deny_reset};
1767
1768 $self->do_decay_objects;
1769}
1770
1322sub unlink_save { 1771sub unlink_save {
1323 my ($self) = @_; 1772 my ($self) = @_;
1324 1773
1325 utf8::encode (my $save = $self->save_path); 1774 utf8::encode (my $save = $self->save_path);
1326 IO::AIO::aioreq_pri 4; Coro::AIO::aio_unlink $save; 1775 IO::AIO::aioreq_pri 4; Coro::AIO::aio_unlink $save;
1329 1778
1330sub load_header_from($) { 1779sub load_header_from($) {
1331 my ($self, $path) = @_; 1780 my ($self, $path) = @_;
1332 1781
1333 utf8::encode $path; 1782 utf8::encode $path;
1334 #aio_open $path, O_RDONLY, 0 1783 my $f = new_from_file cf::object::thawer $path
1335 # or return;
1336
1337 $self->_load_header ($path)
1338 or return; 1784 or return;
1785
1786 $self->_load_header ($f)
1787 or return;
1788
1789 local $MAP_LOADING{$self->{path}} = $self;
1790 $f->resolve_delayed_derefs;
1339 1791
1340 $self->{load_path} = $path; 1792 $self->{load_path} = $path;
1341 1793
1342 1 1794 1
1343} 1795}
1382 $self->load_header_orig 1834 $self->load_header_orig
1383 or return; 1835 or return;
1384 $self->prepare_orig; 1836 $self->prepare_orig;
1385 } 1837 }
1386 1838
1839 $self->{deny_reset} = 1
1840 if $self->no_reset;
1841
1842 $self->default_region (cf::region::find_by_path $self->{path})
1843 unless $self->default_region;
1844
1387 1 1845 1
1388} 1846}
1389 1847
1390sub find; 1848sub find;
1391sub find { 1849sub find {
1392 my ($path, $origin) = @_; 1850 my ($path, $origin) = @_;
1393 1851
1394 $path = normalise $path, $origin && $origin->path; 1852 $path = normalise $path, $origin && $origin->path;
1395 1853
1854 cf::lock_wait "map_data:$path";#d#remove
1396 cf::lock_wait "map_find:$path"; 1855 cf::lock_wait "map_find:$path";
1397 1856
1398 $cf::MAP{$path} || do { 1857 $cf::MAP{$path} || do {
1399 my $guard = cf::lock_acquire "map_find:$path"; 1858 my $guard1 = cf::lock_acquire "map_find:$path";
1859 my $guard2 = cf::lock_acquire "map_data:$path"; # just for the fun of it
1860
1400 my $map = new_from_path cf::map $path 1861 my $map = new_from_path cf::map $path
1401 or return; 1862 or return;
1402 1863
1403 $map->{last_save} = $cf::RUNTIME; 1864 $map->{last_save} = $cf::RUNTIME;
1404 1865
1405 $map->load_header 1866 $map->load_header
1406 or return; 1867 or return;
1407 1868
1408 if ($map->should_reset && 0) {#d#TODO# disabled, crashy (locking issue?) 1869 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?)
1409 # doing this can freeze the server in a sync job, obviously 1870 # doing this can freeze the server in a sync job, obviously
1410 #$cf::WAIT_FOR_TICK->wait; 1871 #$cf::WAIT_FOR_TICK->wait;
1872 undef $guard1;
1873 undef $guard2;
1411 $map->reset; 1874 $map->reset;
1412 undef $guard;
1413 return find $path; 1875 return find $path;
1414 } 1876 }
1415 1877
1416 $cf::MAP{$path} = $map 1878 $cf::MAP{$path} = $map
1417 } 1879 }
1424 my ($self) = @_; 1886 my ($self) = @_;
1425 1887
1426 local $self->{deny_reset} = 1; # loading can take a long time 1888 local $self->{deny_reset} = 1; # loading can take a long time
1427 1889
1428 my $path = $self->{path}; 1890 my $path = $self->{path};
1891
1892 {
1429 my $guard = cf::lock_acquire "map_load:$path"; 1893 my $guard = cf::lock_acquire "map_data:$path";
1430 1894
1895 return unless $self->valid;
1431 return if $self->in_memory != cf::MAP_SWAPPED; 1896 return unless $self->in_memory == cf::MAP_SWAPPED;
1432 1897
1433 $self->in_memory (cf::MAP_LOADING); 1898 $self->in_memory (cf::MAP_LOADING);
1434 1899
1435 $self->alloc; 1900 $self->alloc;
1436 1901
1437 $self->pre_load; 1902 $self->pre_load;
1903 cf::cede_to_tick;
1438 1904
1439 $self->_load_objects ($self->{load_path}, 1) 1905 my $f = new_from_file cf::object::thawer $self->{load_path};
1906 $f->skip_block;
1907 $self->_load_objects ($f)
1440 or return; 1908 or return;
1441 1909
1442 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1) 1910 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1)
1443 if delete $self->{load_original}; 1911 if delete $self->{load_original};
1444 1912
1445 if (my $uniq = $self->uniq_path) { 1913 if (my $uniq = $self->uniq_path) {
1446 utf8::encode $uniq; 1914 utf8::encode $uniq;
1447 if (aio_open $uniq, O_RDONLY, 0) { 1915 unless (aio_stat $uniq) {
1916 if (my $f = new_from_file cf::object::thawer $uniq) {
1448 $self->clear_unique_items; 1917 $self->clear_unique_items;
1449 $self->_load_objects ($uniq, 0); 1918 $self->_load_objects ($f);
1919 $f->resolve_delayed_derefs;
1920 }
1450 } 1921 }
1451 } 1922 }
1452 1923
1453 Coro::cede; 1924 $f->resolve_delayed_derefs;
1454 1925
1926 cf::cede_to_tick;
1455 # now do the right thing for maps 1927 # now do the right thing for maps
1456 $self->link_multipart_objects; 1928 $self->link_multipart_objects;
1457
1458 unless ($self->{deny_activate}) {
1459 $self->decay_objects;
1460 $self->fix_auto_apply;
1461 $self->update_buttons;
1462 Coro::cede;
1463 $self->set_darkness_map;
1464 $self->difficulty ($self->estimate_difficulty) 1929 $self->difficulty ($self->estimate_difficulty)
1465 unless $self->difficulty; 1930 unless $self->difficulty;
1466 Coro::cede; 1931 cf::cede_to_tick;
1932
1933 unless ($self->{deny_activate}) {
1934 $self->decay_objects;
1935 $self->fix_auto_apply;
1936 $self->update_buttons;
1937 cf::cede_to_tick;
1938 $self->set_darkness_map;
1939 cf::cede_to_tick;
1467 $self->activate; 1940 $self->activate;
1941 }
1942
1943 $self->{last_save} = $cf::RUNTIME;
1944 $self->last_access ($cf::RUNTIME);
1945
1946 $self->in_memory (cf::MAP_IN_MEMORY);
1468 } 1947 }
1469 1948
1470 $self->post_load; 1949 $self->post_load;
1471
1472 $self->in_memory (cf::MAP_IN_MEMORY);
1473} 1950}
1474 1951
1475sub customise_for { 1952sub customise_for {
1476 my ($self, $ob) = @_; 1953 my ($self, $ob) = @_;
1477 1954
1478 return find "~" . $ob->name . "/" . $self->{path} 1955 return find "~" . $ob->name . "/" . $self->{path}
1479 if $self->per_player; 1956 if $self->per_player;
1480 1957
1958# return find "?party/" . $ob->name . "/" . $self->{path}
1959# if $self->per_party;
1960
1481 $self 1961 $self
1482} 1962}
1483 1963
1484# find and load all maps in the 3x3 area around a map 1964# find and load all maps in the 3x3 area around a map
1485sub load_diag { 1965sub load_neighbours {
1486 my ($map) = @_; 1966 my ($map) = @_;
1487 1967
1488 my @diag; # diagonal neighbours 1968 my @neigh; # diagonal neighbours
1489 1969
1490 for (0 .. 3) { 1970 for (0 .. 3) {
1491 my $neigh = $map->tile_path ($_) 1971 my $neigh = $map->tile_path ($_)
1492 or next; 1972 or next;
1493 $neigh = find $neigh, $map 1973 $neigh = find $neigh, $map
1494 or next; 1974 or next;
1495 $neigh->load; 1975 $neigh->load;
1496 1976
1977 push @neigh,
1497 push @diag, [$neigh->tile_path (($_ + 3) % 4), $neigh], 1978 [$neigh->tile_path (($_ + 3) % 4), $neigh],
1498 [$neigh->tile_path (($_ + 1) % 4), $neigh]; 1979 [$neigh->tile_path (($_ + 1) % 4), $neigh];
1499 } 1980 }
1500 1981
1501 for (@diag) { 1982 for (grep defined $_->[0], @neigh) {
1983 my ($path, $origin) = @$_;
1502 my $neigh = find @$_ 1984 my $neigh = find $path, $origin
1503 or next; 1985 or next;
1504 $neigh->load; 1986 $neigh->load;
1505 } 1987 }
1506} 1988}
1507 1989
1512} 1994}
1513 1995
1514sub do_load_sync { 1996sub do_load_sync {
1515 my ($map) = @_; 1997 my ($map) = @_;
1516 1998
1999 cf::LOG cf::llevDebug | cf::logBacktrace, "do_load_sync"
2000 if $Coro::current == $Coro::main;
2001
1517 cf::sync_job { $map->load }; 2002 cf::sync_job { $map->load };
1518} 2003}
1519 2004
1520our %MAP_PREFETCH; 2005our %MAP_PREFETCH;
1521our $MAP_PREFETCHER = undef; 2006our $MAP_PREFETCHER = undef;
1522 2007
1523sub find_async { 2008sub find_async {
1524 my ($path, $origin) = @_; 2009 my ($path, $origin, $load) = @_;
1525 2010
1526 $path = normalise $path, $origin && $origin->{path}; 2011 $path = normalise $path, $origin && $origin->{path};
1527 2012
1528 if (my $map = $cf::MAP{$path}) { 2013 if (my $map = $cf::MAP{$path}) {
1529 return $map if $map->in_memory == cf::MAP_IN_MEMORY; 2014 return $map if !$load || $map->in_memory == cf::MAP_IN_MEMORY;
1530 } 2015 }
1531 2016
1532 undef $MAP_PREFETCH{$path}; 2017 $MAP_PREFETCH{$path} |= $load;
2018
1533 $MAP_PREFETCHER ||= cf::async { 2019 $MAP_PREFETCHER ||= cf::async {
1534 while (%MAP_PREFETCH) { 2020 while (%MAP_PREFETCH) {
1535 for my $path (keys %MAP_PREFETCH) { 2021 while (my ($k, $v) = each %MAP_PREFETCH) {
1536 my $map = find $path 2022 if (my $map = find $k) {
1537 or next;
1538 $map->load; 2023 $map->load if $v;
2024 }
1539 2025
1540 delete $MAP_PREFETCH{$path}; 2026 delete $MAP_PREFETCH{$k};
1541 } 2027 }
1542 } 2028 }
1543 undef $MAP_PREFETCHER; 2029 undef $MAP_PREFETCHER;
1544 }; 2030 };
1545 $MAP_PREFETCHER->prio (6); 2031 $MAP_PREFETCHER->prio (6);
1548} 2034}
1549 2035
1550sub save { 2036sub save {
1551 my ($self) = @_; 2037 my ($self) = @_;
1552 2038
1553 my $lock = cf::lock_acquire "map_data:" . $self->path; 2039 my $lock = cf::lock_acquire "map_data:$self->{path}";
1554 2040
1555 $self->{last_save} = $cf::RUNTIME; 2041 $self->{last_save} = $cf::RUNTIME;
1556 2042
1557 return unless $self->dirty; 2043 return unless $self->dirty;
1558 2044
1581 my ($self) = @_; 2067 my ($self) = @_;
1582 2068
1583 # save first because save cedes 2069 # save first because save cedes
1584 $self->save; 2070 $self->save;
1585 2071
1586 my $lock = cf::lock_acquire "map_data:" . $self->path; 2072 my $lock = cf::lock_acquire "map_data:$self->{path}";
1587 2073
1588 return if $self->players; 2074 return if $self->players;
1589 return if $self->in_memory != cf::MAP_IN_MEMORY; 2075 return if $self->in_memory != cf::MAP_IN_MEMORY;
1590 return if $self->{deny_save}; 2076 return if $self->{deny_save};
1591 2077
2078 $self->in_memory (cf::MAP_SWAPPED);
2079
2080 $self->deactivate;
2081 $_->clear_links_to ($self) for values %cf::MAP;
1592 $self->clear; 2082 $self->clear;
1593 $self->in_memory (cf::MAP_SWAPPED);
1594} 2083}
1595 2084
1596sub reset_at { 2085sub reset_at {
1597 my ($self) = @_; 2086 my ($self) = @_;
1598 2087
1599 # TODO: safety, remove and allow resettable per-player maps 2088 # TODO: safety, remove and allow resettable per-player maps
1600 return 1e99 if $self->isa ("ext::map_per_player");#d#
1601 return 1e99 if $self->{deny_reset}; 2089 return 1e99 if $self->{deny_reset};
1602 2090
1603 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access; 2091 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
1604 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET; 2092 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET;
1605 2093
1616 my ($self) = @_; 2104 my ($self) = @_;
1617 2105
1618 my $lock = cf::lock_acquire "map_data:$self->{path}"; 2106 my $lock = cf::lock_acquire "map_data:$self->{path}";
1619 2107
1620 return if $self->players; 2108 return if $self->players;
1621 return if $self->isa ("ext::map_per_player");#d#
1622 2109
1623 warn "resetting map ", $self->path;#d# 2110 warn "resetting map ", $self->path;
1624 2111
1625 $self->in_memory (cf::MAP_SWAPPED); 2112 $self->in_memory (cf::MAP_SWAPPED);
1626 2113
1627 # need to save uniques path 2114 # need to save uniques path
1628 unless ($self->{deny_save}) { 2115 unless ($self->{deny_save}) {
1632 if $uniq; 2119 if $uniq;
1633 } 2120 }
1634 2121
1635 delete $cf::MAP{$self->path}; 2122 delete $cf::MAP{$self->path};
1636 2123
2124 $self->deactivate;
2125 $_->clear_links_to ($self) for values %cf::MAP;
1637 $self->clear; 2126 $self->clear;
1638
1639 $_->clear_links_to ($self) for values %cf::MAP;
1640 2127
1641 $self->unlink_save; 2128 $self->unlink_save;
1642 $self->destroy; 2129 $self->destroy;
1643} 2130}
1644 2131
1645my $nuke_counter = "aaaa"; 2132my $nuke_counter = "aaaa";
1646 2133
1647sub nuke { 2134sub nuke {
1648 my ($self) = @_; 2135 my ($self) = @_;
1649 2136
2137 {
2138 my $lock = cf::lock_acquire "map_data:$self->{path}";
2139
1650 delete $cf::MAP{$self->path}; 2140 delete $cf::MAP{$self->path};
1651 2141
1652 $self->unlink_save; 2142 $self->unlink_save;
1653 2143
1654 bless $self, "cf::map"; 2144 bless $self, "cf::map";
1655 delete $self->{deny_reset}; 2145 delete $self->{deny_reset};
1656 $self->{deny_save} = 1; 2146 $self->{deny_save} = 1;
1657 $self->reset_timeout (1); 2147 $self->reset_timeout (1);
1658 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++)); 2148 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));
1659 2149
1660 $cf::MAP{$self->path} = $self; 2150 $cf::MAP{$self->path} = $self;
2151 }
1661 2152
1662 $self->reset; # polite request, might not happen 2153 $self->reset; # polite request, might not happen
2154}
2155
2156=item $maps = cf::map::tmp_maps
2157
2158Returns an arrayref with all map paths of currently instantiated and saved
2159maps. May block.
2160
2161=cut
2162
2163sub tmp_maps() {
2164 [
2165 map {
2166 utf8::decode $_;
2167 /\.map$/
2168 ? normalise $_
2169 : ()
2170 } @{ aio_readdir $TMPDIR or [] }
2171 ]
2172}
2173
2174=item $maps = cf::map::random_maps
2175
2176Returns an arrayref with all map paths of currently instantiated and saved
2177random maps. May block.
2178
2179=cut
2180
2181sub random_maps() {
2182 [
2183 map {
2184 utf8::decode $_;
2185 /\.map$/
2186 ? normalise "?random/$_"
2187 : ()
2188 } @{ aio_readdir $RANDOMDIR or [] }
2189 ]
1663} 2190}
1664 2191
1665=item cf::map::unique_maps 2192=item cf::map::unique_maps
1666 2193
1667Returns an arrayref of paths of all shared maps that have 2194Returns an arrayref of paths of all shared maps that have
1668instantiated unique items. May block. 2195instantiated unique items. May block.
1669 2196
1670=cut 2197=cut
1671 2198
1672sub unique_maps() { 2199sub unique_maps() {
1673 my $files = aio_readdir cf::localdir . "/" . cf::uniquedir 2200 [
1674 or return; 2201 map {
1675
1676 my @paths;
1677
1678 for (@$files) {
1679 utf8::decode $_; 2202 utf8::decode $_;
1680 next if /\.pst$/; 2203 /\.map$/
1681 next unless /^$PATH_SEP/o; 2204 ? normalise $_
1682 2205 : ()
1683 push @paths, cf::map::normalise $_; 2206 } @{ aio_readdir $UNIQUEDIR or [] }
1684 } 2207 ]
1685
1686 \@paths
1687} 2208}
1688 2209
1689package cf; 2210package cf;
1690 2211
1691=back 2212=back
1709 map { $_, inv_recursive_ $_->inv } @_ 2230 map { $_, inv_recursive_ $_->inv } @_
1710} 2231}
1711 2232
1712sub inv_recursive { 2233sub inv_recursive {
1713 inv_recursive_ inv $_[0] 2234 inv_recursive_ inv $_[0]
2235}
2236
2237=item $ref = $ob->ref
2238
2239creates and returns a persistent reference to an objetc that can be stored as a string.
2240
2241=item $ob = cf::object::deref ($refstring)
2242
2243returns the objetc referenced by refstring. may return undef when it cnanot find the object,
2244even if the object actually exists. May block.
2245
2246=cut
2247
2248sub deref {
2249 my ($ref) = @_;
2250
2251 # temporary compatibility#TODO#remove
2252 $ref =~ s{^<}{player/<};
2253
2254 if ($ref =~ m{^player\/(<1\.\d+>)/(.*)$}) {
2255 my ($uuid, $name) = ($1, $2);
2256 my $pl = $cf::PLAYER_LOADING{$name} || cf::player::find $name
2257 or return;
2258 $pl->ob->uuid eq $uuid
2259 or return;
2260
2261 $pl->ob
2262 } else {
2263 warn "$ref: cannot resolve object reference\n";
2264 undef
2265 }
1714} 2266}
1715 2267
1716package cf; 2268package cf;
1717 2269
1718=back 2270=back
1737 2289
1738 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4; 2290 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4;
1739 2291
1740 if ($self->{record_replies}) { 2292 if ($self->{record_replies}) {
1741 push @{ $self->{record_replies} }, [$npc, $msg, $flags]; 2293 push @{ $self->{record_replies} }, [$npc, $msg, $flags];
2294
1742 } else { 2295 } else {
2296 my $pl = $self->contr;
2297
2298 if ($pl->{npc_dialog} && $pl->{npc_dialog}->{id}) {
2299 my $dialog = $pl->{npc_dialog};
2300 $dialog->{pl}->ext_msg ($dialog->{id}, update => msg => $dialog->{pl}->expand_cfpod ($msg));
2301
2302 } else {
1743 $msg = $npc->name . " says: $msg" if $npc; 2303 $msg = $npc->name . " says: $msg" if $npc;
1744 $self->message ($msg, $flags); 2304 $self->message ($msg, $flags);
2305 }
1745 } 2306 }
2307}
2308
2309=item $object->send_msg ($channel, $msg, $color, [extra...])
2310
2311=cut
2312
2313sub cf::object::send_msg {
2314 my $pl = shift->contr
2315 or return;
2316 $pl->send_msg (@_);
1746} 2317}
1747 2318
1748=item $player_object->may ("access") 2319=item $player_object->may ("access")
1749 2320
1750Returns wether the given player is authorized to access resource "access" 2321Returns wether the given player is authorized to access resource "access"
1797 $self->deactivate_recursive; 2368 $self->deactivate_recursive;
1798 2369
1799 return if UNIVERSAL::isa $self->map, "ext::map_link"; 2370 return if UNIVERSAL::isa $self->map, "ext::map_link";
1800 2371
1801 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y] 2372 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y]
1802 if $self->map; 2373 if $self->map && $self->map->{path} ne "{link}";
1803 2374
1804 $self->enter_map ($LINK_MAP || link_map, 10, 10); 2375 $self->enter_map ($LINK_MAP || link_map, 10, 10);
1805} 2376}
1806 2377
1807sub cf::object::player::leave_link { 2378sub cf::object::player::leave_link {
1808 my ($self, $map, $x, $y) = @_; 2379 my ($self, $map, $x, $y) = @_;
2380
2381 return unless $self->contr->active;
1809 2382
1810 my $link_pos = delete $self->{_link_pos}; 2383 my $link_pos = delete $self->{_link_pos};
1811 2384
1812 unless ($map) { 2385 unless ($map) {
1813 # restore original map position 2386 # restore original map position
1827 # use -1 or undef as default coordinates, not 0, 0 2400 # use -1 or undef as default coordinates, not 0, 0
1828 ($x, $y) = ($map->enter_x, $map->enter_y) 2401 ($x, $y) = ($map->enter_x, $map->enter_y)
1829 if $x <=0 && $y <= 0; 2402 if $x <=0 && $y <= 0;
1830 2403
1831 $map->load; 2404 $map->load;
1832 $map->load_diag; 2405 $map->load_neighbours;
1833 2406
1834 return unless $self->contr->active; 2407 return unless $self->contr->active;
1835 $self->activate_recursive; 2408 $self->activate_recursive;
1836 2409
1837 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext 2410 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
1838 $self->enter_map ($map, $x, $y); 2411 $self->enter_map ($map, $x, $y);
1839} 2412}
1840 2413
1841cf::player->attach ( 2414=item $player_object->goto ($path, $x, $y[, $check->($map)[, $done->()]])
1842 on_logout => sub {
1843 my ($pl) = @_;
1844 2415
1845 # abort map switching before logout 2416Moves the player to the given map-path and coordinates by first freezing
1846 if ($pl->ob->{_link_pos}) { 2417her, loading and preparing them map, calling the provided $check callback
1847 cf::sync_job { 2418that has to return the map if sucecssful, and then unfreezes the player on
1848 $pl->ob->leave_link 2419the new (success) or old (failed) map position. In either case, $done will
1849 }; 2420be called at the end of this process.
1850 }
1851 },
1852 on_login => sub {
1853 my ($pl) = @_;
1854 2421
1855 # try to abort aborted map switching on player login :)
1856 # should happen only on crashes
1857 if ($pl->ob->{_link_pos}) {
1858 $pl->ob->enter_link;
1859 (async {
1860 $pl->ob->reply (undef,
1861 "There was an internal problem at your last logout, "
1862 . "the server will try to bring you to your intended destination in a second.",
1863 cf::NDI_RED);
1864 # we need this sleep as the login has a concurrent enter_exit running
1865 # and this sleep increases chances of the player not ending up in scorn
1866 Coro::Timer::sleep 1;
1867 $pl->ob->leave_link;
1868 })->prio (2);
1869 }
1870 },
1871);
1872
1873=item $player_object->goto ($path, $x, $y)
1874
1875=cut 2422=cut
2423
2424our $GOTOGEN;
1876 2425
1877sub cf::object::player::goto { 2426sub cf::object::player::goto {
1878 my ($self, $path, $x, $y) = @_; 2427 my ($self, $path, $x, $y, $check, $done) = @_;
2428
2429 # do generation counting so two concurrent goto's will be executed in-order
2430 my $gen = $self->{_goto_generation} = ++$GOTOGEN;
1879 2431
1880 $self->enter_link; 2432 $self->enter_link;
1881 2433
1882 (async { 2434 (async {
1883 my $map = eval { 2435 my $map = eval {
1884 my $map = cf::map::find $path; 2436 my $map = cf::map::find $path;
2437
2438 if ($map) {
1885 $map = $map->customise_for ($self) if $map; 2439 $map = $map->customise_for ($self);
2440 $map = $check->($map) if $check && $map;
2441 } else {
2442 $self->message ("The exit to '$path' is closed", cf::NDI_UNIQUE | cf::NDI_RED);
2443 }
2444
1886 $map 2445 $map
2446 };
2447
2448 if ($@) {
2449 $self->message ("Something went wrong within the server, please report this incident!", cf::NDI_UNIQUE | cf::NDI_RED);
2450 LOG llevError | logBacktrace, Carp::longmess $@;
1887 } or 2451 }
1888 $self->message ("The exit to '$path' is closed", cf::NDI_UNIQUE | cf::NDI_RED);
1889 2452
2453 if ($gen == $self->{_goto_generation}) {
2454 delete $self->{_goto_generation};
1890 $self->leave_link ($map, $x, $y); 2455 $self->leave_link ($map, $x, $y);
2456 }
2457
2458 $done->() if $done;
1891 })->prio (1); 2459 })->prio (1);
1892} 2460}
1893 2461
1894=item $player_object->enter_exit ($exit_object) 2462=item $player_object->enter_exit ($exit_object)
1895 2463
1934 2502
1935 $rmp->{random_seed} ||= $exit->random_seed; 2503 $rmp->{random_seed} ||= $exit->random_seed;
1936 2504
1937 my $data = cf::to_json $rmp; 2505 my $data = cf::to_json $rmp;
1938 my $md5 = Digest::MD5::md5_hex $data; 2506 my $md5 = Digest::MD5::md5_hex $data;
1939 my $meta = "$cf::RANDOM_MAPS/$md5.meta"; 2507 my $meta = "$RANDOMDIR/$md5.meta";
1940 2508
1941 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) { 2509 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) {
1942 aio_write $fh, 0, (length $data), $data, 0; 2510 aio_write $fh, 0, (length $data), $data, 0;
1943 undef $fh; 2511 undef $fh;
1944 aio_rename "$meta~", $meta; 2512 aio_rename "$meta~", $meta;
1953 2521
1954 return unless $self->type == cf::PLAYER; 2522 return unless $self->type == cf::PLAYER;
1955 2523
1956 if ($exit->slaying eq "/!") { 2524 if ($exit->slaying eq "/!") {
1957 #TODO: this should de-fi-ni-te-ly not be a sync-job 2525 #TODO: this should de-fi-ni-te-ly not be a sync-job
2526 # the problem is that $exit might not survive long enough
2527 # so it needs to be done right now, right here
1958 cf::sync_job { prepare_random_map $exit }; 2528 cf::sync_job { prepare_random_map $exit };
1959 } 2529 }
1960 2530
1961 my $slaying = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path; 2531 my $slaying = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path;
1962 my $hp = $exit->stats->hp; 2532 my $hp = $exit->stats->hp;
1963 my $sp = $exit->stats->sp; 2533 my $sp = $exit->stats->sp;
1964 2534
1965 $self->enter_link; 2535 $self->enter_link;
2536
2537 # if exit is damned, update players death & WoR home-position
2538 $self->contr->savebed ($slaying, $hp, $sp)
2539 if $exit->flag (FLAG_DAMNED);
1966 2540
1967 (async { 2541 (async {
1968 $self->deactivate_recursive; # just to be sure 2542 $self->deactivate_recursive; # just to be sure
1969 unless (eval { 2543 unless (eval {
1970 $self->goto ($slaying, $hp, $sp); 2544 $self->goto ($slaying, $hp, $sp);
1971 2545
1972 1; 2546 1;
1973 }) { 2547 }) {
1974 $self->message ("Something went wrong deep within the crossfire server. " 2548 $self->message ("Something went wrong deep within the crossfire server. "
1975 . "I'll try to bring you back to the map you were before. " 2549 . "I'll try to bring you back to the map you were before. "
1976 . "Please report this to the dungeon master!", 2550 . "Please report this to the dungeon master!",
1977 cf::NDI_UNIQUE | cf::NDI_RED); 2551 cf::NDI_UNIQUE | cf::NDI_RED);
1978 2552
1979 warn "ERROR in enter_exit: $@"; 2553 warn "ERROR in enter_exit: $@";
1980 $self->leave_link; 2554 $self->leave_link;
1981 } 2555 }
1982 })->prio (1); 2556 })->prio (1);
1998 2572
1999 utf8::encode $text; 2573 utf8::encode $text;
2000 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text); 2574 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);
2001} 2575}
2002 2576
2577=item $client->send_msg ($channel, $msg, $color, [extra...])
2578
2579Send a drawinfo or msg packet to the client, formatting the msg for the
2580client if neccessary. C<$type> should be a string identifying the type of
2581the message, with C<log> being the default. If C<$color> is negative, suppress
2582the message unless the client supports the msg packet.
2583
2584=cut
2585
2586our %CHANNEL = (
2587 "c/identify" => {
2588 id => "identify",
2589 title => "Identify",
2590 reply => undef,
2591 tooltip => "Items recently identified",
2592 },
2593 "c/examine" => {
2594 id => "examine",
2595 title => "Examine",
2596 reply => undef,
2597 tooltip => "Signs and other items you examined",
2598 },
2599);
2600
2601sub cf::client::send_msg {
2602 my ($self, $channel, $msg, $color, @extra) = @_;
2603
2604 $msg = $self->pl->expand_cfpod ($msg);
2605
2606 $color &= cf::NDI_CLIENT_MASK; # just in case...
2607
2608 # check predefined channels, for the benefit of C
2609 $channel = $CHANNEL{$channel} if $CHANNEL{$channel};
2610
2611 if (ref $channel) {
2612 # send meta info to client, if not yet sent
2613 unless (exists $self->{channel}{$channel->{id}}) {
2614 $self->{channel}{$channel->{id}} = $channel;
2615 $self->ext_msg (channel_info => $channel)
2616 if $self->can_msg;
2617 }
2618
2619 $channel = $channel->{id};
2620 }
2621
2622 return unless @extra || length $msg;
2623
2624 if ($self->can_msg) {
2625 # default colour, mask it out
2626 $color &= ~(cf::NDI_COLOR_MASK | cf::NDI_DEF)
2627 if $color & cf::NDI_DEF;
2628
2629 $self->send_packet ("msg " . $self->{json_coder}->encode (
2630 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]));
2631 } else {
2632 if ($color >= 0) {
2633 # replace some tags by gcfclient-compatible ones
2634 for ($msg) {
2635 1 while
2636 s/<b>([^<]*)<\/b>/[b]${1}[\/b]/
2637 || s/<i>([^<]*)<\/i>/[i]${1}[\/i]/
2638 || s/<u>([^<]*)<\/u>/[ul]${1}[\/ul]/
2639 || s/<tt>([^<]*)<\/tt>/[fixed]${1}[\/fixed]/
2640 || s/<fg name=\"([^"]+)\">([^<]*)<\/fg>/[color=$1]${2}[\/color]/;
2641 }
2642
2643 $color &= cf::NDI_COLOR_MASK;
2644
2645 utf8::encode $msg;
2646
2647 if (0 && $msg =~ /\[/) {
2648 # COMMAND/INFO
2649 $self->send_packet ("drawextinfo $color 10 8 $msg")
2650 } else {
2651 $msg =~ s/\[\/?(?:b|i|u|fixed|color)[^\]]*\]//g;
2652 $self->send_packet ("drawinfo $color $msg")
2653 }
2654 }
2655 }
2656}
2657
2658=item $client->ext_msg ($type, @msg)
2659
2660Sends an ext event to the client.
2661
2662=cut
2663
2664sub cf::client::ext_msg($$@) {
2665 my ($self, $type, @msg) = @_;
2666
2667 if ($self->extcmd == 2) {
2668 $self->send_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
2669 } elsif ($self->extcmd == 1) { # TODO: remove
2670 push @msg, msgtype => "event_$type";
2671 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2672 }
2673}
2674
2675=item $client->ext_reply ($msgid, @msg)
2676
2677Sends an ext reply to the client.
2678
2679=cut
2680
2681sub cf::client::ext_reply($$@) {
2682 my ($self, $id, @msg) = @_;
2683
2684 if ($self->extcmd == 2) {
2685 $self->send_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg]));
2686 } elsif ($self->extcmd == 1) {
2687 #TODO: version 1, remove
2688 unshift @msg, msgtype => "reply", msgid => $id;
2689 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2690 }
2691}
2003 2692
2004=item $success = $client->query ($flags, "text", \&cb) 2693=item $success = $client->query ($flags, "text", \&cb)
2005 2694
2006Queues a query to the client, calling the given callback with 2695Queues a query to the client, calling the given callback with
2007the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>, 2696the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>,
2008C<cf::CS_QUERY_SINGLECHAR> or C<cf::CS_QUERY_HIDEINPUT> or C<0>. 2697C<cf::CS_QUERY_SINGLECHAR> or C<cf::CS_QUERY_HIDEINPUT> or C<0>.
2009 2698
2010Queries can fail, so check the return code. Or don't, as queries will become 2699Queries can fail, so check the return code. Or don't, as queries will
2011reliable at some point in the future. 2700become reliable at some point in the future.
2012 2701
2013=cut 2702=cut
2014 2703
2015sub cf::client::query { 2704sub cf::client::query {
2016 my ($self, $flags, $text, $cb) = @_; 2705 my ($self, $flags, $text, $cb) = @_;
2024 utf8::encode $text; 2713 utf8::encode $text;
2025 push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb]; 2714 push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb];
2026 2715
2027 $self->send_packet ($self->{query_queue}[0][0]) 2716 $self->send_packet ($self->{query_queue}[0][0])
2028 if @{ $self->{query_queue} } == 1; 2717 if @{ $self->{query_queue} } == 1;
2718
2719 1
2029} 2720}
2030 2721
2031cf::client->attach ( 2722cf::client->attach (
2723 on_connect => sub {
2724 my ($ns) = @_;
2725
2726 $ns->{json_coder} = JSON::XS->new->utf8->max_size (1e6)->convert_blessed;
2727 },
2032 on_reply => sub { 2728 on_reply => sub {
2033 my ($ns, $msg) = @_; 2729 my ($ns, $msg) = @_;
2034 2730
2035 # this weird shuffling is so that direct followup queries 2731 # this weird shuffling is so that direct followup queries
2036 # get handled first 2732 # get handled first
2048 } else { 2744 } else {
2049 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM; 2745 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM;
2050 } 2746 }
2051 } 2747 }
2052 }, 2748 },
2749 on_exticmd => sub {
2750 my ($ns, $buf) = @_;
2751
2752 my $msg = eval { $ns->{json_coder}->decode ($buf) };
2753
2754 if (ref $msg) {
2755 my ($type, $reply, @payload) =
2756 "ARRAY" eq ref $msg
2757 ? @$msg
2758 : ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
2759
2760 my @reply;
2761
2762 if (my $cb = $EXTICMD{$type}) {
2763 @reply = $cb->($ns, @payload);
2764 }
2765
2766 $ns->ext_reply ($reply, @reply)
2767 if $reply;
2768
2769 } else {
2770 warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";
2771 }
2772
2773 cf::override;
2774 },
2053); 2775);
2054 2776
2055=item $client->async (\&cb) 2777=item $client->async (\&cb)
2056 2778
2057Create a new coroutine, running the specified callback. The coroutine will 2779Create a new coroutine, running the specified callback. The coroutine will
2098our $safe = new Safe "safe"; 2820our $safe = new Safe "safe";
2099our $safe_hole = new Safe::Hole; 2821our $safe_hole = new Safe::Hole;
2100 2822
2101$SIG{FPE} = 'IGNORE'; 2823$SIG{FPE} = 'IGNORE';
2102 2824
2103$safe->permit_only (Opcode::opset qw(:base_core :base_mem :base_orig :base_math sort time)); 2825$safe->permit_only (Opcode::opset qw(
2826 :base_core :base_mem :base_orig :base_math
2827 grepstart grepwhile mapstart mapwhile
2828 sort time
2829));
2104 2830
2105# here we export the classes and methods available to script code 2831# here we export the classes and methods available to script code
2106 2832
2107=pod 2833=pod
2108 2834
2109The following fucntions and emthods are available within a safe environment: 2835The following functions and methods are available within a safe environment:
2110 2836
2111 cf::object contr pay_amount pay_player map 2837 cf::object
2838 contr pay_amount pay_player map x y force_find force_add
2839 insert remove name archname title slaying race decrease_ob_nr
2840
2112 cf::object::player player 2841 cf::object::player
2113 cf::player peaceful 2842 player
2114 cf::map trigger 2843
2844 cf::player
2845 peaceful
2846
2847 cf::map
2848 trigger
2115 2849
2116=cut 2850=cut
2117 2851
2118for ( 2852for (
2119 ["cf::object" => qw(contr pay_amount pay_player map)], 2853 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y
2854 insert remove inv name archname title slaying race
2855 decrease_ob_nr)],
2120 ["cf::object::player" => qw(player)], 2856 ["cf::object::player" => qw(player)],
2121 ["cf::player" => qw(peaceful)], 2857 ["cf::player" => qw(peaceful)],
2122 ["cf::map" => qw(trigger)], 2858 ["cf::map" => qw(trigger)],
2123) { 2859) {
2124 no strict 'refs'; 2860 no strict 'refs';
2195=back 2931=back
2196 2932
2197=cut 2933=cut
2198 2934
2199############################################################################# 2935#############################################################################
2200
2201=head2 EXTENSION DATABASE SUPPORT
2202
2203Crossfire maintains a very simple database for extension use. It can
2204currently store anything that can be serialised using Storable, which
2205excludes objects.
2206
2207The parameter C<$family> should best start with the name of the extension
2208using it, it should be unique.
2209
2210=over 4
2211
2212=item $value = cf::db_get $family => $key
2213
2214Returns a single value from the database.
2215
2216=item cf::db_put $family => $key => $value
2217
2218Stores the given C<$value> in the family.
2219
2220=cut
2221
2222our $DB;
2223
2224sub db_init {
2225 unless ($DB) {
2226 $DB = BDB::db_create $DB_ENV;
2227
2228 cf::sync_job {
2229 eval {
2230 $DB->set_flags (BDB::CHKSUM);
2231
2232 BDB::db_open $DB, undef, "db", undef, BDB::BTREE,
2233 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
2234 cf::cleanup "db_open(db): $!" if $!;
2235 };
2236 cf::cleanup "db_open(db): $@" if $@;
2237 };
2238
2239 my $path = cf::localdir . "/database.pst";
2240 if (stat $path) {
2241 cf::sync_job {
2242 my $pst = Storable::retrieve $path;
2243
2244 cf::db_put (board => data => $pst->{board});
2245 cf::db_put (guildrules => data => $pst->{guildrules});
2246 cf::db_put (rent => balance => $pst->{rent}{balance});
2247 BDB::db_env_txn_checkpoint $DB_ENV;
2248
2249 unlink $path;
2250 };
2251 }
2252 }
2253}
2254
2255sub db_get($$) {
2256 my $key = "$_[0]/$_[1]";
2257
2258 cf::sync_job {
2259 BDB::db_get $DB, undef, $key, my $data;
2260
2261 $! ? ()
2262 : Compress::LZF::sthaw $data
2263 }
2264}
2265
2266sub db_put($$$) {
2267 BDB::dbreq_pri 4;
2268 BDB::db_put $DB, undef, "$_[0]/$_[1]", Compress::LZF::sfreeze_cr $_[2], 0, sub { };
2269}
2270
2271#############################################################################
2272# the server's init and main functions 2936# the server's init and main functions
2273 2937
2274sub load_faces { 2938sub load_facedata($) {
2275 my $path = sprintf "%s/faces", cf::datadir; 2939 my ($path) = @_;
2276 2940
2941 # HACK to clear player env face cache, we need some signal framework
2942 # for this (global event?)
2943 %ext::player_env::MUSIC_FACE_CACHE = ();
2944
2945 my $enc = JSON::XS->new->utf8->canonical->relaxed;
2946
2277 warn "loading faces from $path\n"; 2947 warn "loading facedata from $path\n";
2278 2948
2279 my $faces; 2949 my $facedata;
2280 0 < aio_load $path, $faces 2950 0 < aio_load $path, $facedata
2281 or die "$path: $!"; 2951 or die "$path: $!";
2282 2952
2283 Coro::cede;
2284 $faces = Storable::thaw $faces; 2953 $facedata = Coro::Storable::thaw $facedata;
2285 Coro::cede;
2286 2954
2287 my $meta = delete $faces->{""};
2288 $meta->{version} == 1 2955 $facedata->{version} == 2
2289 or cf::cleanup "$path: version mismatch, cannot proceed."; 2956 or cf::cleanup "$path: version mismatch, cannot proceed.";
2290 2957
2958 # patch in the exptable
2959 $facedata->{resource}{"res/exp_table"} = {
2960 type => FT_RSRC,
2961 data => $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]),
2962 };
2963 cf::cede_to_tick;
2964
2965 {
2966 my $faces = $facedata->{faceinfo};
2967
2291 while (my ($face, $info) = each %$faces) { 2968 while (my ($face, $info) = each %$faces) {
2292 my $idx = (cf::face::find $face) || cf::face::alloc $face; 2969 my $idx = (cf::face::find $face) || cf::face::alloc $face;
2293 cf::face::set $idx, $info->{visibility}, $info->{magicmap}; 2970 cf::face::set_visibility $idx, $info->{visibility};
2971 cf::face::set_magicmap $idx, $info->{magicmap};
2294 cf::face::set_data $idx, 0, $info->{data32}, $info->{chksum32}; 2972 cf::face::set_data $idx, 0, $info->{data32}, Digest::MD5::md5 $info->{data32};
2295 Coro::cede; 2973 cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64};
2296 }
2297 2974
2975 cf::cede_to_tick;
2976 }
2977
2298 while (my ($face, $info) = each %$faces) { 2978 while (my ($face, $info) = each %$faces) {
2299 next unless $info->{smooth}; 2979 next unless $info->{smooth};
2300 my $idx = cf::face::find $face 2980 my $idx = cf::face::find $face
2301 or next; 2981 or next;
2302 if (my $smooth = cf::face::find $info->{smooth}) { 2982 if (my $smooth = cf::face::find $info->{smooth}) {
2303 cf::face::set_smooth $idx, $smooth; 2983 cf::face::set_smooth $idx, $smooth;
2984 cf::face::set_smoothlevel $idx, $info->{smoothlevel};
2304 } else { 2985 } else {
2305 warn "smooth face '$info->{smooth}' not found for face '$face'"; 2986 warn "smooth face '$info->{smooth}' not found for face '$face'";
2306 } 2987 }
2307 Coro::cede; 2988
2989 cf::cede_to_tick;
2990 }
2991 }
2992
2993 {
2994 my $anims = $facedata->{animinfo};
2995
2996 while (my ($anim, $info) = each %$anims) {
2997 cf::anim::set $anim, $info->{frames}, $info->{facings};
2998 cf::cede_to_tick;
2999 }
3000
3001 cf::anim::invalidate_all; # d'oh
3002 }
3003
3004 {
3005 # TODO: for gcfclient pleasure, we should give resources
3006 # that gcfclient doesn't grok a >10000 face index.
3007 my $res = $facedata->{resource};
3008
3009 my $soundconf = delete $res->{"res/sound.conf"};
3010
3011 while (my ($name, $info) = each %$res) {
3012 my $idx = (cf::face::find $name) || cf::face::alloc $name;
3013 my $data;
3014
3015 if ($info->{type} & 1) {
3016 # prepend meta info
3017
3018 my $meta = $enc->encode ({
3019 name => $name,
3020 %{ $info->{meta} || {} },
3021 });
3022
3023 $data = pack "(w/a*)*", $meta, $info->{data};
3024 } else {
3025 $data = $info->{data};
3026 }
3027
3028 cf::face::set_data $idx, 0, $data, Digest::MD5::md5 $data;
3029 cf::face::set_type $idx, $info->{type};
3030
3031 cf::cede_to_tick;
3032 }
3033
3034 if ($soundconf) {
3035 $soundconf = $enc->decode (delete $soundconf->{data});
3036
3037 for (0 .. SOUND_CAST_SPELL_0 - 1) {
3038 my $sound = $soundconf->{compat}[$_]
3039 or next;
3040
3041 my $face = cf::face::find "sound/$sound->[1]";
3042 cf::sound::set $sound->[0] => $face;
3043 cf::sound::old_sound_index $_, $face; # gcfclient-compat
3044 }
3045
3046 while (my ($k, $v) = each %{$soundconf->{event}}) {
3047 my $face = cf::face::find "sound/$v";
3048 cf::sound::set $k => $face;
3049 }
3050 }
2308 } 3051 }
2309 3052
2310 1 3053 1
2311} 3054}
2312 3055
3056register_exticmd fx_want => sub {
3057 my ($ns, $want) = @_;
3058
3059 while (my ($k, $v) = each %$want) {
3060 $ns->fx_want ($k, $v);
3061 }
3062};
3063
3064sub reload_regions {
3065 # HACK to clear player env face cache, we need some signal framework
3066 # for this (global event?)
3067 %ext::player_env::MUSIC_FACE_CACHE = ();
3068
3069 load_resource_file "$MAPDIR/regions"
3070 or die "unable to load regions file\n";
3071
3072 for (cf::region::list) {
3073 $_->{match} = qr/$_->{match}/
3074 if exists $_->{match};
3075 }
3076}
3077
3078sub reload_facedata {
3079 load_facedata "$DATADIR/facedata"
3080 or die "unable to load facedata\n";
3081}
3082
3083sub reload_archetypes {
3084 load_resource_file "$DATADIR/archetypes"
3085 or die "unable to load archetypes\n";
3086 #d# NEED to laod twice to resolve forward references
3087 # this really needs to be done in an extra post-pass
3088 # (which needs to be synchronous, so solve it differently)
3089 load_resource_file "$DATADIR/archetypes"
3090 or die "unable to load archetypes\n";
3091}
3092
3093sub reload_treasures {
3094 load_resource_file "$DATADIR/treasures"
3095 or die "unable to load treasurelists\n";
3096}
3097
2313sub reload_resources { 3098sub reload_resources {
2314 load_resource_file sprintf "%s/%s/regions", cf::datadir, cf::mapdir 3099 warn "reloading resource files...\n";
2315 or die "unable to load regions file\n";#d# 3100
3101 reload_regions;
2316 load_faces 3102 reload_facedata;
2317 or die "unable to load faces\n";#d# 3103 #reload_archetypes;#d#
3104 reload_archetypes;
3105 reload_treasures;
3106
3107 warn "finished reloading resource files\n";
2318} 3108}
2319 3109
2320sub init { 3110sub init {
2321 reload_resources; 3111 reload_resources;
2322} 3112}
2323 3113
2324sub cfg_load { 3114sub reload_config {
2325 open my $fh, "<:utf8", cf::confdir . "/config" 3115 open my $fh, "<:utf8", "$CONFDIR/config"
2326 or return; 3116 or return;
2327 3117
2328 local $/; 3118 local $/;
2329 *CFG = YAML::Syck::Load <$fh>; 3119 *CFG = YAML::Syck::Load <$fh>;
2330 3120
2349 (async { 3139 (async {
2350 Event::one_event; 3140 Event::one_event;
2351 })->prio (Coro::PRIO_MAX); 3141 })->prio (Coro::PRIO_MAX);
2352 }; 3142 };
2353 3143
2354 cfg_load; 3144 reload_config;
2355 db_init; 3145 db_init;
2356 load_extensions; 3146 load_extensions;
2357 3147
2358 $TICK_WATCHER->start; 3148 $TICK_WATCHER->start;
2359 Event::loop; 3149 Event::loop;
2375 }, 3165 },
2376 ); 3166 );
2377 } 3167 }
2378} 3168}
2379 3169
3170sub write_runtime {
3171 my $runtime = "$LOCALDIR/runtime";
3172
3173 # first touch the runtime file to show we are still running:
3174 # the fsync below can take a very very long time.
3175
3176 IO::AIO::aio_utime $runtime, undef, undef;
3177
3178 my $guard = cf::lock_acquire "write_runtime";
3179
3180 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644
3181 or return;
3182
3183 my $value = $cf::RUNTIME + 90 + 10;
3184 # 10 is the runtime save interval, for a monotonic clock
3185 # 60 allows for the watchdog to kill the server.
3186
3187 (aio_write $fh, 0, (length $value), $value, 0) <= 0
3188 and return;
3189
3190 # always fsync - this file is important
3191 aio_fsync $fh
3192 and return;
3193
3194 # touch it again to show we are up-to-date
3195 aio_utime $fh, undef, undef;
3196
3197 close $fh
3198 or return;
3199
3200 aio_rename "$runtime~", $runtime
3201 and return;
3202
3203 warn "runtime file written.\n";
3204
3205 1
3206}
3207
2380sub emergency_save() { 3208sub emergency_save() {
2381 my $freeze_guard = cf::freeze_mainloop; 3209 my $freeze_guard = cf::freeze_mainloop;
2382 3210
2383 warn "enter emergency perl save\n"; 3211 warn "enter emergency perl save\n";
2384 3212
2415 3243
2416 warn Carp::longmess "post_cleanup backtrace" 3244 warn Carp::longmess "post_cleanup backtrace"
2417 if $make_core; 3245 if $make_core;
2418} 3246}
2419 3247
2420sub reload() { 3248sub do_reload_perl() {
2421 # can/must only be called in main 3249 # can/must only be called in main
2422 if ($Coro::current != $Coro::main) { 3250 if ($Coro::current != $Coro::main) {
2423 warn "can only reload from main coroutine"; 3251 warn "can only reload from main coroutine";
2424 return; 3252 return;
2425 } 3253 }
2459 %EXT_CORO = (); 3287 %EXT_CORO = ();
2460 3288
2461 warn "removing commands"; 3289 warn "removing commands";
2462 %COMMAND = (); 3290 %COMMAND = ();
2463 3291
2464 warn "removing ext commands"; 3292 warn "removing ext/exti commands";
2465 %EXTCMD = (); 3293 %EXTCMD = ();
3294 %EXTICMD = ();
2466 3295
2467 warn "unloading/nuking all extensions"; 3296 warn "unloading/nuking all extensions";
2468 for my $pkg (@EXTS) { 3297 for my $pkg (@EXTS) {
2469 warn "... unloading $pkg"; 3298 warn "... unloading $pkg";
2470 3299
2500 Symbol::delete_package "safe::$_" 3329 Symbol::delete_package "safe::$_"
2501 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region); 3330 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
2502 3331
2503 warn "unloading cf.pm \"a bit\""; 3332 warn "unloading cf.pm \"a bit\"";
2504 delete $INC{"cf.pm"}; 3333 delete $INC{"cf.pm"};
3334 delete $INC{"cf/pod.pm"};
2505 3335
2506 # don't, removes xs symbols, too, 3336 # don't, removes xs symbols, too,
2507 # and global variables created in xs 3337 # and global variables created in xs
2508 #Symbol::delete_package __PACKAGE__; 3338 #Symbol::delete_package __PACKAGE__;
2509 3339
2512 warn "reloading cf.pm"; 3342 warn "reloading cf.pm";
2513 require cf; 3343 require cf;
2514 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 3344 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
2515 3345
2516 warn "loading config and database again"; 3346 warn "loading config and database again";
2517 cf::cfg_load; 3347 cf::reload_config;
2518 3348
2519 warn "loading extensions"; 3349 warn "loading extensions";
2520 cf::load_extensions; 3350 cf::load_extensions;
2521 3351
2522 warn "reattaching attachments to objects/players"; 3352 warn "reattaching attachments to objects/players";
2524 warn "reattaching attachments to maps"; 3354 warn "reattaching attachments to maps";
2525 reattach $_ for values %MAP; 3355 reattach $_ for values %MAP;
2526 warn "reattaching attachments to players"; 3356 warn "reattaching attachments to players";
2527 reattach $_ for values %PLAYER; 3357 reattach $_ for values %PLAYER;
2528 3358
2529 warn "loading reloadable resources";
2530 reload_resources;
2531
2532 warn "leaving sync_job"; 3359 warn "leaving sync_job";
2533 3360
2534 1 3361 1
2535 } or do { 3362 } or do {
2536 warn $@; 3363 warn $@;
2541 warn "reloaded"; 3368 warn "reloaded";
2542}; 3369};
2543 3370
2544our $RELOAD_WATCHER; # used only during reload 3371our $RELOAD_WATCHER; # used only during reload
2545 3372
3373sub reload_perl() {
3374 # doing reload synchronously and two reloads happen back-to-back,
3375 # coro crashes during coro_state_free->destroy here.
3376
3377 $RELOAD_WATCHER ||= Event->timer (
3378 reentrant => 0,
3379 after => 0,
3380 data => WF_AUTOCANCEL,
3381 cb => sub {
3382 do_reload_perl;
3383 undef $RELOAD_WATCHER;
3384 },
3385 );
3386}
3387
2546register_command "reload" => sub { 3388register_command "reload" => sub {
2547 my ($who, $arg) = @_; 3389 my ($who, $arg) = @_;
2548 3390
2549 if ($who->flag (FLAG_WIZ)) { 3391 if ($who->flag (FLAG_WIZ)) {
2550 $who->message ("reloading server."); 3392 $who->message ("reloading server.");
2551 3393 async { reload_perl };
2552 # doing reload synchronously and two reloads happen back-to-back,
2553 # coro crashes during coro_state_free->destroy here.
2554
2555 $RELOAD_WATCHER ||= Event->timer (
2556 reentrant => 0,
2557 after => 0,
2558 data => WF_AUTOCANCEL,
2559 cb => sub {
2560 reload;
2561 undef $RELOAD_WATCHER;
2562 },
2563 );
2564 } 3394 }
2565}; 3395};
2566 3396
2567unshift @INC, $LIBDIR; 3397unshift @INC, $LIBDIR;
2568 3398
2569my $bug_warning = 0; 3399my $bug_warning = 0;
2570 3400
3401our @WAIT_FOR_TICK;
3402our @WAIT_FOR_TICK_BEGIN;
3403
3404sub wait_for_tick {
3405 return unless $TICK_WATCHER->is_active;
3406 return if $Coro::current == $Coro::main;
3407
3408 my $signal = new Coro::Signal;
3409 push @WAIT_FOR_TICK, $signal;
3410 $signal->wait;
3411}
3412
3413sub wait_for_tick_begin {
3414 return unless $TICK_WATCHER->is_active;
3415 return if $Coro::current == $Coro::main;
3416
3417 my $signal = new Coro::Signal;
3418 push @WAIT_FOR_TICK_BEGIN, $signal;
3419 $signal->wait;
3420}
3421
3422 my $min = 1e6;#d#
3423 my $avg = 10;
2571$TICK_WATCHER = Event->timer ( 3424$TICK_WATCHER = Event->timer (
2572 reentrant => 0, 3425 reentrant => 0,
2573 parked => 1, 3426 parked => 1,
2574 prio => 0, 3427 prio => 0,
2575 at => $NEXT_TICK || $TICK, 3428 at => $NEXT_TICK || $TICK,
2579 Carp::cluck "major BUG: server tick called outside of main coro, skipping it" 3432 Carp::cluck "major BUG: server tick called outside of main coro, skipping it"
2580 unless ++$bug_warning > 10; 3433 unless ++$bug_warning > 10;
2581 return; 3434 return;
2582 } 3435 }
2583 3436
2584 $NOW = Event::time; 3437 $NOW = $tick_start = Event::time;
2585 3438
2586 cf::server_tick; # one server iteration 3439 cf::server_tick; # one server iteration
3440
3441 0 && sync_job {#d#
3442 for(1..10) {
3443 my $t = Event::time;
3444 my $map = my $map = new_from_path cf::map "/tmp/x.map"
3445 or die;
3446
3447 $map->width (50);
3448 $map->height (50);
3449 $map->alloc;
3450 $map->_load_objects ("/tmp/x.map", 1); #TODO: does not work
3451 my $t = Event::time - $t;
3452
3453 #next unless $t < 0.0013;#d#
3454 if ($t < $min) {
3455 $min = $t;
3456 }
3457 $avg = $avg * 0.99 + $t * 0.01;
3458 }
3459 warn "XXXXXXXXXXXXXXXXXX min $min avg $avg\n";#d#
3460 exit 0;
3461 # 2007-05-22 02:33:04.569 min 0.00112509727478027 avg 0.0012259249572477
3462 };
3463
2587 $RUNTIME += $TICK; 3464 $RUNTIME += $TICK;
2588 $NEXT_TICK += $TICK; 3465 $NEXT_TICK += $TICK;
2589 3466
2590 if ($NOW >= $NEXT_RUNTIME_WRITE) { 3467 if ($NOW >= $NEXT_RUNTIME_WRITE) {
2591 $NEXT_RUNTIME_WRITE = $NOW + 10; 3468 $NEXT_RUNTIME_WRITE = $NOW + 10;
2593 write_runtime 3470 write_runtime
2594 or warn "ERROR: unable to write runtime file: $!"; 3471 or warn "ERROR: unable to write runtime file: $!";
2595 }; 3472 };
2596 } 3473 }
2597 3474
2598 $WAIT_FOR_TICK->broadcast;
2599 $WAIT_FOR_TICK_ONE->send if $WAIT_FOR_TICK_ONE->awaited;
2600
2601# my $AFTER = Event::time; 3475# my $AFTER = Event::time;
2602# warn $AFTER - $NOW;#d# 3476# warn $AFTER - $NOW;#d#
2603 3477
3478 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
3479 $sig->send;
3480 }
3481 while (my $sig = shift @WAIT_FOR_TICK) {
3482 $sig->send;
3483 }
3484
3485 $NOW = Event::time;
3486
2604 # if we are delayed by four ticks or more, skip them all 3487 # if we are delayed by four ticks or more, skip them all
2605 $NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4; 3488 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
2606 3489
2607 $TICK_WATCHER->at ($NEXT_TICK); 3490 $TICK_WATCHER->at ($NEXT_TICK);
2608 $TICK_WATCHER->start; 3491 $TICK_WATCHER->start;
3492
3493 $LOAD = ($NOW - $tick_start) / $TICK;
3494 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
3495
3496 _post_tick;
3497
3498
2609 }, 3499 },
2610); 3500);
2611 3501
2612{ 3502{
2613 BDB::max_poll_time $TICK * 0.1; 3503 BDB::max_poll_time $TICK * 0.1;
2641 3531
2642 cf::sync_job { 3532 cf::sync_job {
2643 eval { 3533 eval {
2644 BDB::db_env_open 3534 BDB::db_env_open
2645 $DB_ENV, 3535 $DB_ENV,
2646 $BDB_ENV_DIR, 3536 $BDBDIR,
2647 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN 3537 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN
2648 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE, 3538 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE,
2649 0666; 3539 0666;
2650 3540
2651 cf::cleanup "db_env_open($BDB_ENV_DIR): $!" if $!; 3541 cf::cleanup "db_env_open($BDBDIR): $!" if $!;
2652 3542
2653 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC, 1); 3543 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC, 1);
2654 $DB_ENV->set_lk_detect; 3544 $DB_ENV->set_lk_detect;
2655 }; 3545 };
2656 3546
2672 prio => 6, 3562 prio => 6,
2673 cb => \&IO::AIO::poll_cb, 3563 cb => \&IO::AIO::poll_cb,
2674 ); 3564 );
2675} 3565}
2676 3566
3567my $_log_backtrace;
3568
3569sub _log_backtrace {
3570 my ($msg, @addr) = @_;
3571
3572 $msg =~ s/\n//;
3573
3574 # limit the # of concurrent backtraces
3575 if ($_log_backtrace < 2) {
3576 ++$_log_backtrace;
3577 async {
3578 my @bt = fork_call {
3579 @addr = map { sprintf "%x", $_ } @addr;
3580 my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X;
3581 open my $fh, "exec addr2line -C -f -i -e \Q$self\E @addr 2>&1 |"
3582 or die "addr2line: $!";
3583
3584 my @funcs;
3585 my @res = <$fh>;
3586 chomp for @res;
3587 while (@res) {
3588 my ($func, $line) = splice @res, 0, 2, ();
3589 push @funcs, "[$func] $line";
3590 }
3591
3592 @funcs
3593 };
3594
3595 LOG llevInfo, "[ABT] $msg\n";
3596 LOG llevInfo, "[ABT] $_\n" for @bt;
3597 --$_log_backtrace;
3598 };
3599 } else {
3600 LOG llevInfo, "[ABT] $msg\n";
3601 LOG llevInfo, "[ABT] [suppressed]\n";
3602 }
3603}
3604
3605# load additional modules
3606use cf::pod;
3607
2677END { cf::emergency_save } 3608END { cf::emergency_save }
2678 3609
26791 36101
2680 3611

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines