A little tie magic

One function that I miss from my Tk days is the ability to bind perl variables to the contents of the widgets. So here's an implementation of this functionality. Please see example and pm file if you're not familiar with Tk or otherwise don't quite understand what I'm talking about, that will hopefully make it clearer.

Still missing:
1) Documentation
2) Support for more widgets. I've only implemented a few in order to test the concept, but it's easy to add more.

1) Is there enough interest in this that the powers that be should be requested to include it in the core Gtk2 distribution?
2) Is this the way the interface should work?  Any better suggestions?
3) Would it be OK to document Gtk2::BindVariable as such, even though at least one additional method will be compiled into each and every Gtk2 'client' class?

One addition I have though about is to add what I think about as 'variants' of the tie. Let me try and explain.

In the current implementation, only one pair of of get/set methods can be tied to the variable. Which means that the user won't have to provide which methods to bind, but this will also limit this approach to only one part of the widget. For the button, I've chosen to provide bindings for the button state, not the button mode. The 'variants' are optional arguments to the bind_variable to specify other choices:

$ckbut->bind_variable (\$state); # Bind state of button
$ckbut->bind_variable (\$state, 'state'); # Same as above
$ckbut->bind_variable (\$state, 'mode'); # Bind the mode instead

It's easy enough to change the code to support different 'variants', but is it worth it?


#! /usr/bin/perl

use strict;
use Gtk2 -init;
use Gtk2::BindVariable;
use Data::Dumper;

my $window = Gtk2::Window->new ('toplevel');
$window->set_title ('Test variable binding');
$window->signal_connect (destroy => sub {Gtk2->main_quit;});

my $vbox = Gtk2::VBox->new (0, 0);

my $lab_text = 'This is a test';
my $lab = Gtk2::Label->new ($lab_text);
$lab->bind_variable (\$lab_text);
$vbox->pack_start ($lab, 0, 0, 0);

my $but_state = 1;
my $check = Gtk2::CheckButton->new_with_label ('CheckButton');
$check->bind_variable (\$but_state);
$vbox->pack_start ($check, 0, 0, 0);

my $lab_but = Gtk2::Button->new_with_label ('Change label');
$lab_but->signal_connect (clicked => sub {
    printf STDERR "Existing label = '%s'\n", $lab_text;
    $lab_text .= '_change';
    printf STDERR "Changing to '%s'\n", $lab_text;
$vbox->pack_start ($lab_but, 0, 0, 0);

my $but_but = Gtk2::Button->new_with_label ('Change CheckButton');
$but_but->signal_connect (clicked => sub {
    printf STDERR "Existing button state = '%d'\n", $but_state;
    $but_state = ($but_state + 1) % 2;
    printf STDERR "Changing to '%d'\n", $but_state;
$vbox->pack_start ($but_but, 0, 0, 0);

$window->add ($vbox);
exit 0;
package Gtk2::BindVariable;

use strict;
use Carp;
use Gtk2;

our $VERSION = '0.01';

my %class_handlers = (
    'Gtk2::Label' => {
        get_contents => 'get_text',
        set_contents => 'set_text',
    'Gtk2::ToggleButton' => {
        get_contents => 'get_active',
        set_contents => 'set_active',

# Compile code into each client class to enable variable binding
for my $class (keys %class_handlers) {
    my $code .= qq{
        package ${class}::bound;
        use strict;
        use Carp;
        our \ ISA = qw($class Gtk2::BindVariable);

        sub get_tied_contents {

        sub set_tied_contents {
        package ${class};
        use strict;
        use Carp;
        sub bind_variable {
            my (\$self, \$var) = \ _;
            my \$val = \$\$var;
            croak "${class}::bind_variable : Need reference to scalar"
                unless ref \$var eq 'SCALAR';
            \$self->{_BoundVariable} = \$self;
            tie \$\$var, 'Gtk2::BindVariable', \$self, q{${class}::bound};
            \$\$var = \$val; # Trigger init
            return \$self->{_BoundVariable};
    # print $code;
    eval $code;
    croak "Gtk2::BindVariable : Can't compile code for '$class' : $@"
        if $@;

    my ($class, $self, $other_class) = @_;
    return bless $self->{_BoundVariable}, $other_class;

sub FETCH {

sub STORE {
    $_[0]->set_tied_contents ($_[1]);

# Break circular reference
    delete $_[0]->{_BoundVariable};


=head1 NAME

Gtk2::BindVariable - Install extra methods in various packages to bind perl
variables to the underlying widget contents.


 use Gtk2;
 use Gtk2::BindVariable;

 my $label = Gtk2::Label->new();
 my $label_txt = 'This is the label';
 $label->bind_variable (\$label_txt);
 $label_txt = 'New label text';

 my $ckbutton = Gtk2::Checkbutton->new;
 my $but = 1;
 $ckbutton->bind_variable (\$but);
 if ($but) { do_something () };



=head1 EXPORT

=head1 SEE ALSO

Perl(1), Glib(3pm), Gtk2(3pm).

=head1 AUTHORS

 Bjarne Steinsbo <steinsbo at users dot sf dot net>


Copyright 2003 by the Gtk2-Perl team.
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
You should have received a copy of the GNU Library General Public License along
with this library; if not, write to the Free Software Foundation, Inc., 59
Temple Place - Suite 330, Boston, MA  02111-1307  USA.


[Date Prev][Date Next]   [Thread Prev][Thread Next]   [Thread Index] [Date Index] [Author Index]