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