File Coverage

blib/lib/OrePAN2/Indexer/Tiny.pm
Criterion Covered Total %
statement 42 128 32.8
branch 0 30 0.0
condition 0 7 0.0
subroutine 14 26 53.8
pod 0 6 0.0
total 56 197 28.4


line stmt bran cond sub pod time code
1             package OrePAN2::Indexer::Tiny;
2 1     1   752 use strict;
  1         2  
  1         31  
3 1     1   6 use warnings;
  1         2  
  1         23  
4 1     1   664 use utf8;
  1         15  
  1         5  
5              
6 1     1   666 use Archive::Extract ();
  1         189786  
  1         34  
7 1     1   541 use CPAN::Meta;
  1         29249  
  1         33  
8 1     1   8 use Carp ();
  1         3  
  1         16  
9 1     1   5 use File::Basename ();
  1         3  
  1         19  
10 1     1   5 use File::Find qw(find);
  1         3  
  1         47  
11 1     1   6 use File::Spec ();
  1         3  
  1         16  
12 1     1   807 use File::Temp qw(tempdir);
  1         10015  
  1         74  
13 1     1   479 use File::pushd qw(pushd);
  1         1232  
  1         63  
14 1     1   622 use IO::Uncompress::Gunzip ('$GunzipError');
  1         36535  
  1         103  
15 1     1   617 use IO::Zlib;
  1         24022  
  1         9  
16 1     1   567 use Parse::LocalDistribution;
  1         66472  
  1         1495  
17              
18             our $VERSION = "0.03";
19              
20             sub new {
21 0     0 0   my ($class, %args) = @_;
22 0 0         unless ( defined $args{directory} ) {
23 0           Carp::croak('Missing mandatory parameter: directory');
24             }
25             bless {
26 0           index => {},
27             %args,
28             }, $class;
29             }
30              
31             sub add_index {
32 0     0 0   my ( $self, $archive_file ) = @_;
33              
34 0           my $archive = Archive::Extract->new( archive => $archive_file );
35 0           my $tmpdir = tempdir( 'orepan2.XXXXXX', TMPDIR => 1, CLEANUP => 1 );
36 0           $archive->extract( to => $tmpdir );
37              
38 0           my $provides = $self->scan_provides( $tmpdir, $archive_file );
39 0           my $path = $self->_orepan_archive_path($archive_file);
40              
41 0           for my $package ( sort keys %{$provides} ) {
  0            
42             $self->_add_index(
43             $package,
44             $provides->{$package}->{version},
45 0           $path,
46             );
47             }
48             }
49              
50             # Order of preference is last updated. So if some modules maintain the same
51             # version number across multiple uploads, we'll point to the module in the
52             # latest archive.
53              
54             sub _add_index {
55 0     0     my ( $self, $package, $version, $archive_file ) = @_;
56              
57 0 0         if ( $self->{index}{$package} ) {
58 0           my ($orig_ver) = @{ $self->{index}{$package} };
  0            
59              
60 0 0         if ( version->parse($orig_ver) > version->parse($version) ) {
61 0   0       $version //= 'undef';
62 0           print STDERR "[INFO] Not adding $package in $archive_file\n";
63 0           print STDERR
64             "[INFO] Existing version $orig_ver is greater than $version\n";
65 0           return;
66             }
67             }
68 0           $self->{index}->{$package} = [ $version, $archive_file ];
69             }
70              
71             sub _orepan_archive_path {
72 0     0     my ( $self, $archive_file ) = @_;
73             my $path = File::Spec->abs2rel(
74             $archive_file,
75 0           File::Spec->catfile( $self->{directory}, 'authors', 'id' )
76             );
77 0           $path =~ s!\\!/!g;
78 0           return $path;
79             }
80              
81             sub scan_provides {
82 0     0 0   my ( $self, $dir, $archive_file ) = @_;
83              
84 0           my $guard = pushd( glob("$dir/*") );
85 0           for my $mfile ( 'META.json', 'META.yml', 'META.yaml' ) {
86 0 0         next unless -f $mfile;
87 0           my $meta = eval { CPAN::Meta->load_file($mfile) };
  0            
88 0 0 0       return $meta->{provides} if $meta && $meta->{provides};
89              
90 0 0         if ($@) {
91 0           print STDERR "[WARN] Error using '$mfile' from '$archive_file'\n";
92 0           print STDERR "[WARN] $@\n";
93 0           print STDERR "[WARN] Attempting to continue...\n";
94             }
95             }
96              
97 0           print STDERR
98             "[INFO] Found META file in '$archive_file' but it does not contain 'provides'\n";
99 0           print STDERR "[INFO] Scanning for provided modules...\n";
100              
101 0           my $provides = eval { $self->_scan_provides('.') };
  0            
102 0 0         return $provides if $provides;
103              
104 0           print STDERR "[WARN] Error scanning: $@\n";
105              
106             # Return empty provides.
107 0           return {};
108             }
109              
110             sub _scan_provides {
111 0     0     my ( $self, $dir, $meta ) = @_;
112              
113 0           my $provides = Parse::LocalDistribution->new( { ALLOW_DEV_VERSION => 1 } )
114             ->parse($dir);
115 0           return $provides;
116             }
117              
118             sub write_index {
119 0     0 0   my ( $self ) = @_;
120              
121 0           my $pkgfname = $self->_package_file();
122 0           mkdir( File::Basename::dirname($pkgfname) );
123 0 0         my $fh = IO::Zlib->new( $pkgfname, 'w' )
124             or die "Cannot open $pkgfname for writing: $!\n";
125 0           print $fh $self->_as_string();
126 0           close $fh;
127             }
128              
129             sub _as_string {
130 0     0     my ( $self ) = @_;
131              
132 0           my @buf;
133              
134 0           push @buf, <<"...";
135             File: 02packages.details.txt
136             URL: http://www.perl.com/CPAN/modules/02packages.details.txt
137             Description: DarkPAN
138             Columns: package name, version, path
139             Intended-For: Automated fetch routines, namespace documentation.
140             Written-By: OrePAN2::Indexer::Tiny $OrePAN2::Indexer::Tiny::VERSION
141 0           Line-Count: @{[ scalar(keys %{$self->{index}}) ]}
  0            
142 0           Last-Updated: @{[ scalar localtime ]}
143             ...
144              
145 0           for my $pkg ( sort { lc $a cmp lc $b } keys %{ $self->{index} } ) {
  0            
  0            
146 0           my $entry = $self->{index}{$pkg};
147              
148             # package name, version, path
149 0   0       push @buf, sprintf '%-22s %-22s %s', $pkg, $entry->[0] || 'undef',
150             $entry->[1];
151             }
152 0           return join( "\n", @buf ) . "\n";
153             }
154              
155             sub load_index {
156 0     0 0   my ( $self ) = @_;
157              
158 0 0         return unless -e $self->_package_file;
159              
160 0 0         my $fh = IO::Uncompress::Gunzip->new($self->_package_file)
161             or die "gzip failed: $GunzipError\n";
162              
163             # skip headers
164 0           while (<$fh>) {
165 0 0         last unless /\S/;
166             }
167              
168 0           while (<$fh>) {
169 0 0         if (/^(\S+)\s+(\S+)\s+(.*)$/) {
170 0 0         $self->_add_index( $1, $2 eq 'undef' ? undef : $2, $3 );
171             }
172             }
173              
174 0           close $fh;
175             }
176              
177             sub _package_file {
178 0     0     my ( $self ) = @_;
179              
180             return File::Spec->catfile(
181             $self->{directory},
182 0           'modules',
183             '02packages.details.txt.gz'
184             );
185             }
186              
187             sub list_archive_files {
188 0     0 0   my ( $self ) = @_;
189              
190 0           my $authors_dir = File::Spec->catfile( $self->{directory}, 'authors' );
191 0 0         return () unless -d $authors_dir;
192              
193 0           my @files;
194             find(
195             {
196             wanted => sub {
197 0 0   0     return unless /
198             (?:
199             \.tar\.gz
200             | \.tgz
201             | \.zip
202             )
203             \z/x;
204 0           push @files, $_;
205             },
206 0           no_chdir => 1,
207             },
208             $authors_dir
209             );
210              
211             # Sort files by modication time so that we can index distributions from
212             # earliest to latest version.
213              
214 0           return sort { -M $b <=> -M $a } @files;
  0            
215             }
216              
217             1;
218             __END__