[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

$podidx = "$Config{'archlib'}/pod.idx";
$podidx = "" if $opt_X || !-f "pod.idx" && !-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(@dirs,'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;
}

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) {
	my $lines = $ENV{LINES} || 24;

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