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