view release on metacpan or  search on metacpan

lib/CPAN/FTP.pm  view on Meta::CPAN

sub _new_stats {
    my($self,$file) = @_;
    my $ret = {
               file => $file,
               attempts => [],
               start => _mytime,
              };
    $ret;
}

#-> sub CPAN::FTP::_add_to_statistics
sub _add_to_statistics {
    my($self,$stats) = @_;
    my $yaml_module = CPAN::_yaml_module();
    $self->debug("yaml_module[$yaml_module]") if $CPAN::DEBUG;
    if ($CPAN::META->has_inst($yaml_module)) {
        $stats->{thesiteurl} = $ThesiteURL;
        $stats->{end} = CPAN::FTP::_mytime();
        my $fh = FileHandle->new;
        my $time = time;
        my $sdebug = 0;
        my @debug;
        @debug = $time if $sdebug;
        my $fullstats = $self->_ftp_statistics($fh);
        close $fh if $fh && defined(fileno($fh));
        $fullstats->{history} ||= [];
        push @debug, scalar @{$fullstats->{history}} if $sdebug;
        push @debug, time if $sdebug;
        push @{$fullstats->{history}}, $stats;
        # YAML.pm 0.62 is unacceptably slow with 999;
        # YAML::Syck 0.82 has no noticable performance problem with 999;
        my $ftpstats_size = $CPAN::Config->{ftpstats_size};
        $ftpstats_size = 99 unless defined $ftpstats_size;
        my $ftpstats_period = $CPAN::Config->{ftpstats_period} || 14;
        while (
               @{$fullstats->{history} || []}
               &&
               (
                @{$fullstats->{history}} > $ftpstats_size
                || $time - $fullstats->{history}[0]{start} > 86400*$ftpstats_period
               )
              ) {
            shift @{$fullstats->{history}}
        }
        push @debug, scalar @{$fullstats->{history}} if $sdebug;
        push @debug, time if $sdebug;
        push @debug, scalar localtime($fullstats->{history}[0]{start}) if $sdebug;
        # need no eval because if this fails, it is serious
        my $sfile = File::Spec->catfile($CPAN::Config->{cpan_home},"FTPstats.yml");
        CPAN->_yaml_dumpfile("$sfile.$$",$fullstats);
        if ( $sdebug ) {
            local $CPAN::DEBUG = 512; # FTP
            push @debug, time;
            CPAN->debug(sprintf("DEBUG history: before_read[%d]before[%d]at[%d]".
                                "after[%d]at[%d]oldest[%s]dumped backat[%d]",
                                @debug,
                               ));
        }
        # Win32 cannot rename a file to an existing filename
        unlink($sfile) if ($^O eq 'MSWin32' or $^O eq 'os2');
	_copy_stat($sfile, "$sfile.$$") if -e $sfile;
        rename "$sfile.$$", $sfile
            or $CPAN::Frontend->mywarn("Could not rename '$sfile.$$' to '$sfile': $!\nGiving up\n");
    }
}

# Copy some stat information (owner, group, mode and) from one file to
# another.
# This is a utility function which might be moved to a utility repository.
#-> sub CPAN::FTP::_copy_stat
sub _copy_stat {
    my($src, $dest) = @_;
    my @stat = stat($src);
    if (!@stat) {
	$CPAN::Frontend->mywarn("Can't stat '$src': $!\n");
	return;
    }

    eval {
	chmod $stat[2], $dest
	    or $CPAN::Frontend->mywarn("Can't chmod '$dest' to " . sprintf("0%o", $stat[2]) . ": $!\n");
    };
    warn $@ if $@;
    eval {
	chown $stat[4], $stat[5], $dest
	    or do {
		my $save_err = $!; # otherwise it's lost in the get... calls
		$CPAN::Frontend->mywarn("Can't chown '$dest' to " .
					(getpwuid($stat[4]))[0] . "/" .
					(getgrgid($stat[5]))[0] . ": $save_err\n"
				       );
	    };
    };
    warn $@ if $@;
}

# if file is CHECKSUMS, suggest the place where we got the file to be
# checked from, maybe only for young files?
#-> sub CPAN::FTP::_recommend_url_for
sub _recommend_url_for {
    my($self, $file, $urllist) = @_;
    if ($file =~ s|/CHECKSUMS(.gz)?$||) {
        my $fullstats = $self->_ftp_statistics();
        my $history = $fullstats->{history} || [];
        while (my $last = pop @$history) {
            last if $last->{end} - time > 3600; # only young results are interesting
            next unless $last->{file}; # dirname of nothing dies!
            next unless $file eq dirname($last->{file});
            return $last->{thesiteurl};
        }
    }
    if ($CPAN::Config->{randomize_urllist}
        &&
        rand(1) < $CPAN::Config->{randomize_urllist}
       ) {
        $urllist->[int rand scalar @$urllist];
    } else {
        return ();
    }
}

#-> sub CPAN::FTP::_get_urllist
sub _get_urllist {
    my($self, $with_defaults) = @_;
    $with_defaults ||= 0;
    CPAN->debug("with_defaults[$with_defaults]") if $CPAN::DEBUG;

    $CPAN::Config->{urllist} ||= [];
    unless (ref $CPAN::Config->{urllist} eq 'ARRAY') {
        $CPAN::Frontend->mywarn("Malformed urllist; ignoring.  Configuration file corrupt?\n");
        $CPAN::Config->{urllist} = [];
    }
    my @urllist = grep { defined $_ and length $_ } @{$CPAN::Config->{urllist}};

lib/CPAN/FTP.pm  view on Meta::CPAN

        if ($host) {
          DOMAIN: for my $domain (@noproxy) {
                if ($host =~ /\Q$domain\E$/) { # cf. LWP::UserAgent
                    $want_proxy = 0;
                    last DOMAIN;
                }
            }
        } else {
            $CPAN::Frontend->mywarn("  Could not determine host from http_proxy '$http_proxy'\n");
        }
        if ($want_proxy) {
            my($user, $pass) =
                CPAN::HTTP::Credentials->get_proxy_credentials();
            $ret = {
                    proxy_user => $user,
                    proxy_pass => $pass,
                    http_proxy => $http_proxy
                  };
        }
    }
    return $ret;
}

# package CPAN::FTP;
sub hostdlhardest {
    my($self,$host_seq,$file,$aslocal,$stats) = @_;

    return unless @$host_seq;
    my($ro_url);
    my($aslocal_dir) = dirname($aslocal);
    mkpath($aslocal_dir);
    my $ftpbin = $CPAN::Config->{ftp};
    unless ($ftpbin && length $ftpbin && MM->maybe_command($ftpbin)) {
        $CPAN::Frontend->myprint("No external ftp command available\n\n");
        return;
    }
    $CPAN::Frontend->mywarn(qq{
As a last resort we now switch to the external ftp command '$ftpbin'
to get '$aslocal'.

Doing so often leads to problems that are hard to diagnose.

If you're the victim of such problems, please consider unsetting the
ftp config variable with

    o conf ftp ""
    o conf commit

});
    $CPAN::Frontend->mysleep(2);
  HOSTHARDEST: for $ro_url (@$host_seq) {
        $self->_set_attempt($stats,"dlhardest",$ro_url);
        my $url = "$ro_url$file";
        $self->debug("localizing ftpwise[$url]") if $CPAN::DEBUG;
        unless ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
            next;
        }
        my($host,$dir,$getfile) = ($1,$2,$3);
        my $timestamp = 0;
        my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,
            $ctime,$blksize,$blocks) = stat($aslocal);
        $timestamp = $mtime ||= 0;
        my($netrc) = CPAN::FTP::netrc->new;
        my($netrcfile) = $netrc->netrc;
        my($verbose) = $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG ? " -v" : "";
        my $targetfile = File::Basename::basename($aslocal);
        my(@dialog);
        push(
             @dialog,
             "lcd $aslocal_dir",
             "cd /",
             map("cd $_", split /\//, $dir), # RFC 1738
             "bin",
             "passive",
             "get $getfile $targetfile",
             "quit"
        );
        if (! $netrcfile) {
            CPAN->debug("No ~/.netrc file found") if $CPAN::DEBUG;
        } elsif ($netrc->hasdefault || $netrc->contains($host)) {
            CPAN->debug(sprintf("hasdef[%d]cont($host)[%d]",
                                $netrc->hasdefault,
                                $netrc->contains($host))) if $CPAN::DEBUG;
            if ($netrc->protected) {
                my $dialog = join "", map { "    $_\n" } @dialog;
                my $netrc_explain;
                if ($netrc->contains($host)) {
                    $netrc_explain = "Relying that your .netrc entry for '$host' ".
                        "manages the login";
                } else {
                    $netrc_explain = "Relying that your default .netrc entry ".
                        "manages the login";
                }
                $CPAN::Frontend->myprint(qq{
  Trying with external ftp to get
    '$url'
  $netrc_explain
  Sending the dialog
$dialog
}
                );
                $self->talk_ftp("$ftpbin$verbose $host",
                                @dialog);
                ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
                    $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
                $mtime ||= 0;
                if ($mtime > $timestamp) {
                    $CPAN::Frontend->myprint("GOT $aslocal\n");
                    $ThesiteURL = $ro_url;
                    return $aslocal;
                } else {
                    $CPAN::Frontend->myprint("Hmm... Still failed!\n");
                }
                    return if $CPAN::Signal;
            } else {
                $CPAN::Frontend->mywarn(qq{Your $netrcfile is not }.
                                        qq{correctly protected.\n});
            }
        } else {
            $CPAN::Frontend->mywarn("Your ~/.netrc neither contains $host
  nor does it have a default entry\n");
        }

        # OK, they don't have a valid ~/.netrc. Use 'ftp -n'
        # then and login manually to host, using e-mail as
        # password.
        $CPAN::Frontend->myprint(qq{Issuing "$ftpbin$verbose -n"\n});
        unshift(
                @dialog,
                "open $host",
                "user anonymous $Config::Config{'cf_email'}"
        );
        my $dialog = join "", map { "    $_\n" } @dialog;
        $CPAN::Frontend->myprint(qq{
  Trying with external ftp to get
    $url
  Sending the dialog
$dialog
}
        );
        $self->talk_ftp("$ftpbin$verbose -n", @dialog);
        ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
            $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
        $mtime ||= 0;
        if ($mtime > $timestamp) {
            $CPAN::Frontend->myprint("GOT $aslocal\n");
            $ThesiteURL = $ro_url;
            return $aslocal;
        } else {
            $CPAN::Frontend->myprint("Bad luck... Still failed!\n");
        }
        return if $CPAN::Signal;
        $CPAN::Frontend->mywarn("Can't access URL $url.\n\n");
        $CPAN::Frontend->mysleep(2);
    } # host
}

# package CPAN::FTP;
sub talk_ftp {
    my($self,$command,@dialog) = @_;
    my $fh = FileHandle->new;
    $fh->open("|$command") or die "Couldn't open ftp: $!";
    foreach (@dialog) { $fh->print("$_\n") }
    $fh->close; # Wait for process to complete
    my $wstatus = $?;
    my $estatus = $wstatus >> 8;
    $CPAN::Frontend->myprint(qq{
Subprocess "|$command"
  returned status $estatus (wstat $wstatus)
}) if $wstatus;
}

# find2perl needs modularization, too, all the following is stolen
# from there
# CPAN::FTP::ls
sub ls {
    my($self,$name) = @_;
    my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$sizemm,
     $atime,$mtime,$ctime,$blksize,$blocks) = lstat($name);

    my($perms,%user,%group);
    my $pname = $name;

    if ($blocks) {
        $blocks = int(($blocks + 1) / 2);
    }
    else {
        $blocks = int(($sizemm + 1023) / 1024);
    }

    if    (-f _) { $perms = '-'; }
    elsif (-d _) { $perms = 'd'; }
    elsif (-c _) { $perms = 'c'; $sizemm = &sizemm; }
    elsif (-b _) { $perms = 'b'; $sizemm = &sizemm; }
    elsif (-p _) { $perms = 'p'; }
    elsif (-S _) { $perms = 's'; }
    else         { $perms = 'l'; $pname .= ' -> ' . readlink($_); }

    my(@rwx) = ('---','--x','-w-','-wx','r--','r-x','rw-','rwx');
    my(@moname) = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
    my $tmpmode = $mode;
    my $tmp = $rwx[$tmpmode & 7];
    $tmpmode >>= 3;
    $tmp = $rwx[$tmpmode & 7] . $tmp;
    $tmpmode >>= 3;
    $tmp = $rwx[$tmpmode & 7] . $tmp;
    substr($tmp,2,1) =~ tr/-x/Ss/ if -u _;
    substr($tmp,5,1) =~ tr/-x/Ss/ if -g _;
    substr($tmp,8,1) =~ tr/-x/Tt/ if -k _;
    $perms .= $tmp;

    my $user = $user{$uid} || $uid;   # too lazy to implement lookup
    my $group = $group{$gid} || $gid;

    my($sec,$min,$hour,$mday,$mon,$year) = localtime($mtime);
    my($timeyear);
    my($moname) = $moname[$mon];
    if (-M _ > 365.25 / 2) {
        $timeyear = $year + 1900;
    }
    else {
        $timeyear = sprintf("%02d:%02d", $hour, $min);
    }

    sprintf "%5lu %4ld %-10s %2d %-8s %-8s %8s %s %2d %5s %s\n",
             $ino,
                  $blocks,
                       $perms,
                             $nlink,
                                 $user,
                                      $group,
                                           $sizemm,
                                               $moname,
                                                  $mday,
                                                      $timeyear,
                                                          $pname;
}

1;