lib/Mouse/Meta/Attribute.pm

   1 #!/usr/bin/env perl
   2 package Mouse::Meta::Attribute;
   3 use strict;
   4 use warnings;
   5
   6 use Carp 'confess';
   7 use Scalar::Util 'blessed';
   8
   9 sub new {
  10     my $class = shift;
  11     my %args  = @_;
  12
  13     $args{init_arg} = $args{name}
  14         unless exists $args{init_arg};
  15     $args{is} ||= '';
  16
  17     bless \%args, $class;
  18 }
  19
  20 sub name              { $_[0]->{name}            }
  21 sub class             { $_[0]->{class}           }
  22 sub _is_metadata      { $_[0]->{is}              }
  23 sub is_required       { $_[0]->{required}        }
  24 sub default           { $_[0]->{default}         }
  25 sub is_lazy           { $_[0]->{lazy}            }
  26 sub predicate         { $_[0]->{predicate}       }
  27 sub clearer           { $_[0]->{clearer}         }
  28 sub handles           { $_[0]->{handles}         }
  29 sub is_weak_ref       { $_[0]->{weak_ref}        }
  30 sub init_arg          { $_[0]->{init_arg}        }
  31 sub type_constraint   { $_[0]->{type_constraint} }
  32 sub trigger           { $_[0]->{trigger}         }
  33 sub builder           { $_[0]->{builder}         }
  34 sub should_auto_deref { $_[0]->{auto_deref}      }
  35
  36 sub has_default         { exists $_[0]->{default}         }
  37 sub has_predicate       { exists $_[0]->{predicate}       }
  38 sub has_clearer         { exists $_[0]->{clearer}         }
  39 sub has_handles         { exists $_[0]->{handles}         }
  40 sub has_type_constraint { exists $_[0]->{type_constraint} }
  41 sub has_trigger         { exists $_[0]->{trigger}         }
  42 sub has_builder         { exists $_[0]->{builder}         }
  43
  44 sub _create_args {
  45     $_[0]->{_create_args} = $_[1] if @_ > 1;
  46     $_[0]->{_create_args}
  47 }
  48
  49 sub generate_accessor {
  50     my $attribute = shift;
  51
  52     my $name       = $attribute->name;
  53     my $key        = $name;
  54     my $default    = $attribute->default;
  55     my $trigger    = $attribute->trigger;
  56     my $type       = $attribute->type_constraint;
  57     my $constraint = $attribute->find_type_constraint;
  58     my $builder    = $attribute->builder;
  59
  60     my $accessor = 'sub {
  61         my $self = shift;';
  62
  63     if ($attribute->_is_metadata eq 'rw') {
  64         $accessor .= 'if (@_) {
  65             local $_ = $_[0];';
  66
  67         if ($constraint) {
  68             $accessor .= 'do {
  69                 my $display = defined($_) ? overload::StrVal($_) : "undef";
  70                 Carp::confess("Attribute ($name) does not pass the type constraint because: Validation failed for \'$type\' failed with value $display") unless $constraint->();
  71             };'
  72         }
  73
  74         $accessor .= '$self->{$key} = $_;';
  75
  76         if ($attribute->is_weak_ref) {
  77             $accessor .= 'Scalar::Util::weaken($self->{$key}) if ref($self->{$key});';
  78         }
  79
  80         if ($trigger) {
  81             $accessor .= '$trigger->($self, $_, $attribute);';
  82         }
  83
  84         $accessor .= '}';
  85     }
  86     else {
  87         $accessor .= 'confess "Cannot assign a value to a read-only accessor" if @_;';
  88     }
  89
  90     if ($attribute->is_lazy) {
  91         $accessor .= '$self->{$key} = ';
  92
  93         $accessor .= $attribute->has_builder
  94                    ? '$self->$builder'
  95                      : ref($default) eq 'CODE'
  96                      ? '$default->($self)'
  97                      : '$default';
  98
  99         $accessor .= ' if !exists($self->{$key});';
 100     }
 101
 102     if ($attribute->should_auto_deref) {
 103         if ($attribute->type_constraint eq 'ArrayRef') {
 104             $accessor .= 'if (wantarray) {
 105                 return @{ $self->{$key} || [] };
 106             }';
 107         }
 108         else {
 109             $accessor .= 'if (wantarray) {
 110                 return %{ $self->{$key} || {} };
 111             }';
 112         }
 113     }
 114
 115     $accessor .= 'return $self->{$key};
 116     }';
 117
 118     return eval $accessor;
 119 }
 120
 121 sub generate_predicate {
 122     my $attribute = shift;
 123     my $key = $attribute->name;
 124
 125     my $predicate = 'sub { exists($_[0]->{$key}) }';
 126
 127     return eval $predicate;
 128 }
 129
 130 sub generate_clearer {
 131     my $attribute = shift;
 132     my $key = $attribute->name;
 133
 134     my $predicate = 'sub { delete($_[0]->{$key}) }';
 135
 136     return eval $predicate;
 137 }
 138
 139 sub generate_handles {
 140     my $attribute = shift;
 141     my $reader = $attribute->name;
 142     my %handles = $attribute->_canonicalize_handles($attribute->handles);
 143
 144     my %method_map;
 145
 146     for my $local_method (keys %handles) {
 147         my $remote_method = $handles{$local_method};
 148
 149         my $method = 'sub {
 150             my $self = shift;
 151             $self->$reader->$remote_method(@_)
 152         }';
 153
 154         $method_map{$local_method} = eval $method;
 155     }
 156
 157     return \%method_map;
 158 }
 159
 160 sub create {
 161     my ($self, $class, $name, %args) = @_;
 162
 163     $args{name} = $name;
 164     $args{class} = $class;
 165
 166     $self->validate_args($name, %args);
 167
 168     $args{type_constraint} = delete $args{isa}
 169         if exists $args{isa};
 170
 171     my $attribute = $self->new(%args);
 172     $attribute->_create_args(\%args);
 173
 174     my $meta = $class->meta;
 175
 176     $meta->add_attribute($attribute);
 177
 178     # install an accessor
 179     if ($attribute->_is_metadata eq 'rw' || $attribute->_is_metadata eq 'ro') {
 180         my $accessor = $attribute->generate_accessor;
 181         no strict 'refs';
 182         *{ $class . '::' . $name } = $accessor;
 183     }
 184
 185     for my $method (qw/predicate clearer/) {
 186         my $predicate = "has_$method";
 187         if ($attribute->$predicate) {
 188             my $generator = "generate_$method";
 189             my $coderef = $attribute->$generator;
 190             no strict 'refs';
 191             *{ $class . '::' . $attribute->$method } = $coderef;
 192         }
 193     }
 194
 195     if ($attribute->has_handles) {
 196         my $method_map = $attribute->generate_handles;
 197         for my $method_name (keys %$method_map) {
 198             no strict 'refs';
 199             *{ $class . '::' . $method_name } = $method_map->{$method_name};
 200         }
 201     }
 202
 203     return $attribute;
 204 }
 205
 206 sub validate_args {
 207     my $self = shift;
 208     my $name = shift;
 209     my %args = @_;
 210
 211     confess "You cannot have lazy attribute ($name) without specifying a default value for it"
 212         if $args{lazy} && !exists($args{default}) && !exists($args{builder});
 213
 214     confess "References are not allowed as default values, you must wrap the default of '$name' in a CODE reference (ex: sub { [] } and not [])"
 215         if ref($args{default})
 216         && ref($args{default}) ne 'CODE';
 217
 218     confess "You cannot auto-dereference without specifying a type constraint on attribute $name"
 219         if $args{auto_deref} && !exists($args{isa});
 220
 221     confess "You cannot auto-dereference anything other than a ArrayRef or HashRef on attribute $name"
 222         if $args{auto_deref}
 223         && $args{isa} ne 'ArrayRef'
 224         && $args{isa} ne 'HashRef';
 225
 226     return 1;
 227 }
 228
 229 sub find_type_constraint {
 230     my $self = shift;
 231     my $type = $self->type_constraint;
 232
 233     return unless $type;
 234
 235     my $checker = Mouse::TypeRegistry->optimized_constraints->{$type};
 236     return $checker if $checker;
 237
 238     return sub { blessed($_) && blessed($_) eq $type };
 239 }
 240
 241 sub verify_type_constraint {
 242     my $self = shift;
 243     local $_ = shift;
 244
 245     my $type = $self->type_constraint
 246         or return 1;
 247     my $constraint = $self->find_type_constraint;
 248
 249     return 1 if $constraint->($_);
 250
 251     my $name = $self->name;
 252     my $display = defined($_) ? overload::StrVal($_) : 'undef';
 253     Carp::confess("Attribute ($name) does not pass the type constraint because: Validation failed for \'$type\' failed with value $display");
 254 }
 255
 256 sub _canonicalize_handles {
 257     my $self    = shift;
 258     my $handles = shift;
 259
 260     if (ref($handles) eq 'HASH') {
 261         return %$handles;
 262     }
 263     elsif (ref($handles) eq 'ARRAY') {
 264         return map { $_ => $_ } @$handles;
 265     }
 266     else {
 267         confess "Unable to canonicalize the 'handles' option with $handles";
 268     }
 269 }
 270
 271 sub clone_parent {
 272     my $self  = shift;
 273     my $class = shift;
 274     my $name  = shift;
 275     my %args  = ($self->get_parent_args($class, $name), @_);
 276
 277     $self->create($class, $name, %args);
 278 }
 279
 280 sub get_parent_args {
 281     my $self  = shift;
 282     my $class = shift;
 283     my $name  = shift;
 284
 285     for my $super ($class->meta->linearized_isa) {
 286         my $super_attr = $super->meta->get_attribute($name)
 287             or next;
 288         return %{ $super_attr->_create_args };
 289     }
 290
 291     confess "Could not find an attribute by the name of '$name' to inherit from";
 292 }
 293
 294 1;
 295
 296 __END__
 297
 298 =head1 NAME
 299
 300 Mouse::Meta::Attribute - attribute metaclass
 301
 302 =head1 METHODS
 303
 304 =head2 new %args -> Mouse::Meta::Attribute
 305
 306 Instantiates a new Mouse::Meta::Attribute. Does nothing else.
 307
 308 =head2 create OwnerClass, AttributeName, %args -> Mouse::Meta::Attribute
 309
 310 Creates a new attribute in OwnerClass. Accessors and helper methods are
 311 installed. Some error checking is done.
 312
 313 =head2 name -> AttributeName
 314
 315 =head2 class -> OwnerClass
 316
 317 =head2 is_required -> Bool
 318
 319 =head2 default -> Item
 320
 321 =head2 has_default -> Bool
 322
 323 =head2 is_lazy -> Bool
 324
 325 =head2 predicate -> MethodName | Undef
 326
 327 =head2 has_predicate -> Bool
 328
 329 =head2 clearer -> MethodName | Undef
 330
 331 =head2 has_clearer -> Bool
 332
 333 =head2 handles -> { LocalName => RemoteName }
 334
 335 =head2 has_handles -> Bool
 336
 337 =head2 is_weak_ref -> Bool
 338
 339 =head2 init_arg -> Str
 340
 341 =head2 type_constraint -> Str
 342
 343 =head2 has_type_constraint -> Bool
 344
 345 =head2 trigger => CODE | Undef
 346
 347 =head2 has_trigger -> Bool
 348
 349 =head2 builder => MethodName | Undef
 350
 351 =head2 has_builder -> Bool
 352
 353 =head2 should_auto_deref -> Bool
 354
 355 Informational methods.
 356
 357 =head2 generate_accessor -> CODE
 358
 359 Creates a new code reference for the attribute's accessor.
 360
 361 =head2 generate_predicate -> CODE
 362
 363 Creates a new code reference for the attribute's predicate.
 364
 365 =head2 generate_clearer -> CODE
 366
 367 Creates a new code reference for the attribute's clearer.
 368
 369 =head2 generate_handles -> { MethodName => CODE }
 370
 371 Creates a new code reference for each of the attribute's handles methods.
 372
 373 =head2 find_type_constraint -> CODE
 374
 375 Returns a code reference which can be used to check that a given value passes
 376 this attribute's type constraint;
 377
 378 =head2 verify_type_constraint Item -> 1 | ERROR
 379
 380 Checks that the given value passes this attribute's type constraint. Returns 1
 381 on success, otherwise C<confess>es.
 382
 383 =cut
 384