File Coverage

lib/CPANPLUS/Internals/Utils.pm
Criterion Covered Total %
statement 108 142 76.1
branch 28 52 53.8
condition 2 8 25.0
subroutine 19 21 90.5
pod n/a
total 157 223 70.4


line stmt bran cond sub pod time code
1             package CPANPLUS::Internals::Utils;
2              
3 15     15   282 use strict;
  15         208  
  15         225  
4              
5 15     15   232 use CPANPLUS::Error;
  15         138  
  15         268  
6 15     15   279 use CPANPLUS::Internals::Constants;
  15         187  
  15         3496  
7              
8 15     15   346 use Cwd;
  15         139  
  15         1187  
9 15     15   604 use File::Copy;
  15         168  
  15         357  
10 15     15   263 use Params::Check qw[check];
  15         136  
  15         1676  
11 15     15   559 use Module::Load::Conditional qw[can_load];
  15         347  
  15         478  
12 15     15   284 use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext';
  15         156  
  15         16820  
13              
14             local $Params::Check::VERBOSE = 1;
15              
16             =pod
17            
18             =head1 NAME
19            
20             CPANPLUS::Internals::Utils
21            
22             =head1 SYNOPSIS
23            
24             my $bool = $cb->_mkdir( dir => 'blah' );
25             my $bool = $cb->_chdir( dir => 'blah' );
26             my $bool = $cb->_rmdir( dir => 'blah' );
27            
28             my $bool = $cb->_move( from => '/some/file', to => '/other/file' );
29             my $bool = $cb->_move( from => '/some/dir', to => '/other/dir' );
30            
31             my $cont = $cb->_get_file_contents( file => '/path/to/file' );
32            
33            
34             my $version = $cb->_perl_version( perl => $^X );
35            
36             =head1 DESCRIPTION
37            
38             C<CPANPLUS::Internals::Utils> holds a few convenience functions for
39             CPANPLUS libraries.
40            
41             =head1 METHODS
42            
43             =head2 $cb->_mkdir( dir => '/some/dir' )
44            
45             C<_mkdir> creates a full path to a directory.
46            
47             Returns true on success, false on failure.
48            
49             =cut
50              
51             sub _mkdir {
52 1     1   422     my $self = shift;
53              
54 1         3696     my %hash = @_;
55              
56 1         153     my $tmpl = {
57                     dir => { required => 1 },
58                 };
59              
60 1 50       238     my $args = check( $tmpl, \%hash ) or (
61                     error(loc( Params::Check->last_error ) ), return
62                 );
63              
64 1 50       198     unless( can_load( modules => { 'File::Path' => 0.0 } ) ) {
65 0         0         error( loc("Could not use File::Path! This module should be core!") );
66 0         0         return;
67                 }
68              
69 1         64     eval { File::Path::mkpath($args->{dir}) };
  1         79  
70              
71 1 50       239     if($@) {
72 0         0         chomp($@);
73 0         0         error(loc(qq[Could not create directory '%1': %2], $args->{dir}, $@ ));
74 0         0         return;
75                 }
76              
77 1         75     return 1;
78             }
79              
80             =pod
81            
82             =head2 $cb->_chdir( dir => '/some/dir' )
83            
84             C<_chdir> changes directory to a dir.
85            
86             Returns true on success, false on failure.
87            
88             =cut
89              
90             sub _chdir {
91 49     49   2829     my $self = shift;
92 49         4238     my %hash = @_;
93              
94 49         5024     my $tmpl = {
95                     dir => { required => 1, allow => DIR_EXISTS },
96                 };
97              
98 49 100       2664     my $args = check( $tmpl, \%hash ) or return;
99              
100 48 50       1689     unless( chdir $args->{dir} ) {
101 0         0         error( loc(q[Could not chdir into '%1'], $args->{dir}) );
102 0         0         return;
103                 }
104              
105 48         1114     return 1;
106             }
107              
108             =pod
109            
110             =head2 $cb->_rmdir( dir => '/some/dir' );
111            
112             Removes a directory completely, even if it is non-empty.
113            
114             Returns true on success, false on failure.
115            
116             =cut
117              
118             sub _rmdir {
119 1     1   84     my $self = shift;
120 1         32     my %hash = @_;
121              
122 1         14     my $tmpl = {
123                     dir => { required => 1, allow => IS_DIR },
124                 };
125              
126 1 50       16     my $args = check( $tmpl, \%hash ) or return;
127              
128 1 50       72     unless( can_load( modules => { 'File::Path' => 0.0 } ) ) {
129 0         0         error( loc("Could not use File::Path! This module should be core!") );
130 0         0         return;
131                 }
132              
133 1         106     eval { File::Path::rmtree($args->{dir}) };
  1         78  
134              
135 1 50       32     if($@) {
136 0         0         chomp($@);
137 0         0         error(loc(qq[Could not delete directory '%1': %2], $args->{dir}, $@ ));
138 0         0         return;
139                 }
140              
141 1         95     return 1;
142             }
143              
144             =pod
145            
146             =head2 $cb->_perl_version ( perl => 'some/perl/binary' );
147            
148             C<_perl_version> returns the version of a certain perl binary.
149             It does this by actually running a command.
150            
151             Returns the perl version on success and false on failure.
152            
153             =cut
154              
155             sub _perl_version {
156 16     16   242     my $self = shift;
157 16         228     my %hash = @_;
158              
159 16         188     my $perl;
160 16         235     my $tmpl = {
161                     perl => { required => 1, store => \$perl },
162                 };
163              
164 16 50       310     check( $tmpl, \%hash ) or return;
165                 
166 16         161     my $perl_version;
167             ### special perl, or the one we are running under?
168 16 50       186     if( $perl eq $^X ) {
169             ### just load the config
170 16         813         require Config;
171 16         4832         $perl_version = $Config::Config{version};
172                     
173                 } else {
174 0         0         my $cmd = $perl .
175                             ' -MConfig -eprint+Config::config_vars+version';
176 0         0         ($perl_version) = (`$cmd` =~ /version='(.*)'/);
177                 }
178                 
179 16 50       8535     return $perl_version if defined $perl_version;
180 0         0     return;
181             }
182              
183             =pod
184            
185             =head2 $cb->_version_to_number( version => $version );
186            
187             Returns a proper module version, or '0.0' if none was available.
188            
189             =cut
190              
191             sub _version_to_number {
192 9     9   210     my $self = shift;
193 9         103     my %hash = @_;
194              
195 9         96     my $version;
196 9         149     my $tmpl = {
197                     version => { default => '0.0', store => \$version },
198                 };
199              
200 9 50       140     check( $tmpl, \%hash ) or return;
201              
202 9 100       155     return $version if $version =~ /^\.?\d/;
203 6         106     return '0.0';
204             }
205              
206             =pod
207            
208             =head2 $cb->_whoami
209            
210             Returns the name of the subroutine you're currently in.
211            
212             =cut
213              
214 1     1   33 sub _whoami { my $name = (caller 1)[3]; $name =~ s/.+:://; $name }
  1         128  
  1         13  
215              
216             =pod
217            
218             =head2 _get_file_contents( file => $file );
219            
220             Returns the contents of a file
221            
222             =cut
223              
224             sub _get_file_contents {
225 61     61   1085     my $self = shift;
226 61         3135     my %hash = @_;
227              
228 61         7017     my $file;
229 61         2386     my $tmpl = {
230                     file => { required => 1, store => \$file }
231                 };
232              
233 61 50       5569     check( $tmpl, \%hash ) or return;
234              
235 61 50       6237     my $fh = OPEN_FILE->($file) or return;
236 61         728     my $contents = do { local $/; <$fh> };
  61         760  
  61         9066  
237              
238 61         1053     return $contents;
239             }
240              
241             =pod $cb->_move( from => $file|$dir, to => $target );
242            
243             Moves a file or directory to the target.
244            
245             Returns true on success, false on failure.
246            
247             =cut
248              
249             sub _move {
250 3     3   431     my $self = shift;
251 3         199     my %hash = @_;
252              
253 3         46     my $from; my $to;
  3         114  
254 3         306     my $tmpl = {
255                     file => { required => 1, allow => [IS_FILE,IS_DIR],
256                                     store => \$from },
257                     to => { required => 1, store => \$to }
258                 };
259              
260 3 50       158     check( $tmpl, \%hash ) or return;
261              
262 3 100       294     if( File::Copy::move( $from, $to ) ) {
263 2         515         return 1;
264                 } else {
265 1         201         error(loc("Failed to move '%1' to '%2': %3", $from, $to, $!));
266 1         43         return;
267                 }
268             }
269              
270             =pod $cb->_copy( from => $file|$dir, to => $target );
271            
272             Moves a file or directory to the target.
273            
274             Returns true on success, false on failure.
275            
276             =cut
277              
278             sub _copy {
279 0     0   0     my $self = shift;
280 0         0     my %hash = @_;
281                 
282 0         0     my($from,$to);
283 0         0     my $tmpl = {
284                     file =>{ required => 1, allow => [IS_FILE,IS_DIR],
285                                     store => \$from },
286                     to => { required => 1, store => \$to }
287                 };
288              
289 0 0       0     check( $tmpl, \%hash ) or return;
290              
291 0 0       0     if( File::Copy::copy( $from, $to ) ) {
292 0         0         return 1;
293                 } else {
294 0         0         error(loc("Failed to copy '%1' to '%2': %3", $from, $to, $!));
295 0         0         return;
296                 }
297             }
298              
299             =head2 $cb->_mode_plus_w( file => '/path/to/file' );
300            
301             Sets the +w bit for the file.
302            
303             Returns true on success, false on failure.
304            
305             =cut
306              
307             sub _mode_plus_w {
308 141     141   9674     my $self = shift;
309 141         18051     my %hash = @_;
310                 
311 141         16048     require File::stat;
312                 
313 141         4482     my $file;
314 141         48209     my $tmpl = {
315                     file => { required => 1, allow => IS_FILE, store => \$file },
316                 };
317                 
318 141 50       15812     check( $tmpl, \%hash ) or return;
319                 
320             ### set the mode to +w for a file and +wx for a dir
321 141         14969     my $x = File::stat::stat( $file );
322 141 100       6401     my $mask = -d $file ? 0100 : 0200;
323                 
324 141 50 33     10366     if( $x and chmod( $x->mode|$mask, $file ) ) {
325 141         16333         return 1;
326              
327                 } else {
328 0         0         error(loc("Failed to '%1' '%2': '%3'", 'chmod +w', $file, $!));
329 0         0         return;
330                 }
331             }    
332              
333             =head2 $uri = $cb->_host_to_uri( scheme => SCHEME, host => HOST, path => PATH );
334            
335             Turns a CPANPLUS::Config style C<host> entry into an URI string.
336            
337             Returns the uri on success, and false on failure
338            
339             =cut
340              
341             sub _host_to_uri {
342 0     0   0     my $self = shift;
343 0         0     my %hash = @_;
344                 
345 0         0     my($scheme, $host, $path);
346 0         0     my $tmpl = {
347                     scheme => { required => 1, store => \$scheme },
348                     host => { default => '', store => \$host },
349                     path => { default => '', store => \$path },
350                 };
351              
352 0 0       0     check( $tmpl, \%hash ) or return;
353              
354 0   0     0     $host ||= 'localhost';
355              
356 0         0     return "$scheme://" . File::Spec::Unix->catdir( $host, $path );
357             }
358              
359             =head2 $cb->_vcmp( VERSION, VERSION );
360            
361             Normalizes the versions passed and does a '<=>' on them, returning the result.
362            
363           &n