| 1 | warn "Legacy library @{[(caller(0))[6]]} will be removed from the Perl core distribution in the next major release. Please install it from the CPAN distribution Perl4::CoreLibs. It is being used at @{[(caller)[1]]}, line @{[(caller)[2]]}.\n"; |
| 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; |