1 package File::CheckTree;
11 our @ISA = qw(Exporter);
12 our @EXPORT = qw(validate);
16 validate - run many filetest checks on a tree
22 $num_warnings = validate( q{
30 /usr -d || warn "What happened to $file?\n"
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.
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.
49 The routine returns the number of warnings issued.
53 Unknown. Revised by Paul Grassie <F<grassie@perl.com>> in 2002.
57 File::CheckTree used to not display fatal error messages.
58 It used to count only those warnings produced by a generic C<|| warn>
59 (and not those in which the user supplied the message). In addition,
60 the validate() routine would leave the user program in whatever
61 directory was last entered through the use of "cd" directives.
62 These bugs were fixed during the development of perl 5.8.
63 The first fixed version of File::CheckTree was 4.2.
70 my ($starting_dir, $file, $test, $cwd, $oldwarnings);
77 foreach my $check (split /\n/, $_[0]) {
78 my ($testlist, @testlist);
80 # skip blanks/comments
81 next if $check =~ /^\s*#/ || $check =~ /^\s*$/;
84 # should probably check for invalid directives and die
85 # but earlier versions of File::CheckTree did not do this either
87 # split a line like "/foo -r || die"
88 # so that $file is "/foo", $test is "-rwx || die"
89 ($file, $test) = split(' ', $check, 2); # special whitespace split
91 # change a $test like "!-ug || die" to "!-Z || die",
92 # capturing the bundled tests (e.g. "ug") in $2
93 if ($test =~ s/ ^ (!?-) (\w{2,}) \b /$1Z/x) {
95 # split bundled tests, e.g. "ug" to 'u', 'g'
96 @testlist = split(//, $testlist);
99 # put in placeholder Z for stand-alone test
103 # will compare these two later to stop on 1st warning w/in a bundle
104 $oldwarnings = $Warnings;
106 foreach my $one (@testlist) {
107 # examples of $test: "!-Z || die" or "-w || warn"
110 # expand relative $file to full pathname if preceded by cd directive
111 $file = File::Spec->catfile($cwd, $file)
112 if $cwd && !File::Spec->file_name_is_absolute($file);
114 # put filename in after the test operator
115 $this =~ s/(-\w\b)/$1 "\$file"/g;
117 # change the "-Z" representing a bundle with the $one test
118 $this =~ s/-Z/-$one/;
120 # if it's a "cd" directive...
121 if ($this =~ /^cd\b/) {
123 $this .= ' || die "cannot cd to $file\n"';
124 # expand "cd" directive with directory name
125 $this =~ s/\bcd\b/chdir(\$cwd = '$file')/;
128 # add "|| warn" as a default disposition
129 $this .= ' || warn' unless $this =~ /\|\|/;
131 # change a generic ".. || die" or ".. || warn"
132 # to call valmess instead of die/warn directly
133 # valmess will look up the error message from %Val_Message
134 $this =~ s/ ^ ( (\S+) \s+ \S+ ) \s* \|\| \s* (die|warn) \s* $
135 /$1 || valmess('$3', '$2', \$file)/x;
139 # count warnings, either from valmess or '-r || warn "my msg"'
140 # also, call any pre-existing signal handler for __WARN__
141 my $orig_sigwarn = $SIG{__WARN__};
142 local $SIG{__WARN__} = sub {
144 if ( $orig_sigwarn ) {
155 # re-raise an exception caused by a "... || die" test
157 # in case of any cd directives, return from whence we came
158 if ($starting_dir ne cwd) {
159 chdir($starting_dir) || die "$starting_dir: $!";
165 # stop on 1st warning within a bundle of tests
166 last if $Warnings > $oldwarnings;
170 # in case of any cd directives, return from whence we came
171 if ($starting_dir ne cwd) {
172 chdir($starting_dir) || die "chdir $starting_dir: $!";
179 'r' => "is not readable by uid $>.",
180 'w' => "is not writable by uid $>.",
181 'x' => "is not executable by uid $>.",
182 'o' => "is not owned by uid $>.",
183 'R' => "is not readable by you.",
184 'W' => "is not writable by you.",
185 'X' => "is not executable by you.",
186 'O' => "is not owned by you.",
187 'e' => "does not exist.",
188 'z' => "does not have zero size.",
189 's' => "does not have non-zero size.",
190 'f' => "is not a plain file.",
191 'd' => "is not a directory.",
192 'l' => "is not a symbolic link.",
193 'p' => "is not a named pipe (FIFO).",
194 'S' => "is not a socket.",
195 'b' => "is not a block special file.",
196 'c' => "is not a character special file.",
197 'u' => "does not have the setuid bit set.",
198 'g' => "does not have the setgid bit set.",
199 'k' => "does not have the sticky bit set.",
200 'T' => "is not a text file.",
201 'B' => "is not a binary file."
205 my ($disposition, $test, $file) = @_;
208 if ($test =~ / ^ (!?) -(\w) \s* $ /x) {
209 my ($neg, $ftype) = ($1, $2);
211 $ferror = "$file $Val_Message{$ftype}";
214 $ferror =~ s/ is not / should not be / ||
215 $ferror =~ s/ does not / should not / ||
216 $ferror =~ s/ not / /;
220 $ferror = "Can't do $test $file.\n";
223 die "$ferror\n" if $disposition eq 'die';