File Coverage

blib/lib/Struct/Match.pm

Criterion	Covered	Total	%
statement	43	43	100.0
branch	22	22	100.0
condition	24	24	100.0
subroutine	9	9	100.0
pod	1	1	100.0
total	99	99	100.0

package Struct::Match;
use 5.006; use strict; use warnings; no warnings qw(void); use utf8; our $VERSION = '1.00';
use Combine::Keys qw/combine_keys/;
use base 'Import::Export';
our %STRUCT;
our %EX = ('match' => ['all'], '%STRUCT' => ['struct', 'all']);

BEGIN {
	%STRUCT = (
		SCALAR => sub {
			$STRUCT{SAME}($_[1], 'SCALAR')
				and do {
					my $s = quotemeta($_[1]);
					$_[0] =~ m†^($s)$†;
				};
		},
		HASH => sub {
			$STRUCT{SAME}($_[1], 'HASH')
				and ! $STRUCT{ADDR}($_[0], $_[1])
					? do {
						exists $_[0]->{$_} && exists $_[1]->{$_} && match($_[0]->{$_}, $_[1]->{$_})
							or return for combine_keys($_[0], $_[1]);
						1;
					}
					: 1;
		},
		ARRAY => sub {
			$STRUCT{SAME}($_[1], 'ARRAY')
				and ! $STRUCT{ADDR}($_[0], $_[1])
					? (((
							grep {
								exists $_[0][$_] && match($_[0][$_], $_[1][$_])
							} 0 .. $#{$_[1]}
						) == @{$_[0]}
					) && $#{$_[0]} == $#{$_[1]})
					: 1;
		},
		ADDR => sub {
			0 + $_[0] == 0 + $_[1];
		}, # thou shall not pass/work if the object has + overloaded
		CHECK => sub {
			my $t = $STRUCT{REFTYPE}($_[0]);
			$STRUCT{SAME}($_[1], $t) && $STRUCT{$t}($_[0], $_[1]);
		},
		REFTYPE => sub {
			eval { $_[0]->[0] }
				? 'ARRAY'
				: eval { $_[0]->{shamed}; 1 }
						? 'HASH'
						: 'ADDR';
		},
		REF => sub {
			my $r = ref($_[0]);
			$r and ((exists $STRUCT{$r} && $r) || 'CHECK') or 'SCALAR';
		},
		SAME => sub {
			my $s = $STRUCT{REF}($_[0]);
			$s eq 'CHECK' && do { $s = $STRUCT{REFTYPE}($_[0]) };
			$s eq $_[1];
		},
		# currently we do not care about CODE|GLOB|REF|LVALUE|FORMAT|IO|VSTRING|Regexp.. other than doing ref address check hushh
	);
}

sub match { my $o = $STRUCT{REF}($_[0]); $STRUCT{$o}($_[0], $_[1]) or $_[2] && $o eq 'CHECK' && 1 or 0; }

__END__