Permalink
Browse files

Update inc/bundle, ChangeLog and bump to version 0.9134

  • Loading branch information...
1 parent f721cb2 commit af444911f007c1f74530eb5eda9801db27980f2a @bingos bingos committed Jan 21, 2013
Showing with 1,214 additions and 1,173 deletions.
  1. +4 −0 ChangeLog
  2. +1 −1 META.yml
  3. +8 −3 inc/bundle/Archive/Extract.pm
  4. +457 −462 inc/bundle/File/Fetch.pm
  5. +13 −11 inc/bundle/File/Spec.pm
  6. +2 −2 inc/bundle/File/Spec/Cygwin.pm
  7. +2 −2 inc/bundle/File/Spec/Epoc.pm
  8. +2 −2 inc/bundle/File/Spec/Functions.pm
  9. +18 −13 inc/bundle/File/Spec/Mac.pm
  10. +15 −15 inc/bundle/File/Spec/OS2.pm
  11. +63 −31 inc/bundle/File/Spec/Unix.pm
  12. +83 −546 inc/bundle/File/Spec/VMS.pm
  13. +17 −16 inc/bundle/File/Spec/Win32.pm
  14. +63 −19 inc/bundle/HTTP/Tiny.pm
  15. +415 −4 inc/bundle/Module/CoreList.pm
  16. +1 −1 inc/bundle/Module/CoreList/TieHashDelta.pm
  17. +1 −1 inc/bundle/Module/Pluggable.pm
  18. +1 −1 inc/bundle/Module/Pluggable/Object.pm
  19. +9 −4 inc/bundle/Term/UI.pm
  20. +1 −1 lib/CPANPLUS.pm
  21. +1 −1 lib/CPANPLUS/Backend.pm
  22. +1 −1 lib/CPANPLUS/Backend/RV.pm
  23. +1 −1 lib/CPANPLUS/Config.pm
  24. +1 −1 lib/CPANPLUS/Config/HomeEnv.pm
  25. +1 −1 lib/CPANPLUS/Configure.pm
  26. +1 −1 lib/CPANPLUS/Configure/Setup.pm
  27. +1 −1 lib/CPANPLUS/Dist.pm
  28. +1 −1 lib/CPANPLUS/Dist/Autobundle.pm
  29. +1 −1 lib/CPANPLUS/Dist/Base.pm
  30. +1 −1 lib/CPANPLUS/Dist/MM.pm
  31. +1 −1 lib/CPANPLUS/Dist/Sample.pm
  32. +1 −1 lib/CPANPLUS/Error.pm
  33. +1 −1 lib/CPANPLUS/Internals.pm
  34. +1 −1 lib/CPANPLUS/Internals/Constants.pm
  35. +1 −1 lib/CPANPLUS/Internals/Constants/Report.pm
  36. +1 −1 lib/CPANPLUS/Internals/Extract.pm
  37. +1 −1 lib/CPANPLUS/Internals/Fetch.pm
  38. +1 −1 lib/CPANPLUS/Internals/Report.pm
  39. +1 −1 lib/CPANPLUS/Internals/Search.pm
  40. +1 −1 lib/CPANPLUS/Internals/Source.pm
  41. +1 −1 lib/CPANPLUS/Internals/Source/Memory.pm
  42. +1 −1 lib/CPANPLUS/Internals/Source/SQLite.pm
  43. +1 −1 lib/CPANPLUS/Internals/Source/SQLite/Tie.pm
  44. +1 −1 lib/CPANPLUS/Internals/Utils.pm
  45. +1 −1 lib/CPANPLUS/Internals/Utils/Autoflush.pm
  46. +1 −1 lib/CPANPLUS/Module.pm
  47. +1 −1 lib/CPANPLUS/Module/Author.pm
  48. +1 −1 lib/CPANPLUS/Module/Author/Fake.pm
  49. +1 −1 lib/CPANPLUS/Module/Checksums.pm
  50. +1 −1 lib/CPANPLUS/Module/Fake.pm
  51. +1 −1 lib/CPANPLUS/Module/Signature.pm
  52. +1 −1 lib/CPANPLUS/Selfupdate.pm
  53. +1 −1 lib/CPANPLUS/Shell.pm
  54. +1 −1 lib/CPANPLUS/Shell/Classic.pm
  55. +1 −1 lib/CPANPLUS/Shell/Default.pm
  56. +1 −1 lib/CPANPLUS/Shell/Default/Plugins/CustomSource.pm
  57. +1 −1 lib/CPANPLUS/Shell/Default/Plugins/Remote.pm
  58. +1 −1 lib/CPANPLUS/Shell/Default/Plugins/Source.pm
View
4 ChangeLog
@@ -1,3 +1,7 @@
+Changes for 0.9134 Mon Jan 21 20:00:03 2013
+================================================
+* $VERSION all library files
+
Changes for 0.9133 Sat Sep 29 11:49:02 2012
================================================
* Fix MANIFEST for last release
View
2 META.yml
@@ -18,4 +18,4 @@ resources:
license: http://dev.perl.org/licenses/
homepage: http://github.com/jib/cpanplus-devel
repository: http://github.com/jib/cpanplus-devel
-version: 0.9133
+version: 0.9134
View
11 inc/bundle/Archive/Extract.pm
@@ -16,6 +16,7 @@ use Locale::Maketext::Simple Style => 'gettext';
### solaris has silly /bin/tar output ###
use constant ON_SOLARIS => $^O eq 'solaris' ? 1 : 0;
use constant ON_NETBSD => $^O eq 'netbsd' ? 1 : 0;
+use constant ON_OPENBSD => $^O eq 'openbsd' ? 1 : 0;
use constant ON_FREEBSD => $^O eq 'freebsd' ? 1 : 0;
use constant ON_LINUX => $^O eq 'linux' ? 1 : 0;
use constant FILE_EXISTS => sub { -e $_[0] ? 1 : 0 };
@@ -46,7 +47,7 @@ use vars qw[$VERSION $PREFER_BIN $PROGRAMS $WARN $DEBUG
$_ALLOW_BIN $_ALLOW_PURE_PERL $_ALLOW_TAR_ITER
];
-$VERSION = '0.60';
+$VERSION = '0.62';
$PREFER_BIN = 0;
$WARN = 1;
$DEBUG = 0;
@@ -140,6 +141,10 @@ CMD: for my $pgm (qw[tar unzip gzip bunzip2 uncompress unlzma unxz]) {
($PROGRAMS->{$pgm}) = grep { scalar run(command=> [ $_, $opt, '-1' ]) } can_run($pgm);
next CMD;
}
+ if ( $pgm eq 'tar' and ON_OPENBSD ) {
+ # try gtar first
+ next CMD if $PROGRAMS->{$pgm} = can_run('gtar');
+ }
$PROGRAMS->{$pgm} = can_run($pgm);
}
@@ -654,7 +659,7 @@ sub have_old_bunzip2 {
### check for /bin/tar ###
### check for /bin/gzip if we need it ###
### if any of the binaries are not available, return NA
- { my $diag = not $self->bin_tar ?
+ { my $diag = !$self->bin_tar ?
loc("No '%1' program found", '/bin/tar') :
$self->is_tgz && !$self->bin_gzip ?
loc("No '%1' program found", '/bin/gzip') :
@@ -1662,7 +1667,7 @@ thread safe. See C<rt.cpan.org> bug C<#45671> for details.
=head1 BUG REPORTS
-Please report bugs or other issues to E<lt>bug-archive-extract@rt.cpan.org<gt>.
+Please report bugs or other issues to E<lt>bug-archive-extract@rt.cpan.orgE<gt>.
=head1 AUTHOR
View
919 inc/bundle/File/Fetch.pm
@@ -22,7 +22,7 @@ use vars qw[ $VERBOSE $PREFER_BIN $FROM_EMAIL $USER_AGENT
$FTP_PASSIVE $TIMEOUT $DEBUG $WARN
];
-$VERSION = '0.36';
+$VERSION = '0.38';
$VERSION = eval $VERSION; # avoid warnings with development releases
$PREFER_BIN = 0; # XXX TODO implement
$FROM_EMAIL = 'File-Fetch@example.com';
@@ -164,6 +164,7 @@ http://www.abc.net.au/ the contents retrieved may be from a remote file called
vol => { default => '' }, # windows for file:// uris
share => { default => '' }, # windows for file:// uris
file_default => { default => 'file_default' },
+ tempdir_root => { required => 1 }, # Should be lazy-set at ->new()
_error_msg => { no_override => 1 },
_error_msg_long => { no_override => 1 },
};
@@ -277,10 +278,11 @@ sub new {
my $class = shift;
my %hash = @_;
- my ($uri, $file_default);
+ my ($uri, $file_default, $tempdir_root);
my $tmpl = {
uri => { required => 1, store => \$uri },
file_default => { required => 0, store => \$file_default },
+ tempdir_root => { required => 0, store => \$tempdir_root },
};
check( $tmpl, \%hash ) or return;
@@ -289,6 +291,8 @@ sub new {
my $href = $class->_parse_uri( $uri ) or return;
$href->{file_default} = $file_default if $file_default;
+ $href->{tempdir_root} = File::Spec->rel2abs( $tempdir_root ) if $tempdir_root;
+ $href->{tempdir_root} = File::Spec->rel2abs( Cwd::cwd ) if not $href->{tempdir_root};
### make it into a FFI object ###
my $ff = $class->_create( %$href ) or return;
@@ -444,7 +448,7 @@ sub fetch {
my ($to, $fh);
### you want us to slurp the contents
if( ref $target and UNIVERSAL::isa( $target, 'SCALAR' ) ) {
- $to = tempdir( 'FileFetch.XXXXXX', CLEANUP => 1 );
+ $to = tempdir( 'FileFetch.XXXXXX', DIR => $self->tempdir_root, CLEANUP => 1 );
### plain old fetch
} else {
@@ -560,41 +564,40 @@ sub _lwp_fetch {
};
- if( can_load(modules => $use_list) ) {
-
- ### setup the uri object
- my $uri = URI->new( File::Spec::Unix->catfile(
- $self->path, $self->file
- ) );
+ unless( can_load( modules => $use_list ) ) {
+ $METHOD_FAIL->{'lwp'} = 1;
+ return;
+ }
- ### special rules apply for file:// uris ###
- $uri->scheme( $self->scheme );
- $uri->host( $self->scheme eq 'file' ? '' : $self->host );
- $uri->userinfo("anonymous:$FROM_EMAIL") if $self->scheme ne 'file';
+ ### setup the uri object
+ my $uri = URI->new( File::Spec::Unix->catfile(
+ $self->path, $self->file
+ ) );
- ### set up the useragent object
- my $ua = LWP::UserAgent->new();
- $ua->timeout( $TIMEOUT ) if $TIMEOUT;
- $ua->agent( $USER_AGENT );
- $ua->from( $FROM_EMAIL );
- $ua->env_proxy;
+ ### special rules apply for file:// uris ###
+ $uri->scheme( $self->scheme );
+ $uri->host( $self->scheme eq 'file' ? '' : $self->host );
+ $uri->userinfo("anonymous:$FROM_EMAIL") if $self->scheme ne 'file';
- my $res = $ua->mirror($uri, $to) or return;
+ ### set up the useragent object
+ my $ua = LWP::UserAgent->new();
+ $ua->timeout( $TIMEOUT ) if $TIMEOUT;
+ $ua->agent( $USER_AGENT );
+ $ua->from( $FROM_EMAIL );
+ $ua->env_proxy;
- ### uptodate or fetched ok ###
- if ( $res->code == 304 or $res->code == 200 ) {
- return $to;
+ my $res = $ua->mirror($uri, $to) or return;
- } else {
- return $self->_error(loc("Fetch failed! HTTP response: %1 %2 [%3]",
- $res->code, HTTP::Status::status_message($res->code),
- $res->status_line));
- }
+ ### uptodate or fetched ok ###
+ if ( $res->code == 304 or $res->code == 200 ) {
+ return $to;
} else {
- $METHOD_FAIL->{'lwp'} = 1;
- return;
+ return $self->_error(loc("Fetch failed! HTTP response: %1 %2 [%3]",
+ $res->code, HTTP::Status::status_message($res->code),
+ $res->status_line));
}
+
}
### HTTP::Tiny fetching ###
@@ -613,28 +616,26 @@ sub _httptiny_fetch {
};
- if( can_load(modules => $use_list) ) {
+ unless( can_load(modules => $use_list) ) {
+ $METHOD_FAIL->{'httptiny'} = 1;
+ return;
+ }
- my $uri = $self->uri;
+ my $uri = $self->uri;
- my $http = HTTP::Tiny->new( ( $TIMEOUT ? ( timeout => $TIMEOUT ) : () ) );
+ my $http = HTTP::Tiny->new( ( $TIMEOUT ? ( timeout => $TIMEOUT ) : () ) );
- my $rc = $http->mirror( $uri, $to );
+ my $rc = $http->mirror( $uri, $to );
- unless ( $rc->{success} ) {
+ unless ( $rc->{success} ) {
- return $self->_error(loc( "Fetch failed! HTTP response: %1 [%2]",
- $rc->{status}, $rc->{reason} ) );
+ return $self->_error(loc( "Fetch failed! HTTP response: %1 [%2]",
+ $rc->{status}, $rc->{reason} ) );
- }
+ }
- return $to;
+ return $to;
- }
- else {
- $METHOD_FAIL->{'httptiny'} = 1;
- return;
- }
}
### HTTP::Lite fetching ###
@@ -654,64 +655,63 @@ sub _httplite_fetch {
};
- if( can_load(modules => $use_list) ) {
+ unless( can_load(modules => $use_list) ) {
+ $METHOD_FAIL->{'httplite'} = 1;
+ return;
+ }
- my $uri = $self->uri;
- my $retries = 0;
+ my $uri = $self->uri;
+ my $retries = 0;
- RETRIES: while ( $retries++ < 5 ) {
+ RETRIES: while ( $retries++ < 5 ) {
- my $http = HTTP::Lite->new();
- # Naughty naughty but there isn't any accessor/setter
- $http->{timeout} = $TIMEOUT if $TIMEOUT;
- $http->http11_mode(1);
+ my $http = HTTP::Lite->new();
+ # Naughty naughty but there isn't any accessor/setter
+ $http->{timeout} = $TIMEOUT if $TIMEOUT;
+ $http->http11_mode(1);
- my $fh = FileHandle->new;
+ my $fh = FileHandle->new;
- unless ( $fh->open($to,'>') ) {
- return $self->_error(loc(
- "Could not open '%1' for writing: %2",$to,$!));
- }
+ unless ( $fh->open($to,'>') ) {
+ return $self->_error(loc(
+ "Could not open '%1' for writing: %2",$to,$!));
+ }
- $fh->autoflush(1);
+ $fh->autoflush(1);
- binmode $fh;
+ binmode $fh;
- my $rc = $http->request( $uri, sub { my ($self,$dref,$cbargs) = @_; local $\; print {$cbargs} $$dref }, $fh );
+ my $rc = $http->request( $uri, sub { my ($self,$dref,$cbargs) = @_; local $\; print {$cbargs} $$dref }, $fh );
- close $fh;
+ close $fh;
- if ( $rc == 301 || $rc == 302 ) {
- my $loc;
- HEADERS: for ($http->headers_array) {
- /Location: (\S+)/ and $loc = $1, last HEADERS;
- }
- #$loc or last; # Think we should squeal here.
- if ($loc =~ m!^/!) {
- $uri =~ s{^(\w+?://[^/]+)/.*$}{$1};
- $uri .= $loc;
- }
- else {
- $uri = $loc;
- }
- next RETRIES;
+ if ( $rc == 301 || $rc == 302 ) {
+ my $loc;
+ HEADERS: for ($http->headers_array) {
+ /Location: (\S+)/ and $loc = $1, last HEADERS;
}
- elsif ( $rc == 200 ) {
- return $to;
+ #$loc or last; # Think we should squeal here.
+ if ($loc =~ m!^/!) {
+ $uri =~ s{^(\w+?://[^/]+)/.*$}{$1};
+ $uri .= $loc;
}
else {
- return $self->_error(loc("Fetch failed! HTTP response: %1 [%2]",
- $rc, $http->status_message));
+ $uri = $loc;
}
+ next RETRIES;
+ }
+ elsif ( $rc == 200 ) {
+ return $to;
+ }
+ else {
+ return $self->_error(loc("Fetch failed! HTTP response: %1 [%2]",
+ $rc, $http->status_message));
+ }
- } # Loop for 5 retries.
+ } # Loop for 5 retries.
- return $self->_error("Fetch failed! Gave up after 5 tries");
+ return $self->_error("Fetch failed! Gave up after 5 tries");
- } else {
- $METHOD_FAIL->{'httplite'} = 1;
- return;
- }
}
### Simple IO::Socket::INET fetching ###
@@ -730,74 +730,73 @@ sub _iosock_fetch {
'IO::Select' => '0.0',
};
- if( can_load(modules => $use_list) ) {
- my $sock = IO::Socket::INET->new(
- PeerHost => $self->host,
- ( $self->host =~ /:/ ? () : ( PeerPort => 80 ) ),
- );
+ unless( can_load(modules => $use_list) ) {
+ $METHOD_FAIL->{'iosock'} = 1;
+ return;
+ }
- unless ( $sock ) {
- return $self->_error(loc("Could not open socket to '%1', '%2'",$self->host,$!));
- }
+ my $sock = IO::Socket::INET->new(
+ PeerHost => $self->host,
+ ( $self->host =~ /:/ ? () : ( PeerPort => 80 ) ),
+ );
- my $fh = FileHandle->new;
+ unless ( $sock ) {
+ return $self->_error(loc("Could not open socket to '%1', '%2'",$self->host,$!));
+ }
- # Check open()
+ my $fh = FileHandle->new;
- unless ( $fh->open($to,'>') ) {
- return $self->_error(loc(
- "Could not open '%1' for writing: %2",$to,$!));
- }
+ # Check open()
- $fh->autoflush(1);
- binmode $fh;
+ unless ( $fh->open($to,'>') ) {
+ return $self->_error(loc(
+ "Could not open '%1' for writing: %2",$to,$!));
+ }
- my $path = File::Spec::Unix->catfile( $self->path, $self->file );
- my $req = "GET $path HTTP/1.0\x0d\x0aHost: " . $self->host . "\x0d\x0a\x0d\x0a";
- $sock->send( $req );
+ $fh->autoflush(1);
+ binmode $fh;
- my $select = IO::Select->new( $sock );
+ my $path = File::Spec::Unix->catfile( $self->path, $self->file );
+ my $req = "GET $path HTTP/1.0\x0d\x0aHost: " . $self->host . "\x0d\x0a\x0d\x0a";
+ $sock->send( $req );
- my $resp = '';
- my $normal = 0;
- while ( $select->can_read( $TIMEOUT || 60 ) ) {
- my $ret = $sock->sysread( $resp, 4096, length($resp) );
- if ( !defined $ret or $ret == 0 ) {
- $select->remove( $sock );
- $normal++;
- }
- }
- close $sock;
+ my $select = IO::Select->new( $sock );
- unless ( $normal ) {
- return $self->_error(loc("Socket timed out after '%1' seconds", ( $TIMEOUT || 60 )));
- }
+ my $resp = '';
+ my $normal = 0;
+ while ( $select->can_read( $TIMEOUT || 60 ) ) {
+ my $ret = $sock->sysread( $resp, 4096, length($resp) );
+ if ( !defined $ret or $ret == 0 ) {
+ $select->remove( $sock );
+ $normal++;
+ }
+ }
+ close $sock;
- # Check the "response"
- # Strip preceding blank lines apparently they are allowed (RFC 2616 4.1)
- $resp =~ s/^(\x0d?\x0a)+//;
- # Check it is an HTTP response
- unless ( $resp =~ m!^HTTP/(\d+)\.(\d+)!i ) {
- return $self->_error(loc("Did not get a HTTP response from '%1'",$self->host));
- }
+ unless ( $normal ) {
+ return $self->_error(loc("Socket timed out after '%1' seconds", ( $TIMEOUT || 60 )));
+ }
- # Check for OK
- my ($code) = $resp =~ m!^HTTP/\d+\.\d+\s+(\d+)!i;
- unless ( $code eq '200' ) {
- return $self->_error(loc("Got a '%1' from '%2' expected '200'",$code,$self->host));
- }
+ # Check the "response"
+ # Strip preceding blank lines apparently they are allowed (RFC 2616 4.1)
+ $resp =~ s/^(\x0d?\x0a)+//;
+ # Check it is an HTTP response
+ unless ( $resp =~ m!^HTTP/(\d+)\.(\d+)!i ) {
+ return $self->_error(loc("Did not get a HTTP response from '%1'",$self->host));
+ }
- {
- local $\;
- print $fh +($resp =~ m/\x0d\x0a\x0d\x0a(.*)$/s )[0];
- }
- close $fh;
- return $to;
+ # Check for OK
+ my ($code) = $resp =~ m!^HTTP/\d+\.\d+\s+(\d+)!i;
+ unless ( $code eq '200' ) {
+ return $self->_error(loc("Got a '%1' from '%2' expected '200'",$code,$self->host));
+ }
- } else {
- $METHOD_FAIL->{'iosock'} = 1;
- return;
+ {
+ local $\;
+ print $fh +($resp =~ m/\x0d\x0a\x0d\x0a(.*)$/s )[0];
}
+ close $fh;
+ return $to;
}
### Net::FTP fetching
@@ -814,44 +813,43 @@ sub _netftp_fetch {
### required modules ###
my $use_list = { 'Net::FTP' => 0 };
- if( can_load( modules => $use_list ) ) {
+ unless( can_load( modules => $use_list ) ) {
+ $METHOD_FAIL->{'netftp'} = 1;
+ return;
+ }
- ### make connection ###
- my $ftp;
- my @options = ($self->host);
- push(@options, Timeout => $TIMEOUT) if $TIMEOUT;
- unless( $ftp = Net::FTP->new( @options ) ) {
- return $self->_error(loc("Ftp creation failed: %1",$@));
- }
+ ### make connection ###
+ my $ftp;
+ my @options = ($self->host);
+ push(@options, Timeout => $TIMEOUT) if $TIMEOUT;
+ unless( $ftp = Net::FTP->new( @options ) ) {
+ return $self->_error(loc("Ftp creation failed: %1",$@));
+ }
- ### login ###
- unless( $ftp->login( anonymous => $FROM_EMAIL ) ) {
- return $self->_error(loc("Could not login to '%1'",$self->host));
- }
+ ### login ###
+ unless( $ftp->login( anonymous => $FROM_EMAIL ) ) {
+ return $self->_error(loc("Could not login to '%1'",$self->host));
+ }
- ### set binary mode, just in case ###
- $ftp->binary;
+ ### set binary mode, just in case ###
+ $ftp->binary;
- ### create the remote path
- ### remember remote paths are unix paths! [#11483]
- my $remote = File::Spec::Unix->catfile( $self->path, $self->file );
+ ### create the remote path
+ ### remember remote paths are unix paths! [#11483]
+ my $remote = File::Spec::Unix->catfile( $self->path, $self->file );
- ### fetch the file ###
- my $target;
- unless( $target = $ftp->get( $remote, $to ) ) {
- return $self->_error(loc("Could not fetch '%1' from '%2'",
- $remote, $self->host));
- }
+ ### fetch the file ###
+ my $target;
+ unless( $target = $ftp->get( $remote, $to ) ) {
+ return $self->_error(loc("Could not fetch '%1' from '%2'",
+ $remote, $self->host));
+ }
- ### log out ###
- $ftp->quit;
+ ### log out ###
+ $ftp->quit;
- return $target;
+ return $target;
- } else {
- $METHOD_FAIL->{'netftp'} = 1;
- return;
- }
}
### /bin/wget fetch ###
@@ -865,47 +863,46 @@ sub _wget_fetch {
};
check( $tmpl, \%hash ) or return;
+ my $wget;
### see if we have a wget binary ###
- if( my $wget = can_run('wget') ) {
+ unless( $wget = can_run('wget') ) {
+ $METHOD_FAIL->{'wget'} = 1;
+ return;
+ }
- ### no verboseness, thanks ###
- my $cmd = [ $wget, '--quiet' ];
+ ### no verboseness, thanks ###
+ my $cmd = [ $wget, '--quiet' ];
- ### if a timeout is set, add it ###
- push(@$cmd, '--timeout=' . $TIMEOUT) if $TIMEOUT;
+ ### if a timeout is set, add it ###
+ push(@$cmd, '--timeout=' . $TIMEOUT) if $TIMEOUT;
- ### run passive if specified ###
- push @$cmd, '--passive-ftp' if $FTP_PASSIVE;
+ ### run passive if specified ###
+ push @$cmd, '--passive-ftp' if $FTP_PASSIVE;
- ### set the output document, add the uri ###
- push @$cmd, '--output-document', $to, $self->uri;
+ ### set the output document, add the uri ###
+ push @$cmd, '--output-document', $to, $self->uri;
- ### with IPC::Cmd > 0.41, this is fixed in teh library,
- ### and there's no need for special casing any more.
- ### DO NOT quote things for IPC::Run, it breaks stuff.
- # $IPC::Cmd::USE_IPC_RUN
- # ? ($to, $self->uri)
- # : (QUOTE. $to .QUOTE, QUOTE. $self->uri .QUOTE);
+ ### with IPC::Cmd > 0.41, this is fixed in teh library,
+ ### and there's no need for special casing any more.
+ ### DO NOT quote things for IPC::Run, it breaks stuff.
+ # $IPC::Cmd::USE_IPC_RUN
+ # ? ($to, $self->uri)
+ # : (QUOTE. $to .QUOTE, QUOTE. $self->uri .QUOTE);
- ### shell out ###
- my $captured;
- unless(run( command => $cmd,
- buffer => \$captured,
- verbose => $DEBUG
- )) {
- ### wget creates the output document always, even if the fetch
- ### fails.. so unlink it in that case
- 1 while unlink $to;
-
- return $self->_error(loc( "Command failed: %1", $captured || '' ));
- }
+ ### shell out ###
+ my $captured;
+ unless(run( command => $cmd,
+ buffer => \$captured,
+ verbose => $DEBUG
+ )) {
+ ### wget creates the output document always, even if the fetch
+ ### fails.. so unlink it in that case
+ 1 while unlink $to;
- return $to;
-
- } else {
- $METHOD_FAIL->{'wget'} = 1;
- return;
+ return $self->_error(loc( "Command failed: %1", $captured || '' ));
}
+
+ return $to;
}
### /bin/lftp fetch ###
@@ -919,67 +916,66 @@ sub _lftp_fetch {
};
check( $tmpl, \%hash ) or return;
- ### see if we have a wget binary ###
- if( my $lftp = can_run('lftp') ) {
-
- ### no verboseness, thanks ###
- my $cmd = [ $lftp, '-f' ];
+ ### see if we have a lftp binary ###
+ my $lftp;
+ unless( $lftp = can_run('lftp') ) {
+ $METHOD_FAIL->{'lftp'} = 1;
+ return;
+ }
- my $fh = File::Temp->new;
+ ### no verboseness, thanks ###
+ my $cmd = [ $lftp, '-f' ];
- my $str;
+ my $fh = File::Temp->new;
- ### if a timeout is set, add it ###
- $str .= "set net:timeout $TIMEOUT;\n" if $TIMEOUT;
+ my $str;
- ### run passive if specified ###
- $str .= "set ftp:passive-mode 1;\n" if $FTP_PASSIVE;
+ ### if a timeout is set, add it ###
+ $str .= "set net:timeout $TIMEOUT;\n" if $TIMEOUT;
- ### set the output document, add the uri ###
- ### quote the URI, because lftp supports certain shell
- ### expansions, most notably & for backgrounding.
- ### ' quote does nto work, must be "
- $str .= q[get ']. $self->uri .q[' -o ]. $to . $/;
+ ### run passive if specified ###
+ $str .= "set ftp:passive-mode 1;\n" if $FTP_PASSIVE;
- if( $DEBUG ) {
- my $pp_str = join ' ', split $/, $str;
- print "# lftp command: $pp_str\n";
- }
+ ### set the output document, add the uri ###
+ ### quote the URI, because lftp supports certain shell
+ ### expansions, most notably & for backgrounding.
+ ### ' quote does nto work, must be "
+ $str .= q[get ']. $self->uri .q[' -o ]. $to . $/;
- ### write straight to the file.
- $fh->autoflush(1);
- print $fh $str;
+ if( $DEBUG ) {
+ my $pp_str = join ' ', split $/, $str;
+ print "# lftp command: $pp_str\n";
+ }
- ### the command needs to be 1 string to be executed
- push @$cmd, $fh->filename;
+ ### write straight to the file.
+ $fh->autoflush(1);
+ print $fh $str;
- ### with IPC::Cmd > 0.41, this is fixed in teh library,
- ### and there's no need for special casing any more.
- ### DO NOT quote things for IPC::Run, it breaks stuff.
- # $IPC::Cmd::USE_IPC_RUN
- # ? ($to, $self->uri)
- # : (QUOTE. $to .QUOTE, QUOTE. $self->uri .QUOTE);
+ ### the command needs to be 1 string to be executed
+ push @$cmd, $fh->filename;
+ ### with IPC::Cmd > 0.41, this is fixed in teh library,
+ ### and there's no need for special casing any more.
+ ### DO NOT quote things for IPC::Run, it breaks stuff.
+ # $IPC::Cmd::USE_IPC_RUN
+ # ? ($to, $self->uri)
+ # : (QUOTE. $to .QUOTE, QUOTE. $self->uri .QUOTE);
- ### shell out ###
- my $captured;
- unless(run( command => $cmd,
- buffer => \$captured,
- verbose => $DEBUG
- )) {
- ### wget creates the output document always, even if the fetch
- ### fails.. so unlink it in that case
- 1 while unlink $to;
-
- return $self->_error(loc( "Command failed: %1", $captured || '' ));
- }
- return $to;
+ ### shell out ###
+ my $captured;
+ unless(run( command => $cmd,
+ buffer => \$captured,
+ verbose => $DEBUG
+ )) {
+ ### wget creates the output document always, even if the fetch
+ ### fails.. so unlink it in that case
+ 1 while unlink $to;
- } else {
- $METHOD_FAIL->{'lftp'} = 1;
- return;
+ return $self->_error(loc( "Command failed: %1", $captured || '' ));
}
+
+ return $to;
}
@@ -996,32 +992,35 @@ sub _ftp_fetch {
check( $tmpl, \%hash ) or return;
### see if we have a ftp binary ###
- if( my $ftp = can_run('ftp') ) {
+ my $ftp;
+ unless( $ftp = can_run('ftp') ) {
+ $METHOD_FAIL->{'ftp'} = 1;
+ return;
+ }
- my $fh = FileHandle->new;
+ my $fh = FileHandle->new;
- local $SIG{CHLD} = 'IGNORE';
+ local $SIG{CHLD} = 'IGNORE';
- unless ($fh->open("|$ftp -n")) {
- return $self->_error(loc("%1 creation failed: %2", $ftp, $!));
- }
+ unless ($fh->open("$ftp -n", '|-')) {
+ return $self->_error(loc("%1 creation failed: %2", $ftp, $!));
+ }
- my @dialog = (
- "lcd " . dirname($to),
- "open " . $self->host,
- "user anonymous $FROM_EMAIL",
- "cd /",
- "cd " . $self->path,
- "binary",
- "get " . $self->file . " " . $self->output_file,
- "quit",
- );
+ my @dialog = (
+ "lcd " . dirname($to),
+ "open " . $self->host,
+ "user anonymous $FROM_EMAIL",
+ "cd /",
+ "cd " . $self->path,
+ "binary",
+ "get " . $self->file . " " . $self->output_file,
+ "quit",
+ );
- foreach (@dialog) { $fh->print($_, "\n") }
- $fh->close or return;
+ foreach (@dialog) { $fh->print($_, "\n") }
+ $fh->close or return;
- return $to;
- }
+ return $to;
}
### lynx is stupid - it decompresses any .gz file it finds to be text
@@ -1037,94 +1036,93 @@ sub _lynx_fetch {
check( $tmpl, \%hash ) or return;
### see if we have a lynx binary ###
- if( my $lynx = can_run('lynx') ) {
-
- unless( IPC::Cmd->can_capture_buffer ) {
- $METHOD_FAIL->{'lynx'} = 1;
-
- return $self->_error(loc(
- "Can not capture buffers. Can not use '%1' to fetch files",
- 'lynx' ));
- }
-
- ### check if the HTTP resource exists ###
- if ($self->uri =~ /^https?:\/\//i) {
- my $cmd = [
- $lynx,
- '-head',
- '-source',
- "-auth=anonymous:$FROM_EMAIL",
- ];
-
- push @$cmd, "-connect_timeout=$TIMEOUT" if $TIMEOUT;
-
- push @$cmd, $self->uri;
-
- ### shell out ###
- my $head;
- unless(run( command => $cmd,
- buffer => \$head,
- verbose => $DEBUG )
- ) {
- return $self->_error(loc("Command failed: %1", $head || ''));
- }
+ my $lynx;
+ unless ( $lynx = can_run('lynx') ){
+ $METHOD_FAIL->{'lynx'} = 1;
+ return;
+ }
- unless($head =~ /^HTTP\/\d+\.\d+ 200\b/) {
- return $self->_error(loc("Command failed: %1", $head || ''));
- }
- }
+ unless( IPC::Cmd->can_capture_buffer ) {
+ $METHOD_FAIL->{'lynx'} = 1;
- ### write to the output file ourselves, since lynx ass_u_mes to much
- my $local = FileHandle->new(">$to")
- or return $self->_error(loc(
- "Could not open '%1' for writing: %2",$to,$!));
+ return $self->_error(loc(
+ "Can not capture buffers. Can not use '%1' to fetch files",
+ 'lynx' ));
+ }
- ### dump to stdout ###
+ ### check if the HTTP resource exists ###
+ if ($self->uri =~ /^https?:\/\//i) {
my $cmd = [
$lynx,
+ '-head',
'-source',
"-auth=anonymous:$FROM_EMAIL",
];
push @$cmd, "-connect_timeout=$TIMEOUT" if $TIMEOUT;
- ### DO NOT quote things for IPC::Run, it breaks stuff.
push @$cmd, $self->uri;
- ### with IPC::Cmd > 0.41, this is fixed in teh library,
- ### and there's no need for special casing any more.
- ### DO NOT quote things for IPC::Run, it breaks stuff.
- # $IPC::Cmd::USE_IPC_RUN
- # ? $self->uri
- # : QUOTE. $self->uri .QUOTE;
-
-
### shell out ###
- my $captured;
+ my $head;
unless(run( command => $cmd,
- buffer => \$captured,
+ buffer => \$head,
verbose => $DEBUG )
) {
- return $self->_error(loc("Command failed: %1", $captured || ''));
+ return $self->_error(loc("Command failed: %1", $head || ''));
}
- ### print to local file ###
- ### XXX on a 404 with a special error page, $captured will actually
- ### hold the contents of that page, and make it *appear* like the
- ### request was a success, when really it wasn't :(
- ### there doesn't seem to be an option for lynx to change the exit
- ### code based on a 4XX status or so.
- ### the closest we can come is using --error_file and parsing that,
- ### which is very unreliable ;(
- $local->print( $captured );
- $local->close or return;
-
- return $to;
+ unless($head =~ /^HTTP\/\d+\.\d+ 200\b/) {
+ return $self->_error(loc("Command failed: %1", $head || ''));
+ }
+ }
- } else {
- $METHOD_FAIL->{'lynx'} = 1;
- return;
+ ### write to the output file ourselves, since lynx ass_u_mes to much
+ my $local = FileHandle->new( $to, 'w' )
+ or return $self->_error(loc(
+ "Could not open '%1' for writing: %2",$to,$!));
+
+ ### dump to stdout ###
+ my $cmd = [
+ $lynx,
+ '-source',
+ "-auth=anonymous:$FROM_EMAIL",
+ ];
+
+ push @$cmd, "-connect_timeout=$TIMEOUT" if $TIMEOUT;
+
+ ### DO NOT quote things for IPC::Run, it breaks stuff.
+ push @$cmd, $self->uri;
+
+ ### with IPC::Cmd > 0.41, this is fixed in teh library,
+ ### and there's no need for special casing any more.
+ ### DO NOT quote things for IPC::Run, it breaks stuff.
+ # $IPC::Cmd::USE_IPC_RUN
+ # ? $self->uri
+ # : QUOTE. $self->uri .QUOTE;
+
+
+ ### shell out ###
+ my $captured;
+ unless(run( command => $cmd,
+ buffer => \$captured,
+ verbose => $DEBUG )
+ ) {
+ return $self->_error(loc("Command failed: %1", $captured || ''));
}
+
+ ### print to local file ###
+ ### XXX on a 404 with a special error page, $captured will actually
+ ### hold the contents of that page, and make it *appear* like the
+ ### request was a success, when really it wasn't :(
+ ### there doesn't seem to be an option for lynx to change the exit
+ ### code based on a 4XX status or so.
+ ### the closest we can come is using --error_file and parsing that,
+ ### which is very unreliable ;(
+ $local->print( $captured );
+ $local->close or return;
+
+ return $to;
}
### use /bin/ncftp to fetch files
@@ -1143,38 +1141,38 @@ sub _ncftp_fetch {
return if $FTP_PASSIVE;
### see if we have a ncftp binary ###
- if( my $ncftp = can_run('ncftp') ) {
-
- my $cmd = [
- $ncftp,
- '-V', # do not be verbose
- '-p', $FROM_EMAIL, # email as password
- $self->host, # hostname
- dirname($to), # local dir for the file
- # remote path to the file
- ### DO NOT quote things for IPC::Run, it breaks stuff.
- $IPC::Cmd::USE_IPC_RUN
- ? File::Spec::Unix->catdir( $self->path, $self->file )
- : QUOTE. File::Spec::Unix->catdir(
- $self->path, $self->file ) .QUOTE
-
- ];
-
- ### shell out ###
- my $captured;
- unless(run( command => $cmd,
- buffer => \$captured,
- verbose => $DEBUG )
- ) {
- return $self->_error(loc("Command failed: %1", $captured || ''));
- }
-
- return $to;
-
- } else {
+ my $ncftp;
+ unless( $ncftp = can_run('ncftp') ) {
$METHOD_FAIL->{'ncftp'} = 1;
return;
}
+
+ my $cmd = [
+ $ncftp,
+ '-V', # do not be verbose
+ '-p', $FROM_EMAIL, # email as password
+ $self->host, # hostname
+ dirname($to), # local dir for the file
+ # remote path to the file
+ ### DO NOT quote things for IPC::Run, it breaks stuff.
+ $IPC::Cmd::USE_IPC_RUN
+ ? File::Spec::Unix->catdir( $self->path, $self->file )
+ : QUOTE. File::Spec::Unix->catdir(
+ $self->path, $self->file ) .QUOTE
+
+ ];
+
+ ### shell out ###
+ my $captured;
+ unless(run( command => $cmd,
+ buffer => \$captured,
+ verbose => $DEBUG )
+ ) {
+ return $self->_error(loc("Command failed: %1", $captured || ''));
+ }
+
+ return $to;
+
}
### use /bin/curl to fetch files
@@ -1187,48 +1185,47 @@ sub _curl_fetch {
to => { required => 1, store => \$to }
};
check( $tmpl, \%hash ) or return;
+ my $curl;
+ unless ( $curl = can_run('curl') ) {
+ $METHOD_FAIL->{'curl'} = 1;
+ return;
+ }
- if (my $curl = can_run('curl')) {
-
- ### these long opts are self explanatory - I like that -jmb
- my $cmd = [ $curl, '-q' ];
+ ### these long opts are self explanatory - I like that -jmb
+ my $cmd = [ $curl, '-q' ];
- push(@$cmd, '--connect-timeout', $TIMEOUT) if $TIMEOUT;
+ push(@$cmd, '--connect-timeout', $TIMEOUT) if $TIMEOUT;
- push(@$cmd, '--silent') unless $DEBUG;
+ push(@$cmd, '--silent') unless $DEBUG;
- ### curl does the right thing with passive, regardless ###
- if ($self->scheme eq 'ftp') {
- push(@$cmd, '--user', "anonymous:$FROM_EMAIL");
- }
+ ### curl does the right thing with passive, regardless ###
+ if ($self->scheme eq 'ftp') {
+ push(@$cmd, '--user', "anonymous:$FROM_EMAIL");
+ }
- ### curl doesn't follow 302 (temporarily moved) etc automatically
- ### so we add --location to enable that.
- push @$cmd, '--fail', '--location', '--output', $to, $self->uri;
+ ### curl doesn't follow 302 (temporarily moved) etc automatically
+ ### so we add --location to enable that.
+ push @$cmd, '--fail', '--location', '--output', $to, $self->uri;
- ### with IPC::Cmd > 0.41, this is fixed in teh library,
- ### and there's no need for special casing any more.
- ### DO NOT quote things for IPC::Run, it breaks stuff.
- # $IPC::Cmd::USE_IPC_RUN
- # ? ($to, $self->uri)
- # : (QUOTE. $to .QUOTE, QUOTE. $self->uri .QUOTE);
+ ### with IPC::Cmd > 0.41, this is fixed in teh library,
+ ### and there's no need for special casing any more.
+ ### DO NOT quote things for IPC::Run, it breaks stuff.
+ # $IPC::Cmd::USE_IPC_RUN
+ # ? ($to, $self->uri)
+ # : (QUOTE. $to .QUOTE, QUOTE. $self->uri .QUOTE);
- my $captured;
- unless(run( command => $cmd,
- buffer => \$captured,
- verbose => $DEBUG )
- ) {
+ my $captured;
+ unless(run( command => $cmd,
+ buffer => \$captured,
+ verbose => $DEBUG )
+ ) {
- return $self->_error(loc("Command failed: %1", $captured || ''));
- }
+ return $self->_error(loc("Command failed: %1", $captured || ''));
+ }
- return $to;
+ return $to;
- } else {
- $METHOD_FAIL->{'curl'} = 1;
- return;
- }
}
### /usr/bin/fetch fetch! ###
@@ -1242,48 +1239,47 @@ sub _fetch_fetch {
};
check( $tmpl, \%hash ) or return;
- ### see if we have a wget binary ###
- if( HAS_FETCH and my $fetch = can_run('fetch') ) {
-
- ### no verboseness, thanks ###
- my $cmd = [ $fetch, '-q' ];
-
- ### if a timeout is set, add it ###
- push(@$cmd, '-T', $TIMEOUT) if $TIMEOUT;
-
- ### run passive if specified ###
- #push @$cmd, '-p' if $FTP_PASSIVE;
- local $ENV{'FTP_PASSIVE_MODE'} = 1 if $FTP_PASSIVE;
-
- ### set the output document, add the uri ###
- push @$cmd, '-o', $to, $self->uri;
-
- ### with IPC::Cmd > 0.41, this is fixed in teh library,
- ### and there's no need for special casing any more.
- ### DO NOT quote things for IPC::Run, it breaks stuff.
- # $IPC::Cmd::USE_IPC_RUN
- # ? ($to, $self->uri)
- # : (QUOTE. $to .QUOTE, QUOTE. $self->uri .QUOTE);
-
- ### shell out ###
- my $captured;
- unless(run( command => $cmd,
- buffer => \$captured,
- verbose => $DEBUG
- )) {
- ### wget creates the output document always, even if the fetch
- ### fails.. so unlink it in that case
- 1 while unlink $to;
-
- return $self->_error(loc( "Command failed: %1", $captured || '' ));
- }
-
- return $to;
-
- } else {
- $METHOD_FAIL->{'wget'} = 1;
+ ### see if we have a fetch binary ###
+ my $fetch;
+ unless( HAS_FETCH and $fetch = can_run('fetch') ) {
+ $METHOD_FAIL->{'fetch'} = 1;
return;
}
+
+ ### no verboseness, thanks ###
+ my $cmd = [ $fetch, '-q' ];
+
+ ### if a timeout is set, add it ###
+ push(@$cmd, '-T', $TIMEOUT) if $TIMEOUT;
+
+ ### run passive if specified ###
+ #push @$cmd, '-p' if $FTP_PASSIVE;
+ local $ENV{'FTP_PASSIVE_MODE'} = 1 if $FTP_PASSIVE;
+
+ ### set the output document, add the uri ###
+ push @$cmd, '-o', $to, $self->uri;
+
+ ### with IPC::Cmd > 0.41, this is fixed in teh library,
+ ### and there's no need for special casing any more.
+ ### DO NOT quote things for IPC::Run, it breaks stuff.
+ # $IPC::Cmd::USE_IPC_RUN
+ # ? ($to, $self->uri)
+ # : (QUOTE. $to .QUOTE, QUOTE. $self->uri .QUOTE);
+
+ ### shell out ###
+ my $captured;
+ unless(run( command => $cmd,
+ buffer => \$captured,
+ verbose => $DEBUG
+ )) {
+ ### wget creates the output document always, even if the fetch
+ ### fails.. so unlink it in that case
+ 1 while unlink $to;
+
+ return $self->_error(loc( "Command failed: %1", $captured || '' ));
+ }
+
+ return $to;
}
### use File::Copy for fetching file:// urls ###
@@ -1369,42 +1365,41 @@ sub _rsync_fetch {
to => { required => 1, store => \$to }
};
check( $tmpl, \%hash ) or return;
+ my $rsync;
+ unless ( $rsync = can_run('rsync') ) {
+ $METHOD_FAIL->{'rsync'} = 1;
+ return;
+ }
- if (my $rsync = can_run('rsync')) {
-
- my $cmd = [ $rsync ];
+ my $cmd = [ $rsync ];
- ### XXX: rsync has no I/O timeouts at all, by default
- push(@$cmd, '--timeout=' . $TIMEOUT) if $TIMEOUT;
+ ### XXX: rsync has no I/O timeouts at all, by default
+ push(@$cmd, '--timeout=' . $TIMEOUT) if $TIMEOUT;
- push(@$cmd, '--quiet') unless $DEBUG;
+ push(@$cmd, '--quiet') unless $DEBUG;
- ### DO NOT quote things for IPC::Run, it breaks stuff.
- push @$cmd, $self->uri, $to;
+ ### DO NOT quote things for IPC::Run, it breaks stuff.
+ push @$cmd, $self->uri, $to;
- ### with IPC::Cmd > 0.41, this is fixed in teh library,
- ### and there's no need for special casing any more.
- ### DO NOT quote things for IPC::Run, it breaks stuff.
- # $IPC::Cmd::USE_IPC_RUN
- # ? ($to, $self->uri)
- # : (QUOTE. $to .QUOTE, QUOTE. $self->uri .QUOTE);
+ ### with IPC::Cmd > 0.41, this is fixed in teh library,
+ ### and there's no need for special casing any more.
+ ### DO NOT quote things for IPC::Run, it breaks stuff.
+ # $IPC::Cmd::USE_IPC_RUN
+ # ? ($to, $self->uri)
+ # : (QUOTE. $to .QUOTE, QUOTE. $self->uri .QUOTE);
- my $captured;
- unless(run( command => $cmd,
- buffer => \$captured,
- verbose => $DEBUG )
- ) {
+ my $captured;
+ unless(run( command => $cmd,
+ buffer => \$captured,
+ verbose => $DEBUG )
+ ) {
- return $self->_error(loc("Command %1 failed: %2",
- "@$cmd" || '', $captured || ''));
- }
+ return $self->_error(loc("Command %1 failed: %2",
+ "@$cmd" || '', $captured || ''));
+ }
- return $to;
+ return $to;
- } else {
- $METHOD_FAIL->{'rsync'} = 1;
- return;
- }
}
#################################
View
24 inc/bundle/File/Spec.pm
@@ -3,8 +3,8 @@ package File::Spec;
use strict;
use vars qw(@ISA $VERSION);
-$VERSION = '3.33';
-$VERSION = eval $VERSION;
+$VERSION = '3.40';
+$VERSION =~ tr/_//;
my %module = (MacOS => 'Mac',
MSWin32 => 'Win32',
@@ -197,12 +197,14 @@ join is the same as catfile.
X<splitpath> X<split, path>
Splits a path in to volume, directory, and filename portions. On systems
-with no concept of volume, returns '' for volume.
+with no concept of volume, returns '' for volume.
- ($volume,$directories,$file) = File::Spec->splitpath( $path );
- ($volume,$directories,$file) = File::Spec->splitpath( $path, $no_file );
+ ($volume,$directories,$file) =
+ File::Spec->splitpath( $path );
+ ($volume,$directories,$file) =
+ File::Spec->splitpath( $path, $no_file );
-For systems with no syntax differentiating filenames from directories,
+For systems with no syntax differentiating filenames from directories,
assumes that the last file is a path unless C<$no_file> is true or a
trailing separator or F</.> or F</..> is present. On Unix, this means that C<$no_file>
true makes this return ( '', $path, '' ).
@@ -219,7 +221,7 @@ The opposite of L</catdir>.
@dirs = File::Spec->splitdir( $directories );
-C<$directories> must be only the directory portion of the path on systems
+C<$directories> must be only the directory portion of the path on systems
that have the concept of a volume or that have path syntax that differentiates
files from directories.
@@ -255,7 +257,7 @@ paths, and we will instead simply return C<$path>. Note that previous
versions of this module ignored the volume of C<$base>, which resulted in
garbage results part of the time.
-On systems that have a grammar that indicates filenames, this ignores the
+On systems that have a grammar that indicates filenames, this ignores the
C<$base> filename as well. Otherwise all path components are assumed to be
directories.
@@ -271,7 +273,7 @@ Based on code written by Shigio Yamaguchi.
=item rel2abs()
X<rel2abs> X<absolute, path> X<relative, path>
-Converts a relative path to an absolute path.
+Converts a relative path to an absolute path.
$abs_path = File::Spec->rel2abs( $path ) ;
$abs_path = File::Spec->rel2abs( $path, $base ) ;
@@ -286,7 +288,7 @@ paths, and we will instead simply return C<$path>. Note that previous
versions of this module ignored the volume of C<$base>, which resulted in
garbage results part of the time.
-On systems that have a grammar that indicates filenames, this ignores the
+On systems that have a grammar that indicates filenames, this ignores the
C<$base> filename as well. Otherwise all path components are assumed to be
directories.
@@ -329,7 +331,7 @@ splitpath(), splitdir(), catpath() and catdir() by Barrie Slaymaker.
=head1 COPYRIGHT
-Copyright (c) 2004-2010 by the Perl 5 Porters. All rights reserved.
+Copyright (c) 2004-2013 by the Perl 5 Porters. All rights reserved.
This program is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
View
4 inc/bundle/File/Spec/Cygwin.pm
@@ -4,8 +4,8 @@ use strict;
use vars qw(@ISA $VERSION);
require File::Spec::Unix;
-$VERSION = '3.33';
-$VERSION = eval $VERSION;
+$VERSION = '3.40';
+$VERSION =~ tr/_//;
@ISA = qw(File::Spec::Unix);
View
4 inc/bundle/File/Spec/Epoc.pm
@@ -3,8 +3,8 @@ package File::Spec::Epoc;
use strict;
use vars qw($VERSION @ISA);
-$VERSION = '3.33';
-$VERSION = eval $VERSION;
+$VERSION = '3.40';
+$VERSION =~ tr/_//;
require File::Spec::Unix;
@ISA = qw(File::Spec::Unix);
View
4 inc/bundle/File/Spec/Functions.pm
@@ -5,8 +5,8 @@ use strict;
use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
-$VERSION = '3.33';
-$VERSION = eval $VERSION;
+$VERSION = '3.40';
+$VERSION =~ tr/_//;
require Exporter;
View
31 inc/bundle/File/Spec/Mac.pm
@@ -4,8 +4,8 @@ use strict;
use vars qw(@ISA $VERSION);
require File::Spec::Unix;
-$VERSION = '3.33';
-$VERSION = eval $VERSION;
+$VERSION = '3.40';
+$VERSION =~ tr/_//;
@ISA = qw(File::Spec::Unix);
@@ -156,13 +156,16 @@ their Unix counterparts:
Unix:
Unix->catdir("","") = "/"
Unix->catdir("",".") = "/"
- Unix->catdir("","..") = "/" # can't go beyond root
+ Unix->catdir("","..") = "/" # can't go
+ # beyond root
Unix->catdir("",".","..","..","a") = "/a"
Mac:
- Mac->catdir("","") = rootdir() # (e.g. "HD:")
+ Mac->catdir("","") = rootdir() # (e.g. "HD:")
Mac->catdir("",":") = rootdir()
- Mac->catdir("","::") = rootdir() # can't go beyond root
- Mac->catdir("",":","::","::","a") = rootdir() . "a:" # (e.g. "HD:a:")
+ Mac->catdir("","::") = rootdir() # can't go
+ # beyond root
+ Mac->catdir("",":","::","::","a") = rootdir() . "a:"
+ # (e.g. "HD:a:")
However, this approach is limited to the first arguments following
"root" (again, see C<Unix-E<gt>canonpath()> ). If there are more
@@ -400,10 +403,11 @@ the filename '' is always considered to be absolute. Note that with version
E.g.
- File::Spec->file_name_is_absolute("a"); # false (relative)
- File::Spec->file_name_is_absolute(":a:b:"); # false (relative)
- File::Spec->file_name_is_absolute("MacintoshHD:"); # true (absolute)
- File::Spec->file_name_is_absolute(""); # true (absolute)
+ File::Spec->file_name_is_absolute("a"); # false (relative)
+ File::Spec->file_name_is_absolute(":a:b:"); # false (relative)
+ File::Spec->file_name_is_absolute("MacintoshHD:");
+ # true (absolute)
+ File::Spec->file_name_is_absolute(""); # true (absolute)
=cut
@@ -440,7 +444,8 @@ sub path {
=item splitpath
($volume,$directories,$file) = File::Spec->splitpath( $path );
- ($volume,$directories,$file) = File::Spec->splitpath( $path, $no_file );
+ ($volume,$directories,$file) = File::Spec->splitpath( $path,
+ $no_file );
Splits a path into volume, directory, and filename portions.
@@ -683,7 +688,7 @@ sub abs2rel {
# Now, remove all leading components that are the same
my @pathchunks = $self->splitdir( $path_dirs );
my @basechunks = $self->splitdir( $base_dirs );
-
+
while ( @pathchunks &&
@basechunks &&
lc( $pathchunks[0] ) eq lc( $basechunks[0] ) ) {
@@ -740,7 +745,7 @@ sub rel2abs {
# Split up paths
- # igonore $path's volume
+ # ignore $path's volume
my ( $path_dirs, $path_file ) = ($self->splitpath($path))[1,2] ;
# ignore $base's file part
View
30 inc/bundle/File/Spec/OS2.pm
@@ -4,8 +4,8 @@ use strict;
use vars qw(@ISA $VERSION);
require File::Spec::Unix;
-$VERSION = '3.33';
-$VERSION = eval $VERSION;
+$VERSION = '3.40';
+$VERSION =~ tr/_//;
@ISA = qw(File::Spec::Unix);
@@ -74,15 +74,15 @@ sub splitpath {
my ($self,$path, $nofile) = @_;
my ($volume,$directory,$file) = ('','','');
if ( $nofile ) {
- $path =~
- m{^( (?:[a-zA-Z]:|(?:\\\\|//)[^\\/]+[\\/][^\\/]+)? )
+ $path =~
+ m{^( (?:[a-zA-Z]:|(?:\\\\|//)[^\\/]+[\\/][^\\/]+)? )
(.*)
}xs;
$volume = $1;
$directory = $2;
}
else {
- $path =~
+ $path =~
m{^ ( (?: [a-zA-Z]: |
(?:\\\\|//)[^\\/]+[\\/][^\\/]+
)?
@@ -117,7 +117,7 @@ sub catpath {
$volume .= $directory ;
- # If the volume is not just A:, make sure the glue separator is
+ # If the volume is not just A:, make sure the glue separator is
# there, reusing whatever separator is first in the $volume if possible.
if ( $volume !~ m@^[a-zA-Z]:\Z(?!\n)@s &&
$volume =~ m@[^\\/]\Z(?!\n)@ &&
@@ -162,9 +162,9 @@ sub abs2rel {
my @pathchunks = $self->splitdir( $path_directories );
my @basechunks = $self->splitdir( $base_directories );
- while ( @pathchunks &&
- @basechunks &&
- lc( $pathchunks[0] ) eq lc( $basechunks[0] )
+ while ( @pathchunks &&
+ @basechunks &&
+ lc( $pathchunks[0] ) eq lc( $basechunks[0] )
) {
shift @pathchunks ;
shift @basechunks ;
@@ -175,7 +175,7 @@ sub abs2rel {
$base_directories = CORE::join( '/', @basechunks );
# $base_directories now contains the directories the resulting relative
- # path must ascend out of before it can descend to $path_directory. So,
+ # path must ascend out of before it can descend to $path_directory. So,
# replace all names with $parentDir
#FA Need to replace between backslashes...
@@ -191,8 +191,8 @@ sub abs2rel {
$path_directories = "$base_directories$path_directories" ;
}
- return $self->canonpath(
- $self->catpath( "", $path_directories, $path_file )
+ return $self->canonpath(
+ $self->catpath( "", $path_directories, $path_file )
) ;
}
@@ -218,9 +218,9 @@ sub rel2abs {
my ( $base_volume, $base_directories ) =
$self->splitpath( $base, 1 ) ;
- $path = $self->catpath(
- $base_volume,
- $self->catdir( $base_directories, $path_directories ),
+ $path = $self->catpath(
+ $base_volume,
+ $self->catdir( $base_directories, $path_directories ),
$path_file
) ;
}
View
94 inc/bundle/File/Spec/Unix.pm
@@ -3,8 +3,8 @@ package File::Spec::Unix;
use strict;
use vars qw($VERSION);
-$VERSION = '3.33';
-$VERSION = eval $VERSION;
+$VERSION = '3.40';
+$VERSION =~ tr/_//;
=head1 NAME
@@ -43,7 +43,7 @@ actually traverse the filesystem cleaning up paths like this.
sub canonpath {
my ($self,$path) = @_;
return unless defined $path;
-
+
# Handle POSIX-style node names beginning with double slash (qnx, nto)
# (POSIX says: "a pathname that begins with two successive slashes
# may be interpreted in an implementation-defined manner, although
@@ -135,7 +135,7 @@ writable:
$ENV{TMPDIR}
/tmp
-Since perl 5.8.0, if running under taint mode, and if $ENV{TMPDIR}
+If running under taint mode, and if $ENV{TMPDIR}
is tainted, it is not used.
=cut
@@ -151,6 +151,9 @@ sub _tmpdir {
require Scalar::Util;
@dirlist = grep { ! Scalar::Util::tainted($_) } @dirlist;
}
+ elsif ($] < 5.007) { # No ${^TAINT} before 5.8
+ @dirlist = grep { eval { eval('1'.substr $_,0,0) } } @dirlist;
+ }
}
foreach (@dirlist) {
next unless defined && -d && -w _;
@@ -200,7 +203,7 @@ sub case_tolerant { 0 }
Takes as argument a path and returns true if it is an absolute path.
-This does not consult the local filesystem on Unix, Win32, OS/2 or Mac
+This does not consult the local filesystem on Unix, Win32, OS/2 or Mac
OS (Classic). It does consult the working environment for VMS (see
L<File::Spec::VMS/file_name_is_absolute>).
@@ -238,13 +241,14 @@ sub join {
=item splitpath
($volume,$directories,$file) = File::Spec->splitpath( $path );
- ($volume,$directories,$file) = File::Spec->splitpath( $path, $no_file );
+ ($volume,$directories,$file) = File::Spec->splitpath( $path,
+ $no_file );
Splits a path into volume, directory, and filename portions. On systems
-with no concept of volume, returns '' for volume.
+with no concept of volume, returns '' for volume.
-For systems with no syntax differentiating filenames from directories,
-assumes that the last file is a path unless $no_file is true or a
+For systems with no syntax differentiating filenames from directories,
+assumes that the last file is a path unless $no_file is true or a
trailing separator or /. or /.. is present. On Unix this means that $no_file
true makes this return ( '', $path, '' ).
@@ -279,7 +283,7 @@ The opposite of L</catdir()>.
@dirs = File::Spec->splitdir( $directories );
-$directories must be only the directory portion of the path on systems
+$directories must be only the directory portion of the path on systems
that have the concept of a volume or that have path syntax that differentiates
files from directories.
@@ -314,10 +318,10 @@ inserted if needed (though if the directory portion doesn't start with
sub catpath {
my ($self,$volume,$directory,$file) = @_;
- if ( $directory ne '' &&
- $file ne '' &&
- substr( $directory, -1 ) ne '/' &&
- substr( $file, 0, 1 ) ne '/'
+ if ( $directory ne '' &&
+ $file ne '' &&
+ substr( $directory, -1 ) ne '/' &&
+ substr( $file, 0, 1 ) ne '/'
) {
$directory .= "/$file" ;
}
@@ -341,16 +345,18 @@ relative, then it is converted to absolute form using
L</rel2abs()>. This means that it is taken to be relative to
L<cwd()|Cwd>.
-On systems that have a grammar that indicates filenames, this ignores the
+On systems that have a grammar that indicates filenames, this ignores the
$base filename. Otherwise all path components are assumed to be
directories.
If $path is relative, it is converted to absolute form using L</rel2abs()>.
This means that it is taken to be relative to L<cwd()|Cwd>.
-No checks against the filesystem are made. On VMS, there is
-interaction with the working environment, as logicals and
-macros are expanded.
+No checks against the filesystem are made, so the result may not be correct if
+C<$base> contains symbolic links. (Apply
+L<Cwd::abs_path()|Cwd/abs_path> beforehand if that
+is a concern.) On VMS, there is interaction with the working environment, as
+logicals and macros are expanded.
Based on code written by Shigio Yamaguchi.
@@ -362,48 +368,72 @@ sub abs2rel {
($path, $base) = map $self->canonpath($_), $path, $base;
+ my $path_directories;
+ my $base_directories;
+
if (grep $self->file_name_is_absolute($_), $path, $base) {
($path, $base) = map $self->rel2abs($_), $path, $base;
- }
- else {
- # save a couple of cwd()s if both paths are relative
- ($path, $base) = map $self->catdir('/', $_), $path, $base;
- }
my ($path_volume) = $self->splitpath($path, 1);
my ($base_volume) = $self->splitpath($base, 1);
# Can't relativize across volumes
return $path unless $path_volume eq $base_volume;
- my $path_directories = ($self->splitpath($path, 1))[1];
- my $base_directories = ($self->splitpath($base, 1))[1];
+ $path_directories = ($self->splitpath($path, 1))[1];
+ $base_directories = ($self->splitpath($base, 1))[1];
# For UNC paths, the user might give a volume like //foo/bar that
# strictly speaking has no directory portion. Treat it as if it
# had the root directory for that volume.
if (!length($base_directories) and $self->file_name_is_absolute($base)) {
$base_directories = $self->rootdir;
}
+ }
+ else {
+ my $wd= ($self->splitpath($self->_cwd(), 1))[1];
+ $path_directories = $self->catdir($wd, $path);
+ $base_directories = $self->catdir($wd, $base);
+ }
# Now, remove all leading components that are the same
my @pathchunks = $self->splitdir( $path_directories );
my @basechunks = $self->splitdir( $base_directories );
if ($base_directories eq $self->rootdir) {
+ return $self->curdir if $path_directories eq $self->rootdir;
shift @pathchunks;
return $self->canonpath( $self->catpath('', $self->catdir( @pathchunks ), '') );
}
+ my @common;
while (@pathchunks && @basechunks && $self->_same($pathchunks[0], $basechunks[0])) {
- shift @pathchunks ;
+ push @common, shift @pathchunks ;
shift @basechunks ;
}
return $self->curdir unless @pathchunks || @basechunks;
- # $base now contains the directories the resulting relative path
- # must ascend out of before it can descend to $path_directory.
- my $result_dirs = $self->catdir( ($self->updir) x @basechunks, @pathchunks );
+ # @basechunks now contains the directories the resulting relative path
+ # must ascend out of before it can descend to $path_directory. If there
+ # are updir components, we must descend into the corresponding directories
+ # (this only works if they are no symlinks).
+ my @reverse_base;
+ while( defined(my $dir= shift @basechunks) ) {
+ if( $dir ne $self->updir ) {
+ unshift @reverse_base, $self->updir;
+ push @common, $dir;
+ }
+ elsif( @common ) {
+ if( @reverse_base && $reverse_base[0] eq $self->updir ) {
+ shift @reverse_base;
+ pop @common;
+ }
+ else {
+ unshift @reverse_base, pop @common;
+ }
+ }
+ }
+ my $result_dirs = $self->catdir( @reverse_base, @pathchunks );
return $self->canonpath( $self->catpath('', $result_dirs, '') );
}
@@ -413,7 +443,7 @@ sub _same {
=item rel2abs()
-Converts a relative path to an absolute path.
+Converts a relative path to an absolute path.
$abs_path = File::Spec->rel2abs( $path ) ;
$abs_path = File::Spec->rel2abs( $path, $base ) ;
@@ -469,6 +499,8 @@ Copyright (c) 2004 by the Perl 5 Porters. All rights reserved.
This program is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
+Please submit bug reports and patches to perlbug@perl.org.
+
=head1 SEE ALSO
L<File::Spec>
@@ -502,7 +534,7 @@ sub _collapse {
length $collapsed[-1] and # and its not the rootdir
$collapsed[-1] ne $updir and # nor another updir
$collapsed[-1] ne $curdir # nor the curdir
- )
+ )
{ # then
pop @collapsed; # collapse
}
View
629 inc/bundle/File/Spec/VMS.pm
@@ -4,8 +4,8 @@ use strict;
use vars qw(@ISA $VERSION);
require File::Spec::Unix;
-$VERSION = '3.33';
-$VERSION = eval $VERSION;
+$VERSION = '3.40';
+$VERSION =~ tr/_//;
@ISA = qw(File::Spec::Unix);
@@ -26,16 +26,9 @@ See File::Spec::Unix for a documentation of the methods provided
there. This package overrides the implementation of these methods, not
the semantics.
-The default behavior is to allow either VMS or Unix syntax on input and to
-return VMS syntax on output, even when Unix syntax was given on input.
-
-When used with a Perl of version 5.10 or greater and a CRTL possessing the
-relevant capabilities, override behavior depends on the CRTL features
-C<DECC$FILENAME_UNIX_REPORT> and C<DECC$EFS_CHARSET>. When the
-C<DECC$EFS_CHARSET> feature is enabled and the input parameters are clearly
-in Unix syntax, the output will be in Unix syntax. If
-C<DECC$FILENAME_UNIX_REPORT> is enabled and the output syntax cannot be
-determined from the input syntax, the output will be in Unix syntax.
+The default behavior is to allow either VMS or Unix syntax on input and to
+return VMS syntax on output unless Unix syntax has been explicity requested
+via the C<DECC$FILENAME_UNIX_REPORT> CRTL feature.
=over 4
@@ -59,28 +52,15 @@ sub _unix_rpt {
$unix_rpt = VMS::Feature::current("filename_unix_report");
} else {
my $env_unix_rpt = $ENV{'DECC$FILENAME_UNIX_REPORT'} || '';
- $unix_rpt = $env_unix_rpt =~ /^[ET1]/i;
+ $unix_rpt = $env_unix_rpt =~ /^[ET1]/i;
}
return $unix_rpt;
}
-# Need to look up the EFS character set mode. This may become a dynamic
-# mode in the future.
-sub _efs {
- my $efs;
- if ($use_feature) {
- $efs = VMS::Feature::current("efs_charset");
- } else {
- my $env_efs = $ENV{'DECC$EFS_CHARSET'} || '';
- $efs = $env_efs =~ /^[ET1]/i;
- }
- return $efs;
-}
-
=item canonpath (override)
-Removes redundant portions of file specifications according to the syntax
-detected.
+Removes redundant portions of file specifications and returns results
+in native syntax unless Unix filename reporting has been enabled.
=cut
@@ -90,37 +70,31 @@ sub canonpath {
return undef unless defined $path;
- my $efs = $self->_efs;
+ my $unix_rpt = $self->_unix_rpt;
- if ($path =~ m|/|) { # Fake Unix
+ if ($path =~ m|/|) {
my $pathify = $path =~ m|/\Z(?!\n)|;
$path = $self->SUPER::canonpath($path);
- # Do not convert to VMS when EFS character sets are in use
- return $path if $efs;
-
- if ($pathify) { return vmspath($path); }
- else { return vmsify($path); }
+ return $path if $unix_rpt;
+ $path = $pathify ? vmspath($path) : vmsify($path);
}
- else {
-
-#FIXME - efs parsing has different rules. Characters in a VMS filespec
-# are only delimiters if not preceded by '^';
- $path =~ tr/<>/[]/; # < and > ==> [ and ]
- $path =~ s/\]\[\./\.\]\[/g; # ][. ==> .][
- $path =~ s/\[000000\.\]\[/\[/g; # [000000.][ ==> [
- $path =~ s/\[000000\./\[/g; # [000000. ==> [
- $path =~ s/\.\]\[000000\]/\]/g; # .][000000] ==> ]
- $path =~ s/\.\]\[/\./g; # foo.][bar ==> foo.bar
- 1 while ($path =~ s/([\[\.])(-+)\.(-+)([\.\]])/$1$2$3$4/);
+ $path =~ s/(?<!\^)</[/; # < and > ==> [ and ]
+ $path =~ s/(?<!\^)>/]/;
+ $path =~ s/(?<!\^)\]\[\./\.\]\[/g; # ][. ==> .][
+ $path =~ s/(?<!\^)\[000000\.\]\[/\[/g; # [000000.][ ==> [
+ $path =~ s/(?<!\^)\[000000\./\[/g; # [000000. ==> [
+ $path =~ s/(?<!\^)\.\]\[000000\]/\]/g; # .][000000] ==> ]
+ $path =~ s/(?<!\^)\.\]\[/\./g; # foo.][bar ==> foo.bar
+ 1 while ($path =~ s/(?<!\^)([\[\.])(-+)\.(-+)([\.\]])/$1$2$3$4/);
# That loop does the following
# with any amount of dashes:
# .-.-. ==> .--.
# [-.-. ==> [--.
# .-.-] ==> .--]
# [-.-] ==> [--]
- 1 while ($path =~ s/([\[\.])[^\]\.]+\.-(-+)([\]\.])/$1$2$3/);
+ 1 while ($path =~ s/(?<!\^)([\[\.])[^\]\.]+\.-(-+)([\]\.])/$1$2$3/);
# That loop does the following
# with any amount (minimum 2)
# of dashes:
@@ -130,193 +104,63 @@ sub canonpath {
# [foo.--] ==> [-]
#
# And then, the remaining cases
- $path =~ s/\[\.-/[-/; # [.- ==> [-
- $path =~ s/\.[^\]\.]+\.-\./\./g; # .foo.-. ==> .
- $path =~ s/\[[^\]\.]+\.-\./\[/g; # [foo.-. ==> [
- $path =~ s/\.[^\]\.]+\.-\]/\]/g; # .foo.-] ==> ]
- $path =~ s/\[[^\]\.]+\.-\]/\[000000\]/g;# [foo.-] ==> [000000]
- $path =~ s/\[\]// unless $path eq '[]'; # [] ==>
- return $path;
- }
+ $path =~ s/(?<!\^)\[\.-/[-/; # [.- ==> [-
+ $path =~ s/(?<!\^)\.[^\]\.]+\.-\./\./g; # .foo.-. ==> .
+ $path =~ s/(?<!\^)\[[^\]\.]+\.-\./\[/g; # [foo.-. ==> [
+ $path =~ s/(?<!\^)\.[^\]\.]+\.-\]/\]/g; # .foo.-] ==> ]
+ # [foo.-] ==> [000000]
+ $path =~ s/(?<!\^)\[[^\]\.]+\.-\]/\[000000\]/g;
+ # [] ==>
+ $path =~ s/(?<!\^)\[\]// unless $path eq '[]';
+ return $unix_rpt ? unixify($path) : $path;
}
=item catdir (override)
Concatenates a list of file specifications, and returns the result as a
-directory specification. No check is made for "impossible"
-cases (e.g. elements other than the first being absolute filespecs).
+native directory specification unless the Unix filename reporting feature
+has been enabled. No check is made for "impossible" cases (e.g. elements
+other than the first being absolute filespecs).
=cut
sub catdir {
my $self = shift;
my $dir = pop;
- my $efs = $self->_efs;
my $unix_rpt = $self->_unix_rpt;
-
my @dirs = grep {defined() && length()} @_;
- if ($efs) {
- # Legacy mode removes blank entries.
- # But that breaks existing generic perl code that
- # uses a blank path at the beginning of the array
- # to indicate an absolute path.
- # So put it back if found.
- if (@_) {
- if ($_[0] eq '') {
- unshift @dirs, '';
- }
- }
- }
my $rslt;
if (@dirs) {
my $path = (@dirs == 1 ? $dirs[0] : $self->catdir(@dirs));
my ($spath,$sdir) = ($path,$dir);
+ $spath =~ s/\.dir\Z(?!\n)//i; $sdir =~ s/\.dir\Z(?!\n)//i;
- if ($efs) {
- # Extended character set in use, go into DWIM mode.
-
- # Now we need to identify what the directory is in
- # of the specification in order to merge them.
- my $path_unix = 0;
- $path_unix = 1 if ($path =~ m#/#);
- $path_unix = 1 if ($path =~ /^\.\.?$/);
- my $path_vms = 0;
- $path_vms = 1 if ($path =~ m#(?<!\^)[\[<\]:]#);
- $path_vms = 1 if ($path =~ /^--?$/);
- my $dir_unix = 0;
- $dir_unix = 1 if ($dir =~ m#/#);
- $dir_unix = 1 if ($dir =~ /^\.\.?$/);
- my $dir_vms = 0;
- $dir_vms = 1 if ($dir =~ m#(?<!\^)[\[<\]:]#);
- $dir_vms = 1 if ($dir =~ /^--?$/