[Summary view] [Print] [Text view]

   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: