[p5sagit/p5-mst-13.2.git] / utils / perldoc.PL

#!/usr/local/bin/perl

use Config;
use File::Basename qw(&basename &dirname);
use Cwd;

# List explicitly here the variables you want Configure to
# generate.  Metaconfig only looks for shell variables, so you
# have to mention them as if they were shell variables, not
# %Config entries.  Thus you write
#  $startperl
# to ensure Configure will look for $Config{startperl}.

# 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;
chdir dirname($0);
$file = basename($0, '.PL');
$file .= '.com' if $^O eq 'VMS';

open OUT,">$file" or die "Can't create $file: $!";

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.

print OUT <<"!GROK!THIS!";
$Config{startperl}
    eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}'
	if \$running_under_some_shell;

\@pagers = ();
push \@pagers, "$Config{'pager'}" if -x "$Config{'pager'}";
!GROK!THIS!

# In the following, perl variables are not expanded during extraction.

print OUT <<'!NO!SUBS!';

#
# Perldoc revision #1 -- look up a piece of documentation in .pod format that
# is embedded in the perl installation tree.
#
# This is not to be confused with Tom Christianson's perlman, which is a
# man replacement, written in perl. This perldoc is strictly for reading
# the perl manuals, though it too is written in perl.

if(@ARGV<1) {
	$me = $0;		# Editing $0 is unportable
	$me =~ s,.*/,,;
	die <<EOF;
Usage: $me [-h] [-r] [-i] [-v] [-t] [-u] [-m] [-l] [-F] [-X] PageName|ModuleName|ProgramName
       $me -f PerlFunc
       $me -q FAQKeywords

The -h option prints more help.  Also try "perldoc perldoc" to get
aquainted with the system.
EOF
}

use Getopt::Std;
use Config '%Config';

@global_found = ();
$global_target = "";

$Is_VMS = $^O eq 'VMS';
$Is_MSWin32 = $^O eq 'MSWin32';
$Is_Dos = $^O eq 'dos';

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)
    -u	 Display unformatted pod text
    -m   Display module's file in its entirety
    -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})


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', 
         `Term/Info', the partial name of a module, like `info', or 
         `makemaker', 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
}

use Text::ParseWords;


unshift(@ARGV,shellwords($ENV{"PERLDOC"}));

getopts("mhtluvriFf:Xq:") || usage;

usage if $opt_h || $opt_h; # avoid -w warning

if( $opt_X ) {
    $podidx = "$Config{'archlib'}/pod.idx";
    $podidx = "" unless -f $podidx && -r _ && -M _ <= 7;
}

if ($opt_t + $opt_u + $opt_m + $opt_l > 1) {
    usage("only one of -t, -u, -m or -l")
} elsif ($Is_MSWin32 || $Is_Dos) {
    $opt_t = 1 unless $opt_t + $opt_u + $opt_m + $opt_l;
}

if ($opt_t) { require Pod::Text; import Pod::Text; }

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 and blib/* libs to @INC (if they exist)
	unshift(@INC, '.');
	unshift(@INC, 'lib') if -d 'lib';
	require ExtUtils::testlib;
}


sub containspod {
    my($file, $readit) = @_;
    return 1 if !$readit && $file =~ /\.pod$/i;
    local($_);
    open(TEST,"<$file");
    while(<TEST>) {
	if(/^=head/) {
	    close(TEST);
	    return 1;
	}
    }
    close(TEST);
    return 0;
}

sub minus_f_nocase {
     my($dir,$file) = @_;
     my $path = join('/',$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 $file: unreadable\n" if -f _;
	return '';
     }
     local *DIR;
     local($")="/";
     my @p = ($dir);
     my($p,$cip);
     foreach $p (split(/\//, $file)){
	my $try = "@p/$p";
	stat $try;
 	if (-d _){
 	    push @p, $p;
	    if ( $p eq $global_target) {
		$tmp_path = join ('/', @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";
 	} else {
 	    my $found=0;
 	    my $lcp = lc $p;
 	    opendir DIR, "@p";
 	    while ($cip=readdir(DIR)) {
 		if (lc $cip eq $lcp){
 		    $found++;
 		    last;
 		}
 	    }
 	    closedir DIR;
 	    return "" unless $found;
 	    push @p, $cip;
 	    return "@p" if -f "@p" and -r _;
	    warn "Ignored $file: unreadable\n" if -f _;
 	}
     }
     return "";
}
 

sub check_file {
    my($dir,$file) = @_;
    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 = (split('/', $s))[-1];
    for ($i=0; $i<@dirs; $i++) {
	$dir = $dirs[$i];
	($dir = VMS::Filespec::unixpath($dir)) =~ s!/$!! if $Is_VMS;
	if (       ( $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)
	) {
	    return $ret;
	}
	
	if ($recurse) {
	    opendir(D,$dir);
	    my @newdirs = map "$dir/$_", grep {
		not /^\.\.?$/ and
		not /^auto$/  and   # save time! don't search auto dirs
		-d  "$dir/$_"
	    } readdir D;
	    closedir(D);
	    next unless @newdirs;
	    @newdirs = map((s/.dir$//,$_)[1],@newdirs) if $Is_VMS;
	    print STDERR "Also looking in @newdirs\n" if $opt_v;
	    push(@dirs,@newdirs);
	}
    }
    return ();
}


foreach (@pages) {
        if ($podidx && open(PODIDX, $podidx)) {
	    my $searchfor = $_;
	    local($_);
	    $searchfor =~ s,::,/,g;
	    print STDERR "Searching for '$searchfor' in $podidx\n" if $opt_v;
	    while (<PODIDX>) {
		chomp;
		push(@found, $_) if m,/$searchfor(?:\.(?:pod|pm))?$,i;
	    }
	    close(PODIDX);
	    next;
        }
	print STDERR "Searching for $_\n" if $opt_v;
	# We must look both in @INC for library modules and in PATH
	# for executables, like h2xs or perldoc itself.
	@searchdirs = @INC;
	if ($opt_F) {
	  next unless -r;
	  push @found, $_ if $opt_m or containspod($_);
	  next;
	}
	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'})));
	    }
	}
	@files = searchfor(0,$_,@searchdirs);
	if( @files ) {
		print STDERR "Found as @files\n" if $opt_v;
	} else {
		# no match, try recursive search
		
		@searchdirs = grep(!/^\.$/,@INC);
		
		@files= searchfor(1,$_,@searchdirs) if $opt_r;
		if( @files ) {
			print STDERR "Loosely found as @files\n" if $opt_v;
		} else {
			print STDERR "No documentation found for \"$_\".\n";
			if (@global_found) {
			    print STDERR "However, try\n";
			    my $dir = $file = "";
			    for $dir (@global_found) {
				opendir(DIR, $dir) or die "$!";
				while ($file = readdir(DIR)) {
				    next if ($file =~ /^\./);
				    $file =~ s/\.(pm|pod)$//;
				    print STDERR "\tperldoc $_\::$file\n";
				}
				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;

if( ! -t STDOUT ) { $no_tty = 1 }

if ($Is_MSWin32) {
	$tmp = "$ENV{TEMP}\\perldoc1.$$";
	push @pagers, qw( more< less notepad );
	unshift @pagers, $ENV{PAGER}  if $ENV{PAGER};
} elsif ($Is_VMS) {
	$tmp = 'Sys$Scratch:perldoc.tmp1_'.$$;
	push @pagers, qw( most more less type/page );
} elsif ($Is_Dos) {
	$tmp = "$ENV{TEMP}/perldoc1.$$";
	$tmp =~ tr!\\/!//!s;
	push @pagers, qw( less.exe more.com< );
	unshift @pagers, $ENV{PAGER}  if $ENV{PAGER};
} else {
	if ($^O eq 'os2') {
	  require POSIX;
	  $tmp = POSIX::tmpnam();
	  unshift @pagers, 'less', 'cmd /c more <';
	} else {
	  $tmp = "/tmp/perldoc1.$$";	  
	}
	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 $pager (@pagers) {
		system("$pager @found") or exit;
	}
	if ($Is_VMS) { eval 'use vmsish qw(status exit); exit $?' }
	exit 1;
} 

if ($opt_f) {
   my $perlfunc = shift @found;
   open(PFUNC, $perlfunc) or die "Can't open $perlfunc: $!";

   # Skip introduction
   while (<PFUNC>) {
       last if /^=head2 Alphabetical Listing of Perl Functions/;
   }

   # Look for our function
   my $found = 0;
   my @pod;
   while (<PFUNC>) {
       if (/^=item\s+\Q$opt_f\E\b/o)  {
	   $found = 1;
       } elsif (/^=item/) {
	   last if $found > 1;
       }
       next unless $found;
       push @pod, $_;
       ++$found if /^\w/;	# found descriptive text
   }
   if (@pod) {
       if ($opt_t) {
	   open(FORMATTER, "| pod2text") || die "Can't start filter";
	   print FORMATTER "=over 8\n\n";
	   print FORMATTER @pod;
	   print FORMATTER "=back\n";
	   close(FORMATTER);
       } elsif (@pod < $lines-2) {
	   print @pod;
       } else {
	   foreach $pager (@pagers) {
		open (PAGER, "| $pager") or next;
		print PAGER @pod ;
		close(PAGER) or next;
		last;
	   }
       }
   } else {
       die "No documentation for perl function `$opt_f' found\n";
   }
   exit;
}

if ($opt_q) {
   local @ARGV = @found;	# I'm lazy, sue me.
   my $found = 0;
   my %found_in;
   my @pod;

   while (<>) {
      if (/^=head2\s+.*$opt_q/oi) {
	 $found = 1;
	 push @pod, "=head1 Found in $ARGV\n\n" unless $found_in{$ARGV}++;
      } elsif (/^=head2/) {
	 $found = 0;
      }
      next unless $found;
      push @pod, $_;
   }
   
   if (@pod) {
      if ($opt_t) {
	 open(FORMATTER, "| pod2text") || die "Can't start filter";
	 print FORMATTER "=over 8\n\n";
	 print FORMATTER @pod;
	 print FORMATTER "=back\n";
	 close(FORMATTER);
      } elsif (@pod < $lines-2) {
	 print @pod;
      } else {
	 foreach $pager (@pagers) {
	    open (PAGER, "| $pager") or next;
	    print PAGER @pod ;
	    close(PAGER) or next;
	    last;
	 }
      }
   } else {
      die "No documentation for perl FAQ keyword `$opt_q' found\n";
   }
   exit;
}

foreach (@found) {

	if($opt_t) {
		open(TMP,">>$tmp");
		Pod::Text::pod2text($_,*TMP);
		close(TMP);
	} elsif(not $opt_u) {
		my $cmd = "pod2man --lax $_ | nroff -man";
		$cmd .= " | col -x" if $^O =~ /hpux/;
		$rslt = `$cmd`;
		unless(($err = $?)) {
			open(TMP,">>$tmp");
			print TMP $rslt;
			close TMP;
		}
	}
	                                                
	if( $opt_u or $err or -z $tmp) {
		open(OUT,">>$tmp");
		open(IN,"<$_");
		$cut = 1;
		while (<IN>) {
			$cut = $1 eq 'cut' if /^=(\w+)/;
			next if $cut;
			print OUT;
		}
		close(IN);
		close(OUT);
	}
}

if( $no_tty ) {
	open(TMP,"<$tmp");
	print while <TMP>;
	close(TMP);
} else {
	foreach $pager (@pagers) {
		system("$pager $tmp") or last;
	}
}

1 while unlink($tmp); #Possibly pointless VMSism

exit 0;

__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.

=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 a entry whose basename matches the name given on the
command line in the file C<$Config{archlib}/pod.idx>.  The pod.idx file should
contain fully qualified filenames, one per line.

=item B<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>. You make also give a
partial or wrong-case name, such as "basename" for "File::Basename", but
this will be slower, if there is more then one page with the same partial
name, you will only get the first one.

=back

=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.)

=head1 AUTHOR

Kenneth Albanowski <kjahds@kjahds.com>

Minor updates by Andy Dougherty <doughera@lafcol.lafayette.edu>

=cut

#
# Version 1.13: Fri Feb 27 16:20:50 EST 1997
#       Gurusamy Sarathy <gsar@umich.edu>
#	-doc tweaks for -F and -X options
# Version 1.12: Sat Apr 12 22:41:09 EST 1997
#       Gurusamy Sarathy <gsar@umich.edu>
#	-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;
Commit	Line	Data
4633a7c4	1	#!/usr/local/bin/perl
	2
	3	use Config;
	4	use File::Basename qw(&basename &dirname);
8a5546a1	5	use Cwd;
4633a7c4	6
85880f03	7	# List explicitly here the variables you want Configure to
	8	# generate. Metaconfig only looks for shell variables, so you
	9	# have to mention them as if they were shell variables, not
	10	# %Config entries. Thus you write
4633a7c4	11	# $startperl
85880f03	12	# to ensure Configure will look for $Config{startperl}.
4633a7c4	13
	14	# This forces PL files to create target in same directory as PL file.
	15	# This is so that make depend always knows where to find PL derivatives.
8a5546a1	16	$origdir = cwd;
44a8e56a	17	chdir dirname($0);
44a8e56a	18	$file = basename($0, '.PL');
774d564b	19	$file .= '.com' if $^O eq 'VMS';
4633a7c4	20
	21	open OUT,">$file" or die "Can't create $file: $!";
	22
	23	print "Extracting $file (with variable substitutions)\n";
	24
	25	# In this section, perl variables will be expanded during extraction.
	26	# You can use $Config{...} to use Configure variables.
	27
85880f03	28	print OUT <<"!GROK!THIS!";
5f05dabc	29	$Config{startperl}
	30	eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}'
	31	if \$running_under_some_shell;
55497cff	32
	33	\@pagers = ();
	34	push \@pagers, "$Config{'pager'}" if -x "$Config{'pager'}";
4633a7c4	35	!GROK!THIS!
	36
	37	# In the following, perl variables are not expanded during extraction.
	38
	39	print OUT <<'!NO!SUBS!';
	40
	41	#
	42	# Perldoc revision #1 -- look up a piece of documentation in .pod format that
	43	# is embedded in the perl installation tree.
	44	#
	45	# This is not to be confused with Tom Christianson's perlman, which is a
	46	# man replacement, written in perl. This perldoc is strictly for reading
	47	# the perl manuals, though it too is written in perl.
4633a7c4	48
4633a7c4	49	if(@ARGV<1) {
0b166b66	50	$me = $0; # Editing $0 is unportable
fb73857a	51	$me =~ s,.*/,,;
4633a7c4	52	die <<EOF;
5315ba28	53	Usage: $me [-h] [-r] [-i] [-v] [-t] [-u] [-m] [-l] [-F] [-X] PageName\|ModuleName\|ProgramName
0b166b66	54	$me -f PerlFunc
a3cb178b	55	$me -q FAQKeywords
4633a7c4	56
89b8affa	57	The -h option prints more help. Also try "perldoc perldoc" to get
89b8affa	58	aquainted with the system.
4633a7c4	59	EOF
	60	}
	61
	62	use Getopt::Std;
59586d77	63	use Config '%Config';
59586d77	64
fb73857a	65	@global_found = ();
	66	$global_target = "";
	67
7eda7aea	68	$Is_VMS = $^O eq 'VMS';
137443ea	69	$Is_MSWin32 = $^O eq 'MSWin32';
0151c6ef	70	$Is_Dos = $^O eq 'dos';
4633a7c4	71
4633a7c4	72	sub usage{
ff0cee69	73	warn "@_\n" if @_;
	74	# Erase evidence of previous errors (if any), so exit status is simple.
	75	$! = 0;
4633a7c4	76	die <<EOF;
31bdbec1	77	perldoc [options] PageName\|ModuleName\|ProgramName...
31bdbec1	78	perldoc [options] -f BuiltinFunction
a3cb178b	79	perldoc [options] -q FAQRegex
31bdbec1	80
31bdbec1	81	Options:
137443ea	82	-h Display this help message
5315ba28	83	-r Recursive search (slow)
5315ba28	84	-i Ignore case
137443ea	85	-t Display pod using pod2text instead of pod2man and nroff
137443ea	86	(-t is the default on win32)
85880f03	87	-u Display unformatted pod text
a3cb178b	88	-m Display module's file in its entirety
a3cb178b	89	-l Display the module's file name
cce34969	90	-F Arguments are file names, not modules
137443ea	91	-v Verbosely describe what's going on
89b8affa	92	-X use index if present (looks for pod.idx at $Config{archlib})
31bdbec1	93
a3cb178b	94
4633a7c4	95	PageName\|ModuleName...
	96	is the name of a piece of documentation that you want to look at. You
	97	may either give a descriptive name of the page (as in the case of
	98	`perlfunc') the name of a module, either like `Term::Info',
	99	`Term/Info', the partial name of a module, like `info', or
	100	`makemaker', or the name of a program, like `perldoc'.
31bdbec1	101
	102	BuiltinFunction
	103	is the name of a perl function. Will extract documentation from
	104	`perlfunc'.
a3cb178b	105
	106	FAQRegex
	107	is a regex. Will search perlfaq[1-9] for and extract any
	108	questions that match.
	109
4633a7c4	110	Any switches in the PERLDOC environment variable will be used before the
89b8affa	111	command line arguments. The optional pod index file contains a list of
89b8affa	112	filenames, one per line.
4633a7c4	113
	114	EOF
	115	}
	116
	117	use Text::ParseWords;
	118
	119
	120	unshift(@ARGV,shellwords($ENV{"PERLDOC"}));
	121
c8950503	122	getopts("mhtluvriFf:Xq:") \|\| usage;
85880f03	123
85880f03	124	usage if $opt_h \|\| $opt_h; # avoid -w warning
4633a7c4	125
0d3da1c8	126	if( $opt_X ) {
	127	$podidx = "$Config{'archlib'}/pod.idx";
	128	$podidx = "" unless -f $podidx && -r _ && -M _ <= 7;
	129	}
89b8affa	130
137443ea	131	if ($opt_t + $opt_u + $opt_m + $opt_l > 1) {
137443ea	132	usage("only one of -t, -u, -m or -l")
0151c6ef	133	} elsif ($Is_MSWin32 \|\| $Is_Dos) {
137443ea	134	$opt_t = 1 unless $opt_t + $opt_u + $opt_m + $opt_l;
137443ea	135	}
4633a7c4	136
7eda7aea	137	if ($opt_t) { require Pod::Text; import Pod::Text; }
4633a7c4	138
31bdbec1	139	if ($opt_f) {
31bdbec1	140	@pages = ("perlfunc");
a3cb178b	141	} elsif ($opt_q) {
a3cb178b	142	@pages = ("perlfaq1" .. "perlfaq9");
31bdbec1	143	} else {
	144	@pages = @ARGV;
	145	}
	146
fb73857a	147	# Does this look like a module or extension directory?
	148	if (-f "Makefile.PL") {
	149	# Add ., lib and blib/* libs to @INC (if they exist)
	150	unshift(@INC, '.');
	151	unshift(@INC, 'lib') if -d 'lib';
	152	require ExtUtils::testlib;
	153	}
	154
31bdbec1	155
85880f03	156
4633a7c4	157	sub containspod {
fb73857a	158	my($file, $readit) = @_;
	159	return 1 if !$readit && $file =~ /\.pod$/i;
	160	local($_);
	161	open(TEST,"<$file");
	162	while(<TEST>) {
	163	if(/^=head/) {
	164	close(TEST);
	165	return 1;
4633a7c4	166	}
fb73857a	167	}
	168	close(TEST);
	169	return 0;
4633a7c4	170	}
4633a7c4	171
84902520	172	sub minus_f_nocase {
5315ba28	173	my($dir,$file) = @_;
	174	my $path = join('/',$dir,$file);
	175	return $path if -f $path and -r _;
	176	if (!$opt_i or $Is_VMS or $Is_MSWin32 or $Is_Dos or $^O eq 'os2') {
	177	# on a case-forgiving file system or if case is important
	178	# that is it all we can do
2d7a9237	179	warn "Ignored $file: unreadable\n" if -f _;
fb73857a	180	return '';
84902520	181	}
4633a7c4	182	local *DIR;
4633a7c4	183	local($")="/";
5315ba28	184	my @p = ($dir);
5315ba28	185	my($p,$cip);
4633a7c4	186	foreach $p (split(/\//, $file)){
fb73857a	187	my $try = "@p/$p";
	188	stat $try;
	189	if (-d _){
4633a7c4	190	push @p, $p;
fb73857a	191	if ( $p eq $global_target) {
	192	$tmp_path = join ('/', @p);
	193	my $path_f = 0;
	194	for (@global_found) {
	195	$path_f = 1 if $_ eq $tmp_path;
	196	}
	197	push (@global_found, $tmp_path) unless $path_f;
	198	print STDERR "Found as @p but directory\n" if $opt_v;
	199	}
	200	} elsif (-f _ && -r _) {
	201	return $try;
	202	} elsif (-f _) {
	203	warn "Ignored $try: unreadable\n";
4633a7c4	204	} else {
	205	my $found=0;
	206	my $lcp = lc $p;
	207	opendir DIR, "@p";
	208	while ($cip=readdir(DIR)) {
	209	if (lc $cip eq $lcp){
	210	$found++;
	211	last;
	212	}
	213	}
	214	closedir DIR;
	215	return "" unless $found;
	216	push @p, $cip;
fb73857a	217	return "@p" if -f "@p" and -r _;
fb73857a	218	warn "Ignored $file: unreadable\n" if -f _;
4633a7c4	219	}
4633a7c4	220	}
5315ba28	221	return "";
fb73857a	222	}
4633a7c4	223
fb73857a	224
fb73857a	225	sub check_file {
5315ba28	226	my($dir,$file) = @_;
3046dd9f	227	if ($opt_m) {
5315ba28	228	return minus_f_nocase($dir,$file);
3046dd9f	229	} else {
5315ba28	230	my $path = minus_f_nocase($dir,$file);
249edfdf	231	return $path if length $path and containspod($path);
3046dd9f	232	}
5315ba28	233	return "";
fb73857a	234	}
	235
	236
	237	sub searchfor {
	238	my($recurse,$s,@dirs) = @_;
	239	$s =~ s!::!/!g;
	240	$s = VMS::Filespec::unixify($s) if $Is_VMS;
	241	return $s if -f $s && containspod($s);
	242	printf STDERR "Looking for $s in @dirs\n" if $opt_v;
	243	my $ret;
	244	my $i;
	245	my $dir;
	246	$global_target = (split('/', $s))[-1];
	247	for ($i=0; $i<@dirs; $i++) {
	248	$dir = $dirs[$i];
	249	($dir = VMS::Filespec::unixpath($dir)) =~ s!/$!! if $Is_VMS;
5315ba28	250	if ( ( $ret = check_file $dir,"$s.pod")
	251	or ( $ret = check_file $dir,"$s.pm")
	252	or ( $ret = check_file $dir,$s)
fb73857a	253	or ( $Is_VMS and
5315ba28	254	$ret = check_file $dir,"$s.com")
59586d77	255	or ( $^O eq 'os2' and
5315ba28	256	$ret = check_file $dir,"$s.cmd")
0151c6ef	257	or ( ($Is_MSWin32 or $Is_Dos or $^O eq 'os2') and
5315ba28	258	$ret = check_file $dir,"$s.bat")
	259	or ( $ret = check_file "$dir/pod","$s.pod")
	260	or ( $ret = check_file "$dir/pod",$s)
fb73857a	261	) {
	262	return $ret;
	263	}
	264
	265	if ($recurse) {
	266	opendir(D,$dir);
	267	my @newdirs = map "$dir/$_", grep {
	268	not /^\.\.?$/ and
	269	not /^auto$/ and # save time! don't search auto dirs
	270	-d "$dir/$_"
	271	} readdir D;
	272	closedir(D);
	273	next unless @newdirs;
	274	@newdirs = map((s/.dir$//,$_)[1],@newdirs) if $Is_VMS;
	275	print STDERR "Also looking in @newdirs\n" if $opt_v;
	276	push(@dirs,@newdirs);
	277	}
	278	}
	279	return ();
	280	}
4633a7c4	281
	282
	283	foreach (@pages) {
89b8affa	284	if ($podidx && open(PODIDX, $podidx)) {
	285	my $searchfor = $_;
	286	local($_);
	287	$searchfor =~ s,::,/,g;
	288	print STDERR "Searching for '$searchfor' in $podidx\n" if $opt_v;
	289	while (<PODIDX>) {
	290	chomp;
	291	push(@found, $_) if m,/$searchfor(?:\.(?:pod\|pm))?$,i;
	292	}
	293	close(PODIDX);
	294	next;
	295	}
4633a7c4	296	print STDERR "Searching for $_\n" if $opt_v;
	297	# We must look both in @INC for library modules and in PATH
	298	# for executables, like h2xs or perldoc itself.
	299	@searchdirs = @INC;
cce34969	300	if ($opt_F) {
	301	next unless -r;
	302	push @found, $_ if $opt_m or containspod($_);
	303	next;
	304	}
7eda7aea	305	unless ($opt_m) {
	306	if ($Is_VMS) {
	307	my($i,$trn);
	308	for ($i = 0; $trn = $ENV{'DCL$PATH'.$i}; $i++) {
	309	push(@searchdirs,$trn);
	310	}
877622ba	311	push(@searchdirs,'perl_root:[lib.pod]') # installed pods
7eda7aea	312	} else {
59586d77	313	push(@searchdirs, grep(-d, split($Config{path_sep},
59586d77	314	$ENV{'PATH'})));
7eda7aea	315	}
85880f03	316	}
877622ba	317	@files = searchfor(0,$_,@searchdirs);
4633a7c4	318	if( @files ) {
	319	print STDERR "Found as @files\n" if $opt_v;
	320	} else {
	321	# no match, try recursive search
	322
	323	@searchdirs = grep(!/^\.$/,@INC);
	324
5315ba28	325	@files= searchfor(1,$_,@searchdirs) if $opt_r;
4633a7c4	326	if( @files ) {
85880f03	327	print STDERR "Loosely found as @files\n" if $opt_v;
4633a7c4	328	} else {
fb73857a	329	print STDERR "No documentation found for \"$_\".\n";
	330	if (@global_found) {
	331	print STDERR "However, try\n";
	332	my $dir = $file = "";
	333	for $dir (@global_found) {
	334	opendir(DIR, $dir) or die "$!";
	335	while ($file = readdir(DIR)) {
	336	next if ($file =~ /^\./);
	337	$file =~ s/\.(pm\|pod)$//;
	338	print STDERR "\tperldoc $_\::$file\n";
	339	}
	340	closedir DIR;
	341	}
	342	}
4633a7c4	343	}
	344	}
	345	push(@found,@files);
	346	}
	347
	348	if(!@found) {
85880f03	349	exit ($Is_VMS ? 98962 : 1);
4633a7c4	350	}
4633a7c4	351
44a8e56a	352	if ($opt_l) {
	353	print join("\n", @found), "\n";
	354	exit;
	355	}
	356
877622ba	357	my $lines = $ENV{LINES} \|\| 24;
877622ba	358
31bdbec1	359	if( ! -t STDOUT ) { $no_tty = 1 }
4633a7c4	360
137443ea	361	if ($Is_MSWin32) {
	362	$tmp = "$ENV{TEMP}\\perldoc1.$$";
	363	push @pagers, qw( more< less notepad );
55497cff	364	unshift @pagers, $ENV{PAGER} if $ENV{PAGER};
137443ea	365	} elsif ($Is_VMS) {
4633a7c4	366	$tmp = 'Sys$Scratch:perldoc.tmp1_'.$$;
55497cff	367	push @pagers, qw( most more less type/page );
0151c6ef	368	} elsif ($Is_Dos) {
	369	$tmp = "$ENV{TEMP}/perldoc1.$$";
	370	$tmp =~ tr!\\/!//!s;
	371	push @pagers, qw( less.exe more.com< );
	372	unshift @pagers, $ENV{PAGER} if $ENV{PAGER};
137443ea	373	} else {
59586d77	374	if ($^O eq 'os2') {
	375	require POSIX;
	376	$tmp = POSIX::tmpnam();
491527d0	377	unshift @pagers, 'less', 'cmd /c more <';
59586d77	378	} else {
	379	$tmp = "/tmp/perldoc1.$$";
	380	}
137443ea	381	push @pagers, qw( more less pg view cat );
137443ea	382	unshift @pagers, $ENV{PAGER} if $ENV{PAGER};
4633a7c4	383	}
44a8e56a	384	unshift @pagers, $ENV{PERLDOC_PAGER} if $ENV{PERLDOC_PAGER};
4633a7c4	385
7eda7aea	386	if ($opt_m) {
1e422769	387	foreach $pager (@pagers) {
	388	system("$pager @found") or exit;
	389	}
	390	if ($Is_VMS) { eval 'use vmsish qw(status exit); exit $?' }
	391	exit 1;
7eda7aea	392	}
7eda7aea	393
31bdbec1	394	if ($opt_f) {
	395	my $perlfunc = shift @found;
	396	open(PFUNC, $perlfunc) or die "Can't open $perlfunc: $!";
	397
	398	# Skip introduction
	399	while (<PFUNC>) {
	400	last if /^=head2 Alphabetical Listing of Perl Functions/;
	401	}
	402
	403	# Look for our function
	404	my $found = 0;
fb73857a	405	my @pod;
31bdbec1	406	while (<PFUNC>) {
31bdbec1	407	if (/^=item\s+\Q$opt_f\E\b/o) {
fb73857a	408	$found = 1;
31bdbec1	409	} elsif (/^=item/) {
fb73857a	410	last if $found > 1;
31bdbec1	411	}
fb73857a	412	next unless $found;
	413	push @pod, $_;
	414	++$found if /^\w/; # found descriptive text
31bdbec1	415	}
	416	if (@pod) {
	417	if ($opt_t) {
	418	open(FORMATTER, "\| pod2text") \|\| die "Can't start filter";
	419	print FORMATTER "=over 8\n\n";
	420	print FORMATTER @pod;
	421	print FORMATTER "=back\n";
	422	close(FORMATTER);
43051805	423	} elsif (@pod < $lines-2) {
31bdbec1	424	print @pod;
43051805	425	} else {
	426	foreach $pager (@pagers) {
	427	open (PAGER, "\| $pager") or next;
	428	print PAGER @pod ;
	429	close(PAGER) or next;
	430	last;
	431	}
31bdbec1	432	}
31bdbec1	433	} else {
ed5c9e50	434	die "No documentation for perl function `$opt_f' found\n";
31bdbec1	435	}
	436	exit;
	437	}
	438
a3cb178b	439	if ($opt_q) {
	440	local @ARGV = @found; # I'm lazy, sue me.
	441	my $found = 0;
	442	my %found_in;
	443	my @pod;
	444
	445	while (<>) {
	446	if (/^=head2\s+.*$opt_q/oi) {
	447	$found = 1;
	448	push @pod, "=head1 Found in $ARGV\n\n" unless $found_in{$ARGV}++;
	449	} elsif (/^=head2/) {
	450	$found = 0;
	451	}
	452	next unless $found;
	453	push @pod, $_;
	454	}
	455
	456	if (@pod) {
	457	if ($opt_t) {
	458	open(FORMATTER, "\| pod2text") \|\| die "Can't start filter";
	459	print FORMATTER "=over 8\n\n";
	460	print FORMATTER @pod;
	461	print FORMATTER "=back\n";
	462	close(FORMATTER);
877622ba	463	} elsif (@pod < $lines-2) {
a3cb178b	464	print @pod;
877622ba	465	} else {
	466	foreach $pager (@pagers) {
	467	open (PAGER, "\| $pager") or next;
	468	print PAGER @pod ;
	469	close(PAGER) or next;
	470	last;
	471	}
a3cb178b	472	}
a3cb178b	473	} else {
877622ba	474	die "No documentation for perl FAQ keyword `$opt_q' found\n";
a3cb178b	475	}
	476	exit;
	477	}
	478
4633a7c4	479	foreach (@found) {
7eda7aea	480
85880f03	481	if($opt_t) {
	482	open(TMP,">>$tmp");
	483	Pod::Text::pod2text($_,*TMP);
	484	close(TMP);
	485	} elsif(not $opt_u) {
1e422769	486	my $cmd = "pod2man --lax $_ \| nroff -man";
	487	$cmd .= " \| col -x" if $^O =~ /hpux/;
	488	$rslt = `$cmd`;
	489	unless(($err = $?)) {
	490	open(TMP,">>$tmp");
	491	print TMP $rslt;
	492	close TMP;
40fc7247	493	}
85880f03	494	}
4633a7c4	495
85880f03	496	if( $opt_u or $err or -z $tmp) {
4633a7c4	497	open(OUT,">>$tmp");
4633a7c4	498	open(IN,"<$_");
85880f03	499	$cut = 1;
	500	while (<IN>) {
	501	$cut = $1 eq 'cut' if /^=(\w+)/;
	502	next if $cut;
	503	print OUT;
	504	}
4633a7c4	505	close(IN);
	506	close(OUT);
	507	}
	508	}
	509
31bdbec1	510	if( $no_tty ) {
4633a7c4	511	open(TMP,"<$tmp");
	512	print while <TMP>;
	513	close(TMP);
	514	} else {
85880f03	515	foreach $pager (@pagers) {
1e422769	516	system("$pager $tmp") or last;
4633a7c4	517	}
	518	}
	519
	520	1 while unlink($tmp); #Possibly pointless VMSism
	521
	522	exit 0;
7eda7aea	523
	524	__END__
	525
	526	=head1 NAME
	527
	528	perldoc - Look up Perl documentation in pod format.
	529
	530	=head1 SYNOPSIS
	531
89b8affa	532	B<perldoc> [B<-h>] [B<-v>] [B<-t>] [B<-u>] [B<-m>] [B<-l>] [B<-F>] [B<-X>] PageName\|ModuleName\|ProgramName
7eda7aea	533
31bdbec1	534	B<perldoc> B<-f> BuiltinFunction
31bdbec1	535
c8950503	536	B<perldoc> B<-q> FAQ Keyword
c8950503	537
7eda7aea	538	=head1 DESCRIPTION
7eda7aea	539
40fc7247	540	I<perldoc> looks up a piece of documentation in .pod format that is embedded
	541	in the perl installation tree or in a perl script, and displays it via
	542	C<pod2man \| nroff -man \| $PAGER>. (In addition, if running under HP-UX,
	543	C<col -x> will be used.) This is primarily used for the documentation for
	544	the perl library modules.
7eda7aea	545
	546	Your system may also have man pages installed for those modules, in
	547	which case you can probably just use the man(1) command.
	548
	549	=head1 OPTIONS
	550
	551	=over 5
	552
	553	=item B<-h> help
	554
	555	Prints out a brief help message.
	556
	557	=item B<-v> verbose
	558
	559	Describes search for the item in detail.
	560
	561	=item B<-t> text output
	562
	563	Display docs using plain text converter, instead of nroff. This may be faster,
	564	but it won't look as nice.
	565
	566	=item B<-u> unformatted
	567
	568	Find docs only; skip reformatting by pod2*
	569
	570	=item B<-m> module
	571
	572	Display the entire module: both code and unformatted pod documentation.
	573	This may be useful if the docs don't explain a function in the detail
	574	you need, and you'd like to inspect the code directly; perldoc will find
	575	the file for you and simply hand it off for display.
	576
44a8e56a	577	=item B<-l> file name only
	578
	579	Display the file name of the module found.
	580
cce34969	581	=item B<-F> file names
cce34969	582
89b8affa	583	Consider arguments as file names, no search in directories will be performed.
cce34969	584
31bdbec1	585	=item B<-f> perlfunc
	586
	587	The B<-f> option followed by the name of a perl built in function will
	588	extract the documentation of this function from L<perlfunc>.
	589
c8950503	590	=item B<-q> perlfaq
	591
	592	The B<-q> option takes a regular expression as an argument. It will search
	593	the question headings in perlfaq[1-9] and print the entries matching
	594	the regular expression.
	595
89b8affa	596	=item B<-X> use an index if present
	597
	598	The B<-X> option looks for a entry whose basename matches the name given on the
	599	command line in the file C<$Config{archlib}/pod.idx>. The pod.idx file should
	600	contain fully qualified filenames, one per line.
	601
7eda7aea	602	=item B<PageName\|ModuleName\|ProgramName>
	603
	604	The item you want to look up. Nested modules (such as C<File::Basename>)
	605	are specified either as C<File::Basename> or C<File/Basename>. You may also
	606	give a descriptive name of a page, such as C<perlfunc>. You make also give a
	607	partial or wrong-case name, such as "basename" for "File::Basename", but
	608	this will be slower, if there is more then one page with the same partial
	609	name, you will only get the first one.
	610
	611	=back
	612
	613	=head1 ENVIRONMENT
	614
	615	Any switches in the C<PERLDOC> environment variable will be used before the
	616	command line arguments. C<perldoc> also searches directories
	617	specified by the C<PERL5LIB> (or C<PERLLIB> if C<PERL5LIB> is not
	618	defined) and C<PATH> environment variables.
	619	(The latter is so that embedded pods for executables, such as
a3cb178b	620	C<perldoc> itself, are available.) C<perldoc> will use, in order of
	621	preference, the pager defined in C<PERLDOC_PAGER>, C<MANPAGER>, or
	622	C<PAGER> before trying to find a pager on its own. (C<MANPAGER> is not
	623	used if C<perldoc> was told to display plain text or unformatted pod.)
7eda7aea	624
	625	=head1 AUTHOR
	626
	627	Kenneth Albanowski <kjahds@kjahds.com>
	628
	629	Minor updates by Andy Dougherty <doughera@lafcol.lafayette.edu>
	630
7eda7aea	631	=cut
	632
	633	#
89b8affa	634	# Version 1.13: Fri Feb 27 16:20:50 EST 1997
	635	# Gurusamy Sarathy <gsar@umich.edu>
	636	# -doc tweaks for -F and -X options
137443ea	637	# Version 1.12: Sat Apr 12 22:41:09 EST 1997
	638	# Gurusamy Sarathy <gsar@umich.edu>
	639	# -various fixes for win32
7eda7aea	640	# Version 1.11: Tue Dec 26 09:54:33 EST 1995
	641	# Kenneth Albanowski <kjahds@kjahds.com>
	642	# -added Charles Bailey's further VMS patches, and -u switch
	643	# -added -t switch, with pod2text support
	644	#
	645	# Version 1.10: Thu Nov 9 07:23:47 EST 1995
	646	# Kenneth Albanowski <kjahds@kjahds.com>
	647	# -added VMS support
	648	# -added better error recognition (on no found pages, just exit. On
	649	# missing nroff/pod2man, just display raw pod.)
	650	# -added recursive/case-insensitive matching (thanks, Andreas). This
	651	# slows things down a bit, unfortunately. Give a precise name, and
	652	# it'll run faster.
	653	#
	654	# Version 1.01: Tue May 30 14:47:34 EDT 1995
	655	# Andy Dougherty <doughera@lafcol.lafayette.edu>
	656	# -added pod documentation.
	657	# -added PATH searching.
	658	# -added searching pod/ subdirectory (mainly to pick up perlfunc.pod
	659	# and friends.
	660	#
	661	#
	662	# TODO:
	663	#
	664	# Cache directories read during sloppy match
4633a7c4	665	!NO!SUBS!
	666
	667	close OUT or die "Can't close $file: $!";
	668	chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
	669	exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';
8a5546a1	670	chdir $origdir;