A bug introduced in #8217 (the undefined variable in the

[p5sagit/p5-mst-13.2.git] / ext / Opcode / Safe.pm

diff --git a/ext/Opcode/Safe.pm b/ext/Opcode/Safe.pm
index f15dbd5..a803b5f 100644 (file)
--- a/ext/Opcode/Safe.pm
+++ b/ext/Opcode/Safe.pm
@@ -1,13 +1,11 @@
 package Safe;
 
-require 5.002;
-
+use 5.003_11;
 use strict;
-use Carp;
 
-use vars qw($VERSION);
+our $VERSION = "2.06";
 
-$VERSION = "2.06";
+use Carp;
 
 use Opcode 1.01, qw(
     opset opset_to_ops opmask_add
@@ -49,16 +47,17 @@ sub new {
     # the whole glob *_ rather than $_ and @_ separately, otherwise
     # @_ in non default packages within the compartment don't work.
     $obj->share_from('main', $default_share);
+    Opcode::_safe_pkg_prep($obj->{Root});
     return $obj;
 }
 
 sub DESTROY {
     my $obj = shift;
-    $obj->erase if $obj->{Erase};
+    $obj->erase('DESTROY') if $obj->{Erase};
 }
 
 sub erase {
-    my $obj= shift;
+    my ($obj, $action) = @_;
     my $pkg = $obj->root();
     my ($stem, $leaf);
 
@@ -74,18 +73,22 @@ sub erase {
     #warn " stem_symtab hash ".scalar(%$stem_symtab)."\n";
        # ", join(', ', %$stem_symtab),"\n";
 
-    delete $stem_symtab->{$leaf};
+#    delete $stem_symtab->{$leaf};
 
-#    my $leaf_glob   = $stem_symtab->{$leaf};
-#    my $leaf_symtab = *{$leaf_glob}{HASH};
+    my $leaf_glob   = $stem_symtab->{$leaf};
+    my $leaf_symtab = *{$leaf_glob}{HASH};
 #    warn " leaf_symtab ", join(', ', %$leaf_symtab),"\n";
-#    %$leaf_symtab = ();
+    %$leaf_symtab = ();
     #delete $leaf_symtab->{'__ANON__'};
     #delete $leaf_symtab->{'foo'};
     #delete $leaf_symtab->{'main::'};
 #    my $foo = undef ${"$stem\::"}{"$leaf\::"};
 
-    $obj->share_from('main', $default_share);
+    if ($action and $action eq 'DESTROY') {
+        delete $stem_symtab->{$leaf};
+    } else {
+        $obj->share_from('main', $default_share);
+    }
     1;
 }
 
@@ -151,26 +154,27 @@ sub share_from {
     my $vars = shift;
     my $no_record = shift || 0;
     my $root = $obj->root();
-    my ($var, $arg);
     croak("vars not an array ref") unless ref $vars eq 'ARRAY';
        no strict 'refs';
     # Check that 'from' package actually exists
     croak("Package \"$pkg\" does not exist")
        unless keys %{"$pkg\::"};
+    my $arg;
     foreach $arg (@$vars) {
        # catch some $safe->share($var) errors:
        croak("'$arg' not a valid symbol table name")
            unless $arg =~ /^[\$\@%*&]?\w[\w:]*$/
                or $arg =~ /^\$\W$/;
-       ($var = $arg) =~ s/^(\W)//;     # get type char
-       # warn "share_from $pkg $1 $var";
-       *{$root."::$var"} = ($1 eq '$') ? \${$pkg."::$var"}
-                         : ($1 eq '@') ? \@{$pkg."::$var"}
-                         : ($1 eq '%') ? \%{$pkg."::$var"}
-                         : ($1 eq '*') ?  *{$pkg."::$var"}
-                         : ($1 eq '&') ? \&{$pkg."::$var"}
-                         : (!$1)       ? \&{$pkg."::$var"}
-                         : croak(qq(Can't share "$1$var" of unknown type));
+       my ($var, $type);
+       $type = $1 if ($var = $arg) =~ s/^(\W)//;
+       # warn "share_from $pkg $type $var";
+       *{$root."::$var"} = (!$type)       ? \&{$pkg."::$var"}
+                         : ($type eq '&') ? \&{$pkg."::$var"}
+                         : ($type eq '$') ? \${$pkg."::$var"}
+                         : ($type eq '@') ? \@{$pkg."::$var"}
+                         : ($type eq '%') ? \%{$pkg."::$var"}
+                         : ($type eq '*') ?  *{$pkg."::$var"}
+                         : croak(qq(Can't share "$type$var" of unknown type));
     }
     $obj->share_record($pkg, $vars) unless $no_record or !$vars;
 }
@@ -231,7 +235,7 @@ sub rdo {
 
 1;
 
-__DATA__
+__END__
 
 =head1 NAME
 
@@ -279,16 +283,16 @@ perl code is compiled into an internal format before execution.
 Evaluating perl code (e.g. via "eval" or "do 'file'") causes
 the code to be compiled into an internal format and then,
 provided there was no error in the compilation, executed.
-Code evaulated in a compartment compiles subject to the
-compartment's operator mask. Attempting to evaulate code in a
+Code evaluated in a compartment compiles subject to the
+compartment's operator mask. Attempting to evaluate code in a
 compartment which contains a masked operator will cause the
 compilation to fail with an error. The code will not be executed.
 
 The default operator mask for a newly created compartment is
 the ':default' optag.
 
-It is important that you read the L<Opcode(3)> module documentation
-for more information. Especially for details definitions of opnames,
+It is important that you read the Opcode(3) module documentation
+for more information, especially for detailed definitions of opnames,
 optags and opsets.
 
 Since it is only at the compilation stage that the operator mask
@@ -454,7 +458,7 @@ problem.
 
 Consider a function foo() in package pkg compiled outside a compartment
 but shared with it. Assume the compartment has a root package called
-'Root'. If foo() contains an eval statement like eval '$baz = 1' then,
+'Root'. If foo() contains an eval statement like eval '$foo = 1' then,
 normally, $pkg::foo will be set to 1.  If foo() is called from the
 compartment (by whatever means) then instead of setting $pkg::foo, the
 eval will actually set $Root::pkg::foo.
@@ -549,7 +553,7 @@ Originally designed and implemented by Malcolm Beattie,
 mbeattie@sable.ox.ac.uk.
 
 Reworked to use the Opcode module and other changes added by Tim Bunce
-<Tim.Bunce@ig.co.uk>.
+E<lt>F<Tim.Bunce@ig.co.uk>E<gt>.
 
 =cut