diff options
Diffstat (limited to 'perl-install')
| -rw-r--r-- | perl-install/Makefile | 3 | ||||
| -rw-r--r-- | perl-install/install_interactive.pm | 2 | ||||
| -rw-r--r-- | perl-install/install_steps_gtk.pm | 120 | ||||
| -rw-r--r-- | perl-install/interactive_gtk.pm | 1 | ||||
| -rw-r--r-- | perl-install/my_gtk.pm | 48 |
5 files changed, 90 insertions, 84 deletions
diff --git a/perl-install/Makefile b/perl-install/Makefile index 434a06bcb..fbfdc0dfd 100644 --- a/perl-install/Makefile +++ b/perl-install/Makefile @@ -27,9 +27,6 @@ test_pms: verify_c ./perl2fcalls -excludec -excluderesize_fat::c_rewritten install2 standalone/keyboarddrake standalone/XFdrake for i in install2 install_steps_*.pm; do perl -cw -I. $$i; done -test_all: test_pms - for i in $(PMS); do perl -cw -I. $$i; done - verify_c: ./verify_c $(PMS) diff --git a/perl-install/install_interactive.pm b/perl-install/install_interactive.pm index 074f8aff5..d60e922cb 100644 --- a/perl-install/install_interactive.pm +++ b/perl-install/install_interactive.pm @@ -273,7 +273,7 @@ sub setup_thiskind { } @l = map { $_->{description} } @l; while (1) { - my ($msg_type) = $type =~ /(.*)|/; + (my $msg_type = $type) =~ s/\|.*//; my $msg = @l ? [ _("Found %s %s interfaces", join(", ", @l), $msg_type), _("Do you have another one?") ] : diff --git a/perl-install/install_steps_gtk.pm b/perl-install/install_steps_gtk.pm index 00c452066..6e70ff99d 100644 --- a/perl-install/install_steps_gtk.pm +++ b/perl-install/install_steps_gtk.pm @@ -249,7 +249,7 @@ a percentage of %d%% will install as many packages as possible.", $percentage, $ sub choosePackagesTree { my ($o, $packages, $compss) = @_; - my ($curr, $info_widget, $w_size, $go, $idle, $flat, $auto_deps); + my ($curr, $parent, $info_widget, $w_size, $go, $idle, $flat, $auto_deps); my (%wtree, %ptree); my $w = my_gtk->new(''); @@ -283,22 +283,28 @@ sub choosePackagesTree { my $pix_base = [ gtkcreate_xpm($w->{window}, "$ENV{SHARE_PATH}/rpm-base.xpm") ]; my $pix_selected = [ gtkcreate_xpm($w->{window}, "$ENV{SHARE_PATH}/rpm-selected.xpm") ]; my $pix_unselect = [ gtkcreate_xpm($w->{window}, "$ENV{SHARE_PATH}/rpm-unselected.xpm") ]; + my $pix_semisele = [ gtkcreate_xpm($w->{window}, "$ENV{SHARE_PATH}/rpm-semiselected.xpm") ]; my $pix_installed= [ gtkcreate_xpm($w->{window}, "$ENV{SHARE_PATH}/rpm-installed.xpm") ]; - my $parent; $parent = sub { + my $add_parent; $add_parent = sub { if (my $w = $wtree{$_[0]}) { return $w } my $s; foreach (split '/', $_[0]) { - $wtree{"$s/$_"} ||= - $tree->insert_node($s ? $parent->($s) : undef, undef, [$_, '', ''], 5, (undef) x 4, 0, 0); - $s = "$s/$_"; + my $s2 = $s ? "$s/$_" : $_; + $wtree{$s2} ||= do { + my $n = $tree->insert_node($s ? $add_parent->($s) : undef, undef, [$_, '', ''], 5, (undef) x 4, 0, 0); + $n; + }; + $s = $s2; } + $tree->node_set_pixmap($wtree{$s}, 1, $pix_semisele->[0], $pix_semisele->[1]); $wtree{$s}; }; my $add_node = sub { my ($leaf, $root) = @_; - my $node = $tree->insert_node($parent->($root), undef, [$leaf, '', ''], 5, (undef) x 4, 1, 0); my $p = $packages->[0]{$leaf} or return; $p->{medium}{selected} or return; + my $node = $tree->insert_node($add_parent->($root), + undef, [$leaf, '', ''], 5, (undef) x 4, 1, 0); my $pix = pkgs::packageFlagBase($p) ? $pix_base : pkgs::packageFlagSelected($p) ? $pix_selected : pkgs::packageFlagInstalled($p) ? $pix_installed : $pix_unselect; $tree->node_set_pixmap($node, 1, $pix->[0], $pix->[1]); push @{$ptree{$leaf}}, $node; @@ -337,7 +343,6 @@ sub choosePackagesTree { } $toolbar->set_style("icons"); - my $display_info = sub { my $p = $packages->[0]{$curr} or return gtktext_insert($info_widget, ''); pkgs::extractHeaders($o->{prefix}, [$p], $p->{medium}); @@ -362,57 +367,79 @@ sub choosePackagesTree { pkgs::correctSize($size / sqr(1024)), install_any::getAvailableSpace($o) / sqr(1024))); }; + my $select = sub { + my %l; + my $isSelection = !pkgs::packageFlagSelected($_[0]); + foreach (@_) { + pkgs::togglePackageSelection($packages, $_, my $l = {}); + @l{keys %$l} = (); + } + if (my @l = keys %l) { + #- check for size before trying to select. + my $size = pkgs::selectedSize($packages); + foreach (@l) { + my $p = $packages->[0]{$_}; + pkgs::packageFlagSelected($p) or $size += pkgs::packageSize($p); + } + if (pkgs::correctSize($size / sqr(1024)) > install_any::getAvailableSpace($o) / sqr(1024)) { + return $o->ask_warn('', _("You can't select this package as there is not enough space left to install it")); + } + + @l > @_ && !$auto_deps and $o->ask_okcancel('', [ _("The following packages are going to be installed/removed"), join(", ", sort @l) ], 1) || return; + $isSelection ? pkgs::selectPackage($packages, $_) : pkgs::unselectPackage($packages, $_) foreach @_; + foreach (@l) { + my $p = $packages->[0]{$_}; + my $pix = pkgs::packageFlagSelected($p) ? $pix_selected : $pix_unselect; + $tree->node_set_pixmap($_, 1, $pix->[0], $pix->[1]) foreach @{$ptree{$_}}; + } + &$update_size; + } else { + $o->ask_warn('', _("You can't select/unselect this package")); + } + }; + my $children = sub { map { $packages->[0]{($tree->node_get_pixtext($_, 0))[0]} } gtkctree_children($_[0]) }; my $toggle_ = sub { - if (ref $curr) { + if (ref $curr && ! $_[0]) { $tree->toggle_expansion($curr); } else { - my $p = $packages->[0]{$curr} or return; - if (pkgs::packageFlagBase($p)) { - return $o->ask_warn('', _("This is a mandatory package, it can't be unselected")); - } elsif (pkgs::packageFlagInstalled($p)) { - return $o->ask_warn('', _("You can't unselect this package. It is already installed")); - } elsif (pkgs::packageFlagUpgrade($p)) { - if ($::expert) { - if (pkgs::packageFlagSelected($p)) { - $o->ask_yesorno('', _("This package must be upgraded\nAre you sure you want to deselect it?")) or return; + if (ref $curr) { + my @l = grep { !pkgs::packageFlagBase($_) } $children->($curr) or return; + my @unsel = grep { !pkgs::packageFlagSelected($_) } @l; + my @p = @unsel ? + @unsel : # not all is selected, select all + @l; + $select->(@p); + $parent = $curr; + } else { + my $p = $packages->[0]{$curr} or return; + if (pkgs::packageFlagBase($p)) { + return $o->ask_warn('', _("This is a mandatory package, it can't be unselected")); + } elsif (pkgs::packageFlagInstalled($p)) { + return $o->ask_warn('', _("You can't unselect this package. It is already installed")); + } elsif (pkgs::packageFlagUpgrade($p)) { + if ($::expert) { + if (pkgs::packageFlagSelected($p)) { + $o->ask_yesorno('', _("This package must be upgraded\nAre you sure you want to deselect it?")) or return; + } + } else { + return $o->ask_warn('', _("You can't unselect this package. It must be upgraded")); } - } else { - return $o->ask_warn('', _("You can't unselect this package. It must be upgraded")); - } - } - - pkgs::togglePackageSelection($packages, $p, my $l = {}); - if (my @l = grep { $l->{$_} } keys %$l) { - #- check for size before trying to select. - my $size = pkgs::selectedSize($packages); - foreach (@l) { - my $p = $packages->[0]{$_}; - pkgs::packageFlagSelected($p) or $size += pkgs::packageSize($p); - } - if (pkgs::correctSize($size / sqr(1024)) > install_any::getAvailableSpace($o) / sqr(1024)) { - return $o->ask_warn('', _("You can't select this package as there is not enough space left to install it")); } - - @l > 1 && !$auto_deps and $o->ask_okcancel('', [ _("The following packages are going to be installed/removed"), join(", ", sort @l) ], 1) || return; - pkgs::togglePackageSelection($packages, $p); - foreach (@l) { - my $p = $packages->[0]{$_}; - my $pix = pkgs::packageFlagSelected($p) ? $pix_selected : $pix_unselect; - $tree->node_set_pixmap($_, 1, $pix->[0], $pix->[1]) foreach @{$ptree{$_}}; - } - &$update_size; - } else { - $o->ask_warn('', _("You can't select/unselect this package")); + $select->($p); } + my @l = $children->($parent); + my $nb = grep { pkgs::packageFlagSelected($_) } @l; + my $pix = $nb==0 ? $pix_unselect : $nb<@l ? $pix_semisele : $pix_selected; + $tree->node_set_pixmap($parent, 1, $pix->[0], $pix->[1]); } }; my $toggle = sub { &$toggle_; gtkset_mousecursor_normal() }; - $tree->signal_connect(button_press_event => sub { &$toggle if $_[1]{type} =~ /^2/ }); + $tree->signal_connect(button_press_event => sub { $toggle->(0) if $_[1]{type} =~ /^2/ }); $tree->signal_connect(key_press_event => sub { my ($w, $e) = @_; my $c = chr($e->{keyval} & 0xff); - &$toggle if $e->{keyval} >= 0x100 ? $c eq "\r" || $c eq "\x8d" : $c eq ' '; + $toggle->(0) if $e->{keyval} >= 0x100 ? $c eq "\r" || $c eq "\x8d" : $c eq ' '; 1; }); $tree->signal_connect(tree_select_row => sub { @@ -420,11 +447,12 @@ sub choosePackagesTree { if ($_[1]->row->is_leaf) { ($curr) = $tree->node_get_pixtext($_[1], 0); + $parent = $_[1]->row->parent; $idle = Gtk->timeout_add(100, $display_info); } else { $curr = $_[1]; } - &$toggle if $_[2] == 1; + $toggle->(1) if $_[2] == 1; }); &$update_size; $w->main; diff --git a/perl-install/interactive_gtk.pm b/perl-install/interactive_gtk.pm index c332f9559..2e9e763ad 100644 --- a/perl-install/interactive_gtk.pm +++ b/perl-install/interactive_gtk.pm @@ -364,6 +364,5 @@ sub kill { my $w = pop @interactive::objects; $w->destroy; } - @my_gtk::grabbed = (); $o->{before_killing} = @interactive::objects; } diff --git a/perl-install/my_gtk.pm b/perl-install/my_gtk.pm index 6c94f4ca8..defcb412a 100644 --- a/perl-install/my_gtk.pm +++ b/perl-install/my_gtk.pm @@ -5,12 +5,12 @@ package my_gtk; use diagnostics; use strict; -use vars qw(@ISA %EXPORT_TAGS @EXPORT_OK $border @grabbed); +use vars qw(@ISA %EXPORT_TAGS @EXPORT_OK $border); @ISA = qw(Exporter); %EXPORT_TAGS = ( helpers => [ qw(create_okcancel createScrolledWindow create_menu create_notebook create_packtable create_hbox create_vbox create_adjustment create_box_with_title create_treeitem) ], - wrappers => [ qw(gtksignal_connect gtkpack gtkpack_ gtkpack__ gtkappend gtkadd gtktext_insert gtkset_usize gtkset_justify gtkset_active gtkshow gtkdestroy gtkset_mousecursor gtkset_mousecursor_normal gtkset_mousecursor_wait gtkset_background gtkset_default_fontset gtkxpm gtkcreate_xpm) ], + wrappers => [ qw(gtksignal_connect gtkpack gtkpack_ gtkpack__ gtkappend gtkadd gtktext_insert gtkset_usize gtkset_justify gtkset_active gtkshow gtkdestroy gtkset_mousecursor gtkset_mousecursor_normal gtkset_mousecursor_wait gtkset_background gtkset_default_fontset gtkctree_children gtkxpm gtkcreate_xpm) ], ask => [ qw(ask_warn ask_okcancel ask_yesorno ask_from_entry ask_from_list ask_file) ], ); $EXPORT_TAGS{all} = [ map { @$_ } values %EXPORT_TAGS ]; @@ -39,9 +39,8 @@ sub new { while (my $e = shift @tempory::objects) { $e->destroy } push @interactive::objects, $o unless $opts{no_interactive_objects}; - top(@grabbed)->grab_remove if @grabbed; - push(@grabbed, $o->{rwindow}), $o->{rwindow}->grab_add if $my_gtk::grab || $o->{grab}; - + $o->{rwindow}->set_modal(1) if $my_gtk::grab || $o->{grab}; + print "modal############################################################\n" if $my_gtk::grab || $o->{grab}; $o; } sub main($;$) { @@ -63,8 +62,6 @@ sub show($) { } sub destroy($) { my ($o) = @_; - (pop @grabbed)->grab_remove if @grabbed; - top(@grabbed)->grab_add if @grabbed; $o->{rwindow}->destroy; gtkset_mousecursor_wait(); flush(); @@ -178,7 +175,7 @@ sub gtkset_background { $root->draw_rectangle($gc, 1, 0, 0, $w, $h); } -sub gtkset_default_fontset($) { +sub gtkset_default_fontset { my ($fontset) = @_; my $style = Gtk::Widget->get_default_style; @@ -187,6 +184,15 @@ sub gtkset_default_fontset($) { Gtk::Widget->set_default_style($style); } +sub gtkctree_children { + my ($node) = @_; + my @l; + for (my $p = $node->row->children; $p; $p = $p->row->sibling) { + push @l, $p; + } + @l; +} + sub gtkcreate_xpm { my $w = shift; Gtk::Gdk::Pixmap->create_from_xpm($w->window, $w->style->bg('normal'), @_) } sub xpm_d { my $w = shift; Gtk::Gdk::Pixmap->create_from_xpm_d($w->window, undef, @_) } sub gtkxpm { new Gtk::Pixmap(gtkcreate_xpm(@_)) } @@ -300,31 +306,7 @@ sub _create_window($$) { my $w = new Gtk::Window; my $f = new Gtk::Frame(undef); $w->set_name("Title"); - - if ($::isStandalone || $o->{no_border} || 1) { # hack - gtkadd($w, $f); - } else { - my $t = new Gtk::Table(0, 0, 0); - - my $new = sub { - my $w = new Gtk::DrawingArea; - $w->set_usize($border, $border); - $w->set_events(['exposure_mask']); - $w->signal_connect_after(expose_event => - sub { $w->window->draw_rectangle($w->style->black_gc, 1, 0, 0, @{$w->allocation}[2,3]); 1 } - ); - $w->show; - $w; - }; - - $t->attach(&$new(), 0, 1, 0, 3, [], , ["expand","fill"], 0, 0); - $t->attach(&$new(), 1, 2, 0, 1, ["expand","fill"], [], 0, 0); - $t->attach($f, 1, 2, 1, 2, ["expand","fill"], ["expand","fill"], 0, 0); - $t->attach(&$new(), 1, 2, 2, 3, ["expand","fill"], [], 0, 0); - $t->attach(&$new(), 2, 3, 0, 3, [], ["expand","fill"], 0, 0); - - gtkadd($w, $t); - } + gtkadd($w, $f); $w->set_title($title); |