CPAN::Mini::Inject - Inject modules into a CPAN::Mini mirror.

    use CPAN::Mini::Inject;

    $mcpi=CPAN::Mini::Inject->new;
    $mcpi->parsecfg('t/.mcpani/config');

    $mcpi->add( module   => 'CPAN::Mini::Inject',
                authorid => 'SSORICHE',
                version  => ' 0.01',
                file     => 'mymodules/CPAN-Mini-Inject-0.01.tar.gz' )

    $mcpi->writelist;
    $mcpi->update_mirror;
    $mcpi->inject;

    my $mcpi=CPAN::Mini::Inject->new;
    $mcpi->parsecfg
         ->update_mirror
         ->inject;

 print "$mcpi->{site}\n"; # ftp://ftp.cpan.org/pub/CPAN

  add( module => 'Module::Name',
       authorid => 'AUTHOR',
       version => 0.01,
       file => './Module-Name-0.01.tar.gz' );

package CPAN::Mini::Inject;

use strict;
use warnings;

use CPAN::Checksums qw( updatedir );
use CPAN::Mini;
use CPAN::Mini::Inject::Config;
use Carp;
use Compress::Zlib;
use Env;
use File::Basename;
use File::Copy;
use File::Path qw( make_path );
use File::Spec;
use LWP::Simple;

our $VERSION = '0.30';
our @ISA     = qw( CPAN::Mini );

sub new {
  return bless
   { config_class => 'CPAN::Mini::Inject::Config' },
   $_[0];
}

sub config_class {
  my $self = shift;

  if ( @_ ) { $self->{config_class} = shift }

  $self->{config_class};
}

sub config {
  my $self = shift;

  if ( @_ ) { $self->{config} = shift }

  $self->{config};
}

sub loadcfg {
  my $self = shift;

  unless ( $self->{config} ) {
    $self->{config} = $self->config_class->new;
  }

  $self->{cfgfile} = $self->{config}->load_config( @_ );

  return $self;
}

sub parsecfg {
  my $self = shift;

  unless ( $self->{config} ) {
    $self->config( $self->config_class->new );
  }

  $self->config->parse_config( @_ );

  return $self;
}

sub site {
  no warnings;
  my $self = shift;

  if ( @_ ) { $self->{site} = shift }

  $self->{site} || '';
}

sub testremote {
  my $self    = shift;
  my $verbose = shift;

  $self->site( undef ) if $self->site;

  $ENV{FTP_PASSIVE} = 1 if ( $self->config->get( 'passive' ) );

  for my $site ( split( /\s+/, $self->config->get( 'remote' ) ) ) {

    $site .= '/' unless ( $site =~ m/\/$/ );

    print "Testing site: $site\n" if ( $verbose );

    if ( get( $site . 'authors/01mailrc.txt.gz' ) ) {
      $self->site( $site );

      print "\n$site selected.\n" if ( $verbose );
      last;
    }
  }

  croak "Unable to connect to any remote site" unless $self->site;

  return $self;
}

sub update_mirror {
  my $self    = shift;
  my %options = @_;

  croak 'Can not write to local: ' . $self->config->get( 'local' )
   unless ( -w $self->config->get( 'local' ) );

  $ENV{FTP_PASSIVE} = 1 if $self->config->get( 'passive' );

  $options{local}     ||= $self->config->get( 'local' );
  $options{trace}     ||= 0;
  $options{skip_perl} ||= $self->config->get( 'perl' ) || 1;

  $self->testremote( $options{trace} )
   unless ( $self->site || $options{remote} );
  $options{remote} ||= $self->site;

  $options{dirmode} ||= oct( $self->config->get( 'dirmode' )
     || sprintf( '0%o', 0777 & ~umask ) );

  CPAN::Mini->update_mirror( %options );
}

sub add {
  my $self    = shift;
  my %options = @_;

  my $optionchk
   = _optionchk( \%options, qw/module authorid version file/ );

  croak "Required option not specified: $optionchk" if $optionchk;
  croak "No repository configured"
   unless ( $self->config->get( 'repository' ) );
  croak "Can not write to repository: "
   . $self->config->get( 'repository' )
   unless ( -w $self->config->get( 'repository' ) );

  croak "Can not read module file: $options{file}"
   unless -r $options{file};

  my $modulefile = basename( $options{file} );
  $self->readlist unless exists( $self->{modulelist} );

  $options{authorid} = uc( $options{authorid} );
  $self->{authdir} = $self->_authordir( $options{authorid},
    $self->config->get( 'repository' ) );

  my $target
   = $self->config->get( 'repository' )
   . '/authors/id/'
   . $self->{authdir} . '/'
   . basename( $options{file} );

  copy( $options{file}, dirname( $target ) )
   or croak "Copy failed: $!";

  $self->_updperms( $target );

  # remove old version from the list
  @{ $self->{modulelist} }
   = grep { $_ !~ m/\A$options{module}\s+/ } @{ $self->{modulelist} };

  push(
    @{ $self->{modulelist} },
    _fmtmodule(
      $options{module}, File::Spec::Unix->catfile( File::Spec->splitdir( $self->{authdir} ), $modulefile ),
      $options{version}
    )
  );

  return $self;
}

sub inject {
  my $self    = shift;
  my $verbose = shift;

  my $dirmode = oct( $self->config->get( 'dirmode' ) )
   if ( $self->config->get( 'dirmode' ) );

  $self->readlist unless ( exists( $self->{modulelist} ) );

  my %updatedir;
  for my $modline ( @{ $self->{modulelist} } ) {
    my ( $module, $version, $file ) = split( /\s+/, $modline );
    my $target = $self->config->get( 'local' ) . '/authors/id/' . $file;
    my $source
     = $self->config->get( 'repository' ) . '/authors/id/' . $file;

    $updatedir{ dirname( $file ) } = 1;

    my $tdir = dirname $target;
    _make_path( $tdir, defined $dirmode ? { mode => $dirmode } : {} );
    copy( $source, $tdir )
     or croak "Copy $source to $tdir failed: $!";

    $self->_updperms( $target );
    print "$target ... injected\n" if $verbose;
  }

  for my $dir ( keys( %updatedir ) ) {
    my $authdir = $self->config->get( 'local' ) . "/authors/id/$dir";

    updatedir( $authdir );
    $self->_updperms( "$authdir/CHECKSUMS" );
  }

  $self->updpackages;
  $self->updauthors;

  return $self;
}

sub updpackages {
  my $self = shift;

  my @modules = sort( @{ $self->{modulelist} } );
  my $infile  = $self->_readpkgs;
  my %packages;

  # These need to be unique-per-package, with ones that come from the input
  # file being overridden.
  for my $line (@$infile, @modules) {
    my ($pkg) = split(/\s+/, $line, 2);
    $packages{$pkg} = $line;
  };

  $self->_writepkgs( [ sort values %packages ] );
}

sub updauthors {
  my $self = shift;

  my $repo_authors       = $self->_readauthors;
  my %author_ids_in_repo = map {
    my ( $id ) = $_ =~ /alias \s+ (\S+)/xms;
    $id => 1;
  } @$repo_authors;

  my @authors;
  my %authors_added;
  AUTHOR:
  for my $modline ( @{ $self->{modulelist} } ) {
    my ( $module, $version, $file ) = split( /\s+/, $modline );

    # extract the author from the path
    my @dirs = File::Spec->splitdir( $file );
    my $author = $dirs[2];

    next AUTHOR if defined $author_ids_in_repo{$author};
    next AUTHOR if defined $authors_added{$author};

    push @$repo_authors,
     sprintf( 'alias %-10s "Custom Non-CPAN author <CENSORED>"',
      $author );
    $authors_added{$author} = 1;
  }

  $self->_writeauthors( $repo_authors );

}

sub _repo_file {
  File::Spec->catfile( shift->config->get( 'repository' ), @_ );
}

sub _modulelist { shift->_repo_file( 'modulelist' ) }

sub readlist {
  my $self = shift;

  $self->{modulelist} = undef;

  my $ml = $self->_modulelist;
  return $self unless -e $ml;

  open MODLIST, '<', $ml or croak "Can not read module list: $ml ($!)";
  while ( <MODLIST> ) {
    chomp;
    push @{ $self->{modulelist} }, $_;
  }
  close MODLIST;

  return $self;
}

sub writelist {
  my $self = shift;

  croak 'Can not write module list: '
   . $self->config->get( 'repository' )
   . "/modulelist ERROR: $!"
   unless ( -w $self->{config}{repository} . '/modulelist'
    || -w $self->{config}{repository} );
  return $self unless defined( $self->{modulelist} );

  open( MODLIST,
    '>' . $self->config->get( 'repository' ) . '/modulelist' );
  for ( sort( @{ $self->{modulelist} } ) ) {
    chomp;
    print MODLIST "$_\n";
  }
  close( MODLIST );

  $self->_updperms(
    $self->config->get( 'repository' ) . '/modulelist' );

  return $self;
}

sub _updperms {
  my ( $self, $file ) = @_;

  chmod oct( $self->config->get( 'dirmode' ) ) & 06666, $file
   if $self->config->get( 'dirmode' );
}

sub _optionchk {
  my ( $options, @list ) = @_;
  my @missing;

  for my $option ( @list ) {
    push @missing, $option
     unless defined $$options{$option};
  }

  return join ' ', @missing;
}

sub _make_path {
  my $um = umask 0;
  make_path( @_ );
  umask $um;
}

sub _authordir {
  my ( $self, $author, $dir ) = @_;

  my @author
   = ( substr( $author, 0, 1 ), substr( $author, 0, 2 ), $author );

  my $dm = $self->config->get( 'dirmode' );
  my @new
   = _make_path( File::Spec->catdir( $dir, 'authors', 'id', @author ),
    defined $dm ? { mode => oct $dm } : {} );

  return return File::Spec->catdir( @author );
}

sub _fmtmodule {
  my ( $module, $file, $version ) = @_;
  my $fw = 38 - length $version;
  $fw = length $module if $fw < length $module;
  return sprintf "%-${fw}s %s  %s", $module, $version, $file;
}

sub _cfg { $_[0]->{config}{ $_[1] } }

sub _readpkgs {
  my $self = shift;

  my $gzread = gzopen(
    $self->config->get( 'local' )
     . '/modules/02packages.details.txt.gz', 'rb'
  ) or croak "Cannot open local 02packages.details.txt.gz: $gzerrno";

  my $inheader = 1;
  my @packages;
  my $package;

  while ( $gzread->gzreadline( $package ) ) {
    if ( $inheader ) {
      $inheader = 0 unless $package =~ /\S/;
      next;
    }
    chomp( $package );
    push( @packages, $package );
  }

  $gzread->gzclose;

  return \@packages;
}

sub _writepkgs {
  my $self = shift;
  my $pkgs = shift;

  my $gzwrite = gzopen(
    $self->config->get( 'local' )
     . '/modules/02packages.details.txt.gz', 'wb'
   )
   or croak
   "Can't open local 02packages.details.txt.gz for writing: $gzerrno";

  $gzwrite->gzwrite( "File:         02packages.details.txt\n" );
  $gzwrite->gzwrite(
    "URL:          http://www.perl.com/CPAN/modules/02packages.details.txt\n"
  );
  $gzwrite->gzwrite(
    'Description:  Package names found in directory $CPAN/authors/id/'
     . "\n" );
  $gzwrite->gzwrite( "Columns:      package name, version, path\n" );
  $gzwrite->gzwrite(
    "Intended-For: Automated fetch routines, namespace documentation.\n"
  );
  $gzwrite->gzwrite( "Written-By:   CPAN::Mini::Inject $VERSION\n" );
  $gzwrite->gzwrite( "Line-Count:   " . scalar( @$pkgs ) . "\n" );
  # Last-Updated: Sat, 19 Mar 2005 19:49:10 GMT
  $gzwrite->gzwrite( "Last-Updated: " . _fmtdate() . "\n\n" );

  $gzwrite->gzwrite( "$_\n" ) for ( @$pkgs );

  $gzwrite->gzclose;

}

sub _readauthors {
  my $self = shift;
  my $gzread
   = gzopen( $self->config->get( 'local' ) . '/authors/01mailrc.txt.gz',
    'rb' )
   or croak "Cannot open "
   . $self->config->get( 'local' )
   . "/authors/01mailrc.txt.gz: $gzerrno";

  my @authors;
  my $author;

  while ( $gzread->gzreadline( $author ) ) {
    chomp( $author );
    push( @authors, $author );
  }

  $gzread->gzclose;

  return \@authors;
}

sub _writeauthors {
  my $self    = shift;
  my $authors = shift;

  my $gzwrite
   = gzopen( $self->config->get( 'local' ) . '/authors/01mailrc.txt.gz',
    'wb' )
   or croak
   "Can't open local authors/01mailrc.txt.gz for writing: $gzerrno";

  $gzwrite->gzwrite( "$_\n" ) for ( sort @$authors );

  $gzwrite->gzclose;

}

sub _fmtdate {
  my @date = split( /\s+/, scalar( gmtime ) );
  return "$date[0], $date[2] $date[1] $date[4] $date[3] GMT";
}

1;    # End of CPAN::Mini::Inject