[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

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

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 modules file in its entirety
    -l   Display the modules 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'.
         
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:X") || 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");
} 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();
	} 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);
       } 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.)

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