view release on metacpan or  search on metacpan

inc/Class/MOP/Attribute.pm  view on Meta::CPAN

#line 1

package Class::MOP::Attribute;
BEGIN {
  $Class::MOP::Attribute::AUTHORITY = 'cpan:STEVAN';
}
BEGIN {
  $Class::MOP::Attribute::VERSION = '2.0009';
}

use strict;
use warnings;

use Class::MOP::Method::Accessor;

use Carp         'confess';
use Scalar::Util 'blessed', 'weaken';
use Try::Tiny;

use base 'Class::MOP::Object', 'Class::MOP::Mixin::AttributeCore';

# NOTE: (meta-circularity)
# This method will be replaced in the
# boostrap section of Class::MOP, by
# a new version which uses the
# &Class::MOP::Class::construct_instance
# method to build an attribute meta-object
# which itself is described with attribute
# meta-objects.
#     - Ain't meta-circularity grand? :)
sub new {
    my ( $class, @args ) = @_;

    unshift @args, "name" if @args % 2 == 1;
    my %options = @args;

    my $name = $options{name};

    (defined $name)
        || confess "You must provide a name for the attribute";

    $options{init_arg} = $name
        if not exists $options{init_arg};
    if(exists $options{builder}){
        confess("builder must be a defined scalar value which is a method name")
            if ref $options{builder} || !(defined $options{builder});
        confess("Setting both default and builder is not allowed.")
            if exists $options{default};
    } else {
        ($class->is_default_a_coderef(\%options))
            || confess("References are not allowed as default values, you must ".
                       "wrap the default of '$name' in a CODE reference (ex: sub { [] } and not [])")
                if exists $options{default} && ref $options{default};
    }
    if( $options{required} and not( defined($options{builder}) || defined($options{init_arg}) || exists $options{default} ) ) {
        confess("A required attribute must have either 'init_arg', 'builder', or 'default'");
    }

    $class->_new(\%options);
}

sub _new {
    my $class = shift;

    return Class::MOP::Class->initialize($class)->new_object(@_)
        if $class ne __PACKAGE__;

    my $options = @_ == 1 ? $_[0] : {@_};

    bless {
        'name'               => $options->{name},
        'accessor'           => $options->{accessor},
        'reader'             => $options->{reader},
        'writer'             => $options->{writer},
        'predicate'          => $options->{predicate},
        'clearer'            => $options->{clearer},
        'builder'            => $options->{builder},
        'init_arg'           => $options->{init_arg},
        exists $options->{default}
            ? ('default'     => $options->{default})
            : (),
        'initializer'        => $options->{initializer},
        'definition_context' => $options->{definition_context},
        # keep a weakened link to the
        # class we are associated with
        'associated_class' => undef,
        # and a list of the methods
        # associated with this attr
        'associated_methods' => [],
        # this let's us keep track of
        # our order inside the associated
        # class
        'insertion_order'    => undef,
    }, $class;
}

# NOTE:
# this is a primative (and kludgy) clone operation
# for now, it will be replaced in the Class::MOP
# bootstrap with a proper one, however we know
# that this one will work fine for now.
sub clone {
    my $self    = shift;
    my %options = @_;
    (blessed($self))
        || confess "Can only clone an instance";
    return bless { %{$self}, %options } => ref($self);
}

sub initialize_instance_slot {
    my ($self, $meta_instance, $instance, $params) = @_;
    my $init_arg = $self->{'init_arg'};

    # try to fetch the init arg from the %params ...

    # if nothing was in the %params, we can use the
    # attribute's default value (if it has one)
    if(defined $init_arg and exists $params->{$init_arg}){
        $self->_set_initial_slot_value(
            $meta_instance, 
            $instance,
            $params->{$init_arg},
        );
    } 
    elsif (exists $self->{'default'}) {
        $self->_set_initial_slot_value(
            $meta_instance, 
            $instance,
            $self->default($instance),
        );
    } 
    elsif (defined( my $builder = $self->{'builder'})) {
        if ($builder = $instance->can($builder)) {
            $self->_set_initial_slot_value(
                $meta_instance, 
                $instance,
                $instance->$builder,
            );
        } 
        else {
            confess(ref($instance)." does not support builder method '". $self->{'builder'} ."' for attribute '" . $self->name . "'");
        }
    }
}

inc/Class/MOP/Attribute.pm  view on Meta::CPAN

sub get_write_method { 
    my $self   = shift;
    my $writer = $self->writer || $self->accessor; 
    # normal case ...
    return $writer unless ref $writer;
    # the HASH ref case
    my ($name) = %$writer;
    return $name;    
}

sub get_read_method_ref {
    my $self = shift;
    if ((my $reader = $self->get_read_method) && $self->associated_class) {   
        return $self->associated_class->get_method($reader);
    }
    else {
        my $code = sub { $self->get_value(@_) };
        if (my $class = $self->associated_class) {
            return $class->method_metaclass->wrap(
                $code,
                package_name => $class->name,
                name         => '__ANON__'
            );
        }
        else {
            return $code;
        }
    }
}

sub get_write_method_ref {
    my $self = shift;    
    if ((my $writer = $self->get_write_method) && $self->associated_class) {         
        return $self->associated_class->get_method($writer);
    }
    else {
        my $code = sub { $self->set_value(@_) };
        if (my $class = $self->associated_class) {
            return $class->method_metaclass->wrap(
                $code,
                package_name => $class->name,
                name         => '__ANON__'
            );
        }
        else {
            return $code;
        }
    }
}

# slots

sub slots { (shift)->name }

# class association

sub attach_to_class {
    my ($self, $class) = @_;
    (blessed($class) && $class->isa('Class::MOP::Class'))
        || confess "You must pass a Class::MOP::Class instance (or a subclass)";
    weaken($self->{'associated_class'} = $class);
}

sub detach_from_class {
    my $self = shift;
    $self->{'associated_class'} = undef;
}

# method association

sub associate_method {
    my ($self, $method) = @_;
    push @{$self->{'associated_methods'}} => $method;
}

## Slot management

sub set_initial_value {
    my ($self, $instance, $value) = @_;
    $self->_set_initial_slot_value(
        Class::MOP::Class->initialize(ref($instance))->get_meta_instance,
        $instance,
        $value
    );
}

sub set_value { shift->set_raw_value(@_) }

sub set_raw_value {
    my $self = shift;
    my ($instance, $value) = @_;

    my $mi = Class::MOP::Class->initialize(ref($instance))->get_meta_instance;
    return $mi->set_slot_value($instance, $self->name, $value);
}

sub _inline_set_value {
    my $self = shift;
    return $self->_inline_instance_set(@_) . ';';
}

sub _inline_instance_set {
    my $self = shift;
    my ($instance, $value) = @_;

    my $mi = $self->associated_class->get_meta_instance;
    return $mi->inline_set_slot_value($instance, $self->name, $value);
}

sub get_value { shift->get_raw_value(@_) }

sub get_raw_value {
    my $self = shift;
    my ($instance) = @_;

    my $mi = Class::MOP::Class->initialize(ref($instance))->get_meta_instance;
    return $mi->get_slot_value($instance, $self->name);
}

sub _inline_get_value {
    my $self = shift;