diff options
Diffstat (limited to 'Master/tlpkg/tlperl/lib/File/Fetch.pm')
| -rw-r--r-- | Master/tlpkg/tlperl/lib/File/Fetch.pm | 62 |
1 files changed, 58 insertions, 4 deletions
diff --git a/Master/tlpkg/tlperl/lib/File/Fetch.pm b/Master/tlpkg/tlperl/lib/File/Fetch.pm index 37f7bc6ca9e..7d6a263e2bf 100644 --- a/Master/tlpkg/tlperl/lib/File/Fetch.pm +++ b/Master/tlpkg/tlperl/lib/File/Fetch.pm @@ -19,27 +19,30 @@ use Locale::Maketext::Simple Style => 'gettext'; use vars qw[ $VERBOSE $PREFER_BIN $FROM_EMAIL $USER_AGENT $BLACKLIST $METHOD_FAIL $VERSION $METHODS - $FTP_PASSIVE $TIMEOUT $DEBUG $WARN + $FTP_PASSIVE $TIMEOUT $DEBUG $WARN $FORCEIPV4 ]; -$VERSION = '0.38'; +$VERSION = '0.48'; $VERSION = eval $VERSION; # avoid warnings with development releases $PREFER_BIN = 0; # XXX TODO implement $FROM_EMAIL = 'File-Fetch@example.com'; $USER_AGENT = "File::Fetch/$VERSION"; $BLACKLIST = [qw|ftp|]; +push @$BLACKLIST, qw|lftp| if $^O eq 'dragonfly'; $METHOD_FAIL = { }; $FTP_PASSIVE = 1; $TIMEOUT = 0; $DEBUG = 0; $WARN = 1; +$FORCEIPV4 = 0; ### methods available to fetch the file depending on the scheme $METHODS = { http => [ qw|lwp httptiny wget curl lftp fetch httplite lynx iosock| ], ftp => [ qw|lwp netftp wget curl lftp fetch ncftp ftp| ], file => [ qw|lwp lftp file| ], - rsync => [ qw|rsync| ] + rsync => [ qw|rsync| ], + git => [ qw|git| ], }; ### silly warnings ### @@ -87,7 +90,7 @@ File::Fetch - A generic file fetching mechanism File::Fetch is a generic file fetching mechanism. It allows you to fetch any file pointed to by a C<ftp>, C<http>, -C<file>, or C<rsync> uri by a number of different means. +C<file>, C<git> or C<rsync> uri by a number of different means. See the C<HOW IT WORKS> section further down for details. @@ -1194,6 +1197,8 @@ sub _curl_fetch { ### these long opts are self explanatory - I like that -jmb my $cmd = [ $curl, '-q' ]; + push(@$cmd, '-4') if $^O eq 'netbsd' && $FORCEIPV4; # only seen this on NetBSD so far + push(@$cmd, '--connect-timeout', $TIMEOUT) if $TIMEOUT; push(@$cmd, '--silent') unless $DEBUG; @@ -1402,6 +1407,52 @@ sub _rsync_fetch { } +### use git to fetch files +sub _git_fetch { + my $self = shift; + my %hash = @_; + + my ($to); + my $tmpl = { + to => { required => 1, store => \$to } + }; + check( $tmpl, \%hash ) or return; + my $git; + unless ( $git = can_run('git') ) { + $METHOD_FAIL->{'git'} = 1; + return; + } + + my $cmd = [ $git, 'clone' ]; + + #push(@$cmd, '--timeout=' . $TIMEOUT) if $TIMEOUT; + + push(@$cmd, '--quiet') unless $DEBUG; + + ### DO NOT quote things for IPC::Run, it breaks stuff. + push @$cmd, $self->uri, $to; + + ### with IPC::Cmd > 0.41, this is fixed in teh library, + ### and there's no need for special casing any more. + ### DO NOT quote things for IPC::Run, it breaks stuff. + # $IPC::Cmd::USE_IPC_RUN + # ? ($to, $self->uri) + # : (QUOTE. $to .QUOTE, QUOTE. $self->uri .QUOTE); + + my $captured; + unless(run( command => $cmd, + buffer => \$captured, + verbose => $DEBUG ) + ) { + + return $self->_error(loc("Command %1 failed: %2", + "@$cmd" || '', $captured || '')); + } + + return $to; + +} + ################################# # # Error code @@ -1454,6 +1505,7 @@ for what schemes, if available: http => LWP, HTTP::Lite, wget, curl, lftp, fetch, lynx, iosock ftp => LWP, Net::FTP, wget, curl, lftp, fetch, ncftp, ftp rsync => rsync + git => git If you'd like to disable the use of one or more of these utilities and/or modules, see the C<$BLACKLIST> variable further down. @@ -1470,6 +1522,8 @@ three platforms. C<iosock> is a very limited L<IO::Socket::INET> based mechanism for retrieving C<http> schemed urls. It doesn't follow redirects for instance. +C<git> only supports C<git://> style urls. + A special note about fetching files from an ftp uri: By default, all ftp connections are done in passive mode. To change |