lib/File/CheckTree.pm

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