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]; | |
10 | use Data::Dumper; | |
11 | ||
d4b3706f RGS |
12 | use_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 | ||
79fd8837 JB |
18 | unless( $ENV{PERL_CORE} ) { |
19 | warn qq[ | |
20 | ||
21 | ####################### NOTE ############################## | |
22 | ||
23 | Some of these tests assume you are connected to the | |
24 | internet. If you are not, or if certain protocols or hosts | |
6e654618 | 25 | are blocked and/or firewalled, these tests could fail due |
79fd8837 JB |
26 | to no fault of the module itself. |
27 | ||
28 | ########################################################### | |
29 | ||
30 | ]; | |
31 | ||
d4b3706f | 32 | sleep 3 unless $File::Fetch::DEBUG; |
79fd8837 JB |
33 | } |
34 | ||
d4b3706f RGS |
35 | ### show us the tools IPC::Cmd will use to run binary programs |
36 | if( $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 | } | |
79fd8837 JB |
47 | |
48 | ### _parse_uri tests | |
fe98d82b RGS |
49 | ### these go on all platforms |
50 | my @map = ( | |
79fd8837 JB |
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 | }, | |
fe98d82b RGS |
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 | |
77 | push @map, ( | |
79fd8837 JB |
78 | { uri => 'file:///usr/local/tmp/foo.txt', |
79 | scheme => 'file', | |
80 | host => '', | |
81 | path => '/usr/local/tmp/', | |
82 | file => 'foo.txt', | |
83 | }, | |
fe98d82b | 84 | { uri => 'file://hostname/tmp/foo.txt', |
9e5ea595 RGS |
85 | scheme => 'file', |
86 | host => 'hostname', | |
9e5ea595 RGS |
87 | path => '/tmp/', |
88 | file => 'foo.txt', | |
fe98d82b RGS |
89 | }, |
90 | ) if not &File::Fetch::ON_WIN and not &File::Fetch::ON_VMS; | |
91 | ||
92 | ### these only on win32 | |
93 | push @map, ( | |
94 | { uri => 'file:////hostname/share/tmp/foo.txt', | |
9e5ea595 RGS |
95 | scheme => 'file', |
96 | host => 'hostname', | |
fe98d82b | 97 | share => 'share', |
9e5ea595 RGS |
98 | path => '/tmp/', |
99 | file => 'foo.txt', | |
fe98d82b | 100 | }, |
9e5ea595 RGS |
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 | }, | |
fe98d82b RGS |
115 | ) if &File::Fetch::ON_WIN; |
116 | ||
79fd8837 | 117 | |
6b6e6e92 SH |
118 | ### sanity tests |
119 | { like( $File::Fetch::USER_AGENT, qr/$File::Fetch::VERSION/, | |
120 | "User agent contains version" ); | |
121 | like( $File::Fetch::FROM_EMAIL, qr/@/, | |
122 | q[Email contains '@'] ); | |
123 | } | |
124 | ||
79fd8837 | 125 | ### parse uri tests ### |
fe98d82b | 126 | for my $entry (@map ) { |
79fd8837 JB |
127 | my $uri = $entry->{'uri'}; |
128 | ||
129 | my $href = File::Fetch->_parse_uri( $uri ); | |
130 | ok( $href, "Able to parse uri '$uri'" ); | |
131 | ||
132 | for my $key ( sort keys %$entry ) { | |
133 | is( $href->{$key}, $entry->{$key}, | |
fe98d82b | 134 | " '$key' ok ($entry->{$key}) for $uri"); |
79fd8837 JB |
135 | } |
136 | } | |
137 | ||
d4b3706f | 138 | ### File::Fetch->new tests ### |
fe98d82b | 139 | for my $entry (@map) { |
d4b3706f | 140 | my $ff = File::Fetch->new( uri => $entry->{uri} ); |
fe98d82b RGS |
141 | |
142 | ok( $ff, "Object for uri '$entry->{uri}'" ); | |
143 | isa_ok( $ff, "File::Fetch", " Object" ); | |
79fd8837 JB |
144 | |
145 | for my $acc ( keys %$entry ) { | |
d4b3706f | 146 | is( $ff->$acc(), $entry->{$acc}, |
fe98d82b | 147 | " Accessor '$acc' ok ($entry->{$acc})" ); |
79fd8837 JB |
148 | } |
149 | } | |
150 | ||
79fd8837 JB |
151 | ### fetch() tests ### |
152 | ||
153 | ### file:// tests ### | |
154 | { | |
9e5ea595 | 155 | my $prefix = &File::Fetch::ON_UNIX ? 'file://' : 'file:///'; |
79fd8837 JB |
156 | my $uri = $prefix . cwd() .'/'. basename($0); |
157 | ||
6e654618 | 158 | for (qw[lwp lftp file]) { |
79fd8837 JB |
159 | _fetch_uri( file => $uri, $_ ); |
160 | } | |
161 | } | |
162 | ||
163 | ### ftp:// tests ### | |
164 | { my $uri = 'ftp://ftp.funet.fi/pub/CPAN/index.html'; | |
6e654618 | 165 | for (qw[lwp netftp wget curl lftp ncftp]) { |
79fd8837 JB |
166 | |
167 | ### STUPID STUPID warnings ### | |
168 | next if $_ eq 'ncftp' and $File::Fetch::FTP_PASSIVE | |
169 | and $File::Fetch::FTP_PASSIVE; | |
170 | ||
171 | _fetch_uri( ftp => $uri, $_ ); | |
172 | } | |
173 | } | |
174 | ||
175 | ### http:// tests ### | |
d4b3706f | 176 | { for my $uri ( 'http://www.cpan.org/index.html', |
6e654618 JB |
177 | 'http://www.cpan.org/index.html?q=1', |
178 | 'http://www.cpan.org/index.html?q=1&y=2', | |
d4b3706f | 179 | ) { |
314f5584 | 180 | for (qw[lwp wget curl lftp lynx iosock]) { |
d4b3706f RGS |
181 | _fetch_uri( http => $uri, $_ ); |
182 | } | |
79fd8837 JB |
183 | } |
184 | } | |
185 | ||
186 | ### rsync:// tests ### | |
187 | { my $uri = 'rsync://cpan.pair.com/CPAN/MIRRORING.FROM'; | |
188 | ||
189 | for (qw[rsync]) { | |
190 | _fetch_uri( rsync => $uri, $_ ); | |
191 | } | |
192 | } | |
193 | ||
194 | sub _fetch_uri { | |
195 | my $type = shift; | |
196 | my $uri = shift; | |
197 | my $method = shift or return; | |
198 | ||
199 | SKIP: { | |
d4b3706f | 200 | skip "'$method' fetching tests disabled under perl core", 4 |
79fd8837 JB |
201 | if $ENV{PERL_CORE}; |
202 | ||
203 | ### stupid warnings ### | |
204 | $File::Fetch::METHODS = | |
205 | $File::Fetch::METHODS = { $type => [$method] }; | |
206 | ||
8d16e270 | 207 | ### fetch regularly |
79fd8837 | 208 | my $ff = File::Fetch->new( uri => $uri ); |
8d16e270 | 209 | |
fe98d82b | 210 | ok( $ff, "FF object for $uri (fetch with $method)" ); |
8d16e270 JB |
211 | |
212 | for my $to ( 'tmp', do { \my $o } ) { SKIP: { | |
213 | ||
214 | ||
215 | my $how = ref $to ? 'slurp' : 'file'; | |
216 | my $skip = ref $to ? 4 : 3; | |
217 | ||
218 | ok( 1, " Fetching '$uri' in $how mode" ); | |
219 | ||
220 | my $file = $ff->fetch( to => $to ); | |
221 | ||
222 | skip "You do not have '$method' installed/available", $skip | |
79fd8837 JB |
223 | if $File::Fetch::METHOD_FAIL->{$method} && |
224 | $File::Fetch::METHOD_FAIL->{$method}; | |
6e654618 JB |
225 | |
226 | ### if the file wasn't fetched, it may be a network/firewall issue | |
8d16e270 | 227 | skip "Fetch failed; no network connectivity for '$type'?", $skip |
6e654618 JB |
228 | unless $file; |
229 | ||
fe98d82b | 230 | ok( $file, " File ($file) fetched with $method ($uri)" ); |
8d16e270 JB |
231 | |
232 | ### check we got some contents if we were meant to slurp | |
233 | if( ref $to ) { | |
234 | ok( $$to, " Contents slurped" ); | |
235 | } | |
236 | ||
fe98d82b RGS |
237 | ok( $file && -s $file, |
238 | " File has size" ); | |
239 | is( $file && basename($file), $ff->output_file, | |
240 | " File has expected name" ); | |
79fd8837 JB |
241 | |
242 | unlink $file; | |
8d16e270 | 243 | }} |
79fd8837 JB |
244 | } |
245 | } | |
246 | ||
247 | ||
248 | ||
249 | ||
250 | ||
251 | ||
252 | ||
253 |