This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Removed cpan/Text-Soundex
[perl5.git] / cpan / File-CheckTree / lib / File / CheckTree.pm
CommitLineData
a0d0e21e 1package File::CheckTree;
b75c8c73 2
3b825e41 3use 5.006;
849d5e34 4use Cwd;
026a9d8a
CB
5use Exporter;
6use File::Spec;
b395063c 7use warnings;
849d5e34
JH
8use strict;
9
f85d4d75
CBW
10use if $] > 5.017, 'deprecate';
11
12our $VERSION = '4.42';
849d5e34
JH
13our @ISA = qw(Exporter);
14our @EXPORT = qw(validate);
a0d0e21e 15
f06db76b
AD
16=head1 NAME
17
4d04f904 18File::CheckTree - run many filetest checks on a tree
f06db76b
AD
19
20=head1 SYNOPSIS
21
22 use File::CheckTree;
23
849d5e34
JH
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"
f06db76b
AD
33 });
34
35=head1 DESCRIPTION
36
37The validate() routine takes a single multiline string consisting of
849d5e34
JH
38directives, 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
f06db76b
AD
40to be interpreted relative to that directory.) After the file test
41you may put C<|| die> to make it a fatal error if the file test fails.
42The default is C<|| warn>. The file test may optionally have a "!' prepended
43to test for the opposite condition. If you do a cd and then list some
44relative filenames, you may want to indent them slightly for readability.
45If you supply your own die() or warn() message, you can use $file to
46interpolate the filename.
47
48Filetests may be bunched: "-rwx" tests for all of C<-r>, C<-w>, and C<-x>.
49Only the first failed test of the bunch will produce a warning.
50
51The routine returns the number of warnings issued.
52
849d5e34
JH
53=head1 AUTHOR
54
55b01c1d
DD
55File::CheckTree was derived from lib/validate.pl which was
56written by Larry Wall.
57Revised by Paul Grassie <F<grassie@perl.com>> in 2002.
849d5e34
JH
58
59=head1 HISTORY
60
61File::CheckTree used to not display fatal error messages.
62It 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,
64the validate() routine would leave the user program in whatever
65directory was last entered through the use of "cd" directives.
66These bugs were fixed during the development of perl 5.8.
67The first fixed version of File::CheckTree was 4.2.
68
f06db76b
AD
69=cut
70
849d5e34 71my $Warnings;
a0d0e21e
LW
72
73sub validate {
849d5e34
JH
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"
96dbb1e1
MM
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 };
849d5e34
JH
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
d6f31ecf 124 $file = File::Spec->catfile($cwd, $file)
026a9d8a 125 if $cwd && !File::Spec->file_name_is_absolute($file);
849d5e34
JH
126
127 # put filename in after the test operator
9195d1e0 128 $this =~ s/(-\w\b)/$1 "\$file"/g;
849d5e34
JH
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
d6f31ecf 142 $this .= ' || warn' unless $this =~ /\|\|/;
849d5e34
JH
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* $
9195d1e0 148 /$1 || valmess('$3', '$2', \$file)/x;
849d5e34
JH
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
d6f31ecf 168 # re-raise an exception caused by a "... || die" test
96dbb1e1 169 if (my $err = $@) {
849d5e34
JH
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 }
96dbb1e1 174 die $err;
849d5e34
JH
175 }
176 }
177
178 # stop on 1st warning within a bundle of tests
179 last if $Warnings > $oldwarnings;
180 }
a0d0e21e 181 }
849d5e34
JH
182
183 # in case of any cd directives, return from whence we came
184 if ($starting_dir ne cwd) {
9195d1e0 185 chdir($starting_dir) || die "chdir $starting_dir: $!";
849d5e34
JH
186 }
187
188 return $Warnings;
a0d0e21e
LW
189}
190
849d5e34
JH
191my %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."
b75c8c73
MS
215);
216
a0d0e21e 217sub valmess {
849d5e34 218 my ($disposition, $test, $file) = @_;
b75c8c73 219 my $ferror;
b75c8c73 220
849d5e34
JH
221 if ($test =~ / ^ (!?) -(\w) \s* $ /x) {
222 my ($neg, $ftype) = ($1, $2);
b75c8c73 223
849d5e34
JH
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 }
a0d0e21e
LW
231 }
232 else {
849d5e34 233 $ferror = "Can't do $test $file.\n";
a0d0e21e 234 }
849d5e34 235
b75c8c73
MS
236 die "$ferror\n" if $disposition eq 'die';
237 warn "$ferror\n";
a0d0e21e
LW
238}
239
2401;