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 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 wget curl lftp lynx 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