summaryrefslogtreecommitdiffstats
path: root/urpm/get_pkgs.pm
blob: 060b55c6a6c0ae4237bc7ed69dfc22add44cd1b0 (plain)
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
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
package urpm::get_pkgs;

# $Id: get_pkgs.pm 267986 2010-04-28 10:10:27Z cfergeau $

use strict;
use urpm::msg;
use urpm::sys;
use urpm::util;
use urpm::media;
use urpm 'file_from_local_url';
# perl_checker: require urpm::select


=head1 NAME

urpm::get_pkgs - Package retrieving routines for urpmi

=head1 SYNOPSIS

=head1 DESCRIPTION

=over

=cut 

sub clean_all_cache {
    my ($urpm) = @_;
    #- clean download directory, do it here even if this is not the best moment.
    $urpm->{log}(N("cleaning %s and %s", "$urpm->{cachedir}/partial", "$urpm->{cachedir}/rpms"));
    urpm::sys::empty_dir("$urpm->{cachedir}/partial");
    urpm::sys::empty_dir("$urpm->{cachedir}/rpms");
}

sub cachedir_rpms {
    my ($urpm) = @_;

    #- examine the local repository, which is trusted (no gpg or pgp signature check but md5 is now done).
    my %fn2file;
    foreach my $filepath (glob("$urpm->{cachedir}/rpms/*")) {
	next if -d $filepath;

	if (! -s $filepath) {
	    unlink $filepath; #- this file should be removed or is already empty.
	} else {
	    my $filename = basename($filepath);
	    my ($fullname) = $filename =~ /(.*)\.rpm$/ or next;
	    $fn2file{$fullname} = $filepath;
	}
    }
    \%fn2file;
}

#- select sources for selected packages,
#- according to keys of the packages hash.
#- returns a list of lists containing the source description for each rpm,
#- matching the exact number of registered media; ignored media being
#- associated to a null list.
sub _selected2local_and_ids {
    my ($urpm, $packages, %options) = @_;
    my (%protected_files, %local_sources, %fullname2id);

    #- build association hash to retrieve id and examine all list files.
    foreach (keys %$packages) {
	foreach my $id (split /\|/, $_) {
	    if ($urpm->{source}{$_}) {
		my $file = $local_sources{$id} = $urpm->{source}{$id};
		$protected_files{$file} = undef;
	    } else {
		$fullname2id{$urpm->{depslist}[$id]->fullname} = $id;
	    }
	}
    }

    #- examine the local repository, which is trusted (no gpg or pgp signature check but md5 is now done).
    my $cachedir_rpms = cachedir_rpms($urpm);

    foreach my $fullname (keys %$cachedir_rpms) {
	    my $filepath = $cachedir_rpms->{$fullname};

	    if (my $id = delete $fullname2id{$fullname}) {
		$local_sources{$id} = $filepath;
	    } else {
		$options{clean_other} && ! exists $protected_files{$filepath} and unlink $filepath;
	    }
    }

    my %id2ids;
    foreach my $id (values %fullname2id) {
	my $pkg = $urpm->{depslist}[$id];
	my $fullname = $pkg->fullname;
	my @pkg_ids = $pkg->arch eq 'src' ? do {
	    # packages_by_name can't be used here since $urpm->{provides} doesn't have src.rpm
	    # so a full search is needed
	    my %requested;
	    urpm::select::search_packages($urpm, \%requested, [$pkg->name], src => 1);
	    map { split /\|/ } keys %requested;
	} : do {
	    map { $_->id } grep {
		$_->filename !~ /\.delta\.rpm$/ || $urpm->is_delta_installable($_, $urpm->{root});
	    } grep { $fullname eq $_->fullname } $urpm->packages_by_name($pkg->name);
	};

	$id2ids{$id} = \@pkg_ids;
    }

    (\%local_sources, \%id2ids);
}

sub selected2local_and_blists {
    my ($urpm, $selected, %options) = @_;

    my ($local_sources, $id2ids) = _selected2local_and_ids($urpm, $selected, %options);

    # id_map is a remapping of id.
    # it is needed because @list must be [ { id => pkg } ] where id is one the selected id,
    # not really the real package id
    my %id_map;
    foreach my $id (keys %$id2ids) {
	$id_map{$_} = $id foreach @{$id2ids->{$id}};
    }

    my @remaining_ids = sort { $a <=> $b } keys %id_map;

    my @blists = map {
	my $medium = $_;
	my %pkgs;
	if (urpm::media::is_valid_medium($medium) && !$medium->{ignore}) {
	    while (@remaining_ids) {
		my $id = $remaining_ids[0];
		$medium->{start} <= $id && $id <= $medium->{end} or last;
		shift @remaining_ids;

		my $pkg = $urpm->{depslist}[$id];
		$pkgs{$id_map{$id}} = $pkg;
	    }
	}
	%pkgs ? { medium => $medium, pkgs => \%pkgs } : @{[]};
    } (@{$urpm->{media} || []});

    if (@remaining_ids) {
	$urpm->{error}(N("package %s is not found.", $urpm->{depslist}[$_]->fullname)) foreach @remaining_ids;
	return;
    }

    ($local_sources, \@blists);
}

#- side-effects: none
sub _create_old_list_from_blists {
    my ($media, $blists) = @_;

    [ map {
	my $medium = $_;
	my ($blist) = grep { $_->{medium} == $medium } @$blists;

	{ map { $_ => urpm::blist_pkg_to_url($blist, $blist->{pkgs}{$_}) } keys %{$blist->{pkgs}} }
    } @$media ];
}

sub verify_partial_rpm_and_move {
    my ($urpm, $cachedir, $filename) = @_;

    URPM::verify_rpm("$cachedir/partial/$filename", nosignatures => 1) or do {
	unlink "$cachedir/partial/$filename";
	return;
    };
    #- it seems the the file has been downloaded correctly and has been checked to be valid.
    unlink "$cachedir/rpms/$filename";
    urpm::sys::move_or_die($urpm, "$cachedir/partial/$filename", "$cachedir/rpms/$filename");
    "$cachedir/rpms/$filename";
}


=item get_distant_media_filesize($blists, $sources)

Get the filesize of packages to download from remote media.

=cut

sub get_distant_media_filesize {
    my ($blists, $sources) = @_;

    my $filesize;
    #- get back all ftp and http accessible rpm files into the local cache
    foreach my $blist (@$blists) {
	#- examine all files to know what can be indexed on multiple media.
	while (my ($id, $pkg) = each %{$blist->{pkgs}}) {
	    #- the given URL is trusted, so the file can safely be ignored.
	    defined $sources->{$id} and next;
	    if (!urpm::is_local_medium($blist->{medium})) {
		if (my $n = $pkg->filesize) {
		    $filesize += $n;
		}
	    }
	}
    }
    $filesize;
}

=item download_packages_of_distant_media($urpm, $blists, $sources, $error_sources, %options)

Download packages listed in $blists, and put the result in $sources or
$error_sources

Options: quiet, callback, 

=cut

sub download_packages_of_distant_media {
    my ($urpm, $blists, $sources, $error_sources, %options) = @_;

    my %errors;
    my %new_sources;

    #- get back all ftp and http accessible rpm files into the local cache
    foreach my $blist (@$blists) {
	my %blist_distant = (%$blist, pkgs => {});

	#- examine all files to know what can be indexed on multiple media.
	while (my ($id, $pkg) = each %{$blist->{pkgs}}) {
	    #- the given URL is trusted, so the file can safely be ignored.
            if (defined $sources->{$id}) {
		$new_sources{$id} = [ $pkg->id, $sources->{$id} ];
                delete $sources->{$id};
                next;
            }

	    exists $new_sources{$id} and next;
	    if (urpm::is_local_medium($blist->{medium})) {
		my $local_file = file_from_local_url(urpm::blist_pkg_to_url($blist, $pkg));
		if (-r $local_file) {
		    $new_sources{$id} = [ $pkg->id, $local_file ];
		} else {
		    $errors{$id} = [ $local_file, 'missing' ];
		}
	    } else {
		$blist_distant{pkgs}{$id} = $pkg;
	    }
	}

	if (%{$blist_distant{pkgs}}) {
	    my ($remote_sources, $remote_errors) = _download_packages_of_distant_media($urpm, \%blist_distant, %options);
	    put_in_hash(\%new_sources, $remote_sources);
	    put_in_hash(\%errors, $remote_errors);
	}
    }

    #- clean failed download which have succeeded.
    delete @errors{keys %$sources, keys %new_sources};

    foreach (values %new_sources) {
	my ($id, $local_file) = @$_;
	$sources->{$id} = $local_file;
    }

    push @$error_sources, values %errors;

    1;
}

# download packages listed in $blist,
# and put the result in $sources or $errors
sub _download_packages_of_distant_media {
    my ($urpm, $blist, %options) = @_;

    my $cachedir = urpm::valid_cachedir($urpm);
    my (%sources, %errors);

    $urpm->{log}(N("retrieving rpm files from medium \"%s\"...", $blist->{medium}{name}));
    if (urpm::download::sync_rel($urpm, $blist->{medium}, [ urpm::blist_to_filenames($blist) ],
			     dir => "$cachedir/partial", quiet => $options{quiet}, 
			     is_versioned => 1,
			     resume => $urpm->{options}{resume}, 
			     ask_retry => $options{ask_retry},
			     callback => $options{callback})) {
	$urpm->{log}(N("...retrieving done"));
    } else {
	$urpm->{error}(N("...retrieving failed: %s", $@));
    }

    #- clean files that have not been downloaded, but keep in mind
    #- there have been problems downloading them at least once, this
    #- is necessary to keep track of failing downloads in order to
    #- present the error to the user.
    foreach my $id (keys %{$blist->{pkgs}}) {
	my $pkg = $blist->{pkgs}{$id};
	my $filename = $pkg->filename;
	my $url = urpm::blist_pkg_to_url($blist, $pkg);
	if ($filename && -s "$cachedir/partial/$filename") {
	    if (my $rpm = verify_partial_rpm_and_move($urpm, $cachedir, $filename)) {
		$sources{$id} = [ $pkg->id, $rpm ];
	    } else {
		$errors{$id} = [ $url, 'bad' ];
	    }
	} else {
	    $errors{$id} = [ $url, 'missing' ];
	}
    }
    (\%sources, \%errors);
}

1;

__END__

=back

=head1 COPYRIGHT

Copyright (C) 2005 MandrakeSoft SA

Copyright (C) 2005-2010 Mandriva SA

=cut
;{grab_focus}; (delete $opts->{size_group})->add_widget($w) if $opts->{size_group}; if (my $tip = delete $opts->{tip}) { $global_tooltips ||= Gtk2::Tooltips->new; $global_tooltips->set_tip($w, $tip); } if (%$opts && !$opts->{allow_unknown_options}) { internal_error("$action $class: unknown option(s) " . join(', ', keys %$opts)); } $w; } sub _gtk__Button { &_gtk_any_Button } sub _gtk__ToggleButton { &_gtk_any_Button } sub _gtk__CheckButton { &_gtk_any_Button } sub _gtk_any_Button { my ($w, $opts, $class) = @_; if (!$w) { if (!$opts->{image}) { add2hash_($opts, { mnemonic => 1 }); } $w = $opts->{image} ? "Gtk2::$class"->new : delete $opts->{mnemonic} ? "Gtk2::$class"->new_with_mnemonic(delete $opts->{text} || '') : "Gtk2::$class"->new_with_label(delete $opts->{text} || ''); $w->{format} = delete $opts->{format} if exists $opts->{format}; } if (my $image = delete $opts->{image}) { $w->add($image); $image->show; } $w->set_sensitive(delete $opts->{sensitive}) if exists $opts->{sensitive}; $w->set_relief(delete $opts->{relief}) if exists $opts->{relief}; if (my $text_ref = delete $opts->{text_ref}) { my $set = sub { eval { $w->set_label(may_apply($w->{format}, $$text_ref)) }; }; gtkval_register($w, $text_ref, $set); $set->(); } elsif (exists $opts->{text}) { $w->set_label(delete $opts->{text}); } if ($class eq 'Button') { $w->signal_connect(clicked => delete $opts->{clicked}) if exists $opts->{clicked}; } else { if (my $active_ref = delete $opts->{active_ref}) { my $set = sub { $w->set_active($$active_ref) }; $w->signal_connect(toggled => sub { gtkval_modify($active_ref, $w->get_active, $set); }); gtkval_register($w, $active_ref, $set); gtkval_register($w, $active_ref, delete $opts->{toggled}) if exists $opts->{toggled}; $set->(); } else { $w->set_active(delete $opts->{active}) if exists $opts->{active}; $w->signal_connect(toggled => delete $opts->{toggled}) if exists $opts->{toggled}; } } $w; } sub _gtk__CheckMenuItem { my ($w, $opts, $class) = @_; if (!$w) { add2hash_($opts, { mnemonic => 1 }); $w = $opts->{image} || !exists $opts->{text} ? "Gtk2::$class"->new : delete $opts->{mnemonic} ? "Gtk2::$class"->new_with_label(delete $opts->{text}) : "Gtk2::$class"->new_with_mnemonic(delete $opts->{text}); } $w->set_active(delete $opts->{active}) if exists $opts->{active}; $w->signal_connect(toggled => delete $opts->{toggled}) if exists $opts->{toggled}; $w; } sub _gtk___SpinButton { my ($w, $opts) = @_; if (!$w) { $opts->{adjustment} ||= do { add2hash_($opts, { step_increment => 1, page_increment => 5, page_size => 1, value => delete $opts->{lower} }); Gtk2::Adjustment->new(delete $opts->{value}, delete $opts->{lower}, delete $opts->{upper}, delete $opts->{step_increment}, delete $opts->{page_increment}, delete $opts->{page_size}); }; $w = Gtk2::SpinButton->new(delete $opts->{adjustment}, delete $opts->{climb_rate} || 0, delete $opts->{digits} || 0); } $w->signal_connect(value_changed => delete $opts->{value_changed}) if exists $opts->{value_changed}; $w; } sub _gtk__HScale { my ($w, $opts) = @_; if (!$w) { $opts->{adjustment} ||= do { add2hash_($opts, { step_increment => 1, page_increment => 5, page_size => 1, value => delete $opts->{lower} }); Gtk2::Adjustment->new(delete $opts->{value}, delete $opts->{lower}, (delete $opts->{upper}) + 1, delete $opts->{step_increment}, delete $opts->{page_increment}, delete $opts->{page_size}); }; $w = Gtk2::HScale->new(delete $opts->{adjustment}); } $w->signal_connect(value_changed => delete $opts->{value_changed}) if exists $opts->{value_changed}; $w; } sub _gtk__VSeparator { &_gtk_any_simple } sub _gtk__HSeparator { &_gtk_any_simple } sub _gtk__Calendar { &_gtk_any_simple } sub _gtk__DrawingArea { my ($w, $opts) = @_; if (!$w) { $w = Gtk2::DrawingArea->new; } $w->signal_connect(expose_event => delete $opts->{expose_event}) if exists $opts->{expose_event}; $w; } sub _gtk__Pixbuf { my ($w, $opts) = @_; if (!$w) { my $name = delete $opts->{file} or internal_error("missing file"); my $file = _find_imgfile($name) or internal_error("can not find $name"); $w = Gtk2::Gdk::Pixbuf->new_from_file($file); } $w; } sub _gtk__Image { my ($w, $opts, $class) = @_; if (!$w) { $w = "Gtk2::$class"->new; $w->{format} = delete $opts->{format} if exists $opts->{format}; } if (my $name = delete $opts->{file}) { my $file = _find_imgfile(may_apply($w->{format}, $name)) or internal_error("can not find $name"); $w->set_from_file($file); } elsif (my $file_ref = delete $opts->{file_ref}) { my $set = sub { my $file = _find_imgfile(may_apply($w->{format}, $$file_ref)) or internal_error("can not find $$file_ref"); $w->set_from_file($file); }; gtkval_register($w, $file_ref, $set); $set->(); } $w; } sub _gtk__WrappedLabel { my ($w, $opts) = @_; $opts->{line_wrap} = 1; _gtk__Label($w, $opts); } sub _gtk__Label { my ($w, $opts) = @_; if ($w) { $w->set_text(delete $opts->{text}) if exists $opts->{text}; } else { $w = exists $opts->{text} ? Gtk2::Label->new(delete $opts->{text}) : Gtk2::Label->new; $w->set_justify(delete $opts->{justify}) if exists $opts->{justify}; $w->set_line_wrap(delete $opts->{line_wrap}) if exists $opts->{line_wrap}; $w->set_alignment(@{delete $opts->{alignment}}) if exists $opts->{alignment}; $w->modify_font(Gtk2::Pango::FontDescription->from_string(delete $opts->{font})) if exists $opts->{font}; } $w->set_markup(delete $opts->{text_markup}) if exists $opts->{text_markup}; $w; } sub _gtk__Entry { my ($w, $opts) = @_; if (!$w) { $w = Gtk2::Entry->new; $w->set_editable(delete $opts->{editable}) if exists $opts->{editable}; } $w->set_text(delete $opts->{text}) if exists $opts->{text}; $w->signal_connect(key_press_event => delete $opts->{key_press_event}) if exists $opts->{key_press_event}; $w; } sub _gtk__TextView { my ($w, $opts) = @_; if (!$w) { $w = Gtk2::TextView->new; $w->set_editable(delete $opts->{editable}) if exists $opts->{editable}; $w->set_wrap_mode(delete $opts->{wrap_mode}) if exists $opts->{wrap_mode}; $w->set_cursor_visible(delete $opts->{cursor_visible}) if exists $opts->{cursor_visible}; } _text_insert($w, delete $opts->{text}) if exists $opts->{text}; $w; } sub _gtk__ComboBox { my ($w, $opts, $_class, $action) = @_; if (!$w) { $w = Gtk2::ComboBox->new_text; $w->{format} = delete $opts->{format} if exists $opts->{format}; } if (exists $opts->{list}) { $w->{list} = delete $opts->{list}; $w->{formatted_list} = $w->{format} ? [ map { $w->{format}($_) } @{$w->{list}} ] : $w->{list}; $w->append_text($_) foreach @{$w->{formatted_list}}; } if ($action eq 'gtknew') { if (my $text_ref = delete $opts->{text_ref}) { my $set = sub { my $val = may_apply($w->{format}, $$text_ref); eval { $w->set_active(find_index { $_ eq $val } @{$w->{formatted_list}}) }; }; $w->signal_connect(changed => sub { gtkval_modify($text_ref, $w->{list}[$w->get_active], $set); }); gtkval_register($w, $text_ref, $set); gtkval_register($w, $text_ref, delete $opts->{changed}) if exists $opts->{changed}; $set->(); } else { my $val = delete $opts->{text}; eval { $w->set_active(find_index { $_ eq $val } @{$w->{formatted_list}}) } if defined $val; $w->signal_connect(changed => delete $opts->{changed}) if exists $opts->{changed}; } } $w; } sub _gtk__ScrolledWindow { my ($w, $opts, $_class, $action) = @_; if (!$w) { $w = Gtk2::ScrolledWindow->new(undef, undef); $w->set_policy(delete $opts->{h_policy} || 'automatic', delete $opts->{v_policy} || 'automatic'); } if (my $child = delete $opts->{child}) { if (member(ref($child), qw(Gtk2::Layout Gtk2::Text Gtk2::TextView Gtk2::TreeView))) { $w->add($child); } else { $w->add_with_viewport($child); } $child->set_focus_vadjustment($w->get_vadjustment) if $child->can('set_focus_vadjustment'); $child->set_left_margin(6) if ref($child) =~ /Gtk2::TextView/; $child->show; $w->child->set_shadow_type(delete $opts->{shadow_type}) if exists $opts->{shadow_type}; if ($action eq 'gtknew' && ref($child) =~ /Gtk2::TextView|Gtk2::TreeView/) { $w = gtknew('Frame', shadow_type => 'in', child => $w); } } $w; } sub _gtk__Frame { my ($w, $opts) = @_; if ($w) { $w->set_label(delete $opts->{text}) if exists $opts->{text}; } else { $w = Gtk2::Frame->new(delete $opts->{text}); $w->set_border_width(delete $opts->{border_width}) if exists $opts->{border_width}; $w->set_shadow_type(delete $opts->{shadow_type}) if exists $opts->{shadow_type}; } if (my $child = delete $opts->{child}) { $w->add($child); $child->show; } $w; } sub _gtk__Window { &_gtk_any_Window } sub _gtk__Dialog { &_gtk_any_Window } sub _gtk__Plug { &_gtk_any_Window } sub _gtk_any_Window { my ($w, $opts, $class) = @_; if (!$w) { if ($class eq 'Window') { $w = "Gtk2::$class"->new(delete $opts->{type} || 'toplevel'); } elsif ($class eq 'Plug') { $opts->{socket_id} or internal_error("can not create a Plug without a socket_id"); $w = "Gtk2::$class"->new(delete $opts->{socket_id}); } else { $w = "Gtk2::$class"->new; } $w->set_modal(delete $opts->{modal}) if exists $opts->{modal}; $w->set_transient_for(delete $opts->{transient_for}) if exists $opts->{transient_for}; $w->set_border_width(delete $opts->{border_width}) if exists $opts->{border_width}; $w->set_shadow_type(delete $opts->{shadow_type}) if exists $opts->{shadow_type}; $w->set_position(delete $opts->{position_policy}) if exists $opts->{position_policy}; my $icon_no_error = $opts->{icon_no_error}; if (my $name = delete $opts->{icon} || delete $opts->{icon_no_error}) { if (my $f = _find_imgfile($name)) { $w->set_icon(gtknew('Pixbuf', file => $f)); } elsif (!$icon_no_error) { internal_error("can not find $name"); } } } $w->set_title(delete $opts->{title}) if exists $opts->{title}; if (my $child = delete $opts->{child}) { $w->add($child); $child->show; } $w; } sub _gtk__MagicWindow { my ($w, $opts) = @_; my $pop_it = delete $opts->{pop_it} || !$::isWizard && !$::isEmbedded || $::WizardTable && do { #- do not take into account the wizard banner any { !$_->isa('Gtk2::DrawingArea') && $_->visible } $::WizardTable->get_children; }; my $sub_child = delete $opts->{child} or internal_error("missing child"); if ($pop_it) { $opts->{child} = $::isInstall ? gtknew('Frame', shadow_type => 'out', child => gtknew('Frame', shadow_type => 'none', border_width => 3, child => $sub_child)) : $sub_child; $w = _create_Window($opts); } else { if (!$::WizardWindow) { my $banner; if (!$::isEmbedded && !$::isInstall && $::Wizard_title) { $banner = Gtk2::Banner->new($opts->{icon_no_error}, $::Wizard_title) or log::l("ERROR: missing wizard banner"); } $::WizardTable = gtknew('VBox', if_($banner, children_tight => [ $banner ])); if ($::isEmbedded) { add2hash($opts, { socket_id => $::XID, child => $::WizardTable, }); $::Plug = $::WizardWindow = _gtk(undef, 'Plug', 'gtknew', $opts); sync($::WizardWindow); } else { add2hash($opts, { child => gtknew('Frame', shadow_type => 'out', child => $::WizardTable), }); $::WizardWindow = _create_Window($opts); } } else { %$opts = (); } set_main_window_size($::WizardWindow); $sub_child->set_border_width(10); $w = $::WizardWindow; gtkadd($::WizardTable, children_loose => [ $sub_child ]); } bless { real_window => $w, child => $sub_child, pop_it => $pop_it }, 'mygtk2::MagicWindow'; } sub _gtk__FileSelection { my ($w, $opts) = @_; if (!$w) { $w = Gtk2::FileSelection->new(delete $opts->{title} || ''); gtkset($w->ok_button, %{delete $opts->{ok_button}}) if exists $opts->{ok_button}; gtkset($w->cancel_button, %{delete $opts->{cancel_button}}) if exists $opts->{cancel_button}; } $w; } sub _gtk__FileChooser { my ($w, $opts) = @_; #- no nice way to have a {file_ref} on a FileChooser since selection_changed only works for browsing, not file/folder creation if (!$w) { my $action = delete $opts->{action} || internal_error("missing action for FileChooser"); $w = Gtk2::FileChooserWidget->new($action); my $file = $opts->{file} && delete $opts->{file}; if (my $dir = delete $opts->{directory} || $file && dirname($file)) { $w->set_current_folder($dir); } if ($file) { my $meth = $action =~ /save|create/ ? 'set_current_name' : 'set_filename'; $w->$meth($file); } } $w; } sub _gtk__VBox { &_gtk_any_Box } sub _gtk__HBox { &_gtk_any_Box } sub _gtk_any_Box { my ($w, $opts, $class, $action) = @_; if (!$w) { $w = "Gtk2::$class"->new(0,0); $w->set_homogeneous(delete $opts->{homogenous}) if exists $opts->{homogenous}; $w->set_spacing(delete $opts->{spacing}) if exists $opts->{spacing}; $w->set_border_width(delete $opts->{border_width}) if exists $opts->{border_width}; } elsif ($action eq 'gtkset') { $_->destroy foreach $w->get_children; } _gtknew_handle_children($w, $opts); $w; } sub _gtk__VButtonBox { &_gtk_any_ButtonBox } sub _gtk__HButtonBox { &_gtk_any_ButtonBox } sub _gtk_any_ButtonBox { my ($w, $opts, $class, $action) = @_; if (!$w) { $w = "Gtk2::$class"->new; $w->set_layout(delete $opts->{layout} || 'spread'); } elsif ($action eq 'gtkset') { $_->destroy foreach $w->get_children; } _gtknew_handle_children($w, $opts); $w; } sub _gtk__Notebook { my ($w, $opts) = @_; if (!$w) { $w = Gtk2::Notebook->new; $w->set_property('show-tabs', delete $opts->{show_tabs}) if exists $opts->{show_tabs}; $w->set_property('show-border', delete $opts->{show_border}) if exists $opts->{show_border}; } if (exists $opts->{children}) { foreach (group_by2(@{delete $opts->{children}})) { my ($title, $page) = @$_; $w->append_page($page, $title); $page->show; $title->show; } } $w; } sub _gtk__Table { my ($w, $opts) = @_; if (!$w) { add2hash_($opts, { xpadding => 5, ypadding => 0, border_width => $::isInstall ? 3 : 10 }); $w = Gtk2::Table->new(0, 0, delete $opts->{homogeneous} || 0); $w->set_col_spacings(delete $opts->{col_spacings} || 0); $w->set_row_spacings(delete $opts->{row_spacings} || 0); $w->set_border_width(delete $opts->{border_width}); $w->{$_} = delete $opts->{$_} foreach 'xpadding', 'ypadding', 'mcc'; } each_index { my ($i, $l) = ($::i, $_); each_index { my $j = $::i; if ($_) { ref $_ or $_ = Gtk2::WrappedLabel->new($_); $j != $#$l && !$w->{mcc} ? $w->attach($_, $j, $j + 1, $i, $i + 1, 'fill', 'fill', $w->{xpadding}, $w->{ypadding}) : $w->attach($_, $j, $j + 1, $i, $i + 1, ['expand', 'fill'], ref($_) eq 'Gtk2::ScrolledWindow' || $_->get_data('must_grow') ? ['expand', 'fill'] : [], 0, 0); $_->show; } } @$l; } @{delete $opts->{children} || []}; $w; } sub _gtk_any_simple { my ($w, $_opts, $class) = @_; $w ||= "Gtk2::$class"->new; } sub _gtknew_handle_children { my ($w, $opts) = @_; my @child = exists $opts->{children_tight} ? map { [ 0, $_ ] } @{delete $opts->{children_tight}} : exists $opts->{children_loose} ? map { [ 1, $_ ] } @{delete $opts->{children_loose}} : exists $opts->{children} ? group_by2(@{delete $opts->{children}}) : (); my $padding = delete $opts->{padding}; foreach (@child) { my ($fill, $child) = @$_; $fill eq '0' || $fill eq '1' or internal_error("odd {children} parameter must be 0 or 1 (got $fill)"); ref $child or $child = Gtk2::WrappedLabel->new($child); $w->pack_start($child, $fill, $fill, $padding || 0); $child->show; } } #- this magic function redirects method calls: #- * default is to redirect them to the {child} #- * if the {child} doesn't handle the method, we try with the {real_window} #- (eg : add_accel_group set_position set_default_size #- * a few methods are handled specially my %for_real_window = map { $_ => 1 } qw(show_all size_request); sub mygtk2::MagicWindow::AUTOLOAD { my ($w, @args) = @_; my ($meth) = $mygtk2::MagicWindow::AUTOLOAD =~ /mygtk2::MagicWindow::(.*)/; my ($s1, $s2) = $meth eq 'show' ? ('real_window', 'child') : $meth eq 'get' && $args[0] eq 'window-position' || $w->{pop_it} && ($meth eq 'destroy' || $meth eq 'hide') || $for_real_window{$meth} || !$w->{child}->can($meth) ? 'real_window' : 'child'; #- warn "mygtk2::MagicWindow::$meth", first($w =~ /HASH(.*)/), " on $s1 (@args)\n"; $w->{$s2}->$meth(@args) if $s2; $w->{$s1}->$meth(@args); } sub _create_Window { my ($opts) = @_; my $no_Window_Manager = !$::isStandalone; add2hash($opts, { if_(!$::isInstall && !$::isWizard, border_width => 5), #- policy: during install, we need a special code to handle the weird centering, see below position_policy => $::isInstall ? 'none' : $no_Window_Manager ? 'center-always' : 'center-on-parent', if_($::isInstall, position => [ $::rootwidth - ($::windowwidth + $::real_windowwidth) / 2, $::logoheight + ($::windowheight - $::real_windowheight) / 2, ]), }); my $w = _gtk(undef, 'Window', 'gtknew', $opts); #- when the window is closed using the window manager "X" button (or alt-f4) $w->signal_connect(delete_event => sub { if ($::isWizard) { $w->destroy; die 'wizcancel'; } else { Gtk2->main_quit; } }); if ($no_Window_Manager) { _force_keyboard_focus($w); } if ($::isInstall) { require install_gtk; #- for perl_checker install_gtk::handle_unsafe_mouse($::o, $w); $w->signal_connect(key_press_event => \&install_gtk::special_shortcuts); #- force center at a weird position, this can't be handled by position_policy #- because center-on-parent is a window manager hint, and we don't have a WM my ($wi, $he); $w->signal_connect(size_allocate => sub { my (undef, $event) = @_; my @w_size = $event->values; return if $w_size[2] == $wi && $w_size[3] == $he; #BUG (undef, undef, $wi, $he) = @w_size; $w->set_uposition(max(0, $::rootwidth - ($::windowwidth + $wi) / 2), max(0, $::logoheight + ($::windowheight - $he) / 2)); }); #- without this, the focus is broken during install, though this is not needed during X test, why?? $w->show; } $w; } my $current_window; sub _force_keyboard_focus { my ($w) = @_; sub _XSetInputFocus { my ($w) = @_; if ($current_window == $w) { $w->window->XSetInputFocus; } else { log::l("not XSetInputFocus since already done and not on top"); } 0; } #- force keyboard focus instead of mouse focus my $previous_current_window = $current_window; $current_window = $w; $w->signal_connect(expose_event => \&_XSetInputFocus); $w->signal_connect(destroy => sub { $current_window = $previous_current_window }); } sub _find_imgfile { my ($name) = @_; if ($name =~ m|/| && -f $name) { $name; } else { foreach my $path (_icon_paths()) { foreach ('', '.png', '.xpm') { my $file = "$path/$name$_"; -f $file and return $file; } } } } # _text_insert() can be used with any of choose one of theses styles: # - no tags: # _text_insert($textview, "My text.."); # - anonymous tags: # _text_insert($textview, [ [ 'first text', { 'foreground' => 'blue', 'background' => 'green', ... } ], # [ 'second text' ], # [ 'third', { 'font' => 'Serif 15', ... } ], # ... ]); # - named tags: # $textview->{tags} = { # 'blue_green' => { 'foreground' => 'blue', 'background' => 'green', ... }, # 'big_font' => { 'font' => 'Serif 35', ... }, # } # _text_insert($textview, [ [ 'first text', 'blue_green' ], # [ 'second', 'big_font' ], # ... ]); # - mixed anonymous and named tags: # $textview->{tags} = { # 'blue_green' => { 'foreground' => 'blue', 'background' => 'green', ... }, # 'big_font' => { 'font' => 'Serif 35', ... }, # } # _text_insert($textview, [ [ 'first text', 'blue_green' ], # [ 'second text' ], # [ 'third', 'big_font' ], # [ 'fourth', { 'font' => 'Serif 15', ... } ], # ... ]); sub _text_insert { my ($textview, $t, %opts) = @_; my $buffer = $textview->get_buffer; $buffer->{tags} ||= {}; $buffer->{gtk_tags} ||= {}; my $gtk_tags = $buffer->{gtk_tags}; my $tags = $buffer->{tags}; if (ref($t) eq 'ARRAY') { $opts{append} or $buffer->set_text(''); foreach my $token (@$t) { my ($item, $tag) = @$token; my $iter1 = $buffer->get_end_iter; if ($item =~ /^Gtk2::Gdk::Pixbuf/) { $buffer->insert_pixbuf($iter1, $item); next; } if ($tag) { if (ref($tag)) { # use anonymous tags $buffer->insert_with_tags($iter1, $item, $buffer->create_tag(undef, %$tag)); } else { # fast text insertion: # since in some contexts (eg: localedrake, rpmdrake), we use quite a lot of identical tags, # it's much more efficient and less memory pressure to use named tags $gtk_tags->{$tag} ||= $buffer->create_tag($tag, %{$tags->{$token->[1]}}); $buffer->insert_with_tags($iter1, $item, $gtk_tags->{$tag}); } } else { $buffer->insert($iter1, $item); } } } else { $buffer->set_text($t); } #- the following line is needed to move the cursor to the beginning, so that if the #- textview has a scrollbar, it will not scroll to the bottom when focusing (#3633) $buffer->place_cursor($buffer->get_start_iter); $textview->set_wrap_mode($opts{wrap_mode} || 'word'); $textview->set_editable($opts{editable} || 0); $textview->set_cursor_visible($opts{visible} || 0); $textview; } sub set_main_window_size { my ($window) = @_; my ($width, $height) = $::isInstall ? ($::real_windowwidth, $::real_windowheight) : $::isWizard ? (540, 360) : (600, 400); $window->set_size_request($width, $height); } my @icon_paths; sub add_icon_path { push @icon_paths, @_ } sub _icon_paths() { (@icon_paths, (exists $ENV{SHARE_PATH} ? ($ENV{SHARE_PATH}, "$ENV{SHARE_PATH}/icons", "$ENV{SHARE_PATH}/libDrakX/pixmaps") : ()), "/usr/lib/libDrakX/icons", "pixmaps", 'standalone/icons', '/usr/share/rpmdrake/icons'); } sub main { my ($window, $o_verif) = @_; my $destroyed; $window->signal_connect(destroy => sub { $destroyed = 1 }); $window->show; do { Gtk2->main } while (!$destroyed && $o_verif && !$o_verif->()); may_destroy($window); flush(); } sub sync { my ($window) = @_; $window->show; flush(); } sub flush() { Gtk2->main_iteration while Gtk2->events_pending; } sub may_destroy { my ($w) = @_; $w->destroy if $w; } sub root_window() { my $root if 0; $root ||= Gtk2::Gdk->get_default_root_window; } sub rgb2color { my ($r, $g, $b) = @_; my $color = Gtk2::Gdk::Color->new($r, $g, $b); root_window()->get_colormap->rgb_find_color($color); $color; } sub set_root_window_background { my ($r, $g, $b) = @_; my $root = root_window(); my $gc = Gtk2::Gdk::GC->new($root); my $color = rgb2color($r, $g, $b); $gc->set_rgb_fg_color($color); set_root_window_background_with_gc($gc); } sub set_root_window_background_with_gc { my ($gc) = @_; my $root = root_window(); my ($w, $h) = $root->get_size; $root->set_background($gc->get_values->{foreground}); $root->draw_rectangle($gc, 1, 0, 0, $w, $h); } 1;