4 # Possible improvements:
6 # - distinguish stdout and stderr output
7 # - add environment variable like assignments
8 # - run up to a specific line
9 # - resume at a specific line
15 use POSIX qw(isatty setuid getcwd);
16 use vars qw($opt_l $opt_v);
18 no warnings qw(taint);
20 $opt_l = ~0; # a really huge number
23 my ($OK, $FAILED) = ("ok", "failed");
24 if (isatty(fileno(STDOUT))) {
25 $OK = "\033[32m" . $OK . "\033[m";
26 $FAILED = "\033[31m\033[1m" . $FAILED . "\033[m";
30 sub process_test($$$$);
32 my ($prog, $in, $out) = ([], [], []);
34 my ($tests, $failed) = (0,0);
36 my $width = ($ENV{COLUMNS} || 80) >> 1;
39 my $line = <>; $lineno++;
41 # Substitute %VAR and %{VAR} with environment variables.
42 $line =~ s[%(\w+)][$ENV{$1}]eg;
43 $line =~ s[%{(\w+)}][$ENV{$1}]eg;
46 if ($line =~ s/^\s*< ?//) {
48 } elsif ($line =~ s/^\s*> ?//) {
51 process_test($prog, $prog_line, $in, $out);
52 last if $prog_line >= $opt_l;
57 if ($line =~ s/^\s*\$ ?//) {
58 $line =~ s/\s+#.*//; # remove comments here...
59 $prog = [ map { s/\\(.)/$1/g; $_ } split /(?<!\\)\s+/, $line ];
65 process_test($prog, $prog_line, $in, $out);
70 my $status = sprintf("%d commands (%d passed, %d failed)",
71 $tests, $tests-$failed, $failed);
72 if (isatty(fileno(STDOUT))) {
74 $status = "\033[31m\033[1m" . $status . "\033[m";
76 $status = "\033[32m" . $status . "\033[m";
83 sub process_test($$$$) {
84 my ($prog, $prog_line, $in, $out) = @_;
89 print "[$prog_line] \$ ", join(' ',
90 map { s/\s/\\$&/g; $_ } @$p), " -- ";
91 my $result = exec_test($prog, $in);
93 my $nmax = (@$out > @$result) ? @$out : @$result;
94 for (my $n=0; $n < $nmax; $n++) {
96 if (defined $out->[$n] && $out->[$n] =~ /^~ /) {
98 $out->[$n] =~ s/^~ //g;
101 if (!defined($out->[$n]) || !defined($result->[$n]) ||
102 (!$use_re && $result->[$n] ne $out->[$n]) ||
103 ( $use_re && $result->[$n] !~ /^$out->[$n]/)) {
104 push @good, ($use_re ? '!~' : '!=');
107 push @good, ($use_re ? '=~' : '==');
110 my $good = !(grep /!/, @good);
112 $failed++ unless $good;
113 print $good ? $OK : $FAILED, "\n";
114 if (!$good || $opt_v) {
115 for (my $n=0; $n < $nmax; $n++) {
116 my $l = defined($out->[$n]) ? $out->[$n] : "~";
118 my $r = defined($result->[$n]) ? $result->[$n] : "~";
120 print sprintf("%-" . ($width-3) . "s %s %s\n",
132 my ($login, $pass, $uid, $gid) = getpwnam($user)
133 or return [ "su: user $user does not exist\n" ];
135 my $fh = new FileHandle("/etc/group")
136 or return [ "opening /etc/group: $!\n" ];
139 my ($group, $passwd, $gid, $users) = split /:/;
140 foreach my $u (split /,/, $users) {
147 my $groups = join(" ", ($gid, $gid, @groups));
148 #print STDERR "[[$groups]]\n";
149 $! = 0; # reset errno
154 return [ "su: $!\n" ];
160 return [ "su: $prog->[1]: $!\n" ];
163 #print STDERR "[($>,$<)($(,$))]";
171 my $gid = getgrnam($group)
172 or return [ "sg: group $group does not exist\n" ];
173 my %groups = map { $_ eq $gid ? () : ($_ => 1) } (split /\s/, $));
175 #print STDERR "<<", join("/", keys %groups), ">>\n";
176 my $groups = join(" ", ($gid, $gid, keys %groups));
177 #print STDERR "[[$groups]]\n";
178 $! = 0; # reset errno
190 return [ "sg: $!\n" ];
192 print STDERR "[($>,$<)($(,$))]";
198 my ($prog, $in) = @_;
199 local (*IN, *IN_DUP, *IN2, *OUT_DUP, *OUT, *OUT2);
200 my $needs_shell = (join('', @$prog) =~ /[][|<>"'`\$\*\?]/);
202 if ($prog->[0] eq "umask") {
203 umask oct $prog->[1];
205 } elsif ($prog->[0] eq "cd") {
206 if (!chdir $prog->[1]) {
207 return [ "chdir: $prog->[1]: $!\n" ];
211 } elsif ($prog->[0] eq "su") {
212 return su($prog->[1]);
213 } elsif ($prog->[0] eq "sg") {
214 return sg($prog->[1]);
215 } elsif ($prog->[0] eq "export") {
216 my ($name, $value) = split /=/, $prog->[1];
217 # FIXME: need to evaluate $value, so that things like this will work:
218 # export dir=$PWD/dir
219 $ENV{$name} = $value;
221 } elsif ($prog->[0] eq "unset") {
222 delete $ENV{$prog->[1]};
227 or die "Can't create pipe for reading: $!";
228 open *IN_DUP, "<&STDIN"
231 or die "Can't duplicate pipe for reading: $!";
234 open *OUT_DUP, ">&STDOUT"
235 or die "Can't duplicate STDOUT: $!";
237 or die "Can't create pipe for writing: $!";
238 open *STDOUT, ">&OUT2"
239 or die "Can't duplicate pipe for writing: $!";
242 *STDOUT->autoflush();
248 open *STDIN, "<&IN_DUP"
249 or die "Can't duplicate STDIN: $!";
251 or die "Can't close STDIN duplicate: $!";
253 open *STDOUT, ">&OUT_DUP"
254 or die "Can't duplicate STDOUT: $!";
256 or die "Can't close STDOUT duplicate: $!";
258 foreach my $line (@$in) {
263 or die "Can't close pipe for writing: $!";
269 s#^/bin/sh: line \d+: ##;
278 or die "Can't close read end for input pipe: $!";
280 or die "Can't close write end for output pipe: $!";
282 or die "Can't close STDOUT duplicate: $!";
284 open ERR_DUP, ">&STDERR"
285 or die "Can't duplicate STDERR: $!";
286 open STDERR, ">&STDOUT"
287 or die "Can't join STDOUT and STDERR: $!";
290 exec ('/bin/sh', '-c', join(" ", @$prog));
294 print STDERR $prog->[0], ": $!\n";