A little tie magic

[Bjarne Steinsbø <bosteins broadpark no>]

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.

Questions:
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?

Bjarne

#! /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);
$window->show_all;
 
Gtk2->main;
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 {
            \$_[0]->$class_handlers{$class}{get_contents};
        }

        sub set_tied_contents {
            \$_[0]->$class_handlers{$class}{set_contents}(\$_[1]);
        }
        1;
        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};
        }
        1;
    };
    # print $code;
    eval $code;
    croak "Gtk2::BindVariable : Can't compile code for '$class' : $@"
        if $@;
}

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

sub FETCH {
    $_[0]->get_tied_contents;
}

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

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

1;

=head1 NAME

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

=head1 SYNOPSIS

 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 ABSTRACT


=head1 DESCRIPTION

=head1 EXPORT

=head1 SEE ALSO

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

=head1 AUTHORS

 Bjarne Steinsbo <steinsbo at users dot sf dot net>

=head1 COPYRIGHT AND LICENSE

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
details.
 
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.

=cut