use constant QUOTE => do { $^O eq 'MSWin32' ? q["] : q['] };
-$VERSION = '0.13_02';
-$PREFER_BIN = 0; # XXX TODO implement
+$VERSION = '0.13_03';
+$VERSION = eval $VERSION; # avoid warnings with development releases
+$PREFER_BIN = 0; # XXX TODO implement
$FROM_EMAIL = 'File-Fetch@example.com';
$USER_AGENT = 'File::Fetch/$VERSION';
$BLACKLIST = [qw|ftp|];
use constant ON_WIN => ($^O eq 'MSWin32');
use constant ON_VMS => ($^O eq 'VMS');
use constant ON_UNIX => (!ON_WIN and !ON_VMS);
-
+use constant HAS_VOL => (ON_WIN or ON_VMS);
+use constant HAS_SHARE => (ON_WIN);
=pod
=head1 NAME
=item $ff->host
-The hostname in the uri, will be empty for a 'file' scheme.
+The hostname in the uri. Will be empty if host was originally
+'localhost' for a 'file://' url.
+
+=item $ff->vol
+
+On operating systems with the concept of a volume the second element
+of a file:// is considered to the be volume specification for the file.
+Thus on Win32 and VMS this routine returns the volume, on other operating
+systems this returns nothing.
+
+On Windows this value may be empty if the uri is to a network share, in
+which case the 'share' property will be defined. Additionally, volume
+specifications that use '|' as ':' will be converted on read to use ':'.
+
+=item $ff->share
+
+On systems with the concept of a network share (currently only Windows) returns
+the sharename from a file://// url. On other operating systems returns empty.
=item $ff->path
path => { default => '/' },
file => { required => 1 },
uri => { required => 1 },
- vol => { }, # windows and vms for file:// uris
- share => { }, # windows for file:// uris
+ vol => { default => '' }, # windows and vms for file:// uris
+ share => { default => '' }, # windows for file:// uris
_error_msg => { no_override => 1 },
_error_msg_long => { no_override => 1 },
};
###
### In the case of file:// urls there maybe be additional fields
###
+### For systems with volume specifications such as VMS and Win32 there will be
+### a volume specifier provided in the 'vol' field.
+###
+### 'vol' => 'volumename'
+###
### For windows file shares there may be a 'share' key specified
###
### 'share' => 'sharename'
###
-### For systems with volume specifications such as VMS and Win32 there may be
-### a volume specifier provided in the 'vol' field.
+### Note that the rules of what a file:// url means vary by the operating system
+### of the host being addressed. Thus file:///d|/foo/bar.txt means the obvious
+### 'D:\foo\bar.txt' on windows, but on unix it means '/d|/foo/bar.txt' and
+### not '/foo/bar.txt'
###
-### 'vol' => 'volumename'
+### Similarly if the host interpreting the url is VMS then
+### file:///disk$user/my/notes/note12345.txt' means
+### 'DISK$USER:[MY.NOTES]NOTE123456.TXT' but if it is unix it means
+### #/disk$user/my/notes/note12345.txt'.
+###
+### This means it is impossible to serve certain file:// urls on certain systems.
+###
+### Thus are the problems with a protocol-less specification. :-(
###
sub _parse_uri {
### file://hostname/...
### file://hostname/...
+ ### normalize file://localhost with file:///
$href->{host} = $parts[0] || '';
### index in @parts where the path components begin;
my $index = 1;
-
- ### file:///D|/blah.txt
- ### file:///D:/blah.txt
- ### file://hostname/D|/blah.txt
- ### file://hostname/D:/blah.txt
- if ($parts[1] =~ s/\A([A-Z])\|\z/$1:/i || # s/D|/D:/
- $parts[1] =~ m/\A[A-Z]:\z/i # m/D:/
- ) {
- $href->{vol} = $parts[1];
- $index = 2; # index after the volume
### file:////hostname/sharename/blah.txt
- } elsif ( not length $parts[0] and not length $parts[1] ) {
+ if ( HAS_SHARE and not length $parts[0] and not length $parts[1] ) {
+
$href->{host} = $parts[2] || ''; # avoid warnings
$href->{share} = $parts[3] || ''; # avoid warnings
$index = 4 # index after the share
- }
- ### rebuild the path from the leftover paths;
+ ### file:///D|/blah.txt
+ ### file:///D:/blah.txt
+ ### file:///disk$user/blah.txt
+ } elsif (HAS_VOL) {
+
+ ### this code comes from dmq's patch, but:
+ ### XXX if volume is empty, wouldn't that be an error? --kane
+ ### if so, our file://localhost test needs to be fixed as wel
+ $href->{vol} = $parts[1] || '';
+
+ ### correct D| style colume descriptors
+ $href->{vol} =~ s/\A([A-Z])\|\z/$1:/i if ON_WIN;
+
+ $index = 2; # index after the volume
+ }
+
+ ### rebuild the path from the leftover parts;
$href->{path} = join '/', '', splice( @parts, $index, $#parts );
} else {
$href->{file} = $parts[2];
}
+ ### host will be empty if the target was 'localhost' and the
+ ### scheme was 'file'
+ $href->{host} = '' if ($href->{host} eq 'localhost') and
+ ($href->{scheme} eq 'file');
return $href;
}
### set passive ftp if required ###
local $ENV{FTP_PASSIVE} = $FTP_PASSIVE;
- ###
- my $out_to = File::Spec->catfile( $to, $self->output_file );
+ ### we dont use catfile on win32 because if we are using a cygwin tool
+ ### under cmd.exe they wont understand windows style separators.
+ my $out_to = ON_WIN ? $to.'/'.$self->output_file
+ : File::Spec->catfile( $to, $self->output_file );
+
for my $method ( @{ $METHODS->{$self->scheme} } ) {
my $sub = '_'.$method.'_fetch';
### use File::Copy for fetching file:// urls ###
-### XXX file:// uri to local path conversion is just too weird...
-### depend on LWP to do it for us
###
### See section 3.10 of RFC 1738 (http://www.faqs.org/rfcs/rfc1738.html)
### Also see wikipedia on file:// (http://en.wikipedia.org/wiki/File://)
+###
sub _file_fetch {
my $self = shift;
verbose => $DEBUG )
) {
- return $self->_error(loc("Command failed: %1", $captured || ''));
+ return $self->_error(loc("Command %1 failed: %2",
+ "@$cmd" || '', $captured || ''));
}
return $to;
}
### _parse_uri tests
-my $map = [
+### these go on all platforms
+my @map = (
{ uri => 'ftp://cpan.org/pub/mirror/index.txt',
scheme => 'ftp',
host => 'cpan.org',
path => '/pub/mirror/',
file => 'index.txt'
},
+ { uri => 'rsync://cpan.pair.com/CPAN/MIRRORING.FROM',
+ scheme => 'rsync',
+ host => 'cpan.pair.com',
+ path => '/CPAN/',
+ file => 'MIRRORING.FROM',
+ },
+ { uri => 'http://localhost/tmp/index.txt',
+ scheme => 'http',
+ host => 'localhost', # host is empty only on 'file://'
+ path => '/tmp/',
+ file => 'index.txt',
+ },
+
+ ### only test host part, the rest is OS dependant
+ { uri => 'file://localhost/tmp/index.txt',
+ host => '', # host should be empty on 'file://'
+ },
+);
+
+### these only if we're not on win32/vms
+push @map, (
{ uri => 'file:///usr/local/tmp/foo.txt',
scheme => 'file',
host => '',
path => '/usr/local/tmp/',
file => 'foo.txt',
},
- { uri => 'file:////hostname/share/tmp/foo.txt',
+ { uri => 'file://hostname/tmp/foo.txt',
scheme => 'file',
host => 'hostname',
- share => 'share',
path => '/tmp/',
file => 'foo.txt',
- },
- { uri => 'file://hostname/tmp/foo.txt',
+ },
+) if not &File::Fetch::ON_WIN and not &File::Fetch::ON_VMS;
+
+### these only on win32
+push @map, (
+ { uri => 'file:////hostname/share/tmp/foo.txt',
scheme => 'file',
host => 'hostname',
+ share => 'share',
path => '/tmp/',
file => 'foo.txt',
- },
+ },
{ uri => 'file:///D:/tmp/foo.txt',
scheme => 'file',
host => '',
path => '/tmp/',
file => 'foo.txt',
},
- { uri => 'rsync://cpan.pair.com/CPAN/MIRRORING.FROM',
- scheme => 'rsync',
- host => 'cpan.pair.com',
- path => '/CPAN/',
- file => 'MIRRORING.FROM',
- },
-];
+) if &File::Fetch::ON_WIN;
+
### parse uri tests ###
-for my $entry (@$map ) {
+for my $entry (@map ) {
my $uri = $entry->{'uri'};
my $href = File::Fetch->_parse_uri( $uri );
for my $key ( sort keys %$entry ) {
is( $href->{$key}, $entry->{$key},
- " '$key' ok ($entry->{$key})");
+ " '$key' ok ($entry->{$key}) for $uri");
}
}
### File::Fetch->new tests ###
-for my $entry (@$map) {
+for my $entry (@map) {
my $ff = File::Fetch->new( uri => $entry->{uri} );
- isa_ok( $ff, "File::Fetch" );
+
+ ok( $ff, "Object for uri '$entry->{uri}'" );
+ isa_ok( $ff, "File::Fetch", " Object" );
for my $acc ( keys %$entry ) {
is( $ff->$acc(), $entry->{$acc},
- " Accessor '$acc' ok" );
+ " Accessor '$acc' ok ($entry->{$acc})" );
}
}
my $ff = File::Fetch->new( uri => $uri );
- ok( $ff, "FF object for $uri (will fetch with $method)" );
+ ok( $ff, "FF object for $uri (fetch with $method)" );
my $file = $ff->fetch( to => 'tmp' );
skip "You do not have '$method' installed/available", 3
if $File::Fetch::METHOD_FAIL->{$method} &&
$File::Fetch::METHOD_FAIL->{$method};
-
- ok( $file, " File ($file) fetched using $method" );
- ok( -s $file, " File has size" );
- is( basename($file), $ff->output_file,
- " File has expected name" );
+ ok( $file, " File ($file) fetched with $method ($uri)" );
+ ok( $file && -s $file,
+ " File has size" );
+ is( $file && basename($file), $ff->output_file,
+ " File has expected name" );
unlink $file;
}
projects / p5sagit/p5-mst-13.2.git / commitdiff