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/Perl-Toolchain-Gang/file-fetch.git',
69        scheme	=> 'git',
70        host	=> 'github.com',
71        path	=> '/Perl-Toolchain-Gang/',
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 => 'mirror.bytemark.co.uk', PeerPort => 21, Timeout => 20 )
180     or $heuristics{ftp} = 0;
181}
182
183### ftp:// tests ###
184{   my $uri = 'ftp://mirror.bytemark.co.uk/CPAN/index.html';
185    for (qw[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 => 'httpbin.org', PeerPort => 80, Timeout => 20 )
199     or $heuristics{http} = 0;
200}
201
202### http:// tests ###
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',
207                  #'http://user:passwd@httpbin.org/basic-auth/user/passwd',
208    ) {
209        for (qw[lwp httptiny wget curl lftp fetch lynx httplite iosock]) {
210            _fetch_uri( http => $uri, $_ );
211        }
212    }
213}
214
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
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
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 ###
238{   my $uri = 'git://github.com/Perl-Toolchain-Gang/file-fetch.git';
239
240    for (qw[git]) {
241        local $ENV{GIT_CONFIG_NOSYSTEM} = 1;
242        local $ENV{XDG_CONFIG_HOME};
243        local $ENV{HOME};
244        _fetch_uri( git => $uri, $_ );
245    }
246}
247
248sub _fetch_uri {
249    my $type    = shift;
250    my $uri     = shift;
251    my $method  = shift or return;
252
253    SKIP: {
254        skip "'$method' fetching tests disabled under perl core", 4
255                if $ENV{PERL_CORE};
256
257        skip "'$type' fetching tests disabled due to heuristic failure", 4
258                unless $heuristics{ $type };
259
260        ### stupid warnings ###
261        $File::Fetch::METHODS =
262        $File::Fetch::METHODS = { $type => [$method] };
263
264        ### fetch regularly
265        my $ff  = File::Fetch->new( uri => $uri );
266
267        ok( $ff,                "FF object for $uri (fetch with $method)" );
268
269        for my $to ( 'tmp', do { \my $o } ) { SKIP: {
270
271
272            my $how     = ref $to && $type ne 'git' ? 'slurp' : 'file';
273            my $skip    = ref $to ? 4       : 3;
274
275            ok( 1,              "   Fetching '$uri' in $how mode" );
276
277            my $file = $ff->fetch( to => $to );
278
279            skip "You do not have '$method' installed/available", $skip
280                if $File::Fetch::METHOD_FAIL->{$method} &&
281                   $File::Fetch::METHOD_FAIL->{$method};
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
285                unless $file;
286
287            ok( $file,          "   File ($file) fetched with $method ($uri)" );
288
289            ### check we got some contents if we were meant to slurp
290            if( ref $to && $type ne 'git' ) {
291                ok( $$to,       "   Contents slurped" );
292            }
293
294            ok( $file && -s $file,
295                                "   File has size" );
296            is( $file && basename($file), $ff->output_file,
297                                "   File has expected name" );
298
299            rmtree $file;
300        }}
301    }
302}
303
304
305
306
307
308
309
310
311