File Coverage

blib/lib/App/CPAN/Get.pm
Criterion Covered Total %
statement 49 66 74.2
branch 5 16 31.2
condition 2 6 33.3
subroutine 12 12 100.0
pod 2 2 100.0
total 70 102 68.6


line stmt bran cond sub pod time code
1             package App::CPAN::Get;
2              
3 4     4   59522 use strict;
  4         28  
  4         95  
4 4     4   17 use warnings;
  4         5  
  4         107  
5              
6 4     4   1348 use App::CPAN::Get::Utils qw(process_module_name_and_version);
  4         9  
  4         73  
7 4     4   1840 use Class::Utils qw(set_params);
  4         83512  
  4         63  
8 4     4   249 use Error::Pure qw(err);
  4         6  
  4         125  
9 4     4   6661 use Getopt::Std;
  4         180  
  4         202  
10 4     4   1465 use IO::Barf qw(barf);
  4         2070  
  4         50  
11 4     4   2420 use LWP::UserAgent;
  4         162184  
  4         141  
12 4     4   1606 use Menlo::Index::MetaCPAN;
  4         73598  
  4         140  
13 4     4   1538 use URI::cpan;
  4         32299  
  4         1760  
14              
15             our $VERSION = 0.08;
16              
17             # Constructor.
18             sub new {
19 4     4 1 4731 my ($class, @params) = @_;
20              
21             # Create object.
22 4         10 my $self = bless {}, $class;
23              
24             # LWP::User agent object.
25 4         14 $self->{'lwp_user_agent'} = undef;
26              
27             # Process parameters.
28 4         15 set_params($self, @params);
29              
30 4 100       41 if (defined $self->{'lwp_user_agent'}) {
31 2 100       14 if (! $self->{'lwp_user_agent'}->isa('LWP::UserAgent')) {
32 1         5 err "Parameter 'lwp_user_agent' must be a ".
33             'LWP::UserAgent instance.';
34             }
35             } else {
36 2         12 $self->{'lwp_user_agent'} = LWP::UserAgent->new;
37 2         5300 $self->{'lwp_user_agent'}->agent(__PACKAGE__.'/'.$VERSION);
38             }
39              
40             # Object.
41 3         136 return $self;
42             }
43              
44             # Run.
45             sub run {
46 1     1 1 3 my $self = shift;
47              
48             # Process arguments.
49 1         3 $self->{'_opts'} = {
50             'h' => 0,
51             };
52 1 50 33     5 if (! getopts('h', $self->{'_opts'}) || @ARGV < 1
      33        
53             || $self->{'_opts'}->{'h'}) {
54              
55 1         96 print STDERR "Usage: $0 [-h] [--version] module_name[module_version]\n";
56 1         13 print STDERR "\t-h\t\tPrint help.\n";
57 1         10 print STDERR "\t--version\tPrint version.\n";
58 1         10 print STDERR "\tmodule_name\tModule name. e.g. ".
59             "App::Pod::Example\n";
60 1         9 print STDERR "\tmodule_version\tModule version. e.g. \@1.23, ~1.23 etc.\n";
61 1         5 return 1;
62             }
63 0           $self->{'_module_name_and_version'} = shift @ARGV;
64              
65             # Parse module name and version.
66             ($self->{'_module_name'}, $self->{'_module_version_range'})
67 0           = process_module_name_and_version($self->{'_module_name_and_version'});
68              
69             # Get meta information for module name.
70             # XXX Why not small dist?.
71             my $res = Menlo::Index::MetaCPAN->new->search_packages({
72             'package' => $self->{'_module_name'},
73             exists $self->{'_module_version_range'}
74 0 0         ? ('version_range' => $self->{'_module_version_range'})
75             : (),
76             });
77 0 0         if (! defined $res) {
78 0           err "Module '".$self->{'_module_name'}."' doesn't exist.";
79             }
80              
81             # Download dist.
82 0 0         if (! $res->{'download_uri'}) {
83 0           err "Value 'download_uri' doesn't exist.";
84             }
85 0           my $dist_res = $self->{'lwp_user_agent'}->get($res->{'download_uri'});
86 0 0         if (! $dist_res->is_success) {
87 0           err "Cannot download '$res->{'download_uri'}'.";
88             }
89              
90             # Save to file.
91 0 0         if (! $res->{'uri'}) {
92 0           err "Value 'uri' doesn't exist.";
93             }
94 0           my $u = URI->new($res->{'uri'});
95 0           my $dist_file = ($u->path_segments)[-1];
96 0           barf($dist_file, $dist_res->decoded_content);
97              
98 0           print "Package on '$res->{'download_uri'}' was downloaded.\n";
99            
100 0           return 0;
101             }
102              
103             1;
104              
105             __END__