File Coverage

blib/lib/Object/HashBase.pm

Criterion	Covered	Total	%
statement	140	157	89.1
branch	51	70	72.8
condition	11	21	52.3
subroutine	20	23	86.9
pod	1	4	25.0
total	223	275	81.0

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

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

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

BEGIN {
    {
        # Make sure none of these get messed up.
        local ($SIG{__DIE__}, $@, $?, $!, $^E);
        if (eval { require Class::XSAccessor; Class::XSAccessor->VERSION(1.19); 1 }) {
            *CLASS_XS_ACCESSOR = sub() { 1 }
        }
        else {
            *CLASS_XS_ACCESSOR = sub() { 0 }
        }
    }

    # 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 %SPEC = (
    '^' => {reader => 1, writer => 0, dep_writer => 1, read_only => 0, strip => 1},
    '-' => {reader => 1, writer => 0, dep_writer => 0, read_only => 1, strip => 1},
    '>' => {reader => 0, writer => 1, dep_writer => 0, read_only => 0, strip => 1},
    '<' => {reader => 1, writer => 0, dep_writer => 0, read_only => 0, strip => 1},
    '+' => {reader => 0, writer => 0, dep_writer => 0, read_only => 0, strip => 1},
    '~' => {reader => 1, writer => 1, dep_writer => 0, read_only => 0, strip => 1, no_xs => 1},
);

sub spec { \%SPEC }

sub import {
    my $class = shift;
    my $into  = caller;
    $class->do_import($into, @_);
}

sub do_import {
    my $class = shift;
    my $into  = shift;

    # 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 @pre_init;
    my @post_init;

    my $add_new = 1;

    if (my $have_new = $into->can('new')) {
        my $new_lookup = $Object::HashBase::NEW_LOOKUP //= {};
        $add_new = 0 unless $new_lookup->{$have_new};
    }

    my %subs = (
        ($add_new ? ($class->_build_new($into, \@pre_init, \@post_init)) : ()),
        (map %{$Object::HashBase::ATTR_SUBS{$_} || {}}, @{$isa}[1 .. $#$isa]),
        ($class->args_to_subs($attr_list, $attr_subs, \@_, $into)),
    );

    no strict 'refs';
    while (my ($k, $v) = each %subs) {
        if (ref($v) eq 'CODE') {
            *{"$into\::$k"} = $v;
        }
        else {
            my ($sub, @args) = @$v;
            $sub->(@args);
        }
    }
}

sub args_to_subs {
    my $class = shift;
    my ($attr_list, $attr_subs, $args, $into) = @_;

    my $use_gen = $class->can('gen_accessor') ;

    my %out;

    while (@$args) {
        my $x = shift @$args;
        my $p = substr($x, 0, 1);

        my $spec = $class->spec->{$p} || {reader => 1, writer => 1};
        substr($x, 0, 1) = '' if $spec->{strip};

        push @$attr_list => $x;
        my ($sub, $attr) = (uc $x, $x);

        $attr_subs->{$sub} = sub() { $attr };
        $out{$sub} = $attr_subs->{$sub};

        my $copy = "$attr";
        if ($spec->{reader}) {
            if ($use_gen) {
                $out{$attr} = $class->gen_accessor(reader => $copy, $spec, $args);
            }
            elsif (CLASS_XS_ACCESSOR && !$spec->{no_xs}) {
                $out{$attr} = [\&Class::XSAccessor::newxs_getter, "$into\::$attr", $copy];
            }
            else {
                $out{$attr} = sub { $_[0]->{$attr} };
            }
        }

        if ($spec->{writer}) {
            if ($use_gen) {
                $out{"set_$attr"} = $class->gen_accessor(writer => $copy, $spec, $args);
            }
            elsif(CLASS_XS_ACCESSOR && !$spec->{no_xs}) {
                $out{"set_$attr"} = [\&Class::XSAccessor::newxs_setter, "$into\::set_$attr", $copy, 0];
            }
            else {
                $out{"set_$attr"} = sub { $_[0]->{$attr} = $_[1] };
            }
        }
        elsif($spec->{read_only}) {
            $out{"set_$attr"} = $use_gen ? $class->gen_accessor(read_only => $copy, $spec, $args) : sub { Carp::croak("'$attr' is read-only") };
        }
        elsif($spec->{dep_writer}) {
            $out{"set_$attr"} = $use_gen ? $class->gen_accessor(dep_writer => $copy, $spec, $args) : sub { Carp::carp("set_$attr() is deprecated"); $_[0]->{$attr} = $_[1] };
        }

        if ($spec->{custom}) {
            my %add = $class->gen_accessor(custom => $copy, $spec, $args);
            $out{$_} = $add{$_} for keys %add;
        }
    }

    return %out;
}

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 _build_new {
    my $class = shift;
    my ($into, $pre_init, $post_init) = @_;

    my $add_pre_init  = sub(&) { push @$pre_init  => $_[-1] };
    my $add_post_init = sub(&) { push @$post_init => $_[-1] };

    my $__pre_init = $into->can('_pre_init');
    my $_pre_init  = $__pre_init ? sub { ($__pre_init->(), @$pre_init) } : sub { @$pre_init };

    my $__post_init = $into->can('_post_init');
    my $_post_init  = $__post_init ? sub { ($__post_init->(), @$post_init) } : sub {  @$post_init };

    my $new = sub {
        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->$_() for $_pre_init->();
        $self->init() if $Object::HashBase::CAN_CACHE{$class};
        $self->$_() for reverse $_post_init->();

        $self;
    };

    my $new_lookup = $Object::HashBase::NEW_LOOKUP //= {};
    $new_lookup->{$new} = 1;

    my %out;

    {
        no strict 'refs';
        $out{new}           = $new           unless defined(&{"${into}\::new"});
        $out{add_pre_init}  = $add_pre_init  unless defined(&{"${into}\::add_pre_init"});
        $out{add_post_init} = $add_post_init unless defined(&{"${into}\::add_post_init"});
        $out{_pre_init}     = $_pre_init     unless defined(&{"${into}\::_pre_init"});
        $out{_post_init}    = $_post_init    unless defined(&{"${into}\::_post_init"});
    }

    return %out;
}

1;

__END__