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.155 by root, Tue Jan 9 21:32:42 2007 UTC vs.
Revision 1.160 by root, Wed Jan 10 22:54:06 2007 UTC

… …
33 33
34$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
35 35
36our %COMMAND = (); 36our %COMMAND = ();
37our %COMMAND_TIME = (); 37our %COMMAND_TIME = ();
38
39our @EXTS = (); # list of extension package names
38our %EXTCMD = (); 40our %EXTCMD = ();
41our %EXT_CORO = (); # coroutines bound to extensions
39 42
40our @EVENT; 43our @EVENT;
41our $LIBDIR = datadir . "/ext"; 44our $LIBDIR = datadir . "/ext";
42 45
43our $TICK = MAX_TIME * 1e-6; 46our $TICK = MAX_TIME * 1e-6;
… …
52 55
53our %PLAYER; # all users 56our %PLAYER; # all users
54our %MAP; # all maps 57our %MAP; # all maps
55our $LINK_MAP; # the special {link} map 58our $LINK_MAP; # the special {link} map
56our $RANDOM_MAPS = cf::localdir . "/random"; 59our $RANDOM_MAPS = cf::localdir . "/random";
57our %EXT_CORO; # coroutines bound to extensions
58 60
59our $WAIT_FOR_TICK; $WAIT_FOR_TICK ||= new Coro::Signal; 61our $WAIT_FOR_TICK; $WAIT_FOR_TICK ||= new Coro::Signal;
60our $WAIT_FOR_TICK_ONE; $WAIT_FOR_TICK_ONE ||= new Coro::Signal; 62our $WAIT_FOR_TICK_ONE; $WAIT_FOR_TICK_ONE ||= new Coro::Signal;
61 63
62binmode STDOUT; 64binmode STDOUT;
… …
156} 158}
157 159
158$Event::DIED = sub { 160$Event::DIED = sub {
159 warn "error in event callback: @_"; 161 warn "error in event callback: @_";
160}; 162};
161
162my %ext_pkg;
163my @exts;
164my @hook;
165 163
166=head2 UTILITY FUNCTIONS 164=head2 UTILITY FUNCTIONS
167 165
168=over 4 166=over 4
169 167
… …
319 } 317 }
320} 318}
321 319
322=item $coro = cf::async_ext { BLOCK } 320=item $coro = cf::async_ext { BLOCK }
323 321
324Like async, but this coro is automcatially being canceled when the 322Like async, but this coro is automatically being canceled when the
325extension calling this is being unloaded. 323extension calling this is being unloaded.
326 324
327=cut 325=cut
328 326
329sub async_ext(&) { 327sub async_ext(&) {
… …
366=cut 364=cut
367 365
368############################################################################# 366#############################################################################
369 367
370package cf::path; 368package cf::path;
369
370use overload
371 '""' => \&as_string;
371 372
372# used to convert map paths into valid unix filenames by repalcing / by ∕ 373# used to convert map paths into valid unix filenames by repalcing / by ∕
373our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons 374our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons
374 375
375sub new { 376sub new {
… …
384 # ?random/... random maps 385 # ?random/... random maps
385 # /! non-realised random map exit 386 # /! non-realised random map exit
386 # /... normal maps 387 # /... normal maps
387 # ~/... per-player maps without a specific player (DO NOT USE) 388 # ~/... per-player maps without a specific player (DO NOT USE)
388 # ~user/... per-player map of a specific user 389 # ~user/... per-player map of a specific user
390
391 $path =~ s/$PATH_SEP/\//go;
389 392
390 if ($path =~ /^{/) { 393 if ($path =~ /^{/) {
391 # fine as it is 394 # fine as it is
392 } elsif ($path =~ s{^\?random/}{}) { 395 } elsif ($path =~ s{^\?random/}{}) {
393 Coro::AIO::aio_load "$cf::RANDOM_MAPS/$path.meta", my $data; 396 Coro::AIO::aio_load "$cf::RANDOM_MAPS/$path.meta", my $data;
… …
940=cut 943=cut
941 944
942sub register_extcmd { 945sub register_extcmd {
943 my ($name, $cb) = @_; 946 my ($name, $cb) = @_;
944 947
945 my $caller = caller;
946 #warn "registering extcmd '$name' to '$caller'";
947
948 $EXTCMD{$name} = [$cb, $caller]; 948 $EXTCMD{$name} = $cb;
949} 949}
950 950
951cf::player->attach ( 951cf::player->attach (
952 on_command => sub { 952 on_command => sub {
953 my ($pl, $name, $params) = @_; 953 my ($pl, $name, $params) = @_;
… …
966 966
967 my $msg = eval { from_json $buf }; 967 my $msg = eval { from_json $buf };
968 968
969 if (ref $msg) { 969 if (ref $msg) {
970 if (my $cb = $EXTCMD{$msg->{msgtype}}) { 970 if (my $cb = $EXTCMD{$msg->{msgtype}}) {
971 if (my %reply = $cb->[0]->($pl, $msg)) { 971 if (my %reply = $cb->($pl, $msg)) {
972 $pl->ext_reply ($msg->{msgid}, %reply); 972 $pl->ext_reply ($msg->{msgid}, %reply);
973 } 973 }
974 } 974 }
975 } else { 975 } else {
976 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n"; 976 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
… …
978 978
979 cf::override; 979 cf::override;
980 }, 980 },
981); 981);
982 982
983sub register {
984 my ($base, $pkg) = @_;
985
986 #TODO
987}
988
989sub load_extension { 983sub load_extension {
990 my ($path) = @_; 984 my ($path) = @_;
991 985
992 $path =~ /([^\/\\]+)\.ext$/ or die "$path"; 986 $path =~ /([^\/\\]+)\.ext$/ or die "$path";
993 my $base = $1; 987 my $base = $1;
994 my $pkg = $1; 988 my $pkg = $1;
995 $pkg =~ s/[^[:word:]]/_/g; 989 $pkg =~ s/[^[:word:]]/_/g;
996 $pkg = "ext::$pkg"; 990 $pkg = "ext::$pkg";
997 991
998 warn "loading '$path' into '$pkg'\n"; 992 warn "... loading '$path' into '$pkg'\n";
999 993
1000 open my $fh, "<:utf8", $path 994 open my $fh, "<:utf8", $path
1001 or die "$path: $!"; 995 or die "$path: $!";
1002 996
1003 my $source = 997 my $source =
… …
1008 1002
1009 eval $source 1003 eval $source
1010 or die $@ ? "$path: $@\n" 1004 or die $@ ? "$path: $@\n"
1011 : "extension disabled.\n"; 1005 : "extension disabled.\n";
1012 1006
1013 push @exts, $pkg; 1007 push @EXTS, $pkg;
1014 $ext_pkg{$base} = $pkg;
1015
1016# no strict 'refs';
1017# @{"$pkg\::ISA"} = ext::;
1018
1019 register $base, $pkg;
1020}
1021
1022sub unload_extension {
1023 my ($pkg) = @_;
1024
1025 warn "removing extension $pkg\n";
1026
1027 # remove hooks
1028 #TODO
1029# for my $idx (0 .. $#PLUGIN_EVENT) {
1030# delete $hook[$idx]{$pkg};
1031# }
1032
1033 # remove commands
1034 for my $name (keys %COMMAND) {
1035 my @cb = grep $_->[0] ne $pkg, @{ $COMMAND{$name} };
1036
1037 if (@cb) {
1038 $COMMAND{$name} = \@cb;
1039 } else {
1040 delete $COMMAND{$name};
1041 }
1042 }
1043
1044 # remove extcmds
1045 for my $name (grep $EXTCMD{$_}[1] eq $pkg, keys %EXTCMD) {
1046 delete $EXTCMD{$name};
1047 }
1048
1049 if (my $cb = $pkg->can ("unload")) {
1050 eval {
1051 $cb->($pkg);
1052 1
1053 } or warn "$pkg unloaded, but with errors: $@";
1054 }
1055
1056 Symbol::delete_package $pkg;
1057} 1008}
1058 1009
1059sub load_extensions { 1010sub load_extensions {
1060 for my $ext (<$LIBDIR/*.ext>) { 1011 for my $ext (<$LIBDIR/*.ext>) {
1061 next unless -r $ext; 1012 next unless -r $ext;
… …
1240 my @paths; 1191 my @paths;
1241 1192
1242 for (@$files) { 1193 for (@$files) {
1243 utf8::decode $_; 1194 utf8::decode $_;
1244 next if /\.(?:pl|pst)$/; 1195 next if /\.(?:pl|pst)$/;
1245 next unless /^$PATH_SEP/; 1196 next unless /^$PATH_SEP/o;
1246 1197
1247 s/$PATH_SEP/\//g;
1248 push @paths, new cf::path "~" . $pl->ob->name . "/" . $_; 1198 push @paths, new cf::path "~" . $pl->ob->name . "/" . $_;
1249 } 1199 }
1250 1200
1251 \@paths 1201 \@paths
1252} 1202}
… …
1439 Coro::cede; 1389 Coro::cede;
1440 1390
1441 $self->in_memory (cf::MAP_IN_MEMORY); 1391 $self->in_memory (cf::MAP_IN_MEMORY);
1442} 1392}
1443 1393
1394# find and load all maps in the 3x3 area around a map
1395sub load_diag {
1396 my ($map) = @_;
1397
1398 my @diag; # diagonal neighbours
1399
1400 for (0 .. 3) {
1401 my $neigh = $map->tile_path ($_)
1402 or next;
1403 $neigh = find $neigh, $map
1404 or next;
1405 $neigh->load;
1406
1407 push @diag, [$neigh->tile_path (($_ + 3) % 4), $neigh],
1408 [$neigh->tile_path (($_ + 1) % 4), $neigh];
1409 }
1410
1411 for (@diag) {
1412 my $neigh = find @$_
1413 or next;
1414 $neigh->load;
1415 }
1416}
1417
1444sub find_sync { 1418sub find_sync {
1445 my ($path, $origin) = @_; 1419 my ($path, $origin) = @_;
1446 1420
1447 cf::sync_job { cf::map::find $path, $origin } 1421 cf::sync_job { find $path, $origin }
1448} 1422}
1449 1423
1450sub do_load_sync { 1424sub do_load_sync {
1451 my ($map) = @_; 1425 my ($map) = @_;
1452 1426
1453 cf::sync_job { $map->load }; 1427 cf::sync_job { $map->load };
1428}
1429
1430our %MAP_PREFETCH;
1431our $MAP_PREFETCHER = Coro::async {
1432 while () {
1433 while (%MAP_PREFETCH) {
1434 my $key = each %MAP_PREFETCH
1435 or next;
1436 my $path = delete $MAP_PREFETCH{$key};
1437
1438 my $map = find $path
1439 or next;
1440 $map->load;
1441 }
1442 Coro::schedule;
1443 }
1444};
1445
1446sub find_async {
1447 my ($path, $origin) = @_;
1448
1449 $path = new cf::path $path, $origin && $origin->path;
1450 my $key = $path->as_string;
1451
1452 if (my $map = $cf::MAP{$key}) {
1453 return $map if $map->in_memory == cf::MAP_IN_MEMORY;
1454 }
1455
1456 $MAP_PREFETCH{$key} = $path;
1457 $MAP_PREFETCHER->ready;
1458
1459 ()
1454} 1460}
1455 1461
1456sub save { 1462sub save {
1457 my ($self) = @_; 1463 my ($self) = @_;
1458 1464
… …
1576 } 1582 }
1577 1583
1578 $map 1584 $map
1579} 1585}
1580 1586
1587=item cf::map::unique_maps
1588
1589Returns an arrayref of cf::path's of all shared maps that have
1590instantiated unique items. May block.
1591
1592=cut
1593
1594sub unique_maps() {
1595 my $files = aio_readdir cf::localdir . "/" . cf::uniquedir
1596 or return;
1597
1598 my @paths;
1599
1600 for (@$files) {
1601 utf8::decode $_;
1602 next if /\.pst$/;
1603 next unless /^$PATH_SEP/o;
1604
1605 push @paths, new cf::path $_;
1606 }
1607
1608 \@paths
1609}
1610
1581package cf; 1611package cf;
1582 1612
1583=back 1613=back
1584 1614
1585=head3 cf::object 1615=head3 cf::object
… …
1707 # use -1 or undef as default coordinates, not 0, 0 1737 # use -1 or undef as default coordinates, not 0, 0
1708 ($x, $y) = ($map->enter_x, $map->enter_y) 1738 ($x, $y) = ($map->enter_x, $map->enter_y)
1709 if $x <=0 && $y <= 0; 1739 if $x <=0 && $y <= 0;
1710 1740
1711 $map->load; 1741 $map->load;
1742 $map->load_diag;
1712 1743
1713 return unless $self->contr->active; 1744 return unless $self->contr->active;
1714 $self->activate_recursive; 1745 $self->activate_recursive;
1715 $self->enter_map ($map, $x, $y); 1746 $self->enter_map ($map, $x, $y);
1716} 1747}
… …
1753 1784
1754sub cf::object::player::goto { 1785sub cf::object::player::goto {
1755 my ($self, $path, $x, $y) = @_; 1786 my ($self, $path, $x, $y) = @_;
1756 1787
1757 $path = new cf::path $path; 1788 $path = new cf::path $path;
1758 $path ne "/" or Carp::cluck ("oy");#d#
1759 1789
1760 $self->enter_link; 1790 $self->enter_link;
1761 1791
1762 (async { 1792 (async {
1763 my $map = cf::map::find $path->as_string; 1793 my $map = cf::map::find $path->as_string;
… …
1840 1870
1841 1; 1871 1;
1842 }) { 1872 }) {
1843 $self->message ("Something went wrong deep within the crossfire server. " 1873 $self->message ("Something went wrong deep within the crossfire server. "
1844 . "I'll try to bring you back to the map you were before. " 1874 . "I'll try to bring you back to the map you were before. "
1845 . "Please report this to the dungeon master", 1875 . "Please report this to the dungeon master!",
1846 cf::NDI_UNIQUE | cf::NDI_RED); 1876 cf::NDI_UNIQUE | cf::NDI_RED);
1847 1877
1848 warn "ERROR in enter_exit: $@"; 1878 warn "ERROR in enter_exit: $@";
1849 $self->leave_link; 1879 $self->leave_link;
1850 } 1880 }
… …
2218 }, 2248 },
2219 ); 2249 );
2220 } 2250 }
2221} 2251}
2222 2252
2223sub emergency_save { 2253sub emergency_save() {
2224 my $freeze_guard = cf::freeze_mainloop; 2254 my $freeze_guard = cf::freeze_mainloop;
2225 2255
2226 warn "enter emergency perl save\n"; 2256 warn "enter emergency perl save\n";
2227 2257
2228 cf::sync_job { 2258 cf::sync_job {
… …
2256 return; 2286 return;
2257 } 2287 }
2258 2288
2259 warn "reloading..."; 2289 warn "reloading...";
2260 2290
2291 warn "freezing server";
2261 my $guard = freeze_mainloop; 2292 my $guard = freeze_mainloop;
2262 cf::emergency_save; 2293 cf::emergency_save;
2263 2294
2295 warn "sync database to disk";
2296 cf::db_sync;
2297 IO::AIO::flush;
2298
2264 eval { 2299 eval {
2265 # if anything goes wrong in here, we should simply crash as we already saved 2300 # if anything goes wrong in here, we should simply crash as we already saved
2266 2301
2267 # cancel all watchers 2302 warn "cancel all watchers";
2268 for (Event::all_watchers) { 2303 for (Event::all_watchers) {
2269 $_->cancel if $_->data & WF_AUTOCANCEL; 2304 $_->cancel if $_->data & WF_AUTOCANCEL;
2270 } 2305 }
2271 2306
2272 # cancel all extension coros 2307 warn "cancel all extension coros";
2273 $_->cancel for values %EXT_CORO; 2308 $_->cancel for values %EXT_CORO;
2274 %EXT_CORO = (); 2309 %EXT_CORO = ();
2275 2310
2311 warn "remove commands";
2312 %COMMAND = ();
2313
2314 warn "remove ext commands";
2315 %EXTCMD = ();
2316
2276 # unload all extensions 2317 warn "unload/nuke all extensions";
2277 for (@exts) { 2318 for my $pkg (@EXTS) {
2278 warn "unloading <$_>"; 2319 warn "... unloading $pkg";
2279 unload_extension $_; 2320
2321 if (my $cb = $pkg->can ("unload")) {
2322 eval {
2323 $cb->($pkg);
2324 1
2325 } or warn "$pkg unloaded, but with errors: $@";
2280 } 2326 }
2281 2327
2328 warn "... nuking $pkg";
2329 Symbol::delete_package $pkg;
2330 }
2331
2282 # unload all modules loaded from $LIBDIR 2332 warn "unload all perl modules loaded from $LIBDIR";
2283 while (my ($k, $v) = each %INC) { 2333 while (my ($k, $v) = each %INC) {
2284 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/; 2334 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
2285 2335
2286 warn "removing <$k>"; 2336 warn "removing <$k>";
2287 delete $INC{$k}; 2337 delete $INC{$k};
… …
2294 } 2344 }
2295 2345
2296 Symbol::delete_package $k; 2346 Symbol::delete_package $k;
2297 } 2347 }
2298 2348
2299 # sync database to disk
2300 cf::db_sync;
2301 IO::AIO::flush;
2302
2303 # get rid of safe::, as good as possible 2349 warn "get rid of safe::, as good as possible";
2304 Symbol::delete_package "safe::$_" 2350 Symbol::delete_package "safe::$_"
2305 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region); 2351 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
2306 2352
2307 # remove register_script_function callbacks
2308 # TODO
2309
2310 # unload cf.pm "a bit" 2353 warn "unload cf.pm \"a bit\"";
2311 delete $INC{"cf.pm"}; 2354 delete $INC{"cf.pm"};
2312 2355
2313 # don't, removes xs symbols, too, 2356 # don't, removes xs symbols, too,
2314 # and global variables created in xs 2357 # and global variables created in xs
2315 #Symbol::delete_package __PACKAGE__; 2358 #Symbol::delete_package __PACKAGE__;
2316 2359
2317 # reload cf.pm
2318 warn "reloading cf.pm"; 2360 warn "reloading cf.pm";
2319 require cf; 2361 require cf;
2320 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 2362 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
2321 2363
2322 # load config and database again 2364 warn "load config and database again";
2323 cf::cfg_load; 2365 cf::cfg_load;
2324 cf::db_load; 2366 cf::db_load;
2325 2367
2326 # load extensions
2327 warn "load extensions"; 2368 warn "load extensions";
2328 cf::load_extensions; 2369 cf::load_extensions;
2329 2370
2330 # reattach attachments to objects 2371 warn "reattach attachments to objects/players";
2331 warn "reattach";
2332 _global_reattach; 2372 _global_reattach;
2373 warn "reattach attachments to maps";
2333 reattach $_ for values %MAP; 2374 reattach $_ for values %MAP;
2334 }; 2375 };
2335 2376
2336 if ($@) { 2377 if ($@) {
2337 warn $@; 2378 warn $@;
2338 warn "error while reloading, exiting."; 2379 warn "error while reloading, exiting.";
2339 exit 1; 2380 exit 1;
2340 } 2381 }
2341 2382
2342 warn "reloaded successfully"; 2383 warn "reloaded";
2343}; 2384};
2344 2385
2345############################################################################# 2386#############################################################################
2346 2387
2347unless ($LINK_MAP) { 2388unless ($LINK_MAP) {
… …
2382 $LINK_MAP->{deny_save} = 1; 2423 $LINK_MAP->{deny_save} = 1;
2383 $LINK_MAP->{deny_reset} = 1; 2424 $LINK_MAP->{deny_reset} = 1;
2384 2425
2385 $cf::MAP{$LINK_MAP->path} = $LINK_MAP; 2426 $cf::MAP{$LINK_MAP->path} = $LINK_MAP;
2386} 2427}
2387
2388register "<global>", __PACKAGE__;
2389 2428
2390register_command "reload" => sub { 2429register_command "reload" => sub {
2391 my ($who, $arg) = @_; 2430 my ($who, $arg) = @_;
2392 2431
2393 if ($who->flag (FLAG_WIZ)) { 2432 if ($who->flag (FLAG_WIZ)) {

Diff Legend

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