line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Perl::Download::FTP; |
2
|
5
|
|
|
5
|
|
2576
|
use strict; |
|
5
|
|
|
|
|
26
|
|
|
5
|
|
|
|
|
124
|
|
3
|
5
|
|
|
5
|
|
23
|
use warnings; |
|
5
|
|
|
|
|
8
|
|
|
5
|
|
|
|
|
101
|
|
4
|
5
|
|
|
5
|
|
58
|
use 5.10.1; |
|
5
|
|
|
|
|
19
|
|
5
|
5
|
|
|
5
|
|
29
|
use Carp; |
|
5
|
|
|
|
|
10
|
|
|
5
|
|
|
|
|
408
|
|
6
|
5
|
|
|
5
|
|
2709
|
use Net::FTP; |
|
5
|
|
|
|
|
459125
|
|
|
5
|
|
|
|
|
265
|
|
7
|
5
|
|
|
5
|
|
2144
|
use File::Copy; |
|
5
|
|
|
|
|
18174
|
|
|
5
|
|
|
|
|
257
|
|
8
|
5
|
|
|
5
|
|
27
|
use Cwd; |
|
5
|
|
|
|
|
9
|
|
|
5
|
|
|
|
|
232
|
|
9
|
5
|
|
|
5
|
|
25
|
use File::Spec; |
|
5
|
|
|
|
|
9
|
|
|
5
|
|
|
|
|
9022
|
|
10
|
|
|
|
|
|
|
our $VERSION = '0.04'; |
11
|
|
|
|
|
|
|
|
12
|
|
|
|
|
|
|
=head1 NAME |
13
|
|
|
|
|
|
|
|
14
|
|
|
|
|
|
|
Perl::Download::FTP - Identify Perl releases and download the most recent via FTP |
15
|
|
|
|
|
|
|
|
16
|
|
|
|
|
|
|
=head1 SYNOPSIS |
17
|
|
|
|
|
|
|
|
18
|
|
|
|
|
|
|
use Perl::Download::FTP; |
19
|
|
|
|
|
|
|
|
20
|
|
|
|
|
|
|
$self = Perl::Download::FTP->new( { |
21
|
|
|
|
|
|
|
host => 'ftp.cpan.org', |
22
|
|
|
|
|
|
|
dir => '/pub/CPAN/src/5.0', |
23
|
|
|
|
|
|
|
verbose => 1, |
24
|
|
|
|
|
|
|
} ); |
25
|
|
|
|
|
|
|
|
26
|
|
|
|
|
|
|
@all_releases = $self->ls(); |
27
|
|
|
|
|
|
|
|
28
|
|
|
|
|
|
|
$classified_releases = $self->classify_releases(); |
29
|
|
|
|
|
|
|
|
30
|
|
|
|
|
|
|
@releases = $self->list_releases( { |
31
|
|
|
|
|
|
|
type => 'production', |
32
|
|
|
|
|
|
|
compression => 'gz', |
33
|
|
|
|
|
|
|
} ); |
34
|
|
|
|
|
|
|
|
35
|
|
|
|
|
|
|
$latest_release = $self->get_latest_release( { |
36
|
|
|
|
|
|
|
compression => 'gz', |
37
|
|
|
|
|
|
|
type => 'dev', |
38
|
|
|
|
|
|
|
path => '/path/to/download', |
39
|
|
|
|
|
|
|
verbose => 1, |
40
|
|
|
|
|
|
|
} ); |
41
|
|
|
|
|
|
|
|
42
|
|
|
|
|
|
|
$specific_release = $self->get_specific_release( { |
43
|
|
|
|
|
|
|
release => 'perl-5.27.2.tar.xz', |
44
|
|
|
|
|
|
|
path => '/path/to/download', |
45
|
|
|
|
|
|
|
} ); |
46
|
|
|
|
|
|
|
|
47
|
|
|
|
|
|
|
=head1 DESCRIPTION |
48
|
|
|
|
|
|
|
|
49
|
|
|
|
|
|
|
This library provides (a) methods for obtaining a list of all Perl 5 releases |
50
|
|
|
|
|
|
|
which are available for FTP download; and (b) a method for obtaining the most |
51
|
|
|
|
|
|
|
recent release. |
52
|
|
|
|
|
|
|
|
53
|
|
|
|
|
|
|
=head2 Compression Formats |
54
|
|
|
|
|
|
|
|
55
|
|
|
|
|
|
|
Perl releases have, over time, used three different compression formats: |
56
|
|
|
|
|
|
|
C, C and C. C is the one that has been used in every |
57
|
|
|
|
|
|
|
production, development and release candidate release, so that is the default |
58
|
|
|
|
|
|
|
value used herein. All three compression formats are available for use herein. |
59
|
|
|
|
|
|
|
|
60
|
|
|
|
|
|
|
=head2 Testing |
61
|
|
|
|
|
|
|
|
62
|
|
|
|
|
|
|
This library can only be truly tested by attempting live FTP connections and |
63
|
|
|
|
|
|
|
downloads of Perl 5 source code tarballs. Since testing over the internet |
64
|
|
|
|
|
|
|
can be problematic when being conducted in an automatic manner or when the |
65
|
|
|
|
|
|
|
user is behind a firewall, the test files under F will only be run live |
66
|
|
|
|
|
|
|
when you say: |
67
|
|
|
|
|
|
|
|
68
|
|
|
|
|
|
|
export PERL_ALLOW_NETWORK_TESTING=1 && make test |
69
|
|
|
|
|
|
|
|
70
|
|
|
|
|
|
|
Each test file further attempts to confirm the possibility of making an FTP |
71
|
|
|
|
|
|
|
connection by using CPAN library Test::RequiresInternet. |
72
|
|
|
|
|
|
|
|
73
|
|
|
|
|
|
|
=head1 METHODS |
74
|
|
|
|
|
|
|
|
75
|
|
|
|
|
|
|
=head2 C |
76
|
|
|
|
|
|
|
|
77
|
|
|
|
|
|
|
=over 4 |
78
|
|
|
|
|
|
|
|
79
|
|
|
|
|
|
|
=item * Purpose |
80
|
|
|
|
|
|
|
|
81
|
|
|
|
|
|
|
Perl::Download::FTP constructor. |
82
|
|
|
|
|
|
|
|
83
|
|
|
|
|
|
|
=item * Arguments |
84
|
|
|
|
|
|
|
|
85
|
|
|
|
|
|
|
$self = Perl::Download::FTP->new(); |
86
|
|
|
|
|
|
|
|
87
|
|
|
|
|
|
|
$self = Perl::Download::FTP->new( { |
88
|
|
|
|
|
|
|
host => 'ftp.cpan.org', |
89
|
|
|
|
|
|
|
dir => '/pub/CPAN/src/5.0', |
90
|
|
|
|
|
|
|
verbose => 1, |
91
|
|
|
|
|
|
|
} ); |
92
|
|
|
|
|
|
|
|
93
|
|
|
|
|
|
|
$self = Perl::Download::FTP->new( { |
94
|
|
|
|
|
|
|
host => 'ftp.cpan.org', |
95
|
|
|
|
|
|
|
dir => '/pub/CPAN/src/5.0', |
96
|
|
|
|
|
|
|
Timeout => 5, |
97
|
|
|
|
|
|
|
} ); |
98
|
|
|
|
|
|
|
|
99
|
|
|
|
|
|
|
Takes a hash reference with, typically, two elements: C and C. |
100
|
|
|
|
|
|
|
Any options which can be passed to F may also be passed as |
101
|
|
|
|
|
|
|
key-value pairs. When no argument is provided, the values shown above for |
102
|
|
|
|
|
|
|
C and C will be used. You may enter values for any CPAN mirror |
103
|
|
|
|
|
|
|
which provides FTP access. (See L and |
104
|
|
|
|
|
|
|
L.) You may also pass C for more |
105
|
|
|
|
|
|
|
descriptive output; by default, this is off. |
106
|
|
|
|
|
|
|
|
107
|
|
|
|
|
|
|
=item * Return Value |
108
|
|
|
|
|
|
|
|
109
|
|
|
|
|
|
|
Perl::Download::FTP object. |
110
|
|
|
|
|
|
|
|
111
|
|
|
|
|
|
|
=item * Comment |
112
|
|
|
|
|
|
|
|
113
|
|
|
|
|
|
|
The method establishes an FTP connection to , logs you in as an |
114
|
|
|
|
|
|
|
anonymous user, and changes directory to C. |
115
|
|
|
|
|
|
|
|
116
|
|
|
|
|
|
|
Wrapper around Net::FTP object. You will get Net::FTP error messages at any |
117
|
|
|
|
|
|
|
point of failure. Uses FTP C mode. |
118
|
|
|
|
|
|
|
|
119
|
|
|
|
|
|
|
=back |
120
|
|
|
|
|
|
|
|
121
|
|
|
|
|
|
|
=cut |
122
|
|
|
|
|
|
|
|
123
|
|
|
|
|
|
|
sub new { |
124
|
2
|
|
|
2
|
1
|
811
|
my ($class, $args) = @_; |
125
|
2
|
|
50
|
|
|
7
|
$args //= {}; |
126
|
2
|
100
|
|
|
|
174
|
croak "Argument to constructor must be hashref" |
127
|
|
|
|
|
|
|
unless ref($args) eq 'HASH'; |
128
|
|
|
|
|
|
|
|
129
|
1
|
|
|
|
|
5
|
my %default_args = ( |
130
|
|
|
|
|
|
|
host => 'ftp.cpan.org', |
131
|
|
|
|
|
|
|
dir => '/pub/CPAN/src/5.0', |
132
|
|
|
|
|
|
|
verbose => 0, |
133
|
|
|
|
|
|
|
); |
134
|
1
|
|
|
|
|
4
|
my $default_args_string = join('|' => keys %default_args); |
135
|
1
|
|
|
|
|
10
|
my %netftp_options = ( |
136
|
|
|
|
|
|
|
Firewall => undef, |
137
|
|
|
|
|
|
|
FirewallType => undef, |
138
|
|
|
|
|
|
|
BlockSize => 10240, |
139
|
|
|
|
|
|
|
Port => undef, |
140
|
|
|
|
|
|
|
SSL => undef, |
141
|
|
|
|
|
|
|
Timeout => 120, |
142
|
|
|
|
|
|
|
Debug => 0, |
143
|
|
|
|
|
|
|
Passive => 1, |
144
|
|
|
|
|
|
|
Hash => undef, |
145
|
|
|
|
|
|
|
LocalAddr => undef, |
146
|
|
|
|
|
|
|
Domain => undef, |
147
|
|
|
|
|
|
|
); |
148
|
1
|
|
|
|
|
4
|
my %permitted_args = map {$_ => 1} ( |
|
14
|
|
|
|
|
20
|
|
149
|
|
|
|
|
|
|
keys %default_args, |
150
|
|
|
|
|
|
|
keys %netftp_options, |
151
|
|
|
|
|
|
|
); |
152
|
|
|
|
|
|
|
|
153
|
1
|
|
|
|
|
3
|
for my $k (keys %{$args}) { |
|
1
|
|
|
|
|
3
|
|
154
|
|
|
|
|
|
|
croak "Argument '$k' not permitted in constructor" |
155
|
1
|
50
|
|
|
|
96
|
unless $permitted_args{$k}; |
156
|
|
|
|
|
|
|
} |
157
|
|
|
|
|
|
|
|
158
|
0
|
|
|
|
|
|
my $data; |
159
|
|
|
|
|
|
|
# Populate object starting with default host and directory |
160
|
0
|
|
|
|
|
|
while (my ($k,$v) = each %default_args) { |
161
|
0
|
|
|
|
|
|
$data->{$k} = $v; |
162
|
|
|
|
|
|
|
} |
163
|
|
|
|
|
|
|
# Then add Net::FTP plausible defaults |
164
|
0
|
|
|
|
|
|
while (my ($k,$v) = each %netftp_options) { |
165
|
0
|
|
|
|
|
|
$data->{$k} = $v; |
166
|
|
|
|
|
|
|
} |
167
|
|
|
|
|
|
|
# Then override with key-value pairs passed to new() |
168
|
0
|
|
|
|
|
|
while (my ($k,$v) = each %{$args}) { |
|
0
|
|
|
|
|
|
|
169
|
0
|
|
|
|
|
|
$data->{$k} = $v; |
170
|
|
|
|
|
|
|
} |
171
|
|
|
|
|
|
|
|
172
|
|
|
|
|
|
|
# For the Net::FTP constructor, we don't need 'dir' and 'host' |
173
|
0
|
|
|
|
|
|
my %passed_netftp_options; |
174
|
0
|
|
|
|
|
|
for my $k (keys %{$data}) { |
|
0
|
|
|
|
|
|
|
175
|
0
|
0
|
|
|
|
|
$passed_netftp_options{$k} = $data->{$k} |
176
|
|
|
|
|
|
|
unless ($k =~ m/^($default_args_string)$/); |
177
|
|
|
|
|
|
|
} |
178
|
|
|
|
|
|
|
|
179
|
0
|
0
|
|
|
|
|
my $ftp = Net::FTP->new($data->{host}, %passed_netftp_options) |
180
|
|
|
|
|
|
|
or croak "Cannot connect to $data->{host}: $@"; |
181
|
|
|
|
|
|
|
|
182
|
0
|
0
|
|
|
|
|
$ftp->login("anonymous",'-anonymous@') |
183
|
|
|
|
|
|
|
or croak "Cannot login ", $ftp->message; |
184
|
|
|
|
|
|
|
|
185
|
|
|
|
|
|
|
$ftp->cwd($data->{dir}) |
186
|
0
|
0
|
|
|
|
|
or croak "Cannot change to working directory $data->{dir}", $ftp->message; |
187
|
|
|
|
|
|
|
|
188
|
0
|
|
|
|
|
|
$data->{ftp} = $ftp; |
189
|
|
|
|
|
|
|
|
190
|
0
|
|
|
|
|
|
my @compressions = (qw| gz bz2 xz |); |
191
|
0
|
|
|
|
|
|
$data->{eligible_compressions} = { map { $_ => 1 } @compressions }; |
|
0
|
|
|
|
|
|
|
192
|
0
|
|
|
|
|
|
$data->{compression_string} = join('|' => @compressions); |
193
|
|
|
|
|
|
|
|
194
|
0
|
|
|
|
|
|
return bless $data, $class; |
195
|
|
|
|
|
|
|
} |
196
|
|
|
|
|
|
|
|
197
|
|
|
|
|
|
|
=head2 C |
198
|
|
|
|
|
|
|
|
199
|
|
|
|
|
|
|
=over 4 |
200
|
|
|
|
|
|
|
|
201
|
|
|
|
|
|
|
=item * Purpose |
202
|
|
|
|
|
|
|
|
203
|
|
|
|
|
|
|
Identify all Perl releases. |
204
|
|
|
|
|
|
|
|
205
|
|
|
|
|
|
|
=item * Arguments |
206
|
|
|
|
|
|
|
|
207
|
|
|
|
|
|
|
@all_releases = $self->ls(); |
208
|
|
|
|
|
|
|
|
209
|
|
|
|
|
|
|
Returns list of all Perl core tarballs on the FTP host. |
210
|
|
|
|
|
|
|
|
211
|
|
|
|
|
|
|
@all_gzipped_releases = $self->ls('gz'); |
212
|
|
|
|
|
|
|
|
213
|
|
|
|
|
|
|
Returns list of only those all tarballs on the FTP host which are compressed |
214
|
|
|
|
|
|
|
in C<.gz> format. Also available (in separate calls): C, C. |
215
|
|
|
|
|
|
|
|
216
|
|
|
|
|
|
|
=item * Return Value |
217
|
|
|
|
|
|
|
|
218
|
|
|
|
|
|
|
List of strings like: |
219
|
|
|
|
|
|
|
|
220
|
|
|
|
|
|
|
"perl-5.10.0-RC2.tar.gz", |
221
|
|
|
|
|
|
|
"perl-5.10.0.tar.gz", |
222
|
|
|
|
|
|
|
"perl-5.26.0.tar.gz", |
223
|
|
|
|
|
|
|
"perl-5.26.1-RC1.tar.gz", |
224
|
|
|
|
|
|
|
"perl-5.27.0.tar.gz", |
225
|
|
|
|
|
|
|
"perl-5.6.0.tar.gz", |
226
|
|
|
|
|
|
|
"perl-5.6.1-TRIAL1.tar.gz", |
227
|
|
|
|
|
|
|
"perl-5.6.1-TRIAL2.tar.gz", |
228
|
|
|
|
|
|
|
"perl-5.6.1-TRIAL3.tar.gz", |
229
|
|
|
|
|
|
|
"perl5.003_07.tar.gz", |
230
|
|
|
|
|
|
|
"perl5.004.tar.gz", |
231
|
|
|
|
|
|
|
"perl5.004_01.tar.gz", |
232
|
|
|
|
|
|
|
"perl5.005.tar.gz", |
233
|
|
|
|
|
|
|
"perl5.005_01.tar.gz", |
234
|
|
|
|
|
|
|
|
235
|
|
|
|
|
|
|
"perl-5.10.1.tar.bz2", |
236
|
|
|
|
|
|
|
"perl-5.12.2-RC1.tar.bz2", |
237
|
|
|
|
|
|
|
"perl-5.26.1-RC1.tar.bz2", |
238
|
|
|
|
|
|
|
"perl-5.27.0.tar.bz2", |
239
|
|
|
|
|
|
|
"perl-5.8.9.tar.bz2", |
240
|
|
|
|
|
|
|
|
241
|
|
|
|
|
|
|
"perl-5.21.10.tar.xz", |
242
|
|
|
|
|
|
|
"perl-5.21.6.tar.xz", |
243
|
|
|
|
|
|
|
"perl-5.22.0-RC1.tar.xz", |
244
|
|
|
|
|
|
|
"perl-5.22.0.tar.xz", |
245
|
|
|
|
|
|
|
"perl-5.22.1-RC4.tar.xz", |
246
|
|
|
|
|
|
|
"perl-5.26.1.tar.xz", |
247
|
|
|
|
|
|
|
"perl-5.27.2.tar.xz", |
248
|
|
|
|
|
|
|
|
249
|
|
|
|
|
|
|
=back |
250
|
|
|
|
|
|
|
|
251
|
|
|
|
|
|
|
=cut |
252
|
|
|
|
|
|
|
|
253
|
|
|
|
|
|
|
sub ls { |
254
|
0
|
|
|
0
|
1
|
|
my ($self, $compression) = @_; |
255
|
0
|
0
|
|
|
|
|
if (! defined $compression) { |
256
|
0
|
|
|
|
|
|
$compression = $self->{compression_string}; |
257
|
|
|
|
|
|
|
} |
258
|
|
|
|
|
|
|
else { |
259
|
|
|
|
|
|
|
croak "ls(): Bad compression format: $compression" |
260
|
0
|
0
|
|
|
|
|
unless $self->{eligible_compressions}{$compression}; |
261
|
|
|
|
|
|
|
} |
262
|
|
|
|
|
|
|
my @all_releases = grep { |
263
|
0
|
|
|
|
|
|
/^perl |
264
|
|
|
|
|
|
|
(?: |
265
|
|
|
|
|
|
|
-5\.\d+\.\d+ # 5.6.0 and above |
266
|
|
|
|
|
|
|
| |
267
|
|
|
|
|
|
|
5\.00\d(_\d{2})? # 5.003_007 thru 5.005 |
268
|
|
|
|
|
|
|
) |
269
|
|
|
|
|
|
|
.*? # Account for RC and TRIAL |
270
|
|
|
|
|
|
|
\.tar # We only want tarballs |
271
|
|
|
|
|
|
|
\.(?:${compression}) # Compression format |
272
|
|
|
|
|
|
|
$/x |
273
|
|
|
|
|
|
|
} $self->{ftp}->ls() |
274
|
0
|
0
|
|
|
|
|
or croak "Unable to perform FTP 'get' call to host: $!"; |
275
|
0
|
|
|
|
|
|
$self->{all_releases} = \@all_releases; |
276
|
0
|
|
|
|
|
|
my $location = "ftp://$self->{host}$self->{dir}"; |
277
|
|
|
|
|
|
|
say "Identified ", |
278
|
|
|
|
|
|
|
scalar(@all_releases), |
279
|
|
|
|
|
|
|
" perl releases at $location" |
280
|
0
|
0
|
|
|
|
|
if $self->{verbose}; |
281
|
0
|
|
|
|
|
|
return @all_releases; |
282
|
|
|
|
|
|
|
} |
283
|
|
|
|
|
|
|
|
284
|
|
|
|
|
|
|
=head2 C |
285
|
|
|
|
|
|
|
|
286
|
|
|
|
|
|
|
=over 4 |
287
|
|
|
|
|
|
|
|
288
|
|
|
|
|
|
|
=item * Purpose |
289
|
|
|
|
|
|
|
|
290
|
|
|
|
|
|
|
Categorize releases as production, development or RC (release candidate). |
291
|
|
|
|
|
|
|
|
292
|
|
|
|
|
|
|
=item * Arguments |
293
|
|
|
|
|
|
|
|
294
|
|
|
|
|
|
|
None. Works on data stored in object by C. |
295
|
|
|
|
|
|
|
|
296
|
|
|
|
|
|
|
=item * Return Value |
297
|
|
|
|
|
|
|
|
298
|
|
|
|
|
|
|
Hash reference. |
299
|
|
|
|
|
|
|
|
300
|
|
|
|
|
|
|
=back |
301
|
|
|
|
|
|
|
|
302
|
|
|
|
|
|
|
=cut |
303
|
|
|
|
|
|
|
|
304
|
|
|
|
|
|
|
sub classify_releases { |
305
|
0
|
|
|
0
|
1
|
|
my $self = shift; |
306
|
|
|
|
|
|
|
|
307
|
0
|
|
|
|
|
|
my %versions; |
308
|
0
|
|
|
|
|
|
for my $tb (@{$self->{all_releases}}) { |
|
0
|
|
|
|
|
|
|
309
|
0
|
|
|
|
|
|
my ($major, $minor, $rc); |
310
|
0
|
0
|
|
|
|
|
if ($tb =~ m/^ |
|
|
0
|
|
|
|
|
|
311
|
|
|
|
|
|
|
perl-5\.(\d+) |
312
|
|
|
|
|
|
|
\.(\d+) |
313
|
|
|
|
|
|
|
(?:-((?:TRIAL|RC)\d+))? |
314
|
|
|
|
|
|
|
\.tar\.(?:gz|bz2|xz) |
315
|
|
|
|
|
|
|
$/x) { |
316
|
0
|
|
|
|
|
|
($major, $minor, $rc) = ($1,$2,$3); |
317
|
0
|
0
|
|
|
|
|
if ($major % 2 == 0) { |
318
|
0
|
0
|
|
|
|
|
unless (defined $rc) { |
319
|
0
|
|
|
|
|
|
$versions{prod}{$tb} = { |
320
|
|
|
|
|
|
|
tarball => $tb, |
321
|
|
|
|
|
|
|
major => $major, |
322
|
|
|
|
|
|
|
minor => $minor, |
323
|
|
|
|
|
|
|
} |
324
|
|
|
|
|
|
|
} |
325
|
|
|
|
|
|
|
else { |
326
|
0
|
|
|
|
|
|
$versions{rc}{$tb} = { |
327
|
|
|
|
|
|
|
tarball => $tb, |
328
|
|
|
|
|
|
|
major => $major, |
329
|
|
|
|
|
|
|
minor => $minor, |
330
|
|
|
|
|
|
|
rc => $rc, |
331
|
|
|
|
|
|
|
} |
332
|
|
|
|
|
|
|
} |
333
|
|
|
|
|
|
|
} |
334
|
|
|
|
|
|
|
else { |
335
|
0
|
|
|
|
|
|
$versions{dev}{$tb} = { |
336
|
|
|
|
|
|
|
tarball => $tb, |
337
|
|
|
|
|
|
|
major => $major, |
338
|
|
|
|
|
|
|
minor => $minor, |
339
|
|
|
|
|
|
|
} |
340
|
|
|
|
|
|
|
} |
341
|
|
|
|
|
|
|
} |
342
|
|
|
|
|
|
|
elsif ($tb =~ m/^ |
343
|
|
|
|
|
|
|
perl5\. |
344
|
|
|
|
|
|
|
(00\d) |
345
|
|
|
|
|
|
|
(?:_(\d{2}))? # 5.003_007 thru 5.005; account for RC and TRIAL |
346
|
|
|
|
|
|
|
.*? |
347
|
|
|
|
|
|
|
\.tar # We only want tarballs |
348
|
|
|
|
|
|
|
\.gz # Compression format |
349
|
|
|
|
|
|
|
$/x |
350
|
|
|
|
|
|
|
) { |
351
|
0
|
|
|
|
|
|
my $early_dev; |
352
|
0
|
|
|
|
|
|
($major, $early_dev) = ($1,$2); |
353
|
0
|
|
0
|
|
|
|
$early_dev //= ''; |
354
|
0
|
0
|
|
|
|
|
if (! $early_dev) { |
355
|
0
|
|
|
|
|
|
$versions{prod}{$tb} = { |
356
|
|
|
|
|
|
|
tarball => $tb, |
357
|
|
|
|
|
|
|
major => $major, |
358
|
|
|
|
|
|
|
minor => '', |
359
|
|
|
|
|
|
|
} |
360
|
|
|
|
|
|
|
} |
361
|
|
|
|
|
|
|
else { |
362
|
0
|
|
|
|
|
|
$versions{dev}{$tb} = { |
363
|
|
|
|
|
|
|
tarball => $tb, |
364
|
|
|
|
|
|
|
major => $major, |
365
|
|
|
|
|
|
|
minor => $early_dev, |
366
|
|
|
|
|
|
|
} |
367
|
|
|
|
|
|
|
} |
368
|
|
|
|
|
|
|
} |
369
|
|
|
|
|
|
|
} |
370
|
0
|
|
|
|
|
|
$self->{versions} = \%versions; |
371
|
0
|
|
|
|
|
|
return \%versions; |
372
|
|
|
|
|
|
|
} |
373
|
|
|
|
|
|
|
|
374
|
|
|
|
|
|
|
sub _compression_check { |
375
|
0
|
|
|
0
|
|
|
my ($self, $compression) = @_; |
376
|
0
|
0
|
|
|
|
|
if (! defined $compression) { |
377
|
0
|
|
|
|
|
|
return 'gz'; |
378
|
|
|
|
|
|
|
} |
379
|
|
|
|
|
|
|
else { |
380
|
|
|
|
|
|
|
croak "ls(): Bad compression format: $compression" |
381
|
0
|
0
|
|
|
|
|
unless $self->{eligible_compressions}{$compression}; |
382
|
0
|
|
|
|
|
|
return $compression; |
383
|
|
|
|
|
|
|
} |
384
|
|
|
|
|
|
|
} |
385
|
|
|
|
|
|
|
|
386
|
|
|
|
|
|
|
sub _prepare_list { |
387
|
0
|
|
|
0
|
|
|
my ($self, $compression) = @_; |
388
|
0
|
|
|
|
|
|
$compression = $self->_compression_check($compression); |
389
|
|
|
|
|
|
|
|
390
|
0
|
0
|
|
|
|
|
unless (exists $self->{versions}) { |
391
|
0
|
|
|
|
|
|
$self->classify_releases(); |
392
|
|
|
|
|
|
|
} |
393
|
0
|
|
|
|
|
|
return $compression; |
394
|
|
|
|
|
|
|
} |
395
|
|
|
|
|
|
|
|
396
|
|
|
|
|
|
|
=head2 C |
397
|
|
|
|
|
|
|
|
398
|
|
|
|
|
|
|
=over 4 |
399
|
|
|
|
|
|
|
|
400
|
|
|
|
|
|
|
=item * Purpose |
401
|
|
|
|
|
|
|
|
402
|
|
|
|
|
|
|
List all releases for a specified compression format and release type, sorted |
403
|
|
|
|
|
|
|
in reverse logical order. |
404
|
|
|
|
|
|
|
|
405
|
|
|
|
|
|
|
=item * Arguments |
406
|
|
|
|
|
|
|
|
407
|
|
|
|
|
|
|
@releases = $self->list_releases( { |
408
|
|
|
|
|
|
|
type => 'production', |
409
|
|
|
|
|
|
|
compression => 'gz', |
410
|
|
|
|
|
|
|
} ); |
411
|
|
|
|
|
|
|
|
412
|
|
|
|
|
|
|
Takes a hash reference with, typically two elements: |
413
|
|
|
|
|
|
|
|
414
|
|
|
|
|
|
|
=over 4 |
415
|
|
|
|
|
|
|
|
416
|
|
|
|
|
|
|
=item * C |
417
|
|
|
|
|
|
|
|
418
|
|
|
|
|
|
|
Available values: |
419
|
|
|
|
|
|
|
|
420
|
|
|
|
|
|
|
gz bz2 xz |
421
|
|
|
|
|
|
|
|
422
|
|
|
|
|
|
|
Defaults to C. |
423
|
|
|
|
|
|
|
|
424
|
|
|
|
|
|
|
=item * C |
425
|
|
|
|
|
|
|
|
426
|
|
|
|
|
|
|
Available values: |
427
|
|
|
|
|
|
|
|
428
|
|
|
|
|
|
|
production prod |
429
|
|
|
|
|
|
|
development dev |
430
|
|
|
|
|
|
|
rc |
431
|
|
|
|
|
|
|
|
432
|
|
|
|
|
|
|
Defaults to C. |
433
|
|
|
|
|
|
|
|
434
|
|
|
|
|
|
|
=back |
435
|
|
|
|
|
|
|
|
436
|
|
|
|
|
|
|
=item * Return Value |
437
|
|
|
|
|
|
|
|
438
|
|
|
|
|
|
|
List of strings naming Perl release tarballs for the specified compression |
439
|
|
|
|
|
|
|
format and type. The list is sorted in reverse logical order, I the |
440
|
|
|
|
|
|
|
newest production release will be the first item in the list and the oldest |
441
|
|
|
|
|
|
|
will be the last. So, for instance, the list of development releases in C |
442
|
|
|
|
|
|
|
format will start with something like: |
443
|
|
|
|
|
|
|
|
444
|
|
|
|
|
|
|
perl-5.27.5.tar.gz |
445
|
|
|
|
|
|
|
perl-5.27.4.tar.gz |
446
|
|
|
|
|
|
|
perl-5.27.3.tar.gz |
447
|
|
|
|
|
|
|
|
448
|
|
|
|
|
|
|
and end with: |
449
|
|
|
|
|
|
|
|
450
|
|
|
|
|
|
|
perl5.004_02.tar.gz |
451
|
|
|
|
|
|
|
perl5.004_01.tar.gz |
452
|
|
|
|
|
|
|
perl5.003_07.tar.gz |
453
|
|
|
|
|
|
|
|
454
|
|
|
|
|
|
|
=back |
455
|
|
|
|
|
|
|
|
456
|
|
|
|
|
|
|
=cut |
457
|
|
|
|
|
|
|
|
458
|
|
|
|
|
|
|
sub list_releases { |
459
|
0
|
|
|
0
|
1
|
|
my ($self, $args) = @_; |
460
|
0
|
|
0
|
|
|
|
$args ||= {}; |
461
|
0
|
0
|
|
|
|
|
croak "Argument to method must be hashref" |
462
|
|
|
|
|
|
|
unless ref($args) eq 'HASH'; |
463
|
0
|
|
|
|
|
|
my %eligible_types = ( |
464
|
|
|
|
|
|
|
production => 'prod', |
465
|
|
|
|
|
|
|
prod => 'prod', |
466
|
|
|
|
|
|
|
development => 'dev', |
467
|
|
|
|
|
|
|
dev => 'dev', |
468
|
|
|
|
|
|
|
rc => 'rc', |
469
|
|
|
|
|
|
|
); |
470
|
0
|
|
|
|
|
|
my $type; |
471
|
0
|
0
|
|
|
|
|
if (defined $args->{type}) { |
472
|
|
|
|
|
|
|
croak "Bad value for 'type': $args->{type}" |
473
|
0
|
0
|
|
|
|
|
unless $eligible_types{$args->{type}}; |
474
|
0
|
|
|
|
|
|
$type = $eligible_types{$args->{type}}; |
475
|
|
|
|
|
|
|
} |
476
|
|
|
|
|
|
|
else { |
477
|
0
|
|
|
|
|
|
$type = 'dev'; |
478
|
|
|
|
|
|
|
} |
479
|
|
|
|
|
|
|
|
480
|
0
|
|
|
|
|
|
my $compression = 'gz'; |
481
|
0
|
0
|
|
|
|
|
if (exists $args->{compression}) { |
482
|
0
|
|
|
|
|
|
$compression = $self->_compression_check($args->{compression}); |
483
|
|
|
|
|
|
|
} |
484
|
0
|
|
|
|
|
|
$compression = $self->_prepare_list($compression); |
485
|
|
|
|
|
|
|
|
486
|
|
|
|
|
|
|
say "Preparing list of '$type' releases with '$compression' compression" |
487
|
0
|
0
|
|
|
|
|
if $self->{verbose}; |
488
|
0
|
|
|
|
|
|
my @these_releases; |
489
|
0
|
0
|
|
|
|
|
if ($type eq 'prod') { |
|
|
0
|
|
|
|
|
|
490
|
|
|
|
|
|
|
@these_releases = |
491
|
0
|
|
|
|
|
|
grep { /\.${compression}$/ } sort { |
492
|
|
|
|
|
|
|
$self->{versions}->{$type}{$b}{major} <=> $self->{versions}->{$type}{$a}{major} || |
493
|
|
|
|
|
|
|
$self->{versions}->{$type}{$b}{minor} <=> $self->{versions}->{$type}{$a}{minor} |
494
|
0
|
0
|
|
|
|
|
} keys %{$self->{versions}->{$type}}; |
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
495
|
0
|
|
|
|
|
|
$self->{"${compression}_${type}_releases"} = \@these_releases; |
496
|
0
|
|
|
|
|
|
return @these_releases; |
497
|
|
|
|
|
|
|
} |
498
|
|
|
|
|
|
|
elsif ($type eq 'dev') { |
499
|
|
|
|
|
|
|
@these_releases = |
500
|
0
|
|
|
|
|
|
grep { /\.${compression}$/ } sort { |
501
|
|
|
|
|
|
|
$self->{versions}->{$type}{$b}{major} <=> $self->{versions}->{$type}{$a}{major} || |
502
|
|
|
|
|
|
|
$self->{versions}->{$type}{$b}{minor} <=> $self->{versions}->{$type}{$a}{minor} |
503
|
0
|
0
|
|
|
|
|
} keys %{$self->{versions}->{$type}}; |
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
504
|
0
|
|
|
|
|
|
$self->{"${compression}_${type}_releases"} = \@these_releases; |
505
|
0
|
|
|
|
|
|
return @these_releases; |
506
|
|
|
|
|
|
|
} |
507
|
|
|
|
|
|
|
else { # $type eq rc |
508
|
|
|
|
|
|
|
@these_releases = |
509
|
0
|
|
|
|
|
|
grep { /\.${compression}$/ } sort { |
510
|
|
|
|
|
|
|
$self->{versions}->{$type}{$b}{major} <=> $self->{versions}->{$type}{$a}{major} || |
511
|
|
|
|
|
|
|
$self->{versions}->{$type}{$b}{minor} <=> $self->{versions}->{$type}{$a}{minor} || |
512
|
|
|
|
|
|
|
$self->{versions}->{$type}{$b}{rc} cmp $self->{versions}->{$type}{$a}{rc} |
513
|
0
|
0
|
0
|
|
|
|
} keys %{$self->{versions}->{$type}}; |
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
514
|
0
|
|
|
|
|
|
$self->{"${compression}_${type}_releases"} = \@these_releases; |
515
|
0
|
|
|
|
|
|
return @these_releases; |
516
|
|
|
|
|
|
|
} |
517
|
|
|
|
|
|
|
} |
518
|
|
|
|
|
|
|
|
519
|
|
|
|
|
|
|
=head2 C |
520
|
|
|
|
|
|
|
|
521
|
|
|
|
|
|
|
=over 4 |
522
|
|
|
|
|
|
|
|
523
|
|
|
|
|
|
|
=item * Purpose |
524
|
|
|
|
|
|
|
|
525
|
|
|
|
|
|
|
Download the latest release via FTP. |
526
|
|
|
|
|
|
|
|
527
|
|
|
|
|
|
|
=item * Arguments |
528
|
|
|
|
|
|
|
|
529
|
|
|
|
|
|
|
$latest_release = $self->get_latest_release( { |
530
|
|
|
|
|
|
|
compression => 'gz', |
531
|
|
|
|
|
|
|
type => 'dev', |
532
|
|
|
|
|
|
|
path => '/path/to/download', |
533
|
|
|
|
|
|
|
verbose => 1, |
534
|
|
|
|
|
|
|
} ); |
535
|
|
|
|
|
|
|
|
536
|
|
|
|
|
|
|
=item * Return Value |
537
|
|
|
|
|
|
|
|
538
|
|
|
|
|
|
|
Scalar holding path to download of tarball. |
539
|
|
|
|
|
|
|
|
540
|
|
|
|
|
|
|
=back |
541
|
|
|
|
|
|
|
|
542
|
|
|
|
|
|
|
=cut |
543
|
|
|
|
|
|
|
|
544
|
|
|
|
|
|
|
sub get_latest_release { |
545
|
0
|
|
|
0
|
1
|
|
my ($self, $args) = @_; |
546
|
0
|
0
|
|
|
|
|
croak "Argument to method must be hashref" |
547
|
|
|
|
|
|
|
unless ref($args) eq 'HASH'; |
548
|
0
|
|
|
|
|
|
my %eligible_types = ( |
549
|
|
|
|
|
|
|
production => 'prod', |
550
|
|
|
|
|
|
|
prod => 'prod', |
551
|
|
|
|
|
|
|
development => 'dev', |
552
|
|
|
|
|
|
|
dev => 'dev', |
553
|
|
|
|
|
|
|
rc => 'rc', |
554
|
|
|
|
|
|
|
); |
555
|
0
|
|
|
|
|
|
my $type; |
556
|
0
|
0
|
|
|
|
|
if (defined $args->{type}) { |
557
|
|
|
|
|
|
|
croak "Bad value for 'type': $args->{type}" |
558
|
0
|
0
|
|
|
|
|
unless $eligible_types{$args->{type}}; |
559
|
0
|
|
|
|
|
|
$type = $eligible_types{$args->{type}}; |
560
|
|
|
|
|
|
|
} |
561
|
|
|
|
|
|
|
else { |
562
|
0
|
|
|
|
|
|
$type = 'dev'; |
563
|
|
|
|
|
|
|
} |
564
|
|
|
|
|
|
|
|
565
|
0
|
|
|
|
|
|
my $compression = 'gz'; |
566
|
0
|
0
|
|
|
|
|
if (exists $args->{compression}) { |
567
|
0
|
|
|
|
|
|
$compression = $self->_compression_check($args->{compression}); |
568
|
|
|
|
|
|
|
} |
569
|
0
|
|
|
|
|
|
my $cache = "${compression}_${type}_releases"; |
570
|
|
|
|
|
|
|
|
571
|
0
|
|
|
|
|
|
my $path = cwd(); |
572
|
0
|
0
|
|
|
|
|
if (exists $args->{path}) { |
573
|
0
|
0
|
|
|
|
|
croak "Value for 'path' not found" unless (-d $args->{path}); |
574
|
0
|
|
|
|
|
|
$path = $args->{path}; |
575
|
|
|
|
|
|
|
} |
576
|
0
|
|
|
|
|
|
my $latest; |
577
|
0
|
0
|
|
|
|
|
if (exists $self->{$cache}) { |
578
|
0
|
0
|
|
|
|
|
say "Identifying latest $type release from cache" if $self->{verbose}; |
579
|
0
|
|
|
|
|
|
$latest = $self->{$cache}->[0]; |
580
|
|
|
|
|
|
|
} |
581
|
|
|
|
|
|
|
else { |
582
|
0
|
0
|
|
|
|
|
say "Identifying latest $type release" if $self->{verbose}; |
583
|
0
|
|
|
|
|
|
my @releases = $self->list_releases( { |
584
|
|
|
|
|
|
|
compression => $compression, |
585
|
|
|
|
|
|
|
type => $type, |
586
|
|
|
|
|
|
|
} ); |
587
|
0
|
|
|
|
|
|
$latest = $releases[0]; |
588
|
|
|
|
|
|
|
} |
589
|
0
|
0
|
|
|
|
|
say "Performing FTP 'get' call for: $latest" if $self->{verbose}; |
590
|
0
|
|
|
|
|
|
my $starttime = time(); |
591
|
0
|
0
|
|
|
|
|
$self->{ftp}->get($latest) |
592
|
|
|
|
|
|
|
or croak "Unable to perform FTP get call: $!"; |
593
|
0
|
|
|
|
|
|
my $endtime = time(); |
594
|
|
|
|
|
|
|
say "Elapsed time for FTP 'get' call: ", $endtime - $starttime, " seconds" |
595
|
0
|
0
|
|
|
|
|
if $self->{verbose}; |
596
|
0
|
|
|
|
|
|
my $rv = File::Spec->catfile($path, $latest); |
597
|
0
|
0
|
|
|
|
|
move $latest, $rv or croak "Unable to move $latest to $path"; |
598
|
0
|
0
|
|
|
|
|
say "See: $rv" if $self->{verbose}; |
599
|
0
|
|
|
|
|
|
return $rv; |
600
|
|
|
|
|
|
|
} |
601
|
|
|
|
|
|
|
|
602
|
|
|
|
|
|
|
=head2 C |
603
|
|
|
|
|
|
|
|
604
|
|
|
|
|
|
|
=over 4 |
605
|
|
|
|
|
|
|
|
606
|
|
|
|
|
|
|
=item * Purpose |
607
|
|
|
|
|
|
|
|
608
|
|
|
|
|
|
|
Download a specific release via FTP. |
609
|
|
|
|
|
|
|
|
610
|
|
|
|
|
|
|
=item * Arguments |
611
|
|
|
|
|
|
|
|
612
|
|
|
|
|
|
|
$specific_release = $self->get_specific_release( { |
613
|
|
|
|
|
|
|
release => 'perl-5.27.2.tar.xz', |
614
|
|
|
|
|
|
|
path => '/path/to/download', |
615
|
|
|
|
|
|
|
} ); |
616
|
|
|
|
|
|
|
|
617
|
|
|
|
|
|
|
=item * Return Value |
618
|
|
|
|
|
|
|
|
619
|
|
|
|
|
|
|
Scalar holding path to download of tarball. |
620
|
|
|
|
|
|
|
|
621
|
|
|
|
|
|
|
=back |
622
|
|
|
|
|
|
|
|
623
|
|
|
|
|
|
|
=cut |
624
|
|
|
|
|
|
|
|
625
|
|
|
|
|
|
|
sub get_specific_release { |
626
|
0
|
|
|
0
|
1
|
|
my ($self, $args) = @_; |
627
|
0
|
0
|
|
|
|
|
croak "Argument to method must be hashref" |
628
|
|
|
|
|
|
|
unless ref($args) eq 'HASH'; |
629
|
|
|
|
|
|
|
|
630
|
0
|
|
|
|
|
|
my $path = cwd(); |
631
|
0
|
0
|
|
|
|
|
if (exists $args->{path}) { |
632
|
0
|
0
|
|
|
|
|
croak "Value for 'path' not found" unless (-d $args->{path}); |
633
|
0
|
|
|
|
|
|
$path = $args->{path}; |
634
|
|
|
|
|
|
|
} |
635
|
|
|
|
|
|
|
|
636
|
0
|
|
|
|
|
|
my @all_releases = $self->ls; |
637
|
0
|
|
|
|
|
|
my %all_releases = map {$_ => 1} @all_releases; |
|
0
|
|
|
|
|
|
|
638
|
|
|
|
|
|
|
croak "$args->{release} not found among releases at ftp://$self->{host}$self->{dir}" |
639
|
0
|
0
|
|
|
|
|
unless $all_releases{$args->{release}}; |
640
|
|
|
|
|
|
|
|
641
|
0
|
0
|
|
|
|
|
say "Performing FTP 'get' call for: $args->{release}" if $self->{verbose}; |
642
|
0
|
|
|
|
|
|
my $starttime = time(); |
643
|
|
|
|
|
|
|
$self->{ftp}->get($args->{release}) |
644
|
0
|
0
|
|
|
|
|
or croak "Unable to perform FTP get call: $!"; |
645
|
0
|
|
|
|
|
|
my $endtime = time(); |
646
|
|
|
|
|
|
|
say "Elapsed time for FTP 'get' call: ", $endtime - $starttime, " seconds" |
647
|
0
|
0
|
|
|
|
|
if $self->{verbose}; |
648
|
0
|
|
|
|
|
|
my $rv = File::Spec->catfile($path, $args->{release}); |
649
|
0
|
0
|
|
|
|
|
move $args->{release}, $rv |
650
|
|
|
|
|
|
|
or croak "Unable to move $args->{release} to $path"; |
651
|
0
|
0
|
|
|
|
|
say "See: $rv" if $self->{verbose}; |
652
|
0
|
|
|
|
|
|
return $rv; |
653
|
|
|
|
|
|
|
} |
654
|
|
|
|
|
|
|
|
655
|
|
|
|
|
|
|
=head1 BUGS AND SUPPORT |
656
|
|
|
|
|
|
|
|
657
|
|
|
|
|
|
|
Please report any bugs by mail to C |
658
|
|
|
|
|
|
|
or through the web interface at L. |
659
|
|
|
|
|
|
|
|
660
|
|
|
|
|
|
|
=head1 ACKNOWLEDGEMENTS |
661
|
|
|
|
|
|
|
|
662
|
|
|
|
|
|
|
Thanks for feedback from Chad Granum, Kent Fredric and David Golden |
663
|
|
|
|
|
|
|
in the perl.cpan.workers newsgroup. |
664
|
|
|
|
|
|
|
|
665
|
|
|
|
|
|
|
=head1 AUTHOR |
666
|
|
|
|
|
|
|
|
667
|
|
|
|
|
|
|
James E Keenan |
668
|
|
|
|
|
|
|
CPAN ID: JKEENAN |
669
|
|
|
|
|
|
|
jkeenan@cpan.org |
670
|
|
|
|
|
|
|
http://thenceforward.net/perl |
671
|
|
|
|
|
|
|
|
672
|
|
|
|
|
|
|
=head1 COPYRIGHT |
673
|
|
|
|
|
|
|
|
674
|
|
|
|
|
|
|
This program is free software; you can redistribute |
675
|
|
|
|
|
|
|
it and/or modify it under the same terms as Perl itself. |
676
|
|
|
|
|
|
|
|
677
|
|
|
|
|
|
|
The full text of the license can be found in the |
678
|
|
|
|
|
|
|
LICENSE file included with this module. |
679
|
|
|
|
|
|
|
|
680
|
|
|
|
|
|
|
Copyright James E Keenan 2018. All rights reserved. |
681
|
|
|
|
|
|
|
|
682
|
|
|
|
|
|
|
=head1 SEE ALSO |
683
|
|
|
|
|
|
|
|
684
|
|
|
|
|
|
|
perl(1). Net::FTP(3). Test::RequiresInternet(3). |
685
|
|
|
|
|
|
|
|
686
|
|
|
|
|
|
|
=cut |
687
|
|
|
|
|
|
|
|
688
|
|
|
|
|
|
|
1; |