File Coverage

blib/lib/Test/BrewBuild/BrewCommands.pm
Criterion Covered Total %
statement 62 104 59.6
branch 11 38 28.9
condition n/a
subroutine 13 17 76.4
pod 10 10 100.0
total 96 169 56.8


line stmt bran cond sub pod time code
1             package Test::BrewBuild::BrewCommands;
2 35     35   61410 use strict;
  35         71  
  35         936  
3 35     35   148 use warnings;
  35         64  
  35         721  
4              
5 35     35   11719 use version;
  35         49893  
  35         193  
6              
7 35     35   2805 use Data::Dumper;
  35         5131  
  35         1598  
8 35     35   12370 use Test::BrewBuild::Constant qw(:all);
  35         76  
  35         3746  
9 35     35   11784 use Test::BrewBuild::Regex;
  35         76  
  35         36082  
10              
11             our $VERSION = '2.20';
12              
13             my $log;
14              
15             sub new {
16 11     11 1 34 my ($class, $plog) = @_;
17              
18 11         29 my $self = bless {}, $class;
19              
20 11         48 $self->{min_perl_version} = MIN_PERL_VER;
21              
22 11         44 $self->{log} = $plog->child('BrewCommands');
23 11         265 $log = $self->{log};
24              
25 11         30 $log->child('new')->_7("instantiating new object");
26              
27 11         972 $self->brew;
28              
29 11         33 return $self;
30             }
31             sub brew {
32 11     11 1 20 my $self = shift;
33              
34 11 50       34 return $self->{brew} if $self->{brew};
35              
36 11         19 my $brew;
37              
38 11 50       32 if ($self->is_win){
39 0         0 for (split /;/, $ENV{PATH}){
40 0 0       0 if (-x "$_/berrybrew.exe"){
41 0         0 $brew = "$_/berrybrew.exe";
42 0         0 last;
43             }
44             }
45             }
46             else {
47 11         49 $brew = 'perlbrew';
48             }
49              
50 11 50       40 $log->child('brew')->_6("*brew cmd is: $brew") if $brew;
51 11         969 $self->{brew} = $brew;
52              
53 11         20 return $brew;
54             }
55             sub info {
56 0     0 1 0 my $self = shift;
57              
58 0 0       0 return $self->is_win
59             ? `$self->{brew} available 2>nul`
60             : `perlbrew available 2>/dev/null`;
61             }
62             sub installed {
63 2     2 1 18 my ($self, $legacy, $info) = @_;
64              
65 2         26 $log->child('installed')->_6("cleaning up perls installed");
66              
67 2 50       349 return if ! $info;
68              
69 0 0       0 my @installed = $self->is_win
70 0         0 ? $info =~ /${ re_brewcommands('installed_berrybrew') }/g
71 0         0 : $info =~ /${ re_brewcommands('installed_perlbrew') }/g;
72              
73 0         0 @installed = $self->_legacy_perls($legacy, @installed);
74              
75 0         0 return @installed;
76             }
77             sub using {
78 0     0 1 0 my ($self, $info) = @_;
79              
80 0         0 $log->child( 'using' )->_6( "checking for which ver we're using" );
81              
82 0 0       0 if ($self->is_win) {
83 0         0 my @installed = $info =~ /${ re_brewcommands('using_berrybrew') }/g;
  0         0  
84 0         0 return $installed[0];
85             }
86             else {
87 0         0 my $using = version->parse($])->normal;
88 0         0 $using =~ s/v//;
89 0         0 $using = "perl-$using";
90 0         0 return $using;
91             }
92             }
93             sub available {
94 1     1 1 7 my ($self, $legacy, $info) = @_;
95              
96 1         10 $log->child('available')->_6("determining available perls");
97              
98 1 50       87 my @avail = $self->is_win
99 0         0 ? $info =~ /${ re_brewcommands('available_berrybrew') }/g
100 1         15 : $info =~ /${ re_brewcommands('available_perlbrew') }/g;
101              
102 1         10 @avail = $self->_legacy_perls($legacy, @avail);
103              
104 1         3 my %seen;
105 1         4 $seen{$_}++ for @avail;
106 1         4 return keys %seen;
107             }
108             sub install {
109 0     0 1 0 my $self = shift;
110              
111 0 0       0 my $install_cmd = $self->is_win
112             ? "$self->{brew} install"
113             : 'perlbrew install --notest -j 4';
114              
115 0         0 $log->child('install')->_6("install cmd is: $install_cmd");
116              
117 0         0 return $install_cmd;
118             }
119             sub remove {
120 0     0 1 0 my $self = shift;
121              
122 0         0 my $remove_cmd;
123              
124 0 0       0 if ($self->is_win){
125 0         0 $remove_cmd = "$self->{brew} remove"
126             }
127             else {
128 0         0 my $perlbrew_ver = `$self->{brew} version`;
129 0         0 ($perlbrew_ver) = $perlbrew_ver =~ /(\d+\.\d+)/;
130              
131 0 0       0 if (version->parse($perlbrew_ver) > version->parse('0.76')){
132 0         0 $remove_cmd = 'perlbrew --yes uninstall';
133             }
134             else {
135 0         0 $remove_cmd = 'perlbrew uninstall';
136             }
137             }
138              
139 0         0 $log->child('remove')->_6("remove cmd is: $remove_cmd");
140              
141 0         0 return $remove_cmd;
142             }
143             sub is_win {
144 16 50   16 1 78 my $is_win = ($^O =~ /Win/) ? 1 : 0;
145 16         11631 return $is_win;
146             }
147             sub info_cache {
148 4     4 1 15 my ($self, $reset) = @_;
149              
150 4 100       14 if ($reset){
151 1         24 $log->child('info_cache')->_7("resetting info_cache");
152 1         446 $self->{info_cache} = 0;
153             }
154              
155 4 50       11 if (! $self->{info_cache}){
156 4 50       16 $self->{info_cache} = $self->is_win
157             ? `$self->{brew} available 2>nul`
158             : `perlbrew available 2>/dev/null`;
159              
160 4         257 $log->child('info_cache')->_7("cached availability info");
161             }
162              
163 4         1345 $log->child('info_cache')->_6("using cached availability info");
164              
165 4         658 return $self->{info_cache};
166             }
167             sub _legacy_perls {
168 1     1   6 my ($self, $legacy, @perls) = @_;
169              
170 1 50       10 if ($legacy) {
171 0         0 $log->child('_legacy_perls')->_7(
172             "legacy is enabled, using perls older than 5.8.9"
173             );
174 0 0       0 return @perls if $legacy;
175             }
176             else {
177 1         7 $log->child('_legacy_perls')->_7(
178             "legacy is disabled, ignoring perls older than 5.8.9"
179             );
180             }
181              
182 1         93 my @avail;
183              
184 1         7 for my $ver_string (@perls){
185 0         0 my ($ver) = $ver_string =~ /(5\.\d+\.\d+)/;
186              
187 0 0       0 if (version->parse($ver) > version->parse($self->{min_perl_version})){
188 0         0 push @avail, $ver_string;
189             }
190             }
191 1         11 return @avail;
192             }
193             1;
194              
195             =head1 NAME
196              
197             Test::BrewBuild::BrewCommands - Provides Windows/Unix *brew command
198             translations for Test::BrewBuild
199              
200             =head1 METHODS
201              
202             =head2 new
203              
204             Returns a new Test::BrewBuild::BrewCommands object.
205              
206             =head2 brew
207              
208             Returns C if on Unix, and the full executable path for
209             C if on Windows.
210              
211             =head2 info
212              
213             Returns the string result of C<*brew available>.
214              
215             =head2 info_cache($reset)
216              
217             Fetches, then caches the results of '*brew available'. This is due to the fact
218             that perlbrew does an Internet lookup for the information, and berrybrew will
219             shortly as well.
220              
221             The cache is rebuilt on each new program run.
222              
223             Parameters:
224              
225             $reset
226              
227             Bool, optional. Set to a true value to flush out the cache so it will be
228             re-initialized.
229              
230             =head2 installed($info)
231              
232             Takes the output of C<*brew available> in a string form. Returns the currently
233             installed versions, formatted in a platform specific manner.
234              
235             =head2 using($info)
236              
237             Returns the current version of perl we're using. C<$info> is the output from
238             C.
239              
240             =head2 available($legacy, $info)
241              
242             Similar to C, but returns all perls available. If C<$legacy> is
243             false, we'll only return C versions C<5.8.0+>.
244              
245             =head2 install
246              
247             Returns the current OS's specific C<*brew install> command.
248              
249             =head2 remove
250              
251             Returns the current OS's specific C<*brew remove> command.
252              
253             =head2 is_win
254              
255             Returns 0 if on Unix, and 1 if on Windows.
256              
257             =head1 AUTHOR
258              
259             Steve Bertrand, C<< >>
260              
261             =head1 LICENSE AND COPYRIGHT
262              
263             Copyright 2017 Steve Bertrand.
264              
265             This program is free software; you can redistribute it and/or modify it
266             under the terms of either: the GNU General Public License as published
267             by the Free Software Foundation; or the Artistic License.
268              
269             See L for more information.
270              
271              
272             =cut
273