package File::CheckTree;
use 5.006;
-use Exporter;
use Cwd;
+use Exporter;
+use File::Spec;
use warnings;
use strict;
-our $VERSION = '4.2';
+our $VERSION = '4.3';
our @ISA = qw(Exporter);
our @EXPORT = qw(validate);
=head1 NAME
-validate - run many filetest checks on a tree
+File::CheckTree - run many filetest checks on a tree
=head1 SYNOPSIS
=head1 AUTHOR
-Unknown. Revised by Paul Grassie <F<grassie@perl.com>> in 2002.
+File::CheckTree was derived from lib/validate.pl which was
+written by Larry Wall.
+Revised by Paul Grassie <F<grassie@perl.com>> in 2002.
=head1 HISTORY
# but earlier versions of File::CheckTree did not do this either
# split a line like "/foo -r || die"
- # so that $file is "/foo", $test is "-rwx || die"
- ($file, $test) = split(' ', $check, 2); # special whitespace split
+ # so that $file is "/foo", $test is "-r || die"
+ # (making special allowance for quoted filenames).
+ if ($check =~ m/^\s*"([^"]+)"\s+(.*?)\s*$/ or
+ $check =~ m/^\s*'([^']+)'\s+(.*?)\s*$/ or
+ $check =~ m/^\s*(\S+?)\s+(\S.*?)\s*$/)
+ {
+ ($file, $test) = ($1,$2);
+ }
+ else {
+ die "Malformed line: '$check'";
+ };
# change a $test like "!-ug || die" to "!-Z || die",
# capturing the bundled tests (e.g. "ug") in $2
my $this = $test;
# expand relative $file to full pathname if preceded by cd directive
- $file = $cwd . '/' . $file if $cwd && $file !~ m|^/|;
+ $file = File::Spec->catfile($cwd, $file)
+ if $cwd && !File::Spec->file_name_is_absolute($file);
# put filename in after the test operator
- $this =~ s/(-\w\b)/$1 "$file"/g;
+ $this =~ s/(-\w\b)/$1 "\$file"/g;
# change the "-Z" representing a bundle with the $one test
$this =~ s/-Z/-$one/;
# to call valmess instead of die/warn directly
# valmess will look up the error message from %Val_Message
$this =~ s/ ^ ( (\S+) \s+ \S+ ) \s* \|\| \s* (die|warn) \s* $
- /$1 || valmess('$3', '$2', '$file')/x;
+ /$1 || valmess('$3', '$2', \$file)/x;
}
{
eval $this;
# re-raise an exception caused by a "... || die" test
- if ($@) {
+ if (my $err = $@) {
# in case of any cd directives, return from whence we came
if ($starting_dir ne cwd) {
chdir($starting_dir) || die "$starting_dir: $!";
}
- die $@ if $@;
+ die $err;
}
}
# in case of any cd directives, return from whence we came
if ($starting_dir ne cwd) {
- chdir($starting_dir) || die "$starting_dir: $!";
+ chdir($starting_dir) || die "chdir $starting_dir: $!";
}
return $Warnings;