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 (file)
--- 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 (file)
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 (file)
--- 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