use v5.16; # from dependencies, so go for it.
package CPAN::Mini::Inject;

use strict;
use warnings;

use CPAN::Checksums 2.13;
use CPAN::Mini;
use CPAN::Mini::Inject::Config;
use Carp;
use Compress::Zlib;
use File::Basename;
use File::Copy;
use File::Path qw( make_path );
use File::Spec;
use File::Spec::Functions;
use File::Temp qw(tempfile);
use LWP::Simple;
use Dist::Metadata ();

BEGIN {
  use version 0.9915;
  use CPAN::Meta::Converter;

  # This is here because the CPAN::Meta package has not been updated
  # since 2016 and it's unlikely that they'd accept a patch for this.
  # see https://github.com/briandfoy/cpan-mini-inject/issues/11
  # and https://github.com/Perl-Toolchain-Gang/CPAN-Meta#138
  package # hide from PAUSE
    CPAN::Meta::Converter;

  no warnings qw(redefine);

  # lifted from CPAN::Meta::Converter
  # https://fastapi.metacpan.org/source/DAGOLDEN/CPAN-Meta-2.150010/lib/CPAN/Meta/Converter.pm
  sub _clean_version {
    my ($element) = @_;
    return 0 if ! defined $element;

    $element =~ s{^\s*}{};
    $element =~ s{\s*$}{};
    $element =~ s{^\.}{0.};

    return 0 if ! length $element;
    return 0 if ( $element eq 'undef' || $element eq '<undef>' );
    my $v = eval { version->parse($element) };
    # XXX check defined $v and not just $v because version objects leak memory
    # in boolean context -- dagolden, 2012-02-03
    if ( defined $v ) {
    return _is_qv($v) ? $v->stringify : $element;
    }
    else {
    return 0;
    }
  }
}

=encoding utf8

=head1 NAME

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

=cut

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

=head1 SYNOPSIS

If you're not going to customize the way CPAN::Mini::Inject works you
probably want to look at the L<mcpani> command instead.

    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;

=head1 DESCRIPTION

CPAN::Mini::Inject uses CPAN::Mini to build or update a I<local> CPAN mirror
from a I<remote> one.  It adds two extra features:

1. an additional I<repository> of distribution files and related information
(author and module versions), separate from the local and remote mirrors, to
which you can add your own distribution files.

2. the ability to I<inject> the distribution files from your I<repository>
into a I<local> CPAN mirror.

=head1 METHODS

Each method in CPAN::Mini::Inject returns a CPAN::Mini::Inject object which
allows method chaining. For example:

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

A C<CPAN::Mini::Inject> ISA L<CPAN::Mini>. Refer to the
L<documentation|CPAN::Mini> for that module for details of the interface
C<CPAN::Mini::Inject> inherits from it.

=over 4

=item C<new>

Create a new CPAN::Mini::Inject object.

=cut

sub new {
  my( $class, %args ) = @_;
  my %defaults = (
    config_class => $class->default_config_class,
  );
  my %allowed = map {
    $_, 1
  } qw(config_class);

  my %filtered =
    map { ($_, $args{$_}) }
    grep { exists $allowed{$_} }
    keys %args;


  my %obj = ( %defaults, %filtered );
  return bless \%obj, $class;
}

=item C<< config_class( [CLASS] ) >>

Returns the name of the class used to handle the configuration. Also
see C<default_config_class>.

=cut

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

=item C<< config( [HASHREF] ) >>

With a hashref argument, sets the config data.

Returns the current configuration hash.

=cut

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

=item C<< default_config_class >>

=cut

sub default_config_class {
  'CPAN::Mini::Inject::Config'
}

=item C<< loadcfg( [FILENAME] ) >>


This is a bridge to CPAN::Mini::Inject::Config's loadconfig. It sets the
filename for the configuration, or uses one of the defaults.

=cut

sub loadcfg {
  my $self = shift;

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

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

  return $self;
}

=item C<< parsecfg() >>

This is a bridge to CPAN::Mini::Inject::Config's parseconfig.

=cut

sub parsecfg {
  my $self = shift;

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

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

  return $self;
}

=item C<< site( [SITE] ) >>

With an argument, set the site to use to contact CPAN. Returns the
site setting, or, if the site has not be set (or was set to undef),
returns the empty string.

=cut

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

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

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

=item C<testremote>

Test each site listed in the remote parameter of the config file by
performing a get on each site in order for authors/01mailrc.txt.gz.
The first site to respond successfully is set as the instance variable
site.

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

C<testremote> accepts an optional parameter to enable verbose mode.

=cut

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 "$0: unable to connect to any remote site" unless $self->site;

  return $self;
}

=item C<update_mirror>

This is a subclass of CPAN::Mini.

=cut

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

  croak sprintf "$0: local directory <%s> is not writable. Cannot update mirror.", $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;
  $options{skip_cleanup} ||= $self->config->get( 'skip_cleanup' ) || 0;

  # module_filters, log_level, and force
  my @extra = grep { defined $self->config->get($_) } qw(module_filters log_level force);

  $options{$_} = $self->config->get($_) for @extra;

  $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 );
}

=item C<add>

Add a new distribution to the repository. The C<add> method copies the
distribution file into the repository with the same structure as a
CPAN site. For example, F<CPAN-Mini-Inject-0.01.tar.gz> with author
C<SSORICHE> is copied to F<MYCPAN/authors/id/S/SS/SSORICHE>. add
creates the required directory structure below the repository.

Packages found in the distribution will be added to the module list
For example both C<CPAN::Mini::Inject> and
C<CPAN::Mini::Inject::Config> will be added to the F<modulelist> file
in the repository.

Packages will be looked for in the C<provides> key of the META file if
present, otherwise the files in the dist will be searched. See
L<Dist::Metadata> for more information.

=over 4

=item * module

(optional) The package name of the module to add. The distribution
file will be searched for modules but you can specify the main one
explicitly.

=item * authorid

(required) The CPAN ID of the module's author. Since this isn't
actually CPAN, the ID does not need to exist on CPAN. Typically, this
ID uses C<[A-Z]> and is three to ten letters. This is not enforced,
but other CPAN tools may not like other sorts of names.

=item * version

(optional) The module's version number. If you don't specify this.
C<add> will try to extract it from the distribution.

=item * file

(required) The path to the distribution file.

=back

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

=cut

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

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

  croak "$0: required option not specified: $optionchk" if $optionchk;
  croak "$0: no repository configured"
    unless $self->config->get( 'repository' );
  croak sprintf "$0: cannot write to repository <%s>", $self->config->get( 'repository' )
    unless -w $self->config->get( 'repository' );

  croak "$0: cannot read module file: $options{file}"
   unless -r $options{file};

  # attempt to guess module and version
  my $distmeta = Dist::Metadata->new( file => $options{file} );

  my $packages = $distmeta->package_versions;
  # include passed in module and version (prefer the declared version)
  if ( $options{module} and $options{version} ) {
    $packages->{ $options{module} } ||= $options{version};
  }

  # if no packages were found we need explicit options
  if ( !keys %$packages ) {
    $optionchk  = _optionchk( \%options, qw/module version/ );

    croak "$0: required option not specified and no modules were found: $optionchk"
     if $optionchk;
  }

  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 "$0: copy failed while adding disribution from <%s> to <%s>: $!", $options{file}, dirname( $target );

  $self->_updperms( $target );

  {
    my $mods = join('|', keys %$packages);
    # remove old versions from the list
    @{ $self->{modulelist} }
     = grep { $_ !~ m/\A($mods)\s+/ } @{ $self->{modulelist} };
  }

  # make data available afterwards (since method returns $self)
  push @{ $self->{added_modules} ||= [] },
    { file => $modulefile, authorid => $options{authorid}, modules => $packages };

  push(
    @{ $self->{modulelist} },
    map {
      _fmtmodule(
        $_, File::Spec::Unix->catfile( File::Spec->splitdir( $self->{authdir} ), $modulefile ),
        defined($packages->{$_}) ? $packages->{$_} : 'undef'
      )
    } keys %$packages
  );

  return $self;
}

=item C<added_modules>

Returns a list of hash references describing the modules added by this instance.
Each hashref will contain C<file>, C<authorid>, and C<modules>.
The C<modules> entry is a hashref of module names and versions included in the C<file>.

The list is cumulative.
There will be one entry for each time L</add> was called.

This functionality is mostly provided for the included L<mcpani> script
to be able to verbosely print all the modules added.

=cut

sub added_modules {
  my $self    = shift;
  return @{ $self->{added_modules} ||= [] };
}

=item C<inject>

Insert modules from the repository into the local CPAN::Mini mirror. inject
copies each module into the appropriate directory in the CPAN::Mini mirror
and updates the CHECKSUMS file.

Passing a value to C<inject> enables verbose mode, which lists each module
as it's injected.

=cut

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;
  my %already_injected;
  my %report;
  for my $modline ( @{ $self->{modulelist} } ) {
    my ( $module, $version, $file ) = split( /\s+/, $modline );

    my $target = $self->config->get( 'local' ) . '/authors/id/' . $file;

    # collect all modules of a target/file
    # needed for report
    push @{ $report{$target} }, $module;
    next if $already_injected{$module}++;

    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 sprintf "$0: copy failed while injecting <%s> to <%s>: $!", $source, $tdir;

    $self->_updperms( $target );
  }

  # if verbose report target file and the modules it contains
  if ( $verbose ) {
    for my $target (keys %report) {
        my $target_str = "$target ... injected modules : ";
        my $fmt = '%' . length($target_str) . "s%s\n";
        my @modules = @{ $report{$target} };
        printf $fmt, $target_str, shift @modules;    # first line with target
        for my $module ( @modules ) {                # rest only the module
            printf $fmt, '', $module;
        }
    }
  }

  for my $dir ( keys( %updatedir ) ) {
    my $root    = catfile( $self->config->get( 'local' ), qw(authors id) );
    my $authdir = catfile( $root, $dir );

    CPAN::Checksums::updatedir( $authdir, $root );
    $self->_updperms( catfile($authdir, 'CHECKSUMS') );
  }

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

  return $self;
}

=item C<updpackages>

Update the CPAN::Mini mirror's modules/02packages.details.txt.gz with the
injected module information.

=cut

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 { lc $a cmp lc $b } values %packages ] );
}

=item C<updauthors>

Update the CPAN::Mini mirror's authors/01mailrc.txt.gz with
stub information should the author not actually exist on CPAN

=cut

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 );
    my $author = (File::Spec->splitdir( $file ))[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 );

}

=item C<readlist>

Load the repository's modulelist.

=cut

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 "$0: cannot read module list: $ml ($!)";
  while ( <MODLIST> ) {
    chomp;
    push @{ $self->{modulelist} }, $_;
  }
  close MODLIST;

  return $self;
}

=item C<writelist>

Write to the repository modulelist.

=cut

sub writelist {
  my $self = shift;

  my $modulelist_file = $self->_repo_file( 'modulelist' );

  croak "$0: repository dir <%s> is not writable", $self->config->get( 'repository' )
  	unless -w $self->config->get( 'repository' );
  croak "$0: modulelist file <%s> is not writable", $modulelist_file
  	if( -e $modulelist_file and ! -w _ );

  return $self unless defined $self->{modulelist};

  open my $fh, '>', $modulelist_file
  	or croak sprintf "$0: modulelist file <%s> cannot be opened for writing: %s", $modulelist_file, $!;
  for ( sort( @{ $self->{modulelist} } ) ) {
    chomp;
    print {$fh} "$_\n";
  }
  close $fh;

  $self->_updperms( $modulelist_file );

  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 $file = catfile( $self->config->get( 'local' ), 'modules', _packages_file() );

  unless( -e $file ) {
  	carp sprintf "$0: <%s> does not exist; starting with empty list of packages\n", $file;
  	return [];
  }

  my $gzread = gzopen( $file, 'rb' ) or do {
    carp sprintf "$0: cannot open <%s>: <%s>; starting with empty list of packages\n", $file, $gzerrno;
    return []
  };

  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 _packages_file { '02packages.details.txt.gz' }
sub _writepkgs {
  my( $self, $pkgs ) = @_;

  my $dir = catfile( $self->config->get('local'), 'modules' );
  my $created = () = make_path $dir;
  unless( -d $dir ) {
  	croak sprintf "$0: directory <%s> does not exist. Cannot continue", $dir;
  }

  my($fh, $temp_filename) = tempfile();

  my $gzwrite = gzopen($fh, 'wb')
   or croak sprintf "$0: cannot open local temp file to create <%s>: $gzerrno", _packages_file();

  my $unzipped_file = _packages_file() =~ s/\.gz\z//r;
  my @headers = (
    [ 'File'         =>  $unzipped_file                                           ],
    [ 'URL'          => 'http://www.perl.com/CPAN/modules/' . $unzipped_file      ],
    [ 'Description'  => 'Package names found in directory $CPAN/authors/id/'      ],
    [ 'Columns'      => 'package name, version, path'                             ],
    [ 'Intended-For' => 'Automated fetch routines, namespace documentation.'      ],
    [ 'Written-By'   => "CPAN::Mini::Inject $VERSION"                             ],
    [ 'Line-Count'   => scalar( @$pkgs )                                          ],
    [ 'Last-Updated' => _fmtdate()                                                ],
  );

  foreach my $header ( @headers ) {
    $gzwrite->gzwrite(sprintf "%-13s %s\n", $header->[0] . ':', $header->[1]);
  }
  $gzwrite->gzwrite("\n");
  $gzwrite->gzwrite( "$_\n" ) for ( @$pkgs );
  $gzwrite->gzclose;

  my $dest = catfile( $dir, _packages_file() );
  copy( $temp_filename, $dest ) or croak "$0: copying $dest failed: $!";
}

sub _readauthors {
  my $self = shift;

  my $dir = catfile( $self->config->get('local'), 'authors' );
  my $created = () = make_path $dir;
  unless( -d $dir ) {
  	croak sprintf "$0: directory <%s> does not exist. Cannot continue", $dir;
  }

  my $mailrc_file = catfile( $dir,  '01mailrc.txt.gz' );
  unless( -e $mailrc_file ) {
  	return [];
  }

  my $gzread = gzopen( $mailrc_file, 'rb' ) or do {
    carp sprintf "$0: cannot open <%s>: <%s>\n", $mailrc_file, $gzerrno;
    return []
  };

  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 $file = catfile(
  	$self->config->get( 'local' ),
  	'authors',
  	'01mailrc.txt.gz'
  );

  my $gzwrite = gzopen( $file, 'wb' )
    or croak sprintf
    "$0: cannot open local <%s> authors/01mailrc.txt.gz for writing: %s",
      $file, "$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";
}

=back

=head1 SEE ALSO

L<CPAN::Mini>

=head1 Original Author

Shawn Sorichetti, C<< <ssoriche@cpan.org> >>

=head1 ACKNOWLEDGEMENTS

Special thanks to David Bartle, for bringing this module up
to date, and resolving the reported bugs.

Thanks to Jozef Kutej <jozef@kutej.net> for numerous patches.

=head1 BUGS

Report issues to the GitHub queue at

  https://github.com/briandfoy/cpan-mini-inject/issues

=head1 COPYRIGHT AND LICENSE

Copyright 2008-2009 Shawn Sorichetti, Andy Armstrong, All Rights Reserved.

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

=cut

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