summaryrefslogtreecommitdiffstats
path: root/lib/smartmatch/engine/core.pm
diff options
context:
space:
mode:
Diffstat (limited to 'lib/smartmatch/engine/core.pm')
-rw-r--r--lib/smartmatch/engine/core.pm178
1 files changed, 0 insertions, 178 deletions
diff --git a/lib/smartmatch/engine/core.pm b/lib/smartmatch/engine/core.pm
deleted file mode 100644
index 410c983..0000000
--- a/lib/smartmatch/engine/core.pm
+++ /dev/null
@@ -1,178 +0,0 @@
-package smartmatch::engine::core;
-use strict;
-use warnings;
-use 5.010;
-
-use B;
-use Carp qw(croak);
-use Hash::Util::FieldHash qw(idhash);
-use Scalar::Util qw(blessed looks_like_number reftype);
-use overload ();
-
-sub type {
- my ($thing) = @_;
-
- if (!defined($thing)) {
- return 'undef';
- }
- elsif (blessed($thing) && reftype($thing) ne 'REGEXP') {
- return 'Object';
- }
- elsif (my $reftype = reftype($thing)) {
- if ($reftype eq 'ARRAY') {
- return 'Array';
- }
- elsif ($reftype eq 'HASH') {
- return 'Hash';
- }
- elsif ($reftype eq 'REGEXP') {
- return 'Regex';
- }
- elsif ($reftype eq 'CODE') {
- return 'CodeRef';
- }
- else {
- return 'unknown ref';
- }
- }
- else {
- my $b = B::svref_2object(\$thing);
- my $flags = $b->FLAGS;
- if ($flags & (B::SVf_IOK | B::SVf_NOK)) {
- return 'Num';
- }
- elsif (looks_like_number($thing)) {
- return 'numish';
- }
- else {
- return 'unknown';
- }
- }
-}
-
-sub match {
- my ($a, $b, $seen) = @_;
-
- if (type($b) eq 'undef') {
- return !defined($a);
- }
- elsif (type($b) eq 'Object') {
- my $overload = overload::Method($b, '~~');
-
- # XXX this is buggy behavior and may be changed
- # see http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2011-07/msg00214.html
- if (!$overload && overload::Overloaded($b)) {
- $overload = overload::Method($a, '~~');
- return $a->$overload($b, 0)
- if $overload;
- }
-
- croak("Smart matching a non-overloaded object breaks encapsulation")
- unless $overload;
- return $b->$overload($a, 1);
- }
- elsif (type($b) eq 'CodeRef') {
- if (type($a) eq 'Hash') {
- return !grep { !$b->($_) } keys %$a;
- }
- elsif (type($a) eq 'Array') {
- return !grep { !$b->($_) } @$a;
- }
- else {
- return $b->($a);
- }
- }
- elsif (type($b) eq 'Hash') {
- if (type($a) eq 'Hash') {
- my @a = sort keys %$a;
- my @b = sort keys %$b;
- return unless @a == @b;
- for my $i (0..$#a) {
- return unless $a[$i] eq $b[$i];
- }
- return 1;
- }
- elsif (type($a) eq 'Array') {
- return grep { exists $b->{$_ // ''} } @$a;
- }
- elsif (type($a) eq 'Regex') {
- return grep /$a/, keys %$b;
- }
- elsif (type($a) eq 'undef') {
- return;
- }
- else {
- return exists $b->{$a};
- }
- }
- elsif (type($b) eq 'Array') {
- if (type($a) eq 'Hash') {
- return grep { exists $a->{$_ // ''} } @$b;
- }
- elsif (type($a) eq 'Array') {
- return unless @$a == @$b;
- if (!$seen) {
- $seen = {};
- idhash %$seen;
- }
- for my $i (0..$#$a) {
- if (defined($b->[$i]) && $seen->{$b->[$i]}++) {
- return $a->[$i] == $b->[$i];
- }
- return unless match($a->[$i], $b->[$i], $seen);
- }
- return 1;
- }
- elsif (type($a) eq 'Regex') {
- return grep /$a/, @$b;
- }
- elsif (type($a) eq 'undef') {
- return grep !defined, @$b;
- }
- else {
- if (!$seen) {
- $seen = {};
- idhash %$seen;
- }
- return grep {
- if (defined($_) && $seen->{$_}++) {
- return $a == $_;
- }
- match($a, $_, $seen)
- } @$b;
- }
- }
- elsif (type($b) eq 'Regex') {
- if (type($a) eq 'Hash') {
- return grep /$b/, keys %$a;
- }
- elsif (type($a) eq 'Array') {
- return grep /$b/, @$a;
- }
- else {
- return $a =~ $b;
- }
- }
- elsif (type($a) eq 'Object') {
- my $overload = overload::Method($a, '~~');
- return $a->$overload($b, 0) if $overload;
- }
-
- # XXX perlsyn currently has this undef case after the Num cases, but that's
- # not how it's currently implemented
- if (type($a) eq 'undef') {
- return !defined($b);
- }
- elsif (type($b) eq 'Num') {
- no warnings 'uninitialized', 'numeric'; # ugh
- return $a == $b;
- }
- elsif (type($a) eq 'Num' && type($b) eq 'numish') {
- return $a == $b;
- }
- else {
- return $a eq $b;
- }
-}
-
-1;