buildadm
/
ubuntu-22.04.3-desktop-amd64
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
ubuntu-22.04.3-desktop-amd64/casper/filesystem/usr/share/perl5/Gtk3.pm

2595 lines
77 KiB
Perl
Raw Permalink Blame History

package Gtk3;
$Gtk3::VERSION = '0.038';
=encoding utf8
=head1 NAME
Gtk3 - Perl interface to the 3.x series of the gtk+ toolkit
=head1 SYNOPSIS
use Gtk3 -init;
my $window = Gtk3::Window->new ('toplevel');
my $button = Gtk3::Button->new ('Quit');
$button->signal_connect (clicked => sub { Gtk3::main_quit });
$window->add ($button);
$window->show_all;
Gtk3::main;
=head1 ABSTRACT
Perl bindings to the 3.x series of the gtk+ toolkit. This module allows you to
write graphical user interfaces in a Perlish and object-oriented way, freeing
you from the casting and memory management in C, yet remaining very close in
spirit to original API.
=head1 DESCRIPTION
The C<Gtk3> module allows a Perl developer to use the gtk+ graphical user
interface library. Find out more about gtk+ at L<http://www.gtk.org>.
The gtk+ reference manual is also a handy companion when writing C<Gtk3>
programs in Perl: L<http://developer.gnome.org/gtk3/stable/>. The Perl
bindings follow the C API very closely, and the C reference documentation
should be considered the canonical source. The principles underlying the
mapping from C to Perl are explained in the documentation of
L<Glib::Object::Introspection>, on which C<Gtk3> is based.
L<Glib::Object::Introspection> also comes with the C<perli11ndoc> program which
displays the API reference documentation of all installed libraries organized
in accordance with these principles.
=cut
use strict;
use warnings;
use Carp qw/croak/;
use Cairo::GObject;
use Glib::Object::Introspection;
use Exporter;
our @ISA = qw(Exporter);
=head2 Wrapped libraries
C<Gtk3> automatically sets up the following correspondence between C libraries
and Perl packages:
Library | Package
--------------+----------
Gtk-3.0 | Gtk3
Gdk-3.0 | Gtk3::Gdk
GdkPixbuf-2.0 | Gtk3::Gdk
GdkPixdata-2.0| Gtk3::Gdk
Pango-1.0 | Pango
=cut
=head2 Import arguments
When importing C<Gtk3>, you can pass C<-init> as in C<< use Gtk3 -init; >> to
have C<Gtk3::init> automatically called. You can also pass a version number to
require a certain version of C<Gtk3>.
=cut
my $_GTK_BASENAME = 'Gtk';
my $_GTK_VERSION = '3.0';
my $_GTK_PACKAGE = 'Gtk3';
my $_GDK_BASENAME = 'Gdk';
my $_GDK_VERSION = '3.0';
my $_GDK_PACKAGE = 'Gtk3::Gdk';
my $_GDK_PIXBUF_BASENAME = 'GdkPixbuf';
my $_GDK_PIXBUF_VERSION = '2.0';
my $_GDK_PIXBUF_PACKAGE = 'Gtk3::Gdk';
my $_GDK_PIXDATA_BASENAME = 'GdkPixdata';
my $_GDK_PIXDATA_VERSION = '2.0';
my $_GDK_PIXDATA_PACKAGE = 'Gtk3::Gdk';
my $_PANGO_BASENAME = 'Pango';
my $_PANGO_VERSION = '1.0';
my $_PANGO_PACKAGE = 'Pango';
=head2 Customizations and overrides
In order to make things more Perlish or to make porting from C<Gtk2> to C<Gtk3>
easier, C<Gtk3> customizes the API generated by L<Glib::Object::Introspection>
in a few spots:
=over
=cut
# - Customizations ---------------------------------------------------------- #
=item * The array ref normally returned by the following functions is flattened
into a list:
=over
=item Gtk3::ActionGroup::list_actions
=item Gtk3::Builder::get_objects
=item Gtk3::CellLayout::get_cells
=item Gtk3::Container::get_children
=item Gtk3::SizeGroup::get_widgets
=item Gtk3::TreePath::get_indices
=item Gtk3::TreeView::get_columns
=item Gtk3::UIManager::get_action_groups
=item Gtk3::UIManager::get_toplevels
=item Gtk3::Window::list_toplevels
=item Gtk3::stock_list_ids
=item Gtk3::Gdk::Pixbuf::get_formats
=back
=cut
my @_GTK_FLATTEN_ARRAY_REF_RETURN_FOR = qw/
Gtk3::ActionGroup::list_actions
Gtk3::Builder::get_objects
Gtk3::CellLayout::get_cells
Gtk3::Container::get_children
Gtk3::SizeGroup::get_widgets
Gtk3::TreePath::get_indices
Gtk3::TreeView::get_columns
Gtk3::UIManager::get_action_groups
Gtk3::UIManager::get_toplevels
Gtk3::Window::list_toplevels
Gtk3::stock_list_ids
/;
my @_GDK_PIXBUF_FLATTEN_ARRAY_REF_RETURN_FOR = qw/
Gtk3::Gdk::Pixbuf::get_formats
/;
=item * The following functions normally return a boolean and additional out
arguments, where the boolean indicates whether the out arguments are valid.
They are altered such that when the boolean is true, only the additional out
arguments are returned, and when the boolean is false, an empty list is
returned.
=over
=item Gtk3::TextBuffer::get_selection_bounds
=item Gtk3::TreeModel::get_iter
=item Gtk3::TreeModel::get_iter_first
=item Gtk3::TreeModel::get_iter_from_string
=item Gtk3::TreeModel::iter_children
=item Gtk3::TreeModel::iter_nth_child
=item Gtk3::TreeModel::iter_parent
=item Gtk3::TreeModelFilter::convert_child_iter_to_iter
=item Gtk3::TreeModelSort::convert_child_iter_to_iter
=item Gtk3::TreeSelection::get_selected
=item Gtk3::TreeView::get_dest_row_at_pos
=item Gtk3::TreeView::get_path_at_pos
=item Gtk3::TreeView::get_tooltip_context
=item Gtk3::TreeView::get_visible_range
=item Gtk3::TreeViewColumn::cell_get_position
=item Gtk3::stock_lookup
=item Gtk3::Gdk::Event::get_axis
=item Gtk3::Gdk::Event::get_button
=item Gtk3::Gdk::Event::get_click_count
=item Gtk3::Gdk::Event::get_coords
=item Gtk3::Gdk::Event::get_keycode
=item Gtk3::Gdk::Event::get_keyval
=item Gtk3::Gdk::Event::get_scroll_direction
=item Gtk3::Gdk::Event::get_scroll_deltas
=item Gtk3::Gdk::Event::get_state
=item Gtk3::Gdk::Event::get_root_coords
=item Gtk3::Gdk::Window::get_origin
=back
=cut
my @_GTK_HANDLE_SENTINEL_BOOLEAN_FOR = qw/
Gtk3::TextBuffer::get_selection_bounds
Gtk3::TreeModel::get_iter
Gtk3::TreeModel::get_iter_first
Gtk3::TreeModel::get_iter_from_string
Gtk3::TreeModel::iter_children
Gtk3::TreeModel::iter_nth_child
Gtk3::TreeModel::iter_parent
Gtk3::TreeModelFilter::convert_child_iter_to_iter
Gtk3::TreeModelSort::convert_child_iter_to_iter
Gtk3::TreeSelection::get_selected
Gtk3::TreeView::get_dest_row_at_pos
Gtk3::TreeView::get_path_at_pos
Gtk3::TreeView::get_tooltip_context
Gtk3::TreeView::get_visible_range
Gtk3::TreeViewColumn::cell_get_position
Gtk3::stock_lookup
/;
my @_GDK_HANDLE_SENTINEL_BOOLEAN_FOR = qw/
Gtk3::Gdk::Event::get_axis
Gtk3::Gdk::Event::get_button
Gtk3::Gdk::Event::get_click_count
Gtk3::Gdk::Event::get_coords
Gtk3::Gdk::Event::get_keycode
Gtk3::Gdk::Event::get_keyval
Gtk3::Gdk::Event::get_scroll_direction
Gtk3::Gdk::Event::get_scroll_deltas
Gtk3::Gdk::Event::get_state
Gtk3::Gdk::Event::get_root_coords
Gtk3::Gdk::Window::get_origin
/;
my @_GTK_USE_GENERIC_SIGNAL_MARSHALLER_FOR = (
['Gtk3::Editable', 'insert-text'],
['Gtk3::Dialog', 'response', \&Gtk3::Dialog::_gtk3_perl_response_converter],
['Gtk3::InfoBar', 'response', \&Gtk3::Dialog::_gtk3_perl_response_converter],
);
=item * Values of type Gtk3::ResponseType are converted to and from nick names
if possible, while still allowing raw IDs, in the following places:
=over
=item - For Gtk3::Dialog and Gtk3::InfoBar: the signal C<response> as well as
the methods C<add_action_widget>, C<add_button>, C<add_buttons>, C<response>,
C<set_default_response> and C<set_response_sensitive>.
=item - For Gtk3::Dialog: the methods C<get_response_for_widget>,
C<get_widget_for_response>, C<run> and C<set_alternative_button_order>.
=back
=cut
# GtkResponseType: id <-> nick
my $_GTK_RESPONSE_ID_TO_NICK = sub {
my ($id) = @_;
{
local $@;
my $nick = eval { Glib::Object::Introspection->convert_enum_to_sv (
'Gtk3::ResponseType', $id) };
return $nick if defined $nick;
}
return $id;
};
my $_GTK_RESPONSE_NICK_TO_ID = sub {
my ($nick) = @_;
{
local $@;
my $id = eval { Glib::Object::Introspection->convert_sv_to_enum (
'Gtk3::ResponseType', $nick) };
return $id if defined $id;
}
return $nick;
};
# Converter for GtkDialog's "response" signal.
sub Gtk3::Dialog::_gtk3_perl_response_converter {
my ($dialog, $id, $data) = @_;
return ($dialog, $_GTK_RESPONSE_ID_TO_NICK->($id), $data);
}
=item * Values of type Gtk3::IconSize are converted to and from nick names if
possible, while still allowing raw IDs, in the following places:
=over
=item - Gtk3::Image: the constructors new_from_stock, new_from_icon_set,
new_from_icon_name and new_from_gicon, the getters get_stock, get_icon_set,
get_icon_name and get_gicon and the setters set_from_stock, set_from_icon_set,
set_from_icon_name, set_from_gicon.
=item - Gtk3::Widget: the method render_icon.
=back
=cut
# GtkIconSize: id <-> nick
my $_GTK_ICON_SIZE_ID_TO_NICK = sub {
my ($id) = @_;
{
local $@;
my $nick = eval { Glib::Object::Introspection->convert_enum_to_sv (
'Gtk3::IconSize', $id) };
return $nick if defined $nick;
}
{
my $nick = Gtk3::IconSize::get_name ($id);
return $nick if defined $nick;
}
return $id;
};
my $_GTK_ICON_SIZE_NICK_TO_ID = sub {
my ($nick) = @_;
{
local $@;
my $id = eval { Glib::Object::Introspection->convert_sv_to_enum (
'Gtk3::IconSize', $nick) };
return $id if defined $id;
}
{
my $id = Gtk3::IconSize::from_name ($nick);
return $id if $id;# if it's not zero
}
return $nick;
};
=item * The constants C<Gtk3::EVENT_PROPAGATE> and C<Gtk3::EVENT_STOP> can be
used in handlers for event signals like C<key-press-event> to indicate whether
or not the event should continue propagating through the widget hierarchy.
=cut
# Names "STOP" and "PROPAGATE" here are per the GtkWidget event signal
# descriptions. In some other flavours of signals the jargon is "handled"
# instead of "stop". "Handled" matches g_signal_accumulator_true_handled(),
# though that function doesn't rate a mention in the Gtk docs. There's
# nothing fixed in the idea of "true means cease emission" (whether it's
# called "stop" or "handled"). You can just as easily have false for cease
# (the way the underlying GSignalAccumulator func in fact operates). The
# upshot being don't want to attempt to be too universal with the names
# here; "EVENT" is meant to hint at the context or signal flavour they're
# for use with.
sub Gtk3::EVENT_PROPAGATE() { !1 };
sub Gtk3::EVENT_STOP() { 1 };
=item * The records corresponding to the various Gtk3::Gdk::Event types, like
C<expose> or C<key-release>, are represented as objects blessed into specific
Perl packages, like C<Gtk3::Gdk::EventExpose> or C<Gtk3::Gdk::EventKey>, that
all inherit from C<Gtk3::Gdk::Event>. This allows you to seemlessly access
type-specific fields as well as common fields, as in C<< $event->window >> or
C<< $event->keyval >>.
=cut
my %_GDK_REBLESSERS = (
'Gtk3::Gdk::Event' => \&Gtk3::Gdk::Event::_rebless,
);
my %_GDK_EVENT_TYPE_TO_PACKAGE = (
'expose' => 'Expose',
'motion-notify' => 'Motion',
'button-press' => 'Button',
'2button-press' => 'Button',
'3button-press' => 'Button',
'button-release' => 'Button',
'key-press' => 'Key',
'key-release' => 'Key',
'enter-notify' => 'Crossing',
'leave-notify' => 'Crossing',
'focus-change' => 'Focus',
'configure' => 'Configure',
'property-notify' => 'Property',
'selection-clear' => 'Selection',
'selection-request' => 'Selection',
'selection-notify' => 'Selection',
'proximity-in' => 'Proximity',
'proximity-out' => 'Proximity',
'drag-enter' => 'DND',
'drag-leave' => 'DND',
'drag-motion' => 'DND',
'drag-status' => 'DND',
'drop-start' => 'DND',
'drop-finished' => 'DND',
'client-event' => 'Client',
'visibility-notify' => 'Visibility',
'no-expose' => 'NoExpose',
'scroll' => 'Scroll',
'window-state' => 'WindowState',
'setting' => 'Setting',
'owner-change' => 'OwnerChange',
'grab-broken' => 'GrabBroken',
'damage' => 'Expose',
# added in 3.4:
'touch-begin' => 'Touch',
'touch-update' => 'Touch',
'touch-end' => 'Touch',
'touch-cancel' => 'Touch',
# added in 3.6:
'double-button-press' => 'Button',
'triple-button-press' => 'Button',
);
# Make all of the above sub-types inherit from Gtk3::Gdk::Event.
{
no strict qw(refs);
my %seen;
foreach (grep { !$seen{$_}++ } values %_GDK_EVENT_TYPE_TO_PACKAGE) {
push @{'Gtk3::Gdk::Event' . $_ . '::ISA'}, 'Gtk3::Gdk::Event';
}
}
sub Gtk3::Gdk::Event::_rebless {
my ($event) = @_;
my $package = 'Gtk3::Gdk::Event';
if (exists $_GDK_EVENT_TYPE_TO_PACKAGE{$event->type}) {
$package .= $_GDK_EVENT_TYPE_TO_PACKAGE{$event->type};
}
return bless $event, $package;
}
# - Wiring ------------------------------------------------------------------ #
=item * Gtk3::Gdk::Atom has overloads for the C<==> and C<!=> operators that
check for equality of the underlying atoms.
=cut
sub import {
my $class = shift;
Glib::Object::Introspection->setup (
basename => $_GTK_BASENAME,
version => $_GTK_VERSION,
package => $_GTK_PACKAGE,
flatten_array_ref_return_for => \@_GTK_FLATTEN_ARRAY_REF_RETURN_FOR,
handle_sentinel_boolean_for => \@_GTK_HANDLE_SENTINEL_BOOLEAN_FOR,
use_generic_signal_marshaller_for => \@_GTK_USE_GENERIC_SIGNAL_MARSHALLER_FOR);
Glib::Object::Introspection->setup (
basename => $_GDK_BASENAME,
version => $_GDK_VERSION,
package => $_GDK_PACKAGE,
handle_sentinel_boolean_for => \@_GDK_HANDLE_SENTINEL_BOOLEAN_FOR,
reblessers => \%_GDK_REBLESSERS);
Glib::Object::Introspection->setup (
basename => $_GDK_PIXBUF_BASENAME,
version => $_GDK_PIXBUF_VERSION,
package => $_GDK_PIXBUF_PACKAGE,
flatten_array_ref_return_for => \@_GDK_PIXBUF_FLATTEN_ARRAY_REF_RETURN_FOR);
# In gdk-pixbuf 2.38.0, the GdkPixdata introspection information was split
# out into its own file.
if (Gtk3::Gdk::Pixbuf::CHECK_VERSION (2, 38, 0)) {
Glib::Object::Introspection->setup (
basename => $_GDK_PIXDATA_BASENAME,
version => $_GDK_PIXDATA_VERSION,
package => $_GDK_PIXDATA_PACKAGE);
}
Glib::Object::Introspection->setup (
basename => $_PANGO_BASENAME,
version => $_PANGO_VERSION,
package => $_PANGO_PACKAGE);
Glib::Object::Introspection->_register_boxed_synonym (
"cairo", "RectangleInt", "gdk_rectangle_get_type");
# FIXME: This uses an undocumented interface for overloading to avoid the
# need for a package declaration.
Gtk3::Gdk::Atom->overload::OVERLOAD (
'==' => sub { ${$_[0]} == ${$_[1]} },
'!=' => sub { ${$_[0]} != ${$_[1]} },
fallback => 1);
my $init = 0;
my @unknown_args = ($class);
foreach (@_) {
if (/^-?init$/) {
$init = 1;
} else {
push @unknown_args, $_;
}
}
if ($init) {
Gtk3::init ();
}
# call into Exporter for the unrecognized arguments; handles exporting and
# version checking
Gtk3->export_to_level (1, @unknown_args);
}
# - Overrides --------------------------------------------------------------- #
=item * For backwards compatibility, the functions C<Gtk3::get_version_info>
and C<Gtk3::GET_VERSION_INFO> are provided, and the functions
C<Gtk3::CHECK_VERSION>, C<Gtk3::check_version>, C<Gtk3::init>,
C<Gtk3::init_check>, C<Gtk3::main>, C<Gtk3::main_level> and C<Gtk3::main_quit>
can be called as class-static or as normal functions: for example, C<<
Gtk3->main_quit >> and C<< Gtk3::main_quit >> are both supported.
Additionally, C<Gtk3::init> and C<Gtk3::init_check> automatically handle
passing and updating C<@ARGV> as appropriate.
=cut
sub Gtk3::get_version_info {
return Gtk3::get_major_version (),
Gtk3::get_minor_version (),
Gtk3::get_micro_version ();
}
sub Gtk3::GET_VERSION_INFO {
return Gtk3->MAJOR_VERSION, Gtk3->MINOR_VERSION, Gtk3->MICRO_VERSION;
}
sub Gtk3::CHECK_VERSION {
return not defined Gtk3::check_version(@_ == 4 ? @_[1..3] : @_);
}
sub Gtk3::check_version {
Glib::Object::Introspection->invoke ($_GTK_BASENAME, undef, 'check_version',
@_ == 4 ? @_[1..3] : @_);
}
sub Gtk3::init {
my $rest = Glib::Object::Introspection->invoke (
$_GTK_BASENAME, undef, 'init',
[$0, @ARGV]);
@ARGV = @{$rest}[1 .. $#$rest]; # remove $0
return;
}
sub Gtk3::init_check {
my ($success, $rest) = Glib::Object::Introspection->invoke (
$_GTK_BASENAME, undef, 'init_check',
[$0, @ARGV]);
@ARGV = @{$rest}[1 .. $#$rest]; # remove $0
return $success;
}
sub Gtk3::main {
# Ignore any arguments passed in.
Glib::Object::Introspection->invoke ($_GTK_BASENAME, undef, 'main');
}
sub Gtk3::main_level {
# Ignore any arguments passed in.
return Glib::Object::Introspection->invoke ($_GTK_BASENAME, undef, 'main_level');
}
sub Gtk3::main_quit {
# Ignore any arguments passed in.
Glib::Object::Introspection->invoke ($_GTK_BASENAME, undef, 'main_quit');
}
=item * A Perl reimplementation of C<Gtk3::show_about_dialog> is provided.
=cut
{
my $global_about_dialog = undef;
my $about_dialog_key = '__gtk3_about_dialog';
sub Gtk3::show_about_dialog {
# For backwards-compatibility, optionally accept and discard a class
# argument.
my $parent_or_class = shift;
my $parent = defined $parent_or_class && $parent_or_class eq 'Gtk3'
? shift
: $parent_or_class;
my %props = @_;
my $dialog = defined $parent
? $parent->{$about_dialog_key}
: $global_about_dialog;
if (!$dialog) {
$dialog = Gtk3::AboutDialog->new;
$dialog->signal_connect (delete_event => sub { $dialog->hide_on_delete });
$dialog->signal_connect (response => sub { $dialog->hide });
foreach my $prop (keys %props) {
$dialog->set ($prop => $props{$prop});
}
if ($parent) {
$dialog->set_modal (Glib::TRUE);
$dialog->set_transient_for ($parent);
$dialog->set_destroy_with_parent (Glib::TRUE);
$parent->{$about_dialog_key} = $dialog;
} else {
$global_about_dialog = $dialog;
}
}
$dialog->present;
}
}
=item * Perl reimplementations of C<Gtk3::ActionGroup::add_actions>,
C<add_radio_actions> and C<add_toggle_actions> are provided.
=cut
sub Gtk3::ActionGroup::add_actions {
my ($self, $entries, $user_data) = @_;
croak 'actions must be a reference to an array of action entries'
unless (ref($entries) eq 'ARRAY');
croak 'action array is empty'
unless (@$entries);
my $process = sub {
my ($p) = @_;
my ($name, $stock_id, $label, $accelerator, $tooltip, $callback);
if (ref($p) eq 'ARRAY') {
$name = $p->[0];
$stock_id = $p->[1];
$label = $p->[2];
$accelerator = $p->[3];
$tooltip = $p->[4];
$callback = $p->[5];
} elsif (ref($p) eq 'HASH') {
$name = $p->{name};
$stock_id = $p->{stock_id};
$label = $p->{label};
$accelerator = $p->{accelerator};
$tooltip = $p->{tooltip};
$callback = $p->{callback};
} else {
croak 'action entry must be a reference to a hash or an array';
}
if (defined($label)) {
$label = $self->translate_string($label);
}
if (defined($tooltip)) {
$tooltip = $self->translate_string($tooltip);
}
my $action = Gtk3::Action->new ($name, $label, $tooltip, $stock_id);
if ($callback) {
$action->signal_connect ('activate', $callback, $user_data);
}
$self->add_action_with_accel ($action, $accelerator);
};
for my $e (@$entries) {
$process->($e);
}
}
sub Gtk3::ActionGroup::add_toggle_actions {
my ($self, $entries, $user_data) = @_;
croak 'entries must be a reference to an array of toggle action entries'
unless (ref($entries) eq 'ARRAY');
croak 'toggle action array is empty'
unless (@$entries);
my $process = sub {
my ($p) = @_;
my ($name, $stock_id, $label, $accelerator, $tooltip,
$callback, $is_active);
if (ref($p) eq 'ARRAY') {
$name = $p->[0];
$stock_id = $p->[1];
$label = $p->[2];
$accelerator = $p->[3];
$tooltip = $p->[4];
$callback = $p->[5];
$is_active = $p->[6];
} elsif (ref($p) eq 'HASH') {
$name = $p->{name};
$stock_id = $p->{stock_id};
$label = $p->{label};
$accelerator = $p->{accelerator};
$tooltip = $p->{tooltip};
$callback = $p->{callback};
$is_active = $p->{is_active};
} else {
croak 'action entry must be a hash or an array';
}
if (defined($label)) {
$label = $self->translate_string($label);
}
if (defined($tooltip)) {
$tooltip = $self->translate_string($tooltip);
}
my $action = Gtk3::ToggleAction->new (
$name, $label, $tooltip, $stock_id);
$action->set_active ($is_active) if defined $is_active;
if ($callback) {
$action->signal_connect ('activate', $callback, $user_data);
}
$self->add_action_with_accel ($action, $accelerator);
};
for my $e (@$entries) {
$process->($e);
}
}
sub Gtk3::ActionGroup::add_radio_actions {
my ($self, $entries, $value, $on_change, $user_data) = @_;
croak 'radio_action_entries must be a reference to '
. 'an array of action entries'
unless (ref($entries) eq 'ARRAY');
croak 'radio action array is empty'
unless (@$entries);
my $first_action = undef;
my $process = sub {
my ($group, $p) = @_;
my ($name, $stock_id, $label, $accelerator, $tooltip, $entry_value);
if (ref($p) eq 'ARRAY') {
$name = $p->[0];
$stock_id = $p->[1];
$label = $p->[2];
$accelerator = $p->[3];
$tooltip = $p->[4];
$entry_value = $p->[5];
} elsif (ref($p) eq 'HASH') {
$name = $p->{name};
$stock_id = $p->{stock_id};
$label = $p->{label};
$accelerator = $p->{accelerator};
$tooltip = $p->{tooltip};
$entry_value = $p->{value};
} else {
croak 'radio action entries neither hash nor array';
}
if (defined($label)) {
$label = $self->translate_string($label);
}
if (defined($tooltip)) {
$tooltip = $self->translate_string($tooltip);
}
my $action = Gtk3::RadioAction->new (
$name, $label, $tooltip, $stock_id, $entry_value);
$action->join_group($group);
if ($value == $entry_value) {
$action->set_active(Glib::TRUE);
}
$self->add_action_with_accel($action, $accelerator);
return $action;
};
for my $e (@$entries) {
my $group = $process->($first_action, $e);
if (!$first_action) {
$first_action = $group;
}
}
if ($first_action && $on_change) {
$first_action->signal_connect ('changed', $on_change, $user_data);
}
}
=item * C<Gtk3::Builder::add_objects_from_file> and C<add_objects_from_string>
also accept a list of objects instead of an array ref.
=item * C<Gtk3::Builder::add_objects_from_string> and C<add_from_string> don't
take length arguments, as they are computed automatically.
=cut
sub Gtk3::Builder::add_objects_from_file {
my ($builder, $filename, @rest) = @_;
my $ref = _rest_to_ref (\@rest);
return Glib::Object::Introspection->invoke (
$_GTK_BASENAME, 'Builder', 'add_objects_from_file',
$builder, $filename, $ref);
}
sub Gtk3::Builder::add_objects_from_string {
my ($builder, $string, @rest) = @_;
my $ref = _rest_to_ref (\@rest);
return Glib::Object::Introspection->invoke (
$_GTK_BASENAME, 'Builder', 'add_objects_from_string',
$builder, $string, -1, $ref); # wants length in bytes
}
sub Gtk3::Builder::add_from_string {
my ($builder, $string) = @_;
return Glib::Object::Introspection->invoke (
$_GTK_BASENAME, 'Builder', 'add_from_string',
$builder, $string, -1); # wants length in bytes
}
=item * A Perl reimplementation of C<Gtk3::Builder::connect_signals> is
provided.
=cut
# Copied from Gtk2.pm
sub Gtk3::Builder::connect_signals {
my $builder = shift;
my $user_data = shift;
my $do_connect = sub {
my ($object,
$signal_name,
$user_data,
$connect_object,
$flags,
$handler) = @_;
my $func = ($flags & 'after') ? 'signal_connect_after' : 'signal_connect';
# we get connect_object when we're supposed to call
# signal_connect_object, which ensures that the data (an object)
# lives as long as the signal is connected. the bindings take
# care of that for us in all cases, so we only have signal_connect.
# if we get a connect_object, just use that instead of user_data.
$object->$func($signal_name => $handler,
$connect_object || $user_data);
};
# $builder->connect_signals ($user_data)
# $builder->connect_signals ($user_data, $package)
if ($#_ <= 0) {
my $package = shift;
$package = caller unless defined $package;
$builder->connect_signals_full(sub {
my ($builder,
$object,
$signal_name,
$handler_name,
$connect_object,
$flags) = @_;
no strict qw/refs/;
my $handler = $handler_name;
if (ref $package) {
$handler = sub { $package->$handler_name(@_) };
} else {
if ($package && $handler !~ /::/) {
$handler = $package.'::'.$handler_name;
}
}
$do_connect->($object, $signal_name, $user_data, $connect_object,
$flags, $handler);
});
}
# $builder->connect_signals ($user_data, %handlers)
else {
my %handlers = @_;
$builder->connect_signals_full(sub {
my ($builder,
$object,
$signal_name,
$handler_name,
$connect_object,
$flags) = @_;
return unless exists $handlers{$handler_name};
$do_connect->($object, $signal_name, $user_data, $connect_object,
$flags, $handlers{$handler_name});
});
}
}
=item * The default C<new> constructors of Gtk3::Button, Gtk3::CheckButton,
Gtk3::ColorButton, Gtk3::FontButton and Gtk3::ToggleButton reroute to
C<new_with_mnemonic> if given an extra argument.
=cut
{
no strict 'refs';
my @button_classes = ([Button => 'new_with_mnemonic'],
[CheckButton => 'new_with_mnemonic'],
[ColorButton => 'new_with_color'],
[FontButton => 'new_with_font'],
[ToggleButton => 'new_with_mnemonic']);
foreach my $button_pair (@button_classes) {
my ($button_class, $button_ctor) = @$button_pair;
*{'Gtk3::' . $button_class . '::new'} = sub {
my ($class, $thing) = @_;
if (defined $thing) {
return $class->$button_ctor ($thing);
} else {
return Glib::Object::Introspection->invoke (
$_GTK_BASENAME, $button_class, 'new', @_);
}
}
}
}
=item * The default C<new> constructor of Gtk3::CheckMenuItem reroutes to
C<new_with_mnemonic> if given an extra argument.
=cut
sub Gtk3::CheckMenuItem::new {
my ($class, $mnemonic) = @_;
if (defined $mnemonic) {
return $class->new_with_mnemonic ($mnemonic);
}
return Glib::Object::Introspection->invoke (
$_GTK_BASENAME, 'CheckMenuItem', 'new', @_);
}
=item * The C<length> argument of C<Gtk3::Clipboard::set_text> is optional.
=cut
sub Gtk3::Clipboard::set_text {
return Glib::Object::Introspection->invoke (
$_GTK_BASENAME, 'Clipboard', 'set_text',
@_ == 3 ? @_ : (@_[0,1], -1)); # wants length in bytes
}
=item * Perl reimplementations of C<Gtk3::Container::add_with_properties>,
C<Gtk3::Container::child_get> and C<Gtk3::Container::child_set> are provided.
=cut
sub Gtk3::Container::add_with_properties {
my ($container, $widget, @rest) = @_;
$widget->freeze_child_notify;
$container->add ($widget);
if ($widget->get_parent) {
$container->child_set ($widget, @rest);
}
$widget->thaw_child_notify;
}
sub Gtk3::Container::child_get {
my ($container, $child, @rest) = @_;
my $properties = _rest_to_ref (\@rest);
my @values;
foreach my $property (@$properties) {
my $pspec = Gtk3::ContainerClass::find_child_property ($container, $property);
croak "Cannot find type information for property '$property' on $container"
unless defined $pspec;
my $value_wrapper = Glib::Object::Introspection::GValueWrapper->new (
$pspec->get_value_type, undef);
$container->child_get_property ($child, $property, $value_wrapper);
push @values, $value_wrapper->get_value;
}
return @values[0..$#values];
}
sub Gtk3::Container::child_set {
my ($container, $child, @rest) = @_;
my ($properties, $values) = _unpack_keys_and_values (\@rest);
foreach my $i (0..$#$properties) {
my $property = $properties->[$i];
my $value = $values->[$i];
my $pspec = Gtk3::ContainerClass::find_child_property ($container, $property);
croak "Cannot find type information for property '$property' on $container"
unless defined $pspec;
my $value_wrapper = Glib::Object::Introspection::GValueWrapper->new (
$pspec->get_value_type, $value);
$container->child_set_property ($child, $property, $value_wrapper);
}
}
=item * C<Gtk3::Container::find_child_property> and
C<Gtk3::Container::list_child_properties> are forwarded to the corresponding
functions in C<Gtk3::ContainerClass>.
=cut
sub Gtk3::Container::find_child_property {
return Gtk3::ContainerClass::find_child_property (@_);
}
sub Gtk3::Container::list_child_properties {
my $ref = Gtk3::ContainerClass::list_child_properties (@_);
return if not defined $ref;
return wantarray ? @$ref : $ref->[$#$ref];
}
=item * C<Gtk3::Container::get_focus_chain> returns a list of widgets, or an
empty list.
=cut
sub Gtk3::Container::get_focus_chain {
my ($container) = @_;
my ($is_set, $widgets) = Glib::Object::Introspection->invoke (
$_GTK_BASENAME, 'Container', 'get_focus_chain',
$container);
return () unless $is_set;
return @$widgets;
}
=item * C<Gtk3::Container::set_focus_chain> also accepts a list of widgets.
=cut
sub Gtk3::Container::set_focus_chain {
my ($container, @rest) = @_;
return Glib::Object::Introspection->invoke (
$_GTK_BASENAME, 'Container', 'set_focus_chain',
$container, _rest_to_ref (\@rest));
}
=item * C<Gtk3::CssProvider::load_from_data> also accepts a string.
=cut
sub Gtk3::CssProvider::load_from_data {
my ($self, $data) = @_;
return Glib::Object::Introspection->invoke (
$_GTK_BASENAME, 'CssProvider', 'load_from_data',
$self, _unpack_unless_array_ref ($data));
}
=item * For Gtk3::Dialog and Gtk3::InfoBar, a Perl implementation of
C<add_buttons> is provided.
=cut
# Gtk3::Dialog / Gtk3::InfoBar methods due to overlap
{
no strict qw(refs);
foreach my $dialog_package (qw/Dialog InfoBar/) {
*{'Gtk3::' . $dialog_package . '::add_action_widget'} = sub {
Glib::Object::Introspection->invoke (
$_GTK_BASENAME, $dialog_package, 'add_action_widget',
$_[0], $_[1], $_GTK_RESPONSE_NICK_TO_ID->($_[2]));
};
*{'Gtk3::' . $dialog_package . '::add_button'} = sub {
Glib::Object::Introspection->invoke (
$_GTK_BASENAME, $dialog_package, 'add_button',
$_[0], $_[1], $_GTK_RESPONSE_NICK_TO_ID->($_[2]));
};
*{'Gtk3::' . $dialog_package . '::add_buttons'} = sub {
my ($dialog, @rest) = @_;
for (my $i = 0; $i < @rest; $i += 2) {
$dialog->add_button ($rest[$i], $rest[$i+1]);
}
};
*{'Gtk3::' . $dialog_package . '::response'} = sub {
return Glib::Object::Introspection->invoke (
$_GTK_BASENAME, $dialog_package, 'response',
$_[0], $_GTK_RESPONSE_NICK_TO_ID->($_[1]));
};
*{'Gtk3::' . $dialog_package . '::set_default_response'} = sub {
Glib::Object::Introspection->invoke (
$_GTK_BASENAME, $dialog_package, 'set_default_response',
$_[0], $_GTK_RESPONSE_NICK_TO_ID->($_[1]));
};
*{'Gtk3::' . $dialog_package . '::set_response_sensitive'} = sub {
Glib::Object::Introspection->invoke (
$_GTK_BASENAME, $dialog_package, 'set_response_sensitive',
$_[0], $_GTK_RESPONSE_NICK_TO_ID->($_[1]), $_[2]);
};
}
}
sub Gtk3::Dialog::get_response_for_widget {
my $id = Glib::Object::Introspection->invoke (
$_GTK_BASENAME, 'Dialog', 'get_response_for_widget', @_);
return $_GTK_RESPONSE_ID_TO_NICK->($id);
}
sub Gtk3::Dialog::get_widget_for_response {
return Glib::Object::Introspection->invoke (
$_GTK_BASENAME, 'Dialog', 'get_widget_for_response',
$_[0], $_GTK_RESPONSE_NICK_TO_ID->($_[1]));
}
=item * C<Gtk3::Dialog::new> can optionally be called as C<< Gtk3::Dialog->new
(TITLE, PARENT, FLAGS, ...) >> where C<...> is a series of button text and
response id pairs.
=cut
sub Gtk3::Dialog::new {
my ($class, $title, $parent, $flags, @rest) = @_;
if (@_ == 1) {
return Glib::Object::Introspection->invoke (
$_GTK_BASENAME, 'Dialog', 'new', @_);
} elsif ((@_ < 4) || (@rest % 2)){
croak ("Usage: Gtk3::Dialog->new ()\n" .
" or Gtk3::Dialog->new (TITLE, PARENT, FLAGS, ...)\n" .
" where ... is a series of button text and response id pairs");
} else {
my $dialog = Gtk3::Dialog->new;
defined $title and $dialog->set_title ($title);
defined $parent and $dialog->set_transient_for ($parent);
if (! eval { $flags->isa ('Gtk3::DialogFlags'); }) {
$flags = Gtk3::DialogFlags->new ($flags);
}
$flags & 'modal' and $dialog->set_modal (Glib::TRUE);
$flags & 'destroy-with-parent' and $dialog->set_destroy_with_parent (Glib::TRUE);
$dialog->add_buttons (@rest);
return $dialog;
}
}
=item * A Perl implementation of C<Gtk3::Dialog::new_with_buttons> is provided.
=cut
sub Gtk3::Dialog::new_with_buttons {
&Gtk3::Dialog::new;
}
sub Gtk3::Dialog::run {
my $id = Glib::Object::Introspection->invoke (
$_GTK_BASENAME, 'Dialog', 'run', @_);
return $_GTK_RESPONSE_ID_TO_NICK->($id);
}
sub Gtk3::Dialog::set_alternative_button_order {
my ($dialog, @rest) = @_;
return unless @rest;
Glib::Object::Introspection->invoke (
$_GTK_BASENAME, 'Dialog', 'set_alternative_button_order_from_array',
$dialog, [map { $_GTK_RESPONSE_NICK_TO_ID->($_) } @rest]);
}
=item * The C<length> argument of C<Gtk3::Editable::insert_text> is optional.
=cut
sub Gtk3::Editable::insert_text {
return Glib::Object::Introspection->invoke (
$_GTK_BASENAME, 'Editable', 'insert_text',
@_ == 4 ? @_ : (@_[0,1], -1, $_[2])); # wants length in bytes
}
=item * A Perl implementation of C<Gtk3::FileChooserDialog::new> is provided.
=cut
sub Gtk3::FileChooserDialog::new {
my ($class, $title, $parent, $action, @varargs) = @_;
if (@varargs % 2) {
croak 'Usage: Gtk3::FileChooserDialog->new' .
' (title, parent, action, button-text =>' .
" response-id, ...)\n";
}
my $result = Glib::Object::new (
$class,
title => $title,
action => $action,
);
if ($parent) {
$result->set_transient_for ($parent);
}
for (my $i = 0; $i < @varargs; $i += 2) {
$result->add_button ($varargs[$i], $varargs[$i+1]);
}
return $result;
}
=item * C<Gtk3::HBox::new> uses the defaults homogeneous = FALSE and spacing =
5.
=cut
sub Gtk3::HBox::new {
my ($class, $homogeneous, $spacing) = @_;
$homogeneous = 0 unless defined $homogeneous;
$spacing = 5 unless defined $spacing;
return Glib::Object::Introspection->invoke (
$_GTK_BASENAME, 'HBox', 'new', $class, $homogeneous, $spacing);
}
# Gtk3::Image
{
no strict qw(refs);
foreach my $ctor (qw/new_from_stock new_from_icon_set new_from_icon_name new_from_gicon/) {
*{'Gtk3::Image::' . $ctor} = sub {
my ($class, $thing, $size) = @_;
return Glib::Object::Introspection->invoke (
$_GTK_BASENAME, 'Image', $ctor, $class, $thing,
$_GTK_ICON_SIZE_NICK_TO_ID->($size));
}
}
foreach my $getter (qw/get_stock get_icon_set get_icon_name get_gicon/) {
*{'Gtk3::Image::' . $getter} = sub {
my ($image) = @_;
my ($thing, $size) = Glib::Object::Introspection->invoke (
$_GTK_BASENAME, 'Image', $getter, $image);
return ($thing, $_GTK_ICON_SIZE_ID_TO_NICK->($size));
}
}
foreach my $setter (qw/set_from_stock set_from_icon_set set_from_icon_name set_from_gicon/) {
*{'Gtk3::Image::' . $setter} = sub {
my ($image, $thing, $size) = @_;
Glib::Object::Introspection->invoke (
$_GTK_BASENAME, 'Image', $setter, $image, $thing,
$_GTK_ICON_SIZE_NICK_TO_ID->($size));
}
}
}
=item * The default C<new> constructor of Gtk3::ImageMenuItem reroutes to
C<new_with_mnemonic> if given an extra argument.
=cut
sub Gtk3::ImageMenuItem::new {
my ($class, $mnemonic) = @_;
if (defined $mnemonic) {
return $class->new_with_mnemonic ($mnemonic);
}
return Glib::Object::Introspection->invoke (
$_GTK_BASENAME, 'ImageMenuItem', 'new', @_);
}
=item * C<Gtk3::InfoBar::new> can optionally be called as C<<
Gtk3::InfoBar->new (...) >> where C<...> is a series of button text and
response id pairs.
=cut
sub Gtk3::InfoBar::new {
my ($class, @buttons) = @_;
if (@_ == 1) {
return Glib::Object::Introspection->invoke (
$_GTK_BASENAME, 'InfoBar', 'new', @_);
} elsif (@buttons % 2) {
croak "Usage: Gtk3::InfoBar->new_with_buttons (button-text => response_id, ...)\n";
} else {
my $infobar = Gtk3::InfoBar->new;
for (my $i = 0; $i < @buttons; $i += 2) {
$infobar->add_button ($buttons[$i], $buttons[$i+1]);
}
return $infobar;
}
}
=item * A Perl reimplementation of C<Gtk3::InfoBar::new_with_buttons> is
provided.
=cut
sub Gtk3::InfoBar::new_with_buttons {
&Gtk3::InfoBar::new;
}
=item * The default C<new> constructor of Gtk3::LinkButton reroutes to
C<new_with_label> if given an extra argument.
=cut
sub Gtk3::LinkButton::new {
my ($class, $uri, $label) = @_;
if (defined $label) {
return Gtk3::LinkButton->new_with_label ($uri, $label);
} else {
return Glib::Object::Introspection->invoke (
$_GTK_BASENAME, 'LinkButton', 'new', @_);
}
}
=item * C<Gtk3::ListStore::new> also accepts a list of type names.
=cut
sub Gtk3::ListStore::new {
return _common_tree_model_new ('ListStore', @_);
}
=item * Gtk3::ListStore has a C<get> method that calls C<Gtk3::TreeModel::get>
instead of C<Glib::Object::get>.
=cut
# Reroute 'get' to Gtk3::TreeModel instead of Glib::Object.
sub Gtk3::ListStore::get {
return Gtk3::TreeModel::get (@_);
}
=item * C<Gtk3::ListStore::insert_with_values> also accepts a list of C<<
column => value >> pairs and reroutes to C<insert_with_valuesv>.
=cut
sub Gtk3::ListStore::insert_with_values {
my ($model, $position, @columns_and_values) = @_;
my ($columns, $values) = _unpack_keys_and_values (\@columns_and_values);
if (not defined $columns) {
croak ("Usage: Gtk3::ListStore::insert_with_values (\$model, \$position, \\\@columns, \\\@values)\n",
" -or-: Gtk3::ListStore::insert_with_values (\$model, \$position, \$column1 => \$value1, ...)");
}
my @wrapped_values = ();
foreach my $i (0..$#{$columns}) {
my $column_type = $model->get_column_type ($columns->[$i]);
push @wrapped_values,
Glib::Object::Introspection::GValueWrapper->new (
$column_type, $values->[$i]);
}
return Glib::Object::Introspection->invoke (
$_GTK_BASENAME, 'ListStore', 'insert_with_valuesv', # FIXME: missing rename-to annotation?
$model, $position, $columns, \@wrapped_values);
}
=item * C<Gtk3::ListStore::set> also accepts a list of C<< column => value >>
pairs.
=cut
sub Gtk3::ListStore::set {
return _common_tree_model_set ('ListStore', @_);
}
=item * C<Gtk3::Menu::popup> reroutes to C<popup_for_device> for better
callback handling.
=cut
sub Gtk3::Menu::popup {
my $self = shift;
$self->popup_for_device (undef, @_);
}
=item * C<Gtk3::Menu::popup_for_device> allows the given menu position func to
return only x and y coordinates, defaulting C<push_in> to FALSE.
=cut
sub Gtk3::Menu::popup_for_device {
my ($menu, $device, $parent_menu_shell, $parent_menu_item, $func, $data, $button, $activate_time) = @_;
my $real_func = $func ? sub {
my @stuff = eval { $func->(@_) };
if ($@) {
warn "*** menu position callback ignoring error: $@";
}
if (@stuff == 3) {
return (@stuff);
} elsif (@stuff == 2) {
return (@stuff, Glib::FALSE); # provide a default for push_in
} else {
warn "*** menu position callback must return two integers " .
"(x, y) or two integers and a boolean (x, y, push_in)";
return (0, 0, Glib::FALSE);
}
} : undef;
return Glib::Object::Introspection->invoke (
$_GTK_BASENAME, 'Menu', 'popup_for_device',
$menu, $device, $parent_menu_shell, $parent_menu_item, $real_func, $data, $button, $activate_time);
}
=item * The default C<new> constructor of Gtk3::MenuItem reroutes to
C<new_with_mnemonic> if given an extra argument.
=cut
sub Gtk3::MenuItem::new {
my ($class, $mnemonic) = @_;
if (defined $mnemonic) {
return $class->new_with_mnemonic ($mnemonic);
}
return Glib::Object::Introspection->invoke (
$_GTK_BASENAME, 'MenuItem', 'new', @_);
}
=item * A Perl reimplementation of C<Gtk3::MessageDialog::new> is provided.
=cut
sub Gtk3::MessageDialog::new {
my ($class, $parent, $flags, $type, $buttons, $format, @args) = @_;
my $dialog = Glib::Object::new ($class, message_type => $type,
buttons => $buttons);
if (defined $format) {
# sprintf can handle empty @args
my $msg = sprintf $format, @args;
$dialog->set (text => $msg);
}
if (defined $parent) {
$dialog->set_transient_for ($parent);
}
if (! eval { $flags->isa ('Gtk3::DialogFlags'); }) {
$flags = Gtk3::DialogFlags->new ($flags);
}
if ($flags & 'modal') {
$dialog->set_modal (Glib::TRUE);
}
if ($flags & 'destroy-with-parent') {
$dialog->set_destroy_with_parent (Glib::TRUE);
}
return $dialog;
}
=item * A Perl reimplementation of C<Gtk3::MessageDialog::new_with_markup> is provided.
=cut
sub Gtk3::MessageDialog::new_with_markup {
my ($class, $parent, $flags, $type, $buttons, $format, @args) = @_;
my $dialog = Gtk3::MessageDialog::new ($class, $parent, $flags, $type, $buttons, undef);
if (defined $format) {
my $markup = sprintf $format, @args;
$dialog->set_markup ($markup);
}
return $dialog;
}
=item * A Perl reimplementation of C<Gtk3::MessageDialog::format_secondary_text> and
C<Gtk3::MessageDialog::format_secondary_markup> is provided
=cut
sub Gtk3::MessageDialog::format_secondary_text {
my ($dialog, $format, @args) = @_;
my $text = sprintf $format, @args;
$dialog->set ('secondary-text' => $text, 'secondary-use-markup' => 0);
}
sub Gtk3::MessageDialog::format_secondary_markup {
my ($dialog, $format, @args) = @_;
my $text = sprintf $format, @args;
$dialog->set ('secondary-text' => $text, 'secondary-use-markup' => 1);
}
=item * The group handling in the constructors and accessors of
Gtk3::RadioAction, Gtk3::RadioButton, Gtk3::RadioMenuItem and
Gtk3::RadioToolButton is amended to work correctly when given array refs of
group members or single group members.
=cut
# Gtk3::RadioAction, Gtk3::RadioButton, Gtk3::RadioMenuItem and
# Gtk3::RadioToolButton constructors.
{
no strict qw(refs);
my $group_converter = sub {
my ($ctor, $group_or_member, $package) = @_;
local $@;
# undef => []
if (!defined $group_or_member) {
return ($ctor, []);
}
# [] => []
elsif (eval { $#$group_or_member == -1 }) {
return ($ctor, []);
}
# [member1, ...] => member1
elsif (eval { $#$group_or_member >= 0 }) {
my $member = $group_or_member->[0];
if (defined $member) {
return ($ctor . '_from_widget', $member);
}
return ($ctor, []);
}
# member => member
elsif (eval { $group_or_member->isa ('Gtk3::' . $package) }) {
return ($ctor . '_from_widget', $group_or_member);
}
else {
croak ('Unhandled group or member argument encountered');
}
};
# Gtk3::RadioAction/Gtk3::RadioButton/Gtk3::RadioMenuItem/Gtk3::RadioToolButton
foreach my $package (qw/RadioAction RadioButton RadioMenuItem RadioToolButton/) {
*{'Gtk3::' . $package . '::set_group'} = sub {
my ($button, $group) = @_;
my $real_group = $group;
if (eval { $#$group >= 0 }) {
$real_group = $group->[0];
}
$button->set (group => $real_group);
};
}
# Gtk3::RadioButton/Gtk3::RadioMenuItem
foreach my $package (qw/RadioButton RadioMenuItem/) {
foreach my $ctor (qw/new new_with_label new_with_mnemonic/) {
# Avoid using the list-based API, as G:O:I does not support the memory
# ownership semantics. Use the item-based API instead.
*{'Gtk3::' . $package . '::' . $ctor} = sub {
my ($class, $group_or_member, @rest) = @_;
my ($real_ctor, $real_group_or_member) =
$group_converter->($ctor, $group_or_member, $package);
return Glib::Object::Introspection->invoke (
$_GTK_BASENAME, $package, $real_ctor,
$class, $real_group_or_member, @rest);
};
# Work around <https://bugzilla.gnome.org/show_bug.cgi?id=679563>.
*{'Gtk3::' . $package . '::' . $ctor . '_from_widget'} = sub {
my ($class, $member, @rest) = @_;
my $real_ctor = $ctor;
my $real_group_or_member = $member;
if (!defined $member) {
$real_group_or_member = [];
} else {
$real_ctor .= '_from_widget';
}
return Glib::Object::Introspection->invoke (
$_GTK_BASENAME, $package, $real_ctor,
$class, $real_group_or_member, @rest);
};
}
}
# GtkRadioToolButton
foreach my $ctor (qw/new new_from_stock/) {
# Avoid using the list-based API, as G:O:I does not support the memory
# ownership semantics. Use the item-based API instead.
*{'Gtk3::RadioToolButton::' . $ctor} = sub {
my ($class, $group_or_member, @rest) = @_;
my ($real_ctor, $real_group_or_member) =
$group_converter->($ctor, $group_or_member, 'RadioToolButton');
$real_ctor =~ s/_from_stock_from_/_with_stock_from_/; # you gotta be kidding me...
return Glib::Object::Introspection->invoke (
$_GTK_BASENAME, 'RadioToolButton', $real_ctor,
$class, $real_group_or_member, @rest);
};
}
}
=item * Perl reimplementations of C<Gtk3::RecentChooserDialog::new> and
C<new_for_manager> are provided.
=cut
sub Gtk3::RecentChooserDialog::new {
my ($class, $title, $parent, @buttons) = @_;
my $dialog = Glib::Object::new ($class, title => $title);
for (my $i = 0; $i < @buttons; $i += 2) {
$dialog->add_button ($buttons[$i], $buttons[$i+1]);
}
if (defined $parent) {
$dialog->set_transient_for ($parent);
}
return $dialog;
}
sub Gtk3::RecentChooserDialog::new_for_manager {
my ($class, $title, $parent, $mgr, @buttons) = @_;
my $dialog = Glib::Object::new ($class, title => $title,
recent_manager => $mgr);
for (my $i = 0; $i < @buttons; $i += 2) {
$dialog->add_button ($buttons[$i], $buttons[$i+1]);
}
if (defined $parent) {
$dialog->set_transient_for ($parent);
}
return $dialog;
}
=item * Redirects are provided from C<Gtk3::Stock::[function]> to
C<Gtk3::stock_[function]> for C<add>, C<add_static>, C<list_ids>, C<lookup> and
C<set_translate_func>.
=cut
{
no strict qw/refs/;
my %stock_name_corrections = (
'Gtk3::Stock::add' => 'Gtk3::stock_add',
'Gtk3::Stock::add_static' => 'Gtk3::stock_add_static',
'Gtk3::Stock::list_ids' => 'Gtk3::stock_list_ids',
'Gtk3::Stock::lookup' => 'Gtk3::stock_lookup',
'Gtk3::Stock::set_translate_func' => 'Gtk3::stock_set_translate_func',
);
foreach my $new (keys %stock_name_corrections) {
*{$new} = \&{$stock_name_corrections{$new}};
}
}
=item * A Perl reimplementation of C<Gtk3::StyleContext::get> is provided.
=cut
sub Gtk3::StyleContext::get {
my ($context, $state, @properties) = @_;
my @values = map { $context->get_property ($_, $state) } @properties;
return @values[0..$#values];
}
=item * An override for C<Gtk3::TargetEntry::new> is provided that
automatically handles the conversion of the C<flags> argument.
=cut
sub Gtk3::TargetEntry::new {
my ($class, $target, $flags, $info) = @_;
if ($flags !~ /^\d+$/) {
$flags = Glib::Object::Introspection->convert_sv_to_flags (
"Gtk3::TargetFlags", $flags)
}
return Glib::Object::Introspection->invoke (
$_GTK_BASENAME, 'TargetEntry', 'new', $class, $target, $flags, $info);
}
=item * A Perl reimplementation of C<Gtk3::TextBuffer::create_tag> is provided.
=cut
sub Gtk3::TextBuffer::create_tag {
my ($buffer, $tag_name, @rest) = @_;
if (@rest % 2) {
croak ('Usage: $buffer->create_tag ($tag_name, $property1 => $value1, ...');
}
my $tag = Gtk3::TextTag->new ($tag_name);
my $tag_table = $buffer->get_tag_table;
$tag_table->add ($tag);
for (my $i = 0 ; $i < @rest ; $i += 2) {
$tag->set_property ($rest[$i], $rest[$i+1]);
}
return $tag;
}
=item * The C<length> arguments of C<Gtk3::TextBuffer::insert>,
C<insert_at_cursor>, C<insert_interactive>, C<insert_interactive_at_cursor>,
C<insert_markup> and C<set_text> are optional.
=cut
sub Gtk3::TextBuffer::insert {
return Glib::Object::Introspection->invoke (
$_GTK_BASENAME, 'TextBuffer', 'insert',
@_ == 4 ? @_ : (@_[0,1,2], -1)); # wants length in bytes
}
sub Gtk3::TextBuffer::insert_at_cursor {
return Glib::Object::Introspection->invoke (
$_GTK_BASENAME, 'TextBuffer', 'insert_at_cursor',
@_ == 3 ? @_ : (@_[0,1], -1)); # wants length in bytes
}
sub Gtk3::TextBuffer::insert_interactive {
return Glib::Object::Introspection->invoke (
$_GTK_BASENAME, 'TextBuffer', 'insert_interactive',
@_ == 5 ? @_ : (@_[0,1,2], -1, $_[3])); # wants length in bytes
}
sub Gtk3::TextBuffer::insert_interactive_at_cursor {
return Glib::Object::Introspection->invoke (
$_GTK_BASENAME, 'TextBuffer', 'insert_interactive_at_cursor',
@_ == 4 ? @_ : (@_[0,1], -1, $_[2])); # wants length in bytes
}
sub Gtk3::TextBuffer::insert_markup {
return Glib::Object::Introspection->invoke (
$_GTK_BASENAME, 'TextBuffer', 'insert_markup',
@_ == 4 ? @_ : (@_[0,1,2], -1)); # wants length in bytes
}
=item * Perl reimplementations of C<Gtk3::TextBuffer::insert_with_tags> and
C<insert_with_tags_by_name> are provided which do not require a C<length>
argument.
=cut
sub Gtk3::TextBuffer::insert_with_tags {
my ($buffer, $iter, $text, @tags) = @_;
my $start_offset = $iter->get_offset;
$buffer->insert ($iter, $text);
my $start = $buffer->get_iter_at_offset ($start_offset);
foreach my $tag (@tags) {
$buffer->apply_tag ($tag, $start, $iter);
}
}
sub Gtk3::TextBuffer::insert_with_tags_by_name {
my ($buffer, $iter, $text, @tag_names) = @_;
my $start_offset = $iter->get_offset;
$buffer->insert ($iter, $text);
my $tag_table = $buffer->get_tag_table;
my $start = $buffer->get_iter_at_offset ($start_offset);
foreach my $tag_name (@tag_names) {
my $tag = $tag_table->lookup ($tag_name);
if (!$tag) {
warn "no tag with name $tag_name";
} else {
$buffer->apply_tag ($tag, $start, $iter);
}
}
}
sub Gtk3::TextBuffer::set_text {
return Glib::Object::Introspection->invoke (
$_GTK_BASENAME, 'TextBuffer', 'set_text',
@_ == 3 ? @_ : (@_[0,1], -1)); # wants length in bytes
}
=item * A Perl reimplementation of C<Gtk3::TreeModel::get> is provided.
=cut
sub Gtk3::TreeModel::get {
my ($model, $iter, @columns) = @_;
if (!@columns) {
@columns = (0..($model->get_n_columns-1));
}
my @values = map { $model->get_value ($iter, $_) } @columns;
return @values[0..$#values];
}
=item * A redirect is added from C<Gtk3::TreeModelFilter::new> to
<Gtk3::TreeModel::filter_new> so that Gtk3::TreeModelFilter objects can be
constructed normally.
=cut
# Not needed anymore once <https://bugzilla.gnome.org/show_bug.cgi?id=646742>
# is fixed.
sub Gtk3::TreeModelFilter::new {
my ($class, $child_model, $root) = @_;
Glib::Object::Introspection->invoke (
$_GTK_BASENAME, 'TreeModel', 'filter_new', $child_model, $root);
}
=item * Gtk3::TreeModelFilter has a C<get> method that calls
C<Gtk3::TreeModel::get> instead of C<Glib::Object::get>.
=cut
# Reroute 'get' to Gtk3::TreeModel instead of Glib::Object.
sub Gtk3::TreeModelFilter::get {
return Gtk3::TreeModel::get (@_);
}
=item * Prior to gtk+ 3.24.14, a redirect is added from
C<Gtk3::TreeModelSort::new_with_model> to
<Gtk3::TreeModel::sort_new_with_model> so that Gtk3::TreeModelSort objects can
be constructed normally.
=cut
# Not needed anymore once <https://bugzilla.gnome.org/show_bug.cgi?id=646742>
# is fixed. This never happened, but in gtk+ 3.24.14, the return type
# annotation was changed: <https://gitlab.gnome.org/GNOME/gtk/-/merge_requests/1134>.
sub Gtk3::TreeModelSort::new_with_model {
if (Gtk3::CHECK_VERSION (3, 24, 14)) {
Glib::Object::Introspection->invoke (
$_GTK_BASENAME, 'TreeModelSort', 'new_with_model', @_);
} else {
my ($class, $child_model) = @_;
Glib::Object::Introspection->invoke (
$_GTK_BASENAME, 'TreeModel', 'sort_new_with_model', $child_model);
}
}
=item * Gtk3::TreeModelSort has a C<get> method that calls
C<Gtk3::TreeModel::get> instead of C<Glib::Object::get>.
=cut
# Reroute 'get' to Gtk3::TreeModel instead of Glib::Object.
sub Gtk3::TreeModelSort::get {
return Gtk3::TreeModel::get (@_);
}
=item * C<Gtk3::TreePath::new> redirects to C<new_from_string> if an additional
argument is given.
=cut
sub Gtk3::TreePath::new {
my ($class, @args) = @_;
my $method = (@args == 1) ? 'new_from_string' : 'new';
Glib::Object::Introspection->invoke (
$_GTK_BASENAME, 'TreePath', $method, @_);
}
=item * A Perl reimplementation of C<Gtk3::TreePath::new_from_indices> is
provided.
=cut
sub Gtk3::TreePath::new_from_indices {
my ($class, @indices) = @_;
my $path = Gtk3::TreePath->new;
foreach (@indices) {
$path->append_index ($_);
}
return $path;
}
=item * C<Gtk3::TreeStore::new> also accepts a list of type names.
=cut
sub Gtk3::TreeStore::new {
return _common_tree_model_new ('TreeStore', @_);
}
=item * Gtk3::TreeStore has a C<get> method that calls C<Gtk3::TreeModel::get>
instead of C<Glib::Object::get>.
=cut
# Reroute 'get' to Gtk3::TreeModel instead of Glib::Object.
sub Gtk3::TreeStore::get {
return Gtk3::TreeModel::get (@_);
}
=item * C<Gtk3::TreeStore::insert_with_values> also accepts a list of C<<
column => value >> pairs.
=cut
sub Gtk3::TreeStore::insert_with_values {
my ($model, $parent, $position, @columns_and_values) = @_;
my ($columns, $values) = _unpack_keys_and_values (\@columns_and_values);
if (not defined $columns) {
croak ("Usage: Gtk3::TreeStore::insert_with_values (\$model, \$parent, \$position, \\\@columns, \\\@values)\n",
" -or-: Gtk3::TreeStore::insert_with_values (\$model, \$parent, \$position, \$column1 => \$value1, ...)");
}
my @wrapped_values = ();
foreach my $i (0..$#{$columns}) {
my $column_type = $model->get_column_type ($columns->[$i]);
push @wrapped_values,
Glib::Object::Introspection::GValueWrapper->new (
$column_type, $values->[$i]);
}
return Glib::Object::Introspection->invoke (
$_GTK_BASENAME, 'TreeStore', 'insert_with_values',
$model, $parent, $position, $columns, \@wrapped_values);
}
=item * C<Gtk3::TreeStore::set> also accepts a list of C<< column => value >>
pairs.
=cut
sub Gtk3::TreeStore::set {
return _common_tree_model_set ('TreeStore', @_);
}
=item * C<Gtk3::TreeView::new> redirects to C<new_with_model> if an additional
argument is given.
=cut
sub Gtk3::TreeView::new {
my ($class, @args) = @_;
my $method = (@args == 1) ? 'new_with_model' : 'new';
Glib::Object::Introspection->invoke (
$_GTK_BASENAME, 'TreeView', $method, @_);
}
=item * A Perl reimplementation of
C<Gtk3::TreeView::insert_column_with_attributes> is provided.
=cut
sub Gtk3::TreeView::insert_column_with_attributes {
my ($tree_view, $position, $title, $cell, @rest) = @_;
if (@rest % 2) {
croak ('Usage: $tree_view->insert_column_with_attributes (position, title, cell_renderer, attr1 => col1, ...)');
}
my $column = Gtk3::TreeViewColumn->new;
my $n = $tree_view->insert_column ($column, $position);
$column->set_title ($title);
$column->pack_start ($cell, Glib::TRUE);
for (my $i = 0; $i < @rest; $i += 2) {
$column->add_attribute ($cell, $rest[$i], $rest[$i+1]);
}
return $n;
}
=item * A Perl reimplementation of C<Gtk3::TreeViewColumn::new_with_attributes>
is provided.
=cut
sub Gtk3::TreeViewColumn::new_with_attributes {
my ($class, $title, $cell, @rest) = @_;
if (@rest % 2) {
croak ('Usage: Gtk3::TreeViewColumn->new_with_attributes (title, cell_renderer, attr1 => col1, ...)');
}
my $object = $class->new;
$object->set_title ($title);
$object->pack_start ($cell, Glib::TRUE);
for (my $i = 0; $i < @rest; $i += 2) {
$object->add_attribute ($cell, $rest[$i], $rest[$i+1]);
}
return $object;
}
=item * Perl reimplementations of C<Gtk3::TreeViewColumn::set_attributes> and
C<Gtk3::CellLayout::set_attributes> are provided.
=cut
# Gtk3::TreeViewColumn::set_attributes and Gtk3::CellLayout::set_attributes
{
no strict 'refs';
foreach my $package (qw/TreeViewColumn CellLayout/) {
*{'Gtk3::' . $package . '::set_attributes'} = sub {
my ($object, $cell, @rest) = @_;
if (@rest % 2) {
croak ('Usage: $object->set_attributes (cell_renderer, attr1 => col1, ...)');
}
$object->clear_attributes ($cell);
for (my $i = 0; $i < @rest; $i += 2) {
$object->add_attribute ($cell, $rest[$i], $rest[$i+1]);
}
}
}
}
=item * C<Gtk3::UIManager::add_ui_from_string> takes no C<length> argument.
=cut
sub Gtk3::UIManager::add_ui_from_string {
my ($manager, $string) = @_;
return Glib::Object::Introspection->invoke (
$_GTK_BASENAME, 'UIManager', 'add_ui_from_string',
$manager, $string, -1); # wants length in bytes
}
=item * C<Gtk3::VBox::new> uses the defaults homogeneous = FALSE and spacing =
5.
=cut
sub Gtk3::VBox::new {
my ($class, $homogeneous, $spacing) = @_;
$homogeneous = 0 unless defined $homogeneous;
$spacing = 5 unless defined $spacing;
return Glib::Object::Introspection->invoke (
$_GTK_BASENAME, 'VBox', 'new', $class, $homogeneous, $spacing);
}
=item * C<Gtk3::Widget::add_events> and C<Gtk3::Widget::set_events> also accept
strings, array references and C<Gtk3::Gdk::EventMask> objects for the C<events>
parameter.
=cut
sub Gtk3::Widget::add_events {
my ($widget, $events) = @_;
eval {
$events = Glib::Object::Introspection->convert_sv_to_flags (
'Gtk3::Gdk::EventMask', $events);
};
return Glib::Object::Introspection->invoke (
$_GTK_BASENAME, 'Widget', 'add_events', $widget, $events);
}
sub Gtk3::Widget::set_events {
my ($widget, $events) = @_;
eval {
$events = Glib::Object::Introspection->convert_sv_to_flags (
'Gtk3::Gdk::EventMask', $events);
};
return Glib::Object::Introspection->invoke (
$_GTK_BASENAME, 'Widget', 'set_events', $widget, $events);
}
=item * C<Gtk3::Widget::get_events> returns a C<Gtk3::Gdk::EventMask> object
that can also be compared to numeric values with C<< == >> and C<< >= >>.
=cut
sub Gtk3::Widget::get_events {
my ($widget) = @_;
my $events = Glib::Object::Introspection->invoke (
$_GTK_BASENAME, 'Widget', 'get_events', $widget);
return Glib::Object::Introspection->convert_flags_to_sv (
'Gtk3::Gdk::EventMask', $events);
}
sub Gtk3::Widget::render_icon {
my ($widget, $stock_id, $size, $detail) = @_;
Glib::Object::Introspection->invoke (
$_GTK_BASENAME, 'Widget', 'render_icon', $widget, $stock_id,
$_GTK_ICON_SIZE_NICK_TO_ID->($size), $detail);
}
=item * C<Gtk3::Widget::find_style_property> and
C<Gtk3::Widget::list_style_properties> are forwarded to the corresponding
functions in C<Gtk3::WidgetClass>.
=cut
sub Gtk3::Widget::find_style_property {
return Gtk3::WidgetClass::find_style_property (@_);
}
sub Gtk3::Widget::list_style_properties {
my $ref = Gtk3::WidgetClass::list_style_properties (@_);
return if not defined $ref;
return wantarray ? @$ref : $ref->[$#$ref];
}
=item * A Perl reimplementation of C<Gtk3::Widget::style_get> is provided.
=cut
sub Gtk3::Widget::style_get {
my ($widget, @rest) = @_;
my $properties = _rest_to_ref (\@rest);
my @values;
foreach my $property (@$properties) {
my $pspec = Gtk3::WidgetClass::find_style_property ($widget, $property);
croak "Cannot find type information for property '$property' on $widget"
unless defined $pspec;
my $value_wrapper = Glib::Object::Introspection::GValueWrapper->new (
$pspec->get_value_type, undef);
$widget->style_get_property ($property, $value_wrapper);
push @values, $value_wrapper->get_value;
}
return @values[0..$#values];
}
=item * C<Gtk3::Window::new> uses the default type = 'toplevel'.
=cut
sub Gtk3::Window::new {
my ($class, $type) = @_;
$type = 'toplevel' unless defined $type;
return Glib::Object::Introspection->invoke (
$_GTK_BASENAME, 'Window', 'new', $class, $type);
}
# --- Gdk ---
=item * A constructor C<Gtk3::Gdk::RGBA::new> is provided that can be called as
C<< Gtk3::Gdk::RGBA->new (r, g, b, a) >>.
=cut
sub Gtk3::Gdk::RGBA::new {
my ($class, @rest) = @_;
# Handle Gtk3::Gdk::RGBA->new (r, g, b, a) specially.
if (4 == @rest) {
my %data;
@data{qw/red green blue alpha/} = @rest;
return Glib::Boxed::new ($class, \%data);
}
# Fall back to Glib::Boxed::new.
return Glib::Boxed::new ($class, @rest);
}
=item * C<Gtk3::Gdk::RGBA::parse> can be called as a function returning a new
instance (C<< $rgba = Gtk3::Gdk::RGBA::parse ($spec) >>) or as a method (C<<
$rgba->parse ($spec) >>).
=cut
sub Gtk3::Gdk::RGBA::parse {
my $have_instance;
{
local $@;
$have_instance = eval { $_[0]->isa ('Gtk3::Gdk::RGBA') };
}
# This needs to be switched around if/when
# <https://bugzilla.gnome.org/show_bug.cgi?id=682125> is fixed.
if ($have_instance) {
return Glib::Object::Introspection->invoke (
$_GDK_BASENAME, 'RGBA', 'parse', @_);
} else {
my $instance = Gtk3::Gdk::RGBA->new;
my $success = Glib::Object::Introspection->invoke (
$_GDK_BASENAME, 'RGBA', 'parse',
$instance, @_);
return $success ? $instance : undef;
}
}
=item * C<Gtk3::Gdk::Window::new> optionally computes the C<attr_mask>
automatically from the given C<attr>.
=cut
sub Gtk3::Gdk::Window::new {
my ($class, $parent, $attr, $attr_mask) = @_;
if (not defined $attr_mask) {
$attr_mask = Gtk3::Gdk::WindowAttributesType->new ([]);
if (exists $attr->{title}) { $attr_mask |= 'GDK_WA_TITLE' }
if (exists $attr->{x}) { $attr_mask |= 'GDK_WA_X' }
if (exists $attr->{y}) { $attr_mask |= 'GDK_WA_Y' }
if (exists $attr->{cursor}) { $attr_mask |= 'GDK_WA_CURSOR' }
if (exists $attr->{visual}) { $attr_mask |= 'GDK_WA_VISUAL' }
if (exists $attr->{wmclass_name} && exists $attr->{wmclass_class}) { $attr_mask |= 'GDK_WA_WMCLASS' }
if (exists $attr->{override_redirect}) { $attr_mask |= 'GDK_WA_NOREDIR' }
if (exists $attr->{type_hint}) { $attr_mask |= 'GDK_WA_TYPE_HINT' }
if (!Gtk3::CHECK_VERSION (3, 4, 4)) {
# Before 3.4.4 or 3.5.6, the attribute mask parameter lacked proper
# annotations, hence we numerify it here. FIXME: This breaks
# encapsulation.
$attr_mask = $$attr_mask;
}
}
return Glib::Object::Introspection->invoke (
$_GDK_BASENAME, 'Window', 'new',
$class, $parent, $attr, $attr_mask);
}
# --- GdkPixbuf ---
sub Gtk3::Gdk::Pixbuf::CHECK_VERSION {
my ($major, $minor, $micro) = @_;
return
(Gtk3::Gdk::PIXBUF_MAJOR () > $major) ||
(Gtk3::Gdk::PIXBUF_MAJOR () == $major && Gtk3::Gdk::PIXBUF_MINOR () > $minor) ||
(Gtk3::Gdk::PIXBUF_MAJOR () == $major && Gtk3::Gdk::PIXBUF_MINOR () == $minor && Gtk3::Gdk::PIXBUF_MICRO () >= $micro);
}
=item * C<Gtk3::Gdk::Pixbuf::get_pixels> returns a byte string.
=cut
sub Gtk3::Gdk::Pixbuf::get_pixels {
my $pixel_aref = Glib::Object::Introspection->invoke (
$_GDK_PIXBUF_BASENAME, 'Pixbuf', 'get_pixels', @_);
return pack 'C*', @{$pixel_aref};
}
=item * C<Gtk3::Gdk::Pixbuf::new_from_data> is reimplemented in terms of
C<new_from_bytes> (with gdk-pixbuf >= 2.32) or C<new_from_inline> (with
gtk-pixbuf < 2.32) for correct memory management. No C<destroy_fn> and
C<destroy_fn_data> arguments are needed.
=cut
sub Gtk3::Gdk::Pixbuf::new_from_data {
my ($class, $data, $colorspace, $has_alpha, $bits_per_sample, $width, $height, $rowstride) = @_;
if (Gtk3::Gdk::Pixbuf::CHECK_VERSION (2, 32, 0)) {
my $packed_data = ref($data) eq 'ARRAY' ? pack 'C*', @$data : $data;
return Gtk3::Gdk::Pixbuf->new_from_bytes(
Glib::Bytes->new($packed_data),
$colorspace, $has_alpha,
$bits_per_sample, $width,
$height, $rowstride);
} else {
die 'Only RGB is currently supported' unless $colorspace eq 'rgb';
die 'Only 8 bits per pixel are currently supported'
unless $bits_per_sample == 8;
my $length = Gtk3::Gdk::PIXDATA_HEADER_LENGTH () +
$rowstride*$height;
my $type = Gtk3::Gdk::PixdataType->new ([qw/sample_width_8 encoding_raw/]);
$type |= $has_alpha ? 'color_type_rgba' : 'color_type_rgb';
my @header_numbers = (0x47646b50,
$length,
$$type, # FIXME: This kind of breaks encapsulation.
$rowstride,
$width,
$height);
# Convert to 8 bit unsigned chars, padding to 32 bit little-endian first.
my @header = map { unpack ("C*", pack ("N", $_)) } @header_numbers;
my $inline_data = _unpack_unless_array_ref ($data);
unshift @$inline_data, @header;
return Gtk3::Gdk::Pixbuf->new_from_inline ($inline_data);
}
}
=item * C<Gtk3::Gdk::Pixbuf::new_from_inline> does not take a C<copy_pixels>
argument. It is always set to TRUE for correct memory management.
=cut
sub Gtk3::Gdk::Pixbuf::new_from_inline {
my ($class, $data) = @_;
return Glib::Object::Introspection->invoke (
$_GDK_PIXBUF_BASENAME, 'Pixbuf', 'new_from_inline',
$class, _unpack_unless_array_ref ($data), Glib::TRUE); # always copy pixels
}
=item * C<Gtk3::Gdk::Pixbuf::new_from_xpm_data> also accepts a list of XPM
lines.
=cut
sub Gtk3::Gdk::Pixbuf::new_from_xpm_data {
my ($class, @rest) = @_;
my $data = _rest_to_ref (\@rest);
return Glib::Object::Introspection->invoke (
$_GDK_PIXBUF_BASENAME, 'Pixbuf', 'new_from_xpm_data',
$class, $data);
}
# Version check for the new annotations described in
# <https://bugzilla.gnome.org/show_bug.cgi?id=670372>.
my $_GET_SAVE_VARIANT = sub {
my ($method) = @_;
if (Gtk3::Gdk::Pixbuf::CHECK_VERSION (2, 31, 3)) {
return $method . 'v';
} elsif (Gtk3::Gdk::Pixbuf::CHECK_VERSION (2, 31, 2)) {
return $method;
} else {
return $method . 'v';
}
};
=item * C<Gtk3::Gdk::Pixbuf::save>, C<save_to_buffer> and C<save_to_callback>
also accept C<< key => value >> pairs and invoke the correct C function as
appropriate for the current gdk-pixbuf version.
=cut
sub Gtk3::Gdk::Pixbuf::save {
my ($pixbuf, $filename, $type, @rest) = @_;
my ($keys, $values) = _unpack_keys_and_values (\@rest);
if (not defined $keys) {
croak ("Usage: \$pixbuf->save (\$filename, \$type, \\\@keys, \\\@values)\n",
" -or-: \$pixbuf->save (\$filename, \$type, \$key1 => \$value1, ...)");
}
my $method = $_GET_SAVE_VARIANT->('save');
Glib::Object::Introspection->invoke (
$_GDK_PIXBUF_BASENAME, 'Pixbuf', $method,
$pixbuf, $filename, $type, $keys, $values);
}
sub Gtk3::Gdk::Pixbuf::save_to_buffer {
my ($pixbuf, $type, @rest) = @_;
my ($keys, $values) = _unpack_keys_and_values (\@rest);
if (not defined $keys) {
croak ("Usage: \$pixbuf->save_to_buffer (\$type, \\\@keys, \\\@values)\n",
" -or-: \$pixbuf->save_to_buffer (\$type, \$key1 => \$value1, ...)");
}
my $method = $_GET_SAVE_VARIANT->('save_to_buffer');
my (undef, $buffer) =
Glib::Object::Introspection->invoke (
$_GDK_PIXBUF_BASENAME, 'Pixbuf', $method,
$pixbuf, $type, $keys, $values);
return $buffer;
}
sub Gtk3::Gdk::Pixbuf::save_to_callback {
my ($pixbuf, $save_func, $user_data, $type, @rest) = @_;
my ($keys, $values) = _unpack_keys_and_values (\@rest);
if (not defined $keys) {
croak ("Usage: \$pixbuf->save_to_callback (\$save_func, \$user_data, \$type, \\\@keys, \\\@values)\n",
" -or-: \$pixbuf->save_to_callback (\$save_func, \$user_data, \$type, \$key1 => \$value1, ...)");
}
my $method = $_GET_SAVE_VARIANT->('save_to_callback');
Glib::Object::Introspection->invoke (
$_GDK_PIXBUF_BASENAME, 'Pixbuf', $method,
$pixbuf, $save_func, $user_data, $type, $keys, $values);
}
# --- Pango ---
=item * The C<length> arguments of C<Pango::Layout::set_text> and C<set_markup>
are optional.
=cut
sub Pango::Layout::set_text {
return Glib::Object::Introspection->invoke (
$_PANGO_BASENAME, 'Layout', 'set_text',
@_ == 3 ? @_ : (@_[0,1], -1)); # wants length in bytes
}
sub Pango::Layout::set_markup {
return Glib::Object::Introspection->invoke (
$_PANGO_BASENAME, 'Layout', 'set_markup',
@_ == 3 ? @_ : (@_[0,1], -1)); # wants length in bytes
}
=back
=cut
# - Fixes ------------------------------------------------------------------- #
=head2 Perl compatibility
As of 5.20.0, perl does not automatically re-check the locale environment for
changes. If a function thus changes the locale behind perl's back, problems
might arise whenever numbers are formatted, for example when checking versions.
To ensure perl's assumption about the locale are up-to-date, the functions
C<Gtk3::init>, C<init_check>, C<init_with_args> and C<parse_args> are amended
to let perl know of any changes.
=cut
# Compatibility with perl 5.20 and non-dot locales. Wrap all functions that
# might end up calling setlocale() such that POSIX::setlocale() is also called
# to ensure perl knows about the current locale. See the discussion in
# <https://rt.perl.org/Public/Bug/Display.html?id=121930>,
# <https://rt.perl.org/Public/Bug/Display.html?id=121317>,
# <https://rt.perl.org/Public/Bug/Display.html?id=120723>.
if ($^V ge v5.20.0) {
require POSIX;
no strict 'refs';
no warnings 'redefine';
my $disable_setlocale = 0;
*{'Gtk3::disable_setlocale'} = sub {
$disable_setlocale = 1;
Glib::Object::Introspection->invoke (
$_GTK_BASENAME, undef, 'disable_setlocale', @_);
};
# These two already have overrides.
foreach my $function (qw/Gtk3::init Gtk3::init_check/) {
my $orig = \&{$function};
*{$function} = sub {
if (!$disable_setlocale) {
POSIX::setlocale (POSIX::LC_ALL (), '');
}
$orig->(@_);
};
}
foreach my $function (qw/init_with_args parse_args/) {
*{'Gtk3::' . $function} = sub {
if (!$disable_setlocale) {
POSIX::setlocale (POSIX::LC_ALL (), '');
}
Glib::Object::Introspection->invoke (
$_GTK_BASENAME, undef, $function, @_);
};
}
}
# - Helpers ----------------------------------------------------------------- #
sub _common_tree_model_new {
my ($package, $class, @types) = @_;
my $real_types;
{
local $@;
$real_types = (@types == 1 && eval { @{$types[0]} })
? $types[0]
: \@types;
}
return Glib::Object::Introspection->invoke (
$_GTK_BASENAME, $package, 'new',
$class, $real_types);
}
sub _common_tree_model_set {
my ($package, $model, $iter, @columns_and_values) = @_;
my ($columns, $values) = _unpack_keys_and_values (\@columns_and_values);
if (not defined $columns) {
croak ("Usage: Gtk3::${package}::set (\$model, \$iter, \\\@columns, \\\@values)\n",
" -or-: Gtk3::${package}::set (\$model, \$iter, \$column1 => \$value1, ...)");
}
my @wrapped_values = ();
foreach my $i (0..$#{$columns}) {
my $column_type = $model->get_column_type ($columns->[$i]);
push @wrapped_values,
Glib::Object::Introspection::GValueWrapper->new (
$column_type, $values->[$i]);
}
Glib::Object::Introspection->invoke (
$_GTK_BASENAME, $package, 'set',
$model, $iter, $columns, \@wrapped_values);
}
sub _unpack_keys_and_values {
my ($keys_and_values) = @_;
my (@keys, @values);
my $have_array_refs;
{
local $@;
$have_array_refs =
@$keys_and_values == 2 && eval { @{$keys_and_values->[0]} };
}
if ($have_array_refs) {
@keys = @{$keys_and_values->[0]};
@values = @{$keys_and_values->[1]};
} elsif (@$keys_and_values % 2 == 0) {
# To preserve the order of the key-value pairs, avoid creating an
# intermediate hash.
my @range = 0 .. (@$keys_and_values/2-1);
@keys = @$keys_and_values[map { 2*$_ } @range];
@values = @$keys_and_values[map { 2*$_+1 } @range];
} else {
return ();
}
return (\@keys, \@values);
}
sub _unpack_unless_array_ref {
my ($data) = @_;
local $@;
return eval { @{$data} }
? $data
: [unpack 'C*', $data];
}
sub _rest_to_ref {
my ($rest) = @_;
local $@;
if (scalar @$rest == 1 && eval { defined $rest->[0]->[0] }) {
return $rest->[0];
} else {
return $rest;
}
}
package Gtk3::Gdk::EventMask;
$Gtk3::Gdk::EventMask::VERSION = '0.038';
use overload
'==' => \&eq,
'>=' => \&ge;
use Scalar::Util qw/looks_like_number/;
my $_convert_one = sub {
return Glib::Object::Introspection->convert_flags_to_sv (
'Gtk3::Gdk::EventMask', $_[0]);
};
my $_convert_two = sub {
my ($a, $b) = @_;
if (looks_like_number ($a)) {
$a = $_convert_one->($a);
}
if (looks_like_number ($b)) {
$b = $_convert_one->($b);
}
return ($a, $b);
};
sub eq {
my ($a, $b, $swap) = @_;
($a, $b) = $_convert_two->($a, $b);
return Glib::Flags::eq ($a, $b, $swap);
}
sub ge {
my ($a, $b, $swap) = @_;
($a, $b) = $_convert_two->($a, $b);
return Glib::Flags::ge ($a, $b, $swap);
}
package Gtk3;
1;
__END__
=head2 Porting from Gtk2 to Gtk3
The majority of the API has not changed, so as a first approximation you can
run C<< s/Gtk2/Gtk3/ >> on your application. A big exception to this rule is
APIs that were deprecated in gtk+ 2.x -- these were all removed from gtk+ 3.0
and thus from L<Gtk3>. The migration guide at
L<http://developer.gnome.org/gtk3/stable/migrating.html> describes what to use
instead. Apart from this, here is a list of some other incompatible
differences between L<Gtk2> and L<Gtk3>:
=over
=item * The call syntax for class-static methods is now always
C<< Gtk3::Stock::lookup >> instead of C<< Gtk3::Stock->lookup >>.
=item * The %Gtk2::Gdk::Keysyms hash is gone; instead of C<<
Gtk2::Gdk::Keysyms{XYZ} >>, use C<< Gtk3::Gdk::KEY_XYZ >>.
=item * The Gtk2::Pango compatibility wrapper was not carried over; simply use
the namespace "Pango" everywhere. It gets set up automatically when loading
L<Gtk3>.
=item * The types Gtk3::Allocation and Gtk3::Gdk::Rectangle are now aliases for
Cairo::RectangleInt, and as such they are represented as plain hashes with
keys 'width', 'height', 'x' and 'y'.
=item * Gtk3::Editable: Callbacks connected to the "insert-text" signal do not
have as many options anymore as they had in Gtk2. Changes to arguments will
not be propagated to the next signal handler, and only the updated position can
and must be returned.
=item * Gtk3::Menu: In gtk+ < 3.16, the position callback passed to popup()
does not receive x and y parameters.
=item * Gtk3::RadioAction: The constructor now follows the C API.
=item * Gtk3::TreeModel: iter_next() is now a method that is modifying the iter
directly, instead of returning a new one. rows_reordered() and the
"rows-reordered" signal are currently unusable.
=item * Gtk3::TreeSelection: get_selected_rows() now returns two values: an
array ref containing the selected paths, and the model. get_user_data() is not
available currently.
=item * Gtk3::TreeSortable: get_sort_column_id() has an additional boolean
return value.
=item * Gtk3::TreeStore, Gtk3::ListStore: reorder() is currently unusable.
=item * Gtk3::Widget: grab_add() and grab_remove() are methods now: C<<
$widget->grab_add >>, C<< $widget->grab_remove >>.
=item * Gtk3::Gdk::Atom: The constructor new() is not provided anymore, and the
class function intern() must now be called as C<< Gtk3::Gdk::Atom::intern
(name, only_if_exists) >>.
=item * Implementations of Gtk3::TreeModel: Gtk3::TreeIter now has a
constructor called new() expecting C<< key => value >> pairs;
new_from_arrayref() does not exist anymore. To access the contents of
Gtk3::TreeIter, use stamp(), user_data(), user_data2() and user_data3();
to_arrayref() does not exist anymore. GET_ITER(), ITER_CHILDREN(),
ITER_NTH_CHILD() and ITER_PARENT() must return an additional boolean value.
ITER_NEXT() must modify the iter and return a boolean rather than return a new
iter. GET_VALUE() must return the value wrapped with C<<
Glib::Object::Introspection::GValueWrapper->new >>.
=item * Implementations of Gtk3::CellLayout: GET_CELLS() now needs to return an
array ref instead of a list.
=back
Note also that Gtk3::CHECK_VERSION will always fail when passed 2.y.z, so if
you have any existing version checks in your code, you will most likely need to
remove them.
=head1 SEE ALSO
=over
=item * To discuss Gtk3 and ask questions join gtk-perl-list@gnome.org at
L<http://mail.gnome.org/mailman/listinfo/gtk-perl-list>.
=item * Also have a look at the gtk2-perl website and sourceforge project page,
L<http://gtk2-perl.sourceforge.net>.
=item * L<Glib>
=item * L<Glib::Object::Introspection>
=back
=head1 AUTHORS
=over
=item Torsten Schönfeld <kaffeetisch@gmx.de>
=back
=head1 COPYRIGHT AND LICENSE
Copyright (C) 2011-2015 by Torsten Schoenfeld <kaffeetisch@gmx.de>
This library is free software; you can redistribute it and/or modify it under
the terms of the GNU Library General Public License as published by the Free
Software Foundation; either version 2.1 of the License, or (at your option) any
later version.
=cut
Reference in New Issue View Git Blame Copy Permalink