Commit | Line | Data |
6aaee015 |
1 | package CPANPLUS::Internals::Utils; |
2 | |
3 | use strict; |
4 | |
5 | use CPANPLUS::Error; |
6 | use CPANPLUS::Internals::Constants; |
7 | |
8 | use Cwd; |
9 | use File::Copy; |
10 | use Params::Check qw[check]; |
11 | use Module::Load::Conditional qw[can_load]; |
12 | use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; |
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 | my $self = shift; |
53 | |
54 | my %hash = @_; |
55 | |
56 | my $tmpl = { |
57 | dir => { required => 1 }, |
58 | }; |
59 | |
60 | my $args = check( $tmpl, \%hash ) or ( |
61 | error(loc( Params::Check->last_error ) ), return |
62 | ); |
63 | |
64 | unless( can_load( modules => { 'File::Path' => 0.0 } ) ) { |
65 | error( loc("Could not use File::Path! This module should be core!") ); |
66 | return; |
67 | } |
68 | |
69 | eval { File::Path::mkpath($args->{dir}) }; |
70 | |
71 | if($@) { |
72 | chomp($@); |
73 | error(loc(qq[Could not create directory '%1': %2], $args->{dir}, $@ )); |
74 | return; |
75 | } |
76 | |
77 | 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 | my $self = shift; |
92 | my %hash = @_; |
93 | |
94 | my $tmpl = { |
95 | dir => { required => 1, allow => DIR_EXISTS }, |
96 | }; |
97 | |
98 | my $args = check( $tmpl, \%hash ) or return; |
99 | |
100 | unless( chdir $args->{dir} ) { |
101 | error( loc(q[Could not chdir into '%1'], $args->{dir}) ); |
102 | return; |
103 | } |
104 | |
105 | 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 | my $self = shift; |
120 | my %hash = @_; |
121 | |
122 | my $tmpl = { |
123 | dir => { required => 1, allow => IS_DIR }, |
124 | }; |
125 | |
126 | my $args = check( $tmpl, \%hash ) or return; |
127 | |
128 | unless( can_load( modules => { 'File::Path' => 0.0 } ) ) { |
129 | error( loc("Could not use File::Path! This module should be core!") ); |
130 | return; |
131 | } |
132 | |
133 | eval { File::Path::rmtree($args->{dir}) }; |
134 | |
135 | if($@) { |
136 | chomp($@); |
137 | error(loc(qq[Could not delete directory '%1': %2], $args->{dir}, $@ )); |
138 | return; |
139 | } |
140 | |
141 | 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 | my $self = shift; |
157 | my %hash = @_; |
158 | |
159 | my $perl; |
160 | my $tmpl = { |
161 | perl => { required => 1, store => \$perl }, |
162 | }; |
163 | |
164 | check( $tmpl, \%hash ) or return; |
165 | |
166 | my $perl_version; |
167 | ### special perl, or the one we are running under? |
168 | if( $perl eq $^X ) { |
169 | ### just load the config |
170 | require Config; |
171 | $perl_version = $Config::Config{version}; |
172 | |
173 | } else { |
174 | my $cmd = $perl . |
175 | ' -MConfig -eprint+Config::config_vars+version'; |
176 | ($perl_version) = (`$cmd` =~ /version='(.*)'/); |
177 | } |
178 | |
179 | return $perl_version if defined $perl_version; |
180 | 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 | my $self = shift; |
193 | my %hash = @_; |
194 | |
195 | my $version; |
196 | my $tmpl = { |
197 | version => { default => '0.0', store => \$version }, |
198 | }; |
199 | |
200 | check( $tmpl, \%hash ) or return; |
201 | |
202 | return $version if $version =~ /^\.?\d/; |
203 | 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 | sub _whoami { my $name = (caller 1)[3]; $name =~ s/.+:://; $name } |
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 | my $self = shift; |
226 | my %hash = @_; |
227 | |
228 | my $file; |
229 | my $tmpl = { |
230 | file => { required => 1, store => \$file } |
231 | }; |
232 | |
233 | check( $tmpl, \%hash ) or return; |
234 | |
235 | my $fh = OPEN_FILE->($file) or return; |
236 | my $contents = do { local $/; <$fh> }; |
237 | |
238 | 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 | my $self = shift; |
251 | my %hash = @_; |
252 | |
253 | my $from; my $to; |
254 | my $tmpl = { |
255 | file => { required => 1, allow => [IS_FILE,IS_DIR], |
256 | store => \$from }, |
257 | to => { required => 1, store => \$to } |
258 | }; |
259 | |
260 | check( $tmpl, \%hash ) or return; |
261 | |
262 | if( File::Copy::move( $from, $to ) ) { |
263 | return 1; |
264 | } else { |
265 | error(loc("Failed to move '%1' to '%2': %3", $from, $to, $!)); |
266 | 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 | my $self = shift; |
280 | my %hash = @_; |
281 | |
282 | my($from,$to); |
283 | my $tmpl = { |
284 | file =>{ required => 1, allow => [IS_FILE,IS_DIR], |
285 | store => \$from }, |
286 | to => { required => 1, store => \$to } |
287 | }; |
288 | |
289 | check( $tmpl, \%hash ) or return; |
290 | |
291 | if( File::Copy::copy( $from, $to ) ) { |
292 | return 1; |
293 | } else { |
294 | error(loc("Failed to copy '%1' to '%2': %3", $from, $to, $!)); |
295 | 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 | my $self = shift; |
309 | my %hash = @_; |
310 | |
311 | require File::stat; |
312 | |
313 | my $file; |
314 | my $tmpl = { |
315 | file => { required => 1, allow => IS_FILE, store => \$file }, |
316 | }; |
317 | |
318 | check( $tmpl, \%hash ) or return; |
319 | |
320 | ### set the mode to +w for a file and +wx for a dir |
321 | my $x = File::stat::stat( $file ); |
322 | my $mask = -d $file ? 0100 : 0200; |
323 | |
324 | if( $x and chmod( $x->mode|$mask, $file ) ) { |
325 | return 1; |
326 | |
327 | } else { |
328 | error(loc("Failed to '%1' '%2': '%3'", 'chmod +w', $file, $!)); |
329 | 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 | my $self = shift; |
343 | my %hash = @_; |
344 | |
345 | my($scheme, $host, $path); |
346 | my $tmpl = { |
347 | scheme => { required => 1, store => \$scheme }, |
348 | host => { default => '', store => \$host }, |
349 | path => { default => '', store => \$path }, |
350 | }; |
351 | |
352 | check( $tmpl, \%hash ) or return; |
353 | |
354 | $host ||= 'localhost'; |
355 | |
356 | 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 | =cut |
364 | |
365 | sub _vcmp { |
366 | my $self = shift; |
367 | my ($x, $y) = @_; |
368 | |
369 | s/_//g foreach $x, $y; |
370 | |
371 | return $x <=> $y; |
372 | } |
373 | |
374 | =head2 $cb->_home_dir |
375 | |
376 | Returns the user's homedir, or C<cwd> if it could not be found |
377 | |
378 | =cut |
379 | |
380 | sub _home_dir { |
381 | my @os_home_envs = qw( APPDATA HOME USERPROFILE WINDIR SYS$LOGIN ); |
382 | |
383 | for my $env ( @os_home_envs ) { |
384 | next unless exists $ENV{ $env }; |
385 | next unless defined $ENV{ $env } && length $ENV{ $env }; |
386 | return $ENV{ $env } if -d $ENV{ $env }; |
387 | } |
388 | |
389 | return cwd(); |
390 | } |
391 | |
392 | =head2 $path = $cb->_safe_path( path => $path ); |
393 | |
394 | Returns a path that's safe to us on Win32. Only cleans up |
395 | the path on Win32 if the path exists. |
396 | |
397 | =cut |
398 | |
399 | sub _safe_path { |
400 | my $self = shift; |
401 | |
402 | my %hash = @_; |
403 | |
404 | my $path; |
405 | my $tmpl = { |
406 | path => { required => 1, store => \$path }, |
407 | }; |
408 | |
409 | check( $tmpl, \%hash ) or return; |
410 | |
411 | ### only need to fix it up if there's spaces in the path |
412 | return $path unless $path =~ /\s+/; |
413 | |
414 | ### or if we are on win32 |
415 | return $path if $^O ne 'MSWin32'; |
416 | |
417 | ### clean up paths if we are on win32 |
418 | return Win32::GetShortPathName( $path ) || $path; |
419 | |
420 | } |
421 | |
422 | |
423 | =head2 ($pkg, $version, $ext) = $cb->_split_package_string( package => PACKAGE_STRING ); |
424 | |
425 | Splits the name of a CPAN package string up in it's package, version |
426 | and extension parts. |
427 | |
428 | For example, C<Foo-Bar-1.2.tar.gz> would return the following parts: |
429 | |
430 | Package: Foo-Bar |
431 | Version: 1.2 |
432 | Extension: tar.gz |
433 | |
434 | =cut |
435 | |
436 | { my $del_re = qr/[-_\+]/i; # delimiter between elements |
437 | my $pkg_re = qr/[a-z] # any letters followed by |
438 | [a-z\d]* # any letters, numbers |
439 | (?i:\.pm)? # followed by '.pm'--authors do this :( |
440 | (?: # optionally repeating: |
441 | $del_re # followed by a delimiter |
442 | [a-z] # any letters followed by |
443 | [a-z\d]* # any letters, numbers |
444 | (?i:\.pm)? # followed by '.pm'--authors do this :( |
445 | )* |
446 | /xi; |
447 | |
448 | my $ver_re = qr/[a-z]*\d+[a-z]* # contains a digit and possibly letters |
449 | (?: |
450 | [-._] # followed by a delimiter |
451 | [a-z\d]+ # and more digits and or letters |
452 | )*? |
453 | /xi; |
454 | |
455 | my $ext_re = qr/[a-z] # a letter, followed by |
456 | [a-z\d]* # letters and or digits, optionally |
457 | (?: |
458 | \. # followed by a dot and letters |
459 | [a-z\d]+ # and or digits (like .tar.bz2) |
460 | )? # optionally |
461 | /xi; |
462 | |
463 | my $ver_ext_re = qr/ |
464 | ($ver_re+) # version, optional |
465 | (?: |
466 | \. # a literal . |
467 | ($ext_re) # extension, |
468 | )? # optional, but requires version |
469 | /xi; |
470 | |
471 | ### composed regex for CPAN packages |
472 | my $full_re = qr/ |
473 | ^ |
474 | ($pkg_re+) # package |
475 | (?: |
476 | $del_re # delimiter |
477 | $ver_ext_re # version + extension |
478 | )? |
479 | $ |
480 | /xi; |
481 | |
482 | ### composed regex for perl packages |
483 | my $perl = PERL_CORE; |
484 | my $perl_re = qr/ |
485 | ^ |
486 | ($perl) # package name for 'perl' |
487 | (?: |
488 | $ver_ext_re # version + extension |
489 | )? |
490 | $ |
491 | /xi; |
492 | |
493 | |
494 | sub _split_package_string { |
495 | my $self = shift; |
496 | my %hash = @_; |
497 | |
498 | my $str; |
499 | my $tmpl = { package => { required => 1, store => \$str } }; |
500 | check( $tmpl, \%hash ) or return; |
501 | |
502 | |
503 | ### 2 different regexes, one for the 'perl' package, |
504 | ### one for ordinary CPAN packages.. try them both, |
505 | ### first match wins. |
506 | for my $re ( $full_re, $perl_re ) { |
507 | |
508 | ### try the next if the match fails |
509 | $str =~ $re or next; |
510 | |
511 | my $pkg = $1 || ''; |
512 | my $ver = $2 || ''; |
513 | my $ext = $3 || ''; |
514 | |
515 | ### this regex resets the capture markers! |
516 | ### strip the trailing delimiter |
517 | $pkg =~ s/$del_re$//; |
518 | |
519 | ### strip the .pm package suffix some authors insist on adding |
520 | $pkg =~ s/\.pm$//i; |
521 | |
522 | return ($pkg, $ver, $ext ); |
523 | } |
524 | |
525 | return; |
526 | } |
527 | } |
528 | |
529 | 1; |
530 | |
531 | # Local variables: |
532 | # c-indentation-style: bsd |
533 | # c-basic-offset: 4 |
534 | # indent-tabs-mode: nil |
535 | # End: |
536 | # vim: expandtab shiftwidth=4: |