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.143 by root, Sun Jan 7 02:39:14 2007 UTC vs.
Revision 1.163 by root, Thu Jan 11 01:01:56 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;
51 56
52our %PLAYER; # all users 57our %PLAYER; # all users
53our %MAP; # all maps 58our %MAP; # all maps
54our $LINK_MAP; # the special {link} map 59our $LINK_MAP; # the special {link} map
55our $RANDOM_MAPS = cf::localdir . "/random"; 60our $RANDOM_MAPS = cf::localdir . "/random";
56our %EXT_CORO; # coroutines bound to extensions 61
62our $WAIT_FOR_TICK; $WAIT_FOR_TICK ||= new Coro::Signal;
63our $WAIT_FOR_TICK_ONE; $WAIT_FOR_TICK_ONE ||= new Coro::Signal;
57 64
58binmode STDOUT; 65binmode STDOUT;
59binmode STDERR; 66binmode STDERR;
60 67
61# read virtual server time, if available 68# read virtual server time, if available
106=item %cf::CFG 113=item %cf::CFG
107 114
108Configuration for the server, loaded from C</etc/crossfire/config>, or 115Configuration for the server, loaded from C</etc/crossfire/config>, or
109from wherever your confdir points to. 116from wherever your confdir points to.
110 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
111=back 125=back
112 126
113=cut 127=cut
114 128
115BEGIN { 129BEGIN {
118 utf8::encode $msg; 132 utf8::encode $msg;
119 133
120 $msg .= "\n" 134 $msg .= "\n"
121 unless $msg =~ /\n$/; 135 unless $msg =~ /\n$/;
122 136
123 LOG llevError, "cfperl: $msg"; 137 LOG llevError, $msg;
124 }; 138 };
125} 139}
126 140
127@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable'; 141@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
128@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable'; 142@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';
146 160
147$Event::DIED = sub { 161$Event::DIED = sub {
148 warn "error in event callback: @_"; 162 warn "error in event callback: @_";
149}; 163};
150 164
151my %ext_pkg;
152my @exts;
153my @hook;
154
155=head2 UTILITY FUNCTIONS 165=head2 UTILITY FUNCTIONS
156 166
157=over 4 167=over 4
158 168
169=item dumpval $ref
170
159=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}
160 191
161use JSON::Syck (); # TODO# replace by JSON::PC once working 192use JSON::Syck (); # TODO# replace by JSON::PC once working
162 193
163=item $ref = cf::from_json $json 194=item $ref = cf::from_json $json
164 195
287 } 318 }
288} 319}
289 320
290=item $coro = cf::async_ext { BLOCK } 321=item $coro = cf::async_ext { BLOCK }
291 322
292Like async, but this coro is automcatially being canceled when the 323Like async, but this coro is automatically being canceled when the
293extension calling this is being unloaded. 324extension calling this is being unloaded.
294 325
295=cut 326=cut
296 327
297sub async_ext(&) { 328sub async_ext(&) {
335 366
336############################################################################# 367#############################################################################
337 368
338package cf::path; 369package cf::path;
339 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
340sub new { 383sub new {
341 my ($class, $path, $base) = @_; 384 my ($class, $path, $base) = @_;
342 385
343 $path = $path->as_string if ref $path; 386 return $path if ref $path;
344 387
345 my $self = bless { }, $class; 388 my $self = {};
346 389
347 # {... are special paths that are not touched 390 # {... are special paths that are not being touched
348 # ?xxx/... are special absolute paths 391 # ?xxx/... are special absolute paths
349 # ?random/... random maps 392 # ?random/... random maps
350 # /! non-realised random map exit 393 # /! non-realised random map exit
351 # /... normal maps 394 # /... normal maps
352 # ~/... per-player maps without a specific player (DO NOT USE) 395 # ~/... per-player maps without a specific player (DO NOT USE)
353 # ~user/... per-player map of a specific user 396 # ~user/... per-player map of a specific user
354 397
398 $path =~ s/$PATH_SEP/\//go;
399
355 if ($path =~ /^{/) { 400 if ($path =~ /^{/) {
356 # fine as it is 401 # fine as it is
357 } elsif ($path =~ s{^\?random/}{}) {
358 Coro::AIO::aio_load "$cf::RANDOM_MAPS/$path.meta", my $data;
359 $self->{random} = cf::from_json $data;
360 } else { 402 } else {
361 if ($path =~ s{^~([^/]+)?}{}) { 403 if ($path =~ s{^~([^/]+)?}{}) {
404 # ~user
362 $self->{user_rel} = 1; 405 $self->{user_rel} = 1;
363 406
364 if (defined $1) { 407 if (defined $1) {
365 $self->{user} = $1; 408 $self->{user} = $1;
366 } elsif ($base =~ m{^~([^/]+)/}) { 409 } elsif ($base =~ m{^~([^/]+)/}) {
367 $self->{user} = $1; 410 $self->{user} = $1;
368 } else { 411 } else {
369 warn "cannot resolve user-relative path without user <$path,$base>\n"; 412 warn "cannot resolve user-relative path without user <$path,$base>\n";
370 } 413 }
414 } elsif ($path =~ s{^\?([^/]+)/}{}) {
415 # ?...
416 $self->{ext} = $1;
417 if (my $ext = $EXT_MAP{$1}) {
418 bless $self, $ext;
419 }
371 } elsif ($path =~ /^\//) { 420 } elsif ($path =~ /^\//) {
421 # /...
372 # already absolute 422 # already absolute
373 } else { 423 } else {
424 # relative
374 $base =~ s{[^/]+/?$}{}; 425 $base =~ s{[^/]+/?$}{};
375 return $class->new ("$base/$path"); 426 return $class->new ("$base/$path");
376 } 427 }
377 428
378 for ($path) { 429 for ($path) {
381 } 432 }
382 } 433 }
383 434
384 $self->{path} = $path; 435 $self->{path} = $path;
385 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
386 $self 449 $self
450}
451
452sub init {
453 # nop
454}
455
456sub substitute {
457 ()
387} 458}
388 459
389# the name / primary key / in-game path 460# the name / primary key / in-game path
390sub as_string { 461sub as_string {
391 my ($self) = @_; 462 my ($self) = @_;
392 463
393 $self->{user_rel} ? "~$self->{user}$self->{path}" 464 $self->{user_rel} ? "~$self->{user}$self->{path}"
394 : $self->{random} ? "?random/$self->{path}" 465 : $self->{ext} ? "?$self->{ext}/$self->{path}"
395 : $self->{path} 466 : $self->{path}
396} 467}
397 468
398# the displayed name, this is a one way mapping 469# the displayed name, this is a one way mapping
399sub visible_name { 470sub visible_name {
400 my ($self) = @_; 471 &as_string
401
402# if (my $rmp = $self->{random}) {
403# # todo: be more intelligent about this
404# "?random/$rmp->{origin_map}+$rmp->{origin_x}+$rmp->{origin_y}/$rmp->{dungeon_level}"
405# } else {
406 $self->as_string
407# }
408} 472}
409 473
410# escape the /'s in the path 474# escape the /'s in the path
411sub _escaped_path { 475sub _escaped_path {
412 # ∕ is U+2215
413 (my $path = $_[0]{path}) =~ s/\///g; 476 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g;
477
414 $path 478 $path
415} 479}
416 480
417# the original (read-only) location 481# the original (read-only) location
418sub load_path { 482sub load_path {
423 487
424# the temporary/swap location 488# the temporary/swap location
425sub save_path { 489sub save_path {
426 my ($self) = @_; 490 my ($self) = @_;
427 491
492 $self->{user_rel}
428 $self->{user_rel} ? sprintf "%s/%s/%s/%s", cf::localdir, cf::playerdir, $self->{user}, $self->_escaped_path 493 ? sprintf "%s/%s/%s/%s", cf::localdir, cf::playerdir, $self->{user}, $self->_escaped_path
429 : $self->{random} ? sprintf "%s/%s", $RANDOM_MAPS, $self->{path}
430 : sprintf "%s/%s/%s", cf::localdir, cf::tmpdir, $self->_escaped_path 494 : sprintf "%s/%s/%s", cf::localdir, cf::tmpdir, $self->_escaped_path
431} 495}
432 496
433# the unique path, might be eq to save_path 497# the unique path, undef == no special unique path
434sub uniq_path { 498sub uniq_path {
435 my ($self) = @_; 499 my ($self) = @_;
436 500
437 $self->{user_rel} || $self->{random}
438 ? undef
439 : sprintf "%s/%s/%s", cf::localdir, cf::uniquedir, $self->_escaped_path 501 sprintf "%s/%s/%s", cf::localdir, cf::uniquedir, $self->_escaped_path
440}
441
442# return random map parameters, or undef
443sub random_map_params {
444 my ($self) = @_;
445
446 $self->{random}
447} 502}
448 503
449# this is somewhat ugly, but style maps do need special treatment 504# this is somewhat ugly, but style maps do need special treatment
450sub is_style_map { 505sub is_style_map {
451 $_[0]{path} =~ m{^/styles/} 506 $_[0]{path} =~ m{^/styles/}
507}
508
509sub load_orig {
510 my ($self) = @_;
511
512 &cf::map::load_map_header ($self->load_path)
513}
514
515sub load_temp {
516 my ($self) = @_;
517
518 &cf::map::load_map_header ($self->save_path)
452} 519}
453 520
454package cf; 521package cf;
455 522
456############################################################################# 523#############################################################################
906=cut 973=cut
907 974
908sub register_extcmd { 975sub register_extcmd {
909 my ($name, $cb) = @_; 976 my ($name, $cb) = @_;
910 977
911 my $caller = caller;
912 #warn "registering extcmd '$name' to '$caller'";
913
914 $EXTCMD{$name} = [$cb, $caller]; 978 $EXTCMD{$name} = $cb;
915} 979}
916 980
917cf::player->attach ( 981cf::player->attach (
918 on_command => sub { 982 on_command => sub {
919 my ($pl, $name, $params) = @_; 983 my ($pl, $name, $params) = @_;
932 996
933 my $msg = eval { from_json $buf }; 997 my $msg = eval { from_json $buf };
934 998
935 if (ref $msg) { 999 if (ref $msg) {
936 if (my $cb = $EXTCMD{$msg->{msgtype}}) { 1000 if (my $cb = $EXTCMD{$msg->{msgtype}}) {
937 if (my %reply = $cb->[0]->($pl, $msg)) { 1001 if (my %reply = $cb->($pl, $msg)) {
938 $pl->ext_reply ($msg->{msgid}, %reply); 1002 $pl->ext_reply ($msg->{msgid}, %reply);
939 } 1003 }
940 } 1004 }
941 } else { 1005 } else {
942 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n"; 1006 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
944 1008
945 cf::override; 1009 cf::override;
946 }, 1010 },
947); 1011);
948 1012
949sub register {
950 my ($base, $pkg) = @_;
951
952 #TODO
953}
954
955sub load_extension { 1013sub load_extension {
956 my ($path) = @_; 1014 my ($path) = @_;
957 1015
958 $path =~ /([^\/\\]+)\.ext$/ or die "$path"; 1016 $path =~ /([^\/\\]+)\.ext$/ or die "$path";
959 my $base = $1; 1017 my $base = $1;
960 my $pkg = $1; 1018 my $pkg = $1;
961 $pkg =~ s/[^[:word:]]/_/g; 1019 $pkg =~ s/[^[:word:]]/_/g;
962 $pkg = "ext::$pkg"; 1020 $pkg = "ext::$pkg";
963 1021
964 warn "loading '$path' into '$pkg'\n"; 1022 warn "... loading '$path' into '$pkg'\n";
965 1023
966 open my $fh, "<:utf8", $path 1024 open my $fh, "<:utf8", $path
967 or die "$path: $!"; 1025 or die "$path: $!";
968 1026
969 my $source = 1027 my $source =
974 1032
975 eval $source 1033 eval $source
976 or die $@ ? "$path: $@\n" 1034 or die $@ ? "$path: $@\n"
977 : "extension disabled.\n"; 1035 : "extension disabled.\n";
978 1036
979 push @exts, $pkg; 1037 push @EXTS, $pkg;
980 $ext_pkg{$base} = $pkg;
981
982# no strict 'refs';
983# @{"$pkg\::ISA"} = ext::;
984
985 register $base, $pkg;
986}
987
988sub unload_extension {
989 my ($pkg) = @_;
990
991 warn "removing extension $pkg\n";
992
993 # remove hooks
994 #TODO
995# for my $idx (0 .. $#PLUGIN_EVENT) {
996# delete $hook[$idx]{$pkg};
997# }
998
999 # remove commands
1000 for my $name (keys %COMMAND) {
1001 my @cb = grep $_->[0] ne $pkg, @{ $COMMAND{$name} };
1002
1003 if (@cb) {
1004 $COMMAND{$name} = \@cb;
1005 } else {
1006 delete $COMMAND{$name};
1007 }
1008 }
1009
1010 # remove extcmds
1011 for my $name (grep $EXTCMD{$_}[1] eq $pkg, keys %EXTCMD) {
1012 delete $EXTCMD{$name};
1013 }
1014
1015 if (my $cb = $pkg->can ("unload")) {
1016 eval {
1017 $cb->($pkg);
1018 1
1019 } or warn "$pkg unloaded, but with errors: $@";
1020 }
1021
1022 Symbol::delete_package $pkg;
1023} 1038}
1024 1039
1025sub load_extensions { 1040sub load_extensions {
1026 for my $ext (<$LIBDIR/*.ext>) { 1041 for my $ext (<$LIBDIR/*.ext>) {
1027 next unless -r $ext; 1042 next unless -r $ext;
1045}; 1060};
1046 1061
1047cf::map->attach (prio => -10000, package => cf::mapsupport::); 1062cf::map->attach (prio => -10000, package => cf::mapsupport::);
1048 1063
1049############################################################################# 1064#############################################################################
1050# load/save perl data associated with player->ob objects
1051
1052sub all_objects(@) {
1053 @_, map all_objects ($_->inv), @_
1054}
1055
1056# TODO: compatibility cruft, remove when no longer needed
1057cf::player->attach (
1058 on_load => sub {
1059 my ($pl, $path) = @_;
1060
1061 for my $o (all_objects $pl->ob) {
1062 if (my $value = $o->get_ob_key_value ("_perl_data")) {
1063 $o->set_ob_key_value ("_perl_data");
1064
1065 %$o = %{ Storable::thaw pack "H*", $value };
1066 }
1067 }
1068 },
1069);
1070
1071#############################################################################
1072 1065
1073=head2 CORE EXTENSIONS 1066=head2 CORE EXTENSIONS
1074 1067
1075Functions and methods that extend core crossfire objects. 1068Functions and methods that extend core crossfire objects.
1076 1069
1077=cut 1070=cut
1078 1071
1079package cf::player; 1072package cf::player;
1080 1073
1074use Coro::AIO;
1075
1081=head3 cf::player 1076=head3 cf::player
1082 1077
1083=over 4 1078=over 4
1084 1079
1085=item cf::player::find $login 1080=item cf::player::find $login
1086 1081
1087Returns the given player object, loading it if necessary (might block). 1082Returns the given player object, loading it if necessary (might block).
1088 1083
1089=cut 1084=cut
1090 1085
1086sub playerdir($) {
1087 cf::localdir
1088 . "/"
1089 . cf::playerdir
1090 . "/"
1091 . (ref $_[0] ? $_[0]->ob->name : $_[0])
1092}
1093
1091sub path($) { 1094sub path($) {
1092 sprintf "%s/%s/%s/%s.pl", 1095 my $login = ref $_[0] ? $_[0]->ob->name : $_[0];
1093 cf::localdir, cf::playerdir, 1096
1094 (ref $_[0] ? $_[0]->ob->name : $_[0]) x 2 1097 (playerdir $login) . "/$login.pl"
1095} 1098}
1096 1099
1097sub find_active($) { 1100sub find_active($) {
1098 $cf::PLAYER{$_[0]} 1101 $cf::PLAYER{$_[0]}
1099 and $cf::PLAYER{$_[0]}->active 1102 and $cf::PLAYER{$_[0]}->active
1111 return $cf::PLAYER{$_[0]} || do { 1114 return $cf::PLAYER{$_[0]} || do {
1112 my $login = $_[0]; 1115 my $login = $_[0];
1113 1116
1114 my $guard = cf::lock_acquire "user_find:$login"; 1117 my $guard = cf::lock_acquire "user_find:$login";
1115 1118
1116 $cf::PLAYER{$login} ||= (load_pl path $login or return); 1119 $cf::PLAYER{$_[0]} || do {
1120 my $pl = load_pl path $login
1121 or return;
1122 $cf::PLAYER{$login} = $pl
1123 }
1117 }; 1124 }
1118} 1125}
1119 1126
1120sub save($) { 1127sub save($) {
1121 my ($pl) = @_; 1128 my ($pl) = @_;
1122 1129
1124 1131
1125 my $path = path $pl; 1132 my $path = path $pl;
1126 my $guard = cf::lock_acquire "user_save:$path"; 1133 my $guard = cf::lock_acquire "user_save:$path";
1127 1134
1128 return if $pl->{deny_save}; 1135 return if $pl->{deny_save};
1136
1137 aio_mkdir playerdir $pl, 0770;
1129 $pl->{last_save} = $cf::RUNTIME; 1138 $pl->{last_save} = $cf::RUNTIME;
1130 1139
1131 Coro::cede;
1132 $pl->save_pl ($path); 1140 $pl->save_pl ($path);
1133 Coro::cede; 1141 Coro::cede;
1134} 1142}
1135 1143
1136sub new($) { 1144sub new($) {
1144 $cf::PLAYER{$login} = $self; 1152 $cf::PLAYER{$login} = $self;
1145 1153
1146 $self 1154 $self
1147} 1155}
1148 1156
1157=item $pl->quit_character
1158
1159Nukes the player without looking back. If logged in, the connection will
1160be destroyed. May block for a long time.
1161
1162=cut
1163
1164sub quit_character {
1165 my ($pl) = @_;
1166
1167 $pl->{deny_save} = 1;
1168 $pl->password ("*"); # this should lock out the player until we nuked the dir
1169
1170 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active;
1171 $pl->deactivate;
1172 $pl->invoke (cf::EVENT_PLAYER_QUIT);
1173 $pl->ns->destroy if $pl->ns;
1174
1175 my $path = playerdir $pl;
1176 my $temp = "$path~$cf::RUNTIME~deleting~";
1177 aio_rename $path, $temp;
1178 delete $cf::PLAYER{$pl->ob->name};
1179 $pl->destroy;
1180 IO::AIO::aio_rmtree $temp;
1181}
1182
1183=item cf::player::list_logins
1184
1185Returns am arrayref of all valid playernames in the system, can take a
1186while and may block, so not sync_job-capable, ever.
1187
1188=cut
1189
1190sub list_logins {
1191 my $dirs = aio_readdir cf::localdir . "/" . cf::playerdir
1192 or return [];
1193
1194 my @logins;
1195
1196 for my $login (@$dirs) {
1197 my $fh = aio_open path $login, Fcntl::O_RDONLY, 0 or next;
1198 aio_read $fh, 0, 512, my $buf, 0 or next;
1199 $buf !~ /^password -------------$/m or next; # official not-valid tag
1200
1201 utf8::decode $login;
1202 push @logins, $login;
1203 }
1204
1205 \@logins
1206}
1207
1208=item $player->maps
1209
1210Returns an arrayref of cf::path's of all maps that are private for this
1211player. May block.
1212
1213=cut
1214
1215sub maps($) {
1216 my ($pl) = @_;
1217
1218 my $files = aio_readdir playerdir $pl
1219 or return;
1220
1221 my @paths;
1222
1223 for (@$files) {
1224 utf8::decode $_;
1225 next if /\.(?:pl|pst)$/;
1226 next unless /^$PATH_SEP/o;
1227
1228 push @paths, new cf::path "~" . $pl->ob->name . "/" . $_;
1229 }
1230
1231 \@paths
1232}
1233
1149=item $player->ext_reply ($msgid, $msgtype, %msg) 1234=item $player->ext_reply ($msgid, $msgtype, %msg)
1150 1235
1151Sends an ext reply to the player. 1236Sends an ext reply to the player.
1152 1237
1153=cut 1238=cut
1181 1266
1182sub generate_random_map { 1267sub generate_random_map {
1183 my ($path, $rmp) = @_; 1268 my ($path, $rmp) = @_;
1184 1269
1185 # mit "rum" bekleckern, nicht 1270 # mit "rum" bekleckern, nicht
1186 cf::map::_create_random_map 1271 cf::map::_create_random_map (
1187 $path, 1272 $path,
1188 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle}, 1273 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle},
1189 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle}, 1274 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle},
1190 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map}, 1275 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map},
1191 $rmp->{exit_on_final_map}, 1276 $rmp->{exit_on_final_map},
1193 $rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3}, 1278 $rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3},
1194 $rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase}, 1279 $rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase},
1195 $rmp->{dungeon_level}, $rmp->{dungeon_depth}, $rmp->{decoroptions}, $rmp->{orientation}, 1280 $rmp->{dungeon_level}, $rmp->{dungeon_depth}, $rmp->{decoroptions}, $rmp->{orientation},
1196 $rmp->{origin_y}, $rmp->{origin_x}, $rmp->{random_seed}, $rmp->{total_map_hp}, 1281 $rmp->{origin_y}, $rmp->{origin_x}, $rmp->{random_seed}, $rmp->{total_map_hp},
1197 $rmp->{map_layout_style}, $rmp->{treasureoptions}, $rmp->{symmetry_used}, 1282 $rmp->{map_layout_style}, $rmp->{treasureoptions}, $rmp->{symmetry_used},
1198 (cf::region::find $rmp->{region}) 1283 (cf::region::find $rmp->{region}), $rmp->{custom}
1284 )
1199} 1285}
1200 1286
1201# and all this just because we cannot iterate over 1287# and all this just because we cannot iterate over
1202# all maps in C++... 1288# all maps in C++...
1203sub change_all_map_light { 1289sub change_all_map_light {
1205 1291
1206 $_->change_map_light ($change) 1292 $_->change_map_light ($change)
1207 for grep $_->outdoor, values %cf::MAP; 1293 for grep $_->outdoor, values %cf::MAP;
1208} 1294}
1209 1295
1210sub try_load_header($) { 1296sub load_map_header($) {
1211 my ($path) = @_; 1297 my ($path) = @_;
1212 1298
1213 utf8::encode $path; 1299 utf8::encode $path;
1214 aio_open $path, O_RDONLY, 0 1300 aio_open $path, O_RDONLY, 0
1215 or return; 1301 or return;
1216 1302
1217 my $map = cf::map::new 1303 my $map = cf::map::new
1218 or return; 1304 or return;
1219 1305
1220 # for better error messages only, will be overwritten 1306 # for better error messages only, will be overwritten later
1221 $map->path ($path); 1307 $map->path ($path);
1222 1308
1223 $map->load_header ($path) 1309 $map->load_header ($path)
1224 or return; 1310 or return;
1225 1311
1241 1327
1242 $cf::MAP{$key} || do { 1328 $cf::MAP{$key} || do {
1243 my $guard = cf::lock_acquire "map_find:$key"; 1329 my $guard = cf::lock_acquire "map_find:$key";
1244 1330
1245 # do it the slow way 1331 # do it the slow way
1246 my $map = try_load_header $path->save_path; 1332 my $map = $path->load_temp;
1247 1333
1248 Coro::cede; 1334 Coro::cede;
1249 1335
1250 if ($map) { 1336 if ($map) {
1251 $map->last_access ((delete $map->{last_access}) 1337 $map->last_access ((delete $map->{last_access})
1252 || $cf::RUNTIME); #d# 1338 || $cf::RUNTIME); #d#
1253 # safety 1339 # safety
1254 $map->{instantiate_time} = $cf::RUNTIME 1340 $map->{instantiate_time} = $cf::RUNTIME
1255 if $map->{instantiate_time} > $cf::RUNTIME; 1341 if $map->{instantiate_time} > $cf::RUNTIME;
1256 } else { 1342 } else {
1257 if (my $rmp = $path->random_map_params) { 1343 $map = $path->load_orig
1258 $map = generate_random_map $key, $rmp;
1259 } else {
1260 $map = try_load_header $path->load_path;
1261 }
1262
1263 $map or return; 1344 or return;
1264 1345
1265 $map->{load_original} = 1; 1346 $map->{load_original} = 1;
1266 $map->{instantiate_time} = $cf::RUNTIME; 1347 $map->{instantiate_time} = $cf::RUNTIME;
1267 $map->last_access ($cf::RUNTIME); 1348 $map->last_access ($cf::RUNTIME);
1268 $map->instantiate; 1349 $map->instantiate;
1334 Coro::cede; 1415 Coro::cede;
1335 1416
1336 $self->in_memory (cf::MAP_IN_MEMORY); 1417 $self->in_memory (cf::MAP_IN_MEMORY);
1337} 1418}
1338 1419
1420# find and load all maps in the 3x3 area around a map
1421sub load_diag {
1422 my ($map) = @_;
1423
1424 my @diag; # diagonal neighbours
1425
1426 for (0 .. 3) {
1427 my $neigh = $map->tile_path ($_)
1428 or next;
1429 $neigh = find $neigh, $map
1430 or next;
1431 $neigh->load;
1432
1433 push @diag, [$neigh->tile_path (($_ + 3) % 4), $neigh],
1434 [$neigh->tile_path (($_ + 1) % 4), $neigh];
1435 }
1436
1437 for (@diag) {
1438 my $neigh = find @$_
1439 or next;
1440 $neigh->load;
1441 }
1442}
1443
1339sub find_sync { 1444sub find_sync {
1340 my ($path, $origin) = @_; 1445 my ($path, $origin) = @_;
1341 1446
1342 cf::sync_job { cf::map::find $path, $origin } 1447 cf::sync_job { find $path, $origin }
1343} 1448}
1344 1449
1345sub do_load_sync { 1450sub do_load_sync {
1346 my ($map) = @_; 1451 my ($map) = @_;
1347 1452
1348 cf::sync_job { $map->load }; 1453 cf::sync_job { $map->load };
1454}
1455
1456our %MAP_PREFETCH;
1457our $MAP_PREFETCHER = Coro::async {
1458 while () {
1459 while (%MAP_PREFETCH) {
1460 my $key = each %MAP_PREFETCH
1461 or next;
1462 my $path = delete $MAP_PREFETCH{$key};
1463
1464 my $map = find $path
1465 or next;
1466 $map->load;
1467 }
1468 Coro::schedule;
1469 }
1470};
1471
1472sub find_async {
1473 my ($path, $origin) = @_;
1474
1475 $path = new cf::path $path, $origin && $origin->path;
1476 my $key = $path->as_string;
1477
1478 if (my $map = $cf::MAP{$key}) {
1479 return $map if $map->in_memory == cf::MAP_IN_MEMORY;
1480 }
1481
1482 $MAP_PREFETCH{$key} = $path;
1483 $MAP_PREFETCHER->ready;
1484
1485 ()
1349} 1486}
1350 1487
1351sub save { 1488sub save {
1352 my ($self) = @_; 1489 my ($self) = @_;
1353 1490
1471 } 1608 }
1472 1609
1473 $map 1610 $map
1474} 1611}
1475 1612
1476sub emergency_save { 1613=item cf::map::unique_maps
1477 my $freeze_guard = cf::freeze_mainloop;
1478 1614
1479 warn "enter emergency map save\n"; 1615Returns an arrayref of cf::path's of all shared maps that have
1616instantiated unique items. May block.
1480 1617
1481 cf::sync_job { 1618=cut
1482 warn "begin emergency map save\n"; 1619
1483 $_->save for values %cf::MAP; 1620sub unique_maps() {
1621 my $files = aio_readdir cf::localdir . "/" . cf::uniquedir
1622 or return;
1623
1624 my @paths;
1625
1626 for (@$files) {
1627 utf8::decode $_;
1628 next if /\.pst$/;
1629 next unless /^$PATH_SEP/o;
1630
1631 push @paths, new cf::path $_;
1484 }; 1632 }
1485 1633
1486 warn "end emergency map save\n"; 1634 \@paths
1487} 1635}
1488 1636
1489package cf; 1637package cf;
1490 1638
1491=back 1639=back
1492 1640
1641=head3 cf::object
1642
1643=cut
1644
1645package cf::object;
1646
1647=over 4
1648
1649=item $ob->inv_recursive
1650
1651Returns the inventory of the object _and_ their inventories, recursively.
1652
1653=cut
1654
1655sub inv_recursive_;
1656sub inv_recursive_ {
1657 map { $_, inv_recursive_ $_->inv } @_
1658}
1659
1660sub inv_recursive {
1661 inv_recursive_ inv $_[0]
1662}
1663
1664package cf;
1665
1666=back
1493 1667
1494=head3 cf::object::player 1668=head3 cf::object::player
1495 1669
1496=over 4 1670=over 4
1497 1671
1589 # use -1 or undef as default coordinates, not 0, 0 1763 # use -1 or undef as default coordinates, not 0, 0
1590 ($x, $y) = ($map->enter_x, $map->enter_y) 1764 ($x, $y) = ($map->enter_x, $map->enter_y)
1591 if $x <=0 && $y <= 0; 1765 if $x <=0 && $y <= 0;
1592 1766
1593 $map->load; 1767 $map->load;
1768 $map->load_diag;
1594 1769
1595 return unless $self->contr->active; 1770 return unless $self->contr->active;
1596 $self->activate_recursive; 1771 $self->activate_recursive;
1597 $self->enter_map ($map, $x, $y); 1772 $self->enter_map ($map, $x, $y);
1598} 1773}
1634=cut 1809=cut
1635 1810
1636sub cf::object::player::goto { 1811sub cf::object::player::goto {
1637 my ($self, $path, $x, $y) = @_; 1812 my ($self, $path, $x, $y) = @_;
1638 1813
1814 $path = new cf::path $path;
1815
1639 $self->enter_link; 1816 $self->enter_link;
1640 1817
1641 (async { 1818 (async {
1642 $path = new cf::path $path;
1643
1644 my $map = cf::map::find $path->as_string; 1819 my $map = cf::map::find $path->as_string;
1645 $map = $map->customise_for ($self) if $map; 1820 $map = $map->customise_for ($self) if $map;
1646 1821
1647# warn "entering ", $map->path, " at ($x, $y)\n" 1822# warn "entering ", $map->path, " at ($x, $y)\n"
1648# if $map; 1823# if $map;
1649 1824
1650 $map or $self->message ("The exit is closed", cf::NDI_UNIQUE | cf::NDI_RED); 1825 $map or $self->message ("The exit to '" . ($path->visible_name) . "' is closed", cf::NDI_UNIQUE | cf::NDI_RED);
1651 1826
1652 $self->leave_link ($map, $x, $y); 1827 $self->leave_link ($map, $x, $y);
1653 })->prio (1); 1828 })->prio (1);
1654} 1829}
1655 1830
1721 1896
1722 1; 1897 1;
1723 }) { 1898 }) {
1724 $self->message ("Something went wrong deep within the crossfire server. " 1899 $self->message ("Something went wrong deep within the crossfire server. "
1725 . "I'll try to bring you back to the map you were before. " 1900 . "I'll try to bring you back to the map you were before. "
1726 . "Please report this to the dungeon master", 1901 . "Please report this to the dungeon master!",
1727 cf::NDI_UNIQUE | cf::NDI_RED); 1902 cf::NDI_UNIQUE | cf::NDI_RED);
1728 1903
1729 warn "ERROR in enter_exit: $@"; 1904 warn "ERROR in enter_exit: $@";
1730 $self->leave_link; 1905 $self->leave_link;
1731 } 1906 }
2063 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset}; 2238 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset};
2064 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset}; 2239 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset};
2065 2240
2066 if (exists $CFG{mlockall}) { 2241 if (exists $CFG{mlockall}) {
2067 eval { 2242 eval {
2068 $CFG{mlockall} ? &mlockall : &munlockall 2243 $CFG{mlockall} ? eval "mlockall()" : eval "munlockall()"
2069 and die "WARNING: m(un)lockall failed: $!\n"; 2244 and die "WARNING: m(un)lockall failed: $!\n";
2070 }; 2245 };
2071 warn $@ if $@; 2246 warn $@ if $@;
2072 } 2247 }
2073} 2248}
2084 load_extensions; 2259 load_extensions;
2085 Event::loop; 2260 Event::loop;
2086} 2261}
2087 2262
2088############################################################################# 2263#############################################################################
2089# initialisation 2264# initialisation and cleanup
2265
2266# install some emergency cleanup handlers
2267BEGIN {
2268 for my $signal (qw(INT HUP TERM)) {
2269 Event->signal (
2270 data => WF_AUTOCANCEL,
2271 signal => $signal,
2272 cb => sub {
2273 cf::cleanup "SIG$signal";
2274 },
2275 );
2276 }
2277}
2278
2279sub emergency_save() {
2280 my $freeze_guard = cf::freeze_mainloop;
2281
2282 warn "enter emergency perl save\n";
2283
2284 cf::sync_job {
2285 # use a peculiar iteration method to avoid tripping on perl
2286 # refcount bugs in for. also avoids problems with players
2287 # and maps saved/Destroyed asynchronously.
2288 warn "begin emergency player save\n";
2289 for my $login (keys %cf::PLAYER) {
2290 my $pl = $cf::PLAYER{$login} or next;
2291 $pl->valid or next;
2292 $pl->save;
2293 }
2294 warn "end emergency player save\n";
2295
2296 warn "begin emergency map save\n";
2297 for my $path (keys %cf::MAP) {
2298 my $map = $cf::MAP{$path} or next;
2299 $map->valid or next;
2300 $map->save;
2301 }
2302 warn "end emergency map save\n";
2303 };
2304
2305 warn "leave emergency perl save\n";
2306}
2090 2307
2091sub reload() { 2308sub reload() {
2092 # can/must only be called in main 2309 # can/must only be called in main
2093 if ($Coro::current != $Coro::main) { 2310 if ($Coro::current != $Coro::main) {
2094 warn "can only reload from main coroutine\n"; 2311 warn "can only reload from main coroutine\n";
2095 return; 2312 return;
2096 } 2313 }
2097 2314
2098 warn "reloading..."; 2315 warn "reloading...";
2099 2316
2317 warn "freezing server";
2100 my $guard = freeze_mainloop; 2318 my $guard = freeze_mainloop;
2101 cf::emergency_save; 2319 cf::emergency_save;
2102 2320
2321 warn "sync database to disk";
2322 cf::db_sync;
2323 IO::AIO::flush;
2324
2103 eval { 2325 eval {
2104 # if anything goes wrong in here, we should simply crash as we already saved 2326 # if anything goes wrong in here, we should simply crash as we already saved
2105 2327
2106 # cancel all watchers 2328 warn "cancel all watchers";
2107 for (Event::all_watchers) { 2329 for (Event::all_watchers) {
2108 $_->cancel if $_->data & WF_AUTOCANCEL; 2330 $_->cancel if $_->data & WF_AUTOCANCEL;
2109 } 2331 }
2110 2332
2111 # cancel all extension coros 2333 warn "cancel all extension coros";
2112 $_->cancel for values %EXT_CORO; 2334 $_->cancel for values %EXT_CORO;
2113 %EXT_CORO = (); 2335 %EXT_CORO = ();
2114 2336
2337 warn "remove commands";
2338 %COMMAND = ();
2339
2340 warn "remove ext commands";
2341 %EXTCMD = ();
2342
2115 # unload all extensions 2343 warn "unload/nuke all extensions";
2116 for (@exts) { 2344 for my $pkg (@EXTS) {
2117 warn "unloading <$_>"; 2345 warn "... unloading $pkg";
2118 unload_extension $_; 2346
2347 if (my $cb = $pkg->can ("unload")) {
2348 eval {
2349 $cb->($pkg);
2350 1
2351 } or warn "$pkg unloaded, but with errors: $@";
2119 } 2352 }
2120 2353
2354 warn "... nuking $pkg";
2355 Symbol::delete_package $pkg;
2356 }
2357
2121 # unload all modules loaded from $LIBDIR 2358 warn "unload all perl modules loaded from $LIBDIR";
2122 while (my ($k, $v) = each %INC) { 2359 while (my ($k, $v) = each %INC) {
2123 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/; 2360 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
2124 2361
2125 warn "removing <$k>"; 2362 warn "removing <$k>";
2126 delete $INC{$k}; 2363 delete $INC{$k};
2133 } 2370 }
2134 2371
2135 Symbol::delete_package $k; 2372 Symbol::delete_package $k;
2136 } 2373 }
2137 2374
2138 # sync database to disk
2139 cf::db_sync;
2140 IO::AIO::flush;
2141
2142 # get rid of safe::, as good as possible 2375 warn "get rid of safe::, as good as possible";
2143 Symbol::delete_package "safe::$_" 2376 Symbol::delete_package "safe::$_"
2144 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region); 2377 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
2145 2378
2146 # remove register_script_function callbacks
2147 # TODO
2148
2149 # unload cf.pm "a bit" 2379 warn "unload cf.pm \"a bit\"";
2150 delete $INC{"cf.pm"}; 2380 delete $INC{"cf.pm"};
2151 2381
2152 # don't, removes xs symbols, too, 2382 # don't, removes xs symbols, too,
2153 # and global variables created in xs 2383 # and global variables created in xs
2154 #Symbol::delete_package __PACKAGE__; 2384 #Symbol::delete_package __PACKAGE__;
2155 2385
2156 # reload cf.pm
2157 warn "reloading cf.pm"; 2386 warn "reloading cf.pm";
2158 require cf; 2387 require cf;
2159 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 2388 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
2160 2389
2161 # load config and database again 2390 warn "load config and database again";
2162 cf::cfg_load; 2391 cf::cfg_load;
2163 cf::db_load; 2392 cf::db_load;
2164 2393
2165 # load extensions
2166 warn "load extensions"; 2394 warn "load extensions";
2167 cf::load_extensions; 2395 cf::load_extensions;
2168 2396
2169 # reattach attachments to objects 2397 warn "reattach attachments to objects/players";
2170 warn "reattach";
2171 _global_reattach; 2398 _global_reattach;
2399 warn "reattach attachments to maps";
2400 reattach $_ for values %MAP;
2172 }; 2401 };
2173 2402
2174 if ($@) { 2403 if ($@) {
2175 warn $@; 2404 warn $@;
2176 warn "error while reloading, exiting."; 2405 warn "error while reloading, exiting.";
2177 exit 1; 2406 exit 1;
2178 } 2407 }
2179 2408
2180 warn "reloaded successfully"; 2409 warn "reloaded";
2181}; 2410};
2182 2411
2183############################################################################# 2412#############################################################################
2184 2413
2185unless ($LINK_MAP) { 2414unless ($LINK_MAP) {
2221 $LINK_MAP->{deny_reset} = 1; 2450 $LINK_MAP->{deny_reset} = 1;
2222 2451
2223 $cf::MAP{$LINK_MAP->path} = $LINK_MAP; 2452 $cf::MAP{$LINK_MAP->path} = $LINK_MAP;
2224} 2453}
2225 2454
2226register "<global>", __PACKAGE__;
2227
2228register_command "reload" => sub { 2455register_command "reload" => sub {
2229 my ($who, $arg) = @_; 2456 my ($who, $arg) = @_;
2230 2457
2231 if ($who->flag (FLAG_WIZ)) { 2458 if ($who->flag (FLAG_WIZ)) {
2232 $who->message ("start of reload."); 2459 $who->message ("start of reload.");
2241 reentrant => 0, 2468 reentrant => 0,
2242 prio => 0, 2469 prio => 0,
2243 at => $NEXT_TICK || $TICK, 2470 at => $NEXT_TICK || $TICK,
2244 data => WF_AUTOCANCEL, 2471 data => WF_AUTOCANCEL,
2245 cb => sub { 2472 cb => sub {
2473 $NOW = Event::time;
2474
2246 cf::server_tick; # one server iteration 2475 cf::server_tick; # one server iteration
2247 $RUNTIME += $TICK; 2476 $RUNTIME += $TICK;
2248 $NEXT_TICK += $TICK; 2477 $NEXT_TICK += $TICK;
2478
2479 $WAIT_FOR_TICK->broadcast;
2480 $WAIT_FOR_TICK_ONE->send if $WAIT_FOR_TICK_ONE->awaited;
2249 2481
2250 # if we are delayed by four ticks or more, skip them all 2482 # if we are delayed by four ticks or more, skip them all
2251 $NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4; 2483 $NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4;
2252 2484
2253 $TICK_WATCHER->at ($NEXT_TICK); 2485 $TICK_WATCHER->at ($NEXT_TICK);

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines