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     plan tests => 30;
 164
 165     local $Test::Builder::Level = $Test::Builder::Level + 1;
 166
 167     {
 168         is(
 169             HasClassAttribute->ObjectCount(), 0,
 170             'ObjectCount() is 0'
 171         );
 172
 173         my $hca1 = HasClassAttribute->new();
 174         is(
 175             $hca1->size(), 5,
 176             'size is 5 - object attribute works as expected'
 177         );
 178         is(
 179             HasClassAttribute->ObjectCount(), 1,
 180             'ObjectCount() is 1'
 181         );
 182
 183         my $hca2 = HasClassAttribute->new( size => 10 );
 184         is(
 185             $hca2->size(), 10,
 186             'size is 10 - object attribute can be set via constructor'
 187         );
 188         is(
 189             HasClassAttribute->ObjectCount(), 2,
 190             'ObjectCount() is 2'
 191         );
 192         is(
 193             $hca2->ObjectCount(), 2,
 194             'ObjectCount() is 2 - can call class attribute accessor on object'
 195         );
 196     }
 197
 198     {
 199         my $hca3 = HasClassAttribute->new( ObjectCount => 20 );
 200         is(
 201             $hca3->ObjectCount(), 3,
 202             'class attributes passed to the constructor do not get set in the object'
 203         );
 204         is(
 205             HasClassAttribute->ObjectCount(), 3,
 206             'class attributes are not affected by constructor params'
 207         );
 208     }
 209
 210     {
 211         my $object = bless {}, 'Thing';
 212
 213         HasClassAttribute->WeakAttribute($object);
 214
 215         undef $object;
 216
 217         ok(
 218             !defined HasClassAttribute->WeakAttribute(),
 219             'weak class attributes are weak'
 220         );
 221     }
 222
 223     {
 224         is(
 225             $HasClassAttribute::Lazy, 0,
 226             '$HasClassAttribute::Lazy is 0'
 227         );
 228
 229         is(
 230             HasClassAttribute->LazyAttribute(), 1,
 231             'HasClassAttribute->LazyAttribute() is 1'
 232         );
 233
 234         is(
 235             $HasClassAttribute::Lazy, 1,
 236             '$HasClassAttribute::Lazy is 1 after calling LazyAttribute'
 237         );
 238     }
 239
 240     {
 241         eval { HasClassAttribute->ReadOnlyAttribute(20) };
 242         like(
 243             $@, qr/\QCannot assign a value to a read-only accessor/,
 244             'cannot set read-only class attribute'
 245         );
 246     }
 247
 248     {
 249         is(
 250             Child->ReadOnlyAttribute(), 30,
 251             q{Child class can extend parent's class attribute}
 252         );
 253     }
 254
 255     {
 256         ok(
 257             !HasClassAttribute->HasM(),
 258             'HasM() returns false before M is set'
 259         );
 260
 261         HasClassAttribute->SetM(22);
 262
 263         ok(
 264             HasClassAttribute->HasM(),
 265             'HasM() returns true after M is set'
 266         );
 267         is(
 268             HasClassAttribute->M(), 22,
 269             'M() returns 22'
 270         );
 271
 272         HasClassAttribute->ClearM();
 273
 274         ok(
 275             !HasClassAttribute->HasM(),
 276             'HasM() returns false after M is cleared'
 277         );
 278     }
 279
 280     {
 281         isa_ok(
 282             HasClassAttribute->Delegatee(), 'Delegatee',
 283             'has a Delegetee object'
 284         );
 285         is(
 286             HasClassAttribute->units(), 5,
 287             'units() delegates to Delegatee and returns 5'
 288         );
 289     }
 290
 291     {
 292         my @ids = HasClassAttribute->IdsInMapping();
 293         is(
 294             scalar @ids, 0,
 295             'there are no keys in the mapping yet'
 296         );
 297
 298         ok(
 299             !HasClassAttribute->ExistsInMapping('a'),
 300             'key does not exist in mapping'
 301         );
 302
 303         HasClassAttribute->SetMapping( a => 20 );
 304
 305         ok(
 306             HasClassAttribute->ExistsInMapping('a'),
 307             'key does exist in mapping'
 308         );
 309
 310         is(
 311             HasClassAttribute->GetMapping('a'), 20,
 312             'value for a in mapping is 20'
 313         );
 314     }
 315
 316     {
 317         is(
 318             HasClassAttribute->Built(), 42,
 319             'attribute with builder works'
 320         );
 321
 322         is(
 323             HasClassAttribute->LazyBuilt(), 42,
 324             'attribute with lazy builder works'
 325         );
 326     }
 327
 328     {
 329         HasClassAttribute->Triggerish(42);
 330         is( scalar @HasClassAttribute::Triggered, 1, 'trigger was called' );
 331         is( HasClassAttribute->Triggerish(), 42, 'Triggerish is now 42' );
 332
 333         HasClassAttribute->Triggerish(84);
 334         is( HasClassAttribute->Triggerish(), 84, 'Triggerish is now 84' );
 335
 336         is_deeply(
 337             \@HasClassAttribute::Triggered,
 338             [
 339                 [qw( HasClassAttribute 42 )],
 340                 [qw( HasClassAttribute 84 42 )],
 341             ],
 342             'trigger passes old value correctly'
 343         );
 344     }
 345 }
 346
 347 1;