lib/Mouse/Meta/Attribute.pm

   1 package Mouse::Meta::Attribute;
   2 use strict;
   3 use warnings;
   4
   5 use Scalar::Util ();
   6 use Mouse::Meta::TypeConstraint;
   7 use Mouse::Meta::Method::Accessor;
   8
   9 sub new {
  10     my ($class, $name, %options) = @_;
  11
  12     $options{name} = $name;
  13
  14     $options{init_arg} = $name
  15         unless exists $options{init_arg};
  16
  17     my $is = $options{is} ||= '';
  18
  19     if($is eq 'rw'){
  20         $options{accessor} = $name if !exists $options{accessor};
  21     }
  22     elsif($is eq 'ro'){
  23         $options{reader}   = $name if !exists $options{reader};
  24     }
  25
  26     bless \%options, $class;
  27 }
  28
  29 # readers
  30
  31 sub name                 { $_[0]->{name}                   }
  32 sub associated_class     { $_[0]->{associated_class}       }
  33
  34 sub accessor             { $_[0]->{accessor}               }
  35 sub reader               { $_[0]->{reader}                 }
  36 sub writer               { $_[0]->{writer}                 }
  37 sub predicate            { $_[0]->{predicate}              }
  38 sub clearer              { $_[0]->{clearer}                }
  39 sub handles              { $_[0]->{handles}                }
  40
  41 sub _is_metadata         { $_[0]->{is}                     }
  42 sub is_required          { $_[0]->{required}               }
  43 sub default              { $_[0]->{default}                }
  44 sub is_lazy              { $_[0]->{lazy}                   }
  45 sub is_lazy_build        { $_[0]->{lazy_build}             }
  46 sub is_weak_ref          { $_[0]->{weak_ref}               }
  47 sub init_arg             { $_[0]->{init_arg}               }
  48 sub type_constraint      { $_[0]->{type_constraint}        }
  49 sub find_type_constraint {
  50     Carp::carp("This method was deprecated");
  51     $_[0]->type_constraint();
  52 }
  53 sub trigger              { $_[0]->{trigger}                }
  54 sub builder              { $_[0]->{builder}                }
  55 sub should_auto_deref    { $_[0]->{auto_deref}             }
  56 sub should_coerce        { $_[0]->{should_coerce}          }
  57
  58 # predicates
  59
  60 sub has_accessor         { exists $_[0]->{accessor}        }
  61 sub has_reader           { exists $_[0]->{reader}          }
  62 sub has_writer           { exists $_[0]->{writer}          }
  63 sub has_predicate        { exists $_[0]->{predicate}       }
  64 sub has_clearer          { exists $_[0]->{clearer}         }
  65 sub has_handles          { exists $_[0]->{handles}         }
  66
  67 sub has_default          { exists $_[0]->{default}         }
  68 sub has_type_constraint  { exists $_[0]->{type_constraint} }
  69 sub has_trigger          { exists $_[0]->{trigger}         }
  70 sub has_builder          { exists $_[0]->{builder}         }
  71
  72 sub _create_args {
  73     $_[0]->{_create_args} = $_[1] if @_ > 1;
  74     $_[0]->{_create_args}
  75 }
  76
  77 sub accessor_metaclass { 'Mouse::Meta::Method::Accessor' }
  78
  79 sub _inlined_name {
  80     my $self = shift;
  81     return sprintf '"%s"', quotemeta $self->name;
  82 }
  83
  84
  85 sub create {
  86     my ($self, $class, $name, %args) = @_;
  87
  88     $args{name}             = $name;
  89     $args{associated_class} = $class;
  90
  91     %args = $self->canonicalize_args($name, %args);
  92     $self->validate_args($name, \%args);
  93
  94     $args{should_coerce} = delete $args{coerce}
  95         if exists $args{coerce};
  96
  97     if (exists $args{isa}) {
  98         my $type_constraint = delete $args{isa};
  99         $args{type_constraint}= Mouse::Util::TypeConstraints::find_or_create_isa_type_constraint($type_constraint);
 100     }
 101
 102     my $attribute = $self->new($name, %args);
 103
 104     $attribute->_create_args(\%args);
 105
 106     $class->add_attribute($attribute);
 107
 108     my $associated_methods = 0;
 109
 110     my $generator_class = $self->accessor_metaclass;
 111     foreach my $type(qw(accessor reader writer predicate clearer handles)){
 112         if(exists $attribute->{$type}){
 113             my $installer    = '_install_' . $type;
 114             $generator_class->$installer($attribute, $attribute->{$type}, $class);
 115             $associated_methods++;
 116         }
 117     }
 118
 119     if($associated_methods == 0 && ($attribute->_is_metadata || '') ne 'bare'){
 120         Carp::cluck(qq{Attribute ($name) of class }.$class->name.qq{ has no associated methods (did you mean to provide an "is" argument?)});
 121
 122     }
 123
 124     return $attribute;
 125 }
 126
 127 sub canonicalize_args {
 128     my $self = shift;
 129     my $name = shift;
 130     my %args = @_;
 131
 132     if ($args{lazy_build}) {
 133         $args{lazy}      = 1;
 134         $args{required}  = 1;
 135         $args{builder}   = "_build_${name}"
 136             if !exists($args{builder});
 137         if ($name =~ /^_/) {
 138             $args{clearer}   = "_clear${name}" if !exists($args{clearer});
 139             $args{predicate} = "_has${name}" if !exists($args{predicate});
 140         }
 141         else {
 142             $args{clearer}   = "clear_${name}" if !exists($args{clearer});
 143             $args{predicate} = "has_${name}" if !exists($args{predicate});
 144         }
 145     }
 146
 147     return %args;
 148 }
 149
 150 sub validate_args {
 151     my $self = shift;
 152     my $name = shift;
 153     my $args = shift;
 154
 155     $self->throw_error("You can not use lazy_build and default for the same attribute ($name)")
 156         if $args->{lazy_build} && exists $args->{default};
 157
 158     $self->throw_error("You cannot have lazy attribute ($name) without specifying a default value for it")
 159         if $args->{lazy}
 160         && !exists($args->{default})
 161         && !exists($args->{builder});
 162
 163     $self->throw_error("References are not allowed as default values, you must wrap the default of '$name' in a CODE reference (ex: sub { [] } and not [])")
 164         if ref($args->{default})
 165         && ref($args->{default}) ne 'CODE';
 166
 167     $self->throw_error("You cannot auto-dereference without specifying a type constraint on attribute ($name)")
 168         if $args->{auto_deref} && !exists($args->{isa});
 169
 170     $self->throw_error("You cannot auto-dereference anything other than a ArrayRef or HashRef on attribute ($name)")
 171         if $args->{auto_deref}
 172         && $args->{isa} !~ /^(?:ArrayRef|HashRef)(?:\[.*\])?$/;
 173
 174     if ($args->{trigger}) {
 175         if (ref($args->{trigger}) eq 'HASH') {
 176             $self->throw_error("HASH-based form of trigger has been removed. Only the coderef form of triggers are now supported.");
 177         }
 178
 179         $self->throw_error("Trigger must be a CODE ref on attribute ($name)")
 180             if ref($args->{trigger}) ne 'CODE';
 181     }
 182
 183     return 1;
 184 }
 185
 186 sub verify_against_type_constraint {
 187     my ($self, $value) = @_;
 188     my $tc = $self->type_constraint;
 189     return 1 unless $tc;
 190
 191     local $_ = $value;
 192     return 1 if $tc->check($value);
 193
 194     $self->verify_type_constraint_error($self->name, $value, $tc);
 195 }
 196
 197 sub verify_type_constraint_error {
 198     my($self, $name, $value, $type) = @_;
 199     $self->throw_error("Attribute ($name) does not pass the type constraint because: " . $type->get_message($value));
 200 }
 201
 202 sub coerce_constraint { ## my($self, $value) = @_;
 203     my $type = $_[0]->{type_constraint}
 204         or return $_[1];
 205     return Mouse::Util::TypeConstraints->typecast_constraints($_[0]->associated_class->name, $_[0]->type_constraint, $_[1]);
 206 }
 207
 208 sub _canonicalize_handles {
 209     my $self    = shift;
 210     my $handles = shift;
 211
 212     if (ref($handles) eq 'HASH') {
 213         return %$handles;
 214     }
 215     elsif (ref($handles) eq 'ARRAY') {
 216         return map { $_ => $_ } @$handles;
 217     }
 218     else {
 219         $self->throw_error("Unable to canonicalize the 'handles' option with $handles");
 220     }
 221 }
 222
 223 sub clone_parent {
 224     my $self  = shift;
 225     my $class = shift;
 226     my $name  = shift;
 227     my %args  = ($self->get_parent_args($class, $name), @_);
 228
 229     $self->create($class, $name, %args);
 230 }
 231
 232 sub get_parent_args {
 233     my $self  = shift;
 234     my $class = shift;
 235     my $name  = shift;
 236
 237     for my $super ($class->linearized_isa) {
 238         my $super_attr = $super->can("meta") && $super->meta->get_attribute($name)
 239             or next;
 240         return %{ $super_attr->_create_args };
 241     }
 242
 243     $self->throw_error("Could not find an attribute by the name of '$name' to inherit from");
 244 }
 245
 246 sub throw_error{
 247     my $self = shift;
 248
 249     my $metaclass = (ref $self && $self->associated_class) || 'Mouse::Meta::Class';
 250     $metaclass->throw_error(@_, depth => 1);
 251 }
 252
 253 1;
 254
 255 __END__
 256
 257 =head1 NAME
 258
 259 Mouse::Meta::Attribute - attribute metaclass
 260
 261 =head1 METHODS
 262
 263 =head2 new %args -> Mouse::Meta::Attribute
 264
 265 Instantiates a new Mouse::Meta::Attribute. Does nothing else.
 266
 267 =head2 create OwnerClass, AttributeName, %args -> Mouse::Meta::Attribute
 268
 269 Creates a new attribute in OwnerClass. Accessors and helper methods are
 270 installed. Some error checking is done.
 271
 272 =head2 name -> AttributeName
 273
 274 =head2 associated_class -> OwnerClass
 275
 276 =head2 is_required -> Bool
 277
 278 =head2 default -> Item
 279
 280 =head2 has_default -> Bool
 281
 282 =head2 is_lazy -> Bool
 283
 284 =head2 predicate -> MethodName | Undef
 285
 286 =head2 has_predicate -> Bool
 287
 288 =head2 clearer -> MethodName | Undef
 289
 290 =head2 has_clearer -> Bool
 291
 292 =head2 handles -> { LocalName => RemoteName }
 293
 294 =head2 has_handles -> Bool
 295
 296 =head2 is_weak_ref -> Bool
 297
 298 =head2 init_arg -> Str
 299
 300 =head2 type_constraint -> Str
 301
 302 =head2 has_type_constraint -> Bool
 303
 304 =head2 trigger => CODE | Undef
 305
 306 =head2 has_trigger -> Bool
 307
 308 =head2 builder => MethodName | Undef
 309
 310 =head2 has_builder -> Bool
 311
 312 =head2 is_lazy_build => Bool
 313
 314 =head2 should_auto_deref -> Bool
 315
 316 Informational methods.
 317
 318 =head2 verify_against_type_constraint Item -> 1 | ERROR
 319
 320 Checks that the given value passes this attribute's type constraint. Returns 1
 321 on success, otherwise C<confess>es.
 322
 323 =head2 canonicalize_args Name, %args -> %args
 324
 325 Canonicalizes some arguments to create. In particular, C<lazy_build> is
 326 canonicalized into C<lazy>, C<builder>, etc.
 327
 328 =head2 validate_args Name, \%args -> 1 | ERROR
 329
 330 Checks that the arguments to create the attribute (ie those specified by
 331 C<has>) are valid.
 332
 333 =head2 clone_parent OwnerClass, AttributeName, %args -> Mouse::Meta::Attribute
 334
 335 Creates a new attribute in OwnerClass, inheriting options from parent classes.
 336 Accessors and helper methods are installed. Some error checking is done.
 337
 338 =head2 get_parent_args OwnerClass, AttributeName -> Hash
 339
 340 Returns the options that the parent class of C<OwnerClass> used for attribute
 341 C<AttributeName>.
 342
 343 =cut
 344