| 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; |