File Coverage

blib/lib/Coat/Object.pm

Criterion	Covered	Total	%
statement	63	82	76.8
branch	13	24	54.1
condition	14	15	93.3
subroutine	13	15	86.6
pod	3	7	42.8
total	106	143	74.1

package Coat::Object;

use strict;
use warnings;
use Coat::Meta;
use Carp 'confess';

# this is the mother-class of each Coat objects, it provides
# basic instance methods such as a constructor

# The default constructor
sub new {
    my ( $class, @args ) = @_;

    # create the newborn
    my $self = {};
    bless $self, $class;

    # parse and prepare the args
    my $args = $self->build_args(@args);

    # init the object
    $self->init($args);

    # done
    return $self;
}

sub build_args {
    my ($self, @args) = @_;
    my $class = ref($self);

    my $args;
    $args = {@args} if @args % 2 == 0;

    # if BUILDARGS exists, look or it and run it
    if ($self->can('BUILDARGS')) {
        foreach my $pkg (reverse Coat::Meta->linearized_isa($class)) {
            my $buildargs_sub;
            {
                no strict 'refs';
                $buildargs_sub = *{$pkg."::BUILDARGS"};
            }
            if (defined &$buildargs_sub) {
                $args = $self->$buildargs_sub(@args);
                last;
            }
        }
    }

    # now check everything is OK with the args
    unless (defined $args) {
        if (@args == 1) {
            if (ref($args[0]) ne 'HASHREF') {
                confess "Single argument must be an HASHREF";
            }
            else {
                $args = $args[0];
            }
        }
        else {
            confess "Invalid arguments";
        }
    }
    return $args;
}

# returns the meta-class description of that instance
sub meta {
    my ($self) = @_;
    return Coat::Meta->class( ref($self) );
}

# init an instance : put default values and set values
# given at instanciation time
sub init {
    my ( $self, $attrs ) = @_;
    my $class = ref $self;

    my $class_attr = Coat::Meta->all_attributes( $class );

    # setting all default values
    foreach my $attr ( keys %{$class_attr} ) {
        my $meta = $class_attr->{$attr};

        confess "You cannot have lazy attribute ($attr) without specifying a default value for it"
            if ($meta->{lazy} && !exists($meta->{default}));

        # handling default values for non-lazy slots
        if ( (! $meta->{'lazy'}) && defined $meta->{'default'} ) {

            # saving original permission and setting it to read/write
            my $is = $meta->{'is'};
            $meta->{'is'} = 'rw';

            # set default value
            $self->$attr( Coat::Meta->attr_default( $self, $attr) );

            # restoring original permissions
            $meta->{'is'} = $is;
        }

        # a required read-only field must have a default value or be set at
        # instanciation time
        confess "Attribute ($attr) is required"
            if ($meta->{'required'} &&
                $meta->{'is'} eq 'ro' &&
                (! exists $meta->{'default'}) &&
                (! exists $attrs->{$attr}));
    }

    # setting values given at instanciation time
    foreach my $attr ( keys %$attrs ) {
        my $is = $class_attr->{$attr}{'is'};

        $class_attr->{$attr}{'is'} = 'rw';
        $self->$attr( $attrs->{$attr} );
        $class_attr->{$attr}{'is'} = $is;
    }

    $self->BUILDALL($attrs);
    return $self;
}

# This is done to let us implement easily the BUILDARGS/BUILD/DEMOLISH stuff
# It must behave the same: with inheritance in mind.
# Thanks again to the Moose team for the idea of *ALL() methods.

sub _run_for_all {
    my ($method_name, $self, $params) = @_;
    my $class = ref($self);

    return unless $self->can($method_name);

    my $sub;
    foreach my $pkg (reverse Coat::Meta->linearized_isa($class)) {
        {
            no strict 'refs';
            $sub = *{$pkg."::${method_name}"};
        }
        $self->$sub( %$params ) if defined &$sub;
    }
}

sub BUILDALL { _run_for_all('BUILD', @_) }

sub DEMOLISHALL { _run_for_all('DEMOLISH', @_) }

sub DESTROY { goto &DEMOLISHALL }

# taken from Moose::Object
sub dump {
    my $self = shift;
    require Data::Dumper;
    local $Data::Dumper::Maxdepth = shift if @_;
    Data::Dumper::Dumper $self;
}

# end Coat::Object
1;
__END__