← Back to branch summary

~ubuntu-branches/ubuntu/utopic/libcgi-compile-perl/utopic

« back to all changes in this revision

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

  • Committer: Package Import Robot
  • Author(s): gregor herrmann
  • Date: 2014-05-25 14:50:14 UTC
  • mfrom: (1.1.2)
  • Revision ID: package-import@ubuntu.com-20140525145014-f7w6i2usopo3vjib
Tags: 0.17-1
* New upstream release.
* Strip trailing slash from metacpan URLs.
* Drop debian/README.source, the upstream .gitignore is gone.
* debian/copyright: remove stanza about removed inc/Module/*.
* Update years of packaging copyright.
* Declare compliance with Debian Policy 3.9.5.
* Build-Depend on Module::Build::Tiny. Adjust required debhelper version
  accordingly.

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 @ISA $ISCORE};
8
 
BEGIN {
9
 
        $VERSION = '1.06';
10
 
        @ISA     = 'Module::Install::Base';
11
 
        $ISCORE  = 1;
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;