This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
2ab7a7c2c280912922786b5f5708c23c0aec7a2e
[perl5.git] / cpan / File-Fetch / t / 01_File-Fetch.t
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
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
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 could fail due
26 to 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
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 }
47
48 ### _parse_uri tests
49 ### these go on all platforms
50 my @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
77 push @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
93 push @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 ###
128 for 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 ###
141 for 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 httplite 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
196 sub _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