[perl5.git] / lib / Pod / Find.pm

#############################################################################  
# Pod/Find.pm -- finds files containing POD documentation
#
# Author: Marek Rouchal <marekr@cpan.org>
# 
# Copyright (C) 1999-2000 by Marek Rouchal (and borrowing code
# from Nick Ing-Simmon's PodToHtml). All rights reserved.
# This file is part of "PodParser". Pod::Find is free software;
# you can redistribute it and/or modify it under the same terms
# as Perl itself.
#############################################################################

package Pod::Find;

use vars qw($VERSION);
$VERSION = 0.24_01;   ## Current version of this package
require  5.005;   ## requires this Perl version or later
use Carp;

#############################################################################

=head1 NAME

Pod::Find - find POD documents in directory trees

=head1 SYNOPSIS

  use Pod::Find qw(pod_find simplify_name);
  my %pods = pod_find({ -verbose => 1, -inc => 1 });
  foreach(keys %pods) {
     print "found library POD `$pods{$_}' in $_\n";
  }

  print "podname=",simplify_name('a/b/c/mymodule.pod'),"\n";

  $location = pod_where( { -inc => 1 }, "Pod::Find" );

=head1 DESCRIPTION

B<Pod::Find> provides a set of functions to locate POD files.  Note that
no function is exported by default to avoid pollution of your namespace,
so be sure to specify them in the B<use> statement if you need them:

  use Pod::Find qw(pod_find);

=cut

use strict;
#use diagnostics;
use Exporter;
use File::Spec;
use File::Find;
use Cwd;

use vars qw(@ISA @EXPORT_OK $VERSION);
@ISA = qw(Exporter);
@EXPORT_OK = qw(&pod_find &simplify_name &pod_where &contains_pod);

# package global variables
my $SIMPLIFY_RX;

=head2 C<pod_find( { %opts } , @directories )>

The function B<pod_find> searches for POD documents in a given set of
files and/or directories. It returns a hash with the file names as keys
and the POD name as value. The POD name is derived from the file name
and its position in the directory tree.

E.g. when searching in F<$HOME/perl5lib>, the file
F<$HOME/perl5lib/MyModule.pm> would get the POD name I<MyModule>,
whereas F<$HOME/perl5lib/Myclass/Subclass.pm> would be
I<Myclass::Subclass>. The name information can be used for POD
translators.

Only text files containing at least one valid POD command are found.

A warning is printed if more than one POD file with the same POD name
is found, e.g. F<CPAN.pm> in different directories. This usually
indicates duplicate occurrences of modules in the I<@INC> search path.

B<OPTIONS> The first argument for B<pod_find> may be a hash reference
with options. The rest are either directories that are searched
recursively or files.  The POD names of files are the plain basenames
with any Perl-like extension (.pm, .pl, .pod) stripped.

=over 4

=item C<-verbose =E<gt> 1>

Print progress information while scanning.

=item C<-perl =E<gt> 1>

Apply Perl-specific heuristics to find the correct PODs. This includes
stripping Perl-like extensions, omitting subdirectories that are numeric
but do I<not> match the current Perl interpreter's version id, suppressing
F<site_perl> as a module hierarchy name etc.

=item C<-script =E<gt> 1>

Search for PODs in the current Perl interpreter's installation 
B<scriptdir>. This is taken from the local L<Config|Config> module.

=item C<-inc =E<gt> 1>

Search for PODs in the current Perl interpreter's I<@INC> paths. This
automatically considers paths specified in the C<PERL5LIB> environment
as this is prepended to I<@INC> by the Perl interpreter itself.

=back

=cut

# return a hash of the POD files found
# first argument may be a hashref (options),
# rest is a list of directories to search recursively
sub pod_find
{
    my %opts;
    if(ref $_[0]) {
        %opts = %{shift()};
    }

    $opts{-verbose} ||= 0;
    $opts{-perl}    ||= 0;

    my (@search) = @_;

    if($opts{-script}) {
        require Config;
        push(@search, $Config::Config{scriptdir})
            if -d $Config::Config{scriptdir};
        $opts{-perl} = 1;
    }

    if($opts{-inc}) {
        if ($^O eq 'MacOS') {
            # tolerate '.', './some_dir' and '(../)+some_dir' on Mac OS
            my @new_INC = @INC;
            for (@new_INC) {
                if ( $_ eq '.' ) {
                    $_ = ':';
                } elsif ( $_ =~ s|^((?:\.\./)+)|':' x (length($1)/3)|e ) {
                    $_ = ':'. $_;
                } else {
                    $_ =~ s|^\./|:|;
                }
            }
            push(@search, grep($_ ne File::Spec->curdir, @new_INC));
        } else {
            push(@search, grep($_ ne File::Spec->curdir, @INC));
        }

        $opts{-perl} = 1;
    }

    if($opts{-perl}) {
        require Config;
        # this code simplifies the POD name for Perl modules:
        # * remove "site_perl"
        # * remove e.g. "i586-linux" (from 'archname')
        # * remove e.g. 5.00503
        # * remove pod/ if followed by *.pod (e.g. in pod/perlfunc.pod)

        # Mac OS:
        # * remove ":?site_perl:"
        # * remove :?pod: if followed by *.pod (e.g. in :pod:perlfunc.pod)

        if ($^O eq 'MacOS') {
            $SIMPLIFY_RX =
              qq!^(?i:\:?site_perl\:|\:?pod\:(?=.*?\\.pod\\z))*!;
        } else {
            $SIMPLIFY_RX =
              qq!^(?i:site(_perl)?/|\Q$Config::Config{archname}\E/|\\d+\\.\\d+([_.]?\\d+)?/|pod/(?=.*?\\.pod\\z))*!;
        }
    }

    my %dirs_visited;
    my %pods;
    my %names;
    my $pwd = cwd();

    foreach my $try (@search) {
        unless(File::Spec->file_name_is_absolute($try)) {
            # make path absolute
            $try = File::Spec->catfile($pwd,$try);
        }
        # simplify path
        # on VMS canonpath will vmsify:[the.path], but File::Find::find
        # wants /unixy/paths
        $try = File::Spec->canonpath($try) if ($^O ne 'VMS');
        $try = VMS::Filespec::unixify($try) if ($^O eq 'VMS');
        my $name;
        if(-f $try) {
            if($name = _check_and_extract_name($try, $opts{-verbose})) {
                _check_for_duplicates($try, $name, \%names, \%pods);
            }
            next;
        }
        my $root_rx = $^O eq 'MacOS' ? qq!^\Q$try\E! : qq!^\Q$try\E/!;
        File::Find::find( sub {
            my $item = $File::Find::name;
            if(-d) {
                if($item =~ m{/(?:RCS|CVS|SCCS|\.svn)$}) {
                    $File::Find::prune = 1;
                    return;
                }
                elsif($dirs_visited{$item}) {
                    warn "Directory '$item' already seen, skipping.\n"
                        if($opts{-verbose});
                    $File::Find::prune = 1;
                    return;
                }
                else {
                    $dirs_visited{$item} = 1;
                }
                if($opts{-perl} && /^(\d+\.[\d_]+)\z/s && eval "$1" != $]) {
                    $File::Find::prune = 1;
                    warn "Perl $] version mismatch on $_, skipping.\n"
                        if($opts{-verbose});
                }
                return;
            }
            if($name = _check_and_extract_name($item, $opts{-verbose}, $root_rx)) {
                _check_for_duplicates($item, $name, \%names, \%pods);
            }
        }, $try); # end of File::Find::find
    }
    chdir $pwd;
    %pods;
}

sub _check_for_duplicates {
    my ($file, $name, $names_ref, $pods_ref) = @_;
    if($$names_ref{$name}) {
        warn "Duplicate POD found (shadowing?): $name ($file)\n";
        warn "    Already seen in ",
            join(' ', grep($$pods_ref{$_} eq $name, keys %$pods_ref)),"\n";
    }
    else {
        $$names_ref{$name} = 1;
    }
    $$pods_ref{$file} = $name;
}

sub _check_and_extract_name {
    my ($file, $verbose, $root_rx) = @_;

    # check extension or executable flag
    # this involves testing the .bat extension on Win32!
    unless(-f $file && -T _ && ($file =~ /\.(pod|pm|plx?)\z/i || -x _ )) {
      return undef;
    }

    return undef unless contains_pod($file,$verbose);

    # strip non-significant path components
    # TODO what happens on e.g. Win32?
    my $name = $file;
    if(defined $root_rx) {
        $name =~ s!$root_rx!!s;
        $name =~ s!$SIMPLIFY_RX!!os if(defined $SIMPLIFY_RX);
    }
    else {
        if ($^O eq 'MacOS') {
            $name =~ s/^.*://s;
        } else {
            $name =~ s:^.*/::s;
        }
    }
    _simplify($name);
    $name =~ s!/+!::!g; #/
    if ($^O eq 'MacOS') {
        $name =~ s!:+!::!g; # : -> ::
    } else {
        $name =~ s!/+!::!g; # / -> ::
    }
    $name;
}

=head2 C<simplify_name( $str )>

The function B<simplify_name> is equivalent to B<basename>, but also
strips Perl-like extensions (.pm, .pl, .pod) and extensions like
F<.bat>, F<.cmd> on Win32 and OS/2, or F<.com> on VMS, respectively.

=cut

# basic simplification of the POD name:
# basename & strip extension
sub simplify_name {
    my ($str) = @_;
    # remove all path components
    if ($^O eq 'MacOS') {
        $str =~ s/^.*://s;
    } else {
        $str =~ s:^.*/::s;
    }
    _simplify($str);
    $str;
}

# internal sub only
sub _simplify {
    # strip Perl's own extensions
    $_[0] =~ s/\.(pod|pm|plx?)\z//i;
    # strip meaningless extensions on Win32 and OS/2
    $_[0] =~ s/\.(bat|exe|cmd)\z//i if($^O =~ /mswin|os2/i);
    # strip meaningless extensions on VMS
    $_[0] =~ s/\.(com)\z//i if($^O eq 'VMS');
}

# contribution from Tim Jenness <t.jenness@jach.hawaii.edu>

=head2 C<pod_where( { %opts }, $pod )>

Returns the location of a pod document given a search directory
and a module (e.g. C<File::Find>) or script (e.g. C<perldoc>) name.

Options:

=over 4

=item C<-inc =E<gt> 1>

Search @INC for the pod and also the C<scriptdir> defined in the
L<Config|Config> module.

=item C<-dirs =E<gt> [ $dir1, $dir2, ... ]>

Reference to an array of search directories. These are searched in order
before looking in C<@INC> (if B<-inc>). Current directory is used if
none are specified.

=item C<-verbose =E<gt> 1>

List directories as they are searched

=back

Returns the full path of the first occurrence to the file.
Package names (eg 'A::B') are automatically converted to directory
names in the selected directory. (eg on unix 'A::B' is converted to
'A/B'). Additionally, '.pm', '.pl' and '.pod' are appended to the
search automatically if required.

A subdirectory F<pod/> is also checked if it exists in any of the given
search directories. This ensures that e.g. L<perlfunc|perlfunc> is
found.

It is assumed that if a module name is supplied, that that name
matches the file name. Pods are not opened to check for the 'NAME'
entry.

A check is made to make sure that the file that is found does 
contain some pod documentation.

=cut

sub pod_where {

  # default options
  my %options = (
         '-inc' => 0,
         '-verbose' => 0,
         '-dirs' => [ File::Spec->curdir ],
        );

  # Check for an options hash as first argument
  if (defined $_[0] && ref($_[0]) eq 'HASH') {
    my $opt = shift;

    # Merge default options with supplied options
    %options = (%options, %$opt);
  }

  # Check usage
  carp 'Usage: pod_where({options}, $pod)' unless (scalar(@_));

  # Read argument
  my $pod = shift;

  # Split on :: and then join the name together using File::Spec
  my @parts = split (/::/, $pod);

  # Get full directory list
  my @search_dirs = @{ $options{'-dirs'} };

  if ($options{'-inc'}) {

    require Config;

    # Add @INC
    if ($^O eq 'MacOS' && $options{'-inc'}) {
        # tolerate '.', './some_dir' and '(../)+some_dir' on Mac OS
        my @new_INC = @INC;
        for (@new_INC) {
            if ( $_ eq '.' ) {
                $_ = ':';
            } elsif ( $_ =~ s|^((?:\.\./)+)|':' x (length($1)/3)|e ) {
                $_ = ':'. $_;
            } else {
                $_ =~ s|^\./|:|;
            }
        }
        push (@search_dirs, @new_INC);
    } elsif ($options{'-inc'}) {
        push (@search_dirs, @INC);
    }

    # Add location of pod documentation for perl man pages (eg perlfunc)
    # This is a pod directory in the private install tree
    #my $perlpoddir = File::Spec->catdir($Config::Config{'installprivlib'},
    #					'pod');
    #push (@search_dirs, $perlpoddir)
    #  if -d $perlpoddir;

    # Add location of binaries such as pod2text
    push (@search_dirs, $Config::Config{'scriptdir'})
      if -d $Config::Config{'scriptdir'};
  }

  warn "Search path is: ".join(' ', @search_dirs)."\n"
        if $options{'-verbose'};

  # Loop over directories
  Dir: foreach my $dir ( @search_dirs ) {

    # Don't bother if can't find the directory
    if (-d $dir) {
      warn "Looking in directory $dir\n" 
        if $options{'-verbose'};

      # Now concatenate this directory with the pod we are searching for
      my $fullname = File::Spec->catfile($dir, @parts);
      warn "Filename is now $fullname\n"
        if $options{'-verbose'};

      # Loop over possible extensions
      foreach my $ext ('', '.pod', '.pm', '.pl') {
        my $fullext = $fullname . $ext;
        if (-f $fullext && 
         contains_pod($fullext, $options{'-verbose'}) ) {
          warn "FOUND: $fullext\n" if $options{'-verbose'};
          return $fullext;
        }
      }
    } else {
      warn "Directory $dir does not exist\n"
        if $options{'-verbose'};
      next Dir;
    }
    # for some strange reason the path on MacOS/darwin/cygwin is
    # 'pods' not 'pod'
    # this could be the case also for other systems that
    # have a case-tolerant file system, but File::Spec
    # does not recognize 'darwin' yet. And cygwin also has "pods",
    # but is not case tolerant. Oh well...
    if((File::Spec->case_tolerant || $^O =~ /macos|darwin|cygwin/i)
     && -d File::Spec->catdir($dir,'pods')) {
      $dir = File::Spec->catdir($dir,'pods');
      redo Dir;
    }
    if(-d File::Spec->catdir($dir,'pod')) {
      $dir = File::Spec->catdir($dir,'pod');
      redo Dir;
    }
  }
  # No match;
  return undef;
}

=head2 C<contains_pod( $file , $verbose )>

Returns true if the supplied filename (not POD module) contains some pod
information.

=cut

sub contains_pod {
  my $file = shift;
  my $verbose = 0;
  $verbose = shift if @_;

  # check for one line of POD
  unless(open(POD,"<$file")) {
    warn "Error: $file is unreadable: $!\n";
    return undef;
  }
  
  local $/ = undef;
  my $pod = <POD>;
  close(POD) || die "Error closing $file: $!\n";
  unless($pod =~ /\n=(head\d|pod|over|item)\b/s) {
    warn "No POD in $file, skipping.\n"
      if($verbose);
    return 0;
  }

  return 1;
}

=head1 AUTHOR

Please report bugs using L<http://rt.cpan.org>.

Marek Rouchal E<lt>marekr@cpan.orgE<gt>,
heavily borrowing code from Nick Ing-Simmons' PodToHtml.

Tim Jenness E<lt>t.jenness@jach.hawaii.eduE<gt> provided
C<pod_where> and C<contains_pod>.

=head1 SEE ALSO

L<Pod::Parser>, L<Pod::Checker>, L<perldoc>

=cut

1;
Commit	Line	Data
e2c3adef GS	1	#############################################################################
	2	# Pod/Find.pm -- finds files containing POD documentation
	3	#
aaa799f9	4	# Author: Marek Rouchal <marekr@cpan.org>
e2c3adef	5	#
66aff6dd GS	6	# Copyright (C) 1999-2000 by Marek Rouchal (and borrowing code
66aff6dd GS	7	# from Nick Ing-Simmon's PodToHtml). All rights reserved.
e2c3adef GS	8	# This file is part of "PodParser". Pod::Find is free software;
	9	# you can redistribute it and/or modify it under the same terms
	10	# as Perl itself.
	11	#############################################################################
	12
	13	package Pod::Find;
	14
	15	use vars qw($VERSION);
dfc878f2	16	$VERSION = 0.24_01; ## Current version of this package
92e3d63a JH	17	require 5.005; ## requires this Perl version or later
92e3d63a JH	18	use Carp;
e2c3adef GS	19
	20	#############################################################################
	21
	22	=head1 NAME
	23
	24	Pod::Find - find POD documents in directory trees
	25
	26	=head1 SYNOPSIS
	27
	28	use Pod::Find qw(pod_find simplify_name);
	29	my %pods = pod_find({ -verbose => 1, -inc => 1 });
	30	foreach(keys %pods) {
	31	print "found library POD `$pods{$_}' in $_\n";
	32	}
	33
	34	print "podname=",simplify_name('a/b/c/mymodule.pod'),"\n";
	35
92e3d63a JH	36	$location = pod_where( { -inc => 1 }, "Pod::Find" );
92e3d63a JH	37
e2c3adef GS	38	=head1 DESCRIPTION
e2c3adef GS	39
92e3d63a JH	40	B<Pod::Find> provides a set of functions to locate POD files. Note that
	41	no function is exported by default to avoid pollution of your namespace,
	42	so be sure to specify them in the B<use> statement if you need them:
	43
	44	use Pod::Find qw(pod_find);
	45
	46	=cut
	47
	48	use strict;
	49	#use diagnostics;
	50	use Exporter;
	51	use File::Spec;
	52	use File::Find;
	53	use Cwd;
	54
	55	use vars qw(@ISA @EXPORT_OK $VERSION);
	56	@ISA = qw(Exporter);
	57	@EXPORT_OK = qw(&pod_find &simplify_name &pod_where &contains_pod);
	58
	59	# package global variables
	60	my $SIMPLIFY_RX;
	61
	62	=head2 C<pod_find( { %opts } , @directories )>
	63
	64	The function B<pod_find> searches for POD documents in a given set of
	65	files and/or directories. It returns a hash with the file names as keys
	66	and the POD name as value. The POD name is derived from the file name
	67	and its position in the directory tree.
e2c3adef GS	68
	69	E.g. when searching in F<$HOME/perl5lib>, the file
	70	F<$HOME/perl5lib/MyModule.pm> would get the POD name I<MyModule>,
	71	whereas F<$HOME/perl5lib/Myclass/Subclass.pm> would be
	72	I<Myclass::Subclass>. The name information can be used for POD
	73	translators.
	74
	75	Only text files containing at least one valid POD command are found.
	76
	77	A warning is printed if more than one POD file with the same POD name
	78	is found, e.g. F<CPAN.pm> in different directories. This usually
2773b013	79	indicates duplicate occurrences of modules in the I<@INC> search path.
e2c3adef	80
92e3d63a JH	81	B<OPTIONS> The first argument for B<pod_find> may be a hash reference
	82	with options. The rest are either directories that are searched
	83	recursively or files. The POD names of files are the plain basenames
	84	with any Perl-like extension (.pm, .pl, .pod) stripped.
e2c3adef GS	85
	86	=over 4
	87
92e3d63a	88	=item C<-verbose =E<gt> 1>
e2c3adef GS	89
	90	Print progress information while scanning.
	91
92e3d63a	92	=item C<-perl =E<gt> 1>
e2c3adef GS	93
	94	Apply Perl-specific heuristics to find the correct PODs. This includes
	95	stripping Perl-like extensions, omitting subdirectories that are numeric
	96	but do I<not> match the current Perl interpreter's version id, suppressing
	97	F<site_perl> as a module hierarchy name etc.
	98
92e3d63a	99	=item C<-script =E<gt> 1>
e2c3adef GS	100
	101	Search for PODs in the current Perl interpreter's installation
	102	B<scriptdir>. This is taken from the local L<Config\|Config> module.
	103
92e3d63a	104	=item C<-inc =E<gt> 1>
e2c3adef	105
2773b013	106	Search for PODs in the current Perl interpreter's I<@INC> paths. This
92e3d63a JH	107	automatically considers paths specified in the C<PERL5LIB> environment
92e3d63a JH	108	as this is prepended to I<@INC> by the Perl interpreter itself.
e2c3adef GS	109
	110	=back
	111
e2c3adef GS	112	=cut
e2c3adef GS	113
66aff6dd GS	114	# return a hash of the POD files found
	115	# first argument may be a hashref (options),
	116	# rest is a list of directories to search recursively
e2c3adef GS	117	sub pod_find
	118	{
	119	my %opts;
	120	if(ref $_[0]) {
	121	%opts = %{shift()};
	122	}
	123
	124	$opts{-verbose} \|\|= 0;
	125	$opts{-perl} \|\|= 0;
	126
	127	my (@search) = @_;
	128
	129	if($opts{-script}) {
	130	require Config;
dc459aad JH	131	push(@search, $Config::Config{scriptdir})
dc459aad JH	132	if -d $Config::Config{scriptdir};
e2c3adef GS	133	$opts{-perl} = 1;
	134	}
	135
	136	if($opts{-inc}) {
dc459aad JH	137	if ($^O eq 'MacOS') {
	138	# tolerate '.', './some_dir' and '(../)+some_dir' on Mac OS
	139	my @new_INC = @INC;
	140	for (@new_INC) {
	141	if ( $_ eq '.' ) {
	142	$_ = ':';
	143	} elsif ( $_ =~ s\|^((?:\.\./)+)\|':' x (length($1)/3)\|e ) {
	144	$_ = ':'. $_;
	145	} else {
	146	$_ =~ s\|^\./\|:\|;
	147	}
	148	}
	149	push(@search, grep($_ ne File::Spec->curdir, @new_INC));
	150	} else {
	151	push(@search, grep($_ ne File::Spec->curdir, @INC));
	152	}
	153
e2c3adef GS	154	$opts{-perl} = 1;
	155	}
	156
	157	if($opts{-perl}) {
	158	require Config;
	159	# this code simplifies the POD name for Perl modules:
	160	# * remove "site_perl"
2773b013	161	# * remove e.g. "i586-linux" (from 'archname')
e2c3adef GS	162	# * remove e.g. 5.00503
e2c3adef GS	163	# * remove pod/ if followed by *.pod (e.g. in pod/perlfunc.pod)
66aff6dd	164
dc459aad JH	165	# Mac OS:
	166	# * remove ":?site_perl:"
	167	# * remove :?pod: if followed by *.pod (e.g. in :pod:perlfunc.pod)
	168
	169	if ($^O eq 'MacOS') {
	170	$SIMPLIFY_RX =
	171	qq!^(?i:\:?site_perl\:\|\:?pod\:(?=.?\\.pod\\z))!;
	172	} else {
	173	$SIMPLIFY_RX =
	174	qq!^(?i:site(_perl)?/\|\Q$Config::Config{archname}\E/\|\\d+\\.\\d+([_.]?\\d+)?/\|pod/(?=.?\\.pod\\z))!;
	175	}
e2c3adef GS	176	}
	177
	178	my %dirs_visited;
	179	my %pods;
	180	my %names;
	181	my $pwd = cwd();
	182
	183	foreach my $try (@search) {
2773b013 GS	184	unless(File::Spec->file_name_is_absolute($try)) {
	185	# make path absolute
	186	$try = File::Spec->catfile($pwd,$try);
	187	}
	188	# simplify path
16be52b8 PP	189	# on VMS canonpath will vmsify:[the.path], but File::Find::find
	190	# wants /unixy/paths
	191	$try = File::Spec->canonpath($try) if ($^O ne 'VMS');
c4974618	192	$try = VMS::Filespec::unixify($try) if ($^O eq 'VMS');
e2c3adef GS	193	my $name;
	194	if(-f $try) {
	195	if($name = _check_and_extract_name($try, $opts{-verbose})) {
	196	_check_for_duplicates($try, $name, \%names, \%pods);
	197	}
	198	next;
	199	}
dc459aad	200	my $root_rx = $^O eq 'MacOS' ? qq!^\Q$try\E! : qq!^\Q$try\E/!;
e2c3adef	201	File::Find::find( sub {
2773b013 GS	202	my $item = $File::Find::name;
2773b013 GS	203	if(-d) {
dfc878f2 AB	204	if($item =~ m{/(?:RCS\|CVS\|SCCS\|\.svn)$}) {
	205	$File::Find::prune = 1;
	206	return;
	207	}
	208	elsif($dirs_visited{$item}) {
2773b013 GS	209	warn "Directory '$item' already seen, skipping.\n"
	210	if($opts{-verbose});
	211	$File::Find::prune = 1;
	212	return;
	213	}
	214	else {
	215	$dirs_visited{$item} = 1;
	216	}
	217	if($opts{-perl} && /^(\d+\.[\d_]+)\z/s && eval "$1" != $]) {
e2c3adef GS	218	$File::Find::prune = 1;
e2c3adef GS	219	warn "Perl $] version mismatch on $_, skipping.\n"
2773b013 GS	220	if($opts{-verbose});
	221	}
	222	return;
	223	}
e2c3adef GS	224	if($name = _check_and_extract_name($item, $opts{-verbose}, $root_rx)) {
	225	_check_for_duplicates($item, $name, \%names, \%pods);
	226	}
2773b013	227	}, $try); # end of File::Find::find
e2c3adef GS	228	}
	229	chdir $pwd;
	230	%pods;
	231	}
	232
	233	sub _check_for_duplicates {
	234	my ($file, $name, $names_ref, $pods_ref) = @_;
	235	if($$names_ref{$name}) {
	236	warn "Duplicate POD found (shadowing?): $name ($file)\n";
2773b013 GS	237	warn " Already seen in ",
2773b013 GS	238	join(' ', grep($$pods_ref{$_} eq $name, keys %$pods_ref)),"\n";
e2c3adef GS	239	}
	240	else {
	241	$$names_ref{$name} = 1;
	242	}
	243	$$pods_ref{$file} = $name;
	244	}
	245
	246	sub _check_and_extract_name {
	247	my ($file, $verbose, $root_rx) = @_;
	248
2773b013 GS	249	# check extension or executable flag
2773b013 GS	250	# this involves testing the .bat extension on Win32!
92e3d63a JH	251	unless(-f $file && -T _ && ($file =~ /\.(pod\|pm\|plx?)\z/i \|\| -x _ )) {
92e3d63a JH	252	return undef;
e2c3adef GS	253	}
e2c3adef GS	254
92e3d63a	255	return undef unless contains_pod($file,$verbose);
e2c3adef GS	256
e2c3adef GS	257	# strip non-significant path components
92e3d63a	258	# TODO what happens on e.g. Win32?
e2c3adef GS	259	my $name = $file;
e2c3adef GS	260	if(defined $root_rx) {
fe6f1558 GS	261	$name =~ s!$root_rx!!s;
fe6f1558 GS	262	$name =~ s!$SIMPLIFY_RX!!os if(defined $SIMPLIFY_RX);
e2c3adef GS	263	}
e2c3adef GS	264	else {
dc459aad JH	265	if ($^O eq 'MacOS') {
	266	$name =~ s/^.*://s;
	267	} else {
	268	$name =~ s:^.*/::s;
	269	}
e2c3adef	270	}
2773b013 GS	271	_simplify($name);
2773b013 GS	272	$name =~ s!/+!::!g; #/
dc459aad JH	273	if ($^O eq 'MacOS') {
	274	$name =~ s!:+!::!g; # : -> ::
	275	} else {
	276	$name =~ s!/+!::!g; # / -> ::
	277	}
e2c3adef GS	278	$name;
	279	}
	280
92e3d63a JH	281	=head2 C<simplify_name( $str )>
	282
	283	The function B<simplify_name> is equivalent to B<basename>, but also
	284	strips Perl-like extensions (.pm, .pl, .pod) and extensions like
2eec1a1e	285	F<.bat>, F<.cmd> on Win32 and OS/2, or F<.com> on VMS, respectively.
92e3d63a JH	286
	287	=cut
	288
e2c3adef GS	289	# basic simplification of the POD name:
	290	# basename & strip extension
	291	sub simplify_name {
	292	my ($str) = @_;
2773b013	293	# remove all path components
dc459aad JH	294	if ($^O eq 'MacOS') {
	295	$str =~ s/^.*://s;
	296	} else {
	297	$str =~ s:^.*/::s;
	298	}
2773b013	299	_simplify($str);
e2c3adef GS	300	$str;
	301	}
	302
2773b013 GS	303	# internal sub only
	304	sub _simplify {
	305	# strip Perl's own extensions
	306	$_[0] =~ s/\.(pod\|pm\|plx?)\z//i;
	307	# strip meaningless extensions on Win32 and OS/2
dbd1b0a2	308	$_[0] =~ s/\.(bat\|exe\|cmd)\z//i if($^O =~ /mswin\|os2/i);
2eec1a1e PP	309	# strip meaningless extensions on VMS
2eec1a1e PP	310	$_[0] =~ s/\.(com)\z//i if($^O eq 'VMS');
2773b013 GS	311	}
2773b013 GS	312
92e3d63a JH	313	# contribution from Tim Jenness <t.jenness@jach.hawaii.edu>
	314
	315	=head2 C<pod_where( { %opts }, $pod )>
	316
	317	Returns the location of a pod document given a search directory
	318	and a module (e.g. C<File::Find>) or script (e.g. C<perldoc>) name.
	319
	320	Options:
	321
	322	=over 4
	323
	324	=item C<-inc =E<gt> 1>
	325
	326	Search @INC for the pod and also the C<scriptdir> defined in the
	327	L<Config\|Config> module.
	328
	329	=item C<-dirs =E<gt> [ $dir1, $dir2, ... ]>
	330
	331	Reference to an array of search directories. These are searched in order
	332	before looking in C<@INC> (if B<-inc>). Current directory is used if
	333	none are specified.
	334
	335	=item C<-verbose =E<gt> 1>
	336
	337	List directories as they are searched
	338
	339	=back
	340
fb8eeed8	341	Returns the full path of the first occurrence to the file.
92e3d63a JH	342	Package names (eg 'A::B') are automatically converted to directory
	343	names in the selected directory. (eg on unix 'A::B' is converted to
	344	'A/B'). Additionally, '.pm', '.pl' and '.pod' are appended to the
	345	search automatically if required.
	346
	347	A subdirectory F<pod/> is also checked if it exists in any of the given
	348	search directories. This ensures that e.g. L<perlfunc\|perlfunc> is
	349	found.
	350
	351	It is assumed that if a module name is supplied, that that name
	352	matches the file name. Pods are not opened to check for the 'NAME'
	353	entry.
	354
	355	A check is made to make sure that the file that is found does
	356	contain some pod documentation.
	357
	358	=cut
	359
	360	sub pod_where {
	361
	362	# default options
	363	my %options = (
	364	'-inc' => 0,
	365	'-verbose' => 0,
dc459aad	366	'-dirs' => [ File::Spec->curdir ],
92e3d63a JH	367	);
	368
	369	# Check for an options hash as first argument
	370	if (defined $_[0] && ref($_[0]) eq 'HASH') {
	371	my $opt = shift;
	372
	373	# Merge default options with supplied options
	374	%options = (%options, %$opt);
	375	}
	376
	377	# Check usage
	378	carp 'Usage: pod_where({options}, $pod)' unless (scalar(@_));
	379
	380	# Read argument
	381	my $pod = shift;
	382
	383	# Split on :: and then join the name together using File::Spec
	384	my @parts = split (/::/, $pod);
	385
	386	# Get full directory list
	387	my @search_dirs = @{ $options{'-dirs'} };
	388
	389	if ($options{'-inc'}) {
	390
	391	require Config;
	392
	393	# Add @INC
dc459aad JH	394	if ($^O eq 'MacOS' && $options{'-inc'}) {
	395	# tolerate '.', './some_dir' and '(../)+some_dir' on Mac OS
	396	my @new_INC = @INC;
	397	for (@new_INC) {
	398	if ( $_ eq '.' ) {
	399	$_ = ':';
	400	} elsif ( $_ =~ s\|^((?:\.\./)+)\|':' x (length($1)/3)\|e ) {
	401	$_ = ':'. $_;
	402	} else {
	403	$_ =~ s\|^\./\|:\|;
	404	}
	405	}
	406	push (@search_dirs, @new_INC);
	407	} elsif ($options{'-inc'}) {
	408	push (@search_dirs, @INC);
	409	}
92e3d63a JH	410
	411	# Add location of pod documentation for perl man pages (eg perlfunc)
	412	# This is a pod directory in the private install tree
	413	#my $perlpoddir = File::Spec->catdir($Config::Config{'installprivlib'},
	414	# 'pod');
	415	#push (@search_dirs, $perlpoddir)
	416	# if -d $perlpoddir;
	417
	418	# Add location of binaries such as pod2text
	419	push (@search_dirs, $Config::Config{'scriptdir'})
	420	if -d $Config::Config{'scriptdir'};
	421	}
	422
2dd58eb2 JH	423	warn "Search path is: ".join(' ', @search_dirs)."\n"
	424	if $options{'-verbose'};
	425
92e3d63a JH	426	# Loop over directories
	427	Dir: foreach my $dir ( @search_dirs ) {
	428
dc459aad	429	# Don't bother if can't find the directory
92e3d63a JH	430	if (-d $dir) {
	431	warn "Looking in directory $dir\n"
	432	if $options{'-verbose'};
	433
	434	# Now concatenate this directory with the pod we are searching for
	435	my $fullname = File::Spec->catfile($dir, @parts);
	436	warn "Filename is now $fullname\n"
	437	if $options{'-verbose'};
	438
	439	# Loop over possible extensions
	440	foreach my $ext ('', '.pod', '.pm', '.pl') {
	441	my $fullext = $fullname . $ext;
	442	if (-f $fullext &&
	443	contains_pod($fullext, $options{'-verbose'}) ) {
	444	warn "FOUND: $fullext\n" if $options{'-verbose'};
	445	return $fullext;
	446	}
	447	}
	448	} else {
	449	warn "Directory $dir does not exist\n"
	450	if $options{'-verbose'};
	451	next Dir;
	452	}
c23d1eb0	453	# for some strange reason the path on MacOS/darwin/cygwin is
2dd58eb2 JH	454	# 'pods' not 'pod'
	455	# this could be the case also for other systems that
	456	# have a case-tolerant file system, but File::Spec
c23d1eb0 MR	457	# does not recognize 'darwin' yet. And cygwin also has "pods",
	458	# but is not case tolerant. Oh well...
	459	if((File::Spec->case_tolerant \|\| $^O =~ /macos\|darwin\|cygwin/i)
	460	&& -d File::Spec->catdir($dir,'pods')) {
2dd58eb2 JH	461	$dir = File::Spec->catdir($dir,'pods');
	462	redo Dir;
	463	}
92e3d63a JH	464	if(-d File::Spec->catdir($dir,'pod')) {
	465	$dir = File::Spec->catdir($dir,'pod');
	466	redo Dir;
	467	}
	468	}
	469	# No match;
	470	return undef;
	471	}
	472
	473	=head2 C<contains_pod( $file , $verbose )>
	474
	475	Returns true if the supplied filename (not POD module) contains some pod
	476	information.
	477
	478	=cut
	479
	480	sub contains_pod {
	481	my $file = shift;
	482	my $verbose = 0;
	483	$verbose = shift if @_;
	484
	485	# check for one line of POD
	486	unless(open(POD,"<$file")) {
	487	warn "Error: $file is unreadable: $!\n";
	488	return undef;
	489	}
	490
	491	local $/ = undef;
	492	my $pod = <POD>;
	493	close(POD) \|\| die "Error closing $file: $!\n";
	494	unless($pod =~ /\n=(head\d\|pod\|over\|item)\b/s) {
	495	warn "No POD in $file, skipping.\n"
	496	if($verbose);
	497	return 0;
	498	}
	499
	500	return 1;
	501	}
	502
	503	=head1 AUTHOR
	504
aaa799f9 NC	505	Please report bugs using L<http://rt.cpan.org>.
	506
	507	Marek Rouchal E<lt>marekr@cpan.orgE<gt>,
92e3d63a JH	508	heavily borrowing code from Nick Ing-Simmons' PodToHtml.
	509
	510	Tim Jenness E<lt>t.jenness@jach.hawaii.eduE<gt> provided
	511	C<pod_where> and C<contains_pod>.
	512
	513	=head1 SEE ALSO
	514
	515	L<Pod::Parser>, L<Pod::Checker>, L<perldoc>
	516
	517	=cut
	518
e2c3adef GS	519	1;
e2c3adef GS	520