summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Utils.pm
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Utils.pm')
-rw-r--r--Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Utils.pm657
1 files changed, 657 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Utils.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Utils.pm
new file mode 100644
index 00000000000..27d2abcdad1
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Utils.pm
@@ -0,0 +1,657 @@
+package CPANPLUS::Internals::Utils;
+
+use strict;
+
+use CPANPLUS::Error;
+use CPANPLUS::Internals::Constants;
+
+use Cwd qw[chdir];
+use File::Copy;
+use Params::Check qw[check];
+use Module::Load::Conditional qw[can_load];
+use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext';
+
+local $Params::Check::VERBOSE = 1;
+
+=pod
+
+=head1 NAME
+
+CPANPLUS::Internals::Utils
+
+=head1 SYNOPSIS
+
+ my $bool = $cb->_mkdir( dir => 'blah' );
+ my $bool = $cb->_chdir( dir => 'blah' );
+ my $bool = $cb->_rmdir( dir => 'blah' );
+
+ my $bool = $cb->_move( from => '/some/file', to => '/other/file' );
+ my $bool = $cb->_move( from => '/some/dir', to => '/other/dir' );
+
+ my $cont = $cb->_get_file_contents( file => '/path/to/file' );
+
+
+ my $version = $cb->_perl_version( perl => $^X );
+
+=head1 DESCRIPTION
+
+C<CPANPLUS::Internals::Utils> holds a few convenience functions for
+CPANPLUS libraries.
+
+=head1 METHODS
+
+=head2 $cb->_mkdir( dir => '/some/dir' )
+
+C<_mkdir> creates a full path to a directory.
+
+Returns true on success, false on failure.
+
+=cut
+
+sub _mkdir {
+ my $self = shift;
+
+ my %hash = @_;
+
+ my $tmpl = {
+ dir => { required => 1 },
+ };
+
+ my $args = check( $tmpl, \%hash ) or (
+ error(loc( Params::Check->last_error ) ), return
+ );
+
+ unless( can_load( modules => { 'File::Path' => 0.0 } ) ) {
+ error( loc("Could not use File::Path! This module should be core!") );
+ return;
+ }
+
+ eval { File::Path::mkpath($args->{dir}) };
+
+ if($@) {
+ chomp($@);
+ error(loc(qq[Could not create directory '%1': %2], $args->{dir}, $@ ));
+ return;
+ }
+
+ return 1;
+}
+
+=pod
+
+=head2 $cb->_chdir( dir => '/some/dir' )
+
+C<_chdir> changes directory to a dir.
+
+Returns true on success, false on failure.
+
+=cut
+
+sub _chdir {
+ my $self = shift;
+ my %hash = @_;
+
+ my $tmpl = {
+ dir => { required => 1, allow => DIR_EXISTS },
+ };
+
+ my $args = check( $tmpl, \%hash ) or return;
+
+ unless( chdir $args->{dir} ) {
+ error( loc(q[Could not chdir into '%1'], $args->{dir}) );
+ return;
+ }
+
+ return 1;
+}
+
+=pod
+
+=head2 $cb->_rmdir( dir => '/some/dir' );
+
+Removes a directory completely, even if it is non-empty.
+
+Returns true on success, false on failure.
+
+=cut
+
+sub _rmdir {
+ my $self = shift;
+ my %hash = @_;
+
+ my $tmpl = {
+ dir => { required => 1, allow => IS_DIR },
+ };
+
+ my $args = check( $tmpl, \%hash ) or return;
+
+ unless( can_load( modules => { 'File::Path' => 0.0 } ) ) {
+ error( loc("Could not use File::Path! This module should be core!") );
+ return;
+ }
+
+ eval { File::Path::rmtree($args->{dir}) };
+
+ if($@) {
+ chomp($@);
+ error(loc(qq[Could not delete directory '%1': %2], $args->{dir}, $@ ));
+ return;
+ }
+
+ return 1;
+}
+
+=pod
+
+=head2 $cb->_perl_version ( perl => 'some/perl/binary' );
+
+C<_perl_version> returns the version of a certain perl binary.
+It does this by actually running a command.
+
+Returns the perl version on success and false on failure.
+
+=cut
+
+sub _perl_version {
+ my $self = shift;
+ my %hash = @_;
+
+ my $perl;
+ my $tmpl = {
+ perl => { required => 1, store => \$perl },
+ };
+
+ check( $tmpl, \%hash ) or return;
+
+ my $perl_version;
+ ### special perl, or the one we are running under?
+ if( $perl eq $^X ) {
+ ### just load the config
+ require Config;
+ $perl_version = $Config::Config{version};
+
+ } else {
+ my $cmd = $perl .
+ ' -MConfig -eprint+Config::config_vars+version';
+ ($perl_version) = (`$cmd` =~ /version='(.*)'/);
+ }
+
+ return $perl_version if defined $perl_version;
+ return;
+}
+
+=pod
+
+=head2 $cb->_version_to_number( version => $version );
+
+Returns a proper module version, or '0.0' if none was available.
+
+=cut
+
+sub _version_to_number {
+ my $self = shift;
+ my %hash = @_;
+
+ my $version;
+ my $tmpl = {
+ version => { default => '0.0', store => \$version },
+ };
+
+ check( $tmpl, \%hash ) or return;
+
+ return $version if $version =~ /^\.?\d/;
+ return '0.0';
+}
+
+=pod
+
+=head2 $cb->_whoami
+
+Returns the name of the subroutine you're currently in.
+
+=cut
+
+sub _whoami { my $name = (caller 1)[3]; $name =~ s/.+:://; $name }
+
+=pod
+
+=head2 _get_file_contents( file => $file );
+
+Returns the contents of a file
+
+=cut
+
+sub _get_file_contents {
+ my $self = shift;
+ my %hash = @_;
+
+ my $file;
+ my $tmpl = {
+ file => { required => 1, store => \$file }
+ };
+
+ check( $tmpl, \%hash ) or return;
+
+ my $fh = OPEN_FILE->($file) or return;
+ my $contents = do { local $/; <$fh> };
+
+ return $contents;
+}
+
+=pod $cb->_move( from => $file|$dir, to => $target );
+
+Moves a file or directory to the target.
+
+Returns true on success, false on failure.
+
+=cut
+
+sub _move {
+ my $self = shift;
+ my %hash = @_;
+
+ my $from; my $to;
+ my $tmpl = {
+ file => { required => 1, allow => [IS_FILE,IS_DIR],
+ store => \$from },
+ to => { required => 1, store => \$to }
+ };
+
+ check( $tmpl, \%hash ) or return;
+
+ if( File::Copy::move( $from, $to ) ) {
+ return 1;
+ } else {
+ error(loc("Failed to move '%1' to '%2': %3", $from, $to, $!));
+ return;
+ }
+}
+
+=pod $cb->_copy( from => $file|$dir, to => $target );
+
+Moves a file or directory to the target.
+
+Returns true on success, false on failure.
+
+=cut
+
+sub _copy {
+ my $self = shift;
+ my %hash = @_;
+
+ my($from,$to);
+ my $tmpl = {
+ file =>{ required => 1, allow => [IS_FILE,IS_DIR],
+ store => \$from },
+ to => { required => 1, store => \$to }
+ };
+
+ check( $tmpl, \%hash ) or return;
+
+ if( File::Copy::copy( $from, $to ) ) {
+ return 1;
+ } else {
+ error(loc("Failed to copy '%1' to '%2': %3", $from, $to, $!));
+ return;
+ }
+}
+
+=head2 $cb->_mode_plus_w( file => '/path/to/file' );
+
+Sets the +w bit for the file.
+
+Returns true on success, false on failure.
+
+=cut
+
+sub _mode_plus_w {
+ my $self = shift;
+ my %hash = @_;
+
+ require File::stat;
+
+ my $file;
+ my $tmpl = {
+ file => { required => 1, allow => IS_FILE, store => \$file },
+ };
+
+ check( $tmpl, \%hash ) or return;
+
+ ### set the mode to +w for a file and +wx for a dir
+ my $x = File::stat::stat( $file );
+ my $mask = -d $file ? 0100 : 0200;
+
+ if( $x and chmod( $x->mode|$mask, $file ) ) {
+ return 1;
+
+ } else {
+ error(loc("Failed to '%1' '%2': '%3'", 'chmod +w', $file, $!));
+ return;
+ }
+}
+
+=head2 $uri = $cb->_host_to_uri( scheme => SCHEME, host => HOST, path => PATH );
+
+Turns a CPANPLUS::Config style C<host> entry into an URI string.
+
+Returns the uri on success, and false on failure
+
+=cut
+
+sub _host_to_uri {
+ my $self = shift;
+ my %hash = @_;
+
+ my($scheme, $host, $path);
+ my $tmpl = {
+ scheme => { required => 1, store => \$scheme },
+ host => { default => 'localhost', store => \$host },
+ path => { default => '', store => \$path },
+ };
+
+ check( $tmpl, \%hash ) or return;
+
+ ### it's an URI, so unixify the path.
+ ### VMS has a special method for just that
+ $path = ON_VMS
+ ? VMS::Filespec::unixify($path)
+ : File::Spec::Unix->catdir( File::Spec->splitdir( $path ) );
+
+ return "$scheme://" . File::Spec::Unix->catdir( $host, $path );
+}
+
+=head2 $cb->_vcmp( VERSION, VERSION );
+
+Normalizes the versions passed and does a '<=>' on them, returning the result.
+
+=cut
+
+sub _vcmp {
+ my $self = shift;
+ my ($x, $y) = @_;
+
+ s/_//g foreach $x, $y;
+
+ return $x <=> $y;
+}
+
+=head2 $cb->_home_dir
+
+Returns the user's homedir, or C<cwd> if it could not be found
+
+=cut
+
+sub _home_dir {
+ my @os_home_envs = qw( APPDATA HOME USERPROFILE WINDIR SYS$LOGIN );
+
+ for my $env ( @os_home_envs ) {
+ next unless exists $ENV{ $env };
+ next unless defined $ENV{ $env } && length $ENV{ $env };
+ return $ENV{ $env } if -d $ENV{ $env };
+ }
+
+ return cwd();
+}
+
+=head2 $path = $cb->_safe_path( path => $path );
+
+Returns a path that's safe to us on Win32 and VMS.
+
+Only cleans up the path on Win32 if the path exists.
+
+On VMS, it encodes dots to _ using C<VMS::Filespec::vmsify>
+
+=cut
+
+sub _safe_path {
+ my $self = shift;
+
+ my %hash = @_;
+
+ my $path;
+ my $tmpl = {
+ path => { required => 1, store => \$path },
+ };
+
+ check( $tmpl, \%hash ) or return;
+
+ if( ON_WIN32 ) {
+ ### only need to fix it up if there's spaces in the path
+ return $path unless $path =~ /\s+/;
+
+ ### clean up paths if we are on win32
+ return Win32::GetShortPathName( $path ) || $path;
+
+ } elsif ( ON_VMS ) {
+ ### XXX According to John Malmberg, there's an VMS issue:
+ ### catdir on VMS can not currently deal with directory components
+ ### with dots in them.
+ ### Fixing this is a a three step procedure, which will work for
+ ### VMS in its traditional ODS-2 mode, and it will also work if
+ ### VMS is in the ODS-5 mode that is being implemented.
+ ### If the path is already in VMS syntax, assume that we are done.
+
+ ### VMS format is a path with a trailing ']' or ':'
+ return $path if $path =~ /\:|\]$/;
+
+ ### 1. Make sure that the value to be converted, $path is
+ ### in UNIX directory syntax by appending a '/' to it.
+ $path .= '/' unless $path =~ m|/$|;
+
+ ### 2. Use VMS::Filespec::vmsify($path . '/') to convert the dots to
+ ### underscores if needed. The trailing '/' is needed as so that
+ ### C<vmsify> knows that it should use directory translation instead of
+ ### filename translation, as filename translation leaves one dot.
+ $path = VMS::Filespec::vmsify( $path );
+
+ ### 3. Use $path = File::Spec->splitdir( VMS::Filespec::vmsify(
+ ### $path . '/') to remove the directory delimiters.
+
+ ### From John Malmberg:
+ ### File::Spec->catdir will put the path back together.
+ ### The '/' trick only works if the string is a directory name
+ ### with UNIX style directory delimiters or no directory delimiters.
+ ### It is to force vmsify to treat the input specification as UNIX.
+ ###
+ ### There is a VMS::Filespec::unixpath() to do the appending of the '/'
+ ### to the specification, which will do a VMS::Filespec::vmsify()
+ ### if needed.
+ ### However it is not a good idea to call vmsify() on a pathname
+ ### returned by unixify(), and it is not a good idea to call unixify()
+ ### on a pathname returned by vmsify(). Because of the nature of the
+ ### conversion, not all file specifications can make the round trip.
+ ###
+ ### I think that directory specifications can safely make the round
+ ### trip, but not ones containing filenames.
+ $path = File::Spec->catdir( File::Spec->splitdir( $path ) )
+ }
+
+ return $path;
+}
+
+
+=head2 ($pkg, $version, $ext) = $cb->_split_package_string( package => PACKAGE_STRING );
+
+Splits the name of a CPAN package string up into its package, version
+and extension parts.
+
+For example, C<Foo-Bar-1.2.tar.gz> would return the following parts:
+
+ Package: Foo-Bar
+ Version: 1.2
+ Extension: tar.gz
+
+=cut
+
+{ my $del_re = qr/[-_\+]/i; # delimiter between elements
+ my $pkg_re = qr/[a-z] # any letters followed by
+ [a-z\d]* # any letters, numbers
+ (?i:\.pm)? # followed by '.pm'--authors do this :(
+ (?: # optionally repeating:
+ $del_re # followed by a delimiter
+ [a-z] # any letters followed by
+ [a-z\d]* # any letters, numbers
+ (?i:\.pm)? # followed by '.pm'--authors do this :(
+ )*
+ /xi;
+
+ my $ver_re = qr/[a-z]*\d*?[a-z]* # contains a digit and possibly letters
+ (?: # however, some start with a . only :(
+ [-._] # followed by a delimiter
+ [a-z\d]+ # and more digits and or letters
+ )*?
+ /xi;
+
+ my $ext_re = qr/[a-z] # a letter, followed by
+ [a-z\d]* # letters and or digits, optionally
+ (?:
+ \. # followed by a dot and letters
+ [a-z\d]+ # and or digits (like .tar.bz2)
+ )? # optionally
+ /xi;
+
+ my $ver_ext_re = qr/
+ ($ver_re+) # version, optional
+ (?:
+ \. # a literal .
+ ($ext_re) # extension,
+ )? # optional, but requires version
+ /xi;
+
+ ### composed regex for CPAN packages
+ my $full_re = qr/
+ ^
+ ( # the whole thing
+ ($pkg_re+) # package
+ (?:
+ $del_re # delimiter
+ $ver_ext_re # version + extension
+ )?
+ )
+ $
+ /xi;
+
+ ### composed regex for perl packages
+ my $perl = PERL_CORE;
+ my $perl_re = qr/
+ ^
+ ( # the whole thing
+ ($perl) # package name for 'perl'
+ (?:
+ $ver_ext_re # version + extension
+ )?
+ )
+ $
+ /xi;
+
+
+sub _split_package_string {
+ my $self = shift;
+ my %hash = @_;
+
+ my $str;
+ my $tmpl = { package => { required => 1, store => \$str } };
+ check( $tmpl, \%hash ) or return;
+
+
+ ### 2 different regexes, one for the 'perl' package,
+ ### one for ordinary CPAN packages.. try them both,
+ ### first match wins.
+ for my $re ( $full_re, $perl_re ) {
+
+ ### try the next if the match fails
+ $str =~ $re or next;
+
+ my $full = $1 || '';
+ my $pkg = $2 || '';
+ my $ver = $3 || '';
+ my $ext = $4 || '';
+
+ ### this regex resets the capture markers!
+ ### strip the trailing delimiter
+ $pkg =~ s/$del_re$//;
+
+ ### strip the .pm package suffix some authors insist on adding
+ $pkg =~ s/\.pm$//i;
+
+ return ($pkg, $ver, $ext, $full );
+ }
+
+ return;
+ }
+}
+
+{ my %escapes = map {
+ chr($_) => sprintf("%%%02X", $_)
+ } 0 .. 255;
+
+ sub _uri_encode {
+ my $self = shift;
+ my %hash = @_;
+
+ my $str;
+ my $tmpl = {
+ uri => { store => \$str, required => 1 }
+ };
+
+ check( $tmpl, \%hash ) or return;
+
+ ### XXX taken straight from URI::Encode
+ ### Default unsafe characters. RFC 2732 ^(uric - reserved)
+ $str =~ s|([^A-Za-z0-9\-_.!~*'()])|$escapes{$1}|g;
+
+ return $str;
+ }
+
+
+ sub _uri_decode {
+ my $self = shift;
+ my %hash = @_;
+
+ my $str;
+ my $tmpl = {
+ uri => { store => \$str, required => 1 }
+ };
+
+ check( $tmpl, \%hash ) or return;
+
+ ### XXX use unencode routine in utils?
+ $str =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
+
+ return $str;
+ }
+}
+
+sub _update_timestamp {
+ my $self = shift;
+ my %hash = @_;
+
+ my $file;
+ my $tmpl = {
+ file => { required => 1, store => \$file, allow => FILE_EXISTS }
+ };
+
+ check( $tmpl, \%hash ) or return;
+
+ ### `touch` the file, so windoze knows it's new -jmb
+ ### works on *nix too, good fix -Kane
+ ### make sure it is writable first, otherwise the `touch` will fail
+
+ my $now = time;
+ unless( chmod( 0644, $file) && utime ($now, $now, $file) ) {
+ error( loc("Couldn't touch %1", $file) );
+ return;
+ }
+
+ return 1;
+}
+
+
+1;
+
+# Local variables:
+# c-indentation-style: bsd
+# c-basic-offset: 4
+# indent-tabs-mode: nil
+# End:
+# vim: expandtab shiftwidth=4: