#! /usr/bin/perl
#######################################################################
# $Id: findpmr,v 1.20 2010-12-05 08:36:11 dpchrist Exp $
#######################################################################
# preliminaries:
#----------------------------------------------------------------------

use strict;
use warnings;

#######################################################################
# constants:
#----------------------------------------------------------------------

use constant DEBUG		=> 0;

use constant EXIT_GETOPTIONS_FAILED => 2;
use constant EXIT_HELP		=> 0;
use constant EXIT_MAN		=> 0;
use constant EXIT_NO_ARGS	=> 1;
use constant MAKEFILE_PL	=> 'Makefile.PL';
use constant RX_WRITEMAKEFILE	=> qr/WriteMakefile\(/;
use constant RX_VERSION_FROM	=> qr/VERSION_FROM[^\']+\'([^\']+)\'/;
use constant RX_VERSION		=> qr/(\$VERSION[^;]+;)/;
use constant RX_NAME		=> qr/NAME[^\']+\'([^\']+)\'/;
use constant RX_REQUIRE		=>
    qr/^[^#]*require\s+([A-Z]\w+(?:\:\:[A-Z]\w+)*)/;
use constant RX_USE		=>
    qr/^[^#]*use\s+([A-Z]\w+(?:\:\:[A-Z]\w+)*)/;

#######################################################################
# modules:
#----------------------------------------------------------------------

use Cwd;
use Data::Dumper;
use Dpchrist::Debug		qw( :all );
use Dpchrist::Term		qw( dot );
use ExtUtils::MakeMaker;
use File::Find;
use File::Slurp;
use File::Spec::Functions;
use Getopt::Long;
use Pod::Usage;

#######################################################################
# globals:
#----------------------------------------------------------------------

local $| = 1			if DEBUG;
$Data::Dumper::Sortkeys = 1	if DEBUG;

our $VERSION = sprintf("%d.%03d", q$Revision: 1.20 $ =~ /(\d+)/g);

our $exitval			= 0;
our @modroots			= ();
our $opt;
our %uses_requires;

#######################################################################
# subroutines:
#----------------------------------------------------------------------

sub do_command
{
    ddump('call', [\@_], [qw(*_)]) if DEBUG;

    my ($dir, $command) = @_;

    my $starting_dir = getcwd;

    print "# command: $command\n" unless $opt->{-quiet};
    chdir $dir;

    eval {
	system($command);
	if ($? == -1) {
	    die "failed to execute: $!\n";
	}
	elsif ($? & 127) {
	    die sprintf "child died with signal %d, %s coredump\n",
		($? & 127),  ($? & 128) ? 'with' : 'without';
	}
	elsif ($?) {
	    die "child exited with value %d\n", $? >> 8;
	}
    };
    warn $@ if $@ && !$opt->{-force};

    chdir $starting_dir;

    dprint 'return' if DEBUG;
    return;
}

#----------------------------------------------------------------------

sub do_name
{
    ddump('call', [\@_], [qw(*_)]) if DEBUG;

    my $meta = get_meta(shift)
	or goto DONE;

    print '# name: ' unless $opt->{-quiet};
    print $meta->{NAME}, "\n";

  DONE:

    dprint 'return' if DEBUG;
    return;
}

#----------------------------------------------------------------------

sub do_name_version
{
    ddump('call', [\@_], [qw(*_)]) if DEBUG;

    my $meta = get_meta(shift)
	or goto DONE;

    print '# name/version: ' unless $opt->{-quiet};
    print $meta->{NAME}, "\t", $meta->{VERSION}, "\n";

  DONE:

    dprint 'return' if DEBUG;
    return;
}

#----------------------------------------------------------------------

sub do_requires
{
    ddump('call', [\@_], [qw(*_)]) if DEBUG;

    my $dir = shift;

    %uses_requires = ();

    find(\&wanted_uses_requires, $dir);
    ddump([\%uses_requires], [qw(*uses_requires)]) if DEBUG;
    print "\n" if $opt->{-dots};

    print "# requires:\n" unless $opt->{-quiet};
    print join "\n", sort keys %uses_requires;
    print "\n" if keys %uses_requires;

    dprint 'return' if DEBUG;
    return;
}

#----------------------------------------------------------------------

sub do_uses
{
    ddump('call', [\@_], [qw(*_)]) if DEBUG;

    my $dir = shift;

    %uses_requires = ();

    find(\&wanted_uses_requires, $dir);
    ddump([\%uses_requires], [qw(*uses_requires)]) if DEBUG;
    print "\n" if $opt->{-dots};

    print "# uses:\n" unless $opt->{-quiet};
    print join "\n", sort keys %uses_requires;
    print "\n" if keys %uses_requires;

    dprint 'return' if DEBUG;
    return;
}

#----------------------------------------------------------------------

sub do_uses_requires
{
    ddump('call', [\@_], [qw(*_)]) if DEBUG;

    my $dir = shift;

    %uses_requires = ();

    find(\&wanted_uses_requires, $dir);
    ddump([\%uses_requires], [qw(*uses_requires)]) if DEBUG;
    print "\n" if $opt->{-dots};

    print "# uses/requires:\n" unless $opt->{-quiet};
    print join "\n", sort keys %uses_requires;
    print "\n" if keys %uses_requires;

    dprint 'return' if DEBUG;
    return;
}

#----------------------------------------------------------------------

sub do_version
{
    ddump('call', [\@_], [qw(*_)]) if DEBUG;

    my $meta = get_meta(shift)
	or goto DONE;

    print '# version: ' unless $opt->{-quiet};
    print $meta->{VERSION}, "\n";

  DONE:

    dprint 'return' if DEBUG;
    return;
}

#----------------------------------------------------------------------

sub get_meta
{
    ddump('call', [\@_], [qw(*_)]) if DEBUG;

    my $dir = shift;

    my $meta;

    my $makefile = catfile($_, MAKEFILE_PL);
    ddump([$makefile], [qw(makefile)]) if DEBUG;

    my @lines = eval{ read_file($makefile) };
    if ($@) {
	warn "WARNING: failed to read file '$makefile': $@";
	goto DONE;
    }
    ddump([\@lines], [qw(*lines)]) if DEBUG;

    $_ = shift @lines until RX_WRITEMAKEFILE;

    my $text = join '', @lines;
    ddump([$text], [qw(text)]) if DEBUG;

    $text =~ RX_NAME;
    my $name = $1;
    unless ($name) {
	warn 'WARNING: failed to find NAME argument ' .
	    "in file '$makefile'";
	goto DONE;
    }
    ddump([$name], [qw(name)]) if DEBUG;

    $text =~ RX_VERSION_FROM;
    my $version_from = $1;
    unless ($version_from) {
	warn 'WARNING: failed to find ' .
	    "VERSION_FROM argument in file '$makefile'";
	goto DONE;
    }
    ddump([$version_from], [qw(version_from)]) if DEBUG;

    my $version_file = catfile($dir, $version_from);
    ddump([$version_file], [qw(version_file)]) if DEBUG;

    my $version = eval { MM->parse_version($version_file) };
    if ($@) {
	warn $@;
	goto DONE;
    }

    $meta = {
	DIRECTORY	=> $dir,
	NAME		=> $name,
	VERSION_FROM	=> $version_from,
	VERSION		=> $version,
    };

  DONE:

    ddump('return', [$meta], [qw(meta)]) if DEBUG;
    return $meta;
}

#----------------------------------------------------------------------

sub wanted_uses_requires
{
    ddump('call', [\@_], [qw(*_)]) if 1 < DEBUG;
    dot if $opt->{-dots};
    
    goto DONE if -d $_ || $_ =~ /\.swp$/;

    ddump([$_, $File::Find::dir, $File::Find::name],
	[qw(_   File::Find::dir   File::Find::name)]) if 1 < DEBUG;

    my @lines = read_file($_);

    my @modules;

    foreach my $line (@lines) {
	dot if $opt->{-dots};
	if ($opt->{-uses} && $line =~ RX_USE) {
	    push @modules, $1;
	    ddump([$line, $1], [qw(line 1)]) if DEBUG;
	}
	if ($opt->{-requires} && $line =~ RX_REQUIRE) {
	    push @modules, $1;
	    ddump([$line, $1], [qw(line 1)]) if DEBUG;
	}
    }

    foreach my $module (@modules) {
	dot if $opt->{-dots};
	my $pmver = qx/pmver $module/;
	if ($@) {
	    warn "WARNING: failed looking up require'd " .
		"module '" .  $module . "': $!";
	    next;
	}
	ddump([$pmver], [qw(pmver)]) if DEBUG;
	chomp($pmver);
	$uses_requires{$pmver}++;
    }

  DONE:

    dprint 'return' if 1 < DEBUG;
    return;
}

#----------------------------------------------------------------------

sub wanted_modroots
{
    ddump('call', [\@_], [qw(*_)]) if 1 < DEBUG;
    dot if $opt->{-dots};
    
    goto DONE unless $_ eq MAKEFILE_PL;
    
    ddump([$_, $File::Find::dir, $File::Find::name],
	[qw(_   File::Find::dir   File::Find::name)]) if 1 < DEBUG;

    ### skip distribution temporary directories
    return if $File::Find::dir =~ /\d+\.\d+$/;

    push @modroots, $File::Find::dir;
    ddump([$File::Find::dir], [qw(File::Find::dir)]) if DEBUG;

  DONE:

    dprint 'return' if 1 < DEBUG;
    return;
}

#######################################################################
# main script:
#----------------------------------------------------------------------

{
    ddump('entry', [$0, \%ENV, \@ARGV], [qw(0 *ENV *ARGV)]) if DEBUG;

    Getopt::Long::Configure("bundling");

    my $r = GetOptions(
	'command|c=s'	=> \$opt->{-command },
	'dots|d'	=> \$opt->{-dots    },
	'force|f'	=> \$opt->{-force   },
	'help|h|?'	=> \$opt->{-help    },
	'man'		=> \$opt->{-man     },
	'name|n'	=> \$opt->{-name    },
	'quiet|q'	=> \$opt->{-quiet   },
	'requires|r'	=> \$opt->{-requires},
	'uses|u'	=> \$opt->{-uses    },
	'version|v'	=> \$opt->{-version },
    ) or $exitval = EXIT_GETOPTIONS_FAILED, goto DONE;
    ddump([$opt], [qw(opt)]) if DEBUG;

    if ($opt->{-help}) {
	pod2usage(-exitval => 'NOEXIT', -verbose => 1);
	goto DONE;
    }

    if ($opt->{-man}) {
	pod2usage(-exitval => 'NOEXIT', -verbose => 2);
	goto DONE;
    }

    $| = 1 if $opt->{-dots};

    ddump([-t STDIN], ['t_STDIN']) if DEBUG;

    chomp(@ARGV = <STDIN>) if !@ARGV && !-t STDIN;
    ddump([\@ARGV], [qw(*ARGV)]) if DEBUG;

    unless (@ARGV) {
	pod2usage(-exitval => 'NOEXIT', -verbose => 0);
	$exitval = EXIT_NO_ARGS;
	goto DONE;
    }

    find(\&wanted_modroots, @ARGV);
    ddump([\@modroots], [qw(*modroots)]) if DEBUG;
    print "\n" if $opt->{-dots};

    foreach (sort @modroots) {

	print("# module root: ", $_, "\n")
	    unless $opt->{-quiet};

	do_command($_, $opt->{-command})
	    if $opt->{-command};

	do_name($_)
	    if $opt->{-name} && !$opt->{-version};

	do_name_version($_)
	    if $opt->{-name} && $opt->{-version};

	do_requires($_)
	    if !$opt->{-uses} && $opt->{-requires};

	do_uses($_)
	    if $opt->{-uses} && !$opt->{-requires};

	do_uses_requires($_)
	    if $opt->{-uses} && $opt->{-requires};

	do_version($_)
	    if !$opt->{-name} && $opt->{-version};
    }

  DONE:

    ddump('exit', [$exitval], [qw(exitval)]) if DEBUG;
    exit $exitval;
}

#######################################################################
# end of code:
#----------------------------------------------------------------------

__END__

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

=head1 NAME

findpmr - find Perl module root directories


=head1 SYNOPSIS

    findpmr [Options] [PATH...]

    Options:
	--command, -c STRING  Call system(STRING) in directories found 
	--dots, -d            Print dots for length operations
	--force, -f           Ignore system() errors
	--help, -h, -?        Print a brief help message and exit
	--man                 Print the manual page and exit
	--name, -n            Print module name
	--quiet, -q           Only print results
	--requires, -r        Print modules require'd
	--uses, -u            Print modules use'd
	--version, -v         Print module version


=head1 DESCRIPTION

Recursively searchs PATH
and prints paths to Perl module source code root directories.

If PATH is omitted and STDIN is not connected to a terminal,
reads arguments from STDIN (Unix filter).


=head1 INSTALLATION

Installed as part of Dpchrist::Scripts.


=head1 AUTHOR

David Paul Christensen dpchrist@holgerdanske.com


=head1 COPYRIGHT AND LICENSE

Copyright (C) 2010 by David Paul Chirstensen dpchrist@holgerdanske.com

This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; version 2.

This program is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307,
USA.

=cut

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