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