[BACK]Return to Safe.pm CVS log [TXT] [DIR] Up to [LON-CAPA] / loncom / xml

Diff for /loncom/xml/Safe.pm between versions 1.5 and 1.6

version 1.5, 2002/10/22 15:59:44 version 1.6, 2003/08/30 02:26:37
Line 2  package Safe; Line 2  package Safe;
   
 use 5.003_11;  use 5.003_11;
 use strict;  use strict;
 use vars qw($VERSION);  
   
 $VERSION = "2.062";  $Safe::VERSION = "2.09";
   
 use Carp;  use Carp;
   
Line 48  sub new { Line 47  sub new {
     # the whole glob *_ rather than $_ and @_ separately, otherwise      # the whole glob *_ rather than $_ and @_ separately, otherwise
     # @_ in non default packages within the compartment don't work.      # @_ in non default packages within the compartment don't work.
     $obj->share_from('main', $default_share);      $obj->share_from('main', $default_share);
       Opcode::_safe_pkg_prep($obj->{Root}) if($Opcode::VERSION > 1.04);
     return $obj;      return $obj;
 }  }
   
Line 155  sub share_from { Line 155  sub share_from {
     my $no_record = shift || 0;      my $no_record = shift || 0;
     my $root = $obj->root();      my $root = $obj->root();
     croak("vars not an array ref") unless ref $vars eq 'ARRAY';      croak("vars not an array ref") unless ref $vars eq 'ARRAY';
  no strict 'refs';      no strict 'refs';
     # Check that 'from' package actually exists      # Check that 'from' package actually exists
     croak("Package \"$pkg\" does not exist")      croak("Package \"$pkg\" does not exist")
  unless keys %{"$pkg\::"};   unless keys %{"$pkg\::"};
Line 190  sub share_record { Line 190  sub share_record {
 sub share_redo {  sub share_redo {
     my $obj = shift;      my $obj = shift;
     my $shares = \%{$obj->{Shares} ||= {}};      my $shares = \%{$obj->{Shares} ||= {}};
  my($var, $pkg);      my($var, $pkg);
     while(($var, $pkg) = each %$shares) {      while(($var, $pkg) = each %$shares) {
  # warn "share_redo $pkg\:: $var";   # warn "share_redo $pkg\:: $var";
  $obj->share_from($pkg,  [ $var ], 1);   $obj->share_from($pkg,  [ $var ], 1);
Line 208  sub varglob { Line 208  sub varglob {
   
   
 sub reval {  sub reval {
     my ($obj, $__SAFE_LOCAL_expr, $strict) = @_;      my ($obj, $expr, $strict) = @_;
     my $root = $obj->{Root};      my $root = $obj->{Root};
   
     # Create anon sub ref in root of compartment.      # Create anon sub ref in root of compartment.
     # Uses a closure (on $expr) to pass in the code to be executed.      # 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)      # (eval on one line to keep line numbers as expected by caller)
     my $evalcode = sprintf('package %s; sub { @_ = (\'\'); eval $__SAFE_LOCAL_expr; }', $root);      my $evalcode = sprintf('package %s; sub { @_ = (); eval $expr; }', $root);
     my $evalsub;      my $evalsub;
   
  if ($strict) { use strict; $evalsub = eval $evalcode; }      if ($strict) { use strict; $evalsub = eval $evalcode; }
  else         {  no strict; $evalsub = eval $evalcode; }      else         {  no strict; $evalsub = eval $evalcode; }
   
     return Opcode::_safe_call_sv($root, $obj->{Mask}, $evalsub);      return Opcode::_safe_call_sv($root, $obj->{Mask}, $evalsub);
 }  }
Line 228  sub rdo { Line 228  sub rdo {
     my $root = $obj->{Root};      my $root = $obj->{Root};
   
     my $evalsub = eval      my $evalsub = eval
       sprintf('package %s; sub { @_ = (\'\'); do $file }', $root);      sprintf('package %s; sub { @_ = (); do $file }', $root);
     return Opcode::_safe_call_sv($root, $obj->{Mask}, $evalsub);      return Opcode::_safe_call_sv($root, $obj->{Mask}, $evalsub);
 }  }
   
Line 380  respectfully. Line 380  respectfully.
 =item share (NAME, ...)  =item share (NAME, ...)
   
 This shares the variable(s) in the argument list with the compartment.  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.  module.
   
 Each NAME must be the B<name> of a variable, typically with the leading  Each NAME must be the B<name> of a non-lexical variable, typically
 type identifier included. A bareword is treated as a function name.  with the leading type identifier included. A bareword is treated as a
   function name.
   
 Examples of legal names are '$foo' for a scalar, '@foo' for an  Examples of legal names are '$foo' for a scalar, '@foo' for an
 array, '%foo' for a hash, '&foo' or 'foo' for a subroutine and '*foo'  array, '%foo' for a hash, '&foo' or 'foo' for a subroutine and '*foo'
Line 426  C<main::> package to the code inside the Line 427  C<main::> package to the code inside the
 Any attempt by the code in STRING to use an operator which is not permitted  Any attempt by the code in STRING to use an operator which is not permitted
 by the compartment will cause an error (at run-time of the main program  by the compartment will cause an error (at run-time of the main program
 but at compile-time for the code in STRING).  The error is of the form  but at compile-time for the code in STRING).  The error is of the form
 "%s trapped by operation mask operation...".  "'%s' trapped by operation mask...".
   
 If an operation is trapped in this way, then the code in STRING will  If an operation is trapped in this way, then the code in STRING will
 not be executed. If such a trapped operation occurs or any other  not be executed. If such a trapped operation occurs or any other
Removed from v.1.5  
changed lines
  Added in v.1.6

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>