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

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines