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.157 by root, Wed Jan 10 01:16:54 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}
… …
1632 } 1582 }
1633 1583
1634 $map 1584 $map
1635} 1585}
1636 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
1637package cf; 1611package cf;
1638 1612
1639=back 1613=back
1640 1614
1641=head3 cf::object 1615=head3 cf::object
… …
1810 1784
1811sub cf::object::player::goto { 1785sub cf::object::player::goto {
1812 my ($self, $path, $x, $y) = @_; 1786 my ($self, $path, $x, $y) = @_;
1813 1787
1814 $path = new cf::path $path; 1788 $path = new cf::path $path;
1815 $path ne "/" or Carp::cluck ("oy");#d#
1816 1789
1817 $self->enter_link; 1790 $self->enter_link;
1818 1791
1819 (async { 1792 (async {
1820 my $map = cf::map::find $path->as_string; 1793 my $map = cf::map::find $path->as_string;
… …
1897 1870
1898 1; 1871 1;
1899 }) { 1872 }) {
1900 $self->message ("Something went wrong deep within the crossfire server. " 1873 $self->message ("Something went wrong deep within the crossfire server. "
1901 . "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. "
1902 . "Please report this to the dungeon master", 1875 . "Please report this to the dungeon master!",
1903 cf::NDI_UNIQUE | cf::NDI_RED); 1876 cf::NDI_UNIQUE | cf::NDI_RED);
1904 1877
1905 warn "ERROR in enter_exit: $@"; 1878 warn "ERROR in enter_exit: $@";
1906 $self->leave_link; 1879 $self->leave_link;
1907 } 1880 }
… …
2313 return; 2286 return;
2314 } 2287 }
2315 2288
2316 warn "reloading..."; 2289 warn "reloading...";
2317 2290
2291 warn "freezing server";
2318 my $guard = freeze_mainloop; 2292 my $guard = freeze_mainloop;
2319 cf::emergency_save; 2293 cf::emergency_save;
2320 2294
2295 warn "sync database to disk";
2296 cf::db_sync;
2297 IO::AIO::flush;
2298
2321 eval { 2299 eval {
2322 # 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
2323 2301
2324 # cancel all watchers 2302 warn "cancel all watchers";
2325 for (Event::all_watchers) { 2303 for (Event::all_watchers) {
2326 $_->cancel if $_->data & WF_AUTOCANCEL; 2304 $_->cancel if $_->data & WF_AUTOCANCEL;
2327 } 2305 }
2328 2306
2329 # cancel all extension coros 2307 warn "cancel all extension coros";
2330 $_->cancel for values %EXT_CORO; 2308 $_->cancel for values %EXT_CORO;
2331 %EXT_CORO = (); 2309 %EXT_CORO = ();
2332 2310
2311 warn "remove commands";
2312 %COMMAND = ();
2313
2314 warn "remove ext commands";
2315 %EXTCMD = ();
2316
2333 # unload all extensions 2317 warn "unload/nuke all extensions";
2334 for (@exts) { 2318 for my $pkg (@EXTS) {
2335 warn "unloading <$_>"; 2319 warn "... unloading $pkg";
2336 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: $@";
2337 } 2326 }
2338 2327
2328 warn "... nuking $pkg";
2329 Symbol::delete_package $pkg;
2330 }
2331
2339 # unload all modules loaded from $LIBDIR 2332 warn "unload all perl modules loaded from $LIBDIR";
2340 while (my ($k, $v) = each %INC) { 2333 while (my ($k, $v) = each %INC) {
2341 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/; 2334 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
2342 2335
2343 warn "removing <$k>"; 2336 warn "removing <$k>";
2344 delete $INC{$k}; 2337 delete $INC{$k};
… …
2351 } 2344 }
2352 2345
2353 Symbol::delete_package $k; 2346 Symbol::delete_package $k;
2354 } 2347 }
2355 2348
2356 # sync database to disk
2357 cf::db_sync;
2358 IO::AIO::flush;
2359
2360 # get rid of safe::, as good as possible 2349 warn "get rid of safe::, as good as possible";
2361 Symbol::delete_package "safe::$_" 2350 Symbol::delete_package "safe::$_"
2362 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);
2363 2352
2364 # remove register_script_function callbacks
2365 # TODO
2366
2367 # unload cf.pm "a bit" 2353 warn "unload cf.pm \"a bit\"";
2368 delete $INC{"cf.pm"}; 2354 delete $INC{"cf.pm"};
2369 2355
2370 # don't, removes xs symbols, too, 2356 # don't, removes xs symbols, too,
2371 # and global variables created in xs 2357 # and global variables created in xs
2372 #Symbol::delete_package __PACKAGE__; 2358 #Symbol::delete_package __PACKAGE__;
2373 2359
2374 # reload cf.pm
2375 warn "reloading cf.pm"; 2360 warn "reloading cf.pm";
2376 require cf; 2361 require cf;
2377 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 2362 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
2378 2363
2379 # load config and database again 2364 warn "load config and database again";
2380 cf::cfg_load; 2365 cf::cfg_load;
2381 cf::db_load; 2366 cf::db_load;
2382 2367
2383 # load extensions
2384 warn "load extensions"; 2368 warn "load extensions";
2385 cf::load_extensions; 2369 cf::load_extensions;
2386 2370
2387 # reattach attachments to objects 2371 warn "reattach attachments to objects/players";
2388 warn "reattach";
2389 _global_reattach; 2372 _global_reattach;
2373 warn "reattach attachments to maps";
2390 reattach $_ for values %MAP; 2374 reattach $_ for values %MAP;
2391 }; 2375 };
2392 2376
2393 if ($@) { 2377 if ($@) {
2394 warn $@; 2378 warn $@;
2395 warn "error while reloading, exiting."; 2379 warn "error while reloading, exiting.";
2396 exit 1; 2380 exit 1;
2397 } 2381 }
2398 2382
2399 warn "reloaded successfully"; 2383 warn "reloaded";
2400}; 2384};
2401 2385
2402############################################################################# 2386#############################################################################
2403 2387
2404unless ($LINK_MAP) { 2388unless ($LINK_MAP) {
… …
2439 $LINK_MAP->{deny_save} = 1; 2423 $LINK_MAP->{deny_save} = 1;
2440 $LINK_MAP->{deny_reset} = 1; 2424 $LINK_MAP->{deny_reset} = 1;
2441 2425
2442 $cf::MAP{$LINK_MAP->path} = $LINK_MAP; 2426 $cf::MAP{$LINK_MAP->path} = $LINK_MAP;
2443} 2427}
2444
2445register "<global>", __PACKAGE__;
2446 2428
2447register_command "reload" => sub { 2429register_command "reload" => sub {
2448 my ($who, $arg) = @_; 2430 my ($who, $arg) = @_;
2449 2431
2450 if ($who->flag (FLAG_WIZ)) { 2432 if ($who->flag (FLAG_WIZ)) {

Diff Legend

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