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

Diff Legend

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