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;