Update the run script to a more recent version

Avoid a warning:

main::process_test() called too early to check prototype at ./run line 47.
main::process_test() called too early to check prototype at ./run line 60.

Add a >~ test line that is similar to > but is interpreted as a regular
expression.

Signed-off-by: Brandon Philips <bphilips@suse.de>
Signed-off-by: Andreas Gruenbacher <agruen@suse.de>

1 files changed, 69 insertions, 18 deletions

diff --git a/test/run b/test/run
index c4d017a..40b3565 100644..100755
--- a/test/run
+++ b/test/run
@@ -1,5 +1,32 @@
 #!/usr/bin/perl -w -U
 
+# Copyright (c) 2007, 2008 Andreas Gruenbacher.
+# All rights reserved.
+#
+# Redistribution and use in source and binary forms, with or without
+# modification, are permitted provided that the following conditions
+# are met:
+# 1. Redistributions of source code must retain the above copyright
+#    notice, this list of conditions, and the following disclaimer,
+#    without modification, immediately at the beginning of the file.
+# 2. The name of the author may not be used to endorse or promote products
+#    derived from this software without specific prior written permission.
+#
+# Alternatively, this software may be distributed under the terms of the
+# GNU Public License ("GPL").
+#
+# THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
+# ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+# ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE FOR
+# ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+# DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+# OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+# HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+# LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+# OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+# SUCH DAMAGE.
+
 #
 # Possible improvements:
 #
@@ -12,12 +39,13 @@
 use strict;
 use FileHandle;
 use Getopt::Std;
-use POSIX qw(isatty setuid);
-use vars qw($opt_v);
+use POSIX qw(isatty setuid getcwd);
+use vars qw($opt_l $opt_v);
 
 no warnings qw(taint);
 
-getopts('v');
+$opt_l = ~0;  # a really huge number
+getopts('l:v');
 
 my ($OK, $FAILED) = ("ok", "failed");
 if (isatty(fileno(STDOUT))) {
@@ -26,17 +54,20 @@ if (isatty(fileno(STDOUT))) {
 }
 
 sub exec_test($$);
+sub process_test($$$$);
 
 my ($prog, $in, $out) = ([], [], []);
-my $line_number = 0;
-my $prog_line;
+my $prog_line = 0;
 my ($tests, $failed) = (0,0);
+my $lineno;
+my $width = ($ENV{COLUMNS} || 80) >> 1;
 
 for (;;) {
-  my $line = <>; $line_number++;
+  my $line = <>; $lineno++;
   if (defined $line) {
     # Substitute %VAR and %{VAR} with environment variables.
-    $line =~ s[%(?:(\w+)|\{(\w+)\})][$ENV{"$1$2"}]eg;
+    $line =~ s[%(\w+)][$ENV{$1}]eg;
+    $line =~ s[%{(\w+)}][$ENV{$1}]eg;
   }
   if (defined $line) {
     if ($line =~ s/^\s*< ?//) {
@@ -45,14 +76,14 @@ for (;;) {
       push @$out, $line;
     } else {
       process_test($prog, $prog_line, $in, $out);
+      last if $prog_line >= $opt_l;
 
       $prog = [];
       $prog_line = 0;
     }
     if ($line =~ s/^\s*\$ ?//) {
-      $line =~ s/\s+#.*//;  # remove comments here...
       $prog = [ map { s/\\(.)/$1/g; $_ } split /(?<!\\)\s+/, $line ];
-      $prog_line = $line_number;
+      $prog_line = $lineno;
       $in = [];
       $out = [];
     }
@@ -84,27 +115,37 @@ sub process_test($$$$) {
        print "[$prog_line] \$ ", join(' ',
              map { s/\s/\\$&/g; $_ } @$p), " -- ";
        my $result = exec_test($prog, $in);
-       my $good = 1;
+       my @good = ();
        my $nmax = (@$out > @$result) ? @$out : @$result;
        for (my $n=0; $n < $nmax; $n++) {
-	 if (!defined($out->[$n]) || !defined($result->[$n]) ||
-	     $out->[$n] ne $result->[$n]) {
-		 $good = 0;
-	 }
+	   my $use_re;
+	   if (defined $out->[$n] && $out->[$n] =~ /^~ /) {
+		$use_re = 1;
+		$out->[$n] =~ s/^~ //g;
+	   }
+
+           if (!defined($out->[$n]) || !defined($result->[$n]) ||
+               (!$use_re && $result->[$n] ne $out->[$n]) ||
+               ( $use_re && $result->[$n] !~ /^$out->[$n]/)) {
+               push @good, ($use_re ? '!~' : '!=');
+	   }
+	   else {
+               push @good, ($use_re ? '=~' : '==');
+           }
        }
+       my $good = !(grep /!/, @good);
        $tests++;
        $failed++ unless $good;
        print $good ? $OK : $FAILED, "\n";
-       if (!$good) {
+       if (!$good || $opt_v) {
          for (my $n=0; $n < $nmax; $n++) {
 	   my $l = defined($out->[$n]) ? $out->[$n] : "~";
 	   chomp $l;
 	   my $r = defined($result->[$n]) ? $result->[$n] : "~";
 	   chomp $r;
-	   print sprintf("%-37s %s %-39s\n", $l, $l eq $r ? "|" : "?", $r);
+	   print sprintf("%-" . ($width-3) . "s %s %s\n",
+			 $r, $good[$n], $l);
          }
-       } elsif ($opt_v) {
-	 print join('', @$result);
        }
 }
 
@@ -191,11 +232,21 @@ sub exec_test($$) {
     if (!chdir $prog->[1]) {
       return [ "chdir: $prog->[1]: $!\n" ];
     }
+    $ENV{PWD} = getcwd;
     return [];
   } elsif ($prog->[0] eq "su") {
     return su($prog->[1]);
   } elsif ($prog->[0] eq "sg") {
     return sg($prog->[1]);
+  } elsif ($prog->[0] eq "export") {
+    my ($name, $value) = split /=/, $prog->[1];
+    # FIXME: need to evaluate $value, so that things like this will work:
+    # export dir=$PWD/dir
+    $ENV{$name} = $value;
+    return [];
+  } elsif ($prog->[0] eq "unset") {
+    delete $ENV{$prog->[1]};
+    return [];
   }
 
   pipe *IN2, *OUT