Moos
view release on metacpan - search on metacpan
view release on metacpan or search on metacpan
lib/Moos.pm view on Meta::CPAN
next if $attrs{$name};
push @attrs, ($attrs{$name} = $attr);
}
}
return @attrs;
}
# Cheap introspection stuff
sub get_attribute {
my ($self, $name) = @_;
return $self->{attributes}{$name};
}
sub find_attribute_by_name {
my ($self, $name) = @_;
for ($self->get_all_attributes) {
return $_ if $_->name eq $name;
}
return;
}
# Package for roles
package Moos::Meta::Role;
use Carp qw(confess);
our @ISA = 'Moos::Meta::Class';
sub add_attribute {
my $self = shift;
my $name = shift;
my %args = @_==1 ? %{$_[0]} : @_;
push @{$Role::Tiny::INFO{ $self->name }{attributes}},
$name => \%args;
$self->SUPER::add_attribute($name, \%args);
}
# Package for blessed attributes
package Moos::Meta::Attribute;
use Carp qw(confess);
BEGIN { our @ISA = 'Moos::Object' };
__PACKAGE__->meta->add_attribute($_, { is=>'ro' })
for qw(
name associated_class is isa coerce does required
weak_ref lazy trigger handles builder default clearer
predicate documentation _skip_setup
);
sub _is_simple {
not ( $_[0]{builder}
|| $_[0]{default}
|| $_[0]{trigger}
|| $ENV{PERL_MOOS_ACCESSOR_CALLS}
);
}
# Not sure why it is necessary to override &new here...
sub new {
my $class = shift;
my $self = bless $class->BUILDARGS(@_) => $class;
$self->Moos::Object::BUILDALL;
return $self;
}
sub BUILDARGS {
shift;
my $args = @_==1 ? $_[0] : +{@_};
# Massage %args
my $name = $args->{name};
$args->{builder} = "_build_$name"
if defined $args->{builder} && $args->{builder} eq "1";
$args->{clearer} = $name =~ /^_/ ? "_clear$name" : "clear_$name"
if defined $args->{clearer} && $args->{clearer} eq "1";
$args->{predicate} = $name =~ /^_/ ? "_has$name" : "has_$name"
if defined $args->{predicate} && $args->{predicate} eq "1";
$args->{trigger} = do {
my ($trigger, $method) = "_trigger_$name";
sub {
$method ||= $_[0]->can($trigger)
or confess "method $trigger does not exist for class ".ref($_[0]);
goto $method;
};
} if defined $args->{trigger} && $args->{trigger} eq "1";
$args->{is} = 'rw'
unless defined $args->{is};
return $args;
}
sub BUILD {
my $self = shift;
my $metaclass = $self->{associated_class} or return;
foreach (qw( name builder predicate clearer ))
{
next if !exists $self->{$_};
next if $self->{$_} =~ $VALID_NAME;
confess sprintf(
"invalid method name '%s' for %s",
$self->{$_},
$_ eq 'name' ? 'attribute' : $_,
);
}
unless ( $self->{_skip_setup} ) {
$self->_setup_accessor($metaclass);
$self->_setup_clearer($metaclass) if $self->{clearer};
$self->_setup_predicate($metaclass) if $self->{predicate};
$self->_setup_delegation($metaclass) if $self->{handles};
}
}
# Make a Setter/Getter accessor
sub _setup_accessor
{
my ($self, $metaclass) = @_;
my $name = $self->{name};
if ($self->_is_simple) {
view all matches for this distributionview release on metacpan - search on metacpan
( run in 1.245 second using v1.00-cache-2.02-grep-82fe00e-cpan-503542c4f10 )