← Back to branch summary

~ubuntu-branches/ubuntu/natty/libsignatures-perl/natty

« back to all changes in this revision

Viewing changes to inc/Module/Install/Fetch.pm

  • Committer: Bazaar Package Importer
  • Author(s): Ryan Niebur
  • Date: 2009-05-18 20:34:44 UTC
  • Revision ID: james.westby@ubuntu.com-20090518203444-ee3iqibpk6uxo7u8
Tags: upstream-0.05
Import upstream version 0.05

Show diffs side-by-side

added added

removed removed

Lines of Context:
inc/Module/Install/Fetch.pm
 
1
#line 1
 
2
package Module::Install::Fetch;
 
3
 
 
4
use strict;
 
5
use Module::Install::Base;
 
6
 
 
7
use vars qw{$VERSION $ISCORE @ISA};
 
8
BEGIN {
 
9
        $VERSION = '0.84';
 
10
        $ISCORE  = 1;
 
11
        @ISA     = qw{Module::Install::Base};
 
12
}
 
13
 
 
14
sub 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");
 
64
open $host
 
65
user anonymous anonymous\@example.com
 
66
cd $path
 
67
binary
 
68
get $file $file
 
69
quit
 
70
END_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
 
 
93
1;