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