1 package CPANPLUS::Internals::Utils;
6 use CPANPLUS::Internals::Constants;
10 use Params::Check qw[check];
11 use Module::Load::Conditional qw[can_load];
12 use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext';
14 local $Params::Check::VERBOSE = 1;
20 CPANPLUS::Internals::Utils
24 my $bool = $cb->_mkdir( dir => 'blah' );
25 my $bool = $cb->_chdir( dir => 'blah' );
26 my $bool = $cb->_rmdir( dir => 'blah' );
28 my $bool = $cb->_move( from => '/some/file', to => '/other/file' );
29 my $bool = $cb->_move( from => '/some/dir', to => '/other/dir' );
31 my $cont = $cb->_get_file_contents( file => '/path/to/file' );
34 my $version = $cb->_perl_version( perl => $^X );
38 C<CPANPLUS::Internals::Utils> holds a few convenience functions for
43 =head2 $cb->_mkdir( dir => '/some/dir' )
45 C<_mkdir> creates a full path to a directory.
47 Returns true on success, false on failure.
57 dir => { required => 1 },
60 my $args = check( $tmpl, \%hash ) or (
61 error(loc( Params::Check->last_error ) ), return
64 unless( can_load( modules => { 'File::Path' => 0.0 } ) ) {
65 error( loc("Could not use File::Path! This module should be core!") );
69 eval { File::Path::mkpath($args->{dir}) };
73 error(loc(qq[Could not create directory '%1': %2], $args->{dir}, $@ ));
82 =head2 $cb->_chdir( dir => '/some/dir' )
84 C<_chdir> changes directory to a dir.
86 Returns true on success, false on failure.
95 dir => { required => 1, allow => DIR_EXISTS },
98 my $args = check( $tmpl, \%hash ) or return;
100 unless( chdir $args->{dir} ) {
101 error( loc(q[Could not chdir into '%1'], $args->{dir}) );
110 =head2 $cb->_rmdir( dir => '/some/dir' );
112 Removes a directory completely, even if it is non-empty.
114 Returns true on success, false on failure.
123 dir => { required => 1, allow => IS_DIR },
126 my $args = check( $tmpl, \%hash ) or return;
128 unless( can_load( modules => { 'File::Path' => 0.0 } ) ) {
129 error( loc("Could not use File::Path! This module should be core!") );
133 eval { File::Path::rmtree($args->{dir}) };
137 error(loc(qq[Could not delete directory '%1': %2], $args->{dir}, $@ ));
146 =head2 $cb->_perl_version ( perl => 'some/perl/binary' );
148 C<_perl_version> returns the version of a certain perl binary.
149 It does this by actually running a command.
151 Returns the perl version on success and false on failure.
161 perl => { required => 1, store => \$perl },
164 check( $tmpl, \%hash ) or return;
167 ### special perl, or the one we are running under?
169 ### just load the config
171 $perl_version = $Config::Config{version};
175 ' -MConfig -eprint+Config::config_vars+version';
176 ($perl_version) = (`$cmd` =~ /version='(.*)'/);
179 return $perl_version if defined $perl_version;
185 =head2 $cb->_version_to_number( version => $version );
187 Returns a proper module version, or '0.0' if none was available.
191 sub _version_to_number {
197 version => { default => '0.0', store => \$version },
200 check( $tmpl, \%hash ) or return;
202 return $version if $version =~ /^\.?\d/;
210 Returns the name of the subroutine you're currently in.
214 sub _whoami { my $name = (caller 1)[3]; $name =~ s/.+:://; $name }
218 =head2 _get_file_contents( file => $file );
220 Returns the contents of a file
224 sub _get_file_contents {
230 file => { required => 1, store => \$file }
233 check( $tmpl, \%hash ) or return;
235 my $fh = OPEN_FILE->($file) or return;
236 my $contents = do { local $/; <$fh> };
241 =pod $cb->_move( from => $file|$dir, to => $target );
243 Moves a file or directory to the target.
245 Returns true on success, false on failure.
255 file => { required => 1, allow => [IS_FILE,IS_DIR],
257 to => { required => 1, store => \$to }
260 check( $tmpl, \%hash ) or return;
262 if( File::Copy::move( $from, $to ) ) {
265 error(loc("Failed to move '%1' to '%2': %3", $from, $to, $!));
270 =pod $cb->_copy( from => $file|$dir, to => $target );
272 Moves a file or directory to the target.
274 Returns true on success, false on failure.
284 file =>{ required => 1, allow => [IS_FILE,IS_DIR],
286 to => { required => 1, store => \$to }
289 check( $tmpl, \%hash ) or return;
291 if( File::Copy::copy( $from, $to ) ) {
294 error(loc("Failed to copy '%1' to '%2': %3", $from, $to, $!));
299 =head2 $cb->_mode_plus_w( file => '/path/to/file' );
301 Sets the +w bit for the file.
303 Returns true on success, false on failure.
315 file => { required => 1, allow => IS_FILE, store => \$file },
318 check( $tmpl, \%hash ) or return;
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;
324 if( $x and chmod( $x->mode|$mask, $file ) ) {
328 error(loc("Failed to '%1' '%2': '%3'", 'chmod +w', $file, $!));
333 =head2 $uri = $cb->_host_to_uri( scheme => SCHEME, host => HOST, path => PATH );
335 Turns a CPANPLUS::Config style C<host> entry into an URI string.
337 Returns the uri on success, and false on failure
345 my($scheme, $host, $path);
347 scheme => { required => 1, store => \$scheme },
348 host => { default => 'localhost', store => \$host },
349 path => { default => '', store => \$path },
352 check( $tmpl, \%hash ) or return;
354 ### it's an URI, so unixify the path.
355 ### VMS has a special method for just that
357 ? VMS::Filespec::unixify($path)
358 : File::Spec::Unix->catdir( File::Spec->splitdir( $path ) );
360 return "$scheme://" . File::Spec::Unix->catdir( $host, $path );
363 =head2 $cb->_vcmp( VERSION, VERSION );
365 Normalizes the versions passed and does a '<=>' on them, returning the result.
373 s/_//g foreach $x, $y;
378 =head2 $cb->_home_dir
380 Returns the user's homedir, or C<cwd> if it could not be found
385 my @os_home_envs = qw( APPDATA HOME USERPROFILE WINDIR SYS$LOGIN );
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 };
396 =head2 $path = $cb->_safe_path( path => $path );
398 Returns a path that's safe to us on Win32 and VMS.
400 Only cleans up the path on Win32 if the path exists.
402 On VMS, it encodes dots to _ using C<VMS::Filespec::vmsify>
413 path => { required => 1, store => \$path },
416 check( $tmpl, \%hash ) or return;
419 ### only need to fix it up if there's spaces in the path
420 return $path unless $path =~ /\s+/;
422 ### clean up paths if we are on win32
423 return Win32::GetShortPathName( $path ) || $path;
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.
432 ### If the path is already in VMS syntax, assume that we are done.
434 ### VMS format is a path with a trailing ']' or ':'
435 return $path if $path =~ /\:|\]$/;
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|/$|;
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 );
447 ### 3. Use $path = File::Spec->splitdir( VMS::Filespec::vmsify(
448 ### $path . '/') to remove the directory delimiters.
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.
456 ### There is a VMS::Filespec::unixpath() to do the appending of the '/'
457 ### to the specification, which will do a VMS::Filespec::vmsify()
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.
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 ) )
473 =head2 ($pkg, $version, $ext) = $cb->_split_package_string( package => PACKAGE_STRING );
475 Splits the name of a CPAN package string up into its package, version
478 For example, C<Foo-Bar-1.2.tar.gz> would return the following parts:
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 :(
498 my $ver_re = qr/[a-z]*\d*?[a-z]* # contains a digit and possibly letters
499 (?: # however, some start with a . only :(
500 [-._] # followed by a delimiter
501 [a-z\d]+ # and more digits and or letters
505 my $ext_re = qr/[a-z] # a letter, followed by
506 [a-z\d]* # letters and or digits, optionally
508 \. # followed by a dot and letters
509 [a-z\d]+ # and or digits (like .tar.bz2)
514 ($ver_re+) # version, optional
517 ($ext_re) # extension,
518 )? # optional, but requires version
521 ### composed regex for CPAN packages
528 $ver_ext_re # version + extension
534 ### composed regex for perl packages
535 my $perl = PERL_CORE;
539 ($perl) # package name for 'perl'
541 $ver_ext_re # version + extension
548 sub _split_package_string {
553 my $tmpl = { package => { required => 1, store => \$str } };
554 check( $tmpl, \%hash ) or return;
557 ### 2 different regexes, one for the 'perl' package,
558 ### one for ordinary CPAN packages.. try them both,
559 ### first match wins.
560 for my $re ( $full_re, $perl_re ) {
562 ### try the next if the match fails
570 ### this regex resets the capture markers!
571 ### strip the trailing delimiter
572 $pkg =~ s/$del_re$//;
574 ### strip the .pm package suffix some authors insist on adding
577 return ($pkg, $ver, $ext, $full );
584 { my %escapes = map {
585 chr($_) => sprintf("%%%02X", $_)
594 uri => { store => \$str, required => 1 }
597 check( $tmpl, \%hash ) or return;
599 ### XXX taken straight from URI::Encode
600 ### Default unsafe characters. RFC 2732 ^(uric - reserved)
601 $str =~ s|([^A-Za-z0-9\-_.!~*'()])|$escapes{$1}|g;
613 uri => { store => \$str, required => 1 }
616 check( $tmpl, \%hash ) or return;
618 ### XXX use unencode routine in utils?
619 $str =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
625 sub _update_timestamp {
631 file => { required => 1, store => \$file, allow => FILE_EXISTS }
634 check( $tmpl, \%hash ) or return;
636 ### `touch` the file, so windoze knows it's new -jmb
637 ### works on *nix too, good fix -Kane
638 ### make sure it is writable first, otherwise the `touch` will fail
641 unless( chmod( 0644, $file) && utime ($now, $now, $file) ) {
642 error( loc("Couldn't touch %1", $file) );
653 # c-indentation-style: bsd
655 # indent-tabs-mode: nil
657 # vim: expandtab shiftwidth=4: