1 package File::CheckTree;
10 validate - run many filetest checks on a tree
16 $warnings += validate( q{
24 /usr -d || warn "What happened to $file?\n"
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.
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.
43 The routine returns the number of warnings issued.
47 our @ISA = qw(Exporter);
48 our @EXPORT = qw(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/) {
58 @testlist = split(//,$testlist);
63 $oldwarnings = $warnings;
64 foreach $one (@testlist) {
66 $this =~ s/(-\w\b)/$1 \$file/g;
68 $this .= ' || warn' unless $this =~ /\|\|/;
69 $this =~ s/^(.*\S)\s*\|\|\s*(die|warn)$/$1 ||
71 $this =~ s/\bcd\b/chdir (\$cwd = \$file)/g;
73 last if $warnings > $oldwarnings;
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." },
106 my($disposition,$this) = @_;
107 my $file = $cwd . '/' . $file unless $file =~ m|^/|s;
110 if ($this =~ /^(!?)-(\w)\s+\$file\s*$/) {
111 my($neg,$ftype) = ($1,$2);
113 $ferror = $Val_Switch{$tmp}->($file);
116 $ferror =~ s/ is not / should not be / ||
117 $ferror =~ s/ does not / should not / ||
118 $ferror =~ s/ not / /;
122 $this =~ s/\$file/'$file'/g;
123 $ferror = "Can't do $this.\n";
125 die "$ferror\n" if $disposition eq 'die';