libtk-pod-perl 0.9942-1 / usr / share / perl5 / Tk / Pod / FindPods.pm

# -*- perl -*-

#
# Author: Slaven Rezic
#
# Copyright (C) 2001,2003,2004,2005,2007,2009,2012 Slaven Rezic. All rights reserved.
# This package is free software; you can redistribute it and/or modify
# it under the same terms as Perl itself.
#
# Mail: slaven@rezic.de
# WWW:  http://www.rezic.de/eserte/
#

package Tk::Pod::FindPods;

=head1 NAME

Tk::Pod::FindPods - find Pods installed on the current system


=head1 SYNOPSIS

    use Tk::Pod::FindPods;

    my $o = Tk::Pod::FindPods->new;
    $pods = $o->pod_find(-categorized => 1, -usecache => 1);

=head1 DESCRIPTION

=cut

use base 'Exporter';
use strict;
use vars qw($VERSION @EXPORT_OK $init_done %arch $arch_re);

@EXPORT_OK = qw/%pods $has_cache pod_find/;

$VERSION = '5.16';

BEGIN {  # Make a DEBUG constant very first thing...
  if(defined &DEBUG) {
  } elsif(($ENV{'TKPODDEBUG'} || '') =~ m/^(\d+)/) { # untaint
    my $debug = $1;
    *DEBUG = sub () { $debug };
  } else {
    *DEBUG = sub () {0};
  }
}

use File::Find;
use File::Spec;
use File::Basename;
use Config;

sub new {
    my($class) = @_;
    my $self = bless {}, $class;
    $self->init;
    $self;
}

sub init {
    return if $init_done;
    %arch = guess_architectures();
    $arch_re = "(" . join("|", map { quotemeta $_ } ("mach", keys %arch)) . ")";
    $init_done++;
}

=head2 pod_find

The B<pod_find> method scans the current system for available Pod
documentation. The keys of the returned hash reference are the names
of the modules or Pods (C<::> substituted by C</> --- this makes it
easier for Tk::Pod::Tree, as the separator may only be of one
character). The values are the corresponding filenames.

If C<-categorized> is specified, then the returned hash has an extra
level with four categories: B<perl> (for core language documentation),
B<pragma> (for pragma documentation like L<var|var> or
L<strict|strict>), B<mod> (core or CPAN modules), and B<script> (perl
scripts with embedded Pod documentation). Otherwise, C<-category> may
be set to force the Pods into a category.

By default, C<@INC> is scanned for Pods. This can be overwritten by
the C<-directories> option (specify as an array reference).

If C<-usecache> is specified, then the list of Pods is cached (see
L<cache directory|/Cache directory>). C<-usecache> is disabled if
C<-categorized> is not set or C<-directories> is set.

=cut

sub pod_find {
    my $self = shift;
    my(@args) = @_;
    my %args;
    if (ref $args[0] eq 'HASH') {
	%args = %{ $args[0] };
    } else {
	%args = @args;
    }

    $self->{has_cache} = 0;

    if ($args{-usecache}) {
	if (!$args{-categorized} || $args{-directories}) {
	    DEBUG and warn "Disabling -usecache";
	} else {
	    my $perllocal_site = File::Spec->catfile($Config{'installsitearch'},'perllocal.pod');
	    my $perllocal_lib  = File::Spec->catfile($Config{'installarchlib'},'perllocal.pod');
	    my $cache_file = _cache_file();
	VALIDATE_CACHE: {
		if (!-r $cache_file) {
		    DEBUG and warn "Cache file $cache_file does not exist or is not readable\n";
		    last VALIDATE_CACHE;
		}
		if (-e $perllocal_site && -M $perllocal_site < -M $cache_file) {
		    DEBUG and warn "$perllocal_site is more recent than cache file $cache_file\n";
		    last VALIDATE_CACHE;
		}
		if (-e $perllocal_lib  && -M $perllocal_lib < -M $cache_file) {
		    DEBUG and warn "$perllocal_lib is more recent than cache file $cache_file\n";
		    last VALIDATE_CACHE;
		}

		$self->LoadCache;
		if ($self->{pods}) {
		    $self->{has_cache} = 1;
		    return $self->{pods};
		}
	    }
	}
    }

    my(@dirs, @script_dirs);
    if ($args{-directories}) {
	@dirs = @{ $args{-directories} };
	@script_dirs = ();
    } else {
	@dirs = sort { length($b) <=> length($a) } grep { $_ ne '.' } @INC; # ignore current directory
	@script_dirs = ($Config{'scriptdir'});
    }

    my %seen_dir = ();
    my $curr_dir;
    undef $curr_dir;
    my %pods = ();

    if ($args{-category}) {
	$pods{$args{-category}} = {};
    }

    my $duplicate_warning_header_seen = 0;

    # Assume $_ and $File::Find::name are set
    my $ignore_directory = sub {
	return 1 if m{^(RCS|CVS|\.svn|\.git|blib)$};
    };

    my $wanted = sub {
	if (-d) {
	    if ($ignore_directory->()) {
		$File::Find::prune = 1;
		return;
	    } elsif ($seen_dir{$File::Find::name}) {
		$File::Find::prune = 1;
		return;
	    } else {
		$seen_dir{$File::Find::name}++;
	    }
	}

	if (-f && /\.(pod|pm)$/) {
	    my $curr_dir_rx = quotemeta $curr_dir;
	    (my $name = $File::Find::name) =~ s|^$curr_dir_rx/?||;
	    $name = simplify_name($name);

	    my $hash;
	    if ($args{-categorized}) {
		my $type = type($name);
		$hash = $pods{$type} || do { $pods{$type} = {} };
	    } elsif ($args{-category}) {
		$hash = $pods{$args{-category}};
	    } else {
		$hash = \%pods;
	    }

	    if (exists $hash->{$name}) {
		if ($hash->{$name} =~ /\.pod$/ && $File::Find::name =~ /\.pm$/) {
		    return;
		}
		my($ext1) = $hash->{$name}    =~ /\.(.*)$/;
		my($ext2) = $File::Find::name =~ /\.(.*)$/;
		if ($ext1 eq $ext2) {
		    (my $modname = $name) =~ s{/}{::}g;
		    if (!$duplicate_warning_header_seen) {
			$duplicate_warning_header_seen = 1;
			warn "*** Pod(s) with same name at different locations found: ***\n";
		    }
		    (my $hash_name_without_scheme = $hash->{$name}) =~ s{^file:}{};
		    warn "  $modname:\n    $hash_name_without_scheme\n    $File::Find::name\n";
		    return;
		}
	    }
	    $hash->{$name} = "file:" . $File::Find::name;
	}
    };

    my $wanted_scripts = sub {
	if (-d) {
	    if ($ignore_directory->()) {
		$File::Find::prune = 1;
		return;
	    } elsif ($seen_dir{$File::Find::name}) {
		$File::Find::prune = 1;
		return;
	    } else {
		$seen_dir{$File::Find::name}++;
	    }
	}

	if (-T && open(SCRIPT, $_)) {
	    my $has_pod = 0;
	    {
		local $_;
		while(<SCRIPT>) {
		    if (/^=(head\d+|pod)/) {
			$has_pod = 1;
			last;
		    }
		}
	    }
	    close SCRIPT;
	    if ($has_pod) {
		my $name = $_;

		my $hash;
		if ($args{-categorized}) {
		    my $type = 'script';
		    $hash = $pods{$type} || do { $pods{$type} = {} };
		} elsif ($args{-category}) {
		    $hash = $pods{$args{-category}};
		} else {
		    $hash = \%pods;
		}

		if (exists $hash->{$name}) {
		    return;
		}
		$hash->{$name} = "file:" . $File::Find::name;
	    }
	}
    };

    my %opts;
    if ($^O ne "MSWin32") {
	$opts{follow}      = 1;
	$opts{follow_skip} = 2;
    }

    foreach my $inc (reverse @dirs) {
	next unless -d $inc;
	$curr_dir = $inc;
	find({ %opts, wanted => $wanted }, $inc);
    }

    foreach my $inc (reverse @script_dirs) {
	find({ %opts, wanted => $wanted_scripts }, $inc);
    }

    if ($duplicate_warning_header_seen) {
	warn "*** This was the list of Pod(s) with same name at different locations. ***\n";
    }

    $self->{pods} = \%pods;
    $self->{pods};
}

sub simplify_name {
    my $f = shift;
    $f =~ s|^\d+\.\d+\.\d+/?||; # strip perl version
    $f =~ s|^$arch_re/|| if defined $arch_re; # strip machine
    $f =~ s/\.(pod|pm)$//;
    $f =~ s|^pod/||;
    # Workaround for case insensitive systems --- the pod directory contains
    # general pod documentation as well as Pod::* documentation:
    if ($^O =~ /^cygwin/) {
	$f =~ s|^pods/||; # "pod" is "pods" on cygwin
    } elsif ($^O =~ /^darwin/) {
	$f =~ s|^pods/||; # ... and on MacOSX
    } elsif ($^O eq 'MSWin32') {
	# oldstyle:
	$f =~ s|^pod/perl|perl|i;
	$f =~ s|^pod/Win32|Win32|i;
	# newstyle:
	$f =~ s|^pods/||;
    }
    $f;
}

sub type {
    local $_ = shift;
    if    (/^(?:perl|activeperl)/) { return "perl" }
    elsif (/^a2p$/) { return "script" }
    elsif (/^[a-z]/ && !/^(mod_perl|lwpcook|lwptut|cgi_to_mod_perl|libapreq)/)
	            { return "pragma" }
    else            { return "mod" }
}

# It's not possible to just use $Config{archname} --- it is necessary
# to get the names of all the installated archnames. This may be
# something like i386-freebsd vs. i386-freebsd-64int.
sub guess_architectures {
    my %arch;
    my @configs;
    foreach my $inc (@INC) {
	next unless -d $inc;
	if (!opendir(DIR, $inc)) {
	    warn "Can't opendir $inc: $!";
	    next;
	}
	while(defined(my $base = readdir DIR)) {
	    # Skip . and .., and some obviously wrong directories
	    # containing a Config.pm file. This is not strictly necessary,
	    # but so we avoid to scan the file itself.
	    next if $base =~ /^(\.|\.\.|CPANPLUS|Encode|Prima|Tk|PDL|Template|Net|App)$/;
	    next if !-d File::Spec->catdir($inc, $base);
	    my $cfgpm = File::Spec->catfile($inc, $base, "Config.pm");
	    if (-r $cfgpm) {
		push @configs, $cfgpm;
	    }
	}
	closedir DIR;
    }

    # Scan the Config.pm file to see if it's really a perl Config.pm
    # file.
    foreach my $config (@configs) {
	my($arch) = $config =~ m|[\\/]([^/\\]+)[\\/]Config.pm|;
	if (open(CFG, $config)) {
	    while(<CFG>) {
		/archname.*$arch/ && do {
		    $arch{$arch}++;
		    last;
		};
	    }
	    close CFG;
	} else {
	    warn "cannot open $config: $!";
	}
    }
    %arch;
}

sub module_location {
    my $mod = shift;
    my($type, $path) = $mod =~ /^([^:]+):(.*)/;
    if ($type eq 'cpan') {
	'cpan';
    } elsif (is_site_module($path)) {
	'site';
    } elsif (is_vendor_module($path)) {
	'vendor';
    } else {
	'core';
    }
}

sub is_site_module {
    my $path = shift;
    if ($^O eq 'MSWin32') {
	return $path =~ m|[/\\]site[/\\]lib[/\\]|;
    }
    $path =~ /^(
                \Q$Config{'installsitelib'}\E
               |
		\Q$Config{'installsitearch'}\E
	       )/x;
}

sub is_vendor_module {
    my $path = shift;
    return 0 if (!defined $Config{'installvendorlib'}  ||
		 $Config{'installvendorlib'}  eq ''    ||
		 !defined $Config{'installvendorarch'} ||
		 $Config{'installvendorarch'} eq ''
		);
    $path =~ /^(
                \Q$Config{'installvendorlib'}\E
               |
		\Q$Config{'installvendorarch'}\E
	       )/x;
}

sub _cache_file {
    (my $ver = $])                  =~ s/[^a-z0-9]/_/gi;
    (my $os  = $Config{'archname'}) =~ s/[^a-z0-9]/_/gi;
    my $uid  = $<;

    my $cache_file_pattern = $ENV{TKPODCACHE};
    if (!defined $cache_file_pattern) {
	my $cache_root;
	if ($^O =~ m{^(darwin|MSWin32)} && eval { require File::HomeDir; 1 }) {
	    $cache_root = File::Spec->catfile(File::HomeDir->my_data, ".tkpod_cache");
	} elsif ($ENV{HOME} && -d $ENV{HOME}) {
	    $cache_root = "$ENV{HOME}/.tkpod_cache";
	} else {
	    $cache_root = File::Spec->can('tmpdir') ? File::Spec->tmpdir : $ENV{TMPDIR}||"/tmp";
	}
	$cache_file_pattern = File::Spec->catfile
	    ($cache_root,
	     join('_', 'pods',"%v","%o","%u")
	    );
    }
    $cache_file_pattern =~ s/%v/$ver/g;
    $cache_file_pattern =~ s/%o/$os/g;
    $cache_file_pattern =~ s/%u/$uid/g;
    $cache_file_pattern;
}

sub pods      { shift->{pods} }
sub has_cache { shift->{has_cache} }

# Parts stolen from Pod::Perldoc::search_perlfunc
# Return pod text for given function
sub function_pod {
    my($self, $func) = @_;

    my $pod = "";

    my $perlfunc = $self->{pods}{perl}{perlfunc};
    $perlfunc =~ s{^file:}{};
    open(PFUNC, "< $perlfunc") or die "Can't open $perlfunc: $!";

    # Functions like -r, -e, etc. are listed under `-X'.
    my $search_re = ($func =~ /^-[rwxoRWXOeszfdlpSbctugkTBMAC]$/)
                        ? '(?:I<)?-X' : quotemeta($func) ;

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

    # Look for our function
    my $found = 0;
    my $inlist = 0;
    while (<PFUNC>) {  # "The Mothership Connection is here!"
        if ( m/^=item\s+$search_re\W/ )  {
            $found = 1;
        }
        elsif (/^=item/) {
            last if $found > 1 and not $inlist;
        }
        next unless $found;
        if (/^=over/) {
            ++$inlist;
        }
        elsif (/^=back/) {
            --$inlist;
        }
        $pod .= $_;
        ++$found if /^\w/;        # found descriptive text
    }
    if ($pod eq "") {
        warn sprintf "No documentation for perl function `%s' found\n", $func;
    } else {
	# Fix pod so no warnings are given:
	$pod = "=over\n\n$pod\n\n=back\n";
    }
    close PFUNC                or die "Can't open $perlfunc: $!";

    return $pod;
}

=head2 WriteCache

Write the Pod cache. The cache is written to the L<cache
directory|/Cache directory>. The file name is constructed from the
perl version, operation system and user id.

=cut

sub WriteCache {
    my $self = shift;

    require Data::Dumper;

    my $cache_dir = dirname _cache_file();
    if (!-d $cache_dir) {
	mkdir $cache_dir, 0777
	    or do {
		warn "Can't create cache directory $cache_dir: $!";
		return;
	    };
    }
    if (!open(CACHE, ">" . _cache_file())) {
	warn "Can't write to cache file " . _cache_file() . ": $!";
	return;
    }

    my $dd = Data::Dumper->new([$self->{pods}], ['pods']);
    $dd->Indent(0);
    print CACHE $dd->Dump;
    close CACHE;
}

=head2 LoadCache()

Load the Pod cache, if possible.

=cut

sub LoadCache {
    my $self = shift;
    my $cache_file = _cache_file();
    if (-r $cache_file) {
	return if $< != (stat($cache_file))[4];
	require Safe;
	my $c = Safe->new('Tk::Pod::FindPods::SAFE');
	$c->rdo($cache_file);
	if (keys %$Tk::Pod::FindPods::SAFE::pods) {
	    $self->{pods} = { %$Tk::Pod::FindPods::SAFE::pods };
	    return $self->{pods};
	}
    }
    return {};
}

return 1 if caller;

package main;

require Data::Dumper;
print Data::Dumper->Dumpxs([Tk::Pod::FindPods->new->pod_find(-categorized => 0, -usecache => 0)],[]);

__END__

=head2 Cache directory

By default the cache file is written to the directory
F<~/.tkpod_cache> (Unix systems), or the data directory as determined
by L<File::HomeDir> (Windows, MacOSX). If everything fails, then the
temporary directory (F</tmp> or the OS equivalent) is used.

If necessary, then the last path component will be created (that is,
F<.tkpod_cache> will be created if the directory does not exist).

To use another cache directory set the environment variable
L</TKPODCACHE>.

=head1 ENVIRONMENT

=over

=item TKPODCACHE

Use a custom cache file instead of a file in the L<cache directory|/Cache directory>.
The following placeholders are recognized:

=over

=item %v

The perl version.

=item %o

The OS (technically correct: the archname, which can include tokens
like "64int" or "thread").

=item %u

The user id.

=back

Example for using F</some/other/directory> for the cache file location:

	TKPODCACHE=/some/other/directory/pods_%v_%o_%u; export TKPODCACHE

or

	setenv TKPODCACHE /some/other/directory/pods_%v_%o_%u

depending on your shell (sh-like or csh-like).

=back

=head1 SEE ALSO

L<Tk::Tree>.

=head1 AUTHOR

Slaven ReziE<0x0107> <F<slaven@rezic.de>>

Copyright (c) 2001,2003,2004,2005,2007,2009 Slaven ReziE<0x0107>. All rights reserved.
This program is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.

=cut