automatically update a darkpan

.minicpanrc_example

# where the cpan mirror lives
local:  c:/dpan/mini

# where to mirror from
remote: http://cpan.perl.org

# where to prepare the inserted modules
repository: c:/dpan/mymodules

Automatic.pm

#!/usr/bin/perl

use strict;
use warnings;

package Automatic;

use Moose;

use CPAN::Mini::Inject;
use App::Cache;
use File::Slurp;
use CPAN::ParseDistribution;
use Try::Tiny;
use LockFile::Simple qw( trylock unlock );

has in_dir => ( isa => 'Str', is => 'ro', default => "in" );
has cfg_file => ( isa => 'Str', is => 'ro', default => ".minicpanrc" );
has local_author => ( isa => 'Str', is => 'ro', default => "TFX" );

has cache => ( isa => 'App::Cache', is => 'ro', builder => '_init_cache' );
has inject => ( isa => 'CPAN::Mini::Inject', is => 'ro', builder => '_init_mcpi' );
has new_dists => ( isa => 'Int', is => 'rw', default => 0 );

sub _init_cache { App::Cache->new({ ttl => 32_000_000, directory => 'cache' }) }
sub _init_mcpi { CPAN::Mini::Inject->new }

sub run {
    my ( $self ) = @_;
    
    my $lock = trylock( "Automatic.lock" );
    
    return $self->update_local_mirror if $lock;
    
    print "Lockfile exists, skipping update.";
    return;
}

sub update_local_mirror {
    my ( $self ) = @_;
    
    try {
        my $inject = $self->inject;
        
        $inject->parsecfg($self->cfg_file);
        $inject->config->set( 'dirmode', '0777' );
        
        $self->add_directory;
        
        $inject->writelist;
        $self->update_from_remote;
        $inject->inject( 'verbose' ) if $self->new_dists;
    }
    finally {
        unlock( "Automatic.lock" );
    }
    catch {
        print "Error: $_";
    };
    
    return;
}

sub update_from_remote {
    my ( $self ) = @_;
    
    return if $self->remote_is_fresh;
    
    my $inject = $self->inject;
    $inject->update_mirror( trace => $inject->{config}{trace} );
    
    $self->cache->set( 'last_remote_update', time );
    
    return;
}

sub remote_is_fresh {
    my ( $self ) = @_;
    
    my $last_update = $self->cache->get( 'last_remote_update') || 0;
    return 1 if $last_update > ( time - 60*60 );
    return 0;
}

sub add_directory {
    my ( $self ) = @_;
    
    my $dir = $self->in_dir;
    my @dists = sort @{ read_dir( $dir ) };
    my $known_dists = $self->cache->get("known_dists") || {};
    
    my $need_all_dists = !$self->remote_is_fresh;
    my @new_dists = grep { $need_all_dists or !$known_dists->{$_} } @dists;
    
    for my $dist ( @new_dists ) {
        my $success = try { $self->add_dist( "$dir/$dist" ) };
        
        next if !$success;

        print "added $dist\n";
        
        $known_dists->{$dist} = 1;
        $self->new_dists(1);
    }
    
    $self->cache->set( "known_dists", $known_dists );
    
    return;
}

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

    print "adding $file\n";
    
    my $dist = CPAN::ParseDistribution->new( $file );
    
    my %modules     = %{$dist->modules};
    
    for ( keys %modules ) {
        $self->inject->add(
            module   => $_, 
            authorid => $self->local_author, 
            version  => $modules{$_}, 
            file     => $file
        );
    }
    
    return 1;
}

1;

inject.pl

#!/usr/bin/perl

use strict;
use warnings;

package inject;

BEGIN {

    umask 0;

    use CGI::Carp qw(carpout);
    open my $LOG, ">>inject_error.log" or die "Unable to open mycgi-log: $!\n";
    carpout($LOG);

    CGI::Carp->import( 'fatalsToBrowser' ) if !@ARGV;
    if ( @ARGV ) {
        use FindBin;
        chdir $FindBin::Bin;
    }
}

use Capture::Tiny qw' tee_merged capture_merged ';
use File::Slurp;
use Automatic;

$|++;

my $normal_log_file = 'inject.log';

append_file $normal_log_file, localtime()."\nStarted CPAN mirror update.\n";
my $result;

$result = capture_merged { Automatic->new->run; } if !@ARGV;
$result = tee_merged { Automatic->new->run; } if @ARGV;

$result .= "done updating\n" if $result;
$result ||= "Nothing to do.\n";
append_file $normal_log_file, "$result\n".localtime()."\n";

exit if @ARGV;

my $file = "mini/authors/01mailrc.txt.gz";
my $file_size = -s $file;
print "Content-Type:application/octet-stream\n";   
print "Content-Disposition:attachment;filename=01mailrc.txt.gz\n";
print "Content-Length:$file_size\n\n";
binmode STDOUT;
print read_file $file, binmode => ':raw';

exit;

upload.pl

#!/usr/bin/perl

use strict;
use warnings;

package dpan_upload;

BEGIN {
    umask 0;

    use CGI::Carp qw(carpout);
    open my $LOG, ">>upload_error.log" or die "Unable to open mycgi-log: $!\n";
    carpout($LOG);
}
use CGI 'header';
use CGI::Upload;
use File::Slurp qw( read_file write_file );

receive_file();

print header();
print 'uploaded';

exit;

sub receive_file {

    my $upload = CGI::Upload->new;

    my $file_name = $upload->query->param('pause99_add_uri_upload');
    my $fh = $upload->file_handle('pause99_add_uri_httpupload');

    my $data = read_file( $fh, binmode => ':raw' );

    unlink "in/$file_name" if -e "in/$file_name";
    write_file( "in/$file_name", $data, { binmode => ':raw' } );

    return;
}