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

#!/usr/local/bin/perl

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

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

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