[perl-Gtk3] Add overrides for Gtk3::Builder and implement its connect_signals

[Torsten SchÃnfeld <tsch src gnome org>]

commit 00a8b7bd9faf37ddbc2aaaf4da4062a6dee32de4
Author: Torsten SchÃnfeld <kaffeetisch gmx de>
Date:   Sun Apr 1 17:34:17 2012 +0200

    Add overrides for Gtk3::Builder and implement its connect_signals

 NEWS              |    2 +
 lib/Gtk3.pm       |  130 +++++++++++++++++++++++++++---
 t/zz-GtkBuilder.t |  232 +++++++++++++++++++++++++++++++++++++++++++++++++++++
 3 files changed, 352 insertions(+), 12 deletions(-)
---
diff --git a/NEWS b/NEWS
index a680a62..48aa679 100644
--- a/NEWS
+++ b/NEWS
@@ -1,5 +1,7 @@
 {{$NEXT}}
 
+* Add overrides for Gtk3::Builder and implement its connect_signals.
+
 Overview of changes in Gtk3 0.004 [2012-03-18]
 ==============================================
 
diff --git a/lib/Gtk3.pm b/lib/Gtk3.pm
index 53ffb5c..b7eb5bb 100644
--- a/lib/Gtk3.pm
+++ b/lib/Gtk3.pm
@@ -12,6 +12,18 @@ my $_GTK_BASENAME = 'Gtk';
 my $_GTK_VERSION = '3.0';
 my $_GTK_PACKAGE = 'Gtk3';
 
+my $_GDK_BASENAME = 'Gdk';
+my $_GDK_VERSION = '3.0';
+my $_GDK_PACKAGE = 'Gtk3::Gdk';
+
+my $_GDK_PIXBUF_BASENAME = 'GdkPixbuf';
+my $_GDK_PIXBUF_VERSION = '2.0';
+my $_GDK_PIXBUF_PACKAGE = 'Gtk3::Gdk';
+
+my $_PANGO_BASENAME = 'Pango';
+my $_PANGO_VERSION = '1.0';
+my $_PANGO_PACKAGE = 'Pango';
+
 my %_GTK_NAME_CORRECTIONS = (
   'Gtk3::stock_add' => 'Gtk3::Stock::add',
   'Gtk3::stock_add_static' => 'Gtk3::Stock::add_static',
@@ -20,6 +32,7 @@ my %_GTK_NAME_CORRECTIONS = (
   'Gtk3::stock_set_translate_func' => 'Gtk3::Stock::set_translate_func',
 );
 my @_GTK_FLATTEN_ARRAY_REF_RETURN_FOR = qw/
+  Gtk3::Builder::get_objects
   Gtk3::CellLayout::get_cells
   Gtk3::Stock::list_ids
   Gtk3::TreePath::get_indices
@@ -42,18 +55,6 @@ my @_GDK_PIXBUF_FLATTEN_ARRAY_REF_RETURN_FOR = qw/
   Gtk3::Gdk::Pixbuf::get_formats
 /;
 
-my $_GDK_BASENAME = 'Gdk';
-my $_GDK_VERSION = '3.0';
-my $_GDK_PACKAGE = 'Gtk3::Gdk';
-
-my $_GDK_PIXBUF_BASENAME = 'GdkPixbuf';
-my $_GDK_PIXBUF_VERSION = '2.0';
-my $_GDK_PIXBUF_PACKAGE = 'Gtk3::Gdk';
-
-my $_PANGO_BASENAME = 'Pango';
-my $_PANGO_VERSION = '1.0';
-my $_PANGO_PACKAGE = 'Pango';
-
 sub import {
   my $class = shift;
 
@@ -137,6 +138,101 @@ sub Gtk3::main_quit {
   Glib::Object::Introspection->invoke ($_GTK_BASENAME, undef, 'main_quit');
 }
 
+sub Gtk3::Builder::add_objects_from_file {
+  my ($builder, $filename, @rest) = @_;
+  my $ref = _rest_to_ref (\ rest);
+  return Glib::Object::Introspection->invoke (
+    $_GTK_BASENAME, 'Builder', 'add_objects_from_file',
+    $builder, $filename, $ref);
+}
+
+sub Gtk3::Builder::add_objects_from_string {
+  my ($builder, $string, @rest) = @_;
+  my $ref = _rest_to_ref (\ rest);
+  return Glib::Object::Introspection->invoke (
+    $_GTK_BASENAME, 'Builder', 'add_objects_from_string',
+    $builder, $string, length $string, $ref);
+}
+
+sub Gtk3::Builder::add_from_string {
+  my ($builder, $string) = @_;
+  return Glib::Object::Introspection->invoke (
+    $_GTK_BASENAME, 'Builder', 'add_from_string',
+    $builder, $string, length $string);
+}
+
+# Copied from Gtk2.pm
+sub Gtk3::Builder::connect_signals {
+  my $builder = shift;
+  my $user_data = shift;
+
+  my $do_connect = sub {
+    my ($object,
+        $signal_name,
+        $user_data,
+        $connect_object,
+        $flags,
+        $handler) = @_;
+    my $func = ($flags & 'after') ? 'signal_connect_after' : 'signal_connect';
+    # we get connect_object when we're supposed to call
+    # signal_connect_object, which ensures that the data (an object)
+    # lives as long as the signal is connected.  the bindings take
+    # care of that for us in all cases, so we only have signal_connect.
+    # if we get a connect_object, just use that instead of user_data.
+    $object->$func($signal_name => $handler,
+                   $connect_object ? $connect_object : $user_data);
+  };
+
+  # $builder->connect_signals ($user_data)
+  # $builder->connect_signals ($user_data, $package)
+  if ($#_ <= 0) {
+    my $package = shift;
+    $package = caller unless defined $package;
+
+    $builder->connect_signals_full(sub {
+      my ($builder,
+          $object,
+          $signal_name,
+          $handler_name,
+          $connect_object,
+          $flags) = @_;
+
+      no strict qw/refs/;
+
+      my $handler = $handler_name;
+      if (ref $package) {
+        $handler = sub { $package->$handler_name(@_) };
+      } else {
+        if ($package && $handler !~ /::/) {
+          $handler = $package.'::'.$handler_name;
+        }
+      }
+
+      $do_connect->($object, $signal_name, $user_data, $connect_object,
+                    $flags, $handler);
+    });
+  }
+
+  # $builder->connect_signals ($user_data, %handlers)
+  else {
+    my %handlers = @_;
+
+    $builder->connect_signals_full(sub {
+      my ($builder,
+          $object,
+          $signal_name,
+          $handler_name,
+          $connect_object,
+          $flags) = @_;
+
+      return unless exists $handlers{$handler_name};
+
+      $do_connect->($object, $signal_name, $user_data, $connect_object,
+                    $flags, $handlers{$handler_name});
+    });
+  }
+}
+
 sub Gtk3::Button::new {
   my ($class, $label) = @_;
   if (defined $label) {
@@ -452,6 +548,16 @@ sub _unpack_columns_and_values {
   return (\ columns, \ values);
 }
 
+sub _rest_to_ref {
+  my ($rest) = @_;
+  local $@;
+  if (scalar @$rest == 1 && eval { defined $rest->[0]->[0] }) {
+    return $rest->[0];
+  } else {
+    return $rest;
+  }
+}
+
 1;
 
 __END__
diff --git a/t/zz-GtkBuilder.t b/t/zz-GtkBuilder.t
new file mode 100644
index 0000000..7dc31a0
--- /dev/null
+++ b/t/zz-GtkBuilder.t
@@ -0,0 +1,232 @@
+#!/usr/bin/perl
+
+# Copied from Gtk2/t/GtkBuilder.t
+
+BEGIN { require './t/inc/setup.pl' }
+
+use strict;
+use warnings;
+
+plan tests => 45;
+
+my $builder;
+my $ui = <<EOD;
+<interface>
+  <object class="GtkAdjustment" id="adjustment1">
+    <property name="lower">0</property>
+    <property name="upper">5</property>
+    <property name="step-increment">1</property>
+    <property name="value">5</property>
+  </object>
+  <object class="GtkSpinButton" id="spinbutton1">
+    <property name="visible">True</property>
+    <property name="adjustment">adjustment1</property>
+    <signal name="value-changed" handler="value_changed" object="adjustment1" after="yes"/>
+    <signal name="wrapped" handler="wrapped"/>
+  </object>
+</interface>
+EOD
+
+# --------------------------------------------------------------------------- #
+
+my $ui_file = 'tmp.ui';
+
+open my $fh, '>', $ui_file or plan skip_all => 'unable to create ui file';
+print $fh $ui;
+close $fh;
+
+$builder = Gtk3::Builder->new;
+isa_ok ($builder, 'Gtk3::Builder');
+
+eval {
+  $builder->add_from_file ('bla.ui');
+};
+like ($@, qr/bla\.ui/);
+
+eval {
+  ok ($builder->add_from_file ($ui_file) > 0);
+};
+is ($@, '');
+isa_ok ($builder->get_object ('adjustment1'), 'Gtk3::Adjustment');
+
+$builder->set_translation_domain (undef);
+is ($builder->get_translation_domain, undef);
+$builder->set_translation_domain ('de');
+is ($builder->get_translation_domain, 'de');
+
+{
+  my $builder = Gtk3::Builder->new;
+  eval {
+    ok ($builder->add_objects_from_file ($ui_file, qw/adjustment1 spinbutton1/));
+  };
+  is ($@, '');
+  ok (defined $builder->get_object ('adjustment1') &&
+      defined $builder->get_object ('spinbutton1'));
+
+  eval {
+    $builder->add_objects_from_file ('bla.ui', qw/adjustment1 spinbutton1/);
+  };
+  like ($@, qr/bla\.ui/);
+
+  $builder = Gtk3::Builder->new;
+  eval {
+    ok ($builder->add_objects_from_string ($ui, qw/adjustment1 spinbutton1/));
+  };
+  is ($@, '');
+  ok (defined $builder->get_object ('adjustment1') &&
+      defined $builder->get_object ('spinbutton1'));
+
+  eval {
+    $builder->add_objects_from_string ('<bla>', qw/adjustment1 spinbutton1/);
+  };
+  like ($@, qr/bla/);
+}
+
+unlink $ui_file;
+
+# --------------------------------------------------------------------------- #
+
+$builder = Gtk3::Builder->new;
+
+eval {
+  $builder->add_from_string ('<bla>');
+};
+like ($@, qr/bla/);
+
+eval {
+  ok ($builder->add_from_string ($ui) > 0);
+};
+is ($@, '');
+my @objects = sort { ref $a cmp ref $b } $builder->get_objects;
+isa_ok ($objects[0], 'Gtk3::Adjustment');
+isa_ok ($objects[1], 'Gtk3::SpinButton');
+
+$builder->connect_signals_full(sub {
+  my ($builder,
+      $object,
+      $signal_name,
+      $handler_name,
+      $connect_object,
+      $flags,
+      $data) = @_;
+
+  if ($signal_name ne 'value-changed') {
+    return;
+  }
+
+  isa_ok ($builder, 'Gtk3::Builder');
+  isa_ok ($object, 'Gtk3::SpinButton');
+  is ($signal_name, 'value-changed');
+  is ($handler_name, 'value_changed');
+  isa_ok ($connect_object, 'Gtk3::Adjustment');
+  ok ($flags == [ qw/after swapped/ ]);
+  is ($data, 'data');
+}, 'data');
+
+# --------------------------------------------------------------------------- #
+
+package BuilderTestCaller;
+
+use Test::More; # for is(), isa_ok(), etc.
+use Glib qw/:constants/;
+
+sub value_changed {
+  my ($spin, $data) = @_;
+
+  isa_ok ($spin, 'Gtk3::SpinButton');
+  isa_ok ($data, 'Gtk3::Adjustment');
+}
+
+sub wrapped {
+  my ($spin, $data) = @_;
+
+  isa_ok ($spin, 'Gtk3::SpinButton');
+  is ($data, '!alb');
+}
+
+$builder = Gtk3::Builder->new;
+$builder->add_from_string ($ui);
+$builder->connect_signals ('!alb');
+
+my $spin = $builder->get_object ('spinbutton1');
+$spin->set_wrap (TRUE);
+$spin->spin ('step-forward', 1);
+
+# --------------------------------------------------------------------------- #
+
+package BuilderTest;
+
+use Test::More; # for is(), isa_ok(), etc.
+use Glib qw/:constants/;
+
+sub value_changed {
+  my ($spin, $data) = @_;
+
+  isa_ok ($spin, 'Gtk3::SpinButton');
+  isa_ok ($data, 'Gtk3::Adjustment');
+}
+
+sub wrapped {
+  my ($spin, $data) = @_;
+
+  isa_ok ($spin, 'Gtk3::SpinButton');
+  is ($data, 'bla!');
+}
+
+$builder = Gtk3::Builder->new;
+$builder->add_from_string ($ui);
+$builder->connect_signals ('bla!', 'BuilderTest');
+
+$spin = $builder->get_object ('spinbutton1');
+$spin->set_wrap (TRUE);
+$spin->spin ('step-forward', 1);
+
+# --------------------------------------------------------------------------- #
+
+package BuilderTestOO;
+
+use Test::More; # for is(), isa_ok(), etc.
+use Glib qw/:constants/;
+
+sub value_changed {
+  my ($self, $spin, $data) = @_;
+
+  is ($self->{answer}, 42);
+  isa_ok ($spin, 'Gtk3::SpinButton');
+  isa_ok ($data, 'Gtk3::Adjustment');
+}
+
+sub wrapped {
+  my ($self, $spin, $data) = @_;
+
+  is ($self->{answer}, 42);
+  isa_ok ($spin, 'Gtk3::SpinButton');
+  is ($data, 'bla!');
+}
+
+my $self = bless { answer => 42 }, 'BuilderTestOO';
+
+$builder = Gtk3::Builder->new;
+$builder->add_from_string ($ui);
+$builder->connect_signals ('bla!', $self);
+
+$spin = $builder->get_object ('spinbutton1');
+$spin->set_wrap (TRUE);
+$spin->spin ('step-forward', 1);
+
+# --------------------------------------------------------------------------- #
+
+$builder = Gtk3::Builder->new;
+$builder->add_from_string ($ui);
+$builder->connect_signals ('!alb',
+  value_changed => \&BuilderTest::value_changed,
+  wrapped => \&BuilderTestCaller::wrapped
+);
+
+$spin = $builder->get_object ('spinbutton1');
+$spin->set_wrap (TRUE);
+$spin->spin ('step-forward', 1);
+
+__END__
+
+Copyright (C) 2007 by the gtk2-perl team