UNIVERSAL-Object
view release on metacpan - search on metacpan
view release on metacpan or search on metacpan
lib/UNIVERSAL/Object.pm view on Meta::CPAN
# 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 )
view all matches for this distributionview release on metacpan - search on metacpan
( run in 2.082 seconds using v1.00-cache-2.02-grep-82fe00e-cpan-48ebf85a1963 )