#!/usr/bin/perl
#
# test Glib::Object derivation in Perl.
# derive from a C object in perl, and derive from a Perl object in perl.
# checks order of execution of initializers and finalizers, so the code
# gets a little hairy.
#
use strict;
use warnings;
use Glib qw(:constants);
# From 7.t. Do we need a test helper class?
sub ok($$;$) {
my($test, $num, $name) = @_;
my $out = $test ? "ok" : "not ok";
$out .= " $num" if $num;
$out .= " - $name" if defined $name;
print "$out\n";
return $test;
}
sub pass($;$) {
my($num, $name) = @_;
return ok(1, $num, $name);
}
sub fail(;$) {
my($name) = @_;
return ok(0, 0, $name);
}
print "1..17\n";
pass 1;
my $init_self;
sub Foo::INIT_INSTANCE {
$init_self = $_[0]*1;
pass 2, 'Foo::INIT_INSTANCE';
}
sub Foo::FINALIZE_INSTANCE {
pass 9, 'Foo::FINALIZE_INSTANCE'
}
my $setprop_self;
sub Foo::SET_PROPERTY {
$setprop_self = $_[0]*1;
pass $_[2], 'Foo::SET_PROPERTY';
}
sub Foo::GET_PROPERTY {
pass 6, 'Foo::GET_PROPERTY';
6;
}
Glib::Type->register (
Glib::Object::, Foo::,
properties => [
Glib::ParamSpec->string (
'some_string',
'Some String Property',
'This property is a string that is used as an example',
'default value',
[qw/readable writable/]
),
]);
sub Bar::INIT_INSTANCE {
pass 3, 'Bar::INIT_INSTANCE';
}
sub Bar::FINALIZE_INSTANCE {
pass 8, 'Bar::FINALIZE_INSTANCE';
}
Glib::Type->register (Foo::, Bar::,
properties => [
Glib::ParamSpec->int ('number', 'some number',
'number in bar but not in foo',
0, 10, 0, ['readable']),
]);
{
# instantiate a child. we should get messages from both initializers.
my $bar = new Bar;
# make sure we can set parent properties on the child
$bar->set(some_string => 4);
ok $init_self == $setprop_self, 5;
ok $bar->get("some_string") == 6, 7;
# should see messages from both finalizers here.
}
pass 10;
#
# ensure that any properties added to the subclass were only added to
# the subclass, and not the parent.
#
ok defined Foo->find_property('some_string'), 11;
ok !defined Foo->find_property('number'), 12;
ok defined Bar->find_property('number'), 13;
my @fooprops = Foo->list_properties;
my @barprops = Bar->list_properties;
ok @fooprops == 1, 14, 'property count for parent';
ok @barprops == 2, 15, 'property count for child';
my @ancestry = Glib::Type->list_ancestors ('Bar');
my $ancestry_ok = $ancestry[0] eq 'Bar' &&
$ancestry[1] eq 'Foo' &&
$ancestry[2] eq 'Glib::Object';
print "".($ancestry_ok ? "ok 16" : "not ok")." - ancestry for Bar\n";
my $cname_ok = Glib::Type->package_from_cname ('GObject') eq 'Glib::Object';
print "".($cname_ok ? "ok 17" : "not ok")." - package_from_cname\n";
__END__
Copyright (C) 2003-2006 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.,
51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.