git.maemo.org Git - pkg-perl/blob - deb-src/libspiffy-perl/libspiffy-perl-0.30/inc/Module/Install/Fetch.pm

   1 #line 1 "inc/Module/Install/Fetch.pm - /Users/ingy/local/lib/perl5/site_perl/5.8.6/Module/Install/Fetch.pm"
   2 package Module::Install::Fetch;
   3 use Module::Install::Base; @ISA = qw(Module::Install::Base);
   4
   5 $VERSION = '0.01';
   6
   7 sub get_file {
   8     my ($self, %args) = @_;
   9     my ($scheme, $host, $path, $file) =
  10         $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return;
  11
  12     if ($scheme eq 'http' and !eval { require LWP::Simple; 1 }) {
  13         $args{url} = $args{ftp_url}
  14             or (warn("LWP support unavailable!\n"), return);
  15         ($scheme, $host, $path, $file) =
  16             $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return;
  17     }
  18
  19     $|++;
  20     print "Fetching '$file' from $host... ";
  21
  22     unless (eval { require Socket; Socket::inet_aton($host) }) {
  23         warn "'$host' resolve failed!\n";
  24         return;
  25     }
  26
  27     return unless $scheme eq 'ftp' or $scheme eq 'http';
  28
  29     require Cwd;
  30     my $dir = Cwd::getcwd();
  31     chdir $args{local_dir} or return if exists $args{local_dir};
  32
  33     if (eval { require LWP::Simple; 1 }) {
  34         LWP::Simple::mirror($args{url}, $file);
  35     }
  36     elsif (eval { require Net::FTP; 1 }) { eval {
  37         # use Net::FTP to get past firewall
  38         my $ftp = Net::FTP->new($host, Passive => 1, Timeout => 600);
  39         $ftp->login("anonymous", 'anonymous@example.com');
  40         $ftp->cwd($path);
  41         $ftp->binary;
  42         $ftp->get($file) or (warn("$!\n"), return);
  43         $ftp->quit;
  44     } }
  45     elsif (my $ftp = $self->can_run('ftp')) { eval {
  46         # no Net::FTP, fallback to ftp.exe
  47         require FileHandle;
  48         my $fh = FileHandle->new;
  49
  50         local $SIG{CHLD} = 'IGNORE';
  51         unless ($fh->open("|$ftp -n")) {
  52             warn "Couldn't open ftp: $!\n";
  53             chdir $dir; return;
  54         }
  55
  56         my @dialog = split(/\n/, << ".");
  57 open $host
  58 user anonymous anonymous\@example.com
  59 cd $path
  60 binary
  61 get $file $file
  62 quit
  63 .
  64         foreach (@dialog) { $fh->print("$_\n") }
  65         $fh->close;
  66     } }
  67     else {
  68         warn "No working 'ftp' program available!\n";
  69         chdir $dir; return;
  70     }
  71
  72     unless (-f $file) {
  73         warn "Fetching failed: $@\n";
  74         chdir $dir; return;
  75     }
  76
  77     return if exists $args{size} and -s $file != $args{size};
  78     system($args{run}) if exists $args{run};
  79     unlink($file) if $args{remove};
  80
  81     print(((!exists $args{check_for} or -e $args{check_for})
  82         ? "done!" : "failed! ($!)"), "\n");
  83     chdir $dir; return !$?;
  84 }
  85
  86 1;