File Coverage

blib/lib/Object/HashBase.pm

Criterion	Covered	Total	%
statement	215	246	87.4
branch	85	116	73.2
condition	22	40	55.0
subroutine	26	29	89.6
pod	1	4	25.0
total	349	435	80.2

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

our $VERSION = '0.016';
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;
    }
}

sub _is_role {
    my $pkg = shift;
    return 0 unless $INC{'Role/Tiny.pm'};
    return Role::Tiny->is_role($pkg) ? 1 : 0;
}

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 (@parents, @roles, @attrs);
    for my $arg (@_) {
        if (defined($arg) && length($arg)) {
            my $p = substr($arg, 0, 1);
            if ($p eq '@') {
                push @parents, substr($arg, 1);
                next;
            }
            if ($p eq '&') {
                push @roles, substr($arg, 1);
                next;
            }
        }
        push @attrs, $arg;
    }

    for my $parent (@parents) {
        my $pm = $parent;
        $pm =~ s{::}{/}g;
        $pm .= '.pm';
        unless ($INC{$pm}) {
            local ($@);
            unless (eval { require $pm; 1 }) {
                Carp::croak("Could not load parent class '$parent': $@");
            }
        }
        no strict 'refs';
        push @{"$into\::ISA"}, $parent unless grep { $_ eq $parent } @{"$into\::ISA"};
    }

    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 = _is_role($into) ? 0 : 1;

    if ($add_new && (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, \@attrs, $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);
        }
    }

    if (@roles) {
        Carp::croak("Object::HashBase '&' role prefix requires Perl 5.010 or newer (this is $])")
            if $] < 5.010;

        unless ($INC{'Role/Tiny.pm'}) {
            local ($@);
            unless (eval { require Role::Tiny; 1 }) {
                Carp::croak("Object::HashBase '&' role prefix requires Role::Tiny but it could not be loaded: $@");
            }
        }

        unless (Role::Tiny->can('is_role')) {
            Carp::croak("Object::HashBase '&' role prefix requires Role::Tiny 1.003000 or newer (is_role missing)");
        }

        for my $role (@roles) {
            my $pm = $role;
            $pm =~ s{::}{/}g;
            $pm .= '.pm';

            unless ($INC{$pm}) {
                local ($@);
                unless (eval { require $pm; 1 }) {
                    Carp::croak("Could not load role '$role': $@");
                }
            }

            Carp::croak("'$role' is not a Role::Tiny role")
                unless Role::Tiny->is_role($role);

            Carp::croak("'$role' does not use Object::HashBase")
                unless exists $Object::HashBase::VERSION{$role};

            my $role_subs = $Object::HashBase::ATTR_SUBS{$role} || {};

            no strict 'refs';
            for my $const (keys %$role_subs) {
                next if defined &{"$into\::$const"};   # keep existing sub, no override, no warn
                *{"$into\::$const"} = $role_subs->{$const};
            }

            my $role_attr_list = $Object::HashBase::ATTR_LIST{$role} || [];
            push @{$Object::HashBase::ROLE_ATTRS{$into} ||= []}, @$role_attr_list;
        }

        my $key = "Object::HashBase::role_applier::$into";
        my $applier = $^H{$key} ||= Object::HashBase::_RoleApplier->new($into);
        $applier->add($_) for @roles;
    }
}

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;
    for my $pkg (reverse @$isa) {
        if (0.004 > ($Object::HashBase::VERSION{$pkg} || 0)) {
            Carp::carp("$pkg uses an inlined version of Object::HashBase too old to support attr_list()");
            next;
        }
        my $own = $Object::HashBase::ATTR_LIST{$pkg};
        my $role_attrs = $Object::HashBase::ROLE_ATTRS{$pkg} || [];
        for my $a (@$role_attrs, ($own ? @$own : ())) {
            push @list, $a unless $seen{$a}++;
        }
    }

    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;
}

# _RoleApplier — deferred Role::Tiny composition.
#
# Object::HashBase's '&' import prefix copies role constants into the consumer
# eagerly (so `$self->{+FOO}` resolves at compile time), then defers actual
# Role::Tiny->apply_roles_to_package to end of consumer's compile scope by
# storing a blessed object in %^H. Perl destroys %^H entries at end of compile
# scope, triggering DESTROY here, which finally composes the role(s).

package    # hide from PAUSE indexer
    Object::HashBase::_RoleApplier;

sub new {
    my ($class, $into) = @_;
    return bless { into => $into, roles => [] }, $class;
}

sub add {
    my ($self, $role) = @_;
    push @{$self->{roles}}, $role
        unless grep { $_ eq $role } @{$self->{roles}};
}

sub DESTROY {
    my $self = shift;
    return unless @{$self->{roles}};
    local $@;
    my $ok = eval { Role::Tiny->apply_roles_to_package($self->{into}, @{$self->{roles}}); 1 };
    unless ($ok) {
        my $err = $@ || 'unknown error';
        my $into = $self->{into};
        my $roles = join(', ', @{$self->{roles}});
        warn "Object::HashBase: failed to compose role(s) [$roles] into $into: $err";
    }
}

1;

__END__