File Coverage

blib/lib/App/SmokeBrew/Tools.pm
Criterion Covered Total %
statement 131 138 94.9
branch 66 90 73.3
condition 25 36 69.4
subroutine 23 23 100.0
pod 7 7 100.0
total 252 294 85.7


line stmt bran cond sub pod time code
1             $App::SmokeBrew::Tools::VERSION = '1.02';
2             #ABSTRACT: Various utility functions for smokebrew
3              
4             use strict;
5 4     4   83278 use warnings;
  4         15  
  4         113  
6 4     4   21 use Archive::Extract;
  4         16  
  4         88  
7 4     4   2198 use File::Fetch;
  4         578614  
  4         196  
8 4     4   2082 use File::Spec;
  4         54625  
  4         121  
9 4     4   27 use List::Util qw[uniq];
  4         7  
  4         76  
10 4     4   18 use Module::CoreList;
  4         8  
  4         404  
11 4     4   10021 use Perl::Version;
  4         355191  
  4         50  
12 4     4   4610 use URI;
  4         6864  
  4         138  
13 4     4   2695  
  4         15645  
  4         4975  
14             my @mirrors = (
15             'http://www.cpan.org/',
16             'http://cpan.cpantesters.org/',
17             );
18              
19             my $fetch = shift;
20             $fetch = shift if $fetch->isa(__PACKAGE__);
21 1     1 1 38420 return unless $fetch;
22 1 50       15 my $loc = shift || return;
23 1 50       4 my $mirrors = shift;
24 1   50     5 $mirrors = \@mirrors unless
25 1         2 $mirrors and ref $mirrors eq 'ARRAY' and scalar @{ $mirrors };
26             $loc = File::Spec->rel2abs($loc);
27 1 0 33     6 my $stat;
  0   50     0  
28 1         82 foreach my $mirror ( @{ $mirrors } ) {
29 1         10 my $uri = URI->new( ( $mirror->isa('URI') ? $mirror->as_string : $mirror ) );
30 1         2 $uri->path_segments( ( grep { $_ } $uri->path_segments ), split(m!/!, $fetch) );
  1         4  
31 1 50       16 my $ff = File::Fetch->new( uri => $uri->as_string );
32 1         8515 $stat = $ff->fetch( to => $loc );
  2         100  
33 1         96 last if $stat;
34 1         5316 }
35 1 50       145016 return $stat;
36             }
37 1         31  
38             my $file = shift;
39             $file = shift if $file->isa(__PACKAGE__);
40             return unless $file;
41 1     1 1 1316 my $loc = shift || return;
42 1 50       20 $loc = File::Spec->rel2abs($loc);
43 1 50       4 local $Archive::Extract::PREFER_BIN=1;
44 1   50     7 my $ae = Archive::Extract->new( archive => $file );
45 1         28 return unless $ae;
46 1         10 return unless $ae->extract( to => $loc );
47 1         26 return $ae->extract_path();
48 1 50       362 }
49 1 50       13  
50 1         48926 return $ENV{PERL5_SMOKEBREW_DIR}
51             if exists $ENV{PERL5_SMOKEBREW_DIR}
52             && defined $ENV{PERL5_SMOKEBREW_DIR};
53              
54             my @os_home_envs = qw( APPDATA HOME USERPROFILE WINDIR SYS$LOGIN );
55              
56 1 50 33 1 1 518 for my $env ( @os_home_envs ) {
57             next unless exists $ENV{ $env };
58 0         0 next unless defined $ENV{ $env } && length $ENV{ $env };
59             return $ENV{ $env } if -d $ENV{ $env };
60 0         0 }
61 0 0       0  
62 0 0 0     0 return cwd();
63 0 0       0 }
64              
65             my $type = shift;
66 0         0 $type = shift if $type->isa(__PACKAGE__);
67             if ( $type and $type eq 'latest' ) {
68             my %perls;
69             foreach my $pv ( map { Perl::Version->new($_) } perls('recent') ) {
70 8     8 1 42182 my $vers = $pv->version;
71 8 100       80 unless ( exists $perls{$vers} ) {
72 8 100 100     87 $perls{$vers} = $pv;
73 1         1 next;
74 1         7 }
  37         2515  
75 37         641 $perls{$vers} = $pv if $pv > $perls{$vers};
76 37 100       817 }
77 10         34 return map { _format_version($_) } map { $perls{$_} }
78 10         26 sort { $perls{$a} <=> $perls{$b} } keys %perls;
79             ;
80 27 50       72 }
81             unless ( $type and $type =~ /^(rel|dev|recent|modern)$/i ) {
82 10         17 $type =~ s/[^\d\.]+//g if $type;
  10         31  
83 1         439 }
  21         370  
84             return
85             uniq
86 7 100 100     98 map { _format_version($_) }
87 2 100       20 grep {
88             if ( $type and $type eq 'rel' ) {
89             _is_rel($_) and !_is_ancient($_);
90             }
91 486         886 elsif ( $type and $type eq 'dev' ) {
92             _is_dev($_) and !_is_ancient($_);
93 1288 100 100     26020 }
    100 100        
    100 100        
    100 100        
    100          
94 184 100       247 elsif ( $type and $type eq 'recent' ) {
95             _is_recent($_);
96             }
97 184 100       268 elsif ( $type and $type eq 'modern' ) {
98             _is_modern($_);
99             }
100 368         489 elsif ( $type ) {
101             $_->normal =~ /\Q$type\E$/;
102             }
103 184         249 else {
104             _is_dev($_) or _is_rel($_) and !_is_ancient($_);
105             }
106 184         317 }
107             map { Perl::Version->new($_) }
108             map { $_ >= 5.006 ? sprintf('%.6f', $_) : $_ }
109 184 100 66     241 sort keys %Module::CoreList::released;
110             }
111              
112 1288         87868 my $pv = shift;
113 7 100       639 return 1 if $pv->numify >= 5.021004;
  1288         3918  
114             return 0;
115             }
116              
117             my $pv = shift;
118 2     2   155 return 0 if _is_ancient($pv);
119 2 100       5 return $pv->version % 2;
120 1         27 }
121              
122             my $pv = shift;
123             return 0 if _is_ancient($pv);
124 892     892   1139 return !( $pv->version % 2 );
125 892 100       1042 }
126 872         1433  
127             my $pv = shift;
128             return 0 if _is_ancient($pv);
129             return 0 if _is_dev($pv);
130 254     254   1661 return 1 if $pv->numify >= 5.008009;
131 254 100       313 return 0;
132 234         380 }
133              
134             my $pv = shift;
135             return 0 if _is_ancient($pv);
136 368     368   506 return 0 if _is_dev($pv);
137 368 100       457 return 1 if $pv->numify >= 5.010000;
138 348 100       548 return 0;
139 120 100       2906 }
140 28         570  
141             my $pv = shift;
142             ( my $numify = $pv->numify ) =~ s/_//g;
143             return 1 if $numify < 5.006;
144 184     184   221 return 0;
145 184 100       232 }
146 174 100       256  
147 60 100       1406 my $pv = shift;
148 15         312 my $numify = $pv->numify;
149             $numify =~ s/_//g;
150             return $pv if $numify < 5.006;
151             my $normal = $pv->normal();
152 1932     1932   7153 $normal =~ s/^v//g;
153 1932         3006 return $normal;
154 1932 100       39913 }
155 1862         3278  
156             my $vers = shift;
157             $vers = shift if eval { $vers->isa(__PACKAGE__) };
158             my $version = Perl::Version->new( $vers );
159 496     496   555 ( my $numify = $version->numify ) =~ s/_//g;
160 496         854 my $pv = 'perl'.( $numify < 5.006 ? $version->numify : $version->normal );
161 496         9917 $pv =~ s/perlv/perl-/g;
162 496 50       1003 return $pv;
163 496         886 }
164 496         9755  
165 496         1577 my $perl = shift;
166             $perl = shift if eval { $perl->isa(__PACKAGE__) };
167             return unless $perl;
168             return _is_dev( Perl::Version->new( $perl ) );
169 2     2 1 291 }
170 2 50       4  
  2         11  
171 2         7 my $perl = shift;
172 2         164 $perl = shift if eval { $perl->isa(__PACKAGE__) };
173 2 100       57 return unless $perl;
174 2         54 return _has_quadmath( Perl::Version->new( $perl ) );
175 2         15 }
176              
177             qq[Smoke tools look what's inside of you];
178              
179 2     2 1 2278  
180 2 50       4 =pod
  2         13  
181 2 50       7  
182 2         7 =encoding UTF-8
183              
184             =head1 NAME
185              
186 2     2 1 288 App::SmokeBrew::Tools - Various utility functions for smokebrew
187 2 50       4  
  2         14  
188 2 50       8 =head1 VERSION
189 2         8  
190             version 1.02
191              
192             =head1 SYNOPSIS
193              
194             use strict;
195             use warnings;
196             use App::SmokeBrew::Tools;
197              
198             # Fetch a perl source tarball
199             my $filename = App::SmokeBrew::Tools->fetch( $path_to_fetch, $where_to_fetch_to );
200              
201             # Extract a tarball
202             my $extracted_loc = App::SmokeBrew::Tools->extract( $tarball, $where_to_extract_to );
203              
204             # Find the smokebrew directory
205             my $dir = App::SmokeBrew::Tools->smokebrew_dir();
206              
207             # Obtain a list of perl versions
208             my @perls = App::SmokeBrew::Tools->perls(); # All perls >= 5.006
209              
210             my @stables = App::SmokeBrew::Tools->perls( 'rel' );
211              
212             my @devs = App::SmokeBrew::Tools->perls( 'dev' );
213              
214             my @recents = App::SmokeBrew::Tools->perls( 'recent' );
215              
216             my $perl = '5.13.0';
217              
218             if ( App::SmokeBrew::Tools->devel_perl( $perl ) ) {
219             print "perl ($perl) is a development perl\n";
220             }
221              
222             =head1 DESCRIPTION
223              
224             App::SmokeBrew::Tools provides a number of utility functions for L<smokebrew>.
225              
226             =head1 FUNCTIONS
227              
228             =over
229              
230             =item C<fetch>
231              
232             Requires two mandatory parameters and one optional. The first two parameters are the path to
233             fetch from a CPAN mirror and the file system path where you want the file fetched to.
234             The third, optional parameter, is an arrayref of CPAN mirrors that you wish the file to fetched from.
235              
236             Returns the path to the fetched file on success, false otherwise.
237              
238             This function is a wrapper around L<File::Fetch>.
239              
240             =item C<extract>
241              
242             Requires two mandatory parameters, the path to a file that you wish to be extracted and the file system
243             path of where you wish the file to be extracted to. Returns the path to the extracted file on success,
244             false otherwise.
245              
246             This function is a wrapper around L<Archive::Extract>.
247              
248             =item C<smokebrew_dir>
249              
250             Returns the path to where the C<.smokebrew> directory may be found.
251              
252             =item C<perls>
253              
254             Returns a list of perl versions. Without a parameter returns all perl releases >= 5.006
255              
256             Specifying C<rel> as the parameter will return all C<stable> perl releases >= 5.006
257              
258             Specifying C<dev> as the parameter will return only the C<development> perl releases >= 5.006
259              
260             Specifying C<recent> as the parameter will return only the C<stable> perl releases >= 5.008009
261              
262             =item C<devel_perl>
263              
264             Takes one parameter a perl version to check.
265              
266             Returns true if given perl is a development perl.
267              
268             =item C<can_quadmath>
269              
270             Takes one parameter a perl version to check.
271              
272             Returns true if given perl is able to be built with C<quadmath>.
273              
274             =item C<perl_version>
275              
276             Takes one parameter a perl version.
277              
278             Returns the version with the C<perl-> prefix.
279              
280             =back
281              
282             =head1 SEE ALSO
283              
284             L<smokebrew>
285              
286             L<Perl::Version>
287              
288             L<File::Fetch>
289              
290             L<Archive::Extract>
291              
292             =head1 AUTHOR
293              
294             Chris Williams <chris@bingosnet.co.uk>
295              
296             =head1 COPYRIGHT AND LICENSE
297              
298             This software is copyright (c) 2022 by Chris Williams.
299              
300             This is free software; you can redistribute it and/or modify it under
301             the same terms as the Perl 5 programming language system itself.
302              
303             =cut