lib/File/CheckTree.pm

   1 package File::CheckTree;
   2
   3 our $VERSION = '4.1';
   4
   5 require 5.000;
   6 require Exporter;
   7
   8 =head1 NAME
   9
  10 validate - run many filetest checks on a tree
  11
  12 =head1 SYNOPSIS
  13
  14     use File::CheckTree;
  15
  16     $warnings += validate( q{
  17         /vmunix                 -e || die
  18         /boot                   -e || die
  19         /bin                    cd
  20             csh                 -ex
  21             csh                 !-ug
  22             sh                  -ex
  23             sh                  !-ug
  24         /usr                    -d || warn "What happened to $file?\n"
  25     });
  26
  27 =head1 DESCRIPTION
  28
  29 The validate() routine takes a single multiline string consisting of
  30 lines containing a filename plus a file test to try on it.  (The
  31 file test may also be a "cd", causing subsequent relative filenames
  32 to be interpreted relative to that directory.)  After the file test
  33 you may put C<|| die> to make it a fatal error if the file test fails.
  34 The default is C<|| warn>.  The file test may optionally have a "!' prepended
  35 to test for the opposite condition.  If you do a cd and then list some
  36 relative filenames, you may want to indent them slightly for readability.
  37 If you supply your own die() or warn() message, you can use $file to
  38 interpolate the filename.
  39
  40 Filetests may be bunched:  "-rwx" tests for all of C<-r>, C<-w>, and C<-x>.
  41 Only the first failed test of the bunch will produce a warning.
  42
  43 The routine returns the number of warnings issued.
  44
  45 =cut
  46
  47 our @ISA = qw(Exporter);
  48 our @EXPORT = qw(validate);
  49
  50 sub validate {
  51     local($file,$test,$warnings,$oldwarnings);
  52     foreach $check (split(/\n/,$_[0])) {
  53         next if $check =~ /^#/;
  54         next if $check =~ /^$/;
  55         ($file,$test) = split(' ',$check,2);
  56         if ($test =~ s/^(!?-)(\w{2,}\b)/$1Z/) {
  57             $testlist = $2;
  58             @testlist = split(//,$testlist);
  59         }
  60         else {
  61             @testlist = ('Z');
  62         }
  63         $oldwarnings = $warnings;
  64         foreach $one (@testlist) {
  65             $this = $test;
  66             $this =~ s/(-\w\b)/$1 \$file/g;
  67             $this =~ s/-Z/-$one/;
  68             $this .= ' || warn' unless $this =~ /\|\|/;
  69             $this =~ s/^(.*\S)\s*\|\|\s*(die|warn)$/$1 ||
  70                 valmess('$2','$1')/;
  71             $this =~ s/\bcd\b/chdir (\$cwd = \$file)/g;
  72             eval $this;
  73             last if $warnings > $oldwarnings;
  74         }
  75     }
  76     $warnings;
  77 }
  78
  79 our %Val_Switch = (
  80         'r' => sub { "$_[0] is not readable by uid $>." },
  81         'w' => sub { "$_[0] is not writable by uid $>." },
  82         'x' => sub { "$_[0] is not executable by uid $>." },
  83         'o' => sub { "$_[0] is not owned by uid $>." },
  84         'R' => sub { "$_[0] is not readable by you." },
  85         'W' => sub { "$_[0] is not writable by you." },
  86         'X' => sub { "$_[0] is not executable by you." },
  87         'O' => sub { "$_[0] is not owned by you." },
  88         'e' => sub { "$_[0] does not exist." },
  89         'z' => sub { "$_[0] does not have zero size." },
  90         's' => sub { "$_[0] does not have non-zero size." },
  91         'f' => sub { "$_[0] is not a plain file." },
  92         'd' => sub { "$_[0] is not a directory." },
  93         'l' => sub { "$_[0] is not a symbolic link." },
  94         'p' => sub { "$_[0] is not a named pipe (FIFO)." },
  95         'S' => sub { "$_[0] is not a socket." },
  96         'b' => sub { "$_[0] is not a block special file." },
  97         'c' => sub { "$_[0] is not a character special file." },
  98         'u' => sub { "$_[0] does not have the setuid bit set." },
  99         'g' => sub { "$_[0] does not have the setgid bit set." },
 100         'k' => sub { "$_[0] does not have the sticky bit set." },
 101         'T' => sub { "$_[0] is not a text file." },
 102         'B' => sub { "$_[0] is not a binary file." },
 103 );
 104
 105 sub valmess {
 106     my($disposition,$this) = @_;
 107     my $file = $cwd . '/' . $file unless $file =~ m|^/|s;
 108
 109     my $ferror;
 110     if ($this =~ /^(!?)-(\w)\s+\$file\s*$/) {
 111         my($neg,$ftype) = ($1,$2);
 112
 113         $ferror = $Val_Switch{$tmp}->($file);
 114
 115         if ($neg eq '!') {
 116             $ferror =~ s/ is not / should not be / ||
 117             $ferror =~ s/ does not / should not / ||
 118             $ferror =~ s/ not / /;
 119         }
 120     }
 121     else {
 122         $this =~ s/\$file/'$file'/g;
 123         $ferror = "Can't do $this.\n";
 124     }
 125     die "$ferror\n" if $disposition eq 'die';
 126     warn "$ferror\n";
 127     ++$warnings;
 128 }
 129
 130 1;
 131