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  => '',    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: