source: perl/modules/IRC/inc/Module/Install/Fetch.pm @ bfc127b

barnowl_perlaimdebianrelease-1.10release-1.4release-1.5release-1.6release-1.7release-1.8release-1.9
Last change on this file since bfc127b was 43c62e4, checked in by Nelson Elhage <nelhage@mit.edu>, 17 years ago
Commit inc/ under IRC so we build on systems with too old a M::I
  • Property mode set to 100644
File size: 2.4 KB
Line 
1#line 1
2package Module::Install::Fetch;
3
4use strict;
5use Module::Install::Base;
6
7use vars qw{$VERSION $ISCORE @ISA};
8BEGIN {
9        $VERSION = '0.68';
10        $ISCORE  = 1;
11        @ISA     = qw{Module::Install::Base};
12}
13
14sub get_file {
15    my ($self, %args) = @_;
16    my ($scheme, $host, $path, $file) = 
17        $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return;
18
19    if ( $scheme eq 'http' and ! eval { require LWP::Simple; 1 } ) {
20        $args{url} = $args{ftp_url}
21            or (warn("LWP support unavailable!\n"), return);
22        ($scheme, $host, $path, $file) = 
23            $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return;
24    }
25
26    $|++;
27    print "Fetching '$file' from $host... ";
28
29    unless (eval { require Socket; Socket::inet_aton($host) }) {
30        warn "'$host' resolve failed!\n";
31        return;
32    }
33
34    return unless $scheme eq 'ftp' or $scheme eq 'http';
35
36    require Cwd;
37    my $dir = Cwd::getcwd();
38    chdir $args{local_dir} or return if exists $args{local_dir};
39
40    if (eval { require LWP::Simple; 1 }) {
41        LWP::Simple::mirror($args{url}, $file);
42    }
43    elsif (eval { require Net::FTP; 1 }) { eval {
44        # use Net::FTP to get past firewall
45        my $ftp = Net::FTP->new($host, Passive => 1, Timeout => 600);
46        $ftp->login("anonymous", 'anonymous@example.com');
47        $ftp->cwd($path);
48        $ftp->binary;
49        $ftp->get($file) or (warn("$!\n"), return);
50        $ftp->quit;
51    } }
52    elsif (my $ftp = $self->can_run('ftp')) { eval {
53        # no Net::FTP, fallback to ftp.exe
54        require FileHandle;
55        my $fh = FileHandle->new;
56
57        local $SIG{CHLD} = 'IGNORE';
58        unless ($fh->open("|$ftp -n")) {
59            warn "Couldn't open ftp: $!\n";
60            chdir $dir; return;
61        }
62
63        my @dialog = split(/\n/, <<"END_FTP");
64open $host
65user anonymous anonymous\@example.com
66cd $path
67binary
68get $file $file
69quit
70END_FTP
71        foreach (@dialog) { $fh->print("$_\n") }
72        $fh->close;
73    } }
74    else {
75        warn "No working 'ftp' program available!\n";
76        chdir $dir; return;
77    }
78
79    unless (-f $file) {
80        warn "Fetching failed: $@\n";
81        chdir $dir; return;
82    }
83
84    return if exists $args{size} and -s $file != $args{size};
85    system($args{run}) if exists $args{run};
86    unlink($file) if $args{remove};
87
88    print(((!exists $args{check_for} or -e $args{check_for})
89        ? "done!" : "failed! ($!)"), "\n");
90    chdir $dir; return !$?;
91}
92
931;
Note: See TracBrowser for help on using the repository browser.