App::CPAN::Mini::Visit

# Copyright (c) 2008-2009 by David Golden. All rights reserved.
# Licensed under Apache License, Version 2.0 (the "License").
# You may not use this file except in compliance with the License.
# A copy of the License was distributed with this file or you may obtain a 
# copy of the License from http://www.apache.org/licenses/LICENSE-2.0

package App::CPAN::Mini::Visit;
use 5.010;
use strict;
use warnings;

our $VERSION = '0.006';
$VERSION = eval $VERSION; ## no critic

use CPAN::Mini ();
use Exception::Class::TryCatch qw/ try catch /;
use File::Basename qw/ basename /;
use File::Find qw/ find /;
use File::pushd qw/ tempd /;
use Path::Class qw/ dir file /;
use Getopt::Lucid qw/ :all /;
use Pod::Usage qw/ pod2usage /;

use Archive::Extract ();

my @option_spec = (
  Switch("help|h"),
  Switch("version|V"),
  Switch("quiet|q"),
  Param("append|a", qr/(?:^$|(?:^path|dist$))/ )->default(''),
  Param("e|E"),
  Param("minicpan|m"),
  Param("output|o"),
);

sub run {
  my ($self, @args) = @_;

  # get command line options
  my $opt = try eval { Getopt::Lucid->getopt( \@option_spec, \@args ) };
  for ( catch ) {
    when ( $_->isa('Getopt::Lucid::Exception::ARGV') ) {
      say;
      # usage stuff
      return 1;
    }
    default { die $_ }
  }

  # handle "help" and "version" options
  return _exit_usage() if $opt->get_help;
  return _exit_version() if $opt->get_version;

  # Set Archive::Extract globals
  # if quiet suppress warnings from Archive::Tar, etc.
  local $Archive::Extract::DEBUG = 0;
  local $Archive::Extract::PREFER_BIN = 1;
  local $Archive::Extract::WARN = $opt->get_quiet ? 0 : 1;

  # if -e/-E, then prepend to command
  if ( $opt->get_e ) {
    unshift @args, $^X, '-E', $opt->get_e;
  }

  # locate minicpan directory
  if ( ! $opt->get_minicpan ) {
    my %config = CPAN::Mini->read_config;
    if ( $config{local} ) {
      $opt->merge_defaults( {minicpan => $config{local}} );
    }
  }

  # confirm minicpan directory that looks like minicpan
  return _exit_no_minicpan() if ! $opt->get_minicpan;
  return _exit_bad_minicpan($opt->get_minicpan) if ! -d $opt->get_minicpan;

  my $id_dir = dir($opt->get_minicpan, qw/authors id/);
  return _exit_bad_minicpan($opt->get_minicpan) if ! -d $id_dir;

  # process all distribution tarballs in authors/id/...
  my $archive_re = qr{\.(?:tar\.(?:bz2|gz|Z)|t(?:gz|bz)|zip|pm\.gz)$}i;

  my $minicpan = dir( $opt->get_minicpan )->absolute;
  
  # save output by redirecting STDOUT if requested
  my ($out_fh, $orig_stdout );
  if ( $opt->get_output ) {
    open $out_fh, ">", $opt->get_output;
    open $orig_stdout, "<&=STDOUT";
    open STDOUT, ">&=" . fileno $out_fh;
  }

  find( 
    {
      no_chdir => 1,
      follow => 0,
      preprocess => sub { my @files = sort @_; return @files },
      wanted => sub {
        return unless /$archive_re/;
        # run code if program/args given otherwise print name
        if ( @args ) {
          return if $_ =~ /pm\.gz$/io; # not an archive, just a file
          my @cmd = @args;
          if ( $opt->get_append ) {
            if ( $opt->get_append eq 'dist' ) {
              my $distname = $_;
              my $prefix = dir( $minicpan, qw/authors id/ );
              $distname =~ s{^$prefix[\\/].[\\/]..[\\/]}{};
              push @cmd, $distname;
            }
            else {
              push @cmd, $_;
            }
          }
          _visit( $_, @cmd );
        }
        else {
          say; 
        }
      },
    },
    $minicpan
  );

  # restore STDOUT and close output file
  if ( $opt->get_output ) {
    open STDOUT, ">&=" . fileno $orig_stdout;
    close $out_fh;
  }

  return 0; # exit code
}

sub _exit_no_minicpan {
  say STDERR << "END_NO_MINICPAN";
No minicpan configured.
END_NO_MINICPAN
  return 1;
}

sub _exit_bad_minicpan {
  my ($dir) = @_;
  die "requires directory argument" unless defined $dir;
  say STDERR << "END_BAD_MINICPAN";
Directory '$dir' does not appear to be a CPAN repository.
END_BAD_MINICPAN
  return 1;
}

sub _exit_usage {
  my $exe = basename($0);
  say STDERR << "END_USAGE";
Usage:
  $exe [OPTIONS] [PROGRAM]

  $exe [OPTIONS] -- [PROGRAM] [ARGS]

Options:

 --append|-a        --append=dist -> append distname after ARGS
                    --append=path -> append tarball path after ARGS

 -e|-E              run next argument via 'perl -E'
 
 --help|-h          this usage info 

 --minicpan|-m      directory of a minicpan (defaults to local minicpan 
                    from CPAN::Mini config file)

 --output|-o        file to save output instead of sending to terminal

 --quiet|-q         silence warnings and suppress STDERR from tar

 --version|-V       $exe program version

 --                 indicates the end of options for $exe

END_USAGE
  return 1;
}

sub _exit_version {
  say STDERR basename($0) . ": $VERSION";
  return 1
}

sub _visit {
  my ($archive, @cmd_line) = @_;
  
  my $tempd = tempd;

  my $ae = Archive::Extract->new( archive => $archive );

  my $olderr;

  # stderr > /dev/null if quiet
  if ( ! $Archive::Extract::WARN ) {
    open $olderr, ">&STDERR";
    open STDERR, ">", File::Spec->devnull;
  }

  my $extract_ok = $ae->extract;

  # restore stderr if quiet
  if ( ! $Archive::Extract::WARN ) {
    open STDERR, ">&", $olderr;
    close $olderr;
  }

  if ( ! $extract_ok ) {
    warn "Couldn't extract '$archive'\n" if $Archive::Extract::WARN;
    return;
  }
  
  # most distributions unpack a single directory that we must enter
  # but some behave poorly and unpack to the current directory
  my @children = dir()->children;
  if ( @children == 1 && -d $children[0] ) {
    chdir $children[0];
  }
  
  # execute command
  system( @cmd_line );
  if ( $? ) {
    warn "Error running '@cmd_line': $!\n";
  }

  return;
}

1;

__END__