Package: release.debian.org Severity: normal Tags: stretch User: release.debian....@packages.debian.org Usertags: pu
We would like to apply the following fixes to perl in stretch for the next point release: * Backport various Getopt-Long fixes from upstream 2.49..2.51. (Closes: #855532, #864544) * Backport upstream patch fixing regexp "Malformed UTF-8 character" crashes. (Closes: #864782) * Apply upstream base.pm no-dot-in-inc fix (from 5.24.2-RC1) (Closes: #867170) Hopefully the bug reports provide all the relevant context. The jessie-pu bug #864745 is somewhat related as the third change above is also being proposed there; the others are regressions from jessie which appeared in stretch. Thanks, Dominic.
diff --git a/MANIFEST b/MANIFEST index e4331f1..e6a3dd9 100644 --- a/MANIFEST +++ b/MANIFEST @@ -3007,6 +3007,7 @@ dist/base/t/fields-5_6_0.t See if fields work dist/base/t/fields-5_8_0.t See if fields work dist/base/t/fields-base.t See if fields work dist/base/t/fields.t See if fields work +dist/base/t/incdot.t Test how base.pm handles '.' in @INC dist/base/t/isa.t See if base's behaviour doesn't change dist/base/t/lib/Broken.pm Test module for base.pm dist/base/t/lib/Dummy.pm Test module for base.pm diff --git a/cpan/Getopt-Long/lib/Getopt/Long.pm b/cpan/Getopt-Long/lib/Getopt/Long.pm index fdc96bd..e71fee8 100644 --- a/cpan/Getopt-Long/lib/Getopt/Long.pm +++ b/cpan/Getopt-Long/lib/Getopt/Long.pm @@ -1110,10 +1110,29 @@ sub FindOption ($$$$$) { # Check if there is an option argument available. if ( $gnu_compat ) { - my $optargtype = 0; # 0 = none, 1 = empty, 2 = nonempty - $optargtype = ( !defined($optarg) ? 0 : ( (length($optarg) == 0) ? 1 : 2 ) ); - return (1, $opt, $ctl, undef) - if (($optargtype == 0) && !$mand); + my $optargtype = 0; # none, 1 = empty, 2 = nonempty, 3 = aux + if ( defined($optarg) ) { + $optargtype = (length($optarg) == 0) ? 1 : 2; + } + elsif ( defined $rest || @$argv > 0 ) { + # GNU getopt_long() does not accept the (optional) + # argument to be passed to the option without = sign. + # We do, since not doing so breaks existing scripts. + $optargtype = 3; + } + if(($optargtype == 0) && !$mand) { + if ( $type eq 'I' ) { + # Fake incremental type. + my @c = @$ctl; + $c[CTL_TYPE] = '+'; + return (1, $opt, \@c, 1); + } + my $val + = defined($ctl->[CTL_DEFAULT]) ? $ctl->[CTL_DEFAULT] + : $type eq 's' ? '' + : 0; + return (1, $opt, $ctl, $val); + } return (1, $opt, $ctl, $type eq 's' ? '' : 0) if $optargtype == 1; # --foo= -> return nothing } @@ -2322,11 +2341,14 @@ do. Without C<gnu_compat>, C<--opt=> gives an error. With C<gnu_compat>, C<--opt=> will give option C<opt> and empty value. This is the way GNU getopt_long() does it. +Note that C<--opt value> is still accepted, even though GNU +getopt_long() doesn't. + =item gnu_getopt This is a short way of setting C<gnu_compat> C<bundling> C<permute> C<no_getopt_compat>. With C<gnu_getopt>, command line handling should be -fully compatible with GNU getopt_long(). +reasonably compatible with GNU getopt_long(). =item require_order diff --git a/debian/.git-dpm b/debian/.git-dpm index e62f968..28b4395 100644 --- a/debian/.git-dpm +++ b/debian/.git-dpm @@ -1,6 +1,6 @@ # see git-dpm(1) from git-dpm package -641936971e243d39e8eee510824e076c75965fc6 -641936971e243d39e8eee510824e076c75965fc6 +ceaa6f3d1fd7942ad1de321197030bb2306bd7ec +ceaa6f3d1fd7942ad1de321197030bb2306bd7ec 13beb365bfa6ab6c49c061bd55769bf272a5e1bf 13beb365bfa6ab6c49c061bd55769bf272a5e1bf perl_5.24.1.orig.tar.xz diff --git a/debian/changelog b/debian/changelog index c48cff7..d05b73a 100644 --- a/debian/changelog +++ b/debian/changelog @@ -1,3 +1,14 @@ +perl (5.24.1-3+deb9u1) UNRELEASED; urgency=medium + + * Backport various Getopt-Long fixes from upstream 2.49..2.51. + (Closes: #855532, #864544) + * Backport upstream patch fixing regexp "Malformed UTF-8 character" + crashes. (Closes: #864782) + * Apply upstream base.pm no-dot-in-inc fix (from 5.24.2-RC1) + (Closes: #867170) + + -- Dominic Hargreaves <d...@earth.li> Fri, 23 Jun 2017 21:31:26 +0100 + perl (5.24.1-3) unstable; urgency=high * [CVE-2017-6512] Fix file permissions race condition in File-Path; diff --git a/debian/patches/debian/CVE-2016-1238/base-pm-amends-pt2.diff b/debian/patches/debian/CVE-2016-1238/base-pm-amends-pt2.diff new file mode 100644 index 0000000..fd44d21 --- /dev/null +++ b/debian/patches/debian/CVE-2016-1238/base-pm-amends-pt2.diff @@ -0,0 +1,206 @@ +From ceaa6f3d1fd7942ad1de321197030bb2306bd7ec Mon Sep 17 00:00:00 2001 +From: Aristotle Pagaltzis <pagalt...@gmx.de> +Date: Mon, 13 Feb 2017 01:28:14 +0100 +Subject: wip + +[latest version of base.pm no-dot-in-inc fix, + backported to Debian 5.20 by Niko Tyni] + +Origin: upstream, http://perl5.git.perl.org/perl.git/commit/2d156e07f936ea4f8ce46dee5ade17fe19dbbf29 +Patch-Name: debian/CVE-2016-1238/base-pm-amends-pt2.diff +--- + MANIFEST | 1 + + dist/base/lib/base.pm | 55 +++++++++++++++++++++++++++++++++++-- + dist/base/t/incdot.t | 55 +++++++++++++++++++++++++++++++++++++ + dist/base/t/lib/BaseIncMandatory.pm | 9 ++++++ + dist/base/t/lib/BaseIncOptional.pm | 13 +++++++++ + 5 files changed, 131 insertions(+), 2 deletions(-) + create mode 100644 dist/base/t/incdot.t + create mode 100644 dist/base/t/lib/BaseIncMandatory.pm + create mode 100644 dist/base/t/lib/BaseIncOptional.pm + +diff --git a/MANIFEST b/MANIFEST +index e4331f1..e6a3dd9 100644 +--- a/MANIFEST ++++ b/MANIFEST +@@ -3007,6 +3007,7 @@ dist/base/t/fields-5_6_0.t See if fields work + dist/base/t/fields-5_8_0.t See if fields work + dist/base/t/fields-base.t See if fields work + dist/base/t/fields.t See if fields work ++dist/base/t/incdot.t Test how base.pm handles '.' in @INC + dist/base/t/isa.t See if base's behaviour doesn't change + dist/base/t/lib/Broken.pm Test module for base.pm + dist/base/t/lib/Dummy.pm Test module for base.pm +diff --git a/dist/base/lib/base.pm b/dist/base/lib/base.pm +index 6fee600..044d138 100644 +--- a/dist/base/lib/base.pm ++++ b/dist/base/lib/base.pm +@@ -6,6 +6,11 @@ use vars qw($VERSION); + $VERSION = '2.23'; + $VERSION =~ tr/_//d; + ++# simplest way to avoid indexing of the package: no package statement ++sub base::__inc::unhook { @INC = grep !(ref eq 'CODE' && $_ == $_[0]), @INC } ++# instance is blessed array of coderefs to be removed from @INC at scope exit ++sub base::__inc::scope_guard::DESTROY { base::__inc::unhook $_ for @{$_[0]} } ++ + # constant.pm is slow + sub SUCCESS () { 1 } + +@@ -91,13 +96,59 @@ sub import { + + next if grep $_->isa($base), ($inheritor, @bases); + +- # Following blocks help isolate $SIG{__DIE__} changes ++ # Following blocks help isolate $SIG{__DIE__} and @INC changes + { + my $sigdie; + { + local $SIG{__DIE__}; + my $fn = _module_to_filename($base); +- eval { require $fn }; ++ my $dot_hidden; ++ eval { ++ my $guard; ++ if ($INC[-1] eq '.' && %{"$base\::"}) { ++ # So: the package already exists => this an optional load ++ # And: there is a dot at the end of @INC => we want to hide it ++ # However: we only want to hide it during our *own* require() ++ # (i.e. without affecting nested require()s). ++ # So we add a hook to @INC whose job is to hide the dot, but which ++ # first checks checks the callstack depth, because within nested ++ # require()s the callstack is deeper. ++ # Since CORE::GLOBAL::require makes it unknowable in advance what ++ # the exact relevant callstack depth will be, we have to record it ++ # inside a hook. So we put another hook just for that at the front ++ # of @INC, where it's guaranteed to run -- immediately. ++ # The dot-hiding hook does its job by sitting directly in front of ++ # the dot and removing itself from @INC when reached. This causes ++ # the dot to move up one index in @INC, causing the loop inside ++ # pp_require() to skip it. ++ # Loaded coded may disturb this precise arrangement, but that's OK ++ # because the hook is inert by that time. It is only active during ++ # the top-level require(), when @INC is in our control. The only ++ # possible gotcha is if other hooks already in @INC modify @INC in ++ # some way during that initial require(). ++ # Note that this jiggery hookery works just fine recursively: if ++ # a module loaded via base.pm uses base.pm itself, there will be ++ # one pair of hooks in @INC per base::import call frame, but the ++ # pairs from different nestings do not interfere with each other. ++ my $lvl; ++ unshift @INC, sub { return if defined $lvl; 1 while defined caller ++$lvl; () }; ++ splice @INC, -1, 0, sub { return if defined caller $lvl; ++$dot_hidden, &base::__inc::unhook; () }; ++ $guard = bless [ @INC[0,-2] ], 'base::__inc::scope_guard'; ++ } ++ require $fn ++ }; ++ if ($dot_hidden && (my @fn = grep -e && !( -d _ || -b _ ), $fn.'c', $fn)) { ++ require Carp; ++ Carp::croak(<<ERROR); ++Base class package "$base" is not empty but "$fn[0]" exists in the current directory. ++ To help avoid security issues, base.pm now refuses to load optional modules ++ from the current working directory when it is the last entry in \@INC. ++ If your software worked on previous versions of Perl, the best solution ++ is to use FindBin to detect the path properly and to add that path to ++ \@INC. As a last resort, you can re-enable looking in the current working ++ directory by adding "use lib '.'" to your code. ++ERROR ++ } + # Only ignore "Can't locate" errors from our eval require. + # Other fatal errors (syntax etc) must be reported. + # +diff --git a/dist/base/t/incdot.t b/dist/base/t/incdot.t +new file mode 100644 +index 0000000..412b2fe +--- /dev/null ++++ b/dist/base/t/incdot.t +@@ -0,0 +1,55 @@ ++#!/usr/bin/perl -w ++ ++use strict; ++ ++####################################################################### ++ ++sub array_diff { ++ my ( $got, $expected ) = @_; ++ push @$got, ( '(missing)' ) x ( @$expected - @$got ) if @$got < @$expected; ++ push @$expected, ( '(should not exist)' ) x ( @$got - @$expected ) if @$got > @$expected; ++ join "\n ", ' All differences:', ( ++ map +( "got [$_] " . $got->[$_], 'expected'.(' ' x length).$expected->[$_] ), ++ grep $got->[$_] ne $expected->[$_], ++ 0 .. $#$got ++ ); ++} ++ ++####################################################################### ++ ++use Test::More tests => 8; # some extra tests in t/lib/BaseInc* ++ ++use lib 't/lib', sub {()}; ++ ++# make it look like an older perl ++BEGIN { push @INC, '.' if $INC[-1] ne '.' } ++ ++BEGIN { ++ my $x = sub { CORE::require $_[0] }; ++ my $y = sub { &$x }; ++ my $z = sub { &$y }; ++ *CORE::GLOBAL::require = $z; ++} ++ ++my @expected; BEGIN { @expected = @INC } ++ ++use base 'BaseIncMandatory'; ++ ++BEGIN { ++ @t::lib::Dummy::ISA = (); # make it look like an optional load ++ my $success = eval q{use base 't::lib::Dummy'}, my $err = $@; ++ ok !$success, 'loading optional modules from . using base.pm fails'; ++ is_deeply \@INC, \@expected, '... without changes to @INC' ++ or diag array_diff [@INC], [@expected]; ++ like $err, qr!Base class package "t::lib::Dummy" is not empty but "t/lib/Dummy\.pm" exists in the current directory\.!, ++ '... and the proper error message'; ++} ++ ++BEGIN { @BaseIncOptional::ISA = () } # make it look like an optional load ++use base 'BaseIncOptional'; ++ ++BEGIN { ++ @expected = ( 't/lib/on-head', @expected, 't/lib/on-tail' ); ++ is_deeply \@INC, \@expected, 'modules loaded by base can extend @INC at both ends' ++ or diag array_diff [@INC], [@expected]; ++} +diff --git a/dist/base/t/lib/BaseIncMandatory.pm b/dist/base/t/lib/BaseIncMandatory.pm +new file mode 100644 +index 0000000..9e0718c +--- /dev/null ++++ b/dist/base/t/lib/BaseIncMandatory.pm +@@ -0,0 +1,9 @@ ++package BaseIncMandatory; ++ ++BEGIN { package main; ++ is $INC[-1], '.', 'trailing dot remains in @INC during mandatory module load from base'; ++ ok eval('require t::lib::Dummy'), '... and modules load fine from .' or diag "$@"; ++ delete $INC{'t/lib/Dummy.pm'}; ++} ++ ++1; +diff --git a/dist/base/t/lib/BaseIncOptional.pm b/dist/base/t/lib/BaseIncOptional.pm +new file mode 100644 +index 0000000..e5bf017 +--- /dev/null ++++ b/dist/base/t/lib/BaseIncOptional.pm +@@ -0,0 +1,13 @@ ++package BaseIncOptional; ++ ++BEGIN { package main; ++ is $INC[-1], '.', 'trailing dot remains in @INC during optional module load from base'; ++ ok eval('require t::lib::Dummy'), '... and modules load fine from .' or diag "$@"; ++ delete $INC{'t/lib/Dummy.pm'}; ++} ++ ++use lib 't/lib/on-head'; ++ ++push @INC, 't/lib/on-tail'; ++ ++1; diff --git a/debian/patches/fixes/fbm-instr-crash.diff b/debian/patches/fixes/fbm-instr-crash.diff new file mode 100644 index 0000000..ab675ba --- /dev/null +++ b/debian/patches/fixes/fbm-instr-crash.diff @@ -0,0 +1,107 @@ +From 859dcf997f49025fe0593ae549331b28afc1a791 Mon Sep 17 00:00:00 2001 +From: David Mitchell <da...@iabyn.com> +Date: Fri, 16 Jun 2017 15:46:19 +0100 +Subject: don't call Perl_fbm_instr() with negative length + +RT #131575 + +re_intuit_start() could calculate a maximum end position less than the +current start position. This used to get rejected by fbm_intr(), until +v5.23.3-110-g147f21b, which made fbm_intr() faster and removed unnecessary +checks. + +This commits fixes re_intuit_start(), and adds an assert to fbm_intr(). + +[ backported to Debian 5.24 by Niko Tyni <nt...@debian.org> ] + +Bug-Debian: https://bugs.debian.org/864782 +Bug: https://rt.perl.org/Public/Bug/Display.html?id=131575 +Origin: backport, https://perl5.git.perl.org/perl.git/commit/bb152a4b442f7718fd37d32cc558be675e8ae1ae +Patch-Name: fixes/fbm-instr-crash.diff +--- + regexec.c | 17 +++++++++++------ + t/re/pat.t | 13 ++++++++++++- + util.c | 2 ++ + 3 files changed, 25 insertions(+), 7 deletions(-) + +diff --git a/regexec.c b/regexec.c +index cdaa95c..4cea7d2 100644 +--- a/regexec.c ++++ b/regexec.c +@@ -127,13 +127,16 @@ static const char* const non_utf8_target_but_utf8_required + (U8*)(off >= 0 ? reginfo->strend : reginfo->strbeg)) \ + : (U8*)(pos + off)) + +-#define HOPBACKc(pos, off) \ +- (char*)(reginfo->is_utf8_target \ +- ? reghopmaybe3((U8*)pos, (SSize_t)0-off, (U8*)(reginfo->strbeg)) \ +- : (pos - off >= reginfo->strbeg) \ +- ? (U8*)pos - off \ ++/* like HOPMAYBE3 but backwards. lim must be +ve. Returns NULL on overshoot */ ++#define HOPBACK3(pos, off, lim) \ ++ (reginfo->is_utf8_target \ ++ ? reghopmaybe3((U8*)pos, (SSize_t)0-off, (U8*)(lim)) \ ++ : (pos - off >= lim) \ ++ ? (U8*)pos - off \ + : NULL) + ++#define HOPBACKc(pos, off) ((char*)HOPBACK3(pos, off, reginfo->strbeg)) ++ + #define HOP3(pos,off,lim) (reginfo->is_utf8_target ? reghop3((U8*)(pos), off, (U8*)(lim)) : (U8*)(pos + off)) + #define HOP3c(pos,off,lim) ((char*)HOP3(pos,off,lim)) + +@@ -870,7 +873,9 @@ Perl_re_intuit_start(pTHX_ + (IV)prog->check_end_shift); + }); + +- end_point = HOP3(strend, -end_shift, strbeg); ++ end_point = HOPBACK3(strend, end_shift, rx_origin); ++ if (!end_point) ++ goto fail_finish; + start_point = HOPMAYBE3(rx_origin, start_shift, end_point); + if (!start_point) + goto fail_finish; +diff --git a/t/re/pat.t b/t/re/pat.t +index 8652bf6..f32e529 100644 +--- a/t/re/pat.t ++++ b/t/re/pat.t +@@ -23,7 +23,7 @@ BEGIN { + skip_all_without_unicode_tables(); + } + +-plan tests => 789; # Update this when adding/deleting tests. ++plan tests => 790; # Update this when adding/deleting tests. + + run_tests() unless caller; + +@@ -1758,6 +1758,17 @@ EOP + fresh_perl_is($code, $expect, {}, "$bug - $test_name" ); + } + } ++ ++ { ++ # RT #131575 intuit skipping back from the end to find the highest ++ # possible start point, was potentially hopping back beyond pos() ++ # and crashing by calling fbm_instr with a negative length ++ ++ my $text = "=t=\x{5000}"; ++ pos($text) = 3; ++ ok(scalar($text !~ m{(~*=[a-z]=)}g), "RT #131575"); ++ } ++ + } # End of sub run_tests + + 1; +diff --git a/util.c b/util.c +index 89c44e7..f131504 100644 +--- a/util.c ++++ b/util.c +@@ -806,6 +806,8 @@ Perl_fbm_instr(pTHX_ unsigned char *big, unsigned char *bigend, SV *littlestr, U + + PERL_ARGS_ASSERT_FBM_INSTR; + ++ assert(bigend >= big); ++ + if ((STRLEN)(bigend - big) < littlelen) { + if ( SvTAIL(littlestr) + && ((STRLEN)(bigend - big) == littlelen - 1) diff --git a/debian/patches/fixes/getopt-long-1.diff b/debian/patches/fixes/getopt-long-1.diff new file mode 100644 index 0000000..e2c228a --- /dev/null +++ b/debian/patches/fixes/getopt-long-1.diff @@ -0,0 +1,30 @@ +From 32b77c5078ae73a2cd666ea6ec7f91d95c2c3e83 Mon Sep 17 00:00:00 2001 +From: Roy Ivy III <rivy....@gmail.com> +Date: Tue, 7 Jun 2016 13:00:26 -0500 +Subject: Fix bug RT#114999 + +* fixes [RT#114999](https://rt.cpan.org/Ticket/Display.html?id=114999) +* 'gnu_compat' mode single character options with optional arguments and default values + now return correct values when used with no argument from the CLI + +Origin: backport, https://github.com/sciurius/perl-Getopt-Long/commit/5d9947fb445327c7299d8beb009d609bc70066c0 +Bug: https://rt.cpan.org/Ticket/Display.html?id=114999 +Bug-Debian: https://bugs.debian.org/855532 +Patch-Name: fixes/getopt-long-1.diff +--- + cpan/Getopt-Long/lib/Getopt/Long.pm | 2 +- + 1 file changed, 1 insertion(+), 1 deletion(-) + +diff --git a/cpan/Getopt-Long/lib/Getopt/Long.pm b/cpan/Getopt-Long/lib/Getopt/Long.pm +index fdc96bd..631912b 100644 +--- a/cpan/Getopt-Long/lib/Getopt/Long.pm ++++ b/cpan/Getopt-Long/lib/Getopt/Long.pm +@@ -1112,7 +1112,7 @@ sub FindOption ($$$$$) { + if ( $gnu_compat ) { + my $optargtype = 0; # 0 = none, 1 = empty, 2 = nonempty + $optargtype = ( !defined($optarg) ? 0 : ( (length($optarg) == 0) ? 1 : 2 ) ); +- return (1, $opt, $ctl, undef) ++ return (1, $opt, $ctl, defined($ctl->[CTL_DEFAULT]) ? $ctl->[CTL_DEFAULT] : undef) + if (($optargtype == 0) && !$mand); + return (1, $opt, $ctl, $type eq 's' ? '' : 0) + if $optargtype == 1; # --foo= -> return nothing diff --git a/debian/patches/fixes/getopt-long-2.diff b/debian/patches/fixes/getopt-long-2.diff new file mode 100644 index 0000000..c385802 --- /dev/null +++ b/debian/patches/fixes/getopt-long-2.diff @@ -0,0 +1,57 @@ +From 9ac9f053dcb547dd401e02c360bea416889ced4a Mon Sep 17 00:00:00 2001 +From: Johan Vromans <jvrom...@squirrel.nl> +Date: Wed, 22 Feb 2017 12:10:34 +0100 +Subject: Withdraw part of commit 5d9947fb445327c7299d8beb009d609bc70066c0, + which tries to implement more GNU getopt_long campatibility. GNU + getopt_long() does not accept the (optional) argument to be passed to the + option without = sign. However, we do, since not doing so breaks existing + scripts. + +Origin: backport, https://github.com/sciurius/perl-Getopt-Long/commit/258074ddb2f8960eb1c74a5b20d6ea7263c3bb13 +Bug: https://rt.cpan.org/Public/Bug/Display.html?id=120300 +Patch-Name: fixes/getopt-long-2.diff +--- + cpan/Getopt-Long/lib/Getopt/Long.pm | 19 +++++++++++++++---- + 1 file changed, 15 insertions(+), 4 deletions(-) + +diff --git a/cpan/Getopt-Long/lib/Getopt/Long.pm b/cpan/Getopt-Long/lib/Getopt/Long.pm +index 631912b..68f090b 100644 +--- a/cpan/Getopt-Long/lib/Getopt/Long.pm ++++ b/cpan/Getopt-Long/lib/Getopt/Long.pm +@@ -1110,9 +1110,17 @@ sub FindOption ($$$$$) { + + # Check if there is an option argument available. + if ( $gnu_compat ) { +- my $optargtype = 0; # 0 = none, 1 = empty, 2 = nonempty +- $optargtype = ( !defined($optarg) ? 0 : ( (length($optarg) == 0) ? 1 : 2 ) ); +- return (1, $opt, $ctl, defined($ctl->[CTL_DEFAULT]) ? $ctl->[CTL_DEFAULT] : undef) ++ my $optargtype = 0; # none, 1 = empty, 2 = nonempty, 3 = aux ++ if ( defined($optarg) ) { ++ $optargtype = (length($optarg) == 0) ? 1 : 2; ++ } ++ elsif ( defined $rest || @$argv > 0 ) { ++ # GNU getopt_long() does not accept the (optional) ++ # argument to be passed to the option without = sign. ++ # We do, since not doing so breaks existing scripts. ++ $optargtype = 3; ++ } ++ return (1, $opt, $ctl, $ctl->[CTL_DEFAULT]) + if (($optargtype == 0) && !$mand); + return (1, $opt, $ctl, $type eq 's' ? '' : 0) + if $optargtype == 1; # --foo= -> return nothing +@@ -2322,11 +2330,14 @@ do. Without C<gnu_compat>, C<--opt=> gives an error. With C<gnu_compat>, + C<--opt=> will give option C<opt> and empty value. + This is the way GNU getopt_long() does it. + ++Note that C<--opt value> is still accepted, even though GNU ++getopt_long() doesn't. ++ + =item gnu_getopt + + This is a short way of setting C<gnu_compat> C<bundling> C<permute> + C<no_getopt_compat>. With C<gnu_getopt>, command line handling should be +-fully compatible with GNU getopt_long(). ++reasonably compatible with GNU getopt_long(). + + =item require_order + diff --git a/debian/patches/fixes/getopt-long-3.diff b/debian/patches/fixes/getopt-long-3.diff new file mode 100644 index 0000000..bff2094c --- /dev/null +++ b/debian/patches/fixes/getopt-long-3.diff @@ -0,0 +1,40 @@ +From a945036d71f89cca40cd208e3755967921293947 Mon Sep 17 00:00:00 2001 +From: Andrew Gregory <andrew.gregor...@gmail.com> +Date: Sun, 21 May 2017 21:12:21 -0400 +Subject: provide a default value for optional arguments + +When using gnu_compat, FindOption would return undef as the value for +the options with optional arguments if none was provided. Subsequent +processing in GetOptionsFromArray is skipped entirely for undef values, +causing the option to be silently discarded. The following code snippet +demonstrates the issue: + + use Getopt::Long qw(GetOptionsFromArray :config gnu_compat); + GetOptionsFromArray( ['--foo'], 'foo:s' => sub { print("success") } ); + +Origin: backport, https://github.com/sciurius/perl-Getopt-Long/commit/2d16f355e25537aa742eb2833a7d52a63051429b +Patch-Name: fixes/getopt-long-3.diff +--- + cpan/Getopt-Long/lib/Getopt/Long.pm | 9 +++++++-- + 1 file changed, 7 insertions(+), 2 deletions(-) + +diff --git a/cpan/Getopt-Long/lib/Getopt/Long.pm b/cpan/Getopt-Long/lib/Getopt/Long.pm +index 68f090b..9992578 100644 +--- a/cpan/Getopt-Long/lib/Getopt/Long.pm ++++ b/cpan/Getopt-Long/lib/Getopt/Long.pm +@@ -1120,8 +1120,13 @@ sub FindOption ($$$$$) { + # We do, since not doing so breaks existing scripts. + $optargtype = 3; + } +- return (1, $opt, $ctl, $ctl->[CTL_DEFAULT]) +- if (($optargtype == 0) && !$mand); ++ if(($optargtype == 0) && !$mand) { ++ my $val ++ = defined($ctl->[CTL_DEFAULT]) ? $ctl->[CTL_DEFAULT] ++ : $type eq 's' ? '' ++ : 0; ++ return (1, $opt, $ctl, $val); ++ } + return (1, $opt, $ctl, $type eq 's' ? '' : 0) + if $optargtype == 1; # --foo= -> return nothing + } diff --git a/debian/patches/fixes/getopt-long-4.diff b/debian/patches/fixes/getopt-long-4.diff new file mode 100644 index 0000000..eaf70e7 --- /dev/null +++ b/debian/patches/fixes/getopt-long-4.diff @@ -0,0 +1,30 @@ +From d798073206bb15c1e83f6f3c84a531c9e1292eb4 Mon Sep 17 00:00:00 2001 +From: Johan Vromans <jvrom...@squirrel.nl> +Date: Tue, 13 Jun 2017 13:26:00 +0200 +Subject: Fix issue #122068. + +Origin: backport, https://github.com/sciurius/perl-Getopt-Long/commit/2d16f355e25537aa742eb2833a7d52a63051429b +Bug: https://rt.cpan.org/Ticket/Display.html?id=122068 +Bug-Debian: https://bugs.debian.org/864544 +Patch-Name: fixes/getopt-long-4.diff +--- + cpan/Getopt-Long/lib/Getopt/Long.pm | 6 ++++++ + 1 file changed, 6 insertions(+) + +diff --git a/cpan/Getopt-Long/lib/Getopt/Long.pm b/cpan/Getopt-Long/lib/Getopt/Long.pm +index 9992578..e71fee8 100644 +--- a/cpan/Getopt-Long/lib/Getopt/Long.pm ++++ b/cpan/Getopt-Long/lib/Getopt/Long.pm +@@ -1121,6 +1121,12 @@ sub FindOption ($$$$$) { + $optargtype = 3; + } + if(($optargtype == 0) && !$mand) { ++ if ( $type eq 'I' ) { ++ # Fake incremental type. ++ my @c = @$ctl; ++ $c[CTL_TYPE] = '+'; ++ return (1, $opt, \@c, 1); ++ } + my $val + = defined($ctl->[CTL_DEFAULT]) ? $ctl->[CTL_DEFAULT] + : $type eq 's' ? '' diff --git a/debian/patches/series b/debian/patches/series index 1371a69..06798ee 100644 --- a/debian/patches/series +++ b/debian/patches/series @@ -65,3 +65,9 @@ fixes/perlfunc_inc_doc.diff fixes/file_path_chmod_race.diff fixes/extutils_file_path_compat.diff debian/customized.diff +fixes/getopt-long-1.diff +fixes/getopt-long-2.diff +fixes/getopt-long-3.diff +fixes/getopt-long-4.diff +fixes/fbm-instr-crash.diff +debian/CVE-2016-1238/base-pm-amends-pt2.diff diff --git a/dist/base/lib/base.pm b/dist/base/lib/base.pm index 6fee600..044d138 100644 --- a/dist/base/lib/base.pm +++ b/dist/base/lib/base.pm @@ -6,6 +6,11 @@ use vars qw($VERSION); $VERSION = '2.23'; $VERSION =~ tr/_//d; +# simplest way to avoid indexing of the package: no package statement +sub base::__inc::unhook { @INC = grep !(ref eq 'CODE' && $_ == $_[0]), @INC } +# instance is blessed array of coderefs to be removed from @INC at scope exit +sub base::__inc::scope_guard::DESTROY { base::__inc::unhook $_ for @{$_[0]} } + # constant.pm is slow sub SUCCESS () { 1 } @@ -91,13 +96,59 @@ sub import { next if grep $_->isa($base), ($inheritor, @bases); - # Following blocks help isolate $SIG{__DIE__} changes + # Following blocks help isolate $SIG{__DIE__} and @INC changes { my $sigdie; { local $SIG{__DIE__}; my $fn = _module_to_filename($base); - eval { require $fn }; + my $dot_hidden; + eval { + my $guard; + if ($INC[-1] eq '.' && %{"$base\::"}) { + # So: the package already exists => this an optional load + # And: there is a dot at the end of @INC => we want to hide it + # However: we only want to hide it during our *own* require() + # (i.e. without affecting nested require()s). + # So we add a hook to @INC whose job is to hide the dot, but which + # first checks checks the callstack depth, because within nested + # require()s the callstack is deeper. + # Since CORE::GLOBAL::require makes it unknowable in advance what + # the exact relevant callstack depth will be, we have to record it + # inside a hook. So we put another hook just for that at the front + # of @INC, where it's guaranteed to run -- immediately. + # The dot-hiding hook does its job by sitting directly in front of + # the dot and removing itself from @INC when reached. This causes + # the dot to move up one index in @INC, causing the loop inside + # pp_require() to skip it. + # Loaded coded may disturb this precise arrangement, but that's OK + # because the hook is inert by that time. It is only active during + # the top-level require(), when @INC is in our control. The only + # possible gotcha is if other hooks already in @INC modify @INC in + # some way during that initial require(). + # Note that this jiggery hookery works just fine recursively: if + # a module loaded via base.pm uses base.pm itself, there will be + # one pair of hooks in @INC per base::import call frame, but the + # pairs from different nestings do not interfere with each other. + my $lvl; + unshift @INC, sub { return if defined $lvl; 1 while defined caller ++$lvl; () }; + splice @INC, -1, 0, sub { return if defined caller $lvl; ++$dot_hidden, &base::__inc::unhook; () }; + $guard = bless [ @INC[0,-2] ], 'base::__inc::scope_guard'; + } + require $fn + }; + if ($dot_hidden && (my @fn = grep -e && !( -d _ || -b _ ), $fn.'c', $fn)) { + require Carp; + Carp::croak(<<ERROR); +Base class package "$base" is not empty but "$fn[0]" exists in the current directory. + To help avoid security issues, base.pm now refuses to load optional modules + from the current working directory when it is the last entry in \@INC. + If your software worked on previous versions of Perl, the best solution + is to use FindBin to detect the path properly and to add that path to + \@INC. As a last resort, you can re-enable looking in the current working + directory by adding "use lib '.'" to your code. +ERROR + } # Only ignore "Can't locate" errors from our eval require. # Other fatal errors (syntax etc) must be reported. # diff --git a/dist/base/t/incdot.t b/dist/base/t/incdot.t new file mode 100644 index 0000000..412b2fe --- /dev/null +++ b/dist/base/t/incdot.t @@ -0,0 +1,55 @@ +#!/usr/bin/perl -w + +use strict; + +####################################################################### + +sub array_diff { + my ( $got, $expected ) = @_; + push @$got, ( '(missing)' ) x ( @$expected - @$got ) if @$got < @$expected; + push @$expected, ( '(should not exist)' ) x ( @$got - @$expected ) if @$got > @$expected; + join "\n ", ' All differences:', ( + map +( "got [$_] " . $got->[$_], 'expected'.(' ' x length).$expected->[$_] ), + grep $got->[$_] ne $expected->[$_], + 0 .. $#$got + ); +} + +####################################################################### + +use Test::More tests => 8; # some extra tests in t/lib/BaseInc* + +use lib 't/lib', sub {()}; + +# make it look like an older perl +BEGIN { push @INC, '.' if $INC[-1] ne '.' } + +BEGIN { + my $x = sub { CORE::require $_[0] }; + my $y = sub { &$x }; + my $z = sub { &$y }; + *CORE::GLOBAL::require = $z; +} + +my @expected; BEGIN { @expected = @INC } + +use base 'BaseIncMandatory'; + +BEGIN { + @t::lib::Dummy::ISA = (); # make it look like an optional load + my $success = eval q{use base 't::lib::Dummy'}, my $err = $@; + ok !$success, 'loading optional modules from . using base.pm fails'; + is_deeply \@INC, \@expected, '... without changes to @INC' + or diag array_diff [@INC], [@expected]; + like $err, qr!Base class package "t::lib::Dummy" is not empty but "t/lib/Dummy\.pm" exists in the current directory\.!, + '... and the proper error message'; +} + +BEGIN { @BaseIncOptional::ISA = () } # make it look like an optional load +use base 'BaseIncOptional'; + +BEGIN { + @expected = ( 't/lib/on-head', @expected, 't/lib/on-tail' ); + is_deeply \@INC, \@expected, 'modules loaded by base can extend @INC at both ends' + or diag array_diff [@INC], [@expected]; +} diff --git a/dist/base/t/lib/BaseIncMandatory.pm b/dist/base/t/lib/BaseIncMandatory.pm new file mode 100644 index 0000000..9e0718c --- /dev/null +++ b/dist/base/t/lib/BaseIncMandatory.pm @@ -0,0 +1,9 @@ +package BaseIncMandatory; + +BEGIN { package main; + is $INC[-1], '.', 'trailing dot remains in @INC during mandatory module load from base'; + ok eval('require t::lib::Dummy'), '... and modules load fine from .' or diag "$@"; + delete $INC{'t/lib/Dummy.pm'}; +} + +1; diff --git a/dist/base/t/lib/BaseIncOptional.pm b/dist/base/t/lib/BaseIncOptional.pm new file mode 100644 index 0000000..e5bf017 --- /dev/null +++ b/dist/base/t/lib/BaseIncOptional.pm @@ -0,0 +1,13 @@ +package BaseIncOptional; + +BEGIN { package main; + is $INC[-1], '.', 'trailing dot remains in @INC during optional module load from base'; + ok eval('require t::lib::Dummy'), '... and modules load fine from .' or diag "$@"; + delete $INC{'t/lib/Dummy.pm'}; +} + +use lib 't/lib/on-head'; + +push @INC, 't/lib/on-tail'; + +1; diff --git a/regexec.c b/regexec.c index cdaa95c..4cea7d2 100644 --- a/regexec.c +++ b/regexec.c @@ -127,13 +127,16 @@ static const char* const non_utf8_target_but_utf8_required (U8*)(off >= 0 ? reginfo->strend : reginfo->strbeg)) \ : (U8*)(pos + off)) -#define HOPBACKc(pos, off) \ - (char*)(reginfo->is_utf8_target \ - ? reghopmaybe3((U8*)pos, (SSize_t)0-off, (U8*)(reginfo->strbeg)) \ - : (pos - off >= reginfo->strbeg) \ - ? (U8*)pos - off \ +/* like HOPMAYBE3 but backwards. lim must be +ve. Returns NULL on overshoot */ +#define HOPBACK3(pos, off, lim) \ + (reginfo->is_utf8_target \ + ? reghopmaybe3((U8*)pos, (SSize_t)0-off, (U8*)(lim)) \ + : (pos - off >= lim) \ + ? (U8*)pos - off \ : NULL) +#define HOPBACKc(pos, off) ((char*)HOPBACK3(pos, off, reginfo->strbeg)) + #define HOP3(pos,off,lim) (reginfo->is_utf8_target ? reghop3((U8*)(pos), off, (U8*)(lim)) : (U8*)(pos + off)) #define HOP3c(pos,off,lim) ((char*)HOP3(pos,off,lim)) @@ -870,7 +873,9 @@ Perl_re_intuit_start(pTHX_ (IV)prog->check_end_shift); }); - end_point = HOP3(strend, -end_shift, strbeg); + end_point = HOPBACK3(strend, end_shift, rx_origin); + if (!end_point) + goto fail_finish; start_point = HOPMAYBE3(rx_origin, start_shift, end_point); if (!start_point) goto fail_finish; diff --git a/t/re/pat.t b/t/re/pat.t index 8652bf6..f32e529 100644 --- a/t/re/pat.t +++ b/t/re/pat.t @@ -23,7 +23,7 @@ BEGIN { skip_all_without_unicode_tables(); } -plan tests => 789; # Update this when adding/deleting tests. +plan tests => 790; # Update this when adding/deleting tests. run_tests() unless caller; @@ -1758,6 +1758,17 @@ EOP fresh_perl_is($code, $expect, {}, "$bug - $test_name" ); } } + + { + # RT #131575 intuit skipping back from the end to find the highest + # possible start point, was potentially hopping back beyond pos() + # and crashing by calling fbm_instr with a negative length + + my $text = "=t=\x{5000}"; + pos($text) = 3; + ok(scalar($text !~ m{(~*=[a-z]=)}g), "RT #131575"); + } + } # End of sub run_tests 1; diff --git a/util.c b/util.c index 89c44e7..f131504 100644 --- a/util.c +++ b/util.c @@ -806,6 +806,8 @@ Perl_fbm_instr(pTHX_ unsigned char *big, unsigned char *bigend, SV *littlestr, U PERL_ARGS_ASSERT_FBM_INSTR; + assert(bigend >= big); + if ((STRLEN)(bigend - big) < littlelen) { if ( SvTAIL(littlestr) && ((STRLEN)(bigend - big) == littlelen - 1)