This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
t/test.pl: Simplify ord to/from native fcns
[perl5.git] / t / test.pl
index ad59ca9..e918a42 100644 (file)
--- a/t/test.pl
+++ b/t/test.pl
@@ -109,6 +109,16 @@ sub _comment {
            map { split /\n/ } @_;
 }
 
+sub _have_dynamic_extension {
+    my $extension = shift;
+    unless (eval {require Config; 1}) {
+       warn "test.pl had problems loading Config: $@";
+       return 1;
+    }
+    $extension =~ s!::!/!g;
+    return 1 if ($Config::Config{extensions} =~ /\b$extension\b/);
+}
+
 sub skip_all {
     if (@_) {
         _print "1..0 # Skip @_\n";
@@ -123,14 +133,9 @@ sub skip_all_if_miniperl {
 }
 
 sub skip_all_without_dynamic_extension {
-    my $extension = shift;
+    my ($extension) = @_;
     skip_all("no dynamic loading on miniperl, no $extension") if is_miniperl();
-    unless (eval {require Config; 1}) {
-       warn "test.pl had problems loading Config: $@";
-       return;
-    }
-    $extension =~ s!::!/!g;
-    return if ($Config::Config{extensions} =~ /\b$extension\b/);
+    return if &_have_dynamic_extension;
     skip_all("$extension was not built");
 }
 
@@ -153,9 +158,9 @@ sub skip_all_without_config {
 }
 
 sub find_git_or_skip {
-    my ($found_dir, $reason);
+    my ($source_dir, $reason);
     if (-d '.git') {
-       $found_dir = 1;
+       $source_dir = '.';
     } elsif (-l 'MANIFEST' && -l 'AUTHORS') {
        my $where = readlink 'MANIFEST';
        die "Can't readling MANIFEST: $!" unless defined $where;
@@ -163,16 +168,20 @@ sub find_git_or_skip {
            unless $where =~ s!/MANIFEST\z!!;
        if (-d "$where/.git") {
            # Looks like we are in a symlink tree
-           chdir $where or die "Can't chdir '$where': $!";
-           note("Found source tree at $where");
-           $found_dir = 1;
+           if (exists $ENV{GIT_DIR}) {
+               diag("Found source tree at $where, but \$ENV{GIT_DIR} is $ENV{GIT_DIR}. Not changing it");
+           } else {
+               note("Found source tree at $where, setting \$ENV{GIT_DIR}");
+               $ENV{GIT_DIR} = "$where/.git";
+           }
+           $source_dir = $where;
        }
     }
-    if ($found_dir) {
+    if ($source_dir) {
        my $version_string = `git --version`;
        if (defined $version_string
              && $version_string =~ /\Agit version (\d+\.\d+\.\d+)(.*)/) {
-           return if eval "v$1 ge v1.5.0";
+           return $source_dir if eval "v$1 ge v1.5.0";
            # If you have earlier than 1.5.0 and it works, change this test
            $reason = "in git checkout, but git version '$1$2' too old";
        } else {
@@ -185,6 +194,12 @@ sub find_git_or_skip {
     skip($reason, @_);
 }
 
+sub BAIL_OUT {
+    my ($reason) = @_;
+    _print("Bail out!  $reason\n");
+    exit 255;
+}
+
 sub _ok {
     my ($pass, $where, $name, @mess) = @_;
     # Do not try to microoptimize by factoring out the "not ".
@@ -210,7 +225,10 @@ sub _ok {
        note @mess; # Ensure that the message is properly escaped.
     }
     else {
-       _diag "# Failed $where\n";
+       my $msg = "# Failed test $test - ";
+       $msg.= "$name " if $name;
+       $msg .= "$where\n";
+       _diag $msg;
        _diag @mess;
     }
 
@@ -441,6 +459,13 @@ sub skip_if_miniperl {
     skip(@_) if is_miniperl();
 }
 
+sub skip_without_dynamic_extension {
+    my ($extension) = @_;
+    skip("no dynamic loading on miniperl, no $extension") if is_miniperl();
+    return if &_have_dynamic_extension;
+    skip("$extension was not built");
+}
+
 sub todo_skip {
     my $why = shift;
     my $n   = @_ ? shift : 1;
@@ -472,7 +497,10 @@ sub eq_hash {
     # Force a hash recompute if this perl's internals can cache the hash key.
     $key = "" . $key;
     if (exists $orig->{$key}) {
-      if ($orig->{$key} ne $value) {
+      if (
+        defined $orig->{$key} != defined $value
+        || (defined $value && $orig->{$key} ne $value)
+      ) {
         _print "# key ", _qq($key), " was ", _qq($orig->{$key}),
                      " now ", _qq($value), "\n";
         $fail = 1;
@@ -526,7 +554,7 @@ USE_OK
 #   prog     => one-liner (avoid quotes)
 #   progs    => [ multi-liner (avoid quotes) ]
 #   progfile => perl script
-#   stdin    => string to feed the stdin
+#   stdin    => string to feed the stdin (or undef to redirect from /dev/null)
 #   stderr   => redirect stderr to stdout
 #   args     => [ command-line arguments to the perl program ]
 #   verbose  => print the command line
@@ -609,6 +637,28 @@ sub _create_runperl { # Create the string to qx in runperl().
            $runperl = qq{$Perl -e 'print qq(} .
                $args{stdin} . q{)' | } . $runperl;
        }
+    } elsif (exists $args{stdin}) {
+        # Using the pipe construction above can cause fun on systems which use
+        # ksh as /bin/sh, as ksh does pipes differently (with one less process)
+        # With sh, for the command line 'perl -e 'print qq()' | perl -e ...'
+        # the sh process forks two children, which use exec to start the two
+        # perl processes. The parent shell process persists for the duration of
+        # the pipeline, and the second perl process starts with no children.
+        # With ksh (and zsh), the shell saves a process by forking a child for
+        # just the first perl process, and execing itself to start the second.
+        # This means that the second perl process starts with one child which
+        # it didn't create. This causes "fun" when if the tests assume that
+        # wait (or waitpid) will only return information about processes
+        # started within the test.
+        # They also cause fun on VMS, where the pipe implementation returns
+        # the exit code of the process at the front of the pipeline, not the
+        # end. This messes up any test using OPTION FATAL.
+        # Hence it's useful to have a way to make STDIN be at eof without
+        # needing a pipeline, so that the fork tests have a sane environment
+        # without these surprises.
+
+        # /dev/null appears to be surprisingly portable.
+        $runperl = $runperl . ($is_mswin ? ' <nul' : ' </dev/null');
     }
     if (defined $args{args}) {
        $runperl = _quote_args($runperl, $args{args});
@@ -737,6 +787,44 @@ sub unlink_all {
     $count;
 }
 
+# _num_to_alpha - Returns a string of letters representing a positive integer.
+# Arguments :
+#   number to convert
+#   maximum number of letters
+
+# returns undef if the number is negative
+# returns undef if the number of letters is greater than the maximum wanted
+
+# _num_to_alpha( 0) eq 'A';
+# _num_to_alpha( 1) eq 'B';
+# _num_to_alpha(25) eq 'Z';
+# _num_to_alpha(26) eq 'AA';
+# _num_to_alpha(27) eq 'AB';
+
+my @letters = qw(A B C D E F G H I J K L M N O P Q R S T U V W X Y Z);
+
+# Avoid ++ -- ranges split negative numbers
+sub _num_to_alpha{
+    my($num,$max_char) = @_;
+    return unless $num >= 0;
+    my $alpha = '';
+    my $char_count = 0;
+    $max_char = 0 if $max_char < 0;
+
+    while( 1 ){
+        $alpha = $letters[ $num % 26 ] . $alpha;
+        $num = int( $num / 26 );
+        last if $num == 0;
+        $num = $num - 1;
+
+        # char limit
+        next unless $max_char;
+        $char_count = $char_count + 1;
+        return if $char_count == $max_char;
+    }
+    return $alpha;
+}
+
 my %tmpfiles;
 END { unlink_all keys %tmpfiles }
 
@@ -744,26 +832,24 @@ END { unlink_all keys %tmpfiles }
 $::tempfile_regexp = 'tmp\d+[A-Z][A-Z]?';
 
 # Avoid ++, avoid ranges, avoid split //
-my @letters = qw(A B C D E F G H I J K L M N O P Q R S T U V W X Y Z);
+my $tempfile_count = 0;
 sub tempfile {
-    my $count = 0;
-    do {
-       my $temp = $count;
+    while(1){
        my $try = "tmp$$";
-       do {
-           $try = $try . $letters[$temp % 26];
-           $temp = int ($temp / 26);
-       } while $temp;
+        my $alpha = _num_to_alpha($tempfile_count,2);
+        last unless defined $alpha;
+        $try = $try . $alpha;
+        $tempfile_count = $tempfile_count + 1;
+
        # Need to note all the file names we allocated, as a second request may
        # come before the first is created.
-       if (!-e $try && !$tmpfiles{$try}) {
+       if (!$tmpfiles{$try} && !-e $try) {
            # We have a winner
            $tmpfiles{$try} = 1;
            return $try;
        }
-       $count = $count + 1;
-    } while $count < 26 * 26;
-    die "Can't find temporary file name starting 'tmp$$'";
+    }
+    die "Can't find temporary file name starting \"tmp$$\"";
 }
 
 # This is the temporary file for _fresh_perl
@@ -780,20 +866,10 @@ sub _fresh_perl {
     # it feels like the least-worse thing is to assume that auto-vivification
     # works. At least, this is only going to be a run-time failure, so won't
     # affect tests using this file but not this function.
-    $runperl_args->{progfile} = $tmpfile;
-    $runperl_args->{stderr} = 1;
+    $runperl_args->{progfile} ||= $tmpfile;
+    $runperl_args->{stderr}     = 1 unless exists $runperl_args->{stderr};
 
     open TEST, ">$tmpfile" or die "Cannot open $tmpfile: $!";
-
-    # VMS adjustments
-    if( $is_vms ) {
-        $prog =~ s#/dev/null#NL:#;
-
-        # VMS file locking
-        $prog =~ s{if \(-e _ and -f _ and -r _\)}
-                  {if (-e _ and -f _)}
-    }
-
     print TEST $prog;
     close TEST or die "Cannot close $tmpfile: $!";
 
@@ -880,7 +956,8 @@ 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 contain (note the '# ' on each):
+# 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):
 #   # TODO reason for todo
 #   # SKIP reason for skip
 #   # SKIP ?code to test if this should be skipped
@@ -889,9 +966,6 @@ sub fresh_perl_like {
 # The expected output may contain:
 #   OPTION list of options
 #   OPTIONS list of options
-#   PREFIX
-#     indicates that the supplied output is only a prefix to the
-#     expected output
 #
 # The possible options for OPTION may be:
 #   regex - the expected output is a regular expression
@@ -901,9 +975,74 @@ sub fresh_perl_like {
 # If the actual output contains a line "SKIPPED" the test will be
 # skipped.
 #
+# If the actual output contains a line "PREFIX", any output starting with that
+# line will be ignored when comparing with the expected output
+#
 # If the global variable $FATAL is true then OPTION fatal is the
 # default.
 
+sub _setup_one_file {
+    my $fh = shift;
+    # Store the filename as a program that started at line 0.
+    # Real files count lines starting at line 1.
+    my @these = (0, shift);
+    my ($lineno, $current);
+    while (<$fh>) {
+        if ($_ eq "########\n") {
+            if (defined $current) {
+                push @these, $lineno, $current;
+            }
+            undef $current;
+        } else {
+            if (!defined $current) {
+                $lineno = $.;
+            }
+            $current .= $_;
+        }
+    }
+    if (defined $current) {
+        push @these, $lineno, $current;
+    }
+    ((scalar @these) / 2 - 1, @these);
+}
+
+sub setup_multiple_progs {
+    my ($tests, @prgs);
+    foreach my $file (@_) {
+        next if $file =~ /(?:~|\.orig|,v)$/;
+        next if $file =~ /perlio$/ && !PerlIO::Layer->find('perlio');
+        next if -d $file;
+
+        open my $fh, '<', $file or die "Cannot open $file: $!\n" ;
+        my $found;
+        while (<$fh>) {
+            if (/^__END__/) {
+                ++$found;
+                last;
+            }
+        }
+        # This is an internal error, and should never happen. All bar one of
+        # the files had an __END__ marker to signal the end of their preamble,
+        # although for some it wasn't technically necessary as they have no
+        # tests. It might be possible to process files without an __END__ by
+        # seeking back to the start and treating the whole file as tests, but
+        # it's simpler and more reliable just to make the rule that all files
+        # must have __END__ in. This should never fail - a file without an
+        # __END__ should not have been checked in, because the regression tests
+        # would not have passed.
+        die "Could not find '__END__' in $file"
+            unless $found;
+
+        my ($t, @p) = _setup_one_file($fh, $file);
+        $tests += $t;
+        push @prgs, @p;
+
+        close $fh
+            or die "Cannot close $file: $!\n";
+    }
+    return ($tests, @prgs);
+}
+
 sub run_multiple_progs {
     my $up = shift;
     my @prgs;
@@ -912,17 +1051,31 @@ sub run_multiple_progs {
        # pass in a list of "programs" to run
        @prgs = @_;
     } else {
-       # The tests below t run in t and pass in a file handle.
-       my $fh = shift;
-       local $/;
-       @prgs = split "\n########\n", <$fh>;
+        # The tests below t run in t and pass in a file handle. In theory we
+        # can pass (caller)[1] as the second argument to report errors with
+        # the filename of our caller, as the handle is always DATA. However,
+        # line numbers in DATA count from the __END__ token, so will be wrong.
+        # Which is more confusing than not providing line numbers. So, for now,
+        # don't provide line numbers. No obvious clean solution - one hack
+        # would be to seek DATA back to the start and read to the __END__ token,
+        # but that feels almost like we should just open $0 instead.
+
+        # Not going to rely on undef in list assignment.
+        my $dummy;
+        ($dummy, @prgs) = _setup_one_file(shift);
     }
 
     my $tmpfile = tempfile();
 
-    for (@prgs){
-       unless (/\n/) {
-           print "# From $_\n";
+    my ($file, $line);
+  PROGRAM:
+    while (defined ($line = shift @prgs)) {
+        $_ = shift @prgs;
+        unless ($line) {
+            $file = $_;
+            if (defined $file) {
+                print "# From $file\n";
+            }
            next;
        }
        my $switch = "";
@@ -946,13 +1099,22 @@ sub run_multiple_progs {
                $reason{$what} = $temp;
            }
        }
+
        my $name = '';
        if ($prog =~ s/^#\s*NAME\s+(.+)\n//m) {
            $name = $1;
        }
 
+       if ($reason{skip}) {
+       SKIP:
+         {
+           skip($name ? "$name - $reason{skip}" : $reason{skip}, 1);
+         }
+         next PROGRAM;
+       }
+
        if ($prog =~ /--FILE--/) {
-           my @files = split(/\n--FILE--\s*([^\s\n]*)\s*\n/, $prog) ;
+           my @files = split(/\n?--FILE--\s*([^\s\n]*)\s*\n/, $prog) ;
            shift @files ;
            die "Internal error: test $_ didn't split into pairs, got " .
                scalar(@files) . "[" . join("%%%%", @files) ."]\n"
@@ -984,7 +1146,8 @@ sub run_multiple_progs {
        print $fh "\n#line 1\n";  # So the line numbers don't get messed up.
        print $fh $prog,"\n";
        close $fh or die "Cannot close $tmpfile: $!";
-       my $results = runperl( stderr => 1, progfile => $tmpfile, $up
+       my $results = runperl( stderr => 1, progfile => $tmpfile,
+                              stdin => undef, $up
                               ? (switches => ["-I$up/lib", $switch], nolib => 1)
                               : (switches => [$switch])
                                );
@@ -1073,7 +1236,14 @@ sub run_multiple_progs {
            }
        }
 
-       ok($ok, $name);
+        if (defined $file) {
+            _ok($ok, "at $file line $line", $name);
+        } else {
+            # We don't have file and line number data for the test, so report
+            # errors as coming from our caller.
+            local $Level = $Level + 1;
+            ok($ok, $name);
+        }
 
        foreach (@temps) {
            unlink $_ if $_;
@@ -1558,8 +1728,8 @@ sub ord_latin1_to_native {
     # equivalent value.  Anything above latin1 is itself.
 
     my $ord = shift;
-    return $ord if $ord > 255;
-    return ord latin1_to_native(chr $ord);
+    return $ord if ord('^') == 94;   # ASCII, Latin1
+    return utf8::unicode_to_native($ord);
 }
 
 sub ord_native_to_latin1 {
@@ -1567,8 +1737,8 @@ sub ord_native_to_latin1 {
     # Anything above latin1 is itself.
 
     my $ord = shift;
-    return $ord if $ord > 255;
-    return ord native_to_latin1(chr $ord);
+    return $ord if ord('^') == 94;   # ASCII, Latin1
+    return utf8::native_to_unicode($ord);
 }
 
 1;