public
Last active

automatically update a darkpan

  • Download Gist
.minicpanrc_example
1 2 3 4 5 6 7 8 9
 
# 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
Perl
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132
#!/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
Perl
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51
#!/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
Perl
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39
#!/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;
}

Please sign in to comment on this gist.

Something went wrong with that request. Please try again.