package smartmatch::engine::core;
BEGIN {
$smartmatch::engine::core::VERSION = '0.02'; # TRIAL
}
use strict;
use warnings;
use 5.010;
# ABSTRACT: default smartmatch implementation from 5.10 - 5.14
use parent 'DynaLoader';
sub dl_load_flags { 0x01 }
if (!$smartmatch::engine::core::USE_PP && $] >= 5.011002) {
__PACKAGE__->bootstrap(
# we need to be careful not to touch $VERSION at compile time,
# otherwise DynaLoader will assume it's set and check against it, which
# will cause fail when being run in the checkout without dzil having
# set the actual $VERSION
exists $smartmatch::engine::core::{VERSION}
? ${ $smartmatch::engine::core::{VERSION} } : (),
);
init(__PACKAGE__->can('match'));
}
use Devel::CallChecker;
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 (re::is_regexp($thing)) {
return 'Regex';
}
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 '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) = @_;
my $type_a = type($a);
my $type_b = type($b);
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 {
no warnings 'uninitialized';
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;
__END__
=pod
=head1 NAME
smartmatch::engine::core - default smartmatch implementation from 5.10 - 5.14
=head1 VERSION
version 0.02
=head1 SYNOPSIS
use smartmatch 'core';
=head1 DESCRIPTION
NOTE: This module is still experimental, and the API may change at any point.
You have been warned!
This module implements the existing smart matching algorithm from perl 5.14, as
a module. It has a pure perl implementation of the algorithm (which can be
requested by setting C<$smartmatch::engine::core::USE_PP> to a true value
before C<use>ing this engine), but by default it uses a C implementation which
should be identical to the algorithm in 5.14 - this module uses some new
compiler hooks to turn calls to the engine's C<match> function into a custom
opcode, which is implemented by a copy of the smart match code from perl 5.14.
=for Pod::Coverage type
match
init
=head1 BUGS
No known bugs.
Please report any bugs through RT: email
C<bug-smartmatch-engine-core at rt.cpan.org>, or browse to
L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=smartmatch-engine-core>.
=head1 SEE ALSO
Please see those modules/websites for more information related to this module.
=over 4
=item *
L<smartmatch>
=item *
L<perlsyn/"Smart matching in detail">
=back
=head1 SUPPORT
You can find this documentation for this module with the perldoc command.
perldoc smartmatch::engine::core
You can also look for information at:
=over 4
=item * AnnoCPAN: Annotated CPAN documentation
L<http://annocpan.org/dist/smartmatch-engine-core>
=item * CPAN Ratings
L<http://cpanratings.perl.org/d/smartmatch-engine-core>
=item * RT: CPAN's request tracker
L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=smartmatch-engine-core>
=item * Search CPAN
L<http://search.cpan.org/dist/smartmatch-engine-core>
=back
=head1 AUTHOR
Jesse Luehrs <doy at tozt dot net>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2011 by Jesse Luehrs.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut