File Coverage

blib/lib/Object/HashBase.pm

Criterion	Covered	Total	%
statement	69	77	89.6
branch	24	30	80.0
condition	6	15	40.0
subroutine	13	14	92.8
pod	1	1	100.0
total	113	137	82.4

package Object::HashBase;
use strict;
use warnings;

our $VERSION = '0.006';
our $HB_VERSION = $VERSION;
# The next line is for inlining
# <-- START -->

require Carp;
{
    no warnings 'once';
    $Carp::Internal{+__PACKAGE__} = 1;
}

BEGIN {
    # these are not strictly equivalent, but for out use we don't care
    # about order
    *_isa = ($] >= 5.010 && require mro) ? \&mro::get_linear_isa : sub {
        no strict 'refs';
        my @packages = ($_[0]);
        my %seen;
        for my $package (@packages) {
            push @packages, grep !$seen{$_}++, @{"$package\::ISA"};
        }
        return \@packages;
    }
}

my %STRIP = (
    '^' => 1,
    '-' => 1,
);

sub import {
    my $class = shift;
    my $into  = caller;

    # Make sure we list the OLDEST version used to create this class.
    my $ver = $Object::HashBase::HB_VERSION || $Object::HashBase::VERSION;
    $Object::HashBase::VERSION{$into} = $ver if !$Object::HashBase::VERSION{$into} || $Object::HashBase::VERSION{$into} > $ver;

    my $isa = _isa($into);
    my $attr_list = $Object::HashBase::ATTR_LIST{$into} ||= [];
    my $attr_subs = $Object::HashBase::ATTR_SUBS{$into} ||= {};

    my %subs = (
        ($into->can('new') ? () : (new => \&_new)),
        (map %{$Object::HashBase::ATTR_SUBS{$_} || {}}, @{$isa}[1 .. $#$isa]),
        (
            map {
                my $p = substr($_, 0, 1);
                my $x = $_;
                substr($x, 0, 1) = '' if $STRIP{$p};
                push @$attr_list => $x;
                my ($sub, $attr) = (uc $x, $x);
                $sub => ($attr_subs->{$sub} = sub() { $attr }),
                    $attr => sub { $_[0]->{$attr} },
                      $p eq '-' ? ("set_$attr" => sub { Carp::croak("'$attr' is read-only") })
                    : $p eq '^' ? ("set_$attr" => sub { Carp::carp("set_$attr() is deprecated"); $_[0]->{$attr} = $_[1] })
                    : ("set_$attr" => sub { $_[0]->{$attr} = $_[1] }),
            } @_
        ),
    );

    no strict 'refs';
    *{"$into\::$_"} = $subs{$_} for keys %subs;
}

sub attr_list {
    my $class = shift;

    my $isa = _isa($class);

    my %seen;
    my @list = grep { !$seen{$_}++ } map {
        my @out;

        if (0.004 > ($Object::HashBase::VERSION{$_} || 0)) {
            Carp::carp("$_ uses an inlined version of Object::HashBase too old to support attr_list()");
        }
        else {
            my $list = $Object::HashBase::ATTR_LIST{$_};
            @out = $list ? @$list : ()
        }

        @out;
    } reverse @$isa;

    return @list;
}

sub _new {
    my $class = shift;

    my $self;

    if (@_ == 1) {
        my $arg = shift;
        my $type = ref($arg);

        if ($type eq 'HASH') {
            $self = bless({%$arg}, $class)
        }
        else {
            Carp::croak("Not sure what to do with '$type' in $class constructor")
                unless $type eq 'ARRAY';

            my %proto;
            my @attributes = attr_list($class);
            while (@$arg) {
                my $val = shift @$arg;
                my $key = shift @attributes or Carp::croak("Too many arguments for $class constructor");
                $proto{$key} = $val;
            }

            $self = bless(\%proto, $class);
        }
    }
    else {
        $self = bless({@_}, $class);
    }

    $Object::HashBase::CAN_CACHE{$class} = $self->can('init')
        unless exists $Object::HashBase::CAN_CACHE{$class};

    $self->init if $Object::HashBase::CAN_CACHE{$class};

    $self;
}

1;

__END__