Index: gtk2perl.h =================================================================== --- gtk2perl.h (revision 2134) +++ gtk2perl.h (working copy) @@ -1,6 +1,6 @@ /* * - * Copyright (C) 2003-2004 by the gtk2-perl team (see the file AUTHORS for the + * Copyright (C) 2003-2004, 2009 by the gtk2-perl team (see the file AUTHORS for the * full list) * * This library is free software; you can redistribute it and/or modify it @@ -30,6 +30,12 @@ #include "gtk2perl-versions.h" +/* custom GType for GtkBindingSet */ +#ifndef GTK_TYPE_BINDING_SET +# define GTK_TYPE_BINDING_SET (gtk2perl_binding_set_get_type ()) + GType gtk2perl_binding_set_get_type (void) G_GNUC_CONST; +#endif + /* custom GType for GdkRegion */ #ifndef GDK_TYPE_REGION # define GDK_TYPE_REGION (gtk2perl_gdk_region_get_type ()) Index: MANIFEST =================================================================== --- MANIFEST (revision 2134) +++ MANIFEST (working copy) @@ -152,6 +152,7 @@ t/GtkAspectFrame.t t/GtkAssistant.t t/GtkBin.t +t/GtkBindings.t t/GtkBox.t t/GtkBuildable.t t/GtkBuildableIface.t @@ -373,6 +374,7 @@ xs/GtkAspectFrame.xs xs/GtkAssistant.xs xs/GtkBin.xs +xs/GtkBindings.xs xs/GtkBox.xs xs/GtkBuildable.xs xs/GtkBuilder.xs Index: xs_files-2.0 =================================================================== --- xs_files-2.0 (revision 2134) +++ xs_files-2.0 (working copy) @@ -51,6 +51,7 @@ xs/GtkArrow.xs xs/GtkAspectFrame.xs xs/GtkBin.xs +xs/GtkBindings.xs xs/GtkBox.xs xs/GtkButton.xs xs/GtkButtonBox.xs Index: constants-2.0 =================================================================== --- constants-2.0 (revision 2134) +++ constants-2.0 (working copy) @@ -3,3 +3,10 @@ GDK_PRIORITY_REDRAW GTK_PRIORITY_RESIZE + +GTK_PATH_PRIO_LOWEST +GTK_PATH_PRIO_GTK +GTK_PATH_PRIO_APPLICATION +GTK_PATH_PRIO_THEME +GTK_PATH_PRIO_RC +GTK_PATH_PRIO_HIGHEST Index: xs/GtkObject.xs =================================================================== --- xs/GtkObject.xs (revision 2134) +++ xs/GtkObject.xs (working copy) @@ -1,5 +1,5 @@ /* - * Copyright (c) 2003-2005 by the gtk2-perl team (see the file AUTHORS) + * Copyright (c) 2003-2005, 2009 by the gtk2-perl team (see the file AUTHORS) * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Library General Public Index: xs/GtkBindings.xs =================================================================== --- xs/GtkBindings.xs (revision 0) +++ xs/GtkBindings.xs (revision 0) @@ -0,0 +1,425 @@ +/* + * Copyright 2009 by the gtk2-perl team (see the file AUTHORS) + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Library General Public + * License as published by the Free Software Foundation; either + * version 2.1 of the License, or (at your option) any later version. + * + * This library is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Library General Public License for more details. + * + * You should have received a copy of the GNU Library General Public + * License along with this library; if not, see . + */ + +#include "gtk2perl.h" + +/* GtkBindingSet is a struct treated here as a boxed type. As of Gtk 2.12 + there's no GType for it, so that's created here, with a #ifndef in + gtk2perl.h in case gtk gains it later. + + Once created a GtkBindingSet is never destroyed, so no ref counting and + no distinction between "own" and "copy". + + ENHANCE-ME: Currently there's nothing to retrieve the contents of a + bindingset at the perl level. The widget_path_pspecs and other pspecs + use a private PatternMatch struct so are inaccessible. The linked list + of GtkBindingEntry and their contained GtkBindingSignal might be + extracted though, maybe in some form tolerably close to the kind of + entry_add_signal() calls that would build the set. */ + +static GtkBindingSet * +gtk2perl_binding_set_copy (GtkBindingSet *binding_set) +{ + /* no copying */ + return binding_set; +} +static void +gtk2perl_binding_set_free (GtkBindingSet *binding_set) +{ + /* no freeing */ +} +GType +gtk2perl_binding_set_get_type (void) +{ + static GType binding_set_type = 0; + if (binding_set_type == 0) + binding_set_type = g_boxed_type_register_static + ("Gtk2perlBindingSet", + (GBoxedCopyFunc) gtk2perl_binding_set_copy, + (GBoxedFreeFunc) gtk2perl_binding_set_free); + return binding_set_type; +} + +MODULE = Gtk2::BindingSet PACKAGE = Gtk2::BindingSet + +=for position DESCRIPTION + +=head1 DESCRIPTION + +A C is basically a mapping from keyval+modifiers to +a named action signal to invoke and with argument values for the +signal. Bindings are normally run by the C default +C handler, but can also be activated explicitly. + +Binding sets can be populated from program code with +C, or created from an RC file or string (see +L). If you use the RC note it doesn't parse and create +anything until there's someone interested in the result, such as +C for widgets. This means binding sets in RC files or +strings don't exist for C<< Gtk2::BindingSet->find >> to retrieve +until at least one widget has been created (or similar). + +Currently there's no Perl-level access to the contents of a +BindingSet, except for C. + +=cut + +## Method name "set_name()" corresponds to the struct field name. The name +## might make you think it's a setter, like other set_foo() funcs, so the +## couple of words of apidoc here try to make that clear it's a getter, +## without labouring the point. +=for apidoc +Return the name of $binding_set. +=cut +gchar * +set_name (binding_set) + GtkBindingSet *binding_set + CODE: + RETVAL = binding_set->set_name; + OUTPUT: + RETVAL + +## Note no field accessor for "priority", because as noted in the docs +## it is unused nowadays, and in fact contains garbage. (The priority +## from add_path() is buried in the private PatternSpec struct, +## establishing an order among the matches, and different places using +## the same GtkBindingSet can have different priorities ...) + +MODULE = Gtk2::BindingSet PACKAGE = Gtk2::BindingSet PREFIX = gtk_binding_set_ + +## Is/was gtk_binding_entry_clear() something subtly different from +## gtk_binding_entry_remove()? The code for the two is different as +## of Gtk circa 2.16. +## +## void +## gtk_binding_entry_clear (binding_set, keyval, modifiers) +## GtkBindingSet *binding_set +## guint keyval +## GdkModifierType modifiers + +## GtkBindingSet* gtk_binding_set_new (const gchar *set_name) +## GtkBindingSet* gtk_binding_set_find (const gchar *set_name) +## GtkBindingSet* gtk_binding_set_by_class (gpointer object_class) +## +## gtk_binding_set_new() copies the given set_name, so the string need +## not live beyond the call +## +## Only gtk_binding_set_find() needs the "ornull" return, new() and +## by_class() are never NULL. +## +## In other wrappers normally new() would be an "_own", find() not, +## and by_class() probably not, but as noted at the start of the file +## there's no copying or freeing of GtkBindingSet so no such +## distinction needed here. +## +=for apidoc Gtk2::BindingSet::new +=for signature GtkBindingSet = Gtk2::BindingSet->new ($set_name) +=for arg set_name (string) +=for arg name (__hide__) +=cut + +=for apidoc Gtk2::BindingSet::find +=for signature GtkBindingSet_ornull Gtk2::BindingSet->find ($set_name) +=for arg set_name (string) +=for arg name (__hide__) +=cut + +=for apidoc Gtk2::BindingSet::by_class +=for signature GtkBindingSet = Gtk2::BindingSet->by_class ($package_name) +=for arg package_name (string) +=for arg name (__hide__) +=cut + +=for apidoc new __hide__ +=for apidoc find __hide__ +=for apidoc by_class __hide__ +=cut +GtkBindingSet_ornull* gtk_binding_set_new (class, name) + const gchar *name + ALIAS: + find = 1 + by_class = 2 + CODE: + switch (ix) { + case 0: + RETVAL = gtk_binding_set_new (name); + break; + case 1: + RETVAL = gtk_binding_set_find (name); + break; + default: + { + GType type; + GtkObjectClass *oclass; + type = gperl_object_type_from_package (name); + if (! type) + croak ("package %s is not registered to a GType", + name); + if (! g_type_is_a (type, GTK_TYPE_OBJECT)) + croak ("'%s' is not an object subclass", name); + oclass = (GtkObjectClass*) g_type_class_ref (type); + RETVAL = gtk_binding_set_by_class (oclass); + g_type_class_unref (oclass); + } + break; + } + OUTPUT: + RETVAL + +## See GtkObject.xs +## gboolean gtk_bindings_activate (GtkObject *object, +## guint keyval, +## GdkModifierType modifiers) +## +## See GtkObject.xs +## gboolean gtk_bindings_activate_event (GtkObject *object, +## GdkEventKey *event) + +gboolean +gtk_binding_set_activate (binding_set, keyval, modifiers, object) + GtkBindingSet *binding_set + guint keyval + GdkModifierType modifiers + GtkObject *object + +=for apidoc +The following constants are defined for standard priority levels, + + Gtk2::GTK_PATH_PRIO_LOWEST + Gtk2::GTK_PATH_PRIO_GTK + Gtk2::GTK_PATH_PRIO_APPLICATION + Gtk2::GTK_PATH_PRIO_THEME + Gtk2::GTK_PATH_PRIO_RC + Gtk2::GTK_PATH_PRIO_HIGHEST + +LOWEST, which is 0, and HIGHEST, which is 15, are the limits of the +allowed priorities. The standard values are from the +C enum, but the parameter here is an integer, +not an enum string, so you can give a value for instance a little +above or below the pre-defined levels. +=cut +void +gtk_binding_set_add_path (binding_set, path_type, path_pattern, priority) + GtkBindingSet *binding_set + GtkPathType path_type + const gchar *path_pattern + int priority + +MODULE = Gtk2::BindingSet PACKAGE = Gtk2::BindingSet PREFIX = gtk_binding_ + +=for apidoc +=for signature $binding_set->entry_add_signal ($keyval, $modifiers, $signal_name) +=for signature $binding_set->entry_add_signal ($keyval, $modifiers, $signal_name, $type,$value, ...) +=for arg type (string) +=for arg value (scalar) +=for arg ... (__hide__) +Add an entry to $binding_set. $keyval and $modifier are setup as a +binding for $signal_name and with signal parameters given by $value +arguments. Each value is preceded by a type (a string), which must be +one of + + Glib::Long + Glib::Double + Glib::String + an enum type, ie. subtype of Glib::Enum + Glib::Flags, or a flags subtype + +For example, + + $binding_set->entry_add_signal + (Gtk2->keyval_from_name('Return'), + [ 'control-mask' ], # modifiers + 'some-signal-name', + 'Glib::Double', 1.5, + 'Glib::String, 'hello'); + +A parameter holds one of the three types Long, Double or String. When +invoked they're coerced to the parameter types expected by the target +object or widget. Use Glib::Long for any integer argument, including +chars and unichars by ordinal value. Use Glib::Double for both single +and double precision floats. + +Flags and enums are held as Longs in the BindingSet. You can pass an +enum type and string and C will lookup and store +accordingly. For example + + $binding_set->entry_add_signal + (Gtk2->keyval_from_name('Escape), [], + 'set-direction', + 'Gtk2::Orientation', 'vertical'); + +Likewise flags from an arrayref, + + $binding_set->entry_add_signal + (Gtk2->keyval_from_name('d'), [], + 'initiate-drag', + 'Gtk2::Gdk::DragAction', ['move,'ask']); + +If you've got a Glib::Flags object, rather than just an arrayref, then +you can just give Glib::Flags as the type and the value is taken from +the object. For example, + + my $flags = Gtk2::DebugFlag->new (['tree', 'updates']); + $binding_set->entry_add_signal + (Gtk2->keyval_from_name('x'), ['control-mask'], + 'change-debug', + 'Glib::Flags', $flags); +=cut +## The list style "_signall" version is best here, rather than the +## varargs "_signal". "_signall" is marked as "deprecated" circa Gtk +## 2.12. Of course deprecated is not a word but in this case it means +## "useful feature taken away". As of Gtk 2.16 _signal is in fact +## implemented as a front end to _signall, though with some extra +## coercions on the args, allowing for instance GValue containing +## G_TYPE_INT to promote to G_TYPE_LONG. +## +## void gtk_binding_entry_add_signall (GtkBindingSet *binding_set, +## guint keyval, +## GdkModifierType modifiers, +## const gchar *signal_name, +## GSList *binding_args); +## +## void gtk_binding_entry_add_signal (GtkBindingSet *binding_set, +## guint keyval, +## GdkModifierType modifiers, +## const gchar *signal_name, +## guint n_args, +## ...); +## +## There may be some scope for expanding the helper "type"s accepted. +## For example 'Glib::Boolean' could take the usual perl true/false +## and turn it into 0 or 1. Or 'Glib::Unichar' could take a single +## char string and store its ordinal. Both can be done with +## 'Glib::Long' and a "!!" boolizing or ord() lookup, so it's just +## about what would be helpful and what would be useless bloat. The +## Flags and Enum provided are quite helpful because it's not +## particularly easy to extract the number. A Unichar would probably +## be bloat since there's no signals which take a char ordinal as a +## parameter, is there? +## +void +gtk_binding_entry_add_signal (binding_set, keyval, modifiers, signal_name, ...) + GtkBindingSet *binding_set + guint keyval + GdkModifierType modifiers + const gchar *signal_name + PREINIT: + const int first_argnum = 4; + int count, i; + GSList *binding_args = NULL; + GtkBindingArg *ap; + CODE: + count = (items - first_argnum); + if ((count % 2) != 0) { + croak ("entry_add_signal expects type,value pairs " + "(odd number of arguments detected)"); + } + count /= 2; + ap = g_new (GtkBindingArg, count); + for (i = 0; i < count; i += 2) { + SV *sv_type = ST(i + first_argnum); + SV *sv_value = ST(i + first_argnum + 1); + GType gtype = gperl_type_from_package(SvPV_nolen(sv_type)); + + /* gtype==G_TYPE_NONE if sv_type is not registered; it falls + * through to the "default:" error + */ + switch (G_TYPE_FUNDAMENTAL (gtype)) { + case G_TYPE_LONG: + ap[i].d.long_data = SvIV(sv_value); + break; + case G_TYPE_DOUBLE: + ap[i].d.double_data = SvNV(sv_value); + break; + case G_TYPE_STRING: + /* GTK_TYPE_IDENTIFIER comes through here, but + * believe that's only a hangover from gtk 1.2 and + * needs no special attention. + */ + /* gtk copies the string */ + ap[i].d.string_data = SvPV_nolen(sv_value); + break; + + /* helpers converting to the three basic types ... */ + case G_TYPE_ENUM: + /* coerce enum to long */ + ap[i].d.long_data = gperl_convert_enum(gtype,sv_value); + gtype = G_TYPE_LONG; + break; + case G_TYPE_FLAGS: + /* coerce flags to long */ + ap[i].d.long_data = gperl_convert_flags(gtype,sv_value); + gtype = G_TYPE_LONG; + break; + + default: + g_slist_free (binding_args); + g_free (ap); + croak ("Unrecognised argument type '%s'", + SvPV_nolen(sv_type)); + } + ap[i].arg_type = gtype; + binding_args = g_slist_append (binding_args, &(ap[i])); + } + gtk_binding_entry_add_signall (binding_set, keyval, modifiers, + signal_name, binding_args); + g_slist_free (binding_args); + g_free (ap); + +## void gtk_binding_entry_remove (GtkBindingSet *binding_set, +## guint keyval, +## GdkModifierType modifiers); +void +gtk_binding_entry_skip (binding_set, keyval, modifiers) + GtkBindingSet *binding_set + guint keyval + GdkModifierType modifiers + ALIAS: + entry_remove = 1 + CODE: + if (ix == 0) + gtk_binding_entry_skip (binding_set, keyval, modifiers); + else + gtk_binding_entry_remove (binding_set, keyval, modifiers); + +MODULE = Gtk2::BindingSet PACKAGE = Gtk2::Object PREFIX = gtk_ + +=for apidoc +Although C and C are C +methods, as of Gtk 2.12 they will only actually invoke signals on a +C. On a C the return is always false (no +binding activated). +=cut +gboolean +gtk_bindings_activate (object, keyval, modifiers) + GtkObject *object + guint keyval + GdkModifierType modifiers + +gboolean +gtk_bindings_activate_event (object, event) + GtkObject *object + GdkEvent *event +PREINIT: + GdkEventType type; +CODE: + type = event->type; + if (type != GDK_KEY_PRESS && type != GDK_KEY_RELEASE) + croak ("Event must be key-press or key-release"); + RETVAL = gtk_bindings_activate_event (object, (GdkEventKey*) event); +OUTPUT: + RETVAL Index: maps-2.0 =================================================================== --- maps-2.0 (revision 2134) +++ maps-2.0 (working copy) @@ -1,4 +1,4 @@ -# Copyright (C) 2003-2004 by the gtk2-perl team (see the file AUTHORS for the +# Copyright (C) 2003-2004, 2009 by the gtk2-perl team (see the file AUTHORS for the # full list) # # This library is free software; you can redistribute it and/or modify it under @@ -340,3 +340,7 @@ # not really defined by GTK+, but we'll use it for ourselves. GDK_TYPE_REGION GdkRegion GBoxed Gtk2::Gdk::Region + +# GTK_TYPE_BINDING_SET not defined as of Gtk 2.16, instead jigged up +# ourselves in gtk2perl.h +GTK_TYPE_BINDING_SET GtkBindingSet GBoxed Gtk2::BindingSet Index: t/GtkBindings.t =================================================================== --- t/GtkBindings.t (revision 0) +++ t/GtkBindings.t (revision 0) @@ -0,0 +1,393 @@ +#!/usr/bin/perl + +# Copyright 2009 by the gtk2-perl team (see the file AUTHORS) +# +# This library is free software; you can redistribute it and/or +# modify it under the terms of the GNU Library General Public +# License as published by the Free Software Foundation; either +# version 2.1 of the License, or (at your option) any later version. +# +# This library is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +# Library General Public License for more details. +# +# You should have received a copy of the GNU Library General Public +# License along with this library; if not, see . + + +package My::Object; +use strict; +use warnings; +use Gtk2; +use Glib::Object::Subclass + 'Gtk2::Object', + signals => { mysig => { param_types => [], + return_type => undef, + flags => ['run-last','action'], + class_closure => \&do_mysig }, + mysig_with_long => { param_types => [ 'Glib::Long' ], + return_type => undef, + flags => ['run-last','action'], + class_closure => \&do_mysig_with_long }, + mysig_with_float => { param_types => [ 'Glib::Double' ], + return_type => undef, + flags => ['run-last','action'], + class_closure => \&do_mysig_with_float }, + }; +my $mysig_seen; +sub do_mysig { + Test::More::diag ("mysig runs"); + $mysig_seen = 1; +} +my $mysig_with_long_value; +sub do_mysig_with_long { + my ($self, $value) = @_; + Test::More::diag ("mysig_with_long runs, value=$value"); + $mysig_with_long_value = $value; +} +my $mysig_with_float_value; +sub do_mysig_with_float { + my ($self, $value) = @_; + Test::More::diag ("mysig_with_float runs, value=$value"); + $mysig_with_float_value = $value; +} + +package My::Widget; +use strict; +use warnings; +use Gtk2; +use Glib::Object::Subclass + 'Gtk2::EventBox', + signals => { mywidgetsig => { parameter_types => [], + return_type => undef, + flags => ['run-last','action'], + class_closure => \&do_mywidgetsig }, + }; +my $mywidgetsig_seen; +sub do_mywidgetsig { + Test::More::diag ("mywidgetsig runs"); + $mywidgetsig_seen = 1; +} + + +package main; +use strict; +use warnings; +# Note: need '-init' to make Gtk2::Rc do its thing ... +use Gtk2::TestHelper tests => 43; + + +#----------------------------------------------------------------------------- +# new() + +my $mybindings = Gtk2::BindingSet->new('mybindings'); +ok ($mybindings, 'new()'); + +#----------------------------------------------------------------------------- +# priority constants + +is (Gtk2::GTK_PATH_PRIO_LOWEST, 0); +ok (Gtk2::GTK_PATH_PRIO_GTK); +ok (Gtk2::GTK_PATH_PRIO_APPLICATION); +ok (Gtk2::GTK_PATH_PRIO_THEME); +ok (Gtk2::GTK_PATH_PRIO_RC); +ok (Gtk2::GTK_PATH_PRIO_HIGHEST); + +#----------------------------------------------------------------------------- +# set_name() field accessor + +is ($mybindings->set_name, 'mybindings', + 'set_name() of mybindings'); + +#----------------------------------------------------------------------------- +# find() + +ok (Gtk2::BindingSet->find('mybindings'), + 'find() mybindings'); +is (Gtk2::BindingSet->find('nosuchbindingset'), undef, + 'find() not found'); + +#----------------------------------------------------------------------------- +# by_class() + +ok (Gtk2::BindingSet->by_class('Gtk2::Entry'), + 'by_class() Gtk2::Entry'); + +#----------------------------------------------------------------------------- +# activate() + +# The rc mechanism doesn't actually parse anything or create any +# GtkBindingSet's until one or more GtkSettings objects exist and are +# interested in the rc values. Create a dummy label widget to force that to +# happen and thus ensure creation of the "some_bindings" set. +# +my $dummy_label = Gtk2::Label->new; + +Gtk2::Rc->parse_string (<<'HERE'); +binding "some_bindings" { + bind "Return" { "mysig" () } +} +HERE + +{ + my $some_bindings = Gtk2::BindingSet->find('some_bindings'); + ok ($some_bindings, 'find() of RC parsed bindings'); + + my $myobj = My::Object->new; + $mysig_seen = 0; + ok ($some_bindings->activate (Gtk2::Gdk->keyval_from_name('Return'), + [],$myobj), + 'activate() return true on myobj'); + is ($mysig_seen, 1, 'activate() runs mysig on myobj'); +} + +#----------------------------------------------------------------------------- +# add_path() and $object->bindings_activate() and bindings_activate_event() + +Gtk2::Rc->parse_string (<<'HERE'); +binding "my_widget_bindings" { + bind "Return" { "mywidgetsig" () } +} +HERE + +# As of Gtk 2.12 $gtkobj->bindings_activate() only actually works on a +# Gtk2::Widget, not a Gtk2::Object, hence using My::Widget to exercise +# add_path() instead of My::Object. +{ + my $my_widget_bindings = Gtk2::BindingSet->find('my_widget_bindings'); + ok ($my_widget_bindings, 'find() of RC parsed bindings'); + + $my_widget_bindings->add_path ('class', 'My__Widget', + Gtk2::GTK_PATH_PRIO_APPLICATION); + + my $mywidget = My::Widget->new; + my $keyval = Gtk2::Gdk->keyval_from_name ('Return'); + my $modifiers = []; + + $mywidgetsig_seen = 0; + ok ($mywidget->bindings_activate ($keyval,$modifiers), + 'bindings_activate() return true on mywidget'); + is ($mywidgetsig_seen, 1, + 'bindings_activate() runs mywidgetsig on mywidget'); + + # This diabolical bit of code is what it takes to synthesize a + # Gtk2::Gdk::Event::Key which gtk_bindings_activate_event() will dispatch. + # That func looks at the hardware_keycode and group, rather than the + # keyval in the event, so must generate those. hardware_keycode values + # are basically arbitrary aren't they? At any rate the strategy is to + # lookup what hardware code is Return in the display keymap and use that. + # gtk_bindings_activate_event() then ends up then going the other way, + # turning the hardware code into a keyval to lookup in the bindingset! + # + # The gtk_widget_get_display() docs say $mywidget won't have a display + # until it's the child of a toplevel. Gtk 2.12 will give you back the + # default display before then, but probably better not to rely on that. + # + my $toplevel = Gtk2::Window->new; + $toplevel->add ($mywidget); + my $display = $mywidget->get_display; + my $keymap = Gtk2::Gdk::Keymap->get_for_display ($display); + my @keys = $keymap->get_entries_for_keyval ($keyval); + # diag "keys ", explain \ keys; + + my $event = Gtk2::Gdk::Event->new ('key-press'); + $event->window ($mywidget->window); + $event->keyval ($keyval); + $event->set_state ($modifiers); + $event->group($keys[0]->{'group'}); + $event->hardware_keycode($keys[0]->{'keycode'}); + $mywidget->bindings_activate_event ($event); + + $mywidgetsig_seen = 0; + ok ($mywidget->bindings_activate_event ($event), + 'bindings_activate() return true on mywidget'); + is ($mywidgetsig_seen, 1, + 'bindings_activate() runs mywidgetsig on mywidget'); + + $toplevel->destroy; +} + +#----------------------------------------------------------------------------- +# entry_add_signal() + +{ + my $bindings = Gtk2::BindingSet->new ('entry_add_signal_test'); + my $obj = My::Object->new; + + { + my $keyval = Gtk2::Gdk->keyval_from_name('Return'); + my $modifiers = []; + $bindings->entry_add_signal ($keyval, $modifiers, 'mysig'); + $mysig_seen = 0; + ok ($bindings->activate ($keyval, $modifiers, $obj), + 'entry_add_signal() activate on MyObject -- dispatch mysig'); + is ($mysig_seen, 1, + 'entry_add_signal() activate on MyObject -- ran mysig'); + } + + # object taking Glib::Long, pass as Glib::Long + # + { + my $keyval = Gtk2::Gdk->keyval_from_name('Escape'); + my $modifiers = []; + my $arg = 12456; + $bindings->entry_add_signal ($keyval, $modifiers, 'mysig-with-long', + 'Glib::Long', $arg); + $mysig_with_long_value = 0; + ok ($bindings->activate ($keyval, $modifiers, $obj), + 'entry_add_signal() activate on MyObject -- dispatch mysig_with_long'); + is ($mysig_with_long_value, $arg, + 'entry_add_signal() activate on MyObject -- mysig_with_long value'); + } + + # object taking Glib::Float, pass as Glib::Double + # + { + my $keyval = Gtk2::Gdk->keyval_from_name('space'); + my $modifiers = [ 'control-mask' ]; + my $arg = 1.25; + $bindings->entry_add_signal ($keyval, $modifiers, 'mysig-with-float', + 'Glib::Double', $arg); + $mysig_with_float_value = 0; + ok ($bindings->activate ($keyval, $modifiers, $obj), + 'entry_add_signal() activate on MyObject -- dispatch mysig_with_float'); + is ($mysig_with_float_value, $arg, + 'entry_add_signal() activate on MyObject -- mysig_with_float value'); + } + + Glib::Type->register_flags ('My::Flags', + ['value-one' => 8 ], + ['value-two' => 16 ], + ['value-three' => 32 ]); + + # object taking Glib::Long, give flags as arrayref + # + { + my $keyval = Gtk2::Gdk->keyval_from_name('Escape'); + my $modifiers = [ 'control-mask' ]; + my $flags = ['value-one', 'value-three']; + my $flags_num = 40; + $bindings->entry_add_signal ($keyval, $modifiers, 'mysig-with-long', + 'My::Flags', $flags); + $mysig_with_long_value = -1; + ok ($bindings->activate ($keyval, $modifiers, $obj), + 'entry_add_signal() activate on MyObject -- dispatch mysig_with_long'); + is ($mysig_with_long_value, $flags_num, + 'entry_add_signal() activate on MyObject -- mysig_with_long value'); + } + + # object taking Glib::Long, give flags as flags object + # + { + my $keyval = Gtk2::Gdk->keyval_from_name('Escape'); + my $modifiers = [ 'control-mask' ]; + my $flags = My::Flags->new (['value-one', 'value-two']); + my $flags_num = 24; + $bindings->entry_add_signal ($keyval, $modifiers, 'mysig-with-long', + 'Glib::Flags', $flags); + $mysig_with_long_value = -1; + ok ($bindings->activate ($keyval, $modifiers, $obj), + 'entry_add_signal() activate on MyObject -- dispatch mysig_with_long'); + is ($mysig_with_long_value, $flags_num, + 'entry_add_signal() activate on MyObject -- mysig_with_long value'); + } + + Glib::Type->register_flags ('My::Enum', + [eeeek => 123 ]); + + # object taking Glib::Long, give enum as string + # + { + my $keyval = Gtk2::Gdk->keyval_from_name('space'); + my $modifiers = []; + $bindings->entry_add_signal ($keyval, $modifiers, 'mysig-with-long', + 'My::Enum', 'eeeek'); + $mysig_with_long_value = -1; + ok ($bindings->activate ($keyval, $modifiers, $obj), + 'entry_add_signal() activate on MyObject -- dispatch mysig_with_long'); + is ($mysig_with_long_value, 123, + 'entry_add_signal() activate on MyObject -- mysig_with_long value'); + } +} + +#----------------------------------------------------------------------------- +# entry_remove() + +{ + my $bindings = Gtk2::BindingSet->new ('entry_remove_test'); + my $obj = My::Object->new; + + my $keyval = Gtk2::Gdk->keyval_from_name('Return'); + my $modifiers = []; + $bindings->entry_add_signal ($keyval, $modifiers, 'mysig'); + + $mysig_seen = 0; + ok ($bindings->activate ($keyval, $modifiers, $obj), + 'before entry_remove() activate on MyObject -- dispatch mysig'); + is ($mysig_seen, 1, + 'before entry_remove() activate on MyObject -- ran mysig'); + + $bindings->entry_remove ($keyval, $modifiers); + + $mysig_seen = 0; + ok (! $bindings->activate ($keyval, $modifiers, $obj), + 'after entry_remove() activate on MyObject -- no dispatch mysig'); + is ($mysig_seen, 0, + 'after entry_remove() activate on MyObject -- no run mysig'); +} + + +#----------------------------------------------------------------------------- +# entry_skip() + +# basic invocation on object doesn't dispatch +{ + my $skip_bindings = Gtk2::BindingSet->new ('entry_skip_test'); + my $keyval = Gtk2::Gdk->keyval_from_name('Return'); + my $modifiers = []; + $skip_bindings->entry_add_signal ($keyval, $modifiers, 'mysig'); + + my $obj = My::Object->new; + + $mysig_seen = 0; + ok ($skip_bindings->activate ($keyval, $modifiers, $obj), + 'before entry_skip() activate on MyObject -- dispatch mysig'); + is ($mysig_seen, 1, + 'before entry_skip() activate on MyObject -- ran mysig'); + + $skip_bindings->entry_skip ($keyval, $modifiers); + + $mysig_seen = 0; + ok (! $skip_bindings->activate ($keyval, $modifiers, $obj), + 'after entry_skip() activate on MyObject -- no dispatch mysig'); + is ($mysig_seen, 0, + 'after entry_skip() activate on MyObject -- no run mysig'); + + + # When an entry_skip() binding shadows another binding the latter doesn't + # run. + # + # This more exercises gtk than it does the bindings, but it does make sure + # the shared code of ->entry_skip() and ->entry_remove() have the right + # func under the right name. + # + my $mywidget = My::Widget->new; + + $mywidgetsig_seen = 0; + ok ($mywidget->bindings_activate (Gtk2::Gdk->keyval_from_name('Return'),[]), + 'before entry_skip(), bindings_activate return true on mywidget'); + is ($mywidgetsig_seen, 1, + 'before entry_skip(), bindings_activate runs mywidgetsig on mywidget'); + + $skip_bindings->add_path ('widget-class', 'My__Widget', + Gtk2::GTK_PATH_PRIO_HIGHEST); + + $mywidgetsig_seen = 0; + ok (! $mywidget->bindings_activate(Gtk2::Gdk->keyval_from_name('Return'),[]), + 'before entry_skip(), bindings_activate return true on mywidget'); + is ($mywidgetsig_seen, 0, + 'before entry_skip(), bindings_activate runs mywidgetsig on mywidget'); +} + +exit 0;