X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FFile%2FCheckTree.pm;h=7884ca711e6a756601b48c844d69700704e5880a;hb=57db8a1156a63b084cc784787f4fbf02ce40bb10;hp=8b6ae0805a4cde59d03a5fb071dc83336ab77222;hpb=0e06870bf080a38cda51c06c6612359afc2334e1;p=p5sagit%2Fp5-mst-13.2.git diff --git a/lib/File/CheckTree.pm b/lib/File/CheckTree.pm index 8b6ae08..7884ca7 100644 --- a/lib/File/CheckTree.pm +++ b/lib/File/CheckTree.pm @@ -1,9 +1,15 @@ package File::CheckTree; -our $VERSION = '4.1'; +use 5.006; +use Cwd; +use Exporter; +use File::Spec; +use warnings; +use strict; -require 5.000; -require Exporter; +our $VERSION = '4.2'; +our @ISA = qw(Exporter); +our @EXPORT = qw(validate); =head1 NAME @@ -13,22 +19,22 @@ validate - run many filetest checks on a tree use File::CheckTree; - $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" + $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 -lines containing a filename plus a file test to try on it. (The -file test may also be a "cd", causing subsequent relative filenames +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 @@ -42,90 +48,180 @@ Only the first failed test of the bunch will produce a warning. The routine returns the number of warnings issued. +=head1 AUTHOR + +Unknown. Revised by Paul Grassie > 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 -our @ISA = qw(Exporter); -our @EXPORT = qw(validate); +my $Warnings; sub validate { - local($file,$test,$warnings,$oldwarnings); - foreach $check (split(/\n/,$_[0])) { - next if $check =~ /^#/; - next if $check =~ /^$/; - ($file,$test) = split(' ',$check,2); - if ($test =~ s/^(!?-)(\w{2,}\b)/$1Z/) { - $testlist = $2; - @testlist = split(//,$testlist); - } - else { - @testlist = ('Z'); - } - $oldwarnings = $warnings; - foreach $one (@testlist) { - $this = $test; - $this =~ s/(-\w\b)/$1 \$file/g; - $this =~ s/-Z/-$one/; - $this .= ' || warn' unless $this =~ /\|\|/; - $this =~ s/^(.*\S)\s*\|\|\s*(die|warn)$/$1 || - valmess('$2','$1')/; - $this =~ s/\bcd\b/chdir (\$cwd = \$file)/g; - eval $this; - last if $warnings > $oldwarnings; - } + 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: $!"; } - $warnings; + + return $Warnings; } -our %Val_Switch = ( - 'r' => sub { "$_[0] is not readable by uid $>." }, - 'w' => sub { "$_[0] is not writable by uid $>." }, - 'x' => sub { "$_[0] is not executable by uid $>." }, - 'o' => sub { "$_[0] is not owned by uid $>." }, - 'R' => sub { "$_[0] is not readable by you." }, - 'W' => sub { "$_[0] is not writable by you." }, - 'X' => sub { "$_[0] is not executable by you." }, - 'O' => sub { "$_[0] is not owned by you." }, - 'e' => sub { "$_[0] does not exist." }, - 'z' => sub { "$_[0] does not have zero size." }, - 's' => sub { "$_[0] does not have non-zero size." }, - 'f' => sub { "$_[0] is not a plain file." }, - 'd' => sub { "$_[0] is not a directory." }, - 'l' => sub { "$_[0] is not a symbolic link." }, - 'p' => sub { "$_[0] is not a named pipe (FIFO)." }, - 'S' => sub { "$_[0] is not a socket." }, - 'b' => sub { "$_[0] is not a block special file." }, - 'c' => sub { "$_[0] is not a character special file." }, - 'u' => sub { "$_[0] does not have the setuid bit set." }, - 'g' => sub { "$_[0] does not have the setgid bit set." }, - 'k' => sub { "$_[0] does not have the sticky bit set." }, - 'T' => sub { "$_[0] is not a text file." }, - 'B' => sub { "$_[0] is not a binary file." }, +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,$this) = @_; - my $file = $cwd . '/' . $file unless $file =~ m|^/|s; - + my ($disposition, $test, $file) = @_; my $ferror; - if ($this =~ /^(!?)-(\w)\s+\$file\s*$/) { - my($neg,$ftype) = ($1,$2); - $ferror = $Val_Switch{$tmp}->($file); + 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 / /; - } + if ($neg eq '!') { + $ferror =~ s/ is not / should not be / || + $ferror =~ s/ does not / should not / || + $ferror =~ s/ not / /; + } } else { - $this =~ s/\$file/'$file'/g; - $ferror = "Can't do $this.\n"; + $ferror = "Can't do $test $file.\n"; } + die "$ferror\n" if $disposition eq 'die'; warn "$ferror\n"; - ++$warnings; } 1; -