Created
November 10, 2010 13:08
-
-
Save wchristian/670826 to your computer and use it in GitHub Desktop.
automatically update a darkpan
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
# 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 |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
#!/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; |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
#!/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; |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
#!/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; | |
} |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment