lib/Class/Struct.t

   1 #!./perl -w
   2
   3 BEGIN {
   4         chdir 't' if -d 't';
   5         @INC = '../lib';
   6 }
   7
   8 #
   9 # A couple of simple classes to use as struct elements.
  10 #
  11 package aClass;
  12 sub new { bless {}, shift }
  13 sub meth { 42 }
  14
  15 package RecClass;
  16 sub new { bless {}, shift }
  17
  18 #
  19 # The first of our Class::Struct based objects.
  20 #
  21 package MyObj;
  22 use Class::Struct;
  23 use Class::Struct 'struct'; # test out both forms
  24 use Class::Struct SomeClass => { SomeElem => '$' };
  25
  26 struct( s => '$', a => '@', h => '%', c => 'aClass' );
  27
  28 #
  29 # The second Class::Struct objects:
  30 # test the 'compile-time without package name' feature.
  31 #
  32 package MyOther;
  33 use Class::Struct s => '$', a => '@', h => '%', c => 'aClass';
  34
  35 #
  36 # test overriden accessors
  37 #
  38 package OverrideAccessor;
  39 use Class::Struct;
  40
  41 {
  42  no warnings qw(Class::Struct);
  43  struct( 'OverrideAccessor', { count => '$' } );
  44 }
  45
  46 sub count {
  47   my ($self,$count) = @_;
  48
  49   if ( @_ >= 2 ) {
  50     $self->{'OverrideAccessor::count'} = $count + 9;
  51   }
  52
  53   return $self->{'OverrideAccessor::count'};
  54 }
  55
  56 #
  57 # back to main...
  58 #
  59 package main;
  60
  61 use Test::More;
  62
  63 my $obj = MyObj->new;
  64 isa_ok $obj, 'MyObj';
  65
  66 $obj->s('foo');
  67 is $obj->s(), 'foo';
  68
  69 isa_ok $obj->a, 'ARRAY';
  70 $obj->a(2, 'secundus');
  71 is $obj->a(2), 'secundus';
  72
  73 $obj->a([4,5,6]);
  74 is $obj->a(1), 5;
  75
  76 isa_ok $obj->h, 'HASH';
  77 $obj->h('x', 10);
  78 is $obj->h('x'), 10;
  79
  80 $obj->h({h=>7,r=>8,f=>9});
  81 is $obj->h('r'), 8;
  82
  83 is $obj->c, undef;
  84
  85 $obj = MyObj->new( c => aClass->new );
  86 isa_ok $obj->c, 'aClass';
  87 is $obj->c->meth(), 42;
  88
  89
  90 $obj = MyOther->new;
  91 isa_ok $obj, 'MyOther';
  92
  93 $obj->s('foo');
  94 is $obj->s(), 'foo';
  95
  96 isa_ok $obj->a, 'ARRAY';
  97 $obj->a(2, 'secundus');
  98 is $obj->a(2), 'secundus';
  99
 100 $obj->a([4,5,6]);
 101 is $obj->a(1), 5;
 102
 103 isa_ok $obj->h, 'HASH';
 104 $obj->h('x', 10);
 105 is $obj->h('x'), 10;
 106
 107 $obj->h({h=>7,r=>8,f=>9});
 108 is $obj->h('r'), 8;
 109
 110 is $obj->c, undef;
 111
 112 $obj = MyOther->new( c => aClass->new );
 113 isa_ok $obj->c, 'aClass';
 114 is $obj->c->meth(), 42;
 115
 116
 117
 118 my $obk = SomeClass->new();
 119 $obk->SomeElem(123);
 120 is $obk->SomeElem(), 123;
 121
 122 my $recobj = RecClass->new();
 123 isa_ok $recobj, 'RecClass';
 124
 125 my $override_obj = OverrideAccessor->new( count => 3 );
 126 is $override_obj->count, 12;
 127
 128 $override_obj->count( 1 );
 129 is $override_obj->count, 10;
 130
 131
 132 use Class::Struct Kapow => { z_zwap => 'Regexp', sploosh => 'MyObj' };
 133
 134 is eval { main->new(); }, undef,
 135     'No new method injected into current package';
 136
 137 my $obj3 = Kapow->new();
 138
 139 isa_ok $obj3, 'Kapow';
 140 is $obj3->z_zwap, undef, 'No z_zwap member by default';
 141 is $obj3->sploosh, undef, 'No sploosh member by default';
 142 $obj3->z_zwap(qr//);
 143 isa_ok $obj3->z_zwap, 'Regexp', 'Can set z_zwap member';
 144 $obj3->sploosh(MyObj->new(s => 'pie'));
 145 isa_ok $obj3->sploosh, 'MyObj',
 146     'Can set sploosh member to object of correct class';
 147 is $obj3->sploosh->s, 'pie', 'Can set sploosh member to correct object';
 148
 149 my $obj4 = Kapow->new( z_zwap => qr//, sploosh => MyObj->new(a => ['Good']) );
 150
 151 isa_ok $obj4, 'Kapow';
 152 isa_ok $obj4->z_zwap, 'Regexp', 'Initialised z_zwap member';
 153 isa_ok $obj4->sploosh, 'MyObj', 'Initialised sploosh member';
 154 is_deeply $obj4->sploosh->a, ['Good'], 'with correct object';
 155
 156 my $obj5 = Kapow->new( sploosh => { h => {perl => 'rules'} } );
 157
 158 isa_ok $obj5, 'Kapow';
 159 is $obj5->z_zwap, undef, 'No z_zwap member by default';
 160 isa_ok $obj5->sploosh, 'MyObj', 'Initialised sploosh member from hash';
 161 is_deeply $obj5->sploosh->h, { perl => 'rules'} , 'with correct object';
 162
 163 is eval {
 164     package MyObj;
 165     struct( s => '$', a => '@', h => '%', c => 'aClass' );
 166 }, undef, 'Calling struct a second time fails';
 167
 168 like $@, qr/^function 'new' already defined in package MyObj/,
 169     'fails with the expected error';
 170
 171 is eval { MyObj->new( a => {} ) }, undef,
 172     'Using a hash where an array reference is expected';
 173 like $@, qr/^Initializer for a must be array reference/,
 174     'fails with the expected error';
 175
 176 is eval { MyObj->new( h => [] ) }, undef,
 177     'Using an array where a hash reference is expected';
 178 like $@, qr/^Initializer for h must be hash reference/,
 179     'fails with the expected error';
 180
 181 is eval { Kapow->new( sploosh => { h => [perl => 'rules'] } ); }, undef,
 182     'Using an array where a hash reference is expected in an initialiser list';
 183 like $@, qr/^Initializer for h must be hash reference/,
 184     'fails with the expected error';
 185
 186 is eval { Kapow->new( sploosh => [ h => {perl => 'rules'} ] ); }, undef,
 187     "Using an array for a member object's initialiser list";
 188 like $@, qr/^Initializer for sploosh must be hash or MyObj reference/,
 189     'fails with the expected error';
 190
 191 is eval {
 192     package Crraack;
 193     use Class::Struct 'struct';
 194     struct( 'pow' => '@$%!' );
 195 }, undef, 'Bad type fails';
 196 like $@, qr/^'\@\$\%\!' is not a valid struct element type/,
 197     'with the expected error';
 198
 199 is eval {
 200     $obj3->sploosh(MyOther->new(s => 3.14));
 201 }, undef, 'Setting member to the wrong class of object fails';
 202 like $@, qr/^sploosh argument is wrong class/,
 203     'with the expected error';
 204 is $obj3->sploosh->s, 'pie', 'Object is unchanged';
 205
 206 is eval {
 207     $obj3->sploosh(MyObj->new(s => 3.14), 'plop');
 208 }, undef, 'Too many arguments to setter fails';
 209 like $@, qr/^Too many args to sploosh/,
 210     'with the expected error';
 211 is $obj3->sploosh->s, 'pie', 'Object is unchanged';
 212
 213 is eval {
 214     package Blurp;
 215     use Class::Struct 'struct';
 216     struct( Blurp => {}, 'Bonus!' );
 217 }, undef, 'hash based class with extra argument fails';
 218 like $@, qr/\Astruct usage error.*\n.*\n/,
 219     'with the expected confession';
 220
 221 is eval {
 222     package Zamm;
 223     use Class::Struct 'struct';
 224     struct( Zamm => [], 'Bonus!' );
 225 }, undef, 'array based class with extra argument fails';
 226 like $@, qr/\Astruct usage error.*\n.*\n/,
 227     'with the expected confession';
 228
 229 is eval {
 230     package Thwapp;
 231     use Class::Struct 'struct';
 232     struct( Thwapp => ['Bonus!'] );
 233 }, undef, 'array based class with extra constructor argument fails';
 234 like $@, qr/\Astruct usage error.*\n.*\n/,
 235     'with the expected confession';
 236
 237 is eval {
 238     package Rakkk;
 239     use Class::Struct 'struct';
 240     struct( z_zwap => 'Regexp', sploosh => 'MyObj', 'Bonus' );
 241 }, undef, 'default array based class with extra constructor argument fails';
 242 like $@, qr/\Astruct usage error.*\n.*\n/,
 243     'with the expected confession';
 244
 245 is eval {
 246     package Awk;
 247     use parent -norequire, 'Urkkk';
 248     use Class::Struct 'struct';
 249     struct( beer => 'foamy' );
 250 }, undef, '@ISA is not allowed';
 251 like $@, qr/^struct class cannot be a subclass \(\@ISA not allowed\)/,
 252     'with the expected error';
 253
 254 done_testing;