use strict;
use warnings;
my $HAVE_STORABLE;
BEGIN {
if ($] < 5.008) {
print("1..0 # Skip Introspection requires Perl 5.8.0 or later\n");
exit(0);
}
eval { require Storable; };
$HAVE_STORABLE = !$@;
}
use Test::More 'tests' => 43;
package Foo; {
use Object::InsideOut;
my @data :Field :Type(num) :All(data);
my @get :Field
:Type(\&Foo::my_sub)
:Set(setget)
:Get('name' => 'fooget', 'perm' => 'restricted');
my $id = 1;
sub id :ID(restricted) {
return ($id++);
}
sub my_sub :Sub {}
sub my_foo :Method(Class) {}
sub my_fink :Restricted :Method(Object) {}
sub cu :Cumulative { return ('Foo cumulative'); }
sub ch :Chain(Bottom up)
{
my ($self, $val) = @_;
return ($val . ' ' . __PACKAGE__);
}
sub am :Automethod
{
return (sub {});
}
}
package Bar; {
BEGIN {
no warnings 'once';
$Bar::storable = $HAVE_STORABLE;
}
use Object::InsideOut qw(Foo);
use Object::InsideOut::Metadata;
my @info :Field :Type(list(num)) :All(info);
my @more :Field :Type(ARRAY(Foo)) :Arg(more);
my @set
:Field
:Type(sub { $_[0]->isa('UNIVERSAL') })
:Set('name' => 'barset', 'ret' => 'old');
sub cu :Cumulative { return ('Bar cumulative'); }
sub ch :Chain(Bottom up)
{
my ($self, $val) = @_;
return ('Chain: ', __PACKAGE__);
}
sub _internal { return; }
sub bar :Method { return; }
add_meta(__PACKAGE__, 'bar', 'bork', 1);
sub bork :Method :MergeArgs(restricted) { return; }
}
package main;
sub check_bar
{
my $thing = shift;
my $meta = $thing->meta();
my @classes_are = (qw/Foo Bar Storable/);
if (! $HAVE_STORABLE) {
pop(@classes_are);
}
my @classes = $meta->get_classes();
is_deeply(\@classes, \@classes_are, 'Meta classes');
my $classes = $meta->get_classes();
is_deeply($classes, \@classes_are, 'Meta classes (ref)');
@classes = $thing->isa();
is_deeply(\@classes, \@classes_are, '->isa() classes');
$classes = $thing->isa();
is_deeply($classes, \@classes_are, '->isa() classes (ref)');
my %args_are = (
'Foo' => {
'data' => {
'type' => 'numeric',
'field' => 1,
},
},
'Bar' => {
'info' => {
'type' => 'list(numeric)',
'field' => 1,
},
'more' => {
'type' => 'list(Foo)',
'field' => 1,
}
},
);
my %args = $meta->get_args();
is_deeply(\%args, \%args_are, 'Bar args');
my $args = $meta->get_args();
is_deeply($args, \%args_are, 'Bar args (ref)');
my %meths_are = (
'new' => { 'class' => 'Bar',
'kind' => 'constructor',
'merge_args' => 1 },
'clone' => { 'class' => 'Bar',
'kind' => 'object', },
'meta' => { 'class' => 'Bar' },
'set' => { 'class' => 'Bar',
'kind' => 'object',
'restricted' => 1 },
'can' => { 'class' => 'Object::InsideOut',
'kind' => 'object', },
'isa' => { 'class' => 'Object::InsideOut',
'kind' => 'object', },
'id' => { 'class' => 'Foo',
'restricted' => 1 },
'dump' => { 'class' => 'Object::InsideOut',
'kind' => 'object', },
'pump' => { 'class' => 'Object::InsideOut',
'kind' => 'class', },
'create_field' => { 'class' => 'Object::InsideOut',
'kind' => 'class', },
'add_class' => { 'class' => 'Object::InsideOut',
'kind' => 'class', },
'inherit' => { 'class' => 'Bar',
'kind' => 'object',
'restricted' => 1 },
'heritage' => { 'class' => 'Bar',
'kind' => 'object',
'restricted' => 1 },
'disinherit' => { 'class' => 'Bar',
'kind' => 'object',
'restricted' => 1 },
'freeze' => { 'class' => 'Storable',
'kind' => 'foreign', },
'thaw' => { 'class' => 'Storable',
'kind' => 'foreign', },
'data' => { 'class' => 'Foo',
'kind' => 'accessor',
'type' => 'numeric',
'return' => 'new' },
'setget' => { 'class' => 'Foo',
'kind' => 'set',
'type' => '\&Foo::my_sub',
'return' => 'new' },
'fooget' => { 'class' => 'Foo',
'kind' => 'get',
'restricted' => 1 },
'my_foo' => { 'class' => 'Foo',
'kind' => 'class', },
'my_fink' => { 'class' => 'Foo',
'kind' => 'object',
'restricted' => 1 },
'AUTOLOAD' => { 'class' => 'Foo',
'kind' => 'automethod', },
'info' => { 'class' => 'Bar',
'kind' => 'accessor',
'type' => 'list(numeric)',
'return' => 'new' },
'barset' => { 'class' => 'Bar',
'kind' => 'set',
'type' => q/sub { $_[0]->isa('UNIVERSAL') }/,
'return' => 'old' },
'cu' => { 'class' => 'Bar',
'kind' => 'cumulative' },
'ch' => { 'class' => 'Bar',
'kind' => 'chained (bottom up)' },
'bar' => { 'class' => 'Bar',
'bork' => 1 },
'bork' => { 'class' => 'Bar',
'merge_args' => 1,
'restricted' => 1 },
);
if (! $HAVE_STORABLE) {
delete($meths_are{'freeze'});
delete($meths_are{'thaw'});
$meths_are{'inherit'}{'class'} = 'Object::InsideOut';
$meths_are{'heritage'}{'class'} = 'Object::InsideOut';
$meths_are{'disinherit'}{'class'} = 'Object::InsideOut';
}
my %meths = $meta->get_methods();
# Remove most Storable methods
foreach my $meth (keys(%meths)) {
next if ($meth eq 'freeze' || $meth eq 'thaw');
if ($meths{$meth}{'class'} eq 'Storable') {
delete($meths{$meth});
}
}
is_deeply(\%meths, \%meths_are, 'Bar methods');
}
sub check_meta_meta
{
my $thing = shift;
my $meta = $thing->meta();
isa_ok($meta, 'Object::InsideOut::Metadata');
my @meta_classes = ( 'Object::InsideOut::Metadata' );
my @classes = $meta->get_classes();
is_deeply(\@classes, \@meta_classes, 'no subclasses');
my $classes = $meta->get_classes();
is_deeply($classes, \@meta_classes, 'no subclasses (ref)');
my %meta_args = (
'Object::InsideOut::Metadata' => {
'GBL' => {},
'CLASS' => {},
},
);
my %args = $meta->get_args();
is_deeply(\%args, \%meta_args, 'Meta args');
my $args = $meta->get_args();
is_deeply($args, \%meta_args, 'Meta args (ref)');
my %meta_meths = (
'clone' => { 'class' => 'Object::InsideOut::Metadata',
'kind' => 'object' },
'meta' => { 'class' => 'Object::InsideOut::Metadata' },
'set' => { 'class' => 'Object::InsideOut::Metadata',
'kind' => 'object',
'restricted' => 1 },
'can' => { 'class' => 'Object::InsideOut',
'kind' => 'object', },
'isa' => { 'class' => 'Object::InsideOut',
'kind' => 'object', },
'dump' => { 'class' => 'Object::InsideOut',
'kind' => 'object' },
'pump' => { 'class' => 'Object::InsideOut',
'kind' => 'class' },
'get_classes' => { 'class' => 'Object::InsideOut::Metadata',
'kind' => 'object' },
'get_args' => { 'class' => 'Object::InsideOut::Metadata',
'kind' => 'object' },
'get_methods' => { 'class' => 'Object::InsideOut::Metadata',
'kind' => 'object' },
'inherit' => { 'class' => 'Object::InsideOut::Metadata',
'kind' => 'object',
'restricted' => 1 },
'heritage' => { 'class' => 'Object::InsideOut::Metadata',
'kind' => 'object',
'restricted' => 1 },
'disinherit' => { 'class' => 'Object::InsideOut::Metadata',
'kind' => 'object',
'restricted' => 1 },
);
if (! $HAVE_STORABLE) {
$meta_meths{'inherit'}{'class'} = 'Object::InsideOut';
$meta_meths{'heritage'}{'class'} = 'Object::InsideOut';
$meta_meths{'disinherit'}{'class'} = 'Object::InsideOut';
}
my %meths = $meta->get_methods();
is_deeply(\%meths, \%meta_meths, 'Meta methods');
my $meths = $meta->get_methods();
is_deeply($meths, \%meta_meths, 'Meta methods (ref)');
my @meths = sort($thing->can());
my @meths2 = sort(keys(%meta_meths));
is_deeply(\@meths, \@meths2, '->can() methods');
$meths = $thing->can();
@meths = sort(@$meths);
is_deeply(\@meths, \@meths2, '->can() methods (ref)');
my $meta_meta = $meta->meta()->get_methods();
is_deeply($meta_meta, \%meta_meths, 'meta meta');
}
sub check_res
{
my $thing = shift;
my $meta = $thing->meta();
my @meta_classes = ( 'Object::InsideOut::Results' );
my @classes = $meta->get_classes();
is_deeply(\@classes, \@meta_classes, 'no subclasses');
my $classes = $meta->get_classes();
is_deeply($classes, \@meta_classes, 'no subclasses (ref)');
my %meta_args = (
'Object::InsideOut::Results' => {
'VALUES' => { 'field' => 1 },
'CLASSES' => { 'field' => 1 },
},
);
my %args = $meta->get_args();
is_deeply(\%args, \%meta_args, 'Meta args');
my $args = $meta->get_args();
is_deeply($args, \%meta_args, 'Meta args (ref)');
my %meta_meths = (
'clone' => { 'class' => 'Object::InsideOut::Results',
'kind' => 'object' },
'meta' => { 'class' => 'Object::InsideOut::Results' },
'set' => { 'class' => 'Object::InsideOut::Results',
'kind' => 'object',
'restricted' => 1 },
'can' => { 'class' => 'Object::InsideOut',
'kind' => 'object', },
'isa' => { 'class' => 'Object::InsideOut',
'kind' => 'object', },
'dump' => { 'class' => 'Object::InsideOut',
'kind' => 'object' },
'pump' => { 'class' => 'Object::InsideOut',
'kind' => 'class' },
'as_string' => { 'class' => 'Object::InsideOut::Results',
'kind' => 'overload', },
'count' => { 'class' => 'Object::InsideOut::Results',
'kind' => 'overload', },
'as_hash' => { 'class' => 'Object::InsideOut::Results',
'kind' => 'overload', },
'values' => { 'class' => 'Object::InsideOut::Results',
'kind' => 'overload', },
'have_any' => { 'class' => 'Object::InsideOut::Results',
'kind' => 'overload', },
'inherit' => { 'class' => 'Object::InsideOut::Results',
'kind' => 'object',
'restricted' => 1 },
'heritage' => { 'class' => 'Object::InsideOut::Results',
'kind' => 'object',
'restricted' => 1 },
'disinherit' => { 'class' => 'Object::InsideOut::Results',
'kind' => 'object',
'restricted' => 1 },
);
if (! $HAVE_STORABLE) {
$meta_meths{'inherit'}{'class'} = 'Object::InsideOut';
$meta_meths{'heritage'}{'class'} = 'Object::InsideOut';
$meta_meths{'disinherit'}{'class'} = 'Object::InsideOut';
}
my %meths = $meta->get_methods();
is_deeply(\%meths, \%meta_meths, 'Meta methods');
my $meths = $meta->get_methods();
is_deeply($meths, \%meta_meths, 'Meta methods (ref)');
}
MAIN:
{
can_ok('Bar', 'meta');
### Bar class meta
check_bar('Bar');
### Bar object meta
my $obj = Bar->new();
check_bar($obj);
### Meta class meta
check_meta_meta('Object::InsideOut::Metadata');
### Meta object meta
check_meta_meta($obj->meta());
### Cumulative meta
my $res = $obj->cu();
my @cum = @{$res};
is_deeply(\@cum, [ 'Foo cumulative', 'Bar cumulative' ], 'cumulative results');
check_res($res);
eval { Object::InsideOut->meta(); };
is($@->{'message'}, "'meta' called on non-class 'Object::InsideOut'", 'No OIO meta');
}
exit(0);
# EOF