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

Diff Legend

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