From d46ca6eacf7d512ac6d20dda977a4a33f9d4717c Mon Sep 17 00:00:00 2001
From: Jesse Luehrs <doy@tozt.net>
Date: Thu, 7 Jul 2011 00:31:03 -0500
Subject: pure perl implementation of the core smartmatch algorithm

---
 lib/smartmatch.pm             |   8 ++-
 lib/smartmatch/engine/core.pm | 142 ++++++++++++++++++++++++++++++++++++++++++
 t/basic.t                     |   5 ++
 3 files changed, 154 insertions(+), 1 deletion(-)
 create mode 100644 lib/smartmatch/engine/core.pm

diff --git a/lib/smartmatch.pm b/lib/smartmatch.pm
index f464d95..fd15e03 100644
--- a/lib/smartmatch.pm
+++ b/lib/smartmatch.pm
@@ -21,7 +21,13 @@ __PACKAGE__->bootstrap(
 sub import {
     my $package = shift;
     my ($cb) = @_;
-    $cb = $cb->can('match') unless ref($cb);
+
+    if (!ref($cb)) {
+        my $engine = "smartmatch::engine::$cb";
+        eval "require $engine; 1"
+            or die "Couldn't load smartmatch engine $engine: $@";
+        $cb = $engine->can('match') unless ref($cb);
+    }
 
     $^H ||= 0x020000; # HINT_LOCALIZE_HH
 
diff --git a/lib/smartmatch/engine/core.pm b/lib/smartmatch/engine/core.pm
new file mode 100644
index 0000000..ad25001
--- /dev/null
+++ b/lib/smartmatch/engine/core.pm
@@ -0,0 +1,142 @@
+package smartmatch::engine::core;
+use strict;
+use warnings;
+
+use B;
+use Scalar::Util qw(blessed looks_like_number reftype);
+use overload ();
+
+sub type {
+    my ($thing) = @_;
+
+    if (!defined($thing)) {
+        return 'undef';
+    }
+    elsif (blessed($thing)) {
+        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_NOK) && !($flags & B::SVf_POK)) {
+            return 'Num';
+        }
+        elsif (looks_like_number($thing)) {
+            return 'numish';
+        }
+        else {
+            return 'unknown';
+        }
+    }
+}
+
+sub match {
+    my ($a, $b) = @_;
+
+    if (type($b) eq 'undef') {
+        return !defined($a);
+    }
+    elsif (type($b) eq 'Object') {
+        my $overload = overload::Method($b, '~~');
+        die "no ~~ overloading on $b"
+            unless $overload;
+        return $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') {
+            return match([keys %$a], [keys %$b]);
+        }
+        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;
+            for my $i (0..$#$a) {
+                return unless match($a->[$i], $b->[$i]);
+            }
+            return 1;
+        }
+        elsif (type($a) eq 'Regex') {
+            return grep /$a/, @$b;
+        }
+        elsif (type($a) eq 'undef') {
+            return grep !defined, @$b;
+        }
+        else {
+            return grep { match($a, $_) } @$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, '~~');
+        die "no ~~ overloading on $a"
+            unless $overload;
+        return $overload->($b, 0);
+    }
+    elsif (type($b) eq 'Num') {
+        return $a == $b;
+    }
+    elsif (type($a) eq 'Num' && type($b) eq 'numish') {
+        return $a == $b;
+    }
+    elsif (type($a) eq 'undef') {
+        return !defined($b);
+    }
+    else {
+        return $a eq $b;
+    }
+}
+
+1;
diff --git a/t/basic.t b/t/basic.t
index 0493862..b7010e2 100644
--- a/t/basic.t
+++ b/t/basic.t
@@ -10,4 +10,9 @@ ok(1 ~~ 1);
 }
 ok(1 ~~ 1);
 
+{
+    use smartmatch 'core';
+    ok(1 ~~ 1);
+}
+
 done_testing;
-- 
cgit v1.2.3