perl-install/live_install2


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

#!/usr/bin/perl

my $dir = `pwd`;
chomp $dir;
$dir .= "/../../..";

#- allow devfsd to enable a faster upgrade.
system "modprobe loop";
my $devfsd_pid = `/sbin/pidof devfsd`;
$devfsd_pid > 0 and kill 15, $devfsd_pid;

#- perl version of the install, we use directly the version we found,
#- this means there SHOULD BE no module compiled for an older version of perl
#- which will be used by DrakX.
my ($version, $arch) = (glob "$dir/usr/lib/perl5/*/*/CORE/libperl.so")[0] =~ m|$dir/usr/lib/perl5/([^/]*)/([^/]*)/CORE/libperl.so|;

#- keep it mind the ELF loader to use.
$ENV{LD_LOADER} = "$dir/lib/ld-linux.so.2";

$ENV{LOCPATH}="$dir/usr/share/locale";
$ENV{GCONV_PATH}="$dir/usr/lib/gconv";
$ENV{PERL5LIB} = join ":", map { "$dir/usr/lib/perl5/$_" } ("$version/$arch",
							    "$version",
							    "site_perl/$version/$arch",
							    "site_perl/$version",
							    "site_perl",
							    "vendor_perl/$version/$arch",
							    "vendor_perl/$version",
							    "vendor_perl",
							   );
$ENV{LD_LIBRARY_PATH} = "$dir/usr/bin:$dir/bin:$dir/sbin:$dir/usr/sbin:$dir/usr/X11R6/bin:$dir/lib:$dir/usr/lib:$dir/usr/lib/perl5/$version/$arch/CORE";
$ENV{PATH} = join(":", map { "$dir/$_" } split ":", "/usr/bin:/bin:/sbin:/usr/sbin:/usr/X11R6/bin") . ":$ENV{PATH}";
$ENV{SHARE_PATH} = "$dir/usr/share";
$ENV{RPMRC_FILE} = "$dir/usr/lib/rpm/rpmrc";
$ENV{GTK_DATA_PREFIX} = "$dir/usr";
$ENV{GTK_EXE_PREFIX} = "$dir/usr";
$ENV{GDK_IMLIB_PATH} = "$dir/usr/lib";

system $ENV{LD_LOADER}, "../perl", "-i", "-pe", "s,^(.*macrofiles[^/]*)(.*),\$1$dir/usr/lib/rpm/macros:\$2,", $ENV{RPMRC_FILE};
system $ENV{LD_LOADER}, "../perl", "./install2", "--live", @ARGV;

#- at this point, unwind above else they will not run correctly (wrong ld-linux.so.2)
delete $ENV{GTK_EXE_PREFIX};
delete $ENV{RPMRC_FILE};
delete $ENV{LOCPATH};
delete $ENV{SHARE_PATH};
delete $ENV{PATH};
delete $ENV{LD_LIBRARY_PATH};
delete $ENV{PERL5LIB};
delete $ENV{LD_LOADER};

$ENV{DISPLAY} and system "xset", "-fp", "/tmp/drakx/mdkinst/usr/X11R6/lib/X11/fonts/";
foreach (qw(misc PEX Speedo Type1 mdk 75dpi 100dpi cyrillic)) {
    -d "/usr/X11R6/lib/X11/fonts/$_" or next;
    -e "/usr/X11R6/lib/X11/fonts/$_/fonts.dir" and next;
    chdir "/usr/X11R6/lib/X11/fonts/$_";
    system "mkfontdir";
}
$ENV{DISPLAY} and system "xset", "fp", "rehash";

system "/bin/rm", "-rf", "/tmp/drakx";
system "/bin/rm", "-rf", "/tmp/rhimage";

#- restore devfsd if it was running.
$devfsd_pid > 0 and system "/sbin/devfsd /dev";

exec "/bin/sync";
package urpm::download;

# $Id$

use strict;
use urpm::msg;
use urpm::util;
use bytes();
use Cwd;
use Exporter;

our @ISA = 'Exporter';
our @EXPORT = qw(get_proxy
	propagate_sync_callback
	sync_file sync_rsync sync_ssh
	set_proxy_config dump_proxy_config
);

(our $VERSION) = q($Revision$) =~ /(\d+)/;

#- proxy config file.
our $PROXY_CFG = '/etc/urpmi/proxy.cfg';
my $proxy_config;

#- Timeout for curl connection and wget operations
our $CONNECT_TIMEOUT = 60; #-  (in seconds)


sub ftp_http_downloaders() { qw(curl wget prozilla aria2) }

sub available_ftp_http_downloaders() {
    my %binaries = (
	curl => 'curl', 
	wget => 'wget', 
	prozilla => 'proz',
	aria2 => 'aria2c',
    );
    grep { -x "/usr/bin/$binaries{$_}" || -x "/bin/$binaries{$_}" } ftp_http_downloaders();
}

sub metalink_downloaders() { qw(aria2) }

sub available_metalink_downloaders() {
    my %binaries = (
	aria2 => 'aria2c',
    );
    grep { -x "/usr/bin/$binaries{$_}" || -x "/bin/$binaries{$_}" } metalink_downloaders();
}

sub use_metalink {
    my ($urpm, $medium) = @_;

    $medium->{allow_metalink} //= do {
	my $use_metalink = 1;
	preferred_downloader($urpm, $medium, \$use_metalink);
	$use_metalink;
    };
}

my %warned;
sub preferred_downloader {
    my ($urpm, $medium, $use_metalink) = @_;

    my @available = urpm::download::available_ftp_http_downloaders();
    my @metalink_downloaders = urpm::download::available_metalink_downloaders();
    my $metalink_disabled = !$$use_metalink && $medium->{disable_metalink};

    if (($$use_metalink) && !$metalink_disabled) {
	#- If metalink is used, only aria2 is available as other downloaders doesn't support metalink
	unshift @available, @metalink_downloaders;
    }
	    
    #- first downloader of @available is the default one
    my $preferred = $available[0];
    my $requested_downloader = requested_ftp_http_downloader($urpm, $medium);
    if ($requested_downloader) {
	if (member($requested_downloader, @available)) {
	    #- use user default downloader if provided and available
	    $preferred = $requested_downloader;
	} elsif ($warned{webfetch_not_available}++ == 0) {
	    $urpm->{log}(N("%s is not available, falling back on %s", $requested_downloader, $preferred));
	}
    }
    # in some cases, we may want not to use metalink (aria2) since it can 
    # cause issues, see #53434 for example
    if ($metalink_disabled && member($preferred, @metalink_downloaders)) {
	$urpm->{log}("not using $preferred since metalink has been disabled");
	my @no_metalink = urpm::util::difference2(\@available, \@metalink_downloaders);
	$preferred = $no_metalink[0];
    }

    if ($$use_metalink && !member($preferred, @metalink_downloaders)) {
	$warned{not_using_metalink}++ or 
	  $urpm->{log}($requested_downloader eq $preferred ? 
		       "not using metalink since requested downloader does not handle it" :
		       "not using metalink since no downloaders handling metalink are available");
	$$use_metalink = 0;
    }
    $preferred;
}

sub parse_http_proxy {
    $_[0] =~ m!^(?:http://)?([^:/]+(:\d+)?)/*$!;
}

#- parses proxy.cfg (private)
sub load_proxy_config () {
    return if defined $proxy_config;
    $proxy_config = {};
    foreach (cat_($PROXY_CFG)) {
	chomp; s/#.*$//; s/^\s*//; s/\s*$//;
	if (/^(?:(.*):\s*)?(ftp_proxy|http_proxy)\s*=\s*(.*)$/) {
	    $proxy_config->{$1 || ''}{$2} = $3;
	    next;
	}
	if (/^(?:(.*):\s*)?proxy_user\s*=\s*([^:]*)(?::(.*))?$/) {
	    $proxy_config->{$1 || ''}{user} = $2;
	    $proxy_config->{$1 || ''}{pwd} = $3 if defined $3;
	    next;
	}
	if (/^(?:(.*):\s*)?proxy_user_ask/) {
	    $proxy_config->{$1 || ''}{ask} = 1;
	    next;
	}
    }
}

#- writes proxy.cfg
sub dump_proxy_config () {
    $proxy_config or return 0; #- hasn't been read yet

    my $has_password;

    open my $f, '>', $PROXY_CFG or return 0;
    foreach ('', sort grep { !/^(|cmd_line)$/ } keys %$proxy_config) {
	my $m = $_ eq '' ? '' : "$_:";
	my $p = $proxy_config->{$_};
	foreach (qw(http_proxy ftp_proxy)) {
	    if (defined $p->{$_} && $p->{$_} ne '') {
		print $f "$m$_=$p->{$_}\n";
		$has_password ||= hide_password($p->{$_}) ne $p->{$_};
	    }
	}
	if ($p->{ask}) {
	    print $f "${m}proxy_user_ask\n";
	} elsif (defined $p->{user} && $p->{user} ne '') {
	    print $f "${m}proxy_user=$p->{user}:$p->{pwd}\n";
	    $has_password ||= $p->{pwd};
	}
    }
    close $f;
    chmod 0600, $PROXY_CFG if $has_password;
    return 1;
}

#- deletes the proxy configuration for the specified media
sub remove_proxy_media {
    defined $proxy_config and delete $proxy_config->{$_[0] || ''};
}

sub get_proxy_ {
    my ($urpm, $_medium) = @_;

    -e $PROXY_CFG && !-r $PROXY_CFG and $urpm->{error}(N("can not read proxy settings (not enough rights to read %s)", $PROXY_CFG));

    get_proxy($urpm);
}

#- reads and loads the proxy.cfg file ;
#- returns the global proxy settings (without arguments) or the
#- proxy settings for the specified media (with a media name as argument)
sub get_proxy (;$) {
    my ($o_media) = @_; $o_media ||= '';
    load_proxy_config();
    my $p = $proxy_config->{cmd_line}
	|| $proxy_config->{$o_media}
	|| $proxy_config->{''}
	|| {
	    http_proxy => undef,
	    ftp_proxy => undef,
	    user => undef,
	    pwd => undef,
	};
    if ($p->{ask} && ($p->{http_proxy} || $p->{ftp_proxy}) && !$p->{user}) {
	our $PROMPT_PROXY;
	unless (defined $PROMPT_PROXY) {
	    require urpm::prompt;
	    $PROMPT_PROXY = new urpm::prompt(
		N("Please enter your credentials for accessing proxy\n"),
		[ N("User name:"), N("Password:") ],
		undef,
		[ 0, 1 ],
	    );
	}
	($p->{user}, $p->{pwd}) = $PROMPT_PROXY->prompt;
    }
    $p;
}

#- copies the settings for proxies from the command line to media named $media
#- and writes the proxy.cfg file (used when adding new media)
sub copy_cmd_line_proxy {
    my ($media) = @_;
    return unless $media;
    load_proxy_config();
    if (defined $proxy_config->{cmd_line}) {
	$proxy_config->{$media} = $proxy_config->{cmd_line};
	dump_proxy_config();
    } else {
	#- use default if available
	$proxy_config->{$media} = $proxy_config->{''};
    }
}

#- overrides the config file proxy settings with values passed via command-line
sub set_cmdline_proxy {
    my (%h) = @_;
    load_proxy_config();
    $proxy_config->{cmd_line} ||= {
	http_proxy => undef,
	ftp_proxy => undef,
	user => undef,
	pwd => undef,
    };
    $proxy_config->{cmd_line}{$_} = $h{$_} foreach keys %h;
}

#- changes permanently the proxy settings
sub set_proxy_config {
    my ($key, $value, $o_media) = @_;
    $proxy_config->{$o_media || ''}{$key} = $value;
}

#- set up the environment for proxy usage for the appropriate tool.
#- returns an array of command-line arguments for wget or curl.
sub set_proxy {
    my ($proxy) = @_;

    my $p = $proxy->{proxy};
    defined $p->{http_proxy} || defined $p->{ftp_proxy} or return;

    my @res;
    if ($proxy->{type} =~ /\bwget\b/) {
	if (defined $p->{http_proxy}) {
	    $ENV{http_proxy} = $p->{http_proxy} =~ /^http:/
	      ? $p->{http_proxy} : "http://$p->{http_proxy}";
	}
	$ENV{ftp_proxy} = $p->{ftp_proxy} if defined $p->{ftp_proxy};
	@res = ("--proxy-user=$p->{user}", "--proxy-passwd=$p->{pwd}")
	  if defined $p->{user} && defined $p->{pwd};
    } elsif ($proxy->{type} =~ /\bcurl\b/) {
	push @res, ('-x', $p->{http_proxy}) if defined $p->{http_proxy};
	push @res, ('-x', $p->{ftp_proxy}) if defined $p->{ftp_proxy};
	push @res, ('-U', "$p->{user}:$p->{pwd}")
	  if defined $p->{user} && defined $p->{pwd};
	push @res, '-H', 'Pragma:' if @res;
    } elsif ($proxy->{type} =~ /\baria2\b/) {
	if (my ($http_proxy) = $p->{http_proxy} && parse_http_proxy($p->{http_proxy})) {
	    my $allproxy = $p->{user}; 
	    $allproxy .= ":" . $p->{pwd} if $p->{pwd}; 
	    $allproxy .= "@";
	    $allproxy .= $http_proxy;
	    @res = ("--all-proxy=http://$allproxy");
	}
    } else { 
	die N("Unknown webfetch `%s' !!!\n", $proxy->{type});
    }
    @res;
}

sub _error_msg {
    my ($name) = @_;

    my $msg = $? & 127 ? N("%s failed: exited with signal %d", $name, $? & 127) :
                         N("%s failed: exited with %d", $name, $? >> 8);
    "$msg\n";
}

sub _error {
    my ($name) = @_;
    die _error_msg($name);
}

sub hide_password {
    my ($url) = @_;
    $url =~ s|([^:]*://[^/:\@]*:)[^/:\@]*(\@.*)|$1xxxx$2|; #- if needed...
    $url;
}

sub propagate_sync_callback {
    my $options = shift;
    if (ref($options) && $options->{callback}) {
	my $mode = shift;
	if ($mode =~ /^(?:start|progress|end)$/) {
	    my $file = shift;
	    return $options->{callback}($mode, hide_password($file), @_);
	} else {
	    return $options->{callback}($mode, @_);
	}
    }
}

sub sync_file {
    my $options = shift;
    foreach (@_) {
	propagate_sync_callback($options, 'start', $_);
	require urpm::util;
	urpm::util::copy($_, ref($options) ? $options->{dir} : $options)
	    or die N("copy failed");
	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_command = join(" ", map { "'$_'" }
	#- construction of the wget command-line
	"/usr/bin/wget",
	($options->{'limit-rate'} ? "--limit-rate=$options->{'limit-rate'}" : ()),
	($options->{resume} ? "--continue" : "--force-clobber"),
	($options->{proxy} ? set_proxy({ type => "wget", proxy => $options->{proxy} }) : ()),
	($options->{retry} ? ('-t', $options->{retry}) : ()),
	($options->{callback} ? ("--progress=bar:force", "-o", "-") :
	    $options->{quiet} ? "-q" : @{[]}),
	"--retr-symlinks",
	($options->{"no-certificate-check"} ? "--no-check-certificate" : ()),
	"--timeout=$CONNECT_TIMEOUT",
	(defined $options->{'wget-options'} ? split /\s+/, $options->{'wget-options'} : ()),
	'-P', $options->{dir},
	@_
    ) . " |";
    $options->{debug} and $options->{debug}($wget_command);
    local $ENV{LC_ALL} = 'C';
    my $wget_pid = open(my $wget, $wget_command);
    local $/ = \1; #- read input by only one char, this is slow but very nice (and it works!).
    local $_;
    while (<$wget>) {
	$buf .= $_;
	if ($_ eq "\r" || $_ eq "\n") {
	    if ($options->{callback}) {
		if ($buf =~ /^--(\d\d\d\d-\d\d-\d\d )?\d\d:\d\d:\d\d--\s+(\S.*)\n/ms) {
		    my $file_ = $2;
		    if ($file && $file ne $file_) {
			propagate_sync_callback($options, 'end', $file);
			undef $file;
		    }
		    ! defined $file and propagate_sync_callback($options, 'start', $file = $file_);
		} elsif (defined $file && ! defined $total && ($buf =~ /==>\s+RETR/ || $buf =~ /200 OK$/)) {
		    $total = '';
		} elsif ($buf =~ /^Length:\s*(\d\S*)/) {
		    $total = $1;
		} elsif (defined $total && $buf =~ m!^\s*(\d+)%.*\s+(\S+/s)\s+((ETA|eta)\s+(.*?)\s*)?[\r\n]$!ms) {
		    my ($percent, $speed, $eta) = ($1, $2, $5);
		    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 _error('wget');
}

sub sync_curl {
    -x "/usr/bin/curl" or die N("curl is missing\n");
    my $options = shift;
    $options = { dir => $options } if !ref $options;
    if (defined $options->{'limit-rate'} && $options->{'limit-rate'} =~ /\d$/) {
	#- use bytes by default
	$options->{'limit-rate'} .= 'B';
    }
    #- 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 (@_) {
	my ($proto, $nick, $rest) = m,^(http|ftp)://([^:/]+):(.*),,;
	if ($nick) { #- escape @ in user names
	    $nick =~ s/@/%40/;
	    $_ = "$proto://$nick:$rest";
	}
	if (m|^ftp://.*/([^/]*)$| && file_size($1) > 8192) { #- manage time stamp for large file only
	    push @ftp_files, $_;
	} else {
	    push @other_files, $_;
	}
    }
    if (@ftp_files) {
	my ($cur_ftp_file, %ftp_files_info);
	local $_;

	eval { require Date::Manip };

	#- prepare to get back size and time stamp of each file.
	my $cmd = join(" ", map { "'$_'" } "/usr/bin/curl",
	    "-q", # don't read .curlrc; some toggle options might interfer
	    ($options->{'limit-rate'} ? ("--limit-rate", $options->{'limit-rate'}) : ()),
	    ($options->{proxy} ? set_proxy({ type => "curl", proxy => $options->{proxy} }) : ()),
	    ($options->{retry} ? ('--retry', $options->{retry}) : ()),
	    "--stderr", "-", # redirect everything to stdout
	    "--disable-epsv",
	    "--connect-timeout", $CONNECT_TIMEOUT,
	    "-s", "-I",
	    "--anyauth",
	    (defined $options->{'curl-options'} ? split /\s+/, $options->{'curl-options'} : ()),
	    @ftp_files);
	$options->{debug} and $options->{debug}($cmd);
	open my $curl, "$cmd |";
	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);
		};
	    }
	}
	close $curl or _error('curl');