package mygtk2;
use diagnostics;
use strict;
use feature 'state';
our @ISA = qw(Exporter);
our @EXPORT = qw(gtknew gtkset gtkadd gtkval_register gtkval_modify);
use c;
use log;
use common;
use Gtk2;
sub init() {
!check_for_xserver() and print("Cannot be run in console mode.\n"), c::_exit(0);
$::one_message_has_been_translated and warn("N() was called from $::one_message_has_been_translated BEFORE gtk2 initialisation, replace it with a N_() AND a translate() later.\n"), c::_exit(1);
Gtk2->init;
Locale::gettext::bind_textdomain_codeset($_, 'UTF8') foreach 'libDrakX', if_(!$::isInstall, 'libDrakX-standalone'),
if_($::isRestore, 'draksnapshot'), if_($::isInstall, 'urpmi'),
'drakx-net', 'drakx-kbd-mouse-x11', # shared translation
@::textdomains;
Glib->enable_exceptions2;
}
init() unless $::no_ugtk_init;
Glib->enable_exceptions2 if $::isInstall;
sub gtknew {
my $class = shift;
if (@_ % 2 != 0) {
internal_error("gtknew $class: bad options @_");
}
if (my $r = find { ref $_->[0] } group_by2(@_)) {
internal_error("gtknew $class: $r should be a string in @_");
}
my %opts = @_;
_gtk(undef, $class, 'gtknew', \%opts);
}
sub gtkset {
my $w = shift;
my $class = ref($w);
if (@_ % 2 != 0) {
internal_error("gtkset $class: bad options @_");
}
if (my $r = find { ref $_->[0] } group_by2(@_)) {
internal_error("gtkset $class: $r should be a string in @_");
}
my %opts = @_;
$class =~ s/^(Gtk2|Gtk2::Gdk|mygtk2)::// or internal_error("gtkset unknown class $class");
_gtk($w, $class, 'gtkset', \%opts);
}
sub gtkadd {
my $w = shift;
my $class = ref($w);
if (@_ % 2 != 0) {
internal_error("gtkadd $class: bad options @_");
}
if (my $r = find { ref $_->[0] } group_by2(@_)) {
internal_error("gtkadd $class: $r should be a string in @_");
}
my %opts = @_;
$class =~ s/^(Gtk2|Gtk2::Gdk|mygtk2)::// or internal_error("gtkadd unknown class $class");
_gtk($w, $class, 'gtkadd', \%opts);
}
my %refs;
sub gtkval_register {
my ($w, $ref, $sub) = @_;
push @{$w->{_ref}}, $ref;
$w->signal_connect(destroy => sub {
@{$refs{$ref}} = grep { $_->[1] != $w } @{$refs{$ref}};
delete $refs{$ref} if !@{$refs{$ref}};
});
push @{$refs{$ref}}, [ $sub, $w ];
}
sub gtkval_modify {
my ($ref, $val, @to_skip) = @_;
my $prev = '' . $ref;
$$ref = $val;
if ($prev ne '' . $ref) {
internal_error();
}
foreach (@{$refs{$ref} || []}) {
my ($f, @para) = @$_;
$f->(@para) if !member($f, @to_skip);
}
}
my $global_tooltips;
sub _gtk {
my ($w, $class, $action, $opts) = @_;
if (my $f = $mygtk2::{"_gtk__$class"}) {
$w = $f->($w, $opts, $class, $action);
} else {
internal_error("$action $class: unknown class");
}
$w->set_size_request(delete $opts->{width} || -1, delete $opts->{height} || -1) if exists $opts->{width} || exists $opts->{height};
if (my $position = delete $opts->{position}) {
$w->move($position->[0], $position->[1]);
}
$w->set_name(delete $opts->{widget_name}) if exists $opts->{widget_name};
$w->can_focus(delete $opts->{can_focus}) if exists $opts->{can_focus};
$w->can_default(delete $opts->{can_default}) if exists $opts->{can_default};
$w->grab_focus if delete $opts->{grab_focus};
$w->set_padding(@{delete $opts->{padding}}) if exists $opts->{padding};
$w->set_sensitive(delete $opts->{sensitive}) if exists $opts->{sensitive};
$w->signal_connect(expose_event => delete $opts->{expose_event}) if exists $opts->{expose_event};
$w->signal_connect(realize => delete $opts->{realize}) if exists $opts->{realize};
(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);
}
#- WARNING: hide_ref and show_ref are not effective until you gtkval_modify the ref
if (my $hide_ref = delete $opts->{hide_ref}) {
gtkval_register($w, $hide_ref, sub { $$hide_ref ? $w->hide : $w->show });
} elsif (my $show_ref = delete $opts->{show_ref}) {
gtkval_register($w, $show_ref, sub { $$show_ref ? $w->show : $w->hide });
}
if (my $sensitive_ref = delete $opts->{sensitive_ref}) {
my $set = sub { $w->set_sensitive($$sensitive_ref) };
gtkval_register($w, $sensitive_ref, $set);
$set->();
}
if (%$opts && !$opts->{allow_unknown_options}) {
internal_error("$action $class: unknown option(s) " . join(', ', keys %$opts));
}
$w;
}
sub _gtk__Install_Button {
my ($w, $opts, $_class) = @_;
$opts->{child} = gtknew('HBox', spacing => 5,
children_tight => [
# FIXME: not RTL compliant (lang::text_direction_rtl() ? ...)
gtknew('Image', file => 'advanced_expander'),
gtknew('Label', text => delete $opts->{text}),
],
);
$opts->{relief} = 'none';
_gtk__Button($w, $opts, 'Button');
}
sub _gtk__Button { &_gtk_any_Button }
sub _gtk__ToggleButton { &_gtk_any_Button }
sub _gtk__CheckButton { &_gtk_any_Button }
sub _gtk__RadioButton { &_gtk_any_Button }
sub _gtk_any_Button {
my ($w, $opts, $class) = @_;
|