File Coverage

blib/lib/Test/BrewBuild/BrewCommands.pm
Criterion Covered Total %
statement 66 109 60.5
branch 12 40 30.0
condition 1 3 33.3
subroutine 14 18 77.7
pod 10 10 100.0
total 103 180 57.2


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