#!/usr/bin/perl
# vim: set filetype=perl expandtab softtabstop=4 shiftwidth=4 :
use strict;
use warnings;
use Gtk2::TestHelper
tests => 92,
at_least_version => [2, 12, 0, 'GtkBuildable appeared in 2.12'];
my $builder = Gtk2::Builder->new ();
my $ui = <<EOD;
<interface>
<object class="TestThing" id="thing1">
<property name="a">7</property>
<property name="b">ftang</property>
<property name="c">left</property>
<signal name="changed" handler="on_thing1_changed" />
</object>
<object class="TestThingView" id="view1">
<property name="visible">FALSE</property>
<property name="thing">thing1</property>
<property name="color-string">purple</property>
</object>
<object class="TestComplexThing" id="fancy-thing">
<option name="x">10</option>
<option name="y" selected="TRUE">15</option>
<option name="z">20</option>
</object>
<object class="TestComplexWidget" id="fancy-widget">
<property name="shadow-type">in</property>
<child type="label">
<object class="GtkCheckButton" id="check-label">
<property name="label">Woohoo</property>
</object>
</child>
<child>
<object class="GtkLabel" id="content-label">
<property name="label"><b>Bold text</b></property>
<property name="use-markup">TRUE</property>
</object>
</child>
</object>
</interface>
EOD
$builder->add_from_string ($ui);
$builder->connect_signals ();
my $thing1 = $builder->get_object ('thing1');
isa_ok ($thing1, 'TestThing');
is ($thing1->get_name(), 'thing1');
is ($thing1->get ('a'), 7);
is ($thing1->get ('b'), 'ftang');
is ($thing1->get ('c'), 'left');
$thing1->changed ();
sub on_thing1_changed {
my $thing = shift;
ok (1, "on_thing1_changed connected correctly");
isa_ok ($thing, 'TestThing');
}
my $view1 = $builder->get_object ('view1');
isa_ok ($view1, 'TestThingView');
# TestThingView doesn't directly implement Gtk2::Buildable, thus it's not first
# in the @ISA chain. So get_name() alone actually resolves to
# Gtk2::Widget::get_name(), which breaks things as of gtk+ commit
# 46f5ee1d0c0f4601853ed57e99b1b513f1baa445. So fully qualify the method.
is ($view1->Gtk2::Buildable::get_name (), 'view1');
ok (! $view1->get ('visible'));
is ($view1->get ('thing'), $thing1);
is ($view1->get ('color-string'), 'purple');
my $fancything = $builder->get_object ('fancy-thing');
isa_ok ($fancything, 'TestComplexThing');
is ($fancything->get_name (), 'fancy-thing');
use Data::Dumper;
print Dumper($fancything);
is ($fancything->{options}{x}, 10);
is ($fancything->{options}{y}, 15);
is ($fancything->{options}{z}, 20);
is ($fancything->{selected}, 'y');
my $fancywidget = $builder->get_object ('fancy-widget');
isa_ok ($fancywidget, 'TestComplexWidget');
is ($fancywidget->get_name (), 'fancy-widget');
package TestThing;
use strict;
use warnings;
use Gtk2;
use Test::More;
use Glib ':constants';
BEGIN {
Glib::Type->register_enum ('TestThing::Stuff', qw( left right top bottom ));
}
use Glib::Object::Subclass
Glib::Object::,
signals => {
changed => {},
},
properties => [
Glib::ParamSpec->int ('a', 'A', 'A', 1, 10, 5, G_PARAM_READWRITE),
Glib::ParamSpec->string ('b', 'B', 'B', "whee", G_PARAM_READWRITE),
Glib::ParamSpec->enum ('c', 'C', 'C', 'TestThing::Stuff', 'top',
G_PARAM_READWRITE),
],
interfaces => [
Gtk2::Buildable::,
],
;
sub changed {
my $self = shift;
$self->signal_emit ('changed');
}
package TestThingView;
use strict;
use warnings;
use Gtk2;
use Test::More;
use Glib ':constants';
use Glib::Object::Subclass
Gtk2::Table::,
signals => {
},
properties => [
Glib::ParamSpec->object ('thing', 'Thing', 'The Thing',
TestThing::, G_PARAM_READWRITE),
Glib::ParamSpec->string ('color-string', 'Color String', 'duh',
"red", G_PARAM_READWRITE),
],
# NOTE: we DON't implement Buildable here, we inherit it from Gtk2::Widget
;
package TestComplexThing;
use strict;
use warnings;
use Gtk2;
use Test::More;
use Glib ':constants';
use Glib::Object::Subclass
Glib::Object::,
signals => {
},
properties => [
],
# Here we'll override some of the interface methods directly
interfaces => [
Gtk2::Buildable::,
],
;
sub SET_NAME {
my ($self, $name) = @_;
$self->{name} = $name;
}
sub GET_NAME {
my $self = shift;
return $self->{name};
}
sub ADD_CHILD {
my ($self, $builder, $child, $type) = @_;
print "ADD_CHILD $child\n";
}
sub SET_BUILDABLE_PROPERTY {
print "SET_BUILDABLE_PROPERTY\n";
}
{
package TestComplexThing::OptionParser;
use strict;
use warnings;
sub new {
my $class = shift;
return bless { @_ }, $class;
}
sub START_ELEMENT {
my ($self, $context, $tagname, $attributes) = @_;
print "START_ELEMENT $tagname name=\"$attributes->{name}\"\n";
print " ".$context->get_element."\n";
print " ".join(":", $context->get_position)."\n";
print " ".join("/", reverse $context->get_element_stack)."\n"
if $context->can ('get_element_stack');
$self->{tagname} = $tagname;
$self->{attributes} = $attributes;
}
sub TEXT {
my ($self, $context, $text) = @_;
print "TEXT ".$self->{tagname}."\n";
$self->{text} = '' if not defined $self->{text};
$self->{text} .= $text;
}
sub END_ELEMENT {
print "END_ELEMENT ".$_[0]{tagname}."\n";
}
sub DESTROY {
print "DESTROY ".$_[0]{tagname}."\n";
}
}
sub CUSTOM_TAG_START {
my ($self, $builder, $child, $tagname) = @_;
print "CUSTOM_TAG_START $tagname\n";
isa_ok ($self, TestComplexThing::);
isa_ok ($self, Gtk2::Buildable::);
isa_ok ($self, Glib::Object::);
isa_ok ($builder, Gtk2::Builder::);
ok (not defined $child);
is ($tagname, 'option');
return TestComplexThing::OptionParser->new ();
}
sub CUSTOM_TAG_END {
my ($self, $builder, $child, $tagname, $parser) = @_;
print "CUSTOM_TAG_END $tagname\n";
isa_ok ($self, TestComplexThing::);
isa_ok ($builder, Gtk2::Builder::);
ok (not defined $child);
is ($tagname, 'option');
isa_ok ($parser, TestComplexThing::OptionParser::);
$self->{options}{$parser->{attributes}{name}} = $parser->{text};
$self->{selected} = $parser->{attributes}{name}
if $parser->{attributes}{selected};
}
sub CUSTOM_FINISHED {
my ($self, $builder, $child, $tagname, $parser) = @_;
print "CUSTOM_FINISHED $tagname\n";
isa_ok ($self, TestComplexThing::);
isa_ok ($builder, Gtk2::Builder::);
ok (not defined $child);
is ($tagname, 'option');
isa_ok ($parser, TestComplexThing::OptionParser::);
}
sub PARSER_FINISHED {
my ($self, $builder) = @_;
print "PARSER_FINISHED\n";
}
sub GET_INTERNAL_CHILD {
my ($self, $builder, $childname) = @_;
print "GET_INTERNAL_CHILD $childname\n";
return undef;
}
package TestComplexWidget;
use strict;
use warnings;
use Gtk2;
use Test::More;
use Glib ':constants';
use Glib::Object::Subclass
Gtk2::Frame::,
signals => {
},
properties => [
],
# Here we'll override some of the interface methods directly
interfaces => [
Gtk2::Buildable::,
],
;
sub SET_NAME {
my ($self, $name) = @_;
isa_ok ($self, TestComplexWidget::);
isa_ok ($self, Gtk2::Buildable::);
isa_ok ($self, Gtk2::Frame::);
$self->{name} = $name;
}
sub GET_NAME {
my $self = shift;
isa_ok ($self, TestComplexWidget::);
isa_ok ($self, Gtk2::Buildable::);
isa_ok ($self, Gtk2::Frame::);
return $self->{name};
}
sub ADD_CHILD {
my ($self, $builder, $child, $type) = @_;
isa_ok ($self, TestComplexWidget::);
isa_ok ($self, Gtk2::Buildable::);
isa_ok ($self, Gtk2::Frame::);
isa_ok ($builder, Gtk2::Builder::);
isa_ok ($child, Gtk2::Widget::);
if (defined ($type)) {
if ($type eq 'label') {
$self->set_label_widget ($child);
} else {
ok (0, "Unknown internal child type");
}
} else {
$self->add ($child);
}
}
sub SET_BUILDABLE_PROPERTY {
my ($self, $builder, $name, $value) = @_;
isa_ok ($self, TestComplexWidget::);
isa_ok ($self, Gtk2::Buildable::);
isa_ok ($self, Gtk2::Frame::);
isa_ok ($builder, Gtk2::Builder::);
ok (defined $name);
$self->set ($name, $value);
}
# --------------------------------------------------------------------------- #
# GET_INTERNAL_CHILD() returning undef for no such internal child
{
my $get_internal_child = 0;
{
package MyWidget;
use Glib::Object::Subclass 'Gtk2::Widget',
interfaces => [ 'Gtk2::Buildable' ];
sub GET_INTERNAL_CHILD {
$get_internal_child = 1;
return undef;
}
}
my $builder = Gtk2::Builder->new;
eval {
$builder->add_from_string (<<'HERE');
<interface>
<object class="MyWidget" id="mywidget">
<child internal-child="foo">
<object class="GObject" id="in-foo"/>
</child>
<object>
</interface>
HERE
};
my $err = $@;
is ($get_internal_child, 1,
'GET_INTERNAL_CHILD returning undef - iface func called');
isnt ($@, '',
'GET_INTERNAL_CHILD returning undef - builder throws an error');
isa_ok ($err, 'Glib::Error',
'GET_INTERNAL_CHILD returning undef - builder error is a GError');
}