| 1 |
root |
1.1 |
;# $RCSfile: validate.pl,v $$Revision: 4.1 $$Date: 92/08/07 18:24:19 $ |
| 2 |
|
|
|
| 3 |
|
|
;# The validate routine takes a single multiline string consisting of |
| 4 |
|
|
;# lines containing a filename plus a file test to try on it. (The |
| 5 |
|
|
;# file test may also be a 'cd', causing subsequent relative filenames |
| 6 |
|
|
;# to be interpreted relative to that directory.) After the file test |
| 7 |
|
|
;# you may put '|| die' to make it a fatal error if the file test fails. |
| 8 |
|
|
;# The default is '|| warn'. The file test may optionally have a ! prepended |
| 9 |
|
|
;# to test for the opposite condition. If you do a cd and then list some |
| 10 |
|
|
;# relative filenames, you may want to indent them slightly for readability. |
| 11 |
|
|
;# If you supply your own "die" or "warn" message, you can use $file to |
| 12 |
|
|
;# interpolate the filename. |
| 13 |
|
|
|
| 14 |
|
|
;# Filetests may be bunched: -rwx tests for all of -r, -w and -x. |
| 15 |
|
|
;# Only the first failed test of the bunch will produce a warning. |
| 16 |
|
|
|
| 17 |
|
|
;# The routine returns the number of warnings issued. |
| 18 |
|
|
|
| 19 |
|
|
;# Usage: |
| 20 |
|
|
;# require "validate.pl"; |
| 21 |
|
|
;# $warnings += do validate(' |
| 22 |
|
|
;# /vmunix -e || die |
| 23 |
|
|
;# /boot -e || die |
| 24 |
|
|
;# /bin cd |
| 25 |
|
|
;# csh -ex |
| 26 |
|
|
;# csh !-ug |
| 27 |
|
|
;# sh -ex |
| 28 |
|
|
;# sh !-ug |
| 29 |
|
|
;# /usr -d || warn "What happened to $file?\n" |
| 30 |
|
|
;# '); |
| 31 |
|
|
|
| 32 |
|
|
sub validate { |
| 33 |
|
|
local($file,$test,$warnings,$oldwarnings); |
| 34 |
|
|
foreach $check (split(/\n/,$_[0])) { |
| 35 |
|
|
next if $check =~ /^#/; |
| 36 |
|
|
next if $check =~ /^$/; |
| 37 |
|
|
($file,$test) = split(' ',$check,2); |
| 38 |
|
|
if ($test =~ s/^(!?-)(\w{2,}\b)/$1Z/) { |
| 39 |
|
|
$testlist = $2; |
| 40 |
|
|
@testlist = split(//,$testlist); |
| 41 |
|
|
} |
| 42 |
|
|
else { |
| 43 |
|
|
@testlist = ('Z'); |
| 44 |
|
|
} |
| 45 |
|
|
$oldwarnings = $warnings; |
| 46 |
|
|
foreach $one (@testlist) { |
| 47 |
|
|
$this = $test; |
| 48 |
|
|
$this =~ s/(-\w\b)/$1 \$file/g; |
| 49 |
|
|
$this =~ s/-Z/-$one/; |
| 50 |
|
|
$this .= ' || warn' unless $this =~ /\|\|/; |
| 51 |
|
|
$this =~ s/^(.*\S)\s*\|\|\s*(die|warn)$/$1 || do valmess('$2','$1')/; |
| 52 |
|
|
$this =~ s/\bcd\b/chdir (\$cwd = \$file)/g; |
| 53 |
|
|
eval $this; |
| 54 |
|
|
last if $warnings > $oldwarnings; |
| 55 |
|
|
} |
| 56 |
|
|
} |
| 57 |
|
|
$warnings; |
| 58 |
|
|
} |
| 59 |
|
|
|
| 60 |
|
|
sub valmess { |
| 61 |
|
|
local($disposition,$this) = @_; |
| 62 |
|
|
$file = $cwd . '/' . $file unless $file =~ m|^/|; |
| 63 |
|
|
if ($this =~ /^(!?)-(\w)\s+\$file\s*$/) { |
| 64 |
|
|
$neg = $1; |
| 65 |
|
|
$tmp = $2; |
| 66 |
|
|
$tmp eq 'r' && ($mess = "$file is not readable by uid $>."); |
| 67 |
|
|
$tmp eq 'w' && ($mess = "$file is not writable by uid $>."); |
| 68 |
|
|
$tmp eq 'x' && ($mess = "$file is not executable by uid $>."); |
| 69 |
|
|
$tmp eq 'o' && ($mess = "$file is not owned by uid $>."); |
| 70 |
|
|
$tmp eq 'R' && ($mess = "$file is not readable by you."); |
| 71 |
|
|
$tmp eq 'W' && ($mess = "$file is not writable by you."); |
| 72 |
|
|
$tmp eq 'X' && ($mess = "$file is not executable by you."); |
| 73 |
|
|
$tmp eq 'O' && ($mess = "$file is not owned by you."); |
| 74 |
|
|
$tmp eq 'e' && ($mess = "$file does not exist."); |
| 75 |
|
|
$tmp eq 'z' && ($mess = "$file does not have zero size."); |
| 76 |
|
|
$tmp eq 's' && ($mess = "$file does not have non-zero size."); |
| 77 |
|
|
$tmp eq 'f' && ($mess = "$file is not a plain file."); |
| 78 |
|
|
$tmp eq 'd' && ($mess = "$file is not a directory."); |
| 79 |
|
|
$tmp eq 'l' && ($mess = "$file is not a symbolic link."); |
| 80 |
|
|
$tmp eq 'p' && ($mess = "$file is not a named pipe (FIFO)."); |
| 81 |
|
|
$tmp eq 'S' && ($mess = "$file is not a socket."); |
| 82 |
|
|
$tmp eq 'b' && ($mess = "$file is not a block special file."); |
| 83 |
|
|
$tmp eq 'c' && ($mess = "$file is not a character special file."); |
| 84 |
|
|
$tmp eq 'u' && ($mess = "$file does not have the setuid bit set."); |
| 85 |
|
|
$tmp eq 'g' && ($mess = "$file does not have the setgid bit set."); |
| 86 |
|
|
$tmp eq 'k' && ($mess = "$file does not have the sticky bit set."); |
| 87 |
|
|
$tmp eq 'T' && ($mess = "$file is not a text file."); |
| 88 |
|
|
$tmp eq 'B' && ($mess = "$file is not a binary file."); |
| 89 |
|
|
if ($neg eq '!') { |
| 90 |
|
|
$mess =~ s/ is not / should not be / || |
| 91 |
|
|
$mess =~ s/ does not / should not / || |
| 92 |
|
|
$mess =~ s/ not / /; |
| 93 |
|
|
} |
| 94 |
|
|
print STDERR $mess,"\n"; |
| 95 |
|
|
} |
| 96 |
|
|
else { |
| 97 |
|
|
$this =~ s/\$file/'$file'/g; |
| 98 |
|
|
print STDERR "Can't do $this.\n"; |
| 99 |
|
|
} |
| 100 |
|
|
if ($disposition eq 'die') { exit 1; } |
| 101 |
|
|
++$warnings; |
| 102 |
|
|
} |
| 103 |
|
|
|
| 104 |
|
|
1; |
