File Coverage

blib/lib/CPAN/Mirror/Tiny.pm
Criterion Covered Total %
statement 65 302 21.5
branch 0 130 0.0
condition 0 34 0.0
subroutine 22 52 42.3
pod 7 20 35.0
total 94 538 17.4


line stmt bran cond sub pod time code
1             package CPAN::Mirror::Tiny;
2 1     1   67232 use 5.008001;
  1         3  
3 1     1   6 use strict;
  1         1  
  1         20  
4 1     1   4 use warnings;
  1         2  
  1         36  
5              
6             our $VERSION = '0.31';
7              
8 1     1   581 use CPAN::Meta;
  1         31276  
  1         32  
9 1     1   462 use CPAN::Mirror::Tiny::Archive;
  1         3  
  1         34  
10 1     1   405 use CPAN::Mirror::Tiny::Tempdir;
  1         3  
  1         28  
11 1     1   6 use Cwd ();
  1         2  
  1         13  
12 1     1   5 use Digest::MD5 ();
  1         2  
  1         13  
13 1     1   4 use File::Basename ();
  1         2  
  1         11  
14 1     1   478 use File::Copy ();
  1         2333  
  1         25  
15 1     1   530 use File::Copy::Recursive ();
  1         4043  
  1         24  
16 1     1   7 use File::Path ();
  1         2  
  1         16  
17 1     1   4 use File::Spec::Unix;
  1         2  
  1         36  
18 1     1   5 use File::Spec;
  1         2  
  1         15  
19 1     1   4 use File::Temp ();
  1         2  
  1         14  
20 1     1   4 use File::Which ();
  1         2  
  1         15  
21 1     1   508 use HTTP::Tinyish;
  1         984  
  1         32  
22 1     1   7 use IPC::Run3 ();
  1         2  
  1         13  
23 1     1   701 use JSON ();
  1         10164  
  1         29  
24 1     1   460 use Parse::LocalDistribution;
  1         71203  
  1         37  
25 1     1   8 use Parse::PMFile;
  1         2  
  1         3537  
26              
27             my $JSON = JSON->new->canonical(1)->utf8(1);
28             my $CACHE_VERSION = 1;
29              
30             sub run3 {
31 0     0 0   my ($cmd, $outfile) = @_;
32 0           my $out;
33 0 0         IPC::Run3::run3 $cmd, \undef, ($outfile ? $outfile : \$out), \my $err;
34 0           return ($out, $err, $?);
35             }
36              
37             sub new {
38 0     0 1   my ($class, %option) = @_;
39 0 0 0       my $base = $option{base} || $ENV{PERL_CPAN_MIRROR_TINY_BASE} or die "Missing base directory argument";
40 0   0       my $tempdir = $option{tempdir} || File::Temp::tempdir(CLEANUP => 1);
41 0 0         File::Path::mkpath($base) unless -d $base;
42 0           $base = Cwd::abs_path($base);
43 0           my $archive = CPAN::Mirror::Tiny::Archive->new;
44 0           my $http = HTTP::Tinyish->new;
45 0           my $self = bless {
46             base => $base,
47             archive => $archive,
48             http => $http,
49             tempdir => $tempdir,
50             }, $class;
51 0           $self->init_tools;
52             }
53              
54             sub init_tools {
55 0     0 0   my $self = shift;
56 0           for my $cmd (qw(git tar gzip)) {
57 0 0         $self->{$cmd} = File::Which::which($cmd)
58             or die "Couldn't find $cmd; CPAN::Mirror::Tiny needs it";
59             }
60 0           $self;
61             }
62              
63 0     0 0   sub archive { shift->{archive} }
64 0     0 1   sub http { shift->{http} }
65              
66             sub extract {
67 0     0 0   my ($self, $path) = @_;
68 0           $self->archive->unpack($path);
69             }
70              
71             sub base {
72 0     0 1   my $self = shift;
73 0 0         return $self->{base} unless @_;
74 0           File::Spec->catdir($self->{base}, @_);
75             }
76              
77 0     0 1   sub tempdir { CPAN::Mirror::Tiny::Tempdir->new(shift->{tempdir}) }
78 0     0 0   sub pushd_tempdir { CPAN::Mirror::Tiny::Tempdir->pushd(shift->{tempdir}) }
79              
80             sub _author_dir {
81 0     0     my ($self, $author) = @_;
82 0           my ($a2, $a1) = $author =~ /^((.).)/;
83 0           $self->base("authors", "id", $a1, $a2, $author);
84             }
85              
86             sub _locate_tarball {
87 0     0     my ($self, $file, $author) = @_;
88 0           my $dir = $self->_author_dir($author);
89 0 0         File::Path::mkpath($dir) unless -d $dir;
90 0           my $basename = File::Basename::basename($file);
91 0           my $dest = File::Spec->catfile($dir, $basename);
92 0           File::Copy::move($file, $dest);
93 0 0         return -f $dest ? $dest : undef;
94             }
95              
96             sub inject {
97 0     0 1   my ($self, $url, $option) = @_;
98              
99             my $maybe_git = sub {
100 0     0     my $url = shift;
101 0           scalar($url =~ m{\A https?:// (?:github\.com|bitbucket.org) / [^/]+ / [^/]+ \z}x);
102 0           };
103              
104 0 0 0       if ($url =~ s{^file://}{} or -e $url) {
    0 0        
    0          
    0          
105 0           $self->inject_local($url, $option);
106             } elsif ($url =~ /(?:^git|\.git(?:@(.+))?$)/ or $maybe_git->($url)) {
107 0           $self->inject_git($url, $option);
108             } elsif ($url =~ /^cpan:(.+)/) {
109 0           $self->inject_cpan($1, $option);
110             } elsif ($url =~ /^https?:/) {
111 0           $self->inject_http($url, $option);
112             } else {
113 0           die "Unknown url $url\n";
114             }
115             }
116              
117             sub _encode {
118 0     0     my $str = shift;
119 0           $str =~ s/([^a-zA-Z0-9_\-.])/uc sprintf("%%%02x",ord($1))/eg;
  0            
120 0           $str;
121             }
122              
123             sub _cpan_url {
124 0     0     my ($self, $module, $version) = @_;
125 0           my $url = "https://fastapi.metacpan.org/v1/download_url/$module";
126 0 0         $url .= "?version=" . _encode("== $version") if $version;
127 0           my $res = $self->http->get($url);
128 0 0         return (undef, "$res->{status} $res->{reason}, $url") unless $res->{success};
129 0           my $hash = eval { $JSON->decode($res->{content}) };
  0            
130 0 0         if ($@) {
131 0           return (undef, $@);
132             } else {
133 0           return ($hash->{download_url}, undef);
134             }
135             }
136              
137             sub inject_local {
138 0     0 0   my ($self, $arg) = (shift, shift);
139 0 0         if (-f $arg) {
    0          
140 0           return $self->inject_local_file($arg, @_);
141             } elsif (-d $arg) {
142 0           return $self->inject_local_directory($arg, @_);
143             } else {
144 0           die "$arg is neither file nor directory";
145             }
146             }
147              
148             sub inject_local_file {
149 0     0 0   my ($self, $file, $option) = @_;
150 0 0         die "'$file' is not a file" unless -f $file;
151 0 0         die "'$file' must be tarball or zipball" if $file !~ /(?:\.tgz|\.tar\.gz|\.tar\.bz2|\.zip)$/;
152 0           $file = Cwd::abs_path($file);
153 0           my $guard = $self->pushd_tempdir;
154 0           my $dir = $self->extract($file);
155 0           return $self->inject_local_directory($dir, $option);
156             }
157              
158             sub inject_local_directory {
159 0     0 0   my ($self, $dir, $option) = @_;
160 0           my $metafile = File::Spec->catfile($dir, "META.json");
161 0 0         die "Missing META.json in $dir" unless -f $metafile;
162 0           my $meta = CPAN::Meta->load_file($metafile);
163 0           my $distvname = sprintf "%s-%s", $meta->name, $meta->version;
164 0           $dir = Cwd::abs_path($dir);
165 0           my $guard = $self->pushd_tempdir;
166 0 0         File::Path::rmtree($distvname) if -d $distvname;
167 0 0         File::Copy::Recursive::dircopy($dir, $distvname) or die;
168 0           my ($out, $err, $exit) = run3 [$self->{tar}, "czf", "$distvname.tar.gz", $distvname];
169 0 0         die "Failed to create tarball: $err" unless $exit == 0;
170 0   0       my $author = ($option ||= {})->{author} || "VENDOR";
171 0           return $self->_locate_tarball("$distvname.tar.gz", $author);
172             }
173              
174             sub inject_http {
175 0     0 0   my ($self, $url, $option) = @_;
176 0 0         if ($url !~ /(?:\.tgz|\.tar\.gz|\.tar\.bz2|\.zip)$/) {
177 0           die "URL must be tarball or zipball\n";
178             }
179 0           my $basename = File::Basename::basename($url);
180 0           my $tempdir = $self->tempdir;
181 0           my $file = File::Spec->catfile($tempdir->as_string, $basename);
182 0           my $res = $self->http->mirror($url => $file);
183 0 0         if ($res->{success}) {
184 0   0       my $author = ($option ||= {})->{author};
185 0 0         if (!$author) {
186 0 0         if ($url =~ m{/authors/id/./../([^/]+)/}) {
187 0           $author = $1;
188 0           return $self->_locate_tarball($file, $author);
189             } else {
190 0           $author = "VENDOR";
191             }
192             }
193 0           return $self->inject_local_file($file, {author => $author});
194             } else {
195 0           die "Couldn't get $url: $res->{status} $res->{reason}";
196             }
197             }
198              
199             sub inject_cpan {
200 0     0 0   my ($self, $package, $option) = @_;
201 0           $package =~ s/^cpan://;
202 0           my $version = $option->{version};
203 0 0         if ($package =~ s/@(.+)$//) {
204 0   0       $version ||= $1;
205             }
206 0           my ($url, $err) = $self->_cpan_url($package, $version);
207 0 0         die $err if $err;
208 0           $self->inject_http($url, $option);
209             }
210              
211             sub inject_git {
212 0     0 0   my ($self, $url, $option) = @_;
213              
214 0   0       my $ref = ($option ||= {})->{ref};
215 0 0         if ($url =~ /(.*)\@(.*)$/) {
216             # take care of git@github.com:skaji/repo@tag, http://user:pass@example.com/foo@tag
217 0           my ($leading, $remove) = ($1, $2);
218 0           my ($out, $err, $exit) = run3 [$self->{git}, "ls-remote", $leading];
219 0 0         if ($exit == 0) {
220 0           $ref = $remove;
221 0           $url =~ s/\@$remove$//;
222             }
223             }
224              
225 0           my $guard = $self->pushd_tempdir;
226 0           my (undef, $err, $exit) = run3 [$self->{git}, "clone", $url, "."];
227 0 0         die "Couldn't git clone $url: $err" unless $exit == 0;
228 0 0         if ($ref) {
229 0           my (undef, $err, $exit) = run3 [$self->{git}, "checkout", $ref];
230 0 0         die "Couldn't git checkout $ref: $err" unless $exit == 0;
231             }
232 0           my $metafile = "META.json";
233 0 0         die "Couldn't find $metafile in $url" unless -f $metafile;
234 0           my $meta = CPAN::Meta->load_file($metafile);
235 0           my ($rev) = run3 [$self->{git}, "rev-parse", "--short", "HEAD"];
236 0           chomp $rev;
237 0           my $distvname = sprintf "%s-%s-%s", $meta->name, $meta->version, $rev;
238             {
239 0           my $temp = File::Temp->new(SUFFIX => '.tar', EXLOCK => 0);
  0            
240             (undef, $err, $exit)
241 0           = run3 [$self->{git}, "archive", "--format=tar", "--prefix=$distvname/", "HEAD"], $temp->filename;
242 0 0         last if $exit != 0;
243 0           (undef, $err, $exit) = run3 [$self->{gzip}, "--stdout", "--no-name", $temp->filename], "$distvname.tar.gz";
244             }
245 0 0 0       if ($exit == 0 && -f "$distvname.tar.gz") {
246 0   0       my $author = ($option || +{})->{author} || "VENDOR";
247 0           return $self->_locate_tarball("$distvname.tar.gz", $author);
248             } else {
249 0           die "Couldn't archive $url: $err";
250             }
251             }
252              
253             sub _cached {
254 0     0     my ($self, $path, $sub) = @_;
255 0 0         return unless -f $path;
256 0           my $cache_dir = $self->base("modules", ".cache");
257 0 0         File::Path::mkpath($cache_dir) unless -d $cache_dir;
258              
259 0           my $md5 = Digest::MD5->new;
260 0 0         $md5->addfile(do { open my $fh, "<", $path or die; $fh });
  0            
  0            
261 0           my $cache_file = File::Spec->catfile($cache_dir, $md5->hexdigest . ".json");
262              
263 0 0         if (-f $cache_file) {
264 0 0         my $content = do { open my $fh, "<", $cache_file or die; local $/; <$fh> };
  0            
  0            
  0            
265 0           my $cache = $JSON->decode($content);
266 0 0 0       if ( ($cache->{version} || 0) == $CACHE_VERSION ) {
267 0           return $cache->{payload};
268             } else {
269 0           unlink $cache_file;
270             }
271             }
272 0           my $result = $sub->();
273 0 0         if ($result) {
274 0 0         open my $fh, ">", $cache_file or die;
275 0           my $content = {version => $CACHE_VERSION, payload => $result};
276 0           print {$fh} $JSON->encode($content), "\n";
  0            
277 0           close $fh;
278             }
279 0           $result;
280             }
281              
282             sub extract_provides {
283 0     0 0   my ($self, $path) = @_;
284 0           $path = Cwd::abs_path($path);
285 0     0     $self->_cached($path, sub { $self->_extract_provides($path) });
  0            
286             }
287              
288             sub _extract_provides {
289 0     0     my ($self, $path) = @_;
290 0           my $gurad = $self->pushd_tempdir;
291 0 0         my $dir = $self->extract($path) or return;
292 0           my $parser = Parse::LocalDistribution->new({ALLOW_DEV_VERSION => 1});
293 0 0         $parser->parse($dir) || +{};
294             }
295              
296             sub index_path {
297 0     0 0   my ($self, %option) = @_;
298 0           my $file = $self->base("modules", "02packages.details.txt");
299 0 0         $option{compress} ? "$file.gz" : $file;
300             }
301              
302             sub index {
303 0     0 1   my ($self, %option) = @_;
304 0           my $base = $self->base("authors", "id");
305 0 0         return unless -d $base;
306              
307 0           my @dist;
308             my $wanted = sub {
309 0 0   0     return unless -f;
310 0 0         return unless /(?:\.tgz|\.tar\.gz|\.tar\.bz2|\.zip)$/;
311 0           my $path = $_;
312 0           push @dist, {
313             path => $path,
314             mtime => (stat $path)[9],
315             relative => File::Spec::Unix->abs2rel($path, $base),
316             };
317 0           };
318 0           File::Find::find({wanted => $wanted, no_chdir => 1}, $base);
319              
320 0           my %packages;
321 0           for my $i (0..$#dist) {
322 0           my $dist = $dist[$i];
323 0 0         if ($option{show_progress}) {
324             warn sprintf "%d/%d examining %s\n",
325 0           $i+1, scalar @dist, $dist->{relative};
326             }
327 0           my $provides = $self->extract_provides($dist->{path});
328 0           $self->_update_packages(\%packages, $provides, $dist->{relative}, $dist->{mtime});
329             }
330              
331 0           my @line;
332 0           for my $package (sort { lc $a cmp lc $b } keys %packages) {
  0            
333 0           my $path = $packages{$package}[1];
334 0           my $version = $packages{$package}[0];
335 0 0         $version = 'undef' unless defined $version;
336 0           push @line, sprintf "%-36s %-8s %s\n", $package, $version, $path;
337             }
338 0           join '', @line;
339             }
340              
341             sub write_index {
342 0     0 1   my ($self, %option) = @_;
343 0           my $file = $self->index_path;
344 0           my $dir = File::Basename::dirname($file);
345 0 0         File::Path::mkpath($dir) unless -d $dir;
346 0 0         open my $fh, ">", "$file.tmp" or die "Couldn't open $file: $!";
347 0           printf {$fh} "Written-By: %s %s\n\n", ref $self, $self->VERSION;
  0            
348 0           print {$fh} $self->index(%option);
  0            
349 0           close $fh;
350 0 0         if ($option{compress}) {
351             my (undef, $err, $exit)
352 0           = run3 [$self->{gzip}, "--stdout", "--no-name", "$file.tmp"], "$file.gz.tmp";
353 0 0         if ($exit == 0) {
354 0 0         rename "$file.gz.tmp", "$file.gz"
355             or die "Couldn't rename $file.gz.tmp to $file.gz: $!";
356 0           unlink "$file.tmp";
357 0           return "$file.gz";
358             } else {
359 0           unlink $_ for "$file.tmp", "$file.gz.tmp";
360 0           return;
361             }
362             } else {
363 0 0         rename "$file.tmp", $file or die "Couldn't rename $file.tmp to $file: $!";
364 0           return $file;
365             }
366             }
367              
368             # Copy from WorePAN: https://github.com/charsbar/worepan/blob/master/lib/WorePAN.pm
369             # Copyright (C) 2012 by Kenichi Ishigaki.
370             # This program is free software; you can redistribute it and/or
371             # modify it under the same terms as Perl itself.
372             sub _update_packages {
373 0     0     my ($self, $packages, $info, $path, $mtime) = @_;
374              
375 0           for my $module (sort keys %$info) {
376 0 0         next unless exists $info->{$module}{version};
377 0           my $new_version = $info->{$module}{version};
378 0 0         if (!$packages->{$module}) { # shortcut
379 0           $packages->{$module} = [$new_version, $path, $mtime];
380 0           next;
381             }
382 0           my $ok = 0;
383 0           my $cur_version = $packages->{$module}[0];
384 0 0         if (Parse::PMFile->_vgt($new_version, $cur_version)) {
    0          
385 0           $ok++;
386             }
387             elsif (Parse::PMFile->_vgt($cur_version, $new_version)) {
388             # lower VERSION number
389             }
390             else {
391 1     1   8 no warnings; # numeric/version
  1         3  
  1         150  
392 0 0 0       if (
      0        
393             $new_version eq 'undef' or $new_version == 0 or
394             Parse::PMFile->_vcmp($new_version, $cur_version) == 0
395             ) {
396 0 0         if ($mtime >= $packages->{$module}[2]) {
397 0           $ok++; # dist is newer
398             }
399             }
400             }
401 0 0         if ($ok) {
402 0           $packages->{$module} = [$new_version, $path, $mtime];
403             }
404             }
405             }
406              
407             1;
408             __END__