with a module-driven version, and separates out its docs.
p4raw-id: //depot/perl@18228
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
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
--- /dev/null
+
+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?
--- /dev/null
+
+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;
+
--- /dev/null
+
+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;
+
--- /dev/null
+
+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
+
--- /dev/null
+
+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
+
--- /dev/null
+
+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
+
--- /dev/null
+
+# 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
+
--- /dev/null
+
+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
+
--- /dev/null
+
+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
+
--- /dev/null
+
+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
+
--- /dev/null
+
+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
+
--- /dev/null
+
+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;
+
--- /dev/null
+
+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;
+
--- /dev/null
+
+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;
+
--- /dev/null
+
+=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
+
#!/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;
# 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;
+
projects / platform / upstream / perl.git / commitdiff