by muppet, 15 Sep 2003
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.
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 =>
fff);
$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,
$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.
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 receives no extra parameters[2]
# 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:
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.
[2] That is, no parameters beyond the instance and user data, which are passed to all signal handlers. The instance on which the signal handler is connected is always passed first, and any user data added at signal_connect-time always comes last, if present. So a signal with "no parameters" will actually get at least one, at most two.