--- deliantra/server/lib/cf.pm 2008/06/15 20:32:51 1.436 +++ deliantra/server/lib/cf.pm 2008/08/31 09:03:31 1.442 @@ -21,8 +21,9 @@ package cf; +use 5.10.0; use utf8; -use strict; +use strict "vars", "subs"; use Symbol; use List::Util; @@ -36,13 +37,14 @@ use Coro (); use Coro::State; use Coro::Handle; +use Coro::EV; use Coro::AnyEvent; use Coro::Timer; use Coro::Signal; use Coro::Semaphore; use Coro::AnyEvent; use Coro::AIO; -use Coro::BDB; +use Coro::BDB 1.6; use Coro::Storable; use Coro::Util (); @@ -245,9 +247,9 @@ cf::object cf::object::player cf::client cf::player cf::arch cf::living - cf::map cf::party cf::region + cf::map cf::mapspace + cf::party cf::region )) { - no strict 'refs'; @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg; } @@ -1088,7 +1090,8 @@ # basically do the same as instantiate, without calling instantiate my ($obj) = @_; - bless $obj, ref $obj; # re-bless in case extensions have been reloaded + # no longer needed after getting rid of delete_package? + #bless $obj, ref $obj; # re-bless in case extensions have been reloaded my $registry = $obj->registry; @@ -1334,7 +1337,7 @@ if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m; $ext{source} = - "package $pkg; use strict; use utf8;\n" + "package $pkg; use 5.10.0; use strict 'vars', 'subs'; use utf8;\n" . "#line 1 \"$path\"\n{\n" . $source . "\n};\n1"; @@ -1624,88 +1627,90 @@ =cut -use re 'eval'; - -my $group; -my $interior; $interior = qr{ - # match a pod interior sequence sans C<< >> - (?: - \ (.*?)\ (?{ $group = $^N }) - | < (??{$interior}) > - ) -}x; - sub expand_cfpod { my ($self, $pod) = @_; + my @nest = [qr<\G$>, undef, ""]; my $xml; - while () { - if ($pod =~ /\G( (?: [^BCGHITU]+ | .(?!<) )+ )/xgcs) { - $group = $1; + for ($pod) { + while () { + if (/\G( (?: [^BCEGHITUZ&>\n\ ]+ | [BCEGHITUZ](?!<) | \ (?!>) )+ )/xgcs) { + $xml .= $1; + } elsif (/\G\n(?=\S)/xgcs) { + $xml .= " "; + } elsif (/\G\n/xgcs) { + $xml .= "\n"; + } elsif (/\G ([BCEGHITUZ]) (< (?: <+\ | (?!<) ) )/xgcs) { + my ($code, $delim) = ($1, scalar reverse $2); + $delim =~ y//; # delim now contains the stop sequence + $delim = qr{\G\Q$delim}; + + my $cb; + + if ($code eq "B") { + $cb = sub { "$_[0]" }; + } elsif ($code eq "C") { + $cb = sub { "$_[0]" }; + } elsif ($code eq "E") { + $cb = sub { warn "E<$_[0]>\n";"&$_[0];" }; + } elsif ($code eq "G") { + $cb = sub { + my ($male, $female) = split /\|/, $_[0]; + $self->gender ? $female : $male + }; + } elsif ($code eq "H") { + $cb = sub { + ( + "[$_[0] (Use hintmode to suppress hints)]", + "[Hint suppressed, see hintmode]", + "", + )[$self->{hintmode}]; + }; + } elsif ($code eq "I") { + $cb = sub { "$_[0]" }; + } elsif ($code eq "T") { + $cb = sub { "$_[0]" }; + } elsif ($code eq "U") { + $cb = sub { "$_[0]" }; + } elsif ($code eq "Z") { + $cb = sub { }; + } else { + die "FATAL error in expand_cfpod"; + } + + push @nest, [$delim, $cb, $xml]; + undef $xml; - $group =~ s/&/&/g; - $group =~ s/]*) (?{ $group = $^N }) - | < $interior > - ) - > - %gcsx - ) { - my ($code, $data) = ($1, $group); - - if ($code eq "B") { - $xml .= "" . expand_cfpod ($self, $data) . ""; - } elsif ($code eq "I") { - $xml .= "" . expand_cfpod ($self, $data) . ""; - } elsif ($code eq "U") { - $xml .= "" . expand_cfpod ($self, $data) . ""; - } elsif ($code eq "C") { - $xml .= "" . expand_cfpod ($self, $data) . ""; - } elsif ($code eq "T") { - $xml .= "" . expand_cfpod ($self, $data) . ""; - } elsif ($code eq "G") { - my ($male, $female) = split /\|/, $data; - $data = $self->gender ? $female : $male; - $xml .= expand_cfpod ($self, $data); - } elsif ($code eq "H") { - $xml .= ("[" . expand_cfpod ($self, $data) . " (Use hintmode to suppress hints)]", - "[Hint suppressed, see hintmode]", - "") - [$self->{hintmode}]; + if ($nest->[1]) { + $xml = $nest->[2] . $nest->[1]->($xml); + } else { + last; + } + } elsif (/\G/xgcs) { + $xml .= ">"; } else { - $xml .= "error processing '$code($data)' directive"; - } - } else { - if ($pod =~ /\G(.+)/) { - warn "parse error while expanding $pod (at $1)"; + if ($pod =~ /\G(.+)/xgcs) { + warn "parse error (at $1)($nest[-1][0]) while expanding cfpod:\n$pod"; + last; + } else { + warn "parse error (unclosed interior sequence at end of cfpod) while expanding cfpod:\n$pod"; + return "Sorry, the server encountered an internal error when formatting this message, please report this."; + } } - last; } } - for ($xml) { - # create single paragraphs (very hackish) - s/(?<=\S)\n(?=\w)/ /g; - - # compress some whitespace - s/\s+\n/\n/g; # ws line-ends - s/\n\n+/\n/g; # double lines - s/^\n+//; # beginning lines - s/\n+$//; # ending lines - } - $xml } -no re 'eval'; - sub hintmode { $_[0]{hintmode} = $_[1] if @_ > 1; $_[0]{hintmode} @@ -2088,7 +2093,7 @@ $self->_load_objects ($f) or return; - $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1) + $self->post_load_original if delete $self->{load_original}; if (my $uniq = $self->uniq_path) { @@ -3130,7 +3135,7 @@ for ( ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y insert remove inv nrof name archname title slaying race - decrease split destroy)], + decrease split destroy change_exp)], ["cf::object::player" => qw(player)], ["cf::player" => qw(peaceful)], ["cf::map" => qw(trigger)], @@ -3588,6 +3593,34 @@ if $make_core; } +# a safer delete_package, copied from Symbol +sub clear_package($) { + my $pkg = shift; + + # expand to full symbol table name if needed + unless ($pkg =~ /^main::.*::$/) { + $pkg = "main$pkg" if $pkg =~ /^::/; + $pkg = "main::$pkg" unless $pkg =~ /^main::/; + $pkg .= '::' unless $pkg =~ /::$/; + } + + my($stem, $leaf) = $pkg =~ m/(.*::)(\w+::)$/; + my $stem_symtab = *{$stem}{HASH}; + + defined $stem_symtab and exists $stem_symtab->{$leaf} + or return; + + # clear all symbols + my $leaf_symtab = *{$stem_symtab->{$leaf}}{HASH}; + for my $name (keys %$leaf_symtab) { + _gv_clear *{"$pkg$name"}; +# use PApp::Util; PApp::Util::sv_dump *{"$pkg$name"}; + } + warn "cleared package #$pkg\n";#d# +} + +our $RELOAD; # how many times to reload + sub do_reload_perl() { # can/must only be called in main if ($Coro::current != $Coro::main) { @@ -3595,114 +3628,113 @@ return; } - warn "reloading..."; + return if $RELOAD++; - warn "entering sync_job"; + while ($RELOAD) { + warn "reloading..."; - cf::sync_job { - cf::write_runtime_sync; # external watchdog should not bark - cf::emergency_save; - cf::write_runtime_sync; # external watchdog should not bark + warn "entering sync_job"; - warn "syncing database to disk"; - BDB::db_env_txn_checkpoint $DB_ENV; + cf::sync_job { + cf::write_runtime_sync; # external watchdog should not bark + cf::emergency_save; + cf::write_runtime_sync; # external watchdog should not bark - # if anything goes wrong in here, we should simply crash as we already saved + warn "syncing database to disk"; + BDB::db_env_txn_checkpoint $DB_ENV; - warn "flushing outstanding aio requests"; - for (;;) { - BDB::flush; - IO::AIO::flush; - Coro::cede_notself; - last unless IO::AIO::nreqs || BDB::nreqs; - warn "iterate..."; - } + # if anything goes wrong in here, we should simply crash as we already saved - ++$RELOAD; + warn "flushing outstanding aio requests"; + while (IO::AIO::nreqs || BDB::nreqs) { + Coro::EV::timer_once 0.01; # let the sync_job do it's thing + } - warn "cancelling all extension coros"; - $_->cancel for values %EXT_CORO; - %EXT_CORO = (); + warn "cancelling all extension coros"; + $_->cancel for values %EXT_CORO; + %EXT_CORO = (); - warn "removing commands"; - %COMMAND = (); + warn "removing commands"; + %COMMAND = (); - warn "removing ext/exti commands"; - %EXTCMD = (); - %EXTICMD = (); + warn "removing ext/exti commands"; + %EXTCMD = (); + %EXTICMD = (); - warn "unloading/nuking all extensions"; - for my $pkg (@EXTS) { - warn "... unloading $pkg"; + warn "unloading/nuking all extensions"; + for my $pkg (@EXTS) { + warn "... unloading $pkg"; - if (my $cb = $pkg->can ("unload")) { - eval { - $cb->($pkg); - 1 - } or warn "$pkg unloaded, but with errors: $@"; + if (my $cb = $pkg->can ("unload")) { + eval { + $cb->($pkg); + 1 + } or warn "$pkg unloaded, but with errors: $@"; + } + + warn "... clearing $pkg"; + clear_package $pkg; } - warn "... nuking $pkg"; - Symbol::delete_package $pkg; - } + warn "unloading all perl modules loaded from $LIBDIR"; + while (my ($k, $v) = each %INC) { + next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/; - warn "unloading all perl modules loaded from $LIBDIR"; - while (my ($k, $v) = each %INC) { - next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/; + warn "... unloading $k"; + delete $INC{$k}; - warn "... unloading $k"; - delete $INC{$k}; + $k =~ s/\.pm$//; + $k =~ s/\//::/g; - $k =~ s/\.pm$//; - $k =~ s/\//::/g; + if (my $cb = $k->can ("unload_module")) { + $cb->(); + } - if (my $cb = $k->can ("unload_module")) { - $cb->(); + clear_package $k; } - Symbol::delete_package $k; - } - - warn "getting rid of safe::, as good as possible"; - Symbol::delete_package "safe::$_" - for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region); + warn "getting rid of safe::, as good as possible"; + clear_package "safe::$_" + for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region); - warn "unloading cf.pm \"a bit\""; - delete $INC{"cf.pm"}; - delete $INC{"cf/pod.pm"}; + warn "unloading cf.pm \"a bit\""; + delete $INC{"cf.pm"}; + delete $INC{"cf/pod.pm"}; - # don't, removes xs symbols, too, - # and global variables created in xs - #Symbol::delete_package __PACKAGE__; + # don't, removes xs symbols, too, + # and global variables created in xs + #clear_package __PACKAGE__; - warn "unload completed, starting to reload now"; + warn "unload completed, starting to reload now"; - warn "reloading cf.pm"; - require cf; - cf::_connect_to_perl; # nominally unnecessary, but cannot hurt + warn "reloading cf.pm"; + require cf; + cf::_connect_to_perl; # nominally unnecessary, but cannot hurt - warn "loading config and database again"; - cf::reload_config; + warn "loading config and database again"; + cf::reload_config; - warn "loading extensions"; - cf::load_extensions; + warn "loading extensions"; + cf::load_extensions; - warn "reattaching attachments to objects/players"; - _global_reattach; # objects, sockets - warn "reattaching attachments to maps"; - reattach $_ for values %MAP; - warn "reattaching attachments to players"; - reattach $_ for values %PLAYER; + warn "reattaching attachments to objects/players"; + _global_reattach; # objects, sockets + warn "reattaching attachments to maps"; + reattach $_ for values %MAP; + warn "reattaching attachments to players"; + reattach $_ for values %PLAYER; - warn "leaving sync_job"; + warn "leaving sync_job"; - 1 - } or do { - warn $@; - cf::cleanup "error while reloading, exiting."; - }; + 1 + } or do { + warn $@; + cf::cleanup "error while reloading, exiting."; + }; - warn "reloaded"; + warn "reloaded"; + --$RELOAD; + } }; our $RELOAD_WATCHER; # used only during reload @@ -3798,8 +3830,9 @@ unless ($DB_ENV) { $DB_ENV = BDB::db_env_create; - $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC - | BDB::LOG_AUTOREMOVE, 1); + $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT); + $DB_ENV->set_flags (&BDB::LOG_AUTOREMOVE ) if BDB::VERSION v0, v4.7; + $DB_ENV->log_set_config (&BDB::LOG_AUTO_REMOVE) if BDB::VERSION v4.7; $DB_ENV->set_timeout (30, BDB::SET_TXN_TIMEOUT); $DB_ENV->set_timeout (30, BDB::SET_LOCK_TIMEOUT);