lib/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 will 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 ### parse uri tests ###
 119 for my $entry (@map ) {
 120     my $uri = $entry->{'uri'};
 121
 122     my $href = File::Fetch->_parse_uri( $uri );
 123     ok( $href,  "Able to parse uri '$uri'" );
 124
 125     for my $key ( sort keys %$entry ) {
 126         is( $href->{$key}, $entry->{$key},
 127                 "   '$key' ok ($entry->{$key}) for $uri");
 128     }
 129 }
 130
 131 ### File::Fetch->new tests ###
 132 for my $entry (@map) {
 133     my $ff = File::Fetch->new( uri => $entry->{uri} );
 134
 135     ok( $ff,                    "Object for uri '$entry->{uri}'" );
 136     isa_ok( $ff, "File::Fetch", "   Object" );
 137
 138     for my $acc ( keys %$entry ) {
 139         is( $ff->$acc(), $entry->{$acc},
 140                                 "   Accessor '$acc' ok ($entry->{$acc})" );
 141     }
 142 }
 143
 144 ### fetch() tests ###
 145
 146 ### file:// tests ###
 147 {
 148     my $prefix = &File::Fetch::ON_UNIX ? 'file://' : 'file:///';
 149     my $uri = $prefix . cwd() .'/'. basename($0);
 150
 151     for (qw[lwp file]) {
 152         _fetch_uri( file => $uri, $_ );
 153     }
 154 }
 155
 156 ### ftp:// tests ###
 157 {   my $uri = 'ftp://ftp.funet.fi/pub/CPAN/index.html';
 158     for (qw[lwp netftp wget curl ncftp]) {
 159
 160         ### STUPID STUPID warnings ###
 161         next if $_ eq 'ncftp' and $File::Fetch::FTP_PASSIVE
 162                               and $File::Fetch::FTP_PASSIVE;
 163
 164         _fetch_uri( ftp => $uri, $_ );
 165     }
 166 }
 167
 168 ### http:// tests ###
 169 {   for my $uri ( 'http://www.cpan.org/index.html',
 170                   'http://www.cpan.org/index.html?q=1&y=2'
 171     ) {
 172         for (qw[lwp wget curl lynx]) {
 173             _fetch_uri( http => $uri, $_ );
 174         }
 175     }
 176 }
 177
 178 ### rsync:// tests ###
 179 {   my $uri = 'rsync://cpan.pair.com/CPAN/MIRRORING.FROM';
 180
 181     for (qw[rsync]) {
 182         _fetch_uri( rsync => $uri, $_ );
 183     }
 184 }
 185
 186 sub _fetch_uri {
 187     my $type    = shift;
 188     my $uri     = shift;
 189     my $method  = shift or return;
 190
 191     SKIP: {
 192         skip "'$method' fetching tests disabled under perl core", 4
 193                 if $ENV{PERL_CORE};
 194
 195         ### stupid warnings ###
 196         $File::Fetch::METHODS =
 197         $File::Fetch::METHODS = { $type => [$method] };
 198
 199         my $ff  = File::Fetch->new( uri => $uri );
 200
 201         ok( $ff,                "FF object for $uri (fetch with $method)" );
 202
 203         my $file = $ff->fetch( to => 'tmp' );
 204
 205         SKIP: {
 206             skip "You do not have '$method' installed/available", 3
 207                 if $File::Fetch::METHOD_FAIL->{$method} &&
 208                    $File::Fetch::METHOD_FAIL->{$method};
 209             ok( $file,          "   File ($file) fetched with $method ($uri)" );
 210             ok( $file && -s $file,
 211                                 "   File has size" );
 212             is( $file && basename($file), $ff->output_file,
 213                                 "   File has expected name" );
 214
 215             unlink $file;
 216         }
 217     }
 218 }
 219
 220
 221
 222
 223
 224
 225
 226