Change 33614 by [EMAIL PROTECTED] on 2008/03/31 16:59:07
Affected files ...
... //depot/maint-5.10/perl/av.c#3 integrate
... //depot/maint-5.10/perl/dump.c#6 integrate
... //depot/maint-5.10/perl/perl.c#7 integrate
... //depot/maint-5.10/perl/perlio.c#5 integrate
... //depot/maint-5.10/perl/pp_pack.c#4 integrate
... //depot/maint-5.10/perl/sv.c#9 integrate
... //depot/maint-5.10/perl/t/op/pack.t#2 integrate
... //depot/maint-5.10/perl/t/run/switches.t#2 integrate
... //depot/maint-5.10/perl/util.c#4 integrate
Differences ...
==== //depot/maint-5.10/perl/av.c#3 (text) ====
Index: perl/av.c
--- perl/av.c#2~33139~ 2008-01-30 15:19:42.000000000 -0800
+++ perl/av.c 2008-03-31 09:59:07.000000000 -0700
@@ -433,7 +433,7 @@
/* Give any tie a chance to cleanup first */
if (SvRMAGICAL(av)) {
const MAGIC* const mg = SvMAGIC(av);
- if (PL_delaymagic && mg->mg_type == PERL_MAGIC_isa)
+ if (PL_delaymagic && mg && mg->mg_type == PERL_MAGIC_isa)
PL_delaymagic |= DM_ARRAY;
else
mg_clear((SV*)av);
==== //depot/maint-5.10/perl/dump.c#6 (text) ====
Index: perl/dump.c
--- perl/dump.c#5~33149~ 2008-01-31 03:43:05.000000000 -0800
+++ perl/dump.c 2008-03-31 09:59:07.000000000 -0700
@@ -1188,7 +1188,7 @@
{ PERL_MAGIC_qr, "qr(r)" },
{ PERL_MAGIC_sigelem, "sigelem(s)" },
{ PERL_MAGIC_taint, "taint(t)" },
- { PERL_MAGIC_uvar_elem, "uvar_elem(v)" },
+ { PERL_MAGIC_uvar_elem, "uvar_elem(u)" },
{ PERL_MAGIC_vec, "vec(v)" },
{ PERL_MAGIC_vstring, "vstring(V)" },
{ PERL_MAGIC_utf8, "utf8(w)" },
==== //depot/maint-5.10/perl/perl.c#7 (text) ====
Index: perl/perl.c
--- perl/perl.c#6~33611~ 2008-03-31 05:32:56.000000000 -0700
+++ perl/perl.c 2008-03-31 09:59:07.000000000 -0700
@@ -1128,18 +1128,11 @@
}
/* Now absolutely destruct everything, somehow or other, loops or no. */
- SvFLAGS(PL_fdpid) |= SVTYPEMASK; /* don't clean out pid table
now */
- SvFLAGS(PL_strtab) |= SVTYPEMASK; /* don't clean out strtab now */
/* the 2 is for PL_fdpid and PL_strtab */
- while (PL_sv_count > 2 && sv_clean_all())
+ while (sv_clean_all() > 2)
;
- SvFLAGS(PL_fdpid) &= ~SVTYPEMASK;
- SvFLAGS(PL_fdpid) |= SVt_PVAV;
- SvFLAGS(PL_strtab) &= ~SVTYPEMASK;
- SvFLAGS(PL_strtab) |= SVt_PVHV;
-
AvREAL_off(PL_fdpid); /* no surviving entries */
SvREFCNT_dec(PL_fdpid); /* needed in io_close() */
PL_fdpid = NULL;
@@ -1371,10 +1364,17 @@
*/
const char * const s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL");
if (!s || atoi(s) == 0) {
+ const U32 old_debug = PL_debug;
/* Emulate the PerlHost behaviour of free()ing all memory allocated
in this
thread at thread exit. */
+ if (DEBUG_m_TEST) {
+ PerlIO_puts(Perl_debug_log, "Disabling memory debugging as we "
+ "free this thread's memory\n");
+ PL_debug &= ~ DEBUG_m_FLAG;
+ }
while(aTHXx->Imemory_debug_header.next !=
&(aTHXx->Imemory_debug_header))
safesysfree(sTHX + (char *)(aTHXx->Imemory_debug_header.next));
+ PL_debug = old_debug;
}
}
#endif
@@ -2981,6 +2981,7 @@
{
dVAR;
UV rschar;
+ const char option = *s; /* used to remember option in -m/-M code */
switch (*s) {
case '0':
@@ -3178,6 +3179,7 @@
const char *end;
SV *sv;
const char *use = "use ";
+ bool colon = FALSE;
/* -M-foo == 'no foo' */
/* Leading space on " no " is deliberate, to make both
possibilities the same length. */
@@ -3185,19 +3187,30 @@
sv = newSVpvn(use,4);
start = s;
/* We allow -M'Module qw(Foo Bar)' */
- while(isALNUM(*s) || *s==':') ++s;
+ while(isALNUM(*s) || *s==':') {
+ if( *s++ == ':' ) {
+ if( *s == ':' )
+ s++;
+ else
+ colon = TRUE;
+ }
+ }
+ if (s == start)
+ Perl_croak(aTHX_ "Module name required with -%c option",
+ option);
+ if (colon)
+ Perl_croak(aTHX_ "Invalid module name %.*s with -%c option: "
+ "contains single ':'",
+ s - start, start, option);
end = s + strlen(s);
if (*s != '=') {
sv_catpvn(sv, start, end - start);
- if (*(start-1) == 'm') {
+ if (option == 'm') {
if (*s != '\0')
Perl_croak(aTHX_ "Can't use '%c' after -mname", *s);
sv_catpvs( sv, " ()");
}
} else {
- if (s == start)
- Perl_croak(aTHX_ "Module name required with -%c option",
- s[-1]);
sv_catpvn(sv, start, s-start);
/* Use NUL as q''-delimiter. */
sv_catpvs(sv, " split(/,/,q\0");
@@ -3209,7 +3222,7 @@
Perl_av_create_and_push(aTHX_ &PL_preambleav, sv);
}
else
- Perl_croak(aTHX_ "Missing argument to -%c", *(s-1));
+ Perl_croak(aTHX_ "Missing argument to -%c", option);
return s;
case 'n':
PL_minus_n = TRUE;
==== //depot/maint-5.10/perl/perlio.c#5 (text) ====
Index: perl/perlio.c
--- perl/perlio.c#4~33590~ 2008-03-28 12:01:33.000000000 -0700
+++ perl/perlio.c 2008-03-31 09:59:07.000000000 -0700
@@ -4126,6 +4126,9 @@
PerlIOBuf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
{
PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
+#ifndef DEBUGGING
+ PERL_UNUSED_ARG(cnt);
+#endif
if (!b->buf)
PerlIO_get_base(f);
b->ptr = ptr;
==== //depot/maint-5.10/perl/pp_pack.c#4 (text) ====
Index: perl/pp_pack.c
--- perl/pp_pack.c#3~33496~ 2008-03-12 10:43:34.000000000 -0700
+++ perl/pp_pack.c 2008-03-31 09:59:07.000000000 -0700
@@ -1258,6 +1258,7 @@
symptr->previous = &savsym;
symptr->level++;
PUTBACK;
+ if (len && unpack_only_one) len = 1;
while (len--) {
symptr->patptr = savsym.grpbeg;
if (utf8) symptr->flags |= FLAG_PARSE_UTF8;
==== //depot/maint-5.10/perl/sv.c#9 (text) ====
Index: perl/sv.c
--- perl/sv.c#8~33599~ 2008-03-29 08:41:22.000000000 -0700
+++ perl/sv.c 2008-03-31 09:59:07.000000000 -0700
@@ -506,6 +506,10 @@
do_clean_all(pTHX_ SV *sv)
{
dVAR;
+ if (sv == (SV*) PL_fdpid || sv == (SV *)PL_strtab) {
+ /* don't clean pid table and strtab */
+ return;
+ }
DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at
0x%"UVxf"\n", PTR2UV(sv)) ));
SvFLAGS(sv) |= SVf_BREAK;
SvREFCNT_dec(sv);
@@ -6237,11 +6241,6 @@
Safefree(mg->mg_ptr);
s = SvPV_const(sv, len);
if ((xf = mem_collxfrm(s, len, &xlen))) {
- if (SvREADONLY(sv)) {
- SAVEFREEPV(xf);
- *nxp = xlen;
- return xf + sizeof(PL_collation_ix);
- }
if (! mg) {
#ifdef PERL_OLD_COPY_ON_WRITE
if (SvIsCOW(sv))
==== //depot/maint-5.10/perl/t/op/pack.t#2 (xtext) ====
Index: perl/t/op/pack.t
--- perl/t/op/pack.t#1~32694~ 2007-12-22 01:23:09.000000000 -0800
+++ perl/t/op/pack.t 2008-03-31 09:59:07.000000000 -0700
@@ -12,7 +12,7 @@
my $no_signedness = $] > 5.009 ? '' :
"Signed/unsigned pack modifiers not available on this perl";
-plan tests => 14696;
+plan tests => 14697;
use strict;
use warnings qw(FATAL all);
@@ -1980,3 +1980,8 @@
is(unpack('@!4 a*', "\x{301}\x{302}\x{303}\x{304}\x{305}"),
"\x{303}\x{304}\x{305}", 'Test basic utf8 @!');
}
+{
+ #50256
+ my ($v) = split //, unpack ('(B)*', 'ab');
+ is($v, 0); # Doesn't SEGV :-)
+}
==== //depot/maint-5.10/perl/t/run/switches.t#2 (text) ====
Index: perl/t/run/switches.t
--- perl/t/run/switches.t#1~32694~ 2007-12-22 01:23:09.000000000 -0800
+++ perl/t/run/switches.t 2008-03-31 09:59:07.000000000 -0700
@@ -11,7 +11,7 @@
BEGIN { require "./test.pl"; }
-plan(tests => 61);
+plan(tests => 67);
use Config;
@@ -194,6 +194,34 @@
);
is( $r, '<swtest><foo><bar>', '-m with import parameters' );
push @tmpfiles, $filename;
+
+ is( runperl( switches => [ '-MTie::Hash' ], stderr => 1, prog => 1 ),
+ '', "-MFoo::Bar allowed" );
+
+ like( runperl( switches => [ '-M:swtest' ], stderr => 1,
+ prog => 'die "oops"' ),
+ qr/Invalid module name [\w:]+ with -M option\b/,
+ "-M:Foo not allowed" );
+
+ like( runperl( switches => [ '-mA:B:C' ], stderr => 1,
+ prog => 'die "oops"' ),
+ qr/Invalid module name [\w:]+ with -m option\b/,
+ "-mFoo:Bar not allowed" );
+
+ like( runperl( switches => [ '-m-A:B:C' ], stderr => 1,
+ prog => 'die "oops"' ),
+ qr/Invalid module name [\w:]+ with -m option\b/,
+ "-m-Foo:Bar not allowed" );
+
+ like( runperl( switches => [ '-m-' ], stderr => 1,
+ prog => 'die "oops"' ),
+ qr/Module name required with -m option\b/,
+ "-m- not allowed" );
+
+ like( runperl( switches => [ '-M-=' ], stderr => 1,
+ prog => 'die "oops"' ),
+ qr/Module name required with -M option\b/,
+ "-M- not allowed" );
}
# Tests for -V
==== //depot/maint-5.10/perl/util.c#4 (text) ====
Index: perl/util.c
--- perl/util.c#3~33139~ 2008-01-30 15:19:42.000000000 -0800
+++ perl/util.c 2008-03-31 09:59:07.000000000 -0700
@@ -178,11 +178,11 @@
ptr = (Malloc_t)PerlMem_realloc(where,size);
PERL_ALLOC_CHECK(ptr);
- DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld)
rfree\n",PTR2UV(where),(long)PL_an++));
- DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) realloc %ld
bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
-
- if (ptr != NULL) {
+ /* MUST do this fixup first, before doing ANYTHING else, as anything else
+ might allocate memory/free/move memory, and until we do the fixup, it
+ may well be chasing (and writing to) free memory. */
#ifdef PERL_TRACK_MEMPOOL
+ if (ptr != NULL) {
struct perl_memory_debug_header *const header
= (struct perl_memory_debug_header *)ptr;
@@ -198,7 +198,17 @@
header->prev->next = header;
ptr = (Malloc_t)((char*)ptr+sTHX);
+ }
#endif
+
+ /* In particular, must do that fixup above before logging anything via
+ *printf(), as it can reallocate memory, which can cause SEGVs. */
+
+ DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld)
rfree\n",PTR2UV(where),(long)PL_an++));
+ DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) realloc %ld
bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
+
+
+ if (ptr != NULL) {
return ptr;
}
else if (PL_nomemok)
@@ -2945,6 +2955,7 @@
#endif
if (result < 0 && errno == EINTR) {
PERL_ASYNC_CHECK();
+ errno = EINTR; /* reset in case a signal handler changed $! */
}
return result;
}
End of Patch.
