282 lines
7.6 KiB
Perl
282 lines
7.6 KiB
Perl
BEGIN { chdir 't' if -d 't' };
|
|
|
|
use strict;
|
|
use lib '../lib';
|
|
|
|
use Test::More 'no_plan';
|
|
|
|
use Cwd qw[cwd];
|
|
use File::Basename qw[basename];
|
|
use Data::Dumper;
|
|
|
|
use_ok('File::Fetch');
|
|
|
|
### optionally set debugging ###
|
|
$File::Fetch::DEBUG = $File::Fetch::DEBUG = 1 if $ARGV[0];
|
|
$IPC::Cmd::DEBUG = $IPC::Cmd::DEBUG = 1 if $ARGV[0];
|
|
|
|
unless( $ENV{PERL_CORE} ) {
|
|
warn qq[
|
|
|
|
####################### NOTE ##############################
|
|
|
|
Some of these tests assume you are connected to the
|
|
internet. If you are not, or if certain protocols or hosts
|
|
are blocked and/or firewalled, these tests could fail due
|
|
to no fault of the module itself.
|
|
|
|
###########################################################
|
|
|
|
];
|
|
|
|
sleep 3 unless $File::Fetch::DEBUG;
|
|
}
|
|
|
|
### show us the tools IPC::Cmd will use to run binary programs
|
|
if( $File::Fetch::DEBUG ) {
|
|
### stupid 'used only once' warnings ;(
|
|
diag( "IPC::Run enabled: " .
|
|
$IPC::Cmd::USE_IPC_RUN || $IPC::Cmd::USE_IPC_RUN );
|
|
diag( "IPC::Run available: " . IPC::Cmd->can_use_ipc_run );
|
|
diag( "IPC::Run vesion: $IPC::Run::VERSION" );
|
|
diag( "IPC::Open3 enabled: " .
|
|
$IPC::Cmd::USE_IPC_OPEN3 || $IPC::Cmd::USE_IPC_OPEN3 );
|
|
diag( "IPC::Open3 available: " . IPC::Cmd->can_use_ipc_open3 );
|
|
diag( "IPC::Open3 vesion: $IPC::Open3::VERSION" );
|
|
}
|
|
|
|
### Heuristics
|
|
my %heuristics = map { $_ => 1 } qw(http ftp rsync file);
|
|
### _parse_uri tests
|
|
### 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/tmp/foo.txt',
|
|
scheme => 'file',
|
|
host => 'hostname',
|
|
path => '/tmp/',
|
|
file => '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 => '',
|
|
vol => 'D:',
|
|
path => '/tmp/',
|
|
file => 'foo.txt',
|
|
},
|
|
{ uri => 'file:///D|/tmp/foo.txt',
|
|
scheme => 'file',
|
|
host => '',
|
|
vol => 'D:',
|
|
path => '/tmp/',
|
|
file => 'foo.txt',
|
|
},
|
|
) if &File::Fetch::ON_WIN;
|
|
|
|
|
|
### sanity tests
|
|
{
|
|
no warnings;
|
|
like( $File::Fetch::USER_AGENT, qr/$File::Fetch::VERSION/,
|
|
"User agent contains version" );
|
|
like( $File::Fetch::FROM_EMAIL, qr/@/,
|
|
q[Email contains '@'] );
|
|
}
|
|
|
|
### parse uri tests ###
|
|
for my $entry (@map ) {
|
|
my $uri = $entry->{'uri'};
|
|
|
|
my $href = File::Fetch->_parse_uri( $uri );
|
|
ok( $href, "Able to parse uri '$uri'" );
|
|
|
|
for my $key ( sort keys %$entry ) {
|
|
is( $href->{$key}, $entry->{$key},
|
|
" '$key' ok ($entry->{$key}) for $uri");
|
|
}
|
|
}
|
|
|
|
### File::Fetch->new tests ###
|
|
for my $entry (@map) {
|
|
my $ff = File::Fetch->new( uri => $entry->{uri} );
|
|
|
|
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 ($entry->{$acc})" );
|
|
}
|
|
}
|
|
|
|
### fetch() tests ###
|
|
|
|
### file:// tests ###
|
|
{
|
|
my $prefix = &File::Fetch::ON_UNIX ? 'file://' : 'file:///';
|
|
my $uri = $prefix . cwd() .'/'. basename($0);
|
|
|
|
for (qw[lwp lftp file]) {
|
|
_fetch_uri( file => $uri, $_ );
|
|
}
|
|
}
|
|
|
|
### Heuristics
|
|
{
|
|
require IO::Socket::INET;
|
|
my $sock = IO::Socket::INET->new( PeerAddr => 'ftp.funet.fi', PeerPort => 21, Timeout => 20 )
|
|
or $heuristics{ftp} = 0;
|
|
}
|
|
|
|
### ftp:// tests ###
|
|
{ my $uri = 'ftp://ftp.funet.fi/pub/CPAN/index.html';
|
|
for (qw[lwp netftp wget curl lftp fetch ncftp]) {
|
|
|
|
### STUPID STUPID warnings ###
|
|
next if $_ eq 'ncftp' and $File::Fetch::FTP_PASSIVE
|
|
and $File::Fetch::FTP_PASSIVE;
|
|
|
|
_fetch_uri( ftp => $uri, $_ );
|
|
}
|
|
}
|
|
|
|
### Heuristics
|
|
{
|
|
require IO::Socket::INET;
|
|
my $sock = IO::Socket::INET->new( PeerAddr => 'www.cpan.org', PeerPort => 80, Timeout => 20 )
|
|
or $heuristics{http} = 0;
|
|
}
|
|
|
|
### http:// tests ###
|
|
{ for my $uri ( 'http://www.cpan.org/index.html',
|
|
'http://www.cpan.org/index.html?q=1',
|
|
'http://www.cpan.org/index.html?q=1&y=2',
|
|
) {
|
|
for (qw[lwp httptiny wget curl lftp fetch lynx httplite iosock]) {
|
|
_fetch_uri( http => $uri, $_ );
|
|
}
|
|
}
|
|
}
|
|
|
|
### Heuristics
|
|
{
|
|
require IO::Socket::INET;
|
|
my $sock = IO::Socket::INET->new( PeerAddr => 'cpan.pair.com', PeerPort => 873, Timeout => 20 )
|
|
or $heuristics{rsync} = 0;
|
|
}
|
|
|
|
### rsync:// tests ###
|
|
{ my $uri = 'rsync://cpan.pair.com/CPAN/MIRRORING.FROM';
|
|
|
|
for (qw[rsync]) {
|
|
_fetch_uri( rsync => $uri, $_ );
|
|
}
|
|
}
|
|
|
|
sub _fetch_uri {
|
|
my $type = shift;
|
|
my $uri = shift;
|
|
my $method = shift or return;
|
|
|
|
SKIP: {
|
|
skip "'$method' fetching tests disabled under perl core", 4
|
|
if $ENV{PERL_CORE};
|
|
|
|
skip "'$type' fetching tests disabled due to heuristic failure", 4
|
|
unless $heuristics{ $type };
|
|
|
|
### stupid warnings ###
|
|
$File::Fetch::METHODS =
|
|
$File::Fetch::METHODS = { $type => [$method] };
|
|
|
|
### fetch regularly
|
|
my $ff = File::Fetch->new( uri => $uri );
|
|
|
|
ok( $ff, "FF object for $uri (fetch with $method)" );
|
|
|
|
for my $to ( 'tmp', do { \my $o } ) { SKIP: {
|
|
|
|
|
|
my $how = ref $to ? 'slurp' : 'file';
|
|
my $skip = ref $to ? 4 : 3;
|
|
|
|
ok( 1, " Fetching '$uri' in $how mode" );
|
|
|
|
my $file = $ff->fetch( to => $to );
|
|
|
|
skip "You do not have '$method' installed/available", $skip
|
|
if $File::Fetch::METHOD_FAIL->{$method} &&
|
|
$File::Fetch::METHOD_FAIL->{$method};
|
|
|
|
### if the file wasn't fetched, it may be a network/firewall issue
|
|
skip "Fetch failed; no network connectivity for '$type'?", $skip
|
|
unless $file;
|
|
|
|
ok( $file, " File ($file) fetched with $method ($uri)" );
|
|
|
|
### check we got some contents if we were meant to slurp
|
|
if( ref $to ) {
|
|
ok( $$to, " Contents slurped" );
|
|
}
|
|
|
|
ok( $file && -s $file,
|
|
" File has size" );
|
|
is( $file && basename($file), $ff->output_file,
|
|
" File has expected name" );
|
|
|
|
unlink $file;
|
|
}}
|
|
}
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|