Bug#867490: stretch-pu: package perl/5.24.1-3+deb9u1
Dominic Hargreaves
dom at earth.li
Thu Jul 6 19:52:44 UTC 2017
Package: release.debian.org
Severity: normal
Tags: stretch
User: release.debian.org at 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.
-------------- next part --------------
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 <dom at 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 <pagaltzis at 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 <davem at 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 <ntyni at 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.dev at 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 <jvromans at 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.gregory.8 at 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 <jvromans at 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)
More information about the Perl-maintainers
mailing list