From: Rafael Garcia-Suarez Date: Sun, 11 Nov 2007 12:22:48 +0000 (+0000) Subject: Upgrade File::Fetch to 0.13_03 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=fe98d82b2e4171a609025e7b159d7945efe2900c;p=p5sagit%2Fp5-mst-13.2.git Upgrade File::Fetch to 0.13_03 p4raw-id: //depot/perl@32274 --- diff --git a/lib/File/Fetch.pm b/lib/File/Fetch.pm index 8798c57..2273ae0 100644 --- a/lib/File/Fetch.pm +++ b/lib/File/Fetch.pm @@ -23,8 +23,9 @@ use vars qw[ $VERBOSE $PREFER_BIN $FROM_EMAIL $USER_AGENT 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|]; @@ -52,7 +53,8 @@ local $Module::Load::Conditional::VERBOSE = 0; 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 @@ -104,7 +106,24 @@ The scheme from the uri (like 'file', 'http', etc) =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 @@ -130,8 +149,8 @@ result of $ff->output_file will be used. 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 }, }; @@ -276,14 +295,28 @@ sub new { ### ### 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 { @@ -306,30 +339,37 @@ 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 { @@ -344,6 +384,10 @@ sub _parse_uri { $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; } @@ -379,8 +423,11 @@ sub fetch { ### 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'; @@ -812,11 +859,10 @@ sub _curl_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; @@ -911,7 +957,8 @@ sub _rsync_fetch { verbose => $DEBUG ) ) { - return $self->_error(loc("Command failed: %1", $captured || '')); + return $self->_error(loc("Command %1 failed: %2", + "@$cmd" || '', $captured || '')); } return $to; diff --git a/lib/File/Fetch/t/01_File-Fetch.t b/lib/File/Fetch/t/01_File-Fetch.t index 53496f1..4f814cb 100644 --- a/lib/File/Fetch/t/01_File-Fetch.t +++ b/lib/File/Fetch/t/01_File-Fetch.t @@ -46,32 +46,58 @@ if( $File::Fetch::DEBUG ) { } ### _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 => '', @@ -86,16 +112,11 @@ my $map = [ 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 ); @@ -103,18 +124,20 @@ for my $entry (@$map ) { 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})" ); } } @@ -175,7 +198,7 @@ sub _fetch_uri { 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' ); @@ -183,11 +206,11 @@ sub _fetch_uri { 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; }