File Coverage

blib/lib/Gtk3.pm
Criterion Covered Total %
statement 10 12 83.3
branch n/a
condition n/a
subroutine 4 4 100.0
pod n/a
total 14 16 87.5


line stmt bran cond sub pod time code
1             package Gtk3;
2             $Gtk3::VERSION = '0.033';
3             =encoding utf8
4              
5             =head1 NAME
6              
7             Gtk3 - Perl interface to the 3.x series of the gtk+ toolkit
8              
9             =head1 SYNOPSIS
10              
11             use Gtk3 -init;
12             my $window = Gtk3::Window->new ('toplevel');
13             my $button = Gtk3::Button->new ('Quit');
14             $button->signal_connect (clicked => sub { Gtk3::main_quit });
15             $window->add ($button);
16             $window->show_all;
17             Gtk3::main;
18              
19             =head1 ABSTRACT
20              
21             Perl bindings to the 3.x series of the gtk+ toolkit. This module allows you to
22             write graphical user interfaces in a Perlish and object-oriented way, freeing
23             you from the casting and memory management in C, yet remaining very close in
24             spirit to original API.
25              
26             =head1 DESCRIPTION
27              
28             The C module allows a Perl developer to use the gtk+ graphical user
29             interface library. Find out more about gtk+ at L.
30              
31             The gtk+ reference manual is also a handy companion when writing C
32             programs in Perl: L. The Perl
33             bindings follow the C API very closely, and the C reference documentation
34             should be considered the canonical source. The principles underlying the
35             mapping from C to Perl are explained in the documentation of
36             L, on which C is based.
37              
38             L also comes with the C program which
39             displays the API reference documentation of all installed libraries organized
40             in accordance with these principles.
41              
42             =cut
43              
44 22     22   1693408 use strict;
  22         316  
  22         850  
45 22     22   164 use warnings;
  22         52  
  22         1025  
46 22     22   172 use Carp qw/croak/;
  22         53  
  22         1315  
47 22     22   20548 use Cairo::GObject;
  0            
  0            
48             use Glib::Object::Introspection;
49             use Exporter;
50              
51             our @ISA = qw(Exporter);
52              
53             =head2 Wrapped libraries
54              
55             C automatically sets up the following correspondence between C libraries
56             and Perl packages:
57              
58             Library | Package
59             --------------+----------
60             Gtk-3.0 | Gtk3
61             Gdk-3.0 | Gtk3::Gdk
62             GdkPixbuf-2.0 | Gtk3::Gdk
63             Pango-1.0 | Pango
64              
65             =cut
66              
67             =head2 Import arguments
68              
69             When importing C, you can pass C<-init> as in C<< use Gtk3 -init; >> to
70             have C automatically called. You can also pass a version number to
71             require a certain version of C.
72              
73             =cut
74              
75             my $_GTK_BASENAME = 'Gtk';
76             my $_GTK_VERSION = '3.0';
77             my $_GTK_PACKAGE = 'Gtk3';
78              
79             my $_GDK_BASENAME = 'Gdk';
80             my $_GDK_VERSION = '3.0';
81             my $_GDK_PACKAGE = 'Gtk3::Gdk';
82              
83             my $_GDK_PIXBUF_BASENAME = 'GdkPixbuf';
84             my $_GDK_PIXBUF_VERSION = '2.0';
85             my $_GDK_PIXBUF_PACKAGE = 'Gtk3::Gdk';
86              
87             my $_PANGO_BASENAME = 'Pango';
88             my $_PANGO_VERSION = '1.0';
89             my $_PANGO_PACKAGE = 'Pango';
90              
91             =head2 Customizations and overrides
92              
93             In order to make things more Perlish or to make porting from C to C
94             easier, C customizes the API generated by L
95             in a few spots:
96              
97             =over
98              
99             =cut
100              
101             # - Customizations ---------------------------------------------------------- #
102              
103             =item * The array ref normally returned by the following functions is flattened
104             into a list:
105              
106             =over
107              
108             =item Gtk3::ActionGroup::list_actions
109              
110             =item Gtk3::Builder::get_objects
111              
112             =item Gtk3::CellLayout::get_cells
113              
114             =item Gtk3::Container::get_children
115              
116             =item Gtk3::SizeGroup::get_widgets
117              
118             =item Gtk3::TreePath::get_indices
119              
120             =item Gtk3::TreeView::get_columns
121              
122             =item Gtk3::UIManager::get_action_groups
123              
124             =item Gtk3::UIManager::get_toplevels
125              
126             =item Gtk3::Window::list_toplevels
127              
128             =item Gtk3::stock_list_ids
129              
130             =item Gtk3::Gdk::Pixbuf::get_formats
131              
132             =back
133              
134             =cut
135              
136             my @_GTK_FLATTEN_ARRAY_REF_RETURN_FOR = qw/
137             Gtk3::ActionGroup::list_actions
138             Gtk3::Builder::get_objects
139             Gtk3::CellLayout::get_cells
140             Gtk3::Container::get_children
141             Gtk3::SizeGroup::get_widgets
142             Gtk3::TreePath::get_indices
143             Gtk3::TreeView::get_columns
144             Gtk3::UIManager::get_action_groups
145             Gtk3::UIManager::get_toplevels
146             Gtk3::Window::list_toplevels
147             Gtk3::stock_list_ids
148             /;
149              
150             my @_GDK_PIXBUF_FLATTEN_ARRAY_REF_RETURN_FOR = qw/
151             Gtk3::Gdk::Pixbuf::get_formats
152             /;
153              
154             =item * The following functions normally return a boolean and additional out
155             arguments, where the boolean indicates whether the out arguments are valid.
156             They are altered such that when the boolean is true, only the additional out
157             arguments are returned, and when the boolean is false, an empty list is
158             returned.
159              
160             =over
161              
162             =item Gtk3::TextBuffer::get_selection_bounds
163              
164             =item Gtk3::TreeModel::get_iter
165              
166             =item Gtk3::TreeModel::get_iter_first
167              
168             =item Gtk3::TreeModel::get_iter_from_string
169              
170             =item Gtk3::TreeModel::iter_children
171              
172             =item Gtk3::TreeModel::iter_nth_child
173              
174             =item Gtk3::TreeModel::iter_parent
175              
176             =item Gtk3::TreeModelFilter::convert_child_iter_to_iter
177              
178             =item Gtk3::TreeModelSort::convert_child_iter_to_iter
179              
180             =item Gtk3::TreeSelection::get_selected
181              
182             =item Gtk3::TreeView::get_dest_row_at_pos
183              
184             =item Gtk3::TreeView::get_path_at_pos
185              
186             =item Gtk3::TreeView::get_tooltip_context
187              
188             =item Gtk3::TreeView::get_visible_range
189              
190             =item Gtk3::TreeViewColumn::cell_get_position
191              
192             =item Gtk3::stock_lookup
193              
194             =item Gtk3::Gdk::Event::get_axis
195              
196             =item Gtk3::Gdk::Event::get_button
197              
198             =item Gtk3::Gdk::Event::get_click_count
199              
200             =item Gtk3::Gdk::Event::get_coords
201              
202             =item Gtk3::Gdk::Event::get_keycode
203              
204             =item Gtk3::Gdk::Event::get_keyval
205              
206             =item Gtk3::Gdk::Event::get_scroll_direction
207              
208             =item Gtk3::Gdk::Event::get_scroll_deltas
209              
210             =item Gtk3::Gdk::Event::get_state
211              
212             =item Gtk3::Gdk::Event::get_root_coords
213              
214             =item Gtk3::Gdk::Window::get_origin
215              
216             =back
217              
218             =cut
219              
220             my @_GTK_HANDLE_SENTINEL_BOOLEAN_FOR = qw/
221             Gtk3::TextBuffer::get_selection_bounds
222             Gtk3::TreeModel::get_iter
223             Gtk3::TreeModel::get_iter_first
224             Gtk3::TreeModel::get_iter_from_string
225             Gtk3::TreeModel::iter_children
226             Gtk3::TreeModel::iter_nth_child
227             Gtk3::TreeModel::iter_parent
228             Gtk3::TreeModelFilter::convert_child_iter_to_iter
229             Gtk3::TreeModelSort::convert_child_iter_to_iter
230             Gtk3::TreeSelection::get_selected
231             Gtk3::TreeView::get_dest_row_at_pos
232             Gtk3::TreeView::get_path_at_pos
233             Gtk3::TreeView::get_tooltip_context
234             Gtk3::TreeView::get_visible_range
235             Gtk3::TreeViewColumn::cell_get_position
236             Gtk3::stock_lookup
237             /;
238              
239             my @_GDK_HANDLE_SENTINEL_BOOLEAN_FOR = qw/
240             Gtk3::Gdk::Event::get_axis
241             Gtk3::Gdk::Event::get_button
242             Gtk3::Gdk::Event::get_click_count
243             Gtk3::Gdk::Event::get_coords
244             Gtk3::Gdk::Event::get_keycode
245             Gtk3::Gdk::Event::get_keyval
246             Gtk3::Gdk::Event::get_scroll_direction
247             Gtk3::Gdk::Event::get_scroll_deltas
248             Gtk3::Gdk::Event::get_state
249             Gtk3::Gdk::Event::get_root_coords
250             Gtk3::Gdk::Window::get_origin
251             /;
252              
253             my @_GTK_USE_GENERIC_SIGNAL_MARSHALLER_FOR = (
254             ['Gtk3::Editable', 'insert-text'],
255             ['Gtk3::Dialog', 'response', \&Gtk3::Dialog::_gtk3_perl_response_converter],
256             ['Gtk3::InfoBar', 'response', \&Gtk3::Dialog::_gtk3_perl_response_converter],
257             );
258              
259             =item * Values of type Gtk3::ResponseType are converted to and from nick names
260             if possible, while still allowing raw IDs, in the following places:
261              
262             =over
263              
264             =item - For Gtk3::Dialog and Gtk3::InfoBar: the signal C as well as
265             the methods C, C, C, C,
266             C and C.
267              
268             =item - For Gtk3::Dialog: the methods C,
269             C, C and C.
270              
271             =back
272              
273             =cut
274              
275             # GtkResponseType: id <-> nick
276             my $_GTK_RESPONSE_ID_TO_NICK = sub {
277             my ($id) = @_;
278             {
279             local $@;
280             my $nick = eval { Glib::Object::Introspection->convert_enum_to_sv (
281             'Gtk3::ResponseType', $id) };
282             return $nick if defined $nick;
283             }
284             return $id;
285             };
286             my $_GTK_RESPONSE_NICK_TO_ID = sub {
287             my ($nick) = @_;
288             {
289             local $@;
290             my $id = eval { Glib::Object::Introspection->convert_sv_to_enum (
291             'Gtk3::ResponseType', $nick) };
292             return $id if defined $id;
293             }
294             return $nick;
295             };
296              
297             # Converter for GtkDialog's "response" signal.
298             sub Gtk3::Dialog::_gtk3_perl_response_converter {
299             my ($dialog, $id, $data) = @_;
300             return ($dialog, $_GTK_RESPONSE_ID_TO_NICK->($id), $data);
301             }
302              
303             =item * Values of type Gtk3::IconSize are converted to and from nick names if
304             possible, while still allowing raw IDs, in the following places:
305              
306             =over
307              
308             =item - Gtk3::Image: the constructors new_from_stock, new_from_icon_set,
309             new_from_icon_name and new_from_gicon, the getters get_stock, get_icon_set,
310             get_icon_name and get_gicon and the setters set_from_stock, set_from_icon_set,
311             set_from_icon_name, set_from_gicon.
312              
313             =item - Gtk3::Widget: the method render_icon.
314              
315             =back
316              
317             =cut
318              
319             # GtkIconSize: id <-> nick
320             my $_GTK_ICON_SIZE_ID_TO_NICK = sub {
321             my ($id) = @_;
322             {
323             local $@;
324             my $nick = eval { Glib::Object::Introspection->convert_enum_to_sv (
325             'Gtk3::IconSize', $id) };
326             return $nick if defined $nick;
327             }
328             {
329             my $nick = Gtk3::IconSize::get_name ($id);
330             return $nick if defined $nick;
331             }
332             return $id;
333             };
334             my $_GTK_ICON_SIZE_NICK_TO_ID = sub {
335             my ($nick) = @_;
336             {
337             local $@;
338             my $id = eval { Glib::Object::Introspection->convert_sv_to_enum (
339             'Gtk3::IconSize', $nick) };
340             return $id if defined $id;
341             }
342             {
343             my $id = Gtk3::IconSize::from_name ($nick);
344             return $id if $id;# if it's not zero
345             }
346             return $nick;
347             };
348              
349             =item * The constants C and C can be
350             used in handlers for event signals like C to indicate whether
351             or not the event should continue propagating through the widget hierarchy.
352              
353             =cut
354              
355             # Names "STOP" and "PROPAGATE" here are per the GtkWidget event signal
356             # descriptions. In some other flavours of signals the jargon is "handled"
357             # instead of "stop". "Handled" matches g_signal_accumulator_true_handled(),
358             # though that function doesn't rate a mention in the Gtk docs. There's
359             # nothing fixed in the idea of "true means cease emission" (whether it's
360             # called "stop" or "handled"). You can just as easily have false for cease
361             # (the way the underlying GSignalAccumulator func in fact operates). The
362             # upshot being don't want to attempt to be too universal with the names
363             # here; "EVENT" is meant to hint at the context or signal flavour they're
364             # for use with.
365             sub Gtk3::EVENT_PROPAGATE() { !1 };
366             sub Gtk3::EVENT_STOP() { 1 };
367              
368             =item * The records corresponding to the various Gtk3::Gdk::Event types, like
369             C or C, are represented as objects blessed into specific
370             Perl packages, like C or C, that
371             all inherit from C. This allows you to seemlessly access
372             type-specific fields as well as common fields, as in C<< $event->window >> or
373             C<< $event->keyval >>.
374              
375             =cut
376              
377             my %_GDK_REBLESSERS = (
378             'Gtk3::Gdk::Event' => \&Gtk3::Gdk::Event::_rebless,
379             );
380              
381             my %_GDK_EVENT_TYPE_TO_PACKAGE = (
382             'expose' => 'Expose',
383             'motion-notify' => 'Motion',
384             'button-press' => 'Button',
385             '2button-press' => 'Button',
386             '3button-press' => 'Button',
387             'button-release' => 'Button',
388             'key-press' => 'Key',
389             'key-release' => 'Key',
390             'enter-notify' => 'Crossing',
391             'leave-notify' => 'Crossing',
392             'focus-change' => 'Focus',
393             'configure' => 'Configure',
394             'property-notify' => 'Property',
395             'selection-clear' => 'Selection',
396             'selection-request' => 'Selection',
397             'selection-notify' => 'Selection',
398             'proximity-in' => 'Proximity',
399             'proximity-out' => 'Proximity',
400             'drag-enter' => 'DND',
401             'drag-leave' => 'DND',
402             'drag-motion' => 'DND',
403             'drag-status' => 'DND',
404             'drop-start' => 'DND',
405             'drop-finished' => 'DND',
406             'client-event' => 'Client',
407             'visibility-notify' => 'Visibility',
408             'no-expose' => 'NoExpose',
409             'scroll' => 'Scroll',
410             'window-state' => 'WindowState',
411             'setting' => 'Setting',
412             'owner-change' => 'OwnerChange',
413             'grab-broken' => 'GrabBroken',
414             'damage' => 'Expose',
415             # added in 3.4:
416             'touch-begin' => 'Touch',
417             'touch-update' => 'Touch',
418             'touch-end' => 'Touch',
419             'touch-cancel' => 'Touch',
420             # added in 3.6:
421             'double-button-press' => 'Button',
422             'triple-button-press' => 'Button',
423             );
424              
425             # Make all of the above sub-types inherit from Gtk3::Gdk::Event.
426             {
427             no strict qw(refs);
428             my %seen;
429             foreach (grep { !$seen{$_}++ } values %_GDK_EVENT_TYPE_TO_PACKAGE) {
430             push @{'Gtk3::Gdk::Event' . $_ . '::ISA'}, 'Gtk3::Gdk::Event';
431             }
432             }
433              
434             sub Gtk3::Gdk::Event::_rebless {
435             my ($event) = @_;
436             my $package = 'Gtk3::Gdk::Event';
437             if (exists $_GDK_EVENT_TYPE_TO_PACKAGE{$event->type}) {
438             $package .= $_GDK_EVENT_TYPE_TO_PACKAGE{$event->type};
439             }
440             return bless $event, $package;
441             }
442              
443             # - Wiring ------------------------------------------------------------------ #
444              
445             =item * Gtk3::Gdk::Atom has overloads for the C<==> and C operators that
446             check for equality of the underlying atoms.
447              
448             =cut
449              
450             sub import {
451             my $class = shift;
452              
453             Glib::Object::Introspection->setup (
454             basename => $_GTK_BASENAME,
455             version => $_GTK_VERSION,
456             package => $_GTK_PACKAGE,
457             flatten_array_ref_return_for => \@_GTK_FLATTEN_ARRAY_REF_RETURN_FOR,
458             handle_sentinel_boolean_for => \@_GTK_HANDLE_SENTINEL_BOOLEAN_FOR,
459             use_generic_signal_marshaller_for => \@_GTK_USE_GENERIC_SIGNAL_MARSHALLER_FOR);
460              
461             Glib::Object::Introspection->setup (
462             basename => $_GDK_BASENAME,
463             version => $_GDK_VERSION,
464             package => $_GDK_PACKAGE,
465             handle_sentinel_boolean_for => \@_GDK_HANDLE_SENTINEL_BOOLEAN_FOR,
466             reblessers => \%_GDK_REBLESSERS);
467              
468             Glib::Object::Introspection->setup (
469             basename => $_GDK_PIXBUF_BASENAME,
470             version => $_GDK_PIXBUF_VERSION,
471             package => $_GDK_PIXBUF_PACKAGE,
472             flatten_array_ref_return_for => \@_GDK_PIXBUF_FLATTEN_ARRAY_REF_RETURN_FOR);
473              
474             Glib::Object::Introspection->setup (
475             basename => $_PANGO_BASENAME,
476             version => $_PANGO_VERSION,
477             package => $_PANGO_PACKAGE);
478              
479             Glib::Object::Introspection->_register_boxed_synonym (
480             "cairo", "RectangleInt", "gdk_rectangle_get_type");
481              
482             # FIXME: This uses an undocumented interface for overloading to avoid the
483             # need for a package declaration.
484             Gtk3::Gdk::Atom->overload::OVERLOAD (
485             '==' => sub { ${$_[0]} == ${$_[1]} },
486             '!=' => sub { ${$_[0]} != ${$_[1]} },
487             fallback => 1);
488              
489             my $init = 0;
490             my @unknown_args = ($class);
491             foreach (@_) {
492             if (/^-?init$/) {
493             $init = 1;
494             } else {
495             push @unknown_args, $_;
496             }
497             }
498              
499             if ($init) {
500             Gtk3::init ();
501             }
502              
503             # call into Exporter for the unrecognized arguments; handles exporting and
504             # version checking
505             Gtk3->export_to_level (1, @unknown_args);
506             }
507              
508             # - Overrides --------------------------------------------------------------- #
509              
510             =item * For backwards compatibility, C,
511             C, C, C, C,
512             C and C can be called as class-static or as
513             normal functions: for example, C<< Gtk3->main_quit >> and C<< Gtk3::main_quit
514             >> are both supported. Additionally, C and C
515             automatically handle passing and updating C<@ARGV> as appropriate.
516              
517             =cut
518              
519             sub Gtk3::CHECK_VERSION {
520             return not defined Gtk3::check_version(@_ == 4 ? @_[1..3] : @_);
521             }
522              
523             sub Gtk3::check_version {
524             Glib::Object::Introspection->invoke ($_GTK_BASENAME, undef, 'check_version',
525             @_ == 4 ? @_[1..3] : @_);
526             }
527              
528             sub Gtk3::init {
529             my $rest = Glib::Object::Introspection->invoke (
530             $_GTK_BASENAME, undef, 'init',
531             [$0, @ARGV]);
532             @ARGV = @{$rest}[1 .. $#$rest]; # remove $0
533             return;
534             }
535              
536             sub Gtk3::init_check {
537             my ($success, $rest) = Glib::Object::Introspection->invoke (
538             $_GTK_BASENAME, undef, 'init_check',
539             [$0, @ARGV]);
540             @ARGV = @{$rest}[1 .. $#$rest]; # remove $0
541             return $success;
542             }
543              
544             sub Gtk3::main {
545             # Ignore any arguments passed in.
546             Glib::Object::Introspection->invoke ($_GTK_BASENAME, undef, 'main');
547             }
548              
549             sub Gtk3::main_level {
550             # Ignore any arguments passed in.
551             return Glib::Object::Introspection->invoke ($_GTK_BASENAME, undef, 'main_level');
552             }
553              
554             sub Gtk3::main_quit {
555             # Ignore any arguments passed in.
556             Glib::Object::Introspection->invoke ($_GTK_BASENAME, undef, 'main_quit');
557             }
558              
559             =item * A Perl reimplementation of C is provided.
560              
561             =cut
562              
563             {
564             my $global_about_dialog = undef;
565             my $about_dialog_key = '__gtk3_about_dialog';
566              
567             sub Gtk3::show_about_dialog {
568             # For backwards-compatibility, optionally accept and discard a class
569             # argument.
570             my $parent_or_class = shift;
571             my $parent = defined $parent_or_class && $parent_or_class eq 'Gtk3'
572             ? shift
573             : $parent_or_class;
574             my %props = @_;
575             my $dialog = defined $parent
576             ? $parent->{$about_dialog_key}
577             : $global_about_dialog;
578              
579             if (!$dialog) {
580             $dialog = Gtk3::AboutDialog->new;
581             $dialog->signal_connect (delete_event => sub { $dialog->hide_on_delete });
582             $dialog->signal_connect (response => sub { $dialog->hide });
583             foreach my $prop (keys %props) {
584             $dialog->set ($prop => $props{$prop});
585             }
586             if ($parent) {
587             $dialog->set_modal (Glib::TRUE);
588             $dialog->set_transient_for ($parent);
589             $dialog->set_destroy_with_parent (Glib::TRUE);
590             $parent->{$about_dialog_key} = $dialog;
591             } else {
592             $global_about_dialog = $dialog;
593             }
594             }
595              
596             $dialog->present;
597             }
598             }
599              
600             =item * Perl reimplementations of C,
601             C and C are provided.
602              
603             =cut
604              
605             sub Gtk3::ActionGroup::add_actions {
606             my ($self, $entries, $user_data) = @_;
607              
608             croak 'actions must be a reference to an array of action entries'
609             unless (ref($entries) eq 'ARRAY');
610              
611             croak 'action array is empty'
612             unless (@$entries);
613              
614             my $process = sub {
615             my ($p) = @_;
616             my ($name, $stock_id, $label, $accelerator, $tooltip, $callback);
617              
618             if (ref($p) eq 'ARRAY') {
619             $name = $p->[0];
620             $stock_id = $p->[1];
621             $label = $p->[2];
622             $accelerator = $p->[3];
623             $tooltip = $p->[4];
624             $callback = $p->[5];
625             } elsif (ref($p) eq 'HASH') {
626             $name = $p->{name};
627             $stock_id = $p->{stock_id};
628             $label = $p->{label};
629             $accelerator = $p->{accelerator};
630             $tooltip = $p->{tooltip};
631             $callback = $p->{callback};
632             } else {
633             croak 'action entry must be a reference to a hash or an array';
634             }
635              
636             if (defined($label)) {
637             $label = $self->translate_string($label);
638             }
639             if (defined($tooltip)) {
640             $tooltip = $self->translate_string($tooltip);
641             }
642              
643             my $action = Gtk3::Action->new ($name, $label, $tooltip, $stock_id);
644              
645             if ($callback) {
646             $action->signal_connect ('activate', $callback, $user_data);
647             }
648             $self->add_action_with_accel ($action, $accelerator);
649             };
650              
651             for my $e (@$entries) {
652             $process->($e);
653             }
654             }
655              
656             sub Gtk3::ActionGroup::add_toggle_actions {
657             my ($self, $entries, $user_data) = @_;
658              
659             croak 'entries must be a reference to an array of toggle action entries'
660             unless (ref($entries) eq 'ARRAY');
661              
662             croak 'toggle action array is empty'
663             unless (@$entries);
664              
665             my $process = sub {
666             my ($p) = @_;
667             my ($name, $stock_id, $label, $accelerator, $tooltip,
668             $callback, $is_active);
669              
670             if (ref($p) eq 'ARRAY') {
671             $name = $p->[0];
672             $stock_id = $p->[1];
673             $label = $p->[2];
674             $accelerator = $p->[3];
675             $tooltip = $p->[4];
676             $callback = $p->[5];
677             $is_active = $p->[6];
678             } elsif (ref($p) eq 'HASH') {
679             $name = $p->{name};
680             $stock_id = $p->{stock_id};
681             $label = $p->{label};
682             $accelerator = $p->{accelerator};
683             $tooltip = $p->{tooltip};
684             $callback = $p->{callback};
685             $is_active = $p->{is_active};
686             } else {
687             croak 'action entry must be a hash or an array';
688             }
689              
690             if (defined($label)) {
691             $label = $self->translate_string($label);
692             }
693             if (defined($tooltip)) {
694             $tooltip = $self->translate_string($tooltip);
695             }
696              
697             my $action = Gtk3::ToggleAction->new (
698             $name, $label, $tooltip, $stock_id);
699             $action->set_active ($is_active) if defined $is_active;
700              
701             if ($callback) {
702             $action->signal_connect ('activate', $callback, $user_data);
703             }
704              
705             $self->add_action_with_accel ($action, $accelerator);
706             };
707              
708             for my $e (@$entries) {
709             $process->($e);
710             }
711             }
712              
713             sub Gtk3::ActionGroup::add_radio_actions {
714             my ($self, $entries, $value, $on_change, $user_data) = @_;
715              
716             croak 'radio_action_entries must be a reference to '
717             . 'an array of action entries'
718             unless (ref($entries) eq 'ARRAY');
719              
720             croak 'radio action array is empty'
721             unless (@$entries);
722              
723             my $first_action = undef;
724              
725             my $process = sub {
726             my ($group, $p) = @_;
727             my ($name, $stock_id, $label, $accelerator, $tooltip, $entry_value);
728              
729             if (ref($p) eq 'ARRAY') {
730             $name = $p->[0];
731             $stock_id = $p->[1];
732             $label = $p->[2];
733             $accelerator = $p->[3];
734             $tooltip = $p->[4];
735             $entry_value = $p->[5];
736             } elsif (ref($p) eq 'HASH') {
737             $name = $p->{name};
738             $stock_id = $p->{stock_id};
739             $label = $p->{label};
740             $accelerator = $p->{accelerator};
741             $tooltip = $p->{tooltip};
742             $entry_value = $p->{value};
743             } else {
744             croak 'radio action entries neither hash nor array';
745             }
746              
747             if (defined($label)) {
748             $label = $self->translate_string($label);
749             }
750             if (defined($tooltip)) {
751             $tooltip = $self->translate_string($tooltip);
752             }
753              
754             my $action = Gtk3::RadioAction->new (
755             $name, $label, $tooltip, $stock_id, $entry_value);
756              
757             $action->join_group($group);
758              
759             if ($value == $entry_value) {
760             $action->set_active(Glib::TRUE);
761             }
762             $self->add_action_with_accel($action, $accelerator);
763             return $action;
764             };
765              
766             for my $e (@$entries) {
767             my $group = $process->($first_action, $e);
768             if (!$first_action) {
769             $first_action = $group;
770             }
771             }
772              
773             if ($first_action && $on_change) {
774             $first_action->signal_connect ('changed', $on_change, $user_data);
775             }
776             }
777              
778             =item * C and C
779             also accept a list of objects instead of an array ref.
780              
781             =item * C and C don't
782             take length arguments, as they are computed automatically.
783              
784             =cut
785              
786             sub Gtk3::Builder::add_objects_from_file {
787             my ($builder, $filename, @rest) = @_;
788             my $ref = _rest_to_ref (\@rest);
789             return Glib::Object::Introspection->invoke (
790             $_GTK_BASENAME, 'Builder', 'add_objects_from_file',
791             $builder, $filename, $ref);
792             }
793              
794             sub Gtk3::Builder::add_objects_from_string {
795             my ($builder, $string, @rest) = @_;
796             my $ref = _rest_to_ref (\@rest);
797             return Glib::Object::Introspection->invoke (
798             $_GTK_BASENAME, 'Builder', 'add_objects_from_string',
799             $builder, $string, -1, $ref); # wants length in bytes
800             }
801              
802             sub Gtk3::Builder::add_from_string {
803             my ($builder, $string) = @_;
804             return Glib::Object::Introspection->invoke (
805             $_GTK_BASENAME, 'Builder', 'add_from_string',
806             $builder, $string, -1); # wants length in bytes
807             }
808              
809             =item * A Perl reimplementation of C is
810             provided.
811              
812             =cut
813              
814             # Copied from Gtk2.pm
815             sub Gtk3::Builder::connect_signals {
816             my $builder = shift;
817             my $user_data = shift;
818              
819             my $do_connect = sub {
820             my ($object,
821             $signal_name,
822             $user_data,
823             $connect_object,
824             $flags,
825             $handler) = @_;
826             my $func = ($flags & 'after') ? 'signal_connect_after' : 'signal_connect';
827             # we get connect_object when we're supposed to call
828             # signal_connect_object, which ensures that the data (an object)
829             # lives as long as the signal is connected. the bindings take
830             # care of that for us in all cases, so we only have signal_connect.
831             # if we get a connect_object, just use that instead of user_data.
832             $object->$func($signal_name => $handler,
833             $connect_object || $user_data);
834             };
835              
836             # $builder->connect_signals ($user_data)
837             # $builder->connect_signals ($user_data, $package)
838             if ($#_ <= 0) {
839             my $package = shift;
840             $package = caller unless defined $package;
841              
842             $builder->connect_signals_full(sub {
843             my ($builder,
844             $object,
845             $signal_name,
846             $handler_name,
847             $connect_object,
848             $flags) = @_;
849              
850             no strict qw/refs/;
851              
852             my $handler = $handler_name;
853             if (ref $package) {
854             $handler = sub { $package->$handler_name(@_) };
855             } else {
856             if ($package && $handler !~ /::/) {
857             $handler = $package.'::'.$handler_name;
858             }
859             }
860              
861             $do_connect->($object, $signal_name, $user_data, $connect_object,
862             $flags, $handler);
863             });
864             }
865              
866             # $builder->connect_signals ($user_data, %handlers)
867             else {
868             my %handlers = @_;
869              
870             $builder->connect_signals_full(sub {
871             my ($builder,
872             $object,
873             $signal_name,
874             $handler_name,
875             $connect_object,
876             $flags) = @_;
877              
878             return unless exists $handlers{$handler_name};
879              
880             $do_connect->($object, $signal_name, $user_data, $connect_object,
881             $flags, $handlers{$handler_name});
882             });
883             }
884             }
885              
886             =item * The default C constructors of Gtk3::Button, Gtk3::CheckButton,
887             Gtk3::ColorButton, Gtk3::FontButton and Gtk3::ToggleButton reroute to
888             C if given an extra argument.
889              
890             =cut
891              
892             {
893             no strict 'refs';
894             my @button_classes = ([Button => 'new_with_mnemonic'],
895             [CheckButton => 'new_with_mnemonic'],
896             [ColorButton => 'new_with_color'],
897             [FontButton => 'new_with_font'],
898             [ToggleButton => 'new_with_mnemonic']);
899             foreach my $button_pair (@button_classes) {
900             my ($button_class, $button_ctor) = @$button_pair;
901             *{'Gtk3::' . $button_class . '::new'} = sub {
902             my ($class, $thing) = @_;
903             if (defined $thing) {
904             return $class->$button_ctor ($thing);
905             } else {
906             return Glib::Object::Introspection->invoke (
907             $_GTK_BASENAME, $button_class, 'new', @_);
908             }
909             }
910             }
911             }
912              
913             =item * The default C constructor of Gtk3::CheckMenuItem reroutes to
914             C if given an extra argument.
915              
916             =cut
917              
918             sub Gtk3::CheckMenuItem::new {
919             my ($class, $mnemonic) = @_;
920             if (defined $mnemonic) {
921             return $class->new_with_mnemonic ($mnemonic);
922             }
923             return Glib::Object::Introspection->invoke (
924             $_GTK_BASENAME, 'CheckMenuItem', 'new', @_);
925             }
926              
927             =item * The C argument of C is optional.
928              
929             =cut
930              
931             sub Gtk3::Clipboard::set_text {
932             return Glib::Object::Introspection->invoke (
933             $_GTK_BASENAME, 'Clipboard', 'set_text',
934             @_ == 3 ? @_ : (@_[0,1], -1)); # wants length in bytes
935             }
936              
937             =item * Perl reimplementations of C,
938             C and C are provided.
939              
940             =cut
941              
942             sub Gtk3::Container::add_with_properties {
943             my ($container, $widget, @rest) = @_;
944             $widget->freeze_child_notify;
945             $container->add ($widget);
946             if ($widget->get_parent) {
947             $container->child_set ($widget, @rest);
948             }
949             $widget->thaw_child_notify;
950             }
951              
952             sub Gtk3::Container::child_get {
953             my ($container, $child, @rest) = @_;
954             my $properties = _rest_to_ref (\@rest);
955             my @values;
956             foreach my $property (@$properties) {
957             my $pspec = Gtk3::ContainerClass::find_child_property ($container, $property);
958             croak "Cannot find type information for property '$property' on $container"
959             unless defined $pspec;
960             my $value_wrapper = Glib::Object::Introspection::GValueWrapper->new (
961             $pspec->get_value_type, undef);
962             $container->child_get_property ($child, $property, $value_wrapper);
963             push @values, $value_wrapper->get_value;
964             }
965             return @values[0..$#values];
966             }
967              
968             sub Gtk3::Container::child_set {
969             my ($container, $child, @rest) = @_;
970             my ($properties, $values) = _unpack_keys_and_values (\@rest);
971             foreach my $i (0..$#$properties) {
972             my $property = $properties->[$i];
973             my $value = $values->[$i];
974             my $pspec = Gtk3::ContainerClass::find_child_property ($container, $property);
975             croak "Cannot find type information for property '$property' on $container"
976             unless defined $pspec;
977             my $value_wrapper = Glib::Object::Introspection::GValueWrapper->new (
978             $pspec->get_value_type, $value);
979             $container->child_set_property ($child, $property, $value_wrapper);
980             }
981             }
982              
983             =item * C and
984             C are forwarded to the corresponding
985             functions in C.
986              
987             =cut
988              
989             sub Gtk3::Container::find_child_property {
990             return Gtk3::ContainerClass::find_child_property (@_);
991             }
992              
993             sub Gtk3::Container::list_child_properties {
994             my $ref = Gtk3::ContainerClass::list_child_properties (@_);
995             return if not defined $ref;
996             return wantarray ? @$ref : $ref->[$#$ref];
997             }
998              
999             =item * C returns a list of widgets, or an
1000             empty list.
1001              
1002             =cut
1003              
1004             sub Gtk3::Container::get_focus_chain {
1005             my ($container) = @_;
1006             my ($is_set, $widgets) = Glib::Object::Introspection->invoke (
1007             $_GTK_BASENAME, 'Container', 'get_focus_chain',
1008             $container);
1009             return () unless $is_set;
1010             return @$widgets;
1011             }
1012              
1013             =item * C also accepts a list of widgets.
1014              
1015             =cut
1016              
1017             sub Gtk3::Container::set_focus_chain {
1018             my ($container, @rest) = @_;
1019             return Glib::Object::Introspection->invoke (
1020             $_GTK_BASENAME, 'Container', 'set_focus_chain',
1021             $container, _rest_to_ref (\@rest));
1022             }
1023              
1024             =item * C also accepts a string.
1025              
1026             =cut
1027              
1028             sub Gtk3::CssProvider::load_from_data {
1029             my ($self, $data) = @_;
1030             return Glib::Object::Introspection->invoke (
1031             $_GTK_BASENAME, 'CssProvider', 'load_from_data',
1032             $self, _unpack_unless_array_ref ($data));
1033             }
1034              
1035             =item * For Gtk3::Dialog and Gtk3::InfoBar, a Perl implementation of
1036             C is provided.
1037              
1038             =cut
1039              
1040             # Gtk3::Dialog / Gtk3::InfoBar methods due to overlap
1041             {
1042             no strict qw(refs);
1043             foreach my $dialog_package (qw/Dialog InfoBar/) {
1044             *{'Gtk3::' . $dialog_package . '::add_action_widget'} = sub {
1045             Glib::Object::Introspection->invoke (
1046             $_GTK_BASENAME, $dialog_package, 'add_action_widget',
1047             $_[0], $_[1], $_GTK_RESPONSE_NICK_TO_ID->($_[2]));
1048             };
1049             *{'Gtk3::' . $dialog_package . '::add_button'} = sub {
1050             Glib::Object::Introspection->invoke (
1051             $_GTK_BASENAME, $dialog_package, 'add_button',
1052             $_[0], $_[1], $_GTK_RESPONSE_NICK_TO_ID->($_[2]));
1053             };
1054             *{'Gtk3::' . $dialog_package . '::add_buttons'} = sub {
1055             my ($dialog, @rest) = @_;
1056             for (my $i = 0; $i < @rest; $i += 2) {
1057             $dialog->add_button ($rest[$i], $rest[$i+1]);
1058             }
1059             };
1060             *{'Gtk3::' . $dialog_package . '::response'} = sub {
1061             return Glib::Object::Introspection->invoke (
1062             $_GTK_BASENAME, $dialog_package, 'response',
1063             $_[0], $_GTK_RESPONSE_NICK_TO_ID->($_[1]));
1064             };
1065             *{'Gtk3::' . $dialog_package . '::set_default_response'} = sub {
1066             Glib::Object::Introspection->invoke (
1067             $_GTK_BASENAME, $dialog_package, 'set_default_response',
1068             $_[0], $_GTK_RESPONSE_NICK_TO_ID->($_[1]));
1069             };
1070             *{'Gtk3::' . $dialog_package . '::set_response_sensitive'} = sub {
1071             Glib::Object::Introspection->invoke (
1072             $_GTK_BASENAME, $dialog_package, 'set_response_sensitive',
1073             $_[0], $_GTK_RESPONSE_NICK_TO_ID->($_[1]), $_[2]);
1074             };
1075             }
1076             }
1077              
1078             sub Gtk3::Dialog::get_response_for_widget {
1079             my $id = Glib::Object::Introspection->invoke (
1080             $_GTK_BASENAME, 'Dialog', 'get_response_for_widget', @_);
1081             return $_GTK_RESPONSE_ID_TO_NICK->($id);
1082             }
1083              
1084             sub Gtk3::Dialog::get_widget_for_response {
1085             return Glib::Object::Introspection->invoke (
1086             $_GTK_BASENAME, 'Dialog', 'get_widget_for_response',
1087             $_[0], $_GTK_RESPONSE_NICK_TO_ID->($_[1]));
1088             }
1089              
1090             =item * C can optionally be called as C<< Gtk3::Dialog->new
1091             (TITLE, PARENT, FLAGS, ...) >> where C<...> is a series of button text and
1092             response id pairs.
1093              
1094             =cut
1095              
1096             sub Gtk3::Dialog::new {
1097             my ($class, $title, $parent, $flags, @rest) = @_;
1098             if (@_ == 1) {
1099             return Glib::Object::Introspection->invoke (
1100             $_GTK_BASENAME, 'Dialog', 'new', @_);
1101             } elsif ((@_ < 4) || (@rest % 2)){
1102             croak ("Usage: Gtk3::Dialog->new ()\n" .
1103             " or Gtk3::Dialog->new (TITLE, PARENT, FLAGS, ...)\n" .
1104             " where ... is a series of button text and response id pairs");
1105             } else {
1106             my $dialog = Gtk3::Dialog->new;
1107             defined $title and $dialog->set_title ($title);
1108             defined $parent and $dialog->set_transient_for ($parent);
1109             $flags & 'modal' and $dialog->set_modal (Glib::TRUE);
1110             $flags & 'destroy-with-parent' and $dialog->set_destroy_with_parent (Glib::TRUE);
1111             $dialog->add_buttons (@rest);
1112             return $dialog;
1113             }
1114             }
1115              
1116             =item * A Perl implementation of C is provided.
1117              
1118             =cut
1119              
1120             sub Gtk3::Dialog::new_with_buttons {
1121             &Gtk3::Dialog::new;
1122             }
1123              
1124             sub Gtk3::Dialog::run {
1125             my $id = Glib::Object::Introspection->invoke (
1126             $_GTK_BASENAME, 'Dialog', 'run', @_);
1127             return $_GTK_RESPONSE_ID_TO_NICK->($id);
1128             }
1129              
1130             sub Gtk3::Dialog::set_alternative_button_order {
1131             my ($dialog, @rest) = @_;
1132             return unless @rest;
1133             Glib::Object::Introspection->invoke (
1134             $_GTK_BASENAME, 'Dialog', 'set_alternative_button_order_from_array',
1135             $dialog, [map { $_GTK_RESPONSE_NICK_TO_ID->($_) } @rest]);
1136             }
1137              
1138             =item * The C argument of C is optional.
1139              
1140             =cut
1141              
1142             sub Gtk3::Editable::insert_text {
1143             return Glib::Object::Introspection->invoke (
1144             $_GTK_BASENAME, 'Editable', 'insert_text',
1145             @_ == 4 ? @_ : (@_[0,1], -1, $_[2])); # wants length in bytes
1146             }
1147              
1148             =item * A Perl implementation of C is provided.
1149              
1150             =cut
1151              
1152             sub Gtk3::FileChooserDialog::new {
1153             my ($class, $title, $parent, $action, @varargs) = @_;
1154              
1155             if (@varargs % 2) {
1156             croak 'Usage: Gtk3::FileChooserDialog->new' .
1157             ' (title, parent, action, button-text =>' .
1158             " response-id, ...)\n";
1159             }
1160              
1161             my $result = Glib::Object::new (
1162             $class,
1163             title => $title,
1164             action => $action,
1165             );
1166              
1167             if ($parent) {
1168             $result->set_transient_for ($parent);
1169             }
1170              
1171             for (my $i = 0; $i < @varargs; $i += 2) {
1172             $result->add_button ($varargs[$i], $varargs[$i+1]);
1173             }
1174              
1175             return $result;
1176             }
1177              
1178             =item * C uses the defaults homogeneous = FALSE and spacing =
1179             5.
1180              
1181             =cut
1182              
1183             sub Gtk3::HBox::new {
1184             my ($class, $homogeneous, $spacing) = @_;
1185             $homogeneous = 0 unless defined $homogeneous;
1186             $spacing = 5 unless defined $spacing;
1187             return Glib::Object::Introspection->invoke (
1188             $_GTK_BASENAME, 'HBox', 'new', $class, $homogeneous, $spacing);
1189             }
1190              
1191             # Gtk3::Image
1192             {
1193             no strict qw(refs);
1194             foreach my $ctor (qw/new_from_stock new_from_icon_set new_from_icon_name new_from_gicon/) {
1195             *{'Gtk3::Image::' . $ctor} = sub {
1196             my ($class, $thing, $size) = @_;
1197             return Glib::Object::Introspection->invoke (
1198             $_GTK_BASENAME, 'Image', $ctor, $class, $thing,
1199             $_GTK_ICON_SIZE_NICK_TO_ID->($size));
1200             }
1201             }
1202             foreach my $getter (qw/get_stock get_icon_set get_icon_name get_gicon/) {
1203             *{'Gtk3::Image::' . $getter} = sub {
1204             my ($image) = @_;
1205             my ($thing, $size) = Glib::Object::Introspection->invoke (
1206             $_GTK_BASENAME, 'Image', $getter, $image);
1207             return ($thing, $_GTK_ICON_SIZE_ID_TO_NICK->($size));
1208             }
1209             }
1210             foreach my $setter (qw/set_from_stock set_from_icon_set set_from_icon_name set_from_gicon/) {
1211             *{'Gtk3::Image::' . $setter} = sub {
1212             my ($image, $thing, $size) = @_;
1213             Glib::Object::Introspection->invoke (
1214             $_GTK_BASENAME, 'Image', $setter, $image, $thing,
1215             $_GTK_ICON_SIZE_NICK_TO_ID->($size));
1216             }
1217             }
1218             }
1219              
1220             =item * The default C constructor of Gtk3::ImageMenuItem reroutes to
1221             C if given an extra argument.
1222              
1223             =cut
1224              
1225             sub Gtk3::ImageMenuItem::new {
1226             my ($class, $mnemonic) = @_;
1227             if (defined $mnemonic) {
1228             return $class->new_with_mnemonic ($mnemonic);
1229             }
1230             return Glib::Object::Introspection->invoke (
1231             $_GTK_BASENAME, 'ImageMenuItem', 'new', @_);
1232             }
1233              
1234             =item * C can optionally be called as C<<
1235             Gtk3::InfoBar->new (...) >> where C<...> is a series of button text and
1236             response id pairs.
1237              
1238             =cut
1239              
1240             sub Gtk3::InfoBar::new {
1241             my ($class, @buttons) = @_;
1242             if (@_ == 1) {
1243             return Glib::Object::Introspection->invoke (
1244             $_GTK_BASENAME, 'InfoBar', 'new', @_);
1245             } elsif (@buttons % 2) {
1246             croak "Usage: Gtk3::InfoBar->new_with_buttons (button-text => response_id, ...)\n";
1247             } else {
1248             my $infobar = Gtk3::InfoBar->new;
1249             for (my $i = 0; $i < @buttons; $i += 2) {
1250             $infobar->add_button ($buttons[$i], $buttons[$i+1]);
1251             }
1252             return $infobar;
1253             }
1254             }
1255              
1256             =item * A Perl reimplementation of C is
1257             provided.
1258              
1259             =cut
1260              
1261             sub Gtk3::InfoBar::new_with_buttons {
1262             &Gtk3::InfoBar::new;
1263             }
1264              
1265             =item * The default C constructor of Gtk3::LinkButton reroutes to
1266             C if given an extra argument.
1267              
1268             =cut
1269              
1270             sub Gtk3::LinkButton::new {
1271             my ($class, $uri, $label) = @_;
1272             if (defined $label) {
1273             return Gtk3::LinkButton->new_with_label ($uri, $label);
1274             } else {
1275             return Glib::Object::Introspection->invoke (
1276             $_GTK_BASENAME, 'LinkButton', 'new', @_);
1277             }
1278             }
1279              
1280             =item * C also accepts a list of type names.
1281              
1282             =cut
1283              
1284             sub Gtk3::ListStore::new {
1285             return _common_tree_model_new ('ListStore', @_);
1286             }
1287              
1288             =item * Gtk3::ListStore has a C method that calls C
1289             instead of C.
1290              
1291             =cut
1292              
1293             # Reroute 'get' to Gtk3::TreeModel instead of Glib::Object.
1294             sub Gtk3::ListStore::get {
1295             return Gtk3::TreeModel::get (@_);
1296             }
1297              
1298             =item * C also accepts a list of C<<
1299             column => value >> pairs and reroutes to C.
1300              
1301             =cut
1302              
1303             sub Gtk3::ListStore::insert_with_values {
1304             my ($model, $position, @columns_and_values) = @_;
1305             my ($columns, $values) = _unpack_keys_and_values (\@columns_and_values);
1306             if (not defined $columns) {
1307             croak ("Usage: Gtk3::ListStore::insert_with_values (\$model, \$position, \\\@columns, \\\@values)\n",
1308             " -or-: Gtk3::ListStore::insert_with_values (\$model, \$position, \$column1 => \$value1, ...)");
1309             }
1310             my @wrapped_values = ();
1311             foreach my $i (0..$#{$columns}) {
1312             my $column_type = $model->get_column_type ($columns->[$i]);
1313             push @wrapped_values,
1314             Glib::Object::Introspection::GValueWrapper->new (
1315             $column_type, $values->[$i]);
1316             }
1317             return Glib::Object::Introspection->invoke (
1318             $_GTK_BASENAME, 'ListStore', 'insert_with_valuesv', # FIXME: missing rename-to annotation?
1319             $model, $position, $columns, \@wrapped_values);
1320             }
1321              
1322             =item * C also accepts a list of C<< column => value >>
1323             pairs.
1324              
1325             =cut
1326              
1327             sub Gtk3::ListStore::set {
1328             return _common_tree_model_set ('ListStore', @_);
1329             }
1330              
1331             =item * C reroutes to C for better
1332             callback handling.
1333              
1334             =cut
1335              
1336             sub Gtk3::Menu::popup {
1337             my $self = shift;
1338             $self->popup_for_device (undef, @_);
1339             }
1340              
1341             =item * C allows the given menu position func to
1342             return only x and y coordinates, defaulting C to FALSE.
1343              
1344             =cut
1345              
1346             sub Gtk3::Menu::popup_for_device {
1347             my ($menu, $device, $parent_menu_shell, $parent_menu_item, $func, $data, $button, $activate_time) = @_;
1348             my $real_func = $func ? sub {
1349             my @stuff = eval { $func->(@_) };
1350             if ($@) {
1351             warn "*** menu position callback ignoring error: $@";
1352             }
1353             if (@stuff == 3) {
1354             return (@stuff);
1355             } elsif (@stuff == 2) {
1356             return (@stuff, Glib::FALSE); # provide a default for push_in
1357             } else {
1358             warn "*** menu position callback must return two integers " .
1359             "(x, y) or two integers and a boolean (x, y, push_in)";
1360             return (0, 0, Glib::FALSE);
1361             }
1362             } : undef;
1363             return Glib::Object::Introspection->invoke (
1364             $_GTK_BASENAME, 'Menu', 'popup_for_device',
1365             $menu, $device, $parent_menu_shell, $parent_menu_item, $real_func, $data, $button, $activate_time);
1366             }
1367              
1368             =item * The default C constructor of Gtk3::MenuItem reroutes to
1369             C if given an extra argument.
1370              
1371             =cut
1372              
1373             sub Gtk3::MenuItem::new {
1374             my ($class, $mnemonic) = @_;
1375             if (defined $mnemonic) {
1376             return $class->new_with_mnemonic ($mnemonic);
1377             }
1378             return Glib::Object::Introspection->invoke (
1379             $_GTK_BASENAME, 'MenuItem', 'new', @_);
1380             }
1381              
1382             =item * A Perl reimplementation of C is provided.
1383              
1384             =cut
1385              
1386             sub Gtk3::MessageDialog::new {
1387             my ($class, $parent, $flags, $type, $buttons, $format, @args) = @_;
1388             my $dialog = Glib::Object::new ($class, message_type => $type,
1389             buttons => $buttons);
1390             if (defined $format) {
1391             # sprintf can handle empty @args
1392             my $msg = sprintf $format, @args;
1393             $dialog->set (text => $msg);
1394             }
1395             if (defined $parent) {
1396             $dialog->set_transient_for ($parent);
1397             }
1398             if ($flags & 'modal') {
1399             $dialog->set_modal (Glib::TRUE);
1400             }
1401             if ($flags & 'destroy-with-parent') {
1402             $dialog->set_destroy_with_parent (Glib::TRUE);
1403             }
1404             return $dialog;
1405             }
1406              
1407             =item * The group handling in the constructors and accessors of
1408             Gtk3::RadioAction, Gtk3::RadioButton, Gtk3::RadioMenuItem and
1409             Gtk3::RadioToolButton is amended to work correctly when given array refs of
1410             group members or single group members.
1411              
1412             =cut
1413              
1414             # Gtk3::RadioAction, Gtk3::RadioButton, Gtk3::RadioMenuItem and
1415             # Gtk3::RadioToolButton constructors.
1416             {
1417             no strict qw(refs);
1418              
1419             my $group_converter = sub {
1420             my ($ctor, $group_or_member, $package) = @_;
1421             local $@;
1422             # undef => []
1423             if (!defined $group_or_member) {
1424             return ($ctor, []);
1425             }
1426             # [] => []
1427             elsif (eval { $#$group_or_member == -1 }) {
1428             return ($ctor, []);
1429             }
1430             # [member1, ...] => member1
1431             elsif (eval { $#$group_or_member >= 0 }) {
1432             my $member = $group_or_member->[0];
1433             if (defined $member) {
1434             return ($ctor . '_from_widget', $member);
1435             }
1436             return ($ctor, []);
1437             }
1438             # member => member
1439             elsif (eval { $group_or_member->isa ('Gtk3::' . $package) }) {
1440             return ($ctor . '_from_widget', $group_or_member);
1441             }
1442             else {
1443             croak ('Unhandled group or member argument encountered');
1444             }
1445             };
1446              
1447             # Gtk3::RadioAction/Gtk3::RadioButton/Gtk3::RadioMenuItem/Gtk3::RadioToolButton
1448             foreach my $package (qw/RadioAction RadioButton RadioMenuItem RadioToolButton/) {
1449             *{'Gtk3::' . $package . '::set_group'} = sub {
1450             my ($button, $group) = @_;
1451             my $real_group = $group;
1452             if (eval { $#$group >= 0 }) {
1453             $real_group = $group->[0];
1454             }
1455             $button->set (group => $real_group);
1456             };
1457             }
1458              
1459             # Gtk3::RadioButton/Gtk3::RadioMenuItem
1460             foreach my $package (qw/RadioButton RadioMenuItem/) {
1461             foreach my $ctor (qw/new new_with_label new_with_mnemonic/) {
1462             # Avoid using the list-based API, as G:O:I does not support the memory
1463             # ownership semantics. Use the item-based API instead.
1464             *{'Gtk3::' . $package . '::' . $ctor} = sub {
1465             my ($class, $group_or_member, @rest) = @_;
1466             my ($real_ctor, $real_group_or_member) =
1467             $group_converter->($ctor, $group_or_member, $package);
1468             return Glib::Object::Introspection->invoke (
1469             $_GTK_BASENAME, $package, $real_ctor,
1470             $class, $real_group_or_member, @rest);
1471             };
1472              
1473             # Work around .
1474             *{'Gtk3::' . $package . '::' . $ctor . '_from_widget'} = sub {
1475             my ($class, $member, @rest) = @_;
1476             my $real_ctor = $ctor;
1477             my $real_group_or_member = $member;
1478             if (!defined $member) {
1479             $real_group_or_member = [];
1480             } else {
1481             $real_ctor .= '_from_widget';
1482             }
1483             return Glib::Object::Introspection->invoke (
1484             $_GTK_BASENAME, $package, $real_ctor,
1485             $class, $real_group_or_member, @rest);
1486             };
1487             }
1488             }
1489              
1490             # GtkRadioToolButton
1491             foreach my $ctor (qw/new new_from_stock/) {
1492             # Avoid using the list-based API, as G:O:I does not support the memory
1493             # ownership semantics. Use the item-based API instead.
1494             *{'Gtk3::RadioToolButton::' . $ctor} = sub {
1495             my ($class, $group_or_member, @rest) = @_;
1496             my ($real_ctor, $real_group_or_member) =
1497             $group_converter->($ctor, $group_or_member, 'RadioToolButton');
1498             $real_ctor =~ s/_from_stock_from_/_with_stock_from_/; # you gotta be kidding me...
1499             return Glib::Object::Introspection->invoke (
1500             $_GTK_BASENAME, 'RadioToolButton', $real_ctor,
1501             $class, $real_group_or_member, @rest);
1502             };
1503             }
1504             }
1505              
1506             =item * Perl reimplementations of C and
1507             C are provided.
1508              
1509             =cut
1510              
1511             sub Gtk3::RecentChooserDialog::new {
1512             my ($class, $title, $parent, @buttons) = @_;
1513             my $dialog = Glib::Object::new ($class, title => $title);
1514             for (my $i = 0; $i < @buttons; $i += 2) {
1515             $dialog->add_button ($buttons[$i], $buttons[$i+1]);
1516             }
1517             if (defined $parent) {
1518             $dialog->set_transient_for ($parent);
1519             }
1520             return $dialog;
1521             }
1522              
1523             sub Gtk3::RecentChooserDialog::new_for_manager {
1524             my ($class, $title, $parent, $mgr, @buttons) = @_;
1525             my $dialog = Glib::Object::new ($class, title => $title,
1526             recent_manager => $mgr);
1527             for (my $i = 0; $i < @buttons; $i += 2) {
1528             $dialog->add_button ($buttons[$i], $buttons[$i+1]);
1529             }
1530             if (defined $parent) {
1531             $dialog->set_transient_for ($parent);
1532             }
1533             return $dialog;
1534             }
1535              
1536             =item * Redirects are provided from C to
1537             C for C, C, C, C and
1538             C.
1539              
1540             =cut
1541              
1542             {
1543             no strict qw/refs/;
1544              
1545             my %stock_name_corrections = (
1546             'Gtk3::Stock::add' => 'Gtk3::stock_add',
1547             'Gtk3::Stock::add_static' => 'Gtk3::stock_add_static',
1548             'Gtk3::Stock::list_ids' => 'Gtk3::stock_list_ids',
1549             'Gtk3::Stock::lookup' => 'Gtk3::stock_lookup',
1550             'Gtk3::Stock::set_translate_func' => 'Gtk3::stock_set_translate_func',
1551             );
1552              
1553             foreach my $new (keys %stock_name_corrections) {
1554             *{$new} = \&{$stock_name_corrections{$new}};
1555             }
1556             }
1557              
1558             =item * A Perl reimplementation of C is provided.
1559              
1560             =cut
1561              
1562             sub Gtk3::StyleContext::get {
1563             my ($context, $state, @properties) = @_;
1564             my @values = map { $context->get_property ($_, $state) } @properties;
1565             return @values[0..$#values];
1566             }
1567              
1568             =item * A Perl reimplementation of C is provided.
1569              
1570             =cut
1571              
1572             sub Gtk3::TextBuffer::create_tag {
1573             my ($buffer, $tag_name, @rest) = @_;
1574             if (@rest % 2) {
1575             croak ('Usage: $buffer->create_tag ($tag_name, $property1 => $value1, ...');
1576             }
1577             my $tag = Gtk3::TextTag->new ($tag_name);
1578             my $tag_table = $buffer->get_tag_table;
1579             $tag_table->add ($tag);
1580             for (my $i = 0 ; $i < @rest ; $i += 2) {
1581             $tag->set_property ($rest[$i], $rest[$i+1]);
1582             }
1583             return $tag;
1584             }
1585              
1586             =item * The C arguments of C,
1587             C, C, C,
1588             C and C are optional.
1589              
1590             =cut
1591              
1592             sub Gtk3::TextBuffer::insert {
1593             return Glib::Object::Introspection->invoke (
1594             $_GTK_BASENAME, 'TextBuffer', 'insert',
1595             @_ == 4 ? @_ : (@_[0,1,2], -1)); # wants length in bytes
1596             }
1597              
1598             sub Gtk3::TextBuffer::insert_at_cursor {
1599             return Glib::Object::Introspection->invoke (
1600             $_GTK_BASENAME, 'TextBuffer', 'insert_at_cursor',
1601             @_ == 3 ? @_ : (@_[0,1], -1)); # wants length in bytes
1602             }
1603              
1604             sub Gtk3::TextBuffer::insert_interactive {
1605             return Glib::Object::Introspection->invoke (
1606             $_GTK_BASENAME, 'TextBuffer', 'insert_interactive',
1607             @_ == 5 ? @_ : (@_[0,1,2], -1, $_[3])); # wants length in bytes
1608             }
1609              
1610             sub Gtk3::TextBuffer::insert_interactive_at_cursor {
1611             return Glib::Object::Introspection->invoke (
1612             $_GTK_BASENAME, 'TextBuffer', 'insert_interactive_at_cursor',
1613             @_ == 4 ? @_ : (@_[0,1], -1, $_[2])); # wants length in bytes
1614             }
1615              
1616             sub Gtk3::TextBuffer::insert_markup {
1617             return Glib::Object::Introspection->invoke (
1618             $_GTK_BASENAME, 'TextBuffer', 'insert_markup',
1619             @_ == 4 ? @_ : (@_[0,1,2], -1)); # wants length in bytes
1620             }
1621              
1622             =item * Perl reimplementations of C and
1623             C are provided which do not require a C
1624             argument.
1625              
1626             =cut
1627              
1628             sub Gtk3::TextBuffer::insert_with_tags {
1629             my ($buffer, $iter, $text, @tags) = @_;
1630             my $start_offset = $iter->get_offset;
1631             $buffer->insert ($iter, $text);
1632             my $start = $buffer->get_iter_at_offset ($start_offset);
1633             foreach my $tag (@tags) {
1634             $buffer->apply_tag ($tag, $start, $iter);
1635             }
1636             }
1637              
1638             sub Gtk3::TextBuffer::insert_with_tags_by_name {
1639             my ($buffer, $iter, $text, @tag_names) = @_;
1640             my $start_offset = $iter->get_offset;
1641             $buffer->insert ($iter, $text);
1642             my $tag_table = $buffer->get_tag_table;
1643             my $start = $buffer->get_iter_at_offset ($start_offset);
1644             foreach my $tag_name (@tag_names) {
1645             my $tag = $tag_table->lookup ($tag_name);
1646             if (!$tag) {
1647             warn "no tag with name $tag_name";
1648             } else {
1649             $buffer->apply_tag ($tag, $start, $iter);
1650             }
1651             }
1652             }
1653              
1654             sub Gtk3::TextBuffer::set_text {
1655             return Glib::Object::Introspection->invoke (
1656             $_GTK_BASENAME, 'TextBuffer', 'set_text',
1657             @_ == 3 ? @_ : (@_[0,1], -1)); # wants length in bytes
1658             }
1659              
1660             =item * A Perl reimplementation of C is provided.
1661              
1662             =cut
1663              
1664             sub Gtk3::TreeModel::get {
1665             my ($model, $iter, @columns) = @_;
1666             if (!@columns) {
1667             @columns = (0..($model->get_n_columns-1));
1668             }
1669             my @values = map { $model->get_value ($iter, $_) } @columns;
1670             return @values[0..$#values];
1671             }
1672              
1673             =item * A redirect is added from C to
1674             so that Gtk3::TreeModelFilter objects can be
1675             constructed normally.
1676              
1677             =cut
1678              
1679             # Not needed anymore once
1680             # is fixed.
1681             sub Gtk3::TreeModelFilter::new {
1682             my ($class, $child_model, $root) = @_;
1683             Glib::Object::Introspection->invoke (
1684             $_GTK_BASENAME, 'TreeModel', 'filter_new', $child_model, $root);
1685             }
1686              
1687             =item * Gtk3::TreeModelFilter has a C method that calls
1688             C instead of C.
1689              
1690             =cut
1691              
1692             # Reroute 'get' to Gtk3::TreeModel instead of Glib::Object.
1693             sub Gtk3::TreeModelFilter::get {
1694             return Gtk3::TreeModel::get (@_);
1695             }
1696              
1697             =item * A redirect is added from C to
1698             so that Gtk3::TreeModelSort objects can
1699             be constructed normally.
1700              
1701             =cut
1702              
1703             # Not needed anymore once
1704             # is fixed.
1705             sub Gtk3::TreeModelSort::new_with_model {
1706             my ($class, $child_model) = @_;
1707             Glib::Object::Introspection->invoke (
1708             $_GTK_BASENAME, 'TreeModel', 'sort_new_with_model', $child_model);
1709             }
1710              
1711             =item * Gtk3::TreeModelSort has a C method that calls
1712             C instead of C.
1713              
1714             =cut
1715              
1716             # Reroute 'get' to Gtk3::TreeModel instead of Glib::Object.
1717             sub Gtk3::TreeModelSort::get {
1718             return Gtk3::TreeModel::get (@_);
1719             }
1720              
1721             =item * C redirects to C if an additional
1722             argument is given.
1723              
1724             =cut
1725              
1726             sub Gtk3::TreePath::new {
1727             my ($class, @args) = @_;
1728             my $method = (@args == 1) ? 'new_from_string' : 'new';
1729             Glib::Object::Introspection->invoke (
1730             $_GTK_BASENAME, 'TreePath', $method, @_);
1731             }
1732              
1733             =item * A Perl reimplementation of C is
1734             provided.
1735              
1736             =cut
1737              
1738             sub Gtk3::TreePath::new_from_indices {
1739             my ($class, @indices) = @_;
1740             my $path = Gtk3::TreePath->new;
1741             foreach (@indices) {
1742             $path->append_index ($_);
1743             }
1744             return $path;
1745             }
1746              
1747             =item * C also accepts a list of type names.
1748              
1749             =cut
1750              
1751             sub Gtk3::TreeStore::new {
1752             return _common_tree_model_new ('TreeStore', @_);
1753             }
1754              
1755             =item * Gtk3::TreeStore has a C method that calls C
1756             instead of C.
1757              
1758             =cut
1759              
1760             # Reroute 'get' to Gtk3::TreeModel instead of Glib::Object.
1761             sub Gtk3::TreeStore::get {
1762             return Gtk3::TreeModel::get (@_);
1763             }
1764              
1765             =item * C also accepts a list of C<<
1766             column => value >> pairs.
1767              
1768             =cut
1769              
1770             sub Gtk3::TreeStore::insert_with_values {
1771             my ($model, $parent, $position, @columns_and_values) = @_;
1772             my ($columns, $values) = _unpack_keys_and_values (\@columns_and_values);
1773             if (not defined $columns) {
1774             croak ("Usage: Gtk3::TreeStore::insert_with_values (\$model, \$parent, \$position, \\\@columns, \\\@values)\n",
1775             " -or-: Gtk3::TreeStore::insert_with_values (\$model, \$parent, \$position, \$column1 => \$value1, ...)");
1776             }
1777             my @wrapped_values = ();
1778             foreach my $i (0..$#{$columns}) {
1779             my $column_type = $model->get_column_type ($columns->[$i]);
1780             push @wrapped_values,
1781             Glib::Object::Introspection::GValueWrapper->new (
1782             $column_type, $values->[$i]);
1783             }
1784             return Glib::Object::Introspection->invoke (
1785             $_GTK_BASENAME, 'TreeStore', 'insert_with_values',
1786             $model, $parent, $position, $columns, \@wrapped_values);
1787             }
1788              
1789             =item * C also accepts a list of C<< column => value >>
1790             pairs.
1791              
1792             =cut
1793              
1794             sub Gtk3::TreeStore::set {
1795             return _common_tree_model_set ('TreeStore', @_);
1796             }
1797              
1798             =item * C redirects to C if an additional
1799             argument is given.
1800              
1801             =cut
1802              
1803             sub Gtk3::TreeView::new {
1804             my ($class, @args) = @_;
1805             my $method = (@args == 1) ? 'new_with_model' : 'new';
1806             Glib::Object::Introspection->invoke (
1807             $_GTK_BASENAME, 'TreeView', $method, @_);
1808             }
1809              
1810             =item * A Perl reimplementation of
1811             C is provided.
1812              
1813             =cut
1814              
1815             sub Gtk3::TreeView::insert_column_with_attributes {
1816             my ($tree_view, $position, $title, $cell, @rest) = @_;
1817             if (@rest % 2) {
1818             croak ('Usage: $tree_view->insert_column_with_attributes (position, title, cell_renderer, attr1 => col1, ...)');
1819             }
1820             my $column = Gtk3::TreeViewColumn->new;
1821             my $n = $tree_view->insert_column ($column, $position);
1822             $column->set_title ($title);
1823             $column->pack_start ($cell, Glib::TRUE);
1824             for (my $i = 0; $i < @rest; $i += 2) {
1825             $column->add_attribute ($cell, $rest[$i], $rest[$i+1]);
1826             }
1827             return $n;
1828             }
1829              
1830             =item * A Perl reimplementation of C
1831             is provided.
1832              
1833             =cut
1834              
1835             sub Gtk3::TreeViewColumn::new_with_attributes {
1836             my ($class, $title, $cell, @rest) = @_;
1837             if (@rest % 2) {
1838             croak ('Usage: Gtk3::TreeViewColumn->new_with_attributes (title, cell_renderer, attr1 => col1, ...)');
1839             }
1840             my $object = $class->new;
1841             $object->set_title ($title);
1842             $object->pack_start ($cell, Glib::TRUE);
1843             for (my $i = 0; $i < @rest; $i += 2) {
1844             $object->add_attribute ($cell, $rest[$i], $rest[$i+1]);
1845             }
1846             return $object;
1847             }
1848              
1849             =item * Perl reimplementations of C and
1850             C are provided.
1851              
1852             =cut
1853              
1854             # Gtk3::TreeViewColumn::set_attributes and Gtk3::CellLayout::set_attributes
1855             {
1856             no strict 'refs';
1857             foreach my $package (qw/TreeViewColumn CellLayout/) {
1858             *{'Gtk3::' . $package . '::set_attributes'} = sub {
1859             my ($object, $cell, @rest) = @_;
1860             if (@rest % 2) {
1861             croak ('Usage: $object->set_attributes (cell_renderer, attr1 => col1, ...)');
1862             }
1863             $object->clear_attributes ($cell);
1864             for (my $i = 0; $i < @rest; $i += 2) {
1865             $object->add_attribute ($cell, $rest[$i], $rest[$i+1]);
1866             }
1867             }
1868             }
1869             }
1870              
1871             =item * C takes no C argument.
1872              
1873             =cut
1874              
1875             sub Gtk3::UIManager::add_ui_from_string {
1876             my ($manager, $string) = @_;
1877             return Glib::Object::Introspection->invoke (
1878             $_GTK_BASENAME, 'UIManager', 'add_ui_from_string',
1879             $manager, $string, -1); # wants length in bytes
1880             }
1881              
1882             =item * C uses the defaults homogeneous = FALSE and spacing =
1883             5.
1884              
1885             =cut
1886              
1887             sub Gtk3::VBox::new {
1888             my ($class, $homogeneous, $spacing) = @_;
1889             $homogeneous = 0 unless defined $homogeneous;
1890             $spacing = 5 unless defined $spacing;
1891             return Glib::Object::Introspection->invoke (
1892             $_GTK_BASENAME, 'VBox', 'new', $class, $homogeneous, $spacing);
1893             }
1894              
1895             =item * C and C also accept
1896             strings, array references and C objects for the C
1897             parameter.
1898              
1899             =cut
1900              
1901             sub Gtk3::Widget::add_events {
1902             my ($widget, $events) = @_;
1903             eval {
1904             $events = Glib::Object::Introspection->convert_sv_to_flags (
1905             'Gtk3::Gdk::EventMask', $events);
1906             };
1907             return Glib::Object::Introspection->invoke (
1908             $_GTK_BASENAME, 'Widget', 'add_events', $widget, $events);
1909             }
1910              
1911             sub Gtk3::Widget::set_events {
1912             my ($widget, $events) = @_;
1913             eval {
1914             $events = Glib::Object::Introspection->convert_sv_to_flags (
1915             'Gtk3::Gdk::EventMask', $events);
1916             };
1917             return Glib::Object::Introspection->invoke (
1918             $_GTK_BASENAME, 'Widget', 'set_events', $widget, $events);
1919             }
1920              
1921             =item * C returns a C object
1922             that can also be compared to numeric values with C<< == >> and C<< >= >>.
1923              
1924             =cut
1925              
1926             sub Gtk3::Widget::get_events {
1927             my ($widget) = @_;
1928             my $events = Glib::Object::Introspection->invoke (
1929             $_GTK_BASENAME, 'Widget', 'get_events', $widget);
1930             return Glib::Object::Introspection->convert_flags_to_sv (
1931             'Gtk3::Gdk::EventMask', $events);
1932             }
1933              
1934             sub Gtk3::Widget::render_icon {
1935             my ($widget, $stock_id, $size, $detail) = @_;
1936             Glib::Object::Introspection->invoke (
1937             $_GTK_BASENAME, 'Widget', 'render_icon', $widget, $stock_id,
1938             $_GTK_ICON_SIZE_NICK_TO_ID->($size), $detail);
1939             }
1940              
1941             =item * C and
1942             C are forwarded to the corresponding
1943             functions in C.
1944              
1945             =cut
1946              
1947             sub Gtk3::Widget::find_style_property {
1948             return Gtk3::WidgetClass::find_style_property (@_);
1949             }
1950              
1951             sub Gtk3::Widget::list_style_properties {
1952             my $ref = Gtk3::WidgetClass::list_style_properties (@_);
1953             return if not defined $ref;
1954             return wantarray ? @$ref : $ref->[$#$ref];
1955             }
1956              
1957             =item * A Perl reimplementation of C is provided.
1958              
1959             =cut
1960              
1961             sub Gtk3::Widget::style_get {
1962             my ($widget, @rest) = @_;
1963             my $properties = _rest_to_ref (\@rest);
1964             my @values;
1965             foreach my $property (@$properties) {
1966             my $pspec = Gtk3::WidgetClass::find_style_property ($widget, $property);
1967             croak "Cannot find type information for property '$property' on $widget"
1968             unless defined $pspec;
1969             my $value_wrapper = Glib::Object::Introspection::GValueWrapper->new (
1970             $pspec->get_value_type, undef);
1971             $widget->style_get_property ($property, $value_wrapper);
1972             push @values, $value_wrapper->get_value;
1973             }
1974             return @values[0..$#values];
1975             }
1976              
1977             =item * C uses the default type = 'toplevel'.
1978              
1979             =cut
1980              
1981             sub Gtk3::Window::new {
1982             my ($class, $type) = @_;
1983             $type = 'toplevel' unless defined $type;
1984             return Glib::Object::Introspection->invoke (
1985             $_GTK_BASENAME, 'Window', 'new', $class, $type);
1986             }
1987              
1988             # --- Gdk ---
1989              
1990             =item * A constructor C is provided that can be called as
1991             C<< Gtk3::Gdk::RGBA->new (r, g, b, a) >>.
1992              
1993             =cut
1994              
1995             sub Gtk3::Gdk::RGBA::new {
1996             my ($class, @rest) = @_;
1997             # Handle Gtk3::Gdk::RGBA->new (r, g, b, a) specially.
1998             if (4 == @rest) {
1999             my %data;
2000             @data{qw/red green blue alpha/} = @rest;
2001             return Glib::Boxed::new ($class, \%data);
2002             }
2003             # Fall back to Glib::Boxed::new.
2004             return Glib::Boxed::new ($class, @rest);
2005             }
2006              
2007             =item * C can be called as a function returning a new
2008             instance (C<< $rgba = Gtk3::Gdk::RGBA::parse ($spec) >>) or as a method (C<<
2009             $rgba->parse ($spec) >>).
2010              
2011             =cut
2012              
2013             sub Gtk3::Gdk::RGBA::parse {
2014             my $have_instance;
2015             {
2016             local $@;
2017             $have_instance = eval { $_[0]->isa ('Gtk3::Gdk::RGBA') };
2018             }
2019             # This needs to be switched around if/when
2020             # is fixed.
2021             if ($have_instance) {
2022             return Glib::Object::Introspection->invoke (
2023             $_GDK_BASENAME, 'RGBA', 'parse', @_);
2024             } else {
2025             my $instance = Gtk3::Gdk::RGBA->new;
2026             my $success = Glib::Object::Introspection->invoke (
2027             $_GDK_BASENAME, 'RGBA', 'parse',
2028             $instance, @_);
2029             return $success ? $instance : undef;
2030             }
2031             }
2032              
2033             =item * C optionally computes the C
2034             automatically from the given C.
2035              
2036             =cut
2037              
2038             sub Gtk3::Gdk::Window::new {
2039             my ($class, $parent, $attr, $attr_mask) = @_;
2040             if (not defined $attr_mask) {
2041             $attr_mask = Gtk3::Gdk::WindowAttributesType->new ([]);
2042             if (exists $attr->{title}) { $attr_mask |= 'GDK_WA_TITLE' }
2043             if (exists $attr->{x}) { $attr_mask |= 'GDK_WA_X' }
2044             if (exists $attr->{y}) { $attr_mask |= 'GDK_WA_Y' }
2045             if (exists $attr->{cursor}) { $attr_mask |= 'GDK_WA_CURSOR' }
2046             if (exists $attr->{visual}) { $attr_mask |= 'GDK_WA_VISUAL' }
2047             if (exists $attr->{wmclass_name} && exists $attr->{wmclass_class}) { $attr_mask |= 'GDK_WA_WMCLASS' }
2048             if (exists $attr->{override_redirect}) { $attr_mask |= 'GDK_WA_NOREDIR' }
2049             if (exists $attr->{type_hint}) { $attr_mask |= 'GDK_WA_TYPE_HINT' }
2050             if (!Gtk3::CHECK_VERSION (3, 4, 4)) {
2051             # Before 3.4.4 or 3.5.6, the attribute mask parameter lacked proper
2052             # annotations, hence we numerify it here. FIXME: This breaks
2053             # encapsulation.
2054             $attr_mask = $$attr_mask;
2055             }
2056             }
2057             return Glib::Object::Introspection->invoke (
2058             $_GDK_BASENAME, 'Window', 'new',
2059             $class, $parent, $attr, $attr_mask);
2060             }
2061              
2062             # --- GdkPixbuf ---
2063              
2064             sub Gtk3::Gdk::Pixbuf::CHECK_VERSION {
2065             my ($major, $minor, $micro) = @_;
2066             return
2067             (Gtk3::Gdk::PIXBUF_MAJOR () > $major) ||
2068             (Gtk3::Gdk::PIXBUF_MAJOR () == $major && Gtk3::Gdk::PIXBUF_MINOR () > $minor) ||
2069             (Gtk3::Gdk::PIXBUF_MAJOR () == $major && Gtk3::Gdk::PIXBUF_MINOR () == $minor && Gtk3::Gdk::PIXBUF_MICRO () >= $micro);
2070             }
2071              
2072             =item * C returns a byte string.
2073              
2074             =cut
2075              
2076             sub Gtk3::Gdk::Pixbuf::get_pixels {
2077             my $pixel_aref = Glib::Object::Introspection->invoke (
2078             $_GDK_PIXBUF_BASENAME, 'Pixbuf', 'get_pixels', @_);
2079             return pack 'C*', @{$pixel_aref};
2080             }
2081              
2082             =item * C is reimplemented in terms of
2083             C for correct memory management. No C and
2084             C arguments are needed.
2085              
2086             =cut
2087              
2088             sub Gtk3::Gdk::Pixbuf::new_from_data {
2089             my ($class, $data, $colorspace, $has_alpha, $bits_per_sample, $width, $height, $rowstride) = @_;
2090             die 'Only RGB is currently supported' unless $colorspace eq 'rgb';
2091             die 'Only 8 bits per pixel are currently supported' unless $bits_per_sample == 8;
2092             my $length = Gtk3::Gdk::PIXDATA_HEADER_LENGTH () +
2093             $rowstride*$height;
2094             my $type = Gtk3::Gdk::PixdataType->new ([qw/sample_width_8 encoding_raw/]);
2095             $type |= $has_alpha ? 'color_type_rgba' : 'color_type_rgb';
2096             my @header_numbers = (0x47646b50,
2097             $length,
2098             $$type, # FIXME: This kind of breaks encapsulation.
2099             $rowstride,
2100             $width,
2101             $height);
2102             # Convert to 8 bit unsigned chars, padding to 32 bit little-endian first.
2103             my @header = map { unpack ("C*", pack ("N", $_)) } @header_numbers;
2104             my $inline_data = _unpack_unless_array_ref ($data);
2105             unshift @$inline_data, @header;
2106             return Gtk3::Gdk::Pixbuf->new_from_inline ($inline_data);
2107             }
2108              
2109             =item * C does not take a C
2110             argument. It is always set to TRUE for correct memory management.
2111              
2112             =cut
2113              
2114             sub Gtk3::Gdk::Pixbuf::new_from_inline {
2115             my ($class, $data) = @_;
2116             return Glib::Object::Introspection->invoke (
2117             $_GDK_PIXBUF_BASENAME, 'Pixbuf', 'new_from_inline',
2118             $class, _unpack_unless_array_ref ($data), Glib::TRUE); # always copy pixels
2119             }
2120              
2121             =item * C also accepts a list of XPM
2122             lines.
2123              
2124             =cut
2125              
2126             sub Gtk3::Gdk::Pixbuf::new_from_xpm_data {
2127             my ($class, @rest) = @_;
2128             my $data = _rest_to_ref (\@rest);
2129             return Glib::Object::Introspection->invoke (
2130             $_GDK_PIXBUF_BASENAME, 'Pixbuf', 'new_from_xpm_data',
2131             $class, $data);
2132             }
2133              
2134             # Version check for the new annotations described in
2135             # .
2136             my $_GET_SAVE_VARIANT = sub {
2137             my ($method) = @_;
2138             if (Gtk3::Gdk::Pixbuf::CHECK_VERSION (2, 31, 3)) {
2139             return $method . 'v';
2140             } elsif (Gtk3::Gdk::Pixbuf::CHECK_VERSION (2, 31, 2)) {
2141             return $method;
2142             } else {
2143             return $method . 'v';
2144             }
2145             };
2146              
2147             =item * C, C and C
2148             also accept C<< key => value >> pairs and invoke the correct C function as
2149             appropriate for the current gdk-pixbuf version.
2150              
2151             =cut
2152              
2153             sub Gtk3::Gdk::Pixbuf::save {
2154             my ($pixbuf, $filename, $type, @rest) = @_;
2155             my ($keys, $values) = _unpack_keys_and_values (\@rest);
2156             if (not defined $keys) {
2157             croak ("Usage: \$pixbuf->save (\$filename, \$type, \\\@keys, \\\@values)\n",
2158             " -or-: \$pixbuf->save (\$filename, \$type, \$key1 => \$value1, ...)");
2159             }
2160             my $method = $_GET_SAVE_VARIANT->('save');
2161             Glib::Object::Introspection->invoke (
2162             $_GDK_PIXBUF_BASENAME, 'Pixbuf', $method,
2163             $pixbuf, $filename, $type, $keys, $values);
2164             }
2165              
2166             sub Gtk3::Gdk::Pixbuf::save_to_buffer {
2167             my ($pixbuf, $type, @rest) = @_;
2168             my ($keys, $values) = _unpack_keys_and_values (\@rest);
2169             if (not defined $keys) {
2170             croak ("Usage: \$pixbuf->save_to_buffer (\$type, \\\@keys, \\\@values)\n",
2171             " -or-: \$pixbuf->save_to_buffer (\$type, \$key1 => \$value1, ...)");
2172             }
2173             my $method = $_GET_SAVE_VARIANT->('save_to_buffer');
2174             my (undef, $buffer) =
2175             Glib::Object::Introspection->invoke (
2176             $_GDK_PIXBUF_BASENAME, 'Pixbuf', $method,
2177             $pixbuf, $type, $keys, $values);
2178             return $buffer;
2179             }
2180              
2181             sub Gtk3::Gdk::Pixbuf::save_to_callback {
2182             my ($pixbuf, $save_func, $user_data, $type, @rest) = @_;
2183             my ($keys, $values) = _unpack_keys_and_values (\@rest);
2184             if (not defined $keys) {
2185             croak ("Usage: \$pixbuf->save_to_callback (\$save_func, \$user_data, \$type, \\\@keys, \\\@values)\n",
2186             " -or-: \$pixbuf->save_to_callback (\$save_func, \$user_data, \$type, \$key1 => \$value1, ...)");
2187             }
2188             my $method = $_GET_SAVE_VARIANT->('save_to_callback');
2189             Glib::Object::Introspection->invoke (
2190             $_GDK_PIXBUF_BASENAME, 'Pixbuf', $method,
2191             $pixbuf, $save_func, $user_data, $type, $keys, $values);
2192             }
2193              
2194             # --- Pango ---
2195              
2196             =item * The C arguments of C and C
2197             are optional.
2198              
2199             =cut
2200              
2201             sub Pango::Layout::set_text {
2202             return Glib::Object::Introspection->invoke (
2203             $_PANGO_BASENAME, 'Layout', 'set_text',
2204             @_ == 3 ? @_ : (@_[0,1], -1)); # wants length in bytes
2205             }
2206              
2207             sub Pango::Layout::set_markup {
2208             return Glib::Object::Introspection->invoke (
2209             $_PANGO_BASENAME, 'Layout', 'set_markup',
2210             @_ == 3 ? @_ : (@_[0,1], -1)); # wants length in bytes
2211             }
2212              
2213             =back
2214              
2215             =cut
2216              
2217             # - Fixes ------------------------------------------------------------------- #
2218              
2219             =head2 Perl compatibility
2220              
2221             As of 5.20.0, perl does not automatically re-check the locale environment for
2222             changes. If a function thus changes the locale behind perl's back, problems
2223             might arise whenever numbers are formatted, for example when checking versions.
2224             To ensure perl's assumption about the locale are up-to-date, the functions
2225             C, C, C and C are amended
2226             to let perl know of any changes.
2227              
2228             =cut
2229              
2230             # Compatibility with perl 5.20 and non-dot locales. Wrap all functions that
2231             # might end up calling setlocale() such that POSIX::setlocale() is also called
2232             # to ensure perl knows about the current locale. See the discussion in
2233             # ,
2234             # ,
2235             # .
2236             if ($^V ge v5.20.0) {
2237             require POSIX;
2238             no strict 'refs';
2239             no warnings 'redefine';
2240              
2241             my $disable_setlocale = 0;
2242             *{'Gtk3::disable_setlocale'} = sub {
2243             $disable_setlocale = 1;
2244             Glib::Object::Introspection->invoke (
2245             $_GTK_BASENAME, undef, 'disable_setlocale', @_);
2246             };
2247              
2248             # These two already have overrides.
2249             foreach my $function (qw/Gtk3::init Gtk3::init_check/) {
2250             my $orig = \&{$function};
2251             *{$function} = sub {
2252             if (!$disable_setlocale) {
2253             POSIX::setlocale (POSIX::LC_ALL (), '');
2254             }
2255             $orig->(@_);
2256             };
2257             }
2258              
2259             foreach my $function (qw/init_with_args parse_args/) {
2260             *{'Gtk3::' . $function} = sub {
2261             if (!$disable_setlocale) {
2262             POSIX::setlocale (POSIX::LC_ALL (), '');
2263             }
2264             Glib::Object::Introspection->invoke (
2265             $_GTK_BASENAME, undef, $function, @_);
2266             };
2267             }
2268             }
2269              
2270             # - Helpers ----------------------------------------------------------------- #
2271              
2272             sub _common_tree_model_new {
2273             my ($package, $class, @types) = @_;
2274             my $real_types;
2275             {
2276             local $@;
2277             $real_types = (@types == 1 && eval { @{$types[0]} })
2278             ? $types[0]
2279             : \@types;
2280             }
2281             return Glib::Object::Introspection->invoke (
2282             $_GTK_BASENAME, $package, 'new',
2283             $class, $real_types);
2284             }
2285              
2286             sub _common_tree_model_set {
2287             my ($package, $model, $iter, @columns_and_values) = @_;
2288             my ($columns, $values) = _unpack_keys_and_values (\@columns_and_values);
2289             if (not defined $columns) {
2290             croak ("Usage: Gtk3::${package}::set (\$model, \$iter, \\\@columns, \\\@values)\n",
2291             " -or-: Gtk3::${package}::set (\$model, \$iter, \$column1 => \$value1, ...)");
2292             }
2293             my @wrapped_values = ();
2294             foreach my $i (0..$#{$columns}) {
2295             my $column_type = $model->get_column_type ($columns->[$i]);
2296             push @wrapped_values,
2297             Glib::Object::Introspection::GValueWrapper->new (
2298             $column_type, $values->[$i]);
2299             }
2300             Glib::Object::Introspection->invoke (
2301             $_GTK_BASENAME, $package, 'set',
2302             $model, $iter, $columns, \@wrapped_values);
2303             }
2304              
2305             sub _unpack_keys_and_values {
2306             my ($keys_and_values) = @_;
2307             my (@keys, @values);
2308             my $have_array_refs;
2309             {
2310             local $@;
2311             $have_array_refs =
2312             @$keys_and_values == 2 && eval { @{$keys_and_values->[0]} };
2313             }
2314             if ($have_array_refs) {
2315             @keys = @{$keys_and_values->[0]};
2316             @values = @{$keys_and_values->[1]};
2317             } elsif (@$keys_and_values % 2 == 0) {
2318             # To preserve the order of the key-value pairs, avoid creating an
2319             # intermediate hash.
2320             my @range = 0 .. (@$keys_and_values/2-1);
2321             @keys = @$keys_and_values[map { 2*$_ } @range];
2322             @values = @$keys_and_values[map { 2*$_+1 } @range];
2323             } else {
2324             return ();
2325             }
2326             return (\@keys, \@values);
2327             }
2328              
2329             sub _unpack_unless_array_ref {
2330             my ($data) = @_;
2331             local $@;
2332             return eval { @{$data} }
2333             ? $data
2334             : [unpack 'C*', $data];
2335             }
2336              
2337             sub _rest_to_ref {
2338             my ($rest) = @_;
2339             local $@;
2340             if (scalar @$rest == 1 && eval { defined $rest->[0]->[0] }) {
2341             return $rest->[0];
2342             } else {
2343             return $rest;
2344             }
2345             }
2346              
2347             package Gtk3::Gdk::EventMask;
2348             $Gtk3::Gdk::EventMask::VERSION = '0.033';
2349             use overload
2350             '==' => \&eq,
2351             '>=' => \≥
2352             use Scalar::Util qw/looks_like_number/;
2353              
2354             my $_convert_one = sub {
2355             return Glib::Object::Introspection->convert_flags_to_sv (
2356             'Gtk3::Gdk::EventMask', $_[0]);
2357             };
2358              
2359             my $_convert_two = sub {
2360             my ($a, $b) = @_;
2361             if (looks_like_number ($a)) {
2362             $a = $_convert_one->($a);
2363             }
2364             if (looks_like_number ($b)) {
2365             $b = $_convert_one->($b);
2366             }
2367             return ($a, $b);
2368             };
2369              
2370             sub eq {
2371             my ($a, $b, $swap) = @_;
2372             ($a, $b) = $_convert_two->($a, $b);
2373             return Glib::Flags::eq ($a, $b, $swap);
2374             }
2375              
2376             sub ge {
2377             my ($a, $b, $swap) = @_;
2378             ($a, $b) = $_convert_two->($a, $b);
2379             return Glib::Flags::ge ($a, $b, $swap);
2380             }
2381              
2382             package Gtk3;
2383              
2384             1;
2385              
2386             __END__