From: Nick Ing-Simmons <nik@tiuk.ti.com>
Date: Mon, 18 Jun 2001 12:24:42 +0000 (+0000)
Subject: Integrate mainline (new test scheme now ok on Linux).
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=5eac4321f8221a26c9e14f37c0d61443bfafe0b6;p=p5sagit%2Fp5-mst-13.2.git

Integrate mainline (new test scheme now ok on Linux).

p4raw-id: //depot/perlio@10683
---

diff --git a/dump.c b/dump.c
index bbbcec3..1dc5571 100644
--- a/dump.c
+++ b/dump.c
@@ -963,6 +963,7 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo
 	if (GvSHARED(sv))       sv_catpv(d, "SHARED,");
 	if (GvASSUMECV(sv))	sv_catpv(d, "ASSUMECV,");
 	if (GvIN_PAD(sv))       sv_catpv(d, "IN_PAD,");
+	if (flags & SVpad_OUR)	sv_catpv(d, "OUR,");
 	if (GvIMPORTED(sv)) {
 	    sv_catpv(d, "IMPORT");
 	    if (GvIMPORTED(sv) == GVf_IMPORTED)
@@ -976,7 +977,7 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo
 		sv_catpv(d, " ),");
 	    }
 	}
-	/* FALL THROGH */
+	/* FALL THROUGH */
     default:
 	if (SvEVALED(sv))	sv_catpv(d, "EVALED,");
 	if (SvIsUV(sv))		sv_catpv(d, "IsUV,");
@@ -986,6 +987,10 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo
 	if (SvTAIL(sv))		sv_catpv(d, "TAIL,");
 	if (SvVALID(sv))	sv_catpv(d, "VALID,");
 	break;
+    case SVt_PVMG:
+	if (flags & SVpad_TYPED)
+				sv_catpv(d, "TYPED,");
+	break;
     }
 
     if (*(SvEND(d) - 1) == ',')
diff --git a/lib/warnings.t b/lib/warnings.t
new file mode 100644
index 0000000..09b41fb
--- /dev/null
+++ b/lib/warnings.t
@@ -0,0 +1,131 @@
+#!./perl 
+
+BEGIN {
+    chdir 't' if -d 't';
+    @INC = '../lib';
+    $ENV{PERL5LIB} = '../lib';
+    require Config; import Config;
+}
+
+$| = 1;
+
+my $Is_VMS     = $^O eq 'VMS';
+my $Is_MSWin32 = $^O eq 'MSWin32';
+my $Is_NetWare = $^O eq 'NetWare';
+my $tmpfile = "tmp0000";
+my $i = 0 ;
+1 while -f ++$tmpfile;
+END {  if ($tmpfile) { 1 while unlink $tmpfile} }
+
+my @prgs = () ;
+my @w_files = () ;
+
+if (@ARGV)
+  { print "ARGV = [@ARGV]\n" ; @w_files = map { s#^#./pragma/warn/#; $_ } @ARGV }
+else
+  { @w_files = sort glob("pragma/warn/*") }
+
+my $files = 0;
+foreach my $file (@w_files) {
+
+    next if $file =~ /(~|\.orig|,v)$/;
+
+    open F, "<$file" or die "Cannot open $file: $!\n" ;
+    my $line = 0;
+    while (<F>) {
+        $line++; 
+	last if /^__END__/ ;
+    }
+
+    {
+        local $/ = undef;
+        $files++; 
+        @prgs = (@prgs, $file, split "\n########\n", <F>) ;
+    }
+    close F ;
+}
+
+undef $/;
+
+print "1..", scalar(@prgs)-$files, "\n";
+ 
+ 
+for (@prgs){
+    unless (/\n/)
+     {
+      print "# From $_\n"; 
+      next; 
+     }
+    my $switch = "";
+    my @temps = () ;
+    if (s/^\s*-\w+//){
+        $switch = $&;
+        $switch =~ s/(-\S*[A-Z]\S*)/"$1"/ if $Is_VMS; # protect uc switches
+    }
+    my($prog,$expected) = split(/\nEXPECT\n/, $_);
+    if ( $prog =~ /--FILE--/) {
+        my(@files) = split(/\n--FILE--\s*([^\s\n]*)\s*\n/, $prog) ;
+	shift @files ;
+	die "Internal error test $i didn't split into pairs, got " . 
+		scalar(@files) . "[" . join("%%%%", @files) ."]\n"
+	    if @files % 2 ;
+	while (@files > 2) {
+	    my $filename = shift @files ;
+	    my $code = shift @files ;
+    	    push @temps, $filename ;
+	    open F, ">$filename" or die "Cannot open $filename: $!\n" ;
+	    print F $code ;
+	    close F ;
+	}
+	shift @files ;
+	$prog = shift @files ;
+    }
+    open TEST, ">$tmpfile";
+    print TEST $prog,"\n";
+    close TEST;
+    my $results = $Is_VMS ?
+                  `./perl "-I../lib" $switch $tmpfile 2>&1` :
+		  $Is_MSWin32 ?
+                  `.\\perl -I../lib $switch $tmpfile 2>&1` :
+		  $Is_NetWare ?
+                  `perl -I../lib $switch $tmpfile 2>&1` :
+                  `./perl -I../lib $switch $tmpfile 2>&1`;
+    my $status = $?;
+    $results =~ s/\n+$//;
+    # allow expected output to be written as if $prog is on STDIN
+    $results =~ s/tmp\d+/-/g;
+    $results =~ s/\n%[A-Z]+-[SIWEF]-.*$// if $Is_VMS;  # clip off DCL status msg
+# bison says 'parse error' instead of 'syntax error',
+# various yaccs may or may not capitalize 'syntax'.
+    $results =~ s/^(syntax|parse) error/syntax error/mig;
+    # allow all tests to run when there are leaks
+    $results =~ s/Scalars leaked: \d+\n//g;
+    $expected =~ s/\n+$//;
+    my $prefix = ($results =~ s#^PREFIX(\n|$)##) ;
+    # any special options? (OPTIONS foo bar zap)
+    my $option_regex = 0;
+    if ($expected =~ s/^OPTIONS? (.+)\n//) {
+	foreach my $option (split(' ', $1)) {
+	    if ($option eq 'regex') { # allow regular expressions
+		$option_regex = 1;
+	    } else {
+		die "$0: Unknown OPTION '$option'\n";
+	    }
+	}
+    }
+    if ( $results =~ s/^SKIPPED\n//) {
+	print "$results\n" ;
+    }
+    elsif (($prefix  && (( $option_regex && $results !~ /^$expected/) ||
+			 (!$option_regex && $results !~ /^\Q$expected/))) or
+	   (!$prefix && (( $option_regex && $results !~ /^$expected/) ||
+			 (!$option_regex && $results ne $expected)))) {
+        print STDERR "PROG: $switch\n$prog\n";
+        print STDERR "EXPECTED:\n$expected\n";
+        print STDERR "GOT:\n$results\n";
+        print "not ";
+    }
+    print "ok ", ++$i, "\n";
+    foreach (@temps) 
+	{ unlink $_ if $_ } 
+}
diff --git a/sv.c b/sv.c
index 4352fd4..84c778c 100644
--- a/sv.c
+++ b/sv.c
@@ -8159,9 +8159,7 @@ Perl_sv_dup(pTHX_ SV *sstr)
 	}
 	HvPMROOT((HV*)dstr)	= HvPMROOT((HV*)sstr);		/* XXX */
 	HvNAME((HV*)dstr)	= SAVEPV(HvNAME((HV*)sstr));
-        /* If HvNAME() is set hv _may_ be a stash 
-           - record it for possible callback 
-         */
+    /* Record stashes for possible cloning in Perl_clone_using(). */
 	if(HvNAME((HV*)dstr))
 	    av_push(PL_clone_callbacks, dstr);
 	break;
@@ -9310,27 +9308,23 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
         PL_ptr_table = NULL;
     }
     
-    /* For the (possible) stashes identified above 
-         - check that they are stashes
-         - if they are see if the ->CLONE method is defined
-         - if it is call it 
-     */
+    /* Call the ->CLONE method, if it exists, for each of the stashes
+       identified by sv_dup() above.
+    */
     while(av_len(PL_clone_callbacks) != -1) {
         HV* stash = (HV*) av_shift(PL_clone_callbacks);
-        if (gv_stashpv(HvNAME(stash),0)) {
-            GV* cloner = gv_fetchmethod_autoload(stash,"CLONE",0);
-            if (cloner && GvCV(cloner)) {
-                dSP;
-                ENTER;
-                SAVETMPS;
-                PUSHMARK(SP);
-                XPUSHs(newSVpv(HvNAME(stash),0));
-                PUTBACK;
-                call_sv((SV*)GvCV(cloner), G_DISCARD);
-                FREETMPS;
-                LEAVE;
-            }
-        }
+	GV* cloner = gv_fetchmethod_autoload(stash, "CLONE", 0);
+	if (cloner && GvCV(cloner)) {
+	    dSP;
+	    ENTER;
+	    SAVETMPS;
+	    PUSHMARK(SP);
+	    XPUSHs(newSVpv(HvNAME(stash), 0));
+	    PUTBACK;
+	    call_sv((SV*)GvCV(cloner), G_DISCARD);
+	    FREETMPS;
+	    LEAVE;
+	}
     }
 
 #ifdef PERL_OBJECT