#!/usr/local/bin/perl

use 5.010;

use strict;
use warnings;

use autodie;

use Config;
use CPAN::DistnameInfo;
use CPAN::Access::AdHoc;
use Cwd;
use File::Temp;
use Getopt::Long 2.33;
use Pod::Usage;
use POSIX qw{ strftime };
use Term::ReadLine;
use version 0.77;
use YAML::Any;

our $VERSION = '0.000_04';

use constant CURRENT_PACKAGE => 'current';

my %opt;

GetOptions( \%opt,
    'help|?' => sub { pod2usage( { -verbose => 2 } ) },
) or pod2usage( { -verbose => 0 } );

my $rl;
if ( -t STDIN ) {
    my $trl = Term::ReadLine->new( 'cpan-adhoc' );
    $rl = sub {
	return $trl->readline( $_[0] );
    };
} elsif ( -t STDOUT ) {
    $rl = sub { print @_; return scalar <STDIN> };
} else {
    $rl = sub { return scalar <STDIN> };
}

-t STDOUT and say <<"EOD";

cpan-adhoc - Get arbitrary information from a CPAN mirror.
Version $VERSION, based on CPAN::Access::AdHoc version @{[
    CPAN::Access::AdHoc->VERSION ]}

Use 'help' for documentation, copyright, and license.

EOD

my $cad = CPAN::Access::AdHoc->new();
my %dist;

MAIN_LOOP:
while ( defined( my $buffer = $rl->( 'cpan-adhoc> ' ) ) ) {
    $buffer =~ s/ \s+ \z //smx;
    $buffer =~ s/ \A \s+ //smx;
    '' eq $buffer
	and next;
    $buffer =~ m/ \A [#] /smx
	and next;
    my ( $verb, @args ) = split qr{ \s+ }smx, $buffer;
    if ( my $code = __PACKAGE__->can( "verb_$verb" ) ) {
	eval {
	    $code->( @args );
	    1;
	} or warn $@;
    } else {
	warn "Unrecognized verb '$verb'\n";
    }
}

say '';

sub verb_alias {
    my ( $old, $new ) = @_;
    defined $old
	or die "Package alias must be given\n";
    defined $new
	or ( $old, $new ) = ( CURRENT_PACKAGE, $old );
    $dist{$old}
	or die "Package '$old' not downloaded\n";
    $dist{$new} = $dist{$old};
    return;
}

sub verb_base {
    my @args = @_;
    @args or @args = ( CURRENT_PACKAGE );
    foreach my $name ( @args ) {
	if ( $dist{$name} ) {
	    my $di = $dist{$name}{info};
	    say sprintf '%s/%s  %s', $di->cpanid(), $di->filename(),
		$dist{$name}{archive}->base_directory();
	} else {
	    say "Package $name not downloaded";
	}
    }
    return;
}

sub verb_cd {
    my ( $dir ) = @_;
    if ( defined $dir ) {
	chdir $dir
	    or die "Failed to cd to $dir: $!\n";
    } else {
	chdir
	    or die "Failed to cd to home directory: $!\n";
    }
    return;
}

sub verb_checksums {
    my ( $author ) = @_;
    defined $author
	or die 'Must specify a CPAN ID';
    my $cksum = $cad->fetch_distribution_checksums( $author );
    print Dump( $cksum );
    return;
}

sub verb_choose {
    my ( @args ) = @_;
    @args == 1
	or die "The choose command takes exactly one argument.\n";
    $dist{+CURRENT_PACKAGE} = $dist{$args[0]}
	or die "Package $args[0] not downloaded.\n";
    return;
}

sub verb_clear {
    %dist = ();
    $cad->flush();
    return;
}

sub verb_corpus {
    local @ARGV = @_;
    my %opt;
    GetOptions( \%opt, qw{ fetch! } )
	and @ARGV
	or die;
    my $inx = $cad->fetch_author_index();
    foreach my $id ( @ARGV ) {
	my $uc_id = uc $id;
	if ( $inx->{$uc_id} ) {
	    say sprintf '%-14s %s', $uc_id, $inx->{$uc_id}{address};
	    foreach my $dist ( $cad->corpus( $uc_id ) ) {
		say "    $dist";
		$opt{fetch}
		    and _fetch_distribution( $dist );
	    }
	} else {
	    warn "CPAN ID $uc_id not found\n";
	}
    }
    return;
}

sub verb_cpan {
    my @arg = _expand_default( @_ );
    if ( @arg ) {
	$cad->cpan( @arg );
	verb_clear();
    }
    defined $arg[0]
	or say $cad->cpan();
    return;
}

sub verb_default_cpan_source {
    my @arg = _expand_default( @_ );
    @arg
	and $cad->default_cpan_source( @arg );
    defined $arg[0]
	or say $cad->default_cpan_source();
    return;
}

sub verb_diff {
    local @ARGV = @_;
    my ( @d_opt, @d_arg );
    my %opt;
    my $go = Getopt::Long::Parser->new(
	config => [ qw{ pass_through no_auto_abbrev } ] );
    $go->getoptions( \%opt, qw{ less! } );
    while ( @ARGV ) {
	local $_ = shift @ARGV;
	if ( '--' eq $_ ) {
	    @d_arg = @ARGV;
	    last;
	} elsif ( m/ \A - /smx ) {
	    push @d_opt, $_;
	} else {
	    push @d_arg, $_;
	}
    }
    @d_arg
	and @d_arg <= 3
	or die "The diff command requores one to three arguments\n";
    my ( $local, $remote, $pkg ) = reverse @d_arg;
    $remote //= $local;
    my $temp = _fetch_file( $pkg, $remote );
    _issue( \%opt, diff => @d_opt, $temp->filename(), $local );

    return;
}

sub verb_distribution {
    local @ARGV = @_;
    my %opt;
    GetOptions( \%opt, qw{ direct! fetch! } )
	and @ARGV == 1
	or die "The distribution command takes exactly one argument\n";
    if ( $opt{direct} ) {
	_fetch_distribution( $ARGV[0] );
    } else {
	my $re = qr{ $ARGV[0] }smx;
	my $count = 0;
	my $distribution;
	foreach my $dist ( $cad->indexed_distributions() ) {
	    $dist =~ $re
		or next;
	    say $dist;
	    $count++
		or $distribution = $dist;
	}
	if ( $opt{fetch} ) {
	    if ( $count == 1 ) {
		_fetch_distribution( $distribution );
	    } elsif ( $count ) {
		die "Multiple distributions matching $re were found\n";
	    } else {
		die "No distributions matching $re were found\n";
	    }
	}
    }
    return;
}

BEGIN {
    no warnings qw{ once };
    *verb_dist = \&verb_distribution;
}

sub verb_exit {
    no warnings qw{ exiting };
    last MAIN_LOOP;
}

sub verb_extract {
    my @args = @_;
    @args or @args = ( CURRENT_PACKAGE );
    foreach my $name ( @args ) {
	if ( $dist{$name} ) {
	    $dist{$name}{archive}->extract();
	    my $di = $dist{$name}{info};
	    say sprintf '%s/%s  %s', $di->cpanid(), $di->filename(),
		$dist{$name}{archive}->base_directory();
	} else {
	    say "Package $name not downloaded";
	}
    }
    return;
}

sub verb_help {
    pod2usage( { -verbose => 2, -exitval => 'NOEXIT' } );
    return;
}

sub verb_less {
    my ( $pkg, $file ) = @_;
    my $temp = _fetch_file( $pkg, $file );
    _less( $temp );
    return;
}

sub verb_list {
    local @ARGV = @_;
    my %opt;
    GetOptions( \%opt, qw{ less! } )
	or return;
    my @args = @ARGV;
    @args
	or push @args, CURRENT_PACKAGE;
    my $output = $opt{less} ? File::Temp->new() : *STDOUT;
    foreach my $name ( @args ) {
	if ( $dist{$name} ) {
	    say { $output } $dist{$name}{name};
	    foreach my $file ( $dist{$name}{archive}->list_contents() )
	    {
		say { $output } '    ', $file;
	    }
	} else {
	    warn "Package '$name' not found\n";
	}
    }
    $opt{less}
	and _less( $output );
    return;
}

sub verb_metadata {
    my @args = @_;
    @args or push @args, CURRENT_PACKAGE;
    foreach my $name ( @args ) {
	if ( $dist{$name} ) {
	    my $dv = $dist{$name}{info}->distvname();
	    if ( my $meta = $dist{$name}{archive}->metadata() ) {
		my $ms = $meta->as_string();
		chomp $ms;
		say "$dv: $ms";
	    } else {
		warn "No metadata found for $dv\n";
	    }
	} else {
	    warn "Package '$name' not found\n";
	}
    }
    return;
}

sub verb_module {
    local @ARGV = @_;
    my %opt;
    GetOptions( \%opt, qw{ fetch! } )
	and @ARGV == 1
	or die "The module command takes exactly one argument\n";
    my ( $module ) = @ARGV;
    my $inx = $cad->fetch_module_index();
    $inx->{$module}
	or die "Module '$module' not indexed\n";
    my $dist = $inx->{$module}{distribution};
    say join "\t", $module, $inx->{$module}{version}, $dist;
    $opt{fetch}
	and _fetch_distribution( $dist );
    return;
}

sub verb_mtime {
    my ( $pkg, $file ) = _validate_pkg_file( @_ );
    say strftime( '%d-%b-%Y %H:%M:%S', localtime
	$pkg->{archive}->get_item_mtime( $file )
    );
    return;
}

sub verb_perldoc {
    my ( $pkg, $file ) = @_;
    my $temp = _fetch_file( $pkg, $file );
    _issue( {}, perldoc => $temp );
    return;
}

sub verb_pwd {
    say cwd;
    return;
}

sub _expand_default {
    local @ARGV = @_;
    my %opt;
    GetOptions( \%opt, qw{ default! } )
	or die "The only legal option is -default\n";
    if ( $opt{default} ) {
	@ARGV
	    and die "You may not specify both -default and an argument\n";
	return ( undef );
    } elsif ( @ARGV ) {
	@ARGV == 1
	    or die "You may not specify more than one argument\n";
	return @ARGV;
    } else {
	return;
    }
}

sub _validate_pkg_file {
    my ( $pkg, $file ) = @_;
    defined $pkg
	or defined $file
	or die "File name must be given\n";
    defined $file
	or ( $pkg, $file ) = ( CURRENT_PACKAGE, $pkg );
    $pkg //= CURRENT_PACKAGE;
    $dist{$pkg}
	or die "Package '$pkg' not downloaded\n";
    my $dname = $dist{$pkg}{info}->distvname();
    $dist{$pkg}{archive}->item_present( $file )
	or die "File '$file' not in distribution '$dname'\n";
    return ( $dist{$pkg}, $file );
}

sub _fetch_file {
    my ( $pkg, $file ) = _validate_pkg_file( @_ );
    my $temp = File::Temp->new();
    print { $temp } $pkg->{archive}->get_item_content( $file );
    return $temp;
}

sub _fetch_distribution {
    my ( $pkg ) = @_;
    my $archive = $cad->fetch_distribution_archive( $pkg );
    my $path = $archive->path();
    my $di = CPAN::DistnameInfo->new( $path );
    my $dn = $di->dist();
    my $dv = $di->distvname();
    my $version = version->parse( $di->version() );
    $dist{+CURRENT_PACKAGE} = $dist{$pkg} = {
	name	=> $pkg,
	archive	=> $archive,
	version	=> $version,
	dist	=> $dn,
	info	=> $di,
    };

    # $dv and $dn may not be defined if we are dealimg with, e.g., one
    # of Tom Christiansen's unpackaged .pm files, say
    # T/TO/TOMC/scripts/whenon.dir/LastLog/File.pm.gz
    defined $dv
	and $dist{$dv} = $dist{$pkg};
    not defined $dn
	or $dist{$dn}
	and $dist{$dn}{version} > $version
	or $dist{$dn} = $dist{$pkg};
    return;
}

sub _issue {
    my ( $opt, $name, @args ) = @_;
    if ( $opt->{less} ) {
	my $pid = open my $pipe, '-|';
	if ( ! defined $pid ) {
	    die "Failed to fork: $!\n";
	} elsif ( $pid ) {
	    # Parent
	    my $temp = File::Temp->new();
	    while ( <$pipe> ) {
		print { $temp } $_;
	    }
	    _less( $temp );
	} else {
	    # Child
	    exec { $name } $name, @args;
	    die "Exec failed: $!\n";
	}
    } else {
	system { $name } $name, @args;
    }
    return;
}

{

    my @pager;

    BEGIN {
	@pager = split qr{ \s+ }smx, $Config{pager};
    }

    sub _less {
	my ( $file ) = @_;
	_issue( {}, @pager, $file );
	return;
    }

}

__END__

=head1 TITLE

cpan-adhoc - Get arbitrary information from a CPAN mirror.

=head1 SYNOPSIS

 $ cpan-adhoc
 cpan-adhoc> help
 cpan-adhoc> module -fetch LWP::UserAgent
 cpan-adhoc> list
 cpan-adhoc> perldoc lib/LWP/UserAgent.pm
 cpan-adhoc> exit
 
 $ cpan-adhoc -help
 $ cpan-adhoc -version

=head1 OPTIONS

=head2 -help

This option displays the documentation for this script. The script then
exits.

=head2 -version

This option displays the version of this script. The script then exits.

=head1 DETAILS

This Perl script implements an interactive query of a CPAN mirror.

The following commands are supported:

=head2 alias

 cpan-adhoc> alias libwww-perl libwww
 cpan-adhoc> alias libwww

This command creates an alias for a distribution in the downloaded
distribution stash. It is simply a convenience to save typing. The first
argument is the name of an entry in the stash, and the second is the
alias.

The single-argument version creates an alias for the current
distribution, if any.

=head2 base

This command displays the base directories for the named distributions.
If no distribution is specified, the current distribution, if any, is
displayed.  Distributions must be fetched before they can be displayed.

=head2 cd

 cpan-adhoc> cd fu/bar
 cpan-adhoc> cd

This command changes the default directory under which the script runs.
Without an argument, it changes to the user's home directory.

=head2 checksums

 cpan-adhoc> checksums MENUHIN/

This command displays the checksums for the given directory (ending in a
slash, as in the example) or file.

=head2 choose

 cpan-adhoc> choose libwww-perl

This command makes the given downloaded distribution the default.

=head2 clear

 cpan-adhoc> clear

This command removes all distributions from the stash, and purges cached
data from the L<CPAN::Access::AdHoc|CPAN::Access::AdHoc> object.

=head2 corpus

 cpan-adhoc> corpus BACH

This command lists all distributions in the index for the given CPAN ID.
More than one CPAN ID can be specified. The CPAN ID is converted to
upper case before use, so the example could equally well be written

 cpan-adhoc> corpus bach

=head2 cpan

 cpan-adhoc> cpan
 cpan-adhoc> cpan file:///home/yehudi/Mini-CPAN/
 cpan-adhoc> cpan -default

If no argument is specified, this command displays the CPAN URL being
used.

If an argument is specified, this command sets the CPAN URL being used.

If the CPAN URL was specified as C<-default>, a default value is
computed from the current setting of C<default_cpan_source>, and that
value is both set as the current soure and displayed. If no default can
be computed from the current C<default_cpan_source>, an error is
displayed and the current setting is left unchanged.

=head2 default_cpan_source

 cpan-adhoc> default_cpan_source
 cpan-adhoc> default_cpan_source cpanm,CPAN
 cpan-adhoc> default_cpan_source -default

If no argument is specified, this command displays the sources of
default CPAN URLs being used.

If an argument is specified, this command sets the sources of default
CPAN URLs. The value is a comma-delimited list.

If the argument was specified as C<-default>, the default value is
reinstated.

B<Note> that setting this value does not affect the C<cpan> setting. If
you want to recompute the C<cpan> URL after setting this, you must do

 cpan-adhoc> cpan -default

=head2 diff

 cpan-adhoc> diff libwww-perl README README
 cpan-adhoc> diff README README
 cpan-adhoc> diff README
 cpan-adhoc> diff -less -u README README

This command runs F<diff> on a file from a CPAN archive and a local
file. The arguments are the distribution name, the file in the
distribution, and the local file. The distribution defaults to the
current distribution, and the file in the distribution defaults to the
local file.

The C<-less> option specifies that the output of F<diff> be viewed in
F<less>. Anything else that looks like an option (that is, that has a
leading dash) will be passed to the F<diff> program. Because of the
possibility of conflict with F<diff> options, C<-less> may not be
abbreviated, though it may be specified as C<--less>, or negated
C<-noless>.

The null option (C<-->) ends option processing, and causes anything
after it to be considered an argument. For example, in

 cpan-adhoc> diff README -readme

the trailing C<-readme> is taken as an option for F<diff>. But in

 cpan-adhoc> diff -- README -readme

the trailing C<-readme> is taken as a file name.

=head2 dist

This is a synonym for L<distribution|/distribution>, for convenience.

=head2 distribution

 cpan-adhoc> distribution libwww-perl
 cpan-adhoc> distribution -fetch libwww-perl

This command looks up the given distribution in the module index (sic),
using an unanchored regular expression, and displays any matches.

The following options may be specified:

=over

=item C<-direct>

If the C<-direct> option is specified, the argument is taken to be a
path name relative to the F<authors/id/> directory, though possibly
without the two leftmost components. This file is fetched (if it
exists), and no index lookup is done. The C<-fetch> option is
irrelevant.

=item C<-fetch>

If the C<-fetch> option is specified and exactly one match is found,
that distribution is fetched, and stashed locally under the name that
appeared in the index, and under its distribution and version (e.g.
C<libwww-perl-6.03> for the above examples).  It is also stashed under
the distribution name (e.g. C<libwww-perl>) if no higher version of the
same distribution has been stashed. The last distribution fetched
becomes the current distribution.

=back

=head2 exit

 cpan-adhoc> exit

This command causes the script to exit. An end-of-file also works.

=head2 help

 cpan-adhoc> help

This command displays the documentation for this script.

=head2 less

 cpan-adhoc> less libwww-perl lib/LWP/UserAgent.pm
 cpan-adhoc> less lib/LWP/UserAgent.pm

This command feeds the specified file from the specified distribution to
whatever pager was configured when Perl was built. The distribution must
have been previously downloaded.

The single-argument form displays the given file in the current
distribution.

=head2 list

 cpan-adhoc> list libwww-perl
 cpan-adhoc> list

This command lists the files in the given distributions, which must have
been previously downloaded. If no distribution is specified, the current
distribution is listed.

=head2 metadata

This command displays the metadata for the given distributions, which
must have been peviously downloaded. If metadata is not available (i.e.
no F<META.json> or F<META.yml> was found) a warning will be issued.

The metadata is displayed by the L<CPAN::Meta|CPAN::Meta> C<as_string()>
method.

=head2 module

 cpan-adhoc> module LWP::UserAgent
 cpan-adhoc> module -fetch LWP::UserAgent

This command looks up the given modules in the module index, and
displays their version and the distribution they are contained in.

If the C<-fetch> option is specified, the distribution is fetched, and
stashed locally under the name that appeared in the index, and under its
distribution and version (e.g. C<libwww-perl-6.03> for the above
examples).  It is also stashed under the distribution name if no higher
version of the same distribution has been stashed. The last distribution
fetched becomes the current distribution.

=head2 perldoc

 cpan-adhoc> perldoc libwww-perl-6.03 lib/LWP/UserAgent.pm
 cpan-adhoc> perldoc lib/LWP/UserAgent.pm

This command feeds the specified file from the specified distribution to
perldoc. The distribution must have been previously downloaded.

The single-argument form displays the given file in the current
distribution.

=head2 pwd

This command displays the current default directory.

=head1 AUTHOR

Thomas R. Wyant, III F<wyant at cpan dot org>

=head1 COPYRIGHT AND LICENSE

Copyright (C) 2012 by Thomas R. Wyant, III

This program is free software; you can redistribute it and/or modify it
under the same terms as Perl 5.10.0. For more details, see the full text
of the licenses in the directory LICENSES.

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.

=cut

# ex: set textwidth=72 :
