#!/usr/bin/perl -w
=doc
Tests for new property features. These should probably go into 4.t and 5.t,
but the test suite is a mess of order-of-operations spaghetti tests and i
don't really want to mess with that. Someday we'll have to overhaul this
suite, but it's late on Sunday night and i don't have the energy to fix what
ain't really broke.
This stuff makes Glib::Object::Subclass's GET_PROPERTY()/SET_PROPERTY()
replacements unnecessary. Any ideas how to obsolete its new() replacement?
=cut
use Test::More tests => 54;
use Glib ':constants';
use Data::Dumper;
use strict;
# we'll test, for paranoia's sake, that things work the same both with and
# without Glib::Object::Subclass; to simplify things, let's use the exact
# same list of properties for both. however, since the GObjects take
# ownership of the pspecs, we can't share them. just use the same code
# to create them:
sub make_properties {
# a basic one
Glib::ParamSpec->string ('name', '', '', 'Joe', G_PARAM_READWRITE),
# now with the new explicit handler syntax:
{
# with no handlers, this is the same as not using the hash
pspec => Glib::ParamSpec->string ('middle', '', '', 'Momma',
G_PARAM_READWRITE),
},
{
pspec => Glib::ParamSpec->string ('nickname', '', '', 'Jimmy-John',
G_PARAM_READWRITE),
get => sub { ok(1, 'explicit getter for nickname');
$_[0]->{nickname} },
set => sub { ok(1, 'explicit setter for nickname');
$_[0]->{nickname} = $_[1] },
},
{
# if you leave out a getter, you get the default behavior
pspec => Glib::ParamSpec->string ('surname', '', '', 'Jones',
G_PARAM_READWRITE),
set => sub { ok(1, 'explicit setter for surname');
$_[0]->{surname} = $_[1] },
},
{
# same for leaving out a setter
pspec => Glib::ParamSpec->string ('title', '', '', 'Mr',
G_PARAM_READWRITE),
get => sub { ok(1, 'explicit getter for title');
$_[0]->{title} },
},
};
# create a new object type by hand (no Glib::Object::Subclass)
Glib::Type->register_object ('Glib::Object', 'Foo',
properties => [ &make_properties ]);
# now create one with Subclass, with the same properties.
package Bar;
use Glib::Object::Subclass 'Glib::Object',
properties => [ &main::make_properties ];
package main;
sub prop_names {
map { UNIVERSAL::isa ($_, 'Glib::ParamSpec')
? $_->get_name
: $_->{pspec}->get_name
} @_
}
sub Glib::Object::_list_property_names {
prop_names $_[0]->list_properties
}
sub default_values {
map { $_->get_default_value } $_[0]->list_properties
}
my @names = prop_names &make_properties;
# start tests
is_deeply ([prop_names (Foo->list_properties)], \@names,
'props created correctly for Foo');
my $foo = Foo->new;
isa_ok ($foo, 'Foo', 'it\'s a Foo');
is (scalar keys %$foo, 0, 'new Foo has no keys');
# initially all props should have all default values, except for the ones
# with explicit getters, as the explicit getters don't handle default values.
my @initial_values = default_values ('Foo');
$initial_values[2] = undef;
$initial_values[4] = undef;
my @values = $foo->get (@names);
is_deeply ([$foo->get (@names)], \@initial_values,
'all defaults except for explicit ones');
is (scalar keys %$foo, 0, 'Foo still has no keys after get');
my @default_values = default_values ('Foo');
$foo->set (map { $names[$_], $default_values[$_] } 0..$#names);
is (scalar keys %$foo, 5, 'new Foo has keys after setting');
is_deeply ([ map {$foo->{$_}} @names ], [ @default_values ],
'and they have values');
# now add a GET_PROPERTY and SET_PROPERTY that will be called when no
# explicit ones are supplied.
sub get_property {
ok (1, 'fallback GET_PROPERTY called');
return 'fallback';
}
sub set_property {
ok (1, 'fallback SET_PROPERTY called');
$_[0]->{$_[1]->get_name} = 'fallback';
}
{
no warnings;
*Foo::GET_PROPERTY = \&get_property;
*Foo::SET_PROPERTY = \&set_property;
}
# start over.
$foo = Foo->new;
isa_ok ($foo, 'Foo', 'it\'s a Foo');
is (scalar keys %$foo, 0, 'new Foo has no keys');
# with the overrides in place, none of the implicit keys will have values
# in get, because Subclass's GET doesn't handle defaults.
my @expected = map { defined $_ ? 'fallback' : undef } @initial_values;
@values = $foo->get (@names);
is_deeply ([$foo->get (@names)], \@expected,
'fallback called for implicit getters');
is (scalar keys %$foo, 0, 'Foo still has no keys after get');
@expected = @default_values;
$expected[0] = 'fallback';
$expected[1] = 'fallback';
$expected[4] = 'fallback';
$foo->set (map { $names[$_], $default_values[$_] } 0..$#names);
is (scalar keys %$foo, 5, 'new Foo has keys after setting');
is_deeply ([ map {$foo->{$_}} @names ], [ @expected ],
'and they have values');
#
# now verify that Subclass still works as expected.
#
my $bar = Bar->new;
is (scalar keys %$bar, 0, 'bar has no keys on creation');
@expected = @default_values;
$expected[2] = undef;
$expected[4] = undef;
is_deeply ([$bar->get (@names)], \@expected,
'Subclass works just like registering by hand');
$bar->set (map { $names[$_], $default_values[$_] } 0..$#names);
is (scalar keys %$bar, 5, 'new Foo has keys after setting');
is_deeply ([ map {$bar->{$_}} @names ], [ @default_values ],
'and they have values');
{
# Prior to 1.240 a subclass of a class with a pspec/get/set did not reach
# the specified get/set funcs.
my @getter_args;
my @setter_args;
{
package BaseGetSet;
use Glib::Object::Subclass
'Glib::Object',
properties => [
{
pspec => Glib::ParamSpec->string ('my-prop',
'My-Prop',
'Blurb one',
'default one',
['readable','writable']),
get => sub {
@getter_args = @_;
},
set => sub {
@setter_args = @_;
},
},
];
}
{
package SubGetSet;
use Glib::Object::Subclass 'BaseGetSet';
}
my $obj = SubGetSet->new;
@getter_args = ();
@setter_args = ();
$obj->get ('my-prop');
is_deeply (\@getter_args, [$obj], 'my-prop reaches BaseGetSet');
is_deeply (\@setter_args, [], 'my-prop reaches BaseGetSet');
@getter_args = ();
@setter_args = ();
$obj->set (my_prop => 'zzz');
is_deeply (\@getter_args, [], 'my-prop reaches BaseGetSet');
is_deeply (\@setter_args, [$obj,'zzz'], 'my-prop reaches BaseGetSet');
}
{
# Prior to 1.240 a class with a pspec/get/set which is subclassed with
# another separate pspec/get/set property called to the subclass get/set
# funcs, not the superclass ones.
my @baseone_getter_args;
my @baseone_setter_args;
{
package BaseOne;
use Glib::Object::Subclass
'Glib::Object',
properties => [
{
pspec => Glib::ParamSpec->string ('prop-one',
'Prop-One',
'Blurb one',
'default one',
['readable','writable']),
get => sub {
@baseone_getter_args = @_;
},
set => sub {
# Test::More::diag('baseone setter');
@baseone_setter_args = @_;
},
},
];
}
my @subtwo_getter_args;
my @subtwo_setter_args;
{
package SubTwo;
use Glib::Object::Subclass
'BaseOne',
properties => [
{
pspec => Glib::ParamSpec->string ('prop-two',
'Prop-Two',
'Blurb two',
'default two',
['readable','writable']),
get => sub {
@subtwo_getter_args = @_;
},
set => sub {
# Test::More::diag('subtwo setter');
@subtwo_setter_args = @_;
},
},
];
}
my $obj = SubTwo->new;
@baseone_getter_args = ();
@subtwo_getter_args = ();
$obj->get ('prop-two');
is_deeply (\@baseone_getter_args, [], 'prop-two goes to subtwo');
is_deeply (\@subtwo_getter_args, [$obj], 'prop-two goes to subtwo');
@baseone_getter_args = ();
@subtwo_getter_args = ();
$obj->get ('prop-one');
is_deeply (\@baseone_getter_args, [$obj], 'prop-one goes to baseone');
is_deeply (\@subtwo_getter_args, [], 'prop-one goes to baseone');
@baseone_setter_args = ();
@subtwo_setter_args = ();
$obj->set (prop_two => 'xyz');
is_deeply (\@baseone_setter_args, [], 'prop-two goes to subtwo');
is_deeply (\@subtwo_setter_args, [$obj,'xyz'], 'prop-two goes to subtwo');
@baseone_setter_args = ();
@subtwo_setter_args = ();
$obj->set (prop_one => 'abc');
is_deeply (\@baseone_setter_args, [$obj,'abc'], 'prop-one goes to baseone');
is_deeply (\@subtwo_setter_args, [], 'prop-one goes to baseone');
}