[p5sagit/p5-mst-13.2.git] / lib / CPANPLUS / Internals / Utils.pm

package CPANPLUS::Internals::Utils;

use strict;

use CPANPLUS::Error;
use CPANPLUS::Internals::Constants;

use Cwd;
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+/;
        
        ### or if we are on win32
        return $path if $^O ne 'MSWin32';
    
        ### 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 in it's 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
                    (?:
                        [-._]           # 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/
                    ^
                    ($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/
                    ^
                    ($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 $pkg = $1 || ''; 
            my $ver = $2 || '';
            my $ext = $3 || '';

            ### 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 );
        }
        
        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:
Commit	Line	Data
6aaee015	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 = {
5bc5f6dc	347	scheme => { required => 1, store => \$scheme },
	348	host => { default => 'localhost', store => \$host },
	349	path => { default => '', store => \$path },
6aaee015	350	};
	351
	352	check( $tmpl, \%hash ) or return;
	353
5879cbe1	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 ) );
6aaee015	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
5bc5f6dc	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>
6aaee015	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
5bc5f6dc	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	### or if we are on win32
	423	return $path if $^O ne 'MSWin32';
6aaee015	424
5bc5f6dc	425	### clean up paths if we are on win32
	426	return Win32::GetShortPathName( $path ) \|\| $path;
	427
	428	} elsif ( ON_VMS ) {
	429	### XXX According to John Malmberg, there's an VMS issue:
	430	### catdir on VMS can not currently deal with directory components
	431	### with dots in them.
	432	### Fixing this is a a three step procedure, which will work for
	433	### VMS in its traditional ODS-2 mode, and it will also work if
	434	### VMS is in the ODS-5 mode that is being implemented.
5879cbe1	435	### If the path is already in VMS syntax, assume that we are done.
	436
	437	### VMS format is a path with a trailing ']' or ':'
	438	return $path if $path =~ /\:\|\]$/;
5bc5f6dc	439
	440	### 1. Make sure that the value to be converted, $path is
	441	### in UNIX directory syntax by appending a '/' to it.
	442	$path .= '/' unless $path =~ m\|/$\|;
	443
	444	### 2. Use VMS::Filespec::vmsify($path . '/') to convert the dots to
	445	### underscores if needed. The trailing '/' is needed as so that
	446	### C<vmsify> knows that it should use directory translation instead of
	447	### filename translation, as filename translation leaves one dot.
	448	$path = VMS::Filespec::vmsify( $path );
	449
	450	### 3. Use $path = File::Spec->splitdir( VMS::Filespec::vmsify(
	451	### $path . '/') to remove the directory delimiters.
	452
	453	### From John Malmberg:
	454	### File::Spec->catdir will put the path back together.
	455	### The '/' trick only works if the string is a directory name
	456	### with UNIX style directory delimiters or no directory delimiters.
	457	### It is to force vmsify to treat the input specification as UNIX.
	458	###
	459	### There is a VMS::Filespec::unixpath() to do the appending of the '/'
	460	### to the specification, which will do a VMS::Filespec::vmsify()
	461	### if needed.
	462	### However it is not a good idea to call vmsify() on a pathname
	463	### returned by unixify(), and it is not a good idea to call unixify()
	464	### on a pathname returned by vmsify(). Because of the nature of the
	465	### conversion, not all file specifications can make the round trip.
	466	###
	467	### I think that directory specifications can safely make the round
	468	### trip, but not ones containing filenames.
	469	$path = File::Spec->catdir( File::Spec->splitdir( $path ) )
	470	}
	471
	472	return $path;
6aaee015	473	}
	474
	475
	476	=head2 ($pkg, $version, $ext) = $cb->_split_package_string( package => PACKAGE_STRING );
	477
	478	Splits the name of a CPAN package string up in it's package, version
	479	and extension parts.
	480
	481	For example, C<Foo-Bar-1.2.tar.gz> would return the following parts:
	482
	483	Package: Foo-Bar
	484	Version: 1.2
	485	Extension: tar.gz
	486
	487	=cut
	488
	489	{ my $del_re = qr/[-_\+]/i; # delimiter between elements
	490	my $pkg_re = qr/[a-z] # any letters followed by
	491	[a-z\d]* # any letters, numbers
	492	(?i:\.pm)? # followed by '.pm'--authors do this :(
	493	(?: # optionally repeating:
	494	$del_re # followed by a delimiter
	495	[a-z] # any letters followed by
	496	[a-z\d]* # any letters, numbers
	497	(?i:\.pm)? # followed by '.pm'--authors do this :(
	498	)*
	499	/xi;
	500
	501	my $ver_re = qr/[a-z]\d+[a-z] # contains a digit and possibly letters
	502	(?:
	503	[-._] # followed by a delimiter
	504	[a-z\d]+ # and more digits and or letters
	505	)*?
	506	/xi;
	507
	508	my $ext_re = qr/[a-z] # a letter, followed by
	509	[a-z\d]* # letters and or digits, optionally
	510	(?:
	511	\. # followed by a dot and letters
	512	[a-z\d]+ # and or digits (like .tar.bz2)
	513	)? # optionally
	514	/xi;
	515
	516	my $ver_ext_re = qr/
	517	($ver_re+) # version, optional
	518	(?:
	519	\. # a literal .
	520	($ext_re) # extension,
	521	)? # optional, but requires version
	522	/xi;
	523
	524	### composed regex for CPAN packages
	525	my $full_re = qr/
	526	^
	527	($pkg_re+) # package
	528	(?:
	529	$del_re # delimiter
	530	$ver_ext_re # version + extension
	531	)?
	532	$
	533	/xi;
	534
	535	### composed regex for perl packages
	536	my $perl = PERL_CORE;
537	my $perl_re = qr/
538	^
539	($perl) # package name for 'perl'
540	(?:
541	$ver_ext_re # version + extension
542	)?
543	$
544	/xi;
545
546
547	sub _split_package_string {
548	my $self = shift;
549	my %hash = @_;
550
551	my $str;
552	my $tmpl = { package => { required => 1, store => \$str } };
553	check( $tmpl, \%hash ) or return;
554
555
556	### 2 different regexes, one for the 'perl' package,
557	### one for ordinary CPAN packages.. try them both,
558	### first match wins.
559	for my $re ( $full_re, $perl_re ) {
560
561	### try the next if the match fails
562	$str =~ $re or next;
563
564	my $pkg = $1 \|\| '';
565	my $ver = $2 \|\| '';
566	my $ext = $3 \|\| '';
567
568	### this regex resets the capture markers!
569	### strip the trailing delimiter
570	$pkg =~ s/$del_re$//;
571
572	### strip the .pm package suffix some authors insist on adding
573	$pkg =~ s/\.pm$//i;
574
575	return ($pkg, $ver, $ext );
576	}
577
578	return;
579	}
580	}
581
5bc5f6dc	582	{ my %escapes = map {
	583	chr($_) => sprintf("%%%02X", $_)
	584	} 0 .. 255;
	585
	586	sub _uri_encode {
	587	my $self = shift;
	588	my %hash = @_;
	589
	590	my $str;
	591	my $tmpl = {
	592	uri => { store => \$str, required => 1 }
	593	};
	594
	595	check( $tmpl, \%hash ) or return;
	596
	597	### XXX taken straight from URI::Encode
	598	### Default unsafe characters. RFC 2732 ^(uric - reserved)
	599	$str =~ s\|([^A-Za-z0-9\-_.!~*'()])\|$escapes{$1}\|g;
	600
	601	return $str;
	602	}
	603
	604
	605	sub _uri_decode {
	606	my $self = shift;
	607	my %hash = @_;
	608
	609	my $str;
	610	my $tmpl = {
	611	uri => { store => \$str, required => 1 }
	612	};
	613
	614	check( $tmpl, \%hash ) or return;
	615
	616	### XXX use unencode routine in utils?
	617	$str =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
	618
	619	return $str;
	620	}
	621	}
	622
	623	sub _update_timestamp {
	624	my $self = shift;
	625	my %hash = @_;
	626
	627	my $file;
	628	my $tmpl = {
	629	file => { required => 1, store => \$file, allow => FILE_EXISTS }
	630	};
	631
	632	check( $tmpl, \%hash ) or return;
	633
	634	### `touch` the file, so windoze knows it's new -jmb
	635	### works on *nix too, good fix -Kane
	636	### make sure it is writable first, otherwise the `touch` will fail
	637
	638	my $now = time;
	639	unless( chmod( 0644, $file) && utime ($now, $now, $file) ) {
	640	error( loc("Couldn't touch %1", $file) );
	641	return;
	642	}
	643
	644	return 1;
	645	}
646
647
6aaee015	648	1;
	649
	650	# Local variables:
	651	# c-indentation-style: bsd
	652	# c-basic-offset: 4
	653	# indent-tabs-mode: nil
	654	# End:
	655	# vim: expandtab shiftwidth=4: