Nearly-working threads re-structuring. Do not integrate,

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

diff --git a/ext/Opcode/Safe.pm b/ext/Opcode/Safe.pm
index 9b618f2..22ba03f 100644 (file)
--- a/ext/Opcode/Safe.pm
+++ b/ext/Opcode/Safe.pm
@@ -3,7 +3,7 @@ package Safe;
 use 5.003_11;
 use strict;
 
-our $VERSION = "2.06";
+our $VERSION = "2.07";
 
 use Carp;
 
@@ -47,6 +47,7 @@ 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;
 }
 
@@ -152,6 +153,7 @@ sub share_from {
     my $pkg = shift;
     my $vars = shift;
     my $no_record = shift || 0;
+    my $root = $obj->root();
     croak("vars not an array ref") unless ref $vars eq 'ARRAY';
        no strict 'refs';
     # Check that 'from' package actually exists
@@ -166,16 +168,13 @@ sub share_from {
        my ($var, $type);
        $type = $1 if ($var = $arg) =~ s/^(\W)//;
        # warn "share_from $pkg $type $var";
-       my $obj_to_share =  (!$type)       ? \&{$pkg."::$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));
-       package main;
-       Opcode::_safe_call_sv($obj->{Root}, $obj->{Mask},
-                             sub { *$var = $obj_to_share });
     }
     $obj->share_record($pkg, $vars) unless $no_record or !$vars;
 }
@@ -210,25 +209,27 @@ sub varglob {
 
 sub reval {
     my ($obj, $expr, $strict) = @_;
+    my $root = $obj->{Root};
 
-    package main;
-    if ($strict) {
-       use strict;
-       return Opcode::_safe_call_sv($obj->{Root}, $obj->{Mask},
-                                    sub { eval $expr });
-    }
-    else {
-       no strict;
-       return Opcode::_safe_call_sv($obj->{Root}, $obj->{Mask},
-                                    sub { eval $expr });
-    }
+    # Create anon sub ref in root of compartment.
+    # Uses a closure (on $expr) to pass in the code to be executed.
+    # (eval on one line to keep line numbers as expected by caller)
+       my $evalcode = sprintf('package %s; sub { eval $expr; }', $root);
+    my $evalsub;
+
+       if ($strict) { use strict; $evalsub = eval $evalcode; }
+       else         {  no strict; $evalsub = eval $evalcode; }
+
+    return Opcode::_safe_call_sv($root, $obj->{Mask}, $evalsub);
 }
 
 sub rdo {
     my ($obj, $file) = @_;
-    package main;
-    return Opcode::_safe_call_sv($obj->{Root}, $obj->{Mask},
-                                sub { do $file });
+    my $root = $obj->{Root};
+
+    my $evalsub = eval
+           sprintf('package %s; sub { do $file }', $root);
+    return Opcode::_safe_call_sv($root, $obj->{Mask}, $evalsub);
 }
 
 
@@ -379,7 +380,7 @@ respectfully.
 =item share (NAME, ...)
 
 This shares the variable(s) in the argument list with the compartment.
-This is almost identical to exporting variables using the L<Exporter(3)>
+This is almost identical to exporting variables using the L<Exporter>
 module.
 
 Each NAME must be the B<name> of a variable, typically with the leading