(perl #131597) ensure the GV slot is filled for our [%$@]foo: attr

[perl5.git] / t / test.pl

diff --git a/t/test.pl b/t/test.pl
index cda3840..79e6e25 100644 (file)
--- a/t/test.pl
+++ b/t/test.pl
@@ -4,9 +4,9 @@
 
 # NOTE:
 #
-# It's best to not features found only in more modern Perls here, as some cpan
-# distributions copy this file and operate on older Perls.  Similarly keep
-# things simple as this may be run under fairly broken circumstances.  For
+# Do not rely on features found only in more modern Perls here, as some CPAN
+# distributions copy this file and must operate on older Perls. Similarly, keep
+# things, simple as this may be run under fairly broken circumstances. For
 # example, increment ($x++) has a certain amount of cleverness for things like
 #
 #   $x = 'zz';
@@ -284,6 +284,12 @@ sub _qq {
     return defined $x ? '"' . display ($x) . '"' : 'undef';
 };
 
+# Support pre-5.10 Perls, for the benefit of CPAN dists that copy this file.
+# Note that chr(90) exists in both ASCII ("Z") and EBCDIC ("!").
+my $chars_template = defined(eval { pack "W*", 90 }) ? "W*" : "U*";
+eval 'sub re::is_regexp { ref($_[0]) eq "Regexp" }'
+    if !defined &re::is_regexp;
+
 # keys are the codes \n etc map to, values are 2 char strings such as \n
 my %backslash_escape;
 foreach my $x (split //, 'nrtfa\\\'"') {
@@ -296,7 +302,7 @@ sub display {
     foreach my $x (@_) {
         if (defined $x and not ref $x) {
             my $y = '';
-            foreach my $c (unpack("W*", $x)) {
+            foreach my $c (unpack($chars_template, $x)) {
                 if ($c > 255) {
                     $y = $y . sprintf "\\x{%x}", $c;
                 } elsif ($backslash_escape{$c}) {
@@ -452,10 +458,15 @@ sub like_yn ($$$@) {
     my $pass;
     $pass = $_[1] =~ /$expected/ if !$flip;
     $pass = $_[1] !~ /$expected/ if $flip;
+    my $display_got = $_[1];
+    $display_got = display($display_got);
+    my $display_expected = $expected;
+    $display_expected = display($display_expected);
     unless ($pass) {
-       unshift(@mess, "#      got '$_[1]'\n",
+       unshift(@mess, "#      got '$display_got'\n",
                $flip
-               ? "# expected !~ /$expected/\n" : "# expected /$expected/\n");
+               ? "# expected !~ /$display_expected/\n"
+                : "# expected /$display_expected/\n");
     }
     local $Level = $Level + 1;
     _ok($pass, _where(), $name, @mess);
@@ -641,7 +652,7 @@ sub _create_runperl { # Create the string to qx in runperl().
        $runperl = "$ENV{PERL_RUNPERL_DEBUG} $runperl";
     }
     unless ($args{nolib}) {
-       $runperl = $runperl . ' "-I../lib"'; # doublequotes because of VMS
+       $runperl = $runperl . ' "-I../lib" "-I." '; # doublequotes because of VMS
     }
     if ($args{switches}) {
        local $Level = 2;
@@ -849,7 +860,7 @@ sub unlink_all {
        if( -f $file ){
            _print_stderr "# Couldn't unlink '$file': $!\n";
        }else{
-           ++$count;
+           $count = $count + 1; # don't use ++
        }
     }
     $count;
@@ -942,11 +953,19 @@ sub register_tempfile {
     return $count;
 }
 
-# This is the temporary file for _fresh_perl
+# This is the temporary file for fresh_perl
 my $tmpfile = tempfile();
 
-sub _fresh_perl {
-    my($prog, $action, $expect, $runperl_args, $name) = @_;
+sub fresh_perl {
+    my($prog, $runperl_args) = @_;
+
+    # Run 'runperl' with the complete perl program contained in '$prog', and
+    # arguments in the hash referred to by '$runperl_args'.  The results are
+    # returned, with $? set to the exit code.  Unless overridden, stderr is
+    # redirected to stdout.
+
+    die sprintf "Third argument to fresh_perl_.* must be hashref of args to fresh_perl (or {})"
+        unless !(defined $runperl_args) || ref($runperl_args) eq 'HASH';
 
     # Given the choice of the mis-parsable {}
     # (we want an anon hash, but a borked lexer might think that it's a block)
@@ -959,12 +978,14 @@ sub _fresh_perl {
     $runperl_args->{progfile} ||= $tmpfile;
     $runperl_args->{stderr}     = 1 unless exists $runperl_args->{stderr};
 
-    open TEST, ">$tmpfile" or die "Cannot open $tmpfile: $!";
+    open TEST, '>', $tmpfile or die "Cannot open $tmpfile: $!";
+    binmode TEST, ':utf8' if $runperl_args->{wide_chars};
     print TEST $prog;
     close TEST or die "Cannot close $tmpfile: $!";
 
     my $results = runperl(%$runperl_args);
-    my $status = $?;
+    my $status = $?;    # Not necessary to save this, but it makes it clear to
+                        # future maintainers.
 
     # Clean up the results into something a bit more predictable.
     $results  =~ s/\n+$//;
@@ -983,6 +1004,17 @@ sub _fresh_perl {
         $results =~ s/\n\n/\n/g;
     }
 
+    $? = $status;
+    return $results;
+}
+
+
+sub _fresh_perl {
+    my($prog, $action, $expect, $runperl_args, $name) = @_;
+
+    my $results = fresh_perl($prog, $runperl_args);
+    my $status = $?;
+
     # Use the first line of the program as a name if none was given
     unless( $name ) {
         ($first_line, $name) = $prog =~ /^((.{1,50}).*)/;
@@ -1047,8 +1079,9 @@ sub fresh_perl_like {
 # Each program is source code to run followed by an "EXPECT" line, followed
 # by the expected output.
 #
-# The code to run may begin with a command line switch such as -w or -0777
-# (alphanumerics only), and may contain (note the '# ' on each):
+# The first line of the code to run may be a command line switch such as -wE
+# or -0777 (alphanumerics only; only one cluster, beginning with a minus is
+# allowed).  Later lines may contain (note the '# ' on each):
 #   # TODO reason for todo
 #   # SKIP reason for skip
 #   # SKIP ?code to test if this should be skipped
@@ -1108,7 +1141,7 @@ sub setup_multiple_progs {
         my $found;
         while (<$fh>) {
             if (/^__END__/) {
-                ++$found;
+                $found = $found + 1; # don't use ++
                 last;
             }
         }
@@ -1230,6 +1263,7 @@ sub run_multiple_progs {
        open my $fh, '>', $tmpfile or die "Cannot open >$tmpfile: $!";
        print $fh q{
         BEGIN {
+            push @INC, '.';
             open STDERR, '>&', STDOUT
               or die "Can't dup STDOUT->STDERR: $!;";
         }