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