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.169 by root, Sun Jan 14 01:09:46 2007 UTC

… …
15use Coro::Timer; 15use Coro::Timer;
16use Coro::Signal; 16use Coro::Signal;
17use Coro::Semaphore; 17use Coro::Semaphore;
18use Coro::AIO; 18use Coro::AIO;
19 19
20use Data::Dumper;
20use Digest::MD5; 21use Digest::MD5;
21use Fcntl; 22use Fcntl;
22use IO::AIO 2.31 (); 23use IO::AIO 2.32 ();
23use YAML::Syck (); 24use YAML::Syck ();
24use Time::HiRes; 25use Time::HiRes;
25 26
26use Event; $Event::Eval = 1; # no idea why this is required, but it is 27use Event; $Event::Eval = 1; # no idea why this is required, but it is
27 28
29sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
30
28# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode? 31# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode?
29$YAML::Syck::ImplicitUnicode = 1; 32$YAML::Syck::ImplicitUnicode = 1;
30 33
31$Coro::main->prio (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
… …
755# object support 683# object support
756 684
757sub reattach { 685sub reattach {
758 # basically do the same as instantiate, without calling instantiate 686 # basically do the same as instantiate, without calling instantiate
759 my ($obj) = @_; 687 my ($obj) = @_;
688
689 bless $obj, ref $obj; # re-bless in case extensions have been reloaded
760 690
761 my $registry = $obj->registry; 691 my $registry = $obj->registry;
762 692
763 @$registry = (); 693 @$registry = ();
764 694
… …
896=cut 826=cut
897 827
898sub register_extcmd { 828sub register_extcmd {
899 my ($name, $cb) = @_; 829 my ($name, $cb) = @_;
900 830
901 my $caller = caller;
902 #warn "registering extcmd '$name' to '$caller'";
903
904 $EXTCMD{$name} = [$cb, $caller]; 831 $EXTCMD{$name} = $cb;
905} 832}
906 833
907cf::player->attach ( 834cf::player->attach (
908 on_command => sub { 835 on_command => sub {
909 my ($pl, $name, $params) = @_; 836 my ($pl, $name, $params) = @_;
… …
922 849
923 my $msg = eval { from_json $buf }; 850 my $msg = eval { from_json $buf };
924 851
925 if (ref $msg) { 852 if (ref $msg) {
926 if (my $cb = $EXTCMD{$msg->{msgtype}}) { 853 if (my $cb = $EXTCMD{$msg->{msgtype}}) {
927 if (my %reply = $cb->[0]->($pl, $msg)) { 854 if (my %reply = $cb->($pl, $msg)) {
928 $pl->ext_reply ($msg->{msgid}, %reply); 855 $pl->ext_reply ($msg->{msgid}, %reply);
929 } 856 }
930 } 857 }
931 } else { 858 } else {
932 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n"; 859 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
… …
934 861
935 cf::override; 862 cf::override;
936 }, 863 },
937); 864);
938 865
939sub register {
940 my ($base, $pkg) = @_;
941
942 #TODO
943}
944
945sub load_extension { 866sub load_extension {
946 my ($path) = @_; 867 my ($path) = @_;
947 868
948 $path =~ /([^\/\\]+)\.ext$/ or die "$path"; 869 $path =~ /([^\/\\]+)\.ext$/ or die "$path";
949 my $base = $1; 870 my $base = $1;
950 my $pkg = $1; 871 my $pkg = $1;
951 $pkg =~ s/[^[:word:]]/_/g; 872 $pkg =~ s/[^[:word:]]/_/g;
952 $pkg = "ext::$pkg"; 873 $pkg = "ext::$pkg";
953 874
954 warn "loading '$path' into '$pkg'\n"; 875 warn "... loading '$path' into '$pkg'\n";
955 876
956 open my $fh, "<:utf8", $path 877 open my $fh, "<:utf8", $path
957 or die "$path: $!"; 878 or die "$path: $!";
958 879
959 my $source = 880 my $source =
960 "package $pkg; use strict; use utf8;\n" 881 "package $pkg; use strict; use utf8;\n"
961 . "#line 1 \"$path\"\n{\n" 882 . "#line 1 \"$path\"\n{\n"
962 . (do { local $/; <$fh> }) 883 . (do { local $/; <$fh> })
963 . "\n};\n1"; 884 . "\n};\n1";
964 885
965 eval $source 886 unless (eval $source) {
966 or die $@ ? "$path: $@\n" 887 my $msg = $@ ? "$path: $@\n"
967 : "extension disabled.\n"; 888 : "extension disabled.\n";
968 889 if ($source =~ /^#!.*perl.*#.*MANDATORY/m) { # ugly match
969 push @exts, $pkg; 890 warn $@;
970 $ext_pkg{$base} = $pkg; 891 warn "mandatory extension failed to load, exiting.\n";
971 892 exit 1;
972# no strict 'refs'; 893 }
973# @{"$pkg\::ISA"} = ext::; 894 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# } 895 }
988 896
989 # remove commands 897 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} 898}
1014 899
1015sub load_extensions { 900sub load_extensions {
1016 for my $ext (<$LIBDIR/*.ext>) { 901 for my $ext (<$LIBDIR/*.ext>) {
1017 next unless -r $ext; 902 next unless -r $ext;
… …
1021 } or warn "$ext not loaded: $@"; 906 } or warn "$ext not loaded: $@";
1022 } 907 }
1023} 908}
1024 909
1025############################################################################# 910#############################################################################
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 911
1063=head2 CORE EXTENSIONS 912=head2 CORE EXTENSIONS
1064 913
1065Functions and methods that extend core crossfire objects. 914Functions and methods that extend core crossfire objects.
1066 915
916=cut
917
918package cf::player;
919
920use Coro::AIO;
921
1067=head3 cf::player 922=head3 cf::player
1068 923
1069=over 4 924=over 4
1070 925
1071=item cf::player::exists $login 926=item cf::player::find $login
1072 927
1073Returns true when the given account exists. 928Returns the given player object, loading it if necessary (might block).
1074 929
1075=cut 930=cut
1076 931
1077sub cf::player::exists($) { 932sub playerdir($) {
1078 cf::player::find $_[0] 933 cf::localdir
1079 or -f sprintf "%s/%s/%s/%s.pl", cf::localdir, cf::playerdir, ($_[0]) x 2; 934 . "/"
935 . cf::playerdir
936 . "/"
937 . (ref $_[0] ? $_[0]->ob->name : $_[0])
938}
939
940sub path($) {
941 my $login = ref $_[0] ? $_[0]->ob->name : $_[0];
942
943 (playerdir $login) . "/$login.pl"
944}
945
946sub find_active($) {
947 $cf::PLAYER{$_[0]}
948 and $cf::PLAYER{$_[0]}->active
949 and $cf::PLAYER{$_[0]}
950}
951
952sub exists($) {
953 my ($login) = @_;
954
955 $cf::PLAYER{$login}
956 or cf::sync_job { !aio_stat $login }
957}
958
959sub find($) {
960 return $cf::PLAYER{$_[0]} || do {
961 my $login = $_[0];
962
963 my $guard = cf::lock_acquire "user_find:$login";
964
965 $cf::PLAYER{$_[0]} || do {
966 my $pl = load_pl path $login
967 or return;
968 $cf::PLAYER{$login} = $pl
969 }
970 }
971}
972
973sub save($) {
974 my ($pl) = @_;
975
976 return if $pl->{deny_save};
977
978 my $path = path $pl;
979 my $guard = cf::lock_acquire "user_save:$path";
980
981 return if $pl->{deny_save};
982
983 aio_mkdir playerdir $pl, 0770;
984 $pl->{last_save} = $cf::RUNTIME;
985
986 $pl->save_pl ($path);
987 Coro::cede;
988}
989
990sub new($) {
991 my ($login) = @_;
992
993 my $self = create;
994
995 $self->ob->name ($login);
996 $self->{deny_save} = 1;
997
998 $cf::PLAYER{$login} = $self;
999
1000 $self
1001}
1002
1003=item $pl->quit_character
1004
1005Nukes the player without looking back. If logged in, the connection will
1006be destroyed. May block for a long time.
1007
1008=cut
1009
1010sub quit_character {
1011 my ($pl) = @_;
1012
1013 $pl->{deny_save} = 1;
1014 $pl->password ("*"); # this should lock out the player until we nuked the dir
1015
1016 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active;
1017 $pl->deactivate;
1018 $pl->invoke (cf::EVENT_PLAYER_QUIT);
1019 $pl->ns->destroy if $pl->ns;
1020
1021 my $path = playerdir $pl;
1022 my $temp = "$path~$cf::RUNTIME~deleting~";
1023 aio_rename $path, $temp;
1024 delete $cf::PLAYER{$pl->ob->name};
1025 $pl->destroy;
1026 IO::AIO::aio_rmtree $temp;
1027}
1028
1029=item cf::player::list_logins
1030
1031Returns am arrayref of all valid playernames in the system, can take a
1032while and may block, so not sync_job-capable, ever.
1033
1034=cut
1035
1036sub list_logins {
1037 my $dirs = aio_readdir cf::localdir . "/" . cf::playerdir
1038 or return [];
1039
1040 my @logins;
1041
1042 for my $login (@$dirs) {
1043 my $fh = aio_open path $login, Fcntl::O_RDONLY, 0 or next;
1044 aio_read $fh, 0, 512, my $buf, 0 or next;
1045 $buf !~ /^password -------------$/m or next; # official not-valid tag
1046
1047 utf8::decode $login;
1048 push @logins, $login;
1049 }
1050
1051 \@logins
1052}
1053
1054=item $player->maps
1055
1056Returns an arrayref of map paths that are private for this
1057player. May block.
1058
1059=cut
1060
1061sub maps($) {
1062 my ($pl) = @_;
1063
1064 my $files = aio_readdir playerdir $pl
1065 or return;
1066
1067 my @paths;
1068
1069 for (@$files) {
1070 utf8::decode $_;
1071 next if /\.(?:pl|pst)$/;
1072 next unless /^$PATH_SEP/o;
1073
1074 s/\.map$//;
1075 push @paths, "~" . $pl->ob->name . "/" . $_;
1076 }
1077
1078 \@paths
1080} 1079}
1081 1080
1082=item $player->ext_reply ($msgid, $msgtype, %msg) 1081=item $player->ext_reply ($msgid, $msgtype, %msg)
1083 1082
1084Sends an ext reply to the player. 1083Sends an ext reply to the player.
1085 1084
1086=cut 1085=cut
1087 1086
1088sub cf::player::ext_reply($$$%) { 1087sub ext_reply($$$%) {
1089 my ($self, $id, %msg) = @_; 1088 my ($self, $id, %msg) = @_;
1090 1089
1091 $msg{msgid} = $id; 1090 $msg{msgid} = $id;
1092 1091
1093 $self->send ("ext " . to_json \%msg); 1092 $self->send ("ext " . cf::to_json \%msg);
1094} 1093}
1094
1095package cf;
1095 1096
1096=back 1097=back
1097 1098
1098 1099
1099=head3 cf::map 1100=head3 cf::map
… …
1105package cf::map; 1106package cf::map;
1106 1107
1107use Fcntl; 1108use Fcntl;
1108use Coro::AIO; 1109use Coro::AIO;
1109 1110
1111use overload
1112 '""' => \&as_string;
1113
1110our $MAX_RESET = 3600; 1114our $MAX_RESET = 3600;
1111our $DEFAULT_RESET = 3000; 1115our $DEFAULT_RESET = 3000;
1112 1116
1113sub generate_random_map { 1117sub generate_random_map {
1114 my ($path, $rmp) = @_; 1118 my ($self, $rmp) = @_;
1115 1119
1116 # mit "rum" bekleckern, nicht 1120 # mit "rum" bekleckern, nicht
1117 cf::map::_create_random_map 1121 $self->_create_random_map (
1118 $path,
1119 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle}, 1122 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle},
1120 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle}, 1123 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle},
1121 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map}, 1124 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map},
1122 $rmp->{exit_on_final_map}, 1125 $rmp->{exit_on_final_map},
1123 $rmp->{xsize}, $rmp->{ysize}, 1126 $rmp->{xsize}, $rmp->{ysize},
1124 $rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3}, 1127 $rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3},
1125 $rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase}, 1128 $rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase},
1126 $rmp->{dungeon_level}, $rmp->{dungeon_depth}, $rmp->{decoroptions}, $rmp->{orientation}, 1129 $rmp->{dungeon_level}, $rmp->{dungeon_depth}, $rmp->{decoroptions}, $rmp->{orientation},
1127 $rmp->{origin_y}, $rmp->{origin_x}, $rmp->{random_seed}, $rmp->{total_map_hp}, 1130 $rmp->{origin_y}, $rmp->{origin_x}, $rmp->{random_seed}, $rmp->{total_map_hp},
1128 $rmp->{map_layout_style}, $rmp->{treasureoptions}, $rmp->{symmetry_used}, 1131 $rmp->{map_layout_style}, $rmp->{treasureoptions}, $rmp->{symmetry_used},
1129 (cf::region::find $rmp->{region}) 1132 (cf::region::find $rmp->{region}), $rmp->{custom}
1133 )
1134}
1135
1136sub register {
1137 my (undef, $regex) = @_;
1138 my $pkg = caller;
1139
1140 no strict;
1141 push @{"$pkg\::ISA"}, __PACKAGE__;
1142
1143 $EXT_MAP{$pkg} = qr<$regex>;
1144}
1145
1146# also paths starting with '/'
1147$EXT_MAP{"cf::map"} = qr{^(?=/)};
1148
1149sub normalise {
1150 my ($path, $base) = @_;
1151
1152 # map plan:
1153 #
1154 # /! non-realised random map exit (special hack!)
1155 # {... are special paths that are not being touched
1156 # ?xxx/... are special absolute paths
1157 # ?random/... random maps
1158 # /... normal maps
1159 # ~user/... per-player map of a specific user
1160
1161 $path =~ s/$PATH_SEP/\//go;
1162
1163 # treat it as relative path if it starts with
1164 # something that looks reasonable
1165 if ($path =~ m{^(?:\./|\.\./|\w)}) {
1166 $base or Carp::carp "normalise called with relative path and no base: '$path'";
1167
1168 $base =~ s{[^/]+/?$}{};
1169 $path = "$base/$path";
1170 }
1171
1172 for ($path) {
1173 redo if s{//}{/};
1174 redo if s{/\.?/}{/};
1175 redo if s{/[^/]+/\.\./}{/};
1176 }
1177
1178 $path
1179}
1180
1181sub new_from_path {
1182 my (undef, $path, $base) = @_;
1183
1184 return $path if UNIVERSAL::isa $path, "cf::map"; # already a map object
1185
1186 $path = normalise $path, $base;
1187
1188 for my $pkg (keys %EXT_MAP) {
1189 if ($path =~ $EXT_MAP{$pkg}) {
1190 my $self = bless cf::map::new, $pkg;
1191 $self->{path} = $path; $self->path ($path);
1192 $self->init; # pass $1 etc.
1193 return $self;
1194 }
1195 }
1196
1197 Carp::carp "unable to resolve path '$path'.";
1198 ()
1199}
1200
1201sub init {
1202 my ($self) = @_;
1203
1204 $self
1205}
1206
1207sub as_string {
1208 my ($self) = @_;
1209
1210 "$self->{path}"
1211}
1212
1213# the displayed name, this is a one way mapping
1214sub visible_name {
1215 &as_string
1216}
1217
1218# the original (read-only) location
1219sub load_path {
1220 my ($self) = @_;
1221
1222 sprintf "%s/%s/%s", cf::datadir, cf::mapdir, $self->{path}
1223}
1224
1225# the temporary/swap location
1226sub save_path {
1227 my ($self) = @_;
1228
1229 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g;
1230 sprintf "%s/%s/%s", cf::localdir, cf::tmpdir, $path
1231}
1232
1233# the unique path, undef == no special unique path
1234sub uniq_path {
1235 my ($self) = @_;
1236
1237 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g;
1238 sprintf "%s/%s/%s", cf::localdir, cf::uniquedir, $path
1130} 1239}
1131 1240
1132# and all this just because we cannot iterate over 1241# and all this just because we cannot iterate over
1133# all maps in C++... 1242# all maps in C++...
1134sub change_all_map_light { 1243sub change_all_map_light {
… …
1136 1245
1137 $_->change_map_light ($change) 1246 $_->change_map_light ($change)
1138 for grep $_->outdoor, values %cf::MAP; 1247 for grep $_->outdoor, values %cf::MAP;
1139} 1248}
1140 1249
1250sub unlink_save {
1251 my ($self) = @_;
1252
1253 utf8::encode (my $save = $self->save_path);
1254 IO::AIO::aioreq_pri 4; IO::AIO::aio_unlink $save;
1255 IO::AIO::aioreq_pri 4; IO::AIO::aio_unlink "$save.pst";
1256}
1257
1141sub try_load_header($) { 1258sub load_header_from($) {
1142 my ($path) = @_; 1259 my ($self, $path) = @_;
1143 1260
1144 utf8::encode $path; 1261 utf8::encode $path;
1145 aio_open $path, O_RDONLY, 0 1262 aio_open $path, O_RDONLY, 0
1146 or return; 1263 or return;
1147 1264
1148 my $map = cf::map::new 1265 $self->_load_header ($path)
1149 or return; 1266 or return;
1150 1267
1151 # for better error messages only, will be overwritten 1268 $self->{load_path} = $path;
1152 $map->path ($path);
1153 1269
1154 $map->load_header ($path) 1270 1
1271}
1272
1273sub load_orig {
1274 my ($self) = @_;
1275
1276 $self->load_header_from ($self->load_path)
1277}
1278
1279sub load_temp {
1280 my ($self) = @_;
1281
1282 $self->load_header_from ($self->save_path)
1283}
1284
1285sub load_header {
1286 my ($self) = @_;
1287
1288 if ($self->load_temp) {
1289 $self->last_access ((delete $self->{last_access})
1290 || $cf::RUNTIME); #d#
1291 # safety
1292 $self->{instantiate_time} = $cf::RUNTIME
1293 if $self->{instantiate_time} > $cf::RUNTIME;
1294 } else {
1295 $self->load_orig
1155 or return; 1296 or return;
1156 1297
1157 $map->{load_path} = $path; 1298 $self->{load_original} = 1;
1299 $self->{instantiate_time} = $cf::RUNTIME;
1300 $self->last_access ($cf::RUNTIME);
1301 $self->instantiate;
1302 }
1158 1303
1159 $map 1304 1
1160} 1305}
1161 1306
1162sub find; 1307sub find;
1163sub find { 1308sub find {
1164 my ($path, $origin) = @_; 1309 my ($path, $origin) = @_;
1165 1310
1166 #warn "find<$path,$origin>\n";#d#
1167
1168 $path = new cf::path $path, $origin && $origin->path; 1311 $path = normalise $path, $origin && $origin->path;
1169 my $key = $path->as_string;
1170 1312
1171 cf::lock_wait "map_find:$key"; 1313 cf::lock_wait "map_find:$path";
1172 1314
1173 $cf::MAP{$key} || do { 1315 $cf::MAP{$path} || do {
1174 my $guard = cf::lock_acquire "map_find:$key"; 1316 my $guard = cf::lock_acquire "map_find:$path";
1175 1317 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; 1318 or return;
1195 1319
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; 1320 $map->{last_save} = $cf::RUNTIME;
1208 1321
1209 Coro::cede; 1322 $map->load_header
1323 or return;
1210 1324
1211 if ($map->should_reset) { 1325 if ($map->should_reset) {
1212 $map->reset; 1326 $map->reset;
1213 undef $guard; 1327 undef $guard;
1214 $map = find $path 1328 $map = find $path
1215 or return; 1329 or return;
1216 } 1330 }
1217 1331
1218 $cf::MAP{$key} = $map 1332 $cf::MAP{$path} = $map
1219 } 1333 }
1220} 1334}
1221 1335
1222sub load { 1336sub load {
1223 my ($self) = @_; 1337 my ($self) = @_;
1224 1338
1225 my $path = $self->{path}; 1339 my $path = $self->{path};
1226 my $guard = cf::lock_acquire "map_load:" . $path->as_string; 1340 my $guard = cf::lock_acquire "map_load:$path";
1227 1341
1228 return if $self->in_memory != cf::MAP_SWAPPED; 1342 return if $self->in_memory != cf::MAP_SWAPPED;
1229 1343
1230 $self->in_memory (cf::MAP_LOADING); 1344 $self->in_memory (cf::MAP_LOADING);
1231 1345
1232 $self->alloc; 1346 $self->alloc;
1233 $self->load_objects ($self->{load_path}, 1) 1347 $self->_load_objects ($self->{load_path}, 1)
1234 or return; 1348 or return;
1235 1349
1236 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1) 1350 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1)
1237 if delete $self->{load_original}; 1351 if delete $self->{load_original};
1238 1352
1239 if (my $uniq = $path->uniq_path) { 1353 if (my $uniq = $self->uniq_path) {
1240 utf8::encode $uniq; 1354 utf8::encode $uniq;
1241 if (aio_open $uniq, O_RDONLY, 0) { 1355 if (aio_open $uniq, O_RDONLY, 0) {
1242 $self->clear_unique_items; 1356 $self->clear_unique_items;
1243 $self->load_objects ($uniq, 0); 1357 $self->_load_objects ($uniq, 0);
1244 } 1358 }
1245 } 1359 }
1246 1360
1247 Coro::cede; 1361 Coro::cede;
1248 1362
1249 # now do the right thing for maps 1363 # now do the right thing for maps
1250 $self->link_multipart_objects; 1364 $self->link_multipart_objects;
1251 1365
1252 if ($self->{path}->is_style_map) { 1366 unless ($self->{deny_activate}) {
1253 $self->{deny_save} = 1; 1367 $self->decay_objects;
1254 $self->{deny_reset} = 1;
1255 } else {
1256 $self->fix_auto_apply; 1368 $self->fix_auto_apply;
1257 $self->decay_objects;
1258 $self->update_buttons; 1369 $self->update_buttons;
1370 Coro::cede;
1259 $self->set_darkness_map; 1371 $self->set_darkness_map;
1260 $self->difficulty ($self->estimate_difficulty) 1372 $self->difficulty ($self->estimate_difficulty)
1261 unless $self->difficulty; 1373 unless $self->difficulty;
1374 Coro::cede;
1262 $self->activate; 1375 $self->activate;
1263 } 1376 }
1264 1377
1265 Coro::cede;
1266
1267 $self->in_memory (cf::MAP_IN_MEMORY); 1378 $self->in_memory (cf::MAP_IN_MEMORY);
1379}
1380
1381sub customise_for {
1382 my ($self, $ob) = @_;
1383
1384 return find "~" . $ob->name . "/" . $self->{path}
1385 if $self->per_player;
1386
1387 $self
1388}
1389
1390# find and load all maps in the 3x3 area around a map
1391sub load_diag {
1392 my ($map) = @_;
1393
1394 my @diag; # diagonal neighbours
1395
1396 for (0 .. 3) {
1397 my $neigh = $map->tile_path ($_)
1398 or next;
1399 $neigh = find $neigh, $map
1400 or next;
1401 $neigh->load;
1402
1403 push @diag, [$neigh->tile_path (($_ + 3) % 4), $neigh],
1404 [$neigh->tile_path (($_ + 1) % 4), $neigh];
1405 }
1406
1407 for (@diag) {
1408 my $neigh = find @$_
1409 or next;
1410 $neigh->load;
1411 }
1268} 1412}
1269 1413
1270sub find_sync { 1414sub find_sync {
1271 my ($path, $origin) = @_; 1415 my ($path, $origin) = @_;
1272 1416
1273 cf::sync_job { cf::map::find $path, $origin } 1417 cf::sync_job { find $path, $origin }
1274} 1418}
1275 1419
1276sub do_load_sync { 1420sub do_load_sync {
1277 my ($map) = @_; 1421 my ($map) = @_;
1278 1422
1279 cf::sync_job { $map->load }; 1423 cf::sync_job { $map->load };
1280} 1424}
1281 1425
1426our %MAP_PREFETCH;
1427our $MAP_PREFETCHER = Coro::async {
1428 while () {
1429 for my $path (keys %MAP_PREFETCH) {
1430 my $map = find $path
1431 or next;
1432 $map->load;
1433
1434 delete $MAP_PREFETCH{$path};
1435 }
1436 Coro::schedule;
1437 }
1438};
1439
1440sub find_async {
1441 my ($path, $origin) = @_;
1442
1443 $path = normalise $path, $origin && $origin->{path};
1444
1445 if (my $map = $cf::MAP{$path}) {
1446 return $map if $map->in_memory == cf::MAP_IN_MEMORY;
1447 }
1448
1449 $MAP_PREFETCH{$path} = 0;
1450 $MAP_PREFETCHER->ready;
1451
1452 ()
1453}
1454
1282sub save { 1455sub save {
1283 my ($self) = @_; 1456 my ($self) = @_;
1284 1457
1285 my $lock = cf::lock_acquire "map_data:" . $self->path; 1458 my $lock = cf::lock_acquire "map_data:" . $self->path;
1286 1459
1287 $self->{last_save} = $cf::RUNTIME; 1460 $self->{last_save} = $cf::RUNTIME;
1288 1461
1289 return unless $self->dirty; 1462 return unless $self->dirty;
1290 1463
1291 my $save = $self->{path}->save_path; utf8::encode $save; 1464 my $save = $self->save_path; utf8::encode $save;
1292 my $uniq = $self->{path}->uniq_path; utf8::encode $uniq; 1465 my $uniq = $self->uniq_path; utf8::encode $uniq;
1293 1466
1294 $self->{load_path} = $save; 1467 $self->{load_path} = $save;
1295 1468
1296 return if $self->{deny_save}; 1469 return if $self->{deny_save};
1297 1470
1298 local $self->{last_access} = $self->last_access;#d# 1471 local $self->{last_access} = $self->last_access;#d#
1299 1472
1473 cf::async {
1474 $_->contr->save for $self->players;
1475 };
1476
1300 if ($uniq) { 1477 if ($uniq) {
1301 $self->save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS); 1478 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS);
1302 $self->save_objects ($uniq, cf::IO_UNIQUES); 1479 $self->_save_objects ($uniq, cf::IO_UNIQUES);
1303 } else { 1480 } else {
1304 $self->save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES); 1481 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES);
1305 } 1482 }
1306} 1483}
1307 1484
1308sub swap_out { 1485sub swap_out {
1309 my ($self) = @_; 1486 my ($self) = @_;
… …
1323 1500
1324sub reset_at { 1501sub reset_at {
1325 my ($self) = @_; 1502 my ($self) = @_;
1326 1503
1327 # TODO: safety, remove and allow resettable per-player maps 1504 # TODO: safety, remove and allow resettable per-player maps
1328 return 1e99 if $self->{path}{user_rel}; 1505 return 1e99 if $self->isa ("ext::map_per_player");#d#
1329 return 1e99 if $self->{deny_reset}; 1506 return 1e99 if $self->{deny_reset};
1330 1507
1331 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access; 1508 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
1332 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET; 1509 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET;
1333 1510
… …
1338 my ($self) = @_; 1515 my ($self) = @_;
1339 1516
1340 $self->reset_at <= $cf::RUNTIME 1517 $self->reset_at <= $cf::RUNTIME
1341} 1518}
1342 1519
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 { 1520sub rename {
1352 my ($self, $new_path) = @_; 1521 my ($self, $new_path) = @_;
1353 1522
1523 normalise $new_path;
1524
1354 $self->unlink_save; 1525 $self->unlink_save;
1355 1526
1356 delete $cf::MAP{$self->path}; 1527 delete $cf::MAP{$self->path};
1357 $self->{path} = new cf::path $new_path; 1528 $self->{path} = $new_path; $self->path ($self->{path});
1358 $self->path ($self->{path}->as_string);
1359 $cf::MAP{$self->path} = $self; 1529 $cf::MAP{$self->path} = $self;
1360 1530
1361 $self->save; 1531 $self->save;
1362} 1532}
1363 1533
1364sub reset { 1534sub reset {
1365 my ($self) = @_; 1535 my ($self) = @_;
1366 1536
1367 my $lock = cf::lock_acquire "map_data:" . $self->path; 1537 my $lock = cf::lock_acquire "map_data:$self->{path}";
1368 1538
1369 return if $self->players; 1539 return if $self->players;
1370 return if $self->{path}{user_rel};#d# 1540 return if $self->isa ("ext::map_per_player");#d#
1371 1541
1372 warn "resetting map ", $self->path;#d# 1542 warn "resetting map ", $self->path;#d#
1373 1543
1374 delete $cf::MAP{$self->path}; 1544 delete $cf::MAP{$self->path};
1545
1546 $self->in_memory (cf::MAP_SWAPPED);
1547 $self->clear;
1375 1548
1376 $_->clear_links_to ($self) for values %cf::MAP; 1549 $_->clear_links_to ($self) for values %cf::MAP;
1377 1550
1378 $self->unlink_save; 1551 $self->unlink_save;
1379 $self->destroy; 1552 $self->destroy;
… …
1388 $self->reset_timeout (1); 1561 $self->reset_timeout (1);
1389 $self->rename ("{nuke}/" . ($nuke_counter++)); 1562 $self->rename ("{nuke}/" . ($nuke_counter++));
1390 $self->reset; # polite request, might not happen 1563 $self->reset; # polite request, might not happen
1391} 1564}
1392 1565
1393sub customise_for { 1566=item cf::map::unique_maps
1394 my ($map, $ob) = @_;
1395 1567
1396 if ($map->per_player) { 1568Returns an arrayref of paths of all shared maps that have
1397 return cf::map::find "~" . $ob->name . "/" . $map->{path}{path}; 1569instantiated unique items. May block.
1398 }
1399 1570
1400 $map 1571=cut
1401}
1402 1572
1403sub emergency_save { 1573sub unique_maps() {
1404 my $freeze_guard = cf::freeze_mainloop; 1574 my $files = aio_readdir cf::localdir . "/" . cf::uniquedir
1575 or return;
1405 1576
1406 warn "enter emergency map save\n"; 1577 my @paths;
1407 1578
1408 cf::sync_job { 1579 for (@$files) {
1409 warn "begin emergency map save\n"; 1580 utf8::decode $_;
1410 $_->save for values %cf::MAP; 1581 next if /\.pst$/;
1582 next unless /^$PATH_SEP/o;
1583
1584 s/\.map$//;
1585 push @paths, $_;
1411 }; 1586 }
1412 1587
1413 warn "end emergency map save\n"; 1588 \@paths
1414} 1589}
1415 1590
1416package cf; 1591package cf;
1417 1592
1418=back 1593=back
1419 1594
1595=head3 cf::object
1596
1597=cut
1598
1599package cf::object;
1600
1601=over 4
1602
1603=item $ob->inv_recursive
1604
1605Returns the inventory of the object _and_ their inventories, recursively.
1606
1607=cut
1608
1609sub inv_recursive_;
1610sub inv_recursive_ {
1611 map { $_, inv_recursive_ $_->inv } @_
1612}
1613
1614sub inv_recursive {
1615 inv_recursive_ inv $_[0]
1616}
1617
1618package cf;
1619
1620=back
1420 1621
1421=head3 cf::object::player 1622=head3 cf::object::player
1422 1623
1423=over 4 1624=over 4
1424 1625
… …
1464 1665
1465=item $player_object->enter_link 1666=item $player_object->enter_link
1466 1667
1467Freezes the player and moves him/her to a special map (C<{link}>). 1668Freezes the player and moves him/her to a special map (C<{link}>).
1468 1669
1469The player should be reaosnably safe there for short amounts of time. You 1670The player should be reasonably safe there for short amounts of time. You
1470I<MUST> call C<leave_link> as soon as possible, though. 1671I<MUST> call C<leave_link> as soon as possible, though.
1471 1672
1673Will never block.
1674
1472=item $player_object->leave_link ($map, $x, $y) 1675=item $player_object->leave_link ($map, $x, $y)
1473 1676
1474Moves the player out of the specila link map onto the given map. If the 1677Moves the player out of the special C<{link}> map onto the specified
1475map is not valid (or omitted), the player will be moved back to the 1678map. If the map is not valid (or omitted), the player will be moved back
1476location he/she was before the call to C<enter_link>, or, if that fails, 1679to the location he/she was before the call to C<enter_link>, or, if that
1477to the emergency map position. 1680fails, to the emergency map position.
1478 1681
1479Might block. 1682Might block.
1480 1683
1481=cut 1684=cut
1685
1686sub link_map {
1687 unless ($LINK_MAP) {
1688 $LINK_MAP = cf::map::find "{link}"
1689 or do { warn "FATAL: unable to provide {link} map, exiting."; exit 1 };
1690 $LINK_MAP->load;
1691 }
1692
1693 $LINK_MAP
1694}
1482 1695
1483sub cf::object::player::enter_link { 1696sub cf::object::player::enter_link {
1484 my ($self) = @_; 1697 my ($self) = @_;
1485 1698
1486 $self->deactivate_recursive; 1699 $self->deactivate_recursive;
1487 1700
1488 return if $self->map == $LINK_MAP; 1701 return if UNIVERSAL::isa $self->map, "ext::map_link";
1489 1702
1490 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y] 1703 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y]
1491 if $self->map; 1704 if $self->map;
1492 1705
1493 $self->enter_map ($LINK_MAP, 20, 20); 1706 $self->enter_map ($LINK_MAP || link_map, 20, 20);
1494} 1707}
1495 1708
1496sub cf::object::player::leave_link { 1709sub cf::object::player::leave_link {
1497 my ($self, $map, $x, $y) = @_; 1710 my ($self, $map, $x, $y) = @_;
1498 1711
… …
1516 # use -1 or undef as default coordinates, not 0, 0 1729 # use -1 or undef as default coordinates, not 0, 0
1517 ($x, $y) = ($map->enter_x, $map->enter_y) 1730 ($x, $y) = ($map->enter_x, $map->enter_y)
1518 if $x <=0 && $y <= 0; 1731 if $x <=0 && $y <= 0;
1519 1732
1520 $map->load; 1733 $map->load;
1734 $map->load_diag;
1521 1735
1736 return unless $self->contr->active;
1522 $self->activate_recursive; 1737 $self->activate_recursive;
1523 $self->enter_map ($map, $x, $y); 1738 $self->enter_map ($map, $x, $y);
1524} 1739}
1525 1740
1526cf::player->attach ( 1741cf::player->attach (
… …
1539 1754
1540 # try to abort aborted map switching on player login :) 1755 # try to abort aborted map switching on player login :)
1541 # should happen only on crashes 1756 # should happen only on crashes
1542 if ($pl->ob->{_link_pos}) { 1757 if ($pl->ob->{_link_pos}) {
1543 $pl->ob->enter_link; 1758 $pl->ob->enter_link;
1544 Coro::async_pool { 1759 (async {
1545 # we need this sleep as the login has a concurrent enter_exit running 1760 # we need this sleep as the login has a concurrent enter_exit running
1546 # and this sleep increases chances of the player not ending up in scorn 1761 # and this sleep increases chances of the player not ending up in scorn
1762 $pl->ob->reply (undef,
1763 "There was an internal problem at your last logout, "
1764 . "the server will try to bring you to your intended destination in a second.",
1765 cf::NDI_RED);
1547 Coro::Timer::sleep 1; 1766 Coro::Timer::sleep 1;
1548 $pl->ob->leave_link; 1767 $pl->ob->leave_link;
1549 }; 1768 })->prio (2);
1550 } 1769 }
1551 }, 1770 },
1552); 1771);
1553 1772
1554=item $player_object->goto ($path, $x, $y) 1773=item $player_object->goto ($path, $x, $y)
… …
1558sub cf::object::player::goto { 1777sub cf::object::player::goto {
1559 my ($self, $path, $x, $y) = @_; 1778 my ($self, $path, $x, $y) = @_;
1560 1779
1561 $self->enter_link; 1780 $self->enter_link;
1562 1781
1563 (Coro::async_pool { 1782 (async {
1564 $path = new cf::path $path;
1565
1566 my $map = cf::map::find $path->as_string; 1783 my $map = cf::map::find $path;
1567 $map = $map->customise_for ($self) if $map; 1784 $map = $map->customise_for ($self) if $map;
1568 1785
1569# warn "entering ", $map->path, " at ($x, $y)\n" 1786# warn "entering ", $map->path, " at ($x, $y)\n"
1570# if $map; 1787# if $map;
1571 1788
1572 $map or $self->message ("The exit is closed", cf::NDI_UNIQUE | cf::NDI_RED); 1789 $map or $self->message ("The exit to '" . ($path->visible_name) . "' is closed", cf::NDI_UNIQUE | cf::NDI_RED);
1573 1790
1574 $self->leave_link ($map, $x, $y); 1791 $self->leave_link ($map, $x, $y);
1575 })->prio (1); 1792 })->prio (1);
1576} 1793}
1577 1794
… …
1630 1847
1631 return unless $self->type == cf::PLAYER; 1848 return unless $self->type == cf::PLAYER;
1632 1849
1633 $self->enter_link; 1850 $self->enter_link;
1634 1851
1635 (Coro::async_pool { 1852 (async {
1636 $self->deactivate_recursive; # just to be sure 1853 $self->deactivate_recursive; # just to be sure
1637 unless (eval { 1854 unless (eval {
1638 prepare_random_map $exit 1855 prepare_random_map $exit
1639 if $exit->slaying eq "/!"; 1856 if $exit->slaying eq "/!";
1640 1857
1641 my $path = new cf::path $exit->slaying, $exit->map && $exit->map->path; 1858 my $path = new_from_path cf::map $exit->slaying, $exit->map && $exit->map->path;
1642 $self->goto ($path, $exit->stats->hp, $exit->stats->sp); 1859 $self->goto ($path, $exit->stats->hp, $exit->stats->sp);
1643 1860
1644 1; 1861 1;
1645 }) { 1862 }) {
1646 $self->message ("Something went wrong deep within the crossfire server. " 1863 $self->message ("Something went wrong deep within the crossfire server. "
1647 . "I'll try to bring you back to the map you were before. " 1864 . "I'll try to bring you back to the map you were before. "
1648 . "Please report this to the dungeon master", 1865 . "Please report this to the dungeon master!",
1649 cf::NDI_UNIQUE | cf::NDI_RED); 1866 cf::NDI_UNIQUE | cf::NDI_RED);
1650 1867
1651 warn "ERROR in enter_exit: $@"; 1868 warn "ERROR in enter_exit: $@";
1652 $self->leave_link; 1869 $self->leave_link;
1653 } 1870 }
… …
1721 } 1938 }
1722 } 1939 }
1723 }, 1940 },
1724); 1941);
1725 1942
1726=item $client->coro (\&cb) 1943=item $client->async (\&cb)
1727 1944
1728Create a new coroutine, running the specified callback. The coroutine will 1945Create a new coroutine, running the specified callback. The coroutine will
1729be automatically cancelled when the client gets destroyed (e.g. on logout, 1946be automatically cancelled when the client gets destroyed (e.g. on logout,
1730or loss of connection). 1947or loss of connection).
1731 1948
1732=cut 1949=cut
1733 1950
1734sub cf::client::coro { 1951sub cf::client::async {
1735 my ($self, $cb) = @_; 1952 my ($self, $cb) = @_;
1736 1953
1737 my $coro = &Coro::async_pool ($cb); 1954 my $coro = &Coro::async ($cb);
1738 1955
1739 $coro->on_destroy (sub { 1956 $coro->on_destroy (sub {
1740 delete $self->{_coro}{$coro+0}; 1957 delete $self->{_coro}{$coro+0};
1741 }); 1958 });
1742 1959
… …
1980 local $/; 2197 local $/;
1981 *CFG = YAML::Syck::Load <$fh>; 2198 *CFG = YAML::Syck::Load <$fh>;
1982 2199
1983 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37]; 2200 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37];
1984 2201
2202 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset};
2203 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset};
2204
1985 if (exists $CFG{mlockall}) { 2205 if (exists $CFG{mlockall}) {
1986 eval { 2206 eval {
1987 $CFG{mlockall} ? &mlockall : &munlockall 2207 $CFG{mlockall} ? eval "mlockall()" : eval "munlockall()"
1988 and die "WARNING: m(un)lockall failed: $!\n"; 2208 and die "WARNING: m(un)lockall failed: $!\n";
1989 }; 2209 };
1990 warn $@ if $@; 2210 warn $@ if $@;
1991 } 2211 }
1992} 2212}
1993 2213
1994sub main { 2214sub main {
1995 # we must not ever block the main coroutine 2215 # we must not ever block the main coroutine
1996 local $Coro::idle = sub { 2216 local $Coro::idle = sub {
1997 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d# 2217 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
1998 (Coro::unblock_sub {
1999 Event::one_event; 2218 async { Event::one_event };
2000 })->();
2001 }; 2219 };
2002 2220
2003 cfg_load; 2221 cfg_load;
2004 db_load; 2222 db_load;
2005 load_extensions; 2223 load_extensions;
2006 Event::loop; 2224 Event::loop;
2007} 2225}
2008 2226
2009############################################################################# 2227#############################################################################
2010# initialisation 2228# initialisation and cleanup
2229
2230# install some emergency cleanup handlers
2231BEGIN {
2232 for my $signal (qw(INT HUP TERM)) {
2233 Event->signal (
2234 data => WF_AUTOCANCEL,
2235 signal => $signal,
2236 cb => sub {
2237 cf::cleanup "SIG$signal";
2238 },
2239 );
2240 }
2241}
2242
2243sub emergency_save() {
2244 my $freeze_guard = cf::freeze_mainloop;
2245
2246 warn "enter emergency perl save\n";
2247
2248 cf::sync_job {
2249 # use a peculiar iteration method to avoid tripping on perl
2250 # refcount bugs in for. also avoids problems with players
2251 # and maps saved/destroyed asynchronously.
2252 warn "begin emergency player save\n";
2253 for my $login (keys %cf::PLAYER) {
2254 my $pl = $cf::PLAYER{$login} or next;
2255 $pl->valid or next;
2256 $pl->save;
2257 }
2258 warn "end emergency player save\n";
2259
2260 warn "begin emergency map save\n";
2261 for my $path (keys %cf::MAP) {
2262 my $map = $cf::MAP{$path} or next;
2263 $map->valid or next;
2264 $map->save;
2265 }
2266 warn "end emergency map save\n";
2267 };
2268
2269 warn "leave emergency perl save\n";
2270}
2011 2271
2012sub reload() { 2272sub reload() {
2013 # can/must only be called in main 2273 # can/must only be called in main
2014 if ($Coro::current != $Coro::main) { 2274 if ($Coro::current != $Coro::main) {
2015 warn "can only reload from main coroutine\n"; 2275 warn "can only reload from main coroutine\n";
2016 return; 2276 return;
2017 } 2277 }
2018 2278
2019 warn "reloading..."; 2279 warn "reloading...";
2020 2280
2281 warn "freezing server";
2021 my $guard = freeze_mainloop; 2282 my $guard = freeze_mainloop;
2022 cf::emergency_save; 2283 cf::emergency_save;
2023 2284
2285 warn "sync database to disk";
2286 cf::db_sync;
2287 IO::AIO::flush;
2288
2024 eval { 2289 eval {
2025 # if anything goes wrong in here, we should simply crash as we already saved 2290 # if anything goes wrong in here, we should simply crash as we already saved
2026 2291
2027 # cancel all watchers 2292 warn "cancel all watchers";
2028 for (Event::all_watchers) { 2293 for (Event::all_watchers) {
2029 $_->cancel if $_->data & WF_AUTOCANCEL; 2294 $_->cancel if $_->data & WF_AUTOCANCEL;
2030 } 2295 }
2031 2296
2032 # cancel all extension coros 2297 warn "cancel all extension coros";
2033 $_->cancel for values %EXT_CORO; 2298 $_->cancel for values %EXT_CORO;
2034 %EXT_CORO = (); 2299 %EXT_CORO = ();
2035 2300
2301 warn "remove commands";
2302 %COMMAND = ();
2303
2304 warn "remove ext commands";
2305 %EXTCMD = ();
2306
2036 # unload all extensions 2307 warn "unload/nuke all extensions";
2037 for (@exts) { 2308 for my $pkg (@EXTS) {
2038 warn "unloading <$_>"; 2309 warn "... unloading $pkg";
2039 unload_extension $_; 2310
2311 if (my $cb = $pkg->can ("unload")) {
2312 eval {
2313 $cb->($pkg);
2314 1
2315 } or warn "$pkg unloaded, but with errors: $@";
2040 } 2316 }
2041 2317
2318 warn "... nuking $pkg";
2319 Symbol::delete_package $pkg;
2320 }
2321
2042 # unload all modules loaded from $LIBDIR 2322 warn "unload all perl modules loaded from $LIBDIR";
2043 while (my ($k, $v) = each %INC) { 2323 while (my ($k, $v) = each %INC) {
2044 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/; 2324 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
2045 2325
2046 warn "removing <$k>"; 2326 warn "removing <$k>";
2047 delete $INC{$k}; 2327 delete $INC{$k};
… …
2054 } 2334 }
2055 2335
2056 Symbol::delete_package $k; 2336 Symbol::delete_package $k;
2057 } 2337 }
2058 2338
2059 # sync database to disk
2060 cf::db_sync;
2061 IO::AIO::flush;
2062
2063 # get rid of safe::, as good as possible 2339 warn "get rid of safe::, as good as possible";
2064 Symbol::delete_package "safe::$_" 2340 Symbol::delete_package "safe::$_"
2065 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region); 2341 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
2066 2342
2067 # remove register_script_function callbacks
2068 # TODO
2069
2070 # unload cf.pm "a bit" 2343 warn "unload cf.pm \"a bit\"";
2071 delete $INC{"cf.pm"}; 2344 delete $INC{"cf.pm"};
2072 2345
2073 # don't, removes xs symbols, too, 2346 # don't, removes xs symbols, too,
2074 # and global variables created in xs 2347 # and global variables created in xs
2075 #Symbol::delete_package __PACKAGE__; 2348 #Symbol::delete_package __PACKAGE__;
2076 2349
2077 # reload cf.pm
2078 warn "reloading cf.pm"; 2350 warn "reloading cf.pm";
2079 require cf; 2351 require cf;
2080 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 2352 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
2081 2353
2082 # load config and database again 2354 warn "load config and database again";
2083 cf::cfg_load; 2355 cf::cfg_load;
2084 cf::db_load; 2356 cf::db_load;
2085 2357
2086 # load extensions
2087 warn "load extensions"; 2358 warn "load extensions";
2088 cf::load_extensions; 2359 cf::load_extensions;
2089 2360
2090 # reattach attachments to objects 2361 warn "reattach attachments to objects/players";
2091 warn "reattach";
2092 _global_reattach; 2362 _global_reattach;
2363 warn "reattach attachments to maps";
2364 reattach $_ for values %MAP;
2093 }; 2365 };
2094 2366
2095 if ($@) { 2367 if ($@) {
2096 warn $@; 2368 warn $@;
2097 warn "error while reloading, exiting."; 2369 warn "error while reloading, exiting.";
2098 exit 1; 2370 exit 1;
2099 } 2371 }
2100 2372
2101 warn "reloaded successfully"; 2373 warn "reloaded";
2102}; 2374};
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 2375
2149register_command "reload" => sub { 2376register_command "reload" => sub {
2150 my ($who, $arg) = @_; 2377 my ($who, $arg) = @_;
2151 2378
2152 if ($who->flag (FLAG_WIZ)) { 2379 if ($who->flag (FLAG_WIZ)) {
… …
2162 reentrant => 0, 2389 reentrant => 0,
2163 prio => 0, 2390 prio => 0,
2164 at => $NEXT_TICK || $TICK, 2391 at => $NEXT_TICK || $TICK,
2165 data => WF_AUTOCANCEL, 2392 data => WF_AUTOCANCEL,
2166 cb => sub { 2393 cb => sub {
2394 $NOW = Event::time;
2395
2167 cf::server_tick; # one server iteration 2396 cf::server_tick; # one server iteration
2168 $RUNTIME += $TICK; 2397 $RUNTIME += $TICK;
2169 $NEXT_TICK += $TICK; 2398 $NEXT_TICK += $TICK;
2399
2400 $WAIT_FOR_TICK->broadcast;
2401 $WAIT_FOR_TICK_ONE->send if $WAIT_FOR_TICK_ONE->awaited;
2170 2402
2171 # if we are delayed by four ticks or more, skip them all 2403 # if we are delayed by four ticks or more, skip them all
2172 $NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4; 2404 $NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4;
2173 2405
2174 $TICK_WATCHER->at ($NEXT_TICK); 2406 $TICK_WATCHER->at ($NEXT_TICK);
… …
2176 }, 2408 },
2177); 2409);
2178 2410
2179IO::AIO::max_poll_time $TICK * 0.2; 2411IO::AIO::max_poll_time $TICK * 0.2;
2180 2412
2181Event->io ( 2413$AIO_POLL_WATCHER = Event->io (
2182 fd => IO::AIO::poll_fileno, 2414 fd => IO::AIO::poll_fileno,
2183 poll => 'r', 2415 poll => 'r',
2184 prio => 5, 2416 prio => 5,
2185 data => WF_AUTOCANCEL, 2417 data => WF_AUTOCANCEL,
2186 cb => \&IO::AIO::poll_cb, 2418 cb => \&IO::AIO::poll_cb,
2187); 2419);
2188 2420
2189Event->timer ( 2421$WRITE_RUNTIME_WATCHER = Event->timer (
2190 data => WF_AUTOCANCEL, 2422 data => WF_AUTOCANCEL,
2191 after => 0, 2423 after => 0,
2192 interval => 10, 2424 interval => 10,
2193 cb => sub { 2425 cb => sub {
2194 (Coro::unblock_sub { 2426 (Coro::unblock_sub {

Diff Legend

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