X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=utils%2Fperldoc.PL;h=cfb773e6ffe9c1b9afcde01de777ffb35f15932e;hb=41f4651c3a21976c2a7025d67365a484c22412d6;hp=7147607f60b1d37a0ddb67b238cbb9168dee213d;hpb=548848181b3a21c4d3a3ea8f57b9166fab43b0d1;p=p5sagit%2Fp5-mst-13.2.git diff --git a/utils/perldoc.PL b/utils/perldoc.PL index 7147607..cfb773e 100644 --- a/utils/perldoc.PL +++ b/utils/perldoc.PL @@ -30,22 +30,43 @@ $Config{startperl} eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}' if 0; +use warnings; use strict; + +# make sure creat()s are neither too much nor too little +INIT { eval { umask(0077) } } # doubtless someone has no mask + +(my \$pager = <<'/../') =~ s/\\s*\\z//; +$Config{pager} +/../ my \@pagers = (); -push \@pagers, "$Config{'pager'}" if -x "$Config{'pager'}"; +push \@pagers, \$pager if -x \$pager; + +(my \$bindir = <<'/../') =~ s/\\s*\\z//; +$Config{scriptdir} +/../ + !GROK!THIS! # In the following, perl variables are not expanded during extraction. print OUT <<'!NO!SUBS!'; +use Fcntl; # for sysopen +use Getopt::Std; +use Config '%Config'; +use File::Spec::Functions qw(catfile splitdir); + # # Perldoc revision #1 -- look up a piece of documentation in .pod format that # is embedded in the perl installation tree. # -# This is not to be confused with Tom Christianson's perlman, which is a +# This is not to be confused with Tom Christiansen's perlman, which is a # man replacement, written in perl. This perldoc is strictly for reading # the perl manuals, though it too is written in perl. +# +# Massive security and correctness patches applied to this +# noisome program by Tom Christiansen Sat Mar 11 15:22:33 MST 2000 if (@ARGV<1) { my $me = $0; # Editing $0 is unportable @@ -60,15 +81,13 @@ acquainted with the system. EOF } -use Getopt::Std; -use Config '%Config'; - my @global_found = (); my $global_target = ""; my $Is_VMS = $^O eq 'VMS'; my $Is_MSWin32 = $^O eq 'MSWin32'; my $Is_Dos = $^O eq 'dos'; +my $Is_OS2 = $^O eq 'os2'; sub usage{ warn "@_\n" if @_; @@ -93,6 +112,7 @@ Options: -v Verbosely describe what's going on -X use index if present (looks for pod.idx at $Config{archlib}) -q Search the text of questions (not answers) in perlfaq[1-9] + -U Run in insecure mode (superuser only) PageName|ModuleName... is the name of a piece of documentation that you want to look at. You @@ -122,7 +142,7 @@ if (defined $ENV{"PERLDOC"}) { } !NO!SUBS! -my $getopts = "mhtluvriFf:Xq:n:"; +my $getopts = "mhtluvriFf:Xq:n:U"; print OUT <<"!GET!OPTS!"; use vars qw( @{[map "\$opt_$_", ($getopts =~ /\w/g)]} ); @@ -133,6 +153,25 @@ getopts("$getopts") || usage; print OUT <<'!NO!SUBS!'; usage if $opt_h; + +# refuse to run if we should be tainting and aren't +# (but regular users deserve protection too, though!) +if (!($Is_VMS || $Is_MSWin32 || $Is_Dos || $Is_OS2) && ($> == 0 || $< == 0) + && !am_taint_checking()) +{{ + if ($opt_U) { + my $id = eval { getpwnam("nobody") }; + $id = eval { getpwnam("nouser") } unless defined $id; + $id = -2 unless defined $id; + eval { + $> = $id; # must do this one first! + $< = $id; + }; + last if !$@ && $< && $>; + } + die "Superuser must not run $0 without security audit and taint checks.\n"; +}} + $opt_n = "nroff" if !$opt_n; my $podidx; @@ -141,14 +180,14 @@ if ($opt_X) { $podidx = "" unless -f $podidx && -r _ && -M _ <= 7; } -if ((my $opts = do{ local $^W; $opt_t + $opt_u + $opt_m + $opt_l }) > 1) { +if ((my $opts = do{ no warnings; $opt_t + $opt_u + $opt_m + $opt_l }) > 1) { usage("only one of -t, -u, -m or -l") } elsif ($Is_MSWin32 || $Is_Dos - || !(exists $ENV{TERM} && $ENV{TERM} !~ /dumb|emacs|none|unknown/i)) + || !($ENV{TERM} && $ENV{TERM} !~ /dumb|emacs|none|unknown/i)) { - $opt_t = 1 unless $opts + $opt_t = 1 unless $opts; } if ($opt_t) { require Pod::Text; import Pod::Text; } @@ -166,30 +205,35 @@ else { # Does this look like a module or extension directory? if (-f "Makefile.PL") { - # Add ., lib and blib/* libs to @INC (if they exist) - unshift(@INC, '.'); - unshift(@INC, 'lib') if -d 'lib'; - require ExtUtils::testlib; + + # Add ., lib to @INC (if they exist) + eval q{ use lib qw(. lib); 1; } or die; + + # don't add if superuser + if ($< && $> && -f "blib") { # don't be looking too hard now! + eval q{ use blib; 1 }; + warn $@ if $@ && $opt_v; + } } sub containspod { my($file, $readit) = @_; - return 1 if !$readit && $file =~ /\.pod$/i; + return 1 if !$readit && $file =~ /\.pod\z/i; local($_); - open(TEST,"<$file"); + open(TEST,"<", $file) or die "Can't open $file: $!"; while () { if (/^=head/) { - close(TEST); + close(TEST) or die "Can't close $file: $!"; return 1; } } - close(TEST); + close(TEST) or die "Can't close $file: $!"; return 0; } sub minus_f_nocase { my($dir,$file) = @_; - my $path = join('/',$dir,$file); + my $path = catfile($dir,$file); return $path if -f $path and -r _; if (!$opt_i or $Is_VMS or $Is_MSWin32 or $Is_Dos or $^O eq 'os2') { # on a case-forgiving file system or if case is important @@ -198,16 +242,18 @@ sub minus_f_nocase { return ''; } local *DIR; + # this is completely wicked. don't mess with $", and if + # you do, don't assume / is the dirsep! local($")="/"; my @p = ($dir); my($p,$cip); - foreach $p (split(/\//, $file)){ - my $try = "@p/$p"; + foreach $p (splitdir $file){ + my $try = catfile @p, $p; stat $try; if (-d _) { push @p, $p; if ( $p eq $global_target) { - my $tmp_path = join ('/', @p); + my $tmp_path = catfile @p; my $path_f = 0; for (@global_found) { $path_f = 1 if $_ eq $tmp_path; @@ -222,17 +268,17 @@ sub minus_f_nocase { elsif (-f _) { warn "Ignored $try: unreadable\n"; } - else { + elsif (-d "@p") { my $found=0; my $lcp = lc $p; - opendir DIR, "@p"; + opendir DIR, "@p" or die "opendir @p: $!"; while ($cip=readdir(DIR)) { if (lc $cip eq $lcp){ $found++; last; } } - closedir DIR; + closedir DIR or die "closedir @p: $!"; return "" unless $found; push @p, $cip; return "@p" if -f "@p" and -r _; @@ -266,10 +312,10 @@ sub searchfor { my $ret; my $i; my $dir; - $global_target = (split('/', $s))[-1]; + $global_target = (splitdir $s)[-1]; # XXX: why not use File::Basename? for ($i=0; $i<@dirs; $i++) { $dir = $dirs[$i]; - ($dir = VMS::Filespec::unixpath($dir)) =~ s!/$!! if $Is_VMS; + ($dir = VMS::Filespec::unixpath($dir)) =~ s!/\z!! if $Is_VMS; if ( ( $ret = check_file $dir,"$s.pod") or ( $ret = check_file $dir,"$s.pm") or ( $ret = check_file $dir,$s) @@ -288,15 +334,16 @@ sub searchfor { } if ($recurse) { - opendir(D,$dir); - my @newdirs = map "$dir/$_", grep { - not /^\.\.?$/ and - not /^auto$/ and # save time! don't search auto dirs - -d "$dir/$_" + opendir(D,$dir) or die "Can't opendir $dir: $!"; + my @newdirs = map catfile($dir, $_), grep { + not /^\.\.?\z/s and + not /^auto\z/s and # save time! don't search auto dirs + -d catfile($dir, $_) } readdir D; - closedir(D); + closedir(D) or die "Can't closedir $dir: $!"; next unless @newdirs; - @newdirs = map((s/.dir$//,$_)[1],@newdirs) if $Is_VMS; + # what a wicked map! + @newdirs = map((s/\.dir\z//,$_)[1],@newdirs) if $Is_VMS; print STDERR "Also looking in @newdirs\n" if $opt_v; push(@dirs,@newdirs); } @@ -318,45 +365,62 @@ sub printout { my $err; if ($opt_t) { - open(OUT,">>$tmp") or warn("Can't open $tmp: $!"), return; + # why was this append? + sysopen(OUT, $tmp, O_WRONLY | O_EXCL | O_CREAT, 0600) + or die ("Can't open $tmp: $!"); Pod::Text->new()->parse_from_file($file,\*OUT); - close OUT; + close OUT or die "can't close $tmp: $!"; } elsif (not $opt_u) { - my $cmd = "pod2man --lax $_ | $opt_n -man"; + my $cmd = catfile($bindir, 'pod2man') . " --lax $file | $opt_n -man"; $cmd .= " | col -x" if $^O =~ /hpux/; my $rslt = `$cmd`; $rslt = filter_nroff($rslt) if $filter; unless (($err = $?)) { - open(TMP,">>$tmp") or warn("Can't open $tmp: $!"), return; - print TMP $rslt; - close TMP; + # why was this append? + sysopen(TMP, $tmp, O_WRONLY | O_EXCL | O_CREAT, 0600) + or die "Can't open $tmp: $!"; + print TMP $rslt + or die "Can't print $tmp: $!"; + close TMP + or die "Can't close $tmp: $!"; } } - if ($opt_u or $err or -z $tmp) { - open(OUT,">>$tmp") or warn("Can't open $tmp: $!"), return; - open(IN,"<$file") or warn("Can't open $file: $!"), return; + if ($opt_u or $err or -z $tmp) { # XXX: race with -z + # why was this append? + sysopen(OUT, $tmp, O_WRONLY | O_EXCL | O_CREAT, 0600) + or die "Can't open $tmp: $!"; + open(IN,"<", $file) or die("Can't open $file: $!"); my $cut = 1; + local $_; while () { $cut = $1 eq 'cut' if /^=(\w+)/; next if $cut; - print OUT; + print OUT + or die "Can't print $tmp: $!"; } - close IN; - close OUT; + close IN or die "Can't close $file: $!"; + close OUT or die "Can't close $tmp: $!"; } } sub page { my ($tmp, $no_tty, @pagers) = @_; if ($no_tty) { - open(TMP,"<$tmp") or warn("Can't open $tmp: $!"), return; - print while ; - close TMP; + open(TMP,"<", $tmp) or die "Can't open $tmp: $!"; + local $_; + while () { + print or die "Can't print to stdout: $!"; + } + close TMP or die "Can't close while $tmp: $!"; } else { foreach my $pager (@pagers) { - system("$pager $tmp") or last; + if ($Is_VMS) { + last if system("$pager $tmp") == 0; # quoting prevents logical expansion + } else { + last if system("$pager \"$tmp\"") == 0; + } } } } @@ -364,40 +428,31 @@ sub page { sub cleanup { my @files = @_; for (@files) { - 1 while unlink($_); #Possibly pointless VMSism + if ($Is_VMS) { + 1 while unlink($_); # XXX: expect failure + } else { + unlink($_); # or die "Can't unlink $_: $!"; + } } } -sub safe_exit { - my ($val, @files) = @_; - cleanup(@files); - exit $val; -} - -sub safe_die { - my ($msg, @files) = @_; - cleanup(@files); - die $msg; -} - my @found; foreach (@pages) { if ($podidx && open(PODIDX, $podidx)) { - my $searchfor = $_; - local($_); - $searchfor =~ s,::,/,g; + my $searchfor = catfile split '::'; print STDERR "Searching for '$searchfor' in $podidx\n" if $opt_v; + local $_; while () { chomp; - push(@found, $_) if m,/$searchfor(?:\.(?:pod|pm))?$,i; + push(@found, $_) if m,/$searchfor(?:\.(?:pod|pm))?\z,i; } - close(PODIDX); + close(PODIDX) or die "Can't close $podidx: $!"; next; } print STDERR "Searching for $_\n" if $opt_v; - # We must look both in @INC for library modules and in PATH + # We must look both in @INC for library modules and in $bindir # for executables, like h2xs or perldoc itself. - my @searchdirs = @INC; + my @searchdirs = ($bindir, @INC); if ($opt_F) { next unless -r; push @found, $_ if $opt_m or containspod($_); @@ -422,7 +477,7 @@ foreach (@pages) { } else { # no match, try recursive search - @searchdirs = grep(!/^\.$/,@INC); + @searchdirs = grep(!/^\.\z/s,@INC); @files= searchfor(1,$_,@searchdirs) if $opt_r; if (@files) { print STDERR "Loosely found as @files\n" if $opt_v; @@ -432,13 +487,13 @@ foreach (@pages) { if (@global_found) { print STDERR "However, try\n"; for my $dir (@global_found) { - opendir(DIR, $dir) or die "$!"; + opendir(DIR, $dir) or die "opendir $dir: $!"; while (my $file = readdir(DIR)) { - next if ($file =~ /^\./); - $file =~ s/\.(pm|pod)$//; + next if ($file =~ /^\./s); + $file =~ s/\.(pm|pod)\z//; # XXX: badfs print STDERR "\tperldoc $_\::$file\n"; } - closedir DIR; + closedir DIR or die "closedir $dir: $!"; } } } @@ -459,10 +514,12 @@ my $lines = $ENV{LINES} || 24; my $no_tty; if (! -t STDOUT) { $no_tty = 1 } +END { close(STDOUT) || die "Can't close STDOUT: $!" } # until here we could simply exit or die # now we create temporary files that we have to clean up # namely $tmp, $buffer +# that's because you did it wrong, should be descriptor based --tchrist my $tmp; my $buffer; @@ -494,38 +551,54 @@ else { unshift @pagers, 'less', 'cmd /c more <'; } else { - $tmp = "/tmp/perldoc1.$$"; - $buffer = "/tmp/perldoc1.b$$"; + # XXX: this is not secure, because it doesn't open it + ($tmp, $buffer) = eval { require POSIX } + ? (POSIX::tmpnam(), POSIX::tmpnam() ) + : ("/tmp/perldoc1.$$", "/tmp/perldoc1.b$$" ); } push @pagers, qw( more less pg view cat ); unshift @pagers, $ENV{PAGER} if $ENV{PAGER}; } unshift @pagers, $ENV{PERLDOC_PAGER} if $ENV{PERLDOC_PAGER}; -# all exit calls from here on have to be safe_exit calls (see above) -# and all die calls safe_die calls to guarantee removal of files and -# dir as needed +# make sure cleanup called +eval q{ + sub END { cleanup($tmp, $buffer) } + 1; +} || die; + +# exit/die in a windows sighandler is dangerous, so let it do the +# default thing, which is to exit +eval q{ use sigtrap qw(die INT TERM HUP QUIT) } unless $^O eq 'MSWin32'; if ($opt_m) { foreach my $pager (@pagers) { - system("$pager @found") or safe_exit(0, $tmp, $buffer); + if (system($pager, @found) == 0) { + exit; + } + } + if ($Is_VMS) { + eval q{ + use vmsish qw(status exit); + exit $?; + 1; + } or die; } - if ($Is_VMS) { eval 'use vmsish qw(status exit); exit $?' } - # I don't get the line above. Please patch yourself as needed. - safe_exit(1, $tmp, $buffer); + exit(1); } my @pod; if ($opt_f) { my $perlfunc = shift @found; - open(PFUNC, $perlfunc) - or safe_die("Can't open $perlfunc: $!", $tmp, $buffer); + open(PFUNC, "<", $perlfunc) + or die("Can't open $perlfunc: $!"); # Functions like -r, -e, etc. are listed under `-X'. my $search_string = ($opt_f =~ /^-[rwxoRWXOeszfdlpSbctugkTBMAC]$/) ? 'I<-X' : $opt_f ; # Skip introduction + local $_; while () { last if /^=head2 Alphabetical Listing of Perl Functions/; } @@ -553,20 +626,22 @@ if ($opt_f) { if (!@pod) { die "No documentation for perl function `$opt_f' found\n"; } + close PFUNC or die "Can't open $perlfunc: $!"; } if ($opt_q) { local @ARGV = @found; # I'm lazy, sue me. my $found = 0; my %found_in; - my $rx = eval { qr/$opt_q/ }; - die <|]/ } + local $_; while (<>) { if (/^=head2\s+.*(?:$opt_q)/oi) { $found = 1; @@ -579,19 +654,19 @@ EOD push @pod, $_; } if (!@pod) { - safe_die("No documentation for perl FAQ keyword `$opt_q' found\n", - $tmp, $buffer); + die("No documentation for perl FAQ keyword `$opt_q' found\n"); } } my $filter; if (@pod) { - open(TMP,">$buffer") or safe_die("Can't open '$buffer': $!", $tmp, $buffer); + sysopen(TMP, $buffer, O_WRONLY | O_EXCL | O_CREAT) + or die("Can't open $buffer: $!"); print TMP "=over 8\n\n"; - print TMP @pod; + print TMP @pod or die "Can't print $buffer: $!"; print TMP "=back\n"; - close TMP; + close TMP or die "Can't close $buffer: $!"; @found = $buffer; $filter = 1; } @@ -601,7 +676,21 @@ foreach (@found) { } page($tmp, $no_tty, @pagers); -safe_exit(0, $tmp, $buffer); +exit; + +sub is_tainted { + my $arg = shift; + my $nada = substr($arg, 0, 0); # zero-length + local $@; # preserve caller's version + eval { eval "# $nada" }; + return length($@) != 0; +} + +sub am_taint_checking { + my($k,$v) = each %ENV; + return is_tainted($v); +} + __END__ @@ -681,6 +770,15 @@ The B<-X> option looks for a entry whose basename matches the name given on the command line in the file C<$Config{archlib}/pod.idx>. The pod.idx file should contain fully qualified filenames, one per line. +=item B<-U> run insecurely + +Because B does not run properly tainted, and is known to +have security issues, it will not normally execute as the superuser. +If you use the B<-U> flag, it will do so, but only after setting +the effective and real IDs to nobody's or nouser's account, or -2 +if unavailable. If it cannot relinguish its privileges, it will not +run. + =item B The item you want to look up. Nested modules (such as C) @@ -708,7 +806,7 @@ One useful value for C is C. =head1 VERSION -This is perldoc v2.0. +This is perldoc v2.03. =head1 AUTHOR @@ -720,6 +818,17 @@ and others. =cut # +# Version 2.03: Sun Apr 23 16:56:34 BST 2000 +# Hugo van der Sanden +# don't die when 'use blib' fails +# Version 2.02: Mon Mar 13 18:03:04 MST 2000 +# Tom Christiansen +# Added -U insecurity option +# Version 2.01: Sat Mar 11 15:22:33 MST 2000 +# Tom Christiansen , querulously. +# Security and correctness patches. +# What a twisted bit of distasteful spaghetti code. +# Version 2.0: ???? # Version 1.15: Tue Aug 24 01:50:20 EST 1999 # Charles Wilson # changed /pod/ directory to /pods/ for cygwin