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