01_File-Fetch.t revision 1.1.1.2
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### _parse_uri tests 49### these go on all platforms 50my @map = ( 51 { uri => 'ftp://cpan.org/pub/mirror/index.txt', 52 scheme => 'ftp', 53 host => 'cpan.org', 54 path => '/pub/mirror/', 55 file => 'index.txt' 56 }, 57 { uri => 'rsync://cpan.pair.com/CPAN/MIRRORING.FROM', 58 scheme => 'rsync', 59 host => 'cpan.pair.com', 60 path => '/CPAN/', 61 file => 'MIRRORING.FROM', 62 }, 63 { uri => 'http://localhost/tmp/index.txt', 64 scheme => 'http', 65 host => 'localhost', # host is empty only on 'file://' 66 path => '/tmp/', 67 file => 'index.txt', 68 }, 69 70 ### only test host part, the rest is OS dependant 71 { uri => 'file://localhost/tmp/index.txt', 72 host => '', # host should be empty on 'file://' 73 }, 74); 75 76### these only if we're not on win32/vms 77push @map, ( 78 { uri => 'file:///usr/local/tmp/foo.txt', 79 scheme => 'file', 80 host => '', 81 path => '/usr/local/tmp/', 82 file => 'foo.txt', 83 }, 84 { uri => 'file://hostname/tmp/foo.txt', 85 scheme => 'file', 86 host => 'hostname', 87 path => '/tmp/', 88 file => 'foo.txt', 89 }, 90) if not &File::Fetch::ON_WIN and not &File::Fetch::ON_VMS; 91 92### these only on win32 93push @map, ( 94 { uri => 'file:////hostname/share/tmp/foo.txt', 95 scheme => 'file', 96 host => 'hostname', 97 share => 'share', 98 path => '/tmp/', 99 file => 'foo.txt', 100 }, 101 { uri => 'file:///D:/tmp/foo.txt', 102 scheme => 'file', 103 host => '', 104 vol => 'D:', 105 path => '/tmp/', 106 file => 'foo.txt', 107 }, 108 { uri => 'file:///D|/tmp/foo.txt', 109 scheme => 'file', 110 host => '', 111 vol => 'D:', 112 path => '/tmp/', 113 file => 'foo.txt', 114 }, 115) if &File::Fetch::ON_WIN; 116 117 118### sanity tests 119{ 120 no warnings; 121 like( $File::Fetch::USER_AGENT, qr/$File::Fetch::VERSION/, 122 "User agent contains version" ); 123 like( $File::Fetch::FROM_EMAIL, qr/@/, 124 q[Email contains '@'] ); 125} 126 127### parse uri tests ### 128for my $entry (@map ) { 129 my $uri = $entry->{'uri'}; 130 131 my $href = File::Fetch->_parse_uri( $uri ); 132 ok( $href, "Able to parse uri '$uri'" ); 133 134 for my $key ( sort keys %$entry ) { 135 is( $href->{$key}, $entry->{$key}, 136 " '$key' ok ($entry->{$key}) for $uri"); 137 } 138} 139 140### File::Fetch->new tests ### 141for my $entry (@map) { 142 my $ff = File::Fetch->new( uri => $entry->{uri} ); 143 144 ok( $ff, "Object for uri '$entry->{uri}'" ); 145 isa_ok( $ff, "File::Fetch", " Object" ); 146 147 for my $acc ( keys %$entry ) { 148 is( $ff->$acc(), $entry->{$acc}, 149 " Accessor '$acc' ok ($entry->{$acc})" ); 150 } 151} 152 153### fetch() tests ### 154 155### file:// tests ### 156{ 157 my $prefix = &File::Fetch::ON_UNIX ? 'file://' : 'file:///'; 158 my $uri = $prefix . cwd() .'/'. basename($0); 159 160 for (qw[lwp lftp file]) { 161 _fetch_uri( file => $uri, $_ ); 162 } 163} 164 165### ftp:// tests ### 166{ my $uri = 'ftp://ftp.funet.fi/pub/CPAN/index.html'; 167 for (qw[lwp netftp wget curl lftp fetch ncftp]) { 168 169 ### STUPID STUPID warnings ### 170 next if $_ eq 'ncftp' and $File::Fetch::FTP_PASSIVE 171 and $File::Fetch::FTP_PASSIVE; 172 173 _fetch_uri( ftp => $uri, $_ ); 174 } 175} 176 177### http:// tests ### 178{ for my $uri ( 'http://www.cpan.org/index.html', 179 'http://www.cpan.org/index.html?q=1', 180 'http://www.cpan.org/index.html?q=1&y=2', 181 ) { 182 for (qw[lwp httptiny wget curl lftp fetch lynx httplite iosock]) { 183 _fetch_uri( http => $uri, $_ ); 184 } 185 } 186} 187 188### rsync:// tests ### 189{ my $uri = 'rsync://cpan.pair.com/CPAN/MIRRORING.FROM'; 190 191 for (qw[rsync]) { 192 _fetch_uri( rsync => $uri, $_ ); 193 } 194} 195 196sub _fetch_uri { 197 my $type = shift; 198 my $uri = shift; 199 my $method = shift or return; 200 201 SKIP: { 202 skip "'$method' fetching tests disabled under perl core", 4 203 if $ENV{PERL_CORE}; 204 205 ### stupid warnings ### 206 $File::Fetch::METHODS = 207 $File::Fetch::METHODS = { $type => [$method] }; 208 209 ### fetch regularly 210 my $ff = File::Fetch->new( uri => $uri ); 211 212 ok( $ff, "FF object for $uri (fetch with $method)" ); 213 214 for my $to ( 'tmp', do { \my $o } ) { SKIP: { 215 216 217 my $how = ref $to ? 'slurp' : 'file'; 218 my $skip = ref $to ? 4 : 3; 219 220 ok( 1, " Fetching '$uri' in $how mode" ); 221 222 my $file = $ff->fetch( to => $to ); 223 224 skip "You do not have '$method' installed/available", $skip 225 if $File::Fetch::METHOD_FAIL->{$method} && 226 $File::Fetch::METHOD_FAIL->{$method}; 227 228 ### if the file wasn't fetched, it may be a network/firewall issue 229 skip "Fetch failed; no network connectivity for '$type'?", $skip 230 unless $file; 231 232 ok( $file, " File ($file) fetched with $method ($uri)" ); 233 234 ### check we got some contents if we were meant to slurp 235 if( ref $to ) { 236 ok( $$to, " Contents slurped" ); 237 } 238 239 ok( $file && -s $file, 240 " File has size" ); 241 is( $file && basename($file), $ff->output_file, 242 " File has expected name" ); 243 244 unlink $file; 245 }} 246 } 247} 248 249 250 251 252 253 254 255 256