lib/File/CheckTree.pm

   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.2';
  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 Unknown.  Revised by Paul Grassie <F<grassie@perl.com>> in 2002.
  54
  55 =head1 HISTORY
  56
  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.
  64
  65 =cut
  66
  67 my $Warnings;
  68
  69 sub validate {
  70     my ($starting_dir, $file, $test, $cwd, $oldwarnings);
  71
  72     $starting_dir = cwd;
  73
  74     $cwd = "";
  75     $Warnings = 0;
  76
  77     foreach my $check (split /\n/, $_[0]) {
  78         my ($testlist, @testlist);
  79
  80         # skip blanks/comments
  81         next if $check =~ /^\s*#/ || $check =~ /^\s*$/;
  82
  83         # Todo:
  84         # should probably check for invalid directives and die
  85         # but earlier versions of File::CheckTree did not do this either
  86
  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
  90
  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) {
  94             $testlist = $2;
  95             # split bundled tests, e.g. "ug" to 'u', 'g'
  96             @testlist = split(//, $testlist);
  97         }
  98         else {
  99             # put in placeholder Z for stand-alone test
 100             @testlist = ('Z');
 101         }
 102
 103         # will compare these two later to stop on 1st warning w/in a bundle
 104         $oldwarnings = $Warnings;
 105
 106         foreach my $one (@testlist) {
 107             # examples of $test: "!-Z || die" or "-w || warn"
 108             my $this = $test;
 109
 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);
 113
 114             # put filename in after the test operator
 115             $this =~ s/(-\w\b)/$1 "\$file"/g;
 116
 117             # change the "-Z" representing a bundle with the $one test
 118             $this =~ s/-Z/-$one/;
 119
 120             # if it's a "cd" directive...
 121             if ($this =~ /^cd\b/) {
 122                 # add "|| die ..."
 123                 $this .= ' || die "cannot cd to $file\n"';
 124                 # expand "cd" directive with directory name
 125                 $this =~ s/\bcd\b/chdir(\$cwd = '$file')/;
 126             }
 127             else {
 128                 # add "|| warn" as a default disposition
 129                 $this .= ' || warn' unless $this =~ /\|\|/;
 130
 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;
 136             }
 137
 138             {
 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 {
 143                     ++$Warnings;
 144                     if ( $orig_sigwarn ) {
 145                         $orig_sigwarn->(@_);
 146                     }
 147                     else {
 148                         warn "@_";
 149                     }
 150                 };
 151
 152                 # do the test
 153                 eval $this;
 154
 155                 # re-raise an exception caused by a "... || die" test
 156                 if ($@) {
 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: $!";
 160                     }
 161                     die $@ if $@;
 162                 }
 163             }
 164
 165             # stop on 1st warning within a bundle of tests
 166             last if $Warnings > $oldwarnings;
 167         }
 168     }
 169
 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: $!";
 173     }
 174
 175     return $Warnings;
 176 }
 177
 178 my %Val_Message = (
 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."
 202 );
 203
 204 sub valmess {
 205     my ($disposition, $test, $file) = @_;
 206     my $ferror;
 207
 208     if ($test =~ / ^ (!?) -(\w) \s* $ /x) {
 209         my ($neg, $ftype) = ($1, $2);
 210
 211         $ferror = "$file $Val_Message{$ftype}";
 212
 213         if ($neg eq '!') {
 214             $ferror =~ s/ is not / should not be / ||
 215             $ferror =~ s/ does not / should not / ||
 216             $ferror =~ s/ not / /;
 217         }
 218     }
 219     else {
 220         $ferror = "Can't do $test $file.\n";
 221     }
 222
 223     die "$ferror\n" if $disposition eq 'die';
 224     warn "$ferror\n";
 225 }
 226
 227 1;