File Coverage

blib/lib/RPC/ExtDirect/Util/Accessor.pm

Criterion	Covered	Total	%
statement	410	633	64.7
branch	163	210	77.6
condition	8	12	66.6
subroutine	110	177	62.1
pod	77	161	47.8
total	768	1193	64.3

package RPC::ExtDirect::Util::Accessor;

use strict;
use warnings;
no  warnings 'uninitialized';       ## no critic

use Carp;

### NON-EXPORTED PUBLIC PACKAGE SUBROUTINE ###
#
# Generate either simple accessors, or complex ones, or both
#

sub mk_accessors {
    # Support class method calling convention for convenience
    shift if $_[0] eq __PACKAGE__;

    my (%arg) = @_;

    $arg{class} ||= caller();

    my $simplexes = $arg{simple};

    $simplexes = [ $simplexes ] unless 'ARRAY' eq ref $simplexes;

    for my $accessor ( @$simplexes ) {
        next unless defined $accessor;

        _create_accessor(
            type     => 'simple',
            accessor => $accessor,
            %arg,
        );
    }

    my $complexes = $arg{complex};

    for my $prop ( @$complexes ) {
        my $setters  = $prop->{setter} || $prop->{accessor};

        $setters = [ $setters ] unless 'ARRAY' eq ref $setters;

        for my $specific ( @$setters ) {
            _create_accessor(
                type     => 'complex',
                accessor => $specific,
                fallback => $prop->{fallback},
                %arg,
            );
        }
    }
}

# This is a convenience shortcut, too, as I always forget if
# the sub name is singular or plural...
*mk_accessor = *mk_accessors;

############## PRIVATE METHODS BELOW ##############

### PRIVATE PACKAGE SUBROUTINE ###
#
# Create an accessor
#

sub _create_accessor {
    my (%arg) = @_;

    my $class     = $arg{class};
    my $overwrite = $arg{overwrite};
    my $ignore    = $arg{ignore};
    my $type      = $arg{type};
    my $accessor  = $arg{accessor};
    my $fallback  = $arg{fallback};

    return unless defined $accessor;

    if ( $class->can($accessor) ) {
        croak "Accessor $accessor already exists in class $class"
            if !$overwrite && !$ignore;

        return if $ignore && !$overwrite;
    }

    my $accessor_fn  = $type eq 'complex' ? _complex($accessor, $fallback)
                     :                      _simplex($accessor)
                     ;
    my $predicate_fn = _predicate($accessor);

    eval "package $class; no warnings 'redefine'; " .
         "$accessor_fn; $predicate_fn; 1";
}

### PRIVATE PACKAGE SUBROUTINE ###
#
# Return the text for a predicate method
#

sub _predicate {
    my ($prop) = @_;

    return "
        sub has_$prop {
            my \$self = shift;

            return exists \$self->{$prop};
        }
    ";
}

### PRIVATE PACKAGE SUBROUTINE ###
#
# Return the text for a simple accessor method that acts as both getter
# when there are no arguments passed to it, and as a setter when there is
# at least one argument.
# When used as a setter, only the first argument will be assigned
# to the object property, the rest will be ignored.
#

sub _simplex {
    my ($prop) = @_;

    return "
        sub $prop {
            my \$self = shift;

            if ( \@_ ) {
                \$self->{$prop} = shift;
                return \$self;
            }
            else {
                return \$self->{$prop};
            }
        }
    ";
}

### PRIVATE PACKAGE SUBROUTINE ###
#
# Return an accessor that will query the 'specific' object property
# first and return it if it's defined, falling back to the 'fallback'
# property getter otherwise when called with no arguments.
# Setter will set the 'specific' property for the object when called
# with one argument.
#

sub _complex {
    my ($specific, $fallback) = @_;

    return "
        sub $specific {
            my \$self = shift;

            if ( \@_ ) {
                \$self->{$specific} = shift;
                return \$self;
            }
            else {
                return exists \$self->{$specific}
                            ? \$self->{$specific}
                            : \$self->$fallback()
                            ;
            }
        }
    ";
}

1;