Commit | Line | Data |
79fd8837 |
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 |
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 |
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 |
25 | are blocked and/or firewalled, these tests will fail due |
26 | to no fault of the module itself. |
27 | |
28 | ########################################################### |
29 | |
30 | ]; |
31 | |
d4b3706f |
32 | sleep 3 unless $File::Fetch::DEBUG; |
79fd8837 |
33 | } |
34 | |
d4b3706f |
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 |
47 | |
48 | ### _parse_uri tests |
fe98d82b |
49 | ### these go on all platforms |
50 | my @map = ( |
79fd8837 |
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 |
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 |
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 |
85 | scheme => 'file', |
86 | host => 'hostname', |
9e5ea595 |
87 | path => '/tmp/', |
88 | file => 'foo.txt', |
fe98d82b |
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 |
95 | scheme => 'file', |
96 | host => 'hostname', |
fe98d82b |
97 | share => 'share', |
9e5ea595 |
98 | path => '/tmp/', |
99 | file => 'foo.txt', |
fe98d82b |
100 | }, |
9e5ea595 |
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 |
115 | ) if &File::Fetch::ON_WIN; |
116 | |
79fd8837 |
117 | |
118 | ### parse uri tests ### |
fe98d82b |
119 | for my $entry (@map ) { |
79fd8837 |
120 | my $uri = $entry->{'uri'}; |
121 | |
122 | my $href = File::Fetch->_parse_uri( $uri ); |
123 | ok( $href, "Able to parse uri '$uri'" ); |
124 | |
125 | for my $key ( sort keys %$entry ) { |
126 | is( $href->{$key}, $entry->{$key}, |
fe98d82b |
127 | " '$key' ok ($entry->{$key}) for $uri"); |
79fd8837 |
128 | } |
129 | } |
130 | |
d4b3706f |
131 | ### File::Fetch->new tests ### |
fe98d82b |
132 | for my $entry (@map) { |
d4b3706f |
133 | my $ff = File::Fetch->new( uri => $entry->{uri} ); |
fe98d82b |
134 | |
135 | ok( $ff, "Object for uri '$entry->{uri}'" ); |
136 | isa_ok( $ff, "File::Fetch", " Object" ); |
79fd8837 |
137 | |
138 | for my $acc ( keys %$entry ) { |
d4b3706f |
139 | is( $ff->$acc(), $entry->{$acc}, |
fe98d82b |
140 | " Accessor '$acc' ok ($entry->{$acc})" ); |
79fd8837 |
141 | } |
142 | } |
143 | |
79fd8837 |
144 | ### fetch() tests ### |
145 | |
146 | ### file:// tests ### |
147 | { |
9e5ea595 |
148 | my $prefix = &File::Fetch::ON_UNIX ? 'file://' : 'file:///'; |
79fd8837 |
149 | my $uri = $prefix . cwd() .'/'. basename($0); |
150 | |
151 | for (qw[lwp file]) { |
152 | _fetch_uri( file => $uri, $_ ); |
153 | } |
154 | } |
155 | |
156 | ### ftp:// tests ### |
157 | { my $uri = 'ftp://ftp.funet.fi/pub/CPAN/index.html'; |
158 | for (qw[lwp netftp wget curl ncftp]) { |
159 | |
160 | ### STUPID STUPID warnings ### |
161 | next if $_ eq 'ncftp' and $File::Fetch::FTP_PASSIVE |
162 | and $File::Fetch::FTP_PASSIVE; |
163 | |
164 | _fetch_uri( ftp => $uri, $_ ); |
165 | } |
166 | } |
167 | |
168 | ### http:// tests ### |
d4b3706f |
169 | { for my $uri ( 'http://www.cpan.org/index.html', |
170 | 'http://www.cpan.org/index.html?q=1&y=2' |
171 | ) { |
172 | for (qw[lwp wget curl lynx]) { |
173 | _fetch_uri( http => $uri, $_ ); |
174 | } |
79fd8837 |
175 | } |
176 | } |
177 | |
178 | ### rsync:// tests ### |
179 | { my $uri = 'rsync://cpan.pair.com/CPAN/MIRRORING.FROM'; |
180 | |
181 | for (qw[rsync]) { |
182 | _fetch_uri( rsync => $uri, $_ ); |
183 | } |
184 | } |
185 | |
186 | sub _fetch_uri { |
187 | my $type = shift; |
188 | my $uri = shift; |
189 | my $method = shift or return; |
190 | |
191 | SKIP: { |
d4b3706f |
192 | skip "'$method' fetching tests disabled under perl core", 4 |
79fd8837 |
193 | if $ENV{PERL_CORE}; |
194 | |
195 | ### stupid warnings ### |
196 | $File::Fetch::METHODS = |
197 | $File::Fetch::METHODS = { $type => [$method] }; |
198 | |
199 | my $ff = File::Fetch->new( uri => $uri ); |
200 | |
fe98d82b |
201 | ok( $ff, "FF object for $uri (fetch with $method)" ); |
79fd8837 |
202 | |
203 | my $file = $ff->fetch( to => 'tmp' ); |
204 | |
205 | SKIP: { |
d4b3706f |
206 | skip "You do not have '$method' installed/available", 3 |
79fd8837 |
207 | if $File::Fetch::METHOD_FAIL->{$method} && |
208 | $File::Fetch::METHOD_FAIL->{$method}; |
fe98d82b |
209 | ok( $file, " File ($file) fetched with $method ($uri)" ); |
210 | ok( $file && -s $file, |
211 | " File has size" ); |
212 | is( $file && basename($file), $ff->output_file, |
213 | " File has expected name" ); |
79fd8837 |
214 | |
215 | unlink $file; |
216 | } |
217 | } |
218 | } |
219 | |
220 | |
221 | |
222 | |
223 | |
224 | |
225 | |
226 | |