From 2d6ea4fe7621dc7000f5edfb3684af4ddb8bff71 Mon Sep 17 00:00:00 2001 From: tron Date: Mon, 28 Jun 2010 18:32:31 +0000 Subject: Pullup ticket #3151 - requested by spz lang/perl5: security patch Revisions pulled up: - lang/perl5/Makefile 1.159 - lang/perl5/distinfo 1.65 - lang/perl5/patches/patch-fa 1.1 --- Module Name: pkgsrc Committed By: spz Date: Sun Jun 27 13:38:39 UTC 2010 Modified Files: pkgsrc/lang/perl5: Makefile distinfo Added Files: pkgsrc/lang/perl5/patches: patch-fa Log Message: fix CVE-2010-1168 and CVE-2010-1447 by updating Safe.pm to the current, not-affected version --- lang/perl5/Makefile | 4 +- lang/perl5/distinfo | 3 +- lang/perl5/patches/patch-fa | 565 ++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 569 insertions(+), 3 deletions(-) create mode 100644 lang/perl5/patches/patch-fa diff --git a/lang/perl5/Makefile b/lang/perl5/Makefile index 222efb46fc0..a5b6d887321 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.158.2.1 2010/06/28 18:32:31 tron 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..64329ef0b8d 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.64.2.1 2010/06/28 18:32:31 tron 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..7f382149d28 --- /dev/null +++ b/lang/perl5/patches/patch-fa @@ -0,0 +1,565 @@ +$NetBSD: patch-fa,v 1.1.2.2 2010/06/28 18:32:31 tron 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. + + +-=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 to any operators already permitted). +@@ -427,29 +557,30 @@ compartment (in I to any opera + You can list opcodes by names, or use a tag name; see + L. + +-=item permit_only (OP, ...) ++=head2 permit_only (OP, ...) + + Permit I the listed operators to be used when compiling code in + the compartment (I 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 the listed operators from being used when compiling code +-in the compartment (I other operators will be permitted). ++in the compartment (I 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 +@@ -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 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 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. 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. + + The formerly undocumented STRICT argument sets strictness: if true + 'use strict;' is used, otherwise it uses 'no strict;'. B: if +@@ -553,14 +693,12 @@ the code in the compartment. + A similar effect applies to I 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 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 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 ++for I more detail.) ++ ++=head2 wrap_code_refs_within (...) ++ ++Wraps any CODE references found within the arguments by replacing each with the ++result of calling L 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. + -- cgit v1.2.3