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 {   like( $File::Fetch::USER_AGENT, qr/$File::Fetch::VERSION/,
 120                                 "User agent contains version" );
 121     like( $File::Fetch::FROM_EMAIL, qr/@/,
 122                                 q[Email contains '@'] );
 123 }
 124
 125 ### parse uri tests ###
 126 for my $entry (@map ) {
 127     my $uri = $entry->{'uri'};
 128
 129     my $href = File::Fetch->_parse_uri( $uri );
 130     ok( $href,  "Able to parse uri '$uri'" );
 131
 132     for my $key ( sort keys %$entry ) {
 133         is( $href->{$key}, $entry->{$key},
 134                 "   '$key' ok ($entry->{$key}) for $uri");
 135     }
 136 }
 137
 138 ### File::Fetch->new tests ###
 139 for my $entry (@map) {
 140     my $ff = File::Fetch->new( uri => $entry->{uri} );
 141
 142     ok( $ff,                    "Object for uri '$entry->{uri}'" );
 143     isa_ok( $ff, "File::Fetch", "   Object" );
 144
 145     for my $acc ( keys %$entry ) {
 146         is( $ff->$acc(), $entry->{$acc},
 147                                 "   Accessor '$acc' ok ($entry->{$acc})" );
 148     }
 149 }
 150
 151 ### fetch() tests ###
 152
 153 ### file:// tests ###
 154 {
 155     my $prefix = &File::Fetch::ON_UNIX ? 'file://' : 'file:///';
 156     my $uri = $prefix . cwd() .'/'. basename($0);
 157
 158     for (qw[lwp lftp file]) {
 159         _fetch_uri( file => $uri, $_ );
 160     }
 161 }
 162
 163 ### ftp:// tests ###
 164 {   my $uri = 'ftp://ftp.funet.fi/pub/CPAN/index.html';
 165     for (qw[lwp netftp wget curl lftp ncftp]) {
 166
 167         ### STUPID STUPID warnings ###
 168         next if $_ eq 'ncftp' and $File::Fetch::FTP_PASSIVE
 169                               and $File::Fetch::FTP_PASSIVE;
 170
 171         _fetch_uri( ftp => $uri, $_ );
 172     }
 173 }
 174
 175 ### http:// tests ###
 176 {   for my $uri ( 'http://www.cpan.org/index.html',
 177                   'http://www.cpan.org/index.html?q=1',
 178                   'http://www.cpan.org/index.html?q=1&y=2',
 179     ) {
 180         for (qw[lwp wget curl lftp lynx]) {
 181             _fetch_uri( http => $uri, $_ );
 182         }
 183     }
 184 }
 185
 186 ### rsync:// tests ###
 187 {   my $uri = 'rsync://cpan.pair.com/CPAN/MIRRORING.FROM';
 188
 189     for (qw[rsync]) {
 190         _fetch_uri( rsync => $uri, $_ );
 191     }
 192 }
 193
 194 sub _fetch_uri {
 195     my $type    = shift;
 196     my $uri     = shift;
 197     my $method  = shift or return;
 198
 199     SKIP: {
 200         skip "'$method' fetching tests disabled under perl core", 4
 201                 if $ENV{PERL_CORE};
 202
 203         ### stupid warnings ###
 204         $File::Fetch::METHODS =
 205         $File::Fetch::METHODS = { $type => [$method] };
 206
 207         ### fetch regularly
 208         my $ff  = File::Fetch->new( uri => $uri );
 209
 210         ok( $ff,                "FF object for $uri (fetch with $method)" );
 211
 212         for my $to ( 'tmp', do { \my $o } ) { SKIP: {
 213
 214
 215             my $how     = ref $to ? 'slurp' : 'file';
 216             my $skip    = ref $to ? 4       : 3;
 217
 218             ok( 1,              "   Fetching '$uri' in $how mode" );
 219
 220             my $file = $ff->fetch( to => $to );
 221
 222             skip "You do not have '$method' installed/available", $skip
 223                 if $File::Fetch::METHOD_FAIL->{$method} &&
 224                    $File::Fetch::METHOD_FAIL->{$method};
 225
 226             ### if the file wasn't fetched, it may be a network/firewall issue
 227             skip "Fetch failed; no network connectivity for '$type'?", $skip
 228                 unless $file;
 229
 230             ok( $file,          "   File ($file) fetched with $method ($uri)" );
 231
 232             ### check we got some contents if we were meant to slurp
 233             if( ref $to ) {
 234                 ok( $$to,       "   Contents slurped" );
 235             }
 236
 237             ok( $file && -s $file,
 238                                 "   File has size" );
 239             is( $file && basename($file), $ff->output_file,
 240                                 "   File has expected name" );
 241
 242             unlink $file;
 243         }}
 244     }
 245 }
 246
 247
 248
 249
 250
 251
 252
 253