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     has 'size' =>
  80         ( is      => 'rw',
  81           isa     => 'Int',
  82           default => 5,
  83         );
  84
  85     no Moose;
  86
  87     sub BUILD
  88     {
  89         my $self = shift;
  90
  91         $self->ObjectCount( $self->ObjectCount() + 1 );
  92     }
  93
  94     sub make_immutable
  95     {
  96         my $class = shift;
  97
  98         $class->meta()->make_immutable();
  99         Delegatee->meta()->make_immutable();
 100     }
 101 }
 102
 103 {
 104     package Delegatee;
 105
 106     use Moose;
 107
 108     has 'units' =>
 109         ( is      => 'ro',
 110           default => 5,
 111         );
 112
 113     has 'color' =>
 114         ( is      => 'ro',
 115           default => 'blue',
 116         );
 117
 118     no Moose;
 119 }
 120
 121 {
 122     package Child;
 123
 124     use Moose;
 125     use MooseX::ClassAttribute;
 126
 127     extends 'HasClassAttribute';
 128
 129     class_has '+ReadOnlyAttribute' =>
 130         ( default => 30 );
 131
 132     class_has 'YetAnotherAttribute' =>
 133         ( is      => 'ro',
 134           default => 'thing',
 135         );
 136
 137     no Moose;
 138 }
 139
 140 sub run_tests
 141 {
 142     plan tests => 24;
 143
 144     local $Test::Builder::Level = $Test::Builder::Level + 1;
 145
 146     {
 147         is( HasClassAttribute->ObjectCount(), 0,
 148             'ObjectCount() is 0' );
 149
 150         my $hca1 = HasClassAttribute->new();
 151         is( $hca1->size(), 5,
 152             'size is 5 - object attribute works as expected' );
 153         is( HasClassAttribute->ObjectCount(), 1,
 154             'ObjectCount() is 1' );
 155
 156         my $hca2 = HasClassAttribute->new( size => 10 );
 157         is( $hca2->size(), 10,
 158             'size is 10 - object attribute can be set via constructor' );
 159         is( HasClassAttribute->ObjectCount(), 2,
 160             'ObjectCount() is 2' );
 161         is( $hca2->ObjectCount(), 2,
 162             'ObjectCount() is 2 - can call class attribute accessor on object' );
 163     }
 164
 165     {
 166         my $hca3 = HasClassAttribute->new( ObjectCount => 20 );
 167         is( $hca3->ObjectCount(), 3,
 168             'class attributes passed to the constructor do not get set in the object' );
 169         is( HasClassAttribute->ObjectCount(), 3,
 170             'class attributes are not affected by constructor params' );
 171     }
 172
 173     {
 174         my $object = bless {}, 'Thing';
 175
 176         HasClassAttribute->WeakAttribute($object);
 177
 178         undef $object;
 179
 180         ok( ! defined HasClassAttribute->WeakAttribute(),
 181             'weak class attributes are weak' );
 182     }
 183
 184     {
 185         is( $HasClassAttribute::Lazy, 0,
 186             '$HasClassAttribute::Lazy is 0' );
 187
 188         is( HasClassAttribute->LazyAttribute(), 1,
 189             'HasClassAttribute->LazyAttribute() is 1' );
 190
 191         is( $HasClassAttribute::Lazy, 1,
 192             '$HasClassAttribute::Lazy is 1 after calling LazyAttribute' );
 193     }
 194
 195     {
 196         eval { HasClassAttribute->ReadOnlyAttribute(20) };
 197         like( $@, qr/\QCannot assign a value to a read-only accessor/,
 198               'cannot set read-only class attribute' );
 199     }
 200
 201     {
 202         is( Child->ReadOnlyAttribute(), 30,
 203             q{Child class can extend parent's class attribute} );
 204     }
 205
 206     {
 207         ok( ! HasClassAttribute->HasM(),
 208             'HasM() returns false before M is set' );
 209
 210         HasClassAttribute->SetM(22);
 211
 212         ok( HasClassAttribute->HasM(),
 213             'HasM() returns true after M is set' );
 214         is( HasClassAttribute->M(), 22,
 215             'M() returns 22' );
 216
 217         HasClassAttribute->ClearM();
 218
 219         ok( ! HasClassAttribute->HasM(),
 220             'HasM() returns false after M is cleared' );
 221     }
 222
 223     {
 224         isa_ok( HasClassAttribute->Delegatee(), 'Delegatee',
 225                 'has a Delegetee object' );
 226         is( HasClassAttribute->units(), 5,
 227             'units() delegates to Delegatee and returns 5' );
 228     }
 229
 230     {
 231         my @ids = HasClassAttribute->IdsInMapping();
 232         is( scalar @ids, 0,
 233             'there are no keys in the mapping yet' );
 234
 235         ok( ! HasClassAttribute->ExistsInMapping('a'),
 236             'key does not exist in mapping' );
 237
 238         HasClassAttribute->SetMapping( a => 20 );
 239
 240         ok( HasClassAttribute->ExistsInMapping('a'),
 241             'key does exist in mapping' );
 242
 243         is( HasClassAttribute->GetMapping('a'), 20,
 244             'value for a in mapping is 20' );
 245     }
 246 }
 247
 248
 249 1;