File Coverage

blib/lib/CPAN/Mini/Visit/Simple/Auxiliary.pm
Criterion Covered Total %
statement 56 97 57.7
branch 9 16 56.2
condition n/a
subroutine 10 14 71.4
pod 3 6 50.0
total 78 133 58.6


line stmt bran cond sub pod time code
1             package CPAN::Mini::Visit::Simple::Auxiliary;
2 8     8   947 use 5.010;
  8         19  
3 8     8   25 use strict;
  8         8  
  8         121  
4 8     8   20 use warnings;
  8         7  
  8         685  
5             our @ISA = qw( Exporter );
6             our @EXPORT_OK = qw(
7             $ARCHIVE_REGEX
8             dedupe_superseded
9             get_lookup_table
10             normalize_version_number
11             create_minicpan_for_testing
12             create_one_new_distro_version
13             create_file
14             );
15 8     8   26 use Carp;
  8         10  
  8         393  
16 8     8   28 use File::Basename;
  8         9  
  8         432  
17 8     8   26 use File::Path qw( make_path );
  8         9  
  8         291  
18 8     8   24 use File::Spec;
  8         8  
  8         177  
19 8     8   1303 use File::Temp qw( tempdir );
  8         31037  
  8         6239  
20              
21             our $ARCHIVE_REGEX = qr{\.(?:
22             tar\.(?:bz2|gz|Z) |
23             t(?:gz|bz) |
24             zip |
25             gz
26             )$}ix;
27             sub dedupe_superseded {
28 2     2 1 824 my $listref = shift;
29 2         2 my (%version_seen, @newlist);
30 2         4 DISTRO: foreach my $distro (@$listref) {
31 20         12 my $dir;
32 20         16 eval { $dir = dirname($distro); };
  20         365  
33 20 50       32 if ($@) {
34 0         0 say STDERR "Problem calling File::Basename::dirname on '$distro'";
35 0         0 say STDERR $@;
36 0         0 next DISTRO;
37             }
38 20         309 my $base = basename($distro);
39 20 100       131 if ($base =~ m/^(.*)-([\d\.]+)(?:$ARCHIVE_REGEX)/) {
40 18         21 my ($stem, $version) = ($1,$2);
41 18         100 my $k = File::Spec->catfile($dir, $stem);
42 18 100       37 if ( not $version_seen{$k}{version} ) {
43 6         11 $version_seen{$k} = {
44             distro => $distro,
45             version => normalize_version_number($version),
46             };
47             }
48             else {
49             my $norm_current =
50 12         17 normalize_version_number($version_seen{$k}{version});
51 12         15 my $norm_new = normalize_version_number($version);
52 12 100       31 if ( $norm_new > $norm_current ) {
53 9         27 $version_seen{$k} = {
54             distro => $distro,
55             version => $norm_new,
56             };
57             }
58             }
59             }
60             else {
61 2         4 push @newlist, $distro;
62             }
63             }
64 2         5 foreach my $k (keys %version_seen) {
65 6         21 push @newlist, $version_seen{$k}{distro};
66             }
67 2         13 return [ sort @newlist ];
68             }
69              
70             sub get_lookup_table {
71 0     0 1 0 my $distributions_ref = shift;
72 0         0 my %lookup_table = ();
73 0         0 foreach my $distro ( @{$distributions_ref} ) {
  0         0  
74 0         0 my $dir = dirname($distro);
75 0         0 my $base = basename($distro);
76 0 0       0 if ($base =~ m/^(.*)-([\d\.]+)(?:$ARCHIVE_REGEX)/) {
77 0         0 my ($stem, $version) = ($1,$2);
78 0         0 my $k = File::Spec->catfile($dir, $stem);
79 0         0 $lookup_table{$k} = {
80             distro => $distro,
81             version => normalize_version_number($version),
82             };
83             }
84             else {
85             # Since we don't have any authoritative way to compare version
86             # numbers that can't be normalized, we will (for now) pass over
87             # distributions with non-standard version numbers.
88             }
89             }
90 0         0 return \%lookup_table;
91             }
92              
93             sub normalize_version_number {
94 183     183 1 1762 my $v = shift;
95 183         209 my @captures = split /\./, $v;
96 183         138 $captures[0] =~ s/^v//;
97 183         96 my $normalized;
98 183 100       171 if ( $captures[0] eq q{} ) {
99 2         3 $normalized = 0;
100             }
101             else {
102 181         161 $normalized = 0+$captures[0];
103             }
104              
105 183         135 $normalized .= '.';
106 183         190 for my $cap (@captures[1..$#captures]) {
107 342         417 $normalized .= sprintf("%05d", $cap);
108             }
109 183         149 $normalized =~ s/-//g;
110 183         354 return $normalized;
111             }
112              
113             sub create_minicpan_for_testing {
114 0     0 0   my ( $tdir, $id_dir, $author_dir );
115 0           my ( @source_list );
116             # Prepare the test by creating a minicpan in a temporary directory.
117 0           $tdir = tempdir( CLEANUP => 1 );
118 0           $id_dir = File::Spec->catdir($tdir, qw( authors id ));
119 0           make_path($id_dir, { mode => 0711 });
120 0           Test::More::ok( -d $id_dir, "'authors/id' directory created for testing" );
121 0           $author_dir = File::Spec->catdir($id_dir, qw( A AA AARDVARK ) );
122 0           make_path($author_dir, { mode => 0711 });
123 0           Test::More::ok( -d $author_dir, "'author's directory created for testing" );
124              
125 0           @source_list = qw(
126             Alpha-Beta-0.01.tar.gz
127             Gamma-Delta-0.02.tar.gz
128             Epsilon-Zeta-0.03.tar.gz
129             );
130 0           foreach my $distro (@source_list) {
131 0           my $fulldistro = File::Spec->catfile($author_dir, $distro);
132 0           create_file($fulldistro);
133 0           Test::More::ok( ( -f $fulldistro ), "$fulldistro created" );
134             }
135 0           return ($tdir, $author_dir);
136             }
137              
138             sub create_one_new_distro_version {
139 0     0 0   my ($author_dir) = @_;
140             # Bump up the version number of one distro in the minicpan
141 0           my $remove = q{Epsilon-Zeta-0.03.tar.gz};
142 0           my $removed_file = File::Spec->catfile($author_dir, $remove);
143 0           Test::More::is( unlink($removed_file), 1, "$removed_file deleted" );
144              
145 0           my $update = q{Epsilon-Zeta-0.04.tar.gz};
146 0           my $updated_file = File::Spec->catfile($author_dir, $update);
147 0           create_file($updated_file);
148 0           Test::More::ok( ( -f $updated_file ), "$updated_file created" );
149             }
150              
151             sub create_file {
152 0     0 0   my $file = shift;
153 0 0         open my $FH, '>', $file
154             or croak "Unable to open handle to $file for writing";
155 0           say $FH q{};
156 0 0         close $FH or croak "Unable to close handle to $file after writing";
157             }
158              
159             1;
160              
161              
162             =head1 NAME
163              
164             CPAN::Mini::Visit::Simple::Auxiliary - Helper functions for CPAN::Mini::Visit::Simple
165              
166             =head1 SYNOPSIS
167              
168             use CPAN::Mini::Visit::Simple::Auxiliary qw(
169             $ARCHIVE_REGEX
170             dedupe_superseded
171             get_lookup_table
172             normalize_version_number
173             );
174              
175             =head1 DESCRIPTION
176              
177             This package provides subroutines, exported on demand only, which are used in
178             Perl extension CPAN-Mini-Visit-Simple and its test suite.
179              
180             =head1 SUBROUTINES
181              
182             =head2 C
183              
184             =over 4
185              
186             =item * Purpose
187              
188             Due to what is probably a bug in CPAN::Mini, a minicpan repository may, under
189             its F directory, contain two or more versions of a single CPAN
190             distribution. Example:
191              
192             minicpan/authors/id/D/DR/DROLSKY/Class-MOP-0.82.tar.gz
193             minicpan/authors/id/D/DR/DROLSKY/Class-MOP-0.88.tar.gz
194             minicpan/authors/id/D/DR/DROLSKY/Class-MOP-0.98.tar.gz
195              
196             This I be due to an algorithm which searches for the most recent version
197             of each Perl I on CPAN and then places the I in which it
198             is found in the minicpan -- even if that module is not found in the most
199             recent version of the distribution.
200              
201             Be this as it may, if you are using a minicpan, chances are that you really
202             want only the most recent version of a particular CPAN distribution and that
203             you don't care about packages found in older versions which have been deleted
204             by the author/maintainer (presumably for good reason) from the newest
205             version.
206              
207             So when you traverse a minicpan to compose a list of distributions, you
208             probably want that list I by stripping out older, presumably
209             superseded versions of distributions. This function tries to accomplish
210             that. It does I try to be omniscient. In particular, it does not strip
211             out distributions with letters in their versions. So, faced with a situation
212             like this:
213              
214             minicpan/authors/id/D/DR/DROLSKY/Class-MOP-0.82.tar.gz
215             minicpan/authors/id/D/DR/DROLSKY/Class-MOP-0.88.tar.gz
216             minicpan/authors/id/D/DR/DROLSKY/Class-MOP-0.98.tar.gz
217             minicpan/authors/id/D/DR/DROLSKY/Class-MOP-0.98b.tar.gz
218              
219             ... it will dedupe this listing to:
220              
221             minicpan/authors/id/D/DR/DROLSKY/Class-MOP-0.98.tar.gz
222             minicpan/authors/id/D/DR/DROLSKY/Class-MOP-0.98b.tar.gz
223              
224             =item * Arguments
225              
226             $newlist_ref = dedupe_superseded(\@list);
227              
228             One argument: Reference to an array holding a list of distributions needing
229             to be duplicated.
230              
231             =item * Return Value
232              
233             Reference to an array holding a deduplicated list.
234              
235             =back
236              
237              
238             =head2 C
239              
240             =over 4
241              
242             =item * Purpose
243              
244             Convert a list of distributions into a hash keyed on the stem of the
245             distribution name and having values which are corresponding version numbers.
246              
247             =item * Arguments
248              
249             my $primary = get_lookup_table( $self->get_list_ref() );
250              
251             Array reference.
252              
253             =item * Return Value
254              
255             Reference to hash holding lookup table. Elements in that hash will resemble:
256              
257             '/home/user/minicpan/author/id/Alpha-Beta' => {
258             version => '0.01',
259             distro => '/home/user/minicpan/author/id/Alpha-Beta.tar.gz',
260             },
261              
262             =back
263              
264              
265             =head2 C
266              
267             =over 4
268              
269             =item * Purpose
270              
271             Yet another attempt to deal with version number madness. No attempt to claim
272             that this is the absolutely correct way to create comparable version numbers.
273              
274             =item * Arguments
275              
276             $new_version = normalize_version_number($old_version),
277              
278             One argument: Version number, hopefully in two or more
279             decimal-point-delimited parts.
280              
281             =item * Return Value
282              
283             A version number in which 'minor version', 'patch version', etc., have been
284             changed to C<0>-padded 5-digit numbers.
285              
286             =back
287              
288             =head1 BUGS
289              
290             Report bugs at
291             F.
292              
293             =head1 AUTHOR
294              
295             James E Keenan
296             CPAN ID: jkeenan
297             Perl Seminar NY
298             jkeenan@cpan.org
299             http://thenceforward.net/perl/modules/CPAN-Mini-Visit-Simple/
300              
301             =head1 COPYRIGHT
302              
303             This program is free software; you can redistribute
304             it and/or modify it under the same terms as Perl itself.
305              
306             The full text of the license can be found in the
307             LICENSE file included with this module.
308              
309              
310             =head1 SEE ALSO
311              
312             CPAN-Mini. CPAN-Mini-Visit-Simple.
313              
314             =cut
315