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.140 by root, Fri Jan 5 20:04:02 2007 UTC vs.
Revision 1.161 by root, Thu Jan 11 00:16:58 2007 UTC

15use Coro::Timer; 15use Coro::Timer;
16use Coro::Signal; 16use Coro::Signal;
17use Coro::Semaphore; 17use Coro::Semaphore;
18use Coro::AIO; 18use Coro::AIO;
19 19
20use Data::Dumper;
20use Digest::MD5; 21use Digest::MD5;
21use Fcntl; 22use Fcntl;
22use IO::AIO 2.31 (); 23use IO::AIO 2.32 ();
23use YAML::Syck (); 24use YAML::Syck ();
24use Time::HiRes; 25use Time::HiRes;
25 26
26use Event; $Event::Eval = 1; # no idea why this is required, but it is 27use Event; $Event::Eval = 1; # no idea why this is required, but it is
27 28
29sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
30
28# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode? 31# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode?
29$YAML::Syck::ImplicitUnicode = 1; 32$YAML::Syck::ImplicitUnicode = 1;
30 33
31$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority 34$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority
32 35
33sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
34
35our %COMMAND = (); 36our %COMMAND = ();
36our %COMMAND_TIME = (); 37our %COMMAND_TIME = ();
38
39our @EXTS = (); # list of extension package names
37our %EXTCMD = (); 40our %EXTCMD = ();
41our %EXT_CORO = (); # coroutines bound to extensions
42our %EXT_MAP = (); # pluggable maps
38 43
39our @EVENT; 44our @EVENT;
40our $LIBDIR = datadir . "/ext"; 45our $LIBDIR = datadir . "/ext";
41 46
42our $TICK = MAX_TIME * 1e-6; 47our $TICK = MAX_TIME * 1e-6;
47our %CFG; 52our %CFG;
48 53
49our $UPTIME; $UPTIME ||= time; 54our $UPTIME; $UPTIME ||= time;
50our $RUNTIME; 55our $RUNTIME;
51 56
57our %PLAYER; # all users
52our %MAP; # all maps 58our %MAP; # all maps
53our $LINK_MAP; # the special {link} map 59our $LINK_MAP; # the special {link} map
54our $RANDOM_MAPS = cf::localdir . "/random"; 60our $RANDOM_MAPS = cf::localdir . "/random";
55our %EXT_CORO; 61
62our $WAIT_FOR_TICK; $WAIT_FOR_TICK ||= new Coro::Signal;
63our $WAIT_FOR_TICK_ONE; $WAIT_FOR_TICK_ONE ||= new Coro::Signal;
56 64
57binmode STDOUT; 65binmode STDOUT;
58binmode STDERR; 66binmode STDERR;
59 67
60# read virtual server time, if available 68# read virtual server time, if available
105=item %cf::CFG 113=item %cf::CFG
106 114
107Configuration for the server, loaded from C</etc/crossfire/config>, or 115Configuration for the server, loaded from C</etc/crossfire/config>, or
108from wherever your confdir points to. 116from wherever your confdir points to.
109 117
118=item $cf::WAIT_FOR_TICK, $cf::WAIT_FOR_TICK_ONE
119
120These are Coro::Signal objects that are C<< ->broadcast >> (WAIT_FOR_TICK)
121or C<< ->send >> (WAIT_FOR_TICK_ONE) on after normal server tick
122processing has been done. Call C<< ->wait >> on them to maximise the
123window of cpu time available, or simply to synchronise to the server tick.
124
110=back 125=back
111 126
112=cut 127=cut
113 128
114BEGIN { 129BEGIN {
117 utf8::encode $msg; 132 utf8::encode $msg;
118 133
119 $msg .= "\n" 134 $msg .= "\n"
120 unless $msg =~ /\n$/; 135 unless $msg =~ /\n$/;
121 136
122 LOG llevError, "cfperl: $msg"; 137 LOG llevError, $msg;
123 }; 138 };
124} 139}
125 140
126@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable'; 141@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
127@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable'; 142@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';
145 160
146$Event::DIED = sub { 161$Event::DIED = sub {
147 warn "error in event callback: @_"; 162 warn "error in event callback: @_";
148}; 163};
149 164
150my %ext_pkg;
151my @exts;
152my @hook;
153
154=head2 UTILITY FUNCTIONS 165=head2 UTILITY FUNCTIONS
155 166
156=over 4 167=over 4
157 168
169=item dumpval $ref
170
158=cut 171=cut
172
173sub dumpval {
174 eval {
175 local $SIG{__DIE__};
176 my $d;
177 if (1) {
178 $d = new Data::Dumper([$_[0]], ["*var"]);
179 $d->Terse(1);
180 $d->Indent(2);
181 $d->Quotekeys(0);
182 $d->Useqq(1);
183 #$d->Bless(...);
184 $d->Seen($_[1]) if @_ > 1;
185 $d = $d->Dump();
186 }
187 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge;
188 $d
189 } || "[unable to dump $_[0]: '$@']";
190}
159 191
160use JSON::Syck (); # TODO# replace by JSON::PC once working 192use JSON::Syck (); # TODO# replace by JSON::PC once working
161 193
162=item $ref = cf::from_json $json 194=item $ref = cf::from_json $json
163 195
273 warn $@ if $@; 305 warn $@ if $@;
274 undef $busy; 306 undef $busy;
275 })->prio (Coro::PRIO_MAX); 307 })->prio (Coro::PRIO_MAX);
276 308
277 while ($busy) { 309 while ($busy) {
278 unless (Coro::cede) { 310 Coro::cede or Event::one_event;
279 Coro::nready ? Event::one_event 0 : Event::one_event;
280 Coro::cede_notself unless Coro::cede;
281 }
282 } 311 }
283 312
284 wantarray ? @res : $res[0] 313 wantarray ? @res : $res[0]
285 } else { 314 } else {
286 # we are in another coroutine, how wonderful, everything just works 315 # we are in another coroutine, how wonderful, everything just works
289 } 318 }
290} 319}
291 320
292=item $coro = cf::async_ext { BLOCK } 321=item $coro = cf::async_ext { BLOCK }
293 322
294Like async, but this coro is automcatially being canceled when the 323Like async, but this coro is automatically being canceled when the
295extension calling this is being unloaded. 324extension calling this is being unloaded.
296 325
297=cut 326=cut
298 327
299sub async_ext(&) { 328sub async_ext(&) {
337 366
338############################################################################# 367#############################################################################
339 368
340package cf::path; 369package cf::path;
341 370
371use overload
372 '""' => \&as_string;
373
374# used to convert map paths into valid unix filenames by repalcing / by ∕
375our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons
376
377sub register {
378 my ($pkg, $prefix) = @_;
379
380 $EXT_MAP{$prefix} = $pkg;
381}
382
342sub new { 383sub new {
343 my ($class, $path, $base) = @_; 384 my ($class, $path, $base) = @_;
344 385
345 $path = $path->as_string if ref $path; 386 return $path if ref $path;
346 387
347 my $self = bless { }, $class; 388 my $self = {};
348 389
349 # {... are special paths that are not touched 390 # {... are special paths that are not being touched
350 # ?xxx/... are special absolute paths 391 # ?xxx/... are special absolute paths
351 # ?random/... random maps 392 # ?random/... random maps
352 # /! non-realised random map exit 393 # /! non-realised random map exit
353 # /... normal maps 394 # /... normal maps
354 # ~/... per-player maps without a specific player (DO NOT USE) 395 # ~/... per-player maps without a specific player (DO NOT USE)
355 # ~user/... per-player map of a specific user 396 # ~user/... per-player map of a specific user
356 397
398 $path =~ s/$PATH_SEP/\//go;
399
357 if ($path =~ /^{/) { 400 if ($path =~ /^{/) {
358 # fine as it is 401 # fine as it is
359 } elsif ($path =~ s{^\?random/}{}) {
360 Coro::AIO::aio_load "$cf::RANDOM_MAPS/$path.meta", my $data;
361 $self->{random} = cf::from_json $data;
362 } else { 402 } else {
363 if ($path =~ s{^~([^/]+)?}{}) { 403 if ($path =~ s{^~([^/]+)?}{}) {
404 # ~user
364 $self->{user_rel} = 1; 405 $self->{user_rel} = 1;
365 406
366 if (defined $1) { 407 if (defined $1) {
367 $self->{user} = $1; 408 $self->{user} = $1;
368 } elsif ($base =~ m{^~([^/]+)/}) { 409 } elsif ($base =~ m{^~([^/]+)/}) {
369 $self->{user} = $1; 410 $self->{user} = $1;
370 } else { 411 } else {
371 warn "cannot resolve user-relative path without user <$path,$base>\n"; 412 warn "cannot resolve user-relative path without user <$path,$base>\n";
372 } 413 }
414 } elsif ($path =~ s{^\?([^/]+)/}{}) {
415 # ?...
416 $self->{ext} = $1;
417 if (my $ext = $EXT_MAP{$1}) {
418 bless $self, $ext;
419 }
373 } elsif ($path =~ /^\//) { 420 } elsif ($path =~ /^\//) {
421 # /...
374 # already absolute 422 # already absolute
375 } else { 423 } else {
424 # relative
376 $base =~ s{[^/]+/?$}{}; 425 $base =~ s{[^/]+/?$}{};
377 return $class->new ("$base/$path"); 426 return $class->new ("$base/$path");
378 } 427 }
379 428
380 for ($path) { 429 for ($path) {
383 } 432 }
384 } 433 }
385 434
386 $self->{path} = $path; 435 $self->{path} = $path;
387 436
437 if ("HASH" eq ref $self) {
438 bless $self, $class;
439 } else {
440 $self->init;
441 }
442
443 for my $ext (values %EXT_MAP) {
444 if (my $subst = $ext->substitute ($self)) {
445 return $subst;
446 }
447 }
448
388 $self 449 $self
450}
451
452sub init {
453 # nop
454}
455
456sub substitute {
457 ()
389} 458}
390 459
391# the name / primary key / in-game path 460# the name / primary key / in-game path
392sub as_string { 461sub as_string {
393 my ($self) = @_; 462 my ($self) = @_;
394 463
395 $self->{user_rel} ? "~$self->{user}$self->{path}" 464 $self->{user_rel} ? "~$self->{user}$self->{path}"
396 : $self->{random} ? "?random/$self->{path}" 465 : $self->{ext} ? "?$self->{ext}/$self->{path}"
397 : $self->{path} 466 : $self->{path}
398} 467}
399 468
400# the displayed name, this is a one way mapping 469# the displayed name, this is a one way mapping
401sub visible_name { 470sub visible_name {
402 my ($self) = @_; 471 &as_string
403
404# if (my $rmp = $self->{random}) {
405# # todo: be more intelligent about this
406# "?random/$rmp->{origin_map}+$rmp->{origin_x}+$rmp->{origin_y}/$rmp->{dungeon_level}"
407# } else {
408 $self->as_string
409# }
410} 472}
411 473
412# escape the /'s in the path 474# escape the /'s in the path
413sub _escaped_path { 475sub _escaped_path {
414 # ∕ is U+2215
415 (my $path = $_[0]{path}) =~ s/\///g; 476 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g;
416 $path 477 $path
417} 478}
418 479
419# the original (read-only) location 480# the original (read-only) location
420sub load_path { 481sub load_path {
430 $self->{user_rel} ? sprintf "%s/%s/%s/%s", cf::localdir, cf::playerdir, $self->{user}, $self->_escaped_path 491 $self->{user_rel} ? sprintf "%s/%s/%s/%s", cf::localdir, cf::playerdir, $self->{user}, $self->_escaped_path
431 : $self->{random} ? sprintf "%s/%s", $RANDOM_MAPS, $self->{path} 492 : $self->{random} ? sprintf "%s/%s", $RANDOM_MAPS, $self->{path}
432 : sprintf "%s/%s/%s", cf::localdir, cf::tmpdir, $self->_escaped_path 493 : sprintf "%s/%s/%s", cf::localdir, cf::tmpdir, $self->_escaped_path
433} 494}
434 495
435# the unique path, might be eq to save_path 496# the unique path, undef == no special unique path
436sub uniq_path { 497sub uniq_path {
437 my ($self) = @_; 498 my ($self) = @_;
438 499
439 $self->{user_rel} || $self->{random}
440 ? undef
441 : sprintf "%s/%s/%s", cf::localdir, cf::uniquedir, $self->_escaped_path 500 sprintf "%s/%s/%s", cf::localdir, cf::uniquedir, $self->_escaped_path
442}
443
444# return random map parameters, or undef
445sub random_map_params {
446 my ($self) = @_;
447
448 $self->{random}
449} 501}
450 502
451# this is somewhat ugly, but style maps do need special treatment 503# this is somewhat ugly, but style maps do need special treatment
452sub is_style_map { 504sub is_style_map {
453 $_[0]{path} =~ m{^/styles/} 505 $_[0]{path} =~ m{^/styles/}
506}
507
508sub load_orig {
509 my ($self) = @_;
510
511 &cf::map::load_map_header ($self->load_path)
512}
513
514sub load_temp {
515 my ($self) = @_;
516
517 &cf::map::load_map_header ($self->save_path)
454} 518}
455 519
456package cf; 520package cf;
457 521
458############################################################################# 522#############################################################################
908=cut 972=cut
909 973
910sub register_extcmd { 974sub register_extcmd {
911 my ($name, $cb) = @_; 975 my ($name, $cb) = @_;
912 976
913 my $caller = caller;
914 #warn "registering extcmd '$name' to '$caller'";
915
916 $EXTCMD{$name} = [$cb, $caller]; 977 $EXTCMD{$name} = $cb;
917} 978}
918 979
919cf::player->attach ( 980cf::player->attach (
920 on_command => sub { 981 on_command => sub {
921 my ($pl, $name, $params) = @_; 982 my ($pl, $name, $params) = @_;
934 995
935 my $msg = eval { from_json $buf }; 996 my $msg = eval { from_json $buf };
936 997
937 if (ref $msg) { 998 if (ref $msg) {
938 if (my $cb = $EXTCMD{$msg->{msgtype}}) { 999 if (my $cb = $EXTCMD{$msg->{msgtype}}) {
939 if (my %reply = $cb->[0]->($pl, $msg)) { 1000 if (my %reply = $cb->($pl, $msg)) {
940 $pl->ext_reply ($msg->{msgid}, %reply); 1001 $pl->ext_reply ($msg->{msgid}, %reply);
941 } 1002 }
942 } 1003 }
943 } else { 1004 } else {
944 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n"; 1005 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
946 1007
947 cf::override; 1008 cf::override;
948 }, 1009 },
949); 1010);
950 1011
951sub register {
952 my ($base, $pkg) = @_;
953
954 #TODO
955}
956
957sub load_extension { 1012sub load_extension {
958 my ($path) = @_; 1013 my ($path) = @_;
959 1014
960 $path =~ /([^\/\\]+)\.ext$/ or die "$path"; 1015 $path =~ /([^\/\\]+)\.ext$/ or die "$path";
961 my $base = $1; 1016 my $base = $1;
962 my $pkg = $1; 1017 my $pkg = $1;
963 $pkg =~ s/[^[:word:]]/_/g; 1018 $pkg =~ s/[^[:word:]]/_/g;
964 $pkg = "ext::$pkg"; 1019 $pkg = "ext::$pkg";
965 1020
966 warn "loading '$path' into '$pkg'\n"; 1021 warn "... loading '$path' into '$pkg'\n";
967 1022
968 open my $fh, "<:utf8", $path 1023 open my $fh, "<:utf8", $path
969 or die "$path: $!"; 1024 or die "$path: $!";
970 1025
971 my $source = 1026 my $source =
976 1031
977 eval $source 1032 eval $source
978 or die $@ ? "$path: $@\n" 1033 or die $@ ? "$path: $@\n"
979 : "extension disabled.\n"; 1034 : "extension disabled.\n";
980 1035
981 push @exts, $pkg; 1036 push @EXTS, $pkg;
982 $ext_pkg{$base} = $pkg;
983
984# no strict 'refs';
985# @{"$pkg\::ISA"} = ext::;
986
987 register $base, $pkg;
988}
989
990sub unload_extension {
991 my ($pkg) = @_;
992
993 warn "removing extension $pkg\n";
994
995 # remove hooks
996 #TODO
997# for my $idx (0 .. $#PLUGIN_EVENT) {
998# delete $hook[$idx]{$pkg};
999# }
1000
1001 # remove commands
1002 for my $name (keys %COMMAND) {
1003 my @cb = grep $_->[0] ne $pkg, @{ $COMMAND{$name} };
1004
1005 if (@cb) {
1006 $COMMAND{$name} = \@cb;
1007 } else {
1008 delete $COMMAND{$name};
1009 }
1010 }
1011
1012 # remove extcmds
1013 for my $name (grep $EXTCMD{$_}[1] eq $pkg, keys %EXTCMD) {
1014 delete $EXTCMD{$name};
1015 }
1016
1017 if (my $cb = $pkg->can ("unload")) {
1018 eval {
1019 $cb->($pkg);
1020 1
1021 } or warn "$pkg unloaded, but with errors: $@";
1022 }
1023
1024 Symbol::delete_package $pkg;
1025} 1037}
1026 1038
1027sub load_extensions { 1039sub load_extensions {
1028 for my $ext (<$LIBDIR/*.ext>) { 1040 for my $ext (<$LIBDIR/*.ext>) {
1029 next unless -r $ext; 1041 next unless -r $ext;
1047}; 1059};
1048 1060
1049cf::map->attach (prio => -10000, package => cf::mapsupport::); 1061cf::map->attach (prio => -10000, package => cf::mapsupport::);
1050 1062
1051############################################################################# 1063#############################################################################
1052# load/save perl data associated with player->ob objects
1053
1054sub all_objects(@) {
1055 @_, map all_objects ($_->inv), @_
1056}
1057
1058# TODO: compatibility cruft, remove when no longer needed
1059cf::player->attach (
1060 on_load => sub {
1061 my ($pl, $path) = @_;
1062
1063 for my $o (all_objects $pl->ob) {
1064 if (my $value = $o->get_ob_key_value ("_perl_data")) {
1065 $o->set_ob_key_value ("_perl_data");
1066
1067 %$o = %{ Storable::thaw pack "H*", $value };
1068 }
1069 }
1070 },
1071);
1072
1073#############################################################################
1074 1064
1075=head2 CORE EXTENSIONS 1065=head2 CORE EXTENSIONS
1076 1066
1077Functions and methods that extend core crossfire objects. 1067Functions and methods that extend core crossfire objects.
1078 1068
1069=cut
1070
1071package cf::player;
1072
1073use Coro::AIO;
1074
1079=head3 cf::player 1075=head3 cf::player
1080 1076
1081=over 4 1077=over 4
1082 1078
1083=item cf::player::exists $login 1079=item cf::player::find $login
1084 1080
1085Returns true when the given account exists. 1081Returns the given player object, loading it if necessary (might block).
1086 1082
1087=cut 1083=cut
1088 1084
1089sub cf::player::exists($) { 1085sub playerdir($) {
1090 cf::player::find $_[0] 1086 cf::localdir
1091 or -f sprintf "%s/%s/%s/%s.pl", cf::localdir, cf::playerdir, ($_[0]) x 2; 1087 . "/"
1088 . cf::playerdir
1089 . "/"
1090 . (ref $_[0] ? $_[0]->ob->name : $_[0])
1091}
1092
1093sub path($) {
1094 my $login = ref $_[0] ? $_[0]->ob->name : $_[0];
1095
1096 (playerdir $login) . "/$login.pl"
1097}
1098
1099sub find_active($) {
1100 $cf::PLAYER{$_[0]}
1101 and $cf::PLAYER{$_[0]}->active
1102 and $cf::PLAYER{$_[0]}
1103}
1104
1105sub exists($) {
1106 my ($login) = @_;
1107
1108 $cf::PLAYER{$login}
1109 or cf::sync_job { !aio_stat $login }
1110}
1111
1112sub find($) {
1113 return $cf::PLAYER{$_[0]} || do {
1114 my $login = $_[0];
1115
1116 my $guard = cf::lock_acquire "user_find:$login";
1117
1118 $cf::PLAYER{$_[0]} || do {
1119 my $pl = load_pl path $login
1120 or return;
1121 $cf::PLAYER{$login} = $pl
1122 }
1123 }
1124}
1125
1126sub save($) {
1127 my ($pl) = @_;
1128
1129 return if $pl->{deny_save};
1130
1131 my $path = path $pl;
1132 my $guard = cf::lock_acquire "user_save:$path";
1133
1134 return if $pl->{deny_save};
1135
1136 aio_mkdir playerdir $pl, 0770;
1137 $pl->{last_save} = $cf::RUNTIME;
1138
1139 $pl->save_pl ($path);
1140 Coro::cede;
1141}
1142
1143sub new($) {
1144 my ($login) = @_;
1145
1146 my $self = create;
1147
1148 $self->ob->name ($login);
1149 $self->{deny_save} = 1;
1150
1151 $cf::PLAYER{$login} = $self;
1152
1153 $self
1154}
1155
1156=item $pl->quit_character
1157
1158Nukes the player without looking back. If logged in, the connection will
1159be destroyed. May block for a long time.
1160
1161=cut
1162
1163sub quit_character {
1164 my ($pl) = @_;
1165
1166 $pl->{deny_save} = 1;
1167 $pl->password ("*"); # this should lock out the player until we nuked the dir
1168
1169 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active;
1170 $pl->deactivate;
1171 $pl->invoke (cf::EVENT_PLAYER_QUIT);
1172 $pl->ns->destroy if $pl->ns;
1173
1174 my $path = playerdir $pl;
1175 my $temp = "$path~$cf::RUNTIME~deleting~";
1176 aio_rename $path, $temp;
1177 delete $cf::PLAYER{$pl->ob->name};
1178 $pl->destroy;
1179 IO::AIO::aio_rmtree $temp;
1180}
1181
1182=item cf::player::list_logins
1183
1184Returns am arrayref of all valid playernames in the system, can take a
1185while and may block, so not sync_job-capable, ever.
1186
1187=cut
1188
1189sub list_logins {
1190 my $dirs = aio_readdir cf::localdir . "/" . cf::playerdir
1191 or return [];
1192
1193 my @logins;
1194
1195 for my $login (@$dirs) {
1196 my $fh = aio_open path $login, Fcntl::O_RDONLY, 0 or next;
1197 aio_read $fh, 0, 512, my $buf, 0 or next;
1198 $buf !~ /^password -------------$/m or next; # official not-valid tag
1199
1200 utf8::decode $login;
1201 push @logins, $login;
1202 }
1203
1204 \@logins
1205}
1206
1207=item $player->maps
1208
1209Returns an arrayref of cf::path's of all maps that are private for this
1210player. May block.
1211
1212=cut
1213
1214sub maps($) {
1215 my ($pl) = @_;
1216
1217 my $files = aio_readdir playerdir $pl
1218 or return;
1219
1220 my @paths;
1221
1222 for (@$files) {
1223 utf8::decode $_;
1224 next if /\.(?:pl|pst)$/;
1225 next unless /^$PATH_SEP/o;
1226
1227 push @paths, new cf::path "~" . $pl->ob->name . "/" . $_;
1228 }
1229
1230 \@paths
1092} 1231}
1093 1232
1094=item $player->ext_reply ($msgid, $msgtype, %msg) 1233=item $player->ext_reply ($msgid, $msgtype, %msg)
1095 1234
1096Sends an ext reply to the player. 1235Sends an ext reply to the player.
1097 1236
1098=cut 1237=cut
1099 1238
1100sub cf::player::ext_reply($$$%) { 1239sub ext_reply($$$%) {
1101 my ($self, $id, %msg) = @_; 1240 my ($self, $id, %msg) = @_;
1102 1241
1103 $msg{msgid} = $id; 1242 $msg{msgid} = $id;
1104 1243
1105 $self->send ("ext " . to_json \%msg); 1244 $self->send ("ext " . cf::to_json \%msg);
1106} 1245}
1246
1247package cf;
1107 1248
1108=back 1249=back
1109 1250
1110 1251
1111=head3 cf::map 1252=head3 cf::map
1148 1289
1149 $_->change_map_light ($change) 1290 $_->change_map_light ($change)
1150 for grep $_->outdoor, values %cf::MAP; 1291 for grep $_->outdoor, values %cf::MAP;
1151} 1292}
1152 1293
1153sub try_load_header($) { 1294sub load_map_header($) {
1154 my ($path) = @_; 1295 my ($path) = @_;
1155 1296
1156 utf8::encode $path; 1297 utf8::encode $path;
1157 aio_open $path, O_RDONLY, 0 1298 aio_open $path, O_RDONLY, 0
1158 or return; 1299 or return;
1159 1300
1160 my $map = cf::map::new 1301 my $map = cf::map::new
1161 or return; 1302 or return;
1162 1303
1163 # for better error messages only, will be overwritten 1304 # for better error messages only, will be overwritten later
1164 $map->path ($path); 1305 $map->path ($path);
1165 1306
1166 $map->load_header ($path) 1307 $map->load_header ($path)
1167 or return; 1308 or return;
1168 1309
1184 1325
1185 $cf::MAP{$key} || do { 1326 $cf::MAP{$key} || do {
1186 my $guard = cf::lock_acquire "map_find:$key"; 1327 my $guard = cf::lock_acquire "map_find:$key";
1187 1328
1188 # do it the slow way 1329 # do it the slow way
1189 my $map = try_load_header $path->save_path; 1330 my $map = $path->load_temp;
1190 1331
1191 Coro::cede; 1332 Coro::cede;
1192 1333
1193 if ($map) { 1334 if ($map) {
1194 $map->last_access ((delete $map->{last_access}) 1335 $map->last_access ((delete $map->{last_access})
1195 || $cf::RUNTIME); #d# 1336 || $cf::RUNTIME); #d#
1196 # safety 1337 # safety
1197 $map->{instantiate_time} = $cf::RUNTIME 1338 $map->{instantiate_time} = $cf::RUNTIME
1198 if $map->{instantiate_time} > $cf::RUNTIME; 1339 if $map->{instantiate_time} > $cf::RUNTIME;
1199 } else { 1340 } else {
1200 if (my $rmp = $path->random_map_params) { 1341 $map = $path->load_orig
1201 $map = generate_random_map $key, $rmp;
1202 } else {
1203 $map = try_load_header $path->load_path;
1204 }
1205
1206 $map or return; 1342 or return;
1207 1343
1208 $map->{load_original} = 1; 1344 $map->{load_original} = 1;
1209 $map->{instantiate_time} = $cf::RUNTIME; 1345 $map->{instantiate_time} = $cf::RUNTIME;
1210 $map->last_access ($cf::RUNTIME); 1346 $map->last_access ($cf::RUNTIME);
1211 $map->instantiate; 1347 $map->instantiate;
1277 Coro::cede; 1413 Coro::cede;
1278 1414
1279 $self->in_memory (cf::MAP_IN_MEMORY); 1415 $self->in_memory (cf::MAP_IN_MEMORY);
1280} 1416}
1281 1417
1418# find and load all maps in the 3x3 area around a map
1419sub load_diag {
1420 my ($map) = @_;
1421
1422 my @diag; # diagonal neighbours
1423
1424 for (0 .. 3) {
1425 my $neigh = $map->tile_path ($_)
1426 or next;
1427 $neigh = find $neigh, $map
1428 or next;
1429 $neigh->load;
1430
1431 push @diag, [$neigh->tile_path (($_ + 3) % 4), $neigh],
1432 [$neigh->tile_path (($_ + 1) % 4), $neigh];
1433 }
1434
1435 for (@diag) {
1436 my $neigh = find @$_
1437 or next;
1438 $neigh->load;
1439 }
1440}
1441
1282sub find_sync { 1442sub find_sync {
1283 my ($path, $origin) = @_; 1443 my ($path, $origin) = @_;
1284 1444
1285 cf::sync_job { cf::map::find $path, $origin } 1445 cf::sync_job { find $path, $origin }
1286} 1446}
1287 1447
1288sub do_load_sync { 1448sub do_load_sync {
1289 my ($map) = @_; 1449 my ($map) = @_;
1290 1450
1291 cf::sync_job { $map->load }; 1451 cf::sync_job { $map->load };
1292} 1452}
1293 1453
1454our %MAP_PREFETCH;
1455our $MAP_PREFETCHER = Coro::async {
1456 while () {
1457 while (%MAP_PREFETCH) {
1458 my $key = each %MAP_PREFETCH
1459 or next;
1460 my $path = delete $MAP_PREFETCH{$key};
1461
1462 my $map = find $path
1463 or next;
1464 $map->load;
1465 }
1466 Coro::schedule;
1467 }
1468};
1469
1470sub find_async {
1471 my ($path, $origin) = @_;
1472
1473 $path = new cf::path $path, $origin && $origin->path;
1474 my $key = $path->as_string;
1475
1476 if (my $map = $cf::MAP{$key}) {
1477 return $map if $map->in_memory == cf::MAP_IN_MEMORY;
1478 }
1479
1480 $MAP_PREFETCH{$key} = $path;
1481 $MAP_PREFETCHER->ready;
1482
1483 ()
1484}
1485
1294sub save { 1486sub save {
1295 my ($self) = @_; 1487 my ($self) = @_;
1296 1488
1297 my $lock = cf::lock_acquire "map_data:" . $self->path; 1489 my $lock = cf::lock_acquire "map_data:" . $self->path;
1298 1490
1306 $self->{load_path} = $save; 1498 $self->{load_path} = $save;
1307 1499
1308 return if $self->{deny_save}; 1500 return if $self->{deny_save};
1309 1501
1310 local $self->{last_access} = $self->last_access;#d# 1502 local $self->{last_access} = $self->last_access;#d#
1503
1504 cf::async {
1505 $_->contr->save for $self->players;
1506 };
1311 1507
1312 if ($uniq) { 1508 if ($uniq) {
1313 $self->save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS); 1509 $self->save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS);
1314 $self->save_objects ($uniq, cf::IO_UNIQUES); 1510 $self->save_objects ($uniq, cf::IO_UNIQUES);
1315 } else { 1511 } else {
1410 } 1606 }
1411 1607
1412 $map 1608 $map
1413} 1609}
1414 1610
1415sub emergency_save { 1611=item cf::map::unique_maps
1416 my $freeze_guard = cf::freeze_mainloop;
1417 1612
1418 warn "enter emergency map save\n"; 1613Returns an arrayref of cf::path's of all shared maps that have
1614instantiated unique items. May block.
1419 1615
1420 cf::sync_job { 1616=cut
1421 warn "begin emergency map save\n"; 1617
1422 $_->save for values %cf::MAP; 1618sub unique_maps() {
1619 my $files = aio_readdir cf::localdir . "/" . cf::uniquedir
1620 or return;
1621
1622 my @paths;
1623
1624 for (@$files) {
1625 utf8::decode $_;
1626 next if /\.pst$/;
1627 next unless /^$PATH_SEP/o;
1628
1629 push @paths, new cf::path $_;
1423 }; 1630 }
1424 1631
1425 warn "end emergency map save\n"; 1632 \@paths
1426} 1633}
1427 1634
1428package cf; 1635package cf;
1429 1636
1430=back 1637=back
1431 1638
1639=head3 cf::object
1640
1641=cut
1642
1643package cf::object;
1644
1645=over 4
1646
1647=item $ob->inv_recursive
1648
1649Returns the inventory of the object _and_ their inventories, recursively.
1650
1651=cut
1652
1653sub inv_recursive_;
1654sub inv_recursive_ {
1655 map { $_, inv_recursive_ $_->inv } @_
1656}
1657
1658sub inv_recursive {
1659 inv_recursive_ inv $_[0]
1660}
1661
1662package cf;
1663
1664=back
1432 1665
1433=head3 cf::object::player 1666=head3 cf::object::player
1434 1667
1435=over 4 1668=over 4
1436 1669
1528 # use -1 or undef as default coordinates, not 0, 0 1761 # use -1 or undef as default coordinates, not 0, 0
1529 ($x, $y) = ($map->enter_x, $map->enter_y) 1762 ($x, $y) = ($map->enter_x, $map->enter_y)
1530 if $x <=0 && $y <= 0; 1763 if $x <=0 && $y <= 0;
1531 1764
1532 $map->load; 1765 $map->load;
1766 $map->load_diag;
1533 1767
1768 return unless $self->contr->active;
1534 $self->activate_recursive; 1769 $self->activate_recursive;
1535 $self->enter_map ($map, $x, $y); 1770 $self->enter_map ($map, $x, $y);
1536} 1771}
1537 1772
1538cf::player->attach ( 1773cf::player->attach (
1550 my ($pl) = @_; 1785 my ($pl) = @_;
1551 1786
1552 # try to abort aborted map switching on player login :) 1787 # try to abort aborted map switching on player login :)
1553 # should happen only on crashes 1788 # should happen only on crashes
1554 if ($pl->ob->{_link_pos}) { 1789 if ($pl->ob->{_link_pos}) {
1555
1556 $pl->ob->enter_link; 1790 $pl->ob->enter_link;
1557 (async { 1791 (async {
1558 # we need this sleep as the login has a concurrent enter_exit running 1792 # we need this sleep as the login has a concurrent enter_exit running
1559 # and this sleep increases chances of the player not ending up in scorn 1793 # and this sleep increases chances of the player not ending up in scorn
1560 $pl->ob->reply (undef, 1794 $pl->ob->reply (undef,
1573=cut 1807=cut
1574 1808
1575sub cf::object::player::goto { 1809sub cf::object::player::goto {
1576 my ($self, $path, $x, $y) = @_; 1810 my ($self, $path, $x, $y) = @_;
1577 1811
1812 $path = new cf::path $path;
1813
1578 $self->enter_link; 1814 $self->enter_link;
1579 1815
1580 (async { 1816 (async {
1581 $path = new cf::path $path;
1582
1583 my $map = cf::map::find $path->as_string; 1817 my $map = cf::map::find $path->as_string;
1584 $map = $map->customise_for ($self) if $map; 1818 $map = $map->customise_for ($self) if $map;
1585 1819
1586# warn "entering ", $map->path, " at ($x, $y)\n" 1820# warn "entering ", $map->path, " at ($x, $y)\n"
1587# if $map; 1821# if $map;
1588 1822
1589 $map or $self->message ("The exit is closed", cf::NDI_UNIQUE | cf::NDI_RED); 1823 $map or $self->message ("The exit to '" . ($path->visible_name) . "' is closed", cf::NDI_UNIQUE | cf::NDI_RED);
1590 1824
1591 $self->leave_link ($map, $x, $y); 1825 $self->leave_link ($map, $x, $y);
1592 })->prio (1); 1826 })->prio (1);
1593} 1827}
1594 1828
1660 1894
1661 1; 1895 1;
1662 }) { 1896 }) {
1663 $self->message ("Something went wrong deep within the crossfire server. " 1897 $self->message ("Something went wrong deep within the crossfire server. "
1664 . "I'll try to bring you back to the map you were before. " 1898 . "I'll try to bring you back to the map you were before. "
1665 . "Please report this to the dungeon master", 1899 . "Please report this to the dungeon master!",
1666 cf::NDI_UNIQUE | cf::NDI_RED); 1900 cf::NDI_UNIQUE | cf::NDI_RED);
1667 1901
1668 warn "ERROR in enter_exit: $@"; 1902 warn "ERROR in enter_exit: $@";
1669 $self->leave_link; 1903 $self->leave_link;
1670 } 1904 }
2002 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset}; 2236 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset};
2003 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset}; 2237 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset};
2004 2238
2005 if (exists $CFG{mlockall}) { 2239 if (exists $CFG{mlockall}) {
2006 eval { 2240 eval {
2007 $CFG{mlockall} ? &mlockall : &munlockall 2241 $CFG{mlockall} ? eval "mlockall()" : eval "munlockall()"
2008 and die "WARNING: m(un)lockall failed: $!\n"; 2242 and die "WARNING: m(un)lockall failed: $!\n";
2009 }; 2243 };
2010 warn $@ if $@; 2244 warn $@ if $@;
2011 } 2245 }
2012} 2246}
2023 load_extensions; 2257 load_extensions;
2024 Event::loop; 2258 Event::loop;
2025} 2259}
2026 2260
2027############################################################################# 2261#############################################################################
2028# initialisation 2262# initialisation and cleanup
2263
2264# install some emergency cleanup handlers
2265BEGIN {
2266 for my $signal (qw(INT HUP TERM)) {
2267 Event->signal (
2268 data => WF_AUTOCANCEL,
2269 signal => $signal,
2270 cb => sub {
2271 cf::cleanup "SIG$signal";
2272 },
2273 );
2274 }
2275}
2276
2277sub emergency_save() {
2278 my $freeze_guard = cf::freeze_mainloop;
2279
2280 warn "enter emergency perl save\n";
2281
2282 cf::sync_job {
2283 # use a peculiar iteration method to avoid tripping on perl
2284 # refcount bugs in for. also avoids problems with players
2285 # and maps saved/Destroyed asynchronously.
2286 warn "begin emergency player save\n";
2287 for my $login (keys %cf::PLAYER) {
2288 my $pl = $cf::PLAYER{$login} or next;
2289 $pl->valid or next;
2290 $pl->save;
2291 }
2292 warn "end emergency player save\n";
2293
2294 warn "begin emergency map save\n";
2295 for my $path (keys %cf::MAP) {
2296 my $map = $cf::MAP{$path} or next;
2297 $map->valid or next;
2298 $map->save;
2299 }
2300 warn "end emergency map save\n";
2301 };
2302
2303 warn "leave emergency perl save\n";
2304}
2029 2305
2030sub reload() { 2306sub reload() {
2031 # can/must only be called in main 2307 # can/must only be called in main
2032 if ($Coro::current != $Coro::main) { 2308 if ($Coro::current != $Coro::main) {
2033 warn "can only reload from main coroutine\n"; 2309 warn "can only reload from main coroutine\n";
2034 return; 2310 return;
2035 } 2311 }
2036 2312
2037 warn "reloading..."; 2313 warn "reloading...";
2038 2314
2315 warn "freezing server";
2039 my $guard = freeze_mainloop; 2316 my $guard = freeze_mainloop;
2040 cf::emergency_save; 2317 cf::emergency_save;
2041 2318
2319 warn "sync database to disk";
2320 cf::db_sync;
2321 IO::AIO::flush;
2322
2042 eval { 2323 eval {
2043 # if anything goes wrong in here, we should simply crash as we already saved 2324 # if anything goes wrong in here, we should simply crash as we already saved
2044 2325
2045 # cancel all watchers 2326 warn "cancel all watchers";
2046 for (Event::all_watchers) { 2327 for (Event::all_watchers) {
2047 $_->cancel if $_->data & WF_AUTOCANCEL; 2328 $_->cancel if $_->data & WF_AUTOCANCEL;
2048 } 2329 }
2049 2330
2050 # cancel all extension coros 2331 warn "cancel all extension coros";
2051 $_->cancel for values %EXT_CORO; 2332 $_->cancel for values %EXT_CORO;
2052 %EXT_CORO = (); 2333 %EXT_CORO = ();
2053 2334
2335 warn "remove commands";
2336 %COMMAND = ();
2337
2338 warn "remove ext commands";
2339 %EXTCMD = ();
2340
2054 # unload all extensions 2341 warn "unload/nuke all extensions";
2055 for (@exts) { 2342 for my $pkg (@EXTS) {
2056 warn "unloading <$_>"; 2343 warn "... unloading $pkg";
2057 unload_extension $_; 2344
2345 if (my $cb = $pkg->can ("unload")) {
2346 eval {
2347 $cb->($pkg);
2348 1
2349 } or warn "$pkg unloaded, but with errors: $@";
2058 } 2350 }
2059 2351
2352 warn "... nuking $pkg";
2353 Symbol::delete_package $pkg;
2354 }
2355
2060 # unload all modules loaded from $LIBDIR 2356 warn "unload all perl modules loaded from $LIBDIR";
2061 while (my ($k, $v) = each %INC) { 2357 while (my ($k, $v) = each %INC) {
2062 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/; 2358 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
2063 2359
2064 warn "removing <$k>"; 2360 warn "removing <$k>";
2065 delete $INC{$k}; 2361 delete $INC{$k};
2072 } 2368 }
2073 2369
2074 Symbol::delete_package $k; 2370 Symbol::delete_package $k;
2075 } 2371 }
2076 2372
2077 # sync database to disk
2078 cf::db_sync;
2079 IO::AIO::flush;
2080
2081 # get rid of safe::, as good as possible 2373 warn "get rid of safe::, as good as possible";
2082 Symbol::delete_package "safe::$_" 2374 Symbol::delete_package "safe::$_"
2083 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region); 2375 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
2084 2376
2085 # remove register_script_function callbacks
2086 # TODO
2087
2088 # unload cf.pm "a bit" 2377 warn "unload cf.pm \"a bit\"";
2089 delete $INC{"cf.pm"}; 2378 delete $INC{"cf.pm"};
2090 2379
2091 # don't, removes xs symbols, too, 2380 # don't, removes xs symbols, too,
2092 # and global variables created in xs 2381 # and global variables created in xs
2093 #Symbol::delete_package __PACKAGE__; 2382 #Symbol::delete_package __PACKAGE__;
2094 2383
2095 # reload cf.pm
2096 warn "reloading cf.pm"; 2384 warn "reloading cf.pm";
2097 require cf; 2385 require cf;
2098 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 2386 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
2099 2387
2100 # load config and database again 2388 warn "load config and database again";
2101 cf::cfg_load; 2389 cf::cfg_load;
2102 cf::db_load; 2390 cf::db_load;
2103 2391
2104 # load extensions
2105 warn "load extensions"; 2392 warn "load extensions";
2106 cf::load_extensions; 2393 cf::load_extensions;
2107 2394
2108 # reattach attachments to objects 2395 warn "reattach attachments to objects/players";
2109 warn "reattach";
2110 _global_reattach; 2396 _global_reattach;
2397 warn "reattach attachments to maps";
2398 reattach $_ for values %MAP;
2111 }; 2399 };
2112 2400
2113 if ($@) { 2401 if ($@) {
2114 warn $@; 2402 warn $@;
2115 warn "error while reloading, exiting."; 2403 warn "error while reloading, exiting.";
2116 exit 1; 2404 exit 1;
2117 } 2405 }
2118 2406
2119 warn "reloaded successfully"; 2407 warn "reloaded";
2120}; 2408};
2121 2409
2122############################################################################# 2410#############################################################################
2123 2411
2124unless ($LINK_MAP) { 2412unless ($LINK_MAP) {
2131 $LINK_MAP->{path} = bless { path => "{link}" }, "cf::path"; 2419 $LINK_MAP->{path} = bless { path => "{link}" }, "cf::path";
2132 $LINK_MAP->in_memory (MAP_IN_MEMORY); 2420 $LINK_MAP->in_memory (MAP_IN_MEMORY);
2133 2421
2134 # dirty hack because... archetypes are not yet loaded 2422 # dirty hack because... archetypes are not yet loaded
2135 Event->timer ( 2423 Event->timer (
2136 after => 2, 2424 after => 10,
2137 cb => sub { 2425 cb => sub {
2138 $_[0]->w->cancel; 2426 $_[0]->w->cancel;
2139 2427
2140 # provide some exits "home" 2428 # provide some exits "home"
2141 my $exit = cf::object::new "exit"; 2429 my $exit = cf::object::new "exit";
2159 $LINK_MAP->{deny_save} = 1; 2447 $LINK_MAP->{deny_save} = 1;
2160 $LINK_MAP->{deny_reset} = 1; 2448 $LINK_MAP->{deny_reset} = 1;
2161 2449
2162 $cf::MAP{$LINK_MAP->path} = $LINK_MAP; 2450 $cf::MAP{$LINK_MAP->path} = $LINK_MAP;
2163} 2451}
2164
2165register "<global>", __PACKAGE__;
2166 2452
2167register_command "reload" => sub { 2453register_command "reload" => sub {
2168 my ($who, $arg) = @_; 2454 my ($who, $arg) = @_;
2169 2455
2170 if ($who->flag (FLAG_WIZ)) { 2456 if ($who->flag (FLAG_WIZ)) {
2183 data => WF_AUTOCANCEL, 2469 data => WF_AUTOCANCEL,
2184 cb => sub { 2470 cb => sub {
2185 cf::server_tick; # one server iteration 2471 cf::server_tick; # one server iteration
2186 $RUNTIME += $TICK; 2472 $RUNTIME += $TICK;
2187 $NEXT_TICK += $TICK; 2473 $NEXT_TICK += $TICK;
2474
2475 $WAIT_FOR_TICK->broadcast;
2476 $WAIT_FOR_TICK_ONE->send if $WAIT_FOR_TICK_ONE->awaited;
2188 2477
2189 # if we are delayed by four ticks or more, skip them all 2478 # if we are delayed by four ticks or more, skip them all
2190 $NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4; 2479 $NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4;
2191 2480
2192 $TICK_WATCHER->at ($NEXT_TICK); 2481 $TICK_WATCHER->at ($NEXT_TICK);

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines