File Coverage

blib/lib/Class/Accessor/Inherited/XS.pm

Criterion	Covered	Total	%
statement	57	58	98.2
branch	17	18	94.4
condition	14	17	82.3
subroutine	19	19	100.0
pod	0	3	0.0
total	107	115	93.0

package Class::Accessor::Inherited::XS;
use 5.010001;
use strict;
use warnings;

use Class::Accessor::Inherited::XS::Compat qw/mk_type_accessors mk_inherited_accessors mk_class_accessors mk_varclass_accessors mk_object_accessors/;

our $PREFIX = '__cag_';

BEGIN {
    our $VERSION = '0.37';

    require XSLoader;
    XSLoader::load('Class::Accessor::Inherited::XS', $VERSION);
}

use Carp qw/confess/;
use Class::Accessor::Inherited::XS::Constants;

my $REGISTERED_TYPES = {};
register_types(
    inherited       => {installer => _curry(\&_mk_inherited_accessor, None),       clone_arg => 1},
    inherited_ro    => {installer => _curry(\&_mk_inherited_accessor, IsReadonly), clone_arg => 1},
    class           => {installer => _curry(\&_mk_class_accessor, 0, None),        clone_arg => undef},
    class_ro        => {installer => _curry(\&_mk_class_accessor, 0, IsReadonly),  clone_arg => undef},
    varclass        => {installer => _curry(\&_mk_class_accessor, 1, None),        clone_arg => undef},
    varclass_ro     => {installer => _curry(\&_mk_class_accessor, 1, IsReadonly),  clone_arg => undef},
    object          => {installer => _curry(\&_mk_object_accessor, None),          clone_arg => 1},
    accessors       => {installer => _curry(\&_mk_object_accessor, None),          clone_arg => 1}, # alias for object
    object_ro       => {installer => _curry(\&_mk_object_accessor, IsReadonly),    clone_arg => 1},
    getters         => {installer => _curry(\&_mk_object_accessor, IsReadonly),    clone_arg => 1}, # alias for object_ro
    constructor     => {installer => \&_mk_constructor,                            clone_arg => undef},
);

sub import {
    my $pkg = shift;
    return unless scalar @_;

    my %opts = ref($_[0]) eq 'HASH' ? %{ $_[0] } : @_;
    my $class = delete $opts{package} // caller;

    for my $type (keys %opts) {
        my $accessors = $opts{$type};
        my ($installer, $clone_arg) = $pkg->_type_installer($type);

        if (ref($accessors) eq 'HASH') {
            $installer->($class, $_, $accessors->{$_}) for keys %$accessors;

        } elsif (ref($accessors) eq 'ARRAY') {
            $installer->($class, $_, $clone_arg && $_) for @$accessors;

        } elsif (!ref($accessors)) {
            $installer->($class, $accessors, $clone_arg && $accessors);

        } else {
            confess("Can't understand format for '$type' accessors initializer");
        }
    }
}

sub register_types {
    register_type(shift, shift) while scalar @_;
}

sub is_type_registered { exists $REGISTERED_TYPES->{$_[0]} }

sub register_type {
    my ($type, $args) = @_;

    if (exists $REGISTERED_TYPES->{$type}) {
        confess("Type '$type' has already been registered");
    }

    if (!exists $args->{installer}) {
        $args->{installer} = sub {
            my ($class, $name, $field) = @_;
            install_inherited_cb_accessor(
                "${class}::${name}", $field, $PREFIX.$field,
                $args->{read_cb} // $args->{on_read}, $args->{write_cb} // $args->{on_write},
                $args->{opts} // 0,
            );
        };
    }

    $args->{clone_arg} = 1 unless exists $args->{clone_arg}; # for cb-types
    $REGISTERED_TYPES->{$type} = $args;
}

#
#   Functions below are NOT part of the public API
#

sub _curry {
    my ($sub, @args) = @_;

    return sub {
        $sub->(@_, @args);
    };
}

sub _type_installer {
    my (undef, $type) = @_;

    my $type_info = $REGISTERED_TYPES->{$type} or confess("Don't know how to install '$type' accessors");
    return ($type_info->{installer}, $type_info->{clone_arg});
}

sub _mk_inherited_accessor {
    my ($class, $name, $field, $flags) = @_;

    install_inherited_accessor("${class}::${name}", $field, $PREFIX.$field, $flags);
}

sub _mk_class_accessor {
    my ($class, $name, $default, $is_varclass, $flags) = @_;

    install_class_accessor("${class}::${name}", $default, $is_varclass, $flags);
}

sub _mk_object_accessor {
    my ($class, $name, $field, $flags) = @_;

    install_object_accessor("${class}::${name}", $field, $flags);
}

sub _mk_constructor {
    my ($class, $name) = @_;

    install_constructor("${class}::${name}");
}

1;
__END__