From 2a051e40a3fc09bba24c335060e8df327d313e55 Mon Sep 17 00:00:00 2001 From: Lorry Tar Creator Date: Fri, 8 Aug 2014 22:52:09 +0000 Subject: CPAN-Mini-1.111016 --- lib/CPAN/Mini.pm | 1311 ++++++++++++++++++++++++++++++++++++++++++++++++++ lib/CPAN/Mini/App.pm | 209 ++++++++ 2 files changed, 1520 insertions(+) create mode 100644 lib/CPAN/Mini.pm create mode 100644 lib/CPAN/Mini/App.pm (limited to 'lib') diff --git a/lib/CPAN/Mini.pm b/lib/CPAN/Mini.pm new file mode 100644 index 0000000..9569082 --- /dev/null +++ b/lib/CPAN/Mini.pm @@ -0,0 +1,1311 @@ +use 5.006; +use strict; +use warnings; + +package CPAN::Mini; +$CPAN::Mini::VERSION = '1.111016'; +# ABSTRACT: create a minimal mirror of CPAN + +## no critic RequireCarping + +#pod =head1 SYNOPSIS +#pod +#pod (If you're not going to do something weird, you probably want to look at the +#pod L command, instead.) +#pod +#pod use CPAN::Mini; +#pod +#pod CPAN::Mini->update_mirror( +#pod remote => "http://cpan.mirrors.comintern.su", +#pod local => "/usr/share/mirrors/cpan", +#pod log_level => 'debug', +#pod ); +#pod +#pod =head1 DESCRIPTION +#pod +#pod CPAN::Mini provides a simple mechanism to build and update a minimal mirror of +#pod the CPAN on your local disk. It contains only those files needed to install +#pod the newest version of every distribution. Those files are: +#pod +#pod =for :list +#pod * 01mailrc.txt.gz +#pod * 02packages.details.txt.gz +#pod * 03modlist.data.gz +#pod * the last non-developer release of every dist for every author +#pod +#pod =cut + +use Carp (); + +use File::Basename (); +use File::Copy (); +use File::HomeDir 0.57 (); # Win32 support +use File::Find (); +use File::Path 2.04 (); # new API, bugfixes +use File::Spec (); +use File::Temp (); + +use URI 1 (); +use LWP::UserAgent 5 (); + +use Compress::Zlib 1.20 (); + +#pod =method update_mirror +#pod +#pod CPAN::Mini->update_mirror( +#pod remote => "http://cpan.mirrors.comintern.su", +#pod local => "/usr/share/mirrors/cpan", +#pod force => 0, +#pod log_level => 'debug', +#pod ); +#pod +#pod This is the only method that need be called from outside this module. It will +#pod update the local mirror with the files from the remote mirror. +#pod +#pod If called as a class method, C creates an ephemeral CPAN::Mini +#pod object on which other methods are called. That object is used to store mirror +#pod location and state. +#pod +#pod This method returns the number of files updated. +#pod +#pod The following options are recognized: +#pod +#pod =begin :list +#pod +#pod * C +#pod +#pod This is the local file path where the mirror will be written or updated. +#pod +#pod * C +#pod +#pod This is the URL of the CPAN mirror from which to work. A reasonable default +#pod will be picked by default. A list of CPAN mirrors can be found at +#pod L +#pod +#pod * C +#pod +#pod Generally an octal number, this option sets the permissions of created +#pod directories. It defaults to 0711. +#pod +#pod * C +#pod +#pod If true, the C method will allow all extra files to be mirrored. +#pod +#pod * C +#pod +#pod If true, CPAN::Mini will not try to remove source control files during +#pod cleanup. See C for details. +#pod +#pod * C +#pod +#pod If true, this option will cause CPAN::Mini to read the entire module list and +#pod update anything out of date, even if the module list itself wasn't out of date +#pod on this run. +#pod +#pod * C +#pod +#pod If true, CPAN::Mini will skip the major language distributions: perl, parrot, +#pod and ponie. It will also skip embperl, sybperl, bioperl, and kurila. +#pod +#pod * C +#pod +#pod This defines the minimum level of message to log: debug, info, warn, or fatal +#pod +#pod * C +#pod +#pod If true, CPAN::Mini will warn with status messages on errors. (default: true) +#pod +#pod * C +#pod +#pod This options provides a set of rules for filtering paths. If a distribution +#pod matches one of the rules in C, it will not be mirrored. A regex +#pod rule is matched if the path matches the regex; a code rule is matched if the +#pod code returns 1 when the path is passed to it. For example, the following +#pod setting would skip all distributions from RJBS and SUNGO: +#pod +#pod path_filters => [ +#pod qr/RJBS/, +#pod sub { $_[0] =~ /SUNGO/ } +#pod ] +#pod +#pod * C +#pod +#pod This option provides a set of rules for filtering modules. It behaves like +#pod path_filters, but acts only on module names. (Since most modules are in +#pod distributions with more than one module, this setting will probably be less +#pod useful than C.) For example, this setting will skip any +#pod distribution containing only modules with the word "Acme" in them: +#pod +#pod module_filters => [ qr/Acme/i ] +#pod +#pod * C +#pod +#pod This option should be an arrayref of extra files in the remote CPAN to mirror +#pod locally. +#pod +#pod * C +#pod +#pod If this option is true, CPAN::Mini will not try delete unmirrored files when it +#pod has finished mirroring +#pod +#pod * C +#pod +#pod If offline, CPAN::Mini will not attempt to contact remote resources. +#pod +#pod * C +#pod +#pod If true, no connection cache will be established. This is mostly useful as a +#pod workaround for connection cache failures. +#pod +#pod =end :list +#pod +#pod =cut + +sub update_mirror { + my $self = shift; + $self = $self->new(@_) unless ref $self; + + unless ($self->{offline}) { + my $local = $self->{local}; + + $self->log("Updating $local"); + $self->log("Mirroring from $self->{remote}"); + $self->log("=" x 63); + + die "local mirror target $local is not writable" unless -w $local; + + # mirrored tracks the already done, keyed by filename + # 1 = local-checked, 2 = remote-mirrored + $self->mirror_indices; + + return unless $self->{force} or $self->{changes_made}; + + # mirror all the files + $self->_mirror_extras; + $self->mirror_file($_, 1) for @{ $self->_get_mirror_list }; + + # install indices after files are mirrored in case we're interrupted + # so indices will seem new again when continuing + $self->_install_indices; + + $self->_write_out_recent; + + # eliminate files we don't need + $self->clean_unmirrored unless $self->{skip_cleanup}; + } + + return $self->{changes_made}; +} + +sub _recent { $_[0]->{recent}{ $_[1] } = 1 } + +sub _write_out_recent { + my ($self) = @_; + return unless my @keys = keys %{ $self->{recent} }; + + my $recent = File::Spec->catfile($self->{local}, 'RECENT'); + open my $recent_fh, '>', $recent or die "can't open $recent for writing: $!"; + + for my $file (sort keys %{ $self->{recent} }) { + print {$recent_fh} "$file\n" or die "can't write to $recent: $!"; + } + + die "error closing $recent: $!" unless close $recent_fh; + return; +} + +sub _get_mirror_list { + my $self = shift; + + my %mirror_list; + + # now walk the packages list + my $details = File::Spec->catfile( + $self->_scratch_dir, + qw(modules 02packages.details.txt.gz) + ); + + my $gz = Compress::Zlib::gzopen($details, "rb") + or die "Cannot open details: $Compress::Zlib::gzerrno"; + + my $inheader = 1; + my $file_ok = 0; + while ($gz->gzreadline($_) > 0) { + if ($inheader) { + if (/\S/) { + my ($header, $value) = split /:\s*/, $_, 2; + chomp $value; + if ($header eq 'File' + and ($value eq '02packages.details.txt' + or $value eq '02packages.details.txt.gz')) { + $file_ok = 1; + } + } else { + $inheader = 0; + } + + next; + } + + die "02packages.details.txt file is not a valid index\n" + unless $file_ok; + + my ($module, $version, $path) = split; + next if $self->_filter_module({ + module => $module, + version => $version, + path => $path, + }); + + $mirror_list{"authors/id/$path"}++; + } + + return [ sort keys %mirror_list ]; +} + +#pod =method new +#pod +#pod my $minicpan = CPAN::Mini->new; +#pod +#pod This method constructs a new CPAN::Mini object. Its parameters are described +#pod above, under C. +#pod +#pod =cut + +sub new { + my $class = shift; + my %defaults = ( + changes_made => 0, + dirmode => 0711, ## no critic Zero + errors => 1, + mirrored => {}, + log_level => 'info', + ); + + my $self = bless { %defaults, @_ } => $class; + + $self->{dirmode} = $defaults{dirmode} unless defined $self->{dirmode}; + + $self->{recent} = {}; + + Carp::croak "no local mirror supplied" unless $self->{local}; + + substr($self->{local}, 0, 1, $class->__homedir) + if substr($self->{local}, 0, 1) eq q{~}; + + Carp::croak "local mirror path exists but is not a directory" + if (-e $self->{local}) + and not(-d $self->{local}); + + unless (-e $self->{local}) { + File::Path::mkpath( + $self->{local}, + { + verbose => $self->{log_level} eq 'debug', + mode => $self->{dirmode}, + }, + ); + } + + Carp::croak "no write permission to local mirror" unless -w $self->{local}; + + Carp::croak "no remote mirror supplied" unless $self->{remote}; + + $self->{remote} = "$self->{remote}/" if substr($self->{remote}, -1) ne '/'; + + my $version = $class->VERSION; + $version = 'v?' unless defined $version; + + $self->{__lwp} = LWP::UserAgent->new( + agent => "$class/$version", + env_proxy => 1, + ($self->{no_conn_cache} ? () : (keep_alive => 5)), + ($self->{timeout} ? (timeout => $self->{timeout}) : ()), + ); + + unless ($self->{offline}) { + my $test_uri = URI->new_abs( + 'modules/02packages.details.txt.gz', + $self->{remote}, + )->as_string; + + Carp::croak "unable to contact the remote mirror" + unless eval { $self->__lwp->head($test_uri)->is_success }; + } + + return $self; +} + +sub __lwp { $_[0]->{__lwp} } + +#pod =method mirror_indices +#pod +#pod $minicpan->mirror_indices; +#pod +#pod This method updates the index files from the CPAN. +#pod +#pod =cut + +sub _fixed_mirrors { + qw( + authors/01mailrc.txt.gz + modules/02packages.details.txt.gz + modules/03modlist.data.gz + ); +} + +sub _scratch_dir { + my ($self) = @_; + + $self->{scratch} ||= File::Temp::tempdir(CLEANUP => 1); + return $self->{scratch}; +} + +sub mirror_indices { + my $self = shift; + + $self->_make_index_dirs($self->_scratch_dir); + + for my $path ($self->_fixed_mirrors) { + my $local_file = File::Spec->catfile($self->{local}, split m{/}, $path); + my $scratch_file = File::Spec->catfile( + $self->_scratch_dir, + split(m{/}, $path), + ); + + File::Copy::copy($local_file, $scratch_file); + + utime((stat $local_file)[ 8, 9 ], $scratch_file); + + $self->mirror_file($path, undef, { to_scratch => 1 }); + } +} + +sub _mirror_extras { + my $self = shift; + + for my $path (@{ $self->{also_mirror} }) { + $self->mirror_file($path, undef); + } +} + +sub _make_index_dirs { + my ($self, $base_dir, $dir_mode, $trace) = @_; + $base_dir ||= $self->_scratch_dir; + $dir_mode = 0711 if !defined $dir_mode; ## no critic Zero + $trace = 0 if !defined $trace; + + for my $index ($self->_fixed_mirrors) { + my $dir = File::Basename::dirname($index); + my $needed = File::Spec->catdir($base_dir, $dir); + File::Path::mkpath($needed, { verbose => $trace, mode => $dir_mode }); + die "couldn't create $needed: $!" unless -d $needed; + } +} + +sub _install_indices { + my $self = shift; + + $self->_make_index_dirs( + $self->{local}, + $self->{dirmode}, + $self->{log_level} eq 'debug', + ); + + for my $file ($self->_fixed_mirrors) { + my $local_file = File::Spec->catfile($self->{local}, split m{/}, $file); + + unlink $local_file; + + File::Copy::copy( + File::Spec->catfile($self->_scratch_dir, split m{/}, $file), + $local_file, + ); + + $self->{mirrored}{$local_file} = 1; + } +} + +#pod =method mirror_file +#pod +#pod $minicpan->mirror_file($path, $skip_if_present) +#pod +#pod This method will mirror the given file from the remote to the local mirror, +#pod overwriting any existing file unless C<$skip_if_present> is true. +#pod +#pod =cut + +sub mirror_file { + my ($self, $path, $skip_if_present, $arg) = @_; + + $arg ||= {}; + + # full URL + my $remote_uri = eval { $path->isa('URI') } + ? $path + : URI->new_abs($path, $self->{remote})->as_string; + + # native absolute file + my $local_file = File::Spec->catfile( + $arg->{to_scratch} ? $self->_scratch_dir : $self->{local}, + split m{/}, $path + ); + + my $checksum_might_be_up_to_date = 1; + + if ($skip_if_present and -f $local_file) { + ## upgrade to checked if not already + $self->{mirrored}{$local_file} ||= 1; + } elsif (($self->{mirrored}{$local_file} || 0) < 2) { + ## upgrade to full mirror + $self->{mirrored}{$local_file} = 2; + + File::Path::mkpath( + File::Basename::dirname($local_file), + { + verbose => $self->{log_level} eq 'debug', + mode => $self->{dirmode}, + }, + ); + + $self->log($path, { no_nl => 1 }); + my $res = $self->{__lwp}->mirror($remote_uri, $local_file); + + if ($res->is_success) { + utime undef, undef, $local_file if $arg->{update_times}; + $checksum_might_be_up_to_date = 0; + $self->_recent($path); + $self->log(" ... updated"); + $self->{changes_made}++; + } elsif ($res->code != 304) { # not modified + $self->log(" ... resulted in an HTTP error with status " . $res->code); + $self->log_warn("$remote_uri: " . $res->status_line); + return; + } else { + $self->log(" ... up to date"); + } + } + + if ($path =~ m{^authors/id}) { # maybe fetch CHECKSUMS + my $checksum_path + = URI->new_abs("CHECKSUMS", $remote_uri)->rel($self->{remote})->as_string; + + if ($path ne $checksum_path) { + $self->mirror_file($checksum_path, $checksum_might_be_up_to_date); + } + } +} + +#pod =begin devel +#pod +#pod =method _filter_module +#pod +#pod next +#pod if $self->_filter_module({ module => $foo, version => $foo, path => $foo }); +#pod +#pod This method holds the filter chain logic. C takes an optional +#pod set of filter parameters. As C encounters a distribution, it +#pod calls this method to figure out whether or not it should be downloaded. The +#pod user provided filters are taken into account. Returns 1 if the distribution is +#pod filtered (to be skipped). Returns 0 if the distribution is to not filtered +#pod (not to be skipped). +#pod +#pod =end devel +#pod +#pod =cut + +sub __do_filter { + my ($self, $filter, $file) = @_; + return unless $filter; + + if (ref($filter) eq 'ARRAY') { + for (@$filter) { + return 1 if $self->__do_filter($_, $file); + } + return; + } + + if (ref($filter) eq 'CODE') { + return $filter->($file); + } else { + return $file =~ $filter; + } +} + +sub _filter_module { + my $self = shift; + my $args = shift; + + if ($self->{skip_perl}) { + return 1 if $args->{path} =~ m{/(?:emb|syb|bio)?perl-\d}i; + return 1 if $args->{path} =~ m{/(?:parrot|ponie)-\d}i; + return 1 if $args->{path} =~ m{/(?:kurila)-\d}i; + return 1 if $args->{path} =~ m{/\bperl-?5\.004}i; + return 1 if $args->{path} =~ m{/\bperl_mlb\.zip}i; + } + + return 1 if $self->__do_filter($self->{path_filters}, $args->{path}); + return 1 if $self->__do_filter($self->{module_filters}, $args->{module}); + return 0; +} + +#pod =method file_allowed +#pod +#pod next unless $minicpan->file_allowed($filename); +#pod +#pod This method returns true if the given file is allowed to exist in the local +#pod mirror, even if it isn't one of the required mirror files. +#pod +#pod By default, only dot-files are allowed. If the C option is true, +#pod all files are allowed. +#pod +#pod =cut + +sub file_allowed { + my ($self, $file) = @_; + return 1 if $self->{exact_mirror}; + + # It's a cheap hack, but it gets the job done. + return 1 if $file eq File::Spec->catfile($self->{local}, 'RECENT'); + + return (substr(File::Basename::basename($file), 0, 1) eq q{.}) ? 1 : 0; +} + +#pod =method clean_unmirrored +#pod +#pod $minicpan->clean_unmirrored; +#pod +#pod This method looks through the local mirror's files. If it finds a file that +#pod neither belongs in the mirror nor is allowed (see the C method), +#pod C is called on the file. +#pod +#pod If you set C to a true value, then this doesn't clean +#pod up files that belong to source control systems. Currently this ignores: +#pod +#pod .cvs .cvsignore +#pod .svn .svnignore +#pod .git .gitignore +#pod +#pod Send patches for other source control files that you would like to have added. +#pod +#pod =cut + +my %Source_control_files; +BEGIN { + %Source_control_files = map { $_ => 1 } + qw(.cvs .svn .git .cvsignore .svnignore .gitignore); +} + +sub clean_unmirrored { + my $self = shift; + + File::Find::find sub { + my $file = File::Spec->canonpath($File::Find::name); ## no critic Package + my $basename = File::Basename::basename( $file ); + + if ( + $self->{ignore_source_control} + and exists $Source_control_files{$basename} + ) { + $File::Find::prune = 1; + return; + } + + return unless (-f $file and not $self->{mirrored}{$file}); + return if $self->file_allowed($file); + + $self->clean_file($file); + + }, $self->{local}; +} + +#pod =method clean_file +#pod +#pod $minicpan->clean_file($filename); +#pod +#pod This method, called by C, deletes the named file. It returns +#pod true if the file is successfully unlinked. Otherwise, it returns false. +#pod +#pod =cut + +sub clean_file { + my ($self, $file) = @_; + + unless (unlink $file) { + $self->log_warn("$file cannot be removed: $!"); + return; + } + + $self->log("$file removed"); + + return 1; +} + +#pod =method log_warn +#pod +#pod =method log +#pod +#pod =method log_debug +#pod +#pod $minicpan->log($message); +#pod +#pod This will log (print) the given message unless the log level is too low. +#pod +#pod C, which logs at the I level, may also be called as C for +#pod backward compatibility reasons. +#pod +#pod =cut + +sub log_level { + return $_[0]->{log_level} if ref $_[0]; + return 'info'; +} + +sub log_unconditionally { + my ($self, $message, $arg) = @_; + $arg ||= {}; + + print($message, $arg->{no_nl} ? () : "\n"); +} + +sub log_warn { + return if $_[0]->log_level eq 'fatal'; + $_[0]->log_unconditionally($_[1], $_[2]); +} + +sub log { + return unless $_[0]->log_level =~ /\A(?:info|debug)\z/; + $_[0]->log_unconditionally($_[1], $_[2]); +} + +sub trace { + my $self = shift; + $self->log(@_); +} + +sub log_debug { + my ($self, @rest) = @_; + return unless $_[0]->log_level eq 'debug'; + $_[0]->log_unconditionally($_[1], $_[2]); +} + +#pod =method read_config +#pod +#pod my %config = CPAN::Mini->read_config(\%options); +#pod +#pod This routine returns a set of arguments that can be passed to CPAN::Mini's +#pod C or C methods. It will look for a file called +#pod F<.minicpanrc> in the user's home directory as determined by +#pod L. +#pod +#pod =cut + +sub __homedir { + my ($class) = @_; + + my $homedir = File::HomeDir->my_home || $ENV{HOME}; + + Carp::croak "couldn't determine your home directory! set HOME env variable" + unless defined $homedir; + + return $homedir; +} + +sub __homedir_configfile { + my ($class) = @_; + my $default = File::Spec->catfile($class->__homedir, '.minicpanrc'); +} + +sub __default_configfile { + my ($self) = @_; + + (my $pm_loc = $INC{'CPAN/Mini.pm'}) =~ s/Mini\.pm\z//; + File::Spec->catfile($pm_loc, 'minicpan.conf'); +} + +sub read_config { + my ($class, $options) = @_; + + my $config_file = $class->config_file($options); + + return unless defined $config_file; + + # This is ugly, but lets us respect -qq for now even before we have an + # object. I think a better fix is warranted. -- rjbs, 2010-03-04 + $class->log("Using config from $config_file") + if ($options->{log_level}||'info') =~ /\A(?:warn|fatal)\z/; + + substr($config_file, 0, 1, $class->__homedir) + if substr($config_file, 0, 1) eq q{~}; + + return unless -e $config_file; + + open my $config_fh, '<', $config_file + or die "couldn't open config file $config_file: $!"; + + my %config; + my %is_multivalue = map {; $_ => 1 } + qw(also_mirror module_filters path_filters); + + $config{$_} = [] for keys %is_multivalue; + + while (<$config_fh>) { + chomp; + next if /\A\s*\Z/sm; + + if (/\A(\w+):\s*(\S.*?)\s*\Z/sm) { + my ($key, $value) = ($1, $2); + + if ($is_multivalue{ $key }) { + push @{ $config{$key} }, split /\s+/, $value; + } else { + $config{ $key } = $value; + } + } + } + + for (qw(also_mirror)) { + $config{$_} = [ grep { length } @{ $config{$_} } ]; + } + + for (qw(module_filters path_filters)) { + $config{$_} = [ map { qr/$_/ } @{ $config{$_} } ]; + } + + for (keys %is_multivalue) { + delete $config{$_} unless @{ $config{$_} }; + } + + return %config; +} + +#pod =method config_file +#pod +#pod my $config_file = CPAN::Mini->config_file( { options } ); +#pod +#pod This routine returns the config file name. It first looks at for the +#pod C setting, then the C environment +#pod variable, then the default F<~/.minicpanrc>, and finally the +#pod F. It uses the first defined value it finds. +#pod If the filename it selects does not exist, it returns false. +#pod +#pod OPTIONS is an optional hash reference of the C config hash. +#pod +#pod =cut + +sub config_file { + my ($class, $options) = @_; + + my $config_file = do { + if (defined eval { $options->{config_file} }) { + $options->{config_file}; + } elsif (defined $ENV{CPAN_MINI_CONFIG}) { + $ENV{CPAN_MINI_CONFIG}; + } elsif (defined $class->__homedir_configfile) { + $class->__homedir_configfile; + } elsif (defined $class->__default_configfile) { + $class->__default_configfile; + } else { + (); + } + }; + + return ( + (defined $config_file && -e $config_file) + ? $config_file + : () + ); +} + +#pod =head2 remote_from +#pod +#pod my $remote = CPAN::Mini->remote_from( $remote_from, $orig_remote, $quiet ); +#pod +#pod This routine take an string argument and turn it into a method +#pod call to handle to retrieve the a cpan mirror url from a source. +#pod Currently supported methods: +#pod +#pod cpan - fetch the first mirror from your CPAN.pm config +#pod cpanplus - fetch the first mirror from your CPANPLUS.pm config +#pod +#pod =cut + +sub remote_from { + my ( $class, $remote_from, $orig_remote, $quiet ) = @_; + + my $method = lc "remote_from_" . $remote_from; + + Carp::croak "unknown remote_from value: $remote_from" + unless $class->can($method); + + my $new_remote = $class->$method; + + warn "overriding '$orig_remote' with '$new_remote' via $method\n" + if !$quiet && $orig_remote; + + return $new_remote; +} + +#pod =head2 remote_from_cpan +#pod +#pod my $remote = CPAN::Mini->remote_from_cpan; +#pod +#pod This routine loads your CPAN.pm config and returns the first mirror in mirror +#pod list. You can set this as your default by setting remote_from:cpan in your +#pod F<.minicpanrc> file. +#pod +#pod =cut + +sub remote_from_cpan { + my ($self) = @_; + + Carp::croak "unable find a CPAN, maybe you need to install it" + unless eval { require CPAN; 1 }; + + CPAN::HandleConfig::require_myconfig_or_config(); + + Carp::croak "unable to find mirror list in your CPAN config" + unless exists $CPAN::Config->{urllist}; + + Carp::croak "unable to find first mirror url in your CPAN config" + unless ref( $CPAN::Config->{urllist} ) eq 'ARRAY' && $CPAN::Config->{urllist}[0]; + + return $CPAN::Config->{urllist}[0]; +} + +#pod =head2 remote_from_cpanplus +#pod +#pod my $remote = CPAN::Mini->remote_from_cpanplus; +#pod +#pod This routine loads your CPANPLUS.pm config and returns the first mirror in +#pod mirror list. You can set this as your default by setting remote_from:cpanplus +#pod in your F<.minicpanrc> file. +#pod +#pod =cut + +sub remote_from_cpanplus { + my ($self) = @_; + + Carp::croak "unable find a CPANPLUS, maybe you need to install it" + unless eval { require CPANPLUS::Backend }; + + my $cb = CPANPLUS::Backend->new; + my $hosts = $cb->configure_object->get_conf('hosts'); + + Carp::croak "unable to find mirror list in your CPANPLUS config" + unless $hosts; + + Carp::croak "unable to find first mirror in your CPANPLUS config" + unless ref($hosts) eq 'ARRAY' && $hosts->[0]; + + my $url_parts = $hosts->[0]; + return $url_parts->{scheme} . "://" . $url_parts->{host} . ( $url_parts->{path} || '' ); +} + +#pod =head1 SEE ALSO +#pod +#pod Randal Schwartz's original article on minicpan, here: +#pod +#pod http://www.stonehenge.com/merlyn/LinuxMag/col42.html +#pod +#pod L, which provides the C method, which performs +#pod the same task as this module. +#pod +#pod =head1 THANKS +#pod +#pod Thanks to David Dyck for letting me know about my stupid documentation errors. +#pod +#pod Thanks to Roy Fulbright for finding an obnoxious bug on Win32. +#pod +#pod Thanks to Shawn Sorichetti for fixing a stupid octal-number-as-string bug. +#pod +#pod Thanks to sungo for implementing the filters, so I can finally stop mirroring +#pod bioperl, and Robert Rothenberg for suggesting adding coderef rules. +#pod +#pod Thanks to Adam Kennedy for noticing and complaining about a lot of stupid +#pod little design decisions. +#pod +#pod Thanks to Michael Schwern and Jason Kohles, for pointing out missing +#pod documentation. +#pod +#pod Thanks to David Golden for some important bugfixes and refactoring. +#pod +#pod =cut + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +CPAN::Mini - create a minimal mirror of CPAN + +=head1 VERSION + +version 1.111016 + +=head1 SYNOPSIS + +(If you're not going to do something weird, you probably want to look at the +L command, instead.) + + use CPAN::Mini; + + CPAN::Mini->update_mirror( + remote => "http://cpan.mirrors.comintern.su", + local => "/usr/share/mirrors/cpan", + log_level => 'debug', + ); + +=head1 DESCRIPTION + +CPAN::Mini provides a simple mechanism to build and update a minimal mirror of +the CPAN on your local disk. It contains only those files needed to install +the newest version of every distribution. Those files are: + +=over 4 + +=item * + +01mailrc.txt.gz + +=item * + +02packages.details.txt.gz + +=item * + +03modlist.data.gz + +=item * + +the last non-developer release of every dist for every author + +=back + +=head1 METHODS + +=head2 update_mirror + + CPAN::Mini->update_mirror( + remote => "http://cpan.mirrors.comintern.su", + local => "/usr/share/mirrors/cpan", + force => 0, + log_level => 'debug', + ); + +This is the only method that need be called from outside this module. It will +update the local mirror with the files from the remote mirror. + +If called as a class method, C creates an ephemeral CPAN::Mini +object on which other methods are called. That object is used to store mirror +location and state. + +This method returns the number of files updated. + +The following options are recognized: + +=over 4 + +=item * + +C + +This is the local file path where the mirror will be written or updated. + +=item * + +C + +This is the URL of the CPAN mirror from which to work. A reasonable default +will be picked by default. A list of CPAN mirrors can be found at +L + +=item * + +C + +Generally an octal number, this option sets the permissions of created +directories. It defaults to 0711. + +=item * + +C + +If true, the C method will allow all extra files to be mirrored. + +=item * + +C + +If true, CPAN::Mini will not try to remove source control files during +cleanup. See C for details. + +=item * + +C + +If true, this option will cause CPAN::Mini to read the entire module list and +update anything out of date, even if the module list itself wasn't out of date +on this run. + +=item * + +C + +If true, CPAN::Mini will skip the major language distributions: perl, parrot, +and ponie. It will also skip embperl, sybperl, bioperl, and kurila. + +=item * + +C + +This defines the minimum level of message to log: debug, info, warn, or fatal + +=item * + +C + +If true, CPAN::Mini will warn with status messages on errors. (default: true) + +=item * + +C + +This options provides a set of rules for filtering paths. If a distribution +matches one of the rules in C, it will not be mirrored. A regex +rule is matched if the path matches the regex; a code rule is matched if the +code returns 1 when the path is passed to it. For example, the following +setting would skip all distributions from RJBS and SUNGO: + + path_filters => [ + qr/RJBS/, + sub { $_[0] =~ /SUNGO/ } + ] + +=item * + +C + +This option provides a set of rules for filtering modules. It behaves like +path_filters, but acts only on module names. (Since most modules are in +distributions with more than one module, this setting will probably be less +useful than C.) For example, this setting will skip any +distribution containing only modules with the word "Acme" in them: + + module_filters => [ qr/Acme/i ] + +=item * + +C + +This option should be an arrayref of extra files in the remote CPAN to mirror +locally. + +=item * + +C + +If this option is true, CPAN::Mini will not try delete unmirrored files when it +has finished mirroring + +=item * + +C + +If offline, CPAN::Mini will not attempt to contact remote resources. + +=item * + +C + +If true, no connection cache will be established. This is mostly useful as a +workaround for connection cache failures. + +=back + +=head2 new + + my $minicpan = CPAN::Mini->new; + +This method constructs a new CPAN::Mini object. Its parameters are described +above, under C. + +=head2 mirror_indices + + $minicpan->mirror_indices; + +This method updates the index files from the CPAN. + +=head2 mirror_file + + $minicpan->mirror_file($path, $skip_if_present) + +This method will mirror the given file from the remote to the local mirror, +overwriting any existing file unless C<$skip_if_present> is true. + +=head2 file_allowed + + next unless $minicpan->file_allowed($filename); + +This method returns true if the given file is allowed to exist in the local +mirror, even if it isn't one of the required mirror files. + +By default, only dot-files are allowed. If the C option is true, +all files are allowed. + +=head2 clean_unmirrored + + $minicpan->clean_unmirrored; + +This method looks through the local mirror's files. If it finds a file that +neither belongs in the mirror nor is allowed (see the C method), +C is called on the file. + +If you set C to a true value, then this doesn't clean +up files that belong to source control systems. Currently this ignores: + + .cvs .cvsignore + .svn .svnignore + .git .gitignore + +Send patches for other source control files that you would like to have added. + +=head2 clean_file + + $minicpan->clean_file($filename); + +This method, called by C, deletes the named file. It returns +true if the file is successfully unlinked. Otherwise, it returns false. + +=head2 log_warn + +=head2 log + +=head2 log_debug + + $minicpan->log($message); + +This will log (print) the given message unless the log level is too low. + +C, which logs at the I level, may also be called as C for +backward compatibility reasons. + +=head2 read_config + + my %config = CPAN::Mini->read_config(\%options); + +This routine returns a set of arguments that can be passed to CPAN::Mini's +C or C methods. It will look for a file called +F<.minicpanrc> in the user's home directory as determined by +L. + +=head2 config_file + + my $config_file = CPAN::Mini->config_file( { options } ); + +This routine returns the config file name. It first looks at for the +C setting, then the C environment +variable, then the default F<~/.minicpanrc>, and finally the +F. It uses the first defined value it finds. +If the filename it selects does not exist, it returns false. + +OPTIONS is an optional hash reference of the C config hash. + +=begin devel + +=method _filter_module + + next + if $self->_filter_module({ module => $foo, version => $foo, path => $foo }); + +This method holds the filter chain logic. C takes an optional +set of filter parameters. As C encounters a distribution, it +calls this method to figure out whether or not it should be downloaded. The +user provided filters are taken into account. Returns 1 if the distribution is +filtered (to be skipped). Returns 0 if the distribution is to not filtered +(not to be skipped). + +=end devel + +=head2 remote_from + + my $remote = CPAN::Mini->remote_from( $remote_from, $orig_remote, $quiet ); + +This routine take an string argument and turn it into a method +call to handle to retrieve the a cpan mirror url from a source. +Currently supported methods: + + cpan - fetch the first mirror from your CPAN.pm config + cpanplus - fetch the first mirror from your CPANPLUS.pm config + +=head2 remote_from_cpan + + my $remote = CPAN::Mini->remote_from_cpan; + +This routine loads your CPAN.pm config and returns the first mirror in mirror +list. You can set this as your default by setting remote_from:cpan in your +F<.minicpanrc> file. + +=head2 remote_from_cpanplus + + my $remote = CPAN::Mini->remote_from_cpanplus; + +This routine loads your CPANPLUS.pm config and returns the first mirror in +mirror list. You can set this as your default by setting remote_from:cpanplus +in your F<.minicpanrc> file. + +=head1 SEE ALSO + +Randal Schwartz's original article on minicpan, here: + + http://www.stonehenge.com/merlyn/LinuxMag/col42.html + +L, which provides the C method, which performs +the same task as this module. + +=head1 THANKS + +Thanks to David Dyck for letting me know about my stupid documentation errors. + +Thanks to Roy Fulbright for finding an obnoxious bug on Win32. + +Thanks to Shawn Sorichetti for fixing a stupid octal-number-as-string bug. + +Thanks to sungo for implementing the filters, so I can finally stop mirroring +bioperl, and Robert Rothenberg for suggesting adding coderef rules. + +Thanks to Adam Kennedy for noticing and complaining about a lot of stupid +little design decisions. + +Thanks to Michael Schwern and Jason Kohles, for pointing out missing +documentation. + +Thanks to David Golden for some important bugfixes and refactoring. + +=head1 AUTHORS + +=over 4 + +=item * + +Ricardo SIGNES + +=item * + +Randal Schwartz + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2004 by Ricardo SIGNES. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/lib/CPAN/Mini/App.pm b/lib/CPAN/Mini/App.pm new file mode 100644 index 0000000..29b4c69 --- /dev/null +++ b/lib/CPAN/Mini/App.pm @@ -0,0 +1,209 @@ +use strict; +use warnings; + +package CPAN::Mini::App; +$CPAN::Mini::App::VERSION = '1.111016'; +# ABSTRACT: the guts of the minicpan command + +#pod =head1 SYNOPSIS +#pod +#pod #!/usr/bin/perl +#pod use CPAN::Mini::App; +#pod CPAN::Mini::App->run; +#pod +#pod =cut + +use CPAN::Mini; +use File::HomeDir; +use File::Spec; +use Getopt::Long qw(:config no_ignore_case); +use Pod::Usage 1.00; + +sub _display_version { + my $class = shift; + no strict 'refs'; + print "minicpan", + ($class ne 'CPAN::Mini' ? ' (from CPAN::Mini)' : q{}), + ", powered by $class ", $class->VERSION, "\n\n"; + exit; +} + +#pod =method run +#pod +#pod This method is called by F to do all the work. Don't rely on what it +#pod does just yet. +#pod +#pod =cut + +sub _validate_log_level { + my ($class, $level) = @_; + return $level if $level =~ /\A(?:fatal|warn|debug|info)\z/; + die "unknown logging level: $level\n"; +} + +sub run { + my ($class) = @_; + + my $minicpan = $class->initialize_minicpan; + + $minicpan->update_mirror; +} + +sub initialize_minicpan { + my ($class) = @_; + + my $version; + + my %commandline; + + my @option_spec = $class->_option_spec(); + GetOptions(\%commandline, @option_spec) or pod2usage(2); + + # These two options will cause the program to exit before finishing ->run + pod2usage(1) if $commandline{help}; + $version = 1 if $commandline{version}; + + # How noisy should we be? + my $debug = $commandline{debug}; + my $log_level = $commandline{log_level}; + my $quiet = $commandline{qq} ? 2 : $commandline{quiet}; + + die "can't mix --debug, --log-level, and --debug\n" + if defined($quiet) + defined($debug) + defined($log_level) > 1; + + # Set log_level accordingly + $quiet ||= 0; + $log_level = $debug ? 'debug' + : $quiet == 1 ? 'warn' + : $quiet >= 2 ? 'fatal' + : $log_level ? $log_level + : undef; + + my %config = CPAN::Mini->read_config({ + log_level => 'info', + %commandline + }); + + $config{class} ||= 'CPAN::Mini'; + + # Override config with commandline options + %config = (%config, %commandline); + + $config{log_level} = $log_level || $config{log_level} || 'info'; + $class->_validate_log_level($config{log_level}); + + eval "require $config{class}"; + die $@ if $@; + + _display_version($config{class}) if $version; + + if ($config{remote_from} && ! $config{remote}) { + $config{remote} = $config{class}->remote_from( + $config{remote_from}, + $config{remote}, + $config{quiet}, + ); + } + + $config{remote} ||= 'http://www.cpan.org/'; + + pod2usage(2) unless $config{local} and $config{remote}; + + $|++; + + # Convert dirmode string to a real octal value, if given + $config{dirmode} = oct $config{dirmode} if $config{dirmode}; + + # Turn the 'perl' option into 'skip_perl', for backward compatibility + $config{skip_perl} = not delete $config{perl}; + + return $config{class}->new(%config); +} + +sub _option_spec { + return qw< + class|c=s + help|h + version|v + quiet|q+ + qq + debug + log_level|log-level=s + local|l=s + remote|r=s + dirmode|d=s + offline + force|f + perl + exact_mirror|x + timeout|t=i + config_file|config|C=s + remote-from=s + >; +} + +#pod =head1 SEE ALSO +#pod +#pod Randal Schwartz's original article, which can be found here: +#pod +#pod http://www.stonehenge.com/merlyn/LinuxMag/col42.html +#pod +#pod =cut + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +CPAN::Mini::App - the guts of the minicpan command + +=head1 VERSION + +version 1.111016 + +=head1 SYNOPSIS + + #!/usr/bin/perl + use CPAN::Mini::App; + CPAN::Mini::App->run; + +=head1 METHODS + +=head2 run + +This method is called by F to do all the work. Don't rely on what it +does just yet. + +=head1 SEE ALSO + +Randal Schwartz's original article, which can be found here: + + http://www.stonehenge.com/merlyn/LinuxMag/col42.html + +=head1 AUTHORS + +=over 4 + +=item * + +Ricardo SIGNES + +=item * + +Randal Schwartz + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2004 by Ricardo SIGNES. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut -- cgit v1.2.1