This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Update File-CheckTree to CPAN version 4.42
[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 use if $] > 5.017, 'deprecate';
11
12 our $VERSION = '4.42';
13 our @ISA     = qw(Exporter);
14 our @EXPORT  = qw(validate);
15
16 =head1 NAME
17
18 File::CheckTree - run many filetest checks on a tree
19
20 =head1 SYNOPSIS
21
22     use File::CheckTree;
23
24     $num_warnings = validate( q{
25         /vmunix                 -e || die
26         /boot                   -e || die
27         /bin                    cd
28             csh                 -ex
29             csh                 !-ug
30             sh                  -ex
31             sh                  !-ug
32         /usr                    -d || warn "What happened to $file?\n"
33     });
34
35 =head1 DESCRIPTION
36
37 The validate() routine takes a single multiline string consisting of
38 directives, each containing a filename plus a file test to try on it.
39 (The file test may also be a "cd", causing subsequent relative filenames
40 to be interpreted relative to that directory.)  After the file test
41 you may put C<|| die> to make it a fatal error if the file test fails.
42 The default is C<|| warn>.  The file test may optionally have a "!' prepended
43 to test for the opposite condition.  If you do a cd and then list some
44 relative filenames, you may want to indent them slightly for readability.
45 If you supply your own die() or warn() message, you can use $file to
46 interpolate the filename.
47
48 Filetests may be bunched:  "-rwx" tests for all of C<-r>, C<-w>, and C<-x>.
49 Only the first failed test of the bunch will produce a warning.
50
51 The routine returns the number of warnings issued.
52
53 =head1 AUTHOR
54
55 File::CheckTree was derived from lib/validate.pl which was
56 written by Larry Wall.
57 Revised by Paul Grassie <F<grassie@perl.com>> in 2002.
58
59 =head1 HISTORY
60
61 File::CheckTree used to not display fatal error messages.
62 It used to count only those warnings produced by a generic C<|| warn>
63 (and not those in which the user supplied the message).  In addition,
64 the validate() routine would leave the user program in whatever
65 directory was last entered through the use of "cd" directives.
66 These bugs were fixed during the development of perl 5.8.
67 The first fixed version of File::CheckTree was 4.2.
68
69 =cut
70
71 my $Warnings;
72
73 sub validate {
74     my ($starting_dir, $file, $test, $cwd, $oldwarnings);
75
76     $starting_dir = cwd;
77
78     $cwd = "";
79     $Warnings = 0;
80
81     foreach my $check (split /\n/, $_[0]) {
82         my ($testlist, @testlist);
83
84         # skip blanks/comments
85         next if $check =~ /^\s*#/ || $check =~ /^\s*$/;
86
87         # Todo:
88         # should probably check for invalid directives and die
89         # but earlier versions of File::CheckTree did not do this either
90
91         # split a line like "/foo -r || die"
92         # so that $file is "/foo", $test is "-r || die"
93         # (making special allowance for quoted filenames).
94         if ($check =~ m/^\s*"([^"]+)"\s+(.*?)\s*$/ or
95             $check =~ m/^\s*'([^']+)'\s+(.*?)\s*$/ or
96             $check =~ m/^\s*(\S+?)\s+(\S.*?)\s*$/)
97         {
98             ($file, $test) = ($1,$2);
99         }
100         else {
101             die "Malformed line: '$check'";
102         };
103
104         # change a $test like "!-ug || die" to "!-Z || die",
105         # capturing the bundled tests (e.g. "ug") in $2
106         if ($test =~ s/ ^ (!?-) (\w{2,}) \b /$1Z/x) {
107             $testlist = $2;
108             # split bundled tests, e.g. "ug" to 'u', 'g'
109             @testlist = split(//, $testlist);
110         }
111         else {
112             # put in placeholder Z for stand-alone test
113             @testlist = ('Z');
114         }
115
116         # will compare these two later to stop on 1st warning w/in a bundle
117         $oldwarnings = $Warnings;
118
119         foreach my $one (@testlist) {
120             # examples of $test: "!-Z || die" or "-w || warn"
121             my $this = $test;
122
123             # expand relative $file to full pathname if preceded by cd directive
124             $file = File::Spec->catfile($cwd, $file)
125                     if $cwd && !File::Spec->file_name_is_absolute($file);
126
127             # put filename in after the test operator
128             $this =~ s/(-\w\b)/$1 "\$file"/g;
129
130             # change the "-Z" representing a bundle with the $one test
131             $this =~ s/-Z/-$one/;
132
133             # if it's a "cd" directive...
134             if ($this =~ /^cd\b/) {
135                 # add "|| die ..."
136                 $this .= ' || die "cannot cd to $file\n"';
137                 # expand "cd" directive with directory name
138                 $this =~ s/\bcd\b/chdir(\$cwd = '$file')/;
139             }
140             else {
141                 # add "|| warn" as a default disposition
142                 $this .= ' || warn' unless $this =~ /\|\|/;
143
144                 # change a generic ".. || die" or ".. || warn"
145                 # to call valmess instead of die/warn directly
146                 # valmess will look up the error message from %Val_Message
147                 $this =~ s/ ^ ( (\S+) \s+ \S+ ) \s* \|\| \s* (die|warn) \s* $
148                           /$1 || valmess('$3', '$2', \$file)/x;
149             }
150
151             {
152                 # count warnings, either from valmess or '-r || warn "my msg"'
153                 # also, call any pre-existing signal handler for __WARN__
154                 my $orig_sigwarn = $SIG{__WARN__};
155                 local $SIG{__WARN__} = sub {
156                     ++$Warnings;
157                     if ( $orig_sigwarn ) {
158                         $orig_sigwarn->(@_);
159                     }
160                     else {
161                         warn "@_";
162                     }
163                 };
164
165                 # do the test
166                 eval $this;
167
168                 # re-raise an exception caused by a "... || die" test
169                 if (my $err = $@) {
170                     # in case of any cd directives, return from whence we came
171                     if ($starting_dir ne cwd) {
172                         chdir($starting_dir) || die "$starting_dir: $!";
173                     }
174                     die $err;
175                 }
176             }
177
178             # stop on 1st warning within a bundle of tests
179             last if $Warnings > $oldwarnings;
180         }
181     }
182
183     # in case of any cd directives, return from whence we came
184     if ($starting_dir ne cwd) {
185         chdir($starting_dir) || die "chdir $starting_dir: $!";
186     }
187
188     return $Warnings;
189 }
190
191 my %Val_Message = (
192     'r' => "is not readable by uid $>.",
193     'w' => "is not writable by uid $>.",
194     'x' => "is not executable by uid $>.",
195     'o' => "is not owned by uid $>.",
196     'R' => "is not readable by you.",
197     'W' => "is not writable by you.",
198     'X' => "is not executable by you.",
199     'O' => "is not owned by you.",
200     'e' => "does not exist.",
201     'z' => "does not have zero size.",
202     's' => "does not have non-zero size.",
203     'f' => "is not a plain file.",
204     'd' => "is not a directory.",
205     'l' => "is not a symbolic link.",
206     'p' => "is not a named pipe (FIFO).",
207     'S' => "is not a socket.",
208     'b' => "is not a block special file.",
209     'c' => "is not a character special file.",
210     'u' => "does not have the setuid bit set.",
211     'g' => "does not have the setgid bit set.",
212     'k' => "does not have the sticky bit set.",
213     'T' => "is not a text file.",
214     'B' => "is not a binary file."
215 );
216
217 sub valmess {
218     my ($disposition, $test, $file) = @_;
219     my $ferror;
220
221     if ($test =~ / ^ (!?) -(\w) \s* $ /x) {
222         my ($neg, $ftype) = ($1, $2);
223
224         $ferror = "$file $Val_Message{$ftype}";
225
226         if ($neg eq '!') {
227             $ferror =~ s/ is not / should not be / ||
228             $ferror =~ s/ does not / should not / ||
229             $ferror =~ s/ not / /;
230         }
231     }
232     else {
233         $ferror = "Can't do $test $file.\n";
234     }
235
236     die "$ferror\n" if $disposition eq 'die';
237     warn "$ferror\n";
238 }
239
240 1;