File Coverage

blib/lib/Test/Smoke/Util/FindHelpers.pm
Criterion Covered Total %
statement 26 91 28.5
branch 2 48 4.1
condition 0 12 0.0
subroutine 7 14 50.0
pod 9 9 100.0
total 44 174 25.2


line stmt bran cond sub pod time code
1             package Test::Smoke::Util::FindHelpers;
2 4     4   2066 use warnings;
  4         10  
  4         138  
3 4     4   20 use strict;
  4         19  
  4         148  
4              
5             our $VERSION = '0.001';
6              
7             =head1 NAME
8              
9             Test::Smoke::Util::FindHelpers - Functions to help find Helpers (modules/bins)
10              
11             =head1 SYNOPSIS
12              
13             use Test::Smoke::Util::FindHelpers ':all';
14              
15             =cut
16              
17 4     4   20 use Config;
  4         10  
  4         170  
18 4     4   24 use Test::Smoke::Util 'whereis';
  4         9  
  4         186  
19              
20             =head1 EXPORT_OK/EXPORT_TAGS
21              
22             has_module whereis
23             get_avail_tar get_avail_patchers
24             get_avail_posters get_avail_sync get_avail_mailers
25             get_avail_w32compilers
26             get_avail_vms_make
27              
28             :all
29             =cut
30              
31 4     4   25 use Exporter 'import';
  4         9  
  4         5711  
32             our @EXPORT_OK = qw/
33             has_module whereis
34             get_avail_tar get_avail_patchers
35             get_avail_posters get_avail_sync get_avail_mailers
36             get_avail_w32compilers
37             get_avail_vms_make
38             /;
39             our %EXPORT_TAGS = (
40             all => [ @EXPORT_OK ],
41              
42             );
43              
44             =head1 DESCRIPTION
45              
46             =head2 has_module($module)
47              
48             Retuns true if the named module could be Cd.
49              
50             =cut
51              
52             sub has_module {
53 7     7 1 17638 my ($module) = @_;
54 7         18 { local $^W; eval "require $module"; }
  7         49  
  7         731  
55 7         276193 return !$@;
56             }
57              
58             =head2 get_avail_patchers
59              
60             Returns a list of available patch programs (gpatch npatch patch)
61              
62             =cut
63              
64             sub get_avail_patchers {
65 0     0 1 0 my @patchers;
66              
67 0         0 foreach my $patcher (qw( gpatch npatch patch )) {
68 0 0       0 if (my $patch_bin = whereis($patcher)) {
69 0         0 my $version = `$patch_bin -version`;
70 0 0       0 $? or push @patchers, $patch_bin;
71             }
72             }
73 0         0 return @patchers;
74             }
75              
76             =head2 get_avail_posters
77              
78             Return a list of available modules/programs that can be used to HTTP/POST a message.
79             (HTTP::Tiny, LWP::UserAgent, curl)
80              
81             =cut
82              
83             sub get_avail_posters {
84 2     2 1 235 my @posters;
85              
86 2         8 my @modules = qw/HTTP::Tiny LWP::UserAgent/;
87 2         7 for my $module (@modules) {
88 4 50       14 push @posters, $module if has_module($module);
89             }
90 2 50       20 push @posters, 'curl', if whereis('curl');
91              
92 2         13 return @posters;
93             }
94              
95             =head2 get_avail_sync
96              
97             Returns a list of available syncer modules/programs (git, rsync)
98              
99             =cut
100              
101             sub get_avail_sync {
102 0     0 1   my @synctype = qw(copy hardlink);
103              
104 0 0         unshift @synctype, 'rsync' if whereis( 'rsync' );
105              
106 0 0         unshift @synctype, 'git' if whereis('git');
107              
108 0           return @synctype;
109             }
110              
111             =head2 get_avail_tar
112              
113             Returns a list of available untar/ungzip modules/programs (Archive::Tar/...Zlib, tar/gzip)
114              
115             =cut
116              
117             sub get_avail_tar {
118 0     0 1   my $use_modules = 0;
119              
120 0           my $has_archive_tar = has_module('Archive::Tar');
121 0 0         if ($has_archive_tar) {
122 0 0         if ( eval "$Archive::Tar::VERSION" >= 0.99 ) {
123 0           $use_modules = has_module('IO::Zlib');
124             } else {
125 0           $use_modules = has_module('Compress::Zlib');
126             }
127             }
128              
129 0           my $fmt = tar_fmt();
130              
131 0 0 0       return $fmt && $use_modules
    0          
    0          
132             ? ( $fmt, 'Archive::Tar' )
133             : $fmt ? ( $fmt ) : $use_modules ? ( 'Archive::Tar' ) : ();
134             }
135              
136             =head2 tar_fmt
137              
138             Returns the format with wich to gunzip and untar.
139             (gzip -cd %s | tar -xf -) or (tar -xzf %s)
140              
141             =cut
142              
143             sub tar_fmt {
144 0     0 1   my $tar = whereis( 'tar' );
145 0           my $gzip = whereis( 'gzip' );
146              
147 0 0 0       return $tar && $gzip
    0          
148             ? "$gzip -cd %s | $tar -xf -"
149             : $tar ? "tar -xzf %s" : "";
150             }
151              
152             =head2 get_avail_mailers
153              
154             Returns a list available mail modules/programs.
155              
156             =cut
157              
158             sub get_avail_mailers {
159 0     0 1   my %map;
160              
161 0           for my $mailer (qw/mail mailx sendmail sendemail/) {
162 0           local $ENV{PATH} = "$ENV{PATH}$Config{path_sep}/usr/sbin";
163 0 0         if (my $mailer_bin = whereis($mailer)) {
164 0           $map{$mailer} = $mailer_bin;
165             }
166             }
167              
168 0           for my $module (qw/Mail::Sendmail MIME::Lite/) {
169 0 0         $map{$module} = $module if has_module($module);
170             }
171 0           return %map;
172             }
173              
174             =head2 get_avail_w32compilers
175              
176             Returns a list of compilers found (Win32 specific)
177              
178             =cut
179              
180             sub get_avail_w32compilers {
181              
182 0     0 1   my %map = (
183             MSVC => { ccname => 'cl', maker => [ 'nmake' ] },
184             BCC => { ccname => 'bcc32', maker => [ 'dmake' ] },
185             GCC => { ccname => 'gcc', maker => [ 'dmake', 'gmake' ] },
186             );
187              
188 0           my $CC = 'MSVC';
189 0 0         if ( $map{ $CC }->{ccbin} = whereis( $map{ $CC }->{ccname} ) ) {
190             # No, cl doesn't support --version (One can but try)
191 0           my $output =`$map{ $CC }->{ccbin} --version 2>&1`;
192 0 0         my $ccvers = $output =~ /^.*Version\s+([\d.]+)/ ? $1 : '?';
193 0           $map{ $CC }->{ccversarg} = "ccversion=$ccvers";
194 0 0         my $mainvers = $ccvers =~ /^(\d+)/ ? $1 : 1;
195 0 0         $map{ $CC }->{CCTYPE} = $mainvers < 12 ? 'MSVC' : 'MSVC60';
196             }
197              
198 0           $CC = 'BCC';
199 0 0         if ( $map{ $CC }->{ccbin} = whereis( $map{ $CC }->{ccname} ) ) {
200             # No, bcc32 doesn't support --version (One can but try)
201 0           my $output = `$map{ $CC }->{ccbin} --version 2>&1`;
202 0 0         my $ccvers = $output =~ /([\d.]+)/ ? $1 : '?';
203 0           $map{ $CC }->{ccversarg} = "ccversion=$ccvers";
204 0           $map{ $CC }->{CCTYPE} = 'BORLAND';
205             }
206              
207 0           $CC = 'GCC';
208 0 0         if ( $map{ $CC }->{ccbin} = whereis( $map{ $CC }->{ccname} ) ) {
209 0           local *STDERR;
210 0           open STDERR, ">&STDOUT"; #do we need an error?
211 0           select( (select( STDERR ), $|++ )[0] );
212 0           my $output = `$map{ $CC }->{ccbin} --version`;
213 0 0         my $ccvers = $output =~ /(\d+.*)/ ? $1 : '?';
214 0           $ccvers =~ s/\s+copyright.*//i;
215 0           $map{ $CC }->{ccversarg} = "gccversion=$ccvers";
216 0           $map{ $CC }->{CCTYPE} = $CC
217             }
218              
219             return map {
220 0           ( $map{ $_ }->{CCTYPE} => $map{ $_ } )
221 0           } grep length $map{ $_ }->{ccbin} => keys %map;
222             }
223              
224             =head2 get_avail_vms_make
225              
226             Return a list of "make" programs installed on the VMS system.
227              
228             =cut
229              
230             sub get_avail_vms_make {
231              
232 0   0 0 1   return map +( $_ => undef ) => grep defined $_ && length( $_ )
233             => map whereis( $_ ) => qw( MMK MMS );
234              
235 0           local *QXERR; open *QXERR, ">&STDERR"; close STDERR;
  0            
  0            
236              
237             my %makers = map {
238 0           my $maker = $_;
  0            
239 0 0 0       map +( $maker => /V([\d.-]+)/ ? $1 : '' )
240             => grep /\b$maker\b/ && /V[\d.-]+/ => qx($maker/IDENT)
241             } qw( MMK MMS );
242              
243 0           open STDERR, ">&QXERR"; close QXERR;
  0            
244              
245 0           return %makers;
246             }
247              
248             1;
249              
250             =head1 COPYRIGHT
251              
252             (c) MMII - MMXV, The Test-Smoke Team
253              
254             See L for full acknowlegements.
255              
256             =cut