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

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines