/usr/share/perl5/CPANPLUS/Internals/Fetch.pm is in libcpanplus-perl 0.9152-2.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 | package CPANPLUS::Internals::Fetch;
use strict;
use CPANPLUS::Error;
use CPANPLUS::Internals::Constants;
use File::Fetch;
use File::Spec;
use Cwd qw[cwd];
use IPC::Cmd qw[run];
use Params::Check qw[check];
use Module::Load::Conditional qw[can_load];
use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext';
use vars qw[$VERSION];
$VERSION = "0.9152";
$Params::Check::VERBOSE = 1;
=pod
=head1 NAME
CPANPLUS::Internals::Fetch - internals for fetching files
=head1 SYNOPSIS
my $output = $cb->_fetch(
module => $modobj,
fetchdir => '/path/to/save/to',
verbose => BOOL,
force => BOOL,
);
$cb->_add_fail_host( host => 'foo.com' );
$cb->_host_ok( host => 'foo.com' );
=head1 DESCRIPTION
CPANPLUS::Internals::Fetch fetches files from either ftp, http, file
or rsync mirrors.
This is the rough flow:
$cb->_fetch
Delegate to File::Fetch;
=head1 METHODS
=cut
=head1 $path = _fetch( module => $modobj, [fetchdir => '/path/to/save/to', fetch_from => 'scheme://path/to/fetch/from', verbose => BOOL, force => BOOL, prefer_bin => BOOL, ttl => $seconds] )
C<_fetch> will fetch files based on the information in a module
object. You always need a module object. If you want a fake module
object for a one-off fetch, look at C<CPANPLUS::Module::Fake>.
C<fetchdir> is the place to save the file to. Usually this
information comes from your configuration, but you can override it
expressly if needed.
C<fetch_from> lets you specify an URI to get this file from. If you
do not specify one, your list of configured hosts will be probed to
download the file from.
C<force> forces a new download, even if the file already exists.
C<verbose> simply indicates whether or not to print extra messages.
C<prefer_bin> indicates whether you prefer the use of commandline
programs over perl modules. Defaults to your corresponding config
setting.
C<ttl> (in seconds) indicates how long a cached copy is valid for. If
the fetch time of the local copy is within the ttl, the cached copy is
returned. Otherwise, the file is refetched.
C<_fetch> figures out, based on the host list, what scheme to use and
from there, delegates to C<File::Fetch> do the actual fetching.
Returns the path of the output file on success, false on failure.
Note that you can set a C<blacklist> on certain methods in the config.
Simply add the identifying name of the method (ie, C<lwp>) to:
$conf->_set_fetch( blacklist => ['lwp'] );
And the C<LWP> function will be skipped by C<File::Fetch>.
=cut
sub _fetch {
my $self = shift;
my $conf = $self->configure_object;
my %hash = @_;
local $Params::Check::NO_DUPLICATES = 0;
my ($modobj, $verbose, $force, $fetch_from, $ttl);
my $tmpl = {
module => { required => 1, allow => IS_MODOBJ, store => \$modobj },
fetchdir => { default => $conf->get_conf('fetchdir') },
fetch_from => { default => '', store => \$fetch_from },
force => { default => $conf->get_conf('force'),
store => \$force },
verbose => { default => $conf->get_conf('verbose'),
store => \$verbose },
prefer_bin => { default => $conf->get_conf('prefer_bin') },
ttl => { default => 0, store => \$ttl },
};
my $args = check( $tmpl, \%hash ) or return;
### check if we already downloaded the thing ###
if( (my $where = $modobj->status->fetch()) and not $force and not $ttl ) {
msg(loc("Already fetched '%1' to '%2', " .
"won't fetch again without force",
$modobj->module, $where ), $verbose );
return $where;
}
my ($remote_file, $local_file, $local_path);
### build the local path to download to ###
{
$local_path = $args->{fetchdir} ||
File::Spec->catdir(
$conf->get_conf('base'),
$modobj->path,
);
### create the path if it doesn't exist ###
unless( -d $local_path ) {
unless( $self->_mkdir( dir => $local_path ) ) {
msg( loc("Could not create path '%1'", $local_path), $verbose);
return;
}
}
$local_file = File::Spec->rel2abs(
File::Spec->catfile(
$local_path,
$modobj->package,
)
);
### do we already have the file? if so, can we use the cached version,
### or do we need to refetch?
if( -e $local_file ) {
my $unlink = 0;
my $use_cached = 0;
### if force is in effect, we have to refetch
if( $force ) {
$unlink++
### if you provided a ttl, and it was exceeded, we'll refetch,
} elsif( $ttl and ([stat $local_file]->[9] + $ttl > time) ) {
msg(loc("Using cached file '%1' on disk; ".
"ttl (%2s) is not exceeded",
$local_file, $ttl), $verbose );
$use_cached++;
### if you provided a ttl, and the above conditional didn't match,
### we exceeded the ttl, so we refetch
} elsif ( $ttl ) {
$unlink++;
### otherwise we can use the cached version
} else {
$use_cached++;
}
if( $unlink ) {
### some fetches will fail if the files exist already, so let's
### delete them first
1 while unlink $local_file;
msg(loc("Could not delete %1, some methods may " .
"fail to force a download", $local_file), $verbose)
if -e $local_file;
} else {
### store where we fetched it ###
$modobj->status->fetch( $local_file );
return $local_file;
}
}
}
### we got a custom URI
if ( $fetch_from ) {
my $abs = $self->__file_fetch( from => $fetch_from,
to => $local_path,
verbose => $verbose );
unless( $abs ) {
error(loc("Unable to download '%1'", $fetch_from));
return;
}
### store where we fetched it ###
$modobj->status->fetch( $abs );
return $abs;
### we will get it from one of our mirrors
} else {
### build the remote path to download from ###
{ $remote_file = File::Spec::Unix->catfile(
$modobj->path,
$modobj->package,
);
unless( $remote_file ) {
error( loc('No remote file given for download') );
return;
}
}
### see if we even have a host or a method to use to download with ###
my $found_host;
my @maybe_bad_host;
HOST: {
### F*CKING PIECE OF F*CKING p4 SHIT makes
### '$File :: Fetch::SOME_VAR'
### into a meta variable and starts substituting the file name...
### GRAAAAAAAAAAAAAAAAAAAAAAH!
### use ' to combat it!
### set up some flags for File::Fetch ###
local $File'Fetch::BLACKLIST = $conf->_get_fetch('blacklist');
local $File'Fetch::TIMEOUT = $conf->get_conf('timeout');
local $File'Fetch::DEBUG = $conf->get_conf('debug');
local $File'Fetch::FTP_PASSIVE = $conf->get_conf('passive');
local $File'Fetch::FROM_EMAIL = $conf->get_conf('email');
local $File'Fetch::PREFER_BIN = $conf->get_conf('prefer_bin');
local $File'Fetch::WARN = $verbose;
### loop over all hosts we have ###
for my $host ( @{$conf->get_conf('hosts')} ) {
$found_host++;
my $where;
### file:// uris are special and need parsing
if( $host->{'scheme'} eq 'file' ) {
### the full path in the native format of the OS
my $host_spec =
File::Spec->file_name_is_absolute( $host->{'path'} )
? $host->{'path'}
: File::Spec->rel2abs( $host->{'path'} );
### there might be volumes involved on vms/win32
if( ON_WIN32 or ON_VMS ) {
### now extract the volume in order to be Win32 and
### VMS friendly.
### 'no_file' indicates that there's no file part
### of this path, so we only get 2 bits returned.
my ($vol, $host_path) = File::Spec->splitpath(
$host_spec, 'no_file'
);
### and split up the directories
my @host_dirs = File::Spec->splitdir( $host_path );
### if we got a volume we pretend its a directory for
### the sake of the file:// url
if( defined $vol and $vol ) {
### D:\foo\bar needs to be encoded as D|\foo\bar
### For details, see the following link:
### http://en.wikipedia.org/wiki/File://
### The RFC doesn't seem to address Windows volume
### descriptors but it does address VMS volume
### descriptors, however wikipedia covers a bit of
### history regarding win32
$vol =~ s/:$/|/ if ON_WIN32;
$vol =~ s/:// if ON_VMS;
### XXX i'm not sure what cases this is addressing.
### this comes straight from dmq's file:// patches
### for win32. --kane
### According to dmq, the best summary is:
### "if file:// urls don't look right on VMS reuse
### the win32 logic and see if that fixes things"
### first element not empty? Might happen on VMS.
### prepend the volume in that case.
if( $host_dirs[0] ) {
unshift @host_dirs, $vol;
### element empty? reuse it to store the volume
### encoded as a directory name. (Win32/VMS)
} else {
$host_dirs[0] = $vol;
}
}
### now it's in UNIX format, which is the same format
### as used for URIs
$host_spec = File::Spec::Unix->catdir( @host_dirs );
}
### now create the file:// uri from the components
$where = CREATE_FILE_URI->(
File::Spec::Unix->catfile(
$host->{'host'} || '',
$host_spec,
$remote_file,
)
);
### its components will be in unix format, for a http://,
### ftp:// or any other style of URI
} else {
my $mirror_path = File::Spec::Unix->catfile(
$host->{'path'}, $remote_file
);
my %args = ( scheme => $host->{scheme},
host => $host->{host},
path => $mirror_path,
);
$where = $self->_host_to_uri( %args );
}
my $abs = $self->__file_fetch( from => $where,
to => $local_path,
verbose => $verbose );
### we got a path back?
if( $abs ) {
### store where we fetched it ###
$modobj->status->fetch( $abs );
### this host is good, the previous ones are apparently
### not, so mark them as such.
$self->_add_fail_host( host => $_ ) for @maybe_bad_host;
return $abs;
}
### so we tried to get the file but didn't actually fetch it --
### there's a chance this host is bad. mark it as such and
### actually flag it back if we manage to get the file
### somewhere else
push @maybe_bad_host, $host;
}
}
$found_host
? error(loc("Fetch failed: host list exhausted " .
"-- are you connected today?"))
: error(loc("No hosts found to download from " .
"-- check your config"));
}
return;
}
sub __file_fetch {
my $self = shift;
my $conf = $self->configure_object;
my %hash = @_;
my ($where, $local_path, $verbose);
my $tmpl = {
from => { required => 1, store => \$where },
to => { required => 1, store => \$local_path },
verbose => { default => $conf->get_conf('verbose'),
store => \$verbose },
};
check( $tmpl, \%hash ) or return;
msg(loc("Trying to get '%1'", $where ), $verbose );
### build the object ###
my $ff = File::Fetch->new( uri => $where );
### sanity check ###
error(loc("Bad uri '%1'",$where)), return unless $ff;
if( my $file = $ff->fetch( to => $local_path ) ) {
unless( -e $file && -s _ ) {
msg(loc("'%1' said it fetched '%2', but it was not created",
'File::Fetch', $file), $verbose);
} else {
my $abs = File::Spec->rel2abs( $file );
### so TTLs will work
$self->_update_timestamp( file => $abs );
return $abs;
}
} else {
error(loc("Fetching of '%1' failed: %2", $where, $ff->error));
}
return;
}
=pod
=head2 _add_fail_host( host => $host_hashref )
Mark a particular host as bad. This makes C<CPANPLUS::Internals::Fetch>
skip it in fetches until this cache is flushed.
=head2 _host_ok( host => $host_hashref )
Query the cache to see if this host is ok, or if it has been flagged
as bad.
Returns true if the host is ok, false otherwise.
=cut
{ ### caching functions ###
sub _add_fail_host {
my $self = shift;
my %hash = @_;
my $host;
my $tmpl = {
host => { required => 1, default => {},
strict_type => 1, store => \$host },
};
check( $tmpl, \%hash ) or return;
return $self->_hosts->{$host} = 1;
}
sub _host_ok {
my $self = shift;
my %hash = @_;
my $host;
my $tmpl = {
host => { required => 1, store => \$host },
};
check( $tmpl, \%hash ) or return;
return $self->_hosts->{$host} ? 0 : 1;
}
}
1;
# Local variables:
# c-indentation-style: bsd
# c-basic-offset: 4
# indent-tabs-mode: nil
# End:
# vim: expandtab shiftwidth=4:
|