diff options
| -rw-r--r-- | MANIFEST | 15 | ||||
| -rw-r--r-- | lib/Pod/Perldoc.pm | 1708 | ||||
| -rw-r--r-- | lib/Pod/Perldoc/BaseTo.pm | 28 | ||||
| -rw-r--r-- | lib/Pod/Perldoc/GetOptsOO.pm | 106 | ||||
| -rw-r--r-- | lib/Pod/Perldoc/ToChecker.pm | 72 | ||||
| -rw-r--r-- | lib/Pod/Perldoc/ToMan.pm | 161 | ||||
| -rw-r--r-- | lib/Pod/Perldoc/ToNroff.pm | 100 | ||||
| -rw-r--r-- | lib/Pod/Perldoc/ToPod.pm | 90 | ||||
| -rw-r--r-- | lib/Pod/Perldoc/ToRtf.pm | 85 | ||||
| -rw-r--r-- | lib/Pod/Perldoc/ToText.pm | 91 | ||||
| -rw-r--r-- | lib/Pod/Perldoc/ToTk.pm | 129 | ||||
| -rw-r--r-- | lib/Pod/Perldoc/ToXml.pm | 63 | ||||
| -rw-r--r-- | lib/Pod/Perldoc/t/checkerbasic.t | 9 | ||||
| -rw-r--r-- | lib/Pod/Perldoc/t/perldocbasic.t | 9 | ||||
| -rw-r--r-- | lib/Pod/Perldoc/t/textbasic.t | 9 | ||||
| -rw-r--r-- | pod/perldoc.pod | 220 | ||||
| -rw-r--r-- | utils/perldoc.PL | 831 |
17 files changed, 2915 insertions, 811 deletions
@@ -1395,6 +1395,20 @@ lib/Pod/Man.pm Convert POD data to *roff lib/Pod/ParseLink.pm Perl an L<> formatting code in POD text lib/Pod/Parser.pm Pod-Parser - define base class for parsing POD lib/Pod/ParseUtils.pm Pod-Parser - pod utility functions +lib/Pod/Perldoc.pm guts of the 'perldoc' utility +lib/Pod/Perldoc/BaseTo.pm utility module for perldoc +lib/Pod/Perldoc/GetOptsOO.pm options parsing for perldoc +lib/Pod/Perldoc/ToChecker.pm let perldoc check POD for errors +lib/Pod/Perldoc/ToMan.pm render POD as man pages +lib/Pod/Perldoc/ToNroff.pm convert POD to nroff +lib/Pod/Perldoc/ToPod.pm convert POD to POD +lib/Pod/Perldoc/ToRtf.pm convert POD to RTF +lib/Pod/Perldoc/ToText.pm convert POD to plain text +lib/Pod/Perldoc/ToTk.pm convert POD via Tk::Pod +lib/Pod/Perldoc/ToXml.pm convert POD to XML +lib/Pod/Perldoc/t/checkerbasic.t test Pod::Perldoc::ToChecker +lib/Pod/Perldoc/t/perldocbasic.t test Pod::Perldoc basic operation +lib/Pod/Perldoc/t/textbasic.t test Pod::Perldoc::ToText lib/Pod/Plainer.pm Pod migration utility module lib/Pod/PlainText.pm Convert POD data to formatted ASCII text lib/Pod/Select.pm Pod-Parser - select portions of POD docs @@ -2179,6 +2193,7 @@ pod/perldebtut.pod Perl debugging tutorial pod/perldebug.pod Debugger info pod/perldelta.pod Changes since last version pod/perldiag.pod Diagnostic info +pod/perldoc.pod docs for utils/perldoc pod/perldsc.pod Data Structures Cookbook pod/perlebcdic.pod Considerations for running Perl on EBCDIC platforms pod/perlembed.pod Embedding info diff --git a/lib/Pod/Perldoc.pm b/lib/Pod/Perldoc.pm new file mode 100644 index 0000000000..4975b390a4 --- /dev/null +++ b/lib/Pod/Perldoc.pm @@ -0,0 +1,1708 @@ + +require 5; +package Pod::Perldoc; +use strict; +use warnings; +use Config '%Config'; + +use Fcntl; # for sysopen +use File::Spec::Functions qw(catfile catdir splitdir); + +use vars qw($VERSION @Pagers $Bindir $Pod2man + $Temp_Files_Created $Temp_File_Lifetime +); +$VERSION = '3.07'; +#.......................................................................... + +BEGIN { # Make a DEBUG constant very first thing... + unless(defined &DEBUG) { + if(($ENV{'PERLDOCDEBUG'} || '') =~ m/^(\d+)/) { # untaint + eval("sub DEBUG () {$1}"); + die "WHAT? Couldn't eval-up a DEBUG constant!? $@" if $@; + } else { + *DEBUG = sub () {0}; + } + } +} + +use Pod::Perldoc::GetOptsOO; # uses the DEBUG. + +#.......................................................................... +{ my $pager = $Config{'pager'}; + push @Pagers, $pager if -x (split /\\s+/, $pager)[0]; +} +$Bindir = $Config{'scriptdirexp'}; +$Pod2man = "pod2man" . ( $Config{'versiononly'} ? $Config{'version'} : '' ); + +#.......................................................................... + +sub TRUE () {1} +sub FALSE () {return} + +BEGIN { + *IS_VMS = $^O eq 'VMS' ? \&TRUE : \&FALSE unless defined &IS_VMS; + *IS_MSWin32 = $^O eq 'MSWin32' ? \&TRUE : \&FALSE unless defined &IS_MSWin32; + *IS_Dos = $^O eq 'dos' ? \&TRUE : \&FALSE unless defined &IS_Dos; + *IS_OS2 = $^O eq 'os2' ? \&TRUE : \&FALSE unless defined &IS_OS2; +} + +$Temp_File_Lifetime ||= 60 * 60 * 24 * 5; + # If it's older than five days, it's quite unlikely + # that anyone's still looking at it!! + # (Currently used only by the MSWin cleanup routine) + +# End of class-init stuff +# +########################################################################### +# +# Option accessors... + +foreach my $subname (map "opt_$_", split '', q{mhlvriFfXqnTd}) { + no strict 'refs'; + *$subname = do{ use strict 'refs'; sub () { shift->_elem($subname, @_) } }; +} + +# And these are so that GetOptsOO knows they take options: +sub opt_f_with { shift->_elem('opt_f', @_) } +sub opt_q_with { shift->_elem('opt_q', @_) } +sub opt_d_with { shift->_elem('opt_d', @_) } + +sub opt_w_with { # Specify an option for the formatter subclass + my($self, $value) = @_; + if($value =~ m/^([-_a-zA-Z][-_a-zA-Z0-9]*)(?:[=\:](.*?))?$/s) { + my $option = $1; + my $option_value = defined($2) ? $2 : "TRUE"; + $option =~ tr/\-/_/s; # tolerate "foo-bar" for "foo_bar" + $self->add_formatter_option( $option, $option_value ); + } else { + warn "\"$value\" isn't a good formatter option name. I'm ignoring it!\n"; + } + return; +} + +sub opt_M_with { # specify formatter class name(s) + my($self, $classes) = @_; + return unless defined $classes and length $classes; + DEBUG > 4 and print "Considering new formatter classes -M$classes\n"; + my @classes_to_add; + foreach my $classname (split m/[,;]+/s, $classes) { + next unless $classname =~ m/\S/; + if( $classname =~ m/^(\w+(::\w+)+)$/s ) { + # A mildly restrictive concept of what modulenames are valid. + push @classes_to_add, $1; # untaint + } else { + warn "\"$classname\" isn't a valid classname. Ignoring.\n"; + } + } + + unshift @{ $self->{'formatter_classes'} }, @classes_to_add; + + DEBUG > 3 and print( + "Adding @classes_to_add to the list of formatter classes, " + . "making them @{ $self->{'formatter_classes'} }.\n" + ); + + return; +} + +sub opt_V { # report version and exit + print join '', + "Perldoc v$VERSION, under perl v$] for $^O", + + (defined(&Win32::BuildNumber) and defined &Win32::BuildNumber()) + ? (" (win32 build ", &Win32::BuildNumber(), ")") : (), + + (chr(65) eq 'A') ? () : " (non-ASCII)", + + "\n", + ; + exit; +} + +sub opt_U {} # legacy no-op + +sub opt_t { # choose plaintext as output format + my $self = shift; + $self->opt_o_with('text') if @_ and $_[0]; + return $self->_elem('opt_t', @_); +} + +sub opt_u { # choose raw pod as output format + my $self = shift; + $self->opt_o_with('pod') if @_ and $_[0]; + return $self->_elem('opt_u', @_); +} + +sub opt_n_with { + # choose man as the output format, and specify the proggy to run + my $self = shift; + $self->opt_o_with('man') if @_ and $_[0]; + $self->_elem('opt_n', @_); +} + +sub opt_o_with { # "o" for output format + my($self, $rest) = @_; + return unless defined $rest and length $rest; + if($rest =~ m/^(\w+)$/s) { + $rest = $1; #untaint + } else { + warn "\"$rest\" isn't a valid output format. Skipping.\n"; + return; + } + + $self->aside("Noting \"$rest\" as desired output format...\n"); + + # Figure out what class(es) that could actually mean... + + my @classes; + foreach my $prefix ("Pod::Perldoc::To", "Pod::Simple::", "Pod::") { + # Messy but smart: + foreach my $stem ( + $rest, # Yes, try it first with the given capitalization + "\L$rest", "\L\u$rest", "\U$rest" # And then try variations + + ) { + push @classes, $prefix . $stem; + #print "Considering $prefix$stem\n"; + } + + # Tidier, but misses too much: + #push @classes, $prefix . ucfirst(lc($rest)); + } + $self->opt_M_with( join ";", @classes ); + return; +} + +########################################################################### +# % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % + +sub run { # to be called by the "perldoc" executable + my $class = shift; + if(DEBUG > 3) { + print "Parameters to $class\->run:\n"; + my @x = @_; + while(@x) { + $x[1] = '<undef>' unless defined $x[1]; + $x[1] = "@{$x[1]}" if ref( $x[1] ) eq 'ARRAY'; + print " [$x[0]] => [$x[1]]\n"; + splice @x,0,2; + } + print "\n"; + } + return $class -> new(@_) -> process() || 0; +} + +# % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % +########################################################################### + +sub new { # yeah, nothing fancy + my $class = shift; + my $new = bless {@_}, (ref($class) || $class); + DEBUG > 1 and print "New $class object $new\n"; + $new->init(); + $new; +} + +#.......................................................................... + +sub aside { # If we're in -v or DEBUG mode, say this. + my $self = shift; + if( DEBUG or $self->opt_v ) { + my $out = join( '', + DEBUG ? do { + my $callsub = (caller(1))[3]; + my $package = quotemeta(__PACKAGE__ . '::'); + $callsub =~ s/^$package/'/os; + $callsub . ": "; + } : '', + @_, + ); + if(DEBUG) { print $out } else { print STDERR $out } + } + return; +} + +#.......................................................................... + +sub usage { + my $self = shift; + warn "@_\n" if @_; + + # Erase evidence of previous errors (if any), so exit status is simple. + $! = 0; + + die <<EOF; +perldoc [options] PageName|ModuleName|ProgramName... +perldoc [options] -f BuiltinFunction +perldoc [options] -q FAQRegex + +Options: + -h Display this help message + -V report version + -r Recursive search (slow) + -i Ignore case + -t Display pod using pod2text instead of pod2man and nroff + (-t is the default on win32 unless -n is specified) + -u Display unformatted pod text + -m Display module's file in its entirety + -n Specify replacement for nroff + -l Display the module's file name + -F Arguments are file names, not modules + -v Verbosely describe what's going on + -T Send output to STDOUT without any pager + -d output_filename_to_send_to + -o output_format_name + -M FormatterModuleNameToUse + -w formatter_option:option_value + -X use index if present (looks for pod.idx at $Config{archlib}) + -q Search the text of questions (not answers) in perlfaq[1-9] + +PageName|ModuleName... + is the name of a piece of documentation that you want to look at. You + may either give a descriptive name of the page (as in the case of + `perlfunc') the name of a module, either like `Term::Info' or like + `Term/Info', or the name of a program, like `perldoc'. + +BuiltinFunction + is the name of a perl function. Will extract documentation from + `perlfunc'. + +FAQRegex + is a regex. Will search perlfaq[1-9] for and extract any + questions that match. + +Any switches in the PERLDOC environment variable will be used before the +command line arguments. The optional pod index file contains a list of +filenames, one per line. + [Perldoc v$VERSION] +EOF + +} + +#.......................................................................... + +sub usage_brief { + my $me = $0; # Editing $0 is unportable + + $me =~ s,.*[/\\],,; # get basename + + die <<"EOUSAGE"; +Usage: $me [-h] [-V] [-r] [-i] [-v] [-t] [-u] [-m] [-n nroffer_program] [-l] [-T] [-d output_filename] [-o output_format] [-M FormatterModuleNameToUse] [-w formatter_option:option_value] [-F] [-X] PageName|ModuleName|ProgramName + $me -f PerlFunc + $me -q FAQKeywords + +The -h option prints more help. Also try "perldoc perldoc" to get +acquainted with the system. [Perldoc v$VERSION] +EOUSAGE + +} + +#.......................................................................... + +sub pagers { @{ shift->{'pagers'} } } + +#.......................................................................... + +sub _elem { # handy scalar meta-accessor: shift->_elem("foo", @_) + if(@_ > 2) { return $_[0]{ $_[1] } = $_[2] } + else { return $_[0]{ $_[1] } } +} +#.......................................................................... +########################################################################### +# +# Init formatter switches, and start it off with __bindir and all that +# other stuff that ToMan.pm needs. +# + +sub init { + my $self = shift; + + # Make sure creat()s are neither too much nor too little + eval { umask(0077) }; # doubtless someone has no mask + + $self->{'args'} ||= \@ARGV; + $self->{'found'} ||= []; + $self->{'temp_file_list'} ||= []; + + + $self->{'target'} = undef; + + $self->init_formatter_class_list; + + $self->{'pagers' } = [@Pagers] unless exists $self->{'pagers'}; + $self->{'bindir' } = $Bindir unless exists $self->{'bindir'}; + $self->{'pod2man'} = $Pod2man unless exists $self->{'pod2man'}; + + push @{ $self->{'formatter_switches'} = [] }, ( + # Yeah, we could use a hashref, but maybe there's some class where options + # have to be ordered; so we'll use an arrayref. + + [ '__bindir' => $self->{'bindir' } ], + [ '__pod2man' => $self->{'pod2man'} ], + ); + + DEBUG > 3 and printf "Formatter switches now: [%s]\n", + join ' ', map "[@$_]", @{ $self->{'formatter_switches'} }; + + return; +} + +#.......................................................................... + +sub init_formatter_class_list { + my $self = shift; + $self->{'formatter_classes'} ||= []; + + # Remember, no switches have been read yet, when + # we've started this routine. + + $self->opt_M_with('Pod::Perldoc::ToPod'); # the always-there fallthru + $self->opt_o_with('text'); + $self->opt_o_with('man') unless IS_MSWin32 || IS_Dos + || !($ENV{TERM} && $ENV{TERM} !~ /dumb|emacs|none|unknown/i); + + return; +} + +#.......................................................................... + +sub process { + # if this ever returns, its retval will be used for exit(RETVAL) + + my $self = shift; + DEBUG > 1 and print " Beginning process.\n"; + DEBUG > 1 and print " Args: @{$self->{'args'}}\n\n"; + if(DEBUG > 3) { + print "Object contents:\n"; + my @x = %$self; + while(@x) { + $x[1] = '<undef>' unless defined $x[1]; + $x[1] = "@{$x[1]}" if ref( $x[1] ) eq 'ARRAY'; + print " [$x[0]] => [$x[1]]\n"; + splice @x,0,2; + } + print "\n"; + } + + # TODO: make it deal with being invoked as various different things + # such as perlfaq". + + return $self->usage_brief unless @{ $self->{'args'} }; + $self->pagers_guessing; + $self->options_reading; + $self->aside(sprintf "$0 => %s v%s\n", ref($self), $self->VERSION); + $self->drop_privs_maybe; + $self->options_processing; + + # Hm, we have @pages and @found, but we only really act on one + # file per call, with the exception of the opt_q hack, and with + # -l things + + $self->aside("\n"); + + my @pages; + $self->{'pages'} = \@pages; + if( $self->opt_f) { @pages = ("perlfunc") } + elsif( $self->opt_q) { @pages = ("perlfaq1" .. "perlfaq9") } + else { @pages = @{$self->{'args'}}; + # @pages = __FILE__ + # if @pages == 1 and $pages[0] eq 'perldoc'; + } + + return $self->usage_brief unless @pages; + + $self->find_good_formatter_class(); + $self->formatter_sanity_check(); + + $self->maybe_diddle_INC(); + # for when we're apparently in a module or extension directory + + my @found = $self->grand_search_init(\@pages); + exit (IS_VMS ? 98962 : 1) unless @found; + + if ($self->opt_l) { + DEBUG and print "We're in -l mode, so byebye after this:\n"; + print join("\n", @found), "\n"; + return; + } + + $self->tweak_found_pathnames(\@found); + $self->assert_closing_stdout; + return $self->page_module_file(@found) if $self->opt_m; + DEBUG > 2 and print "Found: [@found]\n"; + + return $self->render_and_page(\@found); +} + +#.......................................................................... +{ + +my( %class_seen, %class_loaded ); +sub find_good_formatter_class { + my $self = $_[0]; + my @class_list = @{ $self->{'formatter_classes'} || [] }; + die "WHAT? Nothing in the formatter class list!?" unless @class_list; + + my $good_class_found; + foreach my $c (@class_list) { + DEBUG > 4 and print "Trying to load $c...\n"; + if($class_loaded{$c}) { + DEBUG > 4 and print "OK, the already-loaded $c it is!\n"; + $good_class_found = $c; + last; + } + + if($class_seen{$c}) { + DEBUG > 4 and print + "I've tried $c before, and it's no good. Skipping.\n"; + next; + } + + $class_seen{$c} = 1; + + if( $c->can('parse_from_file') ) { + DEBUG > 4 and print + "Interesting, the formatter class $c is already loaded!\n"; + + } elsif( + (IS_VMS or IS_MSWin32 or IS_Dos or IS_OS2) + # the alway case-insensitive fs's + and $class_seen{lc("~$c")}++ + ) { + DEBUG > 4 and print + "We already used something quite like \"\L$c\E\", so no point using $c\n"; + # This avoids redefining the package. + } else { + DEBUG > 4 and print "Trying to eval 'require $c'...\n"; + + local $^W = $^W; + if(DEBUG() or $self->opt_v) { + # feh, let 'em see it + } else { + $^W = 0; + # The average user just has no reason to be seeing + # $^W-suppressable warnings from the the require! + } + + eval "require $c"; + if($@) { + DEBUG > 4 and print "Couldn't load $c: $!\n"; + next; + } + } + + if( $c->can('parse_from_file') ) { + DEBUG > 4 and print "Settling on $c\n"; + my $v = $c->VERSION; + $v = ( defined $v and length $v ) ? " version $v" : ''; + $self->aside("Formatter class $c$v successfully loaded!\n"); + $good_class_found = $c; + last; + } else { + DEBUG > 4 and print "Class $c isn't a formatter?! Skipping.\n"; + } + } + + die "Can't find any loadable formatter class in @class_list?!\nAborting" + unless $good_class_found; + + $self->{'formatter_class'} = $good_class_found; + $self->aside("Will format with the class $good_class_found\n"); + + return; +} + +} +#.......................................................................... + +sub formatter_sanity_check { + my $self = shift; + my $formatter_class = $self->{'formatter_class'} + || die "NO FORMATTER CLASS YET!?"; + + if(!$self->opt_T # so -T can FORCE sending to STDOUT + and $formatter_class->can('is_pageable') + and !$formatter_class->is_pageable + and !$formatter_class->can('page_for_perldoc') + ) { + my $ext = + ($formatter_class->can('output_extension') + && $formatter_class->output_extension + ) || ''; + $ext = ".$ext" if length $ext; + + die + "When using Perldoc to format with $formatter_class, you have to\n" + . "specify -T or -dsomefile$ext\n" + . "See `perldoc perldoc' for more information on those switches.\n" + ; + } +} + +#.......................................................................... + +sub render_and_page { + my($self, $found_list) = @_; + + $self->maybe_generate_dynamic_pod($found_list); + + my($out, $formatter) = $self->render_findings($found_list); + + if($self->opt_d) { + printf "Perldoc (%s) output saved to %s\n", + $self->{'formatter_class'} || ref($self), + $out; + print "But notice that it's 0 bytes long!\n" unless -s $out; + + + } elsif( # Allow the formatter to "page" itself, if it wants. + $formatter->can('page_for_perldoc') + and do { + $self->aside("Going to call $formatter\->page_for_perldoc(\"$out\")\n"); + if( $formatter->page_for_perldoc($out, $self) ) { + $self->aside("page_for_perldoc returned true, so NOT paging with $self.\n"); + 1; + } else { + $self->aside("page_for_perldoc returned false, so paging with $self instead.\n"); + ''; + } + } + ) { + # Do nothing, since the formatter has "paged" it for itself. + + } else { + # Page it normally (internally) + + if( -s $out ) { # Usual case: + $self->page($out, $self->{'output_to_stdout'}, $self->pagers); + + } else { + # Odd case: + $self->aside("Skipping $out (from $$found_list[0] " + . "via $$self{'formatter_class'}) as it is 0-length.\n"); + + push @{ $self->{'temp_file_list'} }, $out; + $self->unlink_if_temp_file($out); + } + } + + $self->after_rendering(); # any extra cleanup or whatever + + return; +} + +#.......................................................................... + +sub options_reading { + my $self = shift; + + if( defined $ENV{"PERLDOC"} and length $ENV{"PERLDOC"} ) { + require Text::ParseWords; + $self->aside("Noting env PERLDOC setting of $ENV{'PERLDOC'}\n"); + # Yes, appends to the beginning + unshift @{ $self->{'args'} }, + Text::ParseWords::shellwords( $ENV{"PERLDOC"} ) + ; + DEBUG > 1 and print " Args now: @{$self->{'args'}}\n\n"; + } else { + DEBUG > 1 and print " Okay, no PERLDOC setting in ENV.\n"; + } + + DEBUG > 1 + and print " Args right before switch processing: @{$self->{'args'}}\n"; + + Pod::Perldoc::GetOptsOO::getopts( $self, $self->{'args'}, 'YES' ) + or return $self->usage; + + DEBUG > 1 + and print " Args after switch processing: @{$self->{'args'}}\n"; + + return $self->usage if $self->opt_h; + + return; +} + +#.......................................................................... + +sub options_processing { + my $self = shift; + + if ($self->opt_X) { + my $podidx = "$Config{'archlib'}/pod.idx"; + $podidx = "" unless -f $podidx && -r _ && -M _ <= 7; + $self->{'podidx'} = $podidx; + } + + $self->{'output_to_stdout'} = 1 if $self->opt_T or ! -t STDOUT; + + $self->options_sanity; + + $self->opt_n("nroff") unless $self->opt_n; + $self->add_formatter_option( '__nroffer' => $self->opt_n ); + + return; +} + +#.......................................................................... + +sub options_sanity { + my $self = shift; + + # The opts-counting stuff interacts quite badly with + # the $ENV{"PERLDOC"} stuff. I.e., if I have $ENV{"PERLDOC"} + # set to -t, and I specify -u on the command line, I don't want + # to be hectored at that -u and -t don't make sense together. + + #my $opts = grep $_ && 1, # yes, the count of the set ones + # $self->opt_t, $self->opt_u, $self->opt_m, $self->opt_l + #; + # + #$self->usage("only one of -t, -u, -m or -l") if $opts > 1; + + + # Any sanity-checking need doing here? + + return; +} + +#.......................................................................... + +sub grand_search_init { + my($self, $pages, @found) = @_; + + foreach (@$pages) { + if ($self->{'podidx'} && open(PODIDX, $self->{'podidx'})) { + my $searchfor = catfile split '::', $_; + $self->aside( "Searching for '$searchfor' in $self->{'podidx'}\n" ); + local $_; + while (<PODIDX>) { + chomp; + push(@found, $_) if m,/$searchfor(?:\.(?:pod|pm))?\z,i; + } + close(PODIDX) or die "Can't close $$self{'podidx'}: $!"; + next; + } + + $self->aside( "Searching for $_\n" ); + + if ($self->opt_F) { + next unless -r; + push @found, $_ if $self->opt_m or $self->containspod($_); + next; + } + + # We must look both in @INC for library modules and in $bindir + # for executables, like h2xs or perldoc itself. + + my @searchdirs = ($self->{'bindir'}, @INC); + unless ($self->opt_m) { + if (IS_VMS) { + my($i,$trn); + for ($i = 0; $trn = $ENV{'DCL$PATH;'.$i}; $i++) { + push(@searchdirs,$trn); + } + push(@searchdirs,'perl_root:[lib.pod]') # installed pods + } + else { + push(@searchdirs, grep(-d, split($Config{path_sep}, + $ENV{'PATH'}))); + } + } + my @files = $self->searchfor(0,$_,@searchdirs); + if (@files) { + $self->aside( "Found as @files\n" ); + } + else { + # no match, try recursive search + @searchdirs = grep(!/^\.\z/s,@INC); + @files= $self->searchfor(1,$_,@searchdirs) if $self->opt_r; + if (@files) { + $self->aside( "Loosely found as @files\n" ); + } + else { + print STDERR "No " . + ($self->opt_m ? "module" : "documentation") . " found for \"$_\".\n"; + if ( @{ $self->{'found'} } ) { + print STDERR "However, try\n"; + for my $dir (@{ $self->{'found'} }) { + opendir(DIR, $dir) or die "opendir $dir: $!"; + while (my $file = readdir(DIR)) { + next if ($file =~ /^\./s); + $file =~ s/\.(pm|pod)\z//; # XXX: badfs + print STDERR "\tperldoc $_\::$file\n"; + } + closedir DIR or die "closedir $dir: $!"; + } + } + } + } + push(@found,@files); + } + return @found; +} + +#.......................................................................... + +sub maybe_generate_dynamic_pod { + my($self, $found_things) = @_; + my @dynamic_pod; + + $self->search_perlfunc($found_things, \@dynamic_pod) if $self->opt_f; + + $self->search_perlfaqs($found_things, \@dynamic_pod) if $self->opt_q; + + if( ! $self->opt_f and ! $self->opt_q ) { + DEBUG > 4 and print "That's a non-dynamic pod search.\n"; + } elsif ( @dynamic_pod ) { + $self->aside("Hm, I found some Pod from that search!\n"); + my ($buffd, $buffer) = $self->new_tempfile('pod', 'dyn'); + + push @{ $self->{'temp_file_list'} }, $buffer; + # I.e., it MIGHT be deleted at the end. + + print $buffd "=over 8\n\n"; + print $buffd @dynamic_pod or die "Can't print $buffer: $!"; + print $buffd "=back\n"; + close $buffd or die "Can't close $buffer: $!"; + + @$found_things = $buffer; + # Yes, so found_things never has more than one thing in + # it, by time we leave here + + $self->add_formatter_option('__filter_nroff' => 1); + + } else { + @$found_things = (); + $self->aside("I found no Pod from that search!\n"); + } + + return; +} + +#.......................................................................... + +sub add_formatter_option { # $self->add_formatter_option('key' => 'value'); + my $self = shift; + push @{ $self->{'formatter_switches'} }, [ @_ ] if @_; + + DEBUG > 3 and printf "Formatter switches now: [%s]\n", + join ' ', map "[@$_]", @{ $self->{'formatter_switches'} }; + + return; +} + +#.......................................................................... + +sub search_perlfunc { + my($self, $found_things, $pod) = @_; + + DEBUG > 2 and print "Search: @$found_things\n"; + + my $perlfunc = shift @$found_things; + open(PFUNC, "<", $perlfunc) # "Funk is its own reward" + or die("Can't open $perlfunc: $!"); + + # Functions like -r, -e, etc. are listed under `-X'. + my $search_string = ($self->opt_f =~ /^-[rwxoRWXOeszfdlpSbctugkTBMAC]$/) + ? 'I<-X' : $self->opt_f ; + + DEBUG > 2 and + print "Going to perlfunc-scan for $search_string in $perlfunc\n"; + + + # Skip introduction + local $_; + while (<PFUNC>) { + last if /^=head2 Alphabetical Listing of Perl Functions/; + } + + # Look for our function + my $found = 0; + my $inlist = 0; + while (<PFUNC>) { # "The Mothership Connection is here!" + if (/^=item\s+\Q$search_string\E\b/o) { + $found = 1; + } + elsif (/^=item/) { + last if $found > 1 and not $inlist; + } + next unless $found; + if (/^=over/) { + ++$inlist; + } + elsif (/^=back/) { + --$inlist; + } + push @$pod, $_; + ++$found if /^\w/; # found descriptive text + } + if (!@$pod) { + die sprintf + "No documentation for perl function `%s' found\n", + $self->opt_f + ; + } + close PFUNC or die "Can't open $perlfunc: $!"; + + return; +} + +#.......................................................................... + +sub search_perlfaqs { + my( $self, $found_things, $pod) = @_; + + my $found = 0; + my %found_in; + my $search_key = $self->opt_q; + my $rx = eval { qr/$search_key/ } or die <<EOD; +Invalid regular expression '$search_key' given as -q pattern: +$@ +Did you mean \\Q$search_key ? + +EOD + + local $_; + foreach my $file (@$found_things) { + die "invalid file spec: $!" if $file =~ /[<>|]/; + open(INFAQ, "<", $file) or die "Can't read-open $file: $!\nAborting"; + while (<INFAQ>) { + if (/^=head2\s+.*(?:$search_key)/oi) { # it's good for only one key + $found = 1; + push @$pod, "=head1 Found in $file\n\n" unless $found_in{$file}++; + } + elsif (/^=head[12]/) { + $found = 0; + } + next unless $found; + push @$pod, $_; + } + close(INFAQ); + } + die("No documentation for perl FAQ keyword `$search_key' found\n") + unless @$pod; + + return; +} + + +#.......................................................................... + +sub render_findings { + # Return the filename to open + + my($self, $found_things) = @_; + + my $formatter_class = $self->{'formatter_class'} + || die "No formatter class set!?"; + my $formatter = $formatter_class->can('new') + ? $formatter_class->new + : $formatter_class + ; + + if(! @$found_things) { + die "Nothing found?!"; + # should have been caught before here + } elsif(@$found_things > 1) { + warn join '', + "Perldoc is only really meant for reading one document at a time.\n", + "So these parameters are being ignored: ", + join(' ', @$found_things[1 .. $#$found_things] ), + "\n" + } + + my $file = $found_things->[0]; + + DEBUG > 3 and printf "Formatter switches now: [%s]\n", + join ' ', map "[@$_]", @{ $self->{'formatter_switches'} }; + + # Set formatter options: + if( ref $formatter ) { + foreach my $f (@{ $self->{'formatter_switches'} || [] }) { + my($switch, $value, $silent_fail) = @$f; + if( $formatter->can($switch) ) { + eval { $formatter->$switch( defined($value) ? $value : () ) }; + warn "Got an error when setting $formatter_class\->$switch:\n$@\n" + if $@; + } else { + if( $silent_fail or $switch =~ m/^__/s ) { + DEBUG > 2 and print "Formatter $formatter_class doesn't support $switch\n"; + } else { + warn "$formatter_class doesn't recognize the $switch switch.\n"; + } + } + } + } + + $self->{'output_is_binary'} = + $formatter->can('write_with_binmode') && $formatter->write_with_binmode; + + my ($out_fh, $out) = $self->new_output_file( + ( $formatter->can('output_extension') && $formatter->output_extension ) + || undef, + $self->useful_filename_bit, + ); + + # Now, finally, do the formatting! + { + local $^W = $^W; + if(DEBUG() or $self->opt_v) { + # feh, let 'em see it + } else { + $^W = 0; + # The average user just has no reason to be seeing + # $^W-suppressable warnings from the formatting! + } + + eval { $formatter->parse_from_file( $file, $out_fh ) }; + } + + warn "Error while formatting with $formatter_class:\n $@\n" if $@; + DEBUG > 2 and print "Back from formatting with $formatter_class\n"; + + close $out_fh + or warn "Can't close $out: $!\n(Did $formatter already close it?)"; + sleep 0; sleep 0; sleep 0; + # Give the system a few timeslices to meditate on the fact + # that the output file does in fact exist and is closed. + + $self->unlink_if_temp_file($file); + + unless( -s $out ) { + if( $formatter->can( 'if_zero_length' ) ) { + # Basically this is just a hook for Pod::Simple::Checker; since + # what other class could /happily/ format an input file with Pod + # as a 0-length output file? + $formatter->if_zero_length( $file, $out, $out_fh ); + } else { + warn "Got a 0-length file from $$found_things[0] via $formatter_class!?\n" + } + } + + DEBUG and print "Finished writing to $out.\n"; + return($out, $formatter) if wantarray; + return $out; +} + +#.......................................................................... + +sub unlink_if_temp_file { + # Unlink the specified file IFF it's in the list of temp files. + # Really only used in the case of -f / -q things when we can + # throw away the dynamically generated source pod file once + # we've formatted it. + # + my($self, $file) = @_; + return unless defined $file and length $file; + + my $temp_file_list = $self->{'temp_file_list'} || return; + if(grep $_ eq $file, @$temp_file_list) { + $self->aside("Unlinking $file\n"); + unlink($file) or warn "Odd, couldn't unlink $file: $!"; + } else { + DEBUG > 1 and print "$file isn't a temp file, so not unlinking.\n"; + } + return; +} + +#.......................................................................... + +sub MSWin_temp_cleanup { + + # Nothing particularly MSWin-specific in here, but I don't know if any + # other OS needs its temp dir policed like MSWin does! + + my $self = shift; + + my $tempdir = $ENV{'TEMP'}; + return unless defined $tempdir and length $tempdir + and -e $tempdir and -d _ and -w _; + + $self->aside( + "Considering whether any old files of mine in $tempdir need unlinking.\n" + ); + + opendir(TMPDIR, $tempdir) || return; + my @to_unlink; + + my $limit = time() - $Temp_File_Lifetime; + + DEBUG > 5 and printf "Looking for things pre-dating %s (%x)\n", + ($limit) x 2; + + my $filespec; + + while(defined($filespec = readdir(TMPDIR))) { + if( + $filespec =~ m{^perldoc_[a-zA-Z0-9]+_T([a-fA-F0-9]{7,})_[a-fA-F0-9]{3,}}s + ) { + if( hex($1) < $limit ) { + push @to_unlink, "$tempdir/$filespec"; + $self->aside( "Will unlink my old temp file $to_unlink[-1]\n" ); + } else { + DEBUG > 5 and + printf " $tempdir/$filespec is too recent (after %x)\n", $limit; + } + } else { + DEBUG > 5 and + print " $tempdir/$filespec doesn't look like a perldoc temp file.\n"; + } + } + closedir(TMPDIR); + $self->aside(sprintf "Unlinked %s items of mine in %s\n", + scalar(unlink(@to_unlink)), + $tempdir + ); + return; +} + +# . . . . . . . . . . . . . . . . . . . . . . . . . + +sub MSWin_perldoc_tempfile { + my($self, $suffix, $infix) = @_; + + my $tempdir = $ENV{'TEMP'}; + return unless defined $tempdir and length $tempdir + and -e $tempdir and -d _ and -w _; + + my $spec; + + do { + $spec = sprintf "%s/perldoc_%s_T%x_%x%02x.%s", # used also in MSWin_temp_cleanup + # Yes, we embed the create-time in the filename! + $tempdir, + $infix || 'x', + time(), + $$, + defined( &Win32::GetTickCount ) + ? (Win32::GetTickCount() & 0xff) + : int(rand 256) + # Under MSWin, $$ values get reused quickly! So if we ran + # perldoc foo and then perldoc bar before there was time for + # time() to increment time."_$$" would likely be the same + # for each process! So we tack on the tick count's lower + # bits (or, in a pinch, rand) + , + $suffix || 'txt'; + ; + } while( -e $spec ); + + my $counter = 0; + + while($counter < 50) { + my $fh; + # If we are running before perl5.6.0, we can't autovivify + if ($] < 5.006) { + require Symbol; + $fh = Symbol::gensym(); + } + DEBUG > 3 and print "About to try making temp file $spec\n"; + return($fh, $spec) if open($fh, ">", $spec); + $self->aside("Can't create temp file $spec: $!\n"); + } + + $self->aside("Giving up on making a temp file!\n"); + die "Can't make a tempfile!?"; +} + +#.......................................................................... + + +sub after_rendering { + my $self = $_[0]; + $self->after_rendering_VMS if IS_VMS; + $self->after_rendering_MSWin32 if IS_MSWin32; + $self->after_rendering_Dos if IS_Dos; + $self->after_rendering_OS2 if IS_OS2; + return; +} + +sub after_rendering_VMS { return } +sub after_rendering_Dos { return } +sub after_rendering_OS2 { return } + +sub after_rendering_MSWin32 { + shift->MSWin_temp_cleanup() if $Temp_Files_Created; +} + +#.......................................................................... +# : : : : : : : : : +#.......................................................................... + + +sub minus_f_nocase { # i.e., do like -f, but without regard to case + + my($self, $dir, $file) = @_; + my $path = catfile($dir,$file); + return $path if -f $path and -r _; + + if(!$self->opt_i + or IS_VMS or IS_MSWin32 + or IS_Dos or IS_OS2 + ) { + # On a case-forgiving file system, or if case is important, + # that is it, all we can do. + warn "Ignored $path: unreadable\n" if -f _; + return ''; + } + + local *DIR; + my @p = ($dir); + my($p,$cip); + foreach $p (splitdir $file){ + my $try = catfile @p, $p; + $self->aside("Scrutinizing $try...\n"); + stat $try; + if (-d _) { + push @p, $p; + if ( $p eq $self->{'target'} ) { + my $tmp_path = catfile @p; + my $path_f = 0; + for (@{ $self->{'found'} }) { + $path_f = 1 if $_ eq $tmp_path; + } + push (@{ $self->{'found'} }, $tmp_path) unless $path_f; + $self->aside( "Found as $tmp_path but directory\n" ); + } + } + elsif (-f _ && -r _) { + return $try; + } + elsif (-f _) { + warn "Ignored $try: unreadable\n"; + } + elsif (-d catdir(@p)) { # at least we see the containing directory! + my $found = 0; + my $lcp = lc $p; + my $p_dirspec = catdir(@p); + opendir DIR, $p_dirspec or die "opendir $p_dirspec: $!"; + while(defined( $cip = readdir(DIR) )) { + if (lc $cip eq $lcp){ + $found++; + last; # XXX stop at the first? what if there's others? + } + } + closedir DIR or die "closedir $p_dirspec: $!"; + return "" unless $found; + + push @p, $cip; + my $p_filespec = catfile(@p); + return $p_filespec if -f $p_filespec and -r _; + warn "Ignored $p_filespec: unreadable\n" if -f _; + } + } + return ""; +} + +#.......................................................................... + +sub pagers_guessing { + my $self = shift; + + my @pagers; + push @pagers, $self->pagers; + $self->{'pagers'} = \@pagers; + + if (IS_MSWin32) { + push @pagers, qw( more< less notepad ); + unshift @pagers, $ENV{PAGER} if $ENV{PAGER}; + } + elsif (IS_VMS) { + push @pagers, qw( most more less type/page ); + } + elsif (IS_Dos) { + push @pagers, qw( less.exe more.com< ); + unshift @pagers, $ENV{PAGER} if $ENV{PAGER}; + } + else { + if (IS_OS2) { + unshift @pagers, 'less', 'cmd /c more <'; + } + push @pagers, qw( more less pg view cat ); + unshift @pagers, $ENV{PAGER} if $ENV{PAGER}; + } + unshift @pagers, $ENV{PERLDOC_PAGER} if $ENV{PERLDOC_PAGER}; + + return; +} + +#.......................................................................... + +sub page_module_file { + my($self, @found) = @_; + + # Security note: + # Don't ever just pass this off to anything like MSWin's "start.exe", + # since we might be calling on a .pl file, and we wouldn't want that + # to actually /execute/ the file that we just want to page thru! + # Also a consideration if one were to use a web browser as a pager; + # doing so could trigger the browser's MIME mapping for whatever + # it thinks .pm/.pl/whatever is. Probably just a (useless and + # annoying) "Save as..." dialog, but potentially executing the file + # in question -- particularly in the case of MSIE and it's, ahem, + # occasionally hazy distinction between OS-local extension + # associations, and browser-specific MIME mappings. + + if ($self->{'output_to_stdout'}) { + $self->aside("Sending unpaged output to STDOUT.\n"); + local $_; + my $any_error = 0; + foreach my $output (@found) { + unless( open(TMP, "<", $output) ) { + warn("Can't open $output: $!"); + $any_error = 1; + next; + } + while (<TMP>) { + print or die "Can't print to stdout: $!"; + } + close TMP or die "Can't close while $output: $!"; + $self->unlink_if_temp_file($output); + } + return $any_error; # successful + } + + foreach my $pager ( $self->pagers ) { + $self->aside("About to try calling $pager @found\n"); + if (system($pager, @found) == 0) { + $self->aside("Yay, it worked.\n"); + return 0; + } + $self->aside("That didn't work.\n"); + + # Odd -- when it fails, under Win32, this seems to neither + # return with a fail nor return with a success!! + # That's discouraging! + } + + $self->aside( + sprintf "Can't manage to find a way to page [%s] via pagers [%s]\n", + join(' ', @found), + join(' ', $self->pagers), + ); + + if (IS_VMS) { + DEBUG > 1 and print "Bailing out in a VMSish way.\n"; + eval q{ + use vmsish qw(status exit); + exit $?; + 1; + } or die; + } + + return 1; + # i.e., an UNSUCCESSFUL return value! +} + +#.......................................................................... + +sub check_file { + my($self, $dir, $file) = @_; + + unless( ref $self ) { + # Should never get called: + $Carp::Verbose = 1; + Carp::croak join '', + "Crazy ", __PACKAGE__, " error:\n", + "check_file must be an object_method!\n", + "Aborting" + } + + if(length $dir and not -d $dir) { + DEBUG > 3 and print " No dir $dir -- skipping.\n"; + return ""; + } + + if ($self->opt_m) { + return $self->minus_f_nocase($dir,$file); + } + + else { + my $path = $self->minus_f_nocase($dir,$file); + if( length $path and $self->containspod($path) ) { + DEBUG > 3 and print + " The file $path indeed looks promising!\n"; + return $path; + } + } + DEBUG > 3 and print " No good: $file in $dir\n"; + + return ""; +} + +#.......................................................................... + +sub containspod { + my($self, $file, $readit) = @_; + return 1 if !$readit && $file =~ /\.pod\z/i; + local($_); + open(TEST,"<", $file) or die "Can't open $file: $!"; + while (<TEST>) { + if (/^=head/) { + close(TEST) or die "Can't close $file: $!"; + return 1; + } + } + close(TEST) or die "Can't close $file: $!"; + return 0; +} + +#.......................................................................... + +sub maybe_diddle_INC { + my $self = shift; + + # Does this look like a module or extension directory? + + if (-f "Makefile.PL") { + + # Add "." and "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 $@ && $self->opt_v; + } + } + + return; +} + +#.......................................................................... + +sub new_output_file { + my $self = shift; + my $outspec = $self->opt_d; # Yes, -d overrides all else! + # So don't call this twice per format-job! + + return $self->new_tempfile(@_) unless defined $outspec and length $outspec; + + # Otherwise open a write-handle on opt_d!f + + my $fh; + # If we are running before perl5.6.0, we can't autovivify + if ($] < 5.006) { + require Symbol; + $fh = Symbol::gensym(); + } + DEBUG > 3 and print "About to try writing to specified output file $outspec\n"; + die "Can't write-open $outspec: $!" unless open($fh, ">", $outspec); + DEBUG > 3 and print "Successfully opened $outspec\n"; + binmode($fh) if $self->{'output_is_binary'}; + return($fh, $outspec); +} + +#.......................................................................... + +sub useful_filename_bit { + # This tries to provide a meaningful bit of text to do with the query, + # such as can be used in naming the file -- since if we're going to be + # opening windows on temp files (as a "pager" may well do!) then it's + # better if the temp file's name (which may well be used as the window + # title) isn't ALL just random garbage! + # In other words "perldoc_LWPSimple_2371981429" is a better temp file + # name than "perldoc_2371981429". So this routine is what tries to + # provide the "LWPSimple" bit. + # + my $self = shift; + my $pages = $self->{'pages'} || return undef; + return undef unless @$pages; + + my $chunk = $pages->[0]; + return undef unless defined $chunk; + $chunk =~ s/:://g; + $chunk =~ s/\.\w+$//g; # strip any extension + if( $chunk =~ m/([^\#\\:\/\$]+)$/s ) { # get basename, if it's a file + $chunk = $1; + } else { + return undef; + } + $chunk =~ s/[^a-zA-Z0-9]+//g; # leave ONLY a-zA-Z0-9 things! + $chunk = substr($chunk, -10) if length($chunk) > 10; + return $chunk; +} + +#.......................................................................... + +sub new_tempfile { # $self->new_tempfile( [$suffix, [$infix] ] ) + my $self = shift; + + ++$Temp_Files_Created; + + if( IS_MSWin32 ) { + my @out = $self->MSWin_perldoc_tempfile(@_); + return @out if @out; + # otherwise fall thru to the normal stuff below... + } + + require File::Temp; + return File::Temp::tempfile(UNLINK => 1); +} + +#.......................................................................... + +sub page { # apply a pager to the output file + my ($self, $output, $output_to_stdout, @pagers) = @_; + if ($output_to_stdout) { + $self->aside("Sending unpaged output to STDOUT.\n"); + open(TMP, "<", $output) or die "Can't open $output: $!"; + local $_; + while (<TMP>) { + print or die "Can't print to stdout: $!"; + } + close TMP or die "Can't close while $output: $!"; + $self->unlink_if_temp_file($output); + } else { + # On VMS, quoting prevents logical expansion, and temp files with no + # extension get the wrong default extension (such as .LIS for TYPE) + + $output = VMS::Filespec::rmsexpand($output, '.') if IS_VMS; + foreach my $pager (@pagers) { + $self->aside("About to try calling $pager $output\n"); + if (IS_VMS) { + last if system("$pager $output") == 0; + } else { + last if system("$pager \"$output\"") == 0; + } + } + } + return; +} + +#.......................................................................... + +sub searchfor { + my($self, $recurse,$s,@dirs) = @_; + $s =~ s!::!/!g; + $s = VMS::Filespec::unixify($s) if IS_VMS; + return $s if -f $s && $self->containspod($s); + $self->aside( "Looking for $s in @dirs\n" ); + my $ret; + my $i; + my $dir; + $self->{'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!/\z!! if IS_VMS; + if ( (! $self->opt_m && ( $ret = $self->check_file($dir,"$s.pod"))) + or ( $ret = $self->check_file($dir,"$s.pm")) + or ( $ret = $self->check_file($dir,$s)) + or ( IS_VMS and + $ret = $self->check_file($dir,"$s.com")) + or ( IS_OS2 and + $ret = $self->check_file($dir,"$s.cmd")) + or ( (IS_MSWin32 or IS_Dos or IS_OS2) and + $ret = $self->check_file($dir,"$s.bat")) + or ( $ret = $self->check_file("$dir/pod","$s.pod")) + or ( $ret = $self->check_file("$dir/pod",$s)) + or ( $ret = $self->check_file("$dir/pods","$s.pod")) + or ( $ret = $self->check_file("$dir/pods",$s)) + ) { + DEBUG > 1 and print " Found $ret\n"; + return $ret; + } + + if ($recurse) { + 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) or die "Can't closedir $dir: $!"; + next unless @newdirs; + # what a wicked map! + @newdirs = map((s/\.dir\z//,$_)[1],@newdirs) if IS_VMS; + $self->aside( "Also looking in @newdirs\n" ); + push(@dirs,@newdirs); + } + } + return (); +} + +#.......................................................................... +{ + my $already_asserted; + sub assert_closing_stdout { + my $self = shift; + + return if $already_asserted; + + eval q~ END { close(STDOUT) || die "Can't close STDOUT: $!" } ~; + # What for? to let the pager know that nothing more will come? + + die $@ if $@; + $already_asserted = 1; + return; + } +} + +#.......................................................................... + +sub tweak_found_pathnames { + my($self, $found) = @_; + if (IS_MSWin32) { + foreach (@$found) { s,/,\\,g } + } + return; +} + +#.......................................................................... +# : : : : : : : : : +#.......................................................................... + +sub am_taint_checking { + my $self = shift; + die "NO ENVIRONMENT?!?!" unless keys %ENV; # reset iterator along the way + my($k,$v) = each %ENV; + return is_tainted($v); +} + +#.......................................................................... + +sub is_tainted { # just a function + my $arg = shift; + my $nada = substr($arg, 0, 0); # zero-length! + local $@; # preserve the caller's version of $@ + eval { eval "# $nada" }; + return length($@) != 0; +} + +#.......................................................................... + +sub drop_privs_maybe { + my $self = shift; + + # Attempt to drop privs if we should be tainting and aren't + if (!(IS_VMS || IS_MSWin32 || IS_Dos + || IS_OS2 + ) + && ($> == 0 || $< == 0) + && !$self->am_taint_checking() + ) { + my $id = eval { getpwnam("nobody") }; + $id = eval { getpwnam("nouser") } unless defined $id; + $id = -2 unless defined $id; + # + # According to Stevens' APUE and various + # (BSD, Solaris, HP-UX) man pages, setting + # the real uid first and effective uid second + # is the way to go if one wants to drop privileges, + # because if one changes into an effective uid of + # non-zero, one cannot change the real uid any more. + # + # Actually, it gets even messier. There is + # a third uid, called the saved uid, and as + # long as that is zero, one can get back to + # uid of zero. Setting the real-effective *twice* + # helps in *most* systems (FreeBSD and Solaris) + # but apparently in HP-UX even this doesn't help: + # the saved uid stays zero (apparently the only way + # in HP-UX to change saved uid is to call setuid() + # when the effective uid is zero). + # + eval { + $< = $id; # real uid + $> = $id; # effective uid + $< = $id; # real uid + $> = $id; # effective uid + }; + die "Superuser must not run $0 without security audit and taint checks.\n" + unless !$@ && $< && $>; + } + return; +} + +#.......................................................................... + +1; + +__END__ + +# See "perldoc perldoc" for basic details. +# +# Perldoc -- look up a piece of documentation in .pod format that +# is embedded in the perl installation tree. +# +#~~~~~~ +# Version 3.06: Sunday November 17 2002 -- 14:05:28 +# Sean M. Burke <sburke@cpan.org> +# Added -V to report version +# Restore -U as a no-op legacy switch. +# +# Version 3.01: Sun Nov 10 21:38:09 MST 2002 +# Sean M. Burke <sburke@cpan.org> +# Massive refactoring and code-tidying. +# Now it's a module(-family)! +# Formatter-specific stuff pulled out into Pod::Perldoc::To(Whatever).pm +# Added -T, -d, -o, -M, -w. +# Added some improved MSWin funk. +# +#~~~~~~ +# +# Version 2.05: Sat Oct 12 16:09:00 CEST 2002 +# Hugo van der Sanden <hv@crypt.org> +# Made -U the default, based on patch from Simon Cozens +# Version 2.04: Sun Aug 18 13:27:12 BST 2002 +# Randy W. Sims <RandyS@ThePierianSpring.org> +# allow -n to enable nroff under Win32 +# Version 2.03: Sun Apr 23 16:56:34 BST 2000 +# Hugo van der Sanden <hv@crypt.org> +# don't die when 'use blib' fails +# Version 2.02: Mon Mar 13 18:03:04 MST 2000 +# Tom Christiansen <tchrist@perl.com> +# Added -U insecurity option +# Version 2.01: Sat Mar 11 15:22:33 MST 2000 +# Tom Christiansen <tchrist@perl.com>, 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 <cwilson@ece.gatech.edu> +# changed /pod/ directory to /pods/ for cygwin +# to support cygwin/win32 +# Version 1.14: Wed Jul 15 01:50:20 EST 1998 +# Robin Barker <rmb1@cise.npl.co.uk> +# -strict, -w cleanups +# Version 1.13: Fri Feb 27 16:20:50 EST 1997 +# Gurusamy Sarathy <gsar@activestate.com> +# -doc tweaks for -F and -X options +# Version 1.12: Sat Apr 12 22:41:09 EST 1997 +# Gurusamy Sarathy <gsar@activestate.com> +# -various fixes for win32 +# Version 1.11: Tue Dec 26 09:54:33 EST 1995 +# Kenneth Albanowski <kjahds@kjahds.com> +# -added Charles Bailey's further VMS patches, and -u switch +# -added -t switch, with pod2text support +# +# Version 1.10: Thu Nov 9 07:23:47 EST 1995 +# Kenneth Albanowski <kjahds@kjahds.com> +# -added VMS support +# -added better error recognition (on no found pages, just exit. On +# missing nroff/pod2man, just display raw pod.) +# -added recursive/case-insensitive matching (thanks, Andreas). This +# slows things down a bit, unfortunately. Give a precise name, and +# it'll run faster. +# +# Version 1.01: Tue May 30 14:47:34 EDT 1995 +# Andy Dougherty <doughera@lafcol.lafayette.edu> +# -added pod documentation. +# -added PATH searching. +# -added searching pod/ subdirectory (mainly to pick up perlfunc.pod +# and friends. +# +#~~~~~~~ +# +# TODO: +# +# Cache the directories read during sloppy match +# (To disk, or just in-memory?) +# +# Backport this to perl 5.005? +# +# Implement at least part of the "perlman" interface described +# in Programming Perl 3e? diff --git a/lib/Pod/Perldoc/BaseTo.pm b/lib/Pod/Perldoc/BaseTo.pm new file mode 100644 index 0000000000..6ca2a8c7e5 --- /dev/null +++ b/lib/Pod/Perldoc/BaseTo.pm @@ -0,0 +1,28 @@ + +require 5; +package Pod::Perldoc::BaseTo; +use strict; +use warnings; + +sub is_pageable { '' } +sub write_with_binmode { 1 } + +sub output_extension { 'txt' } # override in subclass! + +# sub new { my $self = shift; ... } +# sub parse_from_file( my($class, $in, $out) = ...; ... } + +#sub new { return bless {}, ref($_[0]) || $_[0] } + +sub _perldoc_elem { + my($self, $name) = splice @_,0,2; + if(@_) { + $self->{$name} = $_[0]; + } else { + $self->{$name}; + } +} + + +1; + diff --git a/lib/Pod/Perldoc/GetOptsOO.pm b/lib/Pod/Perldoc/GetOptsOO.pm new file mode 100644 index 0000000000..b29aeb1090 --- /dev/null +++ b/lib/Pod/Perldoc/GetOptsOO.pm @@ -0,0 +1,106 @@ + +require 5; +package Pod::Perldoc::GetOptsOO; +use strict; + +# Rather like Getopt::Std's getopts +# Call Pod::Perldoc::GetOptsOO::getopts($object, \@ARGV, $truth) +# Given -n, if there's a opt_n_with, it'll call $object->opt_n_with( ARGUMENT ) +# (e.g., "-n foo" => $object->opt_n_with('foo'). Ditto "-nfoo") +# Otherwise (given -n) if there's an opt_n, we'll call it $object->opt_n($truth) +# (Truth defaults to 1) +# Otherwise we try calling $object->handle_unknown_option('n') +# (and we increment the error count by the return value of it) +# If there's no handle_unknown_option, then we just warn, and then increment +# the error counter +# +# The return value of Pod::Perldoc::GetOptsOO::getopts is true if no errors, +# otherwise it's false. +# +## sburke@cpan.org 2002-10-31 + +BEGIN { # Make a DEBUG constant ASAP + *DEBUG = defined( &Pod::Perldoc::DEBUG ) + ? \&Pod::Perldoc::DEBUG + : sub(){10}; +} + + +sub getopts { + my($target, $args, $truth) = @_; + + $args ||= \@ARGV; + + $target->aside( + "Starting switch processing. Scanning arguments [@$args]\n" + ) if $target->can('aside'); + + return unless @$args; + + $truth = 1 unless @_ > 2; + + DEBUG > 3 and print " Truth is $truth\n"; + + + my $error_count = 0; + + while( @$args and ($_ = $args->[0]) =~ m/^-(.)(.*)/s ) { + my($first,$rest) = ($1,$2); + if ($_ eq '--') { # early exit if "--" + shift @$args; + last; + } + my $method = "opt_${first}_with"; + if( $target->can($method) ) { # it's argumental + if($rest eq '') { # like -f bar + shift @$args; + warn "Option $first needs a following argument!\n" unless @$args; + $rest = shift @$args; + } else { # like -fbar (== -f bar) + shift @$args; + } + + DEBUG > 3 and print " $method => $rest\n"; + $target->$method( $rest ); + + # Otherwise, it's not argumental... + } else { + + if( $target->can( $method = "opt_$first" ) ) { + DEBUG > 3 and print " $method is true ($truth)\n"; + $target->$method( $truth ); + + # Otherwise it's an unknown option... + + } elsif( $target->can('handle_unknown_option') ) { + DEBUG > 3 + and print " calling handle_unknown_option('$first')\n"; + + $error_count += ( + $target->handle_unknown_option( $first ) || 0 + ); + + } else { + ++$error_count; + warn "Unknown option: $first\n"; + } + + if($rest eq '') { # like -f + shift @$args + } else { # like -fbar (== -f -bar ) + DEBUG > 2 and print " Setting args->[0] to \"-$rest\"\n"; + $args->[0] = "-$rest"; + } + } + } + + + $target->aside( + "Ending switch processing. Args are [@$args] with $error_count errors.\n" + ) if $target->can('aside'); + + $error_count == 0; +} + +1; + diff --git a/lib/Pod/Perldoc/ToChecker.pm b/lib/Pod/Perldoc/ToChecker.pm new file mode 100644 index 0000000000..c60290d650 --- /dev/null +++ b/lib/Pod/Perldoc/ToChecker.pm @@ -0,0 +1,72 @@ + +require 5; +package Pod::Perldoc::ToChecker; +use strict; +use warnings; +use vars qw(@ISA); + +# Pick our superclass... +# +eval 'require Pod::Simple::Checker'; +if($@) { + require Pod::Checker; + @ISA = ('Pod::Checker'); +} else { + @ISA = ('Pod::Simple::Checker'); +} + +sub is_pageable { 1 } +sub write_with_binmode { 0 } +sub output_extension { 'txt' } + +sub if_zero_length { + my( $self, $file, $tmp, $tmpfd ) = @_; + print "No Pod errors in $file\n"; +} + + +1; + +__END__ + +=head1 NAME + +Pod::Perldoc::ToChecker - let Perldoc check Pod for errors + +=head1 SYNOPSIS + + % perldoc -o checker SomeFile.pod + No Pod errors in SomeFile.pod + (or an error report) + +=head1 DESCRIPTION + +This is a "plug-in" class that allows Perldoc to use +Pod::Simple::Checker as a "formatter" class (or if that is +not available, then Pod::Checker), to check for errors in a given +Pod file. + +This is actually a Pod::Simple::Checker (or Pod::Checker) subclass, and +inherits all its options. + +=head1 SEE ALSO + +L<Pod::Simple::Checker>, L<Pod::Simple>, L<Pod::Checker>, L<Pod::Perldoc> + +=head1 COPYRIGHT AND DISCLAIMERS + +Copyright (c) 2002 Sean M. Burke. All rights reserved. + +This library is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +This program is distributed in the hope that it will be useful, but +without any warranty; without even the implied warranty of +merchantability or fitness for a particular purpose. + +=head1 AUTHOR + +Sean M. Burke C<sburke@cpan.org> + +=cut + diff --git a/lib/Pod/Perldoc/ToMan.pm b/lib/Pod/Perldoc/ToMan.pm new file mode 100644 index 0000000000..371a3beea8 --- /dev/null +++ b/lib/Pod/Perldoc/ToMan.pm @@ -0,0 +1,161 @@ + +require 5; +package Pod::Perldoc::ToMan; +use strict; +use warnings; + +# This class is unlike ToText.pm et al, because we're NOT paging thru +# the output in that our particular format -- we make the output and +# then we run nroff (or whatever) on it, and then page thru the +# (plaintext) output of THAT! + +use base qw(Pod::Perldoc::BaseTo); +sub is_pageable { 1 } +sub write_with_binmode { 0 } +sub output_extension { 'txt' } + +sub __filter_nroff { shift->_perldoc_elem('__filter_nroff' , @_) } +sub __nroffer { shift->_perldoc_elem('__nroffer' , @_) } +sub __bindir { shift->_perldoc_elem('__bindir' , @_) } +sub __pod2man { shift->_perldoc_elem('__pod2man' , @_) } +sub __output_file { shift->_perldoc_elem('__output_file' , @_) } + +sub center { shift->_perldoc_elem('center' , @_) } +sub date { shift->_perldoc_elem('date' , @_) } +sub fixed { shift->_perldoc_elem('fixed' , @_) } +sub fixedbold { shift->_perldoc_elem('fixedbold' , @_) } +sub fixeditalic { shift->_perldoc_elem('fixeditalic' , @_) } +sub fixedbolditalic { shift->_perldoc_elem('fixedbolditalic', @_) } +sub quotes { shift->_perldoc_elem('quotes' , @_) } +sub release { shift->_perldoc_elem('release' , @_) } +sub section { shift->_perldoc_elem('section' , @_) } + +sub new { return bless {}, ref($_[0]) || $_[0] } + +use File::Spec::Functions qw(catfile); + +sub parse_from_file { + my $self = shift; + my($file, $outfh) = @_; + + my $render = $self->{'__nroffer'} || die "no nroffer set!?"; + + # turn the switches into CLIs + my $switches = join ' ', + map qq{"--$_=$self->{$_}"}, + grep !m/^_/s, + keys %$self + ; + + my $command = + catfile( + ($self->{'__bindir'} || die "no bindir set?!" ), + ($self->{'__pod2man'} || die "no pod2man set?!" ), + ) + . " $switches --lax $file | $render -man" + ; # no temp file, just a pipe! + + $command .= " | col -x" if $^O =~ /hpux/; + + defined(&Pod::Perldoc::DEBUG) + and Pod::Perldoc::DEBUG() + and print "About to run $command\n"; + ; + + my $rslt = `$command`; + + my $err; + + if( $self->{'__filter_nroff'} ) { + defined(&Pod::Perldoc::DEBUG) + and &Pod::Perldoc::DEBUG() + and print "filter_nroff is set, so filtering...\n"; + $rslt = $self->___Do_filter_nroff($rslt); + } else { + defined(&Pod::Perldoc::DEBUG) + and Pod::Perldoc::DEBUG() + and print "filter_nroff isn't set, so not filtering.\n"; + } + + if (($err = $?)) { + defined(&Pod::Perldoc::DEBUG) + and Pod::Perldoc::DEBUG() + and print "Nonzero exit ($?) while running $command.\n", + "Falling back to Pod::Perldoc::ToPod\n ", + ; + # A desperate fallthru: + require Pod::Perldoc::ToPod; + return Pod::Perldoc::ToPod->new->parse_from_file(@_); + + } else { + print $outfh $rslt + or die "Can't print to $$self{__output_file}: $!"; + } + + return; +} + + +sub ___Do_filter_nroff { + my $self = shift; + my @data = split /\n{2,}/, shift; + + shift @data while @data and $data[0] !~ /\S/; # Go to header + shift @data if @data and $data[0] =~ /Contributed\s+Perl/; # Skip header + pop @data if @data and $data[-1] =~ /^\w/; # Skip footer, like + # 28/Jan/99 perl 5.005, patch 53 1 + join "\n\n", @data; +} + +1; + +__END__ + +=head1 NAME + +Pod::Perldoc::ToMan - let Perldoc render Pod as man pages + +=head1 SYNOPSIS + + perldoc -o man Some::Modulename + +=head1 DESCRIPTION + +This is a "plug-in" class that allows Perldoc to use +Pod::Man and C<nroff> for reading Pod pages. + +The following options are supported: center, date, fixed, fixedbold, +fixeditalic, fixedbolditalic, quotes, release, section + +(Those options are explained in L<Pod::Man>.) + +For example: + + perldoc -o man -w center:Pod Some::Modulename + +=head1 CAVEAT + +This module may change to use a different pod-to-nroff formatter class +in the future, and this may change what options are supported. + +=head1 SEE ALSO + +L<Pod::Man>, L<Pod::Perldoc>, L<Pod::Perldoc::ToNroff> + +=head1 COPYRIGHT AND DISCLAIMERS + +Copyright (c) 2002 Sean M. Burke. All rights reserved. + +This library is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +This program is distributed in the hope that it will be useful, but +without any warranty; without even the implied warranty of +merchantability or fitness for a particular purpose. + +=head1 AUTHOR + +Sean M. Burke C<sburke@cpan.org> + +=cut + diff --git a/lib/Pod/Perldoc/ToNroff.pm b/lib/Pod/Perldoc/ToNroff.pm new file mode 100644 index 0000000000..d056860506 --- /dev/null +++ b/lib/Pod/Perldoc/ToNroff.pm @@ -0,0 +1,100 @@ + +require 5; +package Pod::Perldoc::ToNroff; +use strict; +use warnings; + +# This is unlike ToMan.pm in that it emits the raw nroff source! + +use base qw(Pod::Perldoc::BaseTo); + +sub is_pageable { 1 } # well, if you ask for it... +sub write_with_binmode { 0 } +sub output_extension { 'man' } + +use Pod::Man (); + +sub center { shift->_perldoc_elem('center' , @_) } +sub date { shift->_perldoc_elem('date' , @_) } +sub fixed { shift->_perldoc_elem('fixed' , @_) } +sub fixedbold { shift->_perldoc_elem('fixedbold' , @_) } +sub fixeditalic { shift->_perldoc_elem('fixeditalic' , @_) } +sub fixedbolditalic { shift->_perldoc_elem('fixedbolditalic', @_) } +sub quotes { shift->_perldoc_elem('quotes' , @_) } +sub release { shift->_perldoc_elem('release' , @_) } +sub section { shift->_perldoc_elem('section' , @_) } + +sub new { return bless {}, ref($_[0]) || $_[0] } + +sub parse_from_file { + my $self = shift; + my $file = $_[0]; + + my @options = + map {; $_, $self->{$_} } + grep !m/^_/s, + keys %$self + ; + + defined(&Pod::Perldoc::DEBUG) + and Pod::Perldoc::DEBUG() + and print "About to call new Pod::Man ", + $Pod::Man::VERSION ? "(v$Pod::Man::VERSION) " : '', + "with options: ", + @options ? "[@options]" : "(nil)", "\n"; + ; + + Pod::Man->new(@options)->parse_from_file(@_); +} + +1; +__END__ + +=head1 NAME + +Pod::Perldoc::ToNroff - let Perldoc convert Pod to nroff + +=head1 SYNOPSIS + + perldoc -o nroff -d something.3 Some::Modulename + +=head1 DESCRIPTION + +This is a "plug-in" class that allows Perldoc to use +Pod::Man as a formatter class. + +The following options are supported: center, date, fixed, fixedbold, +fixeditalic, fixedbolditalic, quotes, release, section + +Those options are explained in L<Pod::Man>. + +For example: + + perldoc -o nroff -w center:Pod -d something.3 Some::Modulename + +=head1 CAVEAT + +This module may change to use a different pod-to-nroff formatter class +in the future, and this may change what options are supported. + +=head1 SEE ALSO + +L<Pod::Man>, L<Pod::Perldoc>, L<Pod::Perldoc::ToMan> + +=head1 COPYRIGHT AND DISCLAIMERS + +Copyright (c) 2002 Sean M. Burke. All rights reserved. + +This library is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +This program is distributed in the hope that it will be useful, but +without any warranty; without even the implied warranty of +merchantability or fitness for a particular purpose. + +=head1 AUTHOR + +Sean M. Burke C<sburke@cpan.org> + +=cut + diff --git a/lib/Pod/Perldoc/ToPod.pm b/lib/Pod/Perldoc/ToPod.pm new file mode 100644 index 0000000000..bccbfcadbd --- /dev/null +++ b/lib/Pod/Perldoc/ToPod.pm @@ -0,0 +1,90 @@ + +# This class is just a hack to act as a "formatter" for +# actually unformatted Pod. +# +# Note that this isn't the same as just passing thru whatever +# we're given -- we pass thru only the pod source, and suppress +# the Perl code (or whatever non-pod stuff is in the source file). + + +require 5; +package Pod::Perldoc::ToPod; +use strict; +use warnings; + +use base qw(Pod::Perldoc::BaseTo); +sub is_pageable { 1 } +sub write_with_binmode { 0 } +sub output_extension { 'pod' } + +sub new { return bless {}, ref($_[0]) || $_[0] } + +sub parse_from_file { + my( $self, $in, $outfh ) = @_; + + open(IN, "<", $in) or die "Can't read-open $in: $!\nAborting"; + + my $cut_mode = 1; + + # A hack for finding things between =foo and =cut, inclusive + local $_; + while (<IN>) { + if( m/^=(\w+)/s ) { + if($cut_mode = ($1 eq 'cut')) { + print $outfh "\n=cut\n\n"; + # Pass thru the =cut line with some harmless + # (and occasionally helpful) padding + } + } + next if $cut_mode; + print $outfh $_ or die "Can't print to $outfh: $!"; + } + + close IN or die "Can't close $in: $!"; + return; +} + +1; +__END__ + +=head1 NAME + +Pod::Perldoc::ToPod - let Perldoc render Pod as ... Pod! + +=head1 SYNOPSIS + + perldoc -opod Some::Modulename + +(That's currently the same as the following:) + + perldoc -u Some::Modulename + +=head1 DESCRIPTION + +This is a "plug-in" class that allows Perldoc to display Pod source as +itself! Pretty Zen, huh? + +Currently this class works by just filtering out the non-Pod stuff from +a given input file. + +=head1 SEE ALSO + +L<Pod::Perldoc> + +=head1 COPYRIGHT AND DISCLAIMERS + +Copyright (c) 2002 Sean M. Burke. All rights reserved. + +This library is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +This program is distributed in the hope that it will be useful, but +without any warranty; without even the implied warranty of +merchantability or fitness for a particular purpose. + +=head1 AUTHOR + +Sean M. Burke C<sburke@cpan.org> + +=cut + diff --git a/lib/Pod/Perldoc/ToRtf.pm b/lib/Pod/Perldoc/ToRtf.pm new file mode 100644 index 0000000000..25e609e313 --- /dev/null +++ b/lib/Pod/Perldoc/ToRtf.pm @@ -0,0 +1,85 @@ + +require 5; +package Pod::Perldoc::ToRtf; +use strict; +use warnings; +use vars qw($VERSION); + +use base qw( Pod::Simple::RTF ); + +$VERSION # so that ->VERSION is happy +# stop CPAN from seeing this + = +$Pod::Simple::RTF::VERSION; + + +sub is_pageable { 0 } +sub write_with_binmode { 0 } +sub output_extension { 'rtf' } + +sub page_for_perldoc { + my($self, $tempfile, $perldoc) = @_; + return unless $perldoc->IS_MSWin32; + + my $rtf_pager = $ENV{'RTFREADER'} || 'write.exe'; + + $perldoc->aside( "About to launch <\"$rtf_pager\" \"$tempfile\">\n" ); + + return 1 if system( qq{"$rtf_pager"}, qq{"$tempfile"} ) == 0; + return 0; +} + +1; +__END__ + +=head1 NAME + +Pod::Perldoc::ToRtf - let Perldoc render Pod as RTF + +=head1 SYNOPSIS + + perldoc -o rtf Some::Modulename + +=head1 DESCRIPTION + +This is a "plug-in" class that allows Perldoc to use +Pod::Simple::RTF as a formatter class. + +This is actually a Pod::Simple::RTF subclass, and inherits +all its options. + +You have to have Pod::Simple::RTF installed (from the Pod::Simple dist), +or this module won't work. + +If Perldoc is running under MSWin and uses this class as a formatter, +the output will be opened with F<write.exe> or whatever program is +specified in the environment variable C<RTFREADER>. For example, to +specify that RTF files should be opened the same as they are when you +double-click them, you would do C<set RTFREADER=start.exe> in your +F<autoexec.bat>. + +Handy tip: put C<set PERLDOC=-ortf> in your F<autoexec.bat> +and that will set this class as the default formatter to run when +you do C<perldoc whatever>. + +=head1 SEE ALSO + +L<Pod::Simple::RTF>, L<Pod::Simple>, L<Pod::Perldoc> + +=head1 COPYRIGHT AND DISCLAIMERS + +Copyright (c) 2002 Sean M. Burke. All rights reserved. + +This library is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +This program is distributed in the hope that it will be useful, but +without any warranty; without even the implied warranty of +merchantability or fitness for a particular purpose. + +=head1 AUTHOR + +Sean M. Burke C<sburke@cpan.org> + +=cut + diff --git a/lib/Pod/Perldoc/ToText.pm b/lib/Pod/Perldoc/ToText.pm new file mode 100644 index 0000000000..2eb9e0644a --- /dev/null +++ b/lib/Pod/Perldoc/ToText.pm @@ -0,0 +1,91 @@ + +require 5; +package Pod::Perldoc::ToText; +use strict; +use warnings; + +use base qw(Pod::Perldoc::BaseTo); + +sub is_pageable { 1 } +sub write_with_binmode { 0 } +sub output_extension { 'txt' } + +use Pod::Text (); + +sub alt { shift->_perldoc_elem('alt' , @_) } +sub indent { shift->_perldoc_elem('indent' , @_) } +sub loose { shift->_perldoc_elem('loose' , @_) } +sub quotes { shift->_perldoc_elem('quotes' , @_) } +sub sentence { shift->_perldoc_elem('sentence', @_) } +sub width { shift->_perldoc_elem('width' , @_) } + +sub new { return bless {}, ref($_[0]) || $_[0] } + +sub parse_from_file { + my $self = shift; + + my @options = + map {; $_, $self->{$_} } + grep !m/^_/s, + keys %$self + ; + + defined(&Pod::Perldoc::DEBUG) + and Pod::Perldoc::DEBUG() + and print "About to call new Pod::Text ", + $Pod::Text::VERSION ? "(v$Pod::Text::VERSION) " : '', + "with options: ", + @options ? "[@options]" : "(nil)", "\n"; + ; + + Pod::Text->new(@options)->parse_from_file(@_); +} + +1; + +=head1 NAME + +Pod::Perldoc::ToText - let Perldoc render Pod as plaintext + +=head1 SYNOPSIS + + perldoc -o text Some::Modulename + +=head1 DESCRIPTION + +This is a "plug-in" class that allows Perldoc to use +Pod::Text as a formatter class. + +It supports the following options, which are explained in +L<Pod::Text>: alt, indent, loose, quotes, sentence, width + +For example: + + perldoc -o text -w indent:5 Some::Modulename + +=head1 CAVEAT + +This module may change to use a different text formatter class in the +future, and this may change what options are supported. + +=head1 SEE ALSO + +L<Pod::Text>, L<Pod::Perldoc> + +=head1 COPYRIGHT AND DISCLAIMERS + +Copyright (c) 2002 Sean M. Burke. All rights reserved. + +This library is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +This program is distributed in the hope that it will be useful, but +without any warranty; without even the implied warranty of +merchantability or fitness for a particular purpose. + +=head1 AUTHOR + +Sean M. Burke C<sburke@cpan.org> + +=cut + diff --git a/lib/Pod/Perldoc/ToTk.pm b/lib/Pod/Perldoc/ToTk.pm new file mode 100644 index 0000000000..3945962950 --- /dev/null +++ b/lib/Pod/Perldoc/ToTk.pm @@ -0,0 +1,129 @@ + +require 5; +package Pod::Perldoc::ToTk; +use strict; +use warnings; + +use base qw(Pod::Perldoc::BaseTo); + +sub is_pageable { 1 } +sub write_with_binmode { 0 } +sub output_extension { 'txt' } # doesn't matter +sub if_zero_length { } # because it will be 0-length! +sub new { return bless {}, ref($_[0]) || $_[0] } + +# TODO: document these and their meanings... +sub tree { shift->_perldoc_elem('tree' , @_) } +sub tk_opt { shift->_perldoc_elem('tk_opt' , @_) } +sub forky { shift->_perldoc_elem('forky' , @_) } + +use Pod::Perldoc (); +use File::Spec::Functions qw(catfile); + +use Tk; +die join '', __PACKAGE__, " doesn't work nice with Tk.pm verison $Tk::VERSION" + if $Tk::VERSION eq '800.003'; + +BEGIN { eval { require Tk::FcyEntry; }; }; +use Tk::Pod; + +# The following was adapted from "tkpod" in the Tk-Pod dist. + +sub parse_from_file { + + my($self, $Input_File) = @_; + if($self->{'forky'}) { + return if fork; # i.e., parent process returns + } + + $Input_File =~ s{\\}{/}g + if Pod::Perldoc::IS_MSWin32 or Pod::Perldoc::IS_Dos + # and maybe OS/2 + ; + + my($tk_opt, $tree); + $tree = $self->{'tree' }; + $tk_opt = $self->{'tk_opt'}; + + #require Tk::ErrorDialog; + + # Add 'Tk' subdirectories to search path so, e.g., + # 'Scrolled' will find doc in 'Tk/Scrolled' + + if( $tk_opt ) { + push @INC, grep -d $_, map catfile($_,'Tk'), @INC; + } + + my $mw = MainWindow->new(); + #eval 'use blib "/home/e/eserte/src/perl/Tk-App";require Tk::App::Debug'; + $mw->withdraw; + + # CDE use Font Settings if available + my $ufont = $mw->optionGet('userFont','UserFont'); # fixed width + my $sfont = $mw->optionGet('systemFont','SystemFont'); # proportional + if (defined($ufont) and defined($sfont)) { + foreach ($ufont, $sfont) { s/:$//; }; + $mw->optionAdd('*Font', $sfont); + $mw->optionAdd('*Entry.Font', $ufont); + $mw->optionAdd('*Text.Font', $ufont); + } + + $mw->optionAdd('*Menu.tearOff', $Tk::platform ne 'MSWin32' ? 1 : 0); + + $mw->Pod( + '-file' => $Input_File, + (($Tk::Pod::VERSION >= 4) ? ('-tree' => $tree) : ()) + )->focusNext; + + # xxx dirty but it works. A simple $mw->destroy if $mw->children + # does not work because Tk::ErrorDialogs could be created. + # (they are withdrawn after Ok instead of destory'ed I guess) + + if ($mw->children) { + $mw->repeat(1000, sub { + # ErrorDialog is withdrawn not deleted :-( + foreach ($mw->children) { + return if "$_" =~ /^Tk::Pod/ # ->isa('Tk::Pod') + } + $mw->destroy; + }); + } else { + $mw->destroy; + } + #$mw->WidgetDump; + MainLoop(); + + exit if $self->{'forky'}; # we were the child! so exit now! + return; +} + +1; +__END__ + + +=head1 NAME + +Pod::Perldoc::ToTk - let Perldoc use Tk::Pod to render Pod + +=head1 SYNOPSIS + + perldoc -o tk Some::Modulename & + +=head1 DESCRIPTION + +This is a "plug-in" class that allows Perldoc to use +Tk::Pod as a formatter class. + +You have to have installed Tk::Pod first, or this class won't load. + +=head1 SEE ALSO + +L<Tk::Pod>, L<Pod::Perldoc> + +=head1 AUTHOR + +Sean M. Burke C<sburke@cpan.org>, with significant portions copied from +F<tkpod> in the Tk::Pod dist, by Nick Ing-Simmons, Slaven Rezic, et al. + +=cut + diff --git a/lib/Pod/Perldoc/ToXml.pm b/lib/Pod/Perldoc/ToXml.pm new file mode 100644 index 0000000000..dd0d15cc10 --- /dev/null +++ b/lib/Pod/Perldoc/ToXml.pm @@ -0,0 +1,63 @@ + +require 5; +package Pod::Perldoc::ToXml; +use strict; +use warnings; +use vars qw($VERSION); + +use base qw( Pod::Simple::XMLOutStream ); + +$VERSION # so that ->VERSION is happy +# stop CPAN from seeing this + = +$Pod::Simple::XMLOutStream::VERSION; + + +sub is_pageable { 0 } +sub write_with_binmode { 0 } +sub output_extension { 'xml' } + +1; +__END__ + +=head1 NAME + +Pod::Perldoc::ToXml - let Perldoc render Pod as XML + +=head1 SYNOPSIS + + perldoc -o xml -d out.xml Some::Modulename + +=head1 DESCRIPTION + +This is a "plug-in" class that allows Perldoc to use +Pod::Simple::XMLOutStream as a formatter class. + +This is actually a Pod::Simple::XMLOutStream subclass, and inherits +all its options. + +You have to have installed Pod::Simple::XMLOutStream (from the Pod::Simple +dist), or this class won't work. + + +=head1 SEE ALSO + +L<Pod::Simple::XMLOutStream>, L<Pod::Simple>, L<Pod::Perldoc> + +=head1 COPYRIGHT AND DISCLAIMERS + +Copyright (c) 2002 Sean M. Burke. All rights reserved. + +This library is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +This program is distributed in the hope that it will be useful, but +without any warranty; without even the implied warranty of +merchantability or fitness for a particular purpose. + +=head1 AUTHOR + +Sean M. Burke C<sburke@cpan.org> + +=cut + diff --git a/lib/Pod/Perldoc/t/checkerbasic.t b/lib/Pod/Perldoc/t/checkerbasic.t new file mode 100644 index 0000000000..c47dcedc64 --- /dev/null +++ b/lib/Pod/Perldoc/t/checkerbasic.t @@ -0,0 +1,9 @@ + +use Test; +BEGIN {plan tests => 2}; +ok 1; +require Pod::Perldoc::ToChecker; +$Pod::Perldoc::VERSION + and print "# Pod::Perldoc version $Pod::Perldoc::VERSION\n"; +ok 1; + diff --git a/lib/Pod/Perldoc/t/perldocbasic.t b/lib/Pod/Perldoc/t/perldocbasic.t new file mode 100644 index 0000000000..6f6b9984d7 --- /dev/null +++ b/lib/Pod/Perldoc/t/perldocbasic.t @@ -0,0 +1,9 @@ + +use Test; +BEGIN {plan tests => 3}; +ok 1; +require Pod::Perldoc; +ok($Pod::Perldoc::VERSION) + and print "# Pod::Perldoc version $Pod::Perldoc::VERSION\n"; +ok 1; + diff --git a/lib/Pod/Perldoc/t/textbasic.t b/lib/Pod/Perldoc/t/textbasic.t new file mode 100644 index 0000000000..6814267ec8 --- /dev/null +++ b/lib/Pod/Perldoc/t/textbasic.t @@ -0,0 +1,9 @@ + +use Test; +BEGIN {plan tests => 2}; +ok 1; +require Pod::Perldoc::ToText; +$Pod::Perldoc::VERSION + and print "# Pod::Perldoc version $Pod::Perldoc::VERSION\n"; +ok 1; + diff --git a/pod/perldoc.pod b/pod/perldoc.pod new file mode 100644 index 0000000000..e25b5102a5 --- /dev/null +++ b/pod/perldoc.pod @@ -0,0 +1,220 @@ + +=head1 NAME + +perldoc - Look up Perl documentation in Pod format. + +=head1 SYNOPSIS + +B<perldoc> [B<-h>] [B<-v>] [B<-t>] [B<-u>] [B<-m>] [B<-l>] [B<-F>] +[B<-i>] [B<-V>] [B<-T>] [B<-r>] +[B<-dI<destination_file>>] +[B<-oI<formatname>>] +[B<-MI<FormatterClassName>>] +[B<-wI<formatteroption:value>>] +[B<-n>I<nroff-replacement>] +[B<-X>] +PageName|ModuleName|ProgramName + +B<perldoc> B<-f> BuiltinFunction + +B<perldoc> B<-q> FAQ Keyword + +See below for more description of the switches. + +=head1 DESCRIPTION + +I<perldoc> looks up a piece of documentation in .pod format that is embedded +in the perl installation tree or in a perl script, and displays it via +C<pod2man | nroff -man | $PAGER>. (In addition, if running under HP-UX, +C<col -x> will be used.) This is primarily used for the documentation for +the perl library modules. + +Your system may also have man pages installed for those modules, in +which case you can probably just use the man(1) command. + +If you are looking for a table of contents to the Perl library modules +documentation, see the L<perltoc> page. + +=head1 OPTIONS + +=over 5 + +=item B<-h> + +Prints out a brief B<h>elp message. + +=item B<-v> + +Describes search for the item in detail (B<v>erbosely). + +=item B<-t> + +Display docs using plain B<t>ext converter, instead of nroff. This may be faster, +but it probably won't look as nice. + +=item B<-u> + +Skip the real Pod formatting, and just show the raw Pod source (B<U>nformatted) + +=item B<-m> I<module> + +Display the entire module: both code and unformatted pod documentation. +This may be useful if the docs don't explain a function in the detail +you need, and you'd like to inspect the code directly; perldoc will find +the file for you and simply hand it off for display. + +=item B<-l> + +Display onB<l>y the file name of the module found. + +=item B<-F> + +Consider arguments as file names; no search in directories will be performed. + +=item B<-f> I<perlfunc> + +The B<-f> option followed by the name of a perl built in function will +extract the documentation of this function from L<perlfunc>. + +Example: + + perldoc -f sprintf + +=item B<-q> I<perlfaq-search-regexp> + +The B<-q> option takes a regular expression as an argument. It will search +the B<q>uestion headings in perlfaq[1-9] and print the entries matching +the regular expression. Example: C<perldoc -q shuffle> + +=item B<-T> + +This specifies that the output is not to be sent to a pager, but is to +be sent right to STDOUT. + +=item B<-d> I<destination-filename> + +This specifies that the output is to be sent neither to a pager nor +to STDOUT, but is to be saved to the specified filename. Example: +C<perldoc -oLaTeX -dtextwrapdocs.tex Text::Wrap> + +=item B<-o> I<output-formatname> + +This specifies that you want Perldoc to try using a Pod-formatting +class for the output format that you specify. For example: +C<-oman>. This is actually just a wrapper around the C<-M> switch; +using C<-oI<formatname>> just looks for a loadable class by adding +that format name (with different capitalizations) to the end of +different classname prefixes. + +For example, C<-oLaTeX> currently tries all of the following classes: +Pod::Perldoc::ToLaTeX Pod::Perldoc::Tolatex Pod::Perldoc::ToLatex +Pod::Perldoc::ToLATEX Pod::Simple::LaTeX Pod::Simple::latex +Pod::Simple::Latex Pod::Simple::LATEX Pod::LaTeX Pod::latex Pod::Latex +Pod::LATEX. + +=item B<-M> I<module-name> + +This specifies the module that you want to try using for formatting the +pod. The class must must at least provide a C<parse_from_file> method. +For example: C<perldoc -MPod::Perldoc::ToChecker>. + +You can specify several classes to try by joining them with commas +or semicolons, as in C<-MTk::SuperPod;Tk::Pod>. + +=item B<-w> I<option:value> or B<-w> I<option> + +This specifies an option to call the formatter B<w>ith. For example, +C<-w textsize:15> will call +C<< $formatter->textsize(15) >> on the formatter object before it is +used to format the object. For this to be valid, the formatter class +must provide such a method, and the value you pass should be valid. +(So if C<textsize> expects an integer, and you do C<-w textsize:big>, +expect trouble.) + +You can use C<-w optionname> (without a value) as shorthand for +C<-w optionname:I<TRUE>>. This is presumably useful in cases of on/off +features like: C<-w page_numbering>. + +You can use a "=" instead of the ":", as in: C<-w textsize=15>. This +might be more (or less) convenient, depending on what shell you use. + +=item B<-X> + +Use an index if it is present -- the B<-X> option looks for an entry +whose basename matches the name given on the command line in the file +C<$Config{archlib}/pod.idx>. The F<pod.idx> file should contain fully +qualified filenames, one per line. + +=item B<PageName|ModuleName|ProgramName> + +The item you want to look up. Nested modules (such as C<File::Basename>) +are specified either as C<File::Basename> or C<File/Basename>. You may also +give a descriptive name of a page, such as C<perlfunc>. + +=item B<-n> I<some-formatter> + +Specify replacement for nroff + +=item B<-r> + +Recursive search. + +=item B<-i> + +Ignore case. + +=item B<-V> + +Displays the version of perldoc you're running. + +=back + + + +=head1 SECURITY + +Because B<perldoc> does not run properly tainted, and is known to +have security issues, when run as the superuser it will attempt to +drop privileges by setting the effective and real IDs to nobody's +or nouser's account, or -2 if unavailable. If it cannot relinquish +its privileges, it will not run. + + +=head1 ENVIRONMENT + +Any switches in the C<PERLDOC> environment variable will be used before the +command line arguments. + +Useful values for C<PERLDOC> include C<-oman>, C<-otext>, C<-otk>, C<-ortf>, +C<-oxml>, and so on, depending on what modules you have on hand; or +exactly specify the formatter class with C<-MPod::Perldoc::ToMan> +or the like. + +C<perldoc> also searches directories +specified by the C<PERL5LIB> (or C<PERLLIB> if C<PERL5LIB> is not +defined) and C<PATH> environment variables. +(The latter is so that embedded pods for executables, such as +C<perldoc> itself, are available.) + +C<perldoc> will use, in order of preference, the pager defined in +C<PERLDOC_PAGER>, C<MANPAGER>, or C<PAGER> before trying to find a pager +on its own. (C<MANPAGER> is not used if C<perldoc> was told to display +plain text or unformatted pod.) + +One useful value for C<PERLDOC_PAGER> is C<less -+C -E>. + +Having PERLDOCDEBUG set to a positive integer will make perldoc emit +even more descriptive output than the C<-v> switch does -- the higher the +number, the more it emits. + +=head1 AUTHOR + +Current maintainer: Sean M. Burke, <sburke@cpan.org> + +Past contributors are: +Kenneth Albanowski <kjahds@kjahds.com>, +Andy Dougherty <doughera@lafayette.edu>, +and many others. + +=cut + diff --git a/utils/perldoc.PL b/utils/perldoc.PL index e2c65369d9..a4d8872187 100644 --- a/utils/perldoc.PL +++ b/utils/perldoc.PL @@ -1,5 +1,11 @@ #!/usr/local/bin/perl +# This is for generating the perldoc executable. +# It may eventually be expanded to generate many executables, as +# explained in the preface of /Programming Perl/ 3e. + +require 5; +use strict; use Config; use File::Basename qw(&basename &dirname); use Cwd; @@ -13,837 +19,40 @@ use Cwd; # This forces PL files to create target in same directory as PL file. # This is so that make depend always knows where to find PL derivatives. -$origdir = cwd; + +my $origdir = cwd; chdir dirname($0); -$file = basename($0, '.PL'); +my $file = basename($0, '.PL'); +my $file_shortname = $file; # should be like "perldoc", maybe "perlsyn", etc. +warn "How odd, I'm going to generate $file_shortname?!" + unless $file_shortname =~ m/^\w+$/; + $file .= '.com' if $^O eq 'VMS'; open OUT,">$file" or die "Can't create $file: $!"; -print "Extracting $file (with variable substitutions)\n"; +print "Extracting \"$file\" (with variable substitutions)\n"; # In this section, perl variables will be expanded during extraction. # You can use $Config{...} to use Configure variables. -my $versiononly = $Config{versiononly} ? $Config{version} : ''; - print OUT <<"!GROK!THIS!"; $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, \$pager if -x (split /\\s+/, \$pager)[0]; +# This "$file" file was generated by "$0" -(my \$bindir = <<'/../') =~ s/\\s*\\z//; -$Config{scriptdirexp} -/../ - -(my \$pod2man = <<'/../') =~ s/\\s*\\z//; -pod2man$versiononly -/../ +require 5; +use Pod::Perldoc; +BEGIN { \$^W = 1 if \$ENV{'PERLDOCDEBUG'} } +exit( Pod::Perldoc->run() ); !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 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 - $me =~ s,.*/,,; - die <<EOF; -Usage: $me [-h] [-r] [-i] [-v] [-t] [-u] [-m] [-n program] [-l] [-F] [-X] PageName|ModuleName|ProgramName - $me -f PerlFunc - $me -q FAQKeywords - -The -h option prints more help. Also try "perldoc perldoc" to get -acquainted with the system. -EOF -} - -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'; -my $Is_BeOS = $^O eq 'beos'; - -sub usage{ - warn "@_\n" if @_; - # Erase evidence of previous errors (if any), so exit status is simple. - $! = 0; - die <<EOF; -perldoc [options] PageName|ModuleName|ProgramName... -perldoc [options] -f BuiltinFunction -perldoc [options] -q FAQRegex - -Options: - -h Display this help message - -r Recursive search (slow) - -i Ignore case - -t Display pod using pod2text instead of pod2man and nroff - (-t is the default on win32 unless -n is specified) - -u Display unformatted pod text - -m Display module's file in its entirety - -n Specify replacement for nroff - -l Display the module's file name - -F Arguments are file names, not modules - -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] - -PageName|ModuleName... - is the name of a piece of documentation that you want to look at. You - may either give a descriptive name of the page (as in the case of - `perlfunc') the name of a module, either like `Term::Info' or like - `Term/Info', or the name of a program, like `perldoc'. - -BuiltinFunction - is the name of a perl function. Will extract documentation from - `perlfunc'. - -FAQRegex - is a regex. Will search perlfaq[1-9] for and extract any - questions that match. - -Any switches in the PERLDOC environment variable will be used before the -command line arguments. The optional pod index file contains a list of -filenames, one per line. - -EOF -} - -if (defined $ENV{"PERLDOC"}) { - require Text::ParseWords; - unshift(@ARGV, Text::ParseWords::shellwords($ENV{"PERLDOC"})); -} -!NO!SUBS! - -my $getopts = "mhtluvriFf:Xq:n:"; -print OUT <<"!GET!OPTS!"; - -use vars qw( @{[map "\$opt_$_", ($getopts =~ /\w/g)]} ); - -getopts("$getopts") || usage; -!GET!OPTS! - -print OUT <<'!NO!SUBS!'; - -usage if $opt_h; - -# attempt to drop privs if we should be tainting and aren't -if (!($Is_VMS || $Is_MSWin32 || $Is_Dos || $Is_OS2 || $Is_BeOS) - && ($> == 0 || $< == 0) && !am_taint_checking()) -{ - my $id = eval { getpwnam("nobody") }; - $id = eval { getpwnam("nouser") } unless defined $id; - $id = -2 unless defined $id; - # - # According to Stevens' APUE and various - # (BSD, Solaris, HP-UX) man pages setting - # the real uid first and effective uid second - # is the way to go if one wants to drop privileges, - # because if one changes into an effective uid of - # non-zero, one cannot change the real uid any more. - # - # Actually, it gets even messier. There is - # a third uid, called the saved uid, and as - # long as that is zero, one can get back to - # uid of zero. Setting the real-effective *twice* - # helps in *most* systems (FreeBSD and Solaris) - # but apparently in HP-UX even this doesn't help: - # the saved uid stays zero (apparently the only way - # in HP-UX to change saved uid is to call setuid() - # when the effective uid is zero). - # - eval { - $< = $id; # real uid - $> = $id; # effective uid - $< = $id; # real uid - $> = $id; # effective uid - }; - die "Superuser must not run $0 without security audit and taint checks.\n" - unless !$@ && $< && $>; -} - -my $podidx; -if ($opt_X) { - $podidx = "$Config{'archlib'}/pod.idx"; - $podidx = "" unless -f $podidx && -r _ && -M _ <= 7; -} - -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 || $Is_BeOS - || !($ENV{TERM} && $ENV{TERM} !~ /dumb|emacs|none|unknown/i)) -{ - $opt_t = 1 unless ( $opts || $opt_n ); -} - -if ($opt_t) { require Pod::Text; import Pod::Text; } - -$opt_n = "nroff" if !$opt_n; - -my @pages; -if ($opt_f) { - @pages = ("perlfunc"); -} -elsif ($opt_q) { - @pages = ("perlfaq1" .. "perlfaq9"); -} -else { - @pages = @ARGV; -} - -# Does this look like a module or extension directory? -if (-f "Makefile.PL") { - - # 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\z/i; - local($_); - open(TEST,"<", $file) or die "Can't open $file: $!"; - while (<TEST>) { - if (/^=head/) { - close(TEST) or die "Can't close $file: $!"; - return 1; - } - } - close(TEST) or die "Can't close $file: $!"; - return 0; -} - -sub minus_f_nocase { - my($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 - # that is it all we can do - warn "Ignored $path: unreadable\n" if -f _; - 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 (splitdir $file){ - my $try = catfile @p, $p; - stat $try; - if (-d _) { - push @p, $p; - if ( $p eq $global_target) { - my $tmp_path = catfile @p; - my $path_f = 0; - for (@global_found) { - $path_f = 1 if $_ eq $tmp_path; - } - push (@global_found, $tmp_path) unless $path_f; - print STDERR "Found as @p but directory\n" if $opt_v; - } - } - elsif (-f _ && -r _) { - return $try; - } - elsif (-f _) { - warn "Ignored $try: unreadable\n"; - } - elsif (-d "@p") { - my $found=0; - my $lcp = lc $p; - opendir DIR, "@p" or die "opendir @p: $!"; - while ($cip=readdir(DIR)) { - if (lc $cip eq $lcp){ - $found++; - last; - } - } - closedir DIR or die "closedir @p: $!"; - return "" unless $found; - push @p, $cip; - return "@p" if -f "@p" and -r _; - warn "Ignored @p: unreadable\n" if -f _; - } - } - return ""; -} - - -sub check_file { - my($dir,$file) = @_; - return "" if length $dir and not -d $dir; - if ($opt_m) { - return minus_f_nocase($dir,$file); - } - else { - my $path = minus_f_nocase($dir,$file); - return $path if length $path and containspod($path); - } - return ""; -} - - -sub searchfor { - my($recurse,$s,@dirs) = @_; - $s =~ s!::!/!g; - $s = VMS::Filespec::unixify($s) if $Is_VMS; - return $s if -f $s && containspod($s); - printf STDERR "Looking for $s in @dirs\n" if $opt_v; - my $ret; - my $i; - my $dir; - $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!/\z!! if $Is_VMS; - if ( (! $opt_m && ( $ret = check_file $dir,"$s.pod")) - or ( $ret = check_file $dir,"$s.pm") - or ( $ret = check_file $dir,$s) - or ( $Is_VMS and - $ret = check_file $dir,"$s.com") - or ( $^O eq 'os2' and - $ret = check_file $dir,"$s.cmd") - or ( ($Is_MSWin32 or $Is_Dos or $^O eq 'os2') and - $ret = check_file $dir,"$s.bat") - or ( $ret = check_file "$dir/pod","$s.pod") - or ( $ret = check_file "$dir/pod",$s) - or ( $ret = check_file "$dir/pods","$s.pod") - or ( $ret = check_file "$dir/pods",$s) - ) { - return $ret; - } - - if ($recurse) { - 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) or die "Can't closedir $dir: $!"; - next unless @newdirs; - # 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); - } - } - return (); -} - -sub filter_nroff { - my @data = split /\n{2,}/, shift; - shift @data while @data and $data[0] !~ /\S/; # Go to header - shift @data if @data and $data[0] =~ /Contributed\s+Perl/; # Skip header - pop @data if @data and $data[-1] =~ /^\w/; # Skip footer, like - # 28/Jan/99 perl 5.005, patch 53 1 - join "\n\n", @data; -} - -sub page { - my ($tmp, $no_tty, @pagers) = @_; - if ($no_tty) { - open(TMP,"<", $tmp) or die "Can't open $tmp: $!"; - local $_; - while (<TMP>) { - print or die "Can't print to stdout: $!"; - } - close TMP or die "Can't close while $tmp: $!"; - } - else { - # On VMS, quoting prevents logical expansion, and temp files with no - # extension get the wrong default extension (such as .LIS for TYPE) - - $tmp = VMS::Filespec::rmsexpand($tmp, '.') if ($Is_VMS); - foreach my $pager (@pagers) { - if ($Is_VMS) { - last if system("$pager $tmp") == 0; - } else { - last if system("$pager \"$tmp\"") == 0; - } - } - } -} - -my @found; -foreach (@pages) { - if ($podidx && open(PODIDX, $podidx)) { - my $searchfor = catfile split '::'; - print STDERR "Searching for '$searchfor' in $podidx\n" if $opt_v; - local $_; - while (<PODIDX>) { - chomp; - push(@found, $_) if m,/$searchfor(?:\.(?:pod|pm))?\z,i; - } - close(PODIDX) or die "Can't close $podidx: $!"; - next; - } - print STDERR "Searching for $_\n" if $opt_v; - if ($opt_F) { - next unless -r; - push @found, $_ if $opt_m or containspod($_); - next; - } - # We must look both in @INC for library modules and in $bindir - # for executables, like h2xs or perldoc itself. - my @searchdirs = ($bindir, @INC); - unless ($opt_m) { - if ($Is_VMS) { - my($i,$trn); - for ($i = 0; $trn = $ENV{'DCL$PATH;'.$i}; $i++) { - push(@searchdirs,$trn); - } - push(@searchdirs,'perl_root:[lib.pod]') # installed pods - } - else { - push(@searchdirs, grep(-d, split($Config{path_sep}, - $ENV{'PATH'}))); - } - } - my @files = searchfor(0,$_,@searchdirs); - if (@files) { - print STDERR "Found as @files\n" if $opt_v; - } - else { - # no match, try recursive search - @searchdirs = grep(!/^\.\z/s,@INC); - @files= searchfor(1,$_,@searchdirs) if $opt_r; - if (@files) { - print STDERR "Loosely found as @files\n" if $opt_v; - } - else { - print STDERR "No " . - ($opt_m ? "module" : "documentation") . " found for \"$_\".\n"; - if (@global_found) { - print STDERR "However, try\n"; - for my $dir (@global_found) { - opendir(DIR, $dir) or die "opendir $dir: $!"; - while (my $file = readdir(DIR)) { - next if ($file =~ /^\./s); - $file =~ s/\.(pm|pod)\z//; # XXX: badfs - print STDERR "\tperldoc $_\::$file\n"; - } - closedir DIR or die "closedir $dir: $!"; - } - } - } - } - push(@found,@files); -} - -if (!@found) { - exit ($Is_VMS ? 98962 : 1); -} - -if ($opt_l) { - print join("\n", @found), "\n"; - exit; -} - -my $lines = $ENV{LINES} || 24; - -my $no_tty; -if (! -t STDOUT) { $no_tty = 1 } -END { close(STDOUT) || die "Can't close STDOUT: $!" } - -if ($Is_MSWin32) { - push @pagers, qw( more< less notepad ); - unshift @pagers, $ENV{PAGER} if $ENV{PAGER}; - for (@found) { s,/,\\,g } -} -elsif ($Is_VMS) { - push @pagers, qw( most more less type/page ); -} -elsif ($Is_Dos) { - push @pagers, qw( less.exe more.com< ); - unshift @pagers, $ENV{PAGER} if $ENV{PAGER}; -} -else { - if ($^O eq 'os2') { - unshift @pagers, 'less', 'cmd /c more <'; - } - push @pagers, qw( more less pg view cat ); - unshift @pagers, $ENV{PAGER} if $ENV{PAGER}; -} -unshift @pagers, $ENV{PERLDOC_PAGER} if $ENV{PERLDOC_PAGER}; - -if ($opt_m) { - foreach my $pager (@pagers) { - if (system($pager, @found) == 0) { - exit; - } - } - if ($Is_VMS) { - eval q{ - use vmsish qw(status exit); - exit $?; - 1; - } or die; - } - exit(1); -} - -my @pod; -if ($opt_f) { - my $perlfunc = shift @found; - 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 (<PFUNC>) { - last if /^=head2 Alphabetical Listing of Perl Functions/; - } - - # Look for our function - my $found = 0; - my $inlist = 0; - while (<PFUNC>) { - if (/^=item\s+\Q$search_string\E\b/o) { - $found = 1; - } - elsif (/^=item/) { - last if $found > 1 and not $inlist; - } - next unless $found; - if (/^=over/) { - ++$inlist; - } - elsif (/^=back/) { - --$inlist; - } - push @pod, $_; - ++$found if /^\w/; # found descriptive text - } - 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/ } or die <<EOD; -Invalid regular expression '$opt_q' given as -q pattern: - $@ -Did you mean \\Q$opt_q ? - -EOD - - for (@found) { die "invalid file spec: $!" if /[<>|]/ } - local $_; - while (<>) { - if (/^=head2\s+.*(?:$opt_q)/oi) { - $found = 1; - push @pod, "=head1 Found in $ARGV\n\n" unless $found_in{$ARGV}++; - } - elsif (/^=head[12]/) { - $found = 0; - } - next unless $found; - push @pod, $_; - } - if (!@pod) { - die("No documentation for perl FAQ keyword `$opt_q' found\n"); - } -} - -require File::Temp; - -my ($tmpfd, $tmp) = File::Temp::tempfile(UNLINK => 1); - -my $filter; - -if (@pod) { - my ($buffd, $buffer) = File::Temp::tempfile(UNLINK => 1); - print $buffd "=over 8\n\n"; - print $buffd @pod or die "Can't print $buffer: $!"; - print $buffd "=back\n"; - close $buffd or die "Can't close $buffer: $!"; - @found = $buffer; - $filter = 1; -} - -foreach (@found) { - my $file = $_; - my $err; - - if ($opt_t) { - Pod::Text->new()->parse_from_file($file, $tmpfd); - } - elsif (not $opt_u) { - 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 = $?)) { - print $tmpfd $rslt - or die "Can't print $tmp: $!"; - } - } - if ($opt_u or $err) { - open(IN,"<", $file) or die("Can't open $file: $!"); - my $cut = 1; - local $_; - while (<IN>) { - $cut = $1 eq 'cut' if /^=(\w+)/; - next if $cut; - print $tmpfd $_ - or die "Can't print $tmp: $!"; - } - close IN or die "Can't close $file: $!"; - } -} -close $tmpfd - or die "Can't close $tmp: $!"; -page($tmp, $no_tty, @pagers); - -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__ - -=head1 NAME - -perldoc - Look up Perl documentation in pod format. - -=head1 SYNOPSIS - -B<perldoc> [B<-h>] [B<-v>] [B<-t>] [B<-u>] [B<-m>] [B<-l>] [B<-F>] [B<-X>] PageName|ModuleName|ProgramName - -B<perldoc> B<-f> BuiltinFunction - -B<perldoc> B<-q> FAQ Keyword - -=head1 DESCRIPTION - -I<perldoc> looks up a piece of documentation in .pod format that is embedded -in the perl installation tree or in a perl script, and displays it via -C<pod2man | nroff -man | $PAGER>. (In addition, if running under HP-UX, -C<col -x> will be used.) This is primarily used for the documentation for -the perl library modules. - -Your system may also have man pages installed for those modules, in -which case you can probably just use the man(1) command. - -If you are looking for a table of contents to the Perl library modules -documentation, see the L<perltoc> page. - -=head1 OPTIONS - -=over 5 - -=item B<-h> help - -Prints out a brief help message. - -=item B<-v> verbose - -Describes search for the item in detail. - -=item B<-t> text output - -Display docs using plain text converter, instead of nroff. This may be faster, -but it won't look as nice. - -=item B<-u> unformatted - -Find docs only; skip reformatting by pod2* - -=item B<-m> module - -Display the entire module: both code and unformatted pod documentation. -This may be useful if the docs don't explain a function in the detail -you need, and you'd like to inspect the code directly; perldoc will find -the file for you and simply hand it off for display. - -=item B<-l> file name only - -Display the file name of the module found. - -=item B<-F> file names - -Consider arguments as file names, no search in directories will be performed. - -=item B<-f> perlfunc - -The B<-f> option followed by the name of a perl built in function will -extract the documentation of this function from L<perlfunc>. - -=item B<-q> perlfaq - -The B<-q> option takes a regular expression as an argument. It will search -the question headings in perlfaq[1-9] and print the entries matching -the regular expression. - -=item B<-X> use an index if present - -The B<-X> option looks for an 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<PageName|ModuleName|ProgramName> - -The item you want to look up. Nested modules (such as C<File::Basename>) -are specified either as C<File::Basename> or C<File/Basename>. You may also -give a descriptive name of a page, such as C<perlfunc>. - -=back - -=head1 SECURITY - -Because B<perldoc> does not run properly tainted, and is known to -have security issues, when run as the superuser it will attempt to -drop privileges by setting the effective and real IDs to nobody's -or nouser's account, or -2 if unavailable. If it cannot relinquish -its privileges, it will not run. - -=head1 ENVIRONMENT - -Any switches in the C<PERLDOC> environment variable will be used before the -command line arguments. C<perldoc> also searches directories -specified by the C<PERL5LIB> (or C<PERLLIB> if C<PERL5LIB> is not -defined) and C<PATH> environment variables. -(The latter is so that embedded pods for executables, such as -C<perldoc> itself, are available.) C<perldoc> will use, in order of -preference, the pager defined in C<PERLDOC_PAGER>, C<MANPAGER>, or -C<PAGER> before trying to find a pager on its own. (C<MANPAGER> is not -used if C<perldoc> was told to display plain text or unformatted pod.) - -One useful value for C<PERLDOC_PAGER> is C<less -+C -E>. - -=head1 VERSION - -This is perldoc v2.05. - -=head1 AUTHOR - -Kenneth Albanowski <kjahds@kjahds.com> - -Minor updates by Andy Dougherty <doughera@lafcol.lafayette.edu>, -and others. - -=cut - -# -# Version 2.05: Sat Oct 12 16:09:00 CEST 2002 -# Hugo van der Sanden <hv@crypt.org> -# Made -U the default, based on patch from Simon Cozens -# Version 2.04: Sun Aug 18 13:27:12 BST 2002 -# Randy W. Sims <RandyS@ThePierianSpring.org> -# allow -n to enable nroff under Win32 -# Version 2.03: Sun Apr 23 16:56:34 BST 2000 -# Hugo van der Sanden <hv@crypt.org> -# don't die when 'use blib' fails -# Version 2.02: Mon Mar 13 18:03:04 MST 2000 -# Tom Christiansen <tchrist@perl.com> -# Added -U insecurity option -# Version 2.01: Sat Mar 11 15:22:33 MST 2000 -# Tom Christiansen <tchrist@perl.com>, 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 <cwilson@ece.gatech.edu> -# changed /pod/ directory to /pods/ for cygwin -# to support cygwin/win32 -# Version 1.14: Wed Jul 15 01:50:20 EST 1998 -# Robin Barker <rmb1@cise.npl.co.uk> -# -strict, -w cleanups -# Version 1.13: Fri Feb 27 16:20:50 EST 1997 -# Gurusamy Sarathy <gsar@activestate.com> -# -doc tweaks for -F and -X options -# Version 1.12: Sat Apr 12 22:41:09 EST 1997 -# Gurusamy Sarathy <gsar@activestate.com> -# -various fixes for win32 -# Version 1.11: Tue Dec 26 09:54:33 EST 1995 -# Kenneth Albanowski <kjahds@kjahds.com> -# -added Charles Bailey's further VMS patches, and -u switch -# -added -t switch, with pod2text support -# -# Version 1.10: Thu Nov 9 07:23:47 EST 1995 -# Kenneth Albanowski <kjahds@kjahds.com> -# -added VMS support -# -added better error recognition (on no found pages, just exit. On -# missing nroff/pod2man, just display raw pod.) -# -added recursive/case-insensitive matching (thanks, Andreas). This -# slows things down a bit, unfortunately. Give a precise name, and -# it'll run faster. -# -# Version 1.01: Tue May 30 14:47:34 EDT 1995 -# Andy Dougherty <doughera@lafcol.lafayette.edu> -# -added pod documentation. -# -added PATH searching. -# -added searching pod/ subdirectory (mainly to pick up perlfunc.pod -# and friends. -# -# -# TODO: -# -# Cache directories read during sloppy match -!NO!SUBS! close OUT or die "Can't close $file: $!"; chmod 0755, $file or die "Can't reset permissions for $file: $!\n"; exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':'; chdir $origdir; + |