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