Re: A little tie magic
- From: Bjarne Steinsbø <bosteins broadpark no>
- To: muppet <scott asofyet org>
- Cc: gtk-perl-list gnome org
- Subject: Re: A little tie magic
- Date: Thu, 08 Jan 2004 14:28:09 +0100
A long time ago, muppet wrote:
Bjarne Steinsbø said:
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:
i have no objections to including this, since it is optional and the
functionality seems generally useful and perlish (especially given the
precendent in Tk).
it's also fairly unlikely that the name "bind_variable" will clash with
something that the upstream library will choose. for complete safety and
clarity, however, i would probably choose a slightly ugly alternative such as
"_tie_variable" (leading _ because it's an extension, and 'tie' rather than
'bind' because it's using tie).
however, more than just the 't' sample you attached, we'd need a t-dir
non-interactive regression test and a nicely commented example to show how to
use it. and remember that its API needs to be frozen by march, and all
releases after that must retain backwards compatibility.
Will this do?
Latest iteration includes some bug fixes, including (I hope) fixes for
the possible leaks. Also name changes more or less as suggested, and
more comments/documentation.
Bjarne
#########################
# Gtk2::TieScalar Tests
# - Bjarne Steinsbo
#########################
use Gtk2::TestHelper tests => 13;
require_ok( 'Gtk2::TieScalar' );
# Won't need to realize the test widget
my $button = Gtk2::Button->new;
# Tie to default for button (= label)
my $v;
ok( $button->_tie_scalar (\$v) );
# Initial value should be set by button, not by the tie
ok( !defined ($v) );
# Set label to something
ok( $v = 'something' );
# read back
ok( defined ($v) and $v eq 'something' );
# check against normal access
ok( $button->get_label eq 'something' );
# set using normal access
$button->set_label ('something_else');
# check against tied variable
ok( defined ($v) and $v eq 'something_else' );
# re-use tied variable for something else
ok( untie $v );
$v = 'half';
ok( $button->_tie_scalar (\$v, 'relief') );
# read back
ok( $button->get_relief eq 'half' );
# tie to inherited methods
my $vv;
ok( $button->_tie_scalar (\$vv, 'name') );
ok( defined ($vv) and $vv ne '' );
# let tied variable go out of scope
ok( eval {
my $vv = 'label';
$button->_tie_scalar (\$vv);
$vv eq 'label';
} );
__END__
Copyright (C) 2003 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
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.
#! /usr/bin/perl -w
#
# Copyright (C) 2003 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
# 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.
#
# Extend the "buttonbox.pl" example to allow the user to change the spacing.
# - Bjarne Steinsbo
# Comment from "buttonbox.pl":
# # this was originally gtk-2.2.1/examples/buttonbox/buttonbox.c
# # ported to gtk2-perl by rm
use strict;
use Gtk2;
use Gtk2::TieScalar;
use constant TRUE => 1;
use constant FALSE => 0;
Gtk2->init;
# Create a Button Box with the specified parameters
sub create_bbox
{
my $horizontal = shift;
my $title = shift;
my $spacing = shift;
my $child_w = shift;
my $child_h = shift;
my $layout = shift;
my $frame = Gtk2::Frame->new($title);
my $bbox;
# Create a spin-button to control the spacing, and tie the $spacing
# variable to the default get/set_... methods for a spin-button, which
# happens to be the "get/set_value_as_float".
my $spin = Gtk2::SpinButton->new_with_range (0, $spacing * 100, 1)
->_tie_scalar (\$spacing);
# This will become the variable controlling the new spacing for the
# button-box.
my $new_spacing = $spacing;
# Need something active to actually transfer the value from the
# spin-button to the button-box, as a signal on the spin-button.
$spin->signal_connect (value_changed => sub {
$new_spacing = $spacing;
});
if( $horizontal )
{
$bbox = Gtk2::HButtonBox->new;
}
else
{
$bbox = Gtk2::VButtonBox->new;
}
# Tie $new_spacing to the 'get/set_spacing' methods for the
# button-box.
$bbox->_tie_scalar (\$new_spacing, 'spacing');
$bbox->set_border_width(5);
$frame->add($bbox);
# Set the appearance of the Button Box
$bbox->set_layout($layout);
#gtk_button_box_set_child_size (GTK_BUTTON_BOX (bbox), child_w, child_h);
# "Cheat" a bit by adding the spin-button to a button box. It does
# seem to work...
$bbox->add ($spin);
my $button = Gtk2::Button->new_from_stock('gtk-ok');
$button->signal_connect( 'clicked' => sub {
print "$title ok clicked\n"; } );
$bbox->add($button);
$button = Gtk2::Button->new_from_stock('gtk-cancel');
$button->signal_connect( 'clicked' => sub {
print "$title cancel clicked\n"; } );
$bbox->add($button);
$button = Gtk2::Button->new_from_stock('gtk-help');
$button->signal_connect( 'clicked' => sub {
print "$title help clicked\n"; } );
$bbox->add($button);
return($frame);
}
# Initialize GTK
Gtk2->init;
my $window = Gtk2::Window->new("toplevel");
$window->set_title("Button Boxes");
$window->signal_connect( "destroy" => sub {
Gtk2->main_quit;
});
$window->set_border_width(10);
my $main_vbox = Gtk2::VBox->new("false", 0);
$window->add($main_vbox);
my $frame_horz = Gtk2::Frame->new("Horizontal Button Boxes");
$main_vbox->pack_start($frame_horz, TRUE, TRUE, 10);
my $vbox = Gtk2::VBox->new(FALSE, 0);
$vbox->set_border_width(10);
$frame_horz->add($vbox);
$vbox->pack_start(
create_bbox(TRUE, 'Spread', 40, 85, 20, 'spread'),
TRUE, TRUE, 0);
$vbox->pack_start(
create_bbox(TRUE, 'Edge', 30, 85, 20, 'edge'),
TRUE, TRUE, 5);
$vbox->pack_start(
create_bbox(TRUE, 'Start', 20, 85, 20, 'start'),
TRUE, TRUE, 5);
$vbox->pack_start(
create_bbox(TRUE, 'End', 10, 85, 20, 'end'),
TRUE, TRUE, 5);
my $frame_vert = Gtk2::Frame->new("Vertical Button Boxes");
$main_vbox->pack_start($frame_vert, TRUE, TRUE, 10);
my $hbox = Gtk2::HBox->new(FALSE, 0);
$hbox->set_border_width(10);
$frame_vert->add($hbox);
$hbox->pack_start(
create_bbox(FALSE, 'Spread', 5, 85, 20, 'spread'),
TRUE, TRUE, 0);
$hbox->pack_start(
create_bbox(FALSE, 'Edge', 30, 85, 20, 'edge'),
TRUE, TRUE, 0);
$hbox->pack_start(
create_bbox(FALSE, 'Start', 20, 85, 20, 'start'),
TRUE, TRUE, 0);
$hbox->pack_start(
create_bbox(FALSE, 'End', 20, 85, 20, 'end'),
TRUE, TRUE, 0);
$window->show_all;
# Enter the event loop
Gtk2->main;
exit 0;
package Gtk2::TieScalar;
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::) {
# We only want other symbol table entries
next unless $key =~ /::$/;
# Re-construct the package name
my $pkg_name = 'Gtk2::' . $key;
$pkg_name =~ s/::$//;
my @isa_chain = _isa_chain ($pkg_name);
# Must inherit from Widget
next unless grep { $_ eq 'Gtk2::Widget' } @isa_chain;
# OK, we've found one. Make room for it.
$class_handlers{$pkg_name} = {};
# Seach through the methods
my %methods = map { $_ => 1 } _list_methods ($pkg_name);
for my $meth (keys %methods) {
# One called set_something
next unless $meth =~ /^set(.*)$/;
my $something = $1;
# And one called get_something
next unless exists $methods{'get' . $something};
# Get rid of a possible leading underscore
(my $no_underscore = $something) =~ s/^_//;
# And install it in the data structure
$class_handlers{$pkg_name}{$no_underscore} = [
'get' . $something, 'set' . $something
];
}
}
# Now augment and fix %class_handlers. This is the whole point of having
# a separate data structure for it, otherwise we could have done it all
# automagically.
# 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';
$class_handlers{'Gtk2::FileSelection'}{default} = 'filename';
$class_handlers{'Gtk2::Entry'}{default} = 'text';
$class_handlers{'Gtk2::TextView'}{default} = 'buffer';
$class_handlers{'Gtk2::OptionMenu'}{default} = 'menu';
$class_handlers{'Gtk2::FontSelectionDialog'}{default} = 'font_name';
$class_handlers{'Gtk2::SpinButton'}{default} = 'value';
# 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.
# There are probably more of these, confusing the user with strange error
# messages if they are ever tried.
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}}) {
# Don't overwrite existing names
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!
# Give it a slightly whacky name to make double sure it won't ever collide
# with a native name.
sub Gtk2::Widget::_tie_scalar {
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 "Gtk2::Widget::_tie_scalar : no such variant '$variant' for '$class'"
unless exists $class_handlers{$class}{$variant};
croak "Gtk2::Widget::_tie_scalar : Need reference to scalar"
unless ref ($var) =~ /SCALAR/;
# Get rid of any previous ties to this variable.
# Just to be sure to be sure.
untie $$var if tied $$var;
# Create a package name for the handlers to live in. The
# actual name doesn't really matter, as long as it's consistently
# created, and as long as it is unique for $class and $variant.
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.
# The created class will inherit from $class (to allow it to call
# $class's methods) as well as from Gtk2::TieScalar (so that the
# FETCH/STORE used by the tie will end up at the right place).
# The methods are given standard names, so that FETCH/STORE will know
# what to call.
my $code = qq{
package $bound_pkg_name;
use strict;
use Carp;
our \ ISA = qw(Gtk2::TieScalar $class);
};
my ($getter, $setter) = @{$class_handlers{$class}{$variant}};
if (defined $getter) {
$code .= qq{
sub _get_tied_contents { \${\$_[0]}->$getter; }
};
} else {
$code .= q{
sub _get_tied_contents { croak "Scalar is write-only"; }
};
}
if (defined $setter) {
$code .= qq{
sub _set_tied_contents { \${\$_[0]}->$setter (\$_[1]); }
};
} else {
$code .= q{
sub _set_tied_contents { croak "Scalar is read-only"; }
};
}
$code .= "1;\n";
# print $code;
eval $code;
die "Gtk2::TieScalar : Can't compile code for '$class' : $@"
if $@;
}
my $val = $$var; # Copy contents before tie
tie $$var, 'Gtk2::TieScalar', $self, $bound_pkg_name;
$$var = $val if defined $val; # Trigger init now that the tie is in place
return $self; # Return widget, making chaining possible
}
# The tied scalar methods
sub TIESCALAR {
my ($class, $self, $other_class) = @_;
return bless \$self, $other_class;
}
sub FETCH {
$_[0]->_get_tied_contents;
}
sub STORE {
$_[0]->_set_tied_contents ($_[1]);
}
# 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; # Only functions are of interest
$val = (split /::/, $val)[-1]; # Pick out last part of name
push @list, $val;
}
return @list;
}
# List class inheritance chain from package/class/object up to (and including)
# Gtk2::Widget.
sub _isa_chain {
my ($class, @isa_chain) = @_;
$class = ref $class || $class; # Accept object
$class =~ s/::$//;
@isa_chain = ($class) unless scalar @isa_chain;
return @isa_chain if $class !~ /^Gtk2/ or $class eq 'Gtk2::Object';
no strict 'refs';
for my $pclass (@{"${class}::ISA"}) {
push @isa_chain, $pclass;
@isa_chain = _isa_chain ($pclass, @isa_chain);
}
return @isa_chain;
}
1;
=head1 NAME
Gtk2::TieScalar - Install extra methods in various packages to tie a perl
scalar to the underlying widget contents.
=head1 SYNOPSIS
use Gtk2;
use Gtk2::TieScalar;
my $label = Gtk2::Label->new();
my $label_txt = 'This is the label';
$label->_tie_scalar (\$label_txt);
$label_txt = 'New label text';
my $ckbutton = Gtk2::CheckButton->new;
my $but = 1;
$ckbutton->_tie_scalar (\$but, 'active');
if ($but) { do_something () };
my $but_label = 'Push me!';
$ckbutton->_tie_scalar (\$but_label, 'label'); # Another variant for buttons
# _tie_scalar returns the widget, so chaining calls is OK
my $spin_val;
my $spin = Gtk2::SpinButton
->new_with_range (0, 100, 10)
->_tie_scalar (\$spin_val);
=head1 ABSTRACT
Ties perl scalars 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.
In general, if a Gtk2 widget I<Gtk2::SomeWidget> has a pair of functions
called get_I<something>/set_I<something>, and the I<something> is a scalar
value, it will be possible to tie a perl scalar to I<something> in an
instance of I<Gtk2::SomeWidget>:
$some_widget_instance->_tie_scalar (\$perl_scalar, 'something');
After the tie, reading C<$perl_scalar> will actually do
C<$some_widget_instance-E<gt>get_something>
while storing C<$value> to C<$perl_scalar> will actually do
C<$some_widget_instance-E<gt>set_something ($value)>.
There are more or less sensible defaults for different Gtk2 widgets in place,
so that I<something> can be dropped in the C<_tie_scalar> call for the most
frequently used variants. The defaults are:
=over
=item Gtk2::Button 'label'
=item Gtk2::CheckMenuItem 'active'
=item Gtk2::ColorSelection 'current_color'
=item Gtk2::Entry 'text'
=item Gtk2::Frame 'label'
=item Gtk2::FileSelection 'filename'
=item Gtk2::FontSelection 'font_name'
=item Gtk2::FontSelectionDialog 'font_name'
=item Gtk2::Image 'image'
=item Gtk2::Label 'text'
=item Gtk2::Menu 'active'
=item Gtk2::MenuItem 'submenu'
=item Gtk2::Notebook 'current_page'
=item Gtk2::OptionMenu 'menu'
=item Gtk2::Paned 'position'
=item Gtk2::ProgressBar 'fraction'
=item Gtk2::Range 'value'
=item Gtk2::SpinButton 'value'
=item Gtk2::TextView 'buffer'
=item Gtk2::ToggleButton 'active'
=item Gtk2::Widget 'name'
=item Gtk2::Window 'title'
=back
There also experimental support for some read-only and write-only scalars.
=over
=item Gtk2::Calendar 'day' write-only
=item Gtk2::Combo 'case_sensitive' write-only
=item Gtk2::Combo 'use_arrows' write-only
=item Gtk2::Combo 'use_arrows_always' write-only
=item Gtk2::Widget 'accessible' read-only
=item Gtk2::Widget 'app_paintable' write-only
=item Gtk2::Widget 'child_requisition' read-only
=item Gtk2::Widget 'display' read-only
=item Gtk2::Widget 'double_buffered' write-only
=item Gtk2::Widget 'has_screen' read-only
=item Gtk2::Widget 'is_focus' read-only
=item Gtk2::Widget 'modifier_style' read-only
=item Gtk2::Widget 'pango_context' read-only
=item Gtk2::Widget 'parent' read-only
=item Gtk2::Widget 'redraw_on_allocate' write-only
=item Gtk2::Widget 'root_window' read-only
=item Gtk2::Widget 'sensitive' write-only
=item Gtk2::Widget 'screen' read-only
=item Gtk2::Widget 'settings' read-only
=item Gtk2::Widget 'toplevel' read-only
=item Gtk2::Widget 'visual' read-only
=back
Please note that the class hierarchy of the Gtk2 widgets is honoured, so
the defaults (as well as any I<something>) will be inherited from parent
classes, all the way from Gtk2::Widget.
Also please note that the tied scalar will hold a reference to the widget.
Explicitly destroy the tie or delete the scalar to break this reference
for the widget to be properly garbage collected after destroying 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
[
Date Prev][
Date Next] [
Thread Prev][
Thread Next]
[
Thread Index]
[
Date Index]
[
Author Index]