Re: A little tie magic

[Bjarne Steinsbø <bosteins broadpark no>]

A. Pagaltzis wrote:

> I don't see why this has to be a Gtk2-specific module. Instead of
> having all the widgets support ties, you should implement a
> change-notifying scalar using the tie mechnism along these lines: 
>
>  
Snip, snip...

> Now you have a scalar that runs a callback whenever it is
> updated. In your app you then do something like
>  
>  tie my $button_label, 'Tie::NotifyScalar', sub { $button->set_label($_[1]) };
>
> Now whenever you change $button_label, the button label will
> change as well. No need to add tons of stuff to Gtk2.
>  
It's all a matter of design choices.  After all, TIMTOWTDI.  All of them 
(or least most of them :-) equally valid.  In this case, compare the 
syntax of a specialized way:

 $button->bind_variable (\$but_state);

to the syntax of a generalized way:

 tie $but_state, 'Tie::NotifyScalar', sub { $button->set_active ($_[1] 
}, sub { $button->get_active };

Does the simplified syntax warrent the "pollution" of Gtk?  In my view 
it probably does, but I have no problems accepting that others might 
feel different.  Which is why I asked the list...

So to answer your first question: It is precisely *because* it is 
Gtk2-specific that the code I wrote might have a valid reason to exist.

> Maybe I should add proper sanity checks to this code and a bunch
> of tests and up it to CPAN?

By all means do that.  Your solution might be exactly what somebody else 
has been looking for.  There is already Tie::Watch, which is somewhat 
close (in principle) to what you are doing, but they are sufficiently 
different (IMO) that there is room for both.

BTW, attached is an improved version of the module.  It pollutes the 
namespaces somewhat less, loads stuff dynamically (as needed) instead of 
statically at compile time, adds support for 'variants', has a more 
compact data structure, and fixes some problems which were probably 
bugs.  Still incomplete as to supported widgets and documentation.

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;
my $lab = Gtk2::Label->new ('This is a test')->bind_variable (\$lab_text);
printf "Initial label text = %s\n", $lab_text;
$vbox->pack_start ($lab, 0, 0, 0);

my $but_state;
my $check = Gtk2::CheckButton->new_with_label (
    'CheckButton'
)->bind_variable (\$but_state);
{
    my $but_mode;
    $check->bind_variable (\$but_mode, 'mode');
    # untie $but_mode;
} # Hmmm.  Neither UNTIE nor DESTROY is triggered as $but_mode goes out of scope
my $but_mode;
$check->bind_variable (\$but_mode, 'mode');
$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;
    printf STDERR "Existing button mode = '%d'\n", $but_mode;
    $but_mode = ($but_mode + 1) % 2;
    printf STDERR "Changing to '%d'\n", $but_mode;
});
$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.02';

our %class_handlers = (
    'Gtk2::Label' => {
        default => 'text',
        text => [qw{get_text set_text}],
    },
    'Gtk2::ToggleButton' => {
        default => 'active',
        active => [qw{get_active set_active}],
        mode => [qw{get_mode set_mode}],
        inconsistent => [qw{get_inconsistent set_inconsistent}],
    },
    'Gtk2::CheckButton' => {}, # Inherit
    'Gtk2::RadioButton' => {
        group => [qw{get_group set_group}],
    },
    'Gtk2::Widget' => {
        default => 'name',
        name => [qw{get_name set_name}],
        parent_window => [qw{get_parent_window set_parent_window}],
        extension_events => [qw{get_extension_events set_extension_events}],
        colormap => [qw{get_colormap set_colormap}],
        style => [qw{get_style set_style}],
        direction => [qw{get_direction set_direction}],
        default_direction => [qw{get_default_direction set_default_direction}],
    },
);

# Somewhat a hack, but add data to above data structure for variants handled
# by parent classes.
for my $class (keys %class_handlers) {
    # Take advantage of the simple inheritance chain of widgets in
    # Gtk2, only single-inheritance, all widgets ending up at Gtk2::Widget
    my @isa_chain = ();
    {
        no strict 'refs';
        for (
            my $pclass = $class;
            $pclass ne 'Gtk2::Object';
            $pclass = ${"${pclass}::ISA"}[0]
        ) {
            push @isa_chain, $pclass
                unless $pclass eq $class;
        }
    }
    for my $pclass (@isa_chain) {
        # Only explicitly mentioned classes are handled
        next unless exists $class_handlers{$pclass};
        # Inherit variants
        for my $variant (keys %{$class_handlers{$pclass}}) {
            next if exists $class_handlers{$class}{$variant};
            $class_handlers{$class}{$variant} =
                $class_handlers{$pclass}{$variant};
        }
    }
}

# NB! The following sub is compiled into the namespace of Gtk2::Widget!
sub Gtk2::Widget::bind_variable {
    my ($self, $var, $variant) = @_;
    my $class = ref $self;
    $variant = $class_handlers{$class}{default}
        unless defined $variant;
    croak "${class}::bind_variable : no such variant '$variant'"
        unless exists $class_handlers{$class}{$variant};
    croak "${class}::bind_variable : Need reference to scalar"
        unless ref $var eq 'SCALAR';
    croak "${class}::bind_variable : can't re-tie scalar"
        if tied $$var;
    my $bound_pkg_name = "${class}::${variant}::_bound";
    # Check perl symbol table to see if the handlers are already installed
    unless (exists $::{$bound_pkg_name}) {
        # Nope, need to compile them
        my $code = qq{
            package $bound_pkg_name;
            use strict;
            use Carp;
            our \ ISA = qw($class Gtk2::BindVariable);
        };
        my ($getter, $setter) = @{$class_handlers{$class}{$variant}};
        if (defined $getter) {
            $code .= qq{
                sub get_tied_contents { \${\$_[0]}->$getter; }
            };
        } else {
            $code .= 'sub get_tied_contents { croak "Variable is write-only" }';
        }
        if (defined $setter) {
            $code .= qq{
                sub set_tied_contents { \${\$_[0]}->$setter (\$_[1]); }
            };
        } else {
            $code .= 'sub set_tied_contents { croak "Variable is read-only" }';
        }
        $code .= "1;\n";
        # print $code;
        eval $code;
        die "Gtk2::BindVariable : Can't compile code for '$class' : $@"
            if $@;
    }
    my $val = $$var;
    tie $$var, 'Gtk2::BindVariable', $self, $bound_pkg_name, $variant;
    $$var = $val if defined $val; # Trigger init
    return $self; # Return widget, making chaining possible
}

# The tied scalar methods

sub TIESCALAR {
    my ($class, $self, $other_class, $variant) = @_;
    $self->{'_BoundVariable_' . $variant} = \$self;
    return bless $self->{'_BoundVariable_' . $variant}, $other_class;
}

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

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

# Break circular reference
sub UNTIE {
    my ($self) = @_;
    my $class = ref $self;
    my $pclass = ref $$self;
    my ($variant) = ($class =~ /^${pclass}::(\w+)/);
    delete ${$self}->{'_BoundVariable_' . $variant};
}

# There's a bug here somewhere.  Or at least DESTROY is not called when
# I expect it to be.  This bug will make it difficult to garbage collect
# the widget because of the circular reference.
sub DESTROY {
    $_[0]->UNTIE;
}

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

Binds perl variables to the underlying widget contents.

=head1 DESCRIPTION

Uses tied scalars so that setting/getting the scalar will trigger the
correct widget method to get/set the contents of the widget.

=head1 EXPORT

Nothing.

=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