File Coverage

blib/lib/CPAN/Cpanorg/Auxiliary.pm
Criterion Covered Total %
statement 184 193 95.3
branch 43 68 63.2
condition 12 19 63.1
subroutine 23 24 95.8
pod 10 13 76.9
total 272 317 85.8


line stmt bran cond sub pod time code
1             package CPAN::Cpanorg::Auxiliary;
2 3     3   2174 use 5.14.0;
  3         23  
3 3     3   17 use warnings;
  3         5  
  3         136  
4             our $VERSION = '0.02';
5 3     3   19 use Carp;
  3         6  
  3         302  
6 3     3   18 use Cwd;
  3         13  
  3         257  
7 3     3   19 use File::Basename qw(basename dirname);
  3         12  
  3         383  
8 3     3   21 use File::Spec;
  3         6  
  3         55  
9 3     3   1925 use JSON ();
  3         36784  
  3         94  
10 3     3   1277 use LWP::Simple qw(get);
  3         203801  
  3         28  
11 3     3   3007 use Path::Tiny;
  3         34345  
  3         2223  
12             #use Data::Dump qw(dd pp);
13              
14             =head1 NAME
15              
16             CPAN::Cpanorg::Auxiliary - Methods used in cpan.org infrastructure
17              
18             =head1 USAGE
19              
20             use CPAN::Cpanorg::Auxiliary;
21              
22             =head1 DESCRIPTION
23              
24             The objective of this library is to provide methods which can be used to write
25             replacements for programs used on the CPAN master server and stored in
26             github.com in the F and F
27             repositories.
28              
29             In particular, each of those repositories has an executable program with
30             subroutines identical, or nearly so, to subroutines found in a program in the
31             other. Those programs are:
32              
33             =over 4
34              
35             =item * L
36              
37             =item * L
38              
39             =back
40              
41             By extracting these subroutines into a single package, we hope to improve the
42             maintainability of code running on the CPAN infrastructure.
43              
44             =head1 METHODS
45              
46             =head2 C
47              
48             =over 4
49              
50             =item * Purpose
51              
52             F constructor. Primarily used to check for the
53             presence of certain directories and files on the server. Also stores certain
54             values that are currently hard-coded in various methods in
55             F and F.
56              
57             =item * Arguments
58              
59             my $self = CPAN::Cpanorg::Auxiliary->new({});
60              
61             Hash reference, required. Elements in that hash include:
62              
63             =over 4
64              
65             =item * C
66              
67             Absolute path to the directory on the server which serves as the "top-level"
68             of the infrastructure. Beneath this directory we expect to find these
69             directories already in existence:
70              
71             ./CPAN
72             ./CPAN/src
73             ./CPAN/src/5.0
74             ./CPAN/authors
75             ./CPAN/authors/id
76             ./content
77             ./data
78              
79             =item * C
80              
81             If provided with a Perl-true value, all methods produce extra output on
82             F when run. (However, no methods are yet coded for extra output.)
83              
84             =item * C
85              
86             String holding the basename of a file to be created (or regenerated) on server
87             holding metadata in JSON format about all releases of F. Optional;
88             defaults to C.
89              
90             =item * C
91              
92             String holding the URL for making an API call to get metadata about all
93             releases of F. Optional; defaults to
94             C.
95              
96             =back
97              
98             =item * Return Value
99              
100             F object.
101              
102             =item * Comment
103              
104             =back
105              
106              
107             =cut
108              
109             sub new {
110 9     9 1 97807 my ($class, $args) = @_;
111              
112 9 100 100     753 croak "Argument to constructor must be hashref"
113             unless defined $args and ref($args) eq 'HASH';
114              
115 7         61 my @required_args = ( qw| path | );
116 7         53 my @optional_args = ( qw| verbose versions_json search_api_url | );
117 7         25 my %valid_args = map {$_ => 1} (@required_args, @optional_args);
  28         101  
118 7         21 my @invalid_args_seen = ();
119 7         24 for my $k (keys %{$args}) {
  7         44  
120 9 100       53 push @invalid_args_seen, $k unless $valid_args{$k};
121             }
122 7 100       189 croak "Invalid elements passed to constructor: @invalid_args_seen"
123             if @invalid_args_seen;
124              
125 6         33 for my $el (@required_args) {
126             croak "'$el' not found in elements passed to constructor"
127 6 100       184 unless exists $args->{$el};
128             }
129 5 100       219 croak "Could not locate directory '$args->{path}'" unless (-d $args->{path});
130              
131 4         12 my %data = map { $_ => $args->{$_} } keys %{$args};
  6         42  
  4         25  
132 4         12286 $data{cwd} = cwd();
133 4   100     201 $data{versions_json} ||= 'perl_version_all.json';
134 4   100     71 $data{search_api_url} ||= "http://search.cpan.org/api/dist/perl";
135 4         43 $data{five_url} = "http://www.cpan.org/src/5.0/";
136              
137             my %dirs_required = (
138             CPANdir => [ $data{path}, qw| CPAN | ],
139             srcdir => [ $data{path}, qw| CPAN src | ],
140             fivedir => [ $data{path}, qw| CPAN src 5.0 | ],
141             authorsdir => [ $data{path}, qw| CPAN authors | ],
142             iddir => [ $data{path}, qw| CPAN authors id | ],
143             contentdir => [ $data{path}, qw| content | ],
144 4         391 datadir => [ $data{path}, qw| data | ],
145             );
146 4         46 my @dirs_required = map { File::Spec->catdir(@{$_}) } values %dirs_required;
  28         61  
  28         218  
147 4         22 my @dirs_missing = ();
148 4         21 for my $dir (@dirs_required) {
149 28 100       348 push @dirs_missing, $dir unless -d $dir;
150             }
151 4         22 my $death_message = 'Could not locate required directories:';
152 4         19 for my $el (@dirs_missing) {
153 7         21 $death_message .= "\n $el";
154             }
155 4 100       369 croak $death_message if @dirs_missing;
156              
157 3         30 for my $dir (keys %dirs_required) {
158 21         51 $data{$dir} = File::Spec->catdir(@{$dirs_required{$dir}});
  21         197  
159             }
160             $data{path_versions_json} = File::Spec->catfile(
161 3         47 $data{datadir}, $data{versions_json});
162              
163 3         279 return bless \%data, $class;
164             }
165              
166             =head2 C
167              
168             =over 4
169              
170             =item * Purpose
171              
172             Compares JSON data found on disk to result of API call to CPAN for 'perl' distribution.
173              
174             =item * Arguments
175              
176             None at the present time.
177              
178             =item * Return Value
179              
180             List of two array references:
181              
182             =over 4
183              
184             =item *
185              
186             List of hash references, one per stable perl release.
187              
188             =item *
189              
190             List of hash references, one per developmental or RC perl release.
191              
192             =back
193              
194             Side effect: Guarantees existence of file F
195             beneath the top-level directory.
196              
197             =item * Comment
198              
199             Assumes existence of subdirectory F beneath current working directory.
200              
201             =back
202              
203             =cut
204              
205             sub fetch_perl_version_data {
206 2     2 1 3434 my $self = shift;
207              
208             # See what we have on disk
209             my $disk_json = path($self->{path_versions_json})->slurp_utf8
210 2 50       61 if -r $self->{path_versions_json};
211              
212 2         2190 my $cpan_json = $self->make_api_call;
213              
214 2 100       616 if ( $cpan_json eq $disk_json ) {
215             # Data has not changed so don't need to do anything
216 1         6 return;
217             }
218             else {
219             # Save for next fetch
220 1         13 $self->print_file( $cpan_json );
221             }
222              
223 1         780 my $json = JSON->new->pretty(1);
224 1         112 my $data = $json->decode($cpan_json);
225              
226 1         4 my @perls;
227             my @testing;
228 1         3 foreach my $module ( @{ $data->{releases} } ) {
  1         12  
229             #next unless $module->{authorized} eq 'true';
230             #next unless $module->{authorized};
231              
232 18         30 my $version = $module->{version};
233              
234 18         55 $version =~ s/-(?:RC|TRIAL)\d+$//;
235 18         33 $module->{version_number} = $version;
236              
237 18         72 my ( $major, $minor, $iota ) = split( '[\._]', $version );
238 18         37 $module->{version_major} = $major;
239              
240             # Silence one warning generated when processing the perl release whose
241             # distvname was 'perl-5.6-info'
242 3     3   38 no warnings 'numeric';
  3         8  
  3         160  
243 18         35 $module->{version_minor} = int($minor);
244 3     3   19 use warnings;
  3         7  
  3         5247  
245              
246 18   100     53 $module->{version_iota} = int( $iota || '0' );
247              
248             $module->{type}
249 18 100       45 = $module->{status} eq 'testing'
250             ? 'Devel'
251             : 'Maint';
252              
253             # TODO: Ask - please add some validation logic here
254             # so that on live it checks this exists
255 18         47 $module->{zip_file} = $module->{distvname} . '.tar.gz';
256 18         47 $module->{url} = $self->{five_url} . $module->{zip_file};
257              
258             ( $module->{released_date}, $module->{released_time} )
259 18         83 = split( 'T', $module->{released} );
260              
261 18 50       50 next if $major < 5;
262              
263 18 100       33 if ( $module->{status} eq 'stable' ) {
264 3         7 push @perls, $module;
265             }
266             else {
267 15         39 push @testing, $module;
268             }
269             }
270 1         4 $self->{perl_versions} = \@perls;
271 1         22 $self->{perl_testing} = \@testing;
272             }
273              
274             =head2 C
275              
276             =over 4
277              
278             =item * Purpose
279              
280             Enhance object's data structures with metadata about perl releases.
281              
282             =item * Arguments
283              
284             None.
285              
286             =item * Return Value
287              
288             None.
289              
290             =back
291              
292             =cut
293              
294             sub add_release_metadata {
295 1     1 1 4 my $self = shift;
296              
297 1 50       14 chdir $self->{CPANdir} or croak "Unable to chdir to $self->{CPANdir}";
298              
299             # check disk for files
300 1         3 foreach my $perl ( @{$self->{perl_versions}}, @{$self->{perl_testing}} ) {
  1         4  
  1         4  
301 18         108 my $id = $perl->{cpanid};
302              
303 18 50       127 if ( $id =~ /^(.)(.)/ ) {
304 18         221 my $path = "authors/id/$1/$1$2/$id";
305 18         109 my $fileroot = "$path/" . $perl->{distvname};
306 18         1966 my @files = glob("${fileroot}.*tar.*");
307              
308 18 50       150 die "Could not find perl ${fileroot}.*" unless scalar(@files);
309              
310 18         151 $perl->{files} = [];
311             # The file_meta() sub in bin/perl-sorter.pl assumes the presence
312             # of checksum files for each perl release.
313 18         117 foreach my $file (@files) {
314 18         494 my $ffile = File::Spec->catfile($self->{CPANdir}, $file);
315 18         144 my $meta = file_meta($ffile);
316 18         63 push( @{ $perl->{files} }, $meta );
  18         504  
317             }
318             }
319             }
320             }
321              
322             =head2 C
323              
324             =over 4
325              
326             =item * Purpose
327              
328             For each perl release, create three security files: C. Create symlinks from the F and F directories to the originals underneath the release manager's directory under F.
329              
330             =item * Arguments
331              
332             None.
333              
334             =item * Return Value
335              
336             Returns true value upon success.
337              
338             =back
339              
340             =cut
341              
342             sub write_security_files_and_symlinks {
343 1     1 1 6681 my $self = shift;
344              
345 1 50       27 chdir $self->{srcdir} or croak "Unable to chdir to $self->{srcdir}";
346              
347 1         11 foreach my $perl ( @{$self->{perl_versions}}, @{$self->{perl_testing}} ) {
  1         12  
  1         5  
348              
349             # For a perl e.g. perl-5.12.4-RC1
350             # create or symlink:
351 18         33 foreach my $file ( @{ $perl->{files} } ) {
  18         53  
352              
353 18         54 my $filename = $file->{file};
354 18         46 my $out = "5.0/" . $file->{filename};
355              
356 18         37 foreach my $security (qw(md5 sha1 sha256)) {
357              
358             print_file_if_different( "${out}.${security}.txt",
359 54         14524 $file->{$security} );
360             }
361              
362 18         7226 my $target;
363 18         183 my ($authors_dir) = $file->{filedir} =~ s/^.*?(authors.*)$/$1/r;
364 18         230 $target = File::Spec->catfile('..', '..', $authors_dir, $file->{filename});
365 18         59 create_symlink( $target, $out );
366              
367             # only link stable versions directly from src/
368 18 100       111 next unless $perl->{status} eq 'stable';
369 3         48 $target = File::Spec->catfile('..', $authors_dir, $file->{filename});
370 3         15 create_symlink( $target, $file->{filename} );
371             }
372             }
373 1         7 return 1;
374             }
375              
376             =head2 C
377              
378             =over 4
379              
380             =item * Purpose
381              
382             Create two symlinks in F directory:
383              
384             /src/latest.tar....
385             /src/stable.tar....
386              
387             One symlink for each compression format for a particular release.
388              
389             =item * Arguments
390              
391             None.
392              
393             =item * Return Value
394              
395             Returns true value upon success.
396              
397             =item * Comment
398              
399             Per L (retrieved Jun 10 2018):
400             The "latest" and "stable" are now just aliases for "maint", and "maint" in
401             turn is the maintenance branch with the largest release number.
402              
403             =back
404              
405             =cut
406              
407             sub create_latest_only_symlinks {
408 1     1 1 4814 my $self = shift;
409              
410 1 50       18 chdir $self->{srcdir} or croak "Unable to chdir to $self->{srcdir}";
411              
412 1         7 my ($perl_versions, $perl_testing) = $self->get_perl_versions_and_testing;
413 1         6 my $latest_perl_version
414             = extract_first_perl_version_in_list($perl_versions);
415              
416 1         3 my $latest = sort_versions( [ values %{$latest_perl_version} ] )->[0];
  1         16  
417              
418 1         4 foreach my $file ( @{ $latest->{files} } ) {
  1         8  
419              
420 1         13 my ($authors_dir) = $file->{filedir} =~ s/^.*?(authors.*)$/$1/r;
421             my $out_latest
422 1 50       7 = $file->{file} =~ /bz2/
423             ? "latest.tar.bz2"
424             : "latest.tar.gz";
425              
426 1         20 my $target = File::Spec->catfile('..', $authors_dir, $file->{filename});
427 1         7 create_symlink( $target, $out_latest );
428              
429             my $out_stable
430 1 50       16 = $file->{file} =~ /bz2/
431             ? "stable.tar.bz2"
432             : "stable.tar.gz";
433              
434 1         18 create_symlink( $target, $out_stable );
435             }
436            
437 1 50       23 chdir $self->{cwd} or croak "Could not change back to starting point";
438 1         6 return 1;
439             }
440              
441             ##### INTERNAL METHODS #####
442              
443             # make_api_call(): Called within fetch_perl_version_data()
444              
445             sub make_api_call {
446 0     0 0 0 my $self = shift;
447 0         0 my $cpan_json = get($self->{search_api_url});
448 0 0       0 die "Unable to fetch $self->{search_api_url}" unless $cpan_json;
449 0         0 return $cpan_json;
450             }
451              
452             # get_perl_versions_and_testing(): Called within create_latest_only_symlinks()
453              
454             sub get_perl_versions_and_testing {
455 3     3 0 18 my $self = shift;
456 3   50     37 return ( $self->{perl_versions} || {}, $self->{perl_testing} || {} );
      50        
457             }
458              
459              
460             =head2 C
461              
462             =over 4
463              
464             =item * Purpose
465              
466             Write out data from an array reference, here, data from the result of an HTTP
467             F call which returns data in JSON format.
468              
469             =item * Arguments
470              
471             $self->print_file($file, $array_ref);
472              
473             Two arguments: basename of a file to be written to (implicitly, in a subdirectory called F); reference to an array of JSON elements.
474              
475             =item * Return Value
476              
477             Implicitly returns true value upon success. Dies otherwise.
478              
479             =item * Comment
480              
481             =back
482              
483             =cut
484              
485             sub print_file {
486 1     1 1 5 my ( $self, $data ) = @_;
487 1 50       6 path($self->{path_versions_json})->spew_utf8($data)
488             or croak "Could not write $self->{path_versions_json}";
489             }
490              
491             ##### INTERNAL SUBROUTINES #####
492              
493             =head2 file_meta
494              
495             my $meta = file_meta($file);
496              
497             print $meta->{file};
498             print $meta->{filename};
499             print $meta->{filedir};
500             print $meta->{md5};
501             print $meta->{sha256};
502             print $meta->{mtime};
503             print $meta->{sha1};
504              
505             Get or calculate meta information about a file
506              
507             =cut
508              
509             sub file_meta {
510 18     18 1 53 my $file = shift;
511 18         1529 my $filename = basename($file);
512 18         513 my $dir = dirname($file);
513 18         192 my $checksum = File::Spec->catfile($dir, 'CHECKSUMS');
514              
515             # The CHECKSUM file has already calculated
516             # lots of this so use that
517 18         45 my $cksum;
518 18 50       10416 unless ( defined( $cksum = do $checksum ) ) {
519 0         0 die qq[Checksums file "$checksum" not found\n];
520             }
521              
522             # Calculate the sha1
523 18         84 my $sha1;
524 18 50       38983 if ( open( my $fh, "openssl sha1 $file |" ) ) {
525 18         61882 while (<$fh>) {
526 18 50       610 if (/^SHA1\(.+?\)= ([0-9a-f]+)$/) {
527 18         330 $sha1 = $1;
528 18         47 last;
529             }
530             }
531             }
532 18 50       57 die qq[Failed to compute sha1 for $file\n] unless defined $sha1;
533              
534             return {
535             file => $file,
536             filedir => $dir,
537             filename => $filename,
538             mtime => ( stat($file) )[9],
539             md5 => $cksum->{$filename}->{md5},
540             sha256 => $cksum->{$filename}->{sha256},
541 18         2222 sha1 => $sha1,
542             };
543             }
544              
545             sub print_file_if_different {
546 54     54 0 139 my ( $file, $data ) = @_;
547              
548 54 50       848 if ( -r $file ) {
549 0         0 my $content = path($file)->slurp_utf8;
550 0 0       0 return if $content eq $data;
551             }
552              
553 54 50       242 path($file)->spew_utf8($data)
554             or die "Could not write $file: $!";
555             }
556              
557             =head2 create_symlink
558              
559             create_symlink($oldfile, $newfile);
560              
561             Will unlink $newfile if it already exists and then create
562             the symlink.
563              
564             =cut
565              
566             sub create_symlink {
567 23     23 1 60 my ( $oldfile, $newfile ) = @_;
568              
569             # Clean out old symlink if it does not point to correct location
570 23 50 33     396 if ( -l $newfile && readlink($newfile) ne $oldfile ) {
571 0         0 unlink($newfile);
572             }
573 23 50       768 symlink( $oldfile, $newfile ) unless -l $newfile;
574             }
575              
576             =head2 C
577              
578             =over 4
579              
580             =item * Purpose
581              
582             Produce appropriately sorted list of Perl releases.
583              
584             =item * Arguments
585              
586             my $latest = sort_versions( [ values %{$latest_per_version} ] )->[0];
587              
588             =item * Return Value
589              
590             =item * Comment
591              
592             Call last.
593              
594             =back
595              
596             =cut
597              
598             sub sort_versions {
599 1     1 1 4 my $list = shift;
600              
601             my @sorted = sort {
602             $b->{version_major} <=> $a->{version_major}
603             || int( $b->{version_minor} ) <=> int( $a->{version_minor} )
604             || $b->{version_iota} <=> $a->{version_iota}
605 1 0 0     3 } @{$list};
  0         0  
  1         6  
606              
607 1         8 return \@sorted;
608              
609             }
610              
611             =head2 C
612              
613             =over 4
614              
615             =item * Purpose
616              
617             =item * Arguments
618              
619             =item * Return Value
620              
621             =item * Comment
622              
623             =back
624              
625             =cut
626              
627             sub extract_first_perl_version_in_list {
628 1     1 1 3 my $versions = shift;
629              
630 1         7 my $lookup = {};
631 1         3 foreach my $version ( @{$versions} ) {
  1         8  
632             my $minor_version = $version->{version_major} . '.'
633 3         15 . int( $version->{version_minor} );
634              
635             $lookup->{$minor_version} = $version
636 3 100       17 unless $lookup->{$minor_version};
637             }
638 1         4 return $lookup;
639             }
640              
641             1;
642              
643             __END__