#!/usr/bin/perl
# $Id: cpan,v 1.7 2006/01/11 06:22:32 comdog Exp $
use strict;

=head1 NAME

cpan - easily interact with CPAN from the command line

=head1 SYNOPSIS

	# with arguments and no switches, installs specified modules
	cpan module_name [ module_name ... ]

	# with switches, installs modules with extra behavior
	cpan [-cfimt] module_name [ module_name ... ]

	# without arguments, starts CPAN shell
	cpan

	# without arguments, but some switches
	cpan [-ahrvACDLO]

=head1 DESCRIPTION

This script provides a command interface (not a shell) to CPAN.pm.

=head2 Meta Options

These options are mutually exclusive, and the script processes them in
this order: [hvCAar].  Once the script finds one, it ignores the others,
and then exits after it finishes the task.  The script ignores any other
command line options.

=over 4

=item -a

Creates the CPAN.pm autobundle with CPAN::Shell->autobundle.

=item -A module [ module ... ]

Shows the primary maintainers for the specified modules

=item -C module [ module ... ]

Show the C<Changes> files for the specified modules

=item -D module [ module ... ]

Show the module details. This prints one line for each out-of-date module
(meaning, modules locally installed but have newer versions on CPAN).
Each line has three columns: module name, local version, and CPAN
version.

=item -L author [ author ... ]

List the modules by the specified authors.

=item -h

Prints a help message.

=item -O

Show the out-of-date modules.

=item -r

Recompiles dynamically loaded modules with CPAN::Shell->recompile.

=item -v

Print the script version and CPAN.pm version.

=back

=head2 Module options

These options are mutually exclusive, and the script processes them in
alphabetical order. It only processes the first one it finds.

=over 4

=item c

Runs a `make clean` in the specified module's directories.

=item f

Forces the specified action, when it normally would have failed.

=item i

Installed the specified modules.

=item m

Makes the specified modules.

=item t

Runs a `make test` on the specified modules.

=back

=head2 Examples

	# print a help message
	cpan -h

	# print the version numbers
	cpan -v

	# create an autobundle
	cpan -a

	# recompile modules
	cpan -r

	# install modules ( sole -i is optional )
	cpan -i Netscape::Booksmarks Business::ISBN

	# force install modules ( must use -i )
	cpan -fi CGI::Minimal URI

=head1 TO DO


=head1 BUGS

* none noted

=head1 SEE ALSO

Most behaviour, including environment variables and configuration,
comes directly from CPAN.pm.

=head1 SOURCE AVAILABILITY

This source is part of a SourceForge project which always has the
latest sources in CVS, as well as all of the previous releases.

	http://sourceforge.net/projects/brian-d-foy/

If, for some reason, I disappear from the world, one of the other
members of the project can shepherd this module appropriately.

=head1 CREDITS

Japheth Cleaver added the bits to allow a forced install (-f).

Jim Brandt suggest and provided the initial implementation for the
up-to-date and Changes features.

=head1 AUTHOR

brian d foy, C<< <bdfoy@cpan.org> >>

=head1 COPYRIGHT

Copyright (c) 2001-2006, brian d foy, All Rights Reserved.

You may redistribute this under the same terms as Perl itself.

=cut

use CPAN ();
use Getopt::Std;

my $VERSION =
	sprintf "%d.%d", q$Revision: 403 $ =~ m/ (\d+) \. (\d+) /xg;

if( 0 == @ARGV ) { CPAN::shell(); exit 0 }

# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # 
# set up the order of options that we layer over CPAN::Shell
my @META_OPTIONS = qw( h v C A D O L a r );

# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # 
# map switches to method names in CPAN::Shell
my $Default = 'default';

my %CPAN_METHODS = (
	$Default => 'install',
	'c'      => 'clean',
	'f'      => 'force',
	'i'      => 'install',
	'm'      => 'make',
	't'      => 'test',
	);
my @CPAN_OPTIONS = grep { $_ ne $Default } sort keys %CPAN_METHODS;

# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # 
# map switches to the subroutines in this script, along with other information.
# use this stuff instead of hard-coded indices and values
my %Method_table = (
# key => [ sub ref, takes args?, exit value, description ]
	h => [ \&_print_help,        0, 0, 'Printing help'          ],
	v => [ \&_print_version,     0, 0, 'Printing version'       ],
	C => [ \&_show_Changes,      1, 0, 'Showing Changes file'   ],
	A => [ \&_show_Author,       1, 0, 'Showing Author'         ],
	D => [ \&_show_Details,      1, 0, 'Showing Details'        ],
	O => [ \&_show_out_of_date,  0, 0, 'Showing Out of date'    ],
	L => [ \&_show_author_mods,  1, 0, 'Showing author mods'    ],
	a => [ \&_create_autobundle, 0, 0, 'Creating autobundle'    ],
	r => [ \&_recompile,         0, 0, 'Recompiling'            ],

	c => [ \&_default,           1, 0, 'Running `make clean`'   ],
	f => [ \&_default,           1, 0, 'Installing with force'  ],
	i => [ \&_default,           1, 0, 'Running `make install`' ],
   'm' => [ \&_default,          1, 0, 'Running `make`'         ],
	t => [ \&_default,           1, 0, 'Running `make test`'    ],

	);

my %Method_table_index = (
	code        => 0,
	takes_args  => 1,
	exit_value  => 2,
	description => 3,
	);
	
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # 
# finally, do some argument processing
my @option_order = ( @META_OPTIONS, @CPAN_OPTIONS );

my %options;
Getopt::Std::getopts(
	join( '', @option_order ), \%options );

my $option_count = grep { $options{$_} } @option_order;
$option_count -= $options{'f'}; # don't count force

# if there are no options, set -i (this line fixes RT ticket 16915)
$options{i}++ unless $option_count;

# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # 
# try each of the possible switches until we find one to handle
# print an error message if there are too many switches
# print an error message if there are arguments when there shouldn't be any
foreach my $option ( @option_order )
	{
	next unless $options{$option};
	die unless 
		ref $Method_table{$option}[ $Method_table_index{code} ] eq ref sub {};
	
	print "$Method_table{$option}[ $Method_table_index{description} ] " .
		"-- ignoring other opitions\n" if $option_count > 1;
	print "$Method_table{$option}[ $Method_table_index{description} ] " .
		"-- ignoring other arguments\n" 
		if( @ARGV && ! $Method_table{$option}[ $Method_table_index{takes_args} ] );
		
	$Method_table{$option}[ $Method_table_index{code} ]->( \@ARGV );
	
	last;
	}

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

sub _default
	{
	my $args = shift;
	
	my $switch = '';

	# choose the option that we're going to use
	# we'll deal with 'f' (force) later, so skip it
	foreach my $option ( @CPAN_OPTIONS )
		{
		next if $option eq 'f';
		next unless $options{$option};
		$switch = $option;
		last;
		}

	# 1. with no switches, but arguments, use the default switch (install)
	# 2. with no switches and no args, start the shell
	# 3. With a switch but no args, die! These switches need arguments.
	   if( not $switch and     @$args ) { $switch = $Default;     }
	elsif( not $switch and not @$args ) { CPAN::shell(); exit 0;  }
	elsif(     $switch and not @$args )
		{ die "Nothing to $CPAN_METHODS{$switch}!\n"; }

	# Get and cheeck the method from CPAN::Shell
	my $method = $CPAN_METHODS{$switch};
	die "CPAN.pm cannot $method!\n" unless CPAN::Shell->can( $method );

	# call the CPAN::Shell method, with force if specified
	foreach my $arg ( @$args )
		{
		if( $options{f} ) { CPAN::Shell->force( $method, $arg ) }
		else              { CPAN::Shell->$method( $arg )        }
		}
	}

# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # 
sub _print_help
	{
	print STDERR "Use perldoc to read the documentation\n";
	exec "perldoc $0";
	}
	
sub _print_version
	{
	print STDERR "$0 script version $VERSION, CPAN.pm version " . 
		CPAN->VERSION . "\n";
	}
	
sub _create_autobundle
	{
	print "Creating autobundle in ", $CPAN::Config->{cpan_home},
		"/Bundle\n";

	CPAN::Shell->autobundle;
	}

sub _recompiling
	{
	print "Recompiling dynamically-loaded extensions\n";

	CPAN::Shell->recompile;
	}

sub _show_Changes
	{
	my $args = shift;
	
	foreach my $arg ( @$args )
		{
		print "Checking $arg\n";
		my $module = CPAN::Shell->expand( "Module", $arg );
		
		next unless $module->inst_file;
		#next if $module->uptodate;
	
		( my $id = $module->id() ) =~ s/::/\-/;
	
		my $url = "http://search.cpan.org/~" . lc( $module->userid ) . "/" .
			$id . "-" . $module->cpan_version() . "/";
	
		#print "URL: $url\n";
		_get_changes_file($url);
		}
	}	
	
sub _get_changes_file
	{
	die "Reading Changes files requires LWP::Simple and URI\n"
		unless eval { require LWP::Simple; require URI; };
	
    my $url = shift;

    my $content = LWP::Simple::get( $url );
    print "Got $url ...\n" if defined $content;
	#print $content;
	
	my( $change_link ) = $content =~ m|<a href="(.*?)">Changes</a>|gi;
	
	my $changes_url = URI->new_abs( $change_link, $url );
 	#print "change link is: $changes_url\n";
	my $changes =  LWP::Simple::get( $changes_url );
	#print "change text is: " . $change_link->text() . "\n";
	print $changes;
	}
	
sub _show_Author
	{
	my $args = shift;
	
	foreach my $arg ( @$args )
		{
		my $module = CPAN::Shell->expand( "Module", $arg );
		my $author = CPAN::Shell->expand( "Author", $module->userid );
	
		next unless $module->userid;
	
		printf "%-25s %-8s %-25s %s\n", 
			$arg, $module->userid, $author->email, $author->fullname;
		}
	}	

sub _show_Details
	{
	my $args = shift;
	
	foreach my $arg ( @$args )
		{
		my $module = CPAN::Shell->expand( "Module", $arg );
		my $author = CPAN::Shell->expand( "Author", $module->userid );
	
		next unless $module->userid;
	
		print "$arg\n", "-" x 73, "\n\t";
		print join "\n\t",
			$module->description ? $module->description : "(no description)",
			$module->cpan_file,
			$module->inst_file,
			'Installed: ' . $module->inst_version,
			'CPAN:      ' . $module->cpan_version . '  ' .
				($module->uptodate ? "" : "Not ") . "up to date",
			$author->fullname . " (" . $module->userid . ")",
			$author->email;
		print "\n\n";
		
		}
	}	

sub _show_out_of_date
	{
	my @modules = CPAN::Shell->expand( "Module", "/./" );
		
	printf "%-40s  %6s  %6s\n", "Module Name", "Local", "CPAN";
	print "-" x 73, "\n";
	
	foreach my $module ( @modules )
		{
		next unless $module->inst_file;
		next if $module->uptodate;
		printf "%-40s  %.4f  %.4f\n",
			$module->id, 
			$module->inst_version ? $module->inst_version : '', 
			$module->cpan_version;
		}

	}

sub _show_author_mods
	{
	my $args = shift;

	my %hash = map { lc $_, 1 } @$args;
	
	my @modules = CPAN::Shell->expand( "Module", "/./" );
	
	foreach my $module ( @modules )
		{
		next unless exists $hash{ lc $module->userid };
		print $module->id, "\n";
		}
	
	}
	
1;