This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
add example of warning categorization to perldiag
[perl5.git] / cpan / File-CheckTree / 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.41';
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;