Commit | Line | Data |
---|---|---|
79fd8837 JB |
1 | BEGIN { chdir 't' if -d 't' }; |
2 | ||
3 | use strict; | |
4 | use lib '../lib'; | |
5 | ||
6 | use Test::More 'no_plan'; | |
7 | ||
8 | use Cwd qw[cwd]; | |
9 | use File::Basename qw[basename]; | |
9062a81c | 10 | use File::Path qw[rmtree]; |
79fd8837 JB |
11 | use Data::Dumper; |
12 | ||
d4b3706f RGS |
13 | use_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 | ||
9d56ca6f CBW |
19 | $File::Fetch::FORCEIPV4=1; |
20 | ||
79fd8837 JB |
21 | unless( $ENV{PERL_CORE} ) { |
22 | warn qq[ | |
23 | ||
24 | ####################### NOTE ############################## | |
25 | ||
26 | Some of these tests assume you are connected to the | |
27 | internet. If you are not, or if certain protocols or hosts | |
6e654618 | 28 | are blocked and/or firewalled, these tests could fail due |
79fd8837 JB |
29 | to no fault of the module itself. |
30 | ||
31 | ########################################################### | |
32 | ||
33 | ]; | |
34 | ||
d4b3706f | 35 | sleep 3 unless $File::Fetch::DEBUG; |
79fd8837 JB |
36 | } |
37 | ||
d4b3706f RGS |
38 | ### show us the tools IPC::Cmd will use to run binary programs |
39 | if( $File::Fetch::DEBUG ) { | |
40 | ### stupid 'used only once' warnings ;( | |
22e7b04c | 41 | diag( "IPC::Run enabled: " . |
d4b3706f RGS |
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" ); | |
22e7b04c | 45 | diag( "IPC::Open3 enabled: " . |
d4b3706f RGS |
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 | } | |
79fd8837 | 50 | |
22e7b04c | 51 | ### Heuristics |
9062a81c | 52 | my %heuristics = map { $_ => 1 } qw(http ftp rsync file git); |
79fd8837 | 53 | ### _parse_uri tests |
fe98d82b RGS |
54 | ### these go on all platforms |
55 | my @map = ( | |
79fd8837 JB |
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 | }, | |
fe98d82b RGS |
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 | }, | |
ac1690b9 | 68 | { uri => 'git://github.com/Perl-Toolchain-Gang/file-fetch.git', |
9062a81c CBW |
69 | scheme => 'git', |
70 | host => 'github.com', | |
ac1690b9 | 71 | path => '/Perl-Toolchain-Gang/', |
9062a81c CBW |
72 | file => 'file-fetch.git', |
73 | }, | |
fe98d82b RGS |
74 | { uri => 'http://localhost/tmp/index.txt', |
75 | scheme => 'http', | |
22e7b04c | 76 | host => 'localhost', # host is empty only on 'file://' |
fe98d82b RGS |
77 | path => '/tmp/', |
78 | file => 'index.txt', | |
22e7b04c CBW |
79 | }, |
80 | ||
fe98d82b RGS |
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://' | |
22e7b04c | 84 | }, |
fe98d82b RGS |
85 | ); |
86 | ||
87 | ### these only if we're not on win32/vms | |
88 | push @map, ( | |
79fd8837 JB |
89 | { uri => 'file:///usr/local/tmp/foo.txt', |
90 | scheme => 'file', | |
91 | host => '', | |
92 | path => '/usr/local/tmp/', | |
93 | file => 'foo.txt', | |
94 | }, | |
fe98d82b | 95 | { uri => 'file://hostname/tmp/foo.txt', |
9e5ea595 RGS |
96 | scheme => 'file', |
97 | host => 'hostname', | |
9e5ea595 RGS |
98 | path => '/tmp/', |
99 | file => 'foo.txt', | |
22e7b04c | 100 | }, |
fe98d82b RGS |
101 | ) if not &File::Fetch::ON_WIN and not &File::Fetch::ON_VMS; |
102 | ||
103 | ### these only on win32 | |
104 | push @map, ( | |
105 | { uri => 'file:////hostname/share/tmp/foo.txt', | |
9e5ea595 RGS |
106 | scheme => 'file', |
107 | host => 'hostname', | |
fe98d82b | 108 | share => 'share', |
9e5ea595 RGS |
109 | path => '/tmp/', |
110 | file => 'foo.txt', | |
fe98d82b | 111 | }, |
9e5ea595 RGS |
112 | { uri => 'file:///D:/tmp/foo.txt', |
113 | scheme => 'file', | |
114 | host => '', | |
115 | vol => 'D:', | |
116 | path => '/tmp/', | |
117 | file => 'foo.txt', | |
22e7b04c | 118 | }, |
9e5ea595 RGS |
119 | { uri => 'file:///D|/tmp/foo.txt', |
120 | scheme => 'file', | |
121 | host => '', | |
122 | vol => 'D:', | |
123 | path => '/tmp/', | |
124 | file => 'foo.txt', | |
22e7b04c | 125 | }, |
fe98d82b RGS |
126 | ) if &File::Fetch::ON_WIN; |
127 | ||
79fd8837 | 128 | |
6b6e6e92 | 129 | ### sanity tests |
22e7b04c | 130 | { |
4192a60a CBW |
131 | no warnings; |
132 | like( $File::Fetch::USER_AGENT, qr/$File::Fetch::VERSION/, | |
6b6e6e92 SH |
133 | "User agent contains version" ); |
134 | like( $File::Fetch::FROM_EMAIL, qr/@/, | |
135 | q[Email contains '@'] ); | |
22e7b04c | 136 | } |
6b6e6e92 | 137 | |
79fd8837 | 138 | ### parse uri tests ### |
fe98d82b | 139 | for my $entry (@map ) { |
79fd8837 JB |
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}, | |
fe98d82b | 147 | " '$key' ok ($entry->{$key}) for $uri"); |
79fd8837 JB |
148 | } |
149 | } | |
150 | ||
d4b3706f | 151 | ### File::Fetch->new tests ### |
fe98d82b | 152 | for my $entry (@map) { |
d4b3706f | 153 | my $ff = File::Fetch->new( uri => $entry->{uri} ); |
fe98d82b RGS |
154 | |
155 | ok( $ff, "Object for uri '$entry->{uri}'" ); | |
156 | isa_ok( $ff, "File::Fetch", " Object" ); | |
79fd8837 JB |
157 | |
158 | for my $acc ( keys %$entry ) { | |
d4b3706f | 159 | is( $ff->$acc(), $entry->{$acc}, |
fe98d82b | 160 | " Accessor '$acc' ok ($entry->{$acc})" ); |
79fd8837 JB |
161 | } |
162 | } | |
163 | ||
79fd8837 JB |
164 | ### fetch() tests ### |
165 | ||
166 | ### file:// tests ### | |
167 | { | |
9e5ea595 | 168 | my $prefix = &File::Fetch::ON_UNIX ? 'file://' : 'file:///'; |
79fd8837 JB |
169 | my $uri = $prefix . cwd() .'/'. basename($0); |
170 | ||
6e654618 | 171 | for (qw[lwp lftp file]) { |
79fd8837 JB |
172 | _fetch_uri( file => $uri, $_ ); |
173 | } | |
174 | } | |
175 | ||
22e7b04c CBW |
176 | ### Heuristics |
177 | { | |
178 | require IO::Socket::INET; | |
c5bdcad0 | 179 | my $sock = IO::Socket::INET->new( PeerAddr => 'mirror.bytemark.co.uk', PeerPort => 21, Timeout => 20 ) |
22e7b04c CBW |
180 | or $heuristics{ftp} = 0; |
181 | } | |
182 | ||
79fd8837 | 183 | ### ftp:// tests ### |
c5bdcad0 SH |
184 | { my $uri = 'ftp://mirror.bytemark.co.uk/CPAN/index.html'; |
185 | for (qw[wget curl lftp fetch ncftp]) { | |
79fd8837 JB |
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 | ||
22e7b04c CBW |
195 | ### Heuristics |
196 | { | |
197 | require IO::Socket::INET; | |
60dfa515 | 198 | my $sock = IO::Socket::INET->new( PeerAddr => 'httpbin.org', PeerPort => 80, Timeout => 20 ) |
22e7b04c CBW |
199 | or $heuristics{http} = 0; |
200 | } | |
201 | ||
79fd8837 | 202 | ### http:// tests ### |
60dfa515 CBW |
203 | { for my $uri ( 'http://httpbin.org/html', |
204 | 'http://httpbin.org/response-headers?q=1', | |
205 | 'http://httpbin.org/response-headers?q=1&y=2', | |
206 | #'http://www.cpan.org/index.html?q=1&y=2', | |
ac1690b9 | 207 | #'http://user:passwd@httpbin.org/basic-auth/user/passwd', |
d4b3706f | 208 | ) { |
eee47ba6 | 209 | for (qw[lwp httptiny wget curl lftp fetch lynx httplite iosock]) { |
d4b3706f RGS |
210 | _fetch_uri( http => $uri, $_ ); |
211 | } | |
79fd8837 JB |
212 | } |
213 | } | |
214 | ||
22e7b04c CBW |
215 | ### Heuristics |
216 | { | |
217 | require IO::Socket::INET; | |
218 | my $sock = IO::Socket::INET->new( PeerAddr => 'cpan.pair.com', PeerPort => 873, Timeout => 20 ) | |
219 | or $heuristics{rsync} = 0; | |
220 | } | |
221 | ||
79fd8837 JB |
222 | ### rsync:// tests ### |
223 | { my $uri = 'rsync://cpan.pair.com/CPAN/MIRRORING.FROM'; | |
224 | ||
225 | for (qw[rsync]) { | |
226 | _fetch_uri( rsync => $uri, $_ ); | |
227 | } | |
228 | } | |
229 | ||
9062a81c CBW |
230 | ### Heuristics |
231 | { | |
232 | require IO::Socket::INET; | |
233 | my $sock = IO::Socket::INET->new( PeerAddr => 'github.com', PeerPort => 9418, Timeout => 20 ) | |
234 | or $heuristics{git} = 0; | |
235 | } | |
236 | ||
237 | ### git:// tests ### | |
4f96d02c | 238 | { my $uri = 'https://github.com/Perl-Toolchain-Gang/file-fetch.git'; |
9062a81c CBW |
239 | |
240 | for (qw[git]) { | |
ac1690b9 SH |
241 | local $ENV{GIT_CONFIG_NOSYSTEM} = 1; |
242 | local $ENV{XDG_CONFIG_HOME}; | |
243 | local $ENV{HOME}; | |
9062a81c CBW |
244 | _fetch_uri( git => $uri, $_ ); |
245 | } | |
246 | } | |
247 | ||
79fd8837 JB |
248 | sub _fetch_uri { |
249 | my $type = shift; | |
250 | my $uri = shift; | |
251 | my $method = shift or return; | |
252 | ||
253 | SKIP: { | |
d4b3706f | 254 | skip "'$method' fetching tests disabled under perl core", 4 |
79fd8837 | 255 | if $ENV{PERL_CORE}; |
22e7b04c CBW |
256 | |
257 | skip "'$type' fetching tests disabled due to heuristic failure", 4 | |
258 | unless $heuristics{ $type }; | |
259 | ||
79fd8837 JB |
260 | ### stupid warnings ### |
261 | $File::Fetch::METHODS = | |
262 | $File::Fetch::METHODS = { $type => [$method] }; | |
22e7b04c | 263 | |
8d16e270 | 264 | ### fetch regularly |
79fd8837 | 265 | my $ff = File::Fetch->new( uri => $uri ); |
22e7b04c | 266 | |
fe98d82b | 267 | ok( $ff, "FF object for $uri (fetch with $method)" ); |
22e7b04c | 268 | |
8d16e270 | 269 | for my $to ( 'tmp', do { \my $o } ) { SKIP: { |
22e7b04c CBW |
270 | |
271 | ||
9062a81c | 272 | my $how = ref $to && $type ne 'git' ? 'slurp' : 'file'; |
8d16e270 | 273 | my $skip = ref $to ? 4 : 3; |
22e7b04c | 274 | |
8d16e270 | 275 | ok( 1, " Fetching '$uri' in $how mode" ); |
22e7b04c | 276 | |
8d16e270 | 277 | my $file = $ff->fetch( to => $to ); |
22e7b04c | 278 | |
8d16e270 | 279 | skip "You do not have '$method' installed/available", $skip |
79fd8837 JB |
280 | if $File::Fetch::METHOD_FAIL->{$method} && |
281 | $File::Fetch::METHOD_FAIL->{$method}; | |
22e7b04c CBW |
282 | |
283 | ### if the file wasn't fetched, it may be a network/firewall issue | |
284 | skip "Fetch failed; no network connectivity for '$type'?", $skip | |
6e654618 | 285 | unless $file; |
22e7b04c | 286 | |
fe98d82b | 287 | ok( $file, " File ($file) fetched with $method ($uri)" ); |
8d16e270 JB |
288 | |
289 | ### check we got some contents if we were meant to slurp | |
9062a81c | 290 | if( ref $to && $type ne 'git' ) { |
8d16e270 JB |
291 | ok( $$to, " Contents slurped" ); |
292 | } | |
293 | ||
22e7b04c | 294 | ok( $file && -s $file, |
fe98d82b RGS |
295 | " File has size" ); |
296 | is( $file && basename($file), $ff->output_file, | |
297 | " File has expected name" ); | |
22e7b04c | 298 | |
9062a81c | 299 | rmtree $file; |
8d16e270 | 300 | }} |
79fd8837 JB |
301 | } |
302 | } | |
303 | ||
304 | ||
305 | ||
306 | ||
307 | ||
308 | ||
309 | ||
310 |