[Summary view] [Print] [Text view]

   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  File::CheckTree - 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 "-r || die"
  91          # (making special allowance for quoted filenames).
  92          if ($check =~ m/^\s*"([^"]+)"\s+(.*?)\s*$/ or
  93              $check =~ m/^\s*'([^']+)'\s+(.*?)\s*$/ or
  94              $check =~ m/^\s*(\S+?)\s+(\S.*?)\s*$/)
  95          {
  96              ($file, $test) = ($1,$2);
  97          }
  98          else {
  99              die "Malformed line: '$check'";
 100          };
 101  
 102          # change a $test like "!-ug || die" to "!-Z || die",
 103          # capturing the bundled tests (e.g. "ug") in $2
 104          if ($test =~ s/ ^ (!?-) (\w{2,}) \b /$1Z/x) {
 105              $testlist = $2;
 106              # split bundled tests, e.g. "ug" to 'u', 'g'
 107              @testlist = split(//, $testlist);
 108          }
 109          else {
 110              # put in placeholder Z for stand-alone test
 111              @testlist = ('Z');
 112          }
 113  
 114          # will compare these two later to stop on 1st warning w/in a bundle
 115          $oldwarnings = $Warnings;
 116  
 117          foreach my $one (@testlist) {
 118              # examples of $test: "!-Z || die" or "-w || warn"
 119              my $this = $test;
 120  
 121              # expand relative $file to full pathname if preceded by cd directive
 122              $file = File::Spec->catfile($cwd, $file) 
 123                      if $cwd && !File::Spec->file_name_is_absolute($file);
 124  
 125              # put filename in after the test operator
 126              $this =~ s/(-\w\b)/$1 "\$file"/g;
 127  
 128              # change the "-Z" representing a bundle with the $one test
 129              $this =~ s/-Z/-$one/;
 130  
 131              # if it's a "cd" directive...
 132              if ($this =~ /^cd\b/) {
 133                  # add "|| die ..."
 134                  $this .= ' || die "cannot cd to $file\n"';
 135                  # expand "cd" directive with directory name
 136                  $this =~ s/\bcd\b/chdir(\$cwd = '$file')/;
 137              }
 138              else {
 139                  # add "|| warn" as a default disposition
 140                  $this .= ' || warn' unless $this =~ /\|\|/; 
 141  
 142                  # change a generic ".. || die" or ".. || warn"
 143                  # to call valmess instead of die/warn directly
 144                  # valmess will look up the error message from %Val_Message
 145                  $this =~ s/ ^ ( (\S+) \s+ \S+ ) \s* \|\| \s* (die|warn) \s* $
 146                            /$1 || valmess('$3', '$2', \$file)/x;
 147              }
 148  
 149              {
 150                  # count warnings, either from valmess or '-r || warn "my msg"'
 151                  # also, call any pre-existing signal handler for __WARN__
 152                  my $orig_sigwarn = $SIG{__WARN__};
 153                  local $SIG{__WARN__} = sub {
 154                      ++$Warnings;
 155                      if ( $orig_sigwarn ) {
 156                          $orig_sigwarn->(@_);
 157                      }
 158                      else {
 159                          warn "@_";
 160                      }
 161                  };
 162  
 163                  # do the test
 164                  eval $this;
 165  
 166                  # re-raise an exception caused by a "... || die" test 
 167                  if (my $err = $@) {
 168                      # in case of any cd directives, return from whence we came
 169                      if ($starting_dir ne cwd) {
 170                          chdir($starting_dir) || die "$starting_dir: $!";
 171                      }
 172                      die $err;
 173                  }
 174              }
 175  
 176              # stop on 1st warning within a bundle of tests
 177              last if $Warnings > $oldwarnings;
 178          }
 179      }
 180  
 181      # in case of any cd directives, return from whence we came
 182      if ($starting_dir ne cwd) {
 183          chdir($starting_dir) || die "chdir $starting_dir: $!";
 184      }
 185  
 186      return $Warnings;
 187  }
 188  
 189  my %Val_Message = (
 190      'r' => "is not readable by uid $>.",
 191      'w' => "is not writable by uid $>.",
 192      'x' => "is not executable by uid $>.",
 193      'o' => "is not owned by uid $>.",
 194      'R' => "is not readable by you.",
 195      'W' => "is not writable by you.",
 196      'X' => "is not executable by you.",
 197      'O' => "is not owned by you.",
 198      'e' => "does not exist.",
 199      'z' => "does not have zero size.",
 200      's' => "does not have non-zero size.",
 201      'f' => "is not a plain file.",
 202      'd' => "is not a directory.",
 203      'l' => "is not a symbolic link.",
 204      'p' => "is not a named pipe (FIFO).",
 205      'S' => "is not a socket.",
 206      'b' => "is not a block special file.",
 207      'c' => "is not a character special file.",
 208      'u' => "does not have the setuid bit set.",
 209      'g' => "does not have the setgid bit set.",
 210      'k' => "does not have the sticky bit set.",
 211      'T' => "is not a text file.",
 212      'B' => "is not a binary file."
 213  );
 214  
 215  sub valmess {
 216      my ($disposition, $test, $file) = @_;
 217      my $ferror;
 218  
 219      if ($test =~ / ^ (!?) -(\w) \s* $ /x) {
 220          my ($neg, $ftype) = ($1, $2);
 221  
 222          $ferror = "$file $Val_Message{$ftype}";
 223  
 224          if ($neg eq '!') {
 225              $ferror =~ s/ is not / should not be / ||
 226              $ferror =~ s/ does not / should not / ||
 227              $ferror =~ s/ not / /;
 228          }
 229      }
 230      else {
 231          $ferror = "Can't do $test $file.\n";
 232      }
 233  
 234      die "$ferror\n" if $disposition eq 'die';
 235      warn "$ferror\n";
 236  }
 237  
 238  1;