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.162 by root, Thu Jan 11 00:41:08 2007 UTC vs.
Revision 1.254 by root, Thu Apr 19 11:12: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
46
47sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
35 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 = ();
41our %EXT_CORO = (); # coroutines bound to extensions 54our %EXT_CORO = (); # coroutines bound to extensions
42our %EXT_MAP = (); # pluggable maps 55our %EXT_MAP = (); # pluggable maps
43 56
57our $RELOAD; # number of reloads so far
44our @EVENT; 58our @EVENT;
45our $LIBDIR = datadir . "/ext";
46 59
47our $TICK = MAX_TIME * 1e-6; 60our $CONFDIR = confdir;
61our $DATADIR = datadir;
62our $LIBDIR = "$DATADIR/ext";
63our $PODDIR = "$DATADIR/pod";
64our $MAPDIR = "$DATADIR/" . mapdir;
65our $LOCALDIR = localdir;
66our $TMPDIR = "$LOCALDIR/" . tmpdir;
67our $UNIQUEDIR = "$LOCALDIR/" . uniquedir;
68our $PLAYERDIR = "$LOCALDIR/" . playerdir;
69our $RANDOMDIR = "$LOCALDIR/random";
70our $BDBDIR = "$LOCALDIR/db";
71
72our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!)
48our $TICK_WATCHER; 73our $TICK_WATCHER;
74our $AIO_POLL_WATCHER;
75our $NEXT_RUNTIME_WRITE; # when should the runtime file be written
49our $NEXT_TICK; 76our $NEXT_TICK;
50our $NOW; 77our $NOW;
78our $USE_FSYNC = 1; # use fsync to write maps - default off
79
80our $BDB_POLL_WATCHER;
81our $DB_ENV;
51 82
52our %CFG; 83our %CFG;
53 84
54our $UPTIME; $UPTIME ||= time; 85our $UPTIME; $UPTIME ||= time;
55our $RUNTIME; 86our $RUNTIME;
56 87
57our %PLAYER; # all users 88our %PLAYER; # all users
58our %MAP; # all maps 89our %MAP; # all maps
59our $LINK_MAP; # the special {link} map 90our $LINK_MAP; # the special {link} map, which is always available
60our $RANDOM_MAPS = cf::localdir . "/random";
61 91
62our $WAIT_FOR_TICK; $WAIT_FOR_TICK ||= new Coro::Signal; 92# used to convert map paths into valid unix filenames by replacing / by ∕
63our $WAIT_FOR_TICK_ONE; $WAIT_FOR_TICK_ONE ||= new Coro::Signal; 93our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons
64 94
65binmode STDOUT; 95binmode STDOUT;
66binmode STDERR; 96binmode STDERR;
67 97
68# read virtual server time, if available 98# read virtual server time, if available
69unless ($RUNTIME || !-e cf::localdir . "/runtime") { 99unless ($RUNTIME || !-e "$LOCALDIR/runtime") {
70 open my $fh, "<", cf::localdir . "/runtime" 100 open my $fh, "<", "$LOCALDIR/runtime"
71 or die "unable to read runtime file: $!"; 101 or die "unable to read runtime file: $!";
72 $RUNTIME = <$fh> + 0.; 102 $RUNTIME = <$fh> + 0.;
73} 103}
74 104
75mkdir cf::localdir; 105mkdir $_
76mkdir cf::localdir . "/" . cf::playerdir; 106 for $LOCALDIR, $TMPDIR, $UNIQUEDIR, $PLAYERDIR, $RANDOMDIR, $BDBDIR;
77mkdir cf::localdir . "/" . cf::tmpdir;
78mkdir cf::localdir . "/" . cf::uniquedir;
79mkdir $RANDOM_MAPS;
80 107
81# a special map that is always available
82our $LINK_MAP;
83our $EMERGENCY_POSITION; 108our $EMERGENCY_POSITION;
109
110sub cf::map::normalise;
84 111
85############################################################################# 112#############################################################################
86 113
87=head2 GLOBAL VARIABLES 114=head2 GLOBAL VARIABLES
88 115
95=item $cf::RUNTIME 122=item $cf::RUNTIME
96 123
97The time this server has run, starts at 0 and is increased by $cf::TICK on 124The time this server has run, starts at 0 and is increased by $cf::TICK on
98every server tick. 125every server tick.
99 126
100=item $cf::LIBDIR 127=item $cf::CONFDIR $cf::DATADIR $cf::LIBDIR $cf::PODDIR
128$cf::MAPDIR $cf::LOCALDIR $cf::TMPDIR $cf::UNIQUEDIR
129$cf::PLAYERDIR $cf::RANDOMDIR $cf::BDBDIR
101 130
102The perl library directory, where extensions and cf-specific modules can 131Various directories - "/etc", read-only install directory, perl-library
103be found. It will be added to C<@INC> automatically. 132directory, pod-directory, read-only maps directory, "/var", "/var/tmp",
133unique-items directory, player file directory, random maps directory and
134database environment.
104 135
105=item $cf::NOW 136=item $cf::NOW
106 137
107The time of the last (current) server tick. 138The time of the last (current) server tick.
108 139
113=item %cf::CFG 144=item %cf::CFG
114 145
115Configuration for the server, loaded from C</etc/crossfire/config>, or 146Configuration for the server, loaded from C</etc/crossfire/config>, or
116from wherever your confdir points to. 147from wherever your confdir points to.
117 148
118=item $cf::WAIT_FOR_TICK, $cf::WAIT_FOR_TICK_ONE 149=item cf::wait_for_tick, cf::wait_for_tick_begin
119 150
120These are Coro::Signal objects that are C<< ->broadcast >> (WAIT_FOR_TICK) 151These 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 152returns 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 153per 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 154
125=back 155=back
126 156
127=cut 157=cut
128 158
129BEGIN { 159BEGIN {
130 *CORE::GLOBAL::warn = sub { 160 *CORE::GLOBAL::warn = sub {
131 my $msg = join "", @_; 161 my $msg = join "", @_;
132 utf8::encode $msg;
133 162
134 $msg .= "\n" 163 $msg .= "\n"
135 unless $msg =~ /\n$/; 164 unless $msg =~ /\n$/;
136 165
166 $msg =~ s/([\x00-\x09\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;
167
168 utf8::encode $msg;
137 LOG llevError, $msg; 169 LOG llevError, $msg;
138 }; 170 };
139} 171}
140 172
141@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable'; 173@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
187 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge; 219 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge;
188 $d 220 $d
189 } || "[unable to dump $_[0]: '$@']"; 221 } || "[unable to dump $_[0]: '$@']";
190} 222}
191 223
192use JSON::Syck (); # TODO# replace by JSON::PC once working 224use JSON::XS qw(to_json from_json); # TODO# replace by JSON::PC once working
193 225
194=item $ref = cf::from_json $json 226=item $ref = cf::from_json $json
195 227
196Converts a JSON string into the corresponding perl data structure. 228Converts a JSON string into the corresponding perl data structure.
197 229
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 230=item $json = cf::to_json $ref
206 231
207Converts a perl data structure into its JSON representation. 232Converts a perl data structure into its JSON representation.
208
209=cut
210
211sub to_json($) {
212 $JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs
213 JSON::Syck::Dump $_[0]
214}
215 233
216=item cf::lock_wait $string 234=item cf::lock_wait $string
217 235
218Wait until the given lock is available. See cf::lock_acquire. 236Wait until the given lock is available. See cf::lock_acquire.
219 237
225returned. 243returned.
226 244
227Lock names should begin with a unique identifier (for example, cf::map::find 245Lock names should begin with a unique identifier (for example, cf::map::find
228uses map_find and cf::map::load uses map_load). 246uses map_find and cf::map::load uses map_load).
229 247
248=item $locked = cf::lock_active $string
249
250Return true if the lock is currently active, i.e. somebody has locked it.
251
230=cut 252=cut
231 253
232our %LOCK; 254our %LOCK;
233 255
234sub lock_wait($) { 256sub lock_wait($) {
253 # wake up all waiters, to be on the safe side 275 # wake up all waiters, to be on the safe side
254 $_->ready for @{ delete $LOCK{$key} }; 276 $_->ready for @{ delete $LOCK{$key} };
255 } 277 }
256} 278}
257 279
280sub lock_active($) {
281 my ($key) = @_;
282
283 ! ! $LOCK{$key}
284}
285
258sub freeze_mainloop { 286sub freeze_mainloop {
259 return unless $TICK_WATCHER->is_active; 287 return unless $TICK_WATCHER->is_active;
260 288
261 my $guard = Coro::guard { $TICK_WATCHER->start }; 289 my $guard = Coro::guard {
290 $TICK_WATCHER->start;
291 };
262 $TICK_WATCHER->stop; 292 $TICK_WATCHER->stop;
263 $guard 293 $guard
264} 294}
265 295
266=item cf::async { BLOCK } 296=item cf::async { BLOCK }
337 367
338 $coro 368 $coro
339} 369}
340 370
341sub write_runtime { 371sub write_runtime {
342 my $runtime = cf::localdir . "/runtime"; 372 my $guard = cf::lock_acquire "write_runtime";
373
374 my $runtime = "$LOCALDIR/runtime";
343 375
344 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644 376 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644
345 or return; 377 or return;
346 378
379 my $value = $cf::RUNTIME + 90 + 10;
347 my $value = $cf::RUNTIME + 1 + 10; # 10 is the runtime save interval, for a monotonic clock 380 # 10 is the runtime save interval, for a monotonic clock
381 # 60 allows for the watchdog to kill the server.
382
348 (aio_write $fh, 0, (length $value), $value, 0) <= 0 383 (aio_write $fh, 0, (length $value), $value, 0) <= 0
349 and return; 384 and return;
350 385
386 # always fsync - this file is important
351 aio_fsync $fh 387 aio_fsync $fh
352 and return; 388 and return;
353 389
354 close $fh 390 close $fh
355 or return; 391 or return;
358 and return; 394 and return;
359 395
360 1 396 1
361} 397}
362 398
399=item cf::datalog type => key => value, ...
400
401Log a datalog packet of the given type with the given key-value pairs.
402
403=cut
404
405sub datalog($@) {
406 my ($type, %kv) = @_;
407 warn "DATALOG ", JSON::XS->new->ascii->encode ({ %kv, type => $type });
408}
409
363=back 410=back
364 411
365=cut 412=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 sprintf "%s/%s/%s", cf::localdir, cf::uniquedir, $self->_escaped_path
502}
503
504# this is somewhat ugly, but style maps do need special treatment
505sub is_style_map {
506 $_[0]{path} =~ m{^/styles/}
507}
508
509sub load_orig {
510 my ($self) = @_;
511
512 &cf::map::load_map_header ($self->load_path)
513}
514
515sub load_temp {
516 my ($self) = @_;
517
518 &cf::map::load_map_header ($self->save_path)
519}
520
521package cf;
522 413
523############################################################################# 414#############################################################################
524 415
525=head2 ATTACHABLE OBJECTS 416=head2 ATTACHABLE OBJECTS
526 417
652our @CB_TYPE = (); # registry for type (cf-object class) based events 543our @CB_TYPE = (); # registry for type (cf-object class) based events
653our @CB_MAP = (); 544our @CB_MAP = ();
654 545
655my %attachment; 546my %attachment;
656 547
548sub cf::attachable::thawer_merge {
549 # simply override everything except _meta
550 local $_[0]{_meta};
551 %{$_[0]} = %{$_[1]};
552}
553
657sub _attach_cb($$$$) { 554sub _attach_cb($$$$) {
658 my ($registry, $event, $prio, $cb) = @_; 555 my ($registry, $event, $prio, $cb) = @_;
659 556
660 use sort 'stable'; 557 use sort 'stable';
661 558
832# object support 729# object support
833 730
834sub reattach { 731sub reattach {
835 # basically do the same as instantiate, without calling instantiate 732 # basically do the same as instantiate, without calling instantiate
836 my ($obj) = @_; 733 my ($obj) = @_;
734
735 bless $obj, ref $obj; # re-bless in case extensions have been reloaded
837 736
838 my $registry = $obj->registry; 737 my $registry = $obj->registry;
839 738
840 @$registry = (); 739 @$registry = ();
841 740
888 $filename, length $$rdata, scalar @$objs; 787 $filename, length $$rdata, scalar @$objs;
889 788
890 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) { 789 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
891 chmod SAVE_MODE, $fh; 790 chmod SAVE_MODE, $fh;
892 aio_write $fh, 0, (length $$rdata), $$rdata, 0; 791 aio_write $fh, 0, (length $$rdata), $$rdata, 0;
893 aio_fsync $fh; 792 aio_fsync $fh if $cf::USE_FSYNC;
894 close $fh; 793 close $fh;
895 794
896 if (@$objs) { 795 if (@$objs) {
897 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) { 796 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) {
898 chmod SAVE_MODE, $fh; 797 chmod SAVE_MODE, $fh;
899 my $data = Storable::nfreeze { version => 1, objs => $objs }; 798 my $data = Storable::nfreeze { version => 1, objs => $objs };
900 aio_write $fh, 0, (length $data), $data, 0; 799 aio_write $fh, 0, (length $data), $data, 0;
901 aio_fsync $fh; 800 aio_fsync $fh if $cf::USE_FSYNC;
902 close $fh; 801 close $fh;
903 aio_rename "$filename.pst~", "$filename.pst"; 802 aio_rename "$filename.pst~", "$filename.pst";
904 } 803 }
905 } else { 804 } else {
906 aio_unlink "$filename.pst"; 805 aio_unlink "$filename.pst";
1028 "package $pkg; use strict; use utf8;\n" 927 "package $pkg; use strict; use utf8;\n"
1029 . "#line 1 \"$path\"\n{\n" 928 . "#line 1 \"$path\"\n{\n"
1030 . (do { local $/; <$fh> }) 929 . (do { local $/; <$fh> })
1031 . "\n};\n1"; 930 . "\n};\n1";
1032 931
1033 eval $source 932 unless (eval $source) {
1034 or die $@ ? "$path: $@\n" 933 my $msg = $@ ? "$path: $@\n"
1035 : "extension disabled.\n"; 934 : "extension disabled.\n";
935 if ($source =~ /^#!.*perl.*#.*MANDATORY/m) { # ugly match
936 warn $@;
937 warn "mandatory extension failed to load, exiting.\n";
938 exit 1;
939 }
940 die $@;
941 }
1036 942
1037 push @EXTS, $pkg; 943 push @EXTS, $pkg;
1038} 944}
1039 945
1040sub load_extensions { 946sub load_extensions {
1046 } or warn "$ext not loaded: $@"; 952 } or warn "$ext not loaded: $@";
1047 } 953 }
1048} 954}
1049 955
1050############################################################################# 956#############################################################################
1051# load/save/clean perl data associated with a map
1052
1053*cf::mapsupport::on_clean = sub {
1054 my ($map) = @_;
1055
1056 my $path = $map->tmpname;
1057 defined $path or return;
1058
1059 unlink "$path.pst";
1060};
1061
1062cf::map->attach (prio => -10000, package => cf::mapsupport::);
1063
1064#############################################################################
1065 957
1066=head2 CORE EXTENSIONS 958=head2 CORE EXTENSIONS
1067 959
1068Functions and methods that extend core crossfire objects. 960Functions and methods that extend core crossfire objects.
1069 961
1082Returns the given player object, loading it if necessary (might block). 974Returns the given player object, loading it if necessary (might block).
1083 975
1084=cut 976=cut
1085 977
1086sub playerdir($) { 978sub playerdir($) {
1087 cf::localdir 979 "$PLAYERDIR/"
1088 . "/"
1089 . cf::playerdir
1090 . "/"
1091 . (ref $_[0] ? $_[0]->ob->name : $_[0]) 980 . (ref $_[0] ? $_[0]->ob->name : $_[0])
1092} 981}
1093 982
1094sub path($) { 983sub path($) {
1095 my $login = ref $_[0] ? $_[0]->ob->name : $_[0]; 984 my $login = ref $_[0] ? $_[0]->ob->name : $_[0];
1096 985
1097 (playerdir $login) . "/$login.pl" 986 (playerdir $login) . "/playerdata"
1098} 987}
1099 988
1100sub find_active($) { 989sub find_active($) {
1101 $cf::PLAYER{$_[0]} 990 $cf::PLAYER{$_[0]}
1102 and $cf::PLAYER{$_[0]}->active 991 and $cf::PLAYER{$_[0]}->active
1105 994
1106sub exists($) { 995sub exists($) {
1107 my ($login) = @_; 996 my ($login) = @_;
1108 997
1109 $cf::PLAYER{$login} 998 $cf::PLAYER{$login}
1110 or cf::sync_job { !aio_stat $login } 999 or cf::sync_job { !aio_stat path $login }
1111} 1000}
1112 1001
1113sub find($) { 1002sub find($) {
1114 return $cf::PLAYER{$_[0]} || do { 1003 return $cf::PLAYER{$_[0]} || do {
1115 my $login = $_[0]; 1004 my $login = $_[0];
1116 1005
1117 my $guard = cf::lock_acquire "user_find:$login"; 1006 my $guard = cf::lock_acquire "user_find:$login";
1118 1007
1119 $cf::PLAYER{$_[0]} || do { 1008 $cf::PLAYER{$_[0]} || do {
1009 # rename old playerfiles to new ones
1010 #TODO: remove when no longer required
1011 aio_link +(playerdir $login) . "/$login.pl.pst", (playerdir $login) . "/playerdata.pst";
1012 aio_link +(playerdir $login) . "/$login.pl" , (playerdir $login) . "/playerdata";
1013 aio_unlink +(playerdir $login) . "/$login.pl.pst";
1014 aio_unlink +(playerdir $login) . "/$login.pl";
1015
1120 my $pl = load_pl path $login 1016 my $pl = load_pl path $login
1121 or return; 1017 or return;
1122 $cf::PLAYER{$login} = $pl 1018 $cf::PLAYER{$login} = $pl
1123 } 1019 }
1124 } 1020 }
1161 1057
1162=cut 1058=cut
1163 1059
1164sub quit_character { 1060sub quit_character {
1165 my ($pl) = @_; 1061 my ($pl) = @_;
1062
1063 my $name = $pl->ob->name;
1166 1064
1167 $pl->{deny_save} = 1; 1065 $pl->{deny_save} = 1;
1168 $pl->password ("*"); # this should lock out the player until we nuked the dir 1066 $pl->password ("*"); # this should lock out the player until we nuked the dir
1169 1067
1170 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active; 1068 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active;
1175 my $path = playerdir $pl; 1073 my $path = playerdir $pl;
1176 my $temp = "$path~$cf::RUNTIME~deleting~"; 1074 my $temp = "$path~$cf::RUNTIME~deleting~";
1177 aio_rename $path, $temp; 1075 aio_rename $path, $temp;
1178 delete $cf::PLAYER{$pl->ob->name}; 1076 delete $cf::PLAYER{$pl->ob->name};
1179 $pl->destroy; 1077 $pl->destroy;
1078
1079 my $prefix = qr<^~\Q$name\E/>;
1080
1081 # nuke player maps
1082 $cf::MAP{$_}->nuke for grep /$prefix/, keys %cf::MAP;
1083
1180 IO::AIO::aio_rmtree $temp; 1084 IO::AIO::aio_rmtree $temp;
1085}
1086
1087=item $pl->kick
1088
1089Kicks a player out of the game. This destroys the connection.
1090
1091=cut
1092
1093sub kick {
1094 my ($pl, $kicker) = @_;
1095
1096 $pl->invoke (cf::EVENT_PLAYER_KICK, $kicker);
1097 $pl->killer ("kicked");
1098 $pl->ns->destroy;
1181} 1099}
1182 1100
1183=item cf::player::list_logins 1101=item cf::player::list_logins
1184 1102
1185Returns am arrayref of all valid playernames in the system, can take a 1103Returns am arrayref of all valid playernames in the system, can take a
1186while and may block, so not sync_job-capable, ever. 1104while and may block, so not sync_job-capable, ever.
1187 1105
1188=cut 1106=cut
1189 1107
1190sub list_logins { 1108sub list_logins {
1191 my $dirs = aio_readdir cf::localdir . "/" . cf::playerdir 1109 my $dirs = aio_readdir $PLAYERDIR
1192 or return []; 1110 or return [];
1193 1111
1194 my @logins; 1112 my @logins;
1195 1113
1196 for my $login (@$dirs) { 1114 for my $login (@$dirs) {
1205 \@logins 1123 \@logins
1206} 1124}
1207 1125
1208=item $player->maps 1126=item $player->maps
1209 1127
1210Returns an arrayref of cf::path's of all maps that are private for this 1128Returns an arrayref of map paths that are private for this
1211player. May block. 1129player. May block.
1212 1130
1213=cut 1131=cut
1214 1132
1215sub maps($) { 1133sub maps($) {
1216 my ($pl) = @_; 1134 my ($pl) = @_;
1135
1136 $pl = ref $pl ? $pl->ob->name : $pl;
1217 1137
1218 my $files = aio_readdir playerdir $pl 1138 my $files = aio_readdir playerdir $pl
1219 or return; 1139 or return;
1220 1140
1221 my @paths; 1141 my @paths;
1223 for (@$files) { 1143 for (@$files) {
1224 utf8::decode $_; 1144 utf8::decode $_;
1225 next if /\.(?:pl|pst)$/; 1145 next if /\.(?:pl|pst)$/;
1226 next unless /^$PATH_SEP/o; 1146 next unless /^$PATH_SEP/o;
1227 1147
1228 push @paths, new cf::path "~" . $pl->ob->name . "/" . $_; 1148 push @paths, cf::map::normalise "~$pl/$_";
1229 } 1149 }
1230 1150
1231 \@paths 1151 \@paths
1232} 1152}
1233 1153
1234=item $player->ext_reply ($msgid, $msgtype, %msg) 1154=item $player->ext_reply ($msgid, %msg)
1235 1155
1236Sends an ext reply to the player. 1156Sends an ext reply to the player.
1237 1157
1238=cut 1158=cut
1239 1159
1240sub ext_reply($$$%) { 1160sub ext_reply($$%) {
1241 my ($self, $id, %msg) = @_; 1161 my ($self, $id, %msg) = @_;
1242 1162
1243 $msg{msgid} = $id; 1163 $msg{msgid} = $id;
1244 1164
1245 $self->send ("ext " . cf::to_json \%msg); 1165 $self->send ("ext " . cf::to_json \%msg);
1246} 1166}
1247 1167
1248package cf; 1168=item $player->ext_event ($type, %msg)
1169
1170Sends an ext event to the client.
1171
1172=cut
1173
1174sub ext_event($$%) {
1175 my ($self, $type, %msg) = @_;
1176
1177 $self->ns->ext_event ($type, %msg);
1178}
1179
1180=head3 cf::region
1181
1182=over 4
1183
1184=cut
1185
1186package cf::region;
1187
1188=item cf::region::find_by_path $path
1189
1190Tries to decuce the probable region for a map knowing only its path.
1191
1192=cut
1193
1194sub find_by_path($) {
1195 my ($path) = @_;
1196
1197 my ($match, $specificity);
1198
1199 for my $region (list) {
1200 if ($region->match && $path =~ $region->match) {
1201 ($match, $specificity) = ($region, $region->specificity)
1202 if $region->specificity > $specificity;
1203 }
1204 }
1205
1206 $match
1207}
1249 1208
1250=back 1209=back
1251
1252 1210
1253=head3 cf::map 1211=head3 cf::map
1254 1212
1255=over 4 1213=over 4
1256 1214
1259package cf::map; 1217package cf::map;
1260 1218
1261use Fcntl; 1219use Fcntl;
1262use Coro::AIO; 1220use Coro::AIO;
1263 1221
1222use overload
1223 '""' => \&as_string,
1224 fallback => 1;
1225
1264our $MAX_RESET = 3600; 1226our $MAX_RESET = 3600;
1265our $DEFAULT_RESET = 3000; 1227our $DEFAULT_RESET = 3000;
1266 1228
1267sub generate_random_map { 1229sub generate_random_map {
1268 my ($path, $rmp) = @_; 1230 my ($self, $rmp) = @_;
1269
1270 # mit "rum" bekleckern, nicht 1231 # mit "rum" bekleckern, nicht
1271 cf::map::_create_random_map ( 1232 $self->_create_random_map (
1272 $path,
1273 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle}, 1233 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle},
1274 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle}, 1234 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle},
1275 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map}, 1235 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map},
1276 $rmp->{exit_on_final_map}, 1236 $rmp->{exit_on_final_map},
1277 $rmp->{xsize}, $rmp->{ysize}, 1237 $rmp->{xsize}, $rmp->{ysize},
1282 $rmp->{map_layout_style}, $rmp->{treasureoptions}, $rmp->{symmetry_used}, 1242 $rmp->{map_layout_style}, $rmp->{treasureoptions}, $rmp->{symmetry_used},
1283 (cf::region::find $rmp->{region}), $rmp->{custom} 1243 (cf::region::find $rmp->{region}), $rmp->{custom}
1284 ) 1244 )
1285} 1245}
1286 1246
1247=item cf::map->register ($regex, $prio)
1248
1249Register a handler for the map path matching the given regex at the
1250givne priority (higher is better, built-in handlers have priority 0, the
1251default).
1252
1253=cut
1254
1255sub register {
1256 my (undef, $regex, $prio) = @_;
1257 my $pkg = caller;
1258
1259 no strict;
1260 push @{"$pkg\::ISA"}, __PACKAGE__;
1261
1262 $EXT_MAP{$pkg} = [$prio, qr<$regex>];
1263}
1264
1265# also paths starting with '/'
1266$EXT_MAP{"cf::map"} = [0, qr{^(?=/)}];
1267
1268sub thawer_merge {
1269 my ($self, $merge) = @_;
1270
1271 # we have to keep some variables in memory intact
1272 local $self->{path};
1273 local $self->{load_path};
1274 local $self->{deny_save};
1275 local $self->{deny_reset};
1276
1277 $self->SUPER::thawer_merge ($merge);
1278}
1279
1280sub normalise {
1281 my ($path, $base) = @_;
1282
1283 $path = "$path"; # make sure its a string
1284
1285 $path =~ s/\.map$//;
1286
1287 # map plan:
1288 #
1289 # /! non-realised random map exit (special hack!)
1290 # {... are special paths that are not being touched
1291 # ?xxx/... are special absolute paths
1292 # ?random/... random maps
1293 # /... normal maps
1294 # ~user/... per-player map of a specific user
1295
1296 $path =~ s/$PATH_SEP/\//go;
1297
1298 # treat it as relative path if it starts with
1299 # something that looks reasonable
1300 if ($path =~ m{^(?:\./|\.\./|\w)}) {
1301 $base or Carp::carp "normalise called with relative path and no base: '$path'";
1302
1303 $base =~ s{[^/]+/?$}{};
1304 $path = "$base/$path";
1305 }
1306
1307 for ($path) {
1308 redo if s{//}{/};
1309 redo if s{/\.?/}{/};
1310 redo if s{/[^/]+/\.\./}{/};
1311 }
1312
1313 $path
1314}
1315
1316sub new_from_path {
1317 my (undef, $path, $base) = @_;
1318
1319 return $path if UNIVERSAL::isa $path, "cf::map"; # already a map object
1320
1321 $path = normalise $path, $base;
1322
1323 for my $pkg (sort { $EXT_MAP{$b}[0] <=> $EXT_MAP{$a}[0] } keys %EXT_MAP) {
1324 if ($path =~ $EXT_MAP{$pkg}[1]) {
1325 my $self = bless cf::map::new, $pkg;
1326 $self->{path} = $path; $self->path ($path);
1327 $self->init; # pass $1 etc.
1328 return $self;
1329 }
1330 }
1331
1332 Carp::carp "unable to resolve path '$path' (base '$base').";
1333 ()
1334}
1335
1336sub init {
1337 my ($self) = @_;
1338
1339 $self
1340}
1341
1342sub as_string {
1343 my ($self) = @_;
1344
1345 "$self->{path}"
1346}
1347
1348# the displayed name, this is a one way mapping
1349sub visible_name {
1350 &as_string
1351}
1352
1353# the original (read-only) location
1354sub load_path {
1355 my ($self) = @_;
1356
1357 "$MAPDIR/$self->{path}.map"
1358}
1359
1360# the temporary/swap location
1361sub save_path {
1362 my ($self) = @_;
1363
1364 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g;
1365 "$TMPDIR/$path.map"
1366}
1367
1368# the unique path, undef == no special unique path
1369sub uniq_path {
1370 my ($self) = @_;
1371
1372 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g;
1373 "$UNIQUEDIR/$path"
1374}
1375
1287# and all this just because we cannot iterate over 1376# and all this just because we cannot iterate over
1288# all maps in C++... 1377# all maps in C++...
1289sub change_all_map_light { 1378sub change_all_map_light {
1290 my ($change) = @_; 1379 my ($change) = @_;
1291 1380
1292 $_->change_map_light ($change) 1381 $_->change_map_light ($change)
1293 for grep $_->outdoor, values %cf::MAP; 1382 for grep $_->outdoor, values %cf::MAP;
1294} 1383}
1295 1384
1385sub unlink_save {
1386 my ($self) = @_;
1387
1388 utf8::encode (my $save = $self->save_path);
1389 IO::AIO::aioreq_pri 4; Coro::AIO::aio_unlink $save;
1390 IO::AIO::aioreq_pri 4; Coro::AIO::aio_unlink "$save.pst";
1391}
1392
1296sub load_map_header($) { 1393sub load_header_from($) {
1297 my ($path) = @_; 1394 my ($self, $path) = @_;
1298 1395
1299 utf8::encode $path; 1396 utf8::encode $path;
1300 aio_open $path, O_RDONLY, 0 1397 #aio_open $path, O_RDONLY, 0
1398 # or return;
1399
1400 $self->_load_header ($path)
1301 or return; 1401 or return;
1302 1402
1303 my $map = cf::map::new 1403 $self->{load_path} = $path;
1404
1405 1
1406}
1407
1408sub load_header_orig {
1409 my ($self) = @_;
1410
1411 $self->load_header_from ($self->load_path)
1412}
1413
1414sub load_header_temp {
1415 my ($self) = @_;
1416
1417 $self->load_header_from ($self->save_path)
1418}
1419
1420sub prepare_temp {
1421 my ($self) = @_;
1422
1423 $self->last_access ((delete $self->{last_access})
1424 || $cf::RUNTIME); #d#
1425 # safety
1426 $self->{instantiate_time} = $cf::RUNTIME
1427 if $self->{instantiate_time} > $cf::RUNTIME;
1428}
1429
1430sub prepare_orig {
1431 my ($self) = @_;
1432
1433 $self->{load_original} = 1;
1434 $self->{instantiate_time} = $cf::RUNTIME;
1435 $self->last_access ($cf::RUNTIME);
1436 $self->instantiate;
1437}
1438
1439sub load_header {
1440 my ($self) = @_;
1441
1442 if ($self->load_header_temp) {
1443 $self->prepare_temp;
1444 } else {
1445 $self->load_header_orig
1304 or return; 1446 or return;
1447 $self->prepare_orig;
1448 }
1305 1449
1306 # for better error messages only, will be overwritten later 1450 $self->default_region (cf::region::find_by_path $self->{path})
1307 $map->path ($path); 1451 unless $self->default_region;
1308 1452
1309 $map->load_header ($path) 1453 1
1310 or return;
1311
1312 $map->{load_path} = $path;
1313
1314 $map
1315} 1454}
1316 1455
1317sub find; 1456sub find;
1318sub find { 1457sub find {
1319 my ($path, $origin) = @_; 1458 my ($path, $origin) = @_;
1320 1459
1321 #warn "find<$path,$origin>\n";#d#
1322
1323 $path = new cf::path $path, $origin && $origin->path; 1460 $path = normalise $path, $origin && $origin->path;
1324 my $key = $path->as_string;
1325 1461
1326 cf::lock_wait "map_find:$key"; 1462 cf::lock_wait "map_find:$path";
1327 1463
1328 $cf::MAP{$key} || do { 1464 $cf::MAP{$path} || do {
1329 my $guard = cf::lock_acquire "map_find:$key"; 1465 my $guard = cf::lock_acquire "map_find:$path";
1330 1466 my $map = new_from_path cf::map $path
1331 # do it the slow way
1332 my $map = $path->load_temp;
1333
1334 Coro::cede;
1335
1336 if ($map) {
1337 $map->last_access ((delete $map->{last_access})
1338 || $cf::RUNTIME); #d#
1339 # safety
1340 $map->{instantiate_time} = $cf::RUNTIME
1341 if $map->{instantiate_time} > $cf::RUNTIME;
1342 } else {
1343 $map = $path->load_orig
1344 or return; 1467 or return;
1345 1468
1346 $map->{load_original} = 1;
1347 $map->{instantiate_time} = $cf::RUNTIME;
1348 $map->last_access ($cf::RUNTIME);
1349 $map->instantiate;
1350
1351 # per-player maps become, after loading, normal maps
1352 $map->per_player (0) if $path->{user_rel};
1353 }
1354
1355 $map->path ($key);
1356 $map->{path} = $path;
1357 $map->{last_save} = $cf::RUNTIME; 1469 $map->{last_save} = $cf::RUNTIME;
1358 1470
1359 Coro::cede; 1471 $map->load_header
1472 or return;
1360 1473
1361 if ($map->should_reset) { 1474 if ($map->should_reset && 0) {#d#TODO# disabled, crashy (locking issue?)
1475 # doing this can freeze the server in a sync job, obviously
1476 #$cf::WAIT_FOR_TICK->wait;
1362 $map->reset; 1477 $map->reset;
1363 undef $guard; 1478 undef $guard;
1364 $map = find $path 1479 return find $path;
1365 or return;
1366 } 1480 }
1367 1481
1368 $cf::MAP{$key} = $map 1482 $cf::MAP{$path} = $map
1369 } 1483 }
1370} 1484}
1485
1486sub pre_load { }
1487sub post_load { }
1371 1488
1372sub load { 1489sub load {
1373 my ($self) = @_; 1490 my ($self) = @_;
1374 1491
1492 local $self->{deny_reset} = 1; # loading can take a long time
1493
1375 my $path = $self->{path}; 1494 my $path = $self->{path};
1376 my $guard = cf::lock_acquire "map_load:" . $path->as_string; 1495 my $guard = cf::lock_acquire "map_load:$path";
1377 1496
1378 return if $self->in_memory != cf::MAP_SWAPPED; 1497 return if $self->in_memory != cf::MAP_SWAPPED;
1379 1498
1380 $self->in_memory (cf::MAP_LOADING); 1499 $self->in_memory (cf::MAP_LOADING);
1381 1500
1382 $self->alloc; 1501 $self->alloc;
1502
1503 $self->pre_load;
1504 Coro::cede;
1505
1383 $self->load_objects ($self->{load_path}, 1) 1506 $self->_load_objects ($self->{load_path}, 1)
1384 or return; 1507 or return;
1385 1508
1386 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1) 1509 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1)
1387 if delete $self->{load_original}; 1510 if delete $self->{load_original};
1388 1511
1389 if (my $uniq = $path->uniq_path) { 1512 if (my $uniq = $self->uniq_path) {
1390 utf8::encode $uniq; 1513 utf8::encode $uniq;
1391 if (aio_open $uniq, O_RDONLY, 0) { 1514 if (aio_open $uniq, O_RDONLY, 0) {
1392 $self->clear_unique_items; 1515 $self->clear_unique_items;
1393 $self->load_objects ($uniq, 0); 1516 $self->_load_objects ($uniq, 0);
1394 } 1517 }
1395 } 1518 }
1396 1519
1397 Coro::cede; 1520 Coro::cede;
1398
1399 # now do the right thing for maps 1521 # now do the right thing for maps
1400 $self->link_multipart_objects; 1522 $self->link_multipart_objects;
1523 Coro::cede;
1401 1524
1402 if ($self->{path}->is_style_map) { 1525 unless ($self->{deny_activate}) {
1403 $self->{deny_save} = 1; 1526 $self->decay_objects;
1404 $self->{deny_reset} = 1;
1405 } else {
1406 $self->fix_auto_apply; 1527 $self->fix_auto_apply;
1407 $self->decay_objects;
1408 $self->update_buttons; 1528 $self->update_buttons;
1529 Coro::cede;
1409 $self->set_darkness_map; 1530 $self->set_darkness_map;
1410 $self->difficulty ($self->estimate_difficulty) 1531 $self->difficulty ($self->estimate_difficulty)
1411 unless $self->difficulty; 1532 unless $self->difficulty;
1533 Coro::cede;
1412 $self->activate; 1534 $self->activate;
1535 Coro::cede;
1413 } 1536 }
1414 1537
1538 $self->post_load;
1415 Coro::cede; 1539 Coro::cede;
1416 1540
1417 $self->in_memory (cf::MAP_IN_MEMORY); 1541 $self->in_memory (cf::MAP_IN_MEMORY);
1542}
1543
1544sub customise_for {
1545 my ($self, $ob) = @_;
1546
1547 return find "~" . $ob->name . "/" . $self->{path}
1548 if $self->per_player;
1549
1550 $self
1418} 1551}
1419 1552
1420# find and load all maps in the 3x3 area around a map 1553# find and load all maps in the 3x3 area around a map
1421sub load_diag { 1554sub load_diag {
1422 my ($map) = @_; 1555 my ($map) = @_;
1452 1585
1453 cf::sync_job { $map->load }; 1586 cf::sync_job { $map->load };
1454} 1587}
1455 1588
1456our %MAP_PREFETCH; 1589our %MAP_PREFETCH;
1457our $MAP_PREFETCHER = Coro::async { 1590our $MAP_PREFETCHER = undef;
1458 while () {
1459 while (%MAP_PREFETCH) {
1460 my $key = each %MAP_PREFETCH
1461 or next;
1462 my $path = delete $MAP_PREFETCH{$key};
1463
1464 my $map = find $path
1465 or next;
1466 $map->load;
1467 }
1468 Coro::schedule;
1469 }
1470};
1471 1591
1472sub find_async { 1592sub find_async {
1473 my ($path, $origin) = @_; 1593 my ($path, $origin) = @_;
1474 1594
1475 $path = new cf::path $path, $origin && $origin->path; 1595 $path = normalise $path, $origin && $origin->{path};
1476 my $key = $path->as_string;
1477 1596
1478 if (my $map = $cf::MAP{$key}) { 1597 if (my $map = $cf::MAP{$path}) {
1479 return $map if $map->in_memory == cf::MAP_IN_MEMORY; 1598 return $map if $map->in_memory == cf::MAP_IN_MEMORY;
1480 } 1599 }
1481 1600
1482 $MAP_PREFETCH{$key} = $path; 1601 undef $MAP_PREFETCH{$path};
1602 $MAP_PREFETCHER ||= cf::async {
1603 while (%MAP_PREFETCH) {
1604 for my $path (keys %MAP_PREFETCH) {
1605 my $map = find $path
1606 or next;
1607 $map->load;
1608
1609 delete $MAP_PREFETCH{$path};
1610 }
1611 }
1612 undef $MAP_PREFETCHER;
1613 };
1483 $MAP_PREFETCHER->ready; 1614 $MAP_PREFETCHER->prio (6);
1484 1615
1485 () 1616 ()
1486} 1617}
1487 1618
1488sub save { 1619sub save {
1492 1623
1493 $self->{last_save} = $cf::RUNTIME; 1624 $self->{last_save} = $cf::RUNTIME;
1494 1625
1495 return unless $self->dirty; 1626 return unless $self->dirty;
1496 1627
1497 my $save = $self->{path}->save_path; utf8::encode $save; 1628 my $save = $self->save_path; utf8::encode $save;
1498 my $uniq = $self->{path}->uniq_path; utf8::encode $uniq; 1629 my $uniq = $self->uniq_path; utf8::encode $uniq;
1499 1630
1500 $self->{load_path} = $save; 1631 $self->{load_path} = $save;
1501 1632
1502 return if $self->{deny_save}; 1633 return if $self->{deny_save};
1503 1634
1506 cf::async { 1637 cf::async {
1507 $_->contr->save for $self->players; 1638 $_->contr->save for $self->players;
1508 }; 1639 };
1509 1640
1510 if ($uniq) { 1641 if ($uniq) {
1511 $self->save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS); 1642 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS);
1512 $self->save_objects ($uniq, cf::IO_UNIQUES); 1643 $self->_save_objects ($uniq, cf::IO_UNIQUES);
1513 } else { 1644 } else {
1514 $self->save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES); 1645 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES);
1515 } 1646 }
1516} 1647}
1517 1648
1518sub swap_out { 1649sub swap_out {
1519 my ($self) = @_; 1650 my ($self) = @_;
1533 1664
1534sub reset_at { 1665sub reset_at {
1535 my ($self) = @_; 1666 my ($self) = @_;
1536 1667
1537 # TODO: safety, remove and allow resettable per-player maps 1668 # TODO: safety, remove and allow resettable per-player maps
1538 return 1e99 if $self->{path}{user_rel}; 1669 return 1e99 if $self->isa ("ext::map_per_player");#d#
1539 return 1e99 if $self->{deny_reset}; 1670 return 1e99 if $self->{deny_reset};
1540 1671
1541 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access; 1672 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
1542 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET; 1673 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET;
1543 1674
1548 my ($self) = @_; 1679 my ($self) = @_;
1549 1680
1550 $self->reset_at <= $cf::RUNTIME 1681 $self->reset_at <= $cf::RUNTIME
1551} 1682}
1552 1683
1553sub unlink_save {
1554 my ($self) = @_;
1555
1556 utf8::encode (my $save = $self->{path}->save_path);
1557 aioreq_pri 3; IO::AIO::aio_unlink $save;
1558 aioreq_pri 3; IO::AIO::aio_unlink "$save.pst";
1559}
1560
1561sub rename {
1562 my ($self, $new_path) = @_;
1563
1564 $self->unlink_save;
1565
1566 delete $cf::MAP{$self->path};
1567 $self->{path} = new cf::path $new_path;
1568 $self->path ($self->{path}->as_string);
1569 $cf::MAP{$self->path} = $self;
1570
1571 $self->save;
1572}
1573
1574sub reset { 1684sub reset {
1575 my ($self) = @_; 1685 my ($self) = @_;
1576 1686
1577 my $lock = cf::lock_acquire "map_data:" . $self->path; 1687 my $lock = cf::lock_acquire "map_data:$self->{path}";
1578 1688
1579 return if $self->players; 1689 return if $self->players;
1580 return if $self->{path}{user_rel};#d# 1690 return if $self->isa ("ext::map_per_player");#d#
1581 1691
1582 warn "resetting map ", $self->path;#d# 1692 warn "resetting map ", $self->path;#d#
1583 1693
1694 $self->in_memory (cf::MAP_SWAPPED);
1695
1696 # need to save uniques path
1697 unless ($self->{deny_save}) {
1698 my $uniq = $self->uniq_path; utf8::encode $uniq;
1699
1700 $self->_save_objects ($uniq, cf::IO_UNIQUES)
1701 if $uniq;
1702 }
1703
1584 delete $cf::MAP{$self->path}; 1704 delete $cf::MAP{$self->path};
1705
1706 $self->clear;
1585 1707
1586 $_->clear_links_to ($self) for values %cf::MAP; 1708 $_->clear_links_to ($self) for values %cf::MAP;
1587 1709
1588 $self->unlink_save; 1710 $self->unlink_save;
1589 $self->destroy; 1711 $self->destroy;
1592my $nuke_counter = "aaaa"; 1714my $nuke_counter = "aaaa";
1593 1715
1594sub nuke { 1716sub nuke {
1595 my ($self) = @_; 1717 my ($self) = @_;
1596 1718
1719 delete $cf::MAP{$self->path};
1720
1721 $self->unlink_save;
1722
1723 bless $self, "cf::map";
1724 delete $self->{deny_reset};
1597 $self->{deny_save} = 1; 1725 $self->{deny_save} = 1;
1598 $self->reset_timeout (1); 1726 $self->reset_timeout (1);
1599 $self->rename ("{nuke}/" . ($nuke_counter++)); 1727 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));
1728
1729 $cf::MAP{$self->path} = $self;
1730
1600 $self->reset; # polite request, might not happen 1731 $self->reset; # polite request, might not happen
1601} 1732}
1602 1733
1603sub customise_for {
1604 my ($map, $ob) = @_;
1605
1606 if ($map->per_player) {
1607 return cf::map::find "~" . $ob->name . "/" . $map->{path}{path};
1608 }
1609
1610 $map
1611}
1612
1613=item cf::map::unique_maps 1734=item cf::map::unique_maps
1614 1735
1615Returns an arrayref of cf::path's of all shared maps that have 1736Returns an arrayref of paths of all shared maps that have
1616instantiated unique items. May block. 1737instantiated unique items. May block.
1617 1738
1618=cut 1739=cut
1619 1740
1620sub unique_maps() { 1741sub unique_maps() {
1621 my $files = aio_readdir cf::localdir . "/" . cf::uniquedir 1742 my $files = aio_readdir $UNIQUEDIR
1622 or return; 1743 or return;
1623 1744
1624 my @paths; 1745 my @paths;
1625 1746
1626 for (@$files) { 1747 for (@$files) {
1627 utf8::decode $_; 1748 utf8::decode $_;
1628 next if /\.pst$/; 1749 next if /\.pst$/;
1629 next unless /^$PATH_SEP/o; 1750 next unless /^$PATH_SEP/o;
1630 1751
1631 push @paths, new cf::path $_; 1752 push @paths, cf::map::normalise $_;
1632 } 1753 }
1633 1754
1634 \@paths 1755 \@paths
1635} 1756}
1636 1757
1711 1832
1712=item $player_object->enter_link 1833=item $player_object->enter_link
1713 1834
1714Freezes the player and moves him/her to a special map (C<{link}>). 1835Freezes the player and moves him/her to a special map (C<{link}>).
1715 1836
1716The player should be reaosnably safe there for short amounts of time. You 1837The player should be reasonably safe there for short amounts of time. You
1717I<MUST> call C<leave_link> as soon as possible, though. 1838I<MUST> call C<leave_link> as soon as possible, though.
1718 1839
1840Will never block.
1841
1719=item $player_object->leave_link ($map, $x, $y) 1842=item $player_object->leave_link ($map, $x, $y)
1720 1843
1721Moves the player out of the specila link map onto the given map. If the 1844Moves the player out of the special C<{link}> map onto the specified
1722map is not valid (or omitted), the player will be moved back to the 1845map. If the map is not valid (or omitted), the player will be moved back
1723location he/she was before the call to C<enter_link>, or, if that fails, 1846to the location he/she was before the call to C<enter_link>, or, if that
1724to the emergency map position. 1847fails, to the emergency map position.
1725 1848
1726Might block. 1849Might block.
1727 1850
1728=cut 1851=cut
1852
1853sub link_map {
1854 unless ($LINK_MAP) {
1855 $LINK_MAP = cf::map::find "{link}"
1856 or cf::cleanup "FATAL: unable to provide {link} map, exiting.";
1857 $LINK_MAP->load;
1858 }
1859
1860 $LINK_MAP
1861}
1729 1862
1730sub cf::object::player::enter_link { 1863sub cf::object::player::enter_link {
1731 my ($self) = @_; 1864 my ($self) = @_;
1732 1865
1733 $self->deactivate_recursive; 1866 $self->deactivate_recursive;
1734 1867
1735 return if $self->map == $LINK_MAP; 1868 return if UNIVERSAL::isa $self->map, "ext::map_link";
1736 1869
1737 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y] 1870 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y]
1738 if $self->map; 1871 if $self->map;
1739 1872
1740 $self->enter_map ($LINK_MAP, 20, 20); 1873 $self->enter_map ($LINK_MAP || link_map, 10, 10);
1741} 1874}
1742 1875
1743sub cf::object::player::leave_link { 1876sub cf::object::player::leave_link {
1744 my ($self, $map, $x, $y) = @_; 1877 my ($self, $map, $x, $y) = @_;
1745 1878
1767 $map->load; 1900 $map->load;
1768 $map->load_diag; 1901 $map->load_diag;
1769 1902
1770 return unless $self->contr->active; 1903 return unless $self->contr->active;
1771 $self->activate_recursive; 1904 $self->activate_recursive;
1905
1906 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
1772 $self->enter_map ($map, $x, $y); 1907 $self->enter_map ($map, $x, $y);
1773} 1908}
1774 1909
1775cf::player->attach ( 1910cf::player->attach (
1776 on_logout => sub { 1911 on_logout => sub {
1789 # try to abort aborted map switching on player login :) 1924 # try to abort aborted map switching on player login :)
1790 # should happen only on crashes 1925 # should happen only on crashes
1791 if ($pl->ob->{_link_pos}) { 1926 if ($pl->ob->{_link_pos}) {
1792 $pl->ob->enter_link; 1927 $pl->ob->enter_link;
1793 (async { 1928 (async {
1794 # we need this sleep as the login has a concurrent enter_exit running
1795 # and this sleep increases chances of the player not ending up in scorn
1796 $pl->ob->reply (undef, 1929 $pl->ob->reply (undef,
1797 "There was an internal problem at your last logout, " 1930 "There was an internal problem at your last logout, "
1798 . "the server will try to bring you to your intended destination in a second.", 1931 . "the server will try to bring you to your intended destination in a second.",
1799 cf::NDI_RED); 1932 cf::NDI_RED);
1933 # we need this sleep as the login has a concurrent enter_exit running
1934 # and this sleep increases chances of the player not ending up in scorn
1800 Coro::Timer::sleep 1; 1935 Coro::Timer::sleep 1;
1801 $pl->ob->leave_link; 1936 $pl->ob->leave_link;
1802 })->prio (2); 1937 })->prio (2);
1803 } 1938 }
1804 }, 1939 },
1809=cut 1944=cut
1810 1945
1811sub cf::object::player::goto { 1946sub cf::object::player::goto {
1812 my ($self, $path, $x, $y) = @_; 1947 my ($self, $path, $x, $y) = @_;
1813 1948
1814 $path = new cf::path $path;
1815
1816 $self->enter_link; 1949 $self->enter_link;
1817 1950
1818 (async { 1951 (async {
1952 my $map = eval {
1819 my $map = cf::map::find $path->as_string; 1953 my $map = cf::map::find $path;
1820 $map = $map->customise_for ($self) if $map; 1954 $map = $map->customise_for ($self) if $map;
1821 1955 $map
1822# warn "entering ", $map->path, " at ($x, $y)\n" 1956 } or
1823# if $map;
1824
1825 $map or $self->message ("The exit to '" . ($path->visible_name) . "' is closed", cf::NDI_UNIQUE | cf::NDI_RED); 1957 $self->message ("The exit to '$path' is closed", cf::NDI_UNIQUE | cf::NDI_RED);
1826 1958
1827 $self->leave_link ($map, $x, $y); 1959 $self->leave_link ($map, $x, $y);
1828 })->prio (1); 1960 })->prio (1);
1829} 1961}
1830 1962
1834 1966
1835sub parse_random_map_params { 1967sub parse_random_map_params {
1836 my ($spec) = @_; 1968 my ($spec) = @_;
1837 1969
1838 my $rmp = { # defaults 1970 my $rmp = { # defaults
1839 xsize => 10, 1971 xsize => (cf::rndm 15, 40),
1840 ysize => 10, 1972 ysize => (cf::rndm 15, 40),
1973 symmetry => (cf::rndm 1, cf::SYMMETRY_XY),
1974 #layout => string,
1841 }; 1975 };
1842 1976
1843 for (split /\n/, $spec) { 1977 for (split /\n/, $spec) {
1844 my ($k, $v) = split /\s+/, $_, 2; 1978 my ($k, $v) = split /\s+/, $_, 2;
1845 1979
1849 $rmp 1983 $rmp
1850} 1984}
1851 1985
1852sub prepare_random_map { 1986sub prepare_random_map {
1853 my ($exit) = @_; 1987 my ($exit) = @_;
1988
1989 my $guard = cf::lock_acquire "exit_prepare:$exit";
1854 1990
1855 # all this does is basically replace the /! path by 1991 # all this does is basically replace the /! path by
1856 # a new random map path (?random/...) with a seed 1992 # a new random map path (?random/...) with a seed
1857 # that depends on the exit object 1993 # that depends on the exit object
1858 1994
1859 my $rmp = parse_random_map_params $exit->msg; 1995 my $rmp = parse_random_map_params $exit->msg;
1860 1996
1861 if ($exit->map) { 1997 if ($exit->map) {
1862 $rmp->{region} = $exit->map->region_name; 1998 $rmp->{region} = $exit->region->name;
1863 $rmp->{origin_map} = $exit->map->path; 1999 $rmp->{origin_map} = $exit->map->path;
1864 $rmp->{origin_x} = $exit->x; 2000 $rmp->{origin_x} = $exit->x;
1865 $rmp->{origin_y} = $exit->y; 2001 $rmp->{origin_y} = $exit->y;
1866 } 2002 }
1867 2003
1868 $rmp->{random_seed} ||= $exit->random_seed; 2004 $rmp->{random_seed} ||= $exit->random_seed;
1869 2005
1870 my $data = cf::to_json $rmp; 2006 my $data = cf::to_json $rmp;
1871 my $md5 = Digest::MD5::md5_hex $data; 2007 my $md5 = Digest::MD5::md5_hex $data;
2008 my $meta = "$RANDOMDIR/$md5.meta";
1872 2009
1873 if (my $fh = aio_open "$cf::RANDOM_MAPS/$md5.meta", O_WRONLY | O_CREAT, 0666) { 2010 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) {
1874 aio_write $fh, 0, (length $data), $data, 0; 2011 aio_write $fh, 0, (length $data), $data, 0;
2012 undef $fh;
2013 aio_rename "$meta~", $meta;
1875 2014
1876 $exit->slaying ("?random/$md5"); 2015 $exit->slaying ("?random/$md5");
1877 $exit->msg (undef); 2016 $exit->msg (undef);
1878 } 2017 }
1879} 2018}
1880 2019
1881sub cf::object::player::enter_exit { 2020sub cf::object::player::enter_exit {
1882 my ($self, $exit) = @_; 2021 my ($self, $exit) = @_;
1883 2022
1884 return unless $self->type == cf::PLAYER; 2023 return unless $self->type == cf::PLAYER;
2024
2025 if ($exit->slaying eq "/!") {
2026 #TODO: this should de-fi-ni-te-ly not be a sync-job
2027 # the problem is that $exit might not survive long enough
2028 # so it needs to be done right now, right here
2029 cf::sync_job { prepare_random_map $exit };
2030 }
2031
2032 my $slaying = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path;
2033 my $hp = $exit->stats->hp;
2034 my $sp = $exit->stats->sp;
1885 2035
1886 $self->enter_link; 2036 $self->enter_link;
1887 2037
1888 (async { 2038 (async {
1889 $self->deactivate_recursive; # just to be sure 2039 $self->deactivate_recursive; # just to be sure
1890 unless (eval { 2040 unless (eval {
1891 prepare_random_map $exit 2041 $self->goto ($slaying, $hp, $sp);
1892 if $exit->slaying eq "/!";
1893
1894 my $path = new cf::path $exit->slaying, $exit->map && $exit->map->path;
1895 $self->goto ($path, $exit->stats->hp, $exit->stats->sp);
1896 2042
1897 1; 2043 1;
1898 }) { 2044 }) {
1899 $self->message ("Something went wrong deep within the crossfire server. " 2045 $self->message ("Something went wrong deep within the crossfire server. "
1900 . "I'll try to bring you back to the map you were before. " 2046 . "I'll try to bring you back to the map you were before. "
1901 . "Please report this to the dungeon master!", 2047 . "Please report this to the dungeon master!",
1902 cf::NDI_UNIQUE | cf::NDI_RED); 2048 cf::NDI_UNIQUE | cf::NDI_RED);
1903 2049
1904 warn "ERROR in enter_exit: $@"; 2050 warn "ERROR in enter_exit: $@";
1905 $self->leave_link; 2051 $self->leave_link;
1906 } 2052 }
1907 })->prio (1); 2053 })->prio (1);
1920 2066
1921sub cf::client::send_drawinfo { 2067sub cf::client::send_drawinfo {
1922 my ($self, $text, $flags) = @_; 2068 my ($self, $text, $flags) = @_;
1923 2069
1924 utf8::encode $text; 2070 utf8::encode $text;
1925 $self->send_packet (sprintf "drawinfo %d %s", $flags, $text); 2071 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);
1926} 2072}
1927 2073
2074=item $client->ext_event ($type, %msg)
2075
2076Sends an exti event to the client.
2077
2078=cut
2079
2080sub cf::client::ext_event($$%) {
2081 my ($self, $type, %msg) = @_;
2082
2083 $msg{msgtype} = "event_$type";
2084 $self->send_packet ("ext " . cf::to_json \%msg);
2085}
1928 2086
1929=item $success = $client->query ($flags, "text", \&cb) 2087=item $success = $client->query ($flags, "text", \&cb)
1930 2088
1931Queues a query to the client, calling the given callback with 2089Queues a query to the client, calling the given callback with
1932the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>, 2090the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>,
1961 # get handled first 2119 # get handled first
1962 my $queue = delete $ns->{query_queue} 2120 my $queue = delete $ns->{query_queue}
1963 or return; # be conservative, not sure how that can happen, but we saw a crash here 2121 or return; # be conservative, not sure how that can happen, but we saw a crash here
1964 2122
1965 (shift @$queue)->[1]->($msg); 2123 (shift @$queue)->[1]->($msg);
2124 return unless $ns->valid; # temporary(?) workaround for callback destroying socket
1966 2125
1967 push @{ $ns->{query_queue} }, @$queue; 2126 push @{ $ns->{query_queue} }, @$queue;
1968 2127
1969 if (@{ $ns->{query_queue} } == @$queue) { 2128 if (@{ $ns->{query_queue} } == @$queue) {
1970 if (@$queue) { 2129 if (@$queue) {
2028 2187
2029# here we export the classes and methods available to script code 2188# here we export the classes and methods available to script code
2030 2189
2031=pod 2190=pod
2032 2191
2033The following fucntions and emthods are available within a safe environment: 2192The following functions and methods are available within a safe environment:
2034 2193
2035 cf::object contr pay_amount pay_player map 2194 cf::object contr pay_amount pay_player map
2036 cf::object::player player 2195 cf::object::player player
2037 cf::player peaceful 2196 cf::player peaceful
2038 cf::map trigger 2197 cf::map trigger
2123############################################################################# 2282#############################################################################
2124 2283
2125=head2 EXTENSION DATABASE SUPPORT 2284=head2 EXTENSION DATABASE SUPPORT
2126 2285
2127Crossfire maintains a very simple database for extension use. It can 2286Crossfire maintains a very simple database for extension use. It can
2128currently store anything that can be serialised using Storable, which 2287currently store binary data only (use Compress::LZF::sfreeze_cr/sthaw to
2129excludes objects. 2288convert to/from binary).
2130 2289
2131The parameter C<$family> should best start with the name of the extension 2290The parameter C<$family> should best start with the name of the extension
2132using it, it should be unique. 2291using it, it should be unique.
2133 2292
2134=over 4 2293=over 4
2135 2294
2136=item $hashref = cf::db_get $family
2137
2138Return a hashref for use by the extension C<$family>, which can be
2139modified. After modifications, you have to call C<cf::db_dirty> or
2140C<cf::db_sync>.
2141
2142=item $value = cf::db_get $family => $key 2295=item $value = cf::db_get $family => $key
2143 2296
2144Returns a single value from the database 2297Returns a single value from the database.
2145
2146=item cf::db_put $family => $hashref
2147
2148Stores the given family hashref into the database. Updates are delayed, if
2149you want the data to be synced to disk immediately, use C<cf::db_sync>.
2150 2298
2151=item cf::db_put $family => $key => $value 2299=item cf::db_put $family => $key => $value
2152 2300
2153Stores the given C<$value> in the family hash. Updates are delayed, if you 2301Stores the given C<$value> in the family.
2154want the data to be synced to disk immediately, use C<cf::db_sync>.
2155
2156=item cf::db_dirty
2157
2158Marks the database as dirty, to be updated at a later time.
2159
2160=item cf::db_sync
2161
2162Immediately write the database to disk I<if it is dirty>.
2163 2302
2164=cut 2303=cut
2165 2304
2166our $DB; 2305our $DB;
2167 2306
2168{ 2307sub db_init {
2169 my $path = cf::localdir . "/database.pst"; 2308 unless ($DB) {
2309 $DB = BDB::db_create $DB_ENV;
2170 2310
2171 sub db_load() { 2311 cf::sync_job {
2172 $DB = stat $path ? Storable::retrieve $path : { }; 2312 eval {
2173 } 2313 $DB->set_flags (BDB::CHKSUM);
2174 2314
2175 my $pid; 2315 BDB::db_open $DB, undef, "db", undef, BDB::BTREE,
2176 2316 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
2177 sub db_save() { 2317 cf::cleanup "db_open(db): $!" if $!;
2178 waitpid $pid, 0 if $pid; 2318 };
2179 if (0 == ($pid = fork)) { 2319 cf::cleanup "db_open(db): $@" if $@;
2180 $DB->{_meta}{version} = 1;
2181 Storable::nstore $DB, "$path~";
2182 rename "$path~", $path;
2183 cf::_exit 0 if defined $pid;
2184 } 2320 };
2185 }
2186
2187 my $dirty;
2188
2189 sub db_sync() {
2190 db_save if $dirty;
2191 undef $dirty;
2192 }
2193
2194 my $idle = Event->idle (min => $TICK * 2.8, max => 10, repeat => 0, data => WF_AUTOCANCEL, cb => sub {
2195 db_sync;
2196 }); 2321 }
2322}
2197 2323
2198 sub db_dirty() {
2199 $dirty = 1;
2200 $idle->start;
2201 }
2202
2203 sub db_get($;$) { 2324sub db_get($$) {
2204 @_ >= 2 2325 my $key = "$_[0]/$_[1]";
2205 ? $DB->{$_[0]}{$_[1]}
2206 : ($DB->{$_[0]} ||= { })
2207 }
2208 2326
2327 cf::sync_job {
2328 BDB::db_get $DB, undef, $key, my $data;
2329
2330 $! ? ()
2331 : $data
2332 }
2333}
2334
2209 sub db_put($$;$) { 2335sub db_put($$$) {
2210 if (@_ >= 3) { 2336 BDB::dbreq_pri 4;
2211 $DB->{$_[0]}{$_[1]} = $_[2]; 2337 BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { };
2212 } else { 2338}
2213 $DB->{$_[0]} = $_[1];
2214 }
2215 db_dirty;
2216 }
2217 2339
2218 cf::global->attach ( 2340=item cf::cache $id => [$paths...], $processversion => $process
2219 prio => 10000, 2341
2220 on_cleanup => sub { 2342Generic caching function that returns the value of the resource $id,
2221 db_sync; 2343caching and regenerating as required.
2344
2345This function can block.
2346
2347=cut
2348
2349sub cache {
2350 my ($id, $src, $processversion, $process) = @_;
2351
2352 my $meta =
2353 join "\x00",
2354 $processversion,
2355 map {
2356 aio_stat $_
2357 and Carp::croak "$_: $!";
2358
2359 ($_, (stat _)[7,9])
2360 } @$src;
2361
2362 my $dbmeta = db_get cache => "$id/meta";
2363 if ($dbmeta ne $meta) {
2364 # changed, we may need to process
2365
2366 my @data;
2367 my $md5;
2368
2369 for (0 .. $#$src) {
2370 0 <= aio_load $src->[$_], $data[$_]
2371 or Carp::croak "$src->[$_]: $!";
2222 }, 2372 }
2223 ); 2373
2374 # if processing is expensive, check
2375 # checksum first
2376 if (1) {
2377 $md5 =
2378 join "\x00",
2379 $processversion,
2380 map {
2381 Coro::cede;
2382 ($src->[$_], Digest::MD5::md5_hex $data[$_])
2383 } 0.. $#$src;
2384
2385
2386 my $dbmd5 = db_get cache => "$id/md5";
2387 if ($dbmd5 eq $md5) {
2388 db_put cache => "$id/meta", $meta;
2389
2390 return db_get cache => "$id/data";
2391 }
2392 }
2393
2394 my $t1 = Time::HiRes::time;
2395 my $data = $process->(\@data);
2396 my $t2 = Time::HiRes::time;
2397
2398 warn "cache: '$id' processed in ", $t2 - $t1, "s\n";
2399
2400 db_put cache => "$id/data", $data;
2401 db_put cache => "$id/md5" , $md5;
2402 db_put cache => "$id/meta", $meta;
2403
2404 return $data;
2405 }
2406
2407 db_get cache => "$id/data"
2224} 2408}
2409
2410=item fork_call { }, $args
2411
2412Executes the given code block with the given arguments in a seperate
2413process, returning the results. Everything must be serialisable with
2414Coro::Storable. May, of course, block. Note that the executed sub may
2415never block itself or use any form of Event handling.
2416
2417=cut
2418
2419sub fork_call(&@) {
2420 my ($cb, @args) = @_;
2421
2422# socketpair my $fh1, my $fh2, Socket::AF_UNIX, Socket::SOCK_STREAM, Socket::PF_UNSPEC
2423# or die "socketpair: $!";
2424 pipe my $fh1, my $fh2
2425 or die "pipe: $!";
2426
2427 if (my $pid = fork) {
2428 close $fh2;
2429
2430 my $res = (Coro::Handle::unblock $fh1)->readline (undef);
2431 $res = Coro::Storable::thaw $res;
2432
2433 waitpid $pid, 0; # should not block anymore, we expect the child to simply behave
2434
2435 die $$res unless "ARRAY" eq ref $res;
2436
2437 return wantarray ? @$res : $res->[-1];
2438 } else {
2439 local $SIG{__WARN__};
2440 eval {
2441 local $SIG{__DIE__};
2442 close $fh1;
2443
2444 my @res = eval { $cb->(@args) };
2445 syswrite $fh2, Coro::Storable::freeze +($@ ? \"$@" : \@res);
2446 };
2447
2448 warn $@ if $@;
2449 _exit 0;
2450 }
2451}
2452
2453
2225 2454
2226############################################################################# 2455#############################################################################
2227# the server's main() 2456# the server's init and main functions
2457
2458sub load_facedata($) {
2459 my ($path) = @_;
2460
2461 warn "loading facedata from $path\n";
2462
2463 my $facedata;
2464 0 < aio_load $path, $facedata
2465 or die "$path: $!";
2466
2467 $facedata = Coro::Storable::thaw $facedata;
2468
2469 $facedata->{version} == 2
2470 or cf::cleanup "$path: version mismatch, cannot proceed.";
2471
2472 {
2473 my $faces = $facedata->{faceinfo};
2474
2475 while (my ($face, $info) = each %$faces) {
2476 my $idx = (cf::face::find $face) || cf::face::alloc $face;
2477 cf::face::set $idx, $info->{visibility}, $info->{magicmap};
2478 cf::face::set_data $idx, 0, $info->{data32}, $info->{chksum32};
2479 cf::face::set_data $idx, 1, $info->{data64}, $info->{chksum64};
2480 Coro::cede;
2481 }
2482
2483 while (my ($face, $info) = each %$faces) {
2484 next unless $info->{smooth};
2485 my $idx = cf::face::find $face
2486 or next;
2487 if (my $smooth = cf::face::find $info->{smooth}) {
2488 cf::face::set_smooth $idx, $smooth, $info->{smoothlevel};
2489 } else {
2490 warn "smooth face '$info->{smooth}' not found for face '$face'";
2491 }
2492 Coro::cede;
2493 }
2494 }
2495
2496 {
2497 my $anims = $facedata->{animinfo};
2498
2499 while (my ($anim, $info) = each %$anims) {
2500 cf::anim::set $anim, $info->{frames}, $info->{facings};
2501 Coro::cede;
2502 }
2503
2504 cf::anim::invalidate_all; # d'oh
2505 }
2506
2507 1
2508}
2509
2510sub reload_regions {
2511 load_resource_file "$MAPDIR/regions"
2512 or die "unable to load regions file\n";
2513}
2514
2515sub reload_facedata {
2516 load_facedata "$DATADIR/facedata"
2517 or die "unable to load facedata\n";
2518}
2519
2520sub reload_archetypes {
2521 load_resource_file "$DATADIR/archetypes"
2522 or die "unable to load archetypes\n";
2523}
2524
2525sub reload_treasures {
2526 load_resource_file "$DATADIR/treasures"
2527 or die "unable to load treasurelists\n";
2528}
2529
2530sub reload_resources {
2531 warn "reloading resource files...\n";
2532
2533 reload_regions;
2534 reload_facedata;
2535 reload_archetypes;
2536 reload_treasures;
2537
2538 warn "finished reloading resource files\n";
2539}
2540
2541sub init {
2542 reload_resources;
2543}
2228 2544
2229sub cfg_load { 2545sub cfg_load {
2230 open my $fh, "<:utf8", cf::confdir . "/config" 2546 open my $fh, "<:utf8", "$CONFDIR/config"
2231 or return; 2547 or return;
2232 2548
2233 local $/; 2549 local $/;
2234 *CFG = YAML::Syck::Load <$fh>; 2550 *CFG = YAML::Syck::Load <$fh>;
2235 2551
2249 2565
2250sub main { 2566sub main {
2251 # we must not ever block the main coroutine 2567 # we must not ever block the main coroutine
2252 local $Coro::idle = sub { 2568 local $Coro::idle = sub {
2253 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d# 2569 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
2570 (async {
2254 async { Event::one_event }; 2571 Event::one_event;
2572 })->prio (Coro::PRIO_MAX);
2255 }; 2573 };
2256 2574
2257 cfg_load; 2575 cfg_load;
2258 db_load; 2576 db_init;
2259 load_extensions; 2577 load_extensions;
2578
2579 $TICK_WATCHER->start;
2260 Event::loop; 2580 Event::loop;
2261} 2581}
2262 2582
2263############################################################################# 2583#############################################################################
2264# initialisation and cleanup 2584# initialisation and cleanup
2265 2585
2266# install some emergency cleanup handlers 2586# install some emergency cleanup handlers
2267BEGIN { 2587BEGIN {
2268 for my $signal (qw(INT HUP TERM)) { 2588 for my $signal (qw(INT HUP TERM)) {
2269 Event->signal ( 2589 Event->signal (
2590 reentrant => 0,
2270 data => WF_AUTOCANCEL, 2591 data => WF_AUTOCANCEL,
2271 signal => $signal, 2592 signal => $signal,
2593 prio => 0,
2272 cb => sub { 2594 cb => sub {
2273 cf::cleanup "SIG$signal"; 2595 cf::cleanup "SIG$signal";
2274 }, 2596 },
2275 ); 2597 );
2276 } 2598 }
2277} 2599}
2282 warn "enter emergency perl save\n"; 2604 warn "enter emergency perl save\n";
2283 2605
2284 cf::sync_job { 2606 cf::sync_job {
2285 # use a peculiar iteration method to avoid tripping on perl 2607 # use a peculiar iteration method to avoid tripping on perl
2286 # refcount bugs in for. also avoids problems with players 2608 # refcount bugs in for. also avoids problems with players
2287 # and maps saved/Destroyed asynchronously. 2609 # and maps saved/destroyed asynchronously.
2288 warn "begin emergency player save\n"; 2610 warn "begin emergency player save\n";
2289 for my $login (keys %cf::PLAYER) { 2611 for my $login (keys %cf::PLAYER) {
2290 my $pl = $cf::PLAYER{$login} or next; 2612 my $pl = $cf::PLAYER{$login} or next;
2291 $pl->valid or next; 2613 $pl->valid or next;
2292 $pl->save; 2614 $pl->save;
2298 my $map = $cf::MAP{$path} or next; 2620 my $map = $cf::MAP{$path} or next;
2299 $map->valid or next; 2621 $map->valid or next;
2300 $map->save; 2622 $map->save;
2301 } 2623 }
2302 warn "end emergency map save\n"; 2624 warn "end emergency map save\n";
2625
2626 warn "begin emergency database checkpoint\n";
2627 BDB::db_env_txn_checkpoint $DB_ENV;
2628 warn "end emergency database checkpoint\n";
2303 }; 2629 };
2304 2630
2305 warn "leave emergency perl save\n"; 2631 warn "leave emergency perl save\n";
2306} 2632}
2307 2633
2634sub post_cleanup {
2635 my ($make_core) = @_;
2636
2637 warn Carp::longmess "post_cleanup backtrace"
2638 if $make_core;
2639}
2640
2308sub reload() { 2641sub do_reload_perl() {
2309 # can/must only be called in main 2642 # can/must only be called in main
2310 if ($Coro::current != $Coro::main) { 2643 if ($Coro::current != $Coro::main) {
2311 warn "can only reload from main coroutine\n"; 2644 warn "can only reload from main coroutine";
2312 return; 2645 return;
2313 } 2646 }
2314 2647
2315 warn "reloading..."; 2648 warn "reloading...";
2316 2649
2317 warn "freezing server"; 2650 warn "entering sync_job";
2318 my $guard = freeze_mainloop; 2651
2652 cf::sync_job {
2653 cf::write_runtime; # external watchdog should not bark
2319 cf::emergency_save; 2654 cf::emergency_save;
2655 cf::write_runtime; # external watchdog should not bark
2320 2656
2321 warn "sync database to disk"; 2657 warn "syncing database to disk";
2322 cf::db_sync; 2658 BDB::db_env_txn_checkpoint $DB_ENV;
2323 IO::AIO::flush;
2324 2659
2325 eval {
2326 # if anything goes wrong in here, we should simply crash as we already saved 2660 # if anything goes wrong in here, we should simply crash as we already saved
2327 2661
2328 warn "cancel all watchers"; 2662 warn "cancelling all WF_AUTOCANCEL watchers";
2329 for (Event::all_watchers) { 2663 for (Event::all_watchers) {
2330 $_->cancel if $_->data & WF_AUTOCANCEL; 2664 $_->cancel if $_->data & WF_AUTOCANCEL;
2331 } 2665 }
2332 2666
2667 warn "flushing outstanding aio requests";
2668 for (;;) {
2669 BDB::flush;
2670 IO::AIO::flush;
2671 Coro::cede;
2672 last unless IO::AIO::nreqs || BDB::nreqs;
2673 warn "iterate...";
2674 }
2675
2676 ++$RELOAD;
2677
2333 warn "cancel all extension coros"; 2678 warn "cancelling all extension coros";
2334 $_->cancel for values %EXT_CORO; 2679 $_->cancel for values %EXT_CORO;
2335 %EXT_CORO = (); 2680 %EXT_CORO = ();
2336 2681
2337 warn "remove commands"; 2682 warn "removing commands";
2338 %COMMAND = (); 2683 %COMMAND = ();
2339 2684
2340 warn "remove ext commands"; 2685 warn "removing ext commands";
2341 %EXTCMD = (); 2686 %EXTCMD = ();
2342 2687
2343 warn "unload/nuke all extensions"; 2688 warn "unloading/nuking all extensions";
2344 for my $pkg (@EXTS) { 2689 for my $pkg (@EXTS) {
2345 warn "... unloading $pkg"; 2690 warn "... unloading $pkg";
2346 2691
2347 if (my $cb = $pkg->can ("unload")) { 2692 if (my $cb = $pkg->can ("unload")) {
2348 eval { 2693 eval {
2353 2698
2354 warn "... nuking $pkg"; 2699 warn "... nuking $pkg";
2355 Symbol::delete_package $pkg; 2700 Symbol::delete_package $pkg;
2356 } 2701 }
2357 2702
2358 warn "unload all perl modules loaded from $LIBDIR"; 2703 warn "unloading all perl modules loaded from $LIBDIR";
2359 while (my ($k, $v) = each %INC) { 2704 while (my ($k, $v) = each %INC) {
2360 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/; 2705 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
2361 2706
2362 warn "removing <$k>"; 2707 warn "... unloading $k";
2363 delete $INC{$k}; 2708 delete $INC{$k};
2364 2709
2365 $k =~ s/\.pm$//; 2710 $k =~ s/\.pm$//;
2366 $k =~ s/\//::/g; 2711 $k =~ s/\//::/g;
2367 2712
2370 } 2715 }
2371 2716
2372 Symbol::delete_package $k; 2717 Symbol::delete_package $k;
2373 } 2718 }
2374 2719
2375 warn "get rid of safe::, as good as possible"; 2720 warn "getting rid of safe::, as good as possible";
2376 Symbol::delete_package "safe::$_" 2721 Symbol::delete_package "safe::$_"
2377 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region); 2722 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
2378 2723
2379 warn "unload cf.pm \"a bit\""; 2724 warn "unloading cf.pm \"a bit\"";
2380 delete $INC{"cf.pm"}; 2725 delete $INC{"cf.pm"};
2726 delete $INC{"cf/pod.pm"};
2381 2727
2382 # don't, removes xs symbols, too, 2728 # don't, removes xs symbols, too,
2383 # and global variables created in xs 2729 # and global variables created in xs
2384 #Symbol::delete_package __PACKAGE__; 2730 #Symbol::delete_package __PACKAGE__;
2385 2731
2732 warn "unload completed, starting to reload now";
2733
2386 warn "reloading cf.pm"; 2734 warn "reloading cf.pm";
2387 require cf; 2735 require cf;
2388 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 2736 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
2389 2737
2390 warn "load config and database again"; 2738 warn "loading config and database again";
2391 cf::cfg_load; 2739 cf::cfg_load;
2392 cf::db_load;
2393 2740
2394 warn "load extensions"; 2741 warn "loading extensions";
2395 cf::load_extensions; 2742 cf::load_extensions;
2396 2743
2397 warn "reattach attachments to objects/players"; 2744 warn "reattaching attachments to objects/players";
2398 _global_reattach; 2745 _global_reattach; # objects, sockets
2399 warn "reattach attachments to maps"; 2746 warn "reattaching attachments to maps";
2400 reattach $_ for values %MAP; 2747 reattach $_ for values %MAP;
2401 }; 2748 warn "reattaching attachments to players";
2749 reattach $_ for values %PLAYER;
2402 2750
2403 if ($@) { 2751 warn "leaving sync_job";
2752
2753 1
2754 } or do {
2404 warn $@; 2755 warn $@;
2405 warn "error while reloading, exiting."; 2756 warn "error while reloading, exiting.";
2406 exit 1; 2757 exit 1;
2407 } 2758 };
2408 2759
2409 warn "reloaded"; 2760 warn "reloaded";
2410}; 2761};
2411 2762
2412############################################################################# 2763our $RELOAD_WATCHER; # used only during reload
2413 2764
2414unless ($LINK_MAP) { 2765sub reload_perl() {
2415 $LINK_MAP = cf::map::new; 2766 # doing reload synchronously and two reloads happen back-to-back,
2767 # coro crashes during coro_state_free->destroy here.
2416 2768
2417 $LINK_MAP->width (41); 2769 $RELOAD_WATCHER ||= Event->timer (
2418 $LINK_MAP->height (41); 2770 reentrant => 0,
2419 $LINK_MAP->alloc;
2420 $LINK_MAP->path ("{link}");
2421 $LINK_MAP->{path} = bless { path => "{link}" }, "cf::path";
2422 $LINK_MAP->in_memory (MAP_IN_MEMORY);
2423
2424 # dirty hack because... archetypes are not yet loaded
2425 Event->timer (
2426 after => 10, 2771 after => 0,
2772 data => WF_AUTOCANCEL,
2427 cb => sub { 2773 cb => sub {
2428 $_[0]->w->cancel; 2774 do_reload_perl;
2429 2775 undef $RELOAD_WATCHER;
2430 # provide some exits "home"
2431 my $exit = cf::object::new "exit";
2432
2433 $exit->slaying ($EMERGENCY_POSITION->[0]);
2434 $exit->stats->hp ($EMERGENCY_POSITION->[1]);
2435 $exit->stats->sp ($EMERGENCY_POSITION->[2]);
2436
2437 $LINK_MAP->insert ($exit->clone, 19, 19);
2438 $LINK_MAP->insert ($exit->clone, 19, 20);
2439 $LINK_MAP->insert ($exit->clone, 19, 21);
2440 $LINK_MAP->insert ($exit->clone, 20, 19);
2441 $LINK_MAP->insert ($exit->clone, 20, 21);
2442 $LINK_MAP->insert ($exit->clone, 21, 19);
2443 $LINK_MAP->insert ($exit->clone, 21, 20);
2444 $LINK_MAP->insert ($exit->clone, 21, 21);
2445
2446 $exit->destroy;
2447 }); 2776 },
2448 2777 );
2449 $LINK_MAP->{deny_save} = 1;
2450 $LINK_MAP->{deny_reset} = 1;
2451
2452 $cf::MAP{$LINK_MAP->path} = $LINK_MAP;
2453} 2778}
2454 2779
2455register_command "reload" => sub { 2780register_command "reload" => sub {
2456 my ($who, $arg) = @_; 2781 my ($who, $arg) = @_;
2457 2782
2458 if ($who->flag (FLAG_WIZ)) { 2783 if ($who->flag (FLAG_WIZ)) {
2459 $who->message ("start of reload.");
2460 reload;
2461 $who->message ("end of reload."); 2784 $who->message ("reloading server.");
2785 async { reload_perl };
2462 } 2786 }
2463}; 2787};
2464 2788
2465unshift @INC, $LIBDIR; 2789unshift @INC, $LIBDIR;
2790
2791my $bug_warning = 0;
2792
2793our @WAIT_FOR_TICK;
2794our @WAIT_FOR_TICK_BEGIN;
2795
2796sub wait_for_tick {
2797 return unless $TICK_WATCHER->is_active;
2798 return if $Coro::current == $Coro::main;
2799
2800 my $signal = new Coro::Signal;
2801 push @WAIT_FOR_TICK, $signal;
2802 $signal->wait;
2803}
2804
2805sub wait_for_tick_begin {
2806 return unless $TICK_WATCHER->is_active;
2807 return if $Coro::current == $Coro::main;
2808
2809 my $signal = new Coro::Signal;
2810 push @WAIT_FOR_TICK_BEGIN, $signal;
2811 $signal->wait;
2812}
2466 2813
2467$TICK_WATCHER = Event->timer ( 2814$TICK_WATCHER = Event->timer (
2468 reentrant => 0, 2815 reentrant => 0,
2816 parked => 1,
2469 prio => 0, 2817 prio => 0,
2470 at => $NEXT_TICK || $TICK, 2818 at => $NEXT_TICK || $TICK,
2471 data => WF_AUTOCANCEL, 2819 data => WF_AUTOCANCEL,
2472 cb => sub { 2820 cb => sub {
2821 if ($Coro::current != $Coro::main) {
2822 Carp::cluck "major BUG: server tick called outside of main coro, skipping it"
2823 unless ++$bug_warning > 10;
2824 return;
2825 }
2826
2827 $NOW = Event::time;
2828
2473 cf::server_tick; # one server iteration 2829 cf::server_tick; # one server iteration
2830
2474 $RUNTIME += $TICK; 2831 $RUNTIME += $TICK;
2475 $NEXT_TICK += $TICK; 2832 $NEXT_TICK += $TICK;
2476 2833
2477 $WAIT_FOR_TICK->broadcast; 2834 if ($NOW >= $NEXT_RUNTIME_WRITE) {
2478 $WAIT_FOR_TICK_ONE->send if $WAIT_FOR_TICK_ONE->awaited; 2835 $NEXT_RUNTIME_WRITE = $NOW + 10;
2836 Coro::async_pool {
2837 write_runtime
2838 or warn "ERROR: unable to write runtime file: $!";
2839 };
2840 }
2841
2842# my $AFTER = Event::time;
2843# warn $AFTER - $NOW;#d#
2479 2844
2480 # if we are delayed by four ticks or more, skip them all 2845 # if we are delayed by four ticks or more, skip them all
2481 $NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4; 2846 $NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4;
2482 2847
2483 $TICK_WATCHER->at ($NEXT_TICK); 2848 $TICK_WATCHER->at ($NEXT_TICK);
2484 $TICK_WATCHER->start; 2849 $TICK_WATCHER->start;
2850
2851 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
2852 $sig->send;
2853 }
2854 while (my $sig = shift @WAIT_FOR_TICK) {
2855 $sig->send;
2856 }
2857
2858 _post_tick;
2485 }, 2859 },
2486); 2860);
2487 2861
2862{
2488IO::AIO::max_poll_time $TICK * 0.2; 2863 BDB::max_poll_time $TICK * 0.1;
2489 2864 $BDB_POLL_WATCHER = Event->io (
2490Event->io ( 2865 reentrant => 0,
2491 fd => IO::AIO::poll_fileno, 2866 fd => BDB::poll_fileno,
2492 poll => 'r', 2867 poll => 'r',
2493 prio => 5, 2868 prio => 0,
2494 data => WF_AUTOCANCEL,
2495 cb => \&IO::AIO::poll_cb,
2496);
2497
2498Event->timer (
2499 data => WF_AUTOCANCEL, 2869 data => WF_AUTOCANCEL,
2500 after => 0, 2870 cb => \&BDB::poll_cb,
2501 interval => 10, 2871 );
2502 cb => sub { 2872 BDB::min_parallel 8;
2503 (Coro::unblock_sub { 2873
2504 write_runtime 2874 BDB::set_sync_prepare {
2505 or warn "ERROR: unable to write runtime file: $!"; 2875 my $status;
2876 my $current = $Coro::current;
2877 (
2878 sub {
2879 $status = $!;
2880 $current->ready; undef $current;
2881 },
2882 sub {
2883 Coro::schedule while defined $current;
2884 $! = $status;
2885 },
2886 )
2887 };
2888
2889 unless ($DB_ENV) {
2890 $DB_ENV = BDB::db_env_create;
2891
2892 cf::sync_job {
2893 eval {
2894 BDB::db_env_open
2895 $DB_ENV,
2896 $BDBDIR,
2897 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN
2898 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE,
2899 0666;
2900
2901 cf::cleanup "db_env_open($BDBDIR): $!" if $!;
2902
2903 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC, 1);
2904 $DB_ENV->set_lk_detect;
2905 };
2906
2907 cf::cleanup "db_env_open(db): $@" if $@;
2506 })->(); 2908 };
2507 }, 2909 }
2508); 2910}
2911
2912{
2913 IO::AIO::min_parallel 8;
2914
2915 undef $Coro::AIO::WATCHER;
2916 IO::AIO::max_poll_time $TICK * 0.1;
2917 $AIO_POLL_WATCHER = Event->io (
2918 reentrant => 0,
2919 data => WF_AUTOCANCEL,
2920 fd => IO::AIO::poll_fileno,
2921 poll => 'r',
2922 prio => 6,
2923 cb => \&IO::AIO::poll_cb,
2924 );
2925}
2926
2927# load additional modules
2928use cf::pod;
2509 2929
2510END { cf::emergency_save } 2930END { cf::emergency_save }
2511 2931
25121 29321
2513 2933

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines