lib/CPANPLUS/Internals/Utils.pm

   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  => 'localhost',   store => \$host },
 349         path    => { default  => '',            store => \$path },
 350     };
 351
 352     check( $tmpl, \%hash ) or return;
 353
 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 ) );
 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
 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>
 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
 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
 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.
 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 =~ /\:|\]$/;
 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;
 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
 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
 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: