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 File::Path      qw[rmtree];
  11 use Data::Dumper;
  12
  13 use_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
  21 unless( $ENV{PERL_CORE} ) {
  22     warn qq[
  23
  24 ####################### NOTE ##############################
  25
  26 Some of these tests assume you are connected to the
  27 internet. If you are not, or if certain protocols or hosts
  28 are blocked and/or firewalled, these tests could fail due
  29 to 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
  39 if( $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
  52 my %heuristics = map { $_ => 1 } qw(http ftp rsync file git);
  53 ### _parse_uri tests
  54 ### these go on all platforms
  55 my @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
  88 push @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
 104 push @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 ###
 139 for 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 ###
 152 for 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
 248 sub _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