ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/cf.schmorp.de/server/lib/cf.pm
(Generate patch)

Comparing cf.schmorp.de/server/lib/cf.pm (file contents):
Revision 1.135 by root, Thu Jan 4 20:29:46 2007 UTC vs.
Revision 1.168 by root, Sun Jan 14 00:37:14 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 (2); # 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
33sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
34 35
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
… …
221 # wake up all waiters, to be on the safe side 256 # wake up all waiters, to be on the safe side
222 $_->ready for @{ delete $LOCK{$key} }; 257 $_->ready for @{ delete $LOCK{$key} };
223 } 258 }
224} 259}
225 260
226=item cf::async { BLOCK }
227
228Like C<Coro::async>, but runs the given BLOCK in an eval and only logs the
229error instead of exiting the server in case of a problem.
230
231=cut
232
233sub async(&) {
234 my ($cb) = @_;
235
236 Coro::async {
237 eval { $cb->() };
238 warn $@ if $@;
239 }
240}
241
242sub freeze_mainloop { 261sub freeze_mainloop {
243 return unless $TICK_WATCHER->is_active; 262 return unless $TICK_WATCHER->is_active;
244 263
245 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;
246 $TICK_WATCHER->stop; 269 $TICK_WATCHER->stop;
247 $guard 270 $guard
248} 271}
272
273=item cf::async { BLOCK }
274
275Currently the same as Coro::async_pool, meaning you cannot use
276C<on_destroy>, C<join> or other gimmicks on these coroutines. The only
277thing you are allowed to do is call C<prio> on it.
278
279=cut
280
281BEGIN { *async = \&Coro::async_pool }
249 282
250=item cf::sync_job { BLOCK } 283=item cf::sync_job { BLOCK }
251 284
252The design of crossfire+ requires that the main coro ($Coro::main) is 285The design of crossfire+ requires that the main coro ($Coro::main) is
253always able to handle events or runnable, as crossfire+ is only partly 286always able to handle events or runnable, as crossfire+ is only partly
… …
272 my $freeze_guard = freeze_mainloop; 305 my $freeze_guard = freeze_mainloop;
273 306
274 my $busy = 1; 307 my $busy = 1;
275 my @res; 308 my @res;
276 309
277 (Coro::async { 310 (async {
278 @res = eval { $job->() }; 311 @res = eval { $job->() };
279 warn $@ if $@; 312 warn $@ if $@;
280 undef $busy; 313 undef $busy;
281 })->prio (Coro::PRIO_MAX); 314 })->prio (Coro::PRIO_MAX);
282 315
283 while ($busy) { 316 while ($busy) {
284 Coro::cede_notself; 317 Coro::cede or Event::one_event;
285 Event::one_event unless Coro::nready;
286 } 318 }
287 319
288 wantarray ? @res : $res[0] 320 wantarray ? @res : $res[0]
289 } else { 321 } else {
290 # we are in another coroutine, how wonderful, everything just works 322 # we are in another coroutine, how wonderful, everything just works
291 323
292 $job->() 324 $job->()
293 } 325 }
294} 326}
295 327
296=item $coro = cf::coro { BLOCK } 328=item $coro = cf::async_ext { BLOCK }
297 329
298Creates and returns a new coro. This coro is automcatially being canceled 330Like async, but this coro is automatically being canceled when the
299when the extension calling this is being unloaded. 331extension calling this is being unloaded.
300 332
301=cut 333=cut
302 334
303sub coro(&) { 335sub async_ext(&) {
304 my $cb = shift; 336 my $cb = shift;
305 337
306 my $coro = &cf::async ($cb); 338 my $coro = &Coro::async ($cb);
307 339
308 $coro->on_destroy (sub { 340 $coro->on_destroy (sub {
309 delete $EXT_CORO{$coro+0}; 341 delete $EXT_CORO{$coro+0};
310 }); 342 });
311 $EXT_CORO{$coro+0} = $coro; 343 $EXT_CORO{$coro+0} = $coro;
… …
336} 368}
337 369
338=back 370=back
339 371
340=cut 372=cut
341
342#############################################################################
343
344package cf::path;
345
346sub new {
347 my ($class, $path, $base) = @_;
348
349 $path = $path->as_string if ref $path;
350
351 my $self = bless { }, $class;
352
353 # {... are special paths that are not touched
354 # ?xxx/... are special absolute paths
355 # ?random/... random maps
356 # /! non-realised random map exit
357 # /... normal maps
358 # ~/... per-player maps without a specific player (DO NOT USE)
359 # ~user/... per-player map of a specific user
360
361 if ($path =~ /^{/) {
362 # fine as it is
363 } elsif ($path =~ s{^\?random/}{}) {
364 Coro::AIO::aio_load "$cf::RANDOM_MAPS/$path.meta", my $data;
365 $self->{random} = cf::from_json $data;
366 } else {
367 if ($path =~ s{^~([^/]+)?}{}) {
368 $self->{user_rel} = 1;
369
370 if (defined $1) {
371 $self->{user} = $1;
372 } elsif ($base =~ m{^~([^/]+)/}) {
373 $self->{user} = $1;
374 } else {
375 warn "cannot resolve user-relative path without user <$path,$base>\n";
376 }
377 } elsif ($path =~ /^\//) {
378 # already absolute
379 } else {
380 $base =~ s{[^/]+/?$}{};
381 return $class->new ("$base/$path");
382 }
383
384 for ($path) {
385 redo if s{/\.?/}{/};
386 redo if s{/[^/]+/\.\./}{/};
387 }
388 }
389
390 $self->{path} = $path;
391
392 $self
393}
394
395# the name / primary key / in-game path
396sub as_string {
397 my ($self) = @_;
398
399 $self->{user_rel} ? "~$self->{user}$self->{path}"
400 : $self->{random} ? "?random/$self->{path}"
401 : $self->{path}
402}
403
404# the displayed name, this is a one way mapping
405sub visible_name {
406 my ($self) = @_;
407
408# if (my $rmp = $self->{random}) {
409# # todo: be more intelligent about this
410# "?random/$rmp->{origin_map}+$rmp->{origin_x}+$rmp->{origin_y}/$rmp->{dungeon_level}"
411# } else {
412 $self->as_string
413# }
414}
415
416# escape the /'s in the path
417sub _escaped_path {
418 # ∕ is U+2215
419 (my $path = $_[0]{path}) =~ s/\//∕/g;
420 $path
421}
422
423# the original (read-only) location
424sub load_path {
425 my ($self) = @_;
426
427 sprintf "%s/%s/%s", cf::datadir, cf::mapdir, $self->{path}
428}
429
430# the temporary/swap location
431sub save_path {
432 my ($self) = @_;
433
434 $self->{user_rel} ? sprintf "%s/%s/%s/%s", cf::localdir, cf::playerdir, $self->{user}, $self->_escaped_path
435 : $self->{random} ? sprintf "%s/%s", $RANDOM_MAPS, $self->{path}
436 : sprintf "%s/%s/%s", cf::localdir, cf::tmpdir, $self->_escaped_path
437}
438
439# the unique path, might be eq to save_path
440sub uniq_path {
441 my ($self) = @_;
442
443 $self->{user_rel} || $self->{random}
444 ? undef
445 : sprintf "%s/%s/%s", cf::localdir, cf::uniquedir, $self->_escaped_path
446}
447
448# return random map parameters, or undef
449sub random_map_params {
450 my ($self) = @_;
451
452 $self->{random}
453}
454
455# this is somewhat ugly, but style maps do need special treatment
456sub is_style_map {
457 $_[0]{path} =~ m{^/styles/}
458}
459
460package cf;
461 373
462############################################################################# 374#############################################################################
463 375
464=head2 ATTACHABLE OBJECTS 376=head2 ATTACHABLE OBJECTS
465 377
… …
912=cut 824=cut
913 825
914sub register_extcmd { 826sub register_extcmd {
915 my ($name, $cb) = @_; 827 my ($name, $cb) = @_;
916 828
917 my $caller = caller;
918 #warn "registering extcmd '$name' to '$caller'";
919
920 $EXTCMD{$name} = [$cb, $caller]; 829 $EXTCMD{$name} = $cb;
921} 830}
922 831
923cf::player->attach ( 832cf::player->attach (
924 on_command => sub { 833 on_command => sub {
925 my ($pl, $name, $params) = @_; 834 my ($pl, $name, $params) = @_;
… …
938 847
939 my $msg = eval { from_json $buf }; 848 my $msg = eval { from_json $buf };
940 849
941 if (ref $msg) { 850 if (ref $msg) {
942 if (my $cb = $EXTCMD{$msg->{msgtype}}) { 851 if (my $cb = $EXTCMD{$msg->{msgtype}}) {
943 if (my %reply = $cb->[0]->($pl, $msg)) { 852 if (my %reply = $cb->($pl, $msg)) {
944 $pl->ext_reply ($msg->{msgid}, %reply); 853 $pl->ext_reply ($msg->{msgid}, %reply);
945 } 854 }
946 } 855 }
947 } else { 856 } else {
948 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n"; 857 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
… …
950 859
951 cf::override; 860 cf::override;
952 }, 861 },
953); 862);
954 863
955sub register {
956 my ($base, $pkg) = @_;
957
958 #TODO
959}
960
961sub load_extension { 864sub load_extension {
962 my ($path) = @_; 865 my ($path) = @_;
963 866
964 $path =~ /([^\/\\]+)\.ext$/ or die "$path"; 867 $path =~ /([^\/\\]+)\.ext$/ or die "$path";
965 my $base = $1; 868 my $base = $1;
966 my $pkg = $1; 869 my $pkg = $1;
967 $pkg =~ s/[^[:word:]]/_/g; 870 $pkg =~ s/[^[:word:]]/_/g;
968 $pkg = "ext::$pkg"; 871 $pkg = "ext::$pkg";
969 872
970 warn "loading '$path' into '$pkg'\n"; 873 warn "... loading '$path' into '$pkg'\n";
971 874
972 open my $fh, "<:utf8", $path 875 open my $fh, "<:utf8", $path
973 or die "$path: $!"; 876 or die "$path: $!";
974 877
975 my $source = 878 my $source =
976 "package $pkg; use strict; use utf8;\n" 879 "package $pkg; use strict; use utf8;\n"
977 . "#line 1 \"$path\"\n{\n" 880 . "#line 1 \"$path\"\n{\n"
978 . (do { local $/; <$fh> }) 881 . (do { local $/; <$fh> })
979 . "\n};\n1"; 882 . "\n};\n1";
980 883
981 eval $source 884 unless (eval $source) {
982 or die $@ ? "$path: $@\n" 885 my $msg = $@ ? "$path: $@\n"
983 : "extension disabled.\n"; 886 : "extension disabled.\n";
984 887 if ($source =~ /^#!.*perl.*#.*MANDATORY/m) { # ugly match
985 push @exts, $pkg; 888 warn $@;
986 $ext_pkg{$base} = $pkg; 889 warn "mandatory extension failed to load, exiting.\n";
987 890 exit 1;
988# no strict 'refs'; 891 }
989# @{"$pkg\::ISA"} = ext::; 892 die $@;
990
991 register $base, $pkg;
992}
993
994sub unload_extension {
995 my ($pkg) = @_;
996
997 warn "removing extension $pkg\n";
998
999 # remove hooks
1000 #TODO
1001# for my $idx (0 .. $#PLUGIN_EVENT) {
1002# delete $hook[$idx]{$pkg};
1003# } 893 }
1004 894
1005 # remove commands 895 push @EXTS, $pkg;
1006 for my $name (keys %COMMAND) {
1007 my @cb = grep $_->[0] ne $pkg, @{ $COMMAND{$name} };
1008
1009 if (@cb) {
1010 $COMMAND{$name} = \@cb;
1011 } else {
1012 delete $COMMAND{$name};
1013 }
1014 }
1015
1016 # remove extcmds
1017 for my $name (grep $EXTCMD{$_}[1] eq $pkg, keys %EXTCMD) {
1018 delete $EXTCMD{$name};
1019 }
1020
1021 if (my $cb = $pkg->can ("unload")) {
1022 eval {
1023 $cb->($pkg);
1024 1
1025 } or warn "$pkg unloaded, but with errors: $@";
1026 }
1027
1028 Symbol::delete_package $pkg;
1029} 896}
1030 897
1031sub load_extensions { 898sub load_extensions {
1032 for my $ext (<$LIBDIR/*.ext>) { 899 for my $ext (<$LIBDIR/*.ext>) {
1033 next unless -r $ext; 900 next unless -r $ext;
… …
1037 } or warn "$ext not loaded: $@"; 904 } or warn "$ext not loaded: $@";
1038 } 905 }
1039} 906}
1040 907
1041############################################################################# 908#############################################################################
1042# load/save/clean perl data associated with a map
1043
1044*cf::mapsupport::on_clean = sub {
1045 my ($map) = @_;
1046
1047 my $path = $map->tmpname;
1048 defined $path or return;
1049
1050 unlink "$path.pst";
1051};
1052
1053cf::map->attach (prio => -10000, package => cf::mapsupport::);
1054
1055#############################################################################
1056# load/save perl data associated with player->ob objects
1057
1058sub all_objects(@) {
1059 @_, map all_objects ($_->inv), @_
1060}
1061
1062# TODO: compatibility cruft, remove when no longer needed
1063cf::player->attach (
1064 on_load => sub {
1065 my ($pl, $path) = @_;
1066
1067 for my $o (all_objects $pl->ob) {
1068 if (my $value = $o->get_ob_key_value ("_perl_data")) {
1069 $o->set_ob_key_value ("_perl_data");
1070
1071 %$o = %{ Storable::thaw pack "H*", $value };
1072 }
1073 }
1074 },
1075);
1076
1077#############################################################################
1078 909
1079=head2 CORE EXTENSIONS 910=head2 CORE EXTENSIONS
1080 911
1081Functions and methods that extend core crossfire objects. 912Functions and methods that extend core crossfire objects.
1082 913
914=cut
915
916package cf::player;
917
918use Coro::AIO;
919
1083=head3 cf::player 920=head3 cf::player
1084 921
1085=over 4 922=over 4
1086 923
1087=item cf::player::exists $login 924=item cf::player::find $login
1088 925
1089Returns true when the given account exists. 926Returns the given player object, loading it if necessary (might block).
1090 927
1091=cut 928=cut
1092 929
1093sub cf::player::exists($) { 930sub playerdir($) {
1094 cf::player::find $_[0] 931 cf::localdir
1095 or -f sprintf "%s/%s/%s/%s.pl", cf::localdir, cf::playerdir, ($_[0]) x 2; 932 . "/"
933 . cf::playerdir
934 . "/"
935 . (ref $_[0] ? $_[0]->ob->name : $_[0])
936}
937
938sub path($) {
939 my $login = ref $_[0] ? $_[0]->ob->name : $_[0];
940
941 (playerdir $login) . "/$login.pl"
942}
943
944sub find_active($) {
945 $cf::PLAYER{$_[0]}
946 and $cf::PLAYER{$_[0]}->active
947 and $cf::PLAYER{$_[0]}
948}
949
950sub exists($) {
951 my ($login) = @_;
952
953 $cf::PLAYER{$login}
954 or cf::sync_job { !aio_stat $login }
955}
956
957sub find($) {
958 return $cf::PLAYER{$_[0]} || do {
959 my $login = $_[0];
960
961 my $guard = cf::lock_acquire "user_find:$login";
962
963 $cf::PLAYER{$_[0]} || do {
964 my $pl = load_pl path $login
965 or return;
966 $cf::PLAYER{$login} = $pl
967 }
968 }
969}
970
971sub save($) {
972 my ($pl) = @_;
973
974 return if $pl->{deny_save};
975
976 my $path = path $pl;
977 my $guard = cf::lock_acquire "user_save:$path";
978
979 return if $pl->{deny_save};
980
981 aio_mkdir playerdir $pl, 0770;
982 $pl->{last_save} = $cf::RUNTIME;
983
984 $pl->save_pl ($path);
985 Coro::cede;
986}
987
988sub new($) {
989 my ($login) = @_;
990
991 my $self = create;
992
993 $self->ob->name ($login);
994 $self->{deny_save} = 1;
995
996 $cf::PLAYER{$login} = $self;
997
998 $self
999}
1000
1001=item $pl->quit_character
1002
1003Nukes the player without looking back. If logged in, the connection will
1004be destroyed. May block for a long time.
1005
1006=cut
1007
1008sub quit_character {
1009 my ($pl) = @_;
1010
1011 $pl->{deny_save} = 1;
1012 $pl->password ("*"); # this should lock out the player until we nuked the dir
1013
1014 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active;
1015 $pl->deactivate;
1016 $pl->invoke (cf::EVENT_PLAYER_QUIT);
1017 $pl->ns->destroy if $pl->ns;
1018
1019 my $path = playerdir $pl;
1020 my $temp = "$path~$cf::RUNTIME~deleting~";
1021 aio_rename $path, $temp;
1022 delete $cf::PLAYER{$pl->ob->name};
1023 $pl->destroy;
1024 IO::AIO::aio_rmtree $temp;
1025}
1026
1027=item cf::player::list_logins
1028
1029Returns am arrayref of all valid playernames in the system, can take a
1030while and may block, so not sync_job-capable, ever.
1031
1032=cut
1033
1034sub list_logins {
1035 my $dirs = aio_readdir cf::localdir . "/" . cf::playerdir
1036 or return [];
1037
1038 my @logins;
1039
1040 for my $login (@$dirs) {
1041 my $fh = aio_open path $login, Fcntl::O_RDONLY, 0 or next;
1042 aio_read $fh, 0, 512, my $buf, 0 or next;
1043 $buf !~ /^password -------------$/m or next; # official not-valid tag
1044
1045 utf8::decode $login;
1046 push @logins, $login;
1047 }
1048
1049 \@logins
1050}
1051
1052=item $player->maps
1053
1054Returns an arrayref of map paths that are private for this
1055player. May block.
1056
1057=cut
1058
1059sub maps($) {
1060 my ($pl) = @_;
1061
1062 my $files = aio_readdir playerdir $pl
1063 or return;
1064
1065 my @paths;
1066
1067 for (@$files) {
1068 utf8::decode $_;
1069 next if /\.(?:pl|pst)$/;
1070 next unless /^$PATH_SEP/o;
1071
1072 s/\.map$//;
1073 push @paths, "~" . $pl->ob->name . "/" . $_;
1074 }
1075
1076 \@paths
1096} 1077}
1097 1078
1098=item $player->ext_reply ($msgid, $msgtype, %msg) 1079=item $player->ext_reply ($msgid, $msgtype, %msg)
1099 1080
1100Sends an ext reply to the player. 1081Sends an ext reply to the player.
1101 1082
1102=cut 1083=cut
1103 1084
1104sub cf::player::ext_reply($$$%) { 1085sub ext_reply($$$%) {
1105 my ($self, $id, %msg) = @_; 1086 my ($self, $id, %msg) = @_;
1106 1087
1107 $msg{msgid} = $id; 1088 $msg{msgid} = $id;
1108 1089
1109 $self->send ("ext " . to_json \%msg); 1090 $self->send ("ext " . cf::to_json \%msg);
1110} 1091}
1092
1093package cf;
1111 1094
1112=back 1095=back
1113 1096
1114 1097
1115=head3 cf::map 1098=head3 cf::map
… …
1121package cf::map; 1104package cf::map;
1122 1105
1123use Fcntl; 1106use Fcntl;
1124use Coro::AIO; 1107use Coro::AIO;
1125 1108
1109use overload
1110 '""' => \&as_string;
1111
1126our $MAX_RESET = 3600; 1112our $MAX_RESET = 3600;
1127our $DEFAULT_RESET = 3000; 1113our $DEFAULT_RESET = 3000;
1128 1114
1129sub generate_random_map { 1115sub generate_random_map {
1130 my ($path, $rmp) = @_; 1116 my ($self, $rmp) = @_;
1131 1117
1132 # mit "rum" bekleckern, nicht 1118 # mit "rum" bekleckern, nicht
1133 cf::map::_create_random_map 1119 $self->_create_random_map (
1134 $path,
1135 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle}, 1120 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle},
1136 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle}, 1121 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle},
1137 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map}, 1122 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map},
1138 $rmp->{exit_on_final_map}, 1123 $rmp->{exit_on_final_map},
1139 $rmp->{xsize}, $rmp->{ysize}, 1124 $rmp->{xsize}, $rmp->{ysize},
1140 $rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3}, 1125 $rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3},
1141 $rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase}, 1126 $rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase},
1142 $rmp->{dungeon_level}, $rmp->{dungeon_depth}, $rmp->{decoroptions}, $rmp->{orientation}, 1127 $rmp->{dungeon_level}, $rmp->{dungeon_depth}, $rmp->{decoroptions}, $rmp->{orientation},
1143 $rmp->{origin_y}, $rmp->{origin_x}, $rmp->{random_seed}, $rmp->{total_map_hp}, 1128 $rmp->{origin_y}, $rmp->{origin_x}, $rmp->{random_seed}, $rmp->{total_map_hp},
1144 $rmp->{map_layout_style}, $rmp->{treasureoptions}, $rmp->{symmetry_used}, 1129 $rmp->{map_layout_style}, $rmp->{treasureoptions}, $rmp->{symmetry_used},
1145 (cf::region::find $rmp->{region}) 1130 (cf::region::find $rmp->{region}), $rmp->{custom}
1131 )
1132}
1133
1134sub register {
1135 my (undef, $regex) = @_;
1136 my $pkg = caller;
1137
1138 no strict;
1139 push @{"$pkg\::ISA"}, __PACKAGE__;
1140
1141 $EXT_MAP{$pkg} = qr<$regex>;
1142}
1143
1144# also paths starting with '/'
1145$EXT_MAP{"cf::map"} = qr{^(?=/)};
1146
1147sub normalise {
1148 my ($path, $base) = @_;
1149
1150 # map plan:
1151 #
1152 # /! non-realised random map exit (special hack!)
1153 # {... are special paths that are not being touched
1154 # ?xxx/... are special absolute paths
1155 # ?random/... random maps
1156 # /... normal maps
1157 # ~user/... per-player map of a specific user
1158
1159 $path =~ s/$PATH_SEP/\//go;
1160
1161 # treat it as relative path if it starts with
1162 # something that looks reasonable
1163 if ($path =~ m{^(?:\./|\.\./|\w)}) {
1164 $base or Carp::carp "normalise called with relative path and no base: '$path'";
1165
1166 $base =~ s{[^/]+/?$}{};
1167 $path = "$base/$path";
1168 }
1169
1170 for ($path) {
1171 redo if s{//}{/};
1172 redo if s{/\.?/}{/};
1173 redo if s{/[^/]+/\.\./}{/};
1174 }
1175
1176 $path
1177}
1178
1179sub new_from_path {
1180 my (undef, $path, $base) = @_;
1181
1182 return $path if UNIVERSAL::isa $path, "cf::map"; # already a map object
1183
1184 $path = normalise $path, $base;
1185
1186 for my $pkg (keys %EXT_MAP) {
1187 if ($path =~ $EXT_MAP{$pkg}) {
1188 my $self = bless cf::map::new, $pkg;
1189 $self->{path} = $path; $self->path ($path);
1190 $self->init; # pass $1 etc.
1191 return $self;
1192 }
1193 }
1194
1195 Carp::carp "unable to resolve path '$path'.";
1196 ()
1197}
1198
1199sub init {
1200 my ($self) = @_;
1201
1202 $self
1203}
1204
1205sub as_string {
1206 my ($self) = @_;
1207
1208 "$self->{path}"
1209}
1210
1211# the displayed name, this is a one way mapping
1212sub visible_name {
1213 &as_string
1214}
1215
1216# the original (read-only) location
1217sub load_path {
1218 my ($self) = @_;
1219
1220 sprintf "%s/%s/%s", cf::datadir, cf::mapdir, $self->{path}
1221}
1222
1223# the temporary/swap location
1224sub save_path {
1225 my ($self) = @_;
1226
1227 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g;
1228 sprintf "%s/%s/%s", cf::localdir, cf::tmpdir, $path
1229}
1230
1231# the unique path, undef == no special unique path
1232sub uniq_path {
1233 my ($self) = @_;
1234
1235 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g;
1236 sprintf "%s/%s/%s", cf::localdir, cf::uniquedir, $path
1146} 1237}
1147 1238
1148# and all this just because we cannot iterate over 1239# and all this just because we cannot iterate over
1149# all maps in C++... 1240# all maps in C++...
1150sub change_all_map_light { 1241sub change_all_map_light {
… …
1152 1243
1153 $_->change_map_light ($change) 1244 $_->change_map_light ($change)
1154 for grep $_->outdoor, values %cf::MAP; 1245 for grep $_->outdoor, values %cf::MAP;
1155} 1246}
1156 1247
1248sub unlink_save {
1249 my ($self) = @_;
1250
1251 utf8::encode (my $save = $self->save_path);
1252 IO::AIO::aioreq_pri 4; IO::AIO::aio_unlink $save;
1253 IO::AIO::aioreq_pri 4; IO::AIO::aio_unlink "$save.pst";
1254}
1255
1157sub try_load_header($) { 1256sub load_header_from($) {
1158 my ($path) = @_; 1257 my ($self, $path) = @_;
1159 1258
1160 utf8::encode $path; 1259 utf8::encode $path;
1161 aio_open $path, O_RDONLY, 0 1260 aio_open $path, O_RDONLY, 0
1162 or return; 1261 or return;
1163 1262
1164 my $map = cf::map::new 1263 $self->_load_header ($path)
1165 or return; 1264 or return;
1166 1265
1167 # for better error messages only, will be overwritten 1266 $self->{load_path} = $path;
1168 $map->path ($path);
1169 1267
1170 $map->load_header ($path) 1268 1
1269}
1270
1271sub load_orig {
1272 my ($self) = @_;
1273
1274 $self->load_header_from ($self->load_path)
1275}
1276
1277sub load_temp {
1278 my ($self) = @_;
1279
1280 $self->load_header_from ($self->save_path)
1281}
1282
1283sub load_header {
1284 my ($self) = @_;
1285
1286 if ($self->load_temp) {
1287 $self->last_access ((delete $self->{last_access})
1288 || $cf::RUNTIME); #d#
1289 # safety
1290 $self->{instantiate_time} = $cf::RUNTIME
1291 if $self->{instantiate_time} > $cf::RUNTIME;
1292 } else {
1293 $self->load_orig
1171 or return; 1294 or return;
1172 1295
1173 $map->{load_path} = $path; 1296 $self->{load_original} = 1;
1297 $self->{instantiate_time} = $cf::RUNTIME;
1298 $self->last_access ($cf::RUNTIME);
1299 $self->instantiate;
1300 }
1174 1301
1175 $map 1302 1
1176} 1303}
1177 1304
1178sub find; 1305sub find;
1179sub find { 1306sub find {
1180 my ($path, $origin) = @_; 1307 my ($path, $origin) = @_;
1181 1308
1182 #warn "find<$path,$origin>\n";#d#
1183
1184 $path = new cf::path $path, $origin && $origin->path; 1309 $path = normalise $path, $origin && $origin->path;
1185 my $key = $path->as_string;
1186 1310
1187 cf::lock_wait "map_find:$key"; 1311 cf::lock_wait "map_find:$path";
1188 1312
1189 $cf::MAP{$key} || do { 1313 $cf::MAP{$path} || do {
1190 my $guard = cf::lock_acquire "map_find:$key"; 1314 my $guard = cf::lock_acquire "map_find:$path";
1191 1315 my $map = new_from_path cf::map $path
1192 # do it the slow way
1193 my $map = try_load_header $path->save_path;
1194
1195 Coro::cede;
1196
1197 if ($map) {
1198 $map->last_access ((delete $map->{last_access})
1199 || $cf::RUNTIME); #d#
1200 # safety
1201 $map->{instantiate_time} = $cf::RUNTIME
1202 if $map->{instantiate_time} > $cf::RUNTIME;
1203 } else {
1204 if (my $rmp = $path->random_map_params) {
1205 $map = generate_random_map $key, $rmp;
1206 } else {
1207 $map = try_load_header $path->load_path;
1208 }
1209
1210 $map or return; 1316 or return;
1211 1317
1212 $map->{load_original} = 1;
1213 $map->{instantiate_time} = $cf::RUNTIME;
1214 $map->last_access ($cf::RUNTIME);
1215 $map->instantiate;
1216
1217 # per-player maps become, after loading, normal maps
1218 $map->per_player (0) if $path->{user_rel};
1219 }
1220
1221 $map->path ($key);
1222 $map->{path} = $path;
1223 $map->{last_save} = $cf::RUNTIME; 1318 $map->{last_save} = $cf::RUNTIME;
1224 1319
1225 Coro::cede; 1320 $map->load_header
1321 or return;
1226 1322
1227 if ($map->should_reset) { 1323 if ($map->should_reset) {
1228 $map->reset; 1324 $map->reset;
1229 undef $guard; 1325 undef $guard;
1230 $map = find $path 1326 $map = find $path
1231 or return; 1327 or return;
1232 } 1328 }
1233 1329
1234 $cf::MAP{$key} = $map 1330 $cf::MAP{$path} = $map
1235 } 1331 }
1236} 1332}
1237 1333
1238sub load { 1334sub load {
1239 my ($self) = @_; 1335 my ($self) = @_;
1240 1336
1241 my $path = $self->{path}; 1337 my $path = $self->{path};
1242 my $guard = cf::lock_acquire "map_load:" . $path->as_string; 1338 my $guard = cf::lock_acquire "map_load:$path";
1243 1339
1244 return if $self->in_memory != cf::MAP_SWAPPED; 1340 return if $self->in_memory != cf::MAP_SWAPPED;
1245 1341
1246 $self->in_memory (cf::MAP_LOADING); 1342 $self->in_memory (cf::MAP_LOADING);
1247 1343
1248 $self->alloc; 1344 $self->alloc;
1249 $self->load_objects ($self->{load_path}, 1) 1345 $self->_load_objects ($self->{load_path}, 1)
1250 or return; 1346 or return;
1251 1347
1252 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1) 1348 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1)
1253 if delete $self->{load_original}; 1349 if delete $self->{load_original};
1254 1350
1255 if (my $uniq = $path->uniq_path) { 1351 if (my $uniq = $self->uniq_path) {
1256 utf8::encode $uniq; 1352 utf8::encode $uniq;
1257 if (aio_open $uniq, O_RDONLY, 0) { 1353 if (aio_open $uniq, O_RDONLY, 0) {
1258 $self->clear_unique_items; 1354 $self->clear_unique_items;
1259 $self->load_objects ($uniq, 0); 1355 $self->_load_objects ($uniq, 0);
1260 } 1356 }
1261 } 1357 }
1262 1358
1263 Coro::cede; 1359 Coro::cede;
1264 1360
1265 # now do the right thing for maps 1361 # now do the right thing for maps
1266 $self->link_multipart_objects; 1362 $self->link_multipart_objects;
1267 1363
1268 if ($self->{path}->is_style_map) { 1364 unless ($self->{deny_activate}) {
1269 $self->{deny_save} = 1; 1365 $self->decay_objects;
1270 $self->{deny_reset} = 1;
1271 } else {
1272 $self->fix_auto_apply; 1366 $self->fix_auto_apply;
1273 $self->decay_objects;
1274 $self->update_buttons; 1367 $self->update_buttons;
1368 Coro::cede;
1275 $self->set_darkness_map; 1369 $self->set_darkness_map;
1276 $self->difficulty ($self->estimate_difficulty) 1370 $self->difficulty ($self->estimate_difficulty)
1277 unless $self->difficulty; 1371 unless $self->difficulty;
1372 Coro::cede;
1278 $self->activate; 1373 $self->activate;
1279 } 1374 }
1280 1375
1281 Coro::cede;
1282
1283 $self->in_memory (cf::MAP_IN_MEMORY); 1376 $self->in_memory (cf::MAP_IN_MEMORY);
1377}
1378
1379sub customise_for {
1380 my ($self, $ob) = @_;
1381
1382 return find "~" . $ob->name . "/" . $self->{path}
1383 if $self->per_player;
1384
1385 $self
1386}
1387
1388# find and load all maps in the 3x3 area around a map
1389sub load_diag {
1390 my ($map) = @_;
1391
1392 my @diag; # diagonal neighbours
1393
1394 for (0 .. 3) {
1395 my $neigh = $map->tile_path ($_)
1396 or next;
1397 $neigh = find $neigh, $map
1398 or next;
1399 $neigh->load;
1400
1401 push @diag, [$neigh->tile_path (($_ + 3) % 4), $neigh],
1402 [$neigh->tile_path (($_ + 1) % 4), $neigh];
1403 }
1404
1405 for (@diag) {
1406 my $neigh = find @$_
1407 or next;
1408 $neigh->load;
1409 }
1284} 1410}
1285 1411
1286sub find_sync { 1412sub find_sync {
1287 my ($path, $origin) = @_; 1413 my ($path, $origin) = @_;
1288 1414
1289 cf::sync_job { cf::map::find $path, $origin } 1415 cf::sync_job { find $path, $origin }
1290} 1416}
1291 1417
1292sub do_load_sync { 1418sub do_load_sync {
1293 my ($map) = @_; 1419 my ($map) = @_;
1294 1420
1295 cf::sync_job { $map->load }; 1421 cf::sync_job { $map->load };
1296} 1422}
1297 1423
1424our %MAP_PREFETCH;
1425our $MAP_PREFETCHER = Coro::async {
1426 while () {
1427 for my $path (keys %MAP_PREFETCH) {
1428 my $map = find $path
1429 or next;
1430 $map->load;
1431
1432 delete $MAP_PREFETCH{$path};
1433 }
1434 Coro::schedule;
1435 }
1436};
1437
1438sub find_async {
1439 my ($path, $origin) = @_;
1440
1441 $path = normalise $path, $origin && $origin->{path};
1442
1443 if (my $map = $cf::MAP{$path}) {
1444 return $map if $map->in_memory == cf::MAP_IN_MEMORY;
1445 }
1446
1447 $MAP_PREFETCH{$path} = 0;
1448 $MAP_PREFETCHER->ready;
1449
1450 ()
1451}
1452
1298sub save { 1453sub save {
1299 my ($self) = @_; 1454 my ($self) = @_;
1300 1455
1456 my $lock = cf::lock_acquire "map_data:" . $self->path;
1457
1301 $self->{last_save} = $cf::RUNTIME; 1458 $self->{last_save} = $cf::RUNTIME;
1302 1459
1303 return unless $self->dirty; 1460 return unless $self->dirty;
1304 1461
1305 my $save = $self->{path}->save_path; utf8::encode $save; 1462 my $save = $self->save_path; utf8::encode $save;
1306 my $uniq = $self->{path}->uniq_path; utf8::encode $uniq; 1463 my $uniq = $self->uniq_path; utf8::encode $uniq;
1307 1464
1308 $self->{load_path} = $save; 1465 $self->{load_path} = $save;
1309 1466
1310 return if $self->{deny_save}; 1467 return if $self->{deny_save};
1311 1468
1312 local $self->{last_access} = $self->last_access;#d# 1469 local $self->{last_access} = $self->last_access;#d#
1313 1470
1471 cf::async {
1472 $_->contr->save for $self->players;
1473 };
1474
1314 if ($uniq) { 1475 if ($uniq) {
1315 $self->save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS); 1476 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS);
1316 $self->save_objects ($uniq, cf::IO_UNIQUES); 1477 $self->_save_objects ($uniq, cf::IO_UNIQUES);
1317 } else { 1478 } else {
1318 $self->save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES); 1479 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES);
1319 } 1480 }
1320} 1481}
1321 1482
1322sub swap_out { 1483sub swap_out {
1323 my ($self) = @_; 1484 my ($self) = @_;
1324 1485
1325 # save first because save cedes 1486 # save first because save cedes
1326 $self->save; 1487 $self->save;
1488
1489 my $lock = cf::lock_acquire "map_data:" . $self->path;
1327 1490
1328 return if $self->players; 1491 return if $self->players;
1329 return if $self->in_memory != cf::MAP_IN_MEMORY; 1492 return if $self->in_memory != cf::MAP_IN_MEMORY;
1330 return if $self->{deny_save}; 1493 return if $self->{deny_save};
1331 1494
… …
1335 1498
1336sub reset_at { 1499sub reset_at {
1337 my ($self) = @_; 1500 my ($self) = @_;
1338 1501
1339 # TODO: safety, remove and allow resettable per-player maps 1502 # TODO: safety, remove and allow resettable per-player maps
1340 return 1e99 if $self->{path}{user_rel}; 1503 return 1e99 if $self->isa ("ext::map_per_player");
1341 return 1e99 if $self->{deny_reset}; 1504 return 1e99 if $self->{deny_reset};
1342 1505
1343 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access; 1506 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
1344 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET; 1507 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET;
1345 1508
… …
1350 my ($self) = @_; 1513 my ($self) = @_;
1351 1514
1352 $self->reset_at <= $cf::RUNTIME 1515 $self->reset_at <= $cf::RUNTIME
1353} 1516}
1354 1517
1355sub unlink_save {
1356 my ($self) = @_;
1357
1358 utf8::encode (my $save = $self->{path}->save_path);
1359 aioreq_pri 3; IO::AIO::aio_unlink $save;
1360 aioreq_pri 3; IO::AIO::aio_unlink "$save.pst";
1361}
1362
1363sub rename { 1518sub rename {
1364 my ($self, $new_path) = @_; 1519 my ($self, $new_path) = @_;
1365 1520
1521 normalise $new_path;
1522
1366 $self->unlink_save; 1523 $self->unlink_save;
1367 1524
1368 delete $cf::MAP{$self->path}; 1525 delete $cf::MAP{$self->path};
1369 $self->{path} = new cf::path $new_path; 1526 $self->{path} = $new_path; $self->path ($self->{path});
1370 $self->path ($self->{path}->as_string);
1371 $cf::MAP{$self->path} = $self; 1527 $cf::MAP{$self->path} = $self;
1372 1528
1373 $self->save; 1529 $self->save;
1374} 1530}
1375 1531
1376sub reset { 1532sub reset {
1377 my ($self) = @_; 1533 my ($self) = @_;
1378 1534
1535 my $lock = cf::lock_acquire "map_data:$self->{path}";
1536
1379 return if $self->players; 1537 return if $self->players;
1380 return if $self->{path}{user_rel};#d# 1538 return if $self->isa ("ext::map_per_player");#d#
1381 1539
1382 warn "resetting map ", $self->path;#d# 1540 warn "resetting map ", $self->path;#d#
1383 1541
1384 delete $cf::MAP{$self->path}; 1542 delete $cf::MAP{$self->path};
1543
1544 $self->in_memory (cf::MAP_SWAPPED);
1545 $self->clear;
1385 1546
1386 $_->clear_links_to ($self) for values %cf::MAP; 1547 $_->clear_links_to ($self) for values %cf::MAP;
1387 1548
1388 $self->unlink_save; 1549 $self->unlink_save;
1389 $self->destroy; 1550 $self->destroy;
… …
1398 $self->reset_timeout (1); 1559 $self->reset_timeout (1);
1399 $self->rename ("{nuke}/" . ($nuke_counter++)); 1560 $self->rename ("{nuke}/" . ($nuke_counter++));
1400 $self->reset; # polite request, might not happen 1561 $self->reset; # polite request, might not happen
1401} 1562}
1402 1563
1403sub customise_for { 1564=item cf::map::unique_maps
1404 my ($map, $ob) = @_;
1405 1565
1406 if ($map->per_player) { 1566Returns an arrayref of paths of all shared maps that have
1407 return cf::map::find "~" . $ob->name . "/" . $map->{path}{path}; 1567instantiated unique items. May block.
1408 }
1409 1568
1410 $map 1569=cut
1411}
1412 1570
1413sub emergency_save { 1571sub unique_maps() {
1414 my $freeze_guard = cf::freeze_mainloop; 1572 my $files = aio_readdir cf::localdir . "/" . cf::uniquedir
1573 or return;
1415 1574
1416 warn "enter emergency map save\n"; 1575 my @paths;
1417 1576
1418 cf::sync_job { 1577 for (@$files) {
1419 warn "begin emergency map save\n"; 1578 utf8::decode $_;
1420 $_->save for values %cf::MAP; 1579 next if /\.pst$/;
1580 next unless /^$PATH_SEP/o;
1581
1582 s/\.map$//;
1583 push @paths, $_;
1421 }; 1584 }
1422 1585
1423 warn "end emergency map save\n"; 1586 \@paths
1424} 1587}
1425 1588
1426package cf; 1589package cf;
1427 1590
1428=back 1591=back
1429 1592
1593=head3 cf::object
1594
1595=cut
1596
1597package cf::object;
1598
1599=over 4
1600
1601=item $ob->inv_recursive
1602
1603Returns the inventory of the object _and_ their inventories, recursively.
1604
1605=cut
1606
1607sub inv_recursive_;
1608sub inv_recursive_ {
1609 map { $_, inv_recursive_ $_->inv } @_
1610}
1611
1612sub inv_recursive {
1613 inv_recursive_ inv $_[0]
1614}
1615
1616package cf;
1617
1618=back
1430 1619
1431=head3 cf::object::player 1620=head3 cf::object::player
1432 1621
1433=over 4 1622=over 4
1434 1623
… …
1474 1663
1475=item $player_object->enter_link 1664=item $player_object->enter_link
1476 1665
1477Freezes the player and moves him/her to a special map (C<{link}>). 1666Freezes the player and moves him/her to a special map (C<{link}>).
1478 1667
1479The player should be reaosnably safe there for short amounts of time. You 1668The player should be reasonably safe there for short amounts of time. You
1480I<MUST> call C<leave_link> as soon as possible, though. 1669I<MUST> call C<leave_link> as soon as possible, though.
1481 1670
1671Will never block.
1672
1482=item $player_object->leave_link ($map, $x, $y) 1673=item $player_object->leave_link ($map, $x, $y)
1483 1674
1484Moves the player out of the specila link map onto the given map. If the 1675Moves the player out of the special C<{link}> map onto the specified
1485map is not valid (or omitted), the player will be moved back to the 1676map. If the map is not valid (or omitted), the player will be moved back
1486location he/she was before the call to C<enter_link>, or, if that fails, 1677to the location he/she was before the call to C<enter_link>, or, if that
1487to the emergency map position. 1678fails, to the emergency map position.
1488 1679
1489Might block. 1680Might block.
1490 1681
1491=cut 1682=cut
1683
1684sub link_map {
1685 unless ($LINK_MAP) {
1686 $LINK_MAP = cf::map::find "{link}"
1687 or do { warn "FATAL: unable to provide {link} map, exiting."; exit 1 };
1688 $LINK_MAP->load;
1689 }
1690
1691 $LINK_MAP
1692}
1492 1693
1493sub cf::object::player::enter_link { 1694sub cf::object::player::enter_link {
1494 my ($self) = @_; 1695 my ($self) = @_;
1495 1696
1496 $self->deactivate_recursive; 1697 $self->deactivate_recursive;
1497 1698
1498 return if $self->map == $LINK_MAP; 1699 return if UNIVERSAL::isa $self->map, "ext::map_link";
1499 1700
1500 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y] 1701 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y]
1501 if $self->map; 1702 if $self->map;
1502 1703
1503 $self->enter_map ($LINK_MAP, 20, 20); 1704 $self->enter_map ($LINK_MAP || link_map, 20, 20);
1504} 1705}
1505 1706
1506sub cf::object::player::leave_link { 1707sub cf::object::player::leave_link {
1507 my ($self, $map, $x, $y) = @_; 1708 my ($self, $map, $x, $y) = @_;
1508 1709
… …
1526 # use -1 or undef as default coordinates, not 0, 0 1727 # use -1 or undef as default coordinates, not 0, 0
1527 ($x, $y) = ($map->enter_x, $map->enter_y) 1728 ($x, $y) = ($map->enter_x, $map->enter_y)
1528 if $x <=0 && $y <= 0; 1729 if $x <=0 && $y <= 0;
1529 1730
1530 $map->load; 1731 $map->load;
1732 $map->load_diag;
1531 1733
1734 return unless $self->contr->active;
1532 $self->activate_recursive; 1735 $self->activate_recursive;
1533 $self->enter_map ($map, $x, $y); 1736 $self->enter_map ($map, $x, $y);
1534} 1737}
1535 1738
1536cf::player->attach ( 1739cf::player->attach (
… …
1549 1752
1550 # try to abort aborted map switching on player login :) 1753 # try to abort aborted map switching on player login :)
1551 # should happen only on crashes 1754 # should happen only on crashes
1552 if ($pl->ob->{_link_pos}) { 1755 if ($pl->ob->{_link_pos}) {
1553 $pl->ob->enter_link; 1756 $pl->ob->enter_link;
1554 cf::async { 1757 (async {
1555 # we need this sleep as the login has a concurrent enter_exit running 1758 # 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 1759 # and this sleep increases chances of the player not ending up in scorn
1760 $pl->ob->reply (undef,
1761 "There was an internal problem at your last logout, "
1762 . "the server will try to bring you to your intended destination in a second.",
1763 cf::NDI_RED);
1557 Coro::Timer::sleep 1; 1764 Coro::Timer::sleep 1;
1558 $pl->ob->leave_link; 1765 $pl->ob->leave_link;
1559 }; 1766 })->prio (2);
1560 } 1767 }
1561 }, 1768 },
1562); 1769);
1563 1770
1564=item $player_object->goto_map ($path, $x, $y) 1771=item $player_object->goto ($path, $x, $y)
1565 1772
1566=cut 1773=cut
1567 1774
1568sub cf::object::player::goto_map { 1775sub cf::object::player::goto {
1569 my ($self, $path, $x, $y) = @_; 1776 my ($self, $path, $x, $y) = @_;
1570 1777
1571 $self->enter_link; 1778 $self->enter_link;
1572 1779
1573 (cf::async { 1780 (async {
1574 $path = new cf::path $path;
1575
1576 my $map = cf::map::find $path->as_string; 1781 my $map = cf::map::find $path;
1577 $map = $map->customise_for ($self) if $map; 1782 $map = $map->customise_for ($self) if $map;
1578 1783
1579# warn "entering ", $map->path, " at ($x, $y)\n" 1784# warn "entering ", $map->path, " at ($x, $y)\n"
1580# if $map; 1785# if $map;
1581 1786
1582 $map or $self->message ("The exit is closed", cf::NDI_UNIQUE | cf::NDI_RED); 1787 $map or $self->message ("The exit to '" . ($path->visible_name) . "' is closed", cf::NDI_UNIQUE | cf::NDI_RED);
1583 1788
1584 $self->leave_link ($map, $x, $y); 1789 $self->leave_link ($map, $x, $y);
1585 })->prio (1); 1790 })->prio (1);
1586} 1791}
1587 1792
… …
1640 1845
1641 return unless $self->type == cf::PLAYER; 1846 return unless $self->type == cf::PLAYER;
1642 1847
1643 $self->enter_link; 1848 $self->enter_link;
1644 1849
1645 (cf::async { 1850 (async {
1646 $self->deactivate_recursive; # just to be sure 1851 $self->deactivate_recursive; # just to be sure
1647 unless (eval { 1852 unless (eval {
1648 prepare_random_map $exit 1853 prepare_random_map $exit
1649 if $exit->slaying eq "/!"; 1854 if $exit->slaying eq "/!";
1650 1855
1651 my $path = new cf::path $exit->slaying, $exit->map && $exit->map->path; 1856 my $path = new_from_path cf::map $exit->slaying, $exit->map && $exit->map->path;
1652 $self->goto_map ($path, $exit->stats->hp, $exit->stats->sp); 1857 $self->goto ($path, $exit->stats->hp, $exit->stats->sp);
1653 1858
1654 1; 1859 1;
1655 }) { 1860 }) {
1656 $self->message ("Something went wrong deep within the crossfire server. " 1861 $self->message ("Something went wrong deep within the crossfire server. "
1657 . "I'll try to bring you back to the map you were before. " 1862 . "I'll try to bring you back to the map you were before. "
1658 . "Please report this to the dungeon master", 1863 . "Please report this to the dungeon master!",
1659 cf::NDI_UNIQUE | cf::NDI_RED); 1864 cf::NDI_UNIQUE | cf::NDI_RED);
1660 1865
1661 warn "ERROR in enter_exit: $@"; 1866 warn "ERROR in enter_exit: $@";
1662 $self->leave_link; 1867 $self->leave_link;
1663 } 1868 }
… …
1731 } 1936 }
1732 } 1937 }
1733 }, 1938 },
1734); 1939);
1735 1940
1736=item $client->coro (\&cb) 1941=item $client->async (\&cb)
1737 1942
1738Create a new coroutine, running the specified callback. The coroutine will 1943Create a new coroutine, running the specified callback. The coroutine will
1739be automatically cancelled when the client gets destroyed (e.g. on logout, 1944be automatically cancelled when the client gets destroyed (e.g. on logout,
1740or loss of connection). 1945or loss of connection).
1741 1946
1742=cut 1947=cut
1743 1948
1744sub cf::client::coro { 1949sub cf::client::async {
1745 my ($self, $cb) = @_; 1950 my ($self, $cb) = @_;
1746 1951
1747 my $coro = &cf::async ($cb); 1952 my $coro = &Coro::async ($cb);
1748 1953
1749 $coro->on_destroy (sub { 1954 $coro->on_destroy (sub {
1750 delete $self->{_coro}{$coro+0}; 1955 delete $self->{_coro}{$coro+0};
1751 }); 1956 });
1752 1957
… …
1990 local $/; 2195 local $/;
1991 *CFG = YAML::Syck::Load <$fh>; 2196 *CFG = YAML::Syck::Load <$fh>;
1992 2197
1993 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37]; 2198 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37];
1994 2199
2200 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset};
2201 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset};
2202
1995 if (exists $CFG{mlockall}) { 2203 if (exists $CFG{mlockall}) {
1996 eval { 2204 eval {
1997 $CFG{mlockall} ? &mlockall : &munlockall 2205 $CFG{mlockall} ? eval "mlockall()" : eval "munlockall()"
1998 and die "WARNING: m(un)lockall failed: $!\n"; 2206 and die "WARNING: m(un)lockall failed: $!\n";
1999 }; 2207 };
2000 warn $@ if $@; 2208 warn $@ if $@;
2001 } 2209 }
2002} 2210}
2003 2211
2004sub main { 2212sub main {
2005 # we must not ever block the main coroutine 2213 # we must not ever block the main coroutine
2006 local $Coro::idle = sub { 2214 local $Coro::idle = sub {
2007 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d# 2215 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
2008 (Coro::unblock_sub {
2009 Event::one_event; 2216 async { Event::one_event };
2010 })->();
2011 }; 2217 };
2012 2218
2013 cfg_load; 2219 cfg_load;
2014 db_load; 2220 db_load;
2015 load_extensions; 2221 load_extensions;
2016 Event::loop; 2222 Event::loop;
2017} 2223}
2018 2224
2019############################################################################# 2225#############################################################################
2020# initialisation 2226# initialisation and cleanup
2227
2228# install some emergency cleanup handlers
2229BEGIN {
2230 for my $signal (qw(INT HUP TERM)) {
2231 Event->signal (
2232 data => WF_AUTOCANCEL,
2233 signal => $signal,
2234 cb => sub {
2235 cf::cleanup "SIG$signal";
2236 },
2237 );
2238 }
2239}
2240
2241sub emergency_save() {
2242 my $freeze_guard = cf::freeze_mainloop;
2243
2244 warn "enter emergency perl save\n";
2245
2246 cf::sync_job {
2247 # use a peculiar iteration method to avoid tripping on perl
2248 # refcount bugs in for. also avoids problems with players
2249 # and maps saved/destroyed asynchronously.
2250 warn "begin emergency player save\n";
2251 for my $login (keys %cf::PLAYER) {
2252 my $pl = $cf::PLAYER{$login} or next;
2253 $pl->valid or next;
2254 $pl->save;
2255 }
2256 warn "end emergency player save\n";
2257
2258 warn "begin emergency map save\n";
2259 for my $path (keys %cf::MAP) {
2260 my $map = $cf::MAP{$path} or next;
2261 $map->valid or next;
2262 $map->save;
2263 }
2264 warn "end emergency map save\n";
2265 };
2266
2267 warn "leave emergency perl save\n";
2268}
2021 2269
2022sub reload() { 2270sub reload() {
2023 # can/must only be called in main 2271 # can/must only be called in main
2024 if ($Coro::current != $Coro::main) { 2272 if ($Coro::current != $Coro::main) {
2025 warn "can only reload from main coroutine\n"; 2273 warn "can only reload from main coroutine\n";
2026 return; 2274 return;
2027 } 2275 }
2028 2276
2029 warn "reloading..."; 2277 warn "reloading...";
2030 2278
2279 warn "freezing server";
2031 my $guard = freeze_mainloop; 2280 my $guard = freeze_mainloop;
2032 cf::emergency_save; 2281 cf::emergency_save;
2033 2282
2283 warn "sync database to disk";
2284 cf::db_sync;
2285 IO::AIO::flush;
2286
2034 eval { 2287 eval {
2035 # if anything goes wrong in here, we should simply crash as we already saved 2288 # if anything goes wrong in here, we should simply crash as we already saved
2036 2289
2037 # cancel all watchers 2290 warn "cancel all watchers";
2038 for (Event::all_watchers) { 2291 for (Event::all_watchers) {
2039 $_->cancel if $_->data & WF_AUTOCANCEL; 2292 $_->cancel if $_->data & WF_AUTOCANCEL;
2040 } 2293 }
2041 2294
2042 # cancel all extension coros 2295 warn "cancel all extension coros";
2043 $_->cancel for values %EXT_CORO; 2296 $_->cancel for values %EXT_CORO;
2044 %EXT_CORO = (); 2297 %EXT_CORO = ();
2045 2298
2299 warn "remove commands";
2300 %COMMAND = ();
2301
2302 warn "remove ext commands";
2303 %EXTCMD = ();
2304
2046 # unload all extensions 2305 warn "unload/nuke all extensions";
2047 for (@exts) { 2306 for my $pkg (@EXTS) {
2048 warn "unloading <$_>"; 2307 warn "... unloading $pkg";
2049 unload_extension $_; 2308
2309 if (my $cb = $pkg->can ("unload")) {
2310 eval {
2311 $cb->($pkg);
2312 1
2313 } or warn "$pkg unloaded, but with errors: $@";
2050 } 2314 }
2051 2315
2316 warn "... nuking $pkg";
2317 Symbol::delete_package $pkg;
2318 }
2319
2052 # unload all modules loaded from $LIBDIR 2320 warn "unload all perl modules loaded from $LIBDIR";
2053 while (my ($k, $v) = each %INC) { 2321 while (my ($k, $v) = each %INC) {
2054 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/; 2322 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
2055 2323
2056 warn "removing <$k>"; 2324 warn "removing <$k>";
2057 delete $INC{$k}; 2325 delete $INC{$k};
… …
2064 } 2332 }
2065 2333
2066 Symbol::delete_package $k; 2334 Symbol::delete_package $k;
2067 } 2335 }
2068 2336
2069 # sync database to disk
2070 cf::db_sync;
2071 IO::AIO::flush;
2072
2073 # get rid of safe::, as good as possible 2337 warn "get rid of safe::, as good as possible";
2074 Symbol::delete_package "safe::$_" 2338 Symbol::delete_package "safe::$_"
2075 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region); 2339 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
2076 2340
2077 # remove register_script_function callbacks
2078 # TODO
2079
2080 # unload cf.pm "a bit" 2341 warn "unload cf.pm \"a bit\"";
2081 delete $INC{"cf.pm"}; 2342 delete $INC{"cf.pm"};
2082 2343
2083 # don't, removes xs symbols, too, 2344 # don't, removes xs symbols, too,
2084 # and global variables created in xs 2345 # and global variables created in xs
2085 #Symbol::delete_package __PACKAGE__; 2346 #Symbol::delete_package __PACKAGE__;
2086 2347
2087 # reload cf.pm
2088 warn "reloading cf.pm"; 2348 warn "reloading cf.pm";
2089 require cf; 2349 require cf;
2090 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 2350 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
2091 2351
2092 # load config and database again 2352 warn "load config and database again";
2093 cf::cfg_load; 2353 cf::cfg_load;
2094 cf::db_load; 2354 cf::db_load;
2095 2355
2096 # load extensions
2097 warn "load extensions"; 2356 warn "load extensions";
2098 cf::load_extensions; 2357 cf::load_extensions;
2099 2358
2100 # reattach attachments to objects 2359 warn "reattach attachments to objects/players";
2101 warn "reattach";
2102 _global_reattach; 2360 _global_reattach;
2361 warn "reattach attachments to maps";
2362 reattach $_ for values %MAP;
2103 }; 2363 };
2104 2364
2105 if ($@) { 2365 if ($@) {
2106 warn $@; 2366 warn $@;
2107 warn "error while reloading, exiting."; 2367 warn "error while reloading, exiting.";
2108 exit 1; 2368 exit 1;
2109 } 2369 }
2110 2370
2111 warn "reloaded successfully"; 2371 warn "reloaded";
2112}; 2372};
2113
2114#############################################################################
2115
2116unless ($LINK_MAP) {
2117 $LINK_MAP = cf::map::new;
2118
2119 $LINK_MAP->width (41);
2120 $LINK_MAP->height (41);
2121 $LINK_MAP->alloc;
2122 $LINK_MAP->path ("{link}");
2123 $LINK_MAP->{path} = bless { path => "{link}" }, "cf::path";
2124 $LINK_MAP->in_memory (MAP_IN_MEMORY);
2125
2126 # dirty hack because... archetypes are not yet loaded
2127 Event->timer (
2128 after => 2,
2129 cb => sub {
2130 $_[0]->w->cancel;
2131
2132 # provide some exits "home"
2133 my $exit = cf::object::new "exit";
2134
2135 $exit->slaying ($EMERGENCY_POSITION->[0]);
2136 $exit->stats->hp ($EMERGENCY_POSITION->[1]);
2137 $exit->stats->sp ($EMERGENCY_POSITION->[2]);
2138
2139 $LINK_MAP->insert ($exit->clone, 19, 19);
2140 $LINK_MAP->insert ($exit->clone, 19, 20);
2141 $LINK_MAP->insert ($exit->clone, 19, 21);
2142 $LINK_MAP->insert ($exit->clone, 20, 19);
2143 $LINK_MAP->insert ($exit->clone, 20, 21);
2144 $LINK_MAP->insert ($exit->clone, 21, 19);
2145 $LINK_MAP->insert ($exit->clone, 21, 20);
2146 $LINK_MAP->insert ($exit->clone, 21, 21);
2147
2148 $exit->destroy;
2149 });
2150
2151 $LINK_MAP->{deny_save} = 1;
2152 $LINK_MAP->{deny_reset} = 1;
2153
2154 $cf::MAP{$LINK_MAP->path} = $LINK_MAP;
2155}
2156
2157register "<global>", __PACKAGE__;
2158 2373
2159register_command "reload" => sub { 2374register_command "reload" => sub {
2160 my ($who, $arg) = @_; 2375 my ($who, $arg) = @_;
2161 2376
2162 if ($who->flag (FLAG_WIZ)) { 2377 if ($who->flag (FLAG_WIZ)) {
… …
2172 reentrant => 0, 2387 reentrant => 0,
2173 prio => 0, 2388 prio => 0,
2174 at => $NEXT_TICK || $TICK, 2389 at => $NEXT_TICK || $TICK,
2175 data => WF_AUTOCANCEL, 2390 data => WF_AUTOCANCEL,
2176 cb => sub { 2391 cb => sub {
2392 $NOW = Event::time;
2393
2177 cf::server_tick; # one server iteration 2394 cf::server_tick; # one server iteration
2178 $RUNTIME += $TICK; 2395 $RUNTIME += $TICK;
2179 $NEXT_TICK += $TICK; 2396 $NEXT_TICK += $TICK;
2397
2398 $WAIT_FOR_TICK->broadcast;
2399 $WAIT_FOR_TICK_ONE->send if $WAIT_FOR_TICK_ONE->awaited;
2180 2400
2181 # if we are delayed by four ticks or more, skip them all 2401 # if we are delayed by four ticks or more, skip them all
2182 $NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4; 2402 $NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4;
2183 2403
2184 $TICK_WATCHER->at ($NEXT_TICK); 2404 $TICK_WATCHER->at ($NEXT_TICK);
… …
2186 }, 2406 },
2187); 2407);
2188 2408
2189IO::AIO::max_poll_time $TICK * 0.2; 2409IO::AIO::max_poll_time $TICK * 0.2;
2190 2410
2191Event->io ( 2411$AIO_POLL_WATCHER = Event->io (
2192 fd => IO::AIO::poll_fileno, 2412 fd => IO::AIO::poll_fileno,
2193 poll => 'r', 2413 poll => 'r',
2194 prio => 5, 2414 prio => 5,
2195 data => WF_AUTOCANCEL, 2415 data => WF_AUTOCANCEL,
2196 cb => \&IO::AIO::poll_cb, 2416 cb => \&IO::AIO::poll_cb,
2197); 2417);
2198 2418
2199Event->timer ( 2419$WRITE_RUNTIME_WATCHER = Event->timer (
2200 data => WF_AUTOCANCEL, 2420 data => WF_AUTOCANCEL,
2201 after => 0, 2421 after => 0,
2202 interval => 10, 2422 interval => 10,
2203 cb => sub { 2423 cb => sub {
2204 (Coro::unblock_sub { 2424 (Coro::unblock_sub {

Diff Legend

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