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