1 files changed, 152 insertions, 1 deletions

diff --git a/gnu/usr.bin/perl/lib/Class/Struct.t b/gnu/usr.bin/perl/lib/Class/Struct.t
index 694d622d4d2..fb1eb0b545a 100644
--- a/gnu/usr.bin/perl/lib/Class/Struct.t
+++ b/gnu/usr.bin/perl/lib/Class/Struct.t
@@ -33,11 +33,32 @@ package MyOther;
 use Class::Struct s => '$', a => '@', h => '%', c => 'aClass';
 
 #
+# test overriden accessors
+#
+package OverrideAccessor;
+use Class::Struct;
+
+{ 
+ no warnings qw(Class::Struct);
+ struct( 'OverrideAccessor', { count => '$' } );
+}
+
+sub count {
+  my ($self,$count) = @_;
+
+  if ( @_ >= 2 ) {
+    $self->{'OverrideAccessor::count'} = $count + 9;
+  }
+
+  return $self->{'OverrideAccessor::count'};
+}
+
+#
 # back to main...
 #
 package main;
 
-use Test::More tests => 24;
+use Test::More;
 
 my $obj = MyObj->new;
 isa_ok $obj, 'MyObj';
@@ -101,3 +122,133 @@ is $obk->SomeElem(), 123;
 my $recobj = RecClass->new();
 isa_ok $recobj, 'RecClass';
 
+my $override_obj = OverrideAccessor->new( count => 3 );
+is $override_obj->count, 12;
+
+$override_obj->count( 1 );
+is $override_obj->count, 10;
+
+
+use Class::Struct Kapow => { z_zwap => 'Regexp', sploosh => 'MyObj' };
+
+is eval { main->new(); }, undef,
+    'No new method injected into current package';
+
+my $obj3 = Kapow->new();
+
+isa_ok $obj3, 'Kapow';
+is $obj3->z_zwap, undef, 'No z_zwap member by default';
+is $obj3->sploosh, undef, 'No sploosh member by default';
+$obj3->z_zwap(qr//);
+isa_ok $obj3->z_zwap, 'Regexp', 'Can set z_zwap member';
+$obj3->sploosh(MyObj->new(s => 'pie'));
+isa_ok $obj3->sploosh, 'MyObj',
+    'Can set sploosh member to object of correct class';
+is $obj3->sploosh->s, 'pie', 'Can set sploosh member to correct object';
+
+my $obj4 = Kapow->new( z_zwap => qr//, sploosh => MyObj->new(a => ['Good']) );
+
+isa_ok $obj4, 'Kapow';
+isa_ok $obj4->z_zwap, 'Regexp', 'Initialised z_zwap member';
+isa_ok $obj4->sploosh, 'MyObj', 'Initialised sploosh member';
+is_deeply $obj4->sploosh->a, ['Good'], 'with correct object';
+
+my $obj5 = Kapow->new( sploosh => { h => {perl => 'rules'} } );
+
+isa_ok $obj5, 'Kapow';
+is $obj5->z_zwap, undef, 'No z_zwap member by default';
+isa_ok $obj5->sploosh, 'MyObj', 'Initialised sploosh member from hash';
+is_deeply $obj5->sploosh->h, { perl => 'rules'} , 'with correct object';
+
+is eval {
+    package MyObj;
+    struct( s => '$', a => '@', h => '%', c => 'aClass' );
+}, undef, 'Calling struct a second time fails';
+
+like $@, qr/^function 'new' already defined in package MyObj/,
+    'fails with the expected error';
+
+is eval { MyObj->new( a => {} ) }, undef,
+    'Using a hash where an array reference is expected';
+like $@, qr/^Initializer for a must be array reference/,
+    'fails with the expected error';
+
+is eval { MyObj->new( h => [] ) }, undef,
+    'Using an array where a hash reference is expected';
+like $@, qr/^Initializer for h must be hash reference/,
+    'fails with the expected error';
+
+is eval { Kapow->new( sploosh => { h => [perl => 'rules'] } ); }, undef,
+    'Using an array where a hash reference is expected in an initialiser list';
+like $@, qr/^Initializer for h must be hash reference/,
+    'fails with the expected error';
+
+is eval { Kapow->new( sploosh => [ h => {perl => 'rules'} ] ); }, undef,
+    "Using an array for a member object's initialiser list";
+like $@, qr/^Initializer for sploosh must be hash or MyObj reference/,
+    'fails with the expected error';
+
+is eval {
+    package Crraack;
+    use Class::Struct 'struct';
+    struct( 'pow' => '@$%!' );
+}, undef, 'Bad type fails';
+like $@, qr/^'\@\$\%\!' is not a valid struct element type/,
+    'with the expected error';
+
+is eval {
+    $obj3->sploosh(MyOther->new(s => 3.14));
+}, undef, 'Setting member to the wrong class of object fails';
+like $@, qr/^sploosh argument is wrong class/,
+    'with the expected error';
+is $obj3->sploosh->s, 'pie', 'Object is unchanged';
+
+is eval {
+    $obj3->sploosh(MyObj->new(s => 3.14), 'plop');
+}, undef, 'Too many arguments to setter fails';
+like $@, qr/^Too many args to sploosh/,
+    'with the expected error';
+is $obj3->sploosh->s, 'pie', 'Object is unchanged';
+
+is eval {
+    package Blurp;
+    use Class::Struct 'struct';
+    struct( Blurp => {}, 'Bonus!' );
+}, undef, 'hash based class with extra argument fails';
+like $@, qr/\Astruct usage error.*\n.*\n/,
+    'with the expected confession';
+
+is eval {
+    package Zamm;
+    use Class::Struct 'struct';
+    struct( Zamm => [], 'Bonus!' );
+}, undef, 'array based class with extra argument fails';
+like $@, qr/\Astruct usage error.*\n.*\n/,
+    'with the expected confession';
+
+is eval {
+    package Thwapp;
+    use Class::Struct 'struct';
+    struct( Thwapp => ['Bonus!'] );
+}, undef, 'array based class with extra constructor argument fails';
+like $@, qr/\Astruct usage error.*\n.*\n/,
+    'with the expected confession';
+
+is eval {
+    package Rakkk;
+    use Class::Struct 'struct';
+    struct( z_zwap => 'Regexp', sploosh => 'MyObj', 'Bonus' );
+}, undef, 'default array based class with extra constructor argument fails';
+like $@, qr/\Astruct usage error.*\n.*\n/,
+    'with the expected confession';
+
+is eval {
+    package Awk;
+    use parent -norequire, 'Urkkk';
+    use Class::Struct 'struct';
+    struct( beer => 'foamy' );
+}, undef, '@ISA is not allowed';
+like $@, qr/^struct class cannot be a subclass \(\@ISA not allowed\)/,
+    'with the expected error';
+
+done_testing;