progmod example: PM::Tools::podpath

What this is a suite of programs and modules that provide essential
services related to pod in general and to the perl documentation.
Some of them are very low-level, others are high-level.  There's a    
lot less code here than meets the eye, since as occurs often in
Python, the modules are designed to be standalone programs as well!
In fact, this module is many programs.

I'm still unclear on the naming.  Maybe it should be "PM_Tools" or
something.  See the next message (and the previous one) for better
documentation.

--tom


#!/usr/bin/perl
#
# podpath - find path to perl documentation
# Tom Christiansen, tchrist@perl.com
#
# It's simultaneously a program, a manpage, *and* a module.

package PM::Tools::podpath;

use strict;
use warnings;

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

our $Am_Standalone = !caller;

exit main(@ARGV) if $Am_Standalone;

require Exporter;
our @ISA = qw/Exporter/;
our @EXPORT = qw(podpath);  # only my own name as default
our @EXPORT_OK = qw(
    docpath 
    gotpod 
    mandirs 
    pmanpath 
    pmpodpath 
    pod2manpath 
    podlibdir 
    podpath 
    progpodpath 
    stdpodpath 
);

our %EXPORT_TAGS = ( 
    all => [ @EXPORT, @EXPORT_OK ],
    man => [ qw(mandir pmanpath) ],
);

# podpath := stdpodpath || pmpodpath || progpodpath;
# docpath := pod2manpath || podpath

# stdpodpath("perlfunc") => /usr/local/perl/lib/pod/perlfunc.pod
# pmpodpath("CGI") => /usr/local/perl/lib/CGI.pm
# pmpodpath("POSIX") => /usr/local/lib/perl5/5.6.0/OpenBSD.i386-openbsd/POSIX.pod
# progpodpath("perlbug") => /usr/local/perl/bin/perlbug

# pod2manpath("perlfunc") => /usr/local/man/man1/perlfunc.1
# pod2manpath("CGI") => /usr/local/perl/man/man3/CGI.3

sub mkpath {
    return File::Spec->join(@_);
} 

sub binpath {
    die "don't call me in scalar context" unless wantarray;
    my @dirs = File::Spec->path();
    return @dirs;
} 

sub podlibdir {
    my $path = mkpath($Config{privlib}, "pod");
    die "no pod lib dir in $path" unless -d $path;
    return $path;
} 

sub docpath {
    return allpaths($_[0], \( &pod2manpath, &podpath));
}

sub podpath {
    return allpaths($_[0], \( &stdpodpath, &pmpodpath, &progpodpath));
}

sub allpaths {
    my ($page, @funcs) = @_;

    if (wantarray) {
	return map { $_->($page) } @funcs;
    } 
    else {
	my $resolve;
	for my $fn (@funcs) { 
	    ($resolve = $fn->($page)) && return $resolve;
	}
	return undef;
    } 
} 

sub stdpodpath {
    my $page = $_[0];
    my $path = mkpath(podlibdir(), $page);
    $path .= ".pod" unless $path =~ /\.pod\z/;
    return unless -f $path;
    return $path;
} 

sub pmpodpath {
    my $module = $_[0];
    my @paths = ();
    $module =~ s/\.p(od|m)\z//;
    $module = mkpath(split /::/, $module) if $module =~ /::/;
    for my $dir (@INC) { 
	for my $ext (qw/pod pm/) {
            my $pathname = mkpath($dir, $module . ".$ext");
	    next unless -f $pathname;
	    return $pathname if !wantarray;
	    push @paths, $pathname;
	} 
    }

    # the !wantarray success case is taken care of already
    return wantarray ? @paths : undef;  
} 

# this is controversial: looks for *programs*!!?!?!
sub progpodpath { 
    my $proggie = $_[0];
    my @paths = ();

    for my $dir (binpath()) {
        my $pathname = mkpath($dir, $proggie);
	next unless -f $pathname && -x _ && -r _ && 
		    -T $pathname && gotpod($pathname);

	return $pathname if !wantarray;
	push @paths, $pathname;
    } 
    # the !wantarray success case is taken care of already
    return wantarray ? @paths : undef;  

}

sub gotpod {
    my $file = $_[0];
    local *TESTPOD;
    # XXX: dies!
    open(TESTPOD, "<", $file) || die "can't read $file: $!";
    local($_, $/) = ('', '');
    my $gotpod = 0;
    while (<TESTPOD>) {
        if (/^=\w/) {
            $gotpod = 1;
            last;
        } 
    } 
    close TESTPOD || die "can't close $file: $!";
    return $gotpod;
} 

sub mandirs {
    my %seen = ();
    my @paths = ();
    for my $dir (map { @Config{ "installman${_}dir", 
				"man${_}dir", 
				"siteman${_}" 	    }
			      } (1,3) )
    {
	push @paths,$dir if length($dir) && !$seen{$dir}++ && -d $dir;
    } 
    return @paths;
} 

sub pmanpath {
    my %seen;
    return join ":" => grep {!$seen{$_}++} 
		        map { dirname($_) } mandirs();
} 

sub pod2manpath {
    my $page = $_[0];
    my @paths = ();

EXT: for my $ext (1, 3) {  # XXX: magicnos!
MANDIR: for my $mandir (grep { index($_, $ext) >= 0 } mandirs()) { 
            my $pathname = mkpath($mandir, 
                qq{$page.$Config{"man${ext}ext"}});
            next unless -f $pathname;
	    return $pathname if !wantarray;
	    push @paths, $pathname;
	}
    }
    # the !wantarray success case is taken care of already
    return wantarray ? @paths : undef;  
} 

sub usage {
    print STDERR "@_\n" if @_;
    die "usage: docpath podpage|module|proggie  ...\n";
} 

sub main { 
    my @want = @_ ? @_ : @ARGV;
    my $status = 0;

    my %aliases = (
	"DEFAULT"       => \&docpath,
        "docpath"       => \&docpath,
        "mandirs"       => \&mandirs,
        "pmanpath"      => \&pmanpath,
        "pmpodpath"     => \&pmpodpath,
        "pod2manpath"   => \&pod2manpath,
        "podlibdir"     => \&podlibdir,
        "podpath"       => \&podpath,
        "progpodpath"   => \&progpodpath,
        "stdpodpath"    => \&stdpodpath,
    );

    my $want_func = $aliases{DEFAULT};

    if (@want && $want[0] =~ /^-f(.*)/) {
        shift @want;
        $want_func = $aliases{$1 || shift @want};
        usage("Missing valid argument to -f; use one of these:\n\t" 
	    . join(", " => sort keys %aliases)) unless defined $want_func;
    } elsif ($Am_Standalone) {
	my $alias = (fileparse($0, qr/\..*/))[0];
	if ($aliases{$alias}) {
	    $want_func = $aliases{$alias};
	} 

    } 

    unless (@want) {
	usage("$0: page argument required");
    } 

    for my $page (@want) {
	my @paths = $want_func->($page);
	$status++ if @paths == 0;
	if (@want > 1) {
	    print "$page: @paths\n";
	} else {
	    print join("\n", @paths), "\n" if @paths;
	} 
    } 
    return $status;
} 

1;

__END__

=head1 NAME

docpath - find path to perl docs

• progmod example: PM::Tools::podpath by Tom Christiansen