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