File Coverage

blib/lib/UNIVERSAL/Object.pm

Criterion	Covered	Total	%
statement	76	76	100.0
branch	29	36	80.5
condition	7	15	46.6
subroutine	17	17	100.0
pod	6	6	100.0
total	135	150	90.0

package UNIVERSAL::Object;
# ABSTRACT: A useful base class
use 5.008;
use strict;
use warnings;

use Carp       ();
use Hash::Util ();

our $VERSION   = '0.17';
our $AUTHORITY = 'cpan:STEVAN';

BEGIN { $] >= 5.010 ? require mro : require MRO::Compat }

sub new {
    my $class = shift;
       $class = ref $class if ref $class;

    my $proto = $class->BUILDARGS( @_ );

    Carp::confess('BUILDARGS must return a HASH reference, not '.$proto)
        unless $proto && ref $proto eq 'HASH';

    my $self = $class->BLESS( $proto );

    Carp::confess('BLESS must return a blessed reference, not '.$self)
        unless defined $self && UNIVERSAL::isa( $self, 'UNIVERSAL' );

    $self->can('BUILD') && UNIVERSAL::Object::Util::BUILDALL( $self, $proto );

    return $self;
}

sub BUILDARGS {
    my $class = shift;
    if ( scalar @_ == 1 && ref $_[0] ) {
        Carp::confess('Invalid BUILDARGS args for '.$class.', expected a HASH reference but got a '.$_[0])
            unless ref $_[0] eq 'HASH';
        return +{ %{ $_[0] } };
    }
    else {
        Carp::confess('Invalid BUILDARGS args for '.$class.', expected an even sized list, but got '.(scalar @_).' element(s) instead')
            unless ((scalar @_) % 2) == 0;
        return +{ @_ };
    }
}

sub BLESS {
    my $class = $_[0];
       $class = ref $class if ref $class;
    my $proto = $_[1];

    Carp::confess('Invalid BLESS args for '.$class.', You must specify an instance prototype as a HASH ref')
        unless defined $proto && ref $proto eq 'HASH';

    my $instance = $class->CREATE( $proto );

    Carp::confess('CREATE must return a reference to bless, not '.$instance)
        unless defined $instance && ref $instance;

    my $repr = ref   $instance;
    my $self = bless $instance => $class;

    # So,... for HASH based instances we'll
    # lock the set of keys so as to prevent
    # typos and other such silliness, if
    # you use other $repr types, you are
    # on your own, ... sorry ¯\_(ツ)_/¯
    if ( $repr eq 'HASH' ) {
        my %slots = $self->SLOTS;
        Hash::Util::lock_keys( %$self, keys %slots );
    }

    return $self;
}

sub CREATE {
    my $class = $_[0];
       $class = ref $class if ref $class;
    my $proto = $_[1];

    my $self  = $class->REPR( $proto );
    my %slots = $class->SLOTS;

    # NOTE:
    # We could check the return values of SLOTS
    # and REPR, but they might change and so it
    # is not something we would always know.
    # - SL

    $self->{ $_ } = exists $proto->{ $_ }
        ? $proto->{ $_ }
        : $slots{ $_ }->( $self, $proto )
            foreach sort keys %slots;

    return $self;
}

sub REPR () { +{} }

sub SLOTS {
    my $class = $_[0];
       $class = ref $class if ref $class;
    no strict   'refs';
    no warnings 'once';
    return %{$class . '::HAS'};
}

sub DESTROY {
    my $self = $_[0];
    $self->can('DEMOLISH') && UNIVERSAL::Object::Util::DEMOLISHALL( $self );
    return;
}

## Utils

sub UNIVERSAL::Object::Util::BUILDALL {
    my $self  = $_[0];
    my $proto = $_[1];
    foreach my $super ( reverse @{ mro::get_linear_isa( ref $self ) } ) {
        my $fully_qualified_name = $super . '::BUILD';
        $self->$fully_qualified_name( $proto )
            if defined &{ $fully_qualified_name };
    }
}

sub UNIVERSAL::Object::Util::DEMOLISHALL {
    my $self = $_[0];
    foreach my $super ( @{ mro::get_linear_isa( ref $self ) } ) {
        my $fully_qualified_name = $super . '::DEMOLISH';
        $self->$fully_qualified_name()
            if defined &{ $fully_qualified_name };
    }
}

1;

__END__