File Coverage

blib/lib/Exodist/Util/Accessors.pm

Criterion	Covered	Total	%
statement	142	148	95.9
branch	13	22	59.0
condition	6	7	85.7
subroutine	38	40	95.0
pod	0	4	0.0
total	199	221	90.0

package Exodist::Util::Accessors;
use strict;
use warnings;

use Exporter::Declare;
use Exodist::Util::Package qw/inject_sub/;
use Scalar::Util qw/blessed/;
use Carp qw/croak/;

default_exports qw/
    abstract
    accessors
    array_accessors
    category_accessors
/;

sub abstract {
    my $caller = caller;

    for my $name ( @_ ) {
        inject_sub( $caller, $name, sub { croak "$caller does not implement $name()" });
    }
}

sub accessors {
    my $caller = caller;
    for my $accessor (@_) {
        my ( $name, $default ) = ref( $accessor ) ? @$accessor : ( $accessor );
        inject_sub( $caller, $name, _simple_accessor( $name, $default ))
    }
}

sub array_accessors {
    my $caller = caller;
    _array_subs( $caller, $_ ) for @_;
}

sub category_accessors {
    my $caller = caller;
    _category_subs( $caller, $_ ) for @_;
}

sub _simple_accessor {
    my ( $name, $default ) = @_;
    return sub {
        my $self = shift;
        _verify_self( $self );
        ( $self->{$name} ) = @_ if @_;
        $self->{$name} = $default->()
            if $default && !exists $self->{$name};
        return $self->{$name};
    };
}

sub _array_subs {
    my ( $package, $name ) = @_;
    my $refname     = join( '_', $name,     'ref' );
    my $pullname    = join( '_', 'pull',    $name );
    my $pushname    = join( '_', 'push',    $name );
    my $popname     = join( '_', 'pop',     $name );
    my $unshiftname = join( '_', 'unshift', $name );
    my $shiftname   = join( '_', 'shift',   $name );

    inject_sub( $package, $refname,          _simple_accessor( $refname, sub {[]} ));
    inject_sub( $package, $name,            _arr_all_accessor( $refname,          ));
    inject_sub( $package, $pushname,       _arr_push_accessor( $refname,          ));
    inject_sub( $package, $pullname,       _arr_pull_accessor( $refname,          ));
    inject_sub( $package, $popname,         _arr_pop_accessor( $refname,          ));
    inject_sub( $package, $unshiftname, _arr_unshift_accessor( $refname,          ));
    inject_sub( $package, $shiftname,     _arr_shift_accessor( $refname,          ));
}

sub _category_subs {
    my ( $package, $name ) = @_;
    my $refname     = join( '_', $name,      'ref' );
    my $pullname    = join( '_', 'pull',     $name );
    my $pushname    = join( '_', 'push',     $name );
    my $keysname    = join( '_', 'keys',     $name );
    my $pullallname = join( '_', 'pull_all', $name );

    inject_sub( $package, $refname,           _simple_accessor( $refname, sub {{}} ));
    inject_sub( $package, $name,             _cat_all_accessor( $refname           ));
    inject_sub( $package, $pullname,        _cat_pull_accessor( $refname           ));
    inject_sub( $package, $pushname,        _cat_push_accessor( $refname           ));
    inject_sub( $package, $keysname,        _cat_keys_accessor( $refname           ));
    inject_sub( $package, $pullallname, _cat_pull_all_accessor( $refname           ));
}

sub _cat_pull_accessor {
    my ( $refname ) = @_;
    return sub {
        my $self = shift;
        _verify_self( $self );
        my ( $type ) = @_;
        $type ||= '!';
        my $ref = $self->$refname;
        return @{ delete $ref->{ $type } || [] };
    };
}

sub _cat_push_accessor {
    my ( $refname ) = @_;
    return sub {
        my $self = shift;
        _verify_self( $self );
        return unless @_;
        my $ref = $self->$refname;
        push @{ $ref->{ blessed($_) || '!' }} => $_
            for @_;
    };
}

sub _cat_keys_accessor {
    my ( $refname ) = @_;
    return sub {
        my $self = shift;
        _verify_self( $self );
        my $ref = $self->$refname;
        return keys %$ref;
    };
}

sub _cat_all_accessor {
    my ( $refname ) = @_;
    return sub {
        my $self = shift;
        _verify_self( $self );
        my ( $type ) = @_;
        my $ref = $self->$refname;
        return @{ $ref->{ $type } || [] } if $type;
        return( map { @$_ ? (@$_) : () } values %$ref );
    };
}

sub _cat_pull_all_accessor {
    my ( $refname ) = @_;
    return sub {
        my $self = shift;
        _verify_self( $self );
        my $ref = $self->$refname;
        my @out = map { @$_ ? (@$_) : () } values %$ref;
        $self->$refname({});
        return @out;
    };
}

sub _arr_all_accessor {
    my ( $refname ) = @_;
    return sub {
        my $self = shift;
        _verify_self( $self );
        my $ref = $self->$refname;
        return @$ref;
    };
}

sub _arr_push_accessor {
    my ( $refname ) = @_;
    return sub {
        my $self = shift;
        _verify_self( $self );
        return unless @_;
        my $ref = $self->$refname;
        push @$ref => @_;
    };
}

sub _arr_pull_accessor {
    my ( $refname ) = @_;
    return sub {
        my $self = shift;
        _verify_self( $self );
        my $ref = $self->$refname;
        $self->$refname([]);
        return @$ref;
    };
}

sub _arr_pop_accessor {
    my ( $refname ) = @_;
    return sub {
        my $self = shift;
        _verify_self( $self );
        my $ref = $self->$refname;
        pop @$ref;
    };
}

sub _arr_unshift_accessor {
    my ( $refname ) = @_;
    return sub {
        my $self = shift;
        _verify_self( $self );
        my $ref = $self->$refname;
        unshift @$ref => @_;
    };
}

sub _arr_shift_accessor {
    my ( $refname ) = @_;
    return sub {
        my $self = shift;
        _verify_self( $self );
        my $ref = $self->$refname;
        shift @$ref;
    };
}

sub _verify_self {
    my ( $self ) = @_;
    return if blessed( $self );
    croak "Attempted to use accessor on unblessed item '$self'";
}

1;

__END__