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; 1;' )
  13     {
  14         $HasMXAH = 1;
  15     }
  16 }
  17
  18 plan tests => 25;
  19
  20
  21 {
  22     package HasClassAttribute;
  23
  24     use Moose;
  25     use MooseX::ClassAttribute;
  26
  27     use vars qw($Lazy);
  28     $Lazy = 0;
  29
  30     class_has 'ObjectCount' =>
  31         ( is        => 'rw',
  32           isa       => 'Int',
  33           default   => 0,
  34         );
  35
  36     class_has 'WeakAttribute' =>
  37         ( is        => 'rw',
  38           isa       => 'Object',
  39           weak_ref  => 1,
  40         );
  41
  42     class_has 'LazyAttribute' =>
  43         ( is      => 'rw',
  44           isa     => 'Int',
  45           lazy    => 1,
  46           # The side effect is used to test that this was called
  47           # lazily.
  48           default => sub { $Lazy = 1 },
  49         );
  50
  51     class_has 'ReadOnlyAttribute' =>
  52         ( is      => 'ro',
  53           isa     => 'Int',
  54           default => 10,
  55         );
  56
  57     class_has 'ManyNames' =>
  58         ( is        => 'rw',
  59           isa       => 'Int',
  60           reader    => 'M',
  61           writer    => 'SetM',
  62           clearer   => 'ClearM',
  63           predicate => 'HasM',
  64         );
  65
  66     class_has 'Delegatee' =>
  67         ( is      => 'rw',
  68           isa     => 'Delegatee',
  69           handles => [ 'units', 'color' ],
  70           default => sub { Delegatee->new() },
  71         );
  72
  73     if ($HasMXAH)
  74     {
  75         class_has 'Mapping' =>
  76             ( metaclass => 'Collection::Hash',
  77               is        => 'rw',
  78               isa       => 'HashRef[Str]',
  79               default   => sub { {} },
  80               provides  =>
  81               { exists => 'ExistsInMapping',
  82                 keys   => 'IdsInMapping',
  83                 get    => 'GetMapping',
  84                 set    => 'SetMapping',
  85               },
  86             );
  87     }
  88
  89     has 'size' =>
  90         ( is      => 'rw',
  91           isa     => 'Int',
  92           default => 5,
  93         );
  94
  95     no Moose;
  96     no MooseX::ClassAttribute;
  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         MooseX::ClassAttribute::container_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
 131 {
 132     package Child;
 133
 134     use Moose;
 135     use MooseX::ClassAttribute;
 136
 137     extends 'HasClassAttribute';
 138
 139     class_has '+ReadOnlyAttribute' =>
 140         ( default => 30 );
 141 }
 142
 143 sub run_tests
 144 {
 145     local $Test::Builder::Level = $Test::Builder::Level + 1;
 146
 147     {
 148         is( HasClassAttribute->ObjectCount(), 0,
 149             'ObjectCount() is 0' );
 150
 151         my $hca1 = HasClassAttribute->new();
 152         is( $hca1->size(), 5,
 153             'size is 5 - object attribute works as expected' );
 154         is( HasClassAttribute->ObjectCount(), 1,
 155             'ObjectCount() is 1' );
 156
 157         my $hca2 = HasClassAttribute->new( size => 10 );
 158         is( $hca2->size(), 10,
 159             'size is 10 - object attribute can be set via constructor' );
 160         is( HasClassAttribute->ObjectCount(), 2,
 161             'ObjectCount() is 2' );
 162         is( $hca2->ObjectCount(), 2,
 163             'ObjectCount() is 2 - can call class attribute accessor on object' );
 164     }
 165
 166     {
 167         my $hca3 = HasClassAttribute->new( ObjectCount => 20 );
 168         is( $hca3->ObjectCount(), 3,
 169             'class attributes passed to the constructor do not get set in the object' );
 170         is( HasClassAttribute->ObjectCount(), 3,
 171             'class attributes are not affected by constructor params' );
 172     }
 173
 174     {
 175         my $object = bless {}, 'Thing';
 176
 177         HasClassAttribute->WeakAttribute($object);
 178
 179         undef $object;
 180
 181         ok( ! defined HasClassAttribute->WeakAttribute(),
 182             'weak class attributes are weak' );
 183     }
 184
 185     {
 186         is( $HasClassAttribute::Lazy, 0,
 187             '$HasClassAttribute::Lazy is 0' );
 188
 189         is( HasClassAttribute->LazyAttribute(), 1,
 190             'HasClassAttribute->LazyAttribute() is 1' );
 191
 192         is( $HasClassAttribute::Lazy, 1,
 193             '$HasClassAttribute::Lazy is 1 after calling LazyAttribute' );
 194     }
 195
 196     {
 197         eval { HasClassAttribute->ReadOnlyAttribute(20) };
 198         like( $@, qr/\QCannot assign a value to a read-only accessor/,
 199               'cannot set read-only class attribute' );
 200     }
 201
 202     {
 203         is( Child->ReadOnlyAttribute(), 30,
 204             q{Child class can extend parent's class attribute} );
 205     }
 206
 207     {
 208         ok( ! HasClassAttribute->HasM(),
 209             'HasM() returns false before M is set' );
 210
 211         HasClassAttribute->SetM(22);
 212
 213         ok( HasClassAttribute->HasM(),
 214             'HasM() returns true after M is set' );
 215         is( HasClassAttribute->M(), 22,
 216             'M() returns 22' );
 217
 218         HasClassAttribute->ClearM();
 219
 220         ok( ! HasClassAttribute->HasM(),
 221             'HasM() returns false after M is cleared' );
 222     }
 223
 224     {
 225         isa_ok( HasClassAttribute->Delegatee(), 'Delegatee',
 226                 'has a Delegetee object' );
 227         is( HasClassAttribute->units(), 5,
 228             'units() delegates to Delegatee and returns 5' );
 229     }
 230
 231     {
 232         ok( ! HasClassAttribute->can('class_has'),
 233             q{'no MooseX::ClassAttribute' remove class_has from HasClassAttribute} );
 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;