01_File-Fetch.t revision 1.1.1.3
1BEGIN { chdir 't' if -d 't' }; 2 3use strict; 4use lib '../lib'; 5 6use Test::More 'no_plan'; 7 8use Cwd qw[cwd]; 9use File::Basename qw[basename]; 10use Data::Dumper; 11 12use_ok('File::Fetch'); 13 14### optionally set debugging ### 15$File::Fetch::DEBUG = $File::Fetch::DEBUG = 1 if $ARGV[0]; 16$IPC::Cmd::DEBUG = $IPC::Cmd::DEBUG = 1 if $ARGV[0]; 17 18unless( $ENV{PERL_CORE} ) { 19 warn qq[ 20 21####################### NOTE ############################## 22 23Some of these tests assume you are connected to the 24internet. If you are not, or if certain protocols or hosts 25are blocked and/or firewalled, these tests could fail due 26to no fault of the module itself. 27 28########################################################### 29 30]; 31 32 sleep 3 unless $File::Fetch::DEBUG; 33} 34 35### show us the tools IPC::Cmd will use to run binary programs 36if( $File::Fetch::DEBUG ) { 37 ### stupid 'used only once' warnings ;( 38 diag( "IPC::Run enabled: " . 39 $IPC::Cmd::USE_IPC_RUN || $IPC::Cmd::USE_IPC_RUN ); 40 diag( "IPC::Run available: " . IPC::Cmd->can_use_ipc_run ); 41 diag( "IPC::Run vesion: $IPC::Run::VERSION" ); 42 diag( "IPC::Open3 enabled: " . 43 $IPC::Cmd::USE_IPC_OPEN3 || $IPC::Cmd::USE_IPC_OPEN3 ); 44 diag( "IPC::Open3 available: " . IPC::Cmd->can_use_ipc_open3 ); 45 diag( "IPC::Open3 vesion: $IPC::Open3::VERSION" ); 46} 47 48### Heuristics 49my %heuristics = map { $_ => 1 } qw(http ftp rsync file); 50### _parse_uri tests 51### these go on all platforms 52my @map = ( 53 { uri => 'ftp://cpan.org/pub/mirror/index.txt', 54 scheme => 'ftp', 55 host => 'cpan.org', 56 path => '/pub/mirror/', 57 file => 'index.txt' 58 }, 59 { uri => 'rsync://cpan.pair.com/CPAN/MIRRORING.FROM', 60 scheme => 'rsync', 61 host => 'cpan.pair.com', 62 path => '/CPAN/', 63 file => 'MIRRORING.FROM', 64 }, 65 { uri => 'http://localhost/tmp/index.txt', 66 scheme => 'http', 67 host => 'localhost', # host is empty only on 'file://' 68 path => '/tmp/', 69 file => 'index.txt', 70 }, 71 72 ### only test host part, the rest is OS dependant 73 { uri => 'file://localhost/tmp/index.txt', 74 host => '', # host should be empty on 'file://' 75 }, 76); 77 78### these only if we're not on win32/vms 79push @map, ( 80 { uri => 'file:///usr/local/tmp/foo.txt', 81 scheme => 'file', 82 host => '', 83 path => '/usr/local/tmp/', 84 file => 'foo.txt', 85 }, 86 { uri => 'file://hostname/tmp/foo.txt', 87 scheme => 'file', 88 host => 'hostname', 89 path => '/tmp/', 90 file => 'foo.txt', 91 }, 92) if not &File::Fetch::ON_WIN and not &File::Fetch::ON_VMS; 93 94### these only on win32 95push @map, ( 96 { uri => 'file:////hostname/share/tmp/foo.txt', 97 scheme => 'file', 98 host => 'hostname', 99 share => 'share', 100 path => '/tmp/', 101 file => 'foo.txt', 102 }, 103 { uri => 'file:///D:/tmp/foo.txt', 104 scheme => 'file', 105 host => '', 106 vol => 'D:', 107 path => '/tmp/', 108 file => 'foo.txt', 109 }, 110 { uri => 'file:///D|/tmp/foo.txt', 111 scheme => 'file', 112 host => '', 113 vol => 'D:', 114 path => '/tmp/', 115 file => 'foo.txt', 116 }, 117) if &File::Fetch::ON_WIN; 118 119 120### sanity tests 121{ 122 no warnings; 123 like( $File::Fetch::USER_AGENT, qr/$File::Fetch::VERSION/, 124 "User agent contains version" ); 125 like( $File::Fetch::FROM_EMAIL, qr/@/, 126 q[Email contains '@'] ); 127} 128 129### parse uri tests ### 130for my $entry (@map ) { 131 my $uri = $entry->{'uri'}; 132 133 my $href = File::Fetch->_parse_uri( $uri ); 134 ok( $href, "Able to parse uri '$uri'" ); 135 136 for my $key ( sort keys %$entry ) { 137 is( $href->{$key}, $entry->{$key}, 138 " '$key' ok ($entry->{$key}) for $uri"); 139 } 140} 141 142### File::Fetch->new tests ### 143for my $entry (@map) { 144 my $ff = File::Fetch->new( uri => $entry->{uri} ); 145 146 ok( $ff, "Object for uri '$entry->{uri}'" ); 147 isa_ok( $ff, "File::Fetch", " Object" ); 148 149 for my $acc ( keys %$entry ) { 150 is( $ff->$acc(), $entry->{$acc}, 151 " Accessor '$acc' ok ($entry->{$acc})" ); 152 } 153} 154 155### fetch() tests ### 156 157### file:// tests ### 158{ 159 my $prefix = &File::Fetch::ON_UNIX ? 'file://' : 'file:///'; 160 my $uri = $prefix . cwd() .'/'. basename($0); 161 162 for (qw[lwp lftp file]) { 163 _fetch_uri( file => $uri, $_ ); 164 } 165} 166 167### Heuristics 168{ 169 require IO::Socket::INET; 170 my $sock = IO::Socket::INET->new( PeerAddr => 'ftp.funet.fi', PeerPort => 21, Timeout => 20 ) 171 or $heuristics{ftp} = 0; 172} 173 174### ftp:// tests ### 175{ my $uri = 'ftp://ftp.funet.fi/pub/CPAN/index.html'; 176 for (qw[lwp netftp wget curl lftp fetch ncftp]) { 177 178 ### STUPID STUPID warnings ### 179 next if $_ eq 'ncftp' and $File::Fetch::FTP_PASSIVE 180 and $File::Fetch::FTP_PASSIVE; 181 182 _fetch_uri( ftp => $uri, $_ ); 183 } 184} 185 186### Heuristics 187{ 188 require IO::Socket::INET; 189 my $sock = IO::Socket::INET->new( PeerAddr => 'www.cpan.org', PeerPort => 80, Timeout => 20 ) 190 or $heuristics{http} = 0; 191} 192 193### http:// tests ### 194{ for my $uri ( 'http://www.cpan.org/index.html', 195 'http://www.cpan.org/index.html?q=1', 196 'http://www.cpan.org/index.html?q=1&y=2', 197 ) { 198 for (qw[lwp httptiny wget curl lftp fetch lynx httplite iosock]) { 199 _fetch_uri( http => $uri, $_ ); 200 } 201 } 202} 203 204### Heuristics 205{ 206 require IO::Socket::INET; 207 my $sock = IO::Socket::INET->new( PeerAddr => 'cpan.pair.com', PeerPort => 873, Timeout => 20 ) 208 or $heuristics{rsync} = 0; 209} 210 211### rsync:// tests ### 212{ my $uri = 'rsync://cpan.pair.com/CPAN/MIRRORING.FROM'; 213 214 for (qw[rsync]) { 215 _fetch_uri( rsync => $uri, $_ ); 216 } 217} 218 219sub _fetch_uri { 220 my $type = shift; 221 my $uri = shift; 222 my $method = shift or return; 223 224 SKIP: { 225 skip "'$method' fetching tests disabled under perl core", 4 226 if $ENV{PERL_CORE}; 227 228 skip "'$type' fetching tests disabled due to heuristic failure", 4 229 unless $heuristics{ $type }; 230 231 ### stupid warnings ### 232 $File::Fetch::METHODS = 233 $File::Fetch::METHODS = { $type => [$method] }; 234 235 ### fetch regularly 236 my $ff = File::Fetch->new( uri => $uri ); 237 238 ok( $ff, "FF object for $uri (fetch with $method)" ); 239 240 for my $to ( 'tmp', do { \my $o } ) { SKIP: { 241 242 243 my $how = ref $to ? 'slurp' : 'file'; 244 my $skip = ref $to ? 4 : 3; 245 246 ok( 1, " Fetching '$uri' in $how mode" ); 247 248 my $file = $ff->fetch( to => $to ); 249 250 skip "You do not have '$method' installed/available", $skip 251 if $File::Fetch::METHOD_FAIL->{$method} && 252 $File::Fetch::METHOD_FAIL->{$method}; 253 254 ### if the file wasn't fetched, it may be a network/firewall issue 255 skip "Fetch failed; no network connectivity for '$type'?", $skip 256 unless $file; 257 258 ok( $file, " File ($file) fetched with $method ($uri)" ); 259 260 ### check we got some contents if we were meant to slurp 261 if( ref $to ) { 262 ok( $$to, " Contents slurped" ); 263 } 264 265 ok( $file && -s $file, 266 " File has size" ); 267 is( $file && basename($file), $ff->output_file, 268 " File has expected name" ); 269 270 unlink $file; 271 }} 272 } 273} 274 275 276 277 278 279 280 281 282