#!perl

use 5.008009;
use strict;
use warnings;
use Getopt::Long 2.13 qw(GetOptions);
use Pod::Usage qw(pod2usage);
use English qw( -no_match_vars );
use Config;
use File::Spec::Functions qw(splitpath catfile);
use Carp qw(carp);

sub usage;
sub version;

our $STRING_VERSION = our $VERSION = '1.002';
$VERSION  =~ s/_//;

my $prompt = 0;
my @prompted;

GetOptions('help|?'  => sub { pod2usage(-exitstatus => 0, -verbose => 0); }, 
		   'man'     => sub { pod2usage(-exitstatus => 0, -verbose => 2); },
		   'usage'   => sub { usage(); },
		   'version' => sub { version(); exit(1); },
		   'prompt'  => \$prompt,
		  ) or pod2usage(-verbose => 2);

if (0 == scalar @ARGV) {
	$prompt = 1;
}

if ($prompt) {
	version();
	print "\nPlease type in a space-separated list of modules you want to find\nthe installed versions for below.\n> ";
	my $cmd = <STDIN>;
	@prompted = split m{\s+}, $cmd; 
}

print "\n";
my $version_info;
MODULE:
for my $module (@ARGV, @prompted) {
	if ('perl' eq lc($module)) {
		print "The version of perl is $PERL_VERSION on $OSNAME ($Config{archname})\n";
		next MODULE;
	}

	if ($module =~ m/\Astrawberry (?:perl)?\z/imsx) {
		if (('MSWin32' ne $OSNAME) or ($Config{libperl} !~ m{\.a\z}msx)) {
			print "This is not Strawberry Perl.\n";
		}
	
		if (($Config{libperl} =~ m{\.a\z}msx) and ($Config{myuname} !~ m/\AWin32 [ ] strawberryperl/msx )) {
			print "This is not a new enough version of Strawberry Perl to easily tell what version it is.\n";
			next MODULE;
		}
		
		my ($strawberryversion, $bits) = (q{}, q{});
		if ($Config{myuname} =~ 
			m{\AWin32 [ ] strawberryperl [ ] # Starting code.
			 (\S+)                           # Version
			 .* [ ]                          # The date Strawberry Perl was built.
			 (\S+)\z                         # The version
			 }msx) {
			($strawberryversion, $bits) = ($1, $2);
			$bits = ('i386' eq $bits) ? 32 : 64;
		}
		print "The version of Strawberry Perl is $strawberryversion ($bits-bit), using gcc $Config{gccversion}\n";
		next MODULE;
	}

	if ('activeperl' eq lc($module)) {
		my $buildnumber = eval { return Win32::BuildNumber() };
		if ($EVAL_ERROR) {
			print "This is not ActivePerl (at least, not on Windows.)\n";
			next MODULE;
		}
		print "The version of ActivePerl is $PERL_VERSION build number $buildnumber\n";
		next MODULE;
	}

    my $version_info = {};
    my $module_file = catfile(split(/::/, $module));

    DIRECTORY: foreach my $dir (@INC) {
        my $filename = catfile($dir, "$module_file.pm");
        if (-e $filename ) {
            $version_info->{dir} = $dir;
            if (open IN, "$filename") {
                while (<IN>) {
                    # the following regexp comes from the Extutils::MakeMaker
                    # documentation.
                    if (/([\$*])(([\w\:\']*)\bVERSION)\b.*\=/) {
                        local $VERSION;
                        my $res = eval $_;
                        $version_info->{version} = $VERSION || $res;
                        last DIRECTORY;
                    }
                }
            } else {
                carp "Can't open $filename: $!";
            }
        }
    }
	
	if (exists $version_info->{dir}) {
		if (exists $version_info->{version}) {
			print "The version of $module in " . $version_info->{dir} . ' is ' . $version_info->{version} . "\n";
		} else {
			print "$module is installed in " . $version_info->{dir} . ", but does not have a detectable version.\n";
		}
	} else {
		print "$module could not be found.\n";
	}
}

print "\n";

if ($prompt) {
	require Term::ReadKey;
	my $char = undef;
	print "Press any key to exit.\n";
	$char = Term::ReadKey::ReadKey(-1) until $char;
}

exit;

sub version {

	my (undef, undef, $script) = splitpath( $PROGRAM_NAME );

	print <<"EOF";
This is $script, version $STRING_VERSION, which checks the
installed version of the modules named on the command line.

Copyright 2010 Curtis Jewell.

This script may be copied only under the terms of either the Artistic License
or the GNU General Public License, which may be found in the Perl 5 
distribution or the distribution containing this script.
EOF

	return;
}

sub usage {
	my $error = shift;

	print "Error: $error\n\n" if (defined $error);
	my (undef, undef, $script) = splitpath( $PROGRAM_NAME );

	print <<"EOF";
This is $script, version $STRING_VERSION, which checks the
installed version of the modules named on the command line.

Usage: $script [ --help ] [ --usage ] [ --man ] [ --version ] [ -? ]
                      [--prompt] Module::To::Check...

For more assistance, run $script --help.
EOF

	exit(1);	
}

__END__

=head1 NAME

module-version - Gets the version of a module

=head1 VERSION

This document describes module-version version 1.002.

=head1 DESCRIPTION

This script gets the version of a requested list of modules.

It also can check the version of perl, or of Strawberry Perl or 
ActivePerl.

=head1 SYNOPSIS

  module-version [ --help ] [ --usage ] [ --man ] [ --version ] [ -?] 
                 [--prompt] [perl] [strawberry[perl]] [activeperl]
				 Module::To::Check...

  Options:
    --usage         Gives a minimum amount of aid and comfort.
    --help          Gives aid and comfort.
    -?              Gives aid and comfort.
    --man           Gives maximum aid and comfort.	
	
    --version       Gives the name, version and copyright of the script.

	--prompt        Prompts for module names to print the versions of.
	
	perl            Gives the version, $^O, and $Config{archname} of perl.
	strawberryperl  Gives the version, bitness and version of gcc of
	                Strawberry Perl.
	activeperl      Gives the version and build number of ActivePerl.
	
	Module::To::Check
	                Prints the version of the module if it exists and
					is easily retrievable.
	
=head1 DEPENDENCIES

Perl 5.8.9 is the mimimum version of perl that this script will run on.

Other modules that this script depends on are 
L<Getopt::Long|Getopt::Long>, L<Pod::Usage|Pod::Usage>, 
and L<Term::ReadKey|Term::ReadKey>

=head1 SUPPORT

Support is provided for this script on the same basis as Strawberry Perl.

=head1 AUTHOR

Curtis Jewell, E<lt>csjewell@cpan.orgE<gt>

=head1 COPYRIGHT & LICENSE

Copyright 2010 Curtis Jewell.

This program is free software; you can redistribute
it and/or modify it under the same terms as Perl itself.

The full text of the license can be found in the
LICENSE file included with this distribution.

=cut

