fix CVE-2010-1168 and CVE-2010-1447 by updating Safe.pm to the current,

not-affected version

3 files changed, 569 insertions, 3 deletions

diff --git a/lang/perl5/Makefile b/lang/perl5/Makefile
index 222efb46fc0..8e1bd13e663 100644
--- a/lang/perl5/Makefile
+++ b/lang/perl5/Makefile
@@ -1,10 +1,10 @@
-# $NetBSD: Makefile,v 1.158 2010/04/01 22:03:09 fhajny Exp $
+# $NetBSD: Makefile,v 1.159 2010/06/27 13:38:39 spz Exp $
 
 .include "license.mk"
 
 DISTNAME=	perl-5.10.1
 CATEGORIES=	lang devel perl5
-PKGREVISION=	1
+PKGREVISION=	2
 MASTER_SITES=	${MASTER_SITE_PERL_CPAN:S,/modules/by-module/$,/src/5.0/,}
 DISTFILES+=	${DISTNAME}${EXTRACT_SUFX}
 
diff --git a/lang/perl5/distinfo b/lang/perl5/distinfo
index f14a552c5f8..8de02a0cfb0 100644
--- a/lang/perl5/distinfo
+++ b/lang/perl5/distinfo
@@ -1,4 +1,4 @@
-$NetBSD: distinfo,v 1.64 2010/04/01 22:03:09 fhajny Exp $
+$NetBSD: distinfo,v 1.65 2010/06/27 13:38:39 spz Exp $
 
 SHA1 (perl-5.10.1.tar.gz) = 8536ed1c14444d1efea069525a816fbc7be7109f
 RMD160 (perl-5.10.1.tar.gz) = 6fe727a5e8878c26b5bd7cfc7165e10f311f7214
@@ -17,6 +17,7 @@ SHA1 (patch-ck) = 28207b8186c9ad194a1edc696159915bc16d1097
 SHA1 (patch-cn) = 7ca2b1ff19f8371637a34ec26779b37d74c74cca
 SHA1 (patch-co) = c4a4e30171cebb1ceaa14850b9be99ffa7c94519
 SHA1 (patch-db) = 3aef75518bfea88cb5166026f04ef4d7c016bc99
+SHA1 (patch-fa) = 0a496df9e340291a6162efb1b63b0420c2559be8
 SHA1 (patch-ta) = 69f0d2df022eb8ff0dbcc77bde638cdc9c6391b1
 SHA1 (patch-zc) = a23002397ffaebb243f7683c95c8fb227af90f49
 SHA1 (patch-zd) = 1a4ae60e9ae350c813d8b91c61e93805b3e66210
diff --git a/lang/perl5/patches/patch-fa b/lang/perl5/patches/patch-fa
new file mode 100644
index 00000000000..21b68da38e6
--- /dev/null
+++ b/lang/perl5/patches/patch-fa
@@ -0,0 +1,565 @@
+$NetBSD: patch-fa,v 1.1 2010/06/27 13:38:39 spz Exp $
+
+fixes CVE-2010-1168 and CVE-2010-1447 by updating Safe.pm to the current
+version
+
+--- ./ext/Safe/Safe.pm.orig	2009-08-22 18:39:32.000000000 +0000
++++ ./ext/Safe/Safe.pm
+@@ -2,8 +2,9 @@ package Safe;
+ 
+ use 5.003_11;
+ use strict;
++use Scalar::Util qw(reftype);
+ 
+-$Safe::VERSION = "2.18";
++$Safe::VERSION = "2.27";
+ 
+ # *** Don't declare any lexicals above this point ***
+ #
+@@ -11,18 +12,18 @@ $Safe::VERSION = "2.18";
+ # see any lexicals in scope (apart from __ExPr__ which is unavoidable)
+ 
+ sub lexless_anon_sub {
+-		 # $_[0] is package;
+-		 # $_[1] is strict flag;
++                 # $_[0] is package;
++                 # $_[1] is strict flag;
+     my $__ExPr__ = $_[2];   # must be a lexical to create the closure that
+-			    # can be used to pass the value into the safe
+-			    # world
++                            # can be used to pass the value into the safe
++                            # world
+ 
+     # 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)
+     eval sprintf
+     'package %s; %s strict; sub { @_=(); eval q[my $__ExPr__;] . $__ExPr__; }',
+-		$_[0], $_[1] ? 'use' : 'no';
++                $_[0], $_[1] ? 'use' : 'no';
+ }
+ 
+ use Carp;
+@@ -30,6 +31,18 @@ BEGIN { eval q{
+     use Carp::Heavy;
+ } }
+ 
++use B ();
++BEGIN {
++    no strict 'refs';
++    if (defined &B::sub_generation) {
++        *sub_generation = \&B::sub_generation;
++    }
++    else {
++        # fake sub generation changing for perls < 5.8.9
++        my $sg; *sub_generation = sub { ++$sg };
++    }
++}
++
+ use Opcode 1.01, qw(
+     opset opset_to_ops opmask_add
+     empty_opset full_opset invert_opset verify_opset
+@@ -38,6 +51,23 @@ use Opcode 1.01, qw(
+ 
+ *ops_to_opset = \&opset;   # Temporary alias for old Penguins
+ 
++# Regular expressions and other unicode-aware code may need to call
++# utf8->SWASHNEW (via perl's utf8.c).  That will fail unless we share the
++# SWASHNEW method.
++# Sadly we can't just add utf8::SWASHNEW to $default_share because perl's
++# utf8.c code does a fetchmethod on SWASHNEW to check if utf8.pm is loaded,
++# and sharing makes it look like the method exists.
++# The simplest and most robust fix is to ensure the utf8 module is loaded when
++# Safe is loaded. Then we can add utf8::SWASHNEW to $default_share.
++require utf8;
++# we must ensure that utf8_heavy.pl, where SWASHNEW is defined, is loaded
++# but without depending on knowledge of that implementation detail.
++# This code (//i on a unicode string) ensures utf8 is fully loaded
++# and also loads the ToFold SWASH.
++# (Swashes are cached internally by perl in PL_utf8_* variables
++# independent of being inside/outside of Safe. So once loaded they can be)
++do { my $a = pack('U',0xC4); my $b = chr 0xE4; utf8::upgrade $b; $a =~ /$b/i };
++# now we can safely include utf8::SWASHNEW in $default_share defined below.
+ 
+ my $default_root  = 0;
+ # share *_ and functions defined in universal.c
+@@ -57,10 +87,15 @@ my $default_share = [qw[
+     &utf8::downgrade
+     &utf8::native_to_unicode
+     &utf8::unicode_to_native
++    &utf8::SWASHNEW
+     $version::VERSION
+     $version::CLASS
++    $version::STRICT
++    $version::LAX
+     @version::ISA
+-], ($] >= 5.008001 && qw[
++], ($] < 5.010 && qw[
++    &utf8::SWASHGET
++]), ($] >= 5.008001 && qw[
+     &Regexp::DESTROY
+ ]), ($] >= 5.010 && qw[
+     &re::is_regexp
+@@ -93,6 +128,12 @@ my $default_share = [qw[
+     &version::noop
+     &version::is_alpha
+     &version::qv
++    &version::vxs::declare
++    &version::vxs::qv
++    &version::vxs::_VERSION
++    &version::vxs::stringify
++    &version::vxs::new
++    &version::vxs::parse
+ ]), ($] >= 5.011 && qw[
+     &re::regexp_pattern
+ ])];
+@@ -103,14 +144,14 @@ sub new {
+     bless $obj, $class;
+ 
+     if (defined($root)) {
+-	croak "Can't use \"$root\" as root name"
+-	    if $root =~ /^main\b/ or $root !~ /^\w[:\w]*$/;
+-	$obj->{Root}  = $root;
+-	$obj->{Erase} = 0;
++        croak "Can't use \"$root\" as root name"
++            if $root =~ /^main\b/ or $root !~ /^\w[:\w]*$/;
++        $obj->{Root}  = $root;
++        $obj->{Erase} = 0;
+     }
+     else {
+-	$obj->{Root}  = "Safe::Root".$default_root++;
+-	$obj->{Erase} = 1;
++        $obj->{Root}  = "Safe::Root".$default_root++;
++        $obj->{Erase} = 1;
+     }
+ 
+     # use permit/deny methods instead till interface issues resolved
+@@ -125,7 +166,9 @@ 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}) if($Opcode::VERSION > 1.04);
++
+     return $obj;
+ }
+ 
+@@ -140,7 +183,7 @@ sub erase {
+     my ($stem, $leaf);
+ 
+     no strict 'refs';
+-    $pkg = "main::$pkg\::";	# expand to full symbol table name
++    $pkg = "main::$pkg\::";     # expand to full symbol table name
+     ($stem, $leaf) = $pkg =~ m/(.*::)(\w+::)$/;
+ 
+     # The 'my $foo' is needed! Without it you get an
+@@ -149,7 +192,7 @@ sub erase {
+ 
+     #warn "erase($pkg) stem=$stem, leaf=$leaf";
+     #warn " stem_symtab hash ".scalar(%$stem_symtab)."\n";
+-	# ", join(', ', %$stem_symtab),"\n";
++    # ", join(', ', %$stem_symtab),"\n";
+ 
+ #    delete $stem_symtab->{$leaf};
+ 
+@@ -220,12 +263,12 @@ sub dump_mask {
+ }
+ 
+ 
+-
+ sub share {
+     my($obj, @vars) = @_;
+     $obj->share_from(scalar(caller), \@vars);
+ }
+ 
++
+ sub share_from {
+     my $obj = shift;
+     my $pkg = shift;
+@@ -236,26 +279,27 @@ sub share_from {
+     no strict 'refs';
+     # Check that 'from' package actually exists
+     croak("Package \"$pkg\" does not exist")
+-	unless keys %{"$pkg\::"};
++        unless keys %{"$pkg\::"};
+     my $arg;
+     foreach $arg (@$vars) {
+-	# catch some $safe->share($var) errors:
+-	my ($var, $type);
+-	$type = $1 if ($var = $arg) =~ s/^(\W)//;
+-	# warn "share_from $pkg $type $var";
+-	for (1..2) { # assign twice to avoid any 'used once' warnings
+-	    *{$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));
+-	}
++        # catch some $safe->share($var) errors:
++        my ($var, $type);
++        $type = $1 if ($var = $arg) =~ s/^(\W)//;
++        # warn "share_from $pkg $type $var";
++        for (1..2) { # assign twice to avoid any 'used once' warnings
++            *{$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;
+ }
+ 
++
+ sub share_record {
+     my $obj = shift;
+     my $pkg = shift;
+@@ -264,41 +308,137 @@ sub share_record {
+     # Record shares using keys of $obj->{Shares}. See reinit.
+     @{$shares}{@$vars} = ($pkg) x @$vars if @$vars;
+ }
++
++
+ sub share_redo {
+     my $obj = shift;
+     my $shares = \%{$obj->{Shares} ||= {}};
+     my($var, $pkg);
+     while(($var, $pkg) = each %$shares) {
+-	# warn "share_redo $pkg\:: $var";
+-	$obj->share_from($pkg,  [ $var ], 1);
++        # warn "share_redo $pkg\:: $var";
++        $obj->share_from($pkg,  [ $var ], 1);
+     }
+ }
++
++
+ sub share_forget {
+     delete shift->{Shares};
+ }
+ 
++
+ sub varglob {
+     my ($obj, $var) = @_;
+     no strict 'refs';
+     return *{$obj->root()."::$var"};
+ }
+ 
++sub _clean_stash {
++    my ($root, $saved_refs) = @_;
++    $saved_refs ||= [];
++    no strict 'refs';
++    foreach my $hook (qw(DESTROY AUTOLOAD), grep /^\(/, keys %$root) {
++        push @$saved_refs, \*{$root.$hook};
++        delete ${$root}{$hook};
++    }
++
++    for (grep /::$/, keys %$root) {
++        next if \%{$root.$_} eq \%$root;
++        _clean_stash($root.$_, $saved_refs);
++    }
++}
+ 
+ sub reval {
+     my ($obj, $expr, $strict) = @_;
+     my $root = $obj->{Root};
+ 
+-    my $evalsub = lexless_anon_sub($root,$strict, $expr);
+-    return Opcode::_safe_call_sv($root, $obj->{Mask}, $evalsub);
++    my $evalsub = lexless_anon_sub($root, $strict, $expr);
++    # propagate context
++    my $sg = sub_generation();
++    my @subret = (wantarray)
++               ?        Opcode::_safe_call_sv($root, $obj->{Mask}, $evalsub)
++               : scalar Opcode::_safe_call_sv($root, $obj->{Mask}, $evalsub);
++    _clean_stash($root.'::') if $sg != sub_generation();
++    $obj->wrap_code_refs_within(@subret);
++    return (wantarray) ? @subret : $subret[0];
+ }
+ 
++
++sub wrap_code_refs_within {
++    my $obj = shift;
++
++    $obj->_find_code_refs('wrap_code_ref', @_);
++}
++
++
++sub _find_code_refs {
++    my $obj = shift;
++    my $visitor = shift;
++
++    for my $item (@_) {
++        my $reftype = $item && reftype $item
++            or next;
++        if ($reftype eq 'ARRAY') {
++            $obj->_find_code_refs($visitor, @$item);
++        }
++        elsif ($reftype eq 'HASH') {
++            $obj->_find_code_refs($visitor, values %$item);
++        }
++        # XXX GLOBs?
++        elsif ($reftype eq 'CODE') {
++            $item = $obj->$visitor($item);
++        }
++    }
++}
++
++
++sub wrap_code_ref {
++    my ($obj, $sub) = @_;
++
++    # wrap code ref $sub with _safe_call_sv so that, when called, the
++    # execution will happen with the compartment fully 'in effect'.
++
++    croak "Not a CODE reference"
++        if reftype $sub ne 'CODE';
++
++    my $ret = sub {
++        my @args = @_; # lexical to close over
++        my $sub_with_args = sub { $sub->(@args) };
++
++        my @subret;
++        my $error;
++        do {
++            local $@;  # needed due to perl_call_sv(sv, G_EVAL|G_KEEPERR)
++            my $sg = sub_generation();
++            @subret = (wantarray)
++                ?        Opcode::_safe_call_sv($obj->{Root}, $obj->{Mask}, $sub_with_args)
++                : scalar Opcode::_safe_call_sv($obj->{Root}, $obj->{Mask}, $sub_with_args);
++            $error = $@;
++            _clean_stash($obj->{Root}.'::') if $sg != sub_generation();
++        };
++        if ($error) { # rethrow exception
++            $error =~ s/\t\(in cleanup\) //; # prefix added by G_KEEPERR
++            die $error;
++        }
++        return (wantarray) ? @subret : $subret[0];
++    };
++
++    return $ret;
++}
++
++
+ sub rdo {
+     my ($obj, $file) = @_;
+     my $root = $obj->{Root};
+ 
++    my $sg = sub_generation();
+     my $evalsub = eval
+-	    sprintf('package %s; sub { @_ = (); do $file }', $root);
+-    return Opcode::_safe_call_sv($root, $obj->{Mask}, $evalsub);
++            sprintf('package %s; sub { @_ = (); do $file }', $root);
++    my @subret = (wantarray)
++               ?        Opcode::_safe_call_sv($root, $obj->{Mask}, $evalsub)
++               : scalar Opcode::_safe_call_sv($root, $obj->{Mask}, $evalsub);
++    _clean_stash($root.'::') if $sg != sub_generation();
++    $obj->wrap_code_refs_within(@subret);
++    return (wantarray) ? @subret : $subret[0];
+ }
+ 
+ 
+@@ -390,15 +530,7 @@ of this software.
+ Your mileage will vary. If in any doubt B<do not use it>.
+ 
+ 
+-=head2 RECENT CHANGES
+-
+-The interface to the Safe module has changed quite dramatically since
+-version 1 (as supplied with Perl5.002). Study these pages carefully if
+-you have code written to use Safe version 1 because you will need to
+-makes changes.
+-
+-
+-=head2 Methods in class Safe
++=head1 METHODS
+ 
+ To create a new compartment, use
+ 
+@@ -417,9 +549,7 @@ object returned by the above constructor
+ is implicit in each case.
+ 
+ 
+-=over 8
+-
+-=item permit (OP, ...)
++=head2 permit (OP, ...)
+ 
+ Permit the listed operators to be used when compiling code in the
+ compartment (in I<addition> to any operators already permitted).
+@@ -427,29 +557,30 @@ compartment (in I<addition> to any opera
+ You can list opcodes by names, or use a tag name; see
+ L<Opcode/"Predefined Opcode Tags">.
+ 
+-=item permit_only (OP, ...)
++=head2 permit_only (OP, ...)
+ 
+ Permit I<only> the listed operators to be used when compiling code in
+ the compartment (I<no> other operators are permitted).
+ 
+-=item deny (OP, ...)
++=head2 deny (OP, ...)
+ 
+ Deny the listed operators from being used when compiling code in the
+ compartment (other operators may still be permitted).
+ 
+-=item deny_only (OP, ...)
++=head2 deny_only (OP, ...)
+ 
+ Deny I<only> the listed operators from being used when compiling code
+-in the compartment (I<all> other operators will be permitted).
++in the compartment (I<all> other operators will be permitted, so you probably
++don't want to use this method).
+ 
+-=item trap (OP, ...)
++=head2 trap (OP, ...)
+ 
+-=item untrap (OP, ...)
++=head2 untrap (OP, ...)
+ 
+ The trap and untrap methods are synonyms for deny and permit
+ respectfully.
+ 
+-=item share (NAME, ...)
++=head2 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>
+@@ -465,9 +596,9 @@ for a glob (i.e.  all symbol table entri
+ including scalar, array, hash, sub and filehandle).
+ 
+ Each NAME is assumed to be in the calling package. See share_from
+-for an alternative method (which share uses).
++for an alternative method (which C<share> uses).
+ 
+-=item share_from (PACKAGE, ARRAYREF)
++=head2 share_from (PACKAGE, ARRAYREF)
+ 
+ This method is similar to share() but allows you to explicitly name the
+ package that symbols should be shared from. The symbol names (including
+@@ -475,20 +606,29 @@ type characters) are supplied as an arra
+ 
+     $safe->share_from('main', [ '$foo', '%bar', 'func' ]);
+ 
++Names can include package names, which are relative to the specified PACKAGE.
++So these two calls have the same effect:
++
++    $safe->share_from('Scalar::Util', [ 'reftype' ]);
++    $safe->share_from('main', [ 'Scalar::Util::reftype' ]);
+ 
+-=item varglob (VARNAME)
++=head2 varglob (VARNAME)
+ 
+ This returns a glob reference for the symbol table entry of VARNAME in
+ the package of the compartment. VARNAME must be the B<name> of a
+-variable without any leading type marker. For example,
++variable without any leading type marker. For example:
++
++    ${$cpt->varglob('foo')} = "Hello world";
++
++has the same effect as:
+ 
+     $cpt = new Safe 'Root';
+     $Root::foo = "Hello world";
+-    # Equivalent version which doesn't need to know $cpt's package name:
+-    ${$cpt->varglob('foo')} = "Hello world";
+ 
++but avoids the need to know $cpt's package name.
+ 
+-=item reval (STRING, STRICT)
++
++=head2 reval (STRING, STRICT)
+ 
+ This evaluates STRING as perl code inside the compartment.
+ 
+@@ -511,9 +651,9 @@ expression evaluated, or a return statem
+ subroutines and B<eval()>. The context (list or scalar) is determined
+ by the caller as usual.
+ 
+-This behaviour differs from the beta distribution of the Safe extension
+-where earlier versions of perl made it hard to mimic the return
+-behaviour of the eval() command and the context was always scalar.
++If the return value of reval() is (or contains) any code reference,
++those code references are wrapped to be themselves executed always
++in the compartment. See L</wrap_code_refs_within>.
+ 
+ The formerly undocumented STRICT argument sets strictness: if true
+ 'use strict;' is used, otherwise it uses 'no strict;'. B<Note>: if
+@@ -553,14 +693,12 @@ the code in the compartment.
+ A similar effect applies to I<all> runtime symbol lookups in code
+ called from a compartment but not compiled within it.
+ 
+-
+-
+-=item rdo (FILENAME)
++=head2 rdo (FILENAME)
+ 
+ This evaluates the contents of file FILENAME inside the compartment.
+ See above documentation on the B<reval> method for further details.
+ 
+-=item root (NAMESPACE)
++=head2 root (NAMESPACE)
+ 
+ This method returns the name of the package that is the root of the
+ compartment's namespace.
+@@ -569,7 +707,7 @@ Note that this behaviour differs from ve
+ where the root module could be used to change the namespace. That
+ functionality has been withdrawn pending deeper consideration.
+ 
+-=item mask (MASK)
++=head2 mask (MASK)
+ 
+ This is a get-or-set method for the compartment's operator mask.
+ 
+@@ -579,14 +717,34 @@ the compartment.
+ With the MASK argument present, it sets the operator mask for the
+ compartment (equivalent to calling the deny_only method).
+ 
+-=back
++=head2 wrap_code_ref (CODEREF)
+ 
++Returns a reference to an anonymous subroutine that, when executed, will call
++CODEREF with the Safe compartment 'in effect'.  In other words, with the
++package namespace adjusted and the opmask enabled.
+ 
+-=head2 Some Safety Issues
++Note that the opmask doesn't affect the already compiled code, it only affects
++any I<further> compilation that the already compiled code may try to perform.
+ 
+-This section is currently just an outline of some of the things code in
+-a compartment might do (intentionally or unintentionally) which can
+-have an effect outside the compartment.
++This is particularly useful when applied to code references returned from reval().
++
++(It also provides a kind of workaround for RT#60374: "Safe.pm sort {} bug with
++-Dusethreads". See L<http://rt.perl.org/rt3//Public/Bug/Display.html?id=60374>
++for I<much> more detail.)
++
++=head2 wrap_code_refs_within (...)
++
++Wraps any CODE references found within the arguments by replacing each with the
++result of calling L</wrap_code_ref> on the CODE reference. Any ARRAY or HASH
++references in the arguments are inspected recursively.
++
++Returns nothing.
++
++=head1 RISKS
++
++This section is just an outline of some of the things code in a compartment
++might do (intentionally or unintentionally) which can have an effect outside
++the compartment.
+ 
+ =over 8
+ 
+@@ -624,7 +782,7 @@ but more subtle effect.
+ 
+ =back
+ 
+-=head2 AUTHOR
++=head1 AUTHOR
+ 
+ Originally designed and implemented by Malcolm Beattie.
+