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 = { |
5bc5f6dc |
347 | scheme => { required => 1, store => \$scheme }, |
348 | host => { default => 'localhost', store => \$host }, |
349 | path => { default => '', store => \$path }, |
6aaee015 |
350 | }; |
351 | |
352 | check( $tmpl, \%hash ) or return; |
353 | |
5879cbe1 |
354 | ### it's an URI, so unixify the path. |
355 | ### VMS has a special method for just that |
356 | $path = ON_VMS |
357 | ? VMS::Filespec::unixify($path) |
358 | : File::Spec::Unix->catdir( File::Spec->splitdir( $path ) ); |
6aaee015 |
359 | |
360 | return "$scheme://" . File::Spec::Unix->catdir( $host, $path ); |
361 | } |
362 | |
363 | =head2 $cb->_vcmp( VERSION, VERSION ); |
364 | |
365 | Normalizes the versions passed and does a '<=>' on them, returning the result. |
366 | |
367 | =cut |
368 | |
369 | sub _vcmp { |
370 | my $self = shift; |
371 | my ($x, $y) = @_; |
372 | |
373 | s/_//g foreach $x, $y; |
374 | |
375 | return $x <=> $y; |
376 | } |
377 | |
378 | =head2 $cb->_home_dir |
379 | |
380 | Returns the user's homedir, or C<cwd> if it could not be found |
381 | |
382 | =cut |
383 | |
384 | sub _home_dir { |
385 | my @os_home_envs = qw( APPDATA HOME USERPROFILE WINDIR SYS$LOGIN ); |
386 | |
387 | for my $env ( @os_home_envs ) { |
388 | next unless exists $ENV{ $env }; |
389 | next unless defined $ENV{ $env } && length $ENV{ $env }; |
390 | return $ENV{ $env } if -d $ENV{ $env }; |
391 | } |
392 | |
393 | return cwd(); |
394 | } |
395 | |
396 | =head2 $path = $cb->_safe_path( path => $path ); |
397 | |
5bc5f6dc |
398 | Returns a path that's safe to us on Win32 and VMS. |
399 | |
400 | Only cleans up the path on Win32 if the path exists. |
401 | |
402 | On VMS, it encodes dots to _ using C<VMS::Filespec::vmsify> |
6aaee015 |
403 | |
404 | =cut |
405 | |
406 | sub _safe_path { |
407 | my $self = shift; |
408 | |
409 | my %hash = @_; |
410 | |
411 | my $path; |
412 | my $tmpl = { |
413 | path => { required => 1, store => \$path }, |
414 | }; |
415 | |
416 | check( $tmpl, \%hash ) or return; |
417 | |
5bc5f6dc |
418 | if( ON_WIN32 ) { |
419 | ### only need to fix it up if there's spaces in the path |
420 | return $path unless $path =~ /\s+/; |
421 | |
5bc5f6dc |
422 | ### clean up paths if we are on win32 |
423 | return Win32::GetShortPathName( $path ) || $path; |
424 | |
425 | } elsif ( ON_VMS ) { |
426 | ### XXX According to John Malmberg, there's an VMS issue: |
427 | ### catdir on VMS can not currently deal with directory components |
428 | ### with dots in them. |
429 | ### Fixing this is a a three step procedure, which will work for |
430 | ### VMS in its traditional ODS-2 mode, and it will also work if |
431 | ### VMS is in the ODS-5 mode that is being implemented. |
5879cbe1 |
432 | ### If the path is already in VMS syntax, assume that we are done. |
433 | |
434 | ### VMS format is a path with a trailing ']' or ':' |
435 | return $path if $path =~ /\:|\]$/; |
5bc5f6dc |
436 | |
437 | ### 1. Make sure that the value to be converted, $path is |
438 | ### in UNIX directory syntax by appending a '/' to it. |
439 | $path .= '/' unless $path =~ m|/$|; |
440 | |
441 | ### 2. Use VMS::Filespec::vmsify($path . '/') to convert the dots to |
442 | ### underscores if needed. The trailing '/' is needed as so that |
443 | ### C<vmsify> knows that it should use directory translation instead of |
444 | ### filename translation, as filename translation leaves one dot. |
445 | $path = VMS::Filespec::vmsify( $path ); |
446 | |
447 | ### 3. Use $path = File::Spec->splitdir( VMS::Filespec::vmsify( |
448 | ### $path . '/') to remove the directory delimiters. |
449 | |
450 | ### From John Malmberg: |
451 | ### File::Spec->catdir will put the path back together. |
452 | ### The '/' trick only works if the string is a directory name |
453 | ### with UNIX style directory delimiters or no directory delimiters. |
454 | ### It is to force vmsify to treat the input specification as UNIX. |
455 | ### |
456 | ### There is a VMS::Filespec::unixpath() to do the appending of the '/' |
457 | ### to the specification, which will do a VMS::Filespec::vmsify() |
458 | ### if needed. |
459 | ### However it is not a good idea to call vmsify() on a pathname |
460 | ### returned by unixify(), and it is not a good idea to call unixify() |
461 | ### on a pathname returned by vmsify(). Because of the nature of the |
462 | ### conversion, not all file specifications can make the round trip. |
463 | ### |
464 | ### I think that directory specifications can safely make the round |
465 | ### trip, but not ones containing filenames. |
466 | $path = File::Spec->catdir( File::Spec->splitdir( $path ) ) |
467 | } |
468 | |
469 | return $path; |
6aaee015 |
470 | } |
471 | |
472 | |
473 | =head2 ($pkg, $version, $ext) = $cb->_split_package_string( package => PACKAGE_STRING ); |
474 | |
475 | Splits the name of a CPAN package string up in it's package, version |
476 | and extension parts. |
477 | |
478 | For example, C<Foo-Bar-1.2.tar.gz> would return the following parts: |
479 | |
480 | Package: Foo-Bar |
481 | Version: 1.2 |
482 | Extension: tar.gz |
483 | |
484 | =cut |
485 | |
486 | { my $del_re = qr/[-_\+]/i; # delimiter between elements |
487 | my $pkg_re = qr/[a-z] # any letters followed by |
488 | [a-z\d]* # any letters, numbers |
489 | (?i:\.pm)? # followed by '.pm'--authors do this :( |
490 | (?: # optionally repeating: |
491 | $del_re # followed by a delimiter |
492 | [a-z] # any letters followed by |
493 | [a-z\d]* # any letters, numbers |
494 | (?i:\.pm)? # followed by '.pm'--authors do this :( |
495 | )* |
496 | /xi; |
497 | |
498 | my $ver_re = qr/[a-z]*\d+[a-z]* # contains a digit and possibly letters |
499 | (?: |
500 | [-._] # followed by a delimiter |
501 | [a-z\d]+ # and more digits and or letters |
502 | )*? |
503 | /xi; |
504 | |
505 | my $ext_re = qr/[a-z] # a letter, followed by |
506 | [a-z\d]* # letters and or digits, optionally |
507 | (?: |
508 | \. # followed by a dot and letters |
509 | [a-z\d]+ # and or digits (like .tar.bz2) |
510 | )? # optionally |
511 | /xi; |
512 | |
513 | my $ver_ext_re = qr/ |
514 | ($ver_re+) # version, optional |
515 | (?: |
516 | \. # a literal . |
517 | ($ext_re) # extension, |
518 | )? # optional, but requires version |
519 | /xi; |
520 | |
521 | ### composed regex for CPAN packages |
522 | my $full_re = qr/ |
523 | ^ |
524 | ($pkg_re+) # package |
525 | (?: |
526 | $del_re # delimiter |
527 | $ver_ext_re # version + extension |
528 | )? |
529 | $ |
530 | /xi; |
531 | |
532 | ### composed regex for perl packages |
533 | my $perl = PERL_CORE; |
534 | my $perl_re = qr/ |
535 | ^ |
536 | ($perl) # package name for 'perl' |
537 | (?: |
538 | $ver_ext_re # version + extension |
539 | )? |
540 | $ |
541 | /xi; |
542 | |
543 | |
544 | sub _split_package_string { |
545 | my $self = shift; |
546 | my %hash = @_; |
547 | |
548 | my $str; |
549 | my $tmpl = { package => { required => 1, store => \$str } }; |
550 | check( $tmpl, \%hash ) or return; |
551 | |
552 | |
553 | ### 2 different regexes, one for the 'perl' package, |
554 | ### one for ordinary CPAN packages.. try them both, |
555 | ### first match wins. |
556 | for my $re ( $full_re, $perl_re ) { |
557 | |
558 | ### try the next if the match fails |
559 | $str =~ $re or next; |
560 | |
561 | my $pkg = $1 || ''; |
562 | my $ver = $2 || ''; |
563 | my $ext = $3 || ''; |
564 | |
565 | ### this regex resets the capture markers! |
566 | ### strip the trailing delimiter |
567 | $pkg =~ s/$del_re$//; |
568 | |
569 | ### strip the .pm package suffix some authors insist on adding |
570 | $pkg =~ s/\.pm$//i; |
571 | |
572 | return ($pkg, $ver, $ext ); |
573 | } |
574 | |
575 | return; |
576 | } |
577 | } |
578 | |
5bc5f6dc |
579 | { my %escapes = map { |
580 | chr($_) => sprintf("%%%02X", $_) |
581 | } 0 .. 255; |
582 | |
583 | sub _uri_encode { |
584 | my $self = shift; |
585 | my %hash = @_; |
586 | |
587 | my $str; |
588 | my $tmpl = { |
589 | uri => { store => \$str, required => 1 } |
590 | }; |
591 | |
592 | check( $tmpl, \%hash ) or return; |
593 | |
594 | ### XXX taken straight from URI::Encode |
595 | ### Default unsafe characters. RFC 2732 ^(uric - reserved) |
596 | $str =~ s|([^A-Za-z0-9\-_.!~*'()])|$escapes{$1}|g; |
597 | |
598 | return $str; |
599 | } |
600 | |
601 | |
602 | sub _uri_decode { |
603 | my $self = shift; |
604 | my %hash = @_; |
605 | |
606 | my $str; |
607 | my $tmpl = { |
608 | uri => { store => \$str, required => 1 } |
609 | }; |
610 | |
611 | check( $tmpl, \%hash ) or return; |
612 | |
613 | ### XXX use unencode routine in utils? |
614 | $str =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg; |
615 | |
616 | return $str; |
617 | } |
618 | } |
619 | |
620 | sub _update_timestamp { |
621 | my $self = shift; |
622 | my %hash = @_; |
623 | |
624 | my $file; |
625 | my $tmpl = { |
626 | file => { required => 1, store => \$file, allow => FILE_EXISTS } |
627 | }; |
628 | |
629 | check( $tmpl, \%hash ) or return; |
630 | |
631 | ### `touch` the file, so windoze knows it's new -jmb |
632 | ### works on *nix too, good fix -Kane |
633 | ### make sure it is writable first, otherwise the `touch` will fail |
634 | |
635 | my $now = time; |
636 | unless( chmod( 0644, $file) && utime ($now, $now, $file) ) { |
637 | error( loc("Couldn't touch %1", $file) ); |
638 | return; |
639 | } |
640 | |
641 | return 1; |
642 | } |
643 | |
644 | |
6aaee015 |
645 | 1; |
646 | |
647 | # Local variables: |
648 | # c-indentation-style: bsd |
649 | # c-basic-offset: 4 |
650 | # indent-tabs-mode: nil |
651 | # End: |
652 | # vim: expandtab shiftwidth=4: |