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.134 by root, Thu Jan 4 17:28:49 2007 UTC vs.
Revision 1.282 by elmex, Tue Jun 19 18:15:34 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.3 (); 15use Coro 3.61 ();
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;
19 24
25use BDB ();
26use Data::Dumper;
20use Digest::MD5; 27use Digest::MD5;
21use Fcntl; 28use Fcntl;
22use IO::AIO 2.31 ();
23use YAML::Syck (); 29use YAML::Syck ();
30use IO::AIO 2.32 ();
24use Time::HiRes; 31use Time::HiRes;
32use Compress::LZF;
25 33
34# configure various modules to our taste
35#
36$Storable::canonical = 1; # reduce rsync transfers
37Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator
38Compress::LZF::sfreeze_cr { }; # prime Compress::LZF so it does not use require later
39
26use Event; $Event::Eval = 1; # no idea why this is required, but it is 40$Event::Eval = 1; # no idea why this is required, but it is
27 41
28# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode? 42# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode?
29$YAML::Syck::ImplicitUnicode = 1; 43$YAML::Syck::ImplicitUnicode = 1;
30 44
31$Coro::main->prio (2); # run main coroutine ("the server") with very high priority 45$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority
32 46
33sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload 47sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
34 48
35our %COMMAND = (); 49our %COMMAND = ();
36our %COMMAND_TIME = (); 50our %COMMAND_TIME = ();
51
52our @EXTS = (); # list of extension package names
37our %EXTCMD = (); 53our %EXTCMD = ();
54our %EXT_CORO = (); # coroutines bound to extensions
55our %EXT_MAP = (); # pluggable maps
38 56
57our $RELOAD; # number of reloads so far
39our @EVENT; 58our @EVENT;
40our $LIBDIR = datadir . "/ext";
41 59
42our $TICK = MAX_TIME * 1e-6; 60our $CONFDIR = confdir;
61our $DATADIR = datadir;
62our $LIBDIR = "$DATADIR/ext";
63our $PODDIR = "$DATADIR/pod";
64our $MAPDIR = "$DATADIR/" . mapdir;
65our $LOCALDIR = localdir;
66our $TMPDIR = "$LOCALDIR/" . tmpdir;
67our $UNIQUEDIR = "$LOCALDIR/" . uniquedir;
68our $PLAYERDIR = "$LOCALDIR/" . playerdir;
69our $RANDOMDIR = "$LOCALDIR/random";
70our $BDBDIR = "$LOCALDIR/db";
71
72our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!)
43our $TICK_WATCHER; 73our $TICK_WATCHER;
74our $AIO_POLL_WATCHER;
75our $NEXT_RUNTIME_WRITE; # when should the runtime file be written
44our $NEXT_TICK; 76our $NEXT_TICK;
45our $NOW; 77our $NOW;
78our $USE_FSYNC = 1; # use fsync to write maps - default off
79
80our $BDB_POLL_WATCHER;
81our $DB_ENV;
46 82
47our %CFG; 83our %CFG;
48 84
49our $UPTIME; $UPTIME ||= time; 85our $UPTIME; $UPTIME ||= time;
50our $RUNTIME; 86our $RUNTIME;
51 87
88our %PLAYER; # all users
52our %MAP; # all maps 89our %MAP; # all maps
53our $LINK_MAP; # the special {link} map 90our $LINK_MAP; # the special {link} map, which is always available
54our $RANDOM_MAPS = cf::localdir . "/random"; 91
55our %EXT_CORO; 92# used to convert map paths into valid unix filenames by replacing / by ∕
93our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons
94
95our $LOAD; # a number between 0 (idle) and 1 (too many objects)
96our $LOADAVG; # same thing, but with alpha-smoothing
97our $tick_start; # for load detecting purposes
56 98
57binmode STDOUT; 99binmode STDOUT;
58binmode STDERR; 100binmode STDERR;
59 101
60# read virtual server time, if available 102# read virtual server time, if available
61unless ($RUNTIME || !-e cf::localdir . "/runtime") { 103unless ($RUNTIME || !-e "$LOCALDIR/runtime") {
62 open my $fh, "<", cf::localdir . "/runtime" 104 open my $fh, "<", "$LOCALDIR/runtime"
63 or die "unable to read runtime file: $!"; 105 or die "unable to read runtime file: $!";
64 $RUNTIME = <$fh> + 0.; 106 $RUNTIME = <$fh> + 0.;
65} 107}
66 108
67mkdir cf::localdir; 109mkdir $_
68mkdir cf::localdir . "/" . cf::playerdir; 110 for $LOCALDIR, $TMPDIR, $UNIQUEDIR, $PLAYERDIR, $RANDOMDIR, $BDBDIR;
69mkdir cf::localdir . "/" . cf::tmpdir;
70mkdir cf::localdir . "/" . cf::uniquedir;
71mkdir $RANDOM_MAPS;
72 111
73# a special map that is always available
74our $LINK_MAP;
75our $EMERGENCY_POSITION; 112our $EMERGENCY_POSITION;
113
114sub cf::map::normalise;
76 115
77############################################################################# 116#############################################################################
78 117
79=head2 GLOBAL VARIABLES 118=head2 GLOBAL VARIABLES
80 119
87=item $cf::RUNTIME 126=item $cf::RUNTIME
88 127
89The time this server has run, starts at 0 and is increased by $cf::TICK on 128The time this server has run, starts at 0 and is increased by $cf::TICK on
90every server tick. 129every server tick.
91 130
92=item $cf::LIBDIR 131=item $cf::CONFDIR $cf::DATADIR $cf::LIBDIR $cf::PODDIR
132$cf::MAPDIR $cf::LOCALDIR $cf::TMPDIR $cf::UNIQUEDIR
133$cf::PLAYERDIR $cf::RANDOMDIR $cf::BDBDIR
93 134
94The perl library directory, where extensions and cf-specific modules can 135Various directories - "/etc", read-only install directory, perl-library
95be found. It will be added to C<@INC> automatically. 136directory, pod-directory, read-only maps directory, "/var", "/var/tmp",
137unique-items directory, player file directory, random maps directory and
138database environment.
96 139
97=item $cf::NOW 140=item $cf::NOW
98 141
99The time of the last (current) server tick. 142The time of the last (current) server tick.
100 143
101=item $cf::TICK 144=item $cf::TICK
102 145
103The interval between server ticks, in seconds. 146The interval between server ticks, in seconds.
147
148=item $cf::LOADAVG
149
150The current CPU load on the server (alpha-smoothed), as a value between 0
151(none) and 1 (overloaded), indicating how much time is spent on processing
152objects per tick. Healthy values are < 0.5.
153
154=item $cf::LOAD
155
156The raw value load value from the last tick.
104 157
105=item %cf::CFG 158=item %cf::CFG
106 159
107Configuration for the server, loaded from C</etc/crossfire/config>, or 160Configuration for the server, loaded from C</etc/crossfire/config>, or
108from wherever your confdir points to. 161from wherever your confdir points to.
162
163=item cf::wait_for_tick, cf::wait_for_tick_begin
164
165These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only
166returns directly I<after> the tick processing (and consequently, can only wake one process
167per tick), while cf::wait_for_tick wakes up all waiters after tick processing.
109 168
110=back 169=back
111 170
112=cut 171=cut
113 172
114BEGIN { 173BEGIN {
115 *CORE::GLOBAL::warn = sub { 174 *CORE::GLOBAL::warn = sub {
116 my $msg = join "", @_; 175 my $msg = join "", @_;
117 utf8::encode $msg;
118 176
119 $msg .= "\n" 177 $msg .= "\n"
120 unless $msg =~ /\n$/; 178 unless $msg =~ /\n$/;
121 179
180 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;
181
182 utf8::encode $msg;
122 LOG llevError, "cfperl: $msg"; 183 LOG llevError, $msg;
123 }; 184 };
124} 185}
125 186
126@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable'; 187@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
127@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable'; 188@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';
128@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable'; 189@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable';
129@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable'; 190@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable';
130@safe::cf::map::ISA = @cf::map::ISA = 'cf::attachable'; 191@safe::cf::map::ISA = @cf::map::ISA = 'cf::attachable';
192@safe::cf::arch::ISA = @cf::arch::ISA = 'cf::object';
131@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object'; 193@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object'; # not really true (yet)
132 194
133# we bless all objects into (empty) derived classes to force a method lookup 195# we bless all objects into (empty) derived classes to force a method lookup
134# within the Safe compartment. 196# within the Safe compartment.
135for my $pkg (qw( 197for my $pkg (qw(
136 cf::global cf::attachable 198 cf::global cf::attachable
145 207
146$Event::DIED = sub { 208$Event::DIED = sub {
147 warn "error in event callback: @_"; 209 warn "error in event callback: @_";
148}; 210};
149 211
150my %ext_pkg; 212#############################################################################
151my @exts;
152my @hook;
153 213
154=head2 UTILITY FUNCTIONS 214=head2 UTILITY FUNCTIONS
155 215
156=over 4 216=over 4
157 217
158=cut 218=item dumpval $ref
159 219
220=cut
221
222sub dumpval {
223 eval {
224 local $SIG{__DIE__};
225 my $d;
226 if (1) {
227 $d = new Data::Dumper([$_[0]], ["*var"]);
228 $d->Terse(1);
229 $d->Indent(2);
230 $d->Quotekeys(0);
231 $d->Useqq(1);
232 #$d->Bless(...);
233 $d->Seen($_[1]) if @_ > 1;
234 $d = $d->Dump();
235 }
236 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge;
237 $d
238 } || "[unable to dump $_[0]: '$@']";
239}
240
160use JSON::Syck (); # TODO# replace by JSON::PC once working 241use JSON::XS qw(to_json from_json); # TODO# replace by JSON::PC once working
161 242
162=item $ref = cf::from_json $json 243=item $ref = cf::from_json $json
163 244
164Converts a JSON string into the corresponding perl data structure. 245Converts a JSON string into the corresponding perl data structure.
165 246
166=cut
167
168sub from_json($) {
169 $JSON::Syck::ImplicitUnicode = 1; # work around JSON::Syck bugs
170 JSON::Syck::Load $_[0]
171}
172
173=item $json = cf::to_json $ref 247=item $json = cf::to_json $ref
174 248
175Converts a perl data structure into its JSON representation. 249Converts a perl data structure into its JSON representation.
176 250
177=cut
178
179sub to_json($) {
180 $JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs
181 JSON::Syck::Dump $_[0]
182}
183
184=item my $guard = cf::guard { BLOCK }
185
186Run the given callback when the guard object gets destroyed (useful for
187coroutine cancellations).
188
189You can call C<< ->cancel >> on the guard object to stop the block from
190being executed.
191
192=cut
193
194sub guard(&) {
195 bless \(my $cb = $_[0]), cf::guard::;
196}
197
198sub cf::guard::cancel {
199 ${$_[0]} = sub { };
200}
201
202sub cf::guard::DESTROY {
203 ${$_[0]}->();
204}
205
206=item cf::lock_wait $string 251=item cf::lock_wait $string
207 252
208Wait until the given lock is available. See cf::lock_acquire. 253Wait until the given lock is available. See cf::lock_acquire.
209 254
210=item my $lock = cf::lock_acquire $string 255=item my $lock = cf::lock_acquire $string
211 256
212Wait until the given lock is available and then acquires it and returns 257Wait until the given lock is available and then acquires it and returns
213a guard object. If the guard object gets destroyed (goes out of scope, 258a Coro::guard object. If the guard object gets destroyed (goes out of scope,
214for example when the coroutine gets canceled), the lock is automatically 259for example when the coroutine gets canceled), the lock is automatically
215returned. 260returned.
216 261
217Lock names should begin with a unique identifier (for example, cf::map::find 262Lock names should begin with a unique identifier (for example, cf::map::find
218uses map_find and cf::map::load uses map_load). 263uses map_find and cf::map::load uses map_load).
264
265=item $locked = cf::lock_active $string
266
267Return true if the lock is currently active, i.e. somebody has locked it.
219 268
220=cut 269=cut
221 270
222our %LOCK; 271our %LOCK;
223 272
237 # wait, to be sure we are not locked 286 # wait, to be sure we are not locked
238 lock_wait $key; 287 lock_wait $key;
239 288
240 $LOCK{$key} = []; 289 $LOCK{$key} = [];
241 290
242 cf::guard { 291 Coro::guard {
243 # wake up all waiters, to be on the safe side 292 # wake up all waiters, to be on the safe side
244 $_->ready for @{ delete $LOCK{$key} }; 293 $_->ready for @{ delete $LOCK{$key} };
245 } 294 }
246} 295}
247 296
248=item cf::async { BLOCK } 297sub lock_active($) {
249
250Like C<Coro::async>, but runs the given BLOCK in an eval and only logs the
251error instead of exiting the server in case of a problem.
252
253=cut
254
255sub async(&) {
256 my ($cb) = @_; 298 my ($key) = @_;
257 299
258 Coro::async { 300 ! ! $LOCK{$key}
259 eval { $cb->() };
260 warn $@ if $@;
261 }
262} 301}
263 302
264sub freeze_mainloop { 303sub freeze_mainloop {
265 return unless $TICK_WATCHER->is_active; 304 return unless $TICK_WATCHER->is_active;
266 305
267 my $guard = guard { $TICK_WATCHER->start }; 306 my $guard = Coro::guard {
307 $TICK_WATCHER->start;
308 };
268 $TICK_WATCHER->stop; 309 $TICK_WATCHER->stop;
269 $guard 310 $guard
270} 311}
271 312
313=item cf::async { BLOCK }
314
315Currently the same as Coro::async_pool, meaning you cannot use
316C<on_destroy>, C<join> or other gimmicks on these coroutines. The only
317thing you are allowed to do is call C<prio> on it.
318
319=cut
320
321BEGIN { *async = \&Coro::async_pool }
322
272=item cf::sync_job { BLOCK } 323=item cf::sync_job { BLOCK }
273 324
274The design of crossfire+ requires that the main coro ($Coro::main) is 325The design of Crossfire TRT requires that the main coroutine ($Coro::main)
275always able to handle events or runnable, as crossfire+ is only partly 326is always able to handle events or runnable, as Crossfire TRT is only
276reentrant. Thus "blocking" it by e.g. waiting for I/O is not acceptable. 327partly reentrant. Thus "blocking" it by e.g. waiting for I/O is not
328acceptable.
277 329
278If it must be done, put the blocking parts into C<sync_job>. This will run 330If it must be done, put the blocking parts into C<sync_job>. This will run
279the given BLOCK in another coroutine while waiting for the result. The 331the given BLOCK in another coroutine while waiting for the result. The
280server will be frozen during this time, so the block should either finish 332server will be frozen during this time, so the block should either finish
281fast or be very important. 333fast or be very important.
284 336
285sub sync_job(&) { 337sub sync_job(&) {
286 my ($job) = @_; 338 my ($job) = @_;
287 339
288 if ($Coro::current == $Coro::main) { 340 if ($Coro::current == $Coro::main) {
341 my $time = Event::time;
342
289 # this is the main coro, too bad, we have to block 343 # this is the main coro, too bad, we have to block
290 # till the operation succeeds, freezing the server :/ 344 # till the operation succeeds, freezing the server :/
291 345
292 # TODO: use suspend/resume instead 346 # TODO: use suspend/resume instead
293 # (but this is cancel-safe) 347 # (but this is cancel-safe)
294 my $freeze_guard = freeze_mainloop; 348 my $freeze_guard = freeze_mainloop;
295 349
296 my $busy = 1; 350 my $busy = 1;
297 my @res; 351 my @res;
298 352
299 (Coro::async { 353 (async {
300 @res = eval { $job->() }; 354 @res = eval { $job->() };
301 warn $@ if $@; 355 warn $@ if $@;
302 undef $busy; 356 undef $busy;
303 })->prio (Coro::PRIO_MAX); 357 })->prio (Coro::PRIO_MAX);
304 358
305 while ($busy) { 359 while ($busy) {
306 Coro::cede_notself; 360 Coro::cede or Event::one_event;
307 Event::one_event unless Coro::nready;
308 } 361 }
362
363 $time = Event::time - $time;
364
365 LOG llevError | logBacktrace, Carp::longmess "long sync job"
366 if $time > $TICK * 0.5 && $TICK_WATCHER->is_active;
367
368 $tick_start += $time; # do not account sync jobs to server load
309 369
310 wantarray ? @res : $res[0] 370 wantarray ? @res : $res[0]
311 } else { 371 } else {
312 # we are in another coroutine, how wonderful, everything just works 372 # we are in another coroutine, how wonderful, everything just works
313 373
314 $job->() 374 $job->()
315 } 375 }
316} 376}
317 377
318=item $coro = cf::coro { BLOCK } 378=item $coro = cf::async_ext { BLOCK }
319 379
320Creates and returns a new coro. This coro is automcatially being canceled 380Like async, but this coro is automatically being canceled when the
321when the extension calling this is being unloaded. 381extension calling this is being unloaded.
322 382
323=cut 383=cut
324 384
325sub coro(&) { 385sub async_ext(&) {
326 my $cb = shift; 386 my $cb = shift;
327 387
328 my $coro = &cf::async ($cb); 388 my $coro = &Coro::async ($cb);
329 389
330 $coro->on_destroy (sub { 390 $coro->on_destroy (sub {
331 delete $EXT_CORO{$coro+0}; 391 delete $EXT_CORO{$coro+0};
332 }); 392 });
333 $EXT_CORO{$coro+0} = $coro; 393 $EXT_CORO{$coro+0} = $coro;
334 394
335 $coro 395 $coro
336} 396}
337 397
338sub write_runtime { 398=item fork_call { }, $args
339 my $runtime = cf::localdir . "/runtime";
340 399
341 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644 400Executes the given code block with the given arguments in a seperate
342 or return; 401process, returning the results. Everything must be serialisable with
402Coro::Storable. May, of course, block. Note that the executed sub may
403never block itself or use any form of Event handling.
343 404
344 my $value = $cf::RUNTIME + 1 + 10; # 10 is the runtime save interval, for a monotonic clock 405=cut
345 (aio_write $fh, 0, (length $value), $value, 0) <= 0
346 and return;
347 406
348 aio_fsync $fh 407sub fork_call(&@) {
349 and return; 408 my ($cb, @args) = @_;
350 409
410# socketpair my $fh1, my $fh2, Socket::AF_UNIX, Socket::SOCK_STREAM, Socket::PF_UNSPEC
411# or die "socketpair: $!";
412 pipe my $fh1, my $fh2
413 or die "pipe: $!";
414
415 if (my $pid = fork) {
351 close $fh 416 close $fh2;
352 or return;
353 417
354 aio_rename "$runtime~", $runtime 418 my $res = (Coro::Handle::unblock $fh1)->readline (undef);
355 and return; 419 $res = Coro::Storable::thaw $res;
356 420
421 waitpid $pid, 0; # should not block anymore, we expect the child to simply behave
422
423 die $$res unless "ARRAY" eq ref $res;
424
425 return wantarray ? @$res : $res->[-1];
426 } else {
427 reset_signals;
428 local $SIG{__WARN__};
429 local $SIG{__DIE__};
430 eval {
431 close $fh1;
432
433 my @res = eval { $cb->(@args) };
434 syswrite $fh2, Coro::Storable::freeze +($@ ? \"$@" : \@res);
435 };
436
437 warn $@ if $@;
438 _exit 0;
357 1 439 }
440}
441
442=item $value = cf::db_get $family => $key
443
444Returns a single value from the environment database.
445
446=item cf::db_put $family => $key => $value
447
448Stores the given C<$value> in the family. It can currently store binary
449data only (use Compress::LZF::sfreeze_cr/sthaw to convert to/from binary).
450
451=cut
452
453our $DB;
454
455sub db_init {
456 unless ($DB) {
457 $DB = BDB::db_create $DB_ENV;
458
459 cf::sync_job {
460 eval {
461 $DB->set_flags (BDB::CHKSUM);
462
463 BDB::db_open $DB, undef, "db", undef, BDB::BTREE,
464 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
465 cf::cleanup "db_open(db): $!" if $!;
466 };
467 cf::cleanup "db_open(db): $@" if $@;
468 };
469 }
470}
471
472sub db_get($$) {
473 my $key = "$_[0]/$_[1]";
474
475 cf::sync_job {
476 BDB::db_get $DB, undef, $key, my $data;
477
478 $! ? ()
479 : $data
480 }
481}
482
483sub db_put($$$) {
484 BDB::dbreq_pri 4;
485 BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { };
486}
487
488=item cf::cache $id => [$paths...], $processversion => $process
489
490Generic caching function that returns the value of the resource $id,
491caching and regenerating as required.
492
493This function can block.
494
495=cut
496
497sub cache {
498 my ($id, $src, $processversion, $process) = @_;
499
500 my $meta =
501 join "\x00",
502 $processversion,
503 map {
504 aio_stat $_
505 and Carp::croak "$_: $!";
506
507 ($_, (stat _)[7,9])
508 } @$src;
509
510 my $dbmeta = db_get cache => "$id/meta";
511 if ($dbmeta ne $meta) {
512 # changed, we may need to process
513
514 my @data;
515 my $md5;
516
517 for (0 .. $#$src) {
518 0 <= aio_load $src->[$_], $data[$_]
519 or Carp::croak "$src->[$_]: $!";
520 }
521
522 # if processing is expensive, check
523 # checksum first
524 if (1) {
525 $md5 =
526 join "\x00",
527 $processversion,
528 map {
529 Coro::cede;
530 ($src->[$_], Digest::MD5::md5_hex $data[$_])
531 } 0.. $#$src;
532
533
534 my $dbmd5 = db_get cache => "$id/md5";
535 if ($dbmd5 eq $md5) {
536 db_put cache => "$id/meta", $meta;
537
538 return db_get cache => "$id/data";
539 }
540 }
541
542 my $t1 = Time::HiRes::time;
543 my $data = $process->(\@data);
544 my $t2 = Time::HiRes::time;
545
546 warn "cache: '$id' processed in ", $t2 - $t1, "s\n";
547
548 db_put cache => "$id/data", $data;
549 db_put cache => "$id/md5" , $md5;
550 db_put cache => "$id/meta", $meta;
551
552 return $data;
553 }
554
555 db_get cache => "$id/data"
556}
557
558=item cf::datalog type => key => value, ...
559
560Log a datalog packet of the given type with the given key-value pairs.
561
562=cut
563
564sub datalog($@) {
565 my ($type, %kv) = @_;
566 warn "DATALOG ", JSON::XS->new->ascii->encode ({ %kv, type => $type });
358} 567}
359 568
360=back 569=back
361 570
362=cut 571=cut
363
364#############################################################################
365
366package cf::path;
367
368sub new {
369 my ($class, $path, $base) = @_;
370
371 $path = $path->as_string if ref $path;
372
373 my $self = bless { }, $class;
374
375 # {... are special paths that are not touched
376 # ?xxx/... are special absolute paths
377 # ?random/... random maps
378 # /! non-realised random map exit
379 # /... normal maps
380 # ~/... per-player maps without a specific player (DO NOT USE)
381 # ~user/... per-player map of a specific user
382
383 if ($path =~ /^{/) {
384 # fine as it is
385 } elsif ($path =~ s{^\?random/}{}) {
386 Coro::AIO::aio_load "$cf::RANDOM_MAPS/$path.meta", my $data;
387 $self->{random} = cf::from_json $data;
388 } else {
389 if ($path =~ s{^~([^/]+)?}{}) {
390 $self->{user_rel} = 1;
391
392 if (defined $1) {
393 $self->{user} = $1;
394 } elsif ($base =~ m{^~([^/]+)/}) {
395 $self->{user} = $1;
396 } else {
397 warn "cannot resolve user-relative path without user <$path,$base>\n";
398 }
399 } elsif ($path =~ /^\//) {
400 # already absolute
401 } else {
402 $base =~ s{[^/]+/?$}{};
403 return $class->new ("$base/$path");
404 }
405
406 for ($path) {
407 redo if s{/\.?/}{/};
408 redo if s{/[^/]+/\.\./}{/};
409 }
410 }
411
412 $self->{path} = $path;
413
414 $self
415}
416
417# the name / primary key / in-game path
418sub as_string {
419 my ($self) = @_;
420
421 $self->{user_rel} ? "~$self->{user}$self->{path}"
422 : $self->{random} ? "?random/$self->{path}"
423 : $self->{path}
424}
425
426# the displayed name, this is a one way mapping
427sub visible_name {
428 my ($self) = @_;
429
430# if (my $rmp = $self->{random}) {
431# # todo: be more intelligent about this
432# "?random/$rmp->{origin_map}+$rmp->{origin_x}+$rmp->{origin_y}/$rmp->{dungeon_level}"
433# } else {
434 $self->as_string
435# }
436}
437
438# escape the /'s in the path
439sub _escaped_path {
440 # ∕ is U+2215
441 (my $path = $_[0]{path}) =~ s/\//∕/g;
442 $path
443}
444
445# the original (read-only) location
446sub load_path {
447 my ($self) = @_;
448
449 sprintf "%s/%s/%s", cf::datadir, cf::mapdir, $self->{path}
450}
451
452# the temporary/swap location
453sub save_path {
454 my ($self) = @_;
455
456 $self->{user_rel} ? sprintf "%s/%s/%s/%s", cf::localdir, cf::playerdir, $self->{user}, $self->_escaped_path
457 : $self->{random} ? sprintf "%s/%s", $RANDOM_MAPS, $self->{path}
458 : sprintf "%s/%s/%s", cf::localdir, cf::tmpdir, $self->_escaped_path
459}
460
461# the unique path, might be eq to save_path
462sub uniq_path {
463 my ($self) = @_;
464
465 $self->{user_rel} || $self->{random}
466 ? undef
467 : sprintf "%s/%s/%s", cf::localdir, cf::uniquedir, $self->_escaped_path
468}
469
470# return random map parameters, or undef
471sub random_map_params {
472 my ($self) = @_;
473
474 $self->{random}
475}
476
477# this is somewhat ugly, but style maps do need special treatment
478sub is_style_map {
479 $_[0]{path} =~ m{^/styles/}
480}
481
482package cf;
483 572
484############################################################################# 573#############################################################################
485 574
486=head2 ATTACHABLE OBJECTS 575=head2 ATTACHABLE OBJECTS
487 576
489attach callbacks/event handlers (a collection of which is called an "attachment") 578attach callbacks/event handlers (a collection of which is called an "attachment")
490to it. All such attachable objects support the following methods. 579to it. All such attachable objects support the following methods.
491 580
492In the following description, CLASS can be any of C<global>, C<object> 581In the following description, CLASS can be any of C<global>, C<object>
493C<player>, C<client> or C<map> (i.e. the attachable objects in 582C<player>, C<client> or C<map> (i.e. the attachable objects in
494crossfire+). 583Crossfire TRT).
495 584
496=over 4 585=over 4
497 586
498=item $attachable->attach ($attachment, key => $value...) 587=item $attachable->attach ($attachment, key => $value...)
499 588
613our @CB_TYPE = (); # registry for type (cf-object class) based events 702our @CB_TYPE = (); # registry for type (cf-object class) based events
614our @CB_MAP = (); 703our @CB_MAP = ();
615 704
616my %attachment; 705my %attachment;
617 706
707sub cf::attachable::thawer_merge {
708 # simply override everything except _meta
709 local $_[0]{_meta};
710 %{$_[0]} = %{$_[1]};
711}
712
618sub _attach_cb($$$$) { 713sub _attach_cb($$$$) {
619 my ($registry, $event, $prio, $cb) = @_; 714 my ($registry, $event, $prio, $cb) = @_;
620 715
621 use sort 'stable'; 716 use sort 'stable';
622 717
656 $registry = $CB_TYPE[$object_type] ||= []; 751 $registry = $CB_TYPE[$object_type] ||= [];
657 752
658 } elsif ($type eq "subtype") { 753 } elsif ($type eq "subtype") {
659 defined $object_type or Carp::croak "subtype specified without type"; 754 defined $object_type or Carp::croak "subtype specified without type";
660 my $object_subtype = shift @arg; 755 my $object_subtype = shift @arg;
661 $registry = $CB_TYPE[$object_type + $object_subtype * NUM_SUBTYPES] ||= []; 756 $registry = $CB_TYPE[$object_type + $object_subtype * NUM_TYPES] ||= [];
662 757
663 } elsif ($type eq "package") { 758 } elsif ($type eq "package") {
664 my $pkg = shift @arg; 759 my $pkg = shift @arg;
665 760
666 while (my ($name, $id) = each %cb_id) { 761 while (my ($name, $id) = each %cb_id) {
695 _attach $registry, $klass, @attach; 790 _attach $registry, $klass, @attach;
696 } 791 }
697 792
698 $obj->{$name} = \%arg; 793 $obj->{$name} = \%arg;
699 } else { 794 } else {
700 warn "object uses attachment '$name' that is not available, postponing.\n"; 795 warn "object uses attachment '$name' which is not available, postponing.\n";
701 } 796 }
702 797
703 $obj->{_attachment}{$name} = undef; 798 $obj->{_attachment}{$name} = undef;
704} 799}
705 800
707 if (ref $_[0]) { 802 if (ref $_[0]) {
708 _object_attach @_; 803 _object_attach @_;
709 } else { 804 } else {
710 _attach shift->_attach_registry, @_; 805 _attach shift->_attach_registry, @_;
711 } 806 }
807 _recalc_want;
712}; 808};
713 809
714# all those should be optimised 810# all those should be optimised
715sub cf::attachable::detach { 811sub cf::attachable::detach {
716 my ($obj, $name) = @_; 812 my ($obj, $name) = @_;
719 delete $obj->{_attachment}{$name}; 815 delete $obj->{_attachment}{$name};
720 reattach ($obj); 816 reattach ($obj);
721 } else { 817 } else {
722 Carp::croak "cannot, currently, detach class attachments"; 818 Carp::croak "cannot, currently, detach class attachments";
723 } 819 }
820 _recalc_want;
724}; 821};
725 822
726sub cf::attachable::attached { 823sub cf::attachable::attached {
727 my ($obj, $name) = @_; 824 my ($obj, $name) = @_;
728 825
793# object support 890# object support
794 891
795sub reattach { 892sub reattach {
796 # basically do the same as instantiate, without calling instantiate 893 # basically do the same as instantiate, without calling instantiate
797 my ($obj) = @_; 894 my ($obj) = @_;
895
896 bless $obj, ref $obj; # re-bless in case extensions have been reloaded
798 897
799 my $registry = $obj->registry; 898 my $registry = $obj->registry;
800 899
801 @$registry = (); 900 @$registry = ();
802 901
849 $filename, length $$rdata, scalar @$objs; 948 $filename, length $$rdata, scalar @$objs;
850 949
851 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) { 950 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
852 chmod SAVE_MODE, $fh; 951 chmod SAVE_MODE, $fh;
853 aio_write $fh, 0, (length $$rdata), $$rdata, 0; 952 aio_write $fh, 0, (length $$rdata), $$rdata, 0;
854 aio_fsync $fh; 953 aio_fsync $fh if $cf::USE_FSYNC;
855 close $fh; 954 close $fh;
856 955
857 if (@$objs) { 956 if (@$objs) {
858 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) { 957 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) {
859 chmod SAVE_MODE, $fh; 958 chmod SAVE_MODE, $fh;
860 my $data = Storable::nfreeze { version => 1, objs => $objs }; 959 my $data = Storable::nfreeze { version => 1, objs => $objs };
861 aio_write $fh, 0, (length $data), $data, 0; 960 aio_write $fh, 0, (length $data), $data, 0;
862 aio_fsync $fh; 961 aio_fsync $fh if $cf::USE_FSYNC;
863 close $fh; 962 close $fh;
864 aio_rename "$filename.pst~", "$filename.pst"; 963 aio_rename "$filename.pst~", "$filename.pst";
865 } 964 }
866 } else { 965 } else {
867 aio_unlink "$filename.pst"; 966 aio_unlink "$filename.pst";
899 or return; 998 or return;
900 $av = eval { (Storable::thaw $av)->{objs} }; 999 $av = eval { (Storable::thaw $av)->{objs} };
901 } 1000 }
902 1001
903 warn sprintf "loading %s (%d)\n", 1002 warn sprintf "loading %s (%d)\n",
904 $filename, length $data, scalar @{$av || []};#d# 1003 $filename, length $data, scalar @{$av || []};
905 return ($data, $av); 1004 return ($data, $av);
906} 1005}
1006
1007=head2 COMMAND CALLBACKS
1008
1009=over 4
1010
1011=cut
907 1012
908############################################################################# 1013#############################################################################
909# command handling &c 1014# command handling &c
910 1015
911=item cf::register_command $name => \&callback($ob,$args); 1016=item cf::register_command $name => \&callback($ob,$args);
924 push @{ $COMMAND{$name} }, [$caller, $cb]; 1029 push @{ $COMMAND{$name} }, [$caller, $cb];
925} 1030}
926 1031
927=item cf::register_extcmd $name => \&callback($pl,$packet); 1032=item cf::register_extcmd $name => \&callback($pl,$packet);
928 1033
929Register a callbackf ro execution when the client sends an extcmd packet. 1034Register a callback fro execution when the client sends an extcmd packet.
930 1035
931If the callback returns something, it is sent back as if reply was being 1036If the callback returns something, it is sent back as if reply was being
932called. 1037called.
933 1038
934=cut 1039=cut
935 1040
936sub register_extcmd { 1041sub register_extcmd {
937 my ($name, $cb) = @_; 1042 my ($name, $cb) = @_;
938 1043
939 my $caller = caller;
940 #warn "registering extcmd '$name' to '$caller'";
941
942 $EXTCMD{$name} = [$cb, $caller]; 1044 $EXTCMD{$name} = $cb;
943} 1045}
944 1046
945cf::player->attach ( 1047cf::player->attach (
946 on_command => sub { 1048 on_command => sub {
947 my ($pl, $name, $params) = @_; 1049 my ($pl, $name, $params) = @_;
960 1062
961 my $msg = eval { from_json $buf }; 1063 my $msg = eval { from_json $buf };
962 1064
963 if (ref $msg) { 1065 if (ref $msg) {
964 if (my $cb = $EXTCMD{$msg->{msgtype}}) { 1066 if (my $cb = $EXTCMD{$msg->{msgtype}}) {
965 if (my %reply = $cb->[0]->($pl, $msg)) { 1067 if (my %reply = $cb->($pl, $msg)) {
966 $pl->ext_reply ($msg->{msgid}, %reply); 1068 $pl->ext_reply ($msg->{msgid}, %reply);
967 } 1069 }
968 } 1070 }
969 } else { 1071 } else {
970 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n"; 1072 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
972 1074
973 cf::override; 1075 cf::override;
974 }, 1076 },
975); 1077);
976 1078
977sub register {
978 my ($base, $pkg) = @_;
979
980 #TODO
981}
982
983sub load_extension { 1079sub load_extensions {
1080 cf::sync_job {
1081 my %todo;
1082
1083 for my $path (<$LIBDIR/*.ext>) {
1084 next unless -r $path;
1085
1086 $path =~ /([^\/\\]+)\.ext$/ or die "$path";
1087 my $base = $1;
1088 my $pkg = $1;
1089 $pkg =~ s/[^[:word:]]/_/g;
1090 $pkg = "ext::$pkg";
1091
1092 open my $fh, "<:utf8", $path
1093 or die "$path: $!";
1094
1095 my $source = do { local $/; <$fh> };
1096
1097 my %ext = (
1098 path => $path,
1099 base => $base,
1100 pkg => $pkg,
1101 );
1102
1103 $ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 }
1104 if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m;
1105
1106 $ext{source} =
1107 "package $pkg; use strict; use utf8;\n"
1108 . "#line 1 \"$path\"\n{\n"
1109 . $source
1110 . "\n};\n1";
1111
1112 $todo{$base} = \%ext;
1113 }
1114
1115 my %done;
1116 while (%todo) {
1117 my $progress;
1118
1119 while (my ($k, $v) = each %todo) {
1120 for (split /,\s*/, $v->{meta}{depends}) {
1121 goto skip
1122 unless exists $done{$_};
1123 }
1124
1125 warn "... loading '$k' into '$v->{pkg}'\n";
1126
1127 unless (eval $v->{source}) {
1128 my $msg = $@ ? "$v->{path}: $@\n"
1129 : "$v->{base}: extension inactive.\n";
1130
1131 if (exists $v->{meta}{mandatory}) {
1132 warn $msg;
1133 warn "mandatory extension failed to load, exiting.\n";
1134 exit 1;
1135 }
1136
1137 warn $msg;
1138 }
1139
1140 $done{$k} = delete $todo{$k};
1141 push @EXTS, $v->{pkg};
1142 $progress = 1;
1143 }
1144
1145 skip:
1146 die "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n"
1147 unless $progress;
1148 }
1149 };
1150}
1151
1152#############################################################################
1153
1154=back
1155
1156=head2 CORE EXTENSIONS
1157
1158Functions and methods that extend core crossfire objects.
1159
1160=cut
1161
1162package cf::player;
1163
1164use Coro::AIO;
1165
1166=head3 cf::player
1167
1168=over 4
1169
1170=item cf::player::find $login
1171
1172Returns the given player object, loading it if necessary (might block).
1173
1174=cut
1175
1176sub playerdir($) {
1177 "$PLAYERDIR/"
1178 . (ref $_[0] ? $_[0]->ob->name : $_[0])
1179}
1180
1181sub path($) {
1182 my $login = ref $_[0] ? $_[0]->ob->name : $_[0];
1183
1184 (playerdir $login) . "/playerdata"
1185}
1186
1187sub find_active($) {
1188 $cf::PLAYER{$_[0]}
1189 and $cf::PLAYER{$_[0]}->active
1190 and $cf::PLAYER{$_[0]}
1191}
1192
1193sub exists($) {
1194 my ($login) = @_;
1195
1196 $cf::PLAYER{$login}
1197 or cf::sync_job { !aio_stat path $login }
1198}
1199
1200sub find($) {
1201 return $cf::PLAYER{$_[0]} || do {
1202 my $login = $_[0];
1203
1204 my $guard = cf::lock_acquire "user_find:$login";
1205
1206 $cf::PLAYER{$_[0]} || do {
1207 # rename old playerfiles to new ones
1208 #TODO: remove when no longer required
1209 aio_link +(playerdir $login) . "/$login.pl.pst", (playerdir $login) . "/playerdata.pst";
1210 aio_link +(playerdir $login) . "/$login.pl" , (playerdir $login) . "/playerdata";
1211 aio_unlink +(playerdir $login) . "/$login.pl.pst";
1212 aio_unlink +(playerdir $login) . "/$login.pl";
1213
1214 my $pl = load_pl path $login
1215 or return;
1216 $cf::PLAYER{$login} = $pl
1217 }
1218 }
1219}
1220
1221sub save($) {
1222 my ($pl) = @_;
1223
1224 return if $pl->{deny_save};
1225
1226 my $path = path $pl;
1227 my $guard = cf::lock_acquire "user_save:$path";
1228
1229 return if $pl->{deny_save};
1230
1231 aio_mkdir playerdir $pl, 0770;
1232 $pl->{last_save} = $cf::RUNTIME;
1233
1234 $pl->save_pl ($path);
1235 Coro::cede;
1236}
1237
1238sub new($) {
1239 my ($login) = @_;
1240
1241 my $self = create;
1242
1243 $self->ob->name ($login);
1244 $self->{deny_save} = 1;
1245
1246 $cf::PLAYER{$login} = $self;
1247
1248 $self
1249}
1250
1251=item $pl->quit_character
1252
1253Nukes the player without looking back. If logged in, the connection will
1254be destroyed. May block for a long time.
1255
1256=cut
1257
1258sub quit_character {
1259 my ($pl) = @_;
1260
1261 my $name = $pl->ob->name;
1262
1263 $pl->{deny_save} = 1;
1264 $pl->password ("*"); # this should lock out the player until we nuked the dir
1265
1266 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active;
1267 $pl->deactivate;
1268 $pl->invoke (cf::EVENT_PLAYER_QUIT);
1269 $pl->ns->destroy if $pl->ns;
1270
1271 my $path = playerdir $pl;
1272 my $temp = "$path~$cf::RUNTIME~deleting~";
1273 aio_rename $path, $temp;
1274 delete $cf::PLAYER{$pl->ob->name};
1275 $pl->destroy;
1276
1277 my $prefix = qr<^~\Q$name\E/>;
1278
1279 # nuke player maps
1280 $cf::MAP{$_}->nuke for grep /$prefix/, keys %cf::MAP;
1281
1282 IO::AIO::aio_rmtree $temp;
1283}
1284
1285=item $pl->kick
1286
1287Kicks a player out of the game. This destroys the connection.
1288
1289=cut
1290
1291sub kick {
1292 my ($pl, $kicker) = @_;
1293
1294 $pl->invoke (cf::EVENT_PLAYER_KICK, $kicker);
1295 $pl->killer ("kicked");
1296 $pl->ns->destroy;
1297}
1298
1299=item cf::player::list_logins
1300
1301Returns am arrayref of all valid playernames in the system, can take a
1302while and may block, so not sync_job-capable, ever.
1303
1304=cut
1305
1306sub list_logins {
1307 my $dirs = aio_readdir $PLAYERDIR
1308 or return [];
1309
1310 my @logins;
1311
1312 for my $login (@$dirs) {
1313 my $fh = aio_open path $login, Fcntl::O_RDONLY, 0 or next;
1314 aio_read $fh, 0, 512, my $buf, 0 or next;
1315 $buf !~ /^password -------------$/m or next; # official not-valid tag
1316
1317 utf8::decode $login;
1318 push @logins, $login;
1319 }
1320
1321 \@logins
1322}
1323
1324=item $player->maps
1325
1326Returns an arrayref of map paths that are private for this
1327player. May block.
1328
1329=cut
1330
1331sub maps($) {
1332 my ($pl) = @_;
1333
1334 $pl = ref $pl ? $pl->ob->name : $pl;
1335
1336 my $files = aio_readdir playerdir $pl
1337 or return;
1338
1339 my @paths;
1340
1341 for (@$files) {
1342 utf8::decode $_;
1343 next if /\.(?:pl|pst)$/;
1344 next unless /^$PATH_SEP/o;
1345
1346 push @paths, cf::map::normalise "~$pl/$_";
1347 }
1348
1349 \@paths
1350}
1351
1352=item $player->ext_reply ($msgid, %msg)
1353
1354Sends an ext reply to the player.
1355
1356=cut
1357
1358sub ext_reply($$%) {
1359 my ($self, $id, %msg) = @_;
1360
1361 $msg{msgid} = $id;
1362
1363 $self->send ("ext " . cf::to_json \%msg);
1364}
1365
1366=item $player->ext_event ($type, %msg)
1367
1368Sends an ext event to the client.
1369
1370=cut
1371
1372sub ext_event($$%) {
1373 my ($self, $type, %msg) = @_;
1374
1375 $self->ns->ext_event ($type, %msg);
1376}
1377
1378=head3 cf::region
1379
1380=over 4
1381
1382=cut
1383
1384package cf::region;
1385
1386=item cf::region::find_by_path $path
1387
1388Tries to decuce the likely region for a map knowing only its path.
1389
1390=cut
1391
1392sub find_by_path($) {
984 my ($path) = @_; 1393 my ($path) = @_;
985 1394
986 $path =~ /([^\/\\]+)\.ext$/ or die "$path"; 1395 my ($match, $specificity);
987 my $base = $1;
988 my $pkg = $1;
989 $pkg =~ s/[^[:word:]]/_/g;
990 $pkg = "ext::$pkg";
991 1396
992 warn "loading '$path' into '$pkg'\n"; 1397 for my $region (list) {
993 1398 if ($region->match && $path =~ $region->match) {
994 open my $fh, "<:utf8", $path 1399 ($match, $specificity) = ($region, $region->specificity)
995 or die "$path: $!"; 1400 if $region->specificity > $specificity;
996 1401 }
997 my $source =
998 "package $pkg; use strict; use utf8;\n"
999 . "#line 1 \"$path\"\n{\n"
1000 . (do { local $/; <$fh> })
1001 . "\n};\n1";
1002
1003 eval $source
1004 or die $@ ? "$path: $@\n"
1005 : "extension disabled.\n";
1006
1007 push @exts, $pkg;
1008 $ext_pkg{$base} = $pkg;
1009
1010# no strict 'refs';
1011# @{"$pkg\::ISA"} = ext::;
1012
1013 register $base, $pkg;
1014}
1015
1016sub unload_extension {
1017 my ($pkg) = @_;
1018
1019 warn "removing extension $pkg\n";
1020
1021 # remove hooks
1022 #TODO
1023# for my $idx (0 .. $#PLUGIN_EVENT) {
1024# delete $hook[$idx]{$pkg};
1025# } 1402 }
1026 1403
1027 # remove commands 1404 $match
1028 for my $name (keys %COMMAND) {
1029 my @cb = grep $_->[0] ne $pkg, @{ $COMMAND{$name} };
1030
1031 if (@cb) {
1032 $COMMAND{$name} = \@cb;
1033 } else {
1034 delete $COMMAND{$name};
1035 }
1036 }
1037
1038 # remove extcmds
1039 for my $name (grep $EXTCMD{$_}[1] eq $pkg, keys %EXTCMD) {
1040 delete $EXTCMD{$name};
1041 }
1042
1043 if (my $cb = $pkg->can ("unload")) {
1044 eval {
1045 $cb->($pkg);
1046 1
1047 } or warn "$pkg unloaded, but with errors: $@";
1048 }
1049
1050 Symbol::delete_package $pkg;
1051}
1052
1053sub load_extensions {
1054 for my $ext (<$LIBDIR/*.ext>) {
1055 next unless -r $ext;
1056 eval {
1057 load_extension $ext;
1058 1
1059 } or warn "$ext not loaded: $@";
1060 }
1061}
1062
1063#############################################################################
1064# load/save/clean perl data associated with a map
1065
1066*cf::mapsupport::on_clean = sub {
1067 my ($map) = @_;
1068
1069 my $path = $map->tmpname;
1070 defined $path or return;
1071
1072 unlink "$path.pst";
1073};
1074
1075cf::map->attach (prio => -10000, package => cf::mapsupport::);
1076
1077#############################################################################
1078# load/save perl data associated with player->ob objects
1079
1080sub all_objects(@) {
1081 @_, map all_objects ($_->inv), @_
1082}
1083
1084# TODO: compatibility cruft, remove when no longer needed
1085cf::player->attach (
1086 on_load => sub {
1087 my ($pl, $path) = @_;
1088
1089 for my $o (all_objects $pl->ob) {
1090 if (my $value = $o->get_ob_key_value ("_perl_data")) {
1091 $o->set_ob_key_value ("_perl_data");
1092
1093 %$o = %{ Storable::thaw pack "H*", $value };
1094 }
1095 }
1096 },
1097);
1098
1099#############################################################################
1100
1101=head2 CORE EXTENSIONS
1102
1103Functions and methods that extend core crossfire objects.
1104
1105=head3 cf::player
1106
1107=over 4
1108
1109=item cf::player::exists $login
1110
1111Returns true when the given account exists.
1112
1113=cut
1114
1115sub cf::player::exists($) {
1116 cf::player::find $_[0]
1117 or -f sprintf "%s/%s/%s/%s.pl", cf::localdir, cf::playerdir, ($_[0]) x 2;
1118}
1119
1120=item $player->ext_reply ($msgid, $msgtype, %msg)
1121
1122Sends an ext reply to the player.
1123
1124=cut
1125
1126sub cf::player::ext_reply($$$%) {
1127 my ($self, $id, %msg) = @_;
1128
1129 $msg{msgid} = $id;
1130
1131 $self->send ("ext " . to_json \%msg);
1132} 1405}
1133 1406
1134=back 1407=back
1135
1136 1408
1137=head3 cf::map 1409=head3 cf::map
1138 1410
1139=over 4 1411=over 4
1140 1412
1143package cf::map; 1415package cf::map;
1144 1416
1145use Fcntl; 1417use Fcntl;
1146use Coro::AIO; 1418use Coro::AIO;
1147 1419
1420use overload
1421 '""' => \&as_string,
1422 fallback => 1;
1423
1148our $MAX_RESET = 3600; 1424our $MAX_RESET = 3600;
1149our $DEFAULT_RESET = 3000; 1425our $DEFAULT_RESET = 3000;
1150 1426
1151sub generate_random_map { 1427sub generate_random_map {
1152 my ($path, $rmp) = @_; 1428 my ($self, $rmp) = @_;
1153
1154 # mit "rum" bekleckern, nicht 1429 # mit "rum" bekleckern, nicht
1155 cf::map::_create_random_map 1430 $self->_create_random_map (
1156 $path,
1157 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle}, 1431 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle},
1158 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle}, 1432 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle},
1159 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map}, 1433 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map},
1160 $rmp->{exit_on_final_map}, 1434 $rmp->{exit_on_final_map},
1161 $rmp->{xsize}, $rmp->{ysize}, 1435 $rmp->{xsize}, $rmp->{ysize},
1162 $rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3}, 1436 $rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3},
1163 $rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase}, 1437 $rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase},
1164 $rmp->{dungeon_level}, $rmp->{dungeon_depth}, $rmp->{decoroptions}, $rmp->{orientation}, 1438 $rmp->{dungeon_level}, $rmp->{dungeon_depth}, $rmp->{decoroptions}, $rmp->{orientation},
1165 $rmp->{origin_y}, $rmp->{origin_x}, $rmp->{random_seed}, $rmp->{total_map_hp}, 1439 $rmp->{origin_y}, $rmp->{origin_x}, $rmp->{random_seed}, $rmp->{total_map_hp},
1166 $rmp->{map_layout_style}, $rmp->{treasureoptions}, $rmp->{symmetry_used}, 1440 $rmp->{map_layout_style}, $rmp->{treasureoptions}, $rmp->{symmetry_used},
1167 (cf::region::find $rmp->{region}) 1441 (cf::region::find $rmp->{region}), $rmp->{custom}
1442 )
1443}
1444
1445=item cf::map->register ($regex, $prio)
1446
1447Register a handler for the map path matching the given regex at the
1448givne priority (higher is better, built-in handlers have priority 0, the
1449default).
1450
1451=cut
1452
1453sub register {
1454 my (undef, $regex, $prio) = @_;
1455 my $pkg = caller;
1456
1457 no strict;
1458 push @{"$pkg\::ISA"}, __PACKAGE__;
1459
1460 $EXT_MAP{$pkg} = [$prio, qr<$regex>];
1461}
1462
1463# also paths starting with '/'
1464$EXT_MAP{"cf::map"} = [0, qr{^(?=/)}];
1465
1466sub thawer_merge {
1467 my ($self, $merge) = @_;
1468
1469 # we have to keep some variables in memory intact
1470 local $self->{path};
1471 local $self->{load_path};
1472
1473 $self->SUPER::thawer_merge ($merge);
1474}
1475
1476sub normalise {
1477 my ($path, $base) = @_;
1478
1479 $path = "$path"; # make sure its a string
1480
1481 $path =~ s/\.map$//;
1482
1483 # map plan:
1484 #
1485 # /! non-realised random map exit (special hack!)
1486 # {... are special paths that are not being touched
1487 # ?xxx/... are special absolute paths
1488 # ?random/... random maps
1489 # /... normal maps
1490 # ~user/... per-player map of a specific user
1491
1492 $path =~ s/$PATH_SEP/\//go;
1493
1494 # treat it as relative path if it starts with
1495 # something that looks reasonable
1496 if ($path =~ m{^(?:\./|\.\./|\w)}) {
1497 $base or Carp::carp "normalise called with relative path and no base: '$path'";
1498
1499 $base =~ s{[^/]+/?$}{};
1500 $path = "$base/$path";
1501 }
1502
1503 for ($path) {
1504 redo if s{//}{/};
1505 redo if s{/\.?/}{/};
1506 redo if s{/[^/]+/\.\./}{/};
1507 }
1508
1509 $path
1510}
1511
1512sub new_from_path {
1513 my (undef, $path, $base) = @_;
1514
1515 return $path if UNIVERSAL::isa $path, "cf::map"; # already a map object
1516
1517 $path = normalise $path, $base;
1518
1519 for my $pkg (sort { $EXT_MAP{$b}[0] <=> $EXT_MAP{$a}[0] } keys %EXT_MAP) {
1520 if ($path =~ $EXT_MAP{$pkg}[1]) {
1521 my $self = bless cf::map::new, $pkg;
1522 $self->{path} = $path; $self->path ($path);
1523 $self->init; # pass $1 etc.
1524 return $self;
1525 }
1526 }
1527
1528 Carp::carp "unable to resolve path '$path' (base '$base').";
1529 ()
1530}
1531
1532sub init {
1533 my ($self) = @_;
1534
1535 $self
1536}
1537
1538sub as_string {
1539 my ($self) = @_;
1540
1541 "$self->{path}"
1542}
1543
1544# the displayed name, this is a one way mapping
1545sub visible_name {
1546 &as_string
1547}
1548
1549# the original (read-only) location
1550sub load_path {
1551 my ($self) = @_;
1552
1553 "$MAPDIR/$self->{path}.map"
1554}
1555
1556# the temporary/swap location
1557sub save_path {
1558 my ($self) = @_;
1559
1560 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g;
1561 "$TMPDIR/$path.map"
1562}
1563
1564# the unique path, undef == no special unique path
1565sub uniq_path {
1566 my ($self) = @_;
1567
1568 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g;
1569 "$UNIQUEDIR/$path"
1168} 1570}
1169 1571
1170# and all this just because we cannot iterate over 1572# and all this just because we cannot iterate over
1171# all maps in C++... 1573# all maps in C++...
1172sub change_all_map_light { 1574sub change_all_map_light {
1174 1576
1175 $_->change_map_light ($change) 1577 $_->change_map_light ($change)
1176 for grep $_->outdoor, values %cf::MAP; 1578 for grep $_->outdoor, values %cf::MAP;
1177} 1579}
1178 1580
1581sub decay_objects {
1582 my ($self) = @_;
1583
1584 return if $self->{deny_reset};
1585
1586 $self->do_decay_objects;
1587}
1588
1589sub unlink_save {
1590 my ($self) = @_;
1591
1592 utf8::encode (my $save = $self->save_path);
1593 IO::AIO::aioreq_pri 4; Coro::AIO::aio_unlink $save;
1594 IO::AIO::aioreq_pri 4; Coro::AIO::aio_unlink "$save.pst";
1595}
1596
1179sub try_load_header($) { 1597sub load_header_from($) {
1180 my ($path) = @_; 1598 my ($self, $path) = @_;
1181 1599
1182 utf8::encode $path; 1600 utf8::encode $path;
1183 aio_open $path, O_RDONLY, 0 1601 #aio_open $path, O_RDONLY, 0
1602 # or return;
1603
1604 $self->_load_header ($path)
1184 or return; 1605 or return;
1185 1606
1186 my $map = cf::map::new 1607 $self->{load_path} = $path;
1608
1609 1
1610}
1611
1612sub load_header_orig {
1613 my ($self) = @_;
1614
1615 $self->load_header_from ($self->load_path)
1616}
1617
1618sub load_header_temp {
1619 my ($self) = @_;
1620
1621 $self->load_header_from ($self->save_path)
1622}
1623
1624sub prepare_temp {
1625 my ($self) = @_;
1626
1627 $self->last_access ((delete $self->{last_access})
1628 || $cf::RUNTIME); #d#
1629 # safety
1630 $self->{instantiate_time} = $cf::RUNTIME
1631 if $self->{instantiate_time} > $cf::RUNTIME;
1632}
1633
1634sub prepare_orig {
1635 my ($self) = @_;
1636
1637 $self->{load_original} = 1;
1638 $self->{instantiate_time} = $cf::RUNTIME;
1639 $self->last_access ($cf::RUNTIME);
1640 $self->instantiate;
1641}
1642
1643sub load_header {
1644 my ($self) = @_;
1645
1646 if ($self->load_header_temp) {
1647 $self->prepare_temp;
1648 } else {
1649 $self->load_header_orig
1187 or return; 1650 or return;
1651 $self->prepare_orig;
1652 }
1188 1653
1189 $map->load_header ($path) 1654 $self->{deny_reset} = 1
1190 or return; 1655 if $self->no_reset;
1191 1656
1192 $map->{load_path} = $path; 1657 $self->default_region (cf::region::find_by_path $self->{path})
1658 unless $self->default_region;
1193 1659
1194 $map 1660 1
1195} 1661}
1196 1662
1197sub find; 1663sub find;
1198sub find { 1664sub find {
1199 my ($path, $origin) = @_; 1665 my ($path, $origin) = @_;
1200 1666
1201 #warn "find<$path,$origin>\n";#d#
1202
1203 $path = new cf::path $path, $origin && $origin->path; 1667 $path = normalise $path, $origin && $origin->path;
1204 my $key = $path->as_string;
1205 1668
1206 cf::lock_wait "map_find:$key"; 1669 cf::lock_wait "map_find:$path";
1207 1670
1208 $cf::MAP{$key} || do { 1671 $cf::MAP{$path} || do {
1209 my $guard = cf::lock_acquire "map_find:$key"; 1672 my $guard = cf::lock_acquire "map_find:$path";
1210 1673 my $map = new_from_path cf::map $path
1211 # do it the slow way
1212 my $map = try_load_header $path->save_path;
1213
1214 Coro::cede;
1215
1216 if ($map) {
1217 $map->last_access ((delete $map->{last_access})
1218 || $cf::RUNTIME); #d#
1219 # safety
1220 $map->{instantiate_time} = $cf::RUNTIME
1221 if $map->{instantiate_time} > $cf::RUNTIME;
1222 } else {
1223 if (my $rmp = $path->random_map_params) {
1224 $map = generate_random_map $key, $rmp;
1225 } else {
1226 $map = try_load_header $path->load_path;
1227 }
1228
1229 $map or return; 1674 or return;
1230 1675
1231 $map->{load_original} = 1;
1232 $map->{instantiate_time} = $cf::RUNTIME;
1233 $map->last_access ($cf::RUNTIME);
1234 $map->instantiate;
1235
1236 # per-player maps become, after loading, normal maps
1237 $map->per_player (0) if $path->{user_rel};
1238 }
1239
1240 $map->path ($key);
1241 $map->{path} = $path;
1242 $map->{last_save} = $cf::RUNTIME; 1676 $map->{last_save} = $cf::RUNTIME;
1243 1677
1244 Coro::cede; 1678 $map->load_header
1679 or return;
1245 1680
1246 if ($map->should_reset) { 1681 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?)
1682 # doing this can freeze the server in a sync job, obviously
1683 #$cf::WAIT_FOR_TICK->wait;
1247 $map->reset; 1684 $map->reset;
1248 undef $guard; 1685 undef $guard;
1249 $map = find $path 1686 return find $path;
1250 or return;
1251 } 1687 }
1252 1688
1253 $cf::MAP{$key} = $map 1689 $cf::MAP{$path} = $map
1254 } 1690 }
1255} 1691}
1692
1693sub pre_load { }
1694sub post_load { }
1256 1695
1257sub load { 1696sub load {
1258 my ($self) = @_; 1697 my ($self) = @_;
1259 1698
1699 local $self->{deny_reset} = 1; # loading can take a long time
1700
1260 my $path = $self->{path}; 1701 my $path = $self->{path};
1702
1703 {
1261 my $guard = cf::lock_acquire "map_load:" . $path->as_string; 1704 my $guard = cf::lock_acquire "map_load:$path";
1262 1705
1263 return if $self->in_memory != cf::MAP_SWAPPED; 1706 return if $self->in_memory != cf::MAP_SWAPPED;
1264 1707
1265 $self->in_memory (cf::MAP_LOADING); 1708 $self->in_memory (cf::MAP_LOADING);
1266 1709
1267 $self->alloc; 1710 $self->alloc;
1711
1712 $self->pre_load;
1713 Coro::cede;
1714
1268 $self->load_objects ($self->{load_path}, 1) 1715 $self->_load_objects ($self->{load_path}, 1)
1269 or return; 1716 or return;
1270 1717
1271 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1) 1718 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1)
1272 if delete $self->{load_original}; 1719 if delete $self->{load_original};
1273 1720
1274 if (my $uniq = $path->uniq_path) { 1721 if (my $uniq = $self->uniq_path) {
1275 utf8::encode $uniq; 1722 utf8::encode $uniq;
1276 if (aio_open $uniq, O_RDONLY, 0) { 1723 if (aio_open $uniq, O_RDONLY, 0) {
1277 $self->clear_unique_items; 1724 $self->clear_unique_items;
1278 $self->load_objects ($uniq, 0); 1725 $self->_load_objects ($uniq, 0);
1279 } 1726 }
1280 } 1727 }
1281 1728
1282 Coro::cede; 1729 Coro::cede;
1283
1284 # now do the right thing for maps 1730 # now do the right thing for maps
1285 $self->link_multipart_objects; 1731 $self->link_multipart_objects;
1286
1287 if ($self->{path}->is_style_map) {
1288 $self->{deny_save} = 1;
1289 $self->{deny_reset} = 1;
1290 } else {
1291 $self->fix_auto_apply;
1292 $self->decay_objects;
1293 $self->update_buttons;
1294 $self->set_darkness_map;
1295 $self->difficulty ($self->estimate_difficulty) 1732 $self->difficulty ($self->estimate_difficulty)
1296 unless $self->difficulty; 1733 unless $self->difficulty;
1734 Coro::cede;
1735
1736 unless ($self->{deny_activate}) {
1737 $self->decay_objects;
1738 $self->fix_auto_apply;
1739 $self->update_buttons;
1740 Coro::cede;
1741 $self->set_darkness_map;
1742 Coro::cede;
1297 $self->activate; 1743 $self->activate;
1298 } 1744 }
1299 1745
1300 Coro::cede;
1301
1302 $self->in_memory (cf::MAP_IN_MEMORY); 1746 $self->in_memory (cf::MAP_IN_MEMORY);
1747 }
1748
1749 $self->post_load;
1750}
1751
1752sub customise_for {
1753 my ($self, $ob) = @_;
1754
1755 return find "~" . $ob->name . "/" . $self->{path}
1756 if $self->per_player;
1757
1758# return find "?party/" . $ob->name . "/" . $self->{path}
1759# if $self->per_party;
1760
1761 $self
1762}
1763
1764# find and load all maps in the 3x3 area around a map
1765sub load_diag {
1766 my ($map) = @_;
1767
1768 my @diag; # diagonal neighbours
1769
1770 for (0 .. 3) {
1771 my $neigh = $map->tile_path ($_)
1772 or next;
1773 $neigh = find $neigh, $map
1774 or next;
1775 $neigh->load;
1776
1777 push @diag, [$neigh->tile_path (($_ + 3) % 4), $neigh],
1778 [$neigh->tile_path (($_ + 1) % 4), $neigh];
1779 }
1780
1781 for (@diag) {
1782 my $neigh = find @$_
1783 or next;
1784 $neigh->load;
1785 }
1303} 1786}
1304 1787
1305sub find_sync { 1788sub find_sync {
1306 my ($path, $origin) = @_; 1789 my ($path, $origin) = @_;
1307 1790
1308 cf::sync_job { cf::map::find $path, $origin } 1791 cf::sync_job { find $path, $origin }
1309} 1792}
1310 1793
1311sub do_load_sync { 1794sub do_load_sync {
1312 my ($map) = @_; 1795 my ($map) = @_;
1313 1796
1314 cf::sync_job { $map->load }; 1797 cf::sync_job { $map->load };
1315} 1798}
1316 1799
1800our %MAP_PREFETCH;
1801our $MAP_PREFETCHER = undef;
1802
1803sub find_async {
1804 my ($path, $origin) = @_;
1805
1806 $path = normalise $path, $origin && $origin->{path};
1807
1808 if (my $map = $cf::MAP{$path}) {
1809 return $map if $map->in_memory == cf::MAP_IN_MEMORY;
1810 }
1811
1812 undef $MAP_PREFETCH{$path};
1813 $MAP_PREFETCHER ||= cf::async {
1814 while (%MAP_PREFETCH) {
1815 for my $path (keys %MAP_PREFETCH) {
1816 my $map = find $path
1817 or next;
1818 $map->load;
1819
1820 delete $MAP_PREFETCH{$path};
1821 }
1822 }
1823 undef $MAP_PREFETCHER;
1824 };
1825 $MAP_PREFETCHER->prio (6);
1826
1827 ()
1828}
1829
1317sub save { 1830sub save {
1318 my ($self) = @_; 1831 my ($self) = @_;
1319 1832
1833 my $lock = cf::lock_acquire "map_data:" . $self->path;
1834
1320 $self->{last_save} = $cf::RUNTIME; 1835 $self->{last_save} = $cf::RUNTIME;
1321 1836
1322 return unless $self->dirty; 1837 return unless $self->dirty;
1323 1838
1324 my $save = $self->{path}->save_path; utf8::encode $save; 1839 my $save = $self->save_path; utf8::encode $save;
1325 my $uniq = $self->{path}->uniq_path; utf8::encode $uniq; 1840 my $uniq = $self->uniq_path; utf8::encode $uniq;
1326 1841
1327 $self->{load_path} = $save; 1842 $self->{load_path} = $save;
1328 1843
1329 return if $self->{deny_save}; 1844 return if $self->{deny_save};
1330 1845
1331 local $self->{last_access} = $self->last_access;#d# 1846 local $self->{last_access} = $self->last_access;#d#
1332 1847
1848 cf::async {
1849 $_->contr->save for $self->players;
1850 };
1851
1333 if ($uniq) { 1852 if ($uniq) {
1334 $self->save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS); 1853 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS);
1335 $self->save_objects ($uniq, cf::IO_UNIQUES); 1854 $self->_save_objects ($uniq, cf::IO_UNIQUES);
1336 } else { 1855 } else {
1337 $self->save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES); 1856 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES);
1338 } 1857 }
1339} 1858}
1340 1859
1341sub swap_out { 1860sub swap_out {
1342 my ($self) = @_; 1861 my ($self) = @_;
1343 1862
1344 # save first because save cedes 1863 # save first because save cedes
1345 $self->save; 1864 $self->save;
1865
1866 my $lock = cf::lock_acquire "map_data:" . $self->path;
1346 1867
1347 return if $self->players; 1868 return if $self->players;
1348 return if $self->in_memory != cf::MAP_IN_MEMORY; 1869 return if $self->in_memory != cf::MAP_IN_MEMORY;
1349 return if $self->{deny_save}; 1870 return if $self->{deny_save};
1350 1871
1354 1875
1355sub reset_at { 1876sub reset_at {
1356 my ($self) = @_; 1877 my ($self) = @_;
1357 1878
1358 # TODO: safety, remove and allow resettable per-player maps 1879 # TODO: safety, remove and allow resettable per-player maps
1359 return 1e99 if $self->{path}{user_rel};
1360 return 1e99 if $self->{deny_reset}; 1880 return 1e99 if $self->{deny_reset};
1361 1881
1362 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access; 1882 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
1363 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET; 1883 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET;
1364 1884
1369 my ($self) = @_; 1889 my ($self) = @_;
1370 1890
1371 $self->reset_at <= $cf::RUNTIME 1891 $self->reset_at <= $cf::RUNTIME
1372} 1892}
1373 1893
1374sub unlink_save {
1375 my ($self) = @_;
1376
1377 utf8::encode (my $save = $self->{path}->save_path);
1378 aioreq_pri 3; IO::AIO::aio_unlink $save;
1379 aioreq_pri 3; IO::AIO::aio_unlink "$save.pst";
1380}
1381
1382sub rename {
1383 my ($self, $new_path) = @_;
1384
1385 $self->unlink_save;
1386
1387 delete $cf::MAP{$self->path};
1388 $self->{path} = new cf::path $new_path;
1389 $self->path ($self->{path}->as_string);
1390 $cf::MAP{$self->path} = $self;
1391
1392 $self->save;
1393}
1394
1395sub reset { 1894sub reset {
1396 my ($self) = @_; 1895 my ($self) = @_;
1397 1896
1897 my $lock = cf::lock_acquire "map_data:$self->{path}";
1898
1398 return if $self->players; 1899 return if $self->players;
1399 return if $self->{path}{user_rel};#d#
1400 1900
1401 warn "resetting map ", $self->path;#d# 1901 warn "resetting map ", $self->path;
1902
1903 $self->in_memory (cf::MAP_SWAPPED);
1904
1905 # need to save uniques path
1906 unless ($self->{deny_save}) {
1907 my $uniq = $self->uniq_path; utf8::encode $uniq;
1908
1909 $self->_save_objects ($uniq, cf::IO_UNIQUES)
1910 if $uniq;
1911 }
1402 1912
1403 delete $cf::MAP{$self->path}; 1913 delete $cf::MAP{$self->path};
1914
1915 $self->clear;
1404 1916
1405 $_->clear_links_to ($self) for values %cf::MAP; 1917 $_->clear_links_to ($self) for values %cf::MAP;
1406 1918
1407 $self->unlink_save; 1919 $self->unlink_save;
1408 $self->destroy; 1920 $self->destroy;
1411my $nuke_counter = "aaaa"; 1923my $nuke_counter = "aaaa";
1412 1924
1413sub nuke { 1925sub nuke {
1414 my ($self) = @_; 1926 my ($self) = @_;
1415 1927
1928 delete $cf::MAP{$self->path};
1929
1930 $self->unlink_save;
1931
1932 bless $self, "cf::map";
1933 delete $self->{deny_reset};
1416 $self->{deny_save} = 1; 1934 $self->{deny_save} = 1;
1417 $self->reset_timeout (1); 1935 $self->reset_timeout (1);
1418 $self->rename ("{nuke}/" . ($nuke_counter++)); 1936 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));
1937
1938 $cf::MAP{$self->path} = $self;
1939
1419 $self->reset; # polite request, might not happen 1940 $self->reset; # polite request, might not happen
1420} 1941}
1421 1942
1422sub customise_for { 1943=item $maps = cf::map::tmp_maps
1423 my ($map, $ob) = @_;
1424 1944
1425 if ($map->per_player) { 1945Returns an arrayref with all map paths of currently instantiated and saved
1426 return cf::map::find "~" . $ob->name . "/" . $map->{path}{path}; 1946maps. May block.
1947
1948=cut
1949
1950sub tmp_maps() {
1427 } 1951 [
1428 1952 map {
1429 $map 1953 utf8::decode $_;
1954 /\.map$/
1955 ? normalise $_
1956 : ()
1957 } @{ aio_readdir $TMPDIR or [] }
1958 ]
1430} 1959}
1431 1960
1432sub emergency_save { 1961=item $maps = cf::map::random_maps
1433 my $freeze_guard = cf::freeze_mainloop;
1434 1962
1435 warn "enter emergency map save\n"; 1963Returns an arrayref with all map paths of currently instantiated and saved
1964random maps. May block.
1436 1965
1437 cf::sync_job { 1966=cut
1438 warn "begin emergency map save\n";
1439 $_->save for values %cf::MAP;
1440 };
1441 1967
1442 warn "end emergency map save\n"; 1968sub random_maps() {
1969 [
1970 map {
1971 utf8::decode $_;
1972 /\.map$/
1973 ? normalise "?random/$_"
1974 : ()
1975 } @{ aio_readdir $RANDOMDIR or [] }
1976 ]
1977}
1978
1979=item cf::map::unique_maps
1980
1981Returns an arrayref of paths of all shared maps that have
1982instantiated unique items. May block.
1983
1984=cut
1985
1986sub unique_maps() {
1987 [
1988 map {
1989 utf8::decode $_;
1990 /\.map$/
1991 ? normalise $_
1992 : ()
1993 } @{ aio_readdir $UNIQUEDIR or [] }
1994 ]
1443} 1995}
1444 1996
1445package cf; 1997package cf;
1446 1998
1447=back 1999=back
1448 2000
2001=head3 cf::object
2002
2003=cut
2004
2005package cf::object;
2006
2007=over 4
2008
2009=item $ob->inv_recursive
2010
2011Returns the inventory of the object _and_ their inventories, recursively.
2012
2013=cut
2014
2015sub inv_recursive_;
2016sub inv_recursive_ {
2017 map { $_, inv_recursive_ $_->inv } @_
2018}
2019
2020sub inv_recursive {
2021 inv_recursive_ inv $_[0]
2022}
2023
2024package cf;
2025
2026=back
1449 2027
1450=head3 cf::object::player 2028=head3 cf::object::player
1451 2029
1452=over 4 2030=over 4
1453 2031
1467 2045
1468 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4; 2046 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4;
1469 2047
1470 if ($self->{record_replies}) { 2048 if ($self->{record_replies}) {
1471 push @{ $self->{record_replies} }, [$npc, $msg, $flags]; 2049 push @{ $self->{record_replies} }, [$npc, $msg, $flags];
2050
1472 } else { 2051 } else {
2052 my $pl = $self->contr;
2053
2054 if ($pl->{npc_dialog} && $pl->{npc_dialog}->{id}) {
2055 my $diag = $pl->{npc_dialog};
2056 $diag->{pl}->ext_reply (
2057 $diag->{id}, msgtype => "reply", msg => $msg, add_topics => []
2058 );
2059
2060 } else {
1473 $msg = $npc->name . " says: $msg" if $npc; 2061 $msg = $npc->name . " says: $msg" if $npc;
1474 $self->message ($msg, $flags); 2062 $self->message ($msg, $flags);
2063 }
1475 } 2064 }
1476} 2065}
1477 2066
1478=item $player_object->may ("access") 2067=item $player_object->may ("access")
1479 2068
1493 2082
1494=item $player_object->enter_link 2083=item $player_object->enter_link
1495 2084
1496Freezes the player and moves him/her to a special map (C<{link}>). 2085Freezes the player and moves him/her to a special map (C<{link}>).
1497 2086
1498The player should be reaosnably safe there for short amounts of time. You 2087The player should be reasonably safe there for short amounts of time. You
1499I<MUST> call C<leave_link> as soon as possible, though. 2088I<MUST> call C<leave_link> as soon as possible, though.
1500 2089
2090Will never block.
2091
1501=item $player_object->leave_link ($map, $x, $y) 2092=item $player_object->leave_link ($map, $x, $y)
1502 2093
1503Moves the player out of the specila link map onto the given map. If the 2094Moves the player out of the special C<{link}> map onto the specified
1504map is not valid (or omitted), the player will be moved back to the 2095map. If the map is not valid (or omitted), the player will be moved back
1505location he/she was before the call to C<enter_link>, or, if that fails, 2096to the location he/she was before the call to C<enter_link>, or, if that
1506to the emergency map position. 2097fails, to the emergency map position.
1507 2098
1508Might block. 2099Might block.
1509 2100
1510=cut 2101=cut
2102
2103sub link_map {
2104 unless ($LINK_MAP) {
2105 $LINK_MAP = cf::map::find "{link}"
2106 or cf::cleanup "FATAL: unable to provide {link} map, exiting.";
2107 $LINK_MAP->load;
2108 }
2109
2110 $LINK_MAP
2111}
1511 2112
1512sub cf::object::player::enter_link { 2113sub cf::object::player::enter_link {
1513 my ($self) = @_; 2114 my ($self) = @_;
1514 2115
1515 $self->deactivate_recursive; 2116 $self->deactivate_recursive;
1516 2117
1517 return if $self->map == $LINK_MAP; 2118 return if UNIVERSAL::isa $self->map, "ext::map_link";
1518 2119
1519 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y] 2120 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y]
1520 if $self->map; 2121 if $self->map && $self->map->{path} ne "{link}";
1521 2122
1522 $self->enter_map ($LINK_MAP, 20, 20); 2123 $self->enter_map ($LINK_MAP || link_map, 10, 10);
1523} 2124}
1524 2125
1525sub cf::object::player::leave_link { 2126sub cf::object::player::leave_link {
1526 my ($self, $map, $x, $y) = @_; 2127 my ($self, $map, $x, $y) = @_;
2128
2129 return unless $self->contr->active;
1527 2130
1528 my $link_pos = delete $self->{_link_pos}; 2131 my $link_pos = delete $self->{_link_pos};
1529 2132
1530 unless ($map) { 2133 unless ($map) {
1531 # restore original map position 2134 # restore original map position
1545 # use -1 or undef as default coordinates, not 0, 0 2148 # use -1 or undef as default coordinates, not 0, 0
1546 ($x, $y) = ($map->enter_x, $map->enter_y) 2149 ($x, $y) = ($map->enter_x, $map->enter_y)
1547 if $x <=0 && $y <= 0; 2150 if $x <=0 && $y <= 0;
1548 2151
1549 $map->load; 2152 $map->load;
2153 $map->load_diag;
1550 2154
2155 return unless $self->contr->active;
1551 $self->activate_recursive; 2156 $self->activate_recursive;
2157
2158 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
1552 $self->enter_map ($map, $x, $y); 2159 $self->enter_map ($map, $x, $y);
1553} 2160}
1554 2161
1555cf::player->attach (
1556 on_logout => sub {
1557 my ($pl) = @_;
1558
1559 # abort map switching before logout
1560 if ($pl->ob->{_link_pos}) {
1561 cf::sync_job {
1562 $pl->ob->leave_link
1563 };
1564 }
1565 },
1566 on_login => sub {
1567 my ($pl) = @_;
1568
1569 # try to abort aborted map switching on player login :)
1570 # should happen only on crashes
1571 if ($pl->ob->{_link_pos}) {
1572 $pl->ob->enter_link;
1573 cf::async {
1574 # we need this sleep as the login has a concurrent enter_exit running
1575 # and this sleep increases chances of the player not ending up in scorn
1576 Coro::Timer::sleep 1;
1577 $pl->ob->leave_link;
1578 };
1579 }
1580 },
1581);
1582
1583=item $player_object->goto_map ($path, $x, $y) 2162=item $player_object->goto ($path, $x, $y[, $check->($map)])
1584 2163
1585=cut 2164Moves the player to the given map-path and coordinates by first freezing
2165her, loading and preparing them map, calling the provided $check callback
2166that has to return the map if sucecssful, and then unfreezes the player on
2167the new (success) or old (failed) map position.
1586 2168
2169=cut
2170
2171our $GOTOGEN;
2172
1587sub cf::object::player::goto_map { 2173sub cf::object::player::goto {
1588 my ($self, $path, $x, $y) = @_; 2174 my ($self, $path, $x, $y, $check) = @_;
2175
2176 # do generation counting so two concurrent goto's will be executed in-order
2177 my $gen = $self->{_goto_generation} = ++$GOTOGEN;
1589 2178
1590 $self->enter_link; 2179 $self->enter_link;
1591 2180
1592 (cf::async { 2181 (async {
1593 $path = new cf::path $path; 2182 my $map = eval {
1594
1595 my $map = cf::map::find $path->as_string; 2183 my $map = cf::map::find $path;
2184
2185 if ($map) {
1596 $map = $map->customise_for ($self) if $map; 2186 $map = $map->customise_for ($self);
1597 2187 $map = $check->($map) if $check && $map;
1598# warn "entering ", $map->path, " at ($x, $y)\n" 2188 } else {
1599# if $map;
1600
1601 $map or $self->message ("The exit is closed", cf::NDI_UNIQUE | cf::NDI_RED); 2189 $self->message ("The exit to '$path' is closed", cf::NDI_UNIQUE | cf::NDI_RED);
2190 }
1602 2191
2192 $map
2193 };
2194
2195 if ($@) {
2196 $self->message ("Something went wrong within the server, please report this incident!", cf::NDI_UNIQUE | cf::NDI_RED);
2197 LOG llevError | logBacktrace, Carp::longmess $@;
2198 }
2199
2200 if ($gen == $self->{_goto_generation}) {
2201 delete $self->{_goto_generation};
1603 $self->leave_link ($map, $x, $y); 2202 $self->leave_link ($map, $x, $y);
2203 }
1604 })->prio (1); 2204 })->prio (1);
1605} 2205}
1606 2206
1607=item $player_object->enter_exit ($exit_object) 2207=item $player_object->enter_exit ($exit_object)
1608 2208
1610 2210
1611sub parse_random_map_params { 2211sub parse_random_map_params {
1612 my ($spec) = @_; 2212 my ($spec) = @_;
1613 2213
1614 my $rmp = { # defaults 2214 my $rmp = { # defaults
1615 xsize => 10, 2215 xsize => (cf::rndm 15, 40),
1616 ysize => 10, 2216 ysize => (cf::rndm 15, 40),
2217 symmetry => (cf::rndm 1, cf::SYMMETRY_XY),
2218 #layout => string,
1617 }; 2219 };
1618 2220
1619 for (split /\n/, $spec) { 2221 for (split /\n/, $spec) {
1620 my ($k, $v) = split /\s+/, $_, 2; 2222 my ($k, $v) = split /\s+/, $_, 2;
1621 2223
1625 $rmp 2227 $rmp
1626} 2228}
1627 2229
1628sub prepare_random_map { 2230sub prepare_random_map {
1629 my ($exit) = @_; 2231 my ($exit) = @_;
2232
2233 my $guard = cf::lock_acquire "exit_prepare:$exit";
1630 2234
1631 # all this does is basically replace the /! path by 2235 # all this does is basically replace the /! path by
1632 # a new random map path (?random/...) with a seed 2236 # a new random map path (?random/...) with a seed
1633 # that depends on the exit object 2237 # that depends on the exit object
1634 2238
1635 my $rmp = parse_random_map_params $exit->msg; 2239 my $rmp = parse_random_map_params $exit->msg;
1636 2240
1637 if ($exit->map) { 2241 if ($exit->map) {
1638 $rmp->{region} = $exit->map->region_name; 2242 $rmp->{region} = $exit->region->name;
1639 $rmp->{origin_map} = $exit->map->path; 2243 $rmp->{origin_map} = $exit->map->path;
1640 $rmp->{origin_x} = $exit->x; 2244 $rmp->{origin_x} = $exit->x;
1641 $rmp->{origin_y} = $exit->y; 2245 $rmp->{origin_y} = $exit->y;
1642 } 2246 }
1643 2247
1644 $rmp->{random_seed} ||= $exit->random_seed; 2248 $rmp->{random_seed} ||= $exit->random_seed;
1645 2249
1646 my $data = cf::to_json $rmp; 2250 my $data = cf::to_json $rmp;
1647 my $md5 = Digest::MD5::md5_hex $data; 2251 my $md5 = Digest::MD5::md5_hex $data;
2252 my $meta = "$RANDOMDIR/$md5.meta";
1648 2253
1649 if (my $fh = aio_open "$cf::RANDOM_MAPS/$md5.meta", O_WRONLY | O_CREAT, 0666) { 2254 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) {
1650 aio_write $fh, 0, (length $data), $data, 0; 2255 aio_write $fh, 0, (length $data), $data, 0;
2256 undef $fh;
2257 aio_rename "$meta~", $meta;
1651 2258
1652 $exit->slaying ("?random/$md5"); 2259 $exit->slaying ("?random/$md5");
1653 $exit->msg (undef); 2260 $exit->msg (undef);
1654 } 2261 }
1655} 2262}
1657sub cf::object::player::enter_exit { 2264sub cf::object::player::enter_exit {
1658 my ($self, $exit) = @_; 2265 my ($self, $exit) = @_;
1659 2266
1660 return unless $self->type == cf::PLAYER; 2267 return unless $self->type == cf::PLAYER;
1661 2268
2269 if ($exit->slaying eq "/!") {
2270 #TODO: this should de-fi-ni-te-ly not be a sync-job
2271 # the problem is that $exit might not survive long enough
2272 # so it needs to be done right now, right here
2273 cf::sync_job { prepare_random_map $exit };
2274 }
2275
2276 my $slaying = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path;
2277 my $hp = $exit->stats->hp;
2278 my $sp = $exit->stats->sp;
2279
1662 $self->enter_link; 2280 $self->enter_link;
1663 2281
1664 (cf::async { 2282 (async {
1665 $self->deactivate_recursive; # just to be sure 2283 $self->deactivate_recursive; # just to be sure
1666 unless (eval { 2284 unless (eval {
1667 prepare_random_map $exit 2285 $self->goto ($slaying, $hp, $sp);
1668 if $exit->slaying eq "/!";
1669
1670 my $path = new cf::path $exit->slaying, $exit->map && $exit->map->path;
1671 $self->goto_map ($path, $exit->stats->hp, $exit->stats->sp);
1672 2286
1673 1; 2287 1;
1674 }) { 2288 }) {
1675 $self->message ("Something went wrong deep within the crossfire server. " 2289 $self->message ("Something went wrong deep within the crossfire server. "
1676 . "I'll try to bring you back to the map you were before. " 2290 . "I'll try to bring you back to the map you were before. "
1677 . "Please report this to the dungeon master", 2291 . "Please report this to the dungeon master!",
1678 cf::NDI_UNIQUE | cf::NDI_RED); 2292 cf::NDI_UNIQUE | cf::NDI_RED);
1679 2293
1680 warn "ERROR in enter_exit: $@"; 2294 warn "ERROR in enter_exit: $@";
1681 $self->leave_link; 2295 $self->leave_link;
1682 } 2296 }
1683 })->prio (1); 2297 })->prio (1);
1696 2310
1697sub cf::client::send_drawinfo { 2311sub cf::client::send_drawinfo {
1698 my ($self, $text, $flags) = @_; 2312 my ($self, $text, $flags) = @_;
1699 2313
1700 utf8::encode $text; 2314 utf8::encode $text;
1701 $self->send_packet (sprintf "drawinfo %d %s", $flags, $text); 2315 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);
1702} 2316}
1703 2317
2318=item $client->ext_event ($type, %msg)
2319
2320Sends an exti event to the client.
2321
2322=cut
2323
2324sub cf::client::ext_event($$%) {
2325 my ($self, $type, %msg) = @_;
2326
2327 $msg{msgtype} = "event_$type";
2328 $self->send_packet ("ext " . cf::to_json \%msg);
2329}
1704 2330
1705=item $success = $client->query ($flags, "text", \&cb) 2331=item $success = $client->query ($flags, "text", \&cb)
1706 2332
1707Queues a query to the client, calling the given callback with 2333Queues a query to the client, calling the given callback with
1708the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>, 2334the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>,
1737 # get handled first 2363 # get handled first
1738 my $queue = delete $ns->{query_queue} 2364 my $queue = delete $ns->{query_queue}
1739 or return; # be conservative, not sure how that can happen, but we saw a crash here 2365 or return; # be conservative, not sure how that can happen, but we saw a crash here
1740 2366
1741 (shift @$queue)->[1]->($msg); 2367 (shift @$queue)->[1]->($msg);
2368 return unless $ns->valid; # temporary(?) workaround for callback destroying socket
1742 2369
1743 push @{ $ns->{query_queue} }, @$queue; 2370 push @{ $ns->{query_queue} }, @$queue;
1744 2371
1745 if (@{ $ns->{query_queue} } == @$queue) { 2372 if (@{ $ns->{query_queue} } == @$queue) {
1746 if (@$queue) { 2373 if (@$queue) {
1750 } 2377 }
1751 } 2378 }
1752 }, 2379 },
1753); 2380);
1754 2381
1755=item $client->coro (\&cb) 2382=item $client->async (\&cb)
1756 2383
1757Create a new coroutine, running the specified callback. The coroutine will 2384Create a new coroutine, running the specified callback. The coroutine will
1758be automatically cancelled when the client gets destroyed (e.g. on logout, 2385be automatically cancelled when the client gets destroyed (e.g. on logout,
1759or loss of connection). 2386or loss of connection).
1760 2387
1761=cut 2388=cut
1762 2389
1763sub cf::client::coro { 2390sub cf::client::async {
1764 my ($self, $cb) = @_; 2391 my ($self, $cb) = @_;
1765 2392
1766 my $coro = &cf::async ($cb); 2393 my $coro = &Coro::async ($cb);
1767 2394
1768 $coro->on_destroy (sub { 2395 $coro->on_destroy (sub {
1769 delete $self->{_coro}{$coro+0}; 2396 delete $self->{_coro}{$coro+0};
1770 }); 2397 });
1771 2398
1804 2431
1805# here we export the classes and methods available to script code 2432# here we export the classes and methods available to script code
1806 2433
1807=pod 2434=pod
1808 2435
1809The following fucntions and emthods are available within a safe environment: 2436The following functions and methods are available within a safe environment:
1810 2437
1811 cf::object contr pay_amount pay_player map 2438 cf::object contr pay_amount pay_player map
1812 cf::object::player player 2439 cf::object::player player
1813 cf::player peaceful 2440 cf::player peaceful
1814 cf::map trigger 2441 cf::map trigger
1895=back 2522=back
1896 2523
1897=cut 2524=cut
1898 2525
1899############################################################################# 2526#############################################################################
2527# the server's init and main functions
1900 2528
1901=head2 EXTENSION DATABASE SUPPORT 2529sub load_facedata($) {
2530 my ($path) = @_;
1902 2531
1903Crossfire maintains a very simple database for extension use. It can 2532 warn "loading facedata from $path\n";
1904currently store anything that can be serialised using Storable, which
1905excludes objects.
1906 2533
1907The parameter C<$family> should best start with the name of the extension 2534 my $facedata;
1908using it, it should be unique. 2535 0 < aio_load $path, $facedata
2536 or die "$path: $!";
1909 2537
1910=over 4 2538 $facedata = Coro::Storable::thaw $facedata;
1911 2539
1912=item $hashref = cf::db_get $family 2540 $facedata->{version} == 2
2541 or cf::cleanup "$path: version mismatch, cannot proceed.";
1913 2542
1914Return a hashref for use by the extension C<$family>, which can be
1915modified. After modifications, you have to call C<cf::db_dirty> or
1916C<cf::db_sync>.
1917
1918=item $value = cf::db_get $family => $key
1919
1920Returns a single value from the database
1921
1922=item cf::db_put $family => $hashref
1923
1924Stores the given family hashref into the database. Updates are delayed, if
1925you want the data to be synced to disk immediately, use C<cf::db_sync>.
1926
1927=item cf::db_put $family => $key => $value
1928
1929Stores the given C<$value> in the family hash. Updates are delayed, if you
1930want the data to be synced to disk immediately, use C<cf::db_sync>.
1931
1932=item cf::db_dirty
1933
1934Marks the database as dirty, to be updated at a later time.
1935
1936=item cf::db_sync
1937
1938Immediately write the database to disk I<if it is dirty>.
1939
1940=cut
1941
1942our $DB;
1943
1944{
1945 my $path = cf::localdir . "/database.pst";
1946
1947 sub db_load() {
1948 $DB = stat $path ? Storable::retrieve $path : { };
1949 } 2543 {
2544 my $faces = $facedata->{faceinfo};
1950 2545
1951 my $pid; 2546 while (my ($face, $info) = each %$faces) {
1952 2547 my $idx = (cf::face::find $face) || cf::face::alloc $face;
1953 sub db_save() { 2548 cf::face::set $idx, $info->{visibility}, $info->{magicmap};
1954 waitpid $pid, 0 if $pid; 2549 cf::face::set_data $idx, 0, $info->{data32}, $info->{chksum32};
1955 if (0 == ($pid = fork)) { 2550 cf::face::set_data $idx, 1, $info->{data64}, $info->{chksum64};
1956 $DB->{_meta}{version} = 1; 2551 Coro::cede;
1957 Storable::nstore $DB, "$path~";
1958 rename "$path~", $path;
1959 cf::_exit 0 if defined $pid;
1960 }
1961 }
1962
1963 my $dirty;
1964
1965 sub db_sync() {
1966 db_save if $dirty;
1967 undef $dirty;
1968 }
1969
1970 my $idle = Event->idle (min => $TICK * 2.8, max => 10, repeat => 0, data => WF_AUTOCANCEL, cb => sub {
1971 db_sync;
1972 });
1973
1974 sub db_dirty() {
1975 $dirty = 1;
1976 $idle->start;
1977 }
1978
1979 sub db_get($;$) {
1980 @_ >= 2
1981 ? $DB->{$_[0]}{$_[1]}
1982 : ($DB->{$_[0]} ||= { })
1983 }
1984
1985 sub db_put($$;$) {
1986 if (@_ >= 3) {
1987 $DB->{$_[0]}{$_[1]} = $_[2];
1988 } else {
1989 $DB->{$_[0]} = $_[1];
1990 }
1991 db_dirty;
1992 }
1993
1994 cf::global->attach (
1995 prio => 10000,
1996 on_cleanup => sub {
1997 db_sync;
1998 }, 2552 }
1999 );
2000}
2001 2553
2002############################################################################# 2554 while (my ($face, $info) = each %$faces) {
2003# the server's main() 2555 next unless $info->{smooth};
2556 my $idx = cf::face::find $face
2557 or next;
2558 if (my $smooth = cf::face::find $info->{smooth}) {
2559 cf::face::set_smooth $idx, $smooth, $info->{smoothlevel};
2560 } else {
2561 warn "smooth face '$info->{smooth}' not found for face '$face'";
2562 }
2563 Coro::cede;
2564 }
2565 }
2566
2567 {
2568 my $anims = $facedata->{animinfo};
2569
2570 while (my ($anim, $info) = each %$anims) {
2571 cf::anim::set $anim, $info->{frames}, $info->{facings};
2572 Coro::cede;
2573 }
2574
2575 cf::anim::invalidate_all; # d'oh
2576 }
2577
2578 1
2579}
2580
2581sub reload_regions {
2582 load_resource_file "$MAPDIR/regions"
2583 or die "unable to load regions file\n";
2584}
2585
2586sub reload_facedata {
2587 load_facedata "$DATADIR/facedata"
2588 or die "unable to load facedata\n";
2589}
2590
2591sub reload_archetypes {
2592 load_resource_file "$DATADIR/archetypes"
2593 or die "unable to load archetypes\n";
2594}
2595
2596sub reload_treasures {
2597 load_resource_file "$DATADIR/treasures"
2598 or die "unable to load treasurelists\n";
2599}
2600
2601sub reload_resources {
2602 warn "reloading resource files...\n";
2603
2604 reload_regions;
2605 reload_facedata;
2606 #reload_archetypes;#d#
2607 reload_archetypes;
2608 reload_treasures;
2609
2610 warn "finished reloading resource files\n";
2611}
2612
2613sub init {
2614 reload_resources;
2615}
2004 2616
2005sub cfg_load { 2617sub cfg_load {
2006 open my $fh, "<:utf8", cf::confdir . "/config" 2618 open my $fh, "<:utf8", "$CONFDIR/config"
2007 or return; 2619 or return;
2008 2620
2009 local $/; 2621 local $/;
2010 *CFG = YAML::Syck::Load <$fh>; 2622 *CFG = YAML::Syck::Load <$fh>;
2011 2623
2012 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37]; 2624 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37];
2013 2625
2626 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset};
2627 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset};
2628
2014 if (exists $CFG{mlockall}) { 2629 if (exists $CFG{mlockall}) {
2015 eval { 2630 eval {
2016 $CFG{mlockall} ? &mlockall : &munlockall 2631 $CFG{mlockall} ? eval "mlockall()" : eval "munlockall()"
2017 and die "WARNING: m(un)lockall failed: $!\n"; 2632 and die "WARNING: m(un)lockall failed: $!\n";
2018 }; 2633 };
2019 warn $@ if $@; 2634 warn $@ if $@;
2020 } 2635 }
2021} 2636}
2022 2637
2023sub main { 2638sub main {
2024 # we must not ever block the main coroutine 2639 # we must not ever block the main coroutine
2025 local $Coro::idle = sub { 2640 local $Coro::idle = sub {
2026 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d# 2641 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
2027 (Coro::unblock_sub { 2642 (async {
2028 Event::one_event; 2643 Event::one_event;
2029 })->(); 2644 })->prio (Coro::PRIO_MAX);
2030 }; 2645 };
2031 2646
2032 cfg_load; 2647 cfg_load;
2033 db_load; 2648 db_init;
2034 load_extensions; 2649 load_extensions;
2650
2651 $TICK_WATCHER->start;
2035 Event::loop; 2652 Event::loop;
2036} 2653}
2037 2654
2038############################################################################# 2655#############################################################################
2039# initialisation 2656# initialisation and cleanup
2040 2657
2658# install some emergency cleanup handlers
2659BEGIN {
2660 for my $signal (qw(INT HUP TERM)) {
2661 Event->signal (
2662 reentrant => 0,
2663 data => WF_AUTOCANCEL,
2664 signal => $signal,
2665 prio => 0,
2666 cb => sub {
2667 cf::cleanup "SIG$signal";
2668 },
2669 );
2670 }
2671}
2672
2673sub write_runtime {
2674 my $runtime = "$LOCALDIR/runtime";
2675
2676 # first touch the runtime file to show we are still running:
2677 # the fsync below can take a very very long time.
2678
2679 IO::AIO::aio_utime $runtime, undef, undef;
2680
2681 my $guard = cf::lock_acquire "write_runtime";
2682
2683 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644
2684 or return;
2685
2686 my $value = $cf::RUNTIME + 90 + 10;
2687 # 10 is the runtime save interval, for a monotonic clock
2688 # 60 allows for the watchdog to kill the server.
2689
2690 (aio_write $fh, 0, (length $value), $value, 0) <= 0
2691 and return;
2692
2693 # always fsync - this file is important
2694 aio_fsync $fh
2695 and return;
2696
2697 # touch it again to show we are up-to-date
2698 aio_utime $fh, undef, undef;
2699
2700 close $fh
2701 or return;
2702
2703 aio_rename "$runtime~", $runtime
2704 and return;
2705
2706 warn "runtime file written.\n";
2707
2708 1
2709}
2710
2711sub emergency_save() {
2712 my $freeze_guard = cf::freeze_mainloop;
2713
2714 warn "enter emergency perl save\n";
2715
2716 cf::sync_job {
2717 # use a peculiar iteration method to avoid tripping on perl
2718 # refcount bugs in for. also avoids problems with players
2719 # and maps saved/destroyed asynchronously.
2720 warn "begin emergency player save\n";
2721 for my $login (keys %cf::PLAYER) {
2722 my $pl = $cf::PLAYER{$login} or next;
2723 $pl->valid or next;
2724 $pl->save;
2725 }
2726 warn "end emergency player save\n";
2727
2728 warn "begin emergency map save\n";
2729 for my $path (keys %cf::MAP) {
2730 my $map = $cf::MAP{$path} or next;
2731 $map->valid or next;
2732 $map->save;
2733 }
2734 warn "end emergency map save\n";
2735
2736 warn "begin emergency database checkpoint\n";
2737 BDB::db_env_txn_checkpoint $DB_ENV;
2738 warn "end emergency database checkpoint\n";
2739 };
2740
2741 warn "leave emergency perl save\n";
2742}
2743
2744sub post_cleanup {
2745 my ($make_core) = @_;
2746
2747 warn Carp::longmess "post_cleanup backtrace"
2748 if $make_core;
2749}
2750
2041sub reload() { 2751sub do_reload_perl() {
2042 # can/must only be called in main 2752 # can/must only be called in main
2043 if ($Coro::current != $Coro::main) { 2753 if ($Coro::current != $Coro::main) {
2044 warn "can only reload from main coroutine\n"; 2754 warn "can only reload from main coroutine";
2045 return; 2755 return;
2046 } 2756 }
2047 2757
2048 warn "reloading..."; 2758 warn "reloading...";
2049 2759
2050 my $guard = freeze_mainloop; 2760 warn "entering sync_job";
2761
2762 cf::sync_job {
2763 cf::write_runtime; # external watchdog should not bark
2051 cf::emergency_save; 2764 cf::emergency_save;
2765 cf::write_runtime; # external watchdog should not bark
2052 2766
2053 eval { 2767 warn "syncing database to disk";
2768 BDB::db_env_txn_checkpoint $DB_ENV;
2769
2054 # if anything goes wrong in here, we should simply crash as we already saved 2770 # if anything goes wrong in here, we should simply crash as we already saved
2055 2771
2056 # cancel all watchers 2772 warn "cancelling all WF_AUTOCANCEL watchers";
2057 for (Event::all_watchers) { 2773 for (Event::all_watchers) {
2058 $_->cancel if $_->data & WF_AUTOCANCEL; 2774 $_->cancel if $_->data & WF_AUTOCANCEL;
2059 } 2775 }
2060 2776
2777 warn "flushing outstanding aio requests";
2778 for (;;) {
2779 BDB::flush;
2780 IO::AIO::flush;
2781 Coro::cede;
2782 last unless IO::AIO::nreqs || BDB::nreqs;
2783 warn "iterate...";
2784 }
2785
2786 ++$RELOAD;
2787
2061 # cancel all extension coros 2788 warn "cancelling all extension coros";
2062 $_->cancel for values %EXT_CORO; 2789 $_->cancel for values %EXT_CORO;
2063 %EXT_CORO = (); 2790 %EXT_CORO = ();
2064 2791
2065 # unload all extensions 2792 warn "removing commands";
2066 for (@exts) { 2793 %COMMAND = ();
2794
2795 warn "removing ext commands";
2796 %EXTCMD = ();
2797
2798 warn "unloading/nuking all extensions";
2799 for my $pkg (@EXTS) {
2067 warn "unloading <$_>"; 2800 warn "... unloading $pkg";
2068 unload_extension $_; 2801
2802 if (my $cb = $pkg->can ("unload")) {
2803 eval {
2804 $cb->($pkg);
2805 1
2806 } or warn "$pkg unloaded, but with errors: $@";
2069 } 2807 }
2070 2808
2809 warn "... nuking $pkg";
2810 Symbol::delete_package $pkg;
2811 }
2812
2071 # unload all modules loaded from $LIBDIR 2813 warn "unloading all perl modules loaded from $LIBDIR";
2072 while (my ($k, $v) = each %INC) { 2814 while (my ($k, $v) = each %INC) {
2073 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/; 2815 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
2074 2816
2075 warn "removing <$k>"; 2817 warn "... unloading $k";
2076 delete $INC{$k}; 2818 delete $INC{$k};
2077 2819
2078 $k =~ s/\.pm$//; 2820 $k =~ s/\.pm$//;
2079 $k =~ s/\//::/g; 2821 $k =~ s/\//::/g;
2080 2822
2083 } 2825 }
2084 2826
2085 Symbol::delete_package $k; 2827 Symbol::delete_package $k;
2086 } 2828 }
2087 2829
2088 # sync database to disk
2089 cf::db_sync;
2090 IO::AIO::flush;
2091
2092 # get rid of safe::, as good as possible 2830 warn "getting rid of safe::, as good as possible";
2093 Symbol::delete_package "safe::$_" 2831 Symbol::delete_package "safe::$_"
2094 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region); 2832 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
2095 2833
2096 # remove register_script_function callbacks
2097 # TODO
2098
2099 # unload cf.pm "a bit" 2834 warn "unloading cf.pm \"a bit\"";
2100 delete $INC{"cf.pm"}; 2835 delete $INC{"cf.pm"};
2836 delete $INC{"cf/pod.pm"};
2101 2837
2102 # don't, removes xs symbols, too, 2838 # don't, removes xs symbols, too,
2103 # and global variables created in xs 2839 # and global variables created in xs
2104 #Symbol::delete_package __PACKAGE__; 2840 #Symbol::delete_package __PACKAGE__;
2105 2841
2106 # reload cf.pm 2842 warn "unload completed, starting to reload now";
2843
2107 warn "reloading cf.pm"; 2844 warn "reloading cf.pm";
2108 require cf; 2845 require cf;
2109 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 2846 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
2110 2847
2111 # load config and database again 2848 warn "loading config and database again";
2112 cf::cfg_load; 2849 cf::cfg_load;
2113 cf::db_load;
2114 2850
2115 # load extensions
2116 warn "load extensions"; 2851 warn "loading extensions";
2117 cf::load_extensions; 2852 cf::load_extensions;
2118 2853
2119 # reattach attachments to objects 2854 warn "reattaching attachments to objects/players";
2120 warn "reattach"; 2855 _global_reattach; # objects, sockets
2121 _global_reattach; 2856 warn "reattaching attachments to maps";
2122 }; 2857 reattach $_ for values %MAP;
2858 warn "reattaching attachments to players";
2859 reattach $_ for values %PLAYER;
2123 2860
2124 if ($@) { 2861 warn "leaving sync_job";
2862
2863 1
2864 } or do {
2125 warn $@; 2865 warn $@;
2126 warn "error while reloading, exiting."; 2866 warn "error while reloading, exiting.";
2127 exit 1; 2867 exit 1;
2128 } 2868 };
2129 2869
2130 warn "reloaded successfully"; 2870 warn "reloaded";
2131}; 2871};
2132 2872
2133############################################################################# 2873our $RELOAD_WATCHER; # used only during reload
2134 2874
2135unless ($LINK_MAP) { 2875sub reload_perl() {
2136 $LINK_MAP = cf::map::new; 2876 # doing reload synchronously and two reloads happen back-to-back,
2877 # coro crashes during coro_state_free->destroy here.
2137 2878
2138 $LINK_MAP->width (41); 2879 $RELOAD_WATCHER ||= Event->timer (
2139 $LINK_MAP->height (41); 2880 reentrant => 0,
2140 $LINK_MAP->alloc;
2141 $LINK_MAP->path ("{link}");
2142 $LINK_MAP->{path} = bless { path => "{link}" }, "cf::path";
2143 $LINK_MAP->in_memory (MAP_IN_MEMORY);
2144
2145 # dirty hack because... archetypes are not yet loaded
2146 Event->timer (
2147 after => 2, 2881 after => 0,
2882 data => WF_AUTOCANCEL,
2148 cb => sub { 2883 cb => sub {
2149 $_[0]->w->cancel; 2884 do_reload_perl;
2150 2885 undef $RELOAD_WATCHER;
2151 # provide some exits "home"
2152 my $exit = cf::object::new "exit";
2153
2154 $exit->slaying ($EMERGENCY_POSITION->[0]);
2155 $exit->stats->hp ($EMERGENCY_POSITION->[1]);
2156 $exit->stats->sp ($EMERGENCY_POSITION->[2]);
2157
2158 $LINK_MAP->insert ($exit->clone, 19, 19);
2159 $LINK_MAP->insert ($exit->clone, 19, 20);
2160 $LINK_MAP->insert ($exit->clone, 19, 21);
2161 $LINK_MAP->insert ($exit->clone, 20, 19);
2162 $LINK_MAP->insert ($exit->clone, 20, 21);
2163 $LINK_MAP->insert ($exit->clone, 21, 19);
2164 $LINK_MAP->insert ($exit->clone, 21, 20);
2165 $LINK_MAP->insert ($exit->clone, 21, 21);
2166
2167 $exit->destroy;
2168 }); 2886 },
2169 2887 );
2170 $LINK_MAP->{deny_save} = 1;
2171 $LINK_MAP->{deny_reset} = 1;
2172
2173 $cf::MAP{$LINK_MAP->path} = $LINK_MAP;
2174} 2888}
2175
2176register "<global>", __PACKAGE__;
2177 2889
2178register_command "reload" => sub { 2890register_command "reload" => sub {
2179 my ($who, $arg) = @_; 2891 my ($who, $arg) = @_;
2180 2892
2181 if ($who->flag (FLAG_WIZ)) { 2893 if ($who->flag (FLAG_WIZ)) {
2182 $who->message ("start of reload.");
2183 reload;
2184 $who->message ("end of reload."); 2894 $who->message ("reloading server.");
2895 async { reload_perl };
2185 } 2896 }
2186}; 2897};
2187 2898
2188unshift @INC, $LIBDIR; 2899unshift @INC, $LIBDIR;
2189 2900
2901my $bug_warning = 0;
2902
2903our @WAIT_FOR_TICK;
2904our @WAIT_FOR_TICK_BEGIN;
2905
2906sub wait_for_tick {
2907 return unless $TICK_WATCHER->is_active;
2908 return if $Coro::current == $Coro::main;
2909
2910 my $signal = new Coro::Signal;
2911 push @WAIT_FOR_TICK, $signal;
2912 $signal->wait;
2913}
2914
2915sub wait_for_tick_begin {
2916 return unless $TICK_WATCHER->is_active;
2917 return if $Coro::current == $Coro::main;
2918
2919 my $signal = new Coro::Signal;
2920 push @WAIT_FOR_TICK_BEGIN, $signal;
2921 $signal->wait;
2922}
2923
2924 my $min = 1e6;#d#
2925 my $avg = 10;
2190$TICK_WATCHER = Event->timer ( 2926$TICK_WATCHER = Event->timer (
2191 reentrant => 0, 2927 reentrant => 0,
2928 parked => 1,
2192 prio => 0, 2929 prio => 0,
2193 at => $NEXT_TICK || $TICK, 2930 at => $NEXT_TICK || $TICK,
2194 data => WF_AUTOCANCEL, 2931 data => WF_AUTOCANCEL,
2195 cb => sub { 2932 cb => sub {
2933 if ($Coro::current != $Coro::main) {
2934 Carp::cluck "major BUG: server tick called outside of main coro, skipping it"
2935 unless ++$bug_warning > 10;
2936 return;
2937 }
2938
2939 $NOW = $tick_start = Event::time;
2940
2196 cf::server_tick; # one server iteration 2941 cf::server_tick; # one server iteration
2942
2943 0 && sync_job {#d#
2944 for(1..10) {
2945 my $t = Event::time;
2946 my $map = my $map = new_from_path cf::map "/tmp/x.map"
2947 or die;
2948
2949 $map->width (50);
2950 $map->height (50);
2951 $map->alloc;
2952 $map->_load_objects ("/tmp/x.map", 1);
2953 my $t = Event::time - $t;
2954
2955 #next unless $t < 0.0013;#d#
2956 if ($t < $min) {
2957 $min = $t;
2958 }
2959 $avg = $avg * 0.99 + $t * 0.01;
2960 }
2961 warn "XXXXXXXXXXXXXXXXXX min $min avg $avg\n";#d#
2962 exit 0;
2963 # 2007-05-22 02:33:04.569 min 0.00112509727478027 avg 0.0012259249572477
2964 };
2965
2197 $RUNTIME += $TICK; 2966 $RUNTIME += $TICK;
2198 $NEXT_TICK += $TICK; 2967 $NEXT_TICK += $TICK;
2199 2968
2969 if ($NOW >= $NEXT_RUNTIME_WRITE) {
2970 $NEXT_RUNTIME_WRITE = $NOW + 10;
2971 Coro::async_pool {
2972 write_runtime
2973 or warn "ERROR: unable to write runtime file: $!";
2974 };
2975 }
2976
2977# my $AFTER = Event::time;
2978# warn $AFTER - $NOW;#d#
2979
2980 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
2981 $sig->send;
2982 }
2983 while (my $sig = shift @WAIT_FOR_TICK) {
2984 $sig->send;
2985 }
2986
2987 $NOW = Event::time;
2988
2200 # if we are delayed by four ticks or more, skip them all 2989 # if we are delayed by four ticks or more, skip them all
2201 $NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4; 2990 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
2202 2991
2203 $TICK_WATCHER->at ($NEXT_TICK); 2992 $TICK_WATCHER->at ($NEXT_TICK);
2204 $TICK_WATCHER->start; 2993 $TICK_WATCHER->start;
2994
2995 $LOAD = ($NOW - $tick_start) / $TICK;
2996 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
2997
2998 _post_tick;
2999
3000
2205 }, 3001 },
2206); 3002);
2207 3003
3004{
2208IO::AIO::max_poll_time $TICK * 0.2; 3005 BDB::max_poll_time $TICK * 0.1;
2209 3006 $BDB_POLL_WATCHER = Event->io (
2210Event->io ( 3007 reentrant => 0,
2211 fd => IO::AIO::poll_fileno, 3008 fd => BDB::poll_fileno,
2212 poll => 'r', 3009 poll => 'r',
2213 prio => 5, 3010 prio => 0,
2214 data => WF_AUTOCANCEL,
2215 cb => \&IO::AIO::poll_cb,
2216);
2217
2218Event->timer (
2219 data => WF_AUTOCANCEL, 3011 data => WF_AUTOCANCEL,
2220 after => 0, 3012 cb => \&BDB::poll_cb,
2221 interval => 10, 3013 );
2222 cb => sub { 3014 BDB::min_parallel 8;
2223 (Coro::unblock_sub { 3015
2224 write_runtime 3016 BDB::set_sync_prepare {
2225 or warn "ERROR: unable to write runtime file: $!"; 3017 my $status;
3018 my $current = $Coro::current;
3019 (
3020 sub {
3021 $status = $!;
3022 $current->ready; undef $current;
3023 },
3024 sub {
3025 Coro::schedule while defined $current;
3026 $! = $status;
3027 },
3028 )
3029 };
3030
3031 unless ($DB_ENV) {
3032 $DB_ENV = BDB::db_env_create;
3033
3034 cf::sync_job {
3035 eval {
3036 BDB::db_env_open
3037 $DB_ENV,
3038 $BDBDIR,
3039 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN
3040 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE,
3041 0666;
3042
3043 cf::cleanup "db_env_open($BDBDIR): $!" if $!;
3044
3045 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC, 1);
3046 $DB_ENV->set_lk_detect;
3047 };
3048
3049 cf::cleanup "db_env_open(db): $@" if $@;
2226 })->(); 3050 };
2227 }, 3051 }
2228); 3052}
3053
3054{
3055 IO::AIO::min_parallel 8;
3056
3057 undef $Coro::AIO::WATCHER;
3058 IO::AIO::max_poll_time $TICK * 0.1;
3059 $AIO_POLL_WATCHER = Event->io (
3060 reentrant => 0,
3061 data => WF_AUTOCANCEL,
3062 fd => IO::AIO::poll_fileno,
3063 poll => 'r',
3064 prio => 6,
3065 cb => \&IO::AIO::poll_cb,
3066 );
3067}
3068
3069my $_log_backtrace;
3070
3071sub _log_backtrace {
3072 my ($msg, @addr) = @_;
3073
3074 $msg =~ s/\n//;
3075
3076 # limit the # of concurrent backtraces
3077 if ($_log_backtrace < 2) {
3078 ++$_log_backtrace;
3079 async {
3080 my @bt = fork_call {
3081 @addr = map { sprintf "%x", $_ } @addr;
3082 my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X;
3083 open my $fh, "exec addr2line -C -f -i -e \Q$self\E @addr 2>&1 |"
3084 or die "addr2line: $!";
3085
3086 my @funcs;
3087 my @res = <$fh>;
3088 chomp for @res;
3089 while (@res) {
3090 my ($func, $line) = splice @res, 0, 2, ();
3091 push @funcs, "[$func] $line";
3092 }
3093
3094 @funcs
3095 };
3096
3097 LOG llevInfo, "[ABT] $msg\n";
3098 LOG llevInfo, "[ABT] $_\n" for @bt;
3099 --$_log_backtrace;
3100 };
3101 } else {
3102 LOG llevInfo, "[ABT] $msg\n";
3103 LOG llevInfo, "[ABT] [suppressed]\n";
3104 }
3105}
3106
3107# load additional modules
3108use cf::pod;
2229 3109
2230END { cf::emergency_save } 3110END { cf::emergency_save }
2231 3111
22321 31121
2233 3113

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines