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.142 by root, Fri Jan 5 21:51:42 2007 UTC vs.
Revision 1.169 by root, Sun Jan 14 01:09:46 2007 UTC

… …
15use Coro::Timer; 15use Coro::Timer;
16use Coro::Signal; 16use Coro::Signal;
17use Coro::Semaphore; 17use Coro::Semaphore;
18use Coro::AIO; 18use Coro::AIO;
19 19
20use Data::Dumper;
20use Digest::MD5; 21use Digest::MD5;
21use Fcntl; 22use Fcntl;
22use IO::AIO 2.31 (); 23use IO::AIO 2.32 ();
23use YAML::Syck (); 24use YAML::Syck ();
24use Time::HiRes; 25use Time::HiRes;
25 26
26use Event; $Event::Eval = 1; # no idea why this is required, but it is 27use Event; $Event::Eval = 1; # no idea why this is required, but it is
27 28
29sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
30
28# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode? 31# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode?
29$YAML::Syck::ImplicitUnicode = 1; 32$YAML::Syck::ImplicitUnicode = 1;
30 33
31$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority 34$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority
32 35
33sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
34
35our %COMMAND = (); 36our %COMMAND = ();
36our %COMMAND_TIME = (); 37our %COMMAND_TIME = ();
38
39our @EXTS = (); # list of extension package names
37our %EXTCMD = (); 40our %EXTCMD = ();
41our %EXT_CORO = (); # coroutines bound to extensions
42our %EXT_MAP = (); # pluggable maps
38 43
39our @EVENT; 44our @EVENT;
40our $LIBDIR = datadir . "/ext"; 45our $LIBDIR = datadir . "/ext";
41 46
42our $TICK = MAX_TIME * 1e-6; 47our $TICK = MAX_TIME * 1e-6;
43our $TICK_WATCHER; 48our $TICK_WATCHER;
49our $AIO_POLL_WATCHER;
50our $WRITE_RUNTIME_WATCHER;
44our $NEXT_TICK; 51our $NEXT_TICK;
45our $NOW; 52our $NOW;
46 53
47our %CFG; 54our %CFG;
48 55
49our $UPTIME; $UPTIME ||= time; 56our $UPTIME; $UPTIME ||= time;
50our $RUNTIME; 57our $RUNTIME;
51 58
59our %PLAYER; # all users
52our %MAP; # all maps 60our %MAP; # all maps
53our $LINK_MAP; # the special {link} map 61our $LINK_MAP; # the special {link} map, which is always available
54our $RANDOM_MAPS = cf::localdir . "/random"; 62our $RANDOM_MAPS = cf::localdir . "/random";
55our %EXT_CORO; 63
64our $WAIT_FOR_TICK; $WAIT_FOR_TICK ||= new Coro::Signal;
65our $WAIT_FOR_TICK_ONE; $WAIT_FOR_TICK_ONE ||= new Coro::Signal;
66
67# used to convert map paths into valid unix filenames by replacing / by ∕
68our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons
56 69
57binmode STDOUT; 70binmode STDOUT;
58binmode STDERR; 71binmode STDERR;
59 72
60# read virtual server time, if available 73# read virtual server time, if available
… …
68mkdir cf::localdir . "/" . cf::playerdir; 81mkdir cf::localdir . "/" . cf::playerdir;
69mkdir cf::localdir . "/" . cf::tmpdir; 82mkdir cf::localdir . "/" . cf::tmpdir;
70mkdir cf::localdir . "/" . cf::uniquedir; 83mkdir cf::localdir . "/" . cf::uniquedir;
71mkdir $RANDOM_MAPS; 84mkdir $RANDOM_MAPS;
72 85
73# a special map that is always available
74our $LINK_MAP;
75our $EMERGENCY_POSITION; 86our $EMERGENCY_POSITION;
76 87
77############################################################################# 88#############################################################################
78 89
79=head2 GLOBAL VARIABLES 90=head2 GLOBAL VARIABLES
… …
104 115
105=item %cf::CFG 116=item %cf::CFG
106 117
107Configuration for the server, loaded from C</etc/crossfire/config>, or 118Configuration for the server, loaded from C</etc/crossfire/config>, or
108from wherever your confdir points to. 119from wherever your confdir points to.
120
121=item $cf::WAIT_FOR_TICK, $cf::WAIT_FOR_TICK_ONE
122
123These are Coro::Signal objects that are C<< ->broadcast >> (WAIT_FOR_TICK)
124or C<< ->send >> (WAIT_FOR_TICK_ONE) on after normal server tick
125processing has been done. Call C<< ->wait >> on them to maximise the
126window of cpu time available, or simply to synchronise to the server tick.
109 127
110=back 128=back
111 129
112=cut 130=cut
113 131
… …
117 utf8::encode $msg; 135 utf8::encode $msg;
118 136
119 $msg .= "\n" 137 $msg .= "\n"
120 unless $msg =~ /\n$/; 138 unless $msg =~ /\n$/;
121 139
122 LOG llevError, "cfperl: $msg"; 140 LOG llevError, $msg;
123 }; 141 };
124} 142}
125 143
126@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable'; 144@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
127@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable'; 145@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';
… …
145 163
146$Event::DIED = sub { 164$Event::DIED = sub {
147 warn "error in event callback: @_"; 165 warn "error in event callback: @_";
148}; 166};
149 167
150my %ext_pkg;
151my @exts;
152my @hook;
153
154=head2 UTILITY FUNCTIONS 168=head2 UTILITY FUNCTIONS
155 169
156=over 4 170=over 4
157 171
172=item dumpval $ref
173
158=cut 174=cut
175
176sub dumpval {
177 eval {
178 local $SIG{__DIE__};
179 my $d;
180 if (1) {
181 $d = new Data::Dumper([$_[0]], ["*var"]);
182 $d->Terse(1);
183 $d->Indent(2);
184 $d->Quotekeys(0);
185 $d->Useqq(1);
186 #$d->Bless(...);
187 $d->Seen($_[1]) if @_ > 1;
188 $d = $d->Dump();
189 }
190 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge;
191 $d
192 } || "[unable to dump $_[0]: '$@']";
193}
159 194
160use JSON::Syck (); # TODO# replace by JSON::PC once working 195use JSON::Syck (); # TODO# replace by JSON::PC once working
161 196
162=item $ref = cf::from_json $json 197=item $ref = cf::from_json $json
163 198
… …
224} 259}
225 260
226sub freeze_mainloop { 261sub freeze_mainloop {
227 return unless $TICK_WATCHER->is_active; 262 return unless $TICK_WATCHER->is_active;
228 263
229 my $guard = Coro::guard { $TICK_WATCHER->start }; 264 my $guard = Coro::guard {
265 $TICK_WATCHER->start;
266 $WRITE_RUNTIME_WATCHER->start;
267 };
268 $WRITE_RUNTIME_WATCHER->stop;
230 $TICK_WATCHER->stop; 269 $TICK_WATCHER->stop;
231 $guard 270 $guard
232} 271}
233 272
234=item cf::async { BLOCK } 273=item cf::async { BLOCK }
… …
286 } 325 }
287} 326}
288 327
289=item $coro = cf::async_ext { BLOCK } 328=item $coro = cf::async_ext { BLOCK }
290 329
291Like async, but this coro is automcatially being canceled when the 330Like async, but this coro is automatically being canceled when the
292extension calling this is being unloaded. 331extension calling this is being unloaded.
293 332
294=cut 333=cut
295 334
296sub async_ext(&) { 335sub async_ext(&) {
… …
329} 368}
330 369
331=back 370=back
332 371
333=cut 372=cut
334
335#############################################################################
336
337package cf::path;
338
339sub new {
340 my ($class, $path, $base) = @_;
341
342 $path = $path->as_string if ref $path;
343
344 my $self = bless { }, $class;
345
346 # {... are special paths that are not touched
347 # ?xxx/... are special absolute paths
348 # ?random/... random maps
349 # /! non-realised random map exit
350 # /... normal maps
351 # ~/... per-player maps without a specific player (DO NOT USE)
352 # ~user/... per-player map of a specific user
353
354 if ($path =~ /^{/) {
355 # fine as it is
356 } elsif ($path =~ s{^\?random/}{}) {
357 Coro::AIO::aio_load "$cf::RANDOM_MAPS/$path.meta", my $data;
358 $self->{random} = cf::from_json $data;
359 } else {
360 if ($path =~ s{^~([^/]+)?}{}) {
361 $self->{user_rel} = 1;
362
363 if (defined $1) {
364 $self->{user} = $1;
365 } elsif ($base =~ m{^~([^/]+)/}) {
366 $self->{user} = $1;
367 } else {
368 warn "cannot resolve user-relative path without user <$path,$base>\n";
369 }
370 } elsif ($path =~ /^\//) {
371 # already absolute
372 } else {
373 $base =~ s{[^/]+/?$}{};
374 return $class->new ("$base/$path");
375 }
376
377 for ($path) {
378 redo if s{/\.?/}{/};
379 redo if s{/[^/]+/\.\./}{/};
380 }
381 }
382
383 $self->{path} = $path;
384
385 $self
386}
387
388# the name / primary key / in-game path
389sub as_string {
390 my ($self) = @_;
391
392 $self->{user_rel} ? "~$self->{user}$self->{path}"
393 : $self->{random} ? "?random/$self->{path}"
394 : $self->{path}
395}
396
397# the displayed name, this is a one way mapping
398sub visible_name {
399 my ($self) = @_;
400
401# if (my $rmp = $self->{random}) {
402# # todo: be more intelligent about this
403# "?random/$rmp->{origin_map}+$rmp->{origin_x}+$rmp->{origin_y}/$rmp->{dungeon_level}"
404# } else {
405 $self->as_string
406# }
407}
408
409# escape the /'s in the path
410sub _escaped_path {
411 # ∕ is U+2215
412 (my $path = $_[0]{path}) =~ s/\//∕/g;
413 $path
414}
415
416# the original (read-only) location
417sub load_path {
418 my ($self) = @_;
419
420 sprintf "%s/%s/%s", cf::datadir, cf::mapdir, $self->{path}
421}
422
423# the temporary/swap location
424sub save_path {
425 my ($self) = @_;
426
427 $self->{user_rel} ? sprintf "%s/%s/%s/%s", cf::localdir, cf::playerdir, $self->{user}, $self->_escaped_path
428 : $self->{random} ? sprintf "%s/%s", $RANDOM_MAPS, $self->{path}
429 : sprintf "%s/%s/%s", cf::localdir, cf::tmpdir, $self->_escaped_path
430}
431
432# the unique path, might be eq to save_path
433sub uniq_path {
434 my ($self) = @_;
435
436 $self->{user_rel} || $self->{random}
437 ? undef
438 : sprintf "%s/%s/%s", cf::localdir, cf::uniquedir, $self->_escaped_path
439}
440
441# return random map parameters, or undef
442sub random_map_params {
443 my ($self) = @_;
444
445 $self->{random}
446}
447
448# this is somewhat ugly, but style maps do need special treatment
449sub is_style_map {
450 $_[0]{path} =~ m{^/styles/}
451}
452
453package cf;
454 373
455############################################################################# 374#############################################################################
456 375
457=head2 ATTACHABLE OBJECTS 376=head2 ATTACHABLE OBJECTS
458 377
… …
764# object support 683# object support
765 684
766sub reattach { 685sub reattach {
767 # basically do the same as instantiate, without calling instantiate 686 # basically do the same as instantiate, without calling instantiate
768 my ($obj) = @_; 687 my ($obj) = @_;
688
689 bless $obj, ref $obj; # re-bless in case extensions have been reloaded
769 690
770 my $registry = $obj->registry; 691 my $registry = $obj->registry;
771 692
772 @$registry = (); 693 @$registry = ();
773 694
… …
905=cut 826=cut
906 827
907sub register_extcmd { 828sub register_extcmd {
908 my ($name, $cb) = @_; 829 my ($name, $cb) = @_;
909 830
910 my $caller = caller;
911 #warn "registering extcmd '$name' to '$caller'";
912
913 $EXTCMD{$name} = [$cb, $caller]; 831 $EXTCMD{$name} = $cb;
914} 832}
915 833
916cf::player->attach ( 834cf::player->attach (
917 on_command => sub { 835 on_command => sub {
918 my ($pl, $name, $params) = @_; 836 my ($pl, $name, $params) = @_;
… …
931 849
932 my $msg = eval { from_json $buf }; 850 my $msg = eval { from_json $buf };
933 851
934 if (ref $msg) { 852 if (ref $msg) {
935 if (my $cb = $EXTCMD{$msg->{msgtype}}) { 853 if (my $cb = $EXTCMD{$msg->{msgtype}}) {
936 if (my %reply = $cb->[0]->($pl, $msg)) { 854 if (my %reply = $cb->($pl, $msg)) {
937 $pl->ext_reply ($msg->{msgid}, %reply); 855 $pl->ext_reply ($msg->{msgid}, %reply);
938 } 856 }
939 } 857 }
940 } else { 858 } else {
941 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n"; 859 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
… …
943 861
944 cf::override; 862 cf::override;
945 }, 863 },
946); 864);
947 865
948sub register {
949 my ($base, $pkg) = @_;
950
951 #TODO
952}
953
954sub load_extension { 866sub load_extension {
955 my ($path) = @_; 867 my ($path) = @_;
956 868
957 $path =~ /([^\/\\]+)\.ext$/ or die "$path"; 869 $path =~ /([^\/\\]+)\.ext$/ or die "$path";
958 my $base = $1; 870 my $base = $1;
959 my $pkg = $1; 871 my $pkg = $1;
960 $pkg =~ s/[^[:word:]]/_/g; 872 $pkg =~ s/[^[:word:]]/_/g;
961 $pkg = "ext::$pkg"; 873 $pkg = "ext::$pkg";
962 874
963 warn "loading '$path' into '$pkg'\n"; 875 warn "... loading '$path' into '$pkg'\n";
964 876
965 open my $fh, "<:utf8", $path 877 open my $fh, "<:utf8", $path
966 or die "$path: $!"; 878 or die "$path: $!";
967 879
968 my $source = 880 my $source =
969 "package $pkg; use strict; use utf8;\n" 881 "package $pkg; use strict; use utf8;\n"
970 . "#line 1 \"$path\"\n{\n" 882 . "#line 1 \"$path\"\n{\n"
971 . (do { local $/; <$fh> }) 883 . (do { local $/; <$fh> })
972 . "\n};\n1"; 884 . "\n};\n1";
973 885
974 eval $source 886 unless (eval $source) {
975 or die $@ ? "$path: $@\n" 887 my $msg = $@ ? "$path: $@\n"
976 : "extension disabled.\n"; 888 : "extension disabled.\n";
977 889 if ($source =~ /^#!.*perl.*#.*MANDATORY/m) { # ugly match
978 push @exts, $pkg; 890 warn $@;
979 $ext_pkg{$base} = $pkg; 891 warn "mandatory extension failed to load, exiting.\n";
980 892 exit 1;
981# no strict 'refs'; 893 }
982# @{"$pkg\::ISA"} = ext::; 894 die $@;
983
984 register $base, $pkg;
985}
986
987sub unload_extension {
988 my ($pkg) = @_;
989
990 warn "removing extension $pkg\n";
991
992 # remove hooks
993 #TODO
994# for my $idx (0 .. $#PLUGIN_EVENT) {
995# delete $hook[$idx]{$pkg};
996# } 895 }
997 896
998 # remove commands 897 push @EXTS, $pkg;
999 for my $name (keys %COMMAND) {
1000 my @cb = grep $_->[0] ne $pkg, @{ $COMMAND{$name} };
1001
1002 if (@cb) {
1003 $COMMAND{$name} = \@cb;
1004 } else {
1005 delete $COMMAND{$name};
1006 }
1007 }
1008
1009 # remove extcmds
1010 for my $name (grep $EXTCMD{$_}[1] eq $pkg, keys %EXTCMD) {
1011 delete $EXTCMD{$name};
1012 }
1013
1014 if (my $cb = $pkg->can ("unload")) {
1015 eval {
1016 $cb->($pkg);
1017 1
1018 } or warn "$pkg unloaded, but with errors: $@";
1019 }
1020
1021 Symbol::delete_package $pkg;
1022} 898}
1023 899
1024sub load_extensions { 900sub load_extensions {
1025 for my $ext (<$LIBDIR/*.ext>) { 901 for my $ext (<$LIBDIR/*.ext>) {
1026 next unless -r $ext; 902 next unless -r $ext;
… …
1030 } or warn "$ext not loaded: $@"; 906 } or warn "$ext not loaded: $@";
1031 } 907 }
1032} 908}
1033 909
1034############################################################################# 910#############################################################################
1035# load/save/clean perl data associated with a map
1036
1037*cf::mapsupport::on_clean = sub {
1038 my ($map) = @_;
1039
1040 my $path = $map->tmpname;
1041 defined $path or return;
1042
1043 unlink "$path.pst";
1044};
1045
1046cf::map->attach (prio => -10000, package => cf::mapsupport::);
1047
1048#############################################################################
1049# load/save perl data associated with player->ob objects
1050
1051sub all_objects(@) {
1052 @_, map all_objects ($_->inv), @_
1053}
1054
1055# TODO: compatibility cruft, remove when no longer needed
1056cf::player->attach (
1057 on_load => sub {
1058 my ($pl, $path) = @_;
1059
1060 for my $o (all_objects $pl->ob) {
1061 if (my $value = $o->get_ob_key_value ("_perl_data")) {
1062 $o->set_ob_key_value ("_perl_data");
1063
1064 %$o = %{ Storable::thaw pack "H*", $value };
1065 }
1066 }
1067 },
1068);
1069
1070#############################################################################
1071 911
1072=head2 CORE EXTENSIONS 912=head2 CORE EXTENSIONS
1073 913
1074Functions and methods that extend core crossfire objects. 914Functions and methods that extend core crossfire objects.
1075 915
916=cut
917
918package cf::player;
919
920use Coro::AIO;
921
1076=head3 cf::player 922=head3 cf::player
1077 923
1078=over 4 924=over 4
1079 925
1080=item cf::player::exists $login 926=item cf::player::find $login
1081 927
1082Returns true when the given account exists. 928Returns the given player object, loading it if necessary (might block).
1083 929
1084=cut 930=cut
1085 931
1086sub cf::player::exists($) { 932sub playerdir($) {
1087 cf::player::find $_[0] 933 cf::localdir
1088 or -f sprintf "%s/%s/%s/%s.pl", cf::localdir, cf::playerdir, ($_[0]) x 2; 934 . "/"
935 . cf::playerdir
936 . "/"
937 . (ref $_[0] ? $_[0]->ob->name : $_[0])
938}
939
940sub path($) {
941 my $login = ref $_[0] ? $_[0]->ob->name : $_[0];
942
943 (playerdir $login) . "/$login.pl"
944}
945
946sub find_active($) {
947 $cf::PLAYER{$_[0]}
948 and $cf::PLAYER{$_[0]}->active
949 and $cf::PLAYER{$_[0]}
950}
951
952sub exists($) {
953 my ($login) = @_;
954
955 $cf::PLAYER{$login}
956 or cf::sync_job { !aio_stat $login }
957}
958
959sub find($) {
960 return $cf::PLAYER{$_[0]} || do {
961 my $login = $_[0];
962
963 my $guard = cf::lock_acquire "user_find:$login";
964
965 $cf::PLAYER{$_[0]} || do {
966 my $pl = load_pl path $login
967 or return;
968 $cf::PLAYER{$login} = $pl
969 }
970 }
971}
972
973sub save($) {
974 my ($pl) = @_;
975
976 return if $pl->{deny_save};
977
978 my $path = path $pl;
979 my $guard = cf::lock_acquire "user_save:$path";
980
981 return if $pl->{deny_save};
982
983 aio_mkdir playerdir $pl, 0770;
984 $pl->{last_save} = $cf::RUNTIME;
985
986 $pl->save_pl ($path);
987 Coro::cede;
988}
989
990sub new($) {
991 my ($login) = @_;
992
993 my $self = create;
994
995 $self->ob->name ($login);
996 $self->{deny_save} = 1;
997
998 $cf::PLAYER{$login} = $self;
999
1000 $self
1001}
1002
1003=item $pl->quit_character
1004
1005Nukes the player without looking back. If logged in, the connection will
1006be destroyed. May block for a long time.
1007
1008=cut
1009
1010sub quit_character {
1011 my ($pl) = @_;
1012
1013 $pl->{deny_save} = 1;
1014 $pl->password ("*"); # this should lock out the player until we nuked the dir
1015
1016 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active;
1017 $pl->deactivate;
1018 $pl->invoke (cf::EVENT_PLAYER_QUIT);
1019 $pl->ns->destroy if $pl->ns;
1020
1021 my $path = playerdir $pl;
1022 my $temp = "$path~$cf::RUNTIME~deleting~";
1023 aio_rename $path, $temp;
1024 delete $cf::PLAYER{$pl->ob->name};
1025 $pl->destroy;
1026 IO::AIO::aio_rmtree $temp;
1027}
1028
1029=item cf::player::list_logins
1030
1031Returns am arrayref of all valid playernames in the system, can take a
1032while and may block, so not sync_job-capable, ever.
1033
1034=cut
1035
1036sub list_logins {
1037 my $dirs = aio_readdir cf::localdir . "/" . cf::playerdir
1038 or return [];
1039
1040 my @logins;
1041
1042 for my $login (@$dirs) {
1043 my $fh = aio_open path $login, Fcntl::O_RDONLY, 0 or next;
1044 aio_read $fh, 0, 512, my $buf, 0 or next;
1045 $buf !~ /^password -------------$/m or next; # official not-valid tag
1046
1047 utf8::decode $login;
1048 push @logins, $login;
1049 }
1050
1051 \@logins
1052}
1053
1054=item $player->maps
1055
1056Returns an arrayref of map paths that are private for this
1057player. May block.
1058
1059=cut
1060
1061sub maps($) {
1062 my ($pl) = @_;
1063
1064 my $files = aio_readdir playerdir $pl
1065 or return;
1066
1067 my @paths;
1068
1069 for (@$files) {
1070 utf8::decode $_;
1071 next if /\.(?:pl|pst)$/;
1072 next unless /^$PATH_SEP/o;
1073
1074 s/\.map$//;
1075 push @paths, "~" . $pl->ob->name . "/" . $_;
1076 }
1077
1078 \@paths
1089} 1079}
1090 1080
1091=item $player->ext_reply ($msgid, $msgtype, %msg) 1081=item $player->ext_reply ($msgid, $msgtype, %msg)
1092 1082
1093Sends an ext reply to the player. 1083Sends an ext reply to the player.
1094 1084
1095=cut 1085=cut
1096 1086
1097sub cf::player::ext_reply($$$%) { 1087sub ext_reply($$$%) {
1098 my ($self, $id, %msg) = @_; 1088 my ($self, $id, %msg) = @_;
1099 1089
1100 $msg{msgid} = $id; 1090 $msg{msgid} = $id;
1101 1091
1102 $self->send ("ext " . to_json \%msg); 1092 $self->send ("ext " . cf::to_json \%msg);
1103} 1093}
1094
1095package cf;
1104 1096
1105=back 1097=back
1106 1098
1107 1099
1108=head3 cf::map 1100=head3 cf::map
… …
1114package cf::map; 1106package cf::map;
1115 1107
1116use Fcntl; 1108use Fcntl;
1117use Coro::AIO; 1109use Coro::AIO;
1118 1110
1111use overload
1112 '""' => \&as_string;
1113
1119our $MAX_RESET = 3600; 1114our $MAX_RESET = 3600;
1120our $DEFAULT_RESET = 3000; 1115our $DEFAULT_RESET = 3000;
1121 1116
1122sub generate_random_map { 1117sub generate_random_map {
1123 my ($path, $rmp) = @_; 1118 my ($self, $rmp) = @_;
1124 1119
1125 # mit "rum" bekleckern, nicht 1120 # mit "rum" bekleckern, nicht
1126 cf::map::_create_random_map 1121 $self->_create_random_map (
1127 $path,
1128 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle}, 1122 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle},
1129 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle}, 1123 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle},
1130 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map}, 1124 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map},
1131 $rmp->{exit_on_final_map}, 1125 $rmp->{exit_on_final_map},
1132 $rmp->{xsize}, $rmp->{ysize}, 1126 $rmp->{xsize}, $rmp->{ysize},
1133 $rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3}, 1127 $rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3},
1134 $rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase}, 1128 $rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase},
1135 $rmp->{dungeon_level}, $rmp->{dungeon_depth}, $rmp->{decoroptions}, $rmp->{orientation}, 1129 $rmp->{dungeon_level}, $rmp->{dungeon_depth}, $rmp->{decoroptions}, $rmp->{orientation},
1136 $rmp->{origin_y}, $rmp->{origin_x}, $rmp->{random_seed}, $rmp->{total_map_hp}, 1130 $rmp->{origin_y}, $rmp->{origin_x}, $rmp->{random_seed}, $rmp->{total_map_hp},
1137 $rmp->{map_layout_style}, $rmp->{treasureoptions}, $rmp->{symmetry_used}, 1131 $rmp->{map_layout_style}, $rmp->{treasureoptions}, $rmp->{symmetry_used},
1138 (cf::region::find $rmp->{region}) 1132 (cf::region::find $rmp->{region}), $rmp->{custom}
1133 )
1134}
1135
1136sub register {
1137 my (undef, $regex) = @_;
1138 my $pkg = caller;
1139
1140 no strict;
1141 push @{"$pkg\::ISA"}, __PACKAGE__;
1142
1143 $EXT_MAP{$pkg} = qr<$regex>;
1144}
1145
1146# also paths starting with '/'
1147$EXT_MAP{"cf::map"} = qr{^(?=/)};
1148
1149sub normalise {
1150 my ($path, $base) = @_;
1151
1152 # map plan:
1153 #
1154 # /! non-realised random map exit (special hack!)
1155 # {... are special paths that are not being touched
1156 # ?xxx/... are special absolute paths
1157 # ?random/... random maps
1158 # /... normal maps
1159 # ~user/... per-player map of a specific user
1160
1161 $path =~ s/$PATH_SEP/\//go;
1162
1163 # treat it as relative path if it starts with
1164 # something that looks reasonable
1165 if ($path =~ m{^(?:\./|\.\./|\w)}) {
1166 $base or Carp::carp "normalise called with relative path and no base: '$path'";
1167
1168 $base =~ s{[^/]+/?$}{};
1169 $path = "$base/$path";
1170 }
1171
1172 for ($path) {
1173 redo if s{//}{/};
1174 redo if s{/\.?/}{/};
1175 redo if s{/[^/]+/\.\./}{/};
1176 }
1177
1178 $path
1179}
1180
1181sub new_from_path {
1182 my (undef, $path, $base) = @_;
1183
1184 return $path if UNIVERSAL::isa $path, "cf::map"; # already a map object
1185
1186 $path = normalise $path, $base;
1187
1188 for my $pkg (keys %EXT_MAP) {
1189 if ($path =~ $EXT_MAP{$pkg}) {
1190 my $self = bless cf::map::new, $pkg;
1191 $self->{path} = $path; $self->path ($path);
1192 $self->init; # pass $1 etc.
1193 return $self;
1194 }
1195 }
1196
1197 Carp::carp "unable to resolve path '$path'.";
1198 ()
1199}
1200
1201sub init {
1202 my ($self) = @_;
1203
1204 $self
1205}
1206
1207sub as_string {
1208 my ($self) = @_;
1209
1210 "$self->{path}"
1211}
1212
1213# the displayed name, this is a one way mapping
1214sub visible_name {
1215 &as_string
1216}
1217
1218# the original (read-only) location
1219sub load_path {
1220 my ($self) = @_;
1221
1222 sprintf "%s/%s/%s", cf::datadir, cf::mapdir, $self->{path}
1223}
1224
1225# the temporary/swap location
1226sub save_path {
1227 my ($self) = @_;
1228
1229 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g;
1230 sprintf "%s/%s/%s", cf::localdir, cf::tmpdir, $path
1231}
1232
1233# the unique path, undef == no special unique path
1234sub uniq_path {
1235 my ($self) = @_;
1236
1237 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g;
1238 sprintf "%s/%s/%s", cf::localdir, cf::uniquedir, $path
1139} 1239}
1140 1240
1141# and all this just because we cannot iterate over 1241# and all this just because we cannot iterate over
1142# all maps in C++... 1242# all maps in C++...
1143sub change_all_map_light { 1243sub change_all_map_light {
… …
1145 1245
1146 $_->change_map_light ($change) 1246 $_->change_map_light ($change)
1147 for grep $_->outdoor, values %cf::MAP; 1247 for grep $_->outdoor, values %cf::MAP;
1148} 1248}
1149 1249
1250sub unlink_save {
1251 my ($self) = @_;
1252
1253 utf8::encode (my $save = $self->save_path);
1254 IO::AIO::aioreq_pri 4; IO::AIO::aio_unlink $save;
1255 IO::AIO::aioreq_pri 4; IO::AIO::aio_unlink "$save.pst";
1256}
1257
1150sub try_load_header($) { 1258sub load_header_from($) {
1151 my ($path) = @_; 1259 my ($self, $path) = @_;
1152 1260
1153 utf8::encode $path; 1261 utf8::encode $path;
1154 aio_open $path, O_RDONLY, 0 1262 aio_open $path, O_RDONLY, 0
1155 or return; 1263 or return;
1156 1264
1157 my $map = cf::map::new 1265 $self->_load_header ($path)
1158 or return; 1266 or return;
1159 1267
1160 # for better error messages only, will be overwritten 1268 $self->{load_path} = $path;
1161 $map->path ($path);
1162 1269
1163 $map->load_header ($path) 1270 1
1271}
1272
1273sub load_orig {
1274 my ($self) = @_;
1275
1276 $self->load_header_from ($self->load_path)
1277}
1278
1279sub load_temp {
1280 my ($self) = @_;
1281
1282 $self->load_header_from ($self->save_path)
1283}
1284
1285sub load_header {
1286 my ($self) = @_;
1287
1288 if ($self->load_temp) {
1289 $self->last_access ((delete $self->{last_access})
1290 || $cf::RUNTIME); #d#
1291 # safety
1292 $self->{instantiate_time} = $cf::RUNTIME
1293 if $self->{instantiate_time} > $cf::RUNTIME;
1294 } else {
1295 $self->load_orig
1164 or return; 1296 or return;
1165 1297
1166 $map->{load_path} = $path; 1298 $self->{load_original} = 1;
1299 $self->{instantiate_time} = $cf::RUNTIME;
1300 $self->last_access ($cf::RUNTIME);
1301 $self->instantiate;
1302 }
1167 1303
1168 $map 1304 1
1169} 1305}
1170 1306
1171sub find; 1307sub find;
1172sub find { 1308sub find {
1173 my ($path, $origin) = @_; 1309 my ($path, $origin) = @_;
1174 1310
1175 #warn "find<$path,$origin>\n";#d#
1176
1177 $path = new cf::path $path, $origin && $origin->path; 1311 $path = normalise $path, $origin && $origin->path;
1178 my $key = $path->as_string;
1179 1312
1180 cf::lock_wait "map_find:$key"; 1313 cf::lock_wait "map_find:$path";
1181 1314
1182 $cf::MAP{$key} || do { 1315 $cf::MAP{$path} || do {
1183 my $guard = cf::lock_acquire "map_find:$key"; 1316 my $guard = cf::lock_acquire "map_find:$path";
1184 1317 my $map = new_from_path cf::map $path
1185 # do it the slow way
1186 my $map = try_load_header $path->save_path;
1187
1188 Coro::cede;
1189
1190 if ($map) {
1191 $map->last_access ((delete $map->{last_access})
1192 || $cf::RUNTIME); #d#
1193 # safety
1194 $map->{instantiate_time} = $cf::RUNTIME
1195 if $map->{instantiate_time} > $cf::RUNTIME;
1196 } else {
1197 if (my $rmp = $path->random_map_params) {
1198 $map = generate_random_map $key, $rmp;
1199 } else {
1200 $map = try_load_header $path->load_path;
1201 }
1202
1203 $map or return; 1318 or return;
1204 1319
1205 $map->{load_original} = 1;
1206 $map->{instantiate_time} = $cf::RUNTIME;
1207 $map->last_access ($cf::RUNTIME);
1208 $map->instantiate;
1209
1210 # per-player maps become, after loading, normal maps
1211 $map->per_player (0) if $path->{user_rel};
1212 }
1213
1214 $map->path ($key);
1215 $map->{path} = $path;
1216 $map->{last_save} = $cf::RUNTIME; 1320 $map->{last_save} = $cf::RUNTIME;
1217 1321
1218 Coro::cede; 1322 $map->load_header
1323 or return;
1219 1324
1220 if ($map->should_reset) { 1325 if ($map->should_reset) {
1221 $map->reset; 1326 $map->reset;
1222 undef $guard; 1327 undef $guard;
1223 $map = find $path 1328 $map = find $path
1224 or return; 1329 or return;
1225 } 1330 }
1226 1331
1227 $cf::MAP{$key} = $map 1332 $cf::MAP{$path} = $map
1228 } 1333 }
1229} 1334}
1230 1335
1231sub load { 1336sub load {
1232 my ($self) = @_; 1337 my ($self) = @_;
1233 1338
1234 my $path = $self->{path}; 1339 my $path = $self->{path};
1235 my $guard = cf::lock_acquire "map_load:" . $path->as_string; 1340 my $guard = cf::lock_acquire "map_load:$path";
1236 1341
1237 return if $self->in_memory != cf::MAP_SWAPPED; 1342 return if $self->in_memory != cf::MAP_SWAPPED;
1238 1343
1239 $self->in_memory (cf::MAP_LOADING); 1344 $self->in_memory (cf::MAP_LOADING);
1240 1345
1241 $self->alloc; 1346 $self->alloc;
1242 $self->load_objects ($self->{load_path}, 1) 1347 $self->_load_objects ($self->{load_path}, 1)
1243 or return; 1348 or return;
1244 1349
1245 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1) 1350 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1)
1246 if delete $self->{load_original}; 1351 if delete $self->{load_original};
1247 1352
1248 if (my $uniq = $path->uniq_path) { 1353 if (my $uniq = $self->uniq_path) {
1249 utf8::encode $uniq; 1354 utf8::encode $uniq;
1250 if (aio_open $uniq, O_RDONLY, 0) { 1355 if (aio_open $uniq, O_RDONLY, 0) {
1251 $self->clear_unique_items; 1356 $self->clear_unique_items;
1252 $self->load_objects ($uniq, 0); 1357 $self->_load_objects ($uniq, 0);
1253 } 1358 }
1254 } 1359 }
1255 1360
1256 Coro::cede; 1361 Coro::cede;
1257 1362
1258 # now do the right thing for maps 1363 # now do the right thing for maps
1259 $self->link_multipart_objects; 1364 $self->link_multipart_objects;
1260 1365
1261 if ($self->{path}->is_style_map) { 1366 unless ($self->{deny_activate}) {
1262 $self->{deny_save} = 1; 1367 $self->decay_objects;
1263 $self->{deny_reset} = 1;
1264 } else {
1265 $self->fix_auto_apply; 1368 $self->fix_auto_apply;
1266 $self->decay_objects;
1267 $self->update_buttons; 1369 $self->update_buttons;
1370 Coro::cede;
1268 $self->set_darkness_map; 1371 $self->set_darkness_map;
1269 $self->difficulty ($self->estimate_difficulty) 1372 $self->difficulty ($self->estimate_difficulty)
1270 unless $self->difficulty; 1373 unless $self->difficulty;
1374 Coro::cede;
1271 $self->activate; 1375 $self->activate;
1272 } 1376 }
1273 1377
1274 Coro::cede;
1275
1276 $self->in_memory (cf::MAP_IN_MEMORY); 1378 $self->in_memory (cf::MAP_IN_MEMORY);
1379}
1380
1381sub customise_for {
1382 my ($self, $ob) = @_;
1383
1384 return find "~" . $ob->name . "/" . $self->{path}
1385 if $self->per_player;
1386
1387 $self
1388}
1389
1390# find and load all maps in the 3x3 area around a map
1391sub load_diag {
1392 my ($map) = @_;
1393
1394 my @diag; # diagonal neighbours
1395
1396 for (0 .. 3) {
1397 my $neigh = $map->tile_path ($_)
1398 or next;
1399 $neigh = find $neigh, $map
1400 or next;
1401 $neigh->load;
1402
1403 push @diag, [$neigh->tile_path (($_ + 3) % 4), $neigh],
1404 [$neigh->tile_path (($_ + 1) % 4), $neigh];
1405 }
1406
1407 for (@diag) {
1408 my $neigh = find @$_
1409 or next;
1410 $neigh->load;
1411 }
1277} 1412}
1278 1413
1279sub find_sync { 1414sub find_sync {
1280 my ($path, $origin) = @_; 1415 my ($path, $origin) = @_;
1281 1416
1282 cf::sync_job { cf::map::find $path, $origin } 1417 cf::sync_job { find $path, $origin }
1283} 1418}
1284 1419
1285sub do_load_sync { 1420sub do_load_sync {
1286 my ($map) = @_; 1421 my ($map) = @_;
1287 1422
1288 cf::sync_job { $map->load }; 1423 cf::sync_job { $map->load };
1289} 1424}
1290 1425
1426our %MAP_PREFETCH;
1427our $MAP_PREFETCHER = Coro::async {
1428 while () {
1429 for my $path (keys %MAP_PREFETCH) {
1430 my $map = find $path
1431 or next;
1432 $map->load;
1433
1434 delete $MAP_PREFETCH{$path};
1435 }
1436 Coro::schedule;
1437 }
1438};
1439
1440sub find_async {
1441 my ($path, $origin) = @_;
1442
1443 $path = normalise $path, $origin && $origin->{path};
1444
1445 if (my $map = $cf::MAP{$path}) {
1446 return $map if $map->in_memory == cf::MAP_IN_MEMORY;
1447 }
1448
1449 $MAP_PREFETCH{$path} = 0;
1450 $MAP_PREFETCHER->ready;
1451
1452 ()
1453}
1454
1291sub save { 1455sub save {
1292 my ($self) = @_; 1456 my ($self) = @_;
1293 1457
1294 my $lock = cf::lock_acquire "map_data:" . $self->path; 1458 my $lock = cf::lock_acquire "map_data:" . $self->path;
1295 1459
1296 $self->{last_save} = $cf::RUNTIME; 1460 $self->{last_save} = $cf::RUNTIME;
1297 1461
1298 return unless $self->dirty; 1462 return unless $self->dirty;
1299 1463
1300 my $save = $self->{path}->save_path; utf8::encode $save; 1464 my $save = $self->save_path; utf8::encode $save;
1301 my $uniq = $self->{path}->uniq_path; utf8::encode $uniq; 1465 my $uniq = $self->uniq_path; utf8::encode $uniq;
1302 1466
1303 $self->{load_path} = $save; 1467 $self->{load_path} = $save;
1304 1468
1305 return if $self->{deny_save}; 1469 return if $self->{deny_save};
1306 1470
1307 local $self->{last_access} = $self->last_access;#d# 1471 local $self->{last_access} = $self->last_access;#d#
1308 1472
1473 cf::async {
1474 $_->contr->save for $self->players;
1475 };
1476
1309 if ($uniq) { 1477 if ($uniq) {
1310 $self->save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS); 1478 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS);
1311 $self->save_objects ($uniq, cf::IO_UNIQUES); 1479 $self->_save_objects ($uniq, cf::IO_UNIQUES);
1312 } else { 1480 } else {
1313 $self->save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES); 1481 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES);
1314 } 1482 }
1315} 1483}
1316 1484
1317sub swap_out { 1485sub swap_out {
1318 my ($self) = @_; 1486 my ($self) = @_;
… …
1332 1500
1333sub reset_at { 1501sub reset_at {
1334 my ($self) = @_; 1502 my ($self) = @_;
1335 1503
1336 # TODO: safety, remove and allow resettable per-player maps 1504 # TODO: safety, remove and allow resettable per-player maps
1337 return 1e99 if $self->{path}{user_rel}; 1505 return 1e99 if $self->isa ("ext::map_per_player");#d#
1338 return 1e99 if $self->{deny_reset}; 1506 return 1e99 if $self->{deny_reset};
1339 1507
1340 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access; 1508 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
1341 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET; 1509 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET;
1342 1510
… …
1347 my ($self) = @_; 1515 my ($self) = @_;
1348 1516
1349 $self->reset_at <= $cf::RUNTIME 1517 $self->reset_at <= $cf::RUNTIME
1350} 1518}
1351 1519
1352sub unlink_save {
1353 my ($self) = @_;
1354
1355 utf8::encode (my $save = $self->{path}->save_path);
1356 aioreq_pri 3; IO::AIO::aio_unlink $save;
1357 aioreq_pri 3; IO::AIO::aio_unlink "$save.pst";
1358}
1359
1360sub rename { 1520sub rename {
1361 my ($self, $new_path) = @_; 1521 my ($self, $new_path) = @_;
1362 1522
1523 normalise $new_path;
1524
1363 $self->unlink_save; 1525 $self->unlink_save;
1364 1526
1365 delete $cf::MAP{$self->path}; 1527 delete $cf::MAP{$self->path};
1366 $self->{path} = new cf::path $new_path; 1528 $self->{path} = $new_path; $self->path ($self->{path});
1367 $self->path ($self->{path}->as_string);
1368 $cf::MAP{$self->path} = $self; 1529 $cf::MAP{$self->path} = $self;
1369 1530
1370 $self->save; 1531 $self->save;
1371} 1532}
1372 1533
1373sub reset { 1534sub reset {
1374 my ($self) = @_; 1535 my ($self) = @_;
1375 1536
1376 my $lock = cf::lock_acquire "map_data:" . $self->path; 1537 my $lock = cf::lock_acquire "map_data:$self->{path}";
1377 1538
1378 return if $self->players; 1539 return if $self->players;
1379 return if $self->{path}{user_rel};#d# 1540 return if $self->isa ("ext::map_per_player");#d#
1380 1541
1381 warn "resetting map ", $self->path;#d# 1542 warn "resetting map ", $self->path;#d#
1382 1543
1383 delete $cf::MAP{$self->path}; 1544 delete $cf::MAP{$self->path};
1545
1546 $self->in_memory (cf::MAP_SWAPPED);
1547 $self->clear;
1384 1548
1385 $_->clear_links_to ($self) for values %cf::MAP; 1549 $_->clear_links_to ($self) for values %cf::MAP;
1386 1550
1387 $self->unlink_save; 1551 $self->unlink_save;
1388 $self->destroy; 1552 $self->destroy;
… …
1397 $self->reset_timeout (1); 1561 $self->reset_timeout (1);
1398 $self->rename ("{nuke}/" . ($nuke_counter++)); 1562 $self->rename ("{nuke}/" . ($nuke_counter++));
1399 $self->reset; # polite request, might not happen 1563 $self->reset; # polite request, might not happen
1400} 1564}
1401 1565
1402sub customise_for { 1566=item cf::map::unique_maps
1403 my ($map, $ob) = @_;
1404 1567
1405 if ($map->per_player) { 1568Returns an arrayref of paths of all shared maps that have
1406 return cf::map::find "~" . $ob->name . "/" . $map->{path}{path}; 1569instantiated unique items. May block.
1407 }
1408 1570
1409 $map 1571=cut
1410}
1411 1572
1412sub emergency_save { 1573sub unique_maps() {
1413 my $freeze_guard = cf::freeze_mainloop; 1574 my $files = aio_readdir cf::localdir . "/" . cf::uniquedir
1575 or return;
1414 1576
1415 warn "enter emergency map save\n"; 1577 my @paths;
1416 1578
1417 cf::sync_job { 1579 for (@$files) {
1418 warn "begin emergency map save\n"; 1580 utf8::decode $_;
1419 $_->save for values %cf::MAP; 1581 next if /\.pst$/;
1582 next unless /^$PATH_SEP/o;
1583
1584 s/\.map$//;
1585 push @paths, $_;
1420 }; 1586 }
1421 1587
1422 warn "end emergency map save\n"; 1588 \@paths
1423} 1589}
1424 1590
1425package cf; 1591package cf;
1426 1592
1427=back 1593=back
1428 1594
1595=head3 cf::object
1596
1597=cut
1598
1599package cf::object;
1600
1601=over 4
1602
1603=item $ob->inv_recursive
1604
1605Returns the inventory of the object _and_ their inventories, recursively.
1606
1607=cut
1608
1609sub inv_recursive_;
1610sub inv_recursive_ {
1611 map { $_, inv_recursive_ $_->inv } @_
1612}
1613
1614sub inv_recursive {
1615 inv_recursive_ inv $_[0]
1616}
1617
1618package cf;
1619
1620=back
1429 1621
1430=head3 cf::object::player 1622=head3 cf::object::player
1431 1623
1432=over 4 1624=over 4
1433 1625
… …
1473 1665
1474=item $player_object->enter_link 1666=item $player_object->enter_link
1475 1667
1476Freezes the player and moves him/her to a special map (C<{link}>). 1668Freezes the player and moves him/her to a special map (C<{link}>).
1477 1669
1478The player should be reaosnably safe there for short amounts of time. You 1670The player should be reasonably safe there for short amounts of time. You
1479I<MUST> call C<leave_link> as soon as possible, though. 1671I<MUST> call C<leave_link> as soon as possible, though.
1480 1672
1673Will never block.
1674
1481=item $player_object->leave_link ($map, $x, $y) 1675=item $player_object->leave_link ($map, $x, $y)
1482 1676
1483Moves the player out of the specila link map onto the given map. If the 1677Moves the player out of the special C<{link}> map onto the specified
1484map is not valid (or omitted), the player will be moved back to the 1678map. If the map is not valid (or omitted), the player will be moved back
1485location he/she was before the call to C<enter_link>, or, if that fails, 1679to the location he/she was before the call to C<enter_link>, or, if that
1486to the emergency map position. 1680fails, to the emergency map position.
1487 1681
1488Might block. 1682Might block.
1489 1683
1490=cut 1684=cut
1685
1686sub link_map {
1687 unless ($LINK_MAP) {
1688 $LINK_MAP = cf::map::find "{link}"
1689 or do { warn "FATAL: unable to provide {link} map, exiting."; exit 1 };
1690 $LINK_MAP->load;
1691 }
1692
1693 $LINK_MAP
1694}
1491 1695
1492sub cf::object::player::enter_link { 1696sub cf::object::player::enter_link {
1493 my ($self) = @_; 1697 my ($self) = @_;
1494 1698
1495 $self->deactivate_recursive; 1699 $self->deactivate_recursive;
1496 1700
1497 return if $self->map == $LINK_MAP; 1701 return if UNIVERSAL::isa $self->map, "ext::map_link";
1498 1702
1499 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y] 1703 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y]
1500 if $self->map; 1704 if $self->map;
1501 1705
1502 $self->enter_map ($LINK_MAP, 20, 20); 1706 $self->enter_map ($LINK_MAP || link_map, 20, 20);
1503} 1707}
1504 1708
1505sub cf::object::player::leave_link { 1709sub cf::object::player::leave_link {
1506 my ($self, $map, $x, $y) = @_; 1710 my ($self, $map, $x, $y) = @_;
1507 1711
… …
1525 # use -1 or undef as default coordinates, not 0, 0 1729 # use -1 or undef as default coordinates, not 0, 0
1526 ($x, $y) = ($map->enter_x, $map->enter_y) 1730 ($x, $y) = ($map->enter_x, $map->enter_y)
1527 if $x <=0 && $y <= 0; 1731 if $x <=0 && $y <= 0;
1528 1732
1529 $map->load; 1733 $map->load;
1734 $map->load_diag;
1530 1735
1736 return unless $self->contr->active;
1531 $self->activate_recursive; 1737 $self->activate_recursive;
1532 $self->enter_map ($map, $x, $y); 1738 $self->enter_map ($map, $x, $y);
1533} 1739}
1534 1740
1535cf::player->attach ( 1741cf::player->attach (
… …
1547 my ($pl) = @_; 1753 my ($pl) = @_;
1548 1754
1549 # try to abort aborted map switching on player login :) 1755 # try to abort aborted map switching on player login :)
1550 # should happen only on crashes 1756 # should happen only on crashes
1551 if ($pl->ob->{_link_pos}) { 1757 if ($pl->ob->{_link_pos}) {
1552
1553 $pl->ob->enter_link; 1758 $pl->ob->enter_link;
1554 (async { 1759 (async {
1555 # we need this sleep as the login has a concurrent enter_exit running 1760 # we need this sleep as the login has a concurrent enter_exit running
1556 # and this sleep increases chances of the player not ending up in scorn 1761 # and this sleep increases chances of the player not ending up in scorn
1557 $pl->ob->reply (undef, 1762 $pl->ob->reply (undef,
… …
1573 my ($self, $path, $x, $y) = @_; 1778 my ($self, $path, $x, $y) = @_;
1574 1779
1575 $self->enter_link; 1780 $self->enter_link;
1576 1781
1577 (async { 1782 (async {
1578 $path = new cf::path $path;
1579
1580 my $map = cf::map::find $path->as_string; 1783 my $map = cf::map::find $path;
1581 $map = $map->customise_for ($self) if $map; 1784 $map = $map->customise_for ($self) if $map;
1582 1785
1583# warn "entering ", $map->path, " at ($x, $y)\n" 1786# warn "entering ", $map->path, " at ($x, $y)\n"
1584# if $map; 1787# if $map;
1585 1788
1586 $map or $self->message ("The exit is closed", cf::NDI_UNIQUE | cf::NDI_RED); 1789 $map or $self->message ("The exit to '" . ($path->visible_name) . "' is closed", cf::NDI_UNIQUE | cf::NDI_RED);
1587 1790
1588 $self->leave_link ($map, $x, $y); 1791 $self->leave_link ($map, $x, $y);
1589 })->prio (1); 1792 })->prio (1);
1590} 1793}
1591 1794
… …
1650 $self->deactivate_recursive; # just to be sure 1853 $self->deactivate_recursive; # just to be sure
1651 unless (eval { 1854 unless (eval {
1652 prepare_random_map $exit 1855 prepare_random_map $exit
1653 if $exit->slaying eq "/!"; 1856 if $exit->slaying eq "/!";
1654 1857
1655 my $path = new cf::path $exit->slaying, $exit->map && $exit->map->path; 1858 my $path = new_from_path cf::map $exit->slaying, $exit->map && $exit->map->path;
1656 $self->goto ($path, $exit->stats->hp, $exit->stats->sp); 1859 $self->goto ($path, $exit->stats->hp, $exit->stats->sp);
1657 1860
1658 1; 1861 1;
1659 }) { 1862 }) {
1660 $self->message ("Something went wrong deep within the crossfire server. " 1863 $self->message ("Something went wrong deep within the crossfire server. "
1661 . "I'll try to bring you back to the map you were before. " 1864 . "I'll try to bring you back to the map you were before. "
1662 . "Please report this to the dungeon master", 1865 . "Please report this to the dungeon master!",
1663 cf::NDI_UNIQUE | cf::NDI_RED); 1866 cf::NDI_UNIQUE | cf::NDI_RED);
1664 1867
1665 warn "ERROR in enter_exit: $@"; 1868 warn "ERROR in enter_exit: $@";
1666 $self->leave_link; 1869 $self->leave_link;
1667 } 1870 }
… …
1999 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset}; 2202 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset};
2000 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset}; 2203 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset};
2001 2204
2002 if (exists $CFG{mlockall}) { 2205 if (exists $CFG{mlockall}) {
2003 eval { 2206 eval {
2004 $CFG{mlockall} ? &mlockall : &munlockall 2207 $CFG{mlockall} ? eval "mlockall()" : eval "munlockall()"
2005 and die "WARNING: m(un)lockall failed: $!\n"; 2208 and die "WARNING: m(un)lockall failed: $!\n";
2006 }; 2209 };
2007 warn $@ if $@; 2210 warn $@ if $@;
2008 } 2211 }
2009} 2212}
… …
2020 load_extensions; 2223 load_extensions;
2021 Event::loop; 2224 Event::loop;
2022} 2225}
2023 2226
2024############################################################################# 2227#############################################################################
2025# initialisation 2228# initialisation and cleanup
2229
2230# install some emergency cleanup handlers
2231BEGIN {
2232 for my $signal (qw(INT HUP TERM)) {
2233 Event->signal (
2234 data => WF_AUTOCANCEL,
2235 signal => $signal,
2236 cb => sub {
2237 cf::cleanup "SIG$signal";
2238 },
2239 );
2240 }
2241}
2242
2243sub emergency_save() {
2244 my $freeze_guard = cf::freeze_mainloop;
2245
2246 warn "enter emergency perl save\n";
2247
2248 cf::sync_job {
2249 # use a peculiar iteration method to avoid tripping on perl
2250 # refcount bugs in for. also avoids problems with players
2251 # and maps saved/destroyed asynchronously.
2252 warn "begin emergency player save\n";
2253 for my $login (keys %cf::PLAYER) {
2254 my $pl = $cf::PLAYER{$login} or next;
2255 $pl->valid or next;
2256 $pl->save;
2257 }
2258 warn "end emergency player save\n";
2259
2260 warn "begin emergency map save\n";
2261 for my $path (keys %cf::MAP) {
2262 my $map = $cf::MAP{$path} or next;
2263 $map->valid or next;
2264 $map->save;
2265 }
2266 warn "end emergency map save\n";
2267 };
2268
2269 warn "leave emergency perl save\n";
2270}
2026 2271
2027sub reload() { 2272sub reload() {
2028 # can/must only be called in main 2273 # can/must only be called in main
2029 if ($Coro::current != $Coro::main) { 2274 if ($Coro::current != $Coro::main) {
2030 warn "can only reload from main coroutine\n"; 2275 warn "can only reload from main coroutine\n";
2031 return; 2276 return;
2032 } 2277 }
2033 2278
2034 warn "reloading..."; 2279 warn "reloading...";
2035 2280
2281 warn "freezing server";
2036 my $guard = freeze_mainloop; 2282 my $guard = freeze_mainloop;
2037 cf::emergency_save; 2283 cf::emergency_save;
2038 2284
2285 warn "sync database to disk";
2286 cf::db_sync;
2287 IO::AIO::flush;
2288
2039 eval { 2289 eval {
2040 # if anything goes wrong in here, we should simply crash as we already saved 2290 # if anything goes wrong in here, we should simply crash as we already saved
2041 2291
2042 # cancel all watchers 2292 warn "cancel all watchers";
2043 for (Event::all_watchers) { 2293 for (Event::all_watchers) {
2044 $_->cancel if $_->data & WF_AUTOCANCEL; 2294 $_->cancel if $_->data & WF_AUTOCANCEL;
2045 } 2295 }
2046 2296
2047 # cancel all extension coros 2297 warn "cancel all extension coros";
2048 $_->cancel for values %EXT_CORO; 2298 $_->cancel for values %EXT_CORO;
2049 %EXT_CORO = (); 2299 %EXT_CORO = ();
2050 2300
2301 warn "remove commands";
2302 %COMMAND = ();
2303
2304 warn "remove ext commands";
2305 %EXTCMD = ();
2306
2051 # unload all extensions 2307 warn "unload/nuke all extensions";
2052 for (@exts) { 2308 for my $pkg (@EXTS) {
2053 warn "unloading <$_>"; 2309 warn "... unloading $pkg";
2054 unload_extension $_; 2310
2311 if (my $cb = $pkg->can ("unload")) {
2312 eval {
2313 $cb->($pkg);
2314 1
2315 } or warn "$pkg unloaded, but with errors: $@";
2055 } 2316 }
2056 2317
2318 warn "... nuking $pkg";
2319 Symbol::delete_package $pkg;
2320 }
2321
2057 # unload all modules loaded from $LIBDIR 2322 warn "unload all perl modules loaded from $LIBDIR";
2058 while (my ($k, $v) = each %INC) { 2323 while (my ($k, $v) = each %INC) {
2059 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/; 2324 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
2060 2325
2061 warn "removing <$k>"; 2326 warn "removing <$k>";
2062 delete $INC{$k}; 2327 delete $INC{$k};
… …
2069 } 2334 }
2070 2335
2071 Symbol::delete_package $k; 2336 Symbol::delete_package $k;
2072 } 2337 }
2073 2338
2074 # sync database to disk
2075 cf::db_sync;
2076 IO::AIO::flush;
2077
2078 # get rid of safe::, as good as possible 2339 warn "get rid of safe::, as good as possible";
2079 Symbol::delete_package "safe::$_" 2340 Symbol::delete_package "safe::$_"
2080 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region); 2341 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
2081 2342
2082 # remove register_script_function callbacks
2083 # TODO
2084
2085 # unload cf.pm "a bit" 2343 warn "unload cf.pm \"a bit\"";
2086 delete $INC{"cf.pm"}; 2344 delete $INC{"cf.pm"};
2087 2345
2088 # don't, removes xs symbols, too, 2346 # don't, removes xs symbols, too,
2089 # and global variables created in xs 2347 # and global variables created in xs
2090 #Symbol::delete_package __PACKAGE__; 2348 #Symbol::delete_package __PACKAGE__;
2091 2349
2092 # reload cf.pm
2093 warn "reloading cf.pm"; 2350 warn "reloading cf.pm";
2094 require cf; 2351 require cf;
2095 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 2352 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
2096 2353
2097 # load config and database again 2354 warn "load config and database again";
2098 cf::cfg_load; 2355 cf::cfg_load;
2099 cf::db_load; 2356 cf::db_load;
2100 2357
2101 # load extensions
2102 warn "load extensions"; 2358 warn "load extensions";
2103 cf::load_extensions; 2359 cf::load_extensions;
2104 2360
2105 # reattach attachments to objects 2361 warn "reattach attachments to objects/players";
2106 warn "reattach";
2107 _global_reattach; 2362 _global_reattach;
2363 warn "reattach attachments to maps";
2364 reattach $_ for values %MAP;
2108 }; 2365 };
2109 2366
2110 if ($@) { 2367 if ($@) {
2111 warn $@; 2368 warn $@;
2112 warn "error while reloading, exiting."; 2369 warn "error while reloading, exiting.";
2113 exit 1; 2370 exit 1;
2114 } 2371 }
2115 2372
2116 warn "reloaded successfully"; 2373 warn "reloaded";
2117}; 2374};
2118
2119#############################################################################
2120
2121unless ($LINK_MAP) {
2122 $LINK_MAP = cf::map::new;
2123
2124 $LINK_MAP->width (41);
2125 $LINK_MAP->height (41);
2126 $LINK_MAP->alloc;
2127 $LINK_MAP->path ("{link}");
2128 $LINK_MAP->{path} = bless { path => "{link}" }, "cf::path";
2129 $LINK_MAP->in_memory (MAP_IN_MEMORY);
2130
2131 # dirty hack because... archetypes are not yet loaded
2132 Event->timer (
2133 after => 10,
2134 cb => sub {
2135 $_[0]->w->cancel;
2136
2137 # provide some exits "home"
2138 my $exit = cf::object::new "exit";
2139
2140 $exit->slaying ($EMERGENCY_POSITION->[0]);
2141 $exit->stats->hp ($EMERGENCY_POSITION->[1]);
2142 $exit->stats->sp ($EMERGENCY_POSITION->[2]);
2143
2144 $LINK_MAP->insert ($exit->clone, 19, 19);
2145 $LINK_MAP->insert ($exit->clone, 19, 20);
2146 $LINK_MAP->insert ($exit->clone, 19, 21);
2147 $LINK_MAP->insert ($exit->clone, 20, 19);
2148 $LINK_MAP->insert ($exit->clone, 20, 21);
2149 $LINK_MAP->insert ($exit->clone, 21, 19);
2150 $LINK_MAP->insert ($exit->clone, 21, 20);
2151 $LINK_MAP->insert ($exit->clone, 21, 21);
2152
2153 $exit->destroy;
2154 });
2155
2156 $LINK_MAP->{deny_save} = 1;
2157 $LINK_MAP->{deny_reset} = 1;
2158
2159 $cf::MAP{$LINK_MAP->path} = $LINK_MAP;
2160}
2161
2162register "<global>", __PACKAGE__;
2163 2375
2164register_command "reload" => sub { 2376register_command "reload" => sub {
2165 my ($who, $arg) = @_; 2377 my ($who, $arg) = @_;
2166 2378
2167 if ($who->flag (FLAG_WIZ)) { 2379 if ($who->flag (FLAG_WIZ)) {
… …
2177 reentrant => 0, 2389 reentrant => 0,
2178 prio => 0, 2390 prio => 0,
2179 at => $NEXT_TICK || $TICK, 2391 at => $NEXT_TICK || $TICK,
2180 data => WF_AUTOCANCEL, 2392 data => WF_AUTOCANCEL,
2181 cb => sub { 2393 cb => sub {
2394 $NOW = Event::time;
2395
2182 cf::server_tick; # one server iteration 2396 cf::server_tick; # one server iteration
2183 $RUNTIME += $TICK; 2397 $RUNTIME += $TICK;
2184 $NEXT_TICK += $TICK; 2398 $NEXT_TICK += $TICK;
2399
2400 $WAIT_FOR_TICK->broadcast;
2401 $WAIT_FOR_TICK_ONE->send if $WAIT_FOR_TICK_ONE->awaited;
2185 2402
2186 # if we are delayed by four ticks or more, skip them all 2403 # if we are delayed by four ticks or more, skip them all
2187 $NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4; 2404 $NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4;
2188 2405
2189 $TICK_WATCHER->at ($NEXT_TICK); 2406 $TICK_WATCHER->at ($NEXT_TICK);
… …
2191 }, 2408 },
2192); 2409);
2193 2410
2194IO::AIO::max_poll_time $TICK * 0.2; 2411IO::AIO::max_poll_time $TICK * 0.2;
2195 2412
2196Event->io ( 2413$AIO_POLL_WATCHER = Event->io (
2197 fd => IO::AIO::poll_fileno, 2414 fd => IO::AIO::poll_fileno,
2198 poll => 'r', 2415 poll => 'r',
2199 prio => 5, 2416 prio => 5,
2200 data => WF_AUTOCANCEL, 2417 data => WF_AUTOCANCEL,
2201 cb => \&IO::AIO::poll_cb, 2418 cb => \&IO::AIO::poll_cb,
2202); 2419);
2203 2420
2204Event->timer ( 2421$WRITE_RUNTIME_WATCHER = Event->timer (
2205 data => WF_AUTOCANCEL, 2422 data => WF_AUTOCANCEL,
2206 after => 0, 2423 after => 0,
2207 interval => 10, 2424 interval => 10,
2208 cb => sub { 2425 cb => sub {
2209 (Coro::unblock_sub { 2426 (Coro::unblock_sub {

Diff Legend

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