lib/File/CheckTree.pm

package File::CheckTree;

use 5.006;
use Cwd;
use Exporter;
use File::Spec;
use warnings;
use strict;

our $VERSION = '4.3';
our @ISA     = qw(Exporter);
our @EXPORT  = qw(validate);

=head1 NAME

validate - run many filetest checks on a tree

=head1 SYNOPSIS

    use File::CheckTree;

    $num_warnings = validate( q{
        /vmunix                 -e || die
        /boot                   -e || die
        /bin                    cd
            csh                 -ex
            csh                 !-ug
            sh                  -ex
            sh                  !-ug
        /usr                    -d || warn "What happened to $file?\n"
    });

=head1 DESCRIPTION

The validate() routine takes a single multiline string consisting of
directives, each containing a filename plus a file test to try on it.
(The file test may also be a "cd", causing subsequent relative filenames
to be interpreted relative to that directory.)  After the file test
you may put C<|| die> to make it a fatal error if the file test fails.
The default is C<|| warn>.  The file test may optionally have a "!' prepended
to test for the opposite condition.  If you do a cd and then list some
relative filenames, you may want to indent them slightly for readability.
If you supply your own die() or warn() message, you can use $file to
interpolate the filename.

Filetests may be bunched:  "-rwx" tests for all of C<-r>, C<-w>, and C<-x>.
Only the first failed test of the bunch will produce a warning.

The routine returns the number of warnings issued.

=head1 AUTHOR

File::CheckTree was derived from lib/validate.pl which was
written by Larry Wall.
Revised by Paul Grassie <F<grassie@perl.com>> in 2002.

=head1 HISTORY

File::CheckTree used to not display fatal error messages.
It used to count only those warnings produced by a generic C<|| warn>
(and not those in which the user supplied the message).  In addition,
the validate() routine would leave the user program in whatever
directory was last entered through the use of "cd" directives.
These bugs were fixed during the development of perl 5.8.
The first fixed version of File::CheckTree was 4.2.

=cut

my $Warnings;

sub validate {
    my ($starting_dir, $file, $test, $cwd, $oldwarnings);

    $starting_dir = cwd;

    $cwd = "";
    $Warnings = 0;

    foreach my $check (split /\n/, $_[0]) {
        my ($testlist, @testlist);

        # skip blanks/comments
        next if $check =~ /^\s*#/ || $check =~ /^\s*$/;

        # Todo:
        # should probably check for invalid directives and die
        # but earlier versions of File::CheckTree did not do this either

        # split a line like "/foo -r || die"
        # so that $file is "/foo", $test is "-rwx || die"
        ($file, $test) = split(' ', $check, 2);   # special whitespace split

        # change a $test like "!-ug || die" to "!-Z || die",
        # capturing the bundled tests (e.g. "ug") in $2
        if ($test =~ s/ ^ (!?-) (\w{2,}) \b /$1Z/x) {
            $testlist = $2;
            # split bundled tests, e.g. "ug" to 'u', 'g'
            @testlist = split(//, $testlist);
        }
        else {
            # put in placeholder Z for stand-alone test
            @testlist = ('Z');
        }

        # will compare these two later to stop on 1st warning w/in a bundle
        $oldwarnings = $Warnings;

        foreach my $one (@testlist) {
            # examples of $test: "!-Z || die" or "-w || warn"
            my $this = $test;

            # expand relative $file to full pathname if preceded by cd directive
            $file = File::Spec->catfile($cwd, $file) 
                    if $cwd && !File::Spec->file_name_is_absolute($file);

            # put filename in after the test operator
            $this =~ s/(-\w\b)/$1 "\$file"/g;

            # change the "-Z" representing a bundle with the $one test
            $this =~ s/-Z/-$one/;

            # if it's a "cd" directive...
            if ($this =~ /^cd\b/) {
                # add "|| die ..."
                $this .= ' || die "cannot cd to $file\n"';
                # expand "cd" directive with directory name
                $this =~ s/\bcd\b/chdir(\$cwd = '$file')/;
            }
            else {
                # add "|| warn" as a default disposition
                $this .= ' || warn' unless $this =~ /\|\|/; 

                # change a generic ".. || die" or ".. || warn"
                # to call valmess instead of die/warn directly
                # valmess will look up the error message from %Val_Message
                $this =~ s/ ^ ( (\S+) \s+ \S+ ) \s* \|\| \s* (die|warn) \s* $
                          /$1 || valmess('$3', '$2', \$file)/x;
            }

            {
                # count warnings, either from valmess or '-r || warn "my msg"'
                # also, call any pre-existing signal handler for __WARN__
                my $orig_sigwarn = $SIG{__WARN__};
                local $SIG{__WARN__} = sub {
                    ++$Warnings;
                    if ( $orig_sigwarn ) {
                        $orig_sigwarn->(@_);
                    }
                    else {
                        warn "@_";
                    }
                };

                # do the test
                eval $this;

                # re-raise an exception caused by a "... || die" test 
                if ($@) {
                    # in case of any cd directives, return from whence we came
                    if ($starting_dir ne cwd) {
                        chdir($starting_dir) || die "$starting_dir: $!";
                    }
                    die $@ if $@;
                }
            }

            # stop on 1st warning within a bundle of tests
            last if $Warnings > $oldwarnings;
        }
    }

    # in case of any cd directives, return from whence we came
    if ($starting_dir ne cwd) {
        chdir($starting_dir) || die "chdir $starting_dir: $!";
    }

    return $Warnings;
}

my %Val_Message = (
    'r' => "is not readable by uid $>.",
    'w' => "is not writable by uid $>.",
    'x' => "is not executable by uid $>.",
    'o' => "is not owned by uid $>.",
    'R' => "is not readable by you.",
    'W' => "is not writable by you.",
    'X' => "is not executable by you.",
    'O' => "is not owned by you.",
    'e' => "does not exist.",
    'z' => "does not have zero size.",
    's' => "does not have non-zero size.",
    'f' => "is not a plain file.",
    'd' => "is not a directory.",
    'l' => "is not a symbolic link.",
    'p' => "is not a named pipe (FIFO).",
    'S' => "is not a socket.",
    'b' => "is not a block special file.",
    'c' => "is not a character special file.",
    'u' => "does not have the setuid bit set.",
    'g' => "does not have the setgid bit set.",
    'k' => "does not have the sticky bit set.",
    'T' => "is not a text file.",
    'B' => "is not a binary file."
);

sub valmess {
    my ($disposition, $test, $file) = @_;
    my $ferror;

    if ($test =~ / ^ (!?) -(\w) \s* $ /x) {
        my ($neg, $ftype) = ($1, $2);

        $ferror = "$file $Val_Message{$ftype}";

        if ($neg eq '!') {
            $ferror =~ s/ is not / should not be / ||
            $ferror =~ s/ does not / should not / ||
            $ferror =~ s/ not / /;
        }
    }
    else {
        $ferror = "Can't do $test $file.\n";
    }

    die "$ferror\n" if $disposition eq 'die';
    warn "$ferror\n";
}

1;
Revision:	1.1
Committed:	Thu Jun 30 14:27:11 2005 UTC (21 years, 3 months ago) by root
Branch:	MAIN
CVS Tags:	PERL-5-8-7, HEAD
Branch point for:	PERL
Log Message:	* empty log message *
#	User	Rev	Content
1	root	1.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.3';
11			our @ISA = qw(Exporter);
12			our @EXPORT = qw(validate);
13
14			=head1 NAME
15
16			validate - 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 "-rwx \|\| die"
91			($file, $test) = split(' ', $check, 2); # special whitespace split
92
93			# change a $test like "!-ug \|\| die" to "!-Z \|\| die",
94			# capturing the bundled tests (e.g. "ug") in $2
95			if ($test =~ s/ ^ (!?-) (\w{2,}) \b /$1Z/x) {
96			$testlist = $2;
97			# split bundled tests, e.g. "ug" to 'u', 'g'
98			@testlist = split(//, $testlist);
99			}
100			else {
101			# put in placeholder Z for stand-alone test
102			@testlist = ('Z');
103			}
104
105			# will compare these two later to stop on 1st warning w/in a bundle
106			$oldwarnings = $Warnings;
107
108			foreach my $one (@testlist) {
109			# examples of $test: "!-Z \|\| die" or "-w \|\| warn"
110			my $this = $test;
111
112			# expand relative $file to full pathname if preceded by cd directive
113			$file = File::Spec->catfile($cwd, $file)
114			if $cwd && !File::Spec->file_name_is_absolute($file);
115
116			# put filename in after the test operator
117			$this =~ s/(-\w\b)/$1 "\$file"/g;
118
119			# change the "-Z" representing a bundle with the $one test
120			$this =~ s/-Z/-$one/;
121
122			# if it's a "cd" directive...
123			if ($this =~ /^cd\b/) {
124			# add "\|\| die ..."
125			$this .= ' \|\| die "cannot cd to $file\n"';
126			# expand "cd" directive with directory name
127			$this =~ s/\bcd\b/chdir(\$cwd = '$file')/;
128			}
129			else {
130			# add "\|\| warn" as a default disposition
131			$this .= ' \|\| warn' unless $this =~ /\\|\\|/;
132
133			# change a generic ".. \|\| die" or ".. \|\| warn"
134			# to call valmess instead of die/warn directly
135			# valmess will look up the error message from %Val_Message
136			$this =~ s/ ^ ( (\S+) \s+ \S+ ) \s* \\|\\| \s* (die\|warn) \s* $
137			/$1 \|\| valmess('$3', '$2', \$file)/x;
138			}
139
140			{
141			# count warnings, either from valmess or '-r \|\| warn "my msg"'
142			# also, call any pre-existing signal handler for __WARN__
143			my $orig_sigwarn = $SIG{__WARN__};
144			local $SIG{__WARN__} = sub {
145			++$Warnings;
146			if ( $orig_sigwarn ) {
147			$orig_sigwarn->(@_);
148			}
149			else {
150			warn "@_";
151			}
152			};
153
154			# do the test
155			eval $this;
156
157			# re-raise an exception caused by a "... \|\| die" test
158			if ($@) {
159			# in case of any cd directives, return from whence we came
160			if ($starting_dir ne cwd) {
161			chdir($starting_dir) \|\| die "$starting_dir: $!";
162			}
163			die $@ if $@;
164			}
165			}
166
167			# stop on 1st warning within a bundle of tests
168			last if $Warnings > $oldwarnings;
169			}
170			}
171
172			# in case of any cd directives, return from whence we came
173			if ($starting_dir ne cwd) {
174			chdir($starting_dir) \|\| die "chdir $starting_dir: $!";
175			}
176
177			return $Warnings;
178			}
179
180			my %Val_Message = (
181			'r' => "is not readable by uid $>.",
182			'w' => "is not writable by uid $>.",
183			'x' => "is not executable by uid $>.",
184			'o' => "is not owned by uid $>.",
185			'R' => "is not readable by you.",
186			'W' => "is not writable by you.",
187			'X' => "is not executable by you.",
188			'O' => "is not owned by you.",
189			'e' => "does not exist.",
190			'z' => "does not have zero size.",
191			's' => "does not have non-zero size.",
192			'f' => "is not a plain file.",
193			'd' => "is not a directory.",
194			'l' => "is not a symbolic link.",
195			'p' => "is not a named pipe (FIFO).",
196			'S' => "is not a socket.",
197			'b' => "is not a block special file.",
198			'c' => "is not a character special file.",
199			'u' => "does not have the setuid bit set.",
200			'g' => "does not have the setgid bit set.",
201			'k' => "does not have the sticky bit set.",
202			'T' => "is not a text file.",
203			'B' => "is not a binary file."
204			);
205
206			sub valmess {
207			my ($disposition, $test, $file) = @_;
208			my $ferror;
209
210			if ($test =~ / ^ (!?) -(\w) \s* $ /x) {
211			my ($neg, $ftype) = ($1, $2);
212
213			$ferror = "$file $Val_Message{$ftype}";
214
215			if ($neg eq '!') {
216			$ferror =~ s/ is not / should not be / \|\|
217			$ferror =~ s/ does not / should not / \|\|
218			$ferror =~ s/ not / /;
219			}
220			}
221			else {
222			$ferror = "Can't do $test $file.\n";
223			}
224
225			die "$ferror\n" if $disposition eq 'die';
226			warn "$ferror\n";
227			}
228
229			1;