t/lib/SharedTests.pm

   1 package SharedTests;
   2
   3 use strict;
   4 use warnings;
   5
   6 use Scalar::Util qw( isweak );
   7 use Test::More;
   8
   9 use vars qw($Lazy);
  10 $Lazy = 0;
  11
  12 our %Attrs = (
  13     ObjectCount => {
  14         is      => 'rw',
  15         isa     => 'Int',
  16         default => 0,
  17     },
  18     WeakAttribute => {
  19         is       => 'rw',
  20         isa      => 'Object',
  21         weak_ref => 1,
  22     },
  23     LazyAttribute => {
  24         is   => 'rw',
  25         isa  => 'Int',
  26         lazy => 1,
  27         # The side effect is used to test that this was called
  28         # lazily.
  29         default => sub { $Lazy = 1 },
  30     },
  31     ReadOnlyAttribute => {
  32         is      => 'ro',
  33         isa     => 'Int',
  34         default => 10,
  35     },
  36     ManyNames => {
  37         is        => 'rw',
  38         isa       => 'Int',
  39         reader    => 'M',
  40         writer    => 'SetM',
  41         clearer   => 'ClearM',
  42         predicate => 'HasM',
  43     },
  44     Delegatee => {
  45         is      => 'rw',
  46         isa     => 'Delegatee',
  47         handles => [ 'units', 'color' ],
  48         # if it's not lazy it makes a new object before we define
  49         # Delegatee's attributes.
  50         lazy    => 1,
  51         default => sub { Delegatee->new() },
  52     },
  53     Mapping => {
  54         traits  => ['Hash'],
  55         is      => 'rw',
  56         isa     => 'HashRef[Str]',
  57         default => sub { {} },
  58         handles => {
  59             'ExistsInMapping' => 'exists',
  60             'IdsInMapping'    => 'keys',
  61             'GetMapping'      => 'get',
  62             'SetMapping'      => 'set',
  63         },
  64     },
  65     Built => {
  66         is      => 'ro',
  67         builder => '_BuildIt',
  68     },
  69     LazyBuilt => {
  70         is      => 'ro',
  71         lazy    => 1,
  72         builder => '_BuildIt',
  73     },
  74     Triggerish => {
  75         is      => 'rw',
  76         trigger => sub { shift->_CallTrigger(@_) },
  77     },
  78 );
  79
  80 {
  81     package HasClassAttribute;
  82
  83     use Moose qw( has );
  84     use MooseX::ClassAttribute;
  85
  86     while ( my ( $name, $def ) = each %SharedTests::Attrs ) {
  87         class_has $name => %{$def};
  88     }
  89
  90     has 'size' => (
  91         is      => 'rw',
  92         isa     => 'Int',
  93         default => 5,
  94     );
  95
  96     no Moose;
  97
  98     sub BUILD {
  99         my $self = shift;
 100
 101         $self->ObjectCount( $self->ObjectCount() + 1 );
 102     }
 103
 104     sub _BuildIt {42}
 105
 106     our @Triggered;
 107
 108     sub _CallTrigger {
 109         push @Triggered, [@_];
 110     }
 111
 112     sub make_immutable {
 113         my $class = shift;
 114
 115         $class->meta()->make_immutable();
 116         Delegatee->meta()->make_immutable();
 117     }
 118 }
 119
 120 {
 121     package Delegatee;
 122
 123     use Moose;
 124
 125     has 'units' => (
 126         is      => 'ro',
 127         default => 5,
 128     );
 129
 130     has 'color' => (
 131         is      => 'ro',
 132         default => 'blue',
 133     );
 134
 135     no Moose;
 136 }
 137
 138 {
 139     package Child;
 140
 141     use Moose;
 142     use MooseX::ClassAttribute;
 143
 144     extends 'HasClassAttribute';
 145
 146     class_has '+ReadOnlyAttribute' => ( default => 30 );
 147
 148     class_has 'YetAnotherAttribute' => (
 149         is      => 'ro',
 150         default => 'thing',
 151     );
 152
 153     no Moose;
 154 }
 155
 156 sub run_tests {
 157     my $class = shift || 'HasClassAttribute';
 158
 159     local $Test::Builder::Level = $Test::Builder::Level + 1;
 160
 161     {
 162         is(
 163             $class->ObjectCount(), 0,
 164             'ObjectCount() is 0'
 165         );
 166
 167         my $hca1 = $class->new();
 168         is(
 169             $hca1->size(), 5,
 170             'size is 5 - object attribute works as expected'
 171         );
 172         is(
 173             $class->ObjectCount(), 1,
 174             'ObjectCount() is 1'
 175         );
 176
 177         my $hca2 = $class->new( size => 10 );
 178         is(
 179             $hca2->size(), 10,
 180             'size is 10 - object attribute can be set via constructor'
 181         );
 182         is(
 183             $class->ObjectCount(), 2,
 184             'ObjectCount() is 2'
 185         );
 186         is(
 187             $hca2->ObjectCount(), 2,
 188             'ObjectCount() is 2 - can call class attribute accessor on object'
 189         );
 190     }
 191
 192     {
 193         my $hca3 = $class->new( ObjectCount => 20 );
 194         is(
 195             $hca3->ObjectCount(), 3,
 196             'class attributes passed to the constructor do not get set in the object'
 197         );
 198         is(
 199             $class->ObjectCount(), 3,
 200             'class attributes are not affected by constructor params'
 201         );
 202     }
 203
 204     {
 205         my $object = bless {}, 'Thing';
 206
 207         $class->WeakAttribute($object);
 208
 209         undef $object;
 210
 211         ok(
 212             !defined $class->WeakAttribute(),
 213             'weak class attributes are weak'
 214         );
 215     }
 216
 217     {
 218         is(
 219             $SharedTests::Lazy, 0,
 220             '$SharedTests::Lazy is 0'
 221         );
 222
 223         is(
 224             $class->LazyAttribute(), 1,
 225             '$class->LazyAttribute() is 1'
 226         );
 227
 228         is(
 229             $SharedTests::Lazy, 1,
 230             '$SharedTests::Lazy is 1 after calling LazyAttribute'
 231         );
 232     }
 233
 234     {
 235         eval { $class->ReadOnlyAttribute(20) };
 236         like(
 237             $@, qr/\QCannot assign a value to a read-only accessor/,
 238             'cannot set read-only class attribute'
 239         );
 240     }
 241
 242     {
 243         is(
 244             Child->ReadOnlyAttribute(), 30,
 245             q{Child class can extend parent's class attribute}
 246         );
 247     }
 248
 249     {
 250         ok(
 251             !$class->HasM(),
 252             'HasM() returns false before M is set'
 253         );
 254
 255         $class->SetM(22);
 256
 257         ok(
 258             $class->HasM(),
 259             'HasM() returns true after M is set'
 260         );
 261         is(
 262             $class->M(), 22,
 263             'M() returns 22'
 264         );
 265
 266         $class->ClearM();
 267
 268         ok(
 269             !$class->HasM(),
 270             'HasM() returns false after M is cleared'
 271         );
 272     }
 273
 274     {
 275         isa_ok(
 276             $class->Delegatee(), 'Delegatee',
 277             'has a Delegetee object'
 278         );
 279         is(
 280             $class->units(), 5,
 281             'units() delegates to Delegatee and returns 5'
 282         );
 283     }
 284
 285     {
 286         my @ids = $class->IdsInMapping();
 287         is(
 288             scalar @ids, 0,
 289             'there are no keys in the mapping yet'
 290         );
 291
 292         ok(
 293             !$class->ExistsInMapping('a'),
 294             'key does not exist in mapping'
 295         );
 296
 297         $class->SetMapping( a => 20 );
 298
 299         ok(
 300             $class->ExistsInMapping('a'),
 301             'key does exist in mapping'
 302         );
 303
 304         is(
 305             $class->GetMapping('a'), 20,
 306             'value for a in mapping is 20'
 307         );
 308     }
 309
 310     {
 311         is(
 312             $class->Built(), 42,
 313             'attribute with builder works'
 314         );
 315
 316         is(
 317             $class->LazyBuilt(), 42,
 318             'attribute with lazy builder works'
 319         );
 320     }
 321
 322     {
 323         $class->Triggerish(42);
 324         my $triggered = do { no strict 'refs'; \@{ $class . '::Triggered' } };
 325         is( scalar @{$triggered}, 1, 'trigger was called' );
 326         is( $class->Triggerish(), 42, 'Triggerish is now 42' );
 327
 328         $class->Triggerish(84);
 329         is( $class->Triggerish(), 84, 'Triggerish is now 84' );
 330
 331         is_deeply(
 332             $triggered,
 333             [
 334                 [ $class, qw( 42 ) ],
 335                 [ $class, qw( 84 42 ) ],
 336             ],
 337             'trigger passes old value correctly'
 338         );
 339     }
 340
 341     done_testing();
 342 }
 343
 344 1;