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 $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 $typical_width
             N translate myexit readconf writeconf interactive_msg interactive_packtable interactive_list fatal_msg wait_msg remove_wait_msg but but_ slow_func mirrors choose_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 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 => [] },
	      );
    ${$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}));
    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}{yes} || N("Yes")),
								      clicked => sub { $d->{retval} = 1; Gtk2->main_quit }),
						    gtksignal_connect(Gtk2::Button->new($options{text}{no} || N("No")),
								      clicked => sub { $d->{retval} = 0; 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);
    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}));
    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}));
    my $label = ref($msg) =~ /^Gtk/ ? $msg : Gtk2::Label->new($msg);
    gtkadd($mainw->{window}, gtkpack(gtkadd(create_vbox(), $label, if_(exists $options{widgets}, @{$options{widgets}}))));
    $label->signal_connect(expose_event => sub { $mainw->{displayed} = 1; 0 });
    $mainw->{rwindow}->set_position('center_always');
    $mainw->sync until $mainw->{displayed};
    gtkset_mousecursor_wait($mainw->{rwindow}->window);
    $mainw->flush;
    $mainw;
}
sub remove_wait_msg { $_[0]->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 cz at) ],
	   '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 dk) ],
	   'Australia/\w+' =>     [ qw(au jp ko tw), @$us ],
	   'Brazil/\w+' =>        [ 'br', @$us ],
	   'Canada/\w+' =>        [ 'ca', @$us ],
	   'Europe/Amsterdam' =>  [ qw(nl be de at) ],
	   'Europe/Athens' =>     [ qw(gr pl de nl at) ],
	   'Europe/Berlin' =>     [ qw(de be at nl fr) ],
	   'Europe/Brussels' =>   [ qw(be de nl fr at) ],
	   'Europe/Budapest' =>   [ qw(it cz at de at) ],
	   'Europe/Copenhagen' => [ qw(dk nl de be at) ],
	   'Europe/Dublin' =>     [ qw(uk fr be nl) ],
	   'Europe/Helsinki' =>   [ qw(fi se no nl at) ],
	   'Europe/Istanbul' =>   [ qw(il ru cz at) ],
	   'Europe/Lisbon' =>     [ qw(pt es fr it) ],
	   'Europe/London' =>     [ qw(uk fr be nl at) ],
	   'Europe/Madrid' =>     [ qw(es fr pt it) ],
	   'Europe/Moscow' =>     [ qw(ru de pl at) ],
	   'Europe/Oslo' =>       [ qw(no se fi dk at) ],
	   'Europe/Paris' =>      [ qw(fr be de at) ],
	   'Europe/Prague' =>     [ qw(cz be de at) ],
	   'Europe/Rome' =>       [ qw(it fr de at) ],
	   'Europe/Stockholm' =>  [ qw(se no dk fi at) ],
	   'Europe/Vienna' =>     [ qw(at de cz it) ],
	  );
my %sites2countries = ('proxad.net' => 'fr',
		       'planetmirror.com' => 'au');

sub mirrors {
    my ($cachedir, $class) = @_;
    $cachedir = '/tmp';
    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$class\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 {
    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', 'updates') };
    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);
    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(Gtk2::HBox->new(1, 20),
			       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) };
						     $iter and $iter->free;
						 }
						 Gtk2->main_quit })
			       } ([ N("Ok"), 1 ], [ N("Cancel"), 0 ])),
		   ));
    my %roots;
    $tree_model->append_set($roots{$_->{land}} ||= $tree_model->append_set(undef, [ 0 => $_->{land} ]),
			    [ 0 => $_->{url} ])->free 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);
    $path->free;

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

sub show_urpm_progress {
    my ($label, $pb, $mode, $file, $percent, $total, $eta, $speed) = @_;
    $file =~ s|([^:]*://[^/:\@]*:)[^/:\@]*(\@.*)|$1xxxx$2|; #- if needed...
    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));
    } elsif ($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));
	}
    } elsif ($mode eq 'done') {
	$pb->set_fraction(1.0);
	$label->set_label($label->get_label . N(" done."));
    } elsif ($mode eq 'failed') {
	$pb->set_fraction(1.0);
	$label->set_label($label->get_label . N(" failed!"));
    }
    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, 400, 0) ]);
    $urpm->update_media(%options, callback => sub { show_urpm_progress($label, $pb, @_) });
    remove_wait_msg($w);
}

sub update_sources_interactive {
    my ($urpm, %opts) = @_;
    my $w = ugtk2->new(N("Update media"), grab => 1, center => 1, %opts);
    my @buttons;
    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}) } @{$urpm->{media}}),
		     Gtk2::HSeparator->new,
		     gtkpack(create_hbox(),
			     gtksignal_connect(Gtk2::Button->new(N("Update")), clicked => sub {
						   $w->{retval} = any { $_->get_active } @buttons;
						   each_index { $_->get_active and $urpm->select_media($urpm->{media}[$::i]{name}) } @buttons;
						   Gtk2->main_quit;
					       }),
			     gtksignal_connect(Gtk2::Button->new(N("Cancel")), clicked => sub { $w->{retval} = 0; Gtk2->main_quit }))));
    if ($w->main) {
	foreach (@{$urpm->{media}}) {  #- force ignored media to be returned alive (forked from urpmi.updatemedia...)
	    $_->{modified} and delete $_->{ignore};
	}
	update_sources($urpm, noclean => 1);
	return 1;
    }
    return 0;
}

sub add_medium_and_check {
    my ($urpm, $msg, $options) = splice @_, 0, 3;
    standalone::explanations("Adding medium @_");
    my $wait = wait_msg($msg);
    $urpm->add_medium(@_);
    my @error_msgs;
    local $urpm->{fatal} = sub { push @error_msgs, $_[1] };
    local $urpm->{error} = sub { push @error_msgs, $_[0] };
    update_sources($urpm, %$options, noclean => 1);
    remove_wait_msg($wait);
    my ($medium) = grep { $_->{name} eq $_[0] } @{$urpm->{media}};
    $medium or interactive_msg('rpmdrake', N("Unable to create medium."));
    $medium->{modified} and interactive_msg('rpmdrake',
                                            N("Unable to update medium; it will be automatically disabled.\n\nErrors:\n%s",
                                              join("\n", @error_msgs)));
    $urpm->write_config;
}