path: root/rpmdrake.pm

#*****************************************************************************
# 
#  Copyright (c) 2002 Guillaume Cottenceau (gc at mandrakesoft dot com)
# 
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public License version 2, as
#  published by the Free Software Foundation.
# 
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public License for more details.
# 
#  You should have received a copy of the GNU General Public License
#  along with this program; if not, write to the Free Software
#  Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
# 
#*****************************************************************************
#
# $Id$

package rpmdrake;

use lib qw(/usr/lib/libDrakX);
use standalone;     #- warning, standalone must be loaded very first, for 'explanations'

use MDK::Common;
use urpm;
use URPM;
use URPM::Resolve;
use packdrake;
use strict;
use vars qw(@ISA @EXPORT $configfile %config $mandrakeupdate_wanted_categories $already_splashed $max_info_in_descr $tree_mode $tree_flat $typical_width);
use log;
use c;

use curl_download;

@ISA = qw(Exporter);
@EXPORT = qw($configfile %config $mandrakeupdate_wanted_categories $already_splashed $max_info_in_descr $tree_mode $tree_flat $typical_width
             N N_ translate to_utf8 myexit readconf writeconf interactive_msg interactive_packtable interactive_list fatal_msg
             wait_msg remove_wait_msg but but_ slow_func mirrors choose_mirror make_url_mirror show_urpm_progress
             update_sources update_sources_interactive add_medium_and_check);


eval { require ugtk2; ugtk2->import(qw(:all)) };
if ($@) {
    print "This program cannot be run in console mode.\n";
    c::_exit(0);  #- skip ugtk2::END
}
ugtk2::add_icon_path('/usr/share/rpmdrake/icons');

c::bind_textdomain_codeset('rpmdrake', 'UTF8');
sub translate {
    my ($s) = @_;
    my $r = '';
    if ($s) {
        $r = c::dgettext('rpmdrake', $s);
        $r eq $s and $r = Locale::gettext::iconv(c::dgettext('urpmi', $s), undef, "UTF-8");
        c::set_tagged_utf8($r);
    }
    $r;
}
sub sprintf_fixutf8 {
    my $need_upgrade;
    $need_upgrade |= to_bool(c::is_tagged_utf8($_)) + 1 foreach @_;
    if ($need_upgrade == 3) { c::upgrade_utf8($_) foreach @_ };
    sprintf shift, @_;
}
sub N {
    my $s = shift @_; my $t = translate($s);
    sprintf_fixutf8 $t, @_;
}
sub N_ { $_[0] }
sub to_utf8 {
    foreach (@_) {
        $_ = Locale::gettext::iconv($_, undef, "UTF-8");
        c::set_tagged_utf8($_);
    }
    wantarray() ? @_ : $_[0];
}

sub myexit { ugtk2::exit(undef, @_) }

$ENV{HOME} ||= '/root';

sub readconf {
    $configfile = "$ENV{HOME}/.rpmdrake";
    %config = (mandrakeupdate_wanted_categories => { var => \$mandrakeupdate_wanted_categories, default => [ qw(security) ] },
	       already_splashed => { var => \$already_splashed, default => [] },
	       max_info_in_descr => { var => \$max_info_in_descr, default => [] },
               tree_mode => { var => \$tree_mode, default => [ qw(mandrake_choices) ] },
               tree_flat => { var => \$tree_flat, default => [ 0 ] },
	      );
    ${$config{$_}{var}} = $config{$_}{default} foreach keys %config;
    
    foreach my $l (cat_($configfile)) {
	$l =~ /^\Q$_\E (.*)/ and ${$config{$_}{var}} = [ split ' ', $1 ] foreach keys %config;
    }
}

sub writeconf {
    output $configfile, map { "$_ " . join(' ', @${$config{$_}{var}}) . "\n" } keys %config;
}

sub interactive_msg {
    my ($title, $contents, %options) = @_;
    my $d = ugtk2->new($title, grab => 1, if_(exists $options{transient}, transient => $options{transient}));
    $d->{rwindow}->set_position($options{transient} ? 'center_on_parent' : 'center_always') if !$::isEmbedded;
    gtkadd($d->{window},
	   gtkpack_(Gtk2::VBox->new(0,5),
		    1, $options{scroll} ? gtkadd(gtkset_shadow_type(Gtk2::Frame->new, 'in'),
						 gtkset_size_request(create_scrolled_window(gtktext_insert(Gtk2::TextView->new, $contents)),
								     $typical_width*2, 300))
					: Gtk2::Label->new($contents),
		    0, gtkpack(create_hbox(),
			       ref($options{yesno}) eq 'ARRAY' ? map {
				   my $label = $_;
				   gtksignal_connect(Gtk2::Button->new($label), clicked => sub { $d->{retval} = $label; Gtk2->main_quit })
			       } @{$options{yesno}}
			       : $options{yesno} ? (
                                           gtksignal_connect(Gtk2::Button->new($options{text}{no} || N("No")),
                                                             clicked => sub { $d->{retval} = 0; Gtk2->main_quit }),
                                           gtksignal_connect(Gtk2::Button->new($options{text}{yes} || N("Yes")),
                                                             clicked => sub { $d->{retval} = 1; Gtk2->main_quit }),
                                          )
			       : gtksignal_connect(Gtk2::Button->new(N("Ok")), clicked => sub { Gtk2->main_quit })
			      )));
    $d->main;
}

sub interactive_packtable {
    my ($title, $parent_window, $top_label, $lines, $action_buttons) = @_;
    
    my $w = ugtk2->new($title, grab => 1, transient => $parent_window);
    $w->{rwindow}->set_position('center_on_parent');
    my $packtable = create_packtable({}, @$lines);

    gtkadd($w->{window},
	   gtkpack_(Gtk2::VBox->new(0, 5),
		    if_($top_label, 0, Gtk2::Label->new($top_label)),
		    1, create_scrolled_window($packtable),
		    0, gtkpack__(create_hbox(), @$action_buttons)));
    my $preq = $packtable->size_request;
    my ($xpreq, $ypreq) = ($preq->width, $preq->height);
    my $wreq = $w->{rwindow}->size_request;
    my ($xwreq, $ywreq) = ($wreq->width, $wreq->height);
    $w->{rwindow}->set_default_size(max($typical_width, min($typical_width*2.5, $xpreq+$xwreq)),
 				    max(200, min(450, $ypreq+$ywreq)));
    $w->main;
}

sub interactive_list {
    my ($title, $contents, $list, $callback, %options) = @_;
    my $d = ugtk2->new($title, grab => 1, if_(exists $options{transient}, transient => $options{transient}));
    $d->{rwindow}->set_position($options{transient} ? 'center_on_parent' : 'center_always');
    my @radios = gtkradio('', @$list);
    my $vbradios = $callback ? create_packtable({},
						mapn { my $n = $_[1];
						       [ $_[0],
							 gtksignal_connect(Gtk2::Button->new(but(N("Info..."))),
									   clicked => sub { $callback->($n) }) ]
						   } \@radios, $list)
                             : gtkpack__(Gtk2::VBox->new(0, 0), @radios);
    my $choice;
    gtkadd($d->{window},
	   gtkpack__(Gtk2::VBox->new(0,5),
		     Gtk2::Label->new($contents),
		     int(@$list) > 8 ? gtkset_size_request(create_scrolled_window($vbradios), 250, 320) : $vbradios,
		     gtkpack__(create_hbox(), gtksignal_connect(Gtk2::Button->new(N("Ok")), clicked => sub {
								    each_index { $_->get_active and $choice = $::i } @radios;
								    Gtk2->main_quit
								}))));
    $d->main;
    $choice;
}

sub fatal_msg {
    interactive_msg @_;
    myexit -1;
}

sub wait_msg {
    my ($msg, %options) = @_;
    my $mainw = ugtk2->new('rpmdrake', grab => 1, if_(exists $options{transient}, transient => $options{transient}));
    $mainw->{rwindow}->set_position($options{transient} ? 'center_on_parent' : 'center_always') if !$::isEmbedded;
    my $label = ref($msg) =~ /^Gtk/ ? $msg : Gtk2::Label->new($msg);
    gtkadd($mainw->{window}, gtkpack__(gtkpack__(Gtk2::VBox->new(0, 5), $label, if_(exists $options{widgets}, @{$options{widgets}}))));
    $label->signal_connect(expose_event => sub { $mainw->{displayed} = 1; 0 });
    $mainw->sync until $mainw->{displayed};
    gtkset_mousecursor_wait($mainw->{rwindow}->window);
    $mainw->flush;
    $mainw;
}
sub remove_wait_msg {
    my $w = shift;
    gtkset_mousecursor_normal($w->{rwindow}->window);
    $w->destroy;
}

sub but { "    $_[0]    " }
sub but_ { "        $_[0]        " }

sub slow_func($&) {
    my ($param, $func) = @_;
    if (ref($param) =~ /^Gtk/) {
	gtkset_mousecursor_wait($param);
	ugtk2::flush();
	$func->();
	gtkset_mousecursor_normal($param);
    } else {
	my $w = wait_msg($param);
	$func->();
	remove_wait_msg($w);
    }
}


my %u2l = (
	   at => N("Austria"),
	   au => N("Australia"),
	   be => N("Belgium"),
	   br => N("Brazil"),
	   ca => N("Canada"),
	   cr => N("Costa Rica"),
	   cz => N("Czech Republic"),
	   de => N("Germany"),
	   dk => N("Danmark"),
	   el => N("Greece"),
	   es => N("Spain"),
	   fi => N("Finland"),
	   fr => N("France"),
	   gr => N("Greece"),
	   il => N("Israel"),
	   it => N("Italy"),
	   jp => N("Japan"),
	   ko => N("Korea"),
	   nl => N("Netherlands"),
	   no => N("Norway"),
	   pl => N("Poland"),
	   pt => N("Portugal"),
	   ru => N("Russia"),
	   se => N("Sweden"),
	   tw => N("Taiwan"),
	   uk => N("United Kingdom"),
	   zh => N("China"),
	   com => N("United States"),
	   org => N("United States"),
	   net => N("United States"),
	   edu => N("United States"),
	  );
my $us = [ qw(com org net edu) ];
my %t2l = (
	   'America/\w+' =>       $us,
	   'Asia/Tel_Aviv' =>     [ qw(il ru it cz at de fr se) ],
	   'Asia/Tokyo' =>        [ qw(jp ko tw), @$us ],
	   'Asia/Seoul' =>        [ qw(ko jp tw), @$us ],
	   'Asia/(Taipei|Beijing)' => [ qw(zn jp), @$us ],
	   'Atlantic/Reykjavik' => [ qw(uk no se fi dk), @$us, qw(nl de fr at cz it) ],
	   'Australia/\w+' =>     [ qw(au jp ko tw), @$us ],
	   'Brazil/\w+' =>        [ 'br', @$us ],
	   'Canada/\w+' =>        [ 'ca', @$us ],
	   'Europe/Amsterdam' =>  [ qw(nl be de at cz fr se dk it) ],
	   'Europe/Athens' =>     [ qw(gr pl cz de it nl at fr) ],
	   'Europe/Berlin' =>     [ qw(de be at nl cz it fr se) ],
	   'Europe/Brussels' =>   [ qw(be de nl fr cz at it se) ],
	   'Europe/Budapest' =>   [ qw(cz it at de fr nl se) ],
	   'Europe/Copenhagen' => [ qw(dk nl de be se at cz it) ],
	   'Europe/Dublin' =>     [ qw(uk fr be nl dk se cz it) ],
	   'Europe/Helsinki' =>   [ qw(fi se no nl be de fr at it) ],
	   'Europe/Istanbul' =>   [ qw(il ru it cz it at de fr nl se) ],
	   'Europe/Lisbon' =>     [ qw(pt es fr it cz at de se) ],
	   'Europe/London' =>     [ qw(uk fr be nl de at cz se it) ],
	   'Europe/Madrid' =>     [ qw(es fr pt it cz at de se) ],
	   'Europe/Moscow' =>     [ qw(ru de pl cz at se be fr it) ],
	   'Europe/Oslo' =>       [ qw(no se fi dk de be at cz it) ],
	   'Europe/Paris' =>      [ qw(fr be de at cz nl it se) ],
	   'Europe/Prague' =>     [ qw(cz it at de fr nl se) ],
	   'Europe/Rome' =>       [ qw(it fr cz de at nl se) ],
	   'Europe/Stockholm' =>  [ qw(se no dk fi nl de at cz fr it) ],
	   'Europe/Vienna' =>     [ qw(at de cz it fr nl se) ],
	  );
my %sites2countries = ('proxad.net' => 'fr',
		       'planetmirror.com' => 'au');


sub distro_type {
    cat_('/etc/mandrake-release') =~ /community/i ? 'community'
      : cat_('/etc/mandrake-release') =~ /cooker/i ? 'cooker'
	: 'updates';
}

sub mirrors {
    my ($cachedir) = @_;
    my $distro_type = distro_type();
    $cachedir = '/root';
    my $mirrorslist = "$cachedir/mirrorsfull.list";
    unlink $mirrorslist;
    my $res = curl_download::download('http://www.linux-mandrake.com/mirrorsfull.list', $cachedir, sub {});
    $res and die $res;
    require timezone;
    my $tz = ${timezone::read()}{timezone};
    my @mirrors = map { my ($arch, $url) = m|\Q$distro_type\E([^:]*):(.+)|;
			if ($arch && MDK::Common::System::compat_arch($arch)) {
	                    my ($land, $goodness);
			    $url =~ m|\.\Q$_\E/| and $land = $_ foreach keys %u2l;
			    $url =~ m|\W\Q$_\E/| and $land = $sites2countries{$_} foreach keys %sites2countries;
			    each_index { $_ eq $land and $goodness ||= 100-$::i } (map { if_($tz =~ /^$_$/, @{$t2l{$_}}) } keys %t2l), @$us;
			    { url => $url, land => $u2l{$land} || N("United States"), goodness => $goodness + rand() };
			} else { () }
		    } cat_($mirrorslist);
    unlink $mirrorslist;
    return sort { $b->{goodness} <=> $a->{goodness} } @mirrors;
}

sub choose_mirror {
    my (%options) = @_;
    interactive_msg('', 
N("I need to contact MandrakeSoft website to get the mirrors list.
Please check that your network is currently running.

Is it ok to continue?"), yesno => 1) or return '';
    my $wait = wait_msg(N("Please wait, downloading mirrors addresses from MandrakeSoft website."));
    my @mirrors;
    eval { @mirrors = mirrors('/var/cache/urpmi') };
    remove_wait_msg($wait);
    if ($@) {
	my $msg = $@;  #- seems that value is bitten before being printed by next func..
	interactive_msg(N("Error during download"),
N("There was an error downloading the mirrors list:

%s
The network, or MandrakeSoft website, are maybe unavailable.
Please try again later.", $msg));
	return '';
    }

    !@mirrors and interactive_msg(N("No mirror"),
N("I can't find any suitable mirror.

There can be many reasons for this problem; the most frequent is
the case when the architecture of your processor is not supported
by Mandrake Linux Official Updates.")), return '';

    my $w = ugtk2->new('rpmdrake', grab => 1);
    $w->{rwindow}->set_position($options{transient} ? 'center_on_parent' : 'center_always') if !$::isEmbedded;
    my $tree_model = Gtk2::TreeStore->new("Glib::String");
    my $tree = Gtk2::TreeView->new_with_model($tree_model);
    $tree->get_selection->set_mode('browse');
    my $column = Gtk2::TreeViewColumn->new_with_attributes(undef, Gtk2::CellRendererText->new, 'text' => 0);
    $tree->append_column($column);
    $tree->set_headers_visible(0);

    gtkadd($w->{window}, 
	   gtkpack_(Gtk2::VBox->new(0,5),
		    0, N("Please choose the desired mirror."),
		    1, create_scrolled_window($tree),
		    0, gtkpack(create_hbox('edge'),
			       map {
				   my $retv = $_->[1];
				   gtksignal_connect(Gtk2::Button->new(but($_->[0])), clicked => sub {
						 if ($retv) {
						     my ($model, $iter) = $tree->get_selection->get_selected;
						     $model and $w->{retval} = { sel => $model->get($iter, 0) };
						 }
						 Gtk2->main_quit })
			       } [ N("Cancel"), 0 ], [ N("Ok"), 1 ]),
		   ));
    my %roots;
    $tree_model->append_set($roots{$_->{land}} ||= $tree_model->append_set(undef, [ 0 => $_->{land} ]),
			    [ 0 => $_->{url} ]) foreach @mirrors;

    $w->{window}->set_size_request(500, 400);
    $w->{rwindow}->show_all;

    my $path = Gtk2::TreePath->new_first;
    $tree->expand_row($path, 0);
    $path->down;
    $tree->get_selection->select_path($path);

    $w->main && member($w->{retval}{sel}, map { $_->{url} } @mirrors) and $w->{retval}{sel};
}

sub make_url_mirror {
    my ($mirror) = @_;
    if ($mirror =~ m!/RPMS$!) {
	#- esp. for distro_type() =~ /cooker|community/
	"$mirror/";
    } else {
	my ($class, $release) = cat_('/etc/mandrake-release') =~ /(\S+)\s+release\s+(\S+)/;
	$class !~ /linux/i and $release = lc($class) . "/$release";  #- handle subdirectory for corporate/clustering/etc
	"$mirror/$release/RPMS/";
    }
}

sub show_urpm_progress {
    my ($label, $pb, $mode, $file, $percent, $total, $eta, $speed) = @_;
    $file =~ s|([^:]*://[^/:\@]*:)[^/:\@]*(\@.*)|$1xxxx$2|; #- if needed...
    my $medium if 0;
    if ($mode eq 'copy') {
	$pb->set_fraction(0);
	$label->set_label(N("Copying file for medium `%s'...", $file));
    } elsif ($mode eq 'parse') {
	$pb->set_fraction(0);
	$label->set_label(N("Examining file of medium `%s'...", $file));
    } elsif ($mode eq 'retrieve') {
	$pb->set_fraction(0);
	$label->set_label(N("Examining remote file of medium `%s'...", $file));
        $medium = $file;
    } elsif ($mode eq 'done') {
	$pb->set_fraction(1.0);
	$label->set_label($label->get_label . N(" done."));
        $medium = undef;
    } elsif ($mode eq 'failed') {
	$pb->set_fraction(1.0);
	$label->set_label($label->get_label . N(" failed!"));
        $medium = undef;
    } else {
        length($file) > 60 and $file = $medium ? #-PO: We're downloading the said file from the said medium
                                                 N("%s from medium %s", basename($file), $medium)
                                               : basename($file);
        if ($mode eq 'start') {
            $pb->set_fraction(0);
            $label->set_label(N("Starting download of `%s'...", $file));
        } elsif ($mode eq 'progress') {
            if (defined $total && defined $eta) {
                $pb->set_fraction($percent/100);
                $label->set_label(N("Download of `%s', time to go:%s, speed:%s", $file, $eta, $speed));
            } else {
                $pb->set_fraction($percent/100);
                $label->set_label(N("Download of `%s', speed:%s", $file, $speed));
            }
        }
    }
    Gtk2->main_iteration while Gtk2->events_pending;
}

sub update_sources {
    my ($urpm, %options) = @_;
    my $w = wait_msg(my $label = Gtk2::Label->new(N("Please wait, updating media...")),
		     widgets => [ my $pb = gtkset_size_request(Gtk2::ProgressBar->new, 300, -1) ]);
    $urpm->update_media(%options,
	callback => sub {
	    my ($type, $media) = @_;
	    if ($type eq 'failed') {
		fatal_msg(N("Error retrieving packages"),
N("It's impossible to retrieve the list of new packages from the media
`%s'. Either this update media is misconfigured, and in this case
you should use the Software Media Manager to remove it and re-add it in order
to reconfigure it, either it is currently unreachable and you should retry
later.",
    $media));
	    } else {
		show_urpm_progress($label, $pb, @_);
	    }
	});
    remove_wait_msg($w);
}

sub update_sources_check {
    my ($urpm, $options, $error_msg, @media) = @_;
    my @error_msgs;
    local $urpm->{fatal} = sub { push @error_msgs, to_utf8($_[1]); goto fatal_error };
    local $urpm->{error} = sub { push @error_msgs, to_utf8($_[0]) };
    update_sources($urpm, %$options, noclean => 1);
  fatal_error:
    if (@error_msgs) {
        interactive_msg('rpmdrake', sprintf_fixutf8(translate($error_msg), join("\n", @error_msgs)));
        return 0;
    }
    return 1;
}

sub update_sources_interactive {
    my ($urpm, %options) = @_;
    my $w = ugtk2->new(N("Update media"), grab => 1, center => 1, %options);
    $w->{rwindow}->set_position($options{transient} ? 'center_on_parent' : 'center_always');
    my @buttons;
    my @media;
    gtkadd(
	$w->{window},
	gtkpack__(
	    Gtk2::VBox->new(0,5),
	    Gtk2::Label->new(N("Select the media you wish to update:")),
	    (
		@buttons = map {
		    Gtk2::CheckButton->new($_->{name})
		} grep {
		    ! $_->{ignore}
		} @{$urpm->{media}}
	    ),
	    Gtk2::HSeparator->new,
	    gtkpack(
		create_hbox(),
		gtksignal_connect(
		    Gtk2::Button->new(N("Cancel")),
		    clicked => sub { $w->{retval} = 0; Gtk2->main_quit },
		),
		gtksignal_connect(
		    Gtk2::Button->new(N("Update")),
		    clicked => sub {
			$w->{retval} = any { $_->get_active } @buttons;
			# list of media listed in the checkbox panel
			my @buttonmedia = grep { !$_->{ignore} } @{$urpm->{media}};
			@media = map_index { if_($_->get_active, $buttonmedia[$::i]{name}) } @buttons;
			Gtk2->main_quit;
		    },
		),
	    )
	)
    );
    if ($w->main) {
	foreach (@{$urpm->{media}}) {  #- force ignored media to be returned alive (forked from urpmi.updatemedia...)
	    $_->{modified} and delete $_->{ignore};
	}
        standalone::explanations("Updating media @media");
        $urpm->select_media(@media);
        update_sources_check(
	    $urpm,
	    {},
	    N_("Unable to update medium; it will be automatically disabled.\n\nErrors:\n%s"),
	    @media,
	);
	return 1;
    }
    return 0;
}

sub add_medium_and_check {
    my ($urpm, $options) = splice @_, 0, 2;

    my $fatal_msg;
    my @error_msgs;
    local $urpm->{fatal} = sub { printf STDERR "Fatal: %s\n", $_[1]; $fatal_msg = to_utf8($_[1]); goto fatal_error };
    local $urpm->{error} = sub { printf STDERR "Error: %s\n", $_[0]; push @error_msgs, to_utf8($_[0]) };
    standalone::explanations("Adding medium @_");
    $urpm->add_medium(@_);
    if (@error_msgs) {
        interactive_msg('rpmdrake',
                        N("Unable to add medium, errors reported:\n\n%s",
                          join("\n", @error_msgs)));
        return 0;
    }

    if (update_sources_check($urpm, $options, N_("Unable to add medium, errors reported:\n\n%s"), $_[0])) {
        $urpm->write_config;
    } else {
        $urpm->read_config;
        return 0;
    }

    my ($medium) = grep { $_->{name} eq $_[0] } @{$urpm->{media}};
    if ($medium) {
        return 1;
    } else {
        interactive_msg('rpmdrake', N("Unable to create medium."));
        return 0;
    }

  fatal_error:
    interactive_msg(N("Failure when adding medium"),
                    N("There was a problem adding medium:\n\n%s", $fatal_msg));
    return 0;
}