File Coverage

blib/lib/Rope/Variant.pm

Criterion	Covered	Total	%
statement	61	80	76.2
branch	20	46	43.4
condition	2	7	28.5
subroutine	10	10	100.0
pod			n/a
total	93	143	65.0

package Rope::Variant;

use strict;
use warnings;
use Combine::Keys qw/combine_keys/;
use Rope::Pro;
my (%PRO);

BEGIN {
	%PRO = Rope::Pro->new(
		find_from_given => sub {
			my ( $self, $set, $given) = @_;
			my $ref_given = ref $given;
			if ( $ref_given eq 'Type::Tiny' ) {
				$set = $given->($set);
				return $given->display_name eq 'Object' ? ref $set : $set;
			}
			elsif ( $ref_given eq 'CODE' ) {
				return $given->( $self, $set );
			}
			return $set;
		},
		struct_the_same => sub {
			my ($stored, $passed) = @_;
			my $stored_ref = ref($stored) || 'STRING';
			my $passed_ref = ref($passed) || 'STRING';
			$stored_ref eq $passed_ref or return undef;
			if ($stored_ref eq 'STRING') {
				return ($stored =~ m/^$passed$/) ? 1 : undef;
			} elsif ($stored_ref eq 'SCALAR') {
				return ($$stored =~ m/^$$passed$/) ? 1 : undef;
			} elsif ($stored_ref eq 'HASH') {
				for (combine_keys($stored, $passed)) {
					$stored->{$_} and $passed->{$_} or return undef;
					$PRO{struct_the_same}($stored->{$_}, $passed->{$_}) or return undef;
				}
				return 1;
			} elsif ($stored_ref eq 'ARRAY') {
				my @count = (scalar @{$stored}, scalar @{$passed});
				$count[0] == $count[1] or return undef;
				for ( 0 .. $count[1] - 1 ) {
					$PRO{struct_the_same}($stored->[$_], $passed->[$_]) or return undef;
				}
				return 1;
			}
			return 1;
		}
	);
}

sub import {
	my ($caller) = (scalar caller);
	$PRO{keyword}($caller, 'variant', sub {
		my ($name, %definition) = @_;

		my ($meta, $variant, $exists) = (Rope->get_meta($caller), [], 0);
		if ($meta->{properties}->{$name}) {
			if ($meta->{properties}->{$name}->{variant}) {
				push @{$meta->{properties}->{$name}->{variant}->{when}}, @{$definition{when}};
				Rope->set_property($caller, $name, $meta->{properties}->{$name});
				$exists = 1;
			} else {
				die "Cannot convert an existing property into a variant property";
			}
		}

		$caller->property($name,
			initable => 1,
			writeable => 1,
			variant => \%definition,
			trigger => sub {
				my ($self, $set) = @_;
				my $meta = Rope->get_meta($caller)->{properties}->{$name};
				my $find = $PRO{find_from_given}(@_, $meta->{variant}->{given});
				my @when = @{$meta->{variant}->{when}};
				while (scalar @when >= 2) {
					my ($check, $found) = (
						shift @when,
						shift @when
					);
					if ( $PRO{struct_the_same}($check, $find) ) {
						if ($found->{alias}) {
							if (ref $set ne 'HASH') {
								for my $alias ( keys %{ $found->{alias} } ) {
									next if $set->can($alias);
									my $actual = $found->{alias}->{$alias};
									{
										no strict 'refs';
										*{"${find}::${alias}"} = sub { goto &{"${find}::${actual}"} };
									}
								}
								return $set;
							} else {
								return {
									map { $set->{$_} = $set->{$found->{alias}->{$_}} } keys %{ $found->{alias} }
								}
							}
						}
						elsif ($found->{run}) {
							my $run = $found->{run};
							return ref $run
								? $run->($self, $set)
								: $self->$run($set);
						}
					}
				}
			}
		) if !$exists;
	});
}

1;

__END__