Re: A little tie magic

[Bjarne Steinsbø <bosteins broadpark no>]

A. Pagaltzis wrote:

> True enough that the generic syntax is unwieldly; how about a single
> helper function that implements this mechanism in terms of a tied
> variable? The syntax would change slightly -
>
>  gtk2_bind_variable($button, \$but_state);
>
> and the function would look at the class of $button to determine
> which callbacks to use. You wouldn't need to inject any code in
> the Gtk2 classes and the syntax is just as concise.

I still prefer the method-type invocation, not least because that allows 
a much more natural chaining of calls:

 $button = Gtk2::new_with_label ('Get lost')->bind_variable (\$but_state);

Also, in the last iterations, I'm injecting code "only" into the 
Gtk2::Widget class.  I quite agree that the first cut was doing too much 
of this (and it wasn't even necessary), but I feel that one small method 
injected into Widget might be defendable.  Also, you do have to *use* 
the package to get this, so you're not getting it unless it's explicitly 
asked for.

Anyway, the attached version will probably be the last one unless 
someone else takes an interest in this and wants it in the core 
distribution.  It's now covering all my own needs, and then some.  
Changes in the last iteration:
 - Much more complete as far as number of supported widgets goes 
(builds data structure from the perl symbol table, with only the 
exceptions and default 'variant' hard-coded)
 - A couple of bug fixes

I've still got a problem with garbage collection that I haven't managed 
to figure out.  UNTIE/DESTROY isn't called when I expect them to be, so 
a cyclic dependency introduced in the widget hash will prevent the 
widget from being garbage collected by perl.  It shouldn't be a major 
problem though, since widget destruction is relatively rare and the 
amount of wasted memory is small.

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);
my $display;
$lab->bind_variable (\$display, 'display');
my $style;
$lab->bind_variable (\$style, 'style');
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;
    printf STDERR "Display for label = '%s'\n", $display;
    printf STDERR "Style for label = '%s'\n", $style;
});
$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.03';

our %class_handlers = ();

# Gosh are we getting lazy.  Trawl the perl symbol table for the
# default contents of %class_handlers.
for my $key (keys %Gtk2::) {
    next unless $key =~ /::$/;
    my $pkg_name = 'Gtk2::' . $key;
    $pkg_name =~ s/::$//;
    my @isa_chain = _isa_chain ($pkg_name);
    next unless $isa_chain[-1] eq 'Gtk2::Widget';
    # print $key, "\n";
    $class_handlers{$pkg_name} = {};
    my %methods = map { $_ => 1 } _list_methods ($pkg_name);
    for my $meth (keys %methods) {
        next unless $meth =~ /^set(.*)$/;
        my $something = $1;
        next unless exists $methods{'get' . $something};
        # print "    ", $something, "\n";
        (my $no_underscore = $something) =~ s/^_//;
        $class_handlers{$pkg_name}{$no_underscore} = [
            'get' . $something, 'set' . $something
        ];
    }
}

# Now augment and fix %class_handlers

# Sensible (?) defaults
$class_handlers{'Gtk2::Label'}{default} = 'text';
$class_handlers{'Gtk2::Image'}{default} = 'image';
$class_handlers{'Gtk2::Frame'}{default} = 'label';
$class_handlers{'Gtk2::ToggleButton'}{default} = 'active';
$class_handlers{'Gtk2::Button'}{default} = 'label';
$class_handlers{'Gtk2::MenuItem'}{default} = 'submenu';
$class_handlers{'Gtk2::Widget'}{default} = 'name';
$class_handlers{'Gtk2::Paned'}{default} = 'position';
$class_handlers{'Gtk2::ColorSelection'}{default} = 'current_color';
$class_handlers{'Gtk2::FontSelection'}{default} = 'font_name';
$class_handlers{'Gtk2::Notebook'}{default} = 'current_page';
$class_handlers{'Gtk2::Window'}{default} = 'title';
$class_handlers{'Gtk2::ProgressBar'}{default} = 'fraction';
$class_handlers{'Gtk2::Range'}{default} = 'value';
$class_handlers{'Gtk2::Menu'}{default} = 'active';
$class_handlers{'Gtk2::CheckMenuItem'}{default} = 'active';

# Special cases
$class_handlers{'Gtk2::Image'}{image} = [q{get_image set_from_image}]; # No mask
$class_handlers{'Gtk2::Image'}{pixbuf} = [q{get_pixbuf set_from_pixbuf}];
$class_handlers{'Gtk2::Image'}{pixmap} = [q{get_pixmap set_from_pixmap}];

# Asymmetric, but maybe useful.  There are probably more of these.
$class_handlers{'Gtk2::Combo'}{use_arrows} = [undef, 'set_use_arrows'];
$class_handlers{'Gtk2::Combo'}{use_arrows_always} = [undef, 'set_use_arrows_always'];
$class_handlers{'Gtk2::Combo'}{case_sensitive} = [undef, 'set_case_sensitive'];
$class_handlers{'Gtk2::Calendar'}{day} = [undef, 'select_day'];
$class_handlers{'Gtk2::Widget'}{child_requisition} = ['get_child_requisition'];
$class_handlers{'Gtk2::Widget'}{toplevel} = ['get_toplevel'];
$class_handlers{'Gtk2::Widget'}{is_focus} = ['is_focus'];
$class_handlers{'Gtk2::Widget'}{visual} = ['get_visual'];
$class_handlers{'Gtk2::Widget'}{modifier_style} = ['get_modifier_style'];
$class_handlers{'Gtk2::Widget'}{pango_context} = ['get_pango_context'];
$class_handlers{'Gtk2::Widget'}{accessible} = ['get_accessible'];
$class_handlers{'Gtk2::Widget'}{parent} = ['get_parent'];
$class_handlers{'Gtk2::Widget'}{settings} = ['get_settings'];
$class_handlers{'Gtk2::Widget'}{display} = ['get_display'];
$class_handlers{'Gtk2::Widget'}{root_window} = ['get_root_window'];
$class_handlers{'Gtk2::Widget'}{screen} = ['get_screen'];
$class_handlers{'Gtk2::Widget'}{has_screen} = ['has_screen'];
$class_handlers{'Gtk2::Widget'}{sensitive} = [undef, 'set_sensitive'];
$class_handlers{'Gtk2::Widget'}{app_paintable} = [undef, 'set_app_paintable'];
$class_handlers{'Gtk2::Widget'}{double_buffered} = [undef, 'set_double_buffered'];
$class_handlers{'Gtk2::Widget'}{redraw_on_allocate} = [undef, 'set_redraw_on_allocate'];

# We can't handle the following, so remove and give a sensible error msg.
delete $class_handlers{'Gtk2::Notebook'}{menu_label};
delete $class_handlers{'Gtk2::Notebook'}{tab_label};
delete $class_handlers{'Gtk2::Notebook'}{menu_label_text};
delete $class_handlers{'Gtk2::Notebook'}{tab_label_text};
delete $class_handlers{'Gtk2::Window'}{default_size};
delete $class_handlers{'Gtk2::Window'}{position};
delete $class_handlers{'Gtk2::Window'}{frame_dimensions};
delete $class_handlers{'Gtk2::Window'}{icon_list};
delete $class_handlers{'Gtk2::Window'}{default_icon_list};
delete $class_handlers{'Gtk2::Curve'}{vector};
delete $class_handlers{'Gtk2::Ruler'}{range};
delete $class_handlers{'Gtk2::TreeView'}{drag_dest_row};
delete $class_handlers{'Gtk2::Layout'}{size};
delete $class_handlers{'Gtk2::ScrolledWindow'}{policy};
delete $class_handlers{'Gtk2::Widget'}{default_colormap};
delete $class_handlers{'Gtk2::Widget'}{default_direction};

# Somewhat a hack, but add data to above data structure for variants handled
# by parent classes.
for my $class (keys %class_handlers) {
    my @isa_chain = _isa_chain ($class);
    shift @isa_chain; # Drop the widget name itself
    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};
        }
    }
}

#{
#    use Data::Dumper;
#    warn Data::Dumper::Dumper (\%class_handlers);
#}

## End of compile-time code

# 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;
    # There should always be a default, since Gtk2::Widget has a default
    $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) =~ /SCALAR/;
    croak "${class}::bind_variable : won'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
    my $bound_already;
    {
        no strict 'refs';
        $bound_already = defined %{$bound_pkg_name . "::"};
    }
    unless ($bound_already) {
        # 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;
}

# Utility functions for accessing perl symbol table

# List methods for package/class/object
sub _list_methods {
    my ($class) = @_;
    $class = ref $class || $class; # Accept object
    $class .= '::' unless $class =~ /::$/;
    local (*alias);
    my @list;
    no strict 'refs';
    while (my ($symb, $val) = each %{$class}) {
        *alias = $val;
        next unless defined &alias;
        $val = (split /::/, $val)[-1];
        push @list, $val;
    }
    return @list;
}

# List class inheritance chain from package/class/object up to (and including)
# Gtk2::Widget.  Take advantage of the simple inheritance chain of widgets in
# Gtk2: only single-inheritance, all widgets ending up at Gtk2::Widget
sub _isa_chain {
    my ($class) = @_;
    $class = ref $class || $class; # Accept object
    $class =~ s/::$//;
    my @isa_chain = ();
    no strict 'refs';
    for (
        my $pclass = $class;
        $pclass =~ /^Gtk2/ and $pclass ne 'Gtk2::Object';
        $pclass = ${"${pclass}::ISA"}[0]
    ) {
        push @isa_chain, $pclass;
    }
    return @isa_chain;
}

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