lib/File/CheckTree.pm

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