From: Nick Ing-Simmons Date: Fri, 5 Apr 2002 19:30:12 +0000 (+0000) Subject: Integrate mainline X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=004283b80f6094bb85aba6f48a74e3c5c34ea24f;p=p5sagit%2Fp5-mst-13.2.git Integrate mainline p4raw-id: //depot/perlio@15753 --- diff --git a/Configure b/Configure index 76a058b..076f053 100755 --- a/Configure +++ b/Configure @@ -20,7 +20,7 @@ # $Id: Head.U,v 3.0.1.9 1997/02/28 15:02:09 ram Exp $ # -# Generated on Thu Apr 4 20:10:51 EET DST 2002 [metaconfig 3.0 PL70] +# Generated on Fri Apr 5 20:56:35 EET DST 2002 [metaconfig 3.0 PL70] # (with additional metaconfig patches by perlbug@perl.org) cat >c1$$ <\nul + @copy << stdio.h >\nwnul /* * (C) Copyright 2001-2002 Novell Inc. All rights reserved. @@ -979,7 +979,7 @@ HEADERS : << @copy stdio.h $(COREDIR) - @copy << string.h >\nul + @copy << string.h >\nwnul /* * (C) Copyright 2001-2002 Novell Inc. All rights reserved. @@ -1017,7 +1017,7 @@ HEADERS : @copy string.h $(COREDIR) -$(NLM_NAME): MESSAGE HEADERS $(BLDDIR)\nul $(NLM_OBJ) $(NEWTARE_OBJ_DEP) $(PERL_IO_OBJ_DEP) $(PERL_LIB_OBJ_DEP) $(DLL_OBJ) .XDC $(PERLIMPLIB) $(EXT_MAIN_OBJ) +$(NLM_NAME): MESSAGE HEADERS $(BLDDIR)\nwnul $(NLM_OBJ) $(NEWTARE_OBJ_DEP) $(PERL_IO_OBJ_DEP) $(PERL_LIB_OBJ_DEP) $(DLL_OBJ) .XDC $(PERLIMPLIB) $(EXT_MAIN_OBJ) @echo======= Linking $@ at $(MAKEDIR)\$(BLDDIR) ======= !ifdef WATCOM @$(NLM_LINK) @<<$(BLDDIR)\$*.link @@ -1078,7 +1078,7 @@ Import @perl.imp @echo======= Finished building $(BUILT). # Create the debug\release directory if not existing -$(BLDDIR)\nul: +$(BLDDIR)\nwnul: @echo . . . . mkdir $(BLDDIR) @mkdir $(BLDDIR) diff --git a/NetWare/Nwmain.c b/NetWare/Nwmain.c index 9fb2e50..ce901e6 100644 --- a/NetWare/Nwmain.c +++ b/NetWare/Nwmain.c @@ -177,7 +177,7 @@ void main(int argc, char *argv[]) char sNUL[MAX_DN_BYTES] = {'\0'}; strcpy(sNUL, NWDEFPERLROOT); - strcat(sNUL, "\\nul"); + strcat(sNUL, "\\nwnul"); if (access((const char *)sNUL, 0) != 0) { // The file, "nul" is not found and so create the file. @@ -309,7 +309,7 @@ void fnSigTermHandler(int sig) char sNUL[MAX_DN_BYTES] = {'\0'}; strcpy(sNUL, NWDEFPERLROOT); - strcat(sNUL, "\\nul"); + strcat(sNUL, "\\nwnul"); if (access((const char *)sNUL, 0) == 0) { // The file, "nul" is found and so delete it. diff --git a/NetWare/nw5.c b/NetWare/nw5.c index 66ca348..b217e1c 100644 --- a/NetWare/nw5.c +++ b/NetWare/nw5.c @@ -581,8 +581,8 @@ nw_open(const char *path, int flag, ...) pmode = va_arg(ap, int); va_end(ap); - if (stricmp(path, "/dev/null")==0) - path = "NUL"; + if (stricmp(path, "/dev/nul")==0) + path = "NWNUL"; return open(path, flag, pmode); } diff --git a/dosish.h b/dosish.h index 634efa7..c933597 100644 --- a/dosish.h +++ b/dosish.h @@ -37,7 +37,7 @@ # else # ifdef NETWARE # define PERL_SYS_INIT(c,v) Perl_nw5_init(c,v) -# define BIT_BUCKET "nul" +# define BIT_BUCKET "nwnul" # else # define PERL_SYS_INIT(c,v) # define BIT_BUCKET "\\dev\\nul" /* "wanna be like, umm, Newlined, or somethin?" */ diff --git a/ext/Storable/Storable.xs b/ext/Storable/Storable.xs index 847ec1f..279cd1f 100644 --- a/ext/Storable/Storable.xs +++ b/ext/Storable/Storable.xs @@ -3917,8 +3917,12 @@ static SV *retrieve_scalar(stcxt_t *cxt, char *cname) /* * newSV did not upgrade to SVt_PV so the scalar is undefined. * To make it defined with an empty length, upgrade it now... + * Don't upgrade to a PV if the original type contains more + * information than a scalar. */ - sv_upgrade(sv, SVt_PV); + if (SvTYPE(sv) <= SVt_PV) { + sv_upgrade(sv, SVt_PV); + } SvGROW(sv, 1); *SvEND(sv) = '\0'; /* Ensure it's null terminated anyway */ TRACEME(("ok (retrieve_scalar empty at 0x%"UVxf")", PTR2UV(sv))); diff --git a/ext/Storable/t/dclone.t b/ext/Storable/t/dclone.t index 38c82eb..7e3adce 100644 --- a/ext/Storable/t/dclone.t +++ b/ext/Storable/t/dclone.t @@ -27,7 +27,7 @@ sub BEGIN { use Storable qw(dclone); -print "1..9\n"; +print "1..10\n"; $a = 'toto'; $b = \$a; @@ -80,3 +80,17 @@ $$cloned{a} = "blah"; print "not " unless $$cloned{''}[0] == \$$cloned{a}; print "ok 9\n"; +# [ID 20020221.007] SEGV in Storable with empty string scalar object +package TestString; +sub new { + my ($type, $string) = @_; + return bless(\$string, $type); +} +package main; +my $empty_string_obj = TestString->new(''); +my $clone = dclone($empty_string_obj); +# If still here after the dclone the fix (#17543) worked. +print ref $clone eq ref $empty_string_obj && + $$clone eq $$empty_string_obj && + $$clone eq '' ? "ok 10\n" : "not ok 10\n"; + diff --git a/lib/Tie/File/t/26_twrite.t b/lib/Tie/File/t/26_twrite.t index e3d03a0..1d9073c 100644 --- a/lib/Tie/File/t/26_twrite.t +++ b/lib/Tie/File/t/26_twrite.t @@ -290,6 +290,7 @@ sub try { undef $o; untie @lines; open F, "< $file" or die "Couldn't open file $file: $!"; + binmode F; my $actual; { local $/; $actual = ; diff --git a/lib/sort.t b/lib/sort.t index c132a5c..52d1d8b 100644 --- a/lib/sort.t +++ b/lib/sort.t @@ -58,15 +58,18 @@ sub genarray { sub checkorder { my $aref = shift; my $status = ''; # so far, so good - my $i; + my ($i, $disorder); for ($i = 0; $i < $#$aref; ++$i) { - next if ($aref->[$i] lt $aref->[$i+1]); - $status = (substr($aref->[$i], 0, $RootWidth) eq - substr($aref->[$i+1], 0, $RootWidth)) ? - "Instability" : "Disorder"; - $status .= " at element $i between $aref->[$i] and $aref->[$i+1]"; - last; + # Equality shouldn't happen, but catch it in the contents check + next if ($aref->[$i] le $aref->[$i+1]); + $disorder = (substr($aref->[$i], 0, $RootWidth) eq + substr($aref->[$i+1], 0, $RootWidth)) ? + "Instability" : "Disorder"; + # Keep checking if merely unstable... disorder is much worse. + $status = + "$disorder at element $i between $aref->[$i] and $aref->[$i+1]"; + last unless ($disorder eq "Instability"); } return $status; } @@ -121,6 +124,11 @@ sub main { $status = checkequal(\@sorted, $unsorted); is($status, '', "contents ok for size $ts"); } + # P5P: The following test (#58) has been observed failing on + # a solaris 2.8 platform. Failure doesn't mean that sort is + # misbehaving, it is just exhibiting an exceedingly unlikely + # pattern of breaking ties. If you see no other failures, + # it should be perfectly safe to install. if ($expect_unstable) { ok($unstable_num > 0, 'Instability ok'); } diff --git a/pod/perlfunc.pod b/pod/perlfunc.pod index 322591a..d20851f 100644 --- a/pod/perlfunc.pod +++ b/pod/perlfunc.pod @@ -4610,12 +4610,14 @@ Examples: use sort 'stable'; @new = sort { substr($a, 3, 5) cmp substr($b, 3, 5) } @old; - # force use of quicksort (not portable outside Perl 5.8) - use sort '_quicksort'; # note discouraging _ + # force use of mergesort (not portable outside Perl 5.8) + use sort '_mergesort'; # note discouraging _ @new = sort { substr($a, 3, 5) cmp substr($b, 3, 5) } @old; - # similar to the previous example, but demand stability as well - use sort qw( _mergesort stable ); + # Similar to the previous example, but demand stability as well + # Because of the way quicksort is "stabilized", this combination + # is not threadsafe + use sort qw( _quicksort stable ); @new = sort { substr($a, 3, 5) cmp substr($b, 3, 5) } @old; If you're using strict, you I declare $a