use strict;
$^W++;
use Class::Prototyped qw(:REFLECT :EZACCESS :OVERLOAD);
use Data::Dumper;
use Test;
BEGIN {
$|++;
plan tests => 33
}
$Data::Dumper::Sortkeys = 1;
$Data::Dumper::Sortkeys = 1;
my $p1 = Class::Prototyped->new( s1 => sub {'p1.s1'} );
my $p2 = Class::Prototyped->new(
'*' => $p1,
s1 => sub {'p2.s1'},
's2!' => sub { shift->reflect->super('s1') },
);
my $p2a = $p2->clone();
my $p3 = Class::Prototyped->new(
'*' => $p2,
s1 => sub {'p3.s1'},
[qw(s2 superable)] => sub { shift->super('s1') },
[qw(s3 METHOD superable)] => sub { shift->super('s2') },
[qw(s4 METHOD superable 1)] => sub { join('+', $_[0]->s2, $_[0]->super('s1'), $_[0]->super('s2') ) },
[qw(s5 superable)] => sub { join('+', $_[0]->s2, $_[0]->super('s2'), $_[0]->super('s1') ) },
's6' => sub { join('+', map {$_[0]->$_()} map {"s$_"} (1..5) ) },
);
my $p3a = $p3->clone();
ok( $p1->s1, 'p1.s1' );
ok( $p2->s1, 'p2.s1' );
ok( $p2->s2, 'p1.s1' );
ok( $p2a->s1, 'p2.s1' );
ok( $p2a->s2, 'p1.s1' );
ok( $p3->s1, 'p3.s1' );
ok( $p3->s2, 'p2.s1' );
ok( $p3->s3, 'p1.s1' );
ok( $p3->s4, 'p2.s1+p2.s1+p1.s1' );
ok( $p3->s5, 'p2.s1+p1.s1+p2.s1' );
ok( $p3->s6, 'p3.s1+p2.s1+p1.s1+p2.s1+p2.s1+p1.s1+p2.s1+p1.s1+p2.s1' );
ok( $p3a->s1, 'p3.s1' );
ok( $p3a->s2, 'p2.s1' );
ok( $p3a->s3, 'p1.s1' );
ok( $p3a->s4, 'p2.s1+p2.s1+p1.s1' );
ok( $p3a->s5, 'p2.s1+p1.s1+p2.s1' );
ok( $p3a->s6, 'p3.s1+p2.s1+p1.s1+p2.s1+p2.s1+p1.s1+p2.s1+p1.s1+p2.s1' );
package MyClass;
@MyClass::ISA = qw(Class::Prototyped);
MyClass->addSlots(
'new!' => sub {
my $class = shift;
my $self = $class->super('new');
$self->reflect->addSlots(
value => $self->value()*2,
@_
);
return $self;
},
value => 2,
foo => sub { $_[0] },
);
package main;
my $p4 = MyClass->new();
ok( $p4->value, 4 );
MyClass->value(3);
my $p5 = MyClass->new();
ok( $p4->value, 4 );
ok( $p5->value, 6 );
Class::Prototyped->newPackage('MyClass::Sub',
'*' => 'MyClass',
[qw(new superable)] => sub {
my $class = shift;
my $self = $class->super('new', @_);
$self->value($self->value()+5);
return $self;
},
[qw(foo superable)] => sub {
'Supered: '.(shift->reflect->super('foo'));
},
);
my $p6 = MyClass::Sub->new();
ok( $p4->value, 4 );
ok( $p5->value, 6 );
ok( $p6->value, 11);
my $p7 = MyClass::Sub->new(value => 20);
ok( $p7->value, 25);
my $mcs_dump = Data::Dumper->Dump([MyClass::Sub->reflect->getSlots]);
{
my $np3 = bless {}, 'MyClass::Sub';
ok( $np3->foo, 'Supered: '.$np3 );
ok( Data::Dumper->Dump([$np3->reflect->getSlots]), $mcs_dump);
}
ok( Data::Dumper->Dump([MyClass::Sub->reflect->getSlots]), $mcs_dump);
MyClass::Sub->clonePackage('MyClass::SubClone');
my $p8 = MyClass::Sub->new();
my $p9 = MyClass::SubClone->new();
ok( $p4->value, 4 );
ok( $p5->value, 6 );
ok( $p6->value, 11);
ok( $p8->value, 11);
ok( $p9->value, 11);
my $mcsc_dump = Data::Dumper->Dump([MyClass::SubClone->reflect->getSlots]);
ok($mcs_dump, $mcsc_dump);
# vim: ft=perl