File Coverage

blib/lib/Anonymous/Object.pm

Criterion	Covered	Total	%
statement	299	322	92.8
branch	135	138	97.8
condition	31	32	96.8
subroutine	46	48	95.8
pod	19	20	95.0
total	530	560	94.6

package Anonymous::Object;
use strict;
use warnings;
use Loo qw/dDump/;
our $VERSION = 1.02;

our $UNIQUE;
BEGIN {
	$UNIQUE = 0;
}

sub new {
	my ( $cls, %args ) = ( shift(), scalar @_ == 1 ? %{ $_[0] } : @_ );
	my $self = bless {}, $cls;
	my %accessors = (
		object_name => { default => 'Anonymous::Object' },
		meta => { default => {}, },
		default => { default => {}, },
		types => { default => {}, },
		type_library => { default => 'Types::Standard' },
		type_map => {
			default => {
				HASH => 'HashRef',
				ARRAY => 'ArrayRef',
				STRING => 'Str',
				SCALAR => 'ScalarRef',
				REF => 'Ref',
				CODE => 'CodeRef',
				GLOB => 'GlobRef',
				NUM => 'Num',
				INT => 'Int',
				default => 'Any'
			}
		}
	);
	for my $accessor ( keys %accessors ) {
		my $param = defined $args{$accessor}
			? $args{$accessor}
			: $accessors{$accessor}->{default};
		my $value
			= $self->$accessor( $args{"build_$accessor"}
			? $args{"build_$accessor"}->( $self, $param )
			: $param );
		unless ( defined $value ) {
			die "$accessor accessor is required";
		}
	}
	return $self;
}

sub clean {
	my $class = ref $_[0];
	return $class->new({
		object_name => $_[0]->{object_name},
		type_library => $_[0]->{type_library},
		type_map => $_[0]->{type_map}
	});
}

sub object_name {
	my ($self, $value) = @_;
	if ( defined $value ) {
		if ( ref $value ) {
			die qq{Str: invalid value $value for accessor object_name}
		}
		$self->{object_name} = $value;
	}
	return $self->{object_name};
}

sub default {
	my ( $self, $value ) = @_;
	if ( defined $value ) {
		if ( ( ref($value) || "" ) ne "HASH" ) {
			die qq{HashRef: invalid value $value for accessor default};
		}
		$self->{default} = $value;
	}
	return $self->{default};
}

sub meta {
	my ( $self, $value ) = @_;
	if ( defined $value ) {
		if ( ( ref($value) || "" ) ne "HASH" ) {
			die qq{HashRef: invalid value $value for accessor meta};
		}
		$self->{meta} = $value;
	}
	return $self->{meta};
}

sub types {
	my ( $self, $value ) = @_;
	if ( defined $value ) {
		if ( ( ref($value) || "" ) ne "HASH" ) {
			die qq{HashRef: invalid value $value for accessor types};
		}
		$self->{types} = $value;
	}
	return $self->{types};
}

sub type_library {
	my ($self, $value) = @_;
	if ( defined $value ) {
		if ( ref $value ) {
			die qq{Str: invalid value $value for accessor type_library}
		}
		$self->{type_library} = $value;
	}
	return $self->{type_library};
}

sub type_map {
	my ( $self, $value ) = @_;
	if ( defined $value ) {
		if ( ( ref($value) || "" ) ne "HASH" ) {
			die qq{HashRef: invalid value $value for accessor type_map};
		}
		$self->{type_map} = $value;
	}
	return $self->{type_map};
}

sub hash_to_object_context {
	my ( $self, $hash, %accessors ) = @_;
	if ( ( ref($hash) || "" ) ne "HASH" ) {
		$hash = defined $hash ? $hash : 'undef';
		die
			qq{HashRef: invalid value $hash for variable \$hash in method hash_to_object_context};
	}
	$self = $self->clean();
	$self->default({});
	for my $key ( keys %{$hash} ) {
		$self->add_method(
			{
				name => $key,
				set => 1,
				code => qq|return shift->{$key}->(splice \@_, 1)|,
				%accessors
			}
		);
	}
	my $build = $self->build;
	for my $key ( keys %{$hash} ) {
		my $meth = "set_${key}";
		$build->$meth($hash->{$key});
	}
	return $build;
}

sub hash_to_object {
	my ( $self, $hash, %accessors ) = @_;
	if ( ( ref($hash) || "" ) ne "HASH" ) {
		$hash = defined $hash ? $hash : 'undef';
		die
			qq{HashRef: invalid value $hash for variable \$hash in method hash_to_object};
	}
	$self = $self->clean();
	$self->default($hash);
	for my $key ( keys %{$hash} ) {
		$self->add_method(
			{
				name => $key,
				%accessors
			}
		);
	}
	return $self->build;
}

sub hash_to_nested_object {
	my ( $self, $hash, %accessors ) = @_;
	if ( ( ref($hash) || "" ) ne "HASH" ) {
		$hash = defined $hash ? $hash : 'undef';
		die
			qq{HashRef: invalid value $hash for variable \$hash in method hash_to_object};
	}
	$self = $self->clean();
	for my $key ( keys %{$hash} ) {
		my $val = $hash->{$key};
		my $ref = ref $val || "";
		if ($ref eq 'HASH') {
			$val = $self->hash_to_nested_object(
				$val,
				%accessors
			);
		} elsif ($ref eq 'ARRAY') {
			$val = $self->array_to_nested_object(
				$val,
				%accessors
			);
		}
		$self->add_method(
			{
				name => $key,
				default => $val,
				nested => 1,
				%accessors
			}
		);
	}
	return $self->build;
}

sub array_to_nested_object {
	my ( $self, $array, %accessors ) = @_;
	if ( ( ref($array) || "" ) ne "ARRAY" ) {
		$array = defined $array ? $array : 'undef';
		die
			qq{ArrayRef: invalid value $array for variable \$array in method array_to_object};
	}
	for (my $i = 0; $i < scalar @{$array}; $i++) {
		my $val = $array->[$i];
		my $ref = ref $val || "";
		if ($ref eq 'HASH') {
			$val = $self->hash_to_nested_object(
				$val,
				%accessors
			);
		} elsif ($ref eq 'ARRAY') {
			$val = $self->array_to_nested_object(
				$val,
				%accessors
			);
		}
		$array->[$i] = $val;
	}
	return $array;
}

sub add_new {
	my ( $self, $new ) = @_;
	if ( ( ref($new) || "" ) ne "HASH" ) {
		$new = defined $new ? $new : 'undef';
		die
			qq{HashRef: invalid value $new for variable \$new in method add_new};
	}

	return sprintf q|return bless { %s }, __PACKAGE__;|, join q|,|,
		map { sprintf q|%s => %s|, $_, $self->stringify_struct( $new->{$_} ) }
		keys %{$new};

}

sub add_methods {
	my ( $self, $methods ) = @_;
	if ( ( ref($methods) || "" ) ne "ARRAY" ) {
		$methods = defined $methods ? $methods : 'undef';
		die
			qq{ArrayRef: invalid value $methods for variable \$methods in method add_methods};
	}
	for my $method ( @{$methods} ) {
		$self->add_method($method);
	}
	return $self;
}

sub add_method {
	my ( $self, $method ) = @_;
	if ( ( ref($method) || "" ) ne "HASH" ) {
		$method = defined $method ? $method : 'undef';
		die
			qq{HashRef: invalid value $method for variable \$method in method add_method};
	}
	if ( ( ! defined $method->{name} || ref($method->{name}) ) ) {
		$method->{name} = defined $method->{name} ? $method->{name} : 'undef';
		die
			qq{Str: invalid value $method->{name} for variable \$method->{name} in method add_method};
	}

	my $name = $method->{name};
	if ( $method->{clearer} ) {
		$self->meta->{ q|clear_| . $name }
			= qq|return delete \$_[0]->{$name};|;
	}
	if ( $method->{predicate} ) {
		$self->meta->{ q|has_| . $name }
			= qq|return exists \$_[0]->{$name};|;
	}
	if ( $method->{get} ) {
		$self->meta->{ q|get_| . $name }
			= qq|return \$_[0]->{$name};|;
	}
	if ( $method->{set} ) {
		my $set = q|my ($self, $val) = @_; |;
		$method->{type} = $self->identify_type($method->{default})
			if ($method->{autotype});
		if ($method->{type}) {
			$self->add_type($method->{type});
			$set .= qq|$method->{type}\->(\$val); |;
		}
		my $merge = $method->{merge} ? '|| $first' : '';
		$set .= qq|
			if (defined \$self->{$name}) {
				my \$recurse;
				\$recurse = sub {
					my (\$first, \$second) = \@_;
					my \$fref = Scalar::Util::reftype(\$first) \|\| "";
					my \$sref = Scalar::Util::reftype(\$second) \|\| "";
					if (\$fref eq 'ARRAY' && \$sref eq 'ARRAY') {
						for (my \$i = 0; \$i < scalar \@{ \$first }; \$i++) {
							my (\$f, \$s) = (\$first->[0], \$second->[0]);
							\$second->[\$i] = \$recurse->(\$first->[\$i], \$second->[\$i]);
						}
					} elsif (\$fref eq 'HASH' && \$sref eq 'HASH') {
						my \@keys = (keys \%{ \$first }, keys \%{ \$second });
						for my \$key ( \@keys ) {
							\$second->{\$key} = \$recurse->(\$first->{\$key}, \$second->{\$key});
						}
						\$second = bless \$second, ref \$first;
					}
					return \$second${merge};
				};
				\$val = \$recurse->(\$self->{$name}, \$val);
			}
		| if ($method->{nested});
		$set .= qq|
			\$self->{$name} = \$val;
			return \$self->{$name};
		|;
		$self->meta->{ q|set_| . $name } = $set;
	}
	if ( $method->{ref} ) {
		$self->meta->{ q|ref_| . $name }
			= qq|return ref \$_[0]->{$name};|;
	}
	if ( $method->{reftype} ) {
		$self->meta->{ q|reftype_| . $name }
			= qq|return Scalar::Util::reftype \$_[0]->{$name};|;
	}
	if ( exists $method->{default} ) {
		$self->default->{ $name } = $method->{default};
	}
	unless ($method->{code}) {
		$method->{code} = qq|return \$_[0]->{$name}|;
	}
	$self->meta->{ $name } = $method->{code};
	return $self;
}

sub build {
	my ($self) = @_;

	$self->meta->{new} = $self->add_new( $self->default );

	my $class = sprintf q|%s::%s|, $self->{object_name}, $UNIQUE++;
	my @methods;
	for my $method ( keys %{ $self->meta } ) {
		push @methods, sprintf q|sub %s { %s }|, $method,
			$self->meta->{$method};
	}
	my $c = sprintf(
		q|
			package %s;
			use Scalar::Util qw//;
			use %s qw/%s/;
			%s
			1;
		|, $class, $self->type_library, join(" ", keys %{$self->types}), join( "\n", @methods) );

	eval $c;
	if ($@) {
		die $@;
	}
	return $class->new;
}

sub stringify_struct {
	my ( $self, $struct ) = @_;
	return 'undefined' unless defined $struct;
	$struct = ref $struct ? aDump($struct) : "'$struct'";
	return $struct;
}

sub add_type {
	my ($self, $value) = @_;
	if ( ! defined $value || ref $value ) {
		$value = defined $value ? $value : 'undef';
		die qq{Str: invalid value $value for method push_type};
	}
	$self->{types}->{$value}++;
}

sub identify_type {
	my ($self, $value) = @_;
	my $type_map = $self->type_map;
	my $ref = ref $value;
	return $type_map->{default}
		if (! defined $value);
	return $type_map->{$ref} ? $type_map->{$ref} : $type_map->{REF}
		if ($ref);
	return $type_map->{NUM} if $value =~ m/\d+\.\d+/;
	return $type_map->{INT} if $value =~ m/\d+/;
	return $type_map->{STRING} if $value =~ m/\w+/;
	return $type_map->{default};
}

sub aDump {
	my $loo = Loo->new([$_[0]]);
	$loo->Terse(1)->Deparse(1)->Colour(0)->Indent(0);
	return $loo->Dump;
}

1;

__END__