package Devel::PatchPerl::Plugin::Asan;
use base 'Devel::PatchPerl';
=head1 DESCRIPTION
Plugin for Devel::PatchPerl to fix several buffer overflows and use-after-free
bugs in production perls which prevent compilations with C<clang AddressSanitizer>,
aka I<asan>.
Note that F<buildperl.pl> from L<Devel::PPPerl> and L<Devel::PatchPerl> do
not provide such security patches, only configure and make patches.
Most fixes have very low security impact. No known exploits do exist.
You need to run C<perlall build --allpatches> or C<perlall build --patches=Asan>
to apply these.
=head1 PATCHES
The list is complete for non-threaded perls.
For threaded perls some more patches need to be added.
5.8.2-5.16.2: CVE-2013-1667 prevent hsplit DOS attacks
5.10-5.15.9: RT#111586 sdbm.c off-by-one access to global .dir
5.12-5.16.0: RT#72700 List::Util boot Fix off-by-two on string literal length
5.15.4-9, 5.17.0-6: RT#115702 overlapping memcpy in to_utf8_case
5.6-5.16.0: RT#111594 Socket::unpack_sockaddr_un heap-buffer-overflow
5.8-5.14.3: RT#115992 PL_eval_start use-after-free
5.10-5.14.3: RT#115994 S_join_exact global-buffer-overflow
5.17.7-8: RT#82119 Socket::inet_ntop heap-buffer-overflow
5.14.0-3: RT#91678 S_anonymise_cv_maybe UTF8 cleanup
5.17,18.0,19 RT#118525 Return B::HEK for B::CV::GV of lexical subs
=head2 Devel::PatchPerl::Plugin::Asan::patchperl($class, {version,source,patchexe})
Apply patches in Devel::PatchPerl::Plugin::Asan depending on the
perl version. See L<Devel::PatchPerl::Plugin>.
Every patch is recorded in patchlevel.h, visible in myconfig.
If a patch fails the script dies.
=cut
sub patchperl {
my $class = shift;
my %args = @_;
my ($vers, $source, $patch_exe) = @args{qw(version source patchexe)};
for my $p ( grep { Devel::PatchPerl::_is( $_->{perl}, $vers ) } @Devel::PatchPerl::patch ) {
for my $s (@{$p->{subs}}) {
my ($sub, @args) = @$s;
push @args, $vers unless scalar @args;
$sub->(@args);
}
}
}
package
Devel::PatchPerl;
use File::Copy;
use vars '@patch';
@patch = (
{
perl => [ qr/^5\.1[01]\.\d$/ ],
# fixed in 5.16.0
subs => [ [ \&_patch_sdbm] ],
},
{
perl => [ qr/^5\.12\.[0-5]$/,
qr/^5\.1[35]\.\d$/,
qr/^5\.14\.[0-3]$/,
],
subs => [ [ \&_patch_listutil_boot ], [ \&_patch_sdbm] ],
},
{
perl => [ qr/^5\.16\.0$/ ],
# fixed in 5.16.1
subs => [ [ \&_patch_listutil_boot ] ],
},
{
perl => [ qr/^5\.15\.[4-9]$/,
qr/^5\.17\.[0-6]$/ ],
# fixed in 5.17.6
subs => [ [ \&_patch_to_utf8_case_memcpy ] ],
},
{
perl => [ qr/^5\.[6-9].\d$/,
qr/^5\.1[0-5].\d$/,
qr/^5\.16\.0$/ ],
# fixed in 5.16.1
subs => [ [ \&_patch_socket_un ] ],
},
{
perl => [ qr/^5\.1[0123]\.\d$/,
qr/^5\.15\.[012]$/, # fixed in 5.15.3
qr/^5\.14\.[0123]$/ ], # to be fixed in 5.14.4
subs => [ [ \&_patch_eval_start_510] ],
},
{
perl => [ qr/^5\.8\.\d$/ ],
subs => [ [ \&_patch_eval_start_58] ],
},
{
perl => [ qr/^5\.1[0123]\.\d$/, # broken since 5.10 (at least)
qr/^5\.15\.0$/, # fixed in 5.15.1
qr/^5\.14\.[0123]$/ ], # to be fixed in 5.14.4
subs => [ [ \&_patch_join_exact] ],
},
{
perl => [ qr/^5\.17\.[78]$/ ],
# broken in 5.17.8, 2.006-2.007
subs => [ [ \&_patch_socket_inet_ntop ] ],
},
{
perl => [ qr/^5\.14\.[0123]$/,
qr/^5\.15\.[012]$/ ],
# regression in 5.14, fixed in v5.15.3-232-g1bac5ec
subs => [ [ \&_patch_anonymise_cv_maybe ] ],
},
{
perl => [
qr/^5\.16\.[012]$/, # fixed in 5.16.3
qr/^5\.14\.[0123]$/, # fixed in 5.14.4
qr/^5\.1[01235]\./, # TODO fixes not backported
qr/^5\.8[23456789]\./, # TODO
],
# d59e31fc729d8a39a774f03bc6bc457029a7aef2 CVE-2013-1667
subs => [ [ \&_patch_hsplit_rehash ] ],
},
{
perl => [
qr/^5\.16\.[012]$/, # fixed in 5.16.3
qr/^5\.14\.[0123]$/, # fixed in 5.14.4
qr/^5\.1[01235]\./, #
],
subs => [ [ \&_patch_regcomp_nothing ] ],
},
#{
# perl => [
# qr/^5\.1[789]/, # RT #118525
# ],
# subs => [ [ \&_patch_cvgv_lexsub ] ],
#},
);
sub _add_patchlevel {
my $vers = shift;
my $line = shift;
my $success;
File::Copy::cp("patchlevel.h", "patchlevel.h.orig");
open my $in, "<", "patchlevel.h.orig" or return;
open my $out, ">", "patchlevel.h" or return;
$line =~ s/"/\"/g;
my $qr = $] > 5.010 ? /^\s+PERL_GIT_UNPUSHED_COMMITS/
: /^\tNULL$/;
while (my $s = <$in>) {
print $out $s;
if ($s =~ $qr) {
$success++;
print $out "\t,\"".$line."\"\n";
}
}
close $in;
close $out;
print STDERR "patched: $line\n";
return $success;
}
sub _patch_listutil_boot
{
# RT#72700 Fix off-by-two on string literal length
_patch(<<'END');
--- cpan/List-Util/ListUtil.xs.orig 2012-11-12 10:41:07.000000000 -0600
+++ cpan/List-Util/ListUtil.xs 2012-11-12 10:47:52.943198199 -0600
@@ -600,7 +600,7 @@
varav = GvAVn(vargv);
#endif
if (SvTYPE(rmcgv) != SVt_PVGV)
- gv_init(rmcgv, lu_stash, "List::Util", 12, TRUE);
+ gv_init(rmcgv, lu_stash, "List::Util", 10, TRUE);
rmcsv = GvSVn(rmcgv);
#ifndef SvWEAKREF
av_push(varav, newSVpv("weaken",6));
END
_add_patchlevel(@_, "RT#72700 List::Util boot Fix off-by-two on string literal length");
}
sub _patch_sdbm
{
# acdbe25bd91bf897e0cf373b9
# RT#111586 sdbm.c off-by-one access to global .dir
_patch(<<'END');
--- ext/SDBM_File/sdbm/sdbm.c.orig 2012-11-12 10:53:26.000000000 -0600
+++ ext/SDBM_File/sdbm/sdbm.c 2012-11-12 10:56:02.790350262 -0600
@@ -78,8 +78,8 @@ sdbm_open(register char *file, register int flags, register int mode)
register char *dirname;
register char *pagname;
size_t filelen;
- const size_t dirfext_len = sizeof(DIRFEXT "");
- const size_t pagfext_len = sizeof(PAGFEXT "");
+ const size_t dirfext_size = sizeof(DIRFEXT "");
+ const size_t pagfext_size = sizeof(PAGFEXT "");
if (file == NULL || !*file)
return errno = EINVAL, (DBM *) NULL;
@@ -88,17 +88,17 @@ sdbm_open(register char *file, register int flags, register int mode)
*/
filelen = strlen(file);
- if ((dirname = (char *) malloc(filelen + dirfext_len + 1
- + filelen + pagfext_len + 1)) == NULL)
+ if ((dirname = (char *) malloc(filelen + dirfext_size
+ + filelen + pagfext_size)) == NULL)
return errno = ENOMEM, (DBM *) NULL;
/*
* build the file names
*/
memcpy(dirname, file, filelen);
- memcpy(dirname + filelen, DIRFEXT, dirfext_len + 1);
- pagname = dirname + filelen + dirfext_len + 1;
+ memcpy(dirname + filelen, DIRFEXT, dirfext_size);
+ pagname = dirname + filelen + dirfext_size;
memcpy(pagname, file, filelen);
- memcpy(pagname + filelen, PAGFEXT, pagfext_len + 1);
+ memcpy(pagname + filelen, PAGFEXT, pagfext_size);
db = sdbm_prep(dirname, pagname, flags, mode);
free((char *) dirname);
END
_add_patchlevel(@_, "RT#111586 sdbm.c off-by-one access to global .dir");
}
sub _patch_to_utf8_case_memcpy
{
_patch(<<'END');
--- utf8.c~
+++ utf8.c
@@ -2366,7 +2366,9 @@ Perl_to_utf8_case(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp,
/* Here, there was no mapping defined, which means that the code point maps
* to itself. Return the inputs */
len = UTF8SKIP(p);
- Copy(p, ustrp, len, U8);
+ if (p != ustrp) { /* RT#115702 Don't copy onto itself */
+ Copy(p, ustrp, len, U8);
+ }
if (lenp)
*lenp = len;
END
_add_patchlevel(@_, "RT#115702 overlapping memcpy in to_utf8_case");
}
sub _patch_socket_un
{
my $vers = shift;
my $patch = <<'END';
commit e5086424505dcbfc5e26aeb984b769ecf5ffed01
Author: David Mitchell <davem@iabyn.com>
Date: Sun Feb 24 16:46:19 2013 +0000
On Linux sockaddrlen on sockets returned by accept, recvfrom,
getpeername and getsockname is not equal to sizeof(addr).
A (fairly harmless) read buffer overflow can occur when copying sockaddr
buffers on linux. Cherry-pick the fix from Socket 2.009 to keep ASAN happy.
--- ext/Socket/Socket.xs~
+++ ext/Socket/Socket.xs
@@ -565,10 +565,16 @@ unpack_sockaddr_un(sun_sv)
"Socket::unpack_sockaddr_un",
sockaddrlen, sizeof(addr));
}
+# else
+ if (sockaddrlen < sizeof(addr)) { /* RT #111594 */
+ Copy(sun_ad, &addr, sockaddrlen, char);
+ Zero(((char*)&addr) + sockaddrlen, sizeof(addr) - sockaddrlen, char);
+ }
+ else {
+ Copy(sun_ad, &addr, sizeof(addr), char);
+ }
# endif
- Copy( sun_ad, &addr, sizeof addr, char );
-
if ( addr.sun_family != AF_UNIX ) {
croak("Bad address family for %s, got %d, should be %d",
"Socket::unpack_sockaddr_un",
END
#; )
if ($vers =~ /^5\.6\./) {
$patch =~ s/@@ -565,10 +565,16 @@/@@ -1016,10 +1016,16 @@/;
}
if ($vers =~ /^5\.[89]\./ or $vers =~ /^5\.1[0-2]\./) {
$patch =~ s/@@ -565,10 +565,16 @@/@@ -363,10 +363,16 @@/;
}
if ($vers =~ /^5\.16\./ or $vers =~ /^5\.15\.[5-9]\./) {
$patch =~ s|ext/Socket/Socket.xs|cpan/Socket/Socket.xs|g;
}
_patch($patch);
_add_patchlevel($vers, "RT#111594 Socket::unpack_sockaddr_un heap-buffer-overflow");
}
sub _patch_eval_start_510
{
_patch(<<'END');
--- pp_ctl.c~
+++ pp_ctl.c
@@ -3088,6 +3088,7 @@ Perl_sv_compile_2op_is_broken(pTHX_ SV *sv, OP **startop, const char *code,
CV* runcv = NULL; /* initialise to avoid compiler warnings */
STRLEN len;
bool need_catch;
+ OP* ret;
PERL_ARGS_ASSERT_SV_COMPILE_2OP_IS_BROKEN;
@@ -3182,7 +3183,9 @@ Perl_sv_compile_2op_is_broken(pTHX_ SV *sv, OP **startop, const char *code,
PERL_UNUSED_VAR(newsp);
PERL_UNUSED_VAR(optype);
- return PL_eval_start;
+ ret = PL_eval_start;
+ PL_eval_start = NULL;
+ return ret;
}
@@ -3903,8 +3906,10 @@ PP(pp_require)
encoding = PL_encoding;
PL_encoding = NULL;
- if (doeval(gimme, NULL, NULL, PL_curcop->cop_seq))
+ if (doeval(gimme, NULL, NULL, PL_curcop->cop_seq)) {
op = DOCATCH(PL_eval_start);
+ PL_eval_start = NULL;
+ }
else
op = PL_op->op_next;
@@ -4029,6 +4034,7 @@ PP(pp_entereval)
PUTBACK;
if (doeval(gimme, NULL, runcv, seq)) {
+ OP *ret;
if (was != PL_breakable_sub_gen /* Some subs defined here. */
? (PERLDB_LINE || PERLDB_SAVESRC)
: PERLDB_SAVESRC_NOSUBS) {
@@ -4037,7 +4043,9 @@ PP(pp_entereval)
char *const safestr = savepvn(tmpbuf, len);
SAVEDELETE(PL_defstash, safestr, len);
}
- return DOCATCH(PL_eval_start);
+ ret = DOCATCH(PL_eval_start);
+ PL_eval_start = NULL;
+ return ret;
} else {
/* We have already left the scope set up earlier thanks to the LEAVE
in doeval(). */
END
_add_patchlevel(@_, "RT#115992 PL_eval_start use-after-free");
}
sub _patch_eval_start_58
{
_patch(<<'END');
diff -bu ./pp_ctl.c~ ./pp_ctl.c
--- ./pp_ctl.c~ 2013-03-04 18:45:25.823223519 -0600
+++ ./pp_ctl.c 2013-03-04 18:52:26.691549451 -0600
@@ -2839,7 +2839,7 @@ STATIC OP *
S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
{
dSP;
- OP * const saveop = PL_op;
+ OP * saveop = PL_op;
PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
@@ -2985,7 +2985,9 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
MUTEX_UNLOCK(&PL_eval_mutex);
#endif /* USE_5005THREADS */
- RETURNOP(PL_eval_start);
+ saveop = PL_eval_start;
+ PL_eval_start = NULL;
+ RETURNOP(saveop);
}
STATIC PerlIO *
@@ -3426,7 +3428,12 @@ PP(pp_require)
encoding = PL_encoding;
PL_encoding = Nullsv;
- op = DOCATCH(doeval(gimme, NULL, Nullcv, PL_curcop->cop_seq));
+ if (doeval(gimme, NULL, Nullcv, PL_curcop->cop_seq)) {
+ op = DOCATCH(PL_eval_start);
+ PL_eval_start = NULL;
+ }
+ else
+ op = PL_op->op_next;
/* Restore encoding. */
PL_encoding = encoding;
END
_add_patchlevel(@_, "RT#115992 PL_eval_start use-after-free");
}
sub _patch_join_exact
{
# commit bb789b09de07edfb74477eb1603949c96d60927d
# Author: David Mitchell <davem@iabyn.com>
# AuthorDate: Tue Jul 5 11:35:08 2011 +0100
#
# fix segv in regcomp.c:S_join_exact()
#
# This function joins multiple EXACT* nodes into a single node.
# At the end, under DEBUGGING, it marks the optimised-out nodes as being
# type OPTIMIZED. However, some of the 'nodes' aren't actually nodes;
# they're random bits of string at the tail of those nodes. So you
# can't peek that the 'node's OP field to decide what type it was.
#
# Instead, just unconditionally overwrite all the slots with fake
# OPTIMIZED nodes.
_patch(<<'END');
--- regcomp.c~
+++ regcomp.c
@@ -2647,13 +2647,17 @@ S_join_exact(pTHX_ RExC_state_t *pRExC_state, regnode *scan, I32 *min, U32 flags
}
#ifdef DEBUGGING
- /* Allow dumping */
+ /* Allow dumping but overwriting the collection of skipped
+ * ops and/or strings with fake optimized ops */
n = scan + NODE_SZ_STR(scan);
while (n <= stop) {
- if (PL_regkind[OP(n)] != NOTHING || OP(n) == NOTHING) {
- OP(n) = OPTIMIZED;
- NEXT_OFF(n) = 0;
- }
+ OP(n) = OPTIMIZED;
+#ifdef FLAGS
+ FLAGS(n) = 0;
+#else
+ n->flags = 0;
+#endif
+ NEXT_OFF(n) = 0;
n++;
}
#endif
END
_add_patchlevel(@_, "RT#115994 S_join_exact global-buffer-overflow");
}
sub _patch_socket_inet_ntop
{
my $vers = shift;
my $patch = <<'END';
--- cpan/Socket/Socket.xs~
+++ cpan/Socket/Socket.xs
@@ -934,8 +934,13 @@ inet_ntop(af, ip_address_sv)
#endif
"Socket::inet_ntop", af);
}
-
- Copy(ip_address, &addr, sizeof addr, char);
+ if (addrlen < sizeof(addr)) {
+ Copy(ip_address, &addr, addrlen, char);
+ Zero(((char*)&addr)+addrlen, sizeof(addr) - addrlen, char);
+ }
+ else {
+ Copy(ip_address, &addr, sizeof addr, char);
+ }
inet_ntop(af, &addr, str, sizeof str);
ST(0) = sv_2mortal(newSVpvn(str, strlen(str)));
END
#; )
_patch($patch);
_add_patchlevel($vers, "RT#82119 Socket::inet_ntop heap-buffer-overflow");
}
sub _patch_anonymise_cv_maybe
{
my $vers = shift;
my $patch = <<'END';
commit 1bac5ecc108e6bb05752e5aef66c6890163aff39
Author: Brian Fraser <fraserbn@gmail.com>
Date: Mon Sep 26 13:48:52 2011 -0700
sv.c: S_anonymise_cv_maybe UTF8 cleanup.
diff --git a/sv.c b/sv.c
index d71f901..a3a2c74 100644
--- sv.c.orig
+++ sv.c
@@ -5893,7 +5893,6 @@ Perl_sv_replace(pTHX_ register SV *const sv, register SV *const nsv)
STATIC void
S_anonymise_cv_maybe(pTHX_ GV *gv, CV* cv)
{
- char *stash;
SV *gvname;
GV *anongv;
@@ -5913,10 +5912,10 @@ S_anonymise_cv_maybe(pTHX_ GV *gv, CV* cv)
}
/* if not, anonymise: */
- stash = GvSTASH(gv) && HvNAME(GvSTASH(gv))
- ? HvENAME(GvSTASH(gv)) : NULL;
- gvname = Perl_newSVpvf(aTHX_ "%s::__ANON__",
- stash ? stash : "__ANON__");
+ gvname = (GvSTASH(gv) && HvNAME(GvSTASH(gv)) && HvENAME(GvSTASH(gv)))
+ ? newSVhek(HvENAME_HEK(GvSTASH(gv)))
+ : newSVpvn_flags( "__ANON__", 8, 0 );
+ sv_catpvs(gvname, "::__ANON__");
anongv = gv_fetchsv(gvname, GV_ADDMULTI, SVt_PVCV);
SvREFCNT_dec(gvname);
END
#; )
_patch($patch);
_add_patchlevel($vers, "RT#91678 S_anonymise_cv_maybe UTF8 cleanup");
}
sub _patch_cvgv_lexsub
{
my $vers = shift;
my $patch = <<'END';
From 5e135b6d655cf605ed3d659b94eef847e7d5d29c Mon Sep 17 00:00:00 2001
From: Reini Urban <rurban@x-ray.at>
Date: Thu, 11 Jul 2013 12:09:15 -0500
Subject: [PATCH] [perl #118525] Return B::HEK for B::CV::GV of lexical subs
A lexsub has a hek instead of a gv.
Provide a ref to a PV for the name in the new B::HEK class.
This crashed previously accessing the not existing SvFLAGS of the hek.
---
ext/B/B.pm | 27 ++++++++++++++++++++++++++-
ext/B/B.xs | 42 +++++++++++++++++++++++++++++++++++++++++-
ext/B/typemap | 12 ++++++++++++
3 files changed, 79 insertions(+), 2 deletions(-)
diff ext/B/B.pm~ ext/B/B.pm
index 8b13dea..c153899 100644
--- ext/B/B.pm~
+++ ext/B/B.pm
@@ -1265,6 +1267,29 @@ rather than a list of all of them.
=back
+=head2 B::HEK Methods
+
+A B::HEK is returned by B::CV->GV for a lexical sub, defining its name.
+Using the dereferenced scalar value of the object returns the string value,
+which is usually enough; the other methods are rarely needed.
+
+ use B;
+ use feature 'lexical_subs';
+ my sub p {1};
+ $cv = B::svref_2object(\&p);
+ $hek = $cv->GV;
+ print $$hek, "==", $hek->KEY;
+
+=over 4
+
+=item KEY
+
+=item LEN
+
+=item FLAGS
+
+=back
+
=head2 $B::overlay
Although the optree is read-only, there is an overlay facility that allows
diff ext/B/B.xs~ ext/B/B.xs
index fbe6be6..444d2fe 100644
--- ext/B/B.xs~
+++ ext/B/B.xs
@@ -296,6 +296,17 @@ make_sv_object(pTHX_ SV *sv)
}
static SV *
+make_hek_object(pTHX_ HEK *hek)
+{
+ SV *ret = sv_setref_pvn(sv_newmortal(), "B::HEK", HEK_KEY(hek), HEK_LEN(hek));
+ SV *rv = SvRV(ret);
+ SvIOKp_on(rv);
+ SvIV_set(rv, PTR2IV(hek));
+ SvREADONLY_on(rv);
+ return ret;
+}
+
+static SV *
make_temp_object(pTHX_ SV *temp)
{
SV *target;
@@ -602,6 +613,7 @@ typedef IO *B__IO;
typedef MAGIC *B__MAGIC;
typedef HE *B__HE;
+typedef HEK *B__HEK;
typedef struct refcounted_he *B__RHE;
#ifdef PadlistARRAY
typedef PADLIST *B__PADLIST;
@@ -1390,7 +1402,10 @@ IVX(sv)
ptr = (ix & 0xFFFF) + (char *)SvANY(sv);
switch ((U8)(ix >> 16)) {
case (U8)(sv_SVp >> 16):
- ret = make_sv_object(aTHX_ *((SV **)ptr));
+ if ((ix == (PVCV_gv_ix)) && CvNAMED(sv))
+ ret = make_hek_object(aTHX_ CvNAME_HEK((CV*)sv));
+ else
+ ret = make_sv_object(aTHX_ *((SV **)ptr));
break;
case (U8)(sv_IVp >> 16):
ret = sv_2mortal(newSViv(*((IV *)ptr)));
@@ -1588,6 +1603,31 @@ PV(sv)
}
ST(0) = newSVpvn_flags(p, len, SVs_TEMP | utf8);
+MODULE = B PACKAGE = B::HEK
+
+void
+KEY(hek)
+ B::HEK hek
+ ALIAS:
+ LEN = 1
+ FLAGS = 2
+ PPCODE:
+ SV *pv;
+ switch (ix) {
+ case 0:
+ pv = newSVpvn(HEK_KEY(hek), HEK_LEN(hek));
+ if (HEK_UTF8(hek)) SvUTF8_on(pv);
+ SvREADONLY_on(pv);
+ PUSHs(pv);
+ break;
+ case 1:
+ mPUSHu(HEK_LEN(hek));
+ break;
+ case 2:
+ mPUSHu(HEK_FLAGS(hek));
+ break;
+ }
+
MODULE = B PACKAGE = B::PVMG
void
diff ext/B/typemap~ ext/B/typemap
index e97fb76..88de4da 100644
--- ext/B/typemap~
+++ ext/B/typemap
@@ -35,6 +35,7 @@ PADOFFSET T_UV
B::HE T_HE_OBJ
B::RHE T_RHE_OBJ
+B::HEK T_HEK_OBJ
B::PADLIST T_PL_OBJ
@@ -79,6 +80,14 @@ T_RHE_OBJ
else
croak(\"$var is not a reference\")
+T_HEK_OBJ
+ if (SvROK($arg)) {
+ IV tmp = SvIV((SV*)SvRV($arg));
+ $var = INT2PTR($type,tmp);
+ }
+ else
+ croak(\"$var is not a reference\")
+
T_PL_OBJ
if (SvROK($arg)) {
IV tmp = SvIV((SV*)SvRV($arg));
@@ -94,6 +103,9 @@ T_MG_OBJ
T_HE_OBJ
sv_setiv(newSVrv($arg, "B::HE"), PTR2IV($var));
+T_HEK_OBJ
+ sv_setiv(newSVrv($arg, "B::HEK"), PTR2IV($var));
+
T_RHE_OBJ
sv_setiv(newSVrv($arg, "B::RHE"), PTR2IV($var));
--
1.7.10.4
END
#; )
_patch($patch);
_add_patchlevel($vers, "RT#118525 Return B::HEK for B::CV::GV of lexical subs");
}
sub _patch_hsplit_rehash
{
my $vers = shift;
my $patch = <<'END';
commit d59e31fc729d8a39a774f03bc6bc457029a7aef2
Author: Yves Orton <demerphq@gmail.com>
Date: Tue Feb 12 10:53:05 2013 +0100
Prevent premature hsplit() calls, and only trigger REHASH after hsplit()
Triggering a hsplit due to long chain length allows an attacker
to create a carefully chosen set of keys which can cause the hash
to use 2 * (2**32) * sizeof(void *) bytes ram. AKA a DOS via memory
exhaustion. Doing so also takes non trivial time.
Eliminating this check, and only inspecting chain length after a
normal hsplit() (triggered when keys>buckets) prevents the attack
entirely, and makes such attacks relatively benign.
(cherry picked from commit f1220d61455253b170e81427c9d0357831ca0fac)
diff --git a/ext/Hash-Util-FieldHash/t/10_hash.t b/ext/Hash-Util-FieldHash/t/10_hash.t
index 2cfb4e8..d58f053 100644
--- ext/Hash-Util-FieldHash/t/10_hash.t~
+++ ext/Hash-Util-FieldHash/t/10_hash.t
@@ -38,15 +38,29 @@ use constant START => "a";
# some initial hash data
fieldhash my %h2;
-%h2 = map {$_ => 1} 'a'..'cc';
+my $counter= "a";
+$h2{$counter++}++ while $counter ne 'cd';
ok (!Internals::HvREHASH(%h2),
"starting with pre-populated non-pathological hash (rehash flag if off)");
my @keys = get_keys(\%h2);
+my $buckets= buckets(\%h2);
$h2{$_}++ for @keys;
+$h2{$counter++}++ while buckets(\%h2) == $buckets; # force a split
ok (Internals::HvREHASH(%h2),
- scalar(@keys) . " colliding into the same bucket keys are triggering rehash");
+ scalar(@keys) . " colliding into the same bucket keys are triggering rehash after split");
+
+# returns the number of buckets in a hash
+sub buckets {
+ my $hr = shift;
+ my $keys_buckets= scalar(%$hr);
+ if ($keys_buckets=~m!/([0-9]+)\z!) {
+ return 0+$1;
+ } else {
+ return 8;
+ }
+}
sub get_keys {
my $hr = shift;
diff --git a/hv.c b/hv.c
index 2be1feb..abb9d76 100644
--- hv.c~
+++ hv.c
@@ -35,7 +35,8 @@ holds the key and hash value.
#define PERL_HASH_INTERNAL_ACCESS
#include "perl.h"
-#define HV_MAX_LENGTH_BEFORE_SPLIT 14
+#define HV_MAX_LENGTH_BEFORE_REHASH 14
+#define SHOULD_DO_HSPLIT(xhv) ((xhv)->xhv_keys > (xhv)->xhv_max) /* HvTOTALKEYS(hv) > HvMAX(hv) */
static const char S_strtab_error[]
= "Cannot modify shared string table in hv_%s";
@@ -794,29 +795,9 @@ Perl_hv_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen,
if (masked_flags & HVhek_ENABLEHVKFLAGS)
HvHASKFLAGS_on(hv);
- {
- const HE *counter = HeNEXT(entry);
-
- xhv->xhv_keys++; /* HvTOTALKEYS(hv)++ */
- if (!counter) { /* initial entry? */
- } else if (xhv->xhv_keys > xhv->xhv_max) {
- /* Use only the old HvKEYS(hv) > HvMAX(hv) condition to limit
- bucket splits on a rehashed hash, as we're not going to
- split it again, and if someone is lucky (evil) enough to
- get all the keys in one list they could exhaust our memory
- as we repeatedly double the number of buckets on every
- entry. Linear search feels a less worse thing to do. */
- hsplit(hv);
- } else if(!HvREHASH(hv)) {
- U32 n_links = 1;
-
- while ((counter = HeNEXT(counter)))
- n_links++;
-
- if (n_links > HV_MAX_LENGTH_BEFORE_SPLIT) {
- hsplit(hv);
- }
- }
+ xhv->xhv_keys++; /* HvTOTALKEYS(hv)++ */
+ if ( SHOULD_DO_HSPLIT(xhv) ) {
+ hsplit(hv);
}
if (return_svp) {
@@ -1192,7 +1173,7 @@ S_hsplit(pTHX_ HV *hv)
/* Pick your policy for "hashing isn't working" here: */
- if (longest_chain <= HV_MAX_LENGTH_BEFORE_SPLIT /* split worked? */
+ if (longest_chain <= HV_MAX_LENGTH_BEFORE_REHASH /* split worked? */
|| HvREHASH(hv)) {
return;
}
@@ -2831,8 +2812,8 @@ S_share_hek_flags(pTHX_ const char *str, I32 len, register U32 hash, int flags)
xhv->xhv_keys++; /* HvTOTALKEYS(hv)++ */
if (!next) { /* initial entry? */
- } else if (xhv->xhv_keys > xhv->xhv_max /* HvKEYS(hv) > HvMAX(hv) */) {
- hsplit(PL_strtab);
+ } else if ( SHOULD_DO_HSPLIT(xhv) ) {
+ hsplit(PL_strtab);
}
}
diff --git a/t/op/hash.t b/t/op/hash.t
index 278bea7..201260a 100644
--- t/op/hash.t~
+++ t/op/hash.t
@@ -39,22 +39,36 @@ use constant THRESHOLD => 14;
use constant START => "a";
# some initial hash data
-my %h2 = map {$_ => 1} 'a'..'cc';
+my %h2;
+my $counter= "a";
+$h2{$counter++}++ while $counter ne 'cd';
ok (!Internals::HvREHASH(%h2),
"starting with pre-populated non-pathological hash (rehash flag if off)");
my @keys = get_keys(\%h2);
+my $buckets= buckets(\%h2);
$h2{$_}++ for @keys;
+$h2{$counter++}++ while buckets(\%h2) == $buckets; # force a split
ok (Internals::HvREHASH(%h2),
- scalar(@keys) . " colliding into the same bucket keys are triggering rehash");
+ scalar(@keys) . " colliding into the same bucket keys are triggering rehash after split");
+
+# returns the number of buckets in a hash
+sub buckets {
+ my $hr = shift;
+ my $keys_buckets= scalar(%$hr);
+ if ($keys_buckets=~m!/([0-9]+)\z!) {
+ return 0+$1;
+ } else {
+ return 8;
+ }
+}
sub get_keys {
my $hr = shift;
# the minimum of bits required to mount the attack on a hash
my $min_bits = log(THRESHOLD)/log(2);
-
# if the hash has already been populated with a significant amount
# of entries the number of mask bits can be higher
my $keys = scalar keys %$hr;
END
# "
if ($vers =~ /^5\.8\.[2345678]$/) {
$patch =~ s{diff --git a/ext/Hash-Util-FieldHash.+diff --git a/hv.c b/hv.c}
{diff --git a/hv.c b/hv.c}gm;
}
_patch($patch); #TODO 5.10, 5.12
_add_patchlevel($vers, "CVE-2013-1667 hsplit rehash");
}
1;