File Coverage

blib/lib/Shipwright/Util.pm
Criterion Covered Total %
statement 82 104 78.8
branch 31 44 70.4
condition 3 15 20.0
subroutine 20 22 90.9
pod 13 13 100.0
total 149 198 75.2


line stmt bran cond sub pod time code
1             package Shipwright::Util;
2              
3 15     15   17044 use warnings;
  15         17  
  15         430  
4 15     15   54 use strict;
  15         18  
  15         331  
5 15     15   7802 use IPC::Run3;
  15         348102  
  15         920  
6 15     15   5681 use File::Spec::Functions qw/catfile catdir splitpath splitdir tmpdir rel2abs/;
  15         7518  
  15         1104  
7 15     15   72 use Cwd qw/abs_path getcwd/;
  15         17  
  15         572  
8 15     15   61 use Carp;
  15         22  
  15         641  
9 15     15   2294 use Shipwright; # we need this to find where Shipwright.pm lives
  15         22  
  15         197  
10 15     15   9348 use YAML::Tiny;
  15         71230  
  15         860  
11 15     15   93 use base 'Exporter';
  15         21  
  15         16073  
12             our @EXPORT = qw/load_yaml load_yaml_file dump_yaml dump_yaml_file run_cmd
13             select_fh shipwright_root share_root user_home confess_or_die
14             shipwright_user_root parent_dir find_module/;
15              
16             our ( $SHIPWRIGHT_ROOT, $SHARE_ROOT );
17              
18             sub load_yaml {
19 1     1 1 27073 goto &YAML::Tiny::Load;
20             }
21              
22             sub load_yaml_file {
23 4     4 1 1150 goto &YAML::Tiny::LoadFile;
24             }
25              
26             sub dump_yaml {
27 1     1 1 1076 goto &YAML::Tiny::Dump;
28             }
29              
30             sub dump_yaml_file {
31 3     3 1 1372 goto &YAML::Tiny::DumpFile;
32             }
33              
34              
35             =head1 LIST
36              
37             =head2 General Helpers
38              
39             =head3 load_yaml, load_yaml_file, dump_yaml, dump_yaml_file
40              
41             they are just dropped in from YAML::Tiny
42              
43             =head3 confess_or_die
44              
45             =cut
46              
47             sub confess_or_die {
48 9 50   9 1 37 if ( $ENV{SHIPWRIGHT_DEVEL} ) {
49 0         0 goto &confess;
50             }
51             else {
52 9         75 die @_,"\n";
53             }
54             }
55              
56             =head3 parent_dir
57              
58             return the dir's parent dir, the arg must be a dir path
59              
60             =cut
61              
62             sub parent_dir {
63 0     0 1 0 my $dir = shift;
64 0         0 my @dirs = splitdir($dir);
65 0         0 pop @dirs;
66 0         0 return catdir(@dirs);
67             }
68              
69              
70             =head3 run_cmd
71              
72             a wrapper of run3 sub in IPC::Run3.
73              
74             =cut
75              
76             sub run_cmd {
77 9     9 1 1417 my $cmd = shift;
78 9         17 my $ignore_failure = shift;
79              
80 9 100       62 if ( ref $cmd eq 'CODE' ) {
81 7         11 my @returns;
82 7 100       19 if ( $ignore_failure ) {
83 6         9 @returns = eval { $cmd->() };
  6         14  
84             }
85             else {
86 1         7 @returns = $cmd->();
87             }
88 7 100       51 return wantarray ? @returns : $returns[0];
89             }
90              
91 2         17 my $log = Log::Log4perl->get_logger('Shipwright::Util');
92              
93 2         257 my ( $out, $err );
94 2         12 $log->info( "running cmd: " . join ' ', @$cmd );
95 2         16 select_fh('null');
96 2         8 run3( $cmd, undef, \$out, \$err );
97 2         9172 select_fh('stdout');
98              
99 2 100       16 $log->debug("output:\n$out") if $out;
100 2 100       58 $log->error("err:\n$err") if $err;
101              
102 2 100       24 if ($?) {
103 1         14 $log->error(
104             'failed to run ' . join( ' ', @$cmd ) . " with exit number $?" );
105 1 50       14 unless ($ignore_failure) {
106 0 0       0 $out = "\n$out" if length $out;
107 0 0       0 $err = "\n$err" if length $err;
108 0         0 my $suggest = '';
109 0 0 0     0 if ( $err && $err =~ /Can't locate (\S+)\.pm in \@INC/ ) {
110 0         0 my $module = $1;
111 0         0 $module =~ s!/!::!g;
112 0         0 $suggest = "install $module first";
113             }
114              
115 0         0 my $cwd = getcwd;
116 0         0 confess_or_die <<"EOF";
117             command failed: @$cmd
118             \$?: $?
119             cwd: $cwd
120             stdout was: $out
121             stderr was: $err
122             suggest: $suggest
123             EOF
124             }
125              
126             }
127              
128 2 100       21 return wantarray ? ( $out, $err ) : $out;
129              
130             }
131              
132             =head3 select_fh
133              
134             wrapper for the select in core
135              
136             =cut
137              
138             my ( $null_fh, $stdout_fh, $cpan_fh, $cpan_log_path, $cpan_fh_flag );
139              
140             # use $cpan_fh_flag to record if we've selected cpan_fh before, so so,
141             # we don't need to warn that any more.
142              
143             open $null_fh, '>', '/dev/null';
144              
145             $cpan_log_path = catfile( tmpdir(), 'shipwright_cpan.log');
146              
147             open $cpan_fh, '>>', $cpan_log_path;
148             $stdout_fh = select;
149              
150             sub select_fh {
151 8     8 1 2545 my $type = shift;
152              
153 8 100       39 if ( $type eq 'null' ) {
    100          
    100          
154 3         15 select $null_fh;
155             }
156             elsif ( $type eq 'stdout' ) {
157 2         20 select $stdout_fh;
158             }
159             elsif ( $type eq 'cpan' ) {
160 2 100       109 warn "CPAN related output will be at $cpan_log_path\n"
161             unless $cpan_fh_flag;
162 2         6 $cpan_fh_flag = 1;
163 2         14 select $cpan_fh;
164             }
165             else {
166 1         8 confess_or_die "unknown type: $type";
167             }
168             }
169              
170             =head3 find_module
171              
172             Takes perl modules name space and name of a module in the space.
173             Finds and returns matching module name using case insensitive search, for
174             example:
175              
176             find_module('Shipwright::Backend', 'svn');
177             # returns 'Shipwright::Backend::SVN'
178              
179             find_module('Shipwright::Backend', 'git');
180             # returns 'Shipwright::Backend::Git'
181              
182             Returns undef if there is no module matching criteria.
183              
184             =cut
185              
186             sub find_module {
187 12     12 1 18 my $space = shift;
188 12         14 my $name = shift;
189              
190 12         106 my @space = split /::/, $space;
191 12         701 my @globs = map File::Spec->catfile($_, @space, '*.pm'), @INC;
192 12         29 foreach my $glob ( @globs ) {
193 25         1580 foreach my $module ( map { /([^\\\/]+)\.pm$/; $1 } glob $glob ) {
  60         298  
  60         105  
194 38 100       142 return join '::', @space, $module
195             if lc $name eq lc $module;
196             }
197             }
198 0         0 return;
199             }
200              
201             =head2 PATHS
202              
203             =head3 shipwright_root
204              
205             Returns the root directory that Shipwright has been installed into.
206             Uses %INC to figure out where Shipwright.pm is.
207              
208             =cut
209              
210             sub shipwright_root {
211 6 100   6 1 893 unless ($SHIPWRIGHT_ROOT) {
212 4         28 my $dir = ( splitpath( $INC{"Shipwright.pm"} ) )[1];
213 4         116 $SHIPWRIGHT_ROOT = rel2abs($dir);
214             }
215 6         76 return ($SHIPWRIGHT_ROOT);
216             }
217              
218             =head3 share_root
219              
220             Returns the 'share' directory of the installed Shipwright module. This is
221             currently only used to store the initial files in project.
222              
223             =cut
224              
225             sub share_root {
226 5 100   5 1 21 unless ($SHARE_ROOT) {
227 4         15 my @root = splitdir( shipwright_root() );
228              
229 4 50 33     59 if ( $root[-2] ne 'blib'
      0        
      33        
230             && $root[-1] eq 'lib'
231             && ( $^O !~ /MSWin/ || $root[-2] ne 'site' ) )
232             {
233              
234             # so it's -Ilib in the Shipwright's source dir
235 0         0 $root[-1] = 'share';
236             }
237             else {
238 4         18 push @root, qw/auto share dist Shipwright/;
239             }
240              
241 4         34 $SHARE_ROOT = catdir(@root);
242             }
243              
244 5         20 return ($SHARE_ROOT);
245              
246             }
247              
248             =head3 user_home
249              
250             return current user's home directory
251              
252             =cut
253              
254             sub user_home {
255 0 0   0 1 0 return $ENV{HOME} if $ENV{HOME};
256              
257 0         0 my $home = eval { (getpwuid $<)[7] };
  0         0  
258 0 0       0 if ( $@ ) {
259 0         0 confess_or_die "can't find user's home, please set it by env HOME";
260             }
261             else {
262 0         0 return $home;
263             }
264             }
265              
266             =head3 shipwright_user_root
267              
268             the user's own shipwright root where we put internal files in.
269             it's ~/.shipwright by default.
270             it can be overwritten by $ENV{SHIPWRIGHT_USER_ROOT}
271              
272             =cut
273              
274             sub shipwright_user_root {
275 12   33 12 1 91 return $ENV{SHIPWRIGHT_USER_ROOT} || catdir( user_home, '.shipwright' );
276             }
277              
278             1;
279              
280             __END__