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

Tk-Pod documentation Contained in the Tk-Pod distribution.

Index

Code Index:

NAME

Top

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

SYNOPSIS

Top

    use Tk::Pod::FindPods;

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

DESCRIPTION

Top

pod_find

The 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 (:: substituted by / --- this makes it easier for Tk::Pod::Tree, as the separator may only be of one character). The values are the corresponding filenames.

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

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

If -usecache is specified, then the list of Pods is cached in a temporary directory. -usecache is disabled if -categorized is not set or -directories is set.

WriteCache

Write the Pod cache. The cache is written to the temporary directory. The file name is constructed from the perl version, operation system and user id.

LoadCache()

Load the Pod cache, if possible.

ENVIRONMENT

Top

TKPODCACHE

Path for the cache file. By default, the cache file is written to the temporary directory (/tmp or the OS equivalent). The following placeholders are recognized:

%v

The perl version.

%o

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

%u

The user id.

Example for using /var/tmp instead of /tmp for the cache file location (on many systems /var/tmp is persistent, unlike /tmp):

	setenv TKPODCACHE /var/tmp/pods_%v_%o_%u

or

	TKPODCACHE=/var/tmp/pods_%v_%o_%u; export TKPODCACHE

depending on your shell.

SEE ALSO

Top

Tk::Tree.

AUTHOR

Top

Slaven Reziæ <slaven@rezic.de>

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

Tk-Pod documentation Contained in the Tk-Pod distribution. 
# -*- perl -*-

#
# $Id: FindPods.pm,v 5.11 2008/02/03 16:10:51 eserte Exp $
# Author: Slaven Rezic
#
# Copyright (C) 2001,2003,2004,2005,2007 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;


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 = sprintf("%d.%02d", q$Revision: 5.11 $ =~ /(\d+)\.(\d+)/);

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++;
}


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();
	    if (-r $cache_file &&
		(-e $perllocal_site && -M $perllocal_site > -M $cache_file) &&
		(-e $perllocal_lib  && -M $perllocal_lib > -M $cache_file)
	       ) {
		$self->LoadCache;
		if ($self->{pods}) {
		    $self->{has_cache} = 1;
		    return $self->{pods};
		}
	    } else {
		DEBUG and warn "$perllocal_site and/or $perllocal_lib are more recent than cache file $cache_file or cache file does not exist\n";
	    }
	}
    }

    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;

    my $wanted = sub {
	if (-d) {
	    if ($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 ($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) {
	$cache_file_pattern = File::Spec->catfile
	    (File::Spec->can('tmpdir') ? File::Spec->tmpdir : $ENV{TMPDIR}||"/tmp",
	     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;
}


sub WriteCache {
    my $self = shift;

    require Data::Dumper;

    if (!open(CACHE, ">" . _cache_file())) {
	warn "Can't write to cache file " . _cache_file();
    } else {
	my $dd = Data::Dumper->new([$self->{pods}], ['pods']);
	$dd->Indent(0);
	print CACHE $dd->Dump;
	close CACHE;
    }
}


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__