#!/usr/bin/perl
=begin metadata
Name: test
Description: condition evaluation utility
Author: Brad Appleton
License: perl
=end metadata
=cut
###########################################################################
# test -- Perl script to emulate BSD Unix test(1) functionality
# (with slightly more informative error messages).
#
# Copyright (c) 1999 Brad Appleton. All rights reserved.
#
# This file is part of "Perl Power Tools: the Unix Reconstruction
# Project" (PPT) which is free software. You can redistribute it
# and/or modify it under the same terms as PPT itself.
#
###########################################################################
package PerlPowerTools::test;
use strict;
#use diagnostics;
use vars qw($VERSION);
$VERSION = 1.01;
## Set to 0 to disable debug output; non-zero to enable it
my $DEBUG = $ENV{DEBUG_PPT_TEST} || 0;
sub dbval($) {
local $_ = shift;
return '<undef>' unless defined;
return ($_ ? "true" : "false") if /^\d+$/;
return (/^-\w/ ? $_ : "'$_'");
}
## Keep track of errors/warnings
my $ERRORS = 0;
$SIG{__WARN__} = sub { print STDERR "test: $_[0]"; ++$ERRORS; };
$SIG{__DIE__} = sub { print STDERR "test: $_[0]"; exit 2; };
## Complain about an invalid argument
sub bad_arg(@) { warn "invalid argument @_\n"; }
## Make sure we have a numeric value
sub number($) {
local $_ = shift;
return $_ if (defined && /^[-+]?\d+$/);
bad_arg "'$_[0]' - expecting a number";
return undef;
}
## %TEST_OPS maps test(1) operators or operations to Perl operations
## If a value is a string, the string is returned. If it is a reference,
## then its assumed to be a reference to a subroutine, and the value
## is whatever the subroutine returns.
##
## The code doing the lookup is responsible for passing the correct
## number of parameters and interpreting the result.
##
my %TEST_OPS = (
## Logical/grouping operators ('-a' has higher precedence than '-o')
'(' => '(',
')' => ')',
'!' => '!',
'-a' => '&&',
'-o' => '||',
## NOTE: are && and || 'compatibility' or feature creep?
'&&' => '&&',
'||' => '||',
## File test operators
'-b' => sub { -b $_[0] },
'-c' => sub { -c $_[0] },
'-d' => sub { -d $_[0] },
'-e' => sub { -e $_[0] },
'-f' => sub { -f $_[0] },
'-g' => sub { -g $_[0] },
'-h' => sub { -l $_[0] },
'-k' => sub { -k $_[0] },
'-l' => sub { -l $_[0] },
'-p' => sub { -p $_[0] },
'-r' => sub { -r $_[0] },
'-s' => sub { -s $_[0] },
'-t' => sub { -t (number($_[0])||0) },
'-u' => sub { -u $_[0] },
'-w' => sub { -w $_[0] },
'-x' => sub { -x $_[0] },
'-B' => sub { -B $_[0] },
'-L' => sub { -l $_[0] },
'-O' => sub { -O $_[0] },
'-G' => sub { bad_arg("'-G' - operator not supported") },
'-R' => sub { -R $_[0] },
'-S' => sub { -S $_[0] },
'-T' => sub { -T $_[0] },
'-W' => sub { -W $_[0] },
'-X' => sub { -X $_[0] },
## String comparisons
'-n' => sub { length $_[0] },
'-z' => sub { ! length $_[0] },
'=' => sub { $_[0] eq $_[1] },
'!=' => sub { $_[0] ne $_[1] },
'<' => sub { $_[0] lt $_[1] },
'>' => sub { $_[0] gt $_[1] },
## NOTE: are ==, <=, and >= 'compatibility' or feature creep?
'==' => sub { $_[0] eq $_[1] },
'<=' => sub { $_[0] le $_[1] },
'>=' => sub { $_[0] ge $_[1] },
## Numeric comparisons
'-eq' => sub { (number($_[0])||0) == (number($_[1])||0) },
'-ne' => sub { (number($_[0])||0) != (number($_[1])||0) },
'-lt' => sub { (number($_[0])||0) < (number($_[1])||0) },
'-le' => sub { (number($_[0])||0) <= (number($_[1])||0) },
'-gt' => sub { (number($_[0])||0) > (number($_[1])||0) },
'-ge' => sub { (number($_[0])||0) >= (number($_[1])||0) },
## File comparisons
'-nt' => sub { -M $_[0] < -M $_[1] },
'-ot' => sub { -M $_[0] > -M $_[1] },
'-ef' => sub { bad_arg("'-ef' - operator not supported") },
);
## Apply a test operator to the given arguments
sub apply_op ($;@) {
my $test_op = shift;
my $perl_op = $TEST_OPS{$test_op};
my $result = undef;
if (defined $perl_op) {
$result = (ref $perl_op) ? 0+&{$perl_op}(@_) : $perl_op;
}
else {
## NOTE: should this be an error, or should it be the
## same as saying "-n $test_op"?
warn "invalid operator '$test_op'\n";
}
return $result;
}
## Evaluate test(1) operations and their operands.
## Returns 'undef' upon error, 0 false, !0 for true
sub test (@) {
my @terms = ();
local $_ = "";
my $grouping = 0;
my $need_expr = 1;
while (@_ > 0) {
$_ = shift;
next if m/[\[;\]]/; ## ignore '[', ']', and ';'
if (/^[\(\)!]$/) {
## grouping and negation
if ($_ eq ')') {
--$grouping;
bad_arg "'$_' - unbalanced parentheses" if ($grouping < 0);
push @terms, 0 if ($need_expr);
$need_expr = 0;
}
else {
++$grouping if ($_ eq '(');
bad_arg "'$_' - expecting '-a' or '-o'" unless ($need_expr);
}
$DEBUG and printf ">>> %s", $_;
push @terms, apply_op($_);
}
elsif (/^(?: -[ao] | \|\| | \&\& )$/x) {
## and/or operators
bad_arg "'$_' - expression expected" if ($need_expr);
$DEBUG and printf ">>> %s", $_;
push @terms, apply_op($_);
$need_expr = 1;
}
elsif ($_ eq '-t' and (@_ == 0 or !defined(number $_[0]))) {
## '-t' with no argument
bad_arg "'$_' - expecting '-a' or '-o'" unless ($need_expr);
$DEBUG and printf ">>> %s", $_;
push @terms, 0+(-t );
$need_expr = 0;
}
elsif (/^-\w$/) {
## file tests and string length/existence operators
bad_arg "'$_' - expecting '-a' or '-o'" unless ($need_expr);
warn "argument expected after '$_'\n" if (@_ == 0);
if (@_ > 0) {
$DEBUG and printf ">>> %s %s", $_, $_[0];
push @terms, apply_op($_, shift);
$need_expr = 0;
}
}
elsif (@_ and $_[0] =~ /^(?: -[a-z]{2} | [=!]?= | [<>]=? )$/x) {
## We have a string or a filename that participates
## in a binary infix operation.
bad_arg "'$_' - expecting '-a' or '-o'" unless ($need_expr);
warn "argument expected after '${\shift()}'\n" if (@_ < 2);
if (@_ >= 2) {
$DEBUG and printf ">>> %s %s %s", $_, @_[0..1];
push @terms, apply_op(shift, $_, shift);
$need_expr = 0;
}
}
else {
## We have a lone string, so "-n string" is implied.
bad_arg "'$_' - expecting '-a' or '-o'" unless ($need_expr);
$DEBUG and printf ">>> %s", dbval $_;
push @terms, length;
$need_expr = 0;
}
$DEBUG and @terms and printf " ==> %s\n", dbval($terms[-1]);
}
## Check for errors so far
warn "too many open '(' parentheses\n" if ($grouping > 0);
return undef if $ERRORS;
## Now we have all our primitive terms evaluated, compute the result.
$DEBUG and print ">>>expression is: @terms\n";
return $terms[0] if (@terms == 1 and $terms[0] =~ /^\d*$/);
my $result = eval "@terms";
warn "$@" if ($@ and !$ERRORS);
return ($@) ? undef : 0+$result;
}
exit(1) if (@ARGV == 0);
my $rc = test @ARGV;
## For command-lines, zero is success and non-zero is false, so
## we need to interpret the return code into an exit status.
exit(defined($rc) ? !$rc : 2);
__END__
=head1 NAME
test - condition evaluation utility
=head1 SYNOPSIS
test expression
[ expression ]
=head1 DESCRIPTION
The B<test> utility evaluates the I<expression> and, if it evaluates
to true, returns a zero (true) exit status; otherwise it returns 1
(false). If no expression is given, B<test> also returns 1 (false).
All operators and flags are separate arguments to the test utility.
The following primaries are used to construct expression:
=over 14
=item B<-b> I<file>
True if file exists and is a block special file.
=item B<-c> I<file>
True if file exists and is a character special file.
=item B<-d> I<file>
True if file exists and is a directory.
=item B<-e> I<file>
True if file exists (regardless of type).
=item B<-f> I<file>
True if file exists and is a regular file.
=item B<-g> I<file>
True if file exists and its set-group-ID flag is set.
=item B<-h> I<file>
True if file exists and is a symbolic link. This operator is for
COMPATABILITY purposes, do not rely on its existence. Use B<-L> instead.
=item B<-k> I<file>
True if file exists and its sticky bit is set.
=item B<-n> I<string>
True if the length of string is nonzero.
=item B<-p> I<file>
True if file is a named pipe (FIFO).
=item B<-r> I<file>
True if file exists and is readable by the effective user/group.
=item B<-s> I<file>
True if file exists and has a size greater than zero.
=item B<-t> I<file_descriptor>
True if the file whose file descriptor number is I<file_descriptor> is
open and is associated with a terminal.
=item B<-t>
Same as above with an implicit file descriptor number of "1"
(e.g.: B<-t> 1).
=item B<-u> I<file>
True if file exists and its set-user-ID flag is set.
=item B<-w> I<file>
True if file exists and is writable by the effective user/group. True
indicates only that the write flag is on. The file is not writable on
a read-only file system even if this test indicates true.
=item B<-x> I<file>
True if file exists and is executable by the effective user/group.
True indicates only that the execute flag is on. If file is a
directory, true indicates that file can be searched.
=item B<-z> I<string>
True if the length of string is zero.
=item B<-B> I<file>
True if file exists and is a binary file.
=item B<-L> I<file>
True if file exists and is a symbolic link.
=item B<-O> I<file>
True if file exists and its owner matches the effective user ID of this
process.
=begin _NOT_IMPLEMENTED_
=item B<-G> I<file>
True if file exists and its group matches the effective
group ID of this process.
=end _NOT_IMPLEMENTED_
=item B<-R> I<file>
True if file exists and is readable by the real user/group.
=item B<-S> I<file>
True if file exists and is a socket.
=item B<-T> I<file>
True if file exists and is a text file.
=item B<-W> I<file>
True if file exists and is writable by the real user/group. True
indicates only that the write flag is on. The file is not writable on
a read-only file system even if this test indicates true.
=item B<-X> I<file>
True if file exists and is executable by the real user/group.
True indicates only that the execute flag is on. If file is a
directory, true indicates that file can be searched.
=item I<file1> B<-nt> I<file2>
True if I<file1> exists and is newer than I<file2>.
=item I<file1> B<-ot> I<file2>
True if I<file1> exists and is older than I<file2>.
=begin _NOT_IMPLEMENTED_
=item I<file1> B<-ef> I<file2>
True if I<file1> and I<file2> exist and refer to the same file.
=end _NOT_IMPLEMENTED_
=item I<string>
True if I<string> is not the null string.
=item I<s1> = I<s2>
True if the strings I<s1> and I<s2> are identical.
=item I<s1> != I<s2>
True if the strings I<s1> and I<s2> are not identical.
=item I<s1> < I<s2>
True if string I<s1> comes before I<s2> based on the ASCII value
of their characters.
=item I<s1> > I<s2>
True if string I<s1> comes after I<s2> based on the ASCII value
of their characters.
=item I<s1>
True if I<s1> is not the null string.
=item I<n1> B<-eq> I<n2>
True if the integers I<n1> and I<n2> are algebraically equal.
=item I<n1> B<-ne> I<n2>
True if the integers I<n1> and I<n2> are not algebraically equal.
=item I<n1> B<-gt> I<n2>
True if the integer I<n1> is algebraically greater than the
integer I<n2>.
=item I<n1> B<-ge> I<n2>
True if the integer I<n1> is algebraically greater than or
equal to the integer I<n2>.
=item I<n1> B<-lt> I<n2>
True if the integer I<n1> is algebraically less than the integer I<n2>.
=item I<n1> B<-le> I<n2>
True if the integer I<n1> is algebraically less than or equal
to the integer I<n2>.
=back
These primaries can be combined with the following operators:
=over 14
=item ! I<expression>
True if I<expression> is false.
=item I<expression1> B<-a> I<expression2>
True if both I<expression1> and I<expression2> are true.
=item I<expression1> B<-o> I<expression2>
True if either I<expression1> or I<expression2> are true.
=item (I<expression>)
True if I<expression> is true (uses parentheses for grouping).
=back
Note that the B<-a> operator has higher precedence than the B<-o> operator.
Notice also that all the operators and flags are separate arguments to test.
=head1 RETURN VALUES
The test utility exits with one of the following values:
=over 8
=item $return_val == 0
Expression evaluated to true.
=item $return_val == 1
Expression evaluated to false or expression was missing.
=item $return_val > 1
An error occurred.
=back
=head1 CAVEATS
Command line arguments like parentheses and arithmetic operators
(e.g.: '(', ')', '!', '>', '<', etc.) I<may> be meaningful to the
command-line interpreter (shell) and therefore I<may> need to be
escaped from any special shell interpretation.
=head1 SEE ALSO
L<sh>, L<find>
=cut