| 1 |
package File::CheckTree; |
| 2 |
|
| 3 |
use 5.006; |
| 4 |
use Cwd; |
| 5 |
use Exporter; |
| 6 |
use File::Spec; |
| 7 |
use warnings; |
| 8 |
use strict; |
| 9 |
|
| 10 |
our $VERSION = '4.3'; |
| 11 |
our @ISA = qw(Exporter); |
| 12 |
our @EXPORT = qw(validate); |
| 13 |
|
| 14 |
=head1 NAME |
| 15 |
|
| 16 |
validate - run many filetest checks on a tree |
| 17 |
|
| 18 |
=head1 SYNOPSIS |
| 19 |
|
| 20 |
use File::CheckTree; |
| 21 |
|
| 22 |
$num_warnings = validate( q{ |
| 23 |
/vmunix -e || die |
| 24 |
/boot -e || die |
| 25 |
/bin cd |
| 26 |
csh -ex |
| 27 |
csh !-ug |
| 28 |
sh -ex |
| 29 |
sh !-ug |
| 30 |
/usr -d || warn "What happened to $file?\n" |
| 31 |
}); |
| 32 |
|
| 33 |
=head1 DESCRIPTION |
| 34 |
|
| 35 |
The validate() routine takes a single multiline string consisting of |
| 36 |
directives, each containing a filename plus a file test to try on it. |
| 37 |
(The file test may also be a "cd", causing subsequent relative filenames |
| 38 |
to be interpreted relative to that directory.) After the file test |
| 39 |
you may put C<|| die> to make it a fatal error if the file test fails. |
| 40 |
The default is C<|| warn>. The file test may optionally have a "!' prepended |
| 41 |
to test for the opposite condition. If you do a cd and then list some |
| 42 |
relative filenames, you may want to indent them slightly for readability. |
| 43 |
If you supply your own die() or warn() message, you can use $file to |
| 44 |
interpolate the filename. |
| 45 |
|
| 46 |
Filetests may be bunched: "-rwx" tests for all of C<-r>, C<-w>, and C<-x>. |
| 47 |
Only the first failed test of the bunch will produce a warning. |
| 48 |
|
| 49 |
The routine returns the number of warnings issued. |
| 50 |
|
| 51 |
=head1 AUTHOR |
| 52 |
|
| 53 |
File::CheckTree was derived from lib/validate.pl which was |
| 54 |
written by Larry Wall. |
| 55 |
Revised by Paul Grassie <F<grassie@perl.com>> in 2002. |
| 56 |
|
| 57 |
=head1 HISTORY |
| 58 |
|
| 59 |
File::CheckTree used to not display fatal error messages. |
| 60 |
It used to count only those warnings produced by a generic C<|| warn> |
| 61 |
(and not those in which the user supplied the message). In addition, |
| 62 |
the validate() routine would leave the user program in whatever |
| 63 |
directory was last entered through the use of "cd" directives. |
| 64 |
These bugs were fixed during the development of perl 5.8. |
| 65 |
The first fixed version of File::CheckTree was 4.2. |
| 66 |
|
| 67 |
=cut |
| 68 |
|
| 69 |
my $Warnings; |
| 70 |
|
| 71 |
sub validate { |
| 72 |
my ($starting_dir, $file, $test, $cwd, $oldwarnings); |
| 73 |
|
| 74 |
$starting_dir = cwd; |
| 75 |
|
| 76 |
$cwd = ""; |
| 77 |
$Warnings = 0; |
| 78 |
|
| 79 |
foreach my $check (split /\n/, $_[0]) { |
| 80 |
my ($testlist, @testlist); |
| 81 |
|
| 82 |
# skip blanks/comments |
| 83 |
next if $check =~ /^\s*#/ || $check =~ /^\s*$/; |
| 84 |
|
| 85 |
# Todo: |
| 86 |
# should probably check for invalid directives and die |
| 87 |
# but earlier versions of File::CheckTree did not do this either |
| 88 |
|
| 89 |
# split a line like "/foo -r || die" |
| 90 |
# so that $file is "/foo", $test is "-rwx || die" |
| 91 |
($file, $test) = split(' ', $check, 2); # special whitespace split |
| 92 |
|
| 93 |
# change a $test like "!-ug || die" to "!-Z || die", |
| 94 |
# capturing the bundled tests (e.g. "ug") in $2 |
| 95 |
if ($test =~ s/ ^ (!?-) (\w{2,}) \b /$1Z/x) { |
| 96 |
$testlist = $2; |
| 97 |
# split bundled tests, e.g. "ug" to 'u', 'g' |
| 98 |
@testlist = split(//, $testlist); |
| 99 |
} |
| 100 |
else { |
| 101 |
# put in placeholder Z for stand-alone test |
| 102 |
@testlist = ('Z'); |
| 103 |
} |
| 104 |
|
| 105 |
# will compare these two later to stop on 1st warning w/in a bundle |
| 106 |
$oldwarnings = $Warnings; |
| 107 |
|
| 108 |
foreach my $one (@testlist) { |
| 109 |
# examples of $test: "!-Z || die" or "-w || warn" |
| 110 |
my $this = $test; |
| 111 |
|
| 112 |
# expand relative $file to full pathname if preceded by cd directive |
| 113 |
$file = File::Spec->catfile($cwd, $file) |
| 114 |
if $cwd && !File::Spec->file_name_is_absolute($file); |
| 115 |
|
| 116 |
# put filename in after the test operator |
| 117 |
$this =~ s/(-\w\b)/$1 "\$file"/g; |
| 118 |
|
| 119 |
# change the "-Z" representing a bundle with the $one test |
| 120 |
$this =~ s/-Z/-$one/; |
| 121 |
|
| 122 |
# if it's a "cd" directive... |
| 123 |
if ($this =~ /^cd\b/) { |
| 124 |
# add "|| die ..." |
| 125 |
$this .= ' || die "cannot cd to $file\n"'; |
| 126 |
# expand "cd" directive with directory name |
| 127 |
$this =~ s/\bcd\b/chdir(\$cwd = '$file')/; |
| 128 |
} |
| 129 |
else { |
| 130 |
# add "|| warn" as a default disposition |
| 131 |
$this .= ' || warn' unless $this =~ /\|\|/; |
| 132 |
|
| 133 |
# change a generic ".. || die" or ".. || warn" |
| 134 |
# to call valmess instead of die/warn directly |
| 135 |
# valmess will look up the error message from %Val_Message |
| 136 |
$this =~ s/ ^ ( (\S+) \s+ \S+ ) \s* \|\| \s* (die|warn) \s* $ |
| 137 |
/$1 || valmess('$3', '$2', \$file)/x; |
| 138 |
} |
| 139 |
|
| 140 |
{ |
| 141 |
# count warnings, either from valmess or '-r || warn "my msg"' |
| 142 |
# also, call any pre-existing signal handler for __WARN__ |
| 143 |
my $orig_sigwarn = $SIG{__WARN__}; |
| 144 |
local $SIG{__WARN__} = sub { |
| 145 |
++$Warnings; |
| 146 |
if ( $orig_sigwarn ) { |
| 147 |
$orig_sigwarn->(@_); |
| 148 |
} |
| 149 |
else { |
| 150 |
warn "@_"; |
| 151 |
} |
| 152 |
}; |
| 153 |
|
| 154 |
# do the test |
| 155 |
eval $this; |
| 156 |
|
| 157 |
# re-raise an exception caused by a "... || die" test |
| 158 |
if ($@) { |
| 159 |
# in case of any cd directives, return from whence we came |
| 160 |
if ($starting_dir ne cwd) { |
| 161 |
chdir($starting_dir) || die "$starting_dir: $!"; |
| 162 |
} |
| 163 |
die $@ if $@; |
| 164 |
} |
| 165 |
} |
| 166 |
|
| 167 |
# stop on 1st warning within a bundle of tests |
| 168 |
last if $Warnings > $oldwarnings; |
| 169 |
} |
| 170 |
} |
| 171 |
|
| 172 |
# in case of any cd directives, return from whence we came |
| 173 |
if ($starting_dir ne cwd) { |
| 174 |
chdir($starting_dir) || die "chdir $starting_dir: $!"; |
| 175 |
} |
| 176 |
|
| 177 |
return $Warnings; |
| 178 |
} |
| 179 |
|
| 180 |
my %Val_Message = ( |
| 181 |
'r' => "is not readable by uid $>.", |
| 182 |
'w' => "is not writable by uid $>.", |
| 183 |
'x' => "is not executable by uid $>.", |
| 184 |
'o' => "is not owned by uid $>.", |
| 185 |
'R' => "is not readable by you.", |
| 186 |
'W' => "is not writable by you.", |
| 187 |
'X' => "is not executable by you.", |
| 188 |
'O' => "is not owned by you.", |
| 189 |
'e' => "does not exist.", |
| 190 |
'z' => "does not have zero size.", |
| 191 |
's' => "does not have non-zero size.", |
| 192 |
'f' => "is not a plain file.", |
| 193 |
'd' => "is not a directory.", |
| 194 |
'l' => "is not a symbolic link.", |
| 195 |
'p' => "is not a named pipe (FIFO).", |
| 196 |
'S' => "is not a socket.", |
| 197 |
'b' => "is not a block special file.", |
| 198 |
'c' => "is not a character special file.", |
| 199 |
'u' => "does not have the setuid bit set.", |
| 200 |
'g' => "does not have the setgid bit set.", |
| 201 |
'k' => "does not have the sticky bit set.", |
| 202 |
'T' => "is not a text file.", |
| 203 |
'B' => "is not a binary file." |
| 204 |
); |
| 205 |
|
| 206 |
sub valmess { |
| 207 |
my ($disposition, $test, $file) = @_; |
| 208 |
my $ferror; |
| 209 |
|
| 210 |
if ($test =~ / ^ (!?) -(\w) \s* $ /x) { |
| 211 |
my ($neg, $ftype) = ($1, $2); |
| 212 |
|
| 213 |
$ferror = "$file $Val_Message{$ftype}"; |
| 214 |
|
| 215 |
if ($neg eq '!') { |
| 216 |
$ferror =~ s/ is not / should not be / || |
| 217 |
$ferror =~ s/ does not / should not / || |
| 218 |
$ferror =~ s/ not / /; |
| 219 |
} |
| 220 |
} |
| 221 |
else { |
| 222 |
$ferror = "Can't do $test $file.\n"; |
| 223 |
} |
| 224 |
|
| 225 |
die "$ferror\n" if $disposition eq 'die'; |
| 226 |
warn "$ferror\n"; |
| 227 |
} |
| 228 |
|
| 229 |
1; |
