File Coverage

blib/lib/Alien/Base/ModuleBuild/Repository.pm
Criterion Covered Total %
statement 72 78 92.3
branch 46 52 88.4
condition 25 27 92.5
subroutine 11 16 68.7
pod 0 11 0.0
total 154 184 83.7


line stmt bran cond sub pod time code
1             package Alien::Base::ModuleBuild::Repository;
2              
3 5     5   192816 use strict;
  5         14  
  5         134  
4 5     5   23 use warnings;
  5         9  
  5         111  
5 5     5   22 use Carp;
  5         10  
  5         250  
6 5     5   1834 use Alien::Base::ModuleBuild::File;
  5         13  
  5         160  
7 5     5   1485 use Alien::Base::ModuleBuild::Utils qw/pattern_has_capture_groups/;
  5         11  
  5         3723  
8              
9             # ABSTRACT: Private class
10             our $VERSION = '1.16_01'; # TRIAL VERSION
11             $VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval)
12              
13             sub new {
14 50     50 0 68758 my $class = shift;
15 50 100       177 my (%self) = ref $_[0] ? %{ shift() } : @_;
  32         185  
16              
17 50         133 my $obj = bless \%self, $class;
18              
19             $obj->{c_compiler_required} = 1
20 50 100       190 unless defined $obj->{c_compiler_required};
21              
22 50         101 my $location = $obj->{location};
23 50 100       113 $location = '' unless defined $location;
24              
25 50 100 100     185 if(defined $obj->{exact_filename} && $location !~ m{/$}) {
26 15         40 $obj->{location} = $location . '/'
27             }
28              
29 50         204 return $obj;
30             }
31              
32 8     8 0 22 sub protocol { return shift->{protocol} }
33              
34             sub host {
35 1     1 0 2 my $self = shift;
36 1 50       4 $self->{host} = shift if @_;
37 1         3 return $self->{host};
38             }
39              
40             sub location {
41 27     27 0 117 my $self = shift;
42 27 100       74 $self->{location} = shift if @_;
43 27         113 return $self->{location};
44             }
45              
46             sub is_network_fetch {
47 0     0 0 0 die "must override in the subclass";
48             }
49              
50             sub is_secure_fetch {
51 0     0 0 0 die "must override in the subclass";
52             }
53              
54             sub has_digest
55             {
56 13     13 0 44 my($self) = @_;
57 13 50 100     73 defined $self->{exact_filename} && $self->{exact_version} && (defined $self->{sha1} || defined $self->{sha256});
      66        
58             }
59              
60             sub probe {
61 26     26 0 290 my $self = shift;
62              
63 26         736 require Alien::Base::ModuleBuild;
64 26 100 66     123 if(!Alien::Base::ModuleBuild->alien_install_network && $self->is_network_fetch) {
65 1         12 die "network fetch is disabled via ALIEN_INSTALL_NETWORK";
66             }
67              
68 25         71 my $rule = Alien::Base::ModuleBuild->alien_download_rule;
69 25 100       93 if($rule eq 'warn') {
    100          
    100          
    100          
    50          
70              
71 10 100 100     24 unless($self->is_secure_fetch || $self->has_digest) {
72 1         10 warn "!!! NOTICE OF FUTURE CHANGE IN BEHAVIOR !!!\n";
73 1         19 warn "A future version of Alien::Base::ModuleBuild will die here by default with this exception: File fetch is insecure and has no digest. Required by ALIEN_DOWNLOAD_RULE=digest_or_encrypt.";
74 1         11 warn "!!! NOTICE OF FUTURE CHANGE IN BEHAVIOR !!!\n";
75             }
76              
77             } elsif($rule eq 'digest') {
78              
79 2 100       4 unless($self->has_digest) {
80 1         18 die "File fetch has no digest. Required by ALIEN_DOWNLOAD_RULE=digest.";
81             }
82              
83             } elsif($rule eq 'encrypt') {
84              
85 2 100       5 unless($self->is_secure_fetch) {
86 1         10 die "File fetch is insecure. Secure fetch required by ALIEN_DOWNLOAD_RULE=encrypt.";
87             }
88              
89             } elsif($rule eq 'digest_or_encrypt') {
90              
91 7 100 100     24 unless($self->is_secure_fetch || $self->has_digest) {
92 1         7 die "File fetch is insecure and has no digest. Required by ALIEN_DOWNLOAD_RULE=digest_or_encrypt.";
93             }
94              
95             } elsif($rule eq 'digest_and_encrypt') {
96              
97 4 100 100     18 unless($self->is_secure_fetch && $self->has_digest) {
98 3         28 die "File fetch is insecure and has no digest. Both are required by ALIEN_DOWNLOAD_RULE=digest_and_encrypt.";
99             }
100              
101             } else {
102 0         0 die 'internal error';
103             }
104              
105 19         78 my $pattern = $self->{pattern};
106              
107 19         39 my @files;
108              
109 19 100       44 if ($self->{exact_filename}) {
110             # if filename provided, use that specific file
111 7         15 @files = ($self->{exact_filename});
112             } else {
113 12         33 @files = $self->list_files;
114              
115 12 100       221 if ($pattern) {
116 2         4 @files = grep { $_ =~ $pattern } @files;
  110         239  
117             }
118              
119 12 50       39 carp "Could not find any matching files" unless @files;
120             }
121              
122 19         36 @files = map { +{
123             repository => $self,
124             platform => $self->{platform},
125 429         951 filename => $_,
126             } } @files;
127              
128 19 100 100     108 if ($self->{exact_filename} and $self->{exact_version}) {
    100 100        
129             # if filename and version provided, use a specific version
130 6         11 $files[0]->{version} = $self->{exact_version};
131 6 50       16 $files[0]->{sha1} = $self->{sha1} if defined $self->{sha1};
132 6 100       27 $files[0]->{sha256} = $self->{sha256} if defined $self->{sha256};
133             } elsif ($pattern and pattern_has_capture_groups($pattern)) {
134 1         5 foreach my $file (@files) {
135             $file->{version} = $1
136 17 50       103 if $file->{filename} =~ $pattern;
137             }
138             }
139              
140             @files =
141 19         40 map { Alien::Base::ModuleBuild::File->new($_) }
  429         716  
142             @files;
143              
144 19         150 return @files;
145             }
146              
147             # subclasses are expected to provide
148 0     0 0   sub connection { croak "$_[0] doesn't provide 'connection' method" }
149 0     0 0   sub list_files { croak "$_[0] doesn't provide 'list_files' method" }
150             # get_file must return filename actually used
151 0     0 0   sub get_file { croak "$_[0] doesn't provide 'get_files' method" }
152              
153             1;
154              
155             __END__