Subclassing widgets in perl
- From: muppet man <scott asofyet org>
- To: gtk-perl list <gtk-perl-list gnome org>
- Subject: Subclassing widgets in perl
- Date: Mon, 15 Sep 2003 22:26:56 -0400
(this started out as an answer to a question gavin asked on irc while i
was gone, but ballooned... i figured you guys might like a decent
example. comments and revisions welcome.)
Gtk is an object-oriented toolkit, so it makes sense to add new
functionality by deriving new widgets. This is rather tedious in C,
but quite easy in perl. Depending on what you need, there are two ways
to do it.
Two ways to do it? Well of course, this is Perl, and there's more than
one way to do it, but shouldn't they come down to the same thing in the
end? Well, sort of. But i'll shut up and give you a couple of
examples.
The Easy Way:
---------------------------------
Let's say you want to create a ColorButton, a composite widget made of
a Button with a colored Frame inside. Let's just go at it with the
normal Perl object stuff...
#!/usr/bin/perl -w
use strict;
# this will be our package...
package Mup::ColorButton;
use Gtk2;
use base 'Gtk2::Button';
sub new {
my $class = shift;
my %params = (
red => 0xffff,
green => 0xffff,
blue => 0xffff,
@_,
);
my $self = bless Gtk2::Button->new (), $class;
my $frame = Gtk2::Frame->new;
$frame->set_border_width (3);
$frame->set_shadow_type ('etched-in');
$self->add ($frame);
$frame->show;
my $event_box = Gtk2::EventBox->new;
$event_box->set_size_request (14, 14);
$frame->add ($event_box);
$event_box->show;
$self->{colorbox} = $event_box;
$self->set_color (%params);
return $self;
}
sub set_color {
my $self = shift;
my %params = @_;
my $color = Gtk2::Gdk::Color->new ($params{red},
$params{green},
$params{blue});
$self->{colorbox}->get_colormap->alloc_color ($color, 0, 1);
$self->{colorbox}->modify_bg ('normal', $color);
$self->{colorbox}->modify_bg ('active', $color);
$self->{colorbox}->modify_bg ('prelight', $color);
$self->{red} = $params{red};
$self->{green} = $params{green};
$self->{blue} = $params{blue};
}
package main;
use Gtk2 -init;
my $window = Gtk2::Window->new;
$window->set_title ('Color buttons');
$window->set_border_width (6);
$window->signal_connect (delete_event => sub { Gtk2->main_quit; 1 });
my $vbox = Gtk2::VBox->new;
$window->add ($vbox);
$vbox->show;
my $foo = Mup::ColorButton->new (red => 0xaaaa, green => 0x0, blue =>
0xffff);
$vbox->pack_start ($foo, 1, 1, 0);
$foo->show;
$foo->signal_connect (clicked => sub {
my $self = shift;
my $dialog = Gtk2::ColorSelectionDialog->new ('pick a
color');
my $c = Gtk2::Gdk::Color->new ($self->{red},
$self->{green},
$self->{blue});
$self->{colorbox}->get_colormap->alloc_color ($c, 0,
1);
$dialog->colorsel->set_current_color ($c);
if ('ok' eq $dialog->run) {
my $c = $dialog->colorsel->get_current_color;
$self->set_color (red => $c->red,
green => $c->green,
blue => $c->blue);
}
$dialog->destroy;
});
$window->show;
Gtk2->main;
Lo and behold, that works! You can treat a Mup::ColorButton just like
a button, connecting handlers to the clicked signal and adding it to
boxed and whatnot. What more could you want?
Well, what about a signal that tells me when the color has changed?
What about creating object properties for the color components? What
about being able to tell some widget factory to create these widgets
for me? Or overriding the show method so that our perl override gets
called by the C code in the library when we do $window->show_all?
Suddenly our simple Perl-only method is insufficient, because all three
of those require a new GType and GTypeClass.
The Hard Way
---------------------------------
GObjects differ from Perl objects in a few very important ways. Perl
keeps track of classes by package name, and looks up methods by
packages; GObject requires you to register classes for runtime
introspection to work, and looks up methods by function pointers. Perl
objects have no problem with multiple inheritance; GObjects do single
inheritance. (There are more, but i'll stop there.) Gtk2-Perl tries
very hard to hide these differences from you, but in many places they
leak through. One such place is the fact that you have to register a
GObject-based class before you can create signals or properties for
it.[1]
It sounds nasty, but it really isn't that hard.
#!/usr/bin/perl -w
use strict;
package Mup::ColorButton;
use Gtk2;
# this big hairy statement registers our Glib::Object-derived class
# and sets up all the signals and properties for it.
use Glib::Object::Subclass
Gtk2::Button::,
signals => {
# with an empty hash for color_changed, we use all defaults,
# which results in a signal which takes no parameters and
# returns no value.
color_changed => {},
# by supplying a subroutine reference for an existing signal,
# we override the default handler for the class; this is how
# you override virtual functions on Glib::Objects.
show => \&on_show,
},
properties => [
Glib::ParamSpec->int (
'red', # name
'Red', # nickname
'The Red component of the RGB color', #blurb
0, # min
0xffff, # max
0xffff, # default
[qw/readable writable/] #flags
),
Glib::ParamSpec->int (
'green', 'Green', 'The Green component of the RGB
color',
0, 0xffff, 0xffff, [qw/readable writable/]
),
Glib::ParamSpec->int (
'blue', 'Blue', 'The Blue component of the RGB color',
0, 0xffff, 0xffff, [qw/readable writable/]
),
]
;
# as part of creating the C object, Glib will call the INIT_INSTANCE
# method to, surprise, initialize the instance. this is not an
inherited
# method; it will be called with a fully-qualified package name.
# most of what we used to have in the constructor goes here.
# in fact, we just inherit new() from the base class, because it does
# everything we need it to.
sub INIT_INSTANCE {
my $self = shift;
$self->{red} = 0xffff;
$self->{green} = 0xffff;
$self->{blue} = 0xffff;
my $frame = Gtk2::Frame->new;
$frame->set_border_width (3);
$frame->set_shadow_type ('etched-in');
$self->add ($frame);
$frame->show;
my $event_box = Gtk2::EventBox->new;
$event_box->set_size_request (14, 14);
$frame->add ($event_box);
$event_box->show;
$self->{colorbox} = $event_box;
}
# in a more ambitious widget, we'd probably define GET_PROPERTY
# and SET_PROPERTY to do some custom stuff... for our purposes,
# however, the default implementation provided by
Glib::Object::Subclass
# is sufficient. (it sets the property values as hash members in the
# instance variable.)
# here we need to override the show method to set the color the
# first time we go onscreen, because we can't do that in the
# initializer (the GdkWindow does not exist yet).
sub on_show {
my $self = shift;
$self->set_color (red => $self->{red},
green => $self->{green},
blue => $self->{blue});
# perl code that needs to call the parent class usually does
something
# like $self->SUPER::methodname ---- however, class_closures
for
# for Glib::Objects are not inheritable in that way; the code
to which
# we need to chain may not even be perl code. Glib provides
this
# method to provide that functionality, instead.
$self->signal_chain_from_overridden;
}
sub set_color {
my $self = shift;
my %params = @_;
my $color = Gtk2::Gdk::Color->new ($params{red},
$params{green},
$params{blue});
$self->{colorbox}->get_colormap->alloc_color ($color, 0, 1);
$self->{colorbox}->modify_bg ('normal', $color);
$self->{colorbox}->modify_bg ('active', $color);
$self->{colorbox}->modify_bg ('prelight', $color);
$self->{red} = $params{red};
$self->{green} = $params{green};
$self->{blue} = $params{blue};
# emit the color-changed signal. note again that the signal
# name treats - and _ as equivalent.
$self->signal_emit ('color-changed');
}
package main;
use Gtk2 -init;
my $window = Gtk2::Window->new;
$window->set_title ('Color buttons');
$window->set_border_width (6);
$window->signal_connect (delete_event => sub { Gtk2->main_quit; 1 });
my $vbox = Gtk2::VBox->new;
$window->add ($vbox);
$vbox->show;
my $foo = Mup::ColorButton->new (red => 0xaaaa, green => 0x0, blue =>
0xffff);
$vbox->pack_start ($foo, 1, 1, 0);
$foo->show;
$foo->signal_connect (clicked => sub {
my $self = shift;
my $dialog = Gtk2::ColorSelectionDialog->new ('pick a
color');
my $c = Gtk2::Gdk::Color->new ($self->{red},
$self->{green},
$self->{blue});
$self->{colorbox}->get_colormap->alloc_color ($c, 0,
1);
$dialog->colorsel->set_current_color ($c);
if ('ok' eq $dialog->run) {
my $c = $dialog->colorsel->get_current_color;
$self->set_color (red => $c->red,
green => $c->green,
blue => $c->blue);
}
$dialog->destroy;
});
$foo->signal_connect (color_changed => sub {
warn "the color changed - now "
. join (", ", $_[0]->get (qw/red green blue/))
. ". i should do something!";
});
$window->show;
Gtk2->main;
If you didn't notice, the driver program section differs from the
previous version only in the connection to the new signal. Also notice
that we can use the $gobject->get and $gobject->set interface to work
with the member variables (now properties).
Things to remember:
- use Glib::Object::Subclass to register your widget with signals,
overrides, and properties.
- provide an INIT_INSTANCE function to initialize new objects
- try to inherit the parent's constructor if you can.
- use $object->signal_chain_from_overridden instead of
SUPER::methodname.
- NEVER override the DESTROY method, or you will break the Glib::Object
magic.
There are lots more possibilities; you can have parameters and return
values for your signals, and custom accumulators. There are lots of
object property types. There are also several more methods that you
can override; be sure to read the documentation for
Glib::Object::Subclass.
[1] Why not just auto-register the inheritance based on the contents
of @ISA? Because Perl objects can do multiple inheritance, but
GObjects only do single inheritance, and the first thing in @ISA isn't
necessarily the correct base class in the GObject paradigm.
--
muppet <scott at asofyet dot org>
[
Date Prev][
Date Next] [
Thread Prev][
Thread Next]
[
Thread Index]
[
Date Index]
[
Author Index]
