test/run

   1 #!/usr/bin/perl -w -U
   2
   3 # Copyright (c) 2007, 2008 Andreas Gruenbacher.
   4 # All rights reserved.
   5 #
   6 # Redistribution and use in source and binary forms, with or without
   7 # modification, are permitted provided that the following conditions
   8 # are met:
   9 # 1. Redistributions of source code must retain the above copyright
  10 #    notice, this list of conditions, and the following disclaimer,
  11 #    without modification, immediately at the beginning of the file.
  12 # 2. The name of the author may not be used to endorse or promote products
  13 #    derived from this software without specific prior written permission.
  14 #
  15 # THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
  16 # ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
  17 # IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
  18 # ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE FOR
  19 # ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
  20 # DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
  21 # OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
  22 # HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
  23 # LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
  24 # OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
  25 # SUCH DAMAGE.
  26 #
  27 # Alternatively, this software may be distributed under the terms of the
  28 # GNU Public License ("GPL"):
  29 #
  30 # This program is free software: you can redistribute it and/or modify it
  31 # under the terms of the GNU General Public License as published by
  32 # the Free Software Foundation, either version 2 of the License, or
  33 # (at your option) any later version.
  34 #
  35 # This program is distributed in the hope that it will be useful,
  36 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  37 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  38 # GNU General Public License for more details.
  39 #
  40 # You should have received a copy of the GNU General Public License
  41 # along with this program.  If not, see <http://www.gnu.org/licenses/>.
  42 #
  43
  44 #
  45 # Possible improvements:
  46 #
  47 # - distinguish stdout and stderr output
  48 # - add environment variable like assignments
  49 # - run up to a specific line
  50 # - resume at a specific line
  51 #
  52
  53 use strict;
  54 use FileHandle;
  55 use Getopt::Std;
  56 use POSIX qw(isatty setuid getcwd);
  57 use vars qw($opt_l $opt_v);
  58
  59 no warnings qw(taint);
  60
  61 $opt_l = ~0;  # a really huge number
  62 getopts('l:v');
  63
  64 my ($OK, $FAILED) = ("ok", "failed");
  65 if (isatty(fileno(STDOUT))) {
  66         $OK = "\033[32m" . $OK . "\033[m";
  67         $FAILED = "\033[31m\033[1m" . $FAILED . "\033[m";
  68 }
  69
  70 $ENV{"TUSER"} = getpwuid($>);
  71 $ENV{"TGROUP"} = getgrgid($));
  72
  73 sub exec_test($$);
  74 sub process_test($$$$);
  75
  76 my ($prog, $in, $out) = ([], [], []);
  77 my $prog_line = 0;
  78 my ($tests, $failed) = (0,0);
  79 my $lineno;
  80 my $width = ($ENV{COLUMNS} || 80) >> 1;
  81
  82 for (;;) {
  83   my $line = <>; $lineno++;
  84   if (defined $line) {
  85     # Substitute %VAR and %{VAR} with environment variables.
  86     $line =~ s[%(\w+)][$ENV{$1}]eg;
  87     $line =~ s[%{(\w+)}][$ENV{$1}]eg;
  88   }
  89   if (defined $line) {
  90     if ($line =~ s/^\s*< ?//) {
  91       push @$in, $line;
  92     } elsif ($line =~ s/^\s*> ?//) {
  93       push @$out, $line;
  94     } else {
  95       process_test($prog, $prog_line, $in, $out);
  96       last if $prog_line >= $opt_l;
  97
  98       $prog = [];
  99       $prog_line = 0;
 100     }
 101     if ($line =~ s/^\s*\$ ?//) {
 102       $prog = [ map { s/\\(.)/$1/g; $_ } split /(?<!\\)\s+/, $line ];
 103       $prog_line = $lineno;
 104       $in = [];
 105       $out = [];
 106     }
 107   } else {
 108     process_test($prog, $prog_line, $in, $out);
 109     last;
 110   }
 111 }
 112
 113 my $status = sprintf("%d commands (%d passed, %d failed)",
 114         $tests, $tests-$failed, $failed);
 115 if (isatty(fileno(STDOUT))) {
 116         if ($failed) {
 117                 $status = "\033[31m\033[1m" . $status . "\033[m";
 118         } else {
 119                 $status = "\033[32m" . $status . "\033[m";
 120         }
 121 }
 122 print $status, "\n";
 123 exit $failed ? 1 : 0;
 124
 125
 126 sub process_test($$$$) {
 127   my ($prog, $prog_line, $in, $out) = @_;
 128
 129   return unless @$prog;
 130
 131        my $p = [ @$prog ];
 132        print "[$prog_line] \$ ", join(' ',
 133              map { s/\s/\\$&/g; $_ } @$p), " -- ";
 134        my $result = exec_test($prog, $in);
 135        my @good = ();
 136        my $nmax = (@$out > @$result) ? @$out : @$result;
 137        for (my $n=0; $n < $nmax; $n++) {
 138            my $use_re;
 139            if (defined $out->[$n] && $out->[$n] =~ /^~ /) {
 140                 $use_re = 1;
 141                 $out->[$n] =~ s/^~ //g;
 142            }
 143
 144            if (!defined($out->[$n]) || !defined($result->[$n]) ||
 145                (!$use_re && $result->[$n] ne $out->[$n]) ||
 146                ( $use_re && $result->[$n] !~ /^$out->[$n]/)) {
 147                push @good, ($use_re ? '!~' : '!=');
 148            }
 149            else {
 150                push @good, ($use_re ? '=~' : '==');
 151            }
 152        }
 153        my $good = !(grep /!/, @good);
 154        $tests++;
 155        $failed++ unless $good;
 156        print $good ? $OK : $FAILED, "\n";
 157        if (!$good || $opt_v) {
 158          for (my $n=0; $n < $nmax; $n++) {
 159            my $l = defined($out->[$n]) ? $out->[$n] : "~";
 160            chomp $l;
 161            my $r = defined($result->[$n]) ? $result->[$n] : "~";
 162            chomp $r;
 163            print sprintf("%-" . ($width-3) . "s %s %s\n",
 164                          $r, $good[$n], $l);
 165          }
 166        }
 167 }
 168
 169
 170 sub su($) {
 171   my ($user) = @_;
 172
 173   $user ||= "root";
 174
 175   my ($login, $pass, $uid, $gid) = getpwnam($user)
 176     or return [ "su: user $user does not exist\n" ];
 177   my @groups = ();
 178   my $fh = new FileHandle("/etc/group")
 179     or return [ "opening /etc/group: $!\n" ];
 180   while (<$fh>) {
 181     chomp;
 182     my ($group, $passwd, $gid, $users) = split /:/;
 183     foreach my $u (split /,/, $users) {
 184       push @groups, $gid
 185         if ($user eq $u);
 186     }
 187   }
 188   $fh->close;
 189
 190   my $groups = join(" ", ($gid, $gid, @groups));
 191   #print STDERR "[[$groups]]\n";
 192   $! = 0;  # reset errno
 193   $> = 0;
 194   $( = $gid;
 195   $) = $groups;
 196   if ($!) {
 197     return [ "su: $!\n" ];
 198   }
 199   if ($uid != 0) {
 200     $> = $uid;
 201     #$< = $uid;
 202     if ($!) {
 203       return [ "su: $prog->[1]: $!\n" ];
 204     }
 205   }
 206   #print STDERR "[($>,$<)($(,$))]";
 207   return [];
 208 }
 209
 210
 211 sub sg($) {
 212   my ($group) = @_;
 213
 214   my $gid = getgrnam($group)
 215     or return [ "sg: group $group does not exist\n" ];
 216   my %groups = map { $_ eq $gid ? () : ($_ => 1) } (split /\s/, $));
 217
 218   #print STDERR "<<", join("/", keys %groups), ">>\n";
 219   my $groups = join(" ", ($gid, $gid, keys %groups));
 220   #print STDERR "[[$groups]]\n";
 221   $! = 0;  # reset errno
 222   if ($> != 0) {
 223           my $uid = $>;
 224           $> = 0;
 225           $( = $gid;
 226           $) = $groups;
 227           $> = $uid;
 228   } else {
 229           $( = $gid;
 230           $) = $groups;
 231   }
 232   if ($!) {
 233     return [ "sg: $!\n" ];
 234   }
 235   print STDERR "[($>,$<)($(,$))]";
 236   return [];
 237 }
 238
 239
 240 sub exec_test($$) {
 241   my ($prog, $in) = @_;
 242   local (*IN, *IN_DUP, *IN2, *OUT_DUP, *OUT, *OUT2);
 243   my $needs_shell = (join('', @$prog) =~ /[][|<>"'`\$\*\?]/);
 244
 245   if ($prog->[0] eq "umask") {
 246     umask oct $prog->[1];
 247     return [];
 248   } elsif ($prog->[0] eq "cd") {
 249     if (!chdir $prog->[1]) {
 250       return [ "chdir: $prog->[1]: $!\n" ];
 251     }
 252     $ENV{PWD} = getcwd;
 253     return [];
 254   } elsif ($prog->[0] eq "su") {
 255     return su($prog->[1]);
 256   } elsif ($prog->[0] eq "sg") {
 257     return sg($prog->[1]);
 258   } elsif ($prog->[0] eq "export") {
 259     my ($name, $value) = split /=/, $prog->[1];
 260     # FIXME: need to evaluate $value, so that things like this will work:
 261     # export dir=$PWD/dir
 262     $ENV{$name} = $value;
 263     return [];
 264   } elsif ($prog->[0] eq "unset") {
 265     delete $ENV{$prog->[1]};
 266     return [];
 267   }
 268
 269   pipe *IN2, *OUT
 270     or die "Can't create pipe for reading: $!";
 271   open *IN_DUP, "<&STDIN"
 272     or *IN_DUP = undef;
 273   open *STDIN, "<&IN2"
 274     or die "Can't duplicate pipe for reading: $!";
 275   close *IN2;
 276
 277   open *OUT_DUP, ">&STDOUT"
 278     or die "Can't duplicate STDOUT: $!";
 279   pipe *IN, *OUT2
 280     or die "Can't create pipe for writing: $!";
 281   open *STDOUT, ">&OUT2"
 282     or die "Can't duplicate pipe for writing: $!";
 283   close *OUT2;
 284
 285   *STDOUT->autoflush();
 286   *OUT->autoflush();
 287
 288   if (fork()) {
 289     # Server
 290     if (*IN_DUP) {
 291       open *STDIN, "<&IN_DUP"
 292         or die "Can't duplicate STDIN: $!";
 293       close *IN_DUP
 294         or die "Can't close STDIN duplicate: $!";
 295     }
 296     open *STDOUT, ">&OUT_DUP"
 297       or die "Can't duplicate STDOUT: $!";
 298     close *OUT_DUP
 299       or die "Can't close STDOUT duplicate: $!";
 300
 301     foreach my $line (@$in) {
 302       #print "> $line";
 303       print OUT $line;
 304     }
 305     close *OUT
 306       or die "Can't close pipe for writing: $!";
 307
 308     my $result = [];
 309     while (<IN>) {
 310       #print "< $_";
 311       # remove libtool 'lt-' prefixes on prog name output
 312       s#^lt-##g;
 313       if ($needs_shell) {
 314         s#^/bin/sh: line \d+: ##;
 315       }
 316       push @$result, $_;
 317     }
 318     return $result;
 319   } else {
 320     # Client
 321     $< = $>;
 322     close IN
 323       or die "Can't close read end for input pipe: $!";
 324     close OUT
 325       or die "Can't close write end for output pipe: $!";
 326     close OUT_DUP
 327       or die "Can't close STDOUT duplicate: $!";
 328     local *ERR_DUP;
 329     open ERR_DUP, ">&STDERR"
 330       or die "Can't duplicate STDERR: $!";
 331     open STDERR, ">&STDOUT"
 332       or die "Can't join STDOUT and STDERR: $!";
 333
 334     if ($needs_shell) {
 335       exec ('/bin/sh', '-c', join(" ", @$prog));
 336     } else {
 337       exec @$prog;
 338     }
 339     print STDERR $prog->[0], ": $!\n";
 340     exit;
 341   }
 342 }
 343