urpmi/trunk/gurpmi.pm

package gurpmi;

#- Copyright (C) 2005 MandrakeSoft SA
#- Copyright (C) 2005-2010 Mandriva SA
#- $Id: gurpmi.pm 271299 2010-11-21 15:54:30Z peroyvind $

#- This is needed because text printed by Gtk2 will always be encoded
#- in UTF-8; we first check if LC_ALL is defined, because if it is,
#- changing only LC_COLLATE will have no effect.
use POSIX ();
use locale;
my $collation_locale = $ENV{LC_ALL};
if ($collation_locale) {
    $collation_locale =~ /UTF-8/ or POSIX::setlocale(POSIX::LC_ALL(), "$collation_locale.UTF-8");
} else {
    $collation_locale = POSIX::setlocale(POSIX::LC_COLLATE());
    $collation_locale =~ /UTF-8/ or POSIX::setlocale(POSIX::LC_COLLATE(), "$collation_locale.UTF-8");
}

use urpm;
use strict;
use Gtk2;
use urpm::util 'member';
use urpm::msg;
use urpm::args;
use urpm::select;
use Locale::gettext;

Locale::gettext::bind_textdomain_codeset('urpmi', 'UTF8');
URPM::bind_rpm_textdomain_codeset();

use Exporter;
our @ISA = qw(Exporter);
our @EXPORT = qw(create_scrolled_window fatal but cancel_n_quit quit add_button_box new_label N);

=head1 NAME

gurpmi - Mageia perl tools to handle the urpmi database

=head1 DESCRIPTION

C<gurpmi> is used by gurpmi* executables to manipulate packages and media
on a Mageia Linux distribution.

=head2 The urpm class

=over 4

=cut

urpm::select::add_packages_to_priority_upgrade_list('gurpmi', 'perl-Glib', 'perl-Gtk2');

sub usage () {
    print urpm::args::copyright('gurpmi', [ '1999-2010', 'Mandriva' ])
        . "    gurpmi <rpm> [ <rpm>... ]
" . N("Options:") . "\n"
 . N("  --help         - print this help message.
") . N("  --auto         - non-interactive mode, assume default answers to questions.
") . N("  --auto-select  - automatically select packages to upgrade the system.
") . N("  --force        - force invocation even if some packages do not exist.
") . N("  --verify-rpm   - verify rpm signature before installation
                   (--no-verify-rpm disables it, default is enabled).
") . N("  --media        - use only the given media, separated by comma.
") . N("  -p             - allow search in provides to find package.
") . N("  -P             - do not search in provides to find package.
") . N("  --root         - use another root for rpm installation.
") . N("  --test         - only verify if the installation can be achieved correctly.
") . N("  --searchmedia  - use only the given media to search requested packages.
");
    exit 0;
}

#- fatal gurpmi initialisation error (*not* fatal urpmi errors)
sub fatal { my $s = $_[0]; print STDERR "$s\n"; exit 1 }

=item parse_command_line()

Parse command line,
puts options in %gurpmi::options and puts bare names (not rpm filenames) in @gurpmi::names

=cut

sub parse_command_line() {
    my @all_rpms;
    our %options;
    our @names;

    # keep a copy for gurpmi2
    {
        local @ARGV = @ARGV;
        urpm::args::parse_cmdline(urpm => { options => \%options });
    }

    # Expand *.urpmi arguments
    my @ARGV_expanded;
    foreach my $a (@ARGV) {
        if ($a =~ /\.urpmi$/) {
            open my $fh, '<', $a or do { warn "Can't open $a: $!\n"; next };
            push @ARGV_expanded, map { chomp; $_ } <$fh>;
            close $fh;
        } else {
            push @ARGV_expanded, $a;
        }
    }
    foreach (@ARGV_expanded) {
        next if /^-/;
        if (-f $_) {
            push @all_rpms, $_;
        } else {
            push @names, $_;
        }
        
    }
    $::auto_select || @all_rpms + @names
        or fatal(N("No packages specified"));
    return @all_rpms;
}

sub but($) { "    $_[0]    " }

=item quit()

Quits top level gtk+ main loop or, if not such a loop, terminates with 1 as exit code

=cut

sub quit() {
    if (Gtk2->main_level) {
        Gtk2->main_quit;
    } else {
        # just exit if not in main loop (eg: while starting the GUI)
        exit 1;
    }
}

=item cancel_n_quit()

Quits gtk+ main loop and terminates with 1 as exit code

=cut

sub cancel_n_quit() {
    Gtk2->main_quit;
    exit(1);
}

=item add_button_box($vbox, @buttons)

Packs the buttons in an horizontal ButtonBox, on edges.

=cut

sub add_button_box {
    my ($vbox, @buttons) = @_;
    my $hbox = Gtk2::HButtonBox->new;
    $vbox->pack_start($hbox, 0, 0, 0);
    $hbox->set_layout('edge');
    $_->set_alignment(0.5, 0.5), $hbox->add($_) foreach @buttons;
}

=item new_label($msg)

Creates a new Gtk2::Label widget.
If messages is too big, it's wrapped in a scrolled window

=cut

sub new_label {
    my ($msg) = @_;
    my $label = Gtk2::Label->new($msg);
    $label->set_line_wrap(1);
    $label->set_alignment(0.5, 0.5);
    if (($msg =~ tr/\n/\n/) > 5) {
        my $sw = create_scrolled_window($label, [ 'never', 'automatic' ]);
        $sw->set_size_request(-1,200);
        return $sw;
    } else {
        return $label;
    }
}

=item create_scrolled_window($W, $o_policy, $o_viewport_shadow)

Creates a scrolled window around the $W widget

=cut

# copied from ugtk2:
sub create_scrolled_window {
    my ($W, $o_policy, $o_viewport_shadow) = @_;
    my $w = Gtk2::ScrolledWindow->new(undef, undef);
    $w->set_policy($o_policy ? @$o_policy : ('automatic', 'automatic'));
    if (member(ref($W), qw(Gtk2::Layout Gtk2::Html2::View Gtk2::Text Gtk2::TextView Gtk2::TreeView))) {
        $w->add($W);
    } else {
        $w->add_with_viewport($W);
    }
    $o_viewport_shadow and $w->child->set_shadow_type($o_viewport_shadow);
    $W->can('set_focus_vadjustment') and $W->set_focus_vadjustment($w->get_vadjustment);
    $W->set_left_margin(6) if ref($W) =~ /Gtk2::TextView/;
    $W->show;
    if (ref($W) =~ /Gtk2::TextView|Gtk2::TreeView/) {
        my $f = Gtk2::Frame->new;
        $w->show; # unlike ugtk2, we'd to do this explicitely...
        $f->set_shadow_type('in');
     $f->add($w);
     $f;
    } else {
        $w;
    }
}

=back

=head1 COPYRIGHT

Copyright (C) 2005 MandrakeSoft SA

Copyright (C) 2005-2010 Mandriva SA

Copyright (C) 2011-2013 Mageia SA

This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.

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.

=cut

1;
1	package gurpmi;
2
3	#- Copyright (C) 2005 MandrakeSoft SA
4	#- Copyright (C) 2005-2010 Mandriva SA
5	#- $Id: gurpmi.pm 271299 2010-11-21 15:54:30Z peroyvind $
6
7	#- This is needed because text printed by Gtk2 will always be encoded
8	#- in UTF-8; we first check if LC_ALL is defined, because if it is,
9	#- changing only LC_COLLATE will have no effect.
10	use POSIX ();
11	use locale;
12	my $collation_locale = $ENV{LC_ALL};
13	if ($collation_locale) {
14	$collation_locale =~ /UTF-8/ or POSIX::setlocale(POSIX::LC_ALL(), "$collation_locale.UTF-8");
15	} else {
16	$collation_locale = POSIX::setlocale(POSIX::LC_COLLATE());
17	$collation_locale =~ /UTF-8/ or POSIX::setlocale(POSIX::LC_COLLATE(), "$collation_locale.UTF-8");
18	}
19
20	use urpm;
21	use strict;
22	use Gtk2;
23	use urpm::util 'member';
24	use urpm::msg;
25	use urpm::args;
26	use urpm::select;
27	use Locale::gettext;
28
29	Locale::gettext::bind_textdomain_codeset('urpmi', 'UTF8');
30	URPM::bind_rpm_textdomain_codeset();
31
32	use Exporter;
33	our @ISA = qw(Exporter);
34	our @EXPORT = qw(create_scrolled_window fatal but cancel_n_quit quit add_button_box new_label N);
35
36	=head1 NAME
37
38	gurpmi - Mageia perl tools to handle the urpmi database
39
40	=head1 DESCRIPTION
41
42	C<gurpmi> is used by gurpmi* executables to manipulate packages and media
43	on a Mageia Linux distribution.
44
45	=head2 The urpm class
46
47	=over 4
48
49	=cut
50
51	urpm::select::add_packages_to_priority_upgrade_list('gurpmi', 'perl-Glib', 'perl-Gtk2');
52
53	sub usage () {
54	print urpm::args::copyright('gurpmi', [ '1999-2010', 'Mandriva' ])
55	. " gurpmi <rpm> [ <rpm>... ]
56	" . N("Options:") . "\n"
57	. N(" --help - print this help message.
58	") . N(" --auto - non-interactive mode, assume default answers to questions.
59	") . N(" --auto-select - automatically select packages to upgrade the system.
60	") . N(" --force - force invocation even if some packages do not exist.
61	") . N(" --verify-rpm - verify rpm signature before installation
62	(--no-verify-rpm disables it, default is enabled).
63	") . N(" --media - use only the given media, separated by comma.
64	") . N(" -p - allow search in provides to find package.
65	") . N(" -P - do not search in provides to find package.
66	") . N(" --root - use another root for rpm installation.
67	") . N(" --test - only verify if the installation can be achieved correctly.
68	") . N(" --searchmedia - use only the given media to search requested packages.
69	");
70	exit 0;
71	}
72
73	#- fatal gurpmi initialisation error (not fatal urpmi errors)
74	sub fatal { my $s = $_[0]; print STDERR "$s\n"; exit 1 }
75
76	=item parse_command_line()
77
78	Parse command line,
79	puts options in %gurpmi::options and puts bare names (not rpm filenames) in @gurpmi::names
80
81	=cut
82
83	sub parse_command_line() {
84	my @all_rpms;
85	our %options;
86	our @names;
87
88	# keep a copy for gurpmi2
89	{
90	local @ARGV = @ARGV;
91	urpm::args::parse_cmdline(urpm => { options => \%options });
92	}
93
94	# Expand *.urpmi arguments
95	my @ARGV_expanded;
96	foreach my $a (@ARGV) {
97	if ($a =~ /\.urpmi$/) {
98	open my $fh, '<', $a or do { warn "Can't open $a: $!\n"; next };
99	push @ARGV_expanded, map { chomp; $_ } <$fh>;
100	close $fh;
101	} else {
102	push @ARGV_expanded, $a;
103	}
104	}
105	foreach (@ARGV_expanded) {
106	next if /^-/;
107	if (-f $_) {
108	push @all_rpms, $_;
109	} else {
110	push @names, $_;
111	}
112
113	}
114	$::auto_select \|\| @all_rpms + @names
115	or fatal(N("No packages specified"));
116	return @all_rpms;
117	}
118
119	sub but($) { " $_[0] " }
120
121	=item quit()
122
123	Quits top level gtk+ main loop or, if not such a loop, terminates with 1 as exit code
124
125	=cut
126
127	sub quit() {
128	if (Gtk2->main_level) {
129	Gtk2->main_quit;
130	} else {
131	# just exit if not in main loop (eg: while starting the GUI)
132	exit 1;
133	}
134	}
135
136	=item cancel_n_quit()
137
138	Quits gtk+ main loop and terminates with 1 as exit code
139
140	=cut
141
142	sub cancel_n_quit() {
143	Gtk2->main_quit;
144	exit(1);
145	}
146
147	=item add_button_box($vbox, @buttons)
148
149	Packs the buttons in an horizontal ButtonBox, on edges.
150
151	=cut
152
153	sub add_button_box {
154	my ($vbox, @buttons) = @_;
155	my $hbox = Gtk2::HButtonBox->new;
156	$vbox->pack_start($hbox, 0, 0, 0);
157	$hbox->set_layout('edge');
158	$_->set_alignment(0.5, 0.5), $hbox->add($_) foreach @buttons;
159	}
160
161	=item new_label($msg)
162
163	Creates a new Gtk2::Label widget.
164	If messages is too big, it's wrapped in a scrolled window
165
166	=cut
167
168	sub new_label {
169	my ($msg) = @_;
170	my $label = Gtk2::Label->new($msg);
171	$label->set_line_wrap(1);
172	$label->set_alignment(0.5, 0.5);
173	if (($msg =~ tr/\n/\n/) > 5) {
174	my $sw = create_scrolled_window($label, [ 'never', 'automatic' ]);
175	$sw->set_size_request(-1,200);
176	return $sw;
177	} else {
178	return $label;
179	}
180	}
181
182	=item create_scrolled_window($W, $o_policy, $o_viewport_shadow)
183
184	Creates a scrolled window around the $W widget
185
186	=cut
187
188	# copied from ugtk2:
189	sub create_scrolled_window {
190	my ($W, $o_policy, $o_viewport_shadow) = @_;
191	my $w = Gtk2::ScrolledWindow->new(undef, undef);
192	$w->set_policy($o_policy ? @$o_policy : ('automatic', 'automatic'));
193	if (member(ref($W), qw(Gtk2::Layout Gtk2::Html2::View Gtk2::Text Gtk2::TextView Gtk2::TreeView))) {
194	$w->add($W);
195	} else {
196	$w->add_with_viewport($W);
197	}
198	$o_viewport_shadow and $w->child->set_shadow_type($o_viewport_shadow);
199	$W->can('set_focus_vadjustment') and $W->set_focus_vadjustment($w->get_vadjustment);
200	$W->set_left_margin(6) if ref($W) =~ /Gtk2::TextView/;
201	$W->show;
202	if (ref($W) =~ /Gtk2::TextView\|Gtk2::TreeView/) {
203	my $f = Gtk2::Frame->new;
204	$w->show; # unlike ugtk2, we'd to do this explicitely...
205	$f->set_shadow_type('in');
206	$f->add($w);
207	$f;
208	} else {
209	$w;
210	}
211	}
212
213	=back
214
215	=head1 COPYRIGHT
216
217	Copyright (C) 2005 MandrakeSoft SA
218
219	Copyright (C) 2005-2010 Mandriva SA
220
221	Copyright (C) 2011-2013 Mageia SA
222
223	This program is free software; you can redistribute it and/or modify
224	it under the terms of the GNU General Public License as published by
225	the Free Software Foundation; either version 2, or (at your option)
226	any later version.
227
228	This program is distributed in the hope that it will be useful,
229	but WITHOUT ANY WARRANTY; without even the implied warranty of
230	MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
231	GNU General Public License for more details.
232
233	You should have received a copy of the GNU General Public License
234	along with this program; if not, write to the Free Software
235	Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
236
237	=cut
238
239	1;