├── .gitignore ├── t ├── floating-refs.t ├── signals.t ├── inc │ └── setup.pl ├── vfuncs-double-setup.t ├── vfuncs-destroy.t ├── zz-GtkRadioAction.t ├── zz-GtkRecentChooserDialog.t ├── zz-GtkRadioToolButton.t ├── 00-init.t ├── zz-GtkRadioButton.t ├── zz-GtkInfoBar.t ├── zz-GtkRadioMenuItem.t ├── zz-GtkCellLayoutIface.t ├── zz-GtkCellRendererIface.t ├── zz-GtkActionGroup.t ├── zz-GtkDialog.t ├── zz-GtkImage.t ├── zz-GtkTextBuffer.t ├── zz-GtkBuilder.t ├── zz-GtkContainer.t ├── zz-GdkEvent.t ├── zz-GtkTreeModelIface.t └── overrides.t ├── perl-gtk3.doap ├── dist.ini ├── README ├── NEWS └── lib └── Gtk3.pm /.gitignore: -------------------------------------------------------------------------------- 1 | .build 2 | Gtk3-* 3 | -------------------------------------------------------------------------------- /t/floating-refs.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | BEGIN { require './t/inc/setup.pl' }; 4 | 5 | use strict; 6 | use warnings; 7 | use Scalar::Util qw/weaken/; 8 | 9 | plan tests => 2; 10 | 11 | SKIP: { 12 | my $button = Gtk3::Button->new_with_label ('Label'); 13 | weaken $button; 14 | is ($button, undef); 15 | } 16 | 17 | SKIP: { 18 | skip 'Window ref counting test', 1; # FIXME? 19 | my $window = Gtk3::Window->new ('toplevel'); 20 | weaken $window; 21 | is ($window, undef); 22 | } 23 | -------------------------------------------------------------------------------- /t/signals.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | BEGIN { require './t/inc/setup.pl' }; 4 | 5 | use strict; 6 | use warnings; 7 | 8 | plan tests => 3; 9 | 10 | # Gtk3::Widget.size-allocate 11 | { 12 | my $window = Gtk3::Window->new; 13 | $window->show; 14 | my $alloc = {x => 10, y => 10, width => 100, height => 100}; 15 | my $data = [23, 42]; 16 | $window->signal_connect (size_allocate => sub { 17 | my ($cb_window, $cb_alloc, $cb_data) = @_; 18 | is ($cb_window, $window); 19 | is_deeply ($cb_alloc, $alloc); 20 | is_deeply ($cb_data, $data); 21 | }, $data); 22 | $window->signal_emit (size_allocate => $alloc); 23 | } 24 | -------------------------------------------------------------------------------- /t/inc/setup.pl: -------------------------------------------------------------------------------- 1 | use Test::More; 2 | use Gtk3; 3 | 4 | if (!Gtk3::init_check ()) { 5 | plan skip_all => 'Gtk3::init_check failed'; 6 | } 7 | 8 | sub check_gi_version { 9 | my ($x, $y, $z) = @_; 10 | #return !system ('pkg-config', "--atleast-version=$x.$y.$z", 'gobject-introspection-1.0'); 11 | return Glib::Object::Introspection->CHECK_VERSION ($x, $y, $z); 12 | } 13 | 14 | sub on_unthreaded_freebsd { 15 | if ($^O eq 'freebsd') { 16 | require Config; 17 | if ($Config::Config{ldflags} !~ m/-pthread\b/) { 18 | return 1; 19 | } 20 | } 21 | return 0; 22 | } 23 | 24 | use File::Temp qw{tempdir}; 25 | $ENV{HOME} = tempdir(CLEANUP => 1); 26 | 27 | 1; 28 | -------------------------------------------------------------------------------- /t/vfuncs-double-setup.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | # Ensure that importing Gtk3 multiple times does not break vfunc overloading. 4 | 5 | package MyButton; 6 | 7 | use strict; 8 | use warnings; 9 | 10 | # First import. 11 | use Gtk3; 12 | 13 | use Glib::Object::Subclass 14 | Gtk3::Button::, 15 | signals => {}, 16 | properties => [], 17 | ; 18 | 19 | package main; 20 | 21 | use strict; 22 | use warnings; 23 | 24 | # Second import. 25 | use Gtk3; 26 | 27 | use Test::More; 28 | if (!eval { Glib::Object::Introspection->VERSION ('0.030') }) { 29 | plan skip_all => 'G:O:I 0.030 required'; 30 | } 31 | if (!Gtk3::init_check ()) { 32 | plan skip_all => 'Gtk3::init_check failed'; 33 | } 34 | plan tests => 1; 35 | 36 | my $window = Gtk3::Window->new; 37 | my $my_button = MyButton->new (label => "Test"); 38 | $window->add ($my_button); # trigger PARENT_SET 39 | pass; 40 | -------------------------------------------------------------------------------- /perl-gtk3.doap: -------------------------------------------------------------------------------- 1 | 6 | 7 | Gtk3 8 | Perl interface to the 3.x series of the Gimp Toolkit library 9 | 10 | 11 | 12 | 13 | 14 | 15 | Torsten Schönfeld 16 | 17 | tsch 18 | 19 | 20 | 21 | 22 | -------------------------------------------------------------------------------- /t/vfuncs-destroy.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | BEGIN { require './t/inc/setup.pl' }; 4 | 5 | use strict; 6 | use warnings; 7 | 8 | plan tests => 2; 9 | 10 | # Make sure that we can safely inherit from classes which have a "destroy" 11 | # vfunc. 12 | { 13 | my $label_destroy_called = 0; 14 | my $label_destroy_chain_called = 0; 15 | 16 | package MyLabel; 17 | use Glib::Object::Subclass 18 | Gtk3::Label:: 19 | ; 20 | # no DESTROY_VFUNC override 21 | 22 | package MyLabelDestroy; 23 | use Glib::Object::Subclass 24 | Gtk3::Label:: 25 | ; 26 | sub DESTROY_VFUNC { 27 | $label_destroy_called++; 28 | } 29 | 30 | package MyLabelDestroyChain; 31 | use Glib::Object::Subclass 32 | Gtk3::Label:: 33 | ; 34 | sub DESTROY_VFUNC { 35 | $label_destroy_chain_called++; 36 | $_[0]->SUPER::DESTROY_VFUNC (); 37 | } 38 | 39 | package main; 40 | { 41 | my $label = MyLabel->new; 42 | my $label_destroy = MyLabelDestroy->new; 43 | my $label_destroy_chan = MyLabelDestroyChain->new; 44 | } 45 | is ($label_destroy_called, 1); 46 | is ($label_destroy_chain_called, 1); 47 | } 48 | -------------------------------------------------------------------------------- /t/zz-GtkRadioAction.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Based on Gtk2/t/GtkRadioAction.t 4 | 5 | BEGIN { require './t/inc/setup.pl' } 6 | 7 | use strict; 8 | use warnings; 9 | 10 | plan tests => 14; 11 | 12 | my @actions = (Gtk3::RadioAction->new ('one', undef, undef, undef, 0)); 13 | isa_ok ($actions[$#actions], 'Gtk3::RadioAction'); 14 | my $i = 1; 15 | foreach (qw(two three four five)) { 16 | push @actions, Gtk3::RadioAction->new ($_, undef, undef, undef, $i++); 17 | $actions[$#actions]->set (group => $actions[$#actions-1]); 18 | isa_ok ($actions[$#actions], 'Gtk3::RadioAction'); 19 | } 20 | my $group = $actions[0]->get_group; 21 | push @actions, Gtk3::RadioAction->new ('six', undef, undef, undef, 5); 22 | isa_ok ($actions[$#actions], 'Gtk3::RadioAction'); 23 | $actions[$#actions]->set_group ($group); 24 | { 25 | # get_group() no memory leaks in arrayref return and array items 26 | my $x = Gtk3::RadioAction->new ('x', undef, undef, undef, 0); 27 | my $y = Gtk3::RadioAction->new ('y', undef, undef, undef, 0); 28 | $y->set_group($x); 29 | my $aref = $x->get_group; 30 | is_deeply($aref, [$x,$y]); 31 | require Scalar::Util; 32 | Scalar::Util::weaken ($aref); 33 | is ($aref, undef, 'get_group() array destroyed by weakening'); 34 | Scalar::Util::weaken ($x); 35 | is ($x, undef, 'get_group() item x destroyed by weakening'); 36 | Scalar::Util::weaken ($y); 37 | is ($y, undef, 'get_group() item y destroyed by weakening'); 38 | } 39 | 40 | is ($actions[0]->get_current_value, 0); 41 | $actions[0]->set_current_value (3); 42 | is ($actions[0]->get_current_value, 3); 43 | 44 | $actions[3]->set_active (Glib::TRUE); 45 | ok (!$actions[0]->get_active); 46 | ok ($actions[3]->get_active); 47 | -------------------------------------------------------------------------------- /t/zz-GtkRecentChooserDialog.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | # 3 | # Originally copied from Gtk2/t/GtkRecentChooserDialog.t 4 | # 5 | 6 | BEGIN { require './t/inc/setup.pl' } 7 | 8 | use strict; 9 | use warnings; 10 | 11 | if (on_unthreaded_freebsd ()) { 12 | plan skip_all => 'need a perl built with "-pthread" on freebsd'; 13 | } else { 14 | plan tests => 12; 15 | } 16 | 17 | my $window = Gtk3::Window->new; 18 | my $manager = Gtk3::RecentManager->new; 19 | 20 | my $chooser = Gtk3::RecentChooserDialog->new ('Test', $window); 21 | isa_ok ($chooser, 'Gtk3::RecentChooser'); 22 | isa_ok ($chooser, 'Gtk3::RecentChooserDialog'); 23 | 24 | $chooser = Gtk3::RecentChooserDialog->new ('Test', undef); 25 | isa_ok ($chooser, 'Gtk3::RecentChooser'); 26 | isa_ok ($chooser, 'Gtk3::RecentChooserDialog'); 27 | 28 | $chooser = Gtk3::RecentChooserDialog->new_for_manager ('Test', $window, $manager); 29 | isa_ok ($chooser, 'Gtk3::RecentChooser'); 30 | isa_ok ($chooser, 'Gtk3::RecentChooserDialog'); 31 | 32 | $chooser = Gtk3::RecentChooserDialog->new_for_manager ('Test', undef, $manager); 33 | isa_ok ($chooser, 'Gtk3::RecentChooser'); 34 | isa_ok ($chooser, 'Gtk3::RecentChooserDialog'); 35 | 36 | $chooser = Gtk3::RecentChooserDialog->new ('Test', $window, 'gtk-ok' => 'ok'); 37 | isa_ok ($chooser, 'Gtk3::RecentChooser'); 38 | isa_ok ($chooser, 'Gtk3::RecentChooserDialog'); 39 | 40 | $chooser = Gtk3::RecentChooserDialog->new_for_manager ('Test', $window, $manager, 'gtk-ok' => 'ok', 'gtk-cancel' => 'cancel'); 41 | isa_ok ($chooser, 'Gtk3::RecentChooser'); 42 | isa_ok ($chooser, 'Gtk3::RecentChooserDialog'); 43 | 44 | __END__ 45 | 46 | Copyright (C) 2003-2012 by the gtk2-perl team (see the file AUTHORS for the 47 | full list). See LICENSE for more information. 48 | -------------------------------------------------------------------------------- /dist.ini: -------------------------------------------------------------------------------- 1 | name = Gtk3 2 | version = 0.038 3 | author = Torsten Schoenfeld 4 | license = LGPL_2_1 5 | copyright_holder = Torsten Schoenfeld 6 | copyright_year = 2019 7 | ; 'is_trial' comes from Zilla.pm; use this flag to change between 'stable' and 8 | ; 'testing'. DZil 4.300034 supports only 'stable' and 'testing', not 9 | ; 'unstable'; there's a note in Zilla.pm about this fact 10 | ;is_trial = 1 11 | 12 | [GatherDir] 13 | [PruneCruft] 14 | [ManifestSkip] 15 | [MetaYAML] 16 | version = 2 17 | [MetaJSON] 18 | [License] 19 | [MakeMaker] 20 | [Manifest] 21 | [PkgVersion] 22 | 23 | [Prereqs] 24 | Carp = 0 ; core 25 | Exporter = 0 ; core 26 | Cairo::GObject = 1.000 27 | Glib::Object::Introspection = 0.043 28 | Test::Simple = 0.96 ; for the fix for is() and objects with overloading 29 | 30 | [NextRelease] 31 | filename = NEWS 32 | format = Overview of changes in Gtk3 %v [%{yyyy-MM-dd}d]%n============================================== 33 | 34 | [MetaResources] 35 | homepage = http://gtk2-perl.sourceforge.net 36 | bugtracker.web = http://rt.cpan.org/Public/Dist/Display.html?Name=Gtk3 37 | bugtracker.mailto = bug-Gtk3 [at] rt.cpan.org 38 | repository.url = git://git.gnome.org/perl-Gtk3 39 | repository.web = http://git.gnome.org/browse/perl-Gtk3 40 | repository.type = git 41 | x_twitter = https://twitter.com/GTKPerl 42 | x_IRC = irc://irc.gimp.org/#gtk-perl 43 | 44 | [Git::Check] 45 | changelog = NEWS 46 | [Git::Commit] 47 | changelog = NEWS 48 | commit_msg = Release v%v%n%n%c 49 | [Git::Tag] 50 | signed = 1 51 | [Git::Push] 52 | [TestRelease] 53 | [ConfirmRelease] 54 | [UploadToSFTP] 55 | site = frs.sourceforge.net 56 | directory = /home/pfs/project/g/gt/gtk2-perl/Gtk3 57 | [UploadToCPAN] 58 | -------------------------------------------------------------------------------- /t/zz-GtkRadioToolButton.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Based on Gtk2/t/GtkRadioToolButton.t 4 | 5 | BEGIN { require './t/inc/setup.pl' } 6 | 7 | use strict; 8 | use warnings; 9 | 10 | if (Gtk3::CHECK_VERSION (3, 4, 5)) { 11 | plan tests => 12; 12 | } else { 13 | plan skip_all => 'GtkRadioToolButton was not properly annotated in gtk+ < 3.4.5'; 14 | } 15 | 16 | my $item = Gtk3::RadioToolButton -> new(); 17 | isa_ok($item, "Gtk3::RadioToolButton"); 18 | 19 | my $item_two = Gtk3::RadioToolButton -> new(undef); 20 | isa_ok($item_two, "Gtk3::RadioToolButton"); 21 | 22 | my $item_three = Gtk3::RadioToolButton -> new([$item, $item_two]); 23 | isa_ok($item_three, "Gtk3::RadioToolButton"); 24 | 25 | $item_two = Gtk3::RadioToolButton -> new_from_stock(undef, "gtk-quit"); 26 | isa_ok($item_two, "Gtk3::RadioToolButton"); 27 | 28 | $item_three = Gtk3::RadioToolButton -> new_from_stock([$item, $item_two], "gtk-quit"); 29 | isa_ok($item_three, "Gtk3::RadioToolButton"); 30 | 31 | $item = Gtk3::RadioToolButton -> new_from_widget($item_two); 32 | isa_ok($item, "Gtk3::RadioToolButton"); 33 | 34 | $item = Gtk3::RadioToolButton -> new_with_stock_from_widget($item_two, "gtk-quit"); 35 | isa_ok($item, "Gtk3::RadioToolButton"); 36 | 37 | $item = Gtk3::RadioToolButton -> new(); 38 | $item -> set_group([$item_two, $item_three]); 39 | is_deeply($item -> get_group(), [$item_two, $item_three]); 40 | 41 | { 42 | # get_group() no memory leaks in arrayref return and array items 43 | my $x = Gtk3::RadioToolButton->new; 44 | my $y = Gtk3::RadioToolButton->new; 45 | $y->set_group ($x); 46 | my $aref = $x->get_group; 47 | is_deeply ($aref, [$x,$y]); 48 | require Scalar::Util; 49 | Scalar::Util::weaken ($aref); 50 | is ($aref, undef, 'get_group() array destroyed by weakening'); 51 | Scalar::Util::weaken ($x); 52 | is ($x, undef, 'get_group() item x destroyed by weakening'); 53 | Scalar::Util::weaken ($y); 54 | is ($y, undef, 'get_group() item y destroyed by weakening'); 55 | } 56 | -------------------------------------------------------------------------------- /t/00-init.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | 8 | BEGIN { require Gtk3; } 9 | unless (eval { Gtk3->import; 1 }) { 10 | my $error = $@; 11 | if (eval { $error->isa ('Glib::Error') && 12 | $error->domain eq 'g-irepository-error-quark'}) 13 | { 14 | BAIL_OUT ("OS unsupported: $error"); 15 | } else { 16 | BAIL_OUT ("Cannot load Gtk3: $error"); 17 | } 18 | } 19 | 20 | plan tests => 16; 21 | 22 | SKIP: { 23 | @ARGV = qw(--help --name gtk2perl --urgs tree); 24 | skip 'Gtk3::init_check failed, probably unable to open DISPLAY', 2 25 | unless Gtk3::init_check (); 26 | Gtk3::init (); 27 | is_deeply (\@ARGV, [qw(--help --urgs tree)]); 28 | 29 | # Ensure that version parsing still works after the setlocale() done by 30 | # Gtk3::init(). 31 | ok (defined eval 'use 5.8.0; 1'); 32 | } 33 | 34 | # Ensure that error messages are reported at the point in the program, not in 35 | # Gtk3.pm. 36 | { 37 | eval { my $b = Gtk3::LinkButton->new; }; 38 | like ($@, qr/00-init\.t/); 39 | } 40 | 41 | my @run_version = Gtk3->get_version_info; 42 | my @compile_version = Gtk3->GET_VERSION_INFO; 43 | 44 | diag 'Testing Gtk3 ', $Gtk3::VERSION; 45 | diag ' Running against gtk+ ', join '.', @run_version; 46 | diag ' Compiled against gtk+ ', join '.', @compile_version; 47 | 48 | is (@run_version, 3, 'version info is three items long' ); 49 | is (Gtk3->check_version(0,0,0), 'GTK+ version too new (major mismatch)', 50 | 'check_version fail 1'); 51 | is (Gtk3->check_version(3,0,0), undef, 'check_version pass'); 52 | is (Gtk3->check_version(50,0,0), 'GTK+ version too old (major mismatch)', 53 | 'check_version fail 2'); 54 | ok (defined (Gtk3::get_major_version()), 'major_version'); 55 | ok (defined (Gtk3::get_minor_version()), 'minor_version'); 56 | ok (defined (Gtk3::get_micro_version()), 'micro_version'); 57 | 58 | is (@compile_version, 3, 'version info is three items long'); 59 | ok (Gtk3->CHECK_VERSION(3,0,0), 'CHECK_VERSION pass'); 60 | ok (!Gtk3->CHECK_VERSION(50,0,0), 'CHECK_VERSION fail'); 61 | is (Gtk3->MAJOR_VERSION, $compile_version[0], 'MAJOR_VERSION'); 62 | is (Gtk3->MINOR_VERSION, $compile_version[1], 'MINOR_VERSION'); 63 | is (Gtk3->MICRO_VERSION, $compile_version[2], 'MICRO_VERSION'); 64 | -------------------------------------------------------------------------------- /t/zz-GtkRadioButton.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | BEGIN { require './t/inc/setup.pl' } 4 | 5 | use strict; 6 | use warnings; 7 | 8 | if (Gtk3::CHECK_VERSION (3, 2, 5)) { 9 | plan tests => 11; 10 | } else { 11 | plan skip_all => 'GtkRadioButton was not properly annotated in gtk+ < 3.2.5'; 12 | } 13 | 14 | { 15 | my $item_one = Gtk3::RadioButton -> new(); 16 | isa_ok($item_one, "Gtk3::RadioButton"); 17 | 18 | my $item_two = Gtk3::RadioButton -> new($item_one -> get_group()); 19 | isa_ok($item_two, "Gtk3::RadioButton"); 20 | 21 | my $item_three = Gtk3::RadioButton -> new_with_label([], "Bla"); 22 | isa_ok($item_three, "Gtk3::RadioButton"); 23 | 24 | my $item_four = Gtk3::RadioButton -> new_with_mnemonic([$item_one, $item_two], "_Bla"); 25 | isa_ok($item_four, "Gtk3::RadioButton"); 26 | 27 | $item_three -> set_group($item_one -> get_group()); 28 | is_deeply($item_one -> get_group(), 29 | [$item_one, $item_two, $item_three, $item_four]); 30 | 31 | my $item_five = Gtk3::RadioButton -> new_from_widget($item_one); 32 | isa_ok($item_five, "Gtk3::RadioButton"); 33 | 34 | my $item_six = Gtk3::RadioButton -> new_with_label_from_widget($item_two, "Bla"); 35 | isa_ok($item_six, "Gtk3::RadioButton"); 36 | 37 | my $item_seven = Gtk3::RadioButton -> new_with_mnemonic_from_widget($item_three, "_Bla"); 38 | isa_ok($item_seven, "Gtk3::RadioButton"); 39 | 40 | is_deeply($item_one -> get_group(), 41 | [$item_one, $item_two, $item_three, $item_four, 42 | $item_five, $item_six, $item_seven]); 43 | } 44 | 45 | { 46 | my $item_one = Gtk3::RadioButton -> new_from_widget(undef); 47 | my $item_two = Gtk3::RadioButton -> new($item_one); 48 | my $item_three = Gtk3::RadioButton -> new_with_label($item_one, "Bla"); 49 | my $item_four = Gtk3::RadioButton -> new_with_mnemonic($item_one, "_Bla"); 50 | is_deeply($item_one -> get_group(), [$item_one, $item_two, $item_three, $item_four]); 51 | 52 | my $item_five = Gtk3::RadioButton -> new_from_widget($item_one); 53 | my $item_six = Gtk3::RadioButton -> new_with_label_from_widget($item_two, "Bla"); 54 | my $item_seven = Gtk3::RadioButton -> new_with_mnemonic_from_widget($item_three, "_Bla"); 55 | is_deeply($item_seven -> get_group(), 56 | [$item_one, $item_two, $item_three, $item_four, 57 | $item_five, $item_six, $item_seven]); 58 | } 59 | 60 | __END__ 61 | 62 | Copyright (C) 2003-2012 by the gtk2-perl team (see the file AUTHORS for the 63 | full list). See LICENSE for more information. 64 | -------------------------------------------------------------------------------- /t/zz-GtkInfoBar.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | # 3 | # Originally copied from Gtk2/t/GtkInfoBar.t 4 | # 5 | 6 | BEGIN { require './t/inc/setup.pl' } 7 | 8 | use strict; 9 | use warnings; 10 | 11 | plan tests => 16; 12 | 13 | ok (my $win = Gtk3::Window->new ('toplevel')); 14 | 15 | my $infobar = Gtk3::InfoBar->new; 16 | isa_ok ($infobar, 'Gtk3::InfoBar', 'new'); 17 | $win->add ($infobar); 18 | 19 | isa_ok ($infobar->get_action_area, 'Gtk3::Widget', 'get_action_area'); 20 | isa_ok ($infobar->get_content_area, 'Gtk3::Widget', 'get_content_area'); 21 | 22 | isa_ok ($infobar->add_button (test3 => 3), 'Gtk3::Widget', 'add_button'); 23 | is (button_count ($infobar), 1, 'add_button count'); 24 | $infobar->add_buttons (test4 => 4, test5 => 5); 25 | is (button_count ($infobar), 3, 'add_buttons'); 26 | 27 | my $button = Gtk3::Button->new ('action_widget'); 28 | $infobar->add_action_widget ($button, 6); 29 | is (button_count ($infobar), 4, 'add_action_widget'); 30 | 31 | my $infobar2 = Gtk3::InfoBar->new( 32 | 'gtk-ok' => 'ok', 'test2' => 2, 33 | ); 34 | isa_ok ($infobar2, 'Gtk3::InfoBar', 'new_with_buttons'); 35 | is (button_count ($infobar2), 2, 'new_with_buttons buttons count'); 36 | 37 | $infobar->set_response_sensitive (6, Glib::FALSE); 38 | is ($button->is_sensitive, Glib::FALSE, 'set_response_sensitive'); 39 | 40 | $infobar->set_message_type ('error'); 41 | is ($infobar->get_message_type, 'error', '[gs]et_message_type'); 42 | 43 | $infobar->set_default_response (4); 44 | ok (1, 'set_default_response'); 45 | 46 | { 47 | my $infobar = Gtk3::InfoBar->new; 48 | $infobar->signal_connect (response => sub { 49 | is ($_[2], 'DATA', 'user data made it through'); 50 | Gtk3::EVENT_STOP; 51 | }, 'DATA'); 52 | $infobar->response ('ok'); 53 | } 54 | 55 | SKIP: { 56 | skip 'Need generic signal marshaller', 2 57 | unless check_gi_version (1, 33, 10); 58 | 59 | my $infobar = Gtk3::InfoBar->new; 60 | $infobar->signal_connect (response => sub { 61 | my ($infobar, $response) = @_; 62 | my $expected = $infobar->{expected_response}; 63 | is ($response, $expected, "response '$expected'"); 64 | Gtk3::EVENT_STOP; 65 | }); 66 | $infobar->response ($infobar->{expected_response} = 5); 67 | $infobar->response ($infobar->{expected_response} = 'ok'); 68 | } 69 | 70 | sub button_count { 71 | my @b = $_[0]->get_action_area->get_children; 72 | return scalar @b; 73 | } 74 | 75 | __END__ 76 | 77 | Copyright (C) 2003-2013 by the gtk2-perl team (see the file AUTHORS for the 78 | full list). See LICENSE for more information. 79 | -------------------------------------------------------------------------------- /t/zz-GtkRadioMenuItem.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Based on Gtk2/t/GtkRadioMenuItem.t 4 | 5 | BEGIN { require './t/inc/setup.pl' } 6 | 7 | use strict; 8 | use warnings; 9 | 10 | if (Gtk3::CHECK_VERSION (3, 4, 5)) { 11 | plan tests => 12; 12 | } else { 13 | plan skip_all => 'GtkRadioMenuItem was not properly annotated in gtk+ < 3.4.5'; 14 | } 15 | 16 | { 17 | my $item_one = Gtk3::RadioMenuItem -> new(); 18 | isa_ok($item_one, "Gtk3::RadioMenuItem"); 19 | 20 | my $item_two = Gtk3::RadioMenuItem -> new($item_one -> get_group()); 21 | isa_ok($item_two, "Gtk3::RadioMenuItem"); 22 | 23 | my $item_three = Gtk3::RadioMenuItem -> new_with_label([], "Bla"); 24 | isa_ok($item_three, "Gtk3::RadioMenuItem"); 25 | 26 | my $item_four = Gtk3::RadioMenuItem -> new_with_mnemonic([$item_one, $item_two], "_Bla"); 27 | isa_ok($item_four, "Gtk3::RadioMenuItem"); 28 | 29 | is_deeply($item_one -> get_group(), 30 | [$item_one, $item_two, $item_four]); 31 | 32 | $item_three -> set_group($item_one -> get_group()); 33 | is_deeply($item_one -> get_group(), 34 | [$item_one, $item_two, $item_three, $item_four]); 35 | 36 | my $item_five = Gtk3::RadioMenuItem -> new_from_widget($item_one); 37 | isa_ok($item_five, "Gtk3::RadioMenuItem"); 38 | 39 | my $item_six = Gtk3::RadioMenuItem -> new_with_label_from_widget($item_two, "Bla"); 40 | isa_ok($item_six, "Gtk3::RadioMenuItem"); 41 | 42 | my $item_seven = Gtk3::RadioMenuItem -> new_with_mnemonic_from_widget($item_three, "_Bla"); 43 | isa_ok($item_seven, "Gtk3::RadioMenuItem"); 44 | 45 | is_deeply($item_one -> get_group(), 46 | [$item_one, $item_two, $item_three, $item_four, 47 | $item_five, $item_six, $item_seven]); 48 | } 49 | 50 | { 51 | my $item_one = Gtk3::RadioMenuItem -> new_from_widget(undef); 52 | my $item_two = Gtk3::RadioMenuItem -> new($item_one); 53 | my $item_three = Gtk3::RadioMenuItem -> new_with_label($item_one, "Bla"); 54 | my $item_four = Gtk3::RadioMenuItem -> new_with_mnemonic($item_one, "_Bla"); 55 | is_deeply($item_one -> get_group(), [$item_one, $item_two, $item_three, $item_four]); 56 | 57 | my $item_five = Gtk3::RadioMenuItem -> new_from_widget($item_one); 58 | my $item_six = Gtk3::RadioMenuItem -> new_with_label_from_widget($item_two, "Bla"); 59 | my $item_seven = Gtk3::RadioMenuItem -> new_with_mnemonic_from_widget($item_three, "_Bla"); 60 | is_deeply($item_seven -> get_group(), 61 | [$item_one, $item_two, $item_three, $item_four, 62 | $item_five, $item_six, $item_seven]); 63 | } 64 | 65 | __END__ 66 | 67 | Copyright (C) 2003-2012 by the gtk2-perl team (see the file AUTHORS for the 68 | full list). See LICENSE for more information. 69 | -------------------------------------------------------------------------------- /t/zz-GtkCellLayoutIface.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | BEGIN { require './t/inc/setup.pl' } 4 | 5 | use strict; 6 | use warnings; 7 | use Glib ':constants'; 8 | 9 | plan tests => 35; 10 | 11 | my $cell = Gtk3::CellRendererText->new (); 12 | 13 | my $layout = CustomCellLayout->new (); 14 | $layout->pack_start ($cell, TRUE); 15 | $layout->pack_end ($cell, FALSE); 16 | $layout->clear (); 17 | $layout->add_attribute ($cell, text => 42); 18 | $layout->clear_attributes ($cell); 19 | $layout->set_attributes ($cell, text => 42); 20 | $layout->reorder ($cell, 42); 21 | 22 | my @cells = $layout->get_cells (); 23 | is (scalar @cells, 2); 24 | isa_ok ($cells[0], 'Gtk3::CellRendererText'); 25 | isa_ok ($cells[1], 'Gtk3::CellRendererToggle'); 26 | 27 | SKIP: { 28 | skip 'tree model ctors not properly supported', 9 29 | unless check_gi_version(1, 29, 17); 30 | my $callback = sub { 31 | my ($cb_layout, $cb_cell, $model, $iter, $data) = @_; 32 | is ($cb_layout, $layout); 33 | is ($cb_cell, $cell); 34 | isa_ok ($model, 'Gtk3::ListStore'); 35 | isa_ok ($iter, 'Gtk3::TreeIter'); 36 | is ($data, 'bla!'); 37 | }; 38 | $layout->set_cell_data_func ($cell, $callback, 'bla!'); 39 | $layout->set_cell_data_func ($cell, undef); 40 | } 41 | 42 | package CustomCellLayout; 43 | 44 | use strict; 45 | use warnings; 46 | use Glib ':constants'; 47 | 48 | use Test::More; 49 | 50 | use Glib::Object::Subclass 51 | Gtk3::Widget::, 52 | interfaces => [ Gtk3::CellLayout:: ], 53 | ; 54 | 55 | sub PACK_START { 56 | my ($self, $cell, $expand) = @_; 57 | isa_ok ($self, __PACKAGE__); 58 | isa_ok ($cell, 'Gtk3::CellRenderer'); 59 | is ($expand, TRUE); 60 | } 61 | 62 | sub PACK_END { 63 | my ($self, $cell, $expand) = @_; 64 | isa_ok ($self, __PACKAGE__); 65 | isa_ok ($cell, 'Gtk3::CellRenderer'); 66 | is ($expand, FALSE); 67 | } 68 | 69 | sub CLEAR { 70 | my ($self) = @_; 71 | isa_ok ($self, __PACKAGE__); 72 | } 73 | 74 | sub ADD_ATTRIBUTE { 75 | my ($self, $cell, $attribute, $column) = @_; 76 | isa_ok ($self, __PACKAGE__); 77 | isa_ok ($cell, 'Gtk3::CellRenderer'); 78 | is ($attribute, 'text'); 79 | is ($column, 42); 80 | } 81 | 82 | sub SET_CELL_DATA_FUNC { 83 | my ($self, $cell, $func, $data) = @_; 84 | isa_ok ($self, __PACKAGE__); 85 | isa_ok ($cell, 'Gtk3::CellRenderer'); 86 | if (defined $func) { 87 | my $model = Gtk3::ListStore->new (qw/Glib::String/); 88 | $func->($self, $cell, $model, $model->append (), $data); 89 | } 90 | } 91 | 92 | sub CLEAR_ATTRIBUTES { 93 | my ($self, $cell) = @_; 94 | isa_ok ($self, __PACKAGE__); 95 | isa_ok ($cell, 'Gtk3::CellRenderer'); 96 | } 97 | 98 | sub REORDER { 99 | my ($self, $cell, $position) = @_; 100 | isa_ok ($self, __PACKAGE__); 101 | isa_ok ($cell, 'Gtk3::CellRenderer'); 102 | is ($position, 42); 103 | } 104 | 105 | sub grow_the_stack { 0 .. 500 }; 106 | 107 | sub GET_CELLS { 108 | my ($self) = @_; 109 | isa_ok ($self, __PACKAGE__); 110 | $self->{cell_one} = Gtk3::CellRendererText->new; 111 | $self->{cell_two} = Gtk3::CellRendererToggle->new; 112 | my @list = grow_the_stack(); 113 | return [$self->{cell_one}, $self->{cell_two}]; 114 | } 115 | -------------------------------------------------------------------------------- /t/zz-GtkCellRendererIface.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | BEGIN { require './t/inc/setup.pl' } 4 | 5 | use strict; 6 | use warnings; 7 | use Glib ':constants'; 8 | 9 | plan skip_all => 'tree model ctors not properly supported' 10 | unless check_gi_version(1, 29, 17); 11 | plan tests => 15; 12 | 13 | foreach my $package (qw/StandAlone InheritorC InheritorPerl/) { 14 | my ($cell, $view) = prepare_cell ($package); 15 | 16 | my ($min, $nat) = $cell->get_preferred_width ($view); 17 | ok (defined $min); 18 | ok (defined $nat); 19 | 20 | my $rect = { x => 5, y => 5, width => 10, height => 10 }; 21 | my $aligned_rect = $cell->get_aligned_area ($view, 'selected', $rect); 22 | ok (exists $aligned_rect->{x}); 23 | 24 | TODO: { 25 | local $SIG{__WARN__} = sub { warn $_[0] if -1 == index $_[0], 'Asked to hand out object' }; 26 | $cell->set (mode => 'editable'); 27 | $cell->set (editable => TRUE); 28 | my $event = Gtk3::Gdk::Event->new ("button-press"); 29 | my $editable = $cell->start_editing ($event, $view, "0", $rect, $rect, qw(selected)); 30 | isa_ok ($editable, "Gtk3::Entry"); 31 | 32 | local $TODO = 'ref-counting not quite right yet'; 33 | my $destroyed = FALSE; 34 | $editable->signal_connect (destroy => sub { $destroyed = TRUE }); 35 | undef $editable; 36 | ok ($destroyed, 'editable was destroyed'); 37 | } 38 | } 39 | 40 | sub prepare_cell { 41 | my ($package) = @_; 42 | 43 | my $model = Gtk3::ListStore->new ('Glib::String'); 44 | foreach (qw/foo fluffy flurble frob frobnitz ftang fire truck/) { 45 | my $iter = $model->append; 46 | $model->set ($iter, 0, $_); 47 | } 48 | my $view = Gtk3::TreeView->new ($model); 49 | 50 | my $cell = $package->new; 51 | my $column = Gtk3::TreeViewColumn->new_with_attributes ( 52 | 'stand-alone', $cell); 53 | $view->append_column ($column); 54 | 55 | return ($cell, $view); 56 | } 57 | 58 | { 59 | package StandAlone; 60 | use Glib::Object::Subclass 61 | Gtk3::CellRenderer::, 62 | properties => [ 63 | Glib::ParamSpec->boolean ( 64 | 'editable', 65 | 'editable', 66 | 'editable', 67 | Glib::FALSE, 68 | [qw/readable writable/], 69 | ), 70 | ], 71 | ; 72 | use Test::More; 73 | sub GET_PREFERRED_WIDTH { 74 | my ($cell, $widget) = @_; 75 | return (23, 42); 76 | } 77 | sub GET_ALIGNED_AREA { 78 | my ($cell, $widget, $flags, $cell_area) = @_; 79 | return $cell_area; 80 | } 81 | sub START_EDITING { 82 | my ($cell, $event, $widget, $path, $bg_area, $cell_area, $flags) = @_; 83 | return Gtk3::Entry->new; 84 | } 85 | } 86 | 87 | { 88 | package InheritorC; 89 | use Glib::Object::Subclass 90 | Gtk3::CellRendererText:: 91 | ; 92 | sub GET_PREFERRED_WIDTH { 93 | return shift->SUPER::GET_PREFERRED_WIDTH (@_); 94 | } 95 | sub GET_ALIGNED_AREA { 96 | return shift->SUPER::GET_ALIGNED_AREA (@_); 97 | } 98 | sub START_EDITING { 99 | return shift->SUPER::START_EDITING (@_); 100 | } 101 | } 102 | 103 | { 104 | package InheritorPerl; 105 | use Glib::Object::Subclass 106 | StandAlone:: 107 | ; 108 | sub GET_PREFERRED_WIDTH { 109 | return shift->SUPER::GET_PREFERRED_WIDTH (@_); 110 | } 111 | sub GET_ALIGNED_AREA { 112 | return shift->SUPER::GET_ALIGNED_AREA (@_); 113 | } 114 | sub START_EDITING { 115 | return shift->SUPER::START_EDITING (@_); 116 | } 117 | } 118 | -------------------------------------------------------------------------------- /t/zz-GtkActionGroup.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copied from Gtk2/t/GtkActionGroup.t 4 | 5 | BEGIN { require './t/inc/setup.pl' } 6 | 7 | use strict; 8 | use warnings; 9 | 10 | plan tests => 28; 11 | 12 | use Glib 'TRUE', 'FALSE'; 13 | 14 | my $action_group = Gtk3::ActionGroup->new ('Fred'); 15 | 16 | isa_ok ($action_group, 'Gtk3::ActionGroup'); 17 | is ($action_group->get_name, 'Fred'); 18 | 19 | $action_group->set_sensitive (1); 20 | is ($action_group->get_sensitive, 1); 21 | 22 | $action_group->set_visible (1); 23 | is ($action_group->get_visible, 1); 24 | 25 | my $action = Gtk3::Action->new ('Barney'); 26 | 27 | $action_group->add_action ($action); 28 | 29 | my @list = $action_group->list_actions; 30 | is (@list, 1); 31 | is ($list[0], $action); 32 | is ($action_group->get_action ('Barney'), $action); 33 | $action_group->remove_action ($action); 34 | @list = $action_group->list_actions; 35 | is (@list, 0); 36 | 37 | $action_group->add_action_with_accel ($action, undef); 38 | $action_group->remove_action ($action); 39 | 40 | $action_group->add_action_with_accel ($action, "a"); 41 | $action_group->remove_action ($action); 42 | 43 | my @action_entries = ( 44 | { 45 | name => 'open', 46 | stock_id => 'gtk-open', 47 | label => 'Open', 48 | accelerator => 'o', 49 | tooltip => 'Open something', 50 | callback => sub { ok (TRUE) }, 51 | }, 52 | { 53 | name => 'new', 54 | stock_id => 'gtk-new', 55 | }, 56 | { 57 | name => 'old', 58 | label => 'Old', 59 | }, 60 | [ 'close', 'gtk-close', 'Close', 'w', 'Close something', sub { ok (TRUE) } ], 61 | [ 'quit', 'gtk-quit', undef, 'q', ], 62 | [ 'sep', undef, 'blank', ], 63 | ); 64 | 65 | my @toggle_entries = ( 66 | [ "Bold", 'gtk-bold', "_Bold", # name, stock id, label 67 | "B", "Bold", # accelerator, tooltip 68 | \&activate_action, TRUE ], # is_active 69 | ); 70 | 71 | use constant COLOR_RED => 0; 72 | use constant COLOR_GREEN => 1; 73 | use constant COLOR_BLUE => 2; 74 | 75 | my @color_entries = ( 76 | # name, stock id, label, accelerator, tooltip, value 77 | [ "Red", undef, "_Red", "R", "Blood", COLOR_RED ], 78 | [ "Green", undef, "_Green", "G", "Grass", COLOR_GREEN ], 79 | [ "Blue", undef, "_Blue", "B", "Sky", COLOR_BLUE ], 80 | ); 81 | 82 | #$action_group->add_actions (\@action_entries, 42) 83 | $action_group->add_actions (\@action_entries); 84 | @list = $action_group->list_actions; 85 | is (@list, 6); 86 | 87 | $action_group->add_toggle_actions (\@toggle_entries, 42); 88 | #$action_group->add_toggle_actions (\@toggle_entries); 89 | @list = $action_group->list_actions; 90 | is (@list, 7); 91 | 92 | 93 | #$action_group->add_radio_actions (\@color_entries, COLOR_BLUE, \&on_change, 42); 94 | $action_group->add_radio_actions (\@color_entries, COLOR_GREEN, \&on_change); 95 | @list = $action_group->list_actions; 96 | is (@list, 10); 97 | 98 | $action_group->set_translation_domain("de_DE"); 99 | 100 | $action_group = Gtk3::ActionGroup->new ("Fred"); 101 | 102 | $action_group->set_translate_func(sub { 103 | my ($string, $data) = @_; 104 | 105 | is($string, "Urgs"); 106 | is($data, "bla"); 107 | 108 | return "Sgru"; 109 | }, "bla"); 110 | 111 | is($action_group->translate_string("Urgs"), "Sgru"); 112 | 113 | # as of 2.6.0 we have the ability to call the translation function 114 | # from add_*_actions like we're supposed to, so let's test that. 115 | # the following should result in 14 oks. 116 | $action_group->set_translate_func (sub { ok(TRUE, 'xlate'); reverse $_[0]; }); 117 | $action_group->add_actions (\@action_entries); 118 | $action_group->add_toggle_actions (\@toggle_entries, 42); 119 | $action_group->add_radio_actions (\@color_entries, COLOR_GREEN, \&on_change); 120 | 121 | __END__ 122 | 123 | Copyright (C) 2003-2005 by the gtk2-perl team (see the file AUTHORS for the 124 | full list). See LICENSE for more information. 125 | -------------------------------------------------------------------------------- /README: -------------------------------------------------------------------------------- 1 | Gtk3 2 | ==== 3 | 4 | Perl bindings to the 3.x series of the gtk+ toolkit. This module allows you to 5 | write graphical user interfaces in a Perlish and object-oriented way, freeing 6 | you from the casting and memory management in C, yet remaining very close in 7 | spirit to original API. 8 | 9 | 10 | INSTALLATION 11 | ------------ 12 | 13 | To install this module type the following: 14 | 15 | perl Makefile.PL 16 | make 17 | make test 18 | make install 19 | 20 | 21 | DEPENDENCIES 22 | ------------ 23 | 24 | Gtk3 needs this C library: 25 | 26 | gtk+-3.0 >= 3.0.0 27 | 28 | and these Perl modules: 29 | 30 | Glib::Object::Introspection >= 0.002 31 | 32 | HOW TO CONTACT US 33 | ----------------- 34 | 35 | Homepage: http://gtk2-perl.sourceforge.net/ 36 | Support forum: https://discourse.gnome.org/tags/c/platform/language-bindings/11/perl 37 | Mailing list archives: https://mail.gnome.org/archives/gtk-perl-list/ 38 | IRC: irc://irc.gnome.org/#gtk-perl 39 | E-mail bug submission via CPAN's RT: 40 | bug-Gtk3 [at] rt.cpan.org 41 | Web bug submission via GNOME's bugtracker: 42 | https://gitlab.gnome.org/GNOME/perl-gtk3/-/issues 43 | 44 | Please do not contact any of the maintainers directly unless they ask you to. 45 | The first point of contact for questions/problems/issues should always be the 46 | support forum. 47 | 48 | 49 | BUG REPORTS 50 | ----------- 51 | 52 | For help with problems, please contact the support forum (above). If you 53 | already know you have a bug, please file it with one of the bug trackers 54 | below. With any problems and/or bug reports, it's always helpful for the 55 | developers to have the following information: 56 | 57 | - A small script that demonstrates the problem; this is not required, however, 58 | it will get your issue looked at much faster than a description of the 59 | problem alone. 60 | - Version of Perl (perl -v) 61 | - Versions of Gtk2-Perl modules (Glib/Gtk2/Pango/Cairo) 62 | - Optional, but nice to have: versions of GTK+ libraries on your system 63 | (libglib, libgtk+, libpango, libcairo, etc.) 64 | 65 | There are multiple project bug trackers, please choose the one you are most 66 | comfortable with using and/or already have an account for. 67 | 68 | Request Tracker: 69 | - submitting bugs via the Web (requires a PAUSE account/Bitcard): 70 | https://rt.cpan.org/Public/Bug/Report.html?Queue=Gtk3 71 | - submitting bugs via e-mail (open to anyone with e-mail): 72 | bug-Gtk3 [at] rt.cpan.org 73 | 74 | GNOME's bugtracker: 75 | - report bugs to the 'perl-gtk3' product (requires login) 76 | https://gitlab.gnome.org/GNOME/perl-gtk3/-/issues 77 | 78 | PATCH SUBMISSION GUIDELINES 79 | --------------------------- 80 | 81 | You can send us patches by... 82 | - Creating a Merge Request in GNOME GitLab. 83 | - Those with gnome.org Git ID's can push trivial patches to git directly; if 84 | you're not sure what a trivial patch is, please ask first in the support 85 | forum prior to pushing your commit. 86 | 87 | OBTAINING SOURCE FROM THE GNOME.ORG GIT REPO 88 | -------------------------------------------- 89 | 90 | Assuming you already have the 'git' command installed on your system, you can 91 | use the 'git://' protocol: 92 | 93 | git clone git://git.gnome.org/perl-Gtk3 94 | 95 | Or, read-only access via HTTP: 96 | 97 | git clone http://git.gnome.org/browse/perl-Gtk3 98 | 99 | To update an existing clone of the source: 100 | 101 | git pull 102 | 103 | Most Linux distros package the 'git' command in a package called either 'git' 104 | or 'git-core'. 105 | 106 | 107 | COPYRIGHT AND LICENSE 108 | --------------------- 109 | 110 | Copyright (C) 2005-2012 Torsten Schoenfeld 111 | 112 | This library is free software; you can redistribute it and/or modify it under 113 | the terms of the GNU Library General Public License as published by the Free 114 | Software Foundation; either version 2.1 of the License, or (at your option) any 115 | later version. 116 | 117 | This library is distributed in the hope that it will be useful, but WITHOUT ANY 118 | WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A 119 | PARTICULAR PURPOSE. 120 | 121 | See the LICENSE file in the top-level directory of this distribution for the 122 | full license terms. 123 | -------------------------------------------------------------------------------- /t/zz-GtkDialog.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | # 3 | # Based on Gtk2/t/GtkDialog.t 4 | # 5 | BEGIN { require './t/inc/setup.pl' }; 6 | 7 | use strict; 8 | use warnings; 9 | 10 | plan tests => 49; 11 | 12 | my $win = Gtk3::Window->new ('toplevel'); 13 | 14 | # a constructor-made dialog, run 15 | my $d1 = Gtk3::Dialog->new ('Test Dialog', $win, 16 | [qw/destroy-with-parent/], 17 | 'gtk-cancel', 2, 'gtk-quit', 3); 18 | my $btn1 = $d1->add_button ('Another', 4); 19 | Glib::Idle->add (sub { $btn1->clicked; 0; }); 20 | is ($d1->run, 4); 21 | $d1->hide; 22 | 23 | # a hand-made dialog, run 24 | my $d2 = Gtk3::Dialog->new; 25 | $d2->set_transient_for ($win); 26 | $d2->add_button ('First Button', 0); 27 | my $btn2 = $d2->add_button ('gtk-ok', 1); 28 | $d2->add_buttons ('gtk-cancel', 2, 'gtk-quit', 3, 'Last Button', 4); 29 | $d2->add_action_widget (Gtk3::Button->new('Uhh'), 'help'); 30 | $d2->set_default_response ('cancel'); 31 | $d2->set_response_sensitive (4, Glib::TRUE); 32 | $d2->signal_connect (response => sub { is ($_[1], 1); 1; }); 33 | Glib::Idle->add (sub { $btn2->clicked; 0; }); 34 | is ($d2->run, 1); 35 | $d2->hide; 36 | 37 | # a constructor-made dialog, show 38 | my $d3 = Gtk3::Dialog->new_with_buttons ('Test Dialog', $win, 39 | [qw/destroy-with-parent/], 40 | 'gtk-ok', 22, 'gtk-quit', 33); 41 | my $btn3 = $d3->add_button('Another', 44); 42 | my $btn4 = $d3->add_button('Help', 'help'); 43 | $d3->set_response_sensitive ('help', Glib::TRUE); 44 | is ($d3->get_response_for_widget ($btn3), 44); 45 | is ($d3->get_response_for_widget ($btn4), 'help'); 46 | is ($d3->get_widget_for_response (44), $btn3); 47 | is ($d3->get_widget_for_response ('help'), $btn4); 48 | $d3->get_content_area->pack_start (Gtk3::Label->new ('This is just a test.'), 0, 0, 0); 49 | $d3->get_action_area->pack_start (Gtk3::Label->new ('<- Actions'), 0, 0, 0); 50 | $d3->signal_connect (response => sub { is ($_[1], 44); 1; }); 51 | $btn3->clicked; 52 | 53 | # test whether user data are passed to the callback functions 54 | { 55 | my $d = Gtk3::Dialog->new; 56 | $d->set_transient_for ($win); 57 | my $b = $d->add_button ('First Button', 'ok'); 58 | # pass user data to the callback function 59 | $d->signal_connect('response'=> sub { 60 | is ($_[2], 'DATA', 'user data are passed to the callback function'); 61 | Gtk3::EVENT_STOP; 62 | }, 'DATA'); 63 | Glib::Idle->add( sub { 64 | $b->clicked; 65 | Glib::SOURCE_REMOVE; 66 | }); 67 | is ($d->run, 'ok'); 68 | $d->hide; 69 | } 70 | 71 | # make sure that known response types are converted to strings for the reponse 72 | # signal of Gtk3::Dialog and its ancestors 73 | SKIP: { 74 | skip 'Need generic signal marshaller', 4 75 | unless check_gi_version (1, 33, 10); 76 | 77 | foreach my $package (qw/Gtk3::Dialog Gtk3::AboutDialog/) { 78 | my $d = $package->new; 79 | $d->set_transient_for ($win); 80 | my $b = $d->add_button ('First Button', 'ok'); 81 | $d->signal_connect (response => sub { 82 | is ($_[1], 'ok', "$package response"); 83 | Gtk3::EVENT_STOP; 84 | }); 85 | Glib::Idle->add( sub { 86 | $b->clicked; 87 | Glib::SOURCE_REMOVE; 88 | }); 89 | is ($d->run, 'ok', "$package run"); 90 | $d->hide; 91 | } 92 | } 93 | 94 | { 95 | my $d = Gtk3::Dialog->new; 96 | $d->set_alternative_button_order (2, 3); 97 | $d->set_alternative_button_order (qw(ok cancel accept), 3); 98 | $d->set_alternative_button_order; 99 | 100 | my $screen = Gtk3::Gdk::Screen::get_default; 101 | ok (defined Gtk3::alternative_dialog_button_order ($screen)); 102 | ok (defined Gtk3::alternative_dialog_button_order (undef)); 103 | ok (defined Gtk3::alternative_dialog_button_order); 104 | } 105 | 106 | { 107 | my @expectations = ( 108 | [[], Glib::FALSE, Glib::FALSE], 109 | [['modal'], Glib::TRUE, Glib::FALSE], 110 | [['destroy-with-parent'], Glib::FALSE, Glib::TRUE], 111 | [['modal', 'destroy-with-parent'], Glib::TRUE, Glib::TRUE], 112 | [Gtk3::DialogFlags->new ([]), Glib::FALSE, Glib::FALSE], 113 | [Gtk3::DialogFlags->new (['modal']), Glib::TRUE, Glib::FALSE], 114 | [Gtk3::DialogFlags->new (['destroy-with-parent']), Glib::FALSE, Glib::TRUE], 115 | [Gtk3::DialogFlags->new (['modal', 'destroy-with-parent']), Glib::TRUE, Glib::TRUE], 116 | ); 117 | foreach my $e (@expectations) { 118 | my $d = Gtk3::Dialog->new ('Test Dialog', $win, $e->[0], 'gtk-ok', 1); 119 | is ($d->get_modal, $e->[1]); 120 | is ($d->get_destroy_with_parent, $e->[2]); 121 | } 122 | foreach my $e (@expectations) { 123 | my $d = Gtk3::MessageDialog->new ($win, $e->[0], 'info', 'ok'); 124 | is ($d->get_modal, $e->[1]); 125 | is ($d->get_destroy_with_parent, $e->[2]); 126 | } 127 | } 128 | -------------------------------------------------------------------------------- /t/zz-GtkImage.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | # 3 | # Originally copied from Gtk2/t/GtkImage.t 4 | # 5 | 6 | BEGIN { require './t/inc/setup.pl' } 7 | 8 | use strict; 9 | use warnings; 10 | 11 | plan tests => 36; 12 | 13 | my $pixbuf = Gtk3::Gdk::Pixbuf->new ('rgb', Glib::TRUE, 8, 10, 10); 14 | 15 | # Plain old new ################################################################ 16 | 17 | ok (my $img = Gtk3::Image->new, 'Gtk3::Image->new'); 18 | 19 | my @ret = $img->get_icon_set; 20 | is (scalar (@ret), 2); 21 | is ($ret[0], undef); 22 | ok (defined $ret[1]); # unpredictable 23 | is ($img->get_pixbuf, undef, 'get_pixbuf empty'); 24 | @ret = $img->get_stock (); 25 | is (scalar (@ret), 2); 26 | is ($ret[0], undef); 27 | ok (defined $ret[1]); # unpredictable 28 | is ($img->get_animation, undef, 'get_animation empty'); 29 | is ($img->get_storage_type, 'empty', 'get_storage_type empty'); 30 | 31 | # new from stock ############################################################### 32 | 33 | ok ($img = Gtk3::Image->new_from_stock ('gtk-cancel', 'menu'), 34 | 'Gtk3::Image->new_from_stock'); 35 | is ($img->get_storage_type, 'stock', 'new_from_stock get_storage_type'); 36 | is_deeply ([$img->get_stock ()], ['gtk-cancel', 'menu'], 37 | 'new_from_stock get_stock'); 38 | 39 | # new from icon set ############################################################ 40 | 41 | my $iconset = Gtk3::IconSet->new_from_pixbuf ($pixbuf); 42 | ok ($img = Gtk3::Image->new_from_icon_set ($iconset, 'small-toolbar'), 43 | 'Gtk3::Image->new_from_icon_set'); 44 | @ret = $img->get_icon_set; 45 | is (scalar (@ret), 2, 'new_from_icon_set get_icon_set num rets'); 46 | isa_ok ($ret[0], 'Gtk3::IconSet', 'new_from_icon_set get_icon_set icon_set'); 47 | is ($ret[1], 'small-toolbar', 'new_from_icon_set get_icon_set size'); 48 | 49 | # new from pixbuf ############################################################## 50 | 51 | ok ($img = Gtk3::Image->new_from_pixbuf ($pixbuf), 52 | 'Gtk3::Image->new_from_pixbuf'); 53 | isa_ok ($img->get_pixbuf, 'Gtk3::Gdk::Pixbuf', 'new_from_pixbuf get_pixbuf'); 54 | 55 | # set from stock ############################################################### 56 | 57 | $img->set_from_stock ('gtk-quit', 'dialog'); 58 | is ($img->get_storage_type, 'stock', 'set_from_stock get_storage_type'); 59 | is_deeply ([$img->get_stock ()], ['gtk-quit', 'dialog'], 60 | 'set_from_stock get_stock'); 61 | 62 | # set from icon set ############################################################ 63 | 64 | $img->set_from_icon_set ($iconset, 'small-toolbar'); 65 | @ret = $img->get_icon_set; 66 | is (scalar (@ret), 2, 'set_from_icon_set get_icon_set num rets'); 67 | isa_ok ($ret[0], 'Gtk3::IconSet', 'set_from_icon_set get_icon_set icon_set'); 68 | is ($ret[1], 'small-toolbar', 'set_from_icon_set get_icon_set size'); 69 | 70 | # set from pixbuf ############################################################## 71 | 72 | $img->set_from_pixbuf (undef); 73 | $img->set_from_pixbuf ($pixbuf); 74 | isa_ok ($img->get_pixbuf, 'Gtk3::Gdk::Pixbuf', 'set_from_pixbuf get_pixbuf'); 75 | 76 | # These require access to a file, so they may be skipped 77 | 78 | my $testfile = './gtk-demo/gnome-foot.png'; 79 | 80 | SKIP: 81 | { 82 | skip "unable to find test file, $testfile", 7 83 | unless (-R $testfile); 84 | 85 | my $animation = Gtk3::Gdk::PixbufAnimation->new_from_file ($testfile); 86 | 87 | # new from file ############################################################## 88 | 89 | ok ($img = Gtk3::Image->new_from_file (''), 90 | 'Gtk3::Image->new_from_file undef'); 91 | ok ($img = Gtk3::Image->new_from_file ($testfile), 92 | 'Gtk3::Image->new_from_file'); 93 | isa_ok ($img->get_pixbuf, 'Gtk3::Gdk::Pixbuf', 94 | 'new_from_file get_pixbuf'); 95 | 96 | # new from animation ######################################################### 97 | 98 | ok ($img = Gtk3::Image->new_from_animation ($animation), 99 | 'Gtk3::Image->new_from_animation'); 100 | isa_ok ($img->get_animation, 'Gtk3::Gdk::PixbufAnimation', 101 | 'new_from_animation get_animationf'); 102 | 103 | # set from file ############################################################## 104 | 105 | $img->set_from_file (undef); 106 | $img->set_from_file ($testfile); 107 | isa_ok ($img->get_pixbuf, 'Gtk3::Gdk::Pixbuf', 108 | 'set_from_file get_pixbuf'); 109 | 110 | # set from animation ######################################################### 111 | 112 | $img->set_from_animation ($animation); 113 | isa_ok ($img->get_animation, 'Gtk3::Gdk::PixbufAnimation', 114 | 'set_from_animation get_animation'); 115 | } 116 | 117 | $img = Gtk3::Image->new_from_icon_name ('gtk-ok', 'button'); 118 | isa_ok ($img, 'Gtk3::Image', 'new_from_icon_name isa Gtk3::Image'); 119 | is_deeply ([$img->get_icon_name], ['gtk-ok', 'button'], 'deep get_icon_name'); 120 | 121 | $img->set_from_icon_name ('gtk-cancel', 'menu'); 122 | is_deeply ([$img->get_icon_name], ['gtk-cancel', 'menu'], 123 | 'get_icon_name from Gtk3::Image set_from_icon_name'); 124 | 125 | $img->set_pixel_size (23); 126 | is ($img->get_pixel_size, 23, 'Gtk3::Image get_pixel_size'); 127 | 128 | $img->clear; 129 | 130 | __END__ 131 | 132 | Copyright (C) 2003-2013 by the gtk2-perl team (see the file AUTHORS for the 133 | full list). See LICENSE for more information. 134 | -------------------------------------------------------------------------------- /t/zz-GtkTextBuffer.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Originally copied from Gtk2/t/GtkTextBuffer.t. 4 | 5 | BEGIN { require './t/inc/setup.pl' } 6 | 7 | use strict; 8 | use warnings; 9 | use utf8; 10 | use Glib qw/TRUE FALSE/; 11 | 12 | plan tests => 45; 13 | 14 | my $table = Gtk3::TextTagTable -> new(); 15 | 16 | my $buffer = Gtk3::TextBuffer -> new($table); 17 | isa_ok($buffer, "Gtk3::TextBuffer"); 18 | is($buffer -> get_tag_table(), $table); 19 | 20 | $buffer = Gtk3::TextBuffer -> new(); 21 | isa_ok($buffer, "Gtk3::TextBuffer"); 22 | 23 | isa_ok($buffer -> get_start_iter(), "Gtk3::TextIter"); 24 | isa_ok($buffer -> get_end_iter(), "Gtk3::TextIter"); 25 | 26 | $buffer -> set_modified(FALSE); 27 | 28 | # Use one multi-byte character to test length handling. 29 | my $text = "Lore ipsem dolor‽ I think that is misspelled.\n"; 30 | my $start = sub { $buffer -> get_start_iter() }; 31 | my $end = sub { $buffer -> get_end_iter() }; 32 | my $bounds = sub { $buffer -> get_bounds() }; 33 | 34 | $buffer -> insert($start->(), $text); 35 | ok($buffer -> insert_interactive($start->(), $text, TRUE)); 36 | $buffer -> insert_at_cursor($text); 37 | ok($buffer -> insert_interactive_at_cursor($text, TRUE)); 38 | $buffer -> insert_range($end->(), $bounds->()); 39 | ok($buffer -> insert_range_interactive($end->(), $bounds->(), TRUE)); 40 | 41 | my @tags = ($buffer -> create_tag("bla", indent => 2), 42 | $buffer -> create_tag("blub", indent => 2)); 43 | 44 | $buffer -> create_tag("blaa", indent => 2); 45 | $buffer -> create_tag("bluub", indent => 2); 46 | 47 | $buffer -> insert_with_tags($start->(), $text, @tags); 48 | $buffer -> insert_with_tags_by_name($start->(), $text, "blaa", "bluub"); 49 | 50 | is($buffer -> get_text($bounds->(), TRUE), $text x 18); 51 | is($buffer -> get_line_count(), 18+1); 52 | is($buffer -> get_char_count(), 18 * length $text); 53 | ok($buffer -> get_modified()); 54 | 55 | isa_ok($buffer -> get_iter_at_line_offset(1, 10), "Gtk3::TextIter"); 56 | isa_ok($buffer -> get_iter_at_offset(100), "Gtk3::TextIter"); 57 | isa_ok($buffer -> get_iter_at_line(6), "Gtk3::TextIter"); 58 | isa_ok($buffer -> get_iter_at_line_index(3, 12), "Gtk3::TextIter"); 59 | 60 | my ($start_iter, $end_iter) = $buffer -> get_bounds(); 61 | isa_ok($start_iter, "Gtk3::TextIter"); 62 | isa_ok($end_iter, "Gtk3::TextIter"); 63 | 64 | $buffer -> set_text($text); 65 | is($buffer -> get_text($bounds->(), TRUE), $text); 66 | is($buffer -> get_slice($bounds->(), TRUE), $text); 67 | 68 | $buffer -> delete($bounds->()); 69 | ok($buffer -> delete_interactive($bounds->(), TRUE)); 70 | 71 | $buffer -> insert_pixbuf($start->(), Gtk3::Gdk::Pixbuf -> new("rgb", 0, 8, 10, 10)); 72 | 73 | my $anchor = Gtk3::TextChildAnchor -> new(); 74 | $buffer -> insert_child_anchor($start->(), $anchor); 75 | 76 | isa_ok($buffer -> get_iter_at_child_anchor($anchor), "Gtk3::TextIter"); 77 | 78 | isa_ok($buffer -> create_child_anchor($start->()), "Gtk3::TextChildAnchor"); 79 | 80 | my $mark = $buffer -> create_mark("bla", $start->(), TRUE); 81 | isa_ok($mark, "Gtk3::TextMark"); 82 | is($buffer -> get_mark("bla"), $mark); 83 | 84 | isa_ok($buffer -> get_iter_at_mark($mark), "Gtk3::TextIter"); 85 | 86 | $buffer -> move_mark($mark, $end->()); 87 | $buffer -> move_mark_by_name("bla", $start->()); 88 | $buffer -> delete_mark($mark); 89 | 90 | $mark = $buffer -> create_mark("bla", $start->(), TRUE); 91 | $buffer -> delete_mark_by_name("bla"); 92 | 93 | isa_ok($buffer -> get_insert(), "Gtk3::TextMark"); 94 | isa_ok($buffer -> get_selection_bound(), "Gtk3::TextMark"); 95 | 96 | $buffer -> place_cursor($end->()); 97 | 98 | ok(!$buffer -> delete_selection(TRUE, TRUE)); 99 | ok(!$buffer -> get_selection_bounds()); 100 | 101 | { 102 | $buffer -> select_range($bounds->()); 103 | } 104 | 105 | my $tag_one = $buffer -> create_tag("alb", indent => 2, justification => 'center'); 106 | isa_ok($tag_one, "Gtk3::TextTag"); 107 | is($tag_one->get ('indent'), 2); 108 | is($tag_one->get ('justification'), 'center'); 109 | 110 | $buffer -> apply_tag($tag_one, $bounds->()); 111 | $buffer -> apply_tag_by_name("alb", $bounds->()); 112 | 113 | my $tag_two = $buffer -> create_tag("bulb", indent => 2); 114 | my $tag_three = $buffer -> create_tag(undef, indent => 2); 115 | isa_ok($tag_two, "Gtk3::TextTag"); 116 | isa_ok($tag_three, "Gtk3::TextTag"); 117 | 118 | $buffer -> remove_tag($tag_one, $bounds->()); 119 | $buffer -> remove_tag_by_name("bulb", $bounds->()); 120 | $buffer -> remove_all_tags($bounds->()); 121 | 122 | SKIP: { 123 | skip 'clipboard stuff; missing annotations', 0 124 | unless Gtk3::CHECK_VERSION (3, 2, 0); 125 | 126 | my $clipboard = Gtk3::Clipboard::get(Gtk3::Gdk::Atom::intern('clipboard', Glib::FALSE)); 127 | 128 | $buffer -> paste_clipboard($clipboard, $buffer -> get_end_iter(), TRUE); 129 | $buffer -> paste_clipboard($clipboard, undef, TRUE); 130 | $buffer -> copy_clipboard($clipboard); 131 | $buffer -> cut_clipboard($clipboard, TRUE); 132 | 133 | $buffer -> add_selection_clipboard($clipboard); 134 | $buffer -> remove_selection_clipboard($clipboard); 135 | } 136 | 137 | $buffer -> begin_user_action(); 138 | $buffer -> end_user_action(); 139 | 140 | { 141 | $buffer -> backspace($end->(), TRUE, TRUE); 142 | } 143 | 144 | { 145 | my $bool = $buffer -> get_has_selection(); 146 | ok (1); 147 | 148 | my $targetlist = $buffer -> get_copy_target_list(); 149 | isa_ok($targetlist, 'Gtk3::TargetList'); 150 | $targetlist = $buffer -> get_paste_target_list(); 151 | isa_ok($targetlist, 'Gtk3::TargetList'); 152 | 153 | isa_ok($buffer -> get('copy-target-list'), 'Gtk3::TargetList'); 154 | isa_ok($buffer -> get('paste-target-list'), 'Gtk3::TargetList'); 155 | } 156 | 157 | { 158 | my $mark = Gtk3::TextMark -> new('bla', TRUE); 159 | $buffer -> add_mark($mark, $end->()); 160 | } 161 | 162 | { 163 | my $buf = Gtk3::TextBuffer -> new(); 164 | $buf -> set_text('v年x最y'); 165 | my ($s,$e) = $buf -> get_bounds(); 166 | ok($s -> forward_find_char(sub{shift eq '年'})); 167 | is($s -> get_char, '年'); 168 | ok(not $e -> backward_find_char(sub{shift eq '%'}, undef, $s)); 169 | is($e -> get_char, '年'); 170 | } 171 | 172 | SKIP: { 173 | skip 'insert_markup', 1 174 | unless Gtk3::CHECK_VERSION (3, 16, 0); 175 | 176 | my $table = Gtk3::TextTagTable -> new(); 177 | my $buffer = Gtk3::TextBuffer -> new($table); 178 | my $markup = "Lore ipsem dolor‽\n"; 179 | $buffer -> insert_markup($buffer -> get_start_iter(), $markup); 180 | cmp_ok ($table -> get_size(), '>', 0); 181 | } 182 | 183 | -------------------------------------------------------------------------------- /t/zz-GtkBuilder.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copied from Gtk2/t/GtkBuilder.t 4 | 5 | BEGIN { require './t/inc/setup.pl' } 6 | 7 | use strict; 8 | use warnings; 9 | 10 | plan tests => 45; 11 | 12 | my $builder; 13 | my $ui = < 15 | 16 | 0 17 | 5 18 | 1 19 | 5 20 | 21 | 22 | True 23 | adjustment1 24 | 25 | 26 | 27 | 28 | EOD 29 | 30 | # --------------------------------------------------------------------------- # 31 | 32 | my $ui_file = 'tmp.ui'; 33 | 34 | open my $fh, '>', $ui_file or plan skip_all => 'unable to create ui file'; 35 | print $fh $ui; 36 | close $fh; 37 | 38 | $builder = Gtk3::Builder->new; 39 | isa_ok ($builder, 'Gtk3::Builder'); 40 | 41 | eval { 42 | $builder->add_from_file ('bla.ui'); 43 | }; 44 | like ($@, qr/bla\.ui/); 45 | 46 | eval { 47 | ok ($builder->add_from_file ($ui_file) > 0); 48 | }; 49 | is ($@, ''); 50 | isa_ok ($builder->get_object ('adjustment1'), 'Gtk3::Adjustment'); 51 | 52 | $builder->set_translation_domain (undef); 53 | is ($builder->get_translation_domain, undef); 54 | $builder->set_translation_domain ('de'); 55 | is ($builder->get_translation_domain, 'de'); 56 | 57 | { 58 | my $builder = Gtk3::Builder->new; 59 | eval { 60 | ok ($builder->add_objects_from_file ($ui_file, qw/adjustment1 spinbutton1/)); 61 | }; 62 | is ($@, ''); 63 | ok (defined $builder->get_object ('adjustment1') && 64 | defined $builder->get_object ('spinbutton1')); 65 | 66 | eval { 67 | $builder->add_objects_from_file ('bla.ui', qw/adjustment1 spinbutton1/); 68 | }; 69 | like ($@, qr/bla\.ui/); 70 | 71 | $builder = Gtk3::Builder->new; 72 | eval { 73 | ok ($builder->add_objects_from_string ($ui, qw/adjustment1 spinbutton1/)); 74 | }; 75 | is ($@, ''); 76 | ok (defined $builder->get_object ('adjustment1') && 77 | defined $builder->get_object ('spinbutton1')); 78 | 79 | eval { 80 | $builder->add_objects_from_string ('', qw/adjustment1 spinbutton1/); 81 | }; 82 | like ($@, qr/bla/); 83 | } 84 | 85 | unlink $ui_file; 86 | 87 | # --------------------------------------------------------------------------- # 88 | 89 | $builder = Gtk3::Builder->new; 90 | 91 | eval { 92 | $builder->add_from_string (''); 93 | }; 94 | like ($@, qr/bla/); 95 | 96 | eval { 97 | ok ($builder->add_from_string ($ui) > 0); 98 | }; 99 | is ($@, ''); 100 | my @objects = sort { ref $a cmp ref $b } $builder->get_objects; 101 | isa_ok ($objects[0], 'Gtk3::Adjustment'); 102 | isa_ok ($objects[1], 'Gtk3::SpinButton'); 103 | 104 | $builder->connect_signals_full(sub { 105 | my ($builder, 106 | $object, 107 | $signal_name, 108 | $handler_name, 109 | $connect_object, 110 | $flags, 111 | $data) = @_; 112 | 113 | if ($signal_name ne 'value-changed') { 114 | return; 115 | } 116 | 117 | isa_ok ($builder, 'Gtk3::Builder'); 118 | isa_ok ($object, 'Gtk3::SpinButton'); 119 | is ($signal_name, 'value-changed'); 120 | is ($handler_name, 'value_changed'); 121 | isa_ok ($connect_object, 'Gtk3::Adjustment'); 122 | ok ($flags == [ qw/after swapped/ ]); 123 | is ($data, 'data'); 124 | }, 'data'); 125 | 126 | # --------------------------------------------------------------------------- # 127 | 128 | package BuilderTestCaller; 129 | 130 | use Test::More; # for is(), isa_ok(), etc. 131 | use Glib qw/:constants/; 132 | 133 | sub value_changed { 134 | my ($spin, $data) = @_; 135 | 136 | isa_ok ($spin, 'Gtk3::SpinButton'); 137 | isa_ok ($data, 'Gtk3::Adjustment'); 138 | } 139 | 140 | sub wrapped { 141 | my ($spin, $data) = @_; 142 | 143 | isa_ok ($spin, 'Gtk3::SpinButton'); 144 | is ($data, '!alb'); 145 | } 146 | 147 | $builder = Gtk3::Builder->new; 148 | $builder->add_from_string ($ui); 149 | $builder->connect_signals ('!alb'); 150 | 151 | my $spin = $builder->get_object ('spinbutton1'); 152 | $spin->set_wrap (TRUE); 153 | $spin->spin ('step-forward', 1); 154 | 155 | # --------------------------------------------------------------------------- # 156 | 157 | package BuilderTest; 158 | 159 | use Test::More; # for is(), isa_ok(), etc. 160 | use Glib qw/:constants/; 161 | 162 | sub value_changed { 163 | my ($spin, $data) = @_; 164 | 165 | isa_ok ($spin, 'Gtk3::SpinButton'); 166 | isa_ok ($data, 'Gtk3::Adjustment'); 167 | } 168 | 169 | sub wrapped { 170 | my ($spin, $data) = @_; 171 | 172 | isa_ok ($spin, 'Gtk3::SpinButton'); 173 | is ($data, 'bla!'); 174 | } 175 | 176 | $builder = Gtk3::Builder->new; 177 | $builder->add_from_string ($ui); 178 | $builder->connect_signals ('bla!', 'BuilderTest'); 179 | 180 | $spin = $builder->get_object ('spinbutton1'); 181 | $spin->set_wrap (TRUE); 182 | $spin->spin ('step-forward', 1); 183 | 184 | # --------------------------------------------------------------------------- # 185 | 186 | package BuilderTestOO; 187 | 188 | use Test::More; # for is(), isa_ok(), etc. 189 | use Glib qw/:constants/; 190 | 191 | sub value_changed { 192 | my ($self, $spin, $data) = @_; 193 | 194 | is ($self->{answer}, 42); 195 | isa_ok ($spin, 'Gtk3::SpinButton'); 196 | isa_ok ($data, 'Gtk3::Adjustment'); 197 | } 198 | 199 | sub wrapped { 200 | my ($self, $spin, $data) = @_; 201 | 202 | is ($self->{answer}, 42); 203 | isa_ok ($spin, 'Gtk3::SpinButton'); 204 | is ($data, 'bla!'); 205 | } 206 | 207 | my $self = bless { answer => 42 }, 'BuilderTestOO'; 208 | 209 | $builder = Gtk3::Builder->new; 210 | $builder->add_from_string ($ui); 211 | $builder->connect_signals ('bla!', $self); 212 | 213 | $spin = $builder->get_object ('spinbutton1'); 214 | $spin->set_wrap (TRUE); 215 | $spin->spin ('step-forward', 1); 216 | 217 | # --------------------------------------------------------------------------- # 218 | 219 | $builder = Gtk3::Builder->new; 220 | $builder->add_from_string ($ui); 221 | $builder->connect_signals ('!alb', 222 | value_changed => \&BuilderTest::value_changed, 223 | wrapped => \&BuilderTestCaller::wrapped 224 | ); 225 | 226 | $spin = $builder->get_object ('spinbutton1'); 227 | $spin->set_wrap (TRUE); 228 | $spin->spin ('step-forward', 1); 229 | 230 | __END__ 231 | 232 | Copyright (C) 2007 by the gtk2-perl team 233 | -------------------------------------------------------------------------------- /t/zz-GtkContainer.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl -w 2 | 3 | # Originally copied from Gtk2/t/GtkDialog.t. 4 | 5 | BEGIN { require './t/inc/setup.pl' } 6 | 7 | use strict; 8 | use warnings; 9 | 10 | plan tests => 42; 11 | 12 | # we'll create some containers (windows and boxes are containers) and 13 | # mess around with some of the methods to make sure they do things. 14 | 15 | my $window = Gtk3::Window->new; 16 | my $vbox = Gtk3::VBox->new; 17 | 18 | is ($window->child_type, 'Gtk3::Widget', 'a window wants a widget'); 19 | 20 | # i think we'd know if $container->add didn't work 21 | $window->add ($vbox); 22 | ok (1, 'added a widget to the window'); 23 | $window->show_all; 24 | 25 | $window->set_focus_child($vbox); 26 | ok (1); 27 | 28 | is ($window->get_focus_child, $vbox); 29 | $window->set_focus_child (undef); 30 | is ($window->get_focus_child, undef); 31 | 32 | my $adjustment = Gtk3::Adjustment->new(0, 0, 100, 5, 10, 20); 33 | 34 | $window->set_focus_vadjustment($adjustment); 35 | is($window->get_focus_vadjustment, $adjustment); 36 | 37 | $window->set_focus_hadjustment($adjustment); 38 | is($window->get_focus_hadjustment, $adjustment); 39 | 40 | $window->resize_children; 41 | ok (1); 42 | 43 | $window->set_border_width(10); 44 | is($window->get_border_width, 10); 45 | 46 | # child_type returns undef when no more children may be added 47 | ok (!defined ($window->child_type), 48 | 'child_type returns undef when the container is full'); 49 | is ($window->get_child, $vbox, 50 | 'the window\'s child is set'); 51 | 52 | is ($vbox->child_type, 'Gtk3::Widget', 'a box wants a widget'); 53 | 54 | $vbox->pack_start (Gtk3::Label->new ("one"), 1, 1, 0); 55 | 56 | is ($vbox->child_type, 'Gtk3::Widget', 'a box is always hungry'); 57 | 58 | my $entry = Gtk3::Entry->new (); 59 | 60 | # let's dump in a few more quickly 61 | $vbox->pack_start (Gtk3::Button->new ("two"), 1, 1, 0); 62 | $vbox->pack_start (Gtk3::ToggleButton->new ("three"), 1, 1, 0); 63 | $vbox->pack_start (Gtk3::CheckButton->new ("four"), 1, 1, 0); 64 | $vbox->pack_start ($entry, 1, 1, 0); 65 | 66 | my @children = $vbox->get_children; 67 | is (scalar (@children), 5, 'we packed five children'); 68 | 69 | my @chain = $vbox->get_focus_chain; 70 | is (scalar (@chain), 0, 'we have not set a focus chain'); 71 | 72 | # set focus chain to focusable children in reverse order 73 | @chain = reverse map { $_->get_can_focus ? $_ : () } @children; 74 | $vbox->set_focus_chain (@chain); 75 | is_deeply ([$vbox->get_focus_chain], \@chain, 'focus chain took'); 76 | 77 | $vbox->unset_focus_chain; 78 | is_deeply ([$vbox->get_focus_chain], []); 79 | 80 | # togglebuttons suck. wipe them out... all of them. 81 | my $nremoved = 0; 82 | $vbox->foreach (sub { 83 | if ('Gtk3::ToggleButton' eq ref $_[0]) { 84 | $vbox->remove ($_[0]); 85 | $nremoved++; 86 | } 87 | }); 88 | is ($nremoved, 1, 'removed one toggle'); 89 | @children = $vbox->get_children; 90 | is (scalar (@children), 4, 'four children remain'); 91 | 92 | my $n_total = 0; 93 | $vbox->forall (sub { 94 | isa_ok ($_[0], Gtk3::Widget::); 95 | $n_total++; 96 | }); 97 | is ($n_total, 4, 'forall walks all children'); 98 | 99 | is ($vbox->get_resize_mode, 'parent'); 100 | $vbox->set_resize_mode ('queue'); 101 | is ($vbox->get_resize_mode, 'queue'); 102 | 103 | $vbox->check_resize; 104 | ok (1); 105 | 106 | $vbox->set_reallocate_redraws(1); 107 | ok (1); 108 | 109 | #------------------------------------------------------------------------------ 110 | # child_get(), child_set() 111 | 112 | is_deeply ([$vbox->child_get ($entry, qw(expand fill pack-type padding position))], 113 | [1, 1, "start", 0, 3]); 114 | 115 | $vbox->child_set ($entry, expand => 0, position => 2); 116 | $vbox->child_set ($entry, fill => 0); 117 | 118 | is_deeply ([$vbox->child_get ($entry, qw(expand fill pack-type padding position))], 119 | [0, 0, "start", 0, 2]); 120 | 121 | my $label = Gtk3::Label->new ("Blub"); 122 | 123 | $vbox->add_with_properties ($label, pack_type => "end", position => 4); 124 | is_deeply ([$vbox->child_get ($label, qw(pack-type position))], 125 | ["end", 4]); 126 | $vbox->remove ($label); 127 | 128 | #------------------------------------------------------------------------------ 129 | # find_child_property() 130 | 131 | is (Gtk3::Container->find_child_property('Gtk3-Perl-test-no-such-property'), 132 | undef, 133 | 'find_child_property() no such child property'); 134 | 135 | is (eval { Gtk3::Container::find_child_property('Not::A::Container::Class', 136 | 'propname'); 1 }, 137 | undef, 138 | 'find_child_property() Not::A::Container::Class croaks'); 139 | 140 | { 141 | my $pspec = Gtk3::Box->find_child_property('expand'); 142 | isa_ok ($pspec, 'Glib::Param::Boolean', 143 | 'find_child_property() "expand" is a boolean'); 144 | 145 | require Scalar::Util; 146 | Scalar::Util::weaken($pspec); 147 | is ($pspec, undef, 'find_child_property() destroyed when weakened'); 148 | } 149 | 150 | { 151 | my $hbox = Gtk3::HBox->new; 152 | my $pspec = $hbox->find_child_property('expand'); 153 | isa_ok ($pspec, 'Glib::Param::Boolean', 154 | 'find_child_property() object method "expand" is a boolean'); 155 | } 156 | 157 | #------------------------------------------------------------------------------ 158 | # list_child_properties() 159 | 160 | # as of Gtk 2.20 the base Gtk3::Container class doesn't have any child 161 | # properties, but don't assume that, so don't ask anything of @pspecs, just 162 | # that list_child_properties() returns 163 | my @pspecs = Gtk3::Container->list_child_properties; 164 | 165 | is (eval { Gtk3::Container::list_child_properties('Not::A::Container::Class'); 166 | 1 }, 167 | undef, 168 | 'list_child_properties() Not::A::Container::Class croaks'); 169 | 170 | { 171 | my @pspecs = Gtk3::Box->list_child_properties; 172 | cmp_ok (scalar(@pspecs), '>=', 2, 173 | 'list_child_properties() at least "expand" and "pack"'); 174 | 175 | require Scalar::Util; 176 | foreach (@pspecs) { 177 | Scalar::Util::weaken($_); 178 | } 179 | my $all_undef = 1; 180 | foreach (@pspecs) { 181 | if ($_) { $all_undef = 0; } 182 | } 183 | is ($all_undef, 1, 'list_child_properties() pspecs destroyed when weakened'); 184 | } 185 | 186 | { 187 | my $hbox = Gtk3::HBox->new; 188 | my @pspecs = $hbox->list_child_properties; 189 | cmp_ok (scalar(@pspecs), '>=', 2, 190 | 'list_child_properties() object method at least "expand" and "pack"'); 191 | isa_ok ($pspecs[0], 'Glib::ParamSpec'); 192 | isa_ok ($pspecs[1], 'Glib::ParamSpec'); 193 | } 194 | 195 | __END__ 196 | 197 | Copyright (C) 2003-2012 by the gtk2-perl team (see the file AUTHORS for the 198 | full list). See LICENSE for more information. 199 | -------------------------------------------------------------------------------- /NEWS: -------------------------------------------------------------------------------- 1 | {{$NEXT}} 2 | 3 | Overview of changes in Gtk3 0.038 [2021-01-19] 4 | ============================================== 5 | 6 | * Correctly handle flags argument in Gtk3::Dialog::new and 7 | Gtk3::MessageDialog::new 8 | * Reimplement varargs Gtk3::MessageDialog methods 9 | 10 | Overview of changes in Gtk3 0.037 [2020-03-16] 11 | ============================================== 12 | 13 | * Adapt the Gtk3::TreeModelSort::new_with_model overload to work 14 | with gtk+ 3.24.14 (Based on a patch by Alberts Muktupāvels.) 15 | https://gitlab.gnome.org/GNOME/perl-gtk3/issues/5 16 | 17 | Overview of changes in Gtk3 0.036 [2019-08-27] 18 | ============================================== 19 | 20 | * Use a temporary, writable directory as $HOME while running tests 21 | (GNOME/perl-gtk3!1) 22 | * Avoid using deprecated gdk_pixbuf_new_from_inline() (GNOME/perl-gtk3!2) 23 | 24 | Overview of changes in Gtk3 0.035 [2019-05-01] 25 | ============================================== 26 | 27 | * Load GdkPixdata introspection data if gdk-pixbuf >= 2.38.0 (RT #127071) 28 | 29 | Overview of changes in Gtk3 0.034 [2018-05-21] 30 | ============================================== 31 | 32 | * Add helper functions Gtk3->get_version_info, Gtk3->GET_VERSION_INFO 33 | (Bugzilla #795778) 34 | * Add override for Gtk3::TargetEntry (Bugzilla #795780) 35 | 36 | Overview of changes in Gtk3 0.033 [2017-11-05] 37 | ============================================== 38 | 39 | * dist.ini: bump version on prereq Glib::Object::Introspection to 0.043 40 | 41 | Overview of changes in Gtk3 0.032 [2017-05-30] 42 | ============================================== 43 | 44 | * Add overrides for Gtk3::Widget::add_events, set_events, get_events 45 | 46 | Overview of changes in Gtk3 0.031 [2017-04-20] 47 | ============================================== 48 | 49 | * Fix a test failure in t/zz-GdkEvent.t 50 | 51 | Overview of changes in Gtk3 0.030 [2016-11-23] 52 | ============================================== 53 | 54 | * Fix a test failure due to old CSS syntax 55 | * When marshalling key-value pairs, preserve their order 56 | * Add an override for Gtk3::Widget::style_get 57 | * Add overrides for the child property methods of Gtk3::Container 58 | * Add overrides for Gtk3::Widget::find_style_property and 59 | list_style_properties 60 | * Add overrides for Gtk3::Container::find_child_property and 61 | list_child_properties 62 | 63 | Overview of changes in Gtk3 0.029 [2016-09-27] 64 | ============================================== 65 | 66 | * Docs: fix typo 67 | 68 | Overview of changes in Gtk3 0.028 [2016-06-30] 69 | ============================================== 70 | 71 | * Gtk3::Dialog, Gtk3::InfoBar: correctly pass user data to 'response' handlers 72 | (Maximilian Lika) 73 | * Test for correct error location reports 74 | * Gtk3::Clipboard::set_text: make length arg optional 75 | * Add an implementation of Gtk3::StyleContext::get 76 | * Mention that Gtk3::Widget::grab_add and grab_remove are methods in Gtk3 77 | 78 | Overview of changes in Gtk3 0.027 [2016-06-05] 79 | ============================================== 80 | 81 | * Gtk3::FileChooserDialog: fix typo in usage warning (RT#114506) 82 | 83 | Overview of changes in Gtk3 0.026 [2015-11-30] 84 | ============================================== 85 | 86 | * Add an override for Pango::Layout::set_markup (make the length argument 87 | optional) 88 | 89 | Overview of changes in Gtk3 0.025 [2015-10-01] 90 | ============================================== 91 | 92 | * Added changes since release v0.023 to the NEWS file and re-release 93 | 94 | Overview of changes in Gtk3 0.024 [2015-10-01] 95 | ============================================== 96 | 97 | * Implement the Gtk3::Stock name corrections in a more compatible way 98 | * Add documentation for all overrides and customizations 99 | * Add Gtk3::Gdk::Pixbuf::CHECK_VERSION 100 | * Gtk3::Gdk::Pixbuf::new_from_inline: do not take a copy_pixels argument 101 | * Implement Gtk3::Gdk::Pixbuf::new_from_data in terms of new_from_inline 102 | * Add an override for Gtk3::TextBuffer::insert_markup 103 | * Fix a test failure when no display is available 104 | 105 | Overview of changes in Gtk3 0.023 [2015-08-10] 106 | ============================================== 107 | 108 | * Fix a test failure in t/zz-GdkEvent.t 109 | * Fix warnings from the dialog tests 110 | * Fix warnings from the Gtk3::Menu tests 111 | * Test that loading Gtk3 multiple times does not affect vfunc overloading 112 | 113 | Overview of changes in Gtk3 0.022 [2015-07-11] 114 | ============================================== 115 | 116 | * Support gdk-pixbuf >= 2.31.3 that reverted some annotation changes that came 117 | with 2.31.2 118 | 119 | Overview of changes in Gtk3 0.021 [2015-01-27] 120 | ============================================== 121 | 122 | * Fix handling of 2button-press and 3button-press events 123 | * Handle double-button-press and triple-button-press event type aliases 124 | * Fix a test failure with Gtk3::Widget::render_icon 125 | * Avoid infinite recursion in Gtk3::disable_setlocale 126 | 127 | Overview of changes in Gtk3 0.020 [2014-12-25] 128 | ============================================== 129 | 130 | * Tighten the GtkRadio* test skip conditions 131 | * Use Glib::Object::Introspection->CHECK_VERSION in the tests 132 | * When running tests, display the gtk+ version 133 | * Fix test failures on unthreaded perls on FreeBSD 134 | 135 | Overview of changes in Gtk3 0.019 [2014-11-25] 136 | ============================================== 137 | 138 | * Fix test failures with gdk-pixbuf >= 2.31.2 139 | * Fix test failures with gtk+ 3.0 140 | 141 | Overview of changes in Gtk3 0.018 [2014-09-30] 142 | ============================================== 143 | 144 | * dist.ini: added x_IRC metadata tag 145 | * Attempt to reduce false negatives from CPAN testers 146 | * overrides.t: output current object being tested using note() 147 | 148 | Overview of changes in Gtk3 0.017 [2014-07-02] 149 | ============================================== 150 | 151 | * Fix compatibility with perl 5.20 and non-dot locales. 152 | * Fix a test failure due to changes in gtk+ (GtkRecentChooser) 153 | 154 | Overview of changes in Gtk3 0.016 [2014-02-19] 155 | ============================================== 156 | 157 | * README: added more project contact info/addresses/links 158 | * README: Added more info on how to report bugs, submit patches 159 | ∗ dist.ini: added Twitter URL to MetaResources block 160 | 161 | Overview of changes in Gtk3 0.015 [2013-12-08] 162 | ============================================== 163 | 164 | * Add overrides for Gtk3::RadioAction, Gtk3::RadioButton, Gtk3::RadioMenuItem 165 | and Gtk3::RadioToolButton. 166 | * Add an override for Gtk3::SizeGroup::get_widgets. 167 | * Add an override for Gtk3::Widget::render_icon. 168 | * Add an override for Pango::Layout::set_text. 169 | * Require Test::Simple >= 0.96. 170 | 171 | Overview of changes in Gtk3 0.014 [2013-10-18] 172 | ============================================== 173 | 174 | * dist.ini: document 'is_trial', sets 'testing' in metadata 175 | * dist.ini: Add MetaJSON, set MetaYAML version = 2 176 | * dist.ini: Add [MetaResources] block with correct URLs; fixes RT#89118 177 | 178 | Overview of changes in Gtk3 0.013 [2013-09-30] 179 | ============================================== 180 | 181 | * Add forgotten release notes. 182 | * Reenable UploadToCPAN Dist::Zilla plugin 183 | 184 | Overview of changes in Gtk3 0.012 [2013-09-30] 185 | ============================================== 186 | 187 | * Add overrides for Gtk3::Image. 188 | ∗ Fix partial misquoting in croak usage 189 | * Do not use 'defined' on an array (Spotted by Thierry Vignaud) 190 | * Add overrides for Gtk3::Image (Based on a patch by Dave M.) 191 | * Add two more tests for Gtk3::TextBuffer (Zach Morgan) 192 | 193 | Overview of changes in Gtk3 0.011 [2013-09-01] 194 | ============================================== 195 | 196 | * Add forgotten release notes. 197 | 198 | Overview of changes in Gtk3 0.010 [2013-09-01] 199 | ============================================== 200 | 201 | * Gtk3::HBox/Gtk3::VBox: use correct defaults in constructors. 202 | * Gtk3::TextBuffer::create_tag: handle all property pairs. 203 | * Fix a few test failures for older gtk+. 204 | 205 | Overview of changes in Gtk3 0.009 [2013-02-14] 206 | ============================================== 207 | 208 | * Add overrides for Gtk3::Container. 209 | * Add overrides for Gtk3::Dialog and Gtk3::InfoBar, including the conversion of 210 | predefined response IDs to nick names. 211 | * Add overrides for Gtk3::Editable. 212 | * Add overrides for Gtk3::FileChooserDialog. 213 | * Add overrides for Gtk3::RecentChooserDialog. 214 | * Add overrides for Gtk3::TextBuffer. 215 | * Add overrides for Gtk3::ListStore's and Gtk3::TreeStore's 216 | insert_with_values(). 217 | * Add more overrides for Gtk3::TreeView and friends. 218 | * Add overrides for various button constructors. 219 | * Add an override for Gtk3::main_level. 220 | * Add Gtk3::EVENT_PROPAGATE and Gtk3::EVENT_STOP. 221 | * In Gtk3::TreeModel::get, if no columns are specified, use all columns. 222 | * Test that no double-frees occur for custom Gtk3::Widget subclasses. 223 | * Add overrides for Gtk3::Gdk::Atom. 224 | * Add overrides for Gtk3::Gdk::RGBA. 225 | * Make Gtk3::Gdk::Pixbuf::save, save_to_buffer and save_to_callback usable. 226 | * Fix test failures on older versions of gtk+. 227 | 228 | Overview of changes in Gtk3 0.008 [2012-08-26] 229 | ============================================== 230 | 231 | * Add overrides for Gtk3::Gdk::Event. 232 | * Add overrides for some Gtk3::RadioMenuItem constructors. 233 | * Add overrides for Gtk3::CssProvider. 234 | * Add overrides for Gtk3::UIManager. 235 | * Always convert GdkRectangle objects to and from Cairo::RectangleInt. 236 | 237 | Overview of changes in Gtk3 0.007 [2012-07-05] 238 | ============================================== 239 | 240 | * Add overrides for Gtk3::ActionGroup. 241 | * Add an override for Gtk3::show_about_dialog. 242 | * Fix some test failures due to older dependencies. 243 | 244 | Overview of changes in Gtk3 0.006 [2012-06-04] 245 | ============================================== 246 | 247 | * Add overrides for Gtk3::MenuItem, CheckMenuItem and ImageMenuItem. 248 | * Require Glib 1.260 and Glib::Object::Introspection 0.009 for various 249 | improvements. 250 | 251 | Overview of changes in Gtk3 0.005 [2012-04-22] 252 | ============================================== 253 | 254 | * Require Cairo::GObject and load it automatically. 255 | * Add overrides for Gtk3::Builder and implement its connect_signals. 256 | * Add overrides for Gtk3::Menu::popup and popup_for_device. 257 | * Add some documentation about porting from Gtk2 to Gtk3. 258 | 259 | Overview of changes in Gtk3 0.004 [2012-03-18] 260 | ============================================== 261 | 262 | * Provide GdkPixbuf bindings under Gtk3::Gdk::Pixbuf. 263 | * Make Gtk3::[HV]Box::new provide default arg values. 264 | * Make Gtk3::Gdk::Window::new construct the mask automatically if none is 265 | given. 266 | * Clarify licensing terms. 267 | 268 | Overview of changes in Gtk3 0.003 [2012-01-14] 269 | ============================================== 270 | 271 | * API change: wrap gtk_stock_* as Gtk3::Stock::*. Also, make 272 | Gtk3::Stock::list_ids return a list and make Gtk3::Stock::lookup skip 273 | the sentinel boolean. 274 | * Correctly handle internal errors on perl < 5.14. This fixes a test 275 | failure. 276 | 277 | Overview of changes in Gtk3 0.002 [2011-12-09] 278 | ============================================== 279 | 280 | * Add more overrides for the tree objects. 281 | * Fix a test failure. (RT #72773) 282 | 283 | Overview of changes in Gtk3 0.001 [2011-10-14] 284 | ============================================== 285 | 286 | * Initial release. 287 | -------------------------------------------------------------------------------- /t/zz-GdkEvent.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Originally copied from Gtk2/t/GdkEvent.t. 4 | 5 | BEGIN { require './t/inc/setup.pl' } 6 | 7 | use strict; 8 | use warnings; 9 | 10 | plan tests => 146; 11 | 12 | sub fields_ok { 13 | my ($event, %fields_values) = @_; 14 | foreach my $field (keys %fields_values) { 15 | field_ok ($event, $field, $fields_values{$field}); 16 | } 17 | } 18 | 19 | sub field_ok { 20 | my ($event, $field, $value) = @_; 21 | $event->$field ($value); 22 | is ($event->$field, $value); 23 | } 24 | 25 | # Any ######################################################################### 26 | 27 | isa_ok (my $event = Gtk3::Gdk::Event->new ('enter-notify'), 28 | 'Gtk3::Gdk::Event', 'Gtk3::Gdk::Event->new any'); 29 | 30 | isa_ok ($event->copy, 'Gtk3::Gdk::Event'); 31 | 32 | is ($event->type, 'enter-notify'); 33 | 34 | my $window = Gtk3::Gdk::Window->new (undef, { 35 | width => 20, 36 | height => 20, 37 | window_type => 'toplevel' 38 | }); 39 | field_ok ($event, window => $window); 40 | field_ok ($event, window => undef); 41 | field_ok ($event, send_event => 23); 42 | 43 | my $screen = Gtk3::Gdk::Screen::get_default; 44 | $event->set_screen ($screen); 45 | is ($event->get_screen, $screen, '$event->get_screen'); 46 | 47 | my $device = Gtk3::Gdk::Display::get_default->list_devices->[0]; # FIXME? 48 | $event->set_device ($device); 49 | is ($event->get_device, $device, '$event->get_device'); 50 | 51 | $event->set_source_device ($device); 52 | is ($event->get_source_device, $device, '$event->get_source_device'); 53 | 54 | # Expose ####################################################################### 55 | 56 | isa_ok ($event = Gtk3::Gdk::Event->new ('expose'), 57 | 'Gtk3::Gdk::EventExpose', 'Gtk3::Gdk::Event->new expose'); 58 | 59 | field_ok ($event, count => 10); 60 | 61 | my $rect = {x => 0, y => 0, width => 100, height => 100}; # FIXME: [0, 0, 100, 100] 62 | $event->area ($rect); 63 | is_deeply ($event->area, $rect, '$expose_event->area'); 64 | 65 | my $region = Cairo::Region->create ($rect); 66 | $event->region ($region); 67 | isa_ok ($event->region, 'Cairo::Region', '$expose_event->region'); 68 | is_deeply ($event->region->get_rectangle (0), $rect); 69 | $event->region (undef); 70 | is ($event->region, undef, '$expose_event->region undef'); 71 | 72 | # Visibility ################################################################### 73 | 74 | isa_ok ($event = Gtk3::Gdk::Event->new ('visibility-notify'), 75 | 'Gtk3::Gdk::EventVisibility', 'Gtk3::Gdk::Event->new visibility'); 76 | 77 | field_ok ($event, state => 'partial'); 78 | 79 | # Motion ####################################################################### 80 | 81 | isa_ok ($event = Gtk3::Gdk::Event->new ('motion-notify'), 82 | 'Gtk3::Gdk::EventMotion', 'Gtk3::Gdk::Event->new motion'); 83 | 84 | fields_ok ($event, time => 42, 85 | x => 13, 86 | y => 14, 87 | x_root => 15, 88 | y_root => 16, 89 | state => [qw/shift-mask control-mask/], 90 | is_hint => 2); 91 | 92 | # FIXME: $event->axes not accessible currently 93 | 94 | field_ok ($event, device => $device); 95 | field_ok ($event, device => undef); 96 | 97 | is ($event->get_time, 42, '$event->get_time'); 98 | # FIXME: special case for get_time() 99 | # is (Gtk3::Gdk::Event::get_time (undef), 0, 100 | # "get_time with no event gets GDK_CURRENT_TIME, which is 0"); 101 | 102 | is ($event->get_state, [qw/shift-mask control-mask/], '$event->get_state'); 103 | 104 | is_deeply ([$event->get_coords], [13, 14], '$event->get_coords'); 105 | 106 | is_deeply ([$event->get_root_coords], [15, 16], '$event->get_root_coords'); 107 | 108 | is ($event->get_axis ("x"), 13); 109 | 110 | $event = Gtk3::Gdk::Event->new ('motion-notify'); 111 | $event->device ($device); 112 | $event->window ($window); 113 | 114 | SKIP: { 115 | skip 'request_motions; missing annotations', 0 116 | unless Gtk3::CHECK_VERSION(3, 2, 0); 117 | $event->request_motions; 118 | } 119 | 120 | # Button ####################################################################### 121 | 122 | foreach (qw/3button-press 123 | 2button-press 124 | button-press/) 125 | { 126 | isa_ok ($event = Gtk3::Gdk::Event->new ($_), 127 | 'Gtk3::Gdk::EventButton', "Gtk3::Gdk::Event->new $_"); 128 | } 129 | 130 | SKIP: { 131 | skip 'aliases', 2 132 | unless Gtk3::CHECK_VERSION (3, 6, 0); 133 | foreach (qw/triple-button-press 134 | double-button-press/) 135 | { 136 | isa_ok ($event = Gtk3::Gdk::Event->new ($_), 137 | 'Gtk3::Gdk::EventButton', "Gtk3::Gdk::Event->new $_"); 138 | } 139 | } 140 | 141 | $event = Gtk3::Gdk::Event->new ('button-press'); 142 | fields_ok ($event, time => 42, 143 | x => 13, 144 | y => 14, 145 | x_root => 15, 146 | y_root => 16, 147 | state => [qw/shift-mask control-mask/], 148 | button => 2); 149 | 150 | # FIXME: $event->axes not accessible currently 151 | 152 | field_ok ($event, device => $device); 153 | field_ok ($event, device => undef); 154 | 155 | SKIP: { 156 | skip 'get_button&get_click_count; new in 3.2', 2 157 | unless Gtk3::CHECK_VERSION(3, 2, 0); 158 | 159 | is ($event->get_button, 2); 160 | is ($event->get_click_count, 1); 161 | } 162 | 163 | # Scroll ####################################################################### 164 | 165 | isa_ok ($event = Gtk3::Gdk::Event->new ('scroll'), 166 | 'Gtk3::Gdk::EventScroll', 'Gtk3::Gdk::Event->new scroll'); 167 | 168 | fields_ok ($event, time => 42, 169 | x => 13, 170 | y => 14, 171 | x_root => 15, 172 | y_root => 16, 173 | state => [qw/shift-mask control-mask/], 174 | direction => 'down'); 175 | 176 | field_ok ($event, device => $device); 177 | field_ok ($event, device => undef); 178 | 179 | SKIP: { 180 | skip 'new 3.4 stuff', 2 181 | unless Gtk3::CHECK_VERSION(3, 4, 0); 182 | 183 | $event->delta_x (17); 184 | $event->delta_y (18); 185 | 186 | is ($event->get_scroll_direction, 'down'); 187 | 188 | # 189 | skip 'direction&get_scroll_deltas; missing annotations', 1 190 | unless Gtk3::CHECK_VERSION(3, 6, 0); 191 | $event->direction ('smooth'); 192 | is_deeply ([$event->get_scroll_deltas], [17, 18]); 193 | } 194 | 195 | # Key ########################################################################## 196 | 197 | isa_ok ($event = Gtk3::Gdk::Event->new ('key-press'), 198 | 'Gtk3::Gdk::EventKey', 'Gtk3::Gdk::Event->new key'); 199 | 200 | fields_ok ($event, time => 42, 201 | state => [qw/shift-mask control-mask/], 202 | keyval => 44, 203 | hardware_keycode => 10, 204 | group => 11, 205 | is_modifier => Glib::TRUE); 206 | 207 | SKIP: { 208 | skip 'keycode&keyval; new in 3.2', 2 209 | unless Gtk3::CHECK_VERSION(3, 2, 0); 210 | 211 | is ($event->get_keycode, 10); 212 | is ($event->get_keyval, 44); 213 | } 214 | 215 | # Crossing ##################################################################### 216 | 217 | isa_ok ($event = Gtk3::Gdk::Event->new ('enter-notify'), 218 | 'Gtk3::Gdk::EventCrossing', 'Gtk3::Gdk::Event->new crossing'); 219 | 220 | fields_ok ($event, time => 42, 221 | x => 13, 222 | y => 14, 223 | x_root => 15, 224 | y_root => 16, 225 | mode => 'grab', 226 | detail => 'nonlinear', 227 | focus => Glib::TRUE, 228 | state => [qw/shift-mask control-mask/]); 229 | 230 | field_ok ($event, subwindow => $window); 231 | field_ok ($event, subwindow => undef); 232 | 233 | # Focus ######################################################################## 234 | 235 | isa_ok ($event = Gtk3::Gdk::Event->new ('focus-change'), 236 | 'Gtk3::Gdk::EventFocus', 'Gtk3::Gdk::Event->new focus'); 237 | 238 | fields_ok ($event, in => 10); 239 | 240 | # Configure #################################################################### 241 | 242 | isa_ok ($event = Gtk3::Gdk::Event->new ('configure'), 243 | 'Gtk3::Gdk::EventConfigure', 'Gtk3::Gdk::Event->new configure'); 244 | 245 | fields_ok ($event, x => 13, 246 | y => 14, 247 | width => 10, 248 | height => 10); 249 | 250 | # Property ##################################################################### 251 | 252 | isa_ok ($event = Gtk3::Gdk::Event->new ('property-notify'), 253 | 'Gtk3::Gdk::EventProperty', 'Gtk3::Gdk::Event->new property'); 254 | 255 | fields_ok ($event, time => 42); 256 | 257 | SKIP: { 258 | skip 'atom stuff; missing annotations', 3 259 | unless Gtk3::CHECK_VERSION(3, 2, 0); 260 | 261 | my $atom = Gtk3::Gdk::Atom::intern ('foo', Glib::FALSE); 262 | $event->atom ($atom); 263 | isa_ok ($event->atom, 'Gtk3::Gdk::Atom', '$property_event->atom'); 264 | is ($event->atom->name, $atom->name, '$property_event->atom'); 265 | $event->atom (undef); 266 | is ($event->atom, undef); 267 | } 268 | 269 | SKIP: { 270 | # 271 | skip 'state accessor; missing annotations', 1 272 | unless Gtk3::CHECK_VERSION (3, 6, 0); 273 | field_ok ($event, state => 'new-value'); 274 | } 275 | 276 | # Proximity #################################################################### 277 | 278 | isa_ok ($event = Gtk3::Gdk::Event->new ('proximity-in'), 279 | 'Gtk3::Gdk::EventProximity', 'Gtk3::Gdk::Event->new proximity'); 280 | 281 | fields_ok ($event, time => 42); 282 | 283 | field_ok ($event, device => $device); 284 | field_ok ($event, device => undef); 285 | 286 | # Setting ###################################################################### 287 | 288 | isa_ok ($event = Gtk3::Gdk::Event->new ('setting'), 289 | 'Gtk3::Gdk::EventSetting', 'Gtk3::Gdk::Event->new setting'); 290 | 291 | fields_ok ($event, action => 'new'); 292 | 293 | # FIXME: $event->name not accessible currently 294 | 295 | # WindowState ################################################################## 296 | 297 | isa_ok ($event = Gtk3::Gdk::Event->new ('window-state'), 298 | 'Gtk3::Gdk::EventWindowState', 'Gtk3::Gdk::Event->new windowstate'); 299 | 300 | fields_ok ($event, changed_mask => [qw/withdrawn above/], 301 | new_window_state => [qw/maximized sticky/]); 302 | 303 | # DND ########################################################################## 304 | 305 | isa_ok ($event = Gtk3::Gdk::Event->new ('drag-enter'), 306 | 'Gtk3::Gdk::EventDND', 'Gtk3::Gdk::Event->new dnd'); 307 | 308 | fields_ok ($event, time => 42, 309 | x_root => 15, 310 | y_root => 16); 311 | 312 | my $drag_context = Gtk3::Gdk::DragContext->new; 313 | field_ok ($event, context => $drag_context); 314 | field_ok ($event, context => undef); 315 | 316 | # Selection #################################################################### 317 | 318 | isa_ok ($event = Gtk3::Gdk::Event->new ('selection-clear'), 319 | 'Gtk3::Gdk::EventSelection', 'Gtk3::Gdk::Event->new selection'); 320 | 321 | fields_ok ($event, time => 42); 322 | 323 | SKIP: { 324 | skip 'atom stuff; missing annotations', 3 325 | unless Gtk3::CHECK_VERSION(3, 2, 0); 326 | 327 | my $atom = Gtk3::Gdk::Atom::intern ('foo', Glib::FALSE); 328 | $event->property ($atom); 329 | is ($event->property->name, $atom->name); 330 | $event->selection ($atom); 331 | is ($event->selection->name, $atom->name); 332 | $event->target ($atom); 333 | is ($event->target->name, $atom->name); 334 | } 335 | 336 | field_ok ($event, requestor => $window); 337 | field_ok ($event, requestor => undef); 338 | 339 | # OwnerChange ################################################################## 340 | 341 | isa_ok ($event = Gtk3::Gdk::Event->new ("owner-change"), 342 | "Gtk3::Gdk::EventOwnerChange"); 343 | 344 | fields_ok ($event, reason => 'destroy', 345 | time => 42, 346 | selection_time => 42); 347 | 348 | field_ok ($event, owner => $window); 349 | field_ok ($event, owner => undef); 350 | 351 | SKIP: { 352 | skip 'atom stuff; missing annotations', 1 353 | unless Gtk3::CHECK_VERSION(3, 2, 0); 354 | 355 | my $atom = Gtk3::Gdk::Atom::intern ('foo', Glib::FALSE); 356 | $event->selection ($atom); 357 | is ($event->selection->name, $atom->name); 358 | } 359 | 360 | # GrabBroken ################################################################## 361 | 362 | isa_ok ($event = Gtk3::Gdk::Event->new ("grab-broken"), 363 | "Gtk3::Gdk::EventGrabBroken"); 364 | 365 | fields_ok ($event, keyboard => Glib::TRUE, 366 | implicit => Glib::FALSE); 367 | 368 | field_ok ($event, grab_window => $window); 369 | field_ok ($event, grab_window => undef); 370 | 371 | # Touch ####################################################################### 372 | 373 | SKIP: { 374 | skip 'touch stuff; new in 3.4', 10 375 | unless Gtk3::CHECK_VERSION(3, 4, 0); 376 | 377 | isa_ok ($event = Gtk3::Gdk::Event->new ("touch-begin"), 378 | "Gtk3::Gdk::EventTouch"); 379 | 380 | fields_ok ($event, time => 42, 381 | x => 13, y => 14, 382 | x_root => 15, y_root => 16, 383 | state => [qw/shift-mask control-mask/], 384 | emulating_pointer => Glib::TRUE); 385 | 386 | field_ok ($event, device => $device); 387 | field_ok ($event, device => undef); 388 | 389 | # FIXME: $event->axes not usable currently 390 | 391 | # FIXME: $event->sequence and get_event_sequence not usable currently 392 | } 393 | 394 | # Misc. ####################################################################### 395 | 396 | SKIP: { 397 | skip 'misc. stuff; missing annotations', 4 398 | unless Gtk3::CHECK_VERSION(3, 2, 0); 399 | 400 | # First, clear all pending events. 401 | Gtk3::main_iteration while Gtk3::events_pending; 402 | 403 | # Then add our own. 404 | my $event = Gtk3::Gdk::Event->new ('button-press'); 405 | $event->put; 406 | ok (Gtk3::Gdk::events_pending); 407 | isa_ok (Gtk3::Gdk::Event::get (), 'Gtk3::Gdk::EventButton'); 408 | 409 | my $i_know_you = 0; 410 | Gtk3::Gdk::Event::handler_set (sub { 411 | return if $i_know_you++; 412 | my ($cb_event, $data) = @_; 413 | isa_ok ($cb_event, 'Gtk3::Gdk::EventButton'); 414 | # pass to gtk+ default handler 415 | Gtk3::main_do_event ($cb_event); 416 | }); 417 | 418 | $event->put; 419 | Gtk3::main_iteration while Gtk3::events_pending; 420 | 421 | # reset 422 | Gtk3::Gdk::Event::handler_set (undef); 423 | 424 | Gtk3::Gdk::set_show_events (Glib::FALSE); 425 | ok (!Gtk3::Gdk::get_show_events); 426 | } 427 | 428 | # Test that our custom event handling does not break callback marshalling due 429 | # to incorrect handling of the perl stack. 430 | { 431 | my $widget = Gtk3::Label->new ('Test'); 432 | $widget->signal_connect (key_press_event => sub { 433 | my ($cb_widget, $cb_event) = @_; 434 | is ($cb_widget, $widget); 435 | isa_ok ($cb_event, 'Gtk3::Gdk::EventKey'); 436 | is ($cb_event->keyval, 44); 437 | Glib::TRUE; 438 | }); 439 | my $event = Gtk3::Gdk::Event->new ('key-press'); 440 | $event->keyval (44); 441 | $widget->signal_emit (key_press_event => $event); 442 | } 443 | 444 | SKIP: { 445 | skip 'new 3.4 stuff', 1 446 | unless Gtk3::CHECK_VERSION (3, 4, 0); 447 | my $event = Gtk3::Gdk::Event->new ('button-press'); 448 | $event->button (Gtk3::Gdk::BUTTON_SECONDARY ()); 449 | $event->window ($window); 450 | ok ($event->triggers_context_menu); 451 | } 452 | 453 | # FIXME: gdk_events_get_angle, gdk_events_get_center, gdk_events_get_distance 454 | # are misbound 455 | # { 456 | # my $event1 = Gtk3::Gdk::Event->new ('button-press'); 457 | # $event1->x (1); $event1->y (0); 458 | # my $event2 = Gtk3::Gdk::Event->new ('button-press'); 459 | # $event2->x (0); $event2->y (1); 460 | # warn join ', ', $event1->_get_angle ($event2); 461 | # warn join ', ', $event1->_get_center ($event2); 462 | # warn join ', ', $event1->_get_distance ($event2); 463 | # } 464 | 465 | __END__ 466 | 467 | Copyright (C) 2003-2012 by the gtk2-perl team (see the file AUTHORS for the 468 | full list). See LICENSE for more information. 469 | -------------------------------------------------------------------------------- /t/zz-GtkTreeModelIface.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | BEGIN { require './t/inc/setup.pl' } 4 | 5 | use strict; 6 | use warnings; 7 | use Glib ':constants'; 8 | 9 | plan tests => 171; 10 | 11 | { 12 | package CustomList; 13 | use strict; 14 | use warnings; 15 | use Glib qw(TRUE FALSE); 16 | use Test::More; 17 | 18 | use Glib::Object::Subclass 19 | Glib::Object::, 20 | interfaces => [ Gtk3::TreeModel::, Gtk3::TreeSortable:: ], 21 | ; 22 | 23 | # one-time init: 24 | my %ordmap; 25 | { 26 | my $i = 0; 27 | %ordmap = map { $_ => $i++ } qw( 28 | First Second Third Fourth Fifth 29 | Sixth Seventh Eighth Ninth Tenth 30 | Eleventh Twelfth Thirteenth Fourteenth Fifteenth 31 | Sixteenth Seventeenth Eighteenth Nineteenth Twentieth 32 | ); 33 | } 34 | 35 | sub INIT_INSTANCE { 36 | my ($list) = @_; 37 | 38 | isa_ok ($list, "CustomList", "INIT_INSTANCE: list"); 39 | 40 | $list->{data} = []; 41 | 42 | foreach my $val (sort { $ordmap{$a} <=> $ordmap{$b} } keys %ordmap) { 43 | my $record = { pos => $ordmap{$val}, value => $val }; 44 | push @{$list->{data}}, $record; 45 | } 46 | 47 | $list->{stamp} = 23; 48 | $list->{sort_column_id} = -1; 49 | $list->{sort_order} = "ascending"; 50 | } 51 | 52 | sub FINALIZE_INSTANCE { 53 | my ($list) = @_; 54 | 55 | isa_ok ($list, "CustomList", "FINALIZE_INSTANCE: list"); 56 | } 57 | 58 | sub GET_FLAGS { 59 | my ($list) = @_; 60 | 61 | isa_ok ($list, "CustomList", "GET_FLAGS: list"); 62 | 63 | return [ qw/list-only iters-persist/ ]; 64 | } 65 | 66 | sub GET_N_COLUMNS { 67 | my ($list) = @_; 68 | 69 | isa_ok ($list, "CustomList", "GET_N_COLUMNS: list"); 70 | 71 | # we don't actually have 23 columns, just 1 -- but the point here is 72 | # to test that the marshaling actually puts through the correct 73 | # number, not just nonzero. 74 | return 23; 75 | } 76 | 77 | sub GET_COLUMN_TYPE { 78 | my ($list, $column) = @_; 79 | 80 | isa_ok ($list, "CustomList", "GET_COLUMN_TYPE: list"); 81 | is ($column, 1, "GET_COLUMN_TYPE: column correct"); 82 | 83 | return Glib::String:: 84 | } 85 | 86 | sub GET_ITER { 87 | my ($list, $path) = @_; 88 | 89 | isa_ok ($list, "CustomList", "GET_ITER: list"); 90 | isa_ok ($path, "Gtk3::TreePath", "GET_ITER: path"); 91 | 92 | my @indices = $path->get_indices; 93 | my $depth = $path->get_depth; 94 | 95 | ok ($depth == 1, "GET_ITER: depth OK"); 96 | 97 | my $n = $indices[0]; 98 | 99 | ok ($n < @{$list->{data}}, "GET_ITER: first path index OK"); 100 | ok ($n > 0, "GET_ITER: first path index OK"); 101 | 102 | my $record = $list->{data}[$n]; 103 | 104 | ok (defined ($record), "GET_ITER: record defined"); 105 | ok ($record->{pos} == $n, "GET_ITER: record has the correct index"); 106 | 107 | return (TRUE, Gtk3::TreeIter->new (stamp => $list->{stamp}, user_data => $record)); 108 | } 109 | 110 | sub GET_PATH { 111 | my ($list, $iter) = @_; 112 | 113 | isa_ok ($list, "CustomList", "GET_PATH: list"); 114 | ok ($iter->stamp == $list->{stamp}, "GET_PATH: stamps agree"); 115 | 116 | my $record = $iter->user_data; 117 | 118 | my $path = Gtk3::TreePath->new; 119 | $path->append_index ($record->{pos}); 120 | 121 | return $path; 122 | } 123 | 124 | sub GET_VALUE { 125 | my ($list, $iter, $column) = @_; 126 | 127 | isa_ok ($list, "CustomList"); 128 | ok ($iter->stamp == $list->{stamp}, "GET_VALUE: stamps agree"); 129 | 130 | is ($column, 1, "GET_VALUE: column correct"); 131 | 132 | my $record = $iter->user_data; 133 | 134 | ok (defined ($record), "GET_VALUE: record defined"); 135 | 136 | ok ($record->{pos} < @{$list->{data}}, "GET_VALUE: record within bounds"); 137 | 138 | return Glib::Object::Introspection::GValueWrapper->new ( 139 | Glib::String::, $record->{value}); 140 | } 141 | 142 | sub ITER_NEXT { 143 | my ($list, $iter) = @_; 144 | 145 | isa_ok ($list, "CustomList", "ITER_NEXT: list"); 146 | ok ($iter->stamp == $list->{stamp}, "ITER_NEXT: stamps agree"); 147 | 148 | my $record = $iter->user_data; 149 | ok (defined ($record), "ITER_NEXT: record defined"); 150 | 151 | # Is this the last record in the list? 152 | return FALSE if $record->{pos} >= @{ $list->{data} }; 153 | 154 | my $nextrecord = $list->{data}[$record->{pos} + 1]; 155 | ok (defined ($nextrecord), "ITER_NEXT: next record defined"); 156 | 157 | ok ($nextrecord->{pos} == ($record->{pos} + 1), "ITER_NEXT: next record's pos OK"); 158 | 159 | $iter->user_data ($nextrecord); 160 | return TRUE; 161 | } 162 | 163 | sub ITER_CHILDREN { 164 | my ($list, $iter) = @_; 165 | 166 | isa_ok ($list, "CustomList", "ITER_CHILDREN: list"); 167 | 168 | # this is a list, nodes have no children 169 | return (FALSE, undef) if $iter; 170 | 171 | # parent == NULL is a special case; we need to return the first top-level row 172 | 173 | # No rows => no first row 174 | return (FALSE, undef) unless @{ $list->{data} }; 175 | 176 | # Set iter to first item in list 177 | return (TRUE, Gtk3::TreeIter->new (stamp => $list->{stamp}, user_data => $list->{data}[0])); 178 | } 179 | 180 | sub ITER_HAS_CHILD { 181 | my ($list, $iter) = @_; 182 | 183 | isa_ok ($list, "CustomList", "ITER_HAS_CHILD: list"); 184 | ok ($iter->stamp == $list->{stamp}, "ITER_HAS_CHILD: stamps agree"); 185 | 186 | return 'asdf'; 187 | } 188 | 189 | sub ITER_N_CHILDREN { 190 | my ($list, $iter) = @_; 191 | 192 | isa_ok ($list, "CustomList", "ITER_N_CHILDREN: list"); 193 | 194 | # special case: if iter == NULL, return number of top-level rows 195 | return scalar @{$list->{data}} if ! $iter; 196 | 197 | return 0; # otherwise, this is easy again for a list 198 | } 199 | 200 | sub ITER_NTH_CHILD { 201 | my ($list, $iter, $n) = @_; 202 | 203 | isa_ok ($list, "CustomList", "ITER_NTH_CHILD: list"); 204 | 205 | # a list has only top-level rows 206 | return (FALSE, undef) if $iter; 207 | 208 | # special case: if parent == NULL, set iter to n-th top-level row 209 | 210 | ok ($n < @{$list->{data}}, "ITER_NTH_CHILD: n bounded correctly"); 211 | 212 | my $record = $list->{data}[$n]; 213 | 214 | ok (defined ($record), "ITER_NTH_CHILD: record defined"); 215 | ok ($record->{pos} == $n, "ITER_NTH_CHILD: record's pos correct"); 216 | 217 | return (TRUE, Gtk3::TreeIter->new (stamp => $list->{stamp}, user_data => $record)); 218 | } 219 | 220 | sub ITER_PARENT { 221 | my ($list, $iter) = @_; 222 | 223 | isa_ok ($list, "CustomList", "ITER_PARENT: list"); 224 | 225 | return (FALSE, undef); 226 | } 227 | 228 | sub REF_NODE { 229 | my ($list, $iter) = @_; 230 | 231 | isa_ok ($list, "CustomList", "REF_NODE: list"); 232 | ok ($iter->stamp == $list->{stamp}, "REF_NODE: stamps agree"); 233 | } 234 | 235 | sub UNREF_NODE { 236 | my ($list, $iter) = @_; 237 | 238 | isa_ok ($list, "CustomList", "UNREF_NODE: list"); 239 | ok ($iter->stamp == $list->{stamp}, "UNREF_NODE: stamps agree"); 240 | } 241 | 242 | sub set { 243 | my $list = shift; 244 | my $iter = shift; 245 | 246 | isa_ok ($list, "CustomList", "set: list"); 247 | isa_ok ($iter, "Gtk3::TreeIter", "set: iter"); 248 | 249 | my ($col, $value) = @_; 250 | ok ($col == 1, "set: col OK"); 251 | 252 | my $record = $iter->user_data; 253 | 254 | $record->{value} = $value; 255 | } 256 | 257 | sub get_iter_from_ordinal { 258 | my $list = shift; 259 | my $ord = shift; 260 | 261 | isa_ok ($list, "CustomList", "get_iter_from_ordinal: list"); 262 | 263 | my $n = $ordmap{$ord}; 264 | 265 | my $record = $list->{data}[$n]; 266 | 267 | ok (defined ($record), "get_iter_from_ordinal: record is valid"); 268 | 269 | my $iter = Gtk3::TreeIter->new (stamp => $list->{stamp}, user_data => $record); 270 | 271 | isa_ok ($iter, "Gtk3::TreeIter", "get_iter_from_ordinal: iter"); 272 | 273 | return $iter; 274 | } 275 | 276 | ############################################################################### 277 | 278 | sub GET_SORT_COLUMN_ID { 279 | my ($list) = @_; 280 | 281 | isa_ok ($list, "CustomList", "GET_SORT_COLUMN_ID: list"); 282 | 283 | my $id = $list->{sort_column_id}; 284 | my $order = $list->{sort_order}; 285 | 286 | return $id >= 0, $id, $order; 287 | } 288 | 289 | sub SET_SORT_COLUMN_ID { 290 | my ($list, $id, $order) = @_; 291 | 292 | isa_ok ($list, "CustomList", "SET_SORT_COLUMN_ID: list"); 293 | is ($id, 3, "SET_SORT_COLUMN_ID: id OK"); 294 | is ($order, "descending", "SET_SORT_COLUMN_ID: order OK"); 295 | 296 | $list->{sort_column_id} = $id; 297 | $list->{sort_order} = $order; 298 | } 299 | 300 | sub SET_SORT_FUNC { 301 | my ($list, $id, $func, $data) = @_; 302 | 303 | isa_ok ($list, "CustomList", "SET_SORT_FUNC: list"); 304 | ok ($id == 2 || $id == 3, "SET_SORT_FUNC: id OK"); 305 | ok (defined $func, "SET_SORT_FUNC: func OK"); 306 | ok (defined $data, "SET_SORT_FUNC: data OK"); 307 | 308 | $list->{sort_funcs}->[$id] = [$func, $data]; 309 | } 310 | 311 | sub SET_DEFAULT_SORT_FUNC { 312 | my ($list, $func, $data) = @_; 313 | 314 | isa_ok ($list, "CustomList", "SET_DEFAULT_SORT_FUNC: list"); 315 | ok (defined $func, "SET_SORT_FUNC: func OK"); 316 | ok (defined $data, "SET_DEFAULT_SORT_FUNC: data OK"); 317 | 318 | $list->{sort_func_default} = [$func, $data]; 319 | } 320 | 321 | sub HAS_DEFAULT_SORT_FUNC { 322 | my ($list) = @_; 323 | 324 | isa_ok ($list, "CustomList", "HAS_DEFAULT_SORT_FUNC: list"); 325 | 326 | return defined $list->{sort_func_default}; 327 | } 328 | 329 | sub sort { 330 | my ($list, $id) = @_; 331 | my $a = $list->get_iter_from_string (1); 332 | my $b = $list->get_iter_from_string (2); 333 | 334 | if (exists $list->{sort_funcs}->[$id]) { 335 | my $func = $list->{sort_funcs}->[$id]->[0]; 336 | my $data = $list->{sort_funcs}->[$id]->[1]; 337 | 338 | is ($func->($list, $a, $b, $data), -1); 339 | } else { 340 | my $func = $list->{sort_func_default}->[0]; 341 | my $data = $list->{sort_func_default}->[1]; 342 | 343 | is ($func->($list, $a, $b, $data), 1); 344 | } 345 | } 346 | } 347 | 348 | { 349 | my $model = CustomList->new; 350 | 351 | ok ($model->get_flags eq [qw/iters-persist list-only/]); 352 | is ($model->get_n_columns, 23, "get_n_columns reports the number correctly"); 353 | is ($model->get_column_type (1), Glib::String::); 354 | 355 | my $path = Gtk3::TreePath->new ("5"); 356 | my $iter; 357 | 358 | isa_ok ($iter = $model->get_iter ($path), "Gtk3::TreeIter"); 359 | isa_ok ($path = $model->get_path ($iter), "Gtk3::TreePath"); 360 | is_deeply ([$path->get_indices], [5]); 361 | 362 | is ($model->get_value ($iter, 1), "Sixth"); 363 | is ($model->get ($iter, 1), "Sixth"); 364 | 365 | $model->iter_next ($iter); 366 | isa_ok ($path = $model->get_path ($iter), "Gtk3::TreePath"); 367 | is_deeply ([$path->get_indices], [6]); 368 | 369 | isa_ok ($iter = $model->iter_children(undef), "Gtk3::TreeIter"); 370 | isa_ok ($path = $model->get_path ($iter), "Gtk3::TreePath"); 371 | is_deeply ([$path->get_indices], [0]); 372 | 373 | is ($model->iter_has_child ($iter), TRUE); 374 | is ($model->iter_n_children ($iter), 0); 375 | 376 | isa_ok ($iter = $model->iter_nth_child (undef, 7), "Gtk3::TreeIter"); 377 | isa_ok ($path = $model->get_path ($iter), "Gtk3::TreePath"); 378 | is_deeply ([$path->get_indices], [7]); 379 | 380 | ok (not defined ($model->iter_parent ($iter))); 381 | 382 | isa_ok ($iter = $model->get_iter_from_ordinal ('Twelfth'), "Gtk3::TreeIter"); 383 | isa_ok ($path = $model->get_path ($iter), "Gtk3::TreePath"); 384 | is_deeply ([$path->get_indices], [11]); 385 | 386 | $model->set($iter, 1, '12th'); 387 | is ($model->get($iter, 1), '12th'); 388 | 389 | $model->ref_node ($iter); 390 | $model->unref_node ($iter); 391 | 392 | SKIP: { 393 | skip 'rows_reordered is not usable currently', 8; 394 | my $signal_finished = 0; 395 | my $len = @{$model->{data}}; 396 | my @array = (0 .. $len-1); 397 | my $id = $model->signal_connect (rows_reordered => sub { 398 | my ($s_model, $path, $iter, $aref) = @_; 399 | is ($s_model, $model); 400 | isa_ok ($path, "Gtk3::TreePath"); 401 | my @indices = $path->get_indices; 402 | is_deeply (\@indices, []); 403 | is ($iter, undef); 404 | is_deeply ($aref, \@array); 405 | $signal_finished = 1; 406 | }); 407 | $model->rows_reordered (Gtk3::TreePath->new, undef, @array); 408 | ok ($signal_finished, 'rows-reordered signal ran'); 409 | $model->signal_handler_disconnect ($id); 410 | } 411 | 412 | my $sorter_two = sub { 413 | my ($list, $a, $b, $data) = @_; 414 | 415 | isa_ok ($list, "CustomList"); 416 | isa_ok ($a, "Gtk3::TreeIter"); 417 | isa_ok ($b, "Gtk3::TreeIter"); 418 | is ($data, "tada"); 419 | 420 | return -1; 421 | }; 422 | 423 | my $sorter_three = sub { 424 | my ($list, $a, $b, $data) = @_; 425 | 426 | isa_ok ($list, "CustomList"); 427 | isa_ok ($a, "Gtk3::TreeIter"); 428 | isa_ok ($b, "Gtk3::TreeIter"); 429 | is ($data, "data"); 430 | 431 | return -1; 432 | }; 433 | 434 | my $default_sorter = sub { 435 | my ($list, $a, $b, $data) = @_; 436 | 437 | isa_ok ($list, "CustomList"); 438 | isa_ok ($a, "Gtk3::TreeIter"); 439 | isa_ok ($b, "Gtk3::TreeIter"); 440 | is ($data, "atad"); 441 | 442 | return 1; 443 | }; 444 | 445 | $model->set_sort_column_id (3, "descending"); 446 | is_deeply ([$model->get_sort_column_id], [TRUE, 3, "descending"]); 447 | 448 | $model->set_sort_func (2, $sorter_two, "tada"); 449 | $model->set_sort_func (3, $sorter_three, "data"); 450 | $model->set_default_sort_func ($default_sorter, "atad"); 451 | ok ($model->has_default_sort_func); 452 | 453 | $model->sort(2); 454 | $model->sort(3); 455 | $model->sort(23); 456 | 457 | # This should result in a call to FINALIZE_INSTANCE 458 | $model = undef; 459 | } 460 | 461 | ############################################################################### 462 | 463 | { 464 | package StackTestModel; 465 | use strict; 466 | use warnings; 467 | use Glib qw/TRUE FALSE/; 468 | 469 | use Glib::Object::Subclass 470 | Glib::Object::, 471 | interfaces => [ Gtk3::TreeModel::, Gtk3::TreeSortable:: ]; 472 | 473 | our @ROW = (100,200,300,400,500,600,700,800,900,1000); 474 | 475 | sub grow_the_stack { 1 .. 500; }; 476 | 477 | sub GET_N_COLUMNS { 478 | my @list = grow_the_stack(); 479 | return scalar @ROW; 480 | } 481 | 482 | sub GET_COLUMN_TYPE { return 'Glib::String'; } 483 | 484 | sub GET_ITER { return (TRUE, Gtk3::TreeIter->new (stamp => 123)); } 485 | 486 | sub GET_VALUE { 487 | my ($self, $iter, $col) = @_; 488 | my @list = grow_the_stack(); 489 | return Glib::Object::Introspection::GValueWrapper->new ( 490 | 'Glib::String', $ROW[$col]); 491 | } 492 | 493 | sub GET_SORT_COLUMN_ID { 494 | my @list = grow_the_stack(); 495 | return TRUE, 3, 'ascending'; 496 | } 497 | } 498 | 499 | { 500 | my $model = StackTestModel->new; 501 | is_deeply ([ $model->get ($model->get_iter_first) ], 502 | [ @StackTestModel::ROW ], 503 | '$model->get ($iter) does not result in stack corruption'); 504 | 505 | is_deeply ([ $model->get ($model->get_iter_first, reverse 0 .. 9) ], 506 | [ reverse @StackTestModel::ROW ], 507 | '$model->get ($iter, @columns) does not result in stack corruption'); 508 | 509 | is_deeply ([ $model->get_sort_column_id ], 510 | [ TRUE, 3, 'ascending' ], 511 | '$model->get_sort_column_id does not result in stack corruption'); 512 | } 513 | -------------------------------------------------------------------------------- /t/overrides.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | BEGIN { require './t/inc/setup.pl' }; 4 | 5 | use strict; 6 | use warnings; 7 | use utf8; 8 | use Encode; 9 | 10 | plan tests => 233; 11 | 12 | note('Gtk3::CHECK_VERSION and check_version'); 13 | { 14 | my ($x, $y, $z) = (Gtk3::MAJOR_VERSION, Gtk3::MINOR_VERSION, Gtk3::MICRO_VERSION); 15 | ok (Gtk3::CHECK_VERSION ($x, $y, $z)); 16 | ok (Gtk3->CHECK_VERSION ($x, $y, $z)); 17 | ok (not defined Gtk3::check_version ($x, $y, $z)); 18 | ok (not defined Gtk3->check_version ($x, $y, $z)); 19 | 20 | $z++; 21 | ok (!Gtk3::CHECK_VERSION ($x, $y, $z)); 22 | ok (!Gtk3->CHECK_VERSION ($x, $y, $z)); 23 | ok (defined Gtk3::check_version ($x, $y, $z)); 24 | ok (defined Gtk3->check_version ($x, $y, $z)); 25 | } 26 | 27 | note('Gtk3::Window::new and list_toplevels.'); 28 | note( 29 | 'This is at the top to avoid testing against a polluted list of toplevels.'); 30 | { 31 | my $window1 = Gtk3::Window->new ('toplevel'); 32 | my $window2 = Gtk3::Window->new; 33 | is_deeply ([Gtk3::Window::list_toplevels ()], [$window1, $window2]); 34 | is (scalar Gtk3::Window::list_toplevels (), $window2); 35 | } 36 | 37 | note('Gtk3::show_about_dialog'); 38 | { 39 | my %props = (program_name => 'Foo', 40 | version => '42', 41 | authors => [qw/me myself i/], 42 | license_type => 'lgpl-2-1'); 43 | SKIP: { 44 | skip 'dialogs without parent warn as of gtk+ >= 3.16', 0 45 | if Gtk3::CHECK_VERSION (3, 16, 0); 46 | Gtk3::show_about_dialog (undef, %props); 47 | Gtk3->show_about_dialog (undef, %props); 48 | } 49 | Gtk3::show_about_dialog (Gtk3::Window->new, %props); 50 | Gtk3->show_about_dialog (Gtk3::Window->new, %props); 51 | ok (1); 52 | } 53 | 54 | note('Gtk3::[HV]Box'); 55 | { 56 | foreach my $class (qw/HBox VBox/) { 57 | my $box = "Gtk3::$class"->new; 58 | ok (!$box->get_homogeneous); 59 | is ($box->get_spacing, 5); 60 | } 61 | } 62 | 63 | note('Gtk3::Button::new'); 64 | { 65 | my $button = Gtk3::Button->new; 66 | ok (!defined ($button->get_label)); 67 | $button = Gtk3::Button->new ('_Test'); 68 | is ($button->get_label, '_Test'); 69 | } 70 | 71 | note('Gtk3::CellLayout::get_cells'); 72 | { 73 | my $cell = Gtk3::TreeViewColumn->new; 74 | is_deeply([$cell->get_cells], []); 75 | my $one = Gtk3::CellRendererText->new; 76 | my $two = Gtk3::CellRendererText->new; 77 | $cell->pack_start($one, 0); 78 | $cell->pack_start($two, 1); 79 | is_deeply([$cell->get_cells], [$one, $two]); 80 | } 81 | 82 | note('Gtk3::CheckButton::new'); 83 | { 84 | my $button = Gtk3::CheckButton->new; 85 | ok (!defined ($button->get_label)); 86 | $button = Gtk3::CheckButton->new ('_Test'); 87 | is ($button->get_label, '_Test'); 88 | } 89 | 90 | note('Gtk3::Clipboard::set_text'); 91 | { 92 | my $clipboard = Gtk3::Clipboard::get (Gtk3::Gdk::Atom::intern ('PRIMARY', Glib::FALSE)); 93 | $clipboard->set_text ('→←'); 94 | is ($clipboard->wait_for_text, '→←'); 95 | $clipboard->set_text ('→←', 3); # wants length in bytes 96 | is ($clipboard->wait_for_text, '→'); 97 | } 98 | 99 | note('Gtk3::ColorButton::new'); 100 | { 101 | my $button = Gtk3::ColorButton->new; 102 | is ($button->get_color->red, 0); 103 | my $color = Gtk3::Gdk::Color->new (red => 2**16-1, green => 0, blue => 0); 104 | $button = Gtk3::ColorButton->new ($color); 105 | is ($button->get_color->red, $color->red); 106 | } 107 | 108 | SKIP: { 109 | skip 'Gtk3::CssProvider; incorrect annotations', 2 110 | unless Gtk3::CHECK_VERSION (3, 2, 0); 111 | 112 | note('Gtk3::CssProvider'); 113 | my $css = "GtkButton {font: 10px Cantarelll}"; 114 | my $expect = qr/Cantarelll/; 115 | my $p = Gtk3::CssProvider->new; 116 | 117 | $p->load_from_data ($css); 118 | like ($p->to_string, $expect); 119 | 120 | $p->load_from_data ([unpack 'C*', $css]); 121 | like ($p->to_string, $expect); 122 | } 123 | 124 | note('Gtk3::Editable::insert_text'); 125 | { 126 | my $entry = Gtk3::Entry->new; 127 | my $orig_text = 'aeiou'; 128 | my $orig_text_chars = length ($orig_text); 129 | my $orig_text_bytes = length (Encode::encode_utf8 ($orig_text)); 130 | $entry->set_text ($orig_text); 131 | my ($new_text, $pos) = ('0123456789', $orig_text_chars); 132 | my $new_text_chars = length ($new_text); 133 | my $new_text_bytes = length (Encode::encode_utf8 ($new_text)); 134 | is ($entry->insert_text ($new_text, $pos), 135 | $pos + $new_text_chars); 136 | $pos = 0; 137 | is ($entry->insert_text ($new_text, $new_text_bytes, $pos), 138 | $pos + $new_text_chars); 139 | is ($entry->get_text, $new_text . $orig_text . $new_text); 140 | } 141 | 142 | note('Gtk3::Editable::insert_text and length issues'); 143 | { 144 | my $entry = Gtk3::Entry->new; 145 | my ($text, $pos) = ('0123456789€', 0); 146 | is ($entry->insert_text ($text, $pos), 147 | $pos + length ($text)); 148 | is ($entry->get_text, $text); 149 | } 150 | 151 | SKIP: { 152 | skip 'GtkEditable.insert-text signal; need generic signal marshaller', 5 153 | unless check_gi_version (1, 33, 10); 154 | 155 | note('GtkEditable.insert-text signal'); 156 | my $entry = Gtk3::Entry->new; 157 | my $orig_text = 'äöü'; 158 | $entry->set_text ($orig_text); 159 | 160 | my ($my_text, $my_pos) = ('123', 2); 161 | $entry->signal_connect ('insert-text' => sub { 162 | my ($entry, $new_text, $new_text_bytes, $position, $data) = @_; 163 | is ($new_text, $my_text); 164 | is ($new_text_bytes, length (Encode::encode_utf8 ($my_text))); 165 | is ($position, $my_pos); 166 | # Disregard $position and move the text to the end. 167 | return length $entry->get_text; 168 | }); 169 | is ($entry->insert_text ($my_text, $my_pos), 170 | length ($orig_text) + length ($my_text)); 171 | is ($entry->get_text, $orig_text . $my_text); 172 | } 173 | 174 | note('Gtk3::FileChooserDialog'); 175 | SKIP: { 176 | skip 'need a perl built with "-pthread" on freebsd', 3 177 | if on_unthreaded_freebsd (); 178 | 179 | my $parent = Gtk3::Window->new; 180 | my $dialog = Gtk3::FileChooserDialog->new ('some title', $parent, 'save', 181 | 'gtk-cancel' => 'cancel', 182 | 'gtk-ok' => 23); 183 | is ($dialog->get_title, 'some title'); 184 | is ($dialog->get_transient_for, $parent); 185 | is ($dialog->get_action, 'save'); 186 | } 187 | 188 | note('Gtk3::FontButton::new'); 189 | { 190 | my $button = Gtk3::FontButton->new; 191 | # $button->get_font_name can be anything 192 | $button = Gtk3::FontButton->new ('Sans'); 193 | ok (defined $button->get_font_name); 194 | } 195 | 196 | note('Gtk3::LinkButton::new'); 197 | { 198 | my ($host, $label) = ('http://localhost', 'Local'); 199 | my $button = Gtk3::LinkButton->new ($host); 200 | is ($button->get_label, $host); 201 | $button = Gtk3::LinkButton->new ($host, $label); 202 | is ($button->get_label, $label); 203 | } 204 | 205 | SKIP: { 206 | skip 'Gtk3::ListStore; tree model ctors not properly supported', 10 207 | unless check_gi_version(1, 29, 17); 208 | 209 | note('Gtk3::ListStore::new, set and get, insert_with_values'); 210 | my $model = Gtk3::ListStore->new ([qw/Glib::String Glib::Int/]); 211 | my $iter = $model->append; 212 | $model->set ($iter, [0, 1], ['Foo', 23]); 213 | is_deeply ([$model->get ($iter)], ['Foo', 23]); 214 | is_deeply ([$model->get ($iter, 0,1)], ['Foo', 23]); 215 | is (scalar $model->get ($iter, 0,1), 23); 216 | 217 | $iter = $model->append; 218 | $model->set ($iter, 0 => 'Bar', 1 => 42); 219 | is_deeply ([$model->get ($iter)], ['Bar', 42]); 220 | is_deeply ([$model->get ($iter, 0,1)], ['Bar', 42]); 221 | is (scalar $model->get ($iter, 0,1), 42); 222 | 223 | { 224 | local $@; 225 | eval { $model->set ($iter, 0) }; 226 | like ($@, qr/Usage/); 227 | } 228 | 229 | $iter = $model->insert_with_values (-1, [0, 1], ['FooFoo', 2323]); 230 | is_deeply ([$model->get ($iter)], ['FooFoo', 2323]); 231 | $iter = $model->insert_with_values (-1, 0 => 'BarBar', 1 => 4242); 232 | is_deeply ([$model->get ($iter)], ['BarBar', 4242]); 233 | 234 | { 235 | local $@; 236 | eval { $model->insert_with_values (-1, 0); }; 237 | like ($@, qr/Usage/); 238 | } 239 | } 240 | 241 | SKIP: { 242 | skip 'Gtk3::Menu; incorrect annotations', 2 243 | unless Gtk3::CHECK_VERSION (3, 2, 0); 244 | 245 | note('Gtk3::Menu::popup and popup_for_device'); 246 | { 247 | my $menu = Gtk3::Menu->new; 248 | my $position_callback; 249 | if (Gtk3::CHECK_VERSION (3, 16, 0)) { 250 | $position_callback = sub { 251 | my ($menu, $x, $y, $data) = @_; 252 | isa_ok ($menu, "Gtk3::Menu"); 253 | return @$data; 254 | }; 255 | } else { 256 | $position_callback = sub { 257 | my ($menu, $data) = @_; 258 | isa_ok ($menu, "Gtk3::Menu"); 259 | return @$data; 260 | }; 261 | } 262 | $menu->popup (undef, undef, $position_callback, [50, 50], 1, 0); 263 | $menu->popup_for_device (undef, undef, undef, $position_callback, [50, 50, Glib::TRUE], 1, 0); 264 | } 265 | 266 | # Test this separately to ensure that specifying no callback does not lead to 267 | # an invalid invocation of the destroy notify func. 268 | { 269 | my $menu = Gtk3::Menu->new; 270 | $menu->popup (undef, undef, undef, undef, 1, 0); 271 | } 272 | } 273 | 274 | note('Gtk2::MenuItem::new, Gtk2::CheckMenuItem::new, Gtk2::ImageMenuItem::new'); 275 | { 276 | foreach my $class (qw/Gtk3::MenuItem Gtk3::CheckMenuItem Gtk3::ImageMenuItem/) { 277 | my $item; 278 | 279 | $item = $class->new; 280 | isa_ok ($item, $class); 281 | ok (!$item->get_label); # might be '' or undef 282 | 283 | $item = $class->new ('_Test'); 284 | isa_ok ($item, $class); 285 | is ($item->get_label, '_Test'); 286 | 287 | $item = $class->new_with_mnemonic ('_Test'); 288 | isa_ok ($item, $class); 289 | is ($item->get_label, '_Test'); 290 | } 291 | } 292 | 293 | note('Gtk3::SizeGroup'); 294 | { 295 | my $group = Gtk3::SizeGroup->new ("vertical"); 296 | 297 | my @widgets = $group->get_widgets; 298 | ok (!@widgets); 299 | 300 | my ($uno, $dos, $tres, $cuatro) = 301 | (Gtk3::Label->new ("Tinky-Winky"), 302 | Gtk3::Label->new ("Dipsy"), 303 | Gtk3::Label->new ("La La"), 304 | Gtk3::Label->new ("Po")); 305 | 306 | $group->add_widget ($uno); 307 | $group->add_widget ($dos); 308 | $group->add_widget ($tres); 309 | $group->add_widget ($cuatro); 310 | @widgets = $group->get_widgets; 311 | is (scalar @widgets, 4); 312 | } 313 | 314 | note('Gtk3::Stock'); 315 | { 316 | ok (grep { $_ eq 'gtk-ok' } Gtk3::Stock::list_ids ()); 317 | my $item = Gtk3::Stock::lookup ('gtk-ok'); 318 | is ($item->{stock_id}, 'gtk-ok'); 319 | note('Gtk3::Stock::add and add_static do not work yet'); 320 | Gtk3::Stock::set_translate_func ('perl-domain', sub {}, 42); 321 | } 322 | 323 | note('Gtk3::StyleContext::get'); 324 | { 325 | my $l = Gtk3::Label->new ('Test'); 326 | my $c = $l->get_style_context; 327 | my @v = $c->get ('normal', Gtk3::STYLE_PROPERTY_COLOR, Gtk3::STYLE_PROPERTY_FONT); 328 | is (scalar @v, 2, 'two items returned'); 329 | } 330 | 331 | note('Gtk3::TargetEntry'); 332 | { 333 | my $output; 334 | open local *STDERR, '>', \$output; 335 | my $target_entry = Gtk3::TargetEntry->new( 336 | 'Glib::Scalar', 337 | Glib::Object::Introspection->convert_sv_to_flags ( 338 | "Gtk3::TargetFlags", qw/same-widget/), 339 | 0); 340 | is($output, undef, 'convert_sv_to_flags'); 341 | 342 | $target_entry = Gtk3::TargetEntry->new( 343 | 'Glib::Scalar', 344 | ${Gtk3::TargetFlags->new (qw/same-widget/)}, 345 | 0); 346 | is($output, undef, 'Gtk3::TargetFlags->new'); 347 | 348 | $target_entry = Gtk3::TargetEntry->new( 349 | 'Glib::Scalar', 350 | qw/same-widget/, 351 | 0); 352 | is($output, undef, 'override'); 353 | } 354 | 355 | note('Gtk3::ToggleButton::new'); 356 | { 357 | my $button = Gtk3::ToggleButton->new; 358 | ok (!defined ($button->get_label)); 359 | $button = Gtk3::ToggleButton->new ('_Test'); 360 | is ($button->get_label, '_Test'); 361 | } 362 | 363 | SKIP: { 364 | skip 'Gtk3::TreeStore; tree model ctors not properly supported', 10 365 | unless check_gi_version(1, 29, 17); 366 | 367 | note('Gtk3::TreeStore::new, set and get, insert_with_values'); 368 | my $model = Gtk3::TreeStore->new ([qw/Glib::String Glib::Int/]); 369 | my $iter = $model->append (undef); 370 | $model->set ($iter, [0, 1], ['Foo', 23]); 371 | is_deeply ([$model->get ($iter)], ['Foo', 23]); 372 | is_deeply ([$model->get ($iter, 0,1)], ['Foo', 23]); 373 | is (scalar $model->get ($iter, 0,1), 23); 374 | 375 | $iter = $model->append (undef); 376 | $model->set ($iter, 0 => 'Bar', 1 => 42); 377 | is_deeply ([$model->get ($iter)], ['Bar', 42]); 378 | is_deeply ([$model->get ($iter, 0,1)], ['Bar', 42]); 379 | is (scalar $model->get ($iter, 0,1), 42); 380 | 381 | { 382 | local $@; 383 | eval { $model->set ($iter, 0) }; 384 | like ($@, qr/Usage/); 385 | } 386 | 387 | $iter = $model->insert_with_values (undef, -1, [0, 1], ['FooFoo', 2323]); 388 | is_deeply ([$model->get ($iter)], ['FooFoo', 2323]); 389 | $iter = $model->insert_with_values (undef, -1, 0 => 'BarBar', 1 => 4242); 390 | is_deeply ([$model->get ($iter)], ['BarBar', 4242]); 391 | 392 | { 393 | local $@; 394 | eval { $model->insert_with_values (undef, -1, 0); }; 395 | like ($@, qr/Usage/); 396 | } 397 | } 398 | 399 | note('Gtk3::TreePath::new, new_from_string, new_from_indices, get_indices'); 400 | { 401 | my $path = Gtk3::TreePath->new; 402 | isa_ok ($path, 'Gtk3::TreePath'); 403 | $path = Gtk3::TreePath->new ('1:2:3'); 404 | is_deeply ([$path->get_indices], [1, 2, 3]); 405 | $path = Gtk3::TreePath->new_from_string ('1:2:3'); 406 | is_deeply ([$path->get_indices], [1, 2, 3]); 407 | $path = Gtk3::TreePath->new_from_indices (1, 2, 3); 408 | is_deeply ([$path->get_indices], [1, 2, 3]); 409 | } 410 | 411 | SKIP: { 412 | skip 'Gtk3::TreeModel; tree model ctors not properly supported', 6 413 | unless check_gi_version(1, 29, 17); 414 | 415 | note('Gtk3::TreeModel::get_iter, get_iter_first, get_iter_from_string'); 416 | my $model = Gtk3::ListStore->new ('Glib::String'); 417 | my $path = Gtk3::TreePath->new_from_string ('0'); 418 | is ($model->get_iter ($path), undef); 419 | is ($model->get_iter_first, undef); 420 | is ($model->get_iter_from_string ('0'), undef); 421 | my $iter = $model->append; 422 | isa_ok ($model->get_iter ($path), 'Gtk3::TreeIter'); 423 | isa_ok ($model->get_iter_first, 'Gtk3::TreeIter'); 424 | isa_ok ($model->get_iter_from_string ('0'), 'Gtk3::TreeIter'); 425 | } 426 | 427 | SKIP: { 428 | skip 'Gtk3::TreeModel; tree model ctors not properly supported', 6 429 | unless check_gi_version(1, 29, 17); 430 | 431 | note('Gtk3::TreeModel::iter_children, iter_nth_child, iter_parent'); 432 | my $model = Gtk3::TreeStore->new ([qw/Glib::String/]); 433 | my $parent_iter = $model->append (undef); 434 | is ($model->iter_children ($parent_iter), undef); 435 | is ($model->iter_nth_child ($parent_iter, 0), undef); 436 | is ($model->iter_parent ($parent_iter), undef); 437 | my $child_iter = $model->append ($parent_iter); 438 | isa_ok ($model->iter_children ($parent_iter), 'Gtk3::TreeIter'); 439 | isa_ok ($model->iter_nth_child ($parent_iter, 0), 'Gtk3::TreeIter'); 440 | isa_ok ($model->iter_parent ($child_iter), 'Gtk3::TreeIter'); 441 | } 442 | 443 | SKIP: { 444 | skip 'Gtk3::TreeFilter; tree model ctors not properly supported', 3 445 | unless check_gi_version(1, 29, 17); 446 | 447 | note('Gtk3::TreeModelFilter'); 448 | my $child_model = Gtk3::TreeStore->new ([qw/Glib::String/]); 449 | my $child_iter = $child_model->append (undef); 450 | $child_model->set ($child_iter, 0 => 'Bla'); 451 | my $model = Gtk3::TreeModelFilter->new ($child_model); 452 | isa_ok ($model, 'Gtk3::TreeModelFilter'); 453 | my $iter = $model->convert_child_iter_to_iter ($child_iter); 454 | isa_ok ($iter, 'Gtk3::TreeIter'); 455 | is ($model->get ($iter, 0), 'Bla'); 456 | } 457 | 458 | SKIP: { 459 | skip 'Gtk3::TreeModelSort; tree model ctors not properly supported', 3 460 | unless check_gi_version(1, 29, 17); 461 | 462 | note('Gtk3::TreeModelSort'); 463 | my $child_model = Gtk3::TreeStore->new ([qw/Glib::String/]); 464 | my $child_iter = $child_model->append (undef); 465 | $child_model->set ($child_iter, 0 => 'Bla'); 466 | my $model = Gtk3::TreeModelSort->new_with_model ($child_model); 467 | isa_ok ($model, 'Gtk3::TreeModelSort'); 468 | my $iter = $model->convert_child_iter_to_iter ($child_iter); 469 | isa_ok ($iter, 'Gtk3::TreeIter'); 470 | is ($model->get ($iter, 0), 'Bla'); 471 | } 472 | 473 | SKIP: { 474 | skip 'Gtk3::TreeSelection; tree model ctors not properly supported', 3 475 | unless check_gi_version(1, 29, 17); 476 | 477 | note('Gtk3::TreeSelection::get_selected'); 478 | my $model = Gtk3::ListStore->new ('Glib::String'); 479 | my $view = Gtk3::TreeView->new ($model); 480 | my $selection = $view->get_selection; 481 | my $iter = $model->append; 482 | $selection->select_iter ($iter); 483 | my ($sel_model, $sel_iter) = $selection->get_selected; 484 | is ($sel_model, $model); 485 | isa_ok ($sel_iter, 'Gtk3::TreeIter'); 486 | $sel_iter = $selection->get_selected; 487 | isa_ok ($sel_iter, 'Gtk3::TreeIter'); 488 | } 489 | 490 | SKIP: { 491 | skip 'Gtk3::TreeView; tree model ctors not properly supported', 5 492 | unless check_gi_version(1, 29, 17); 493 | 494 | note('Gtk3::TreeView::insert_column_with_attributes, get_dest_row_at_pos,'); 495 | note('get_path_at_pos, get_tooltip_context, get_visible_range'); 496 | my $model = Gtk3::ListStore->new ('Glib::String'); 497 | $model->insert_with_values (-1, 0 => 'Test string'); 498 | 499 | my $view = Gtk3::TreeView->new ($model); 500 | $view->insert_column_with_attributes (-1, 'String', 501 | Gtk3::CellRendererText->new, 502 | text => 0); 503 | my $column = $view->get_column (0); 504 | is ($column->get_title, 'String'); 505 | is_deeply ([$view->get_columns], [$column]); 506 | 507 | my $window = Gtk3::Window->new; 508 | $window->add ($view); 509 | $window->show_all; 510 | 511 | my @bin_pos = (0, 0); 512 | my @widget_pos = $view->convert_bin_window_to_widget_coords (@bin_pos); 513 | my @dest_stuff = $view->get_dest_row_at_pos (@widget_pos); 514 | is (@dest_stuff, 2); 515 | my @pos_stuff = $view->get_path_at_pos (@bin_pos); 516 | is (@pos_stuff, 4); 517 | 518 | my @tooltip_stuff = $view->get_tooltip_context (@widget_pos, Glib::TRUE); 519 | is (@tooltip_stuff, 5); 520 | 521 | # Nondeterministic: 522 | my @vis_paths = $view->get_visible_range; 523 | # is (@vis_paths, 2); # or sometimes 0 524 | } 525 | 526 | SKIP: { 527 | skip 'Gtk3::TreeViewColumn; tree model ctors not properly supported', 2 528 | unless check_gi_version(1, 29, 17); 529 | 530 | note('Gtk3::TreeViewColumn::new_with_attributes, set_attributes'); 531 | note('cell_get_position'); 532 | my $model = Gtk3::ListStore->new ('Glib::String'); 533 | $model->insert_with_values (-1, 0 => 'Test string'); 534 | 535 | my $renderer = Gtk3::CellRendererText->new; 536 | my $column = Gtk3::TreeViewColumn->new_with_attributes ( 537 | 'String', $renderer, text => 0); 538 | is ($column->get_title, 'String'); 539 | $column->set_attributes ($renderer, text => 0); 540 | 541 | my $view = Gtk3::TreeView->new ($model); 542 | $view->insert_column ($column, -1); 543 | 544 | my $window = Gtk3::Window->new; 545 | $window->add ($view); 546 | $window->show_all; 547 | 548 | my @cell_stuff = $column->cell_get_position ($renderer); 549 | is (@cell_stuff, 2); 550 | } 551 | 552 | note('Gtk3::UIManager'); 553 | { 554 | my $ui_manager = Gtk3::UIManager->new; 555 | my $ui_info = <<__EOD__; 556 | 557 | 558 | 559 | 560 | 561 | 562 | 563 | 564 | 565 | 566 | 567 | 568 | __EOD__ 569 | ok ($ui_manager->add_ui_from_string ($ui_info) != 0); 570 | 571 | my $group_one = Gtk3::ActionGroup->new ("Barney"); 572 | my $group_two = Gtk3::ActionGroup->new ("Fred"); 573 | my @entries = ( 574 | [ "HelpMenu", undef, "_Help" ], 575 | [ "About", undef, "_About", "A", "About" ], 576 | [ "License", undef, "_License", "L", "License" ], 577 | ); 578 | $group_one->add_actions (\@entries, undef); 579 | $ui_manager->insert_action_group ($group_one, 0); 580 | $ui_manager->insert_action_group ($group_two, 1); 581 | is_deeply ([$ui_manager->get_action_groups], [$group_one, $group_two]); 582 | 583 | $ui_manager->ensure_update; 584 | my @menubars = $ui_manager->get_toplevels ("menubar"); 585 | is (@menubars, 2); 586 | isa_ok ($menubars[0], "Gtk3::MenuBar"); 587 | isa_ok ($menubars[1], "Gtk3::MenuBar"); 588 | } 589 | 590 | note('Gtk3::Widget'); 591 | SKIP: { 592 | my $widget = Gtk3::Label->new ("Test"); 593 | my $pixbuf = $widget->render_icon ("gtk-open", "menu", "detail"); 594 | skip "pixbuf test; undef returned", 1 595 | unless defined $pixbuf; 596 | isa_ok ($pixbuf, "Gtk3::Gdk::Pixbuf"); 597 | } 598 | 599 | { 600 | my $widget = Gtk3::Label->new ("Test"); 601 | my @values = $widget->style_get (qw/cursor-aspect-ratio 602 | cursor-color 603 | focus-line-width 604 | focus-padding/); 605 | is (@values, 4); 606 | 607 | { my @pspecs = $widget->list_style_properties; 608 | cmp_ok (scalar(@pspecs), '>', 0); 609 | isa_ok ($pspecs[0], 'Glib::ParamSpec'); 610 | } 611 | { my @pspecs = Gtk3::Label->list_style_properties; 612 | cmp_ok (scalar(@pspecs), '>', 0); 613 | isa_ok ($pspecs[0], 'Glib::ParamSpec'); 614 | } 615 | 616 | is ($widget->find_style_property('no-such-style-property-of-this-name'), 617 | undef, 618 | "find_style_property() no such name, on object"); 619 | is (Gtk3::Label->find_style_property('no-such-style-property-of-this-name'), 620 | undef, 621 | "find_style_property() no such name, on class"); 622 | 623 | isa_ok ($widget->find_style_property('interior-focus'), 'Glib::ParamSpec'); 624 | isa_ok (Gtk3::Label->find_style_property('interior-focus'), 'Glib::ParamSpec'); 625 | } 626 | 627 | { 628 | my $widget = Gtk3::Label->new ("Test"); 629 | 630 | $widget->set_events ([qw/enter-notify-mask leave-notify-mask/]); 631 | ok ($widget->get_events >= [qw/enter-notify-mask leave-notify-mask/], 632 | '$widget->set_events|get_events'); 633 | 634 | $widget->add_events ([qw/button-press-mask/]); 635 | ok ($widget->get_events >= [qw/button-press-mask enter-notify-mask leave-notify-mask/], 636 | '$widget->add_events|get_events'); 637 | 638 | $widget->set_events (0); 639 | ok ($widget->get_events == 0, '$widget->set_events|get_events with numeric 0'); 640 | ok ($widget->get_events == [], '$widget->set_events|get_events with numeric 0'); 641 | 642 | $widget->add_events (24); 643 | ok ($widget->get_events == 24, '$widget->add_events|get_events with numeric 24'); 644 | ok ($widget->get_events == [qw/pointer-motion-hint-mask button-motion-mask/], 645 | '$widget->add_events|get_events with numeric 24'); 646 | } 647 | 648 | SKIP: { 649 | skip 'atom stuff; missing annotations', 2 650 | unless Gtk3::CHECK_VERSION(3, 2, 0); 651 | 652 | note('Gtk3::Gdk::Atom'); 653 | my $atom1 = Gtk3::Gdk::Atom::intern("CLIPBOARD", Glib::FALSE); 654 | my $atom2 = Gtk3::Gdk::Atom::intern("CLIPBOARD", Glib::FALSE); 655 | my $atom3 = Gtk3::Gdk::Atom::intern("PRIMARY", Glib::FALSE); 656 | ok ($atom1 == $atom2); 657 | ok ($atom1 != $atom3); 658 | } 659 | 660 | note('Gtk3::Gdk::RGBA'); 661 | { 662 | my $rgba = Gtk3::Gdk::RGBA->new ({red => 0.0, green => 0.5, blue => 0.5, alpha => 0.5}); 663 | isa_ok ($rgba, 'Gtk3::Gdk::RGBA'); 664 | is ($rgba->red, 0.0); 665 | 666 | $rgba = Gtk3::Gdk::RGBA->new (red => 0.5, green => 0.0, blue => 0.5, alpha => 0.5); 667 | isa_ok ($rgba, 'Gtk3::Gdk::RGBA'); 668 | is ($rgba->green, 0.0); 669 | 670 | $rgba = Gtk3::Gdk::RGBA->new (0.5, 0.5, 0.0, 0.5); 671 | isa_ok ($rgba, 'Gtk3::Gdk::RGBA'); 672 | is ($rgba->blue, 0.0); 673 | 674 | $rgba = Gtk3::Gdk::RGBA::parse ('rgba(0.5, 0.5, 0.5, 0.0)'); 675 | isa_ok ($rgba, 'Gtk3::Gdk::RGBA'); 676 | is ($rgba->alpha, 0.0); 677 | 678 | ok ($rgba->parse ('rgba(0.5, 0.5, 0.5, 1.0)')); 679 | is ($rgba->alpha, 1.0); 680 | } 681 | 682 | SKIP: { 683 | # https://bugzilla.gnome.org/show_bug.cgi?id=670369 684 | skip 'Gtk3::Gdk::Window::new; window attr type annotation missing', 3 685 | unless Gtk3::CHECK_VERSION (3, 6, 0); 686 | 687 | note('Gtk3::Gdk::Window::new'); 688 | my $window = Gtk3::Gdk::Window->new (undef, { 689 | window_type => 'toplevel', 690 | }); 691 | isa_ok ($window, 'Gtk3::Gdk::Window'); 692 | 693 | $window = Gtk3::Gdk::Window->new (undef, { 694 | window_type => 'toplevel', 695 | width => 100, height => 50, 696 | x => 100, y => 50, 697 | }, [qw/x y/]); 698 | isa_ok ($window, 'Gtk3::Gdk::Window'); 699 | 700 | $window = Gtk3::Gdk::Window->new (undef, { 701 | window_type => 'toplevel', 702 | width => 100, height => 50, 703 | x => 100, y => 50, 704 | }); 705 | isa_ok ($window, 'Gtk3::Gdk::Window'); 706 | } 707 | 708 | note('Gtk3::Gdk::Pixbuf::get_formats'); 709 | { 710 | my @formats = Gtk3::Gdk::Pixbuf::get_formats; 711 | isa_ok ($formats[0], 'Gtk3::Gdk::PixbufFormat'); 712 | } 713 | 714 | { 715 | my ($pixbuf_data_width, $pixbuf_data_height) = (4, 5); 716 | my $pixbuf_data_bytes_per_pixel = 3; 717 | my $pixbuf_data_rowstride = $pixbuf_data_bytes_per_pixel*$pixbuf_data_width; 718 | my @pixbuf_data = ( 719 | 255,0,0, 255,0,0, 0,0,0, 0,0,255, 720 | 255,0,0, 0,0,0, 0,0,255, 0,0,255, 721 | 0,0,0, 0,0,255, 0,0,255, 255,0,0, 722 | 0,0,255, 0,0,255, 255,0,0, 255,0,0, 723 | 0,0,255, 255,0,0, 255,0,0, 0,0,0, 724 | ); 725 | my $pixbuf_data_packed = pack 'C*', @pixbuf_data; 726 | my @pixbuf_data_xpm = ( 727 | '4 5 3 1', 728 | ' c black', 729 | '. c red', 730 | '+ c blue', 731 | '.. +', 732 | '. ++', 733 | ' ++.', 734 | '++..', 735 | '+.. '); 736 | my $pixbuf_data_inline = 737 | 'GdkP' # Pixbuf magic (0x47646b50) 738 | . "\0\0\0\124" # length: header (6*4 = 24) + pixel_data (4*5*3 = 60) 739 | . "\1\1\0\1" # pixdata type (0x01010001 = RAW | WIDTH_8 | RGB) 740 | . "\0\0\0\14" # rowstride (12) 741 | . "\0\0\0\4" # width (4) 742 | . "\0\0\0\5" # height (5) 743 | . $pixbuf_data_packed; 744 | sub pixbuf_ok { 745 | my ($pixbuf) = @_; 746 | isa_ok ($pixbuf, 'Gtk3::Gdk::Pixbuf'); 747 | is ($pixbuf->get_colorspace, 'rgb'); 748 | ok (!$pixbuf->get_has_alpha); 749 | is ($pixbuf->get_width, $pixbuf_data_width); 750 | is ($pixbuf->get_height, $pixbuf_data_height); 751 | is ($pixbuf->get_rowstride, $pixbuf_data_rowstride); 752 | is ($pixbuf->get_byte_length, $pixbuf_data_rowstride*$pixbuf_data_height); 753 | is ($pixbuf->get_pixels, $pixbuf_data_packed); 754 | } 755 | 756 | SKIP: { 757 | skip 'Gtk3::Gdk::Pixbuf::new_from_data, new_from_xpm_data, new_from_inline; missing annotations', 48 758 | unless Gtk3::Gdk::Pixbuf::CHECK_VERSION (2, 26, 0); 759 | 760 | note('Gtk3::Gdk::Pixbuf::new_from_data'); 761 | foreach my $data ($pixbuf_data_packed, [unpack 'C*', $pixbuf_data_packed]) { 762 | my $pixbuf = Gtk3::Gdk::Pixbuf->new_from_data ($data, 763 | 'rgb', Glib::FALSE, 8, 764 | $pixbuf_data_width, $pixbuf_data_height, 765 | $pixbuf_data_rowstride); 766 | pixbuf_ok ($pixbuf); 767 | } 768 | 769 | note('Gtk3::Gdk::Pixbuf::new_from_xpm_data'); 770 | foreach my $data (\@pixbuf_data_xpm, [\@pixbuf_data_xpm]) { 771 | my $pixbuf = Gtk3::Gdk::Pixbuf->new_from_xpm_data (@$data); 772 | pixbuf_ok ($pixbuf); 773 | } 774 | 775 | note('Gtk3::Gdk::Pixbuf::new_from_inline'); 776 | foreach my $data ($pixbuf_data_inline, [unpack 'C*', $pixbuf_data_inline]) { 777 | my $pixbuf = Gtk3::Gdk::Pixbuf->new_from_inline ($data); 778 | pixbuf_ok ($pixbuf); 779 | } 780 | } 781 | } 782 | 783 | SKIP: { 784 | skip 'misc. pixbuf stuff; missing annotations', 19 785 | unless Gtk3::Gdk::Pixbuf::CHECK_VERSION (2, 26, 0); 786 | 787 | note('Gtk3::Gdk::Pixbuf::save, save_to_buffer, save_to_callback'); 788 | my ($width, $height) = (10, 5); 789 | my $pixbuf = Gtk3::Gdk::Pixbuf->new ('rgb', Glib::TRUE, 8, $width, $height); 790 | $pixbuf->fill (hex '0xFF000000'); 791 | my $expected_pixels = $pixbuf->get_pixels; 792 | 793 | my $filename = 'testsave.png'; 794 | END { unlink $filename if defined $filename; } 795 | eval { 796 | $pixbuf->save ($filename, 'png', 797 | 'key_arg_without_value_arg'); 798 | }; 799 | like ($@, qr/Usage/); 800 | my $mtime = scalar localtime; 801 | my $desc = 'Something really cool'; 802 | $pixbuf->save ($filename, 'png', 803 | 'tEXt::Thumb::MTime' => $mtime, 804 | 'tEXt::Description' => $desc); 805 | my $new_pixbuf = Gtk3::Gdk::Pixbuf->new_from_file ($filename); 806 | isa_ok ($new_pixbuf, 'Gtk3::Gdk::Pixbuf', 'new_from_file'); 807 | is ($new_pixbuf->get_option ('tEXt::Description'), $desc); 808 | is ($new_pixbuf->get_option ('tEXt::Thumb::MTime'), $mtime); 809 | is ($new_pixbuf->get_width, $width); 810 | is ($new_pixbuf->get_height, $height); 811 | is ($new_pixbuf->get_pixels, $expected_pixels); 812 | 813 | my $buffer = do { 814 | $pixbuf->save_to_buffer ('png', [qw/compression/], [9]); 815 | $pixbuf->save_to_buffer ('png', compression => 9); 816 | $pixbuf->save_to_buffer ('png'); 817 | }; 818 | ok (defined $buffer, 'save_to_buffer'); 819 | my $loader = Gtk3::Gdk::PixbufLoader->new; 820 | $loader->write ($buffer); 821 | $loader->close; 822 | $new_pixbuf = $loader->get_pixbuf; 823 | is ($new_pixbuf->get_width, $width); 824 | is ($new_pixbuf->get_height, $height); 825 | is ($new_pixbuf->get_pixels, $expected_pixels); 826 | 827 | my $callback_buffer = []; 828 | my $invocation_count = 0; 829 | ok ($pixbuf->save_to_callback (sub { 830 | my ($pixels, $length, $data) = @_; 831 | if (0 == $invocation_count++) { 832 | is ($length, scalar @$pixels); 833 | is ($pixels->[0], 137); is ($pixels->[7], 10); # PNG header 834 | is ($data, 'data'); 835 | } 836 | push @$callback_buffer, @$pixels; 837 | return Glib::TRUE, undef; 838 | }, 'data', 'png')); 839 | is_deeply ($callback_buffer, $buffer); 840 | 841 | skip 'Gtk3::Gdk::Pixbuf::save_to_callback; need error domain support', 2 842 | unless check_gi_version (1, 29, 17); 843 | eval { 844 | $pixbuf->save_to_callback (sub { 845 | return Glib::FALSE, Gtk3::Gdk::PixbufError->new ('insufficient-memory', 'buzz'); 846 | }, undef, 'png'); 847 | }; 848 | my $error = $@; 849 | isa_ok ($error, 'Glib::Error'); 850 | is ($error->message, 'buzz'); 851 | } 852 | 853 | note('Pango::Layout'); 854 | { 855 | my $label = Gtk3::Label->new ('Bla'); 856 | my $layout = $label->create_pango_layout ('Bla'); 857 | 858 | $layout->set_text('Bla bla.', 3); 859 | is ($layout->get_text, 'Bla'); 860 | 861 | $layout->set_text('Bla bla.'); 862 | is ($layout->get_text, 'Bla bla.'); 863 | 864 | $layout->set_markup('Bla bla.', 10); 865 | is ($layout->get_text, 'Bla'); 866 | 867 | $layout->set_markup('Bla bla.'); 868 | is ($layout->get_text, 'Bla bla.'); 869 | } 870 | -------------------------------------------------------------------------------- /lib/Gtk3.pm: -------------------------------------------------------------------------------- 1 | package Gtk3; 2 | 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 | use strict; 45 | use warnings; 46 | use Carp qw/croak/; 47 | use Cairo::GObject; 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 | GdkPixdata-2.0| Gtk3::Gdk 64 | Pango-1.0 | Pango 65 | 66 | =cut 67 | 68 | =head2 Import arguments 69 | 70 | When importing C, you can pass C<-init> as in C<< use Gtk3 -init; >> to 71 | have C automatically called. You can also pass a version number to 72 | require a certain version of C. 73 | 74 | =cut 75 | 76 | my $_GTK_BASENAME = 'Gtk'; 77 | my $_GTK_VERSION = '3.0'; 78 | my $_GTK_PACKAGE = 'Gtk3'; 79 | 80 | my $_GDK_BASENAME = 'Gdk'; 81 | my $_GDK_VERSION = '3.0'; 82 | my $_GDK_PACKAGE = 'Gtk3::Gdk'; 83 | 84 | my $_GDK_PIXBUF_BASENAME = 'GdkPixbuf'; 85 | my $_GDK_PIXBUF_VERSION = '2.0'; 86 | my $_GDK_PIXBUF_PACKAGE = 'Gtk3::Gdk'; 87 | 88 | my $_GDK_PIXDATA_BASENAME = 'GdkPixdata'; 89 | my $_GDK_PIXDATA_VERSION = '2.0'; 90 | my $_GDK_PIXDATA_PACKAGE = 'Gtk3::Gdk'; 91 | 92 | my $_PANGO_BASENAME = 'Pango'; 93 | my $_PANGO_VERSION = '1.0'; 94 | my $_PANGO_PACKAGE = 'Pango'; 95 | 96 | =head2 Customizations and overrides 97 | 98 | In order to make things more Perlish or to make porting from C to C 99 | easier, C customizes the API generated by L 100 | in a few spots: 101 | 102 | =over 103 | 104 | =cut 105 | 106 | # - Customizations ---------------------------------------------------------- # 107 | 108 | =item * The array ref normally returned by the following functions is flattened 109 | into a list: 110 | 111 | =over 112 | 113 | =item Gtk3::ActionGroup::list_actions 114 | 115 | =item Gtk3::Builder::get_objects 116 | 117 | =item Gtk3::CellLayout::get_cells 118 | 119 | =item Gtk3::Container::get_children 120 | 121 | =item Gtk3::SizeGroup::get_widgets 122 | 123 | =item Gtk3::TreePath::get_indices 124 | 125 | =item Gtk3::TreeView::get_columns 126 | 127 | =item Gtk3::UIManager::get_action_groups 128 | 129 | =item Gtk3::UIManager::get_toplevels 130 | 131 | =item Gtk3::Window::list_toplevels 132 | 133 | =item Gtk3::stock_list_ids 134 | 135 | =item Gtk3::Gdk::Pixbuf::get_formats 136 | 137 | =back 138 | 139 | =cut 140 | 141 | my @_GTK_FLATTEN_ARRAY_REF_RETURN_FOR = qw/ 142 | Gtk3::ActionGroup::list_actions 143 | Gtk3::Builder::get_objects 144 | Gtk3::CellLayout::get_cells 145 | Gtk3::Container::get_children 146 | Gtk3::SizeGroup::get_widgets 147 | Gtk3::TreePath::get_indices 148 | Gtk3::TreeView::get_columns 149 | Gtk3::UIManager::get_action_groups 150 | Gtk3::UIManager::get_toplevels 151 | Gtk3::Window::list_toplevels 152 | Gtk3::stock_list_ids 153 | /; 154 | 155 | my @_GDK_PIXBUF_FLATTEN_ARRAY_REF_RETURN_FOR = qw/ 156 | Gtk3::Gdk::Pixbuf::get_formats 157 | /; 158 | 159 | =item * The following functions normally return a boolean and additional out 160 | arguments, where the boolean indicates whether the out arguments are valid. 161 | They are altered such that when the boolean is true, only the additional out 162 | arguments are returned, and when the boolean is false, an empty list is 163 | returned. 164 | 165 | =over 166 | 167 | =item Gtk3::TextBuffer::get_selection_bounds 168 | 169 | =item Gtk3::TreeModel::get_iter 170 | 171 | =item Gtk3::TreeModel::get_iter_first 172 | 173 | =item Gtk3::TreeModel::get_iter_from_string 174 | 175 | =item Gtk3::TreeModel::iter_children 176 | 177 | =item Gtk3::TreeModel::iter_nth_child 178 | 179 | =item Gtk3::TreeModel::iter_parent 180 | 181 | =item Gtk3::TreeModelFilter::convert_child_iter_to_iter 182 | 183 | =item Gtk3::TreeModelSort::convert_child_iter_to_iter 184 | 185 | =item Gtk3::TreeSelection::get_selected 186 | 187 | =item Gtk3::TreeView::get_dest_row_at_pos 188 | 189 | =item Gtk3::TreeView::get_path_at_pos 190 | 191 | =item Gtk3::TreeView::get_tooltip_context 192 | 193 | =item Gtk3::TreeView::get_visible_range 194 | 195 | =item Gtk3::TreeViewColumn::cell_get_position 196 | 197 | =item Gtk3::stock_lookup 198 | 199 | =item Gtk3::Gdk::Event::get_axis 200 | 201 | =item Gtk3::Gdk::Event::get_button 202 | 203 | =item Gtk3::Gdk::Event::get_click_count 204 | 205 | =item Gtk3::Gdk::Event::get_coords 206 | 207 | =item Gtk3::Gdk::Event::get_keycode 208 | 209 | =item Gtk3::Gdk::Event::get_keyval 210 | 211 | =item Gtk3::Gdk::Event::get_scroll_direction 212 | 213 | =item Gtk3::Gdk::Event::get_scroll_deltas 214 | 215 | =item Gtk3::Gdk::Event::get_state 216 | 217 | =item Gtk3::Gdk::Event::get_root_coords 218 | 219 | =item Gtk3::Gdk::Window::get_origin 220 | 221 | =back 222 | 223 | =cut 224 | 225 | my @_GTK_HANDLE_SENTINEL_BOOLEAN_FOR = qw/ 226 | Gtk3::TextBuffer::get_selection_bounds 227 | Gtk3::TreeModel::get_iter 228 | Gtk3::TreeModel::get_iter_first 229 | Gtk3::TreeModel::get_iter_from_string 230 | Gtk3::TreeModel::iter_children 231 | Gtk3::TreeModel::iter_nth_child 232 | Gtk3::TreeModel::iter_parent 233 | Gtk3::TreeModelFilter::convert_child_iter_to_iter 234 | Gtk3::TreeModelSort::convert_child_iter_to_iter 235 | Gtk3::TreeSelection::get_selected 236 | Gtk3::TreeView::get_dest_row_at_pos 237 | Gtk3::TreeView::get_path_at_pos 238 | Gtk3::TreeView::get_tooltip_context 239 | Gtk3::TreeView::get_visible_range 240 | Gtk3::TreeViewColumn::cell_get_position 241 | Gtk3::stock_lookup 242 | /; 243 | 244 | my @_GDK_HANDLE_SENTINEL_BOOLEAN_FOR = qw/ 245 | Gtk3::Gdk::Event::get_axis 246 | Gtk3::Gdk::Event::get_button 247 | Gtk3::Gdk::Event::get_click_count 248 | Gtk3::Gdk::Event::get_coords 249 | Gtk3::Gdk::Event::get_keycode 250 | Gtk3::Gdk::Event::get_keyval 251 | Gtk3::Gdk::Event::get_scroll_direction 252 | Gtk3::Gdk::Event::get_scroll_deltas 253 | Gtk3::Gdk::Event::get_state 254 | Gtk3::Gdk::Event::get_root_coords 255 | Gtk3::Gdk::Window::get_origin 256 | /; 257 | 258 | my @_GTK_USE_GENERIC_SIGNAL_MARSHALLER_FOR = ( 259 | ['Gtk3::Editable', 'insert-text'], 260 | ['Gtk3::Dialog', 'response', \&Gtk3::Dialog::_gtk3_perl_response_converter], 261 | ['Gtk3::InfoBar', 'response', \&Gtk3::Dialog::_gtk3_perl_response_converter], 262 | ); 263 | 264 | =item * Values of type Gtk3::ResponseType are converted to and from nick names 265 | if possible, while still allowing raw IDs, in the following places: 266 | 267 | =over 268 | 269 | =item - For Gtk3::Dialog and Gtk3::InfoBar: the signal C as well as 270 | the methods C, C, C, C, 271 | C and C. 272 | 273 | =item - For Gtk3::Dialog: the methods C, 274 | C, C and C. 275 | 276 | =back 277 | 278 | =cut 279 | 280 | # GtkResponseType: id <-> nick 281 | my $_GTK_RESPONSE_ID_TO_NICK = sub { 282 | my ($id) = @_; 283 | { 284 | local $@; 285 | my $nick = eval { Glib::Object::Introspection->convert_enum_to_sv ( 286 | 'Gtk3::ResponseType', $id) }; 287 | return $nick if defined $nick; 288 | } 289 | return $id; 290 | }; 291 | my $_GTK_RESPONSE_NICK_TO_ID = sub { 292 | my ($nick) = @_; 293 | { 294 | local $@; 295 | my $id = eval { Glib::Object::Introspection->convert_sv_to_enum ( 296 | 'Gtk3::ResponseType', $nick) }; 297 | return $id if defined $id; 298 | } 299 | return $nick; 300 | }; 301 | 302 | # Converter for GtkDialog's "response" signal. 303 | sub Gtk3::Dialog::_gtk3_perl_response_converter { 304 | my ($dialog, $id, $data) = @_; 305 | return ($dialog, $_GTK_RESPONSE_ID_TO_NICK->($id), $data); 306 | } 307 | 308 | =item * Values of type Gtk3::IconSize are converted to and from nick names if 309 | possible, while still allowing raw IDs, in the following places: 310 | 311 | =over 312 | 313 | =item - Gtk3::Image: the constructors new_from_stock, new_from_icon_set, 314 | new_from_icon_name and new_from_gicon, the getters get_stock, get_icon_set, 315 | get_icon_name and get_gicon and the setters set_from_stock, set_from_icon_set, 316 | set_from_icon_name, set_from_gicon. 317 | 318 | =item - Gtk3::Widget: the method render_icon. 319 | 320 | =back 321 | 322 | =cut 323 | 324 | # GtkIconSize: id <-> nick 325 | my $_GTK_ICON_SIZE_ID_TO_NICK = sub { 326 | my ($id) = @_; 327 | { 328 | local $@; 329 | my $nick = eval { Glib::Object::Introspection->convert_enum_to_sv ( 330 | 'Gtk3::IconSize', $id) }; 331 | return $nick if defined $nick; 332 | } 333 | { 334 | my $nick = Gtk3::IconSize::get_name ($id); 335 | return $nick if defined $nick; 336 | } 337 | return $id; 338 | }; 339 | my $_GTK_ICON_SIZE_NICK_TO_ID = sub { 340 | my ($nick) = @_; 341 | { 342 | local $@; 343 | my $id = eval { Glib::Object::Introspection->convert_sv_to_enum ( 344 | 'Gtk3::IconSize', $nick) }; 345 | return $id if defined $id; 346 | } 347 | { 348 | my $id = Gtk3::IconSize::from_name ($nick); 349 | return $id if $id;# if it's not zero 350 | } 351 | return $nick; 352 | }; 353 | 354 | =item * The constants C and C can be 355 | used in handlers for event signals like C to indicate whether 356 | or not the event should continue propagating through the widget hierarchy. 357 | 358 | =cut 359 | 360 | # Names "STOP" and "PROPAGATE" here are per the GtkWidget event signal 361 | # descriptions. In some other flavours of signals the jargon is "handled" 362 | # instead of "stop". "Handled" matches g_signal_accumulator_true_handled(), 363 | # though that function doesn't rate a mention in the Gtk docs. There's 364 | # nothing fixed in the idea of "true means cease emission" (whether it's 365 | # called "stop" or "handled"). You can just as easily have false for cease 366 | # (the way the underlying GSignalAccumulator func in fact operates). The 367 | # upshot being don't want to attempt to be too universal with the names 368 | # here; "EVENT" is meant to hint at the context or signal flavour they're 369 | # for use with. 370 | sub Gtk3::EVENT_PROPAGATE() { !1 }; 371 | sub Gtk3::EVENT_STOP() { 1 }; 372 | 373 | =item * The records corresponding to the various Gtk3::Gdk::Event types, like 374 | C or C, are represented as objects blessed into specific 375 | Perl packages, like C or C, that 376 | all inherit from C. This allows you to seemlessly access 377 | type-specific fields as well as common fields, as in C<< $event->window >> or 378 | C<< $event->keyval >>. 379 | 380 | =cut 381 | 382 | my %_GDK_REBLESSERS = ( 383 | 'Gtk3::Gdk::Event' => \&Gtk3::Gdk::Event::_rebless, 384 | ); 385 | 386 | my %_GDK_EVENT_TYPE_TO_PACKAGE = ( 387 | 'expose' => 'Expose', 388 | 'motion-notify' => 'Motion', 389 | 'button-press' => 'Button', 390 | '2button-press' => 'Button', 391 | '3button-press' => 'Button', 392 | 'button-release' => 'Button', 393 | 'key-press' => 'Key', 394 | 'key-release' => 'Key', 395 | 'enter-notify' => 'Crossing', 396 | 'leave-notify' => 'Crossing', 397 | 'focus-change' => 'Focus', 398 | 'configure' => 'Configure', 399 | 'property-notify' => 'Property', 400 | 'selection-clear' => 'Selection', 401 | 'selection-request' => 'Selection', 402 | 'selection-notify' => 'Selection', 403 | 'proximity-in' => 'Proximity', 404 | 'proximity-out' => 'Proximity', 405 | 'drag-enter' => 'DND', 406 | 'drag-leave' => 'DND', 407 | 'drag-motion' => 'DND', 408 | 'drag-status' => 'DND', 409 | 'drop-start' => 'DND', 410 | 'drop-finished' => 'DND', 411 | 'client-event' => 'Client', 412 | 'visibility-notify' => 'Visibility', 413 | 'no-expose' => 'NoExpose', 414 | 'scroll' => 'Scroll', 415 | 'window-state' => 'WindowState', 416 | 'setting' => 'Setting', 417 | 'owner-change' => 'OwnerChange', 418 | 'grab-broken' => 'GrabBroken', 419 | 'damage' => 'Expose', 420 | # added in 3.4: 421 | 'touch-begin' => 'Touch', 422 | 'touch-update' => 'Touch', 423 | 'touch-end' => 'Touch', 424 | 'touch-cancel' => 'Touch', 425 | # added in 3.6: 426 | 'double-button-press' => 'Button', 427 | 'triple-button-press' => 'Button', 428 | ); 429 | 430 | # Make all of the above sub-types inherit from Gtk3::Gdk::Event. 431 | { 432 | no strict qw(refs); 433 | my %seen; 434 | foreach (grep { !$seen{$_}++ } values %_GDK_EVENT_TYPE_TO_PACKAGE) { 435 | push @{'Gtk3::Gdk::Event' . $_ . '::ISA'}, 'Gtk3::Gdk::Event'; 436 | } 437 | } 438 | 439 | sub Gtk3::Gdk::Event::_rebless { 440 | my ($event) = @_; 441 | my $package = 'Gtk3::Gdk::Event'; 442 | if (exists $_GDK_EVENT_TYPE_TO_PACKAGE{$event->type}) { 443 | $package .= $_GDK_EVENT_TYPE_TO_PACKAGE{$event->type}; 444 | } 445 | return bless $event, $package; 446 | } 447 | 448 | # - Wiring ------------------------------------------------------------------ # 449 | 450 | =item * Gtk3::Gdk::Atom has overloads for the C<==> and C operators that 451 | check for equality of the underlying atoms. 452 | 453 | =cut 454 | 455 | sub import { 456 | my $class = shift; 457 | 458 | Glib::Object::Introspection->setup ( 459 | basename => $_GTK_BASENAME, 460 | version => $_GTK_VERSION, 461 | package => $_GTK_PACKAGE, 462 | flatten_array_ref_return_for => \@_GTK_FLATTEN_ARRAY_REF_RETURN_FOR, 463 | handle_sentinel_boolean_for => \@_GTK_HANDLE_SENTINEL_BOOLEAN_FOR, 464 | use_generic_signal_marshaller_for => \@_GTK_USE_GENERIC_SIGNAL_MARSHALLER_FOR); 465 | 466 | Glib::Object::Introspection->setup ( 467 | basename => $_GDK_BASENAME, 468 | version => $_GDK_VERSION, 469 | package => $_GDK_PACKAGE, 470 | handle_sentinel_boolean_for => \@_GDK_HANDLE_SENTINEL_BOOLEAN_FOR, 471 | reblessers => \%_GDK_REBLESSERS); 472 | 473 | Glib::Object::Introspection->setup ( 474 | basename => $_GDK_PIXBUF_BASENAME, 475 | version => $_GDK_PIXBUF_VERSION, 476 | package => $_GDK_PIXBUF_PACKAGE, 477 | flatten_array_ref_return_for => \@_GDK_PIXBUF_FLATTEN_ARRAY_REF_RETURN_FOR); 478 | 479 | # In gdk-pixbuf 2.38.0, the GdkPixdata introspection information was split 480 | # out into its own file. 481 | if (Gtk3::Gdk::Pixbuf::CHECK_VERSION (2, 38, 0)) { 482 | Glib::Object::Introspection->setup ( 483 | basename => $_GDK_PIXDATA_BASENAME, 484 | version => $_GDK_PIXDATA_VERSION, 485 | package => $_GDK_PIXDATA_PACKAGE); 486 | } 487 | 488 | Glib::Object::Introspection->setup ( 489 | basename => $_PANGO_BASENAME, 490 | version => $_PANGO_VERSION, 491 | package => $_PANGO_PACKAGE); 492 | 493 | Glib::Object::Introspection->_register_boxed_synonym ( 494 | "cairo", "RectangleInt", "gdk_rectangle_get_type"); 495 | 496 | # FIXME: This uses an undocumented interface for overloading to avoid the 497 | # need for a package declaration. 498 | Gtk3::Gdk::Atom->overload::OVERLOAD ( 499 | '==' => sub { ${$_[0]} == ${$_[1]} }, 500 | '!=' => sub { ${$_[0]} != ${$_[1]} }, 501 | fallback => 1); 502 | 503 | my $init = 0; 504 | my @unknown_args = ($class); 505 | foreach (@_) { 506 | if (/^-?init$/) { 507 | $init = 1; 508 | } else { 509 | push @unknown_args, $_; 510 | } 511 | } 512 | 513 | if ($init) { 514 | Gtk3::init (); 515 | } 516 | 517 | # call into Exporter for the unrecognized arguments; handles exporting and 518 | # version checking 519 | Gtk3->export_to_level (1, @unknown_args); 520 | } 521 | 522 | # - Overrides --------------------------------------------------------------- # 523 | 524 | =item * For backwards compatibility, the functions C 525 | and C are provided, and the functions 526 | C, C, C, 527 | C, C, C and C 528 | can be called as class-static or as normal functions: for example, C<< 529 | Gtk3->main_quit >> and C<< Gtk3::main_quit >> are both supported. 530 | Additionally, C and C automatically handle 531 | passing and updating C<@ARGV> as appropriate. 532 | 533 | =cut 534 | 535 | sub Gtk3::get_version_info { 536 | return Gtk3::get_major_version (), 537 | Gtk3::get_minor_version (), 538 | Gtk3::get_micro_version (); 539 | } 540 | 541 | sub Gtk3::GET_VERSION_INFO { 542 | return Gtk3->MAJOR_VERSION, Gtk3->MINOR_VERSION, Gtk3->MICRO_VERSION; 543 | } 544 | 545 | sub Gtk3::CHECK_VERSION { 546 | return not defined Gtk3::check_version(@_ == 4 ? @_[1..3] : @_); 547 | } 548 | 549 | sub Gtk3::check_version { 550 | Glib::Object::Introspection->invoke ($_GTK_BASENAME, undef, 'check_version', 551 | @_ == 4 ? @_[1..3] : @_); 552 | } 553 | 554 | sub Gtk3::init { 555 | my $rest = Glib::Object::Introspection->invoke ( 556 | $_GTK_BASENAME, undef, 'init', 557 | [$0, @ARGV]); 558 | @ARGV = @{$rest}[1 .. $#$rest]; # remove $0 559 | return; 560 | } 561 | 562 | sub Gtk3::init_check { 563 | my ($success, $rest) = Glib::Object::Introspection->invoke ( 564 | $_GTK_BASENAME, undef, 'init_check', 565 | [$0, @ARGV]); 566 | @ARGV = @{$rest}[1 .. $#$rest]; # remove $0 567 | return $success; 568 | } 569 | 570 | sub Gtk3::main { 571 | # Ignore any arguments passed in. 572 | Glib::Object::Introspection->invoke ($_GTK_BASENAME, undef, 'main'); 573 | } 574 | 575 | sub Gtk3::main_level { 576 | # Ignore any arguments passed in. 577 | return Glib::Object::Introspection->invoke ($_GTK_BASENAME, undef, 'main_level'); 578 | } 579 | 580 | sub Gtk3::main_quit { 581 | # Ignore any arguments passed in. 582 | Glib::Object::Introspection->invoke ($_GTK_BASENAME, undef, 'main_quit'); 583 | } 584 | 585 | =item * A Perl reimplementation of C is provided. 586 | 587 | =cut 588 | 589 | { 590 | my $global_about_dialog = undef; 591 | my $about_dialog_key = '__gtk3_about_dialog'; 592 | 593 | sub Gtk3::show_about_dialog { 594 | # For backwards-compatibility, optionally accept and discard a class 595 | # argument. 596 | my $parent_or_class = shift; 597 | my $parent = defined $parent_or_class && $parent_or_class eq 'Gtk3' 598 | ? shift 599 | : $parent_or_class; 600 | my %props = @_; 601 | my $dialog = defined $parent 602 | ? $parent->{$about_dialog_key} 603 | : $global_about_dialog; 604 | 605 | if (!$dialog) { 606 | $dialog = Gtk3::AboutDialog->new; 607 | $dialog->signal_connect (delete_event => sub { $dialog->hide_on_delete }); 608 | $dialog->signal_connect (response => sub { $dialog->hide }); 609 | foreach my $prop (keys %props) { 610 | $dialog->set ($prop => $props{$prop}); 611 | } 612 | if ($parent) { 613 | $dialog->set_modal (Glib::TRUE); 614 | $dialog->set_transient_for ($parent); 615 | $dialog->set_destroy_with_parent (Glib::TRUE); 616 | $parent->{$about_dialog_key} = $dialog; 617 | } else { 618 | $global_about_dialog = $dialog; 619 | } 620 | } 621 | 622 | $dialog->present; 623 | } 624 | } 625 | 626 | =item * Perl reimplementations of C, 627 | C and C are provided. 628 | 629 | =cut 630 | 631 | sub Gtk3::ActionGroup::add_actions { 632 | my ($self, $entries, $user_data) = @_; 633 | 634 | croak 'actions must be a reference to an array of action entries' 635 | unless (ref($entries) eq 'ARRAY'); 636 | 637 | croak 'action array is empty' 638 | unless (@$entries); 639 | 640 | my $process = sub { 641 | my ($p) = @_; 642 | my ($name, $stock_id, $label, $accelerator, $tooltip, $callback); 643 | 644 | if (ref($p) eq 'ARRAY') { 645 | $name = $p->[0]; 646 | $stock_id = $p->[1]; 647 | $label = $p->[2]; 648 | $accelerator = $p->[3]; 649 | $tooltip = $p->[4]; 650 | $callback = $p->[5]; 651 | } elsif (ref($p) eq 'HASH') { 652 | $name = $p->{name}; 653 | $stock_id = $p->{stock_id}; 654 | $label = $p->{label}; 655 | $accelerator = $p->{accelerator}; 656 | $tooltip = $p->{tooltip}; 657 | $callback = $p->{callback}; 658 | } else { 659 | croak 'action entry must be a reference to a hash or an array'; 660 | } 661 | 662 | if (defined($label)) { 663 | $label = $self->translate_string($label); 664 | } 665 | if (defined($tooltip)) { 666 | $tooltip = $self->translate_string($tooltip); 667 | } 668 | 669 | my $action = Gtk3::Action->new ($name, $label, $tooltip, $stock_id); 670 | 671 | if ($callback) { 672 | $action->signal_connect ('activate', $callback, $user_data); 673 | } 674 | $self->add_action_with_accel ($action, $accelerator); 675 | }; 676 | 677 | for my $e (@$entries) { 678 | $process->($e); 679 | } 680 | } 681 | 682 | sub Gtk3::ActionGroup::add_toggle_actions { 683 | my ($self, $entries, $user_data) = @_; 684 | 685 | croak 'entries must be a reference to an array of toggle action entries' 686 | unless (ref($entries) eq 'ARRAY'); 687 | 688 | croak 'toggle action array is empty' 689 | unless (@$entries); 690 | 691 | my $process = sub { 692 | my ($p) = @_; 693 | my ($name, $stock_id, $label, $accelerator, $tooltip, 694 | $callback, $is_active); 695 | 696 | if (ref($p) eq 'ARRAY') { 697 | $name = $p->[0]; 698 | $stock_id = $p->[1]; 699 | $label = $p->[2]; 700 | $accelerator = $p->[3]; 701 | $tooltip = $p->[4]; 702 | $callback = $p->[5]; 703 | $is_active = $p->[6]; 704 | } elsif (ref($p) eq 'HASH') { 705 | $name = $p->{name}; 706 | $stock_id = $p->{stock_id}; 707 | $label = $p->{label}; 708 | $accelerator = $p->{accelerator}; 709 | $tooltip = $p->{tooltip}; 710 | $callback = $p->{callback}; 711 | $is_active = $p->{is_active}; 712 | } else { 713 | croak 'action entry must be a hash or an array'; 714 | } 715 | 716 | if (defined($label)) { 717 | $label = $self->translate_string($label); 718 | } 719 | if (defined($tooltip)) { 720 | $tooltip = $self->translate_string($tooltip); 721 | } 722 | 723 | my $action = Gtk3::ToggleAction->new ( 724 | $name, $label, $tooltip, $stock_id); 725 | $action->set_active ($is_active) if defined $is_active; 726 | 727 | if ($callback) { 728 | $action->signal_connect ('activate', $callback, $user_data); 729 | } 730 | 731 | $self->add_action_with_accel ($action, $accelerator); 732 | }; 733 | 734 | for my $e (@$entries) { 735 | $process->($e); 736 | } 737 | } 738 | 739 | sub Gtk3::ActionGroup::add_radio_actions { 740 | my ($self, $entries, $value, $on_change, $user_data) = @_; 741 | 742 | croak 'radio_action_entries must be a reference to ' 743 | . 'an array of action entries' 744 | unless (ref($entries) eq 'ARRAY'); 745 | 746 | croak 'radio action array is empty' 747 | unless (@$entries); 748 | 749 | my $first_action = undef; 750 | 751 | my $process = sub { 752 | my ($group, $p) = @_; 753 | my ($name, $stock_id, $label, $accelerator, $tooltip, $entry_value); 754 | 755 | if (ref($p) eq 'ARRAY') { 756 | $name = $p->[0]; 757 | $stock_id = $p->[1]; 758 | $label = $p->[2]; 759 | $accelerator = $p->[3]; 760 | $tooltip = $p->[4]; 761 | $entry_value = $p->[5]; 762 | } elsif (ref($p) eq 'HASH') { 763 | $name = $p->{name}; 764 | $stock_id = $p->{stock_id}; 765 | $label = $p->{label}; 766 | $accelerator = $p->{accelerator}; 767 | $tooltip = $p->{tooltip}; 768 | $entry_value = $p->{value}; 769 | } else { 770 | croak 'radio action entries neither hash nor array'; 771 | } 772 | 773 | if (defined($label)) { 774 | $label = $self->translate_string($label); 775 | } 776 | if (defined($tooltip)) { 777 | $tooltip = $self->translate_string($tooltip); 778 | } 779 | 780 | my $action = Gtk3::RadioAction->new ( 781 | $name, $label, $tooltip, $stock_id, $entry_value); 782 | 783 | $action->join_group($group); 784 | 785 | if ($value == $entry_value) { 786 | $action->set_active(Glib::TRUE); 787 | } 788 | $self->add_action_with_accel($action, $accelerator); 789 | return $action; 790 | }; 791 | 792 | for my $e (@$entries) { 793 | my $group = $process->($first_action, $e); 794 | if (!$first_action) { 795 | $first_action = $group; 796 | } 797 | } 798 | 799 | if ($first_action && $on_change) { 800 | $first_action->signal_connect ('changed', $on_change, $user_data); 801 | } 802 | } 803 | 804 | =item * C and C 805 | also accept a list of objects instead of an array ref. 806 | 807 | =item * C and C don't 808 | take length arguments, as they are computed automatically. 809 | 810 | =cut 811 | 812 | sub Gtk3::Builder::add_objects_from_file { 813 | my ($builder, $filename, @rest) = @_; 814 | my $ref = _rest_to_ref (\@rest); 815 | return Glib::Object::Introspection->invoke ( 816 | $_GTK_BASENAME, 'Builder', 'add_objects_from_file', 817 | $builder, $filename, $ref); 818 | } 819 | 820 | sub Gtk3::Builder::add_objects_from_string { 821 | my ($builder, $string, @rest) = @_; 822 | my $ref = _rest_to_ref (\@rest); 823 | return Glib::Object::Introspection->invoke ( 824 | $_GTK_BASENAME, 'Builder', 'add_objects_from_string', 825 | $builder, $string, -1, $ref); # wants length in bytes 826 | } 827 | 828 | sub Gtk3::Builder::add_from_string { 829 | my ($builder, $string) = @_; 830 | return Glib::Object::Introspection->invoke ( 831 | $_GTK_BASENAME, 'Builder', 'add_from_string', 832 | $builder, $string, -1); # wants length in bytes 833 | } 834 | 835 | =item * A Perl reimplementation of C is 836 | provided. 837 | 838 | =cut 839 | 840 | # Copied from Gtk2.pm 841 | sub Gtk3::Builder::connect_signals { 842 | my $builder = shift; 843 | my $user_data = shift; 844 | 845 | my $do_connect = sub { 846 | my ($object, 847 | $signal_name, 848 | $user_data, 849 | $connect_object, 850 | $flags, 851 | $handler) = @_; 852 | my $func = ($flags & 'after') ? 'signal_connect_after' : 'signal_connect'; 853 | # we get connect_object when we're supposed to call 854 | # signal_connect_object, which ensures that the data (an object) 855 | # lives as long as the signal is connected. the bindings take 856 | # care of that for us in all cases, so we only have signal_connect. 857 | # if we get a connect_object, just use that instead of user_data. 858 | $object->$func($signal_name => $handler, 859 | $connect_object || $user_data); 860 | }; 861 | 862 | # $builder->connect_signals ($user_data) 863 | # $builder->connect_signals ($user_data, $package) 864 | if ($#_ <= 0) { 865 | my $package = shift; 866 | $package = caller unless defined $package; 867 | 868 | $builder->connect_signals_full(sub { 869 | my ($builder, 870 | $object, 871 | $signal_name, 872 | $handler_name, 873 | $connect_object, 874 | $flags) = @_; 875 | 876 | no strict qw/refs/; 877 | 878 | my $handler = $handler_name; 879 | if (ref $package) { 880 | $handler = sub { $package->$handler_name(@_) }; 881 | } else { 882 | if ($package && $handler !~ /::/) { 883 | $handler = $package.'::'.$handler_name; 884 | } 885 | } 886 | 887 | $do_connect->($object, $signal_name, $user_data, $connect_object, 888 | $flags, $handler); 889 | }); 890 | } 891 | 892 | # $builder->connect_signals ($user_data, %handlers) 893 | else { 894 | my %handlers = @_; 895 | 896 | $builder->connect_signals_full(sub { 897 | my ($builder, 898 | $object, 899 | $signal_name, 900 | $handler_name, 901 | $connect_object, 902 | $flags) = @_; 903 | 904 | return unless exists $handlers{$handler_name}; 905 | 906 | $do_connect->($object, $signal_name, $user_data, $connect_object, 907 | $flags, $handlers{$handler_name}); 908 | }); 909 | } 910 | } 911 | 912 | =item * The default C constructors of Gtk3::Button, Gtk3::CheckButton, 913 | Gtk3::ColorButton, Gtk3::FontButton and Gtk3::ToggleButton reroute to 914 | C if given an extra argument. 915 | 916 | =cut 917 | 918 | { 919 | no strict 'refs'; 920 | my @button_classes = ([Button => 'new_with_mnemonic'], 921 | [CheckButton => 'new_with_mnemonic'], 922 | [ColorButton => 'new_with_color'], 923 | [FontButton => 'new_with_font'], 924 | [ToggleButton => 'new_with_mnemonic']); 925 | foreach my $button_pair (@button_classes) { 926 | my ($button_class, $button_ctor) = @$button_pair; 927 | *{'Gtk3::' . $button_class . '::new'} = sub { 928 | my ($class, $thing) = @_; 929 | if (defined $thing) { 930 | return $class->$button_ctor ($thing); 931 | } else { 932 | return Glib::Object::Introspection->invoke ( 933 | $_GTK_BASENAME, $button_class, 'new', @_); 934 | } 935 | } 936 | } 937 | } 938 | 939 | =item * The default C constructor of Gtk3::CheckMenuItem reroutes to 940 | C if given an extra argument. 941 | 942 | =cut 943 | 944 | sub Gtk3::CheckMenuItem::new { 945 | my ($class, $mnemonic) = @_; 946 | if (defined $mnemonic) { 947 | return $class->new_with_mnemonic ($mnemonic); 948 | } 949 | return Glib::Object::Introspection->invoke ( 950 | $_GTK_BASENAME, 'CheckMenuItem', 'new', @_); 951 | } 952 | 953 | =item * The C argument of C is optional. 954 | 955 | =cut 956 | 957 | sub Gtk3::Clipboard::set_text { 958 | return Glib::Object::Introspection->invoke ( 959 | $_GTK_BASENAME, 'Clipboard', 'set_text', 960 | @_ == 3 ? @_ : (@_[0,1], -1)); # wants length in bytes 961 | } 962 | 963 | =item * Perl reimplementations of C, 964 | C and C are provided. 965 | 966 | =cut 967 | 968 | sub Gtk3::Container::add_with_properties { 969 | my ($container, $widget, @rest) = @_; 970 | $widget->freeze_child_notify; 971 | $container->add ($widget); 972 | if ($widget->get_parent) { 973 | $container->child_set ($widget, @rest); 974 | } 975 | $widget->thaw_child_notify; 976 | } 977 | 978 | sub Gtk3::Container::child_get { 979 | my ($container, $child, @rest) = @_; 980 | my $properties = _rest_to_ref (\@rest); 981 | my @values; 982 | foreach my $property (@$properties) { 983 | my $pspec = Gtk3::ContainerClass::find_child_property ($container, $property); 984 | croak "Cannot find type information for property '$property' on $container" 985 | unless defined $pspec; 986 | my $value_wrapper = Glib::Object::Introspection::GValueWrapper->new ( 987 | $pspec->get_value_type, undef); 988 | $container->child_get_property ($child, $property, $value_wrapper); 989 | push @values, $value_wrapper->get_value; 990 | } 991 | return @values[0..$#values]; 992 | } 993 | 994 | sub Gtk3::Container::child_set { 995 | my ($container, $child, @rest) = @_; 996 | my ($properties, $values) = _unpack_keys_and_values (\@rest); 997 | foreach my $i (0..$#$properties) { 998 | my $property = $properties->[$i]; 999 | my $value = $values->[$i]; 1000 | my $pspec = Gtk3::ContainerClass::find_child_property ($container, $property); 1001 | croak "Cannot find type information for property '$property' on $container" 1002 | unless defined $pspec; 1003 | my $value_wrapper = Glib::Object::Introspection::GValueWrapper->new ( 1004 | $pspec->get_value_type, $value); 1005 | $container->child_set_property ($child, $property, $value_wrapper); 1006 | } 1007 | } 1008 | 1009 | =item * C and 1010 | C are forwarded to the corresponding 1011 | functions in C. 1012 | 1013 | =cut 1014 | 1015 | sub Gtk3::Container::find_child_property { 1016 | return Gtk3::ContainerClass::find_child_property (@_); 1017 | } 1018 | 1019 | sub Gtk3::Container::list_child_properties { 1020 | my $ref = Gtk3::ContainerClass::list_child_properties (@_); 1021 | return if not defined $ref; 1022 | return wantarray ? @$ref : $ref->[$#$ref]; 1023 | } 1024 | 1025 | =item * C returns a list of widgets, or an 1026 | empty list. 1027 | 1028 | =cut 1029 | 1030 | sub Gtk3::Container::get_focus_chain { 1031 | my ($container) = @_; 1032 | my ($is_set, $widgets) = Glib::Object::Introspection->invoke ( 1033 | $_GTK_BASENAME, 'Container', 'get_focus_chain', 1034 | $container); 1035 | return () unless $is_set; 1036 | return @$widgets; 1037 | } 1038 | 1039 | =item * C also accepts a list of widgets. 1040 | 1041 | =cut 1042 | 1043 | sub Gtk3::Container::set_focus_chain { 1044 | my ($container, @rest) = @_; 1045 | return Glib::Object::Introspection->invoke ( 1046 | $_GTK_BASENAME, 'Container', 'set_focus_chain', 1047 | $container, _rest_to_ref (\@rest)); 1048 | } 1049 | 1050 | =item * C also accepts a string. 1051 | 1052 | =cut 1053 | 1054 | sub Gtk3::CssProvider::load_from_data { 1055 | my ($self, $data) = @_; 1056 | return Glib::Object::Introspection->invoke ( 1057 | $_GTK_BASENAME, 'CssProvider', 'load_from_data', 1058 | $self, _unpack_unless_array_ref ($data)); 1059 | } 1060 | 1061 | =item * For Gtk3::Dialog and Gtk3::InfoBar, a Perl implementation of 1062 | C is provided. 1063 | 1064 | =cut 1065 | 1066 | # Gtk3::Dialog / Gtk3::InfoBar methods due to overlap 1067 | { 1068 | no strict qw(refs); 1069 | foreach my $dialog_package (qw/Dialog InfoBar/) { 1070 | *{'Gtk3::' . $dialog_package . '::add_action_widget'} = sub { 1071 | Glib::Object::Introspection->invoke ( 1072 | $_GTK_BASENAME, $dialog_package, 'add_action_widget', 1073 | $_[0], $_[1], $_GTK_RESPONSE_NICK_TO_ID->($_[2])); 1074 | }; 1075 | *{'Gtk3::' . $dialog_package . '::add_button'} = sub { 1076 | Glib::Object::Introspection->invoke ( 1077 | $_GTK_BASENAME, $dialog_package, 'add_button', 1078 | $_[0], $_[1], $_GTK_RESPONSE_NICK_TO_ID->($_[2])); 1079 | }; 1080 | *{'Gtk3::' . $dialog_package . '::add_buttons'} = sub { 1081 | my ($dialog, @rest) = @_; 1082 | for (my $i = 0; $i < @rest; $i += 2) { 1083 | $dialog->add_button ($rest[$i], $rest[$i+1]); 1084 | } 1085 | }; 1086 | *{'Gtk3::' . $dialog_package . '::response'} = sub { 1087 | return Glib::Object::Introspection->invoke ( 1088 | $_GTK_BASENAME, $dialog_package, 'response', 1089 | $_[0], $_GTK_RESPONSE_NICK_TO_ID->($_[1])); 1090 | }; 1091 | *{'Gtk3::' . $dialog_package . '::set_default_response'} = sub { 1092 | Glib::Object::Introspection->invoke ( 1093 | $_GTK_BASENAME, $dialog_package, 'set_default_response', 1094 | $_[0], $_GTK_RESPONSE_NICK_TO_ID->($_[1])); 1095 | }; 1096 | *{'Gtk3::' . $dialog_package . '::set_response_sensitive'} = sub { 1097 | Glib::Object::Introspection->invoke ( 1098 | $_GTK_BASENAME, $dialog_package, 'set_response_sensitive', 1099 | $_[0], $_GTK_RESPONSE_NICK_TO_ID->($_[1]), $_[2]); 1100 | }; 1101 | } 1102 | } 1103 | 1104 | sub Gtk3::Dialog::get_response_for_widget { 1105 | my $id = Glib::Object::Introspection->invoke ( 1106 | $_GTK_BASENAME, 'Dialog', 'get_response_for_widget', @_); 1107 | return $_GTK_RESPONSE_ID_TO_NICK->($id); 1108 | } 1109 | 1110 | sub Gtk3::Dialog::get_widget_for_response { 1111 | return Glib::Object::Introspection->invoke ( 1112 | $_GTK_BASENAME, 'Dialog', 'get_widget_for_response', 1113 | $_[0], $_GTK_RESPONSE_NICK_TO_ID->($_[1])); 1114 | } 1115 | 1116 | =item * C can optionally be called as C<< Gtk3::Dialog->new 1117 | (TITLE, PARENT, FLAGS, ...) >> where C<...> is a series of button text and 1118 | response id pairs. 1119 | 1120 | =cut 1121 | 1122 | sub Gtk3::Dialog::new { 1123 | my ($class, $title, $parent, $flags, @rest) = @_; 1124 | if (@_ == 1) { 1125 | return Glib::Object::Introspection->invoke ( 1126 | $_GTK_BASENAME, 'Dialog', 'new', @_); 1127 | } elsif ((@_ < 4) || (@rest % 2)){ 1128 | croak ("Usage: Gtk3::Dialog->new ()\n" . 1129 | " or Gtk3::Dialog->new (TITLE, PARENT, FLAGS, ...)\n" . 1130 | " where ... is a series of button text and response id pairs"); 1131 | } else { 1132 | my $dialog = Gtk3::Dialog->new; 1133 | defined $title and $dialog->set_title ($title); 1134 | defined $parent and $dialog->set_transient_for ($parent); 1135 | if (! eval { $flags->isa ('Gtk3::DialogFlags'); }) { 1136 | $flags = Gtk3::DialogFlags->new ($flags); 1137 | } 1138 | $flags & 'modal' and $dialog->set_modal (Glib::TRUE); 1139 | $flags & 'destroy-with-parent' and $dialog->set_destroy_with_parent (Glib::TRUE); 1140 | $dialog->add_buttons (@rest); 1141 | return $dialog; 1142 | } 1143 | } 1144 | 1145 | =item * A Perl implementation of C is provided. 1146 | 1147 | =cut 1148 | 1149 | sub Gtk3::Dialog::new_with_buttons { 1150 | &Gtk3::Dialog::new; 1151 | } 1152 | 1153 | sub Gtk3::Dialog::run { 1154 | my $id = Glib::Object::Introspection->invoke ( 1155 | $_GTK_BASENAME, 'Dialog', 'run', @_); 1156 | return $_GTK_RESPONSE_ID_TO_NICK->($id); 1157 | } 1158 | 1159 | sub Gtk3::Dialog::set_alternative_button_order { 1160 | my ($dialog, @rest) = @_; 1161 | return unless @rest; 1162 | Glib::Object::Introspection->invoke ( 1163 | $_GTK_BASENAME, 'Dialog', 'set_alternative_button_order_from_array', 1164 | $dialog, [map { $_GTK_RESPONSE_NICK_TO_ID->($_) } @rest]); 1165 | } 1166 | 1167 | =item * The C argument of C is optional. 1168 | 1169 | =cut 1170 | 1171 | sub Gtk3::Editable::insert_text { 1172 | return Glib::Object::Introspection->invoke ( 1173 | $_GTK_BASENAME, 'Editable', 'insert_text', 1174 | @_ == 4 ? @_ : (@_[0,1], -1, $_[2])); # wants length in bytes 1175 | } 1176 | 1177 | =item * A Perl implementation of C is provided. 1178 | 1179 | =cut 1180 | 1181 | sub Gtk3::FileChooserDialog::new { 1182 | my ($class, $title, $parent, $action, @varargs) = @_; 1183 | 1184 | if (@varargs % 2) { 1185 | croak 'Usage: Gtk3::FileChooserDialog->new' . 1186 | ' (title, parent, action, button-text =>' . 1187 | " response-id, ...)\n"; 1188 | } 1189 | 1190 | my $result = Glib::Object::new ( 1191 | $class, 1192 | title => $title, 1193 | action => $action, 1194 | ); 1195 | 1196 | if ($parent) { 1197 | $result->set_transient_for ($parent); 1198 | } 1199 | 1200 | for (my $i = 0; $i < @varargs; $i += 2) { 1201 | $result->add_button ($varargs[$i], $varargs[$i+1]); 1202 | } 1203 | 1204 | return $result; 1205 | } 1206 | 1207 | =item * C uses the defaults homogeneous = FALSE and spacing = 1208 | 5. 1209 | 1210 | =cut 1211 | 1212 | sub Gtk3::HBox::new { 1213 | my ($class, $homogeneous, $spacing) = @_; 1214 | $homogeneous = 0 unless defined $homogeneous; 1215 | $spacing = 5 unless defined $spacing; 1216 | return Glib::Object::Introspection->invoke ( 1217 | $_GTK_BASENAME, 'HBox', 'new', $class, $homogeneous, $spacing); 1218 | } 1219 | 1220 | # Gtk3::Image 1221 | { 1222 | no strict qw(refs); 1223 | foreach my $ctor (qw/new_from_stock new_from_icon_set new_from_icon_name new_from_gicon/) { 1224 | *{'Gtk3::Image::' . $ctor} = sub { 1225 | my ($class, $thing, $size) = @_; 1226 | return Glib::Object::Introspection->invoke ( 1227 | $_GTK_BASENAME, 'Image', $ctor, $class, $thing, 1228 | $_GTK_ICON_SIZE_NICK_TO_ID->($size)); 1229 | } 1230 | } 1231 | foreach my $getter (qw/get_stock get_icon_set get_icon_name get_gicon/) { 1232 | *{'Gtk3::Image::' . $getter} = sub { 1233 | my ($image) = @_; 1234 | my ($thing, $size) = Glib::Object::Introspection->invoke ( 1235 | $_GTK_BASENAME, 'Image', $getter, $image); 1236 | return ($thing, $_GTK_ICON_SIZE_ID_TO_NICK->($size)); 1237 | } 1238 | } 1239 | foreach my $setter (qw/set_from_stock set_from_icon_set set_from_icon_name set_from_gicon/) { 1240 | *{'Gtk3::Image::' . $setter} = sub { 1241 | my ($image, $thing, $size) = @_; 1242 | Glib::Object::Introspection->invoke ( 1243 | $_GTK_BASENAME, 'Image', $setter, $image, $thing, 1244 | $_GTK_ICON_SIZE_NICK_TO_ID->($size)); 1245 | } 1246 | } 1247 | } 1248 | 1249 | =item * The default C constructor of Gtk3::ImageMenuItem reroutes to 1250 | C if given an extra argument. 1251 | 1252 | =cut 1253 | 1254 | sub Gtk3::ImageMenuItem::new { 1255 | my ($class, $mnemonic) = @_; 1256 | if (defined $mnemonic) { 1257 | return $class->new_with_mnemonic ($mnemonic); 1258 | } 1259 | return Glib::Object::Introspection->invoke ( 1260 | $_GTK_BASENAME, 'ImageMenuItem', 'new', @_); 1261 | } 1262 | 1263 | =item * C can optionally be called as C<< 1264 | Gtk3::InfoBar->new (...) >> where C<...> is a series of button text and 1265 | response id pairs. 1266 | 1267 | =cut 1268 | 1269 | sub Gtk3::InfoBar::new { 1270 | my ($class, @buttons) = @_; 1271 | if (@_ == 1) { 1272 | return Glib::Object::Introspection->invoke ( 1273 | $_GTK_BASENAME, 'InfoBar', 'new', @_); 1274 | } elsif (@buttons % 2) { 1275 | croak "Usage: Gtk3::InfoBar->new_with_buttons (button-text => response_id, ...)\n"; 1276 | } else { 1277 | my $infobar = Gtk3::InfoBar->new; 1278 | for (my $i = 0; $i < @buttons; $i += 2) { 1279 | $infobar->add_button ($buttons[$i], $buttons[$i+1]); 1280 | } 1281 | return $infobar; 1282 | } 1283 | } 1284 | 1285 | =item * A Perl reimplementation of C is 1286 | provided. 1287 | 1288 | =cut 1289 | 1290 | sub Gtk3::InfoBar::new_with_buttons { 1291 | &Gtk3::InfoBar::new; 1292 | } 1293 | 1294 | =item * The default C constructor of Gtk3::LinkButton reroutes to 1295 | C if given an extra argument. 1296 | 1297 | =cut 1298 | 1299 | sub Gtk3::LinkButton::new { 1300 | my ($class, $uri, $label) = @_; 1301 | if (defined $label) { 1302 | return Gtk3::LinkButton->new_with_label ($uri, $label); 1303 | } else { 1304 | return Glib::Object::Introspection->invoke ( 1305 | $_GTK_BASENAME, 'LinkButton', 'new', @_); 1306 | } 1307 | } 1308 | 1309 | =item * C also accepts a list of type names. 1310 | 1311 | =cut 1312 | 1313 | sub Gtk3::ListStore::new { 1314 | return _common_tree_model_new ('ListStore', @_); 1315 | } 1316 | 1317 | =item * Gtk3::ListStore has a C method that calls C 1318 | instead of C. 1319 | 1320 | =cut 1321 | 1322 | # Reroute 'get' to Gtk3::TreeModel instead of Glib::Object. 1323 | sub Gtk3::ListStore::get { 1324 | return Gtk3::TreeModel::get (@_); 1325 | } 1326 | 1327 | =item * C also accepts a list of C<< 1328 | column => value >> pairs and reroutes to C. 1329 | 1330 | =cut 1331 | 1332 | sub Gtk3::ListStore::insert_with_values { 1333 | my ($model, $position, @columns_and_values) = @_; 1334 | my ($columns, $values) = _unpack_keys_and_values (\@columns_and_values); 1335 | if (not defined $columns) { 1336 | croak ("Usage: Gtk3::ListStore::insert_with_values (\$model, \$position, \\\@columns, \\\@values)\n", 1337 | " -or-: Gtk3::ListStore::insert_with_values (\$model, \$position, \$column1 => \$value1, ...)"); 1338 | } 1339 | my @wrapped_values = (); 1340 | foreach my $i (0..$#{$columns}) { 1341 | my $column_type = $model->get_column_type ($columns->[$i]); 1342 | push @wrapped_values, 1343 | Glib::Object::Introspection::GValueWrapper->new ( 1344 | $column_type, $values->[$i]); 1345 | } 1346 | return Glib::Object::Introspection->invoke ( 1347 | $_GTK_BASENAME, 'ListStore', 'insert_with_valuesv', # FIXME: missing rename-to annotation? 1348 | $model, $position, $columns, \@wrapped_values); 1349 | } 1350 | 1351 | =item * C also accepts a list of C<< column => value >> 1352 | pairs. 1353 | 1354 | =cut 1355 | 1356 | sub Gtk3::ListStore::set { 1357 | return _common_tree_model_set ('ListStore', @_); 1358 | } 1359 | 1360 | =item * C reroutes to C for better 1361 | callback handling. 1362 | 1363 | =cut 1364 | 1365 | sub Gtk3::Menu::popup { 1366 | my $self = shift; 1367 | $self->popup_for_device (undef, @_); 1368 | } 1369 | 1370 | =item * C allows the given menu position func to 1371 | return only x and y coordinates, defaulting C to FALSE. 1372 | 1373 | =cut 1374 | 1375 | sub Gtk3::Menu::popup_for_device { 1376 | my ($menu, $device, $parent_menu_shell, $parent_menu_item, $func, $data, $button, $activate_time) = @_; 1377 | my $real_func = $func ? sub { 1378 | my @stuff = eval { $func->(@_) }; 1379 | if ($@) { 1380 | warn "*** menu position callback ignoring error: $@"; 1381 | } 1382 | if (@stuff == 3) { 1383 | return (@stuff); 1384 | } elsif (@stuff == 2) { 1385 | return (@stuff, Glib::FALSE); # provide a default for push_in 1386 | } else { 1387 | warn "*** menu position callback must return two integers " . 1388 | "(x, y) or two integers and a boolean (x, y, push_in)"; 1389 | return (0, 0, Glib::FALSE); 1390 | } 1391 | } : undef; 1392 | return Glib::Object::Introspection->invoke ( 1393 | $_GTK_BASENAME, 'Menu', 'popup_for_device', 1394 | $menu, $device, $parent_menu_shell, $parent_menu_item, $real_func, $data, $button, $activate_time); 1395 | } 1396 | 1397 | =item * The default C constructor of Gtk3::MenuItem reroutes to 1398 | C if given an extra argument. 1399 | 1400 | =cut 1401 | 1402 | sub Gtk3::MenuItem::new { 1403 | my ($class, $mnemonic) = @_; 1404 | if (defined $mnemonic) { 1405 | return $class->new_with_mnemonic ($mnemonic); 1406 | } 1407 | return Glib::Object::Introspection->invoke ( 1408 | $_GTK_BASENAME, 'MenuItem', 'new', @_); 1409 | } 1410 | 1411 | =item * A Perl reimplementation of C is provided. 1412 | 1413 | =cut 1414 | 1415 | sub Gtk3::MessageDialog::new { 1416 | my ($class, $parent, $flags, $type, $buttons, $format, @args) = @_; 1417 | my $dialog = Glib::Object::new ($class, message_type => $type, 1418 | buttons => $buttons); 1419 | if (defined $format) { 1420 | # sprintf can handle empty @args 1421 | my $msg = sprintf $format, @args; 1422 | $dialog->set (text => $msg); 1423 | } 1424 | if (defined $parent) { 1425 | $dialog->set_transient_for ($parent); 1426 | } 1427 | if (! eval { $flags->isa ('Gtk3::DialogFlags'); }) { 1428 | $flags = Gtk3::DialogFlags->new ($flags); 1429 | } 1430 | if ($flags & 'modal') { 1431 | $dialog->set_modal (Glib::TRUE); 1432 | } 1433 | if ($flags & 'destroy-with-parent') { 1434 | $dialog->set_destroy_with_parent (Glib::TRUE); 1435 | } 1436 | return $dialog; 1437 | } 1438 | 1439 | =item * A Perl reimplementation of C is provided. 1440 | 1441 | =cut 1442 | 1443 | sub Gtk3::MessageDialog::new_with_markup { 1444 | my ($class, $parent, $flags, $type, $buttons, $format, @args) = @_; 1445 | my $dialog = Gtk3::MessageDialog::new ($class, $parent, $flags, $type, $buttons, undef); 1446 | if (defined $format) { 1447 | my $markup = sprintf $format, @args; 1448 | $dialog->set_markup ($markup); 1449 | } 1450 | return $dialog; 1451 | } 1452 | 1453 | =item * A Perl reimplementation of C and 1454 | C is provided 1455 | 1456 | =cut 1457 | 1458 | sub Gtk3::MessageDialog::format_secondary_text { 1459 | my ($dialog, $format, @args) = @_; 1460 | 1461 | my $text = sprintf $format, @args; 1462 | $dialog->set ('secondary-text' => $text, 'secondary-use-markup' => 0); 1463 | } 1464 | 1465 | sub Gtk3::MessageDialog::format_secondary_markup { 1466 | my ($dialog, $format, @args) = @_; 1467 | 1468 | my $text = sprintf $format, @args; 1469 | $dialog->set ('secondary-text' => $text, 'secondary-use-markup' => 1); 1470 | } 1471 | 1472 | =item * The group handling in the constructors and accessors of 1473 | Gtk3::RadioAction, Gtk3::RadioButton, Gtk3::RadioMenuItem and 1474 | Gtk3::RadioToolButton is amended to work correctly when given array refs of 1475 | group members or single group members. 1476 | 1477 | =cut 1478 | 1479 | # Gtk3::RadioAction, Gtk3::RadioButton, Gtk3::RadioMenuItem and 1480 | # Gtk3::RadioToolButton constructors. 1481 | { 1482 | no strict qw(refs); 1483 | 1484 | my $group_converter = sub { 1485 | my ($ctor, $group_or_member, $package) = @_; 1486 | local $@; 1487 | # undef => [] 1488 | if (!defined $group_or_member) { 1489 | return ($ctor, []); 1490 | } 1491 | # [] => [] 1492 | elsif (eval { $#$group_or_member == -1 }) { 1493 | return ($ctor, []); 1494 | } 1495 | # [member1, ...] => member1 1496 | elsif (eval { $#$group_or_member >= 0 }) { 1497 | my $member = $group_or_member->[0]; 1498 | if (defined $member) { 1499 | return ($ctor . '_from_widget', $member); 1500 | } 1501 | return ($ctor, []); 1502 | } 1503 | # member => member 1504 | elsif (eval { $group_or_member->isa ('Gtk3::' . $package) }) { 1505 | return ($ctor . '_from_widget', $group_or_member); 1506 | } 1507 | else { 1508 | croak ('Unhandled group or member argument encountered'); 1509 | } 1510 | }; 1511 | 1512 | # Gtk3::RadioAction/Gtk3::RadioButton/Gtk3::RadioMenuItem/Gtk3::RadioToolButton 1513 | foreach my $package (qw/RadioAction RadioButton RadioMenuItem RadioToolButton/) { 1514 | *{'Gtk3::' . $package . '::set_group'} = sub { 1515 | my ($button, $group) = @_; 1516 | my $real_group = $group; 1517 | if (eval { $#$group >= 0 }) { 1518 | $real_group = $group->[0]; 1519 | } 1520 | $button->set (group => $real_group); 1521 | }; 1522 | } 1523 | 1524 | # Gtk3::RadioButton/Gtk3::RadioMenuItem 1525 | foreach my $package (qw/RadioButton RadioMenuItem/) { 1526 | foreach my $ctor (qw/new new_with_label new_with_mnemonic/) { 1527 | # Avoid using the list-based API, as G:O:I does not support the memory 1528 | # ownership semantics. Use the item-based API instead. 1529 | *{'Gtk3::' . $package . '::' . $ctor} = sub { 1530 | my ($class, $group_or_member, @rest) = @_; 1531 | my ($real_ctor, $real_group_or_member) = 1532 | $group_converter->($ctor, $group_or_member, $package); 1533 | return Glib::Object::Introspection->invoke ( 1534 | $_GTK_BASENAME, $package, $real_ctor, 1535 | $class, $real_group_or_member, @rest); 1536 | }; 1537 | 1538 | # Work around . 1539 | *{'Gtk3::' . $package . '::' . $ctor . '_from_widget'} = sub { 1540 | my ($class, $member, @rest) = @_; 1541 | my $real_ctor = $ctor; 1542 | my $real_group_or_member = $member; 1543 | if (!defined $member) { 1544 | $real_group_or_member = []; 1545 | } else { 1546 | $real_ctor .= '_from_widget'; 1547 | } 1548 | return Glib::Object::Introspection->invoke ( 1549 | $_GTK_BASENAME, $package, $real_ctor, 1550 | $class, $real_group_or_member, @rest); 1551 | }; 1552 | } 1553 | } 1554 | 1555 | # GtkRadioToolButton 1556 | foreach my $ctor (qw/new new_from_stock/) { 1557 | # Avoid using the list-based API, as G:O:I does not support the memory 1558 | # ownership semantics. Use the item-based API instead. 1559 | *{'Gtk3::RadioToolButton::' . $ctor} = sub { 1560 | my ($class, $group_or_member, @rest) = @_; 1561 | my ($real_ctor, $real_group_or_member) = 1562 | $group_converter->($ctor, $group_or_member, 'RadioToolButton'); 1563 | $real_ctor =~ s/_from_stock_from_/_with_stock_from_/; # you gotta be kidding me... 1564 | return Glib::Object::Introspection->invoke ( 1565 | $_GTK_BASENAME, 'RadioToolButton', $real_ctor, 1566 | $class, $real_group_or_member, @rest); 1567 | }; 1568 | } 1569 | } 1570 | 1571 | =item * Perl reimplementations of C and 1572 | C are provided. 1573 | 1574 | =cut 1575 | 1576 | sub Gtk3::RecentChooserDialog::new { 1577 | my ($class, $title, $parent, @buttons) = @_; 1578 | my $dialog = Glib::Object::new ($class, title => $title); 1579 | for (my $i = 0; $i < @buttons; $i += 2) { 1580 | $dialog->add_button ($buttons[$i], $buttons[$i+1]); 1581 | } 1582 | if (defined $parent) { 1583 | $dialog->set_transient_for ($parent); 1584 | } 1585 | return $dialog; 1586 | } 1587 | 1588 | sub Gtk3::RecentChooserDialog::new_for_manager { 1589 | my ($class, $title, $parent, $mgr, @buttons) = @_; 1590 | my $dialog = Glib::Object::new ($class, title => $title, 1591 | recent_manager => $mgr); 1592 | for (my $i = 0; $i < @buttons; $i += 2) { 1593 | $dialog->add_button ($buttons[$i], $buttons[$i+1]); 1594 | } 1595 | if (defined $parent) { 1596 | $dialog->set_transient_for ($parent); 1597 | } 1598 | return $dialog; 1599 | } 1600 | 1601 | =item * Redirects are provided from C to 1602 | C for C, C, C, C and 1603 | C. 1604 | 1605 | =cut 1606 | 1607 | { 1608 | no strict qw/refs/; 1609 | 1610 | my %stock_name_corrections = ( 1611 | 'Gtk3::Stock::add' => 'Gtk3::stock_add', 1612 | 'Gtk3::Stock::add_static' => 'Gtk3::stock_add_static', 1613 | 'Gtk3::Stock::list_ids' => 'Gtk3::stock_list_ids', 1614 | 'Gtk3::Stock::lookup' => 'Gtk3::stock_lookup', 1615 | 'Gtk3::Stock::set_translate_func' => 'Gtk3::stock_set_translate_func', 1616 | ); 1617 | 1618 | foreach my $new (keys %stock_name_corrections) { 1619 | *{$new} = \&{$stock_name_corrections{$new}}; 1620 | } 1621 | } 1622 | 1623 | =item * A Perl reimplementation of C is provided. 1624 | 1625 | =cut 1626 | 1627 | sub Gtk3::StyleContext::get { 1628 | my ($context, $state, @properties) = @_; 1629 | my @values = map { $context->get_property ($_, $state) } @properties; 1630 | return @values[0..$#values]; 1631 | } 1632 | 1633 | =item * An override for C is provided that 1634 | automatically handles the conversion of the C argument. 1635 | 1636 | =cut 1637 | 1638 | sub Gtk3::TargetEntry::new { 1639 | my ($class, $target, $flags, $info) = @_; 1640 | if ($flags !~ /^\d+$/) { 1641 | $flags = Glib::Object::Introspection->convert_sv_to_flags ( 1642 | "Gtk3::TargetFlags", $flags) 1643 | } 1644 | return Glib::Object::Introspection->invoke ( 1645 | $_GTK_BASENAME, 'TargetEntry', 'new', $class, $target, $flags, $info); 1646 | } 1647 | 1648 | =item * A Perl reimplementation of C is provided. 1649 | 1650 | =cut 1651 | 1652 | sub Gtk3::TextBuffer::create_tag { 1653 | my ($buffer, $tag_name, @rest) = @_; 1654 | if (@rest % 2) { 1655 | croak ('Usage: $buffer->create_tag ($tag_name, $property1 => $value1, ...'); 1656 | } 1657 | my $tag = Gtk3::TextTag->new ($tag_name); 1658 | my $tag_table = $buffer->get_tag_table; 1659 | $tag_table->add ($tag); 1660 | for (my $i = 0 ; $i < @rest ; $i += 2) { 1661 | $tag->set_property ($rest[$i], $rest[$i+1]); 1662 | } 1663 | return $tag; 1664 | } 1665 | 1666 | =item * The C arguments of C, 1667 | C, C, C, 1668 | C and C are optional. 1669 | 1670 | =cut 1671 | 1672 | sub Gtk3::TextBuffer::insert { 1673 | return Glib::Object::Introspection->invoke ( 1674 | $_GTK_BASENAME, 'TextBuffer', 'insert', 1675 | @_ == 4 ? @_ : (@_[0,1,2], -1)); # wants length in bytes 1676 | } 1677 | 1678 | sub Gtk3::TextBuffer::insert_at_cursor { 1679 | return Glib::Object::Introspection->invoke ( 1680 | $_GTK_BASENAME, 'TextBuffer', 'insert_at_cursor', 1681 | @_ == 3 ? @_ : (@_[0,1], -1)); # wants length in bytes 1682 | } 1683 | 1684 | sub Gtk3::TextBuffer::insert_interactive { 1685 | return Glib::Object::Introspection->invoke ( 1686 | $_GTK_BASENAME, 'TextBuffer', 'insert_interactive', 1687 | @_ == 5 ? @_ : (@_[0,1,2], -1, $_[3])); # wants length in bytes 1688 | } 1689 | 1690 | sub Gtk3::TextBuffer::insert_interactive_at_cursor { 1691 | return Glib::Object::Introspection->invoke ( 1692 | $_GTK_BASENAME, 'TextBuffer', 'insert_interactive_at_cursor', 1693 | @_ == 4 ? @_ : (@_[0,1], -1, $_[2])); # wants length in bytes 1694 | } 1695 | 1696 | sub Gtk3::TextBuffer::insert_markup { 1697 | return Glib::Object::Introspection->invoke ( 1698 | $_GTK_BASENAME, 'TextBuffer', 'insert_markup', 1699 | @_ == 4 ? @_ : (@_[0,1,2], -1)); # wants length in bytes 1700 | } 1701 | 1702 | =item * Perl reimplementations of C and 1703 | C are provided which do not require a C 1704 | argument. 1705 | 1706 | =cut 1707 | 1708 | sub Gtk3::TextBuffer::insert_with_tags { 1709 | my ($buffer, $iter, $text, @tags) = @_; 1710 | my $start_offset = $iter->get_offset; 1711 | $buffer->insert ($iter, $text); 1712 | my $start = $buffer->get_iter_at_offset ($start_offset); 1713 | foreach my $tag (@tags) { 1714 | $buffer->apply_tag ($tag, $start, $iter); 1715 | } 1716 | } 1717 | 1718 | sub Gtk3::TextBuffer::insert_with_tags_by_name { 1719 | my ($buffer, $iter, $text, @tag_names) = @_; 1720 | my $start_offset = $iter->get_offset; 1721 | $buffer->insert ($iter, $text); 1722 | my $tag_table = $buffer->get_tag_table; 1723 | my $start = $buffer->get_iter_at_offset ($start_offset); 1724 | foreach my $tag_name (@tag_names) { 1725 | my $tag = $tag_table->lookup ($tag_name); 1726 | if (!$tag) { 1727 | warn "no tag with name $tag_name"; 1728 | } else { 1729 | $buffer->apply_tag ($tag, $start, $iter); 1730 | } 1731 | } 1732 | } 1733 | 1734 | sub Gtk3::TextBuffer::set_text { 1735 | return Glib::Object::Introspection->invoke ( 1736 | $_GTK_BASENAME, 'TextBuffer', 'set_text', 1737 | @_ == 3 ? @_ : (@_[0,1], -1)); # wants length in bytes 1738 | } 1739 | 1740 | =item * A Perl reimplementation of C is provided. 1741 | 1742 | =cut 1743 | 1744 | sub Gtk3::TreeModel::get { 1745 | my ($model, $iter, @columns) = @_; 1746 | if (!@columns) { 1747 | @columns = (0..($model->get_n_columns-1)); 1748 | } 1749 | my @values = map { $model->get_value ($iter, $_) } @columns; 1750 | return @values[0..$#values]; 1751 | } 1752 | 1753 | =item * A redirect is added from C to 1754 | so that Gtk3::TreeModelFilter objects can be 1755 | constructed normally. 1756 | 1757 | =cut 1758 | 1759 | # Not needed anymore once 1760 | # is fixed. 1761 | sub Gtk3::TreeModelFilter::new { 1762 | my ($class, $child_model, $root) = @_; 1763 | Glib::Object::Introspection->invoke ( 1764 | $_GTK_BASENAME, 'TreeModel', 'filter_new', $child_model, $root); 1765 | } 1766 | 1767 | =item * Gtk3::TreeModelFilter has a C method that calls 1768 | C instead of C. 1769 | 1770 | =cut 1771 | 1772 | # Reroute 'get' to Gtk3::TreeModel instead of Glib::Object. 1773 | sub Gtk3::TreeModelFilter::get { 1774 | return Gtk3::TreeModel::get (@_); 1775 | } 1776 | 1777 | =item * Prior to gtk+ 3.24.14, a redirect is added from 1778 | C to 1779 | so that Gtk3::TreeModelSort objects can 1780 | be constructed normally. 1781 | 1782 | =cut 1783 | 1784 | # Not needed anymore once 1785 | # is fixed. This never happened, but in gtk+ 3.24.14, the return type 1786 | # annotation was changed: . 1787 | sub Gtk3::TreeModelSort::new_with_model { 1788 | if (Gtk3::CHECK_VERSION (3, 24, 14)) { 1789 | Glib::Object::Introspection->invoke ( 1790 | $_GTK_BASENAME, 'TreeModelSort', 'new_with_model', @_); 1791 | } else { 1792 | my ($class, $child_model) = @_; 1793 | Glib::Object::Introspection->invoke ( 1794 | $_GTK_BASENAME, 'TreeModel', 'sort_new_with_model', $child_model); 1795 | } 1796 | } 1797 | 1798 | =item * Gtk3::TreeModelSort has a C method that calls 1799 | C instead of C. 1800 | 1801 | =cut 1802 | 1803 | # Reroute 'get' to Gtk3::TreeModel instead of Glib::Object. 1804 | sub Gtk3::TreeModelSort::get { 1805 | return Gtk3::TreeModel::get (@_); 1806 | } 1807 | 1808 | =item * C redirects to C if an additional 1809 | argument is given. 1810 | 1811 | =cut 1812 | 1813 | sub Gtk3::TreePath::new { 1814 | my ($class, @args) = @_; 1815 | my $method = (@args == 1) ? 'new_from_string' : 'new'; 1816 | Glib::Object::Introspection->invoke ( 1817 | $_GTK_BASENAME, 'TreePath', $method, @_); 1818 | } 1819 | 1820 | =item * A Perl reimplementation of C is 1821 | provided. 1822 | 1823 | =cut 1824 | 1825 | sub Gtk3::TreePath::new_from_indices { 1826 | my ($class, @indices) = @_; 1827 | my $path = Gtk3::TreePath->new; 1828 | foreach (@indices) { 1829 | $path->append_index ($_); 1830 | } 1831 | return $path; 1832 | } 1833 | 1834 | =item * C also accepts a list of type names. 1835 | 1836 | =cut 1837 | 1838 | sub Gtk3::TreeStore::new { 1839 | return _common_tree_model_new ('TreeStore', @_); 1840 | } 1841 | 1842 | =item * Gtk3::TreeStore has a C method that calls C 1843 | instead of C. 1844 | 1845 | =cut 1846 | 1847 | # Reroute 'get' to Gtk3::TreeModel instead of Glib::Object. 1848 | sub Gtk3::TreeStore::get { 1849 | return Gtk3::TreeModel::get (@_); 1850 | } 1851 | 1852 | =item * C also accepts a list of C<< 1853 | column => value >> pairs. 1854 | 1855 | =cut 1856 | 1857 | sub Gtk3::TreeStore::insert_with_values { 1858 | my ($model, $parent, $position, @columns_and_values) = @_; 1859 | my ($columns, $values) = _unpack_keys_and_values (\@columns_and_values); 1860 | if (not defined $columns) { 1861 | croak ("Usage: Gtk3::TreeStore::insert_with_values (\$model, \$parent, \$position, \\\@columns, \\\@values)\n", 1862 | " -or-: Gtk3::TreeStore::insert_with_values (\$model, \$parent, \$position, \$column1 => \$value1, ...)"); 1863 | } 1864 | my @wrapped_values = (); 1865 | foreach my $i (0..$#{$columns}) { 1866 | my $column_type = $model->get_column_type ($columns->[$i]); 1867 | push @wrapped_values, 1868 | Glib::Object::Introspection::GValueWrapper->new ( 1869 | $column_type, $values->[$i]); 1870 | } 1871 | return Glib::Object::Introspection->invoke ( 1872 | $_GTK_BASENAME, 'TreeStore', 'insert_with_values', 1873 | $model, $parent, $position, $columns, \@wrapped_values); 1874 | } 1875 | 1876 | =item * C also accepts a list of C<< column => value >> 1877 | pairs. 1878 | 1879 | =cut 1880 | 1881 | sub Gtk3::TreeStore::set { 1882 | return _common_tree_model_set ('TreeStore', @_); 1883 | } 1884 | 1885 | =item * C redirects to C if an additional 1886 | argument is given. 1887 | 1888 | =cut 1889 | 1890 | sub Gtk3::TreeView::new { 1891 | my ($class, @args) = @_; 1892 | my $method = (@args == 1) ? 'new_with_model' : 'new'; 1893 | Glib::Object::Introspection->invoke ( 1894 | $_GTK_BASENAME, 'TreeView', $method, @_); 1895 | } 1896 | 1897 | =item * A Perl reimplementation of 1898 | C is provided. 1899 | 1900 | =cut 1901 | 1902 | sub Gtk3::TreeView::insert_column_with_attributes { 1903 | my ($tree_view, $position, $title, $cell, @rest) = @_; 1904 | if (@rest % 2) { 1905 | croak ('Usage: $tree_view->insert_column_with_attributes (position, title, cell_renderer, attr1 => col1, ...)'); 1906 | } 1907 | my $column = Gtk3::TreeViewColumn->new; 1908 | my $n = $tree_view->insert_column ($column, $position); 1909 | $column->set_title ($title); 1910 | $column->pack_start ($cell, Glib::TRUE); 1911 | for (my $i = 0; $i < @rest; $i += 2) { 1912 | $column->add_attribute ($cell, $rest[$i], $rest[$i+1]); 1913 | } 1914 | return $n; 1915 | } 1916 | 1917 | =item * A Perl reimplementation of C 1918 | is provided. 1919 | 1920 | =cut 1921 | 1922 | sub Gtk3::TreeViewColumn::new_with_attributes { 1923 | my ($class, $title, $cell, @rest) = @_; 1924 | if (@rest % 2) { 1925 | croak ('Usage: Gtk3::TreeViewColumn->new_with_attributes (title, cell_renderer, attr1 => col1, ...)'); 1926 | } 1927 | my $object = $class->new; 1928 | $object->set_title ($title); 1929 | $object->pack_start ($cell, Glib::TRUE); 1930 | for (my $i = 0; $i < @rest; $i += 2) { 1931 | $object->add_attribute ($cell, $rest[$i], $rest[$i+1]); 1932 | } 1933 | return $object; 1934 | } 1935 | 1936 | =item * Perl reimplementations of C and 1937 | C are provided. 1938 | 1939 | =cut 1940 | 1941 | # Gtk3::TreeViewColumn::set_attributes and Gtk3::CellLayout::set_attributes 1942 | { 1943 | no strict 'refs'; 1944 | foreach my $package (qw/TreeViewColumn CellLayout/) { 1945 | *{'Gtk3::' . $package . '::set_attributes'} = sub { 1946 | my ($object, $cell, @rest) = @_; 1947 | if (@rest % 2) { 1948 | croak ('Usage: $object->set_attributes (cell_renderer, attr1 => col1, ...)'); 1949 | } 1950 | $object->clear_attributes ($cell); 1951 | for (my $i = 0; $i < @rest; $i += 2) { 1952 | $object->add_attribute ($cell, $rest[$i], $rest[$i+1]); 1953 | } 1954 | } 1955 | } 1956 | } 1957 | 1958 | =item * C takes no C argument. 1959 | 1960 | =cut 1961 | 1962 | sub Gtk3::UIManager::add_ui_from_string { 1963 | my ($manager, $string) = @_; 1964 | return Glib::Object::Introspection->invoke ( 1965 | $_GTK_BASENAME, 'UIManager', 'add_ui_from_string', 1966 | $manager, $string, -1); # wants length in bytes 1967 | } 1968 | 1969 | =item * C uses the defaults homogeneous = FALSE and spacing = 1970 | 5. 1971 | 1972 | =cut 1973 | 1974 | sub Gtk3::VBox::new { 1975 | my ($class, $homogeneous, $spacing) = @_; 1976 | $homogeneous = 0 unless defined $homogeneous; 1977 | $spacing = 5 unless defined $spacing; 1978 | return Glib::Object::Introspection->invoke ( 1979 | $_GTK_BASENAME, 'VBox', 'new', $class, $homogeneous, $spacing); 1980 | } 1981 | 1982 | =item * C and C also accept 1983 | strings, array references and C objects for the C 1984 | parameter. 1985 | 1986 | =cut 1987 | 1988 | sub Gtk3::Widget::add_events { 1989 | my ($widget, $events) = @_; 1990 | eval { 1991 | $events = Glib::Object::Introspection->convert_sv_to_flags ( 1992 | 'Gtk3::Gdk::EventMask', $events); 1993 | }; 1994 | return Glib::Object::Introspection->invoke ( 1995 | $_GTK_BASENAME, 'Widget', 'add_events', $widget, $events); 1996 | } 1997 | 1998 | sub Gtk3::Widget::set_events { 1999 | my ($widget, $events) = @_; 2000 | eval { 2001 | $events = Glib::Object::Introspection->convert_sv_to_flags ( 2002 | 'Gtk3::Gdk::EventMask', $events); 2003 | }; 2004 | return Glib::Object::Introspection->invoke ( 2005 | $_GTK_BASENAME, 'Widget', 'set_events', $widget, $events); 2006 | } 2007 | 2008 | =item * C returns a C object 2009 | that can also be compared to numeric values with C<< == >> and C<< >= >>. 2010 | 2011 | =cut 2012 | 2013 | sub Gtk3::Widget::get_events { 2014 | my ($widget) = @_; 2015 | my $events = Glib::Object::Introspection->invoke ( 2016 | $_GTK_BASENAME, 'Widget', 'get_events', $widget); 2017 | return Glib::Object::Introspection->convert_flags_to_sv ( 2018 | 'Gtk3::Gdk::EventMask', $events); 2019 | } 2020 | 2021 | sub Gtk3::Widget::render_icon { 2022 | my ($widget, $stock_id, $size, $detail) = @_; 2023 | Glib::Object::Introspection->invoke ( 2024 | $_GTK_BASENAME, 'Widget', 'render_icon', $widget, $stock_id, 2025 | $_GTK_ICON_SIZE_NICK_TO_ID->($size), $detail); 2026 | } 2027 | 2028 | =item * C and 2029 | C are forwarded to the corresponding 2030 | functions in C. 2031 | 2032 | =cut 2033 | 2034 | sub Gtk3::Widget::find_style_property { 2035 | return Gtk3::WidgetClass::find_style_property (@_); 2036 | } 2037 | 2038 | sub Gtk3::Widget::list_style_properties { 2039 | my $ref = Gtk3::WidgetClass::list_style_properties (@_); 2040 | return if not defined $ref; 2041 | return wantarray ? @$ref : $ref->[$#$ref]; 2042 | } 2043 | 2044 | =item * A Perl reimplementation of C is provided. 2045 | 2046 | =cut 2047 | 2048 | sub Gtk3::Widget::style_get { 2049 | my ($widget, @rest) = @_; 2050 | my $properties = _rest_to_ref (\@rest); 2051 | my @values; 2052 | foreach my $property (@$properties) { 2053 | my $pspec = Gtk3::WidgetClass::find_style_property ($widget, $property); 2054 | croak "Cannot find type information for property '$property' on $widget" 2055 | unless defined $pspec; 2056 | my $value_wrapper = Glib::Object::Introspection::GValueWrapper->new ( 2057 | $pspec->get_value_type, undef); 2058 | $widget->style_get_property ($property, $value_wrapper); 2059 | push @values, $value_wrapper->get_value; 2060 | } 2061 | return @values[0..$#values]; 2062 | } 2063 | 2064 | =item * C uses the default type = 'toplevel'. 2065 | 2066 | =cut 2067 | 2068 | sub Gtk3::Window::new { 2069 | my ($class, $type) = @_; 2070 | $type = 'toplevel' unless defined $type; 2071 | return Glib::Object::Introspection->invoke ( 2072 | $_GTK_BASENAME, 'Window', 'new', $class, $type); 2073 | } 2074 | 2075 | # --- Gdk --- 2076 | 2077 | =item * A constructor C is provided that can be called as 2078 | C<< Gtk3::Gdk::RGBA->new (r, g, b, a) >>. 2079 | 2080 | =cut 2081 | 2082 | sub Gtk3::Gdk::RGBA::new { 2083 | my ($class, @rest) = @_; 2084 | # Handle Gtk3::Gdk::RGBA->new (r, g, b, a) specially. 2085 | if (4 == @rest) { 2086 | my %data; 2087 | @data{qw/red green blue alpha/} = @rest; 2088 | return Glib::Boxed::new ($class, \%data); 2089 | } 2090 | # Fall back to Glib::Boxed::new. 2091 | return Glib::Boxed::new ($class, @rest); 2092 | } 2093 | 2094 | =item * C can be called as a function returning a new 2095 | instance (C<< $rgba = Gtk3::Gdk::RGBA::parse ($spec) >>) or as a method (C<< 2096 | $rgba->parse ($spec) >>). 2097 | 2098 | =cut 2099 | 2100 | sub Gtk3::Gdk::RGBA::parse { 2101 | my $have_instance; 2102 | { 2103 | local $@; 2104 | $have_instance = eval { $_[0]->isa ('Gtk3::Gdk::RGBA') }; 2105 | } 2106 | # This needs to be switched around if/when 2107 | # is fixed. 2108 | if ($have_instance) { 2109 | return Glib::Object::Introspection->invoke ( 2110 | $_GDK_BASENAME, 'RGBA', 'parse', @_); 2111 | } else { 2112 | my $instance = Gtk3::Gdk::RGBA->new; 2113 | my $success = Glib::Object::Introspection->invoke ( 2114 | $_GDK_BASENAME, 'RGBA', 'parse', 2115 | $instance, @_); 2116 | return $success ? $instance : undef; 2117 | } 2118 | } 2119 | 2120 | =item * C optionally computes the C 2121 | automatically from the given C. 2122 | 2123 | =cut 2124 | 2125 | sub Gtk3::Gdk::Window::new { 2126 | my ($class, $parent, $attr, $attr_mask) = @_; 2127 | if (not defined $attr_mask) { 2128 | $attr_mask = Gtk3::Gdk::WindowAttributesType->new ([]); 2129 | if (exists $attr->{title}) { $attr_mask |= 'GDK_WA_TITLE' } 2130 | if (exists $attr->{x}) { $attr_mask |= 'GDK_WA_X' } 2131 | if (exists $attr->{y}) { $attr_mask |= 'GDK_WA_Y' } 2132 | if (exists $attr->{cursor}) { $attr_mask |= 'GDK_WA_CURSOR' } 2133 | if (exists $attr->{visual}) { $attr_mask |= 'GDK_WA_VISUAL' } 2134 | if (exists $attr->{wmclass_name} && exists $attr->{wmclass_class}) { $attr_mask |= 'GDK_WA_WMCLASS' } 2135 | if (exists $attr->{override_redirect}) { $attr_mask |= 'GDK_WA_NOREDIR' } 2136 | if (exists $attr->{type_hint}) { $attr_mask |= 'GDK_WA_TYPE_HINT' } 2137 | if (!Gtk3::CHECK_VERSION (3, 4, 4)) { 2138 | # Before 3.4.4 or 3.5.6, the attribute mask parameter lacked proper 2139 | # annotations, hence we numerify it here. FIXME: This breaks 2140 | # encapsulation. 2141 | $attr_mask = $$attr_mask; 2142 | } 2143 | } 2144 | return Glib::Object::Introspection->invoke ( 2145 | $_GDK_BASENAME, 'Window', 'new', 2146 | $class, $parent, $attr, $attr_mask); 2147 | } 2148 | 2149 | # --- GdkPixbuf --- 2150 | 2151 | sub Gtk3::Gdk::Pixbuf::CHECK_VERSION { 2152 | my ($major, $minor, $micro) = @_; 2153 | return 2154 | (Gtk3::Gdk::PIXBUF_MAJOR () > $major) || 2155 | (Gtk3::Gdk::PIXBUF_MAJOR () == $major && Gtk3::Gdk::PIXBUF_MINOR () > $minor) || 2156 | (Gtk3::Gdk::PIXBUF_MAJOR () == $major && Gtk3::Gdk::PIXBUF_MINOR () == $minor && Gtk3::Gdk::PIXBUF_MICRO () >= $micro); 2157 | } 2158 | 2159 | =item * C returns a byte string. 2160 | 2161 | =cut 2162 | 2163 | sub Gtk3::Gdk::Pixbuf::get_pixels { 2164 | my $pixel_aref = Glib::Object::Introspection->invoke ( 2165 | $_GDK_PIXBUF_BASENAME, 'Pixbuf', 'get_pixels', @_); 2166 | return pack 'C*', @{$pixel_aref}; 2167 | } 2168 | 2169 | =item * C is reimplemented in terms of 2170 | C (with gdk-pixbuf >= 2.32) or C (with 2171 | gtk-pixbuf < 2.32) for correct memory management. No C and 2172 | C arguments are needed. 2173 | 2174 | =cut 2175 | 2176 | sub Gtk3::Gdk::Pixbuf::new_from_data { 2177 | my ($class, $data, $colorspace, $has_alpha, $bits_per_sample, $width, $height, $rowstride) = @_; 2178 | if (Gtk3::Gdk::Pixbuf::CHECK_VERSION (2, 32, 0)) { 2179 | my $packed_data = ref($data) eq 'ARRAY' ? pack 'C*', @$data : $data; 2180 | return Gtk3::Gdk::Pixbuf->new_from_bytes( 2181 | Glib::Bytes->new($packed_data), 2182 | $colorspace, $has_alpha, 2183 | $bits_per_sample, $width, 2184 | $height, $rowstride); 2185 | } else { 2186 | die 'Only RGB is currently supported' unless $colorspace eq 'rgb'; 2187 | die 'Only 8 bits per pixel are currently supported' 2188 | unless $bits_per_sample == 8; 2189 | my $length = Gtk3::Gdk::PIXDATA_HEADER_LENGTH () + 2190 | $rowstride*$height; 2191 | my $type = Gtk3::Gdk::PixdataType->new ([qw/sample_width_8 encoding_raw/]); 2192 | $type |= $has_alpha ? 'color_type_rgba' : 'color_type_rgb'; 2193 | my @header_numbers = (0x47646b50, 2194 | $length, 2195 | $$type, # FIXME: This kind of breaks encapsulation. 2196 | $rowstride, 2197 | $width, 2198 | $height); 2199 | # Convert to 8 bit unsigned chars, padding to 32 bit little-endian first. 2200 | my @header = map { unpack ("C*", pack ("N", $_)) } @header_numbers; 2201 | my $inline_data = _unpack_unless_array_ref ($data); 2202 | unshift @$inline_data, @header; 2203 | return Gtk3::Gdk::Pixbuf->new_from_inline ($inline_data); 2204 | } 2205 | } 2206 | 2207 | =item * C does not take a C 2208 | argument. It is always set to TRUE for correct memory management. 2209 | 2210 | =cut 2211 | 2212 | sub Gtk3::Gdk::Pixbuf::new_from_inline { 2213 | my ($class, $data) = @_; 2214 | return Glib::Object::Introspection->invoke ( 2215 | $_GDK_PIXBUF_BASENAME, 'Pixbuf', 'new_from_inline', 2216 | $class, _unpack_unless_array_ref ($data), Glib::TRUE); # always copy pixels 2217 | } 2218 | 2219 | =item * C also accepts a list of XPM 2220 | lines. 2221 | 2222 | =cut 2223 | 2224 | sub Gtk3::Gdk::Pixbuf::new_from_xpm_data { 2225 | my ($class, @rest) = @_; 2226 | my $data = _rest_to_ref (\@rest); 2227 | return Glib::Object::Introspection->invoke ( 2228 | $_GDK_PIXBUF_BASENAME, 'Pixbuf', 'new_from_xpm_data', 2229 | $class, $data); 2230 | } 2231 | 2232 | # Version check for the new annotations described in 2233 | # . 2234 | my $_GET_SAVE_VARIANT = sub { 2235 | my ($method) = @_; 2236 | if (Gtk3::Gdk::Pixbuf::CHECK_VERSION (2, 31, 3)) { 2237 | return $method . 'v'; 2238 | } elsif (Gtk3::Gdk::Pixbuf::CHECK_VERSION (2, 31, 2)) { 2239 | return $method; 2240 | } else { 2241 | return $method . 'v'; 2242 | } 2243 | }; 2244 | 2245 | =item * C, C and C 2246 | also accept C<< key => value >> pairs and invoke the correct C function as 2247 | appropriate for the current gdk-pixbuf version. 2248 | 2249 | =cut 2250 | 2251 | sub Gtk3::Gdk::Pixbuf::save { 2252 | my ($pixbuf, $filename, $type, @rest) = @_; 2253 | my ($keys, $values) = _unpack_keys_and_values (\@rest); 2254 | if (not defined $keys) { 2255 | croak ("Usage: \$pixbuf->save (\$filename, \$type, \\\@keys, \\\@values)\n", 2256 | " -or-: \$pixbuf->save (\$filename, \$type, \$key1 => \$value1, ...)"); 2257 | } 2258 | my $method = $_GET_SAVE_VARIANT->('save'); 2259 | Glib::Object::Introspection->invoke ( 2260 | $_GDK_PIXBUF_BASENAME, 'Pixbuf', $method, 2261 | $pixbuf, $filename, $type, $keys, $values); 2262 | } 2263 | 2264 | sub Gtk3::Gdk::Pixbuf::save_to_buffer { 2265 | my ($pixbuf, $type, @rest) = @_; 2266 | my ($keys, $values) = _unpack_keys_and_values (\@rest); 2267 | if (not defined $keys) { 2268 | croak ("Usage: \$pixbuf->save_to_buffer (\$type, \\\@keys, \\\@values)\n", 2269 | " -or-: \$pixbuf->save_to_buffer (\$type, \$key1 => \$value1, ...)"); 2270 | } 2271 | my $method = $_GET_SAVE_VARIANT->('save_to_buffer'); 2272 | my (undef, $buffer) = 2273 | Glib::Object::Introspection->invoke ( 2274 | $_GDK_PIXBUF_BASENAME, 'Pixbuf', $method, 2275 | $pixbuf, $type, $keys, $values); 2276 | return $buffer; 2277 | } 2278 | 2279 | sub Gtk3::Gdk::Pixbuf::save_to_callback { 2280 | my ($pixbuf, $save_func, $user_data, $type, @rest) = @_; 2281 | my ($keys, $values) = _unpack_keys_and_values (\@rest); 2282 | if (not defined $keys) { 2283 | croak ("Usage: \$pixbuf->save_to_callback (\$save_func, \$user_data, \$type, \\\@keys, \\\@values)\n", 2284 | " -or-: \$pixbuf->save_to_callback (\$save_func, \$user_data, \$type, \$key1 => \$value1, ...)"); 2285 | } 2286 | my $method = $_GET_SAVE_VARIANT->('save_to_callback'); 2287 | Glib::Object::Introspection->invoke ( 2288 | $_GDK_PIXBUF_BASENAME, 'Pixbuf', $method, 2289 | $pixbuf, $save_func, $user_data, $type, $keys, $values); 2290 | } 2291 | 2292 | # --- Pango --- 2293 | 2294 | =item * The C arguments of C and C 2295 | are optional. 2296 | 2297 | =cut 2298 | 2299 | sub Pango::Layout::set_text { 2300 | return Glib::Object::Introspection->invoke ( 2301 | $_PANGO_BASENAME, 'Layout', 'set_text', 2302 | @_ == 3 ? @_ : (@_[0,1], -1)); # wants length in bytes 2303 | } 2304 | 2305 | sub Pango::Layout::set_markup { 2306 | return Glib::Object::Introspection->invoke ( 2307 | $_PANGO_BASENAME, 'Layout', 'set_markup', 2308 | @_ == 3 ? @_ : (@_[0,1], -1)); # wants length in bytes 2309 | } 2310 | 2311 | =back 2312 | 2313 | =cut 2314 | 2315 | # - Fixes ------------------------------------------------------------------- # 2316 | 2317 | =head2 Perl compatibility 2318 | 2319 | As of 5.20.0, perl does not automatically re-check the locale environment for 2320 | changes. If a function thus changes the locale behind perl's back, problems 2321 | might arise whenever numbers are formatted, for example when checking versions. 2322 | To ensure perl's assumption about the locale are up-to-date, the functions 2323 | C, C, C and C are amended 2324 | to let perl know of any changes. 2325 | 2326 | =cut 2327 | 2328 | # Compatibility with perl 5.20 and non-dot locales. Wrap all functions that 2329 | # might end up calling setlocale() such that POSIX::setlocale() is also called 2330 | # to ensure perl knows about the current locale. See the discussion in 2331 | # , 2332 | # , 2333 | # . 2334 | if ($^V ge v5.20.0) { 2335 | require POSIX; 2336 | no strict 'refs'; 2337 | no warnings 'redefine'; 2338 | 2339 | my $disable_setlocale = 0; 2340 | *{'Gtk3::disable_setlocale'} = sub { 2341 | $disable_setlocale = 1; 2342 | Glib::Object::Introspection->invoke ( 2343 | $_GTK_BASENAME, undef, 'disable_setlocale', @_); 2344 | }; 2345 | 2346 | # These two already have overrides. 2347 | foreach my $function (qw/Gtk3::init Gtk3::init_check/) { 2348 | my $orig = \&{$function}; 2349 | *{$function} = sub { 2350 | if (!$disable_setlocale) { 2351 | POSIX::setlocale (POSIX::LC_ALL (), ''); 2352 | } 2353 | $orig->(@_); 2354 | }; 2355 | } 2356 | 2357 | foreach my $function (qw/init_with_args parse_args/) { 2358 | *{'Gtk3::' . $function} = sub { 2359 | if (!$disable_setlocale) { 2360 | POSIX::setlocale (POSIX::LC_ALL (), ''); 2361 | } 2362 | Glib::Object::Introspection->invoke ( 2363 | $_GTK_BASENAME, undef, $function, @_); 2364 | }; 2365 | } 2366 | } 2367 | 2368 | # - Helpers ----------------------------------------------------------------- # 2369 | 2370 | sub _common_tree_model_new { 2371 | my ($package, $class, @types) = @_; 2372 | my $real_types; 2373 | { 2374 | local $@; 2375 | $real_types = (@types == 1 && eval { @{$types[0]} }) 2376 | ? $types[0] 2377 | : \@types; 2378 | } 2379 | return Glib::Object::Introspection->invoke ( 2380 | $_GTK_BASENAME, $package, 'new', 2381 | $class, $real_types); 2382 | } 2383 | 2384 | sub _common_tree_model_set { 2385 | my ($package, $model, $iter, @columns_and_values) = @_; 2386 | my ($columns, $values) = _unpack_keys_and_values (\@columns_and_values); 2387 | if (not defined $columns) { 2388 | croak ("Usage: Gtk3::${package}::set (\$model, \$iter, \\\@columns, \\\@values)\n", 2389 | " -or-: Gtk3::${package}::set (\$model, \$iter, \$column1 => \$value1, ...)"); 2390 | } 2391 | my @wrapped_values = (); 2392 | foreach my $i (0..$#{$columns}) { 2393 | my $column_type = $model->get_column_type ($columns->[$i]); 2394 | push @wrapped_values, 2395 | Glib::Object::Introspection::GValueWrapper->new ( 2396 | $column_type, $values->[$i]); 2397 | } 2398 | Glib::Object::Introspection->invoke ( 2399 | $_GTK_BASENAME, $package, 'set', 2400 | $model, $iter, $columns, \@wrapped_values); 2401 | } 2402 | 2403 | sub _unpack_keys_and_values { 2404 | my ($keys_and_values) = @_; 2405 | my (@keys, @values); 2406 | my $have_array_refs; 2407 | { 2408 | local $@; 2409 | $have_array_refs = 2410 | @$keys_and_values == 2 && eval { @{$keys_and_values->[0]} }; 2411 | } 2412 | if ($have_array_refs) { 2413 | @keys = @{$keys_and_values->[0]}; 2414 | @values = @{$keys_and_values->[1]}; 2415 | } elsif (@$keys_and_values % 2 == 0) { 2416 | # To preserve the order of the key-value pairs, avoid creating an 2417 | # intermediate hash. 2418 | my @range = 0 .. (@$keys_and_values/2-1); 2419 | @keys = @$keys_and_values[map { 2*$_ } @range]; 2420 | @values = @$keys_and_values[map { 2*$_+1 } @range]; 2421 | } else { 2422 | return (); 2423 | } 2424 | return (\@keys, \@values); 2425 | } 2426 | 2427 | sub _unpack_unless_array_ref { 2428 | my ($data) = @_; 2429 | local $@; 2430 | return eval { @{$data} } 2431 | ? $data 2432 | : [unpack 'C*', $data]; 2433 | } 2434 | 2435 | sub _rest_to_ref { 2436 | my ($rest) = @_; 2437 | local $@; 2438 | if (scalar @$rest == 1 && eval { defined $rest->[0]->[0] }) { 2439 | return $rest->[0]; 2440 | } else { 2441 | return $rest; 2442 | } 2443 | } 2444 | 2445 | package Gtk3::Gdk::EventMask; 2446 | 2447 | use overload 2448 | '==' => \&eq, 2449 | '>=' => \≥ 2450 | use Scalar::Util qw/looks_like_number/; 2451 | 2452 | my $_convert_one = sub { 2453 | return Glib::Object::Introspection->convert_flags_to_sv ( 2454 | 'Gtk3::Gdk::EventMask', $_[0]); 2455 | }; 2456 | 2457 | my $_convert_two = sub { 2458 | my ($a, $b) = @_; 2459 | if (looks_like_number ($a)) { 2460 | $a = $_convert_one->($a); 2461 | } 2462 | if (looks_like_number ($b)) { 2463 | $b = $_convert_one->($b); 2464 | } 2465 | return ($a, $b); 2466 | }; 2467 | 2468 | sub eq { 2469 | my ($a, $b, $swap) = @_; 2470 | ($a, $b) = $_convert_two->($a, $b); 2471 | return Glib::Flags::eq ($a, $b, $swap); 2472 | } 2473 | 2474 | sub ge { 2475 | my ($a, $b, $swap) = @_; 2476 | ($a, $b) = $_convert_two->($a, $b); 2477 | return Glib::Flags::ge ($a, $b, $swap); 2478 | } 2479 | 2480 | package Gtk3; 2481 | 2482 | 1; 2483 | 2484 | __END__ 2485 | 2486 | =head2 Porting from Gtk2 to Gtk3 2487 | 2488 | The majority of the API has not changed, so as a first approximation you can 2489 | run C<< s/Gtk2/Gtk3/ >> on your application. A big exception to this rule is 2490 | APIs that were deprecated in gtk+ 2.x -- these were all removed from gtk+ 3.0 2491 | and thus from L. The migration guide at 2492 | L describes what to use 2493 | instead. Apart from this, here is a list of some other incompatible 2494 | differences between L and L: 2495 | 2496 | =over 2497 | 2498 | =item * The call syntax for class-static methods is now always 2499 | C<< Gtk3::Stock::lookup >> instead of C<< Gtk3::Stock->lookup >>. 2500 | 2501 | =item * The %Gtk2::Gdk::Keysyms hash is gone; instead of C<< 2502 | Gtk2::Gdk::Keysyms{XYZ} >>, use C<< Gtk3::Gdk::KEY_XYZ >>. 2503 | 2504 | =item * The Gtk2::Pango compatibility wrapper was not carried over; simply use 2505 | the namespace "Pango" everywhere. It gets set up automatically when loading 2506 | L. 2507 | 2508 | =item * The types Gtk3::Allocation and Gtk3::Gdk::Rectangle are now aliases for 2509 | Cairo::RectangleInt, and as such they are represented as plain hashes with 2510 | keys 'width', 'height', 'x' and 'y'. 2511 | 2512 | =item * Gtk3::Editable: Callbacks connected to the "insert-text" signal do not 2513 | have as many options anymore as they had in Gtk2. Changes to arguments will 2514 | not be propagated to the next signal handler, and only the updated position can 2515 | and must be returned. 2516 | 2517 | =item * Gtk3::Menu: In gtk+ < 3.16, the position callback passed to popup() 2518 | does not receive x and y parameters. 2519 | 2520 | =item * Gtk3::RadioAction: The constructor now follows the C API. 2521 | 2522 | =item * Gtk3::TreeModel: iter_next() is now a method that is modifying the iter 2523 | directly, instead of returning a new one. rows_reordered() and the 2524 | "rows-reordered" signal are currently unusable. 2525 | 2526 | =item * Gtk3::TreeSelection: get_selected_rows() now returns two values: an 2527 | array ref containing the selected paths, and the model. get_user_data() is not 2528 | available currently. 2529 | 2530 | =item * Gtk3::TreeSortable: get_sort_column_id() has an additional boolean 2531 | return value. 2532 | 2533 | =item * Gtk3::TreeStore, Gtk3::ListStore: reorder() is currently unusable. 2534 | 2535 | =item * Gtk3::Widget: grab_add() and grab_remove() are methods now: C<< 2536 | $widget->grab_add >>, C<< $widget->grab_remove >>. 2537 | 2538 | =item * Gtk3::Gdk::Atom: The constructor new() is not provided anymore, and the 2539 | class function intern() must now be called as C<< Gtk3::Gdk::Atom::intern 2540 | (name, only_if_exists) >>. 2541 | 2542 | =item * Implementations of Gtk3::TreeModel: Gtk3::TreeIter now has a 2543 | constructor called new() expecting C<< key => value >> pairs; 2544 | new_from_arrayref() does not exist anymore. To access the contents of 2545 | Gtk3::TreeIter, use stamp(), user_data(), user_data2() and user_data3(); 2546 | to_arrayref() does not exist anymore. GET_ITER(), ITER_CHILDREN(), 2547 | ITER_NTH_CHILD() and ITER_PARENT() must return an additional boolean value. 2548 | ITER_NEXT() must modify the iter and return a boolean rather than return a new 2549 | iter. GET_VALUE() must return the value wrapped with C<< 2550 | Glib::Object::Introspection::GValueWrapper->new >>. 2551 | 2552 | =item * Implementations of Gtk3::CellLayout: GET_CELLS() now needs to return an 2553 | array ref instead of a list. 2554 | 2555 | =back 2556 | 2557 | Note also that Gtk3::CHECK_VERSION will always fail when passed 2.y.z, so if 2558 | you have any existing version checks in your code, you will most likely need to 2559 | remove them. 2560 | 2561 | =head1 SEE ALSO 2562 | 2563 | =over 2564 | 2565 | =item * To discuss Gtk3 and ask questions join gtk-perl-list@gnome.org at 2566 | L. 2567 | 2568 | =item * Also have a look at the gtk2-perl website and sourceforge project page, 2569 | L. 2570 | 2571 | =item * L 2572 | 2573 | =item * L 2574 | 2575 | =back 2576 | 2577 | =head1 AUTHORS 2578 | 2579 | =over 2580 | 2581 | =item Torsten Schönfeld 2582 | 2583 | =back 2584 | 2585 | =head1 COPYRIGHT AND LICENSE 2586 | 2587 | Copyright (C) 2011-2015 by Torsten Schoenfeld 2588 | 2589 | This library is free software; you can redistribute it and/or modify it under 2590 | the terms of the GNU Library General Public License as published by the Free 2591 | Software Foundation; either version 2.1 of the License, or (at your option) any 2592 | later version. 2593 | 2594 | =cut 2595 | --------------------------------------------------------------------------------