diff options
Diffstat (limited to 'urpm')
| -rw-r--r-- | urpm/args.pm | 6 | ||||
| -rw-r--r-- | urpm/cfg.pm | 41 | ||||
| -rw-r--r-- | urpm/download.pm | 403 | ||||
| -rw-r--r-- | urpm/msg.pm | 9 |
4 files changed, 455 insertions, 4 deletions
diff --git a/urpm/args.pm b/urpm/args.pm index 36e84b79..3d3904f0 100644 --- a/urpm/args.pm +++ b/urpm/args.pm @@ -22,8 +22,8 @@ my $urpm; our %options; sub import { - if ($_[1] eq 'options') { - # export the %options hash + if (@_ > 1 && $_[1] eq 'options') { + # export the global %options hash no strict 'refs'; *{caller().'::options'} = \%options; } @@ -124,7 +124,7 @@ my %options_spec = ( all => sub { foreach my $k (qw(filename group size summary description sourcerpm packager buildhost url provides requires files conflicts obsoletes)) - { $::params{$k} = 1; } + { $::params{$k} = 1 } }, name => \$::params{filename}, group => \$::params{group}, diff --git a/urpm/cfg.pm b/urpm/cfg.pm new file mode 100644 index 00000000..aa485b53 --- /dev/null +++ b/urpm/cfg.pm @@ -0,0 +1,41 @@ +package urpm::cfg; + +use strict; +use warnings; + +=head1 NAME + +urpm::cfg - routines to handle the urpmi configuration files + +=head1 SYNOPSIS + +=head1 DESCRIPTION + +=over + +=cut + +# Standard paths of the config files +our $PROXY_CFG = "/etc/urpmi/proxy.cfg"; + +=item set_environment($env_path) + +Modifies the paths of the config files, so they will be searched +in the $env_path directory. This is obviously to be called early. + +=cut + +sub set_environment { + my ($env) = @_; + for ($PROXY_CFG) { + $env =~ s,^/etc/urpmi,$env,; + } +} + +1; + +__END__ + +=back + +=cut diff --git a/urpm/download.pm b/urpm/download.pm new file mode 100644 index 00000000..05bb4d52 --- /dev/null +++ b/urpm/download.pm @@ -0,0 +1,403 @@ +package urpm::download; + +use strict; +use urpm::msg; +use urpm::cfg; +use Cwd; + +sub import () { + my $c = caller; + no strict 'refs'; + foreach my $symbol (qw(get_proxy set_proxy + propagate_sync_callback + sync_file sync_wget sync_curl sync_rsync sync_ssh + )) { + *{$c.'::'.$symbol} = *$symbol; + } +} + +sub get_proxy () { + my $proxy = { + http_proxy => undef , + ftp_proxy => undef , + user => undef, + pwd => undef + }; + local $_; + open my $f, $urpm::cfg::PROXY_CFG or return undef; + while (<$f>) { + chomp; s/#.*$//; s/^\s*//; s/\s*$//; + /^http_proxy\s*=\s*(.*)$/ and $proxy->{http_proxy} = $1, next; + /^ftp_proxy\s*=\s*(.*)$/ and $proxy->{ftp_proxy} = $1, next; + /^proxy_user\s*=\s*(.*):(.*)$/ and do { + $proxy->{user} = $1; + $proxy->{pwd} = $2; + next; + }; + next; + } + close $f; + bless $proxy; +} + +sub set_proxy { + my ($proxy) = @_; + my @res; + if (defined $proxy->{proxy}{http_proxy} || defined $proxy->{proxy}{ftp_proxy}) { + for ($proxy->{type}) { + /\bwget\b/ and do { + for ($proxy->{proxy}) { + if (defined $_->{http_proxy}) { + $ENV{http_proxy} = $_->{http_proxy} =~ /^http:/ + ? $_->{http_proxy} + : "http://$_->{http_proxy}"; + } + $ENV{ftp_proxy} = $_->{ftp_proxy} if defined $_->{ftp_proxy}; + @res = ("--proxy-user=$_->{user}", "--proxy-passwd=$_->{pwd}") + if defined $_->{user} && defined $_->{pwd}; + } + last; + }; + /\bcurl\b/ and do { + for ($proxy->{proxy}) { + push @res, ('-x', $_->{http_proxy}) if defined $_->{http_proxy}; + push @res, ('-x', $_->{ftp_proxy}) if defined $_->{ftp_proxy}; + push @res, ('-U', "$_->{user}:$_->{pwd}") + if defined $_->{user} && defined $_->{pwd}; + } + last; + }; + die N("Unknown webfetch `%s' !!!\n", $proxy->{type}); + } + } + return @res; +} + +sub propagate_sync_callback { + my $options = shift @_; + if (ref($options) && $options->{callback}) { + my $mode = shift @_; + if ($mode =~ /^(?:start|progress|end)$/) { + my $file = shift @_; + $file =~ s|([^:]*://[^/:\@]*:)[^/:\@]*(\@.*)|$1xxxx$2|; #- if needed... + return $options->{callback}($mode, $file, @_); + } else { + return $options->{callback}($mode, @_); + } + } +} + +sub sync_file { + my $options = shift; + foreach (@_) { + my ($in) = m!^(?:removable[^:]*|file):/(.*)!; + propagate_sync_callback($options, 'start', $_); + system("cp", "-p", "-R", $in || $_, ref($options) ? $options->{dir} : $options) and + die N("copy failed: %s", $@); + propagate_sync_callback($options, 'end', $_); + } +} + +sub sync_wget { + -x "/usr/bin/wget" or die N("wget is missing\n"); + my $options = shift @_; + $options = { dir => $options } if !ref $options; + #- force download to be done in cachedir to avoid polluting cwd. + my $cwd = getcwd(); + chdir $options->{dir}; + my ($buf, $total, $file) = ('', undef, undef); + my $wget_pid = open my $wget, join(" ", map { "'$_'" } + #- construction of the wget command-line + "/usr/bin/wget", + ($options->{limit_rate} ? "--limit-rate=$options->{limit_rate}" : ()), + ($options->{resume} ? "--continue" : ()), + ($options->{proxy} ? set_proxy({ type => "wget", proxy => $options->{proxy} }) : ()), + ($options->{callback} ? ("--progress=bar:force", "-o", "-") : + $options->{quiet} ? "-q" : @{[]}), + "--retr-symlinks", + "-NP", + $options->{dir}, + @_ + ) . " |"; + local $/ = \1; #- read input by only one char, this is slow but very nice (and it works!). + while (<$wget>) { + $buf .= $_; + if ($_ eq "\r" || $_ eq "\n") { + if ($options->{callback}) { + if ($buf =~ /^--\d\d:\d\d:\d\d--\s+(\S.*)\n/ms) { + $file && $file ne $1 and propagate_sync_callback($options, 'end', $file); + ! defined $file and propagate_sync_callback($options, 'start', $file = $1); + } elsif (defined $file && ! defined $total && $buf =~ /==>\s+RETR/) { + $total = ''; + } elsif (defined $total && $total eq '' && $buf =~ /^[^:]*:\s+(\d\S*)/) { + $total = $1; + } elsif (my ($percent, $speed, $eta) = $buf =~ /^\s*(\d+)%.*\s+(\S+)\s+ETA\s+(\S+)\s*[\r\n]$/ms) { + if (propagate_sync_callback($options, 'progress', $file, $percent, $total, $eta, $speed) eq 'canceled') { + kill 15, $wget_pid; + close $wget; + return; + } + if ($_ eq "\n") { + propagate_sync_callback($options, 'end', $file); + ($total, $file) = (undef, undef); + } + } + } else { + $options->{quiet} or print STDERR $buf; + } + $buf = ''; + } + } + $file and propagate_sync_callback($options, 'end', $file); + chdir $cwd; + close $wget or die N("wget failed: exited with %d or signal %d\n", $? >> 8, $? & 127); +} + +sub sync_curl { + -x "/usr/bin/curl" or die N("curl is missing\n"); + my $options = shift @_; + $options = { dir => $options } if !ref $options; + #- force download to be done in cachedir to avoid polluting cwd, + #- however for curl, this is mandatory. + my $cwd = getcwd(); + chdir($options->{dir}); + my (@ftp_files, @other_files); + foreach (@_) { + m|^ftp://.*/([^/]*)$| && -s $1 > 8192 and do { + push @ftp_files, $_; next; + }; #- manage time stamp for large file only. + push @other_files, $_; + } + if (@ftp_files) { + my ($cur_ftp_file, %ftp_files_info); + + eval { require Date::Manip }; + + #- prepare to get back size and time stamp of each file. + open my $curl, join(" ", map { "'$_'" } "/usr/bin/curl", + ($options->{limit_rate} ? ("--limit-rate", $options->{limit_rate}) : ()), + ($options->{proxy} ? set_proxy({ type => "curl", proxy => $options->{proxy} }) : ()), + "--stderr", "-", "-s", "-I", @ftp_files) . " |"; + while (<$curl>) { + if (/Content-Length:\s*(\d+)/) { + !$cur_ftp_file || exists($ftp_files_info{$cur_ftp_file}{size}) + and $cur_ftp_file = shift @ftp_files; + $ftp_files_info{$cur_ftp_file}{size} = $1; + } + if (/Last-Modified:\s*(.*)/) { + !$cur_ftp_file || exists($ftp_files_info{$cur_ftp_file}{time}) + and $cur_ftp_file = shift @ftp_files; + eval { + $ftp_files_info{$cur_ftp_file}{time} = Date::Manip::ParseDate($1); + #- remove day and hour. + $ftp_files_info{$cur_ftp_file}{time} =~ s/(\d{6}).{4}(.*)/$1$2/; + }; + } + } + close $curl; + + #- now analyse size and time stamp according to what already exists here. + if (@ftp_files) { + #- re-insert back shifted element of ftp_files, because curl output above + #- has not been parsed correctly, so in doubt download them all. + push @ftp_files, keys %ftp_files_info; + } else { + #- for that, it should be clear ftp_files is empty... + #- elsewhere, the above work was useless. + foreach (keys %ftp_files_info) { + my ($lfile) = m|/([^/]*)$| or next; #- strange if we can't parse it correctly. + my $ltime = eval { Date::Manip::ParseDate(scalar gmtime((stat $1)[9])) }; + $ltime =~ s/(\d{6}).{4}(.*)/$1$2/; #- remove day and hour. + -s $lfile == $ftp_files_info{$_}{size} && $ftp_files_info{$_}{time} eq $ltime or + push @ftp_files, $_; + } + } + } + #- http files (and other files) are correctly managed by curl to conditionnal download. + #- options for ftp files, -R (-O <file>)* + #- options for http files, -R (-z file -O <file>)* + if (my @all_files = ( + (map { ("-O", $_) } @ftp_files), + (map { m|/([^/]*)$| ? ("-z", $1, "-O", $_) : @{[]} } @other_files))) + { + my @l = (@ftp_files, @other_files); + my ($buf, $file) = (''); + my $curl_pid = open my $curl, join(" ", map { "'$_'" } "/usr/bin/curl", + ($options->{limit_rate} ? ("--limit-rate", $options->{limit_rate}) : ()), + ($options->{resume} ? ("--continue-at", "-") : ()), + ($options->{proxy} ? set_proxy({ type => "curl", proxy => $options->{proxy} }) : ()), + ($options->{quiet} && !$options->{verbose} ? "-s" : @{[]}), + "-k", + `curl -h` =~ /location-trusted/ ? "--location-trusted" : @{[]}, + "-R", "-f", "--stderr", "-", + @all_files) . " |"; + local $/ = \1; #- read input by only one char, this is slow but very nice (and it works!). + while (<$curl>) { + $buf .= $_; + if ($_ eq "\r" || $_ eq "\n") { + if ($options->{callback}) { + unless (defined $file) { + $file = shift @l; + propagate_sync_callback($options, 'start', $file); + } + if (my ($percent, $total, $eta, $speed) = $buf =~ /^\s*(\d+)\s+(\S+)[^\r\n]*\s+(\S+)\s+(\S+)[\r\n]$/ms) { + if (propagate_sync_callback($options, 'progress', $file, $percent, $total, $eta, $speed) eq 'canceled') { + kill 15, $curl_pid; + close $curl; + return; + } + if ($_ eq "\n") { + propagate_sync_callback($options, 'end', $file); + $file = undef; + } + } elsif ($buf =~ /^curl:/) { #- likely to be an error reported by curl + local $/ = "\n"; + chomp $buf; + propagate_sync_callback($options, 'error', $file, $buf); + } + } else { + $options->{quiet} or print STDERR $buf; + } + $buf = ''; + } + } + chdir $cwd; + close $curl or die N("curl failed: exited with %d or signal %d\n", $? >> 8, $? & 127); + } else { + chdir $cwd; + } +} + +sub _calc_limit_rate { + my $limit_rate = $_[0]; + for ($limit_rate) { + /^(\d+)$/ and $limit_rate = int $1/1024, last; + /^(\d+)[kK]$/ and $limit_rate = $1, last; + /^(\d+)[mM]$/ and $limit_rate = 1024*$1, last; + /^(\d+)[gG]$/ and $limit_rate = 1024*1024*$1, last; + } + $limit_rate; +} + +sub sync_rsync { + -x "/usr/bin/rsync" or die N("rsync is missing\n"); + my $options = shift @_; + $options = { dir => $options } if !ref $options; + #- force download to be done in cachedir to avoid polluting cwd. + my $cwd = getcwd(); + chdir($options->{dir}); + my $limit_rate = _calc_limit_rate $options->{limit_rate}; + foreach (@_) { + my $count = 10; #- retry count on error (if file exists). + my $basename = basename($_); + my ($file) = m|^rsync://(.*)| or next; + $file =~ /::/ or $file = $_; + propagate_sync_callback($options, 'start', $file); + do { + local $_; + my $buf = ''; + open my $rsync, join(" ", map { "'$_'" } "/usr/bin/rsync", + ($limit_rate ? "--bwlimit=$limit_rate" : ()), + ($options->{quiet} ? qw(-q) : qw(--progress -v)), + if_($options->{compress}, qw(-z)), + qw(--partial --no-whole-file), + $file, $options->{dir}) . " |"; + local $/ = \1; #- read input by only one char, this is slow but very nice (and it works!). + while (<$rsync>) { + $buf .= $_; + if ($_ eq "\r" || $_ eq "\n") { + if ($options->{callback}) { + if (my ($percent, $speed) = $buf =~ /^\s*\d+\s+(\d+)%\s+(\S+)\s+/) { + propagate_sync_callback($options, 'progress', $file, $percent, undef, undef, $speed); + } + } else { + $options->{quiet} or print STDERR $buf; + } + $buf = ''; + } + } + close $rsync; + } while ($? != 0 && --$count > 0 && -e $options->{dir} . "/$basename"); + propagate_sync_callback($options, 'end', $file); + } + chdir $cwd; + $? == 0 or die N("rsync failed: exited with %d or signal %d\n", $? >> 8, $? & 127); +} + +sub sync_ssh { + -x "/usr/bin/rsync" or die N("rsync is missing\n"); + -x "/usr/bin/ssh" or die N("ssh is missing\n"); + my $options = shift @_; + $options = { dir => $options } if !ref $options; + #- force download to be done in cachedir to avoid polluting cwd. + my $cwd = getcwd(); + chdir($options->{dir}); + my $limit_rate = _calc_limit_rate $options->{limit_rate}; + foreach my $file (@_) { + my $count = 10; #- retry count on error (if file exists). + my $basename = basename($file); + propagate_sync_callback($options, 'start', $file); + do { + local $_; + my $buf = ''; + open my $rsync, join(" ", map { "'$_'" } "/usr/bin/rsync", + ($limit_rate ? "--bwlimit=$limit_rate" : ()), + ($options->{quiet} ? qw(-q) : qw(--progress -v)), + if_($options->{compress}, qw(-z)), + qw(--partial -e ssh), $file, $options->{dir}) . " |"; + local $/ = \1; #- read input by only one char, this is slow but very nice (and it works!). + while (<$rsync>) { + $buf .= $_; + if ($_ eq "\r" || $_ eq "\n") { + if ($options->{callback}) { + if (my ($percent, $speed) = $buf =~ /^\s*\d+\s+(\d+)%\s+(\S+)\s+/) { + propagate_sync_callback($options, 'progress', $file, $percent, undef, undef, $speed); + } + } else { + $options->{quiet} or print STDERR $buf; + } + $buf = ''; + } + } + close $rsync; + } while ($? != 0 && --$count > 0 && -e $options->{dir} . "/$basename"); + propagate_sync_callback($options, 'end', $file); + } + chdir $cwd; + $? == 0 or die N("rsync failed: exited with %d or signal %d\n", $? >> 8, $? & 127); +} + +#- default logger suitable for sync operation on STDERR only. +sub sync_logger { + my ($mode, $file, $percent, $total, $eta, $speed) = @_; + if ($mode eq 'start') { + print STDERR " $file\n"; + } elsif ($mode eq 'progress') { + my $text; + if (defined $total && defined $eta) { + $text = N(" %s%% of %s completed, ETA = %s, speed = %s", $percent, $total, $eta, $speed); + } else { + $text = N(" %s%% completed, speed = %s", $percent, $speed); + } + print STDERR $text, " " x (79 - length($text)), "\r"; + } elsif ($mode eq 'end') { + print STDERR " " x 79, "\r"; + } elsif ($mode eq 'error') { + #- error is 3rd argument, saved in $percent + print STDERR N("...retrieving failed: %s", $percent), "\n"; + } +} + +1; + +__END__ + +=head1 NAME + +urpm::download - download routines for the urpm* tools + +=head1 SYNOPSIS + +=head1 DESCRIPTION + +=cut diff --git a/urpm/msg.pm b/urpm/msg.pm index bf3272e2..5e367daa 100644 --- a/urpm/msg.pm +++ b/urpm/msg.pm @@ -3,7 +3,7 @@ package urpm::msg; use strict; use Exporter; our @ISA = 'Exporter'; -our @EXPORT = qw(N log_it to_utf8 message_input gmessage message); +our @EXPORT = qw(N log_it to_utf8 message_input gmessage message toMb); my $noexpr = N("Nn"); my $yesexpr = N("Yy"); @@ -94,6 +94,13 @@ sub message { } } +sub toMb { + my $nb = $_[0] / 1024 / 1024; + int $nb + 0.5; +} + +sub localtime2changelog { scalar(localtime($_[0])) =~ /(.*) \S+ (\d{4})$/ && "$1 $2" }; + 1; __END__ |