1package File::CheckTree; 2 3use 5.006; 4use Cwd; 5use Exporter; 6use File::Spec; 7use warnings; 8use strict; 9 10our $VERSION = '4.3'; 11our @ISA = qw(Exporter); 12our @EXPORT = qw(validate); 13 14=head1 NAME 15 16validate - 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 35The validate() routine takes a single multiline string consisting of 36directives, 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 38to be interpreted relative to that directory.) After the file test 39you may put C<|| die> to make it a fatal error if the file test fails. 40The default is C<|| warn>. The file test may optionally have a "!' prepended 41to test for the opposite condition. If you do a cd and then list some 42relative filenames, you may want to indent them slightly for readability. 43If you supply your own die() or warn() message, you can use $file to 44interpolate the filename. 45 46Filetests may be bunched: "-rwx" tests for all of C<-r>, C<-w>, and C<-x>. 47Only the first failed test of the bunch will produce a warning. 48 49The routine returns the number of warnings issued. 50 51=head1 AUTHOR 52 53File::CheckTree was derived from lib/validate.pl which was 54written by Larry Wall. 55Revised by Paul Grassie <F<grassie@perl.com>> in 2002. 56 57=head1 HISTORY 58 59File::CheckTree used to not display fatal error messages. 60It 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, 62the validate() routine would leave the user program in whatever 63directory was last entered through the use of "cd" directives. 64These bugs were fixed during the development of perl 5.8. 65The first fixed version of File::CheckTree was 4.2. 66 67=cut 68 69my $Warnings; 70 71sub 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 180my %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 206sub 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 2291; 230