The official fix for the Perl sprintf buffer overflow.

ok millert@

11 files changed, 79 insertions, 23 deletions

diff --git a/gnu/usr.bin/perl/globvar.sym b/gnu/usr.bin/perl/globvar.sym
index 0d768889a85..5a3a6843f6d 100644
--- a/gnu/usr.bin/perl/globvar.sym
+++ b/gnu/usr.bin/perl/globvar.sym
@@ -66,3 +66,4 @@ vtbl_regdatum
 vtbl_collxfrm
 vtbl_amagic
 vtbl_amagicelem
+memory_wrap
diff --git a/gnu/usr.bin/perl/makedef.pl b/gnu/usr.bin/perl/makedef.pl
index 41dc98cfe4b..af8f81ec036 100644
--- a/gnu/usr.bin/perl/makedef.pl
+++ b/gnu/usr.bin/perl/makedef.pl
@@ -635,12 +635,6 @@ else {
 		    )];
 }
 
-if ($define{'PERL_MALLOC_WRAP'}) {
-    emit_symbols [qw(
-		    PL_memory_wrap
-		    )];
-}
-
 unless ($define{'USE_5005THREADS'} || $define{'USE_ITHREADS'}) {
     skip_symbols [qw(
 		    PL_thr_key
diff --git a/gnu/usr.bin/perl/op.c b/gnu/usr.bin/perl/op.c
index 1c6452ef0a0..d59ab1f177e 100644
--- a/gnu/usr.bin/perl/op.c
+++ b/gnu/usr.bin/perl/op.c
@@ -2064,7 +2064,6 @@ Perl_fold_constants(pTHX_ register OP *o)
 	/* XXX might want a ck_negate() for this */
 	cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
 	break;
-    case OP_SPRINTF:
     case OP_UCFIRST:
     case OP_LCFIRST:
     case OP_UC:
diff --git a/gnu/usr.bin/perl/opcode.h b/gnu/usr.bin/perl/opcode.h
index 6a7fc088918..168b39e2b58 100644
--- a/gnu/usr.bin/perl/opcode.h
+++ b/gnu/usr.bin/perl/opcode.h
@@ -1585,7 +1585,7 @@ EXT U32 PL_opargs[] = {
 	0x0022281c,	/* vec */
 	0x0122291c,	/* index */
 	0x0122291c,	/* rindex */
-	0x0004280f,	/* sprintf */
+	0x0004280d,	/* sprintf */
 	0x00042805,	/* formline */
 	0x0001379e,	/* ord */
 	0x0001378e,	/* chr */
diff --git a/gnu/usr.bin/perl/opcode.pl b/gnu/usr.bin/perl/opcode.pl
index d59ac0391e5..b9f76c3693f 100644
--- a/gnu/usr.bin/perl/opcode.pl
+++ b/gnu/usr.bin/perl/opcode.pl
@@ -602,7 +602,7 @@ vec		vec			ck_fun		ist@	S S S
 index		index			ck_index	isT@	S S S?
 rindex		rindex			ck_index	isT@	S S S?
 
-sprintf		sprintf			ck_fun		mfst@	S L
+sprintf		sprintf			ck_fun		mst@	S L
 formline	formline		ck_fun		ms@	S L
 ord		ord			ck_fun		ifsTu%	S?
 chr		chr			ck_fun		fsTu%	S?
diff --git a/gnu/usr.bin/perl/patchlevel.h b/gnu/usr.bin/perl/patchlevel.h
index dec0581c621..83bf774d886 100644
--- a/gnu/usr.bin/perl/patchlevel.h
+++ b/gnu/usr.bin/perl/patchlevel.h
@@ -121,6 +121,7 @@ hunk.
 static	char	*local_patches[] = {
 	NULL
 	,"SUIDPERLIO1 - fix PERLIO_DEBUG buffer overflow (CAN-2005-0156)"
+	,"SPRINTF0 - fixes for sprintf formatting issues - CVE-2005-3962"
 	,NULL
 };
 
diff --git a/gnu/usr.bin/perl/perl.h b/gnu/usr.bin/perl/perl.h
index f33d66e40f6..1b2304df9ba 100644
--- a/gnu/usr.bin/perl/perl.h
+++ b/gnu/usr.bin/perl/perl.h
@@ -3071,10 +3071,8 @@ EXTCONST char PL_no_myglob[]
   INIT("\"my\" variable %s can't be in a package");
 EXTCONST char PL_no_localize_ref[]
   INIT("Can't localize through a reference");
-#ifdef PERL_MALLOC_WRAP
 EXTCONST char PL_memory_wrap[]
   INIT("panic: memory wrap");
-#endif
 
 EXTCONST char PL_uuemap[65]
   INIT("`!\"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_");
diff --git a/gnu/usr.bin/perl/sv.c b/gnu/usr.bin/perl/sv.c
index 1a0da2525c3..d8a510854c1 100644
--- a/gnu/usr.bin/perl/sv.c
+++ b/gnu/usr.bin/perl/sv.c
@@ -8541,7 +8541,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
 	if (EXPECT_NUMBER(q, width)) {
 	    if (*q == '$') {
 		++q;
-		efix = width > PERL_INT_MAX ? PERL_INT_MAX : width;
+		efix = width;
 	    } else {
 		goto gotwidth;
 	    }
@@ -8606,9 +8606,12 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
 	    if (vectorarg) {
 		if (args)
 		    vecsv = va_arg(*args, SV*);
-		else
-		    vecsv = (evix ? evix <= svmax : svix < svmax) ?
-			svargs[evix ? evix-1 : svix++] : &PL_sv_undef;
+		else if (evix) {
+		    vecsv = (evix > 0 && evix <= svmax)
+			? svargs[evix-1] : &PL_sv_undef;
+		} else {
+		    vecsv = svix < svmax ? svargs[svix++] : &PL_sv_undef;
+		}
 		dotstr = SvPVx(vecsv, dotstrlen);
 		if (DO_UTF8(vecsv))
 		    is_utf8 = TRUE;
@@ -8618,12 +8621,13 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
 		vecstr = (U8*)SvPVx(vecsv,veclen);
 		vec_utf8 = DO_UTF8(vecsv);
 	    }
-	    else if (efix ? efix <= svmax : svix < svmax) {
+	    else if (efix ? (efix > 0 && efix <= svmax) : svix < svmax) {
 		vecsv = svargs[efix ? efix-1 : svix++];
 		vecstr = (U8*)SvPVx(vecsv,veclen);
 		vec_utf8 = DO_UTF8(vecsv);
 	    }
 	    else {
+		vecsv = &PL_sv_undef;
 		vecstr = (U8*)"";
 		veclen = 0;
 	    }
@@ -8724,9 +8728,15 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
 
 	if (vectorize)
 	    argsv = vecsv;
-	else if (!args)
-	    argsv = (efix ? efix <= svmax : svix < svmax) ?
-		    svargs[efix ? efix-1 : svix++] : &PL_sv_undef;
+	else if (!args) {
+	    if (efix) {
+		const I32 i = efix-1;
+		argsv = (i >= 0 && i < svmax) ? svargs[i] : &PL_sv_undef;
+	    } else {
+		argsv = (svix >= 0 && svix < svmax)
+		    ? svargs[svix++] : &PL_sv_undef;
+	    }
+	}
 
 	switch (c = *q++) {
 
@@ -8968,6 +8978,8 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
 		    *--eptr = '0';
 		break;
 	    case 2:
+		if (!uv)
+		    alt = FALSE;
 		do {
 		    dig = uv & 1;
 		    *--eptr = '0' + dig;
@@ -9270,6 +9282,8 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
 
 	/* calculate width before utf8_upgrade changes it */
 	have = esignlen + zeros + elen;
+	if (have < zeros)
+	    Perl_croak_nocontext(PL_memory_wrap);
 
 	if (is_utf8 != has_utf8) {
 	     if (is_utf8) {
@@ -9297,6 +9311,8 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
 	need = (have > width ? have : width);
 	gap = need - have;
 
+	if (need >= (((STRLEN)~0) - SvCUR(sv) - dotstrlen - 1))
+	    Perl_croak_nocontext(PL_memory_wrap);
 	SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1);
 	p = SvEND(sv);
 	if (esignlen && fill == '0') {
diff --git a/gnu/usr.bin/perl/t/lib/warnings/sv b/gnu/usr.bin/perl/t/lib/warnings/sv
index b38200d4c84..91398de3e83 100644
--- a/gnu/usr.bin/perl/t/lib/warnings/sv
+++ b/gnu/usr.bin/perl/t/lib/warnings/sv
@@ -301,12 +301,12 @@ $a = sprintf "%" ;
 printf F "%\x02" ;
 $a = sprintf "%\x02" ;
 EXPECT
-Invalid conversion in sprintf: "%z" at - line 5.
-Invalid conversion in sprintf: end of string at - line 7.
-Invalid conversion in sprintf: "%\002" at - line 9.
 Invalid conversion in printf: "%z" at - line 4.
+Invalid conversion in sprintf: "%z" at - line 5.
 Invalid conversion in printf: end of string at - line 6.
+Invalid conversion in sprintf: end of string at - line 7.
 Invalid conversion in printf: "%\002" at - line 8.
+Invalid conversion in sprintf: "%\002" at - line 9.
 ########
 # sv.c
 use warnings 'misc' ;
diff --git a/gnu/usr.bin/perl/t/op/sprintf.t b/gnu/usr.bin/perl/t/op/sprintf.t
index c854588ce23..91a8877111d 100644
--- a/gnu/usr.bin/perl/t/op/sprintf.t
+++ b/gnu/usr.bin/perl/t/op/sprintf.t
@@ -385,3 +385,8 @@ __END__
 >%4$K %d<	>[45, 67]<	>%4$K 45 INVALID<
 >%d %K %d<	>[23, 45]<	>23 %K 45 INVALID<
 >%*v*999\$d %d %d<	>[11, 22, 33]<	>%*v*999\$d 11 22 INVALID<
+>%#b<		>0<	>0<
+>%#o<		>0<	>0<
+>%#x<		>0<	>0<
+>%2918905856$v2d<	>''<	><
+>%*2918905856$v2d<	>''<	> UNINIT<
diff --git a/gnu/usr.bin/perl/t/op/sprintf2.t b/gnu/usr.bin/perl/t/op/sprintf2.t
index 669938b86bc..fc79707a0f7 100755
--- a/gnu/usr.bin/perl/t/op/sprintf2.t
+++ b/gnu/usr.bin/perl/t/op/sprintf2.t
@@ -6,7 +6,7 @@ BEGIN {
     require './test.pl';
 }   
 
-plan tests => 3;
+plan tests => 7 + 256;
 
 is(
     sprintf("%.40g ",0.01),
@@ -26,3 +26,45 @@ is(
 		q(width calculation under utf8 upgrade)
 	);
 }
+
+# Used to mangle PL_sv_undef
+fresh_perl_is(
+    'print sprintf "xxx%n\n"; print undef',
+    'Modification of a read-only value attempted at - line 1.',
+    { switches => [ '-w' ] },
+    q(%n should not be able to modify read-only constants),
+);
+
+# check %NNN$ for range bounds, especially negative 2's complement
+
+{
+    my ($warn, $bad) = (0,0);
+    local $SIG{__WARN__} = sub {
+	if ($_[0] =~ /uninitialized/) {
+	    $warn++
+	}
+	else {
+	    $bad++
+	}
+    };
+    my $result = sprintf join('', map("%$_\$s%" . ~$_ . '$s', 1..20)),
+	qw(a b c d);
+    is($result, "abcd", "only four valid values");
+    is($warn, 36, "expected warnings");
+    is($bad,   0, "unexpected warnings");
+}
+
+{
+    foreach my $ord (0 .. 255) {
+	my $bad = 0;
+	local $SIG{__WARN__} = sub {
+	    unless ($_[0] =~ /^Invalid conversion in sprintf/ ||
+		    $_[0] =~ /^Use of uninitialized value in sprintf/) {
+		warn $_[0];
+		$bad++;
+	    }
+	};
+	my $r = eval {sprintf '%v' . chr $ord};
+	is ($bad, 0, "pattern '%v' . chr $ord");
+    }
+}