From 1a0c3c3a02da09abc11bbad291d09a41c1850d1d Mon Sep 17 00:00:00 2001 From: Jesse Luehrs Date: Fri, 8 Jul 2011 03:01:49 -0500 Subject: split this out into its own dist, and implement the custom opcode --- .gitignore | 2 +- Changes | 2 +- core.xs | 44 ++++ dist.ini | 19 +- hook_op_check_smartmatch.h | 9 - inc/MakeMaker.pm | 25 -- lib/smartmatch.pm | 39 --- lib/smartmatch/engine/core.pm | 15 ++ lib/smartmatch/engine/rjbs.pm | 62 ----- smartmatch.xs | 70 ------ stolen_chunk_of_pp_ctl.c | 553 ++++++++++++++++++++++++++++++++++++++++++ t/basic.t | 20 -- t/lexical.t | 69 ------ t/lib/lexical.pl | 8 - t/rjbs.t | 154 ------------ 15 files changed, 618 insertions(+), 473 deletions(-) create mode 100644 core.xs delete mode 100644 hook_op_check_smartmatch.h delete mode 100644 inc/MakeMaker.pm delete mode 100644 lib/smartmatch.pm delete mode 100644 lib/smartmatch/engine/rjbs.pm delete mode 100644 smartmatch.xs create mode 100644 stolen_chunk_of_pp_ctl.c delete mode 100644 t/basic.t delete mode 100644 t/lexical.t delete mode 100644 t/lib/lexical.pl delete mode 100644 t/rjbs.t diff --git a/.gitignore b/.gitignore index bb4f04d..281733a 100644 --- a/.gitignore +++ b/.gitignore @@ -9,4 +9,4 @@ nytprof.out MANIFEST.bak *.sw[po] .build -smartmatch-* +smartmatch-engine-core-* diff --git a/Changes b/Changes index eb268bc..8c88aba 100644 --- a/Changes +++ b/Changes @@ -1,4 +1,4 @@ -Revision history for smartmatch +Revision history for smartmatch::engine::core {{$NEXT}} - Initial release diff --git a/core.xs b/core.xs new file mode 100644 index 0000000..3f12ea2 --- /dev/null +++ b/core.xs @@ -0,0 +1,44 @@ +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +#include "ppport.h" + +#include "stolen_chunk_of_pp_ctl.c" + +STATIC OP* +install_sm_op(pTHX_ OP *o, GV *gv, SV *ud) +{ + OP *list, *left, *right, *new; + + list = cUNOPo->op_first; + left = cLISTOPx(list)->op_first->op_sibling; /* skip over the pushmark */ + right = left->op_sibling; + + cLISTOPx(list)->op_first->op_sibling = right->op_sibling; + left->op_sibling = right->op_sibling = NULL; + op_free(o); + + new = newBINOP(OP_CUSTOM, 0, left, right); + new->op_ppaddr = INT2PTR(Perl_ppaddr_t, Perl_pp_old_smartmatch); + + return new; +} + +MODULE = smartmatch::engine::core PACKAGE = smartmatch::engine::core + +PROTOTYPES: DISABLE + +void +init(match) + SV *match; + PREINIT: + CV *cv; + CODE: + if (!SvROK(match) || SvTYPE(SvRV(match)) != SVt_PVCV) { + croak("not a coderef"); + } + + cv = (CV*)SvRV(match); + + cv_set_call_checker(cv, install_sm_op, (SV*)cv); diff --git a/dist.ini b/dist.ini index 8eecae1..b4b10ee 100644 --- a/dist.ini +++ b/dist.ini @@ -1,21 +1,10 @@ -name = smartmatch +name = smartmatch-engine-core author = Jesse Luehrs license = Perl_5 copyright_holder = Jesse Luehrs -; authordep Dist::Zilla::PluginBundle::DOY -[@Filter] --bundle = @DOY --remove = MakeMaker -dist = smartmatch - -; authordep Dist::Zilla::Plugin::MakeMaker::Awesome -[=inc::MakeMaker] +[@DOY] +dist = smartmatch-engine-core [Prereqs] -B::Hooks::OP::Check = 0.14 -perl = 5.010 - -[Prereqs / ConfigureRequires] -B::Hooks::OP::Check = 0.14 -ExtUtils::Depends = 0 +smartmatch = 0 diff --git a/hook_op_check_smartmatch.h b/hook_op_check_smartmatch.h deleted file mode 100644 index b6ddf19..0000000 --- a/hook_op_check_smartmatch.h +++ /dev/null @@ -1,9 +0,0 @@ -#ifndef __HOOK_OP_CHECK_SMARTMATCH_H__ -#define __HOOK_OP_CHECK_SMARTMATCH_H__ - -#include "perl.h" -#include "hook_op_check.h" - -UV hook_op_check_smartmatch(); - -#endif diff --git a/inc/MakeMaker.pm b/inc/MakeMaker.pm deleted file mode 100644 index a1b5ed6..0000000 --- a/inc/MakeMaker.pm +++ /dev/null @@ -1,25 +0,0 @@ -package inc::MakeMaker; -use Moose; - -extends 'Dist::Zilla::Plugin::MakeMaker::Awesome'; - -override _build_MakeFile_PL_template => sub { - my $self = shift; - - my $tmpl = super; - - my $depends = <<'END'; -%WriteMakefileArgs = ( - %WriteMakefileArgs, - ExtUtils::Depends->new('smartmatch', 'B::Hooks::OP::Check')->get_makefile_vars, -); -END - - $tmpl =~ s/(use ExtUtils.*)/$1\nuse ExtUtils::Depends;/; - $tmpl =~ s/(WriteMakefile\()/$depends\n$1/; - - return $tmpl; -}; - -__PACKAGE__->meta->make_immutable; -1; diff --git a/lib/smartmatch.pm b/lib/smartmatch.pm deleted file mode 100644 index 071e4ea..0000000 --- a/lib/smartmatch.pm +++ /dev/null @@ -1,39 +0,0 @@ -package smartmatch; -use strict; -use warnings; -use 5.010; -# ABSTRACT: pluggable smart matching backends - -use parent 'DynaLoader'; -use B::Hooks::OP::Check; - -sub dl_load_flags { 0x01 } - -__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::{VERSION} - ? ${ $smartmatch::{VERSION} } : (), -); - -sub import { - my $package = shift; - my ($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); - } - - smartmatch::register($cb); -} - -sub unimport { - smartmatch::unregister(); -} - -1; diff --git a/lib/smartmatch/engine/core.pm b/lib/smartmatch/engine/core.pm index 410c983..948152f 100644 --- a/lib/smartmatch/engine/core.pm +++ b/lib/smartmatch/engine/core.pm @@ -2,6 +2,21 @@ package smartmatch::engine::core; use strict; use warnings; use 5.010; +# ABSTRACT: default smartmatch implementation from 5.10 - 5.14 + +use parent 'DynaLoader'; + +sub dl_load_flags { 0x01 } + +__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} } : (), +); +smartmatch::engine::core::init(__PACKAGE__->can('match')); use B; use Carp qw(croak); diff --git a/lib/smartmatch/engine/rjbs.pm b/lib/smartmatch/engine/rjbs.pm deleted file mode 100644 index da40998..0000000 --- a/lib/smartmatch/engine/rjbs.pm +++ /dev/null @@ -1,62 +0,0 @@ -package smartmatch::engine::rjbs; -use strict; -use warnings; - -use overload (); -use Scalar::Util qw(blessed reftype); - -sub type { - my ($thing) = @_; - - if (!defined($thing)) { - return 'undef'; - } - elsif (!ref($thing)) { - return 'unknown non-ref'; - } - elsif (reftype($thing) eq 'REGEXP') { - return 'Regex'; - } - elsif (blessed($thing)) { - if (overload::Method($thing, '~~')) { - return 'Overloaded'; - } - elsif (overload::Method($thing, 'qr')) { - return 'Regex'; - } - else { - return 'unknown object'; - } - } - elsif (reftype($thing) eq 'CODE') { - return 'Code'; - } - else { - return 'unknown'; - } -} - -sub match { - my ($a, $b) = @_; - - if (type($b) eq 'undef') { - return !defined($a); - } - elsif (type($b) eq 'Overloaded') { - my $overload = overload::Method($b, '~~'); - return $b->$overload($a, 1); - } - elsif (type($b) eq 'Regex') { - return $a =~ $b; - } - elsif (type($b) eq 'Code') { - return $b->($a); - } - else { - $a //= 'undef'; - $b //= 'undef'; - die "invalid smart match: $a ~~ $b"; - } -} - -1; diff --git a/smartmatch.xs b/smartmatch.xs deleted file mode 100644 index 36d7c51..0000000 --- a/smartmatch.xs +++ /dev/null @@ -1,70 +0,0 @@ -#include "EXTERN.h" -#include "perl.h" -#include "XSUB.h" - -#include "ppport.h" - -#include "hook_op_check_smartmatch.h" - -STATIC OP* -smartmatch_cb(pTHX_ OP *o, void *user_data) -{ - OP *left, *right, *cb_op, *list, *new; - SV **cb; - - cb = hv_fetchs(GvHV(PL_hintgv), "smartmatch_cb", 0); - if (!cb) { - return o; - } - - left = cBINOPo->op_first; - right = left->op_sibling; - - o->op_flags &= ~OPf_KIDS; - op_free(o); - - cb_op = newCVREF(0, newSVOP(OP_CONST, 0, newSVsv(*cb))); - list = newLISTOP(OP_LIST, 0, left, right); - new = newUNOP(OP_ENTERSUB, OPf_STACKED, - op_append_elem(OP_LIST, list, cb_op)); - - return new; -} - -UV -hook_op_check_smartmatch() -{ - return hook_op_check(OP_SMARTMATCH, smartmatch_cb, NULL); -} - -MODULE = smartmatch PACKAGE = smartmatch - -PROTOTYPES: DISABLE - -BOOT: - hook_op_check_smartmatch(); - -void -register (cb) - SV *cb; - CODE: - if (!SvROK(cb) || SvTYPE(SvRV(cb)) != SVt_PVCV) { - croak("not a coderef"); - } - - PL_hints |= HINT_LOCALIZE_HH; - gv_HVadd(PL_hintgv); - - SvREFCNT_inc(cb); - if (!hv_stores(GvHV(PL_hintgv), "smartmatch_cb", cb)) { - SvREFCNT_dec(cb); - croak("couldn't store the callback"); - } - -void -unregister () - CODE: - PL_hints |= HINT_LOCALIZE_HH; - gv_HVadd(PL_hintgv); - - hv_delete(GvHV(PL_hintgv), "smartmatch_cb", 13, G_DISCARD); diff --git a/stolen_chunk_of_pp_ctl.c b/stolen_chunk_of_pp_ctl.c new file mode 100644 index 0000000..c9becd7 --- /dev/null +++ b/stolen_chunk_of_pp_ctl.c @@ -0,0 +1,553 @@ +/* embed.h */ + +#define destroy_matcher(a) S_destroy_matcher(aTHX_ a) +#define do_smartmatch(a,b) S_do_smartmatch(aTHX_ a,b) +#define make_matcher(a) S_make_matcher(aTHX_ a) +#define matcher_matches_sv(a,b) S_matcher_matches_sv(aTHX_ a,b) + +/* proto.h */ + +STATIC void S_destroy_matcher(pTHX_ PMOP* matcher) + __attribute__nonnull__(pTHX_1); +#define PERL_ARGS_ASSERT_DESTROY_MATCHER \ + assert(matcher) + +STATIC OP* S_do_smartmatch(pTHX_ HV* seen_this, HV* seen_other); + +STATIC PMOP* S_make_matcher(pTHX_ REGEXP* re) + __attribute__warn_unused_result__ + __attribute__nonnull__(pTHX_1); +#define PERL_ARGS_ASSERT_MAKE_MATCHER \ + assert(re) + +STATIC bool S_matcher_matches_sv(pTHX_ PMOP* matcher, SV* sv) + __attribute__warn_unused_result__ + __attribute__nonnull__(pTHX_1) + __attribute__nonnull__(pTHX_2); +#define PERL_ARGS_ASSERT_MATCHER_MATCHES_SV \ + assert(matcher); assert(sv) + +/* pp_ctl.c */ + +STATIC PMOP * +S_make_matcher(pTHX_ REGEXP *re) +{ + dVAR; + PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED); + + PERL_ARGS_ASSERT_MAKE_MATCHER; + + PM_SETRE(matcher, ReREFCNT_inc(re)); + + SAVEFREEOP((OP *) matcher); + ENTER_with_name("matcher"); SAVETMPS; + SAVEOP(); + return matcher; +} + +STATIC bool +S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv) +{ + dVAR; + dSP; + + PERL_ARGS_ASSERT_MATCHER_MATCHES_SV; + + PL_op = (OP *) matcher; + XPUSHs(sv); + PUTBACK; + (void) Perl_pp_match(aTHX); + SPAGAIN; + return (SvTRUEx(POPs)); +} + +STATIC void +S_destroy_matcher(pTHX_ PMOP *matcher) +{ + dVAR; + + PERL_ARGS_ASSERT_DESTROY_MATCHER; + PERL_UNUSED_ARG(matcher); + + FREETMPS; + LEAVE_with_name("matcher"); +} + +PP(pp_old_smartmatch) +{ + DEBUG_M(Perl_deb(aTHX_ "Starting smart match resolution\n")); + return do_smartmatch(NULL, NULL); +} + +STATIC OP * +S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) +{ + dVAR; + dSP; + + bool object_on_left = FALSE; + SV *e = TOPs; /* e is for 'expression' */ + SV *d = TOPm1s; /* d is for 'default', as in PL_defgv */ + + /* Take care only to invoke mg_get() once for each argument. + * Currently we do this by copying the SV if it's magical. */ + if (d) { + if (SvGMAGICAL(d)) + d = sv_mortalcopy(d); + } + else + d = &PL_sv_undef; + + assert(e); + if (SvGMAGICAL(e)) + e = sv_mortalcopy(e); + + /* First of all, handle overload magic of the rightmost argument */ + if (SvAMAGIC(e)) { + SV * tmpsv; + DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n")); + DEBUG_M(Perl_deb(aTHX_ " attempting overload\n")); + + tmpsv = amagic_call(d, e, smart_amg, 0); + if (tmpsv) { + SPAGAIN; + (void)POPs; + SETs(tmpsv); + RETURN; + } + DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; continuing...\n")); + } + + SP -= 2; /* Pop the values */ + + + /* ~~ undef */ + if (!SvOK(e)) { + DEBUG_M(Perl_deb(aTHX_ " applying rule Any-undef\n")); + if (SvOK(d)) + RETPUSHNO; + else + RETPUSHYES; + } + + if (sv_isobject(e) && (SvTYPE(SvRV(e)) != SVt_REGEXP)) { + DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n")); + Perl_croak(aTHX_ "Smart matching a non-overloaded object breaks encapsulation"); + } + if (sv_isobject(d) && (SvTYPE(SvRV(d)) != SVt_REGEXP)) + object_on_left = TRUE; + + /* ~~ sub */ + if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVCV) { + I32 c; + if (object_on_left) { + goto sm_any_sub; /* Treat objects like scalars */ + } + else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) { + /* Test sub truth for each key */ + HE *he; + bool andedresults = TRUE; + HV *hv = (HV*) SvRV(d); + I32 numkeys = hv_iterinit(hv); + DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-CodeRef\n")); + if (numkeys == 0) + RETPUSHYES; + while ( (he = hv_iternext(hv)) ) { + DEBUG_M(Perl_deb(aTHX_ " testing hash key...\n")); + ENTER_with_name("smartmatch_hash_key_test"); + SAVETMPS; + PUSHMARK(SP); + PUSHs(hv_iterkeysv(he)); + PUTBACK; + c = call_sv(e, G_SCALAR); + SPAGAIN; + if (c == 0) + andedresults = FALSE; + else + andedresults = SvTRUEx(POPs) && andedresults; + FREETMPS; + LEAVE_with_name("smartmatch_hash_key_test"); + } + if (andedresults) + RETPUSHYES; + else + RETPUSHNO; + } + else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) { + /* Test sub truth for each element */ + I32 i; + bool andedresults = TRUE; + AV *av = (AV*) SvRV(d); + const I32 len = av_len(av); + DEBUG_M(Perl_deb(aTHX_ " applying rule Array-CodeRef\n")); + if (len == -1) + RETPUSHYES; + for (i = 0; i <= len; ++i) { + SV * const * const svp = av_fetch(av, i, FALSE); + DEBUG_M(Perl_deb(aTHX_ " testing array element...\n")); + ENTER_with_name("smartmatch_array_elem_test"); + SAVETMPS; + PUSHMARK(SP); + if (svp) + PUSHs(*svp); + PUTBACK; + c = call_sv(e, G_SCALAR); + SPAGAIN; + if (c == 0) + andedresults = FALSE; + else + andedresults = SvTRUEx(POPs) && andedresults; + FREETMPS; + LEAVE_with_name("smartmatch_array_elem_test"); + } + if (andedresults) + RETPUSHYES; + else + RETPUSHNO; + } + else { + sm_any_sub: + DEBUG_M(Perl_deb(aTHX_ " applying rule Any-CodeRef\n")); + ENTER_with_name("smartmatch_coderef"); + SAVETMPS; + PUSHMARK(SP); + PUSHs(d); + PUTBACK; + c = call_sv(e, G_SCALAR); + SPAGAIN; + if (c == 0) + PUSHs(&PL_sv_no); + else if (SvTEMP(TOPs)) + SvREFCNT_inc_void(TOPs); + FREETMPS; + LEAVE_with_name("smartmatch_coderef"); + RETURN; + } + } + /* ~~ %hash */ + else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVHV) { + if (object_on_left) { + goto sm_any_hash; /* Treat objects like scalars */ + } + else if (!SvOK(d)) { + DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash ($a undef)\n")); + RETPUSHNO; + } + else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) { + /* Check that the key-sets are identical */ + HE *he; + HV *other_hv = MUTABLE_HV(SvRV(d)); + bool tied = FALSE; + bool other_tied = FALSE; + U32 this_key_count = 0, + other_key_count = 0; + HV *hv = MUTABLE_HV(SvRV(e)); + + DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Hash\n")); + /* Tied hashes don't know how many keys they have. */ + if (SvTIED_mg((SV*)hv, PERL_MAGIC_tied)) { + tied = TRUE; + } + else if (SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied)) { + HV * const temp = other_hv; + other_hv = hv; + hv = temp; + tied = TRUE; + } + if (SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied)) + other_tied = TRUE; + + if (!tied && HvUSEDKEYS((const HV *) hv) != HvUSEDKEYS(other_hv)) + RETPUSHNO; + + /* The hashes have the same number of keys, so it suffices + to check that one is a subset of the other. */ + (void) hv_iterinit(hv); + while ( (he = hv_iternext(hv)) ) { + SV *key = hv_iterkeysv(he); + + DEBUG_M(Perl_deb(aTHX_ " comparing hash key...\n")); + ++ this_key_count; + + if(!hv_exists_ent(other_hv, key, 0)) { + (void) hv_iterinit(hv); /* reset iterator */ + RETPUSHNO; + } + } + + if (other_tied) { + (void) hv_iterinit(other_hv); + while ( hv_iternext(other_hv) ) + ++other_key_count; + } + else + other_key_count = HvUSEDKEYS(other_hv); + + if (this_key_count != other_key_count) + RETPUSHNO; + else + RETPUSHYES; + } + else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) { + AV * const other_av = MUTABLE_AV(SvRV(d)); + const I32 other_len = av_len(other_av) + 1; + I32 i; + HV *hv = MUTABLE_HV(SvRV(e)); + + DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Hash\n")); + for (i = 0; i < other_len; ++i) { + SV ** const svp = av_fetch(other_av, i, FALSE); + DEBUG_M(Perl_deb(aTHX_ " checking for key existence...\n")); + if (svp) { /* ??? When can this not happen? */ + if (hv_exists_ent(hv, *svp, 0)) + RETPUSHYES; + } + } + RETPUSHNO; + } + else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) { + DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Hash\n")); + sm_regex_hash: + { + PMOP * const matcher = make_matcher((REGEXP*) SvRV(d)); + HE *he; + HV *hv = MUTABLE_HV(SvRV(e)); + + (void) hv_iterinit(hv); + while ( (he = hv_iternext(hv)) ) { + DEBUG_M(Perl_deb(aTHX_ " testing key against pattern...\n")); + if (matcher_matches_sv(matcher, hv_iterkeysv(he))) { + (void) hv_iterinit(hv); + destroy_matcher(matcher); + RETPUSHYES; + } + } + destroy_matcher(matcher); + RETPUSHNO; + } + } + else { + sm_any_hash: + DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash\n")); + if (hv_exists_ent(MUTABLE_HV(SvRV(e)), d, 0)) + RETPUSHYES; + else + RETPUSHNO; + } + } + /* ~~ @array */ + else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVAV) { + if (object_on_left) { + goto sm_any_array; /* Treat objects like scalars */ + } + else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) { + AV * const other_av = MUTABLE_AV(SvRV(e)); + const I32 other_len = av_len(other_av) + 1; + I32 i; + + DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Array\n")); + for (i = 0; i < other_len; ++i) { + SV ** const svp = av_fetch(other_av, i, FALSE); + + DEBUG_M(Perl_deb(aTHX_ " testing for key existence...\n")); + if (svp) { /* ??? When can this not happen? */ + if (hv_exists_ent(MUTABLE_HV(SvRV(d)), *svp, 0)) + RETPUSHYES; + } + } + RETPUSHNO; + } + if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) { + AV *other_av = MUTABLE_AV(SvRV(d)); + DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Array\n")); + if (av_len(MUTABLE_AV(SvRV(e))) != av_len(other_av)) + RETPUSHNO; + else { + I32 i; + const I32 other_len = av_len(other_av); + + if (NULL == seen_this) { + seen_this = newHV(); + (void) sv_2mortal(MUTABLE_SV(seen_this)); + } + if (NULL == seen_other) { + seen_other = newHV(); + (void) sv_2mortal(MUTABLE_SV(seen_other)); + } + for(i = 0; i <= other_len; ++i) { + SV * const * const this_elem = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE); + SV * const * const other_elem = av_fetch(other_av, i, FALSE); + + if (!this_elem || !other_elem) { + if ((this_elem && SvOK(*this_elem)) + || (other_elem && SvOK(*other_elem))) + RETPUSHNO; + } + else if (hv_exists_ent(seen_this, + sv_2mortal(newSViv(PTR2IV(*this_elem))), 0) || + hv_exists_ent(seen_other, + sv_2mortal(newSViv(PTR2IV(*other_elem))), 0)) + { + if (*this_elem != *other_elem) + RETPUSHNO; + } + else { + (void)hv_store_ent(seen_this, + sv_2mortal(newSViv(PTR2IV(*this_elem))), + &PL_sv_undef, 0); + (void)hv_store_ent(seen_other, + sv_2mortal(newSViv(PTR2IV(*other_elem))), + &PL_sv_undef, 0); + PUSHs(*other_elem); + PUSHs(*this_elem); + + PUTBACK; + DEBUG_M(Perl_deb(aTHX_ " recursively comparing array element...\n")); + (void) do_smartmatch(seen_this, seen_other); + SPAGAIN; + DEBUG_M(Perl_deb(aTHX_ " recursion finished\n")); + + if (!SvTRUEx(POPs)) + RETPUSHNO; + } + } + RETPUSHYES; + } + } + else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) { + DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Array\n")); + sm_regex_array: + { + PMOP * const matcher = make_matcher((REGEXP*) SvRV(d)); + const I32 this_len = av_len(MUTABLE_AV(SvRV(e))); + I32 i; + + for(i = 0; i <= this_len; ++i) { + SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE); + DEBUG_M(Perl_deb(aTHX_ " testing element against pattern...\n")); + if (svp && matcher_matches_sv(matcher, *svp)) { + destroy_matcher(matcher); + RETPUSHYES; + } + } + destroy_matcher(matcher); + RETPUSHNO; + } + } + else if (!SvOK(d)) { + /* undef ~~ array */ + const I32 this_len = av_len(MUTABLE_AV(SvRV(e))); + I32 i; + + DEBUG_M(Perl_deb(aTHX_ " applying rule Undef-Array\n")); + for (i = 0; i <= this_len; ++i) { + SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE); + DEBUG_M(Perl_deb(aTHX_ " testing for undef element...\n")); + if (!svp || !SvOK(*svp)) + RETPUSHYES; + } + RETPUSHNO; + } + else { + sm_any_array: + { + I32 i; + const I32 this_len = av_len(MUTABLE_AV(SvRV(e))); + + DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Array\n")); + for (i = 0; i <= this_len; ++i) { + SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE); + if (!svp) + continue; + + PUSHs(d); + PUSHs(*svp); + PUTBACK; + /* infinite recursion isn't supposed to happen here */ + DEBUG_M(Perl_deb(aTHX_ " recursively testing array element...\n")); + (void) do_smartmatch(NULL, NULL); + SPAGAIN; + DEBUG_M(Perl_deb(aTHX_ " recursion finished\n")); + if (SvTRUEx(POPs)) + RETPUSHYES; + } + RETPUSHNO; + } + } + } + /* ~~ qr// */ + else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_REGEXP) { + if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) { + SV *t = d; d = e; e = t; + DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Regex\n")); + goto sm_regex_hash; + } + else if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) { + SV *t = d; d = e; e = t; + DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Regex\n")); + goto sm_regex_array; + } + else { + PMOP * const matcher = make_matcher((REGEXP*) SvRV(e)); + + DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Regex\n")); + PUTBACK; + PUSHs(matcher_matches_sv(matcher, d) + ? &PL_sv_yes + : &PL_sv_no); + destroy_matcher(matcher); + RETURN; + } + } + /* ~~ scalar */ + /* See if there is overload magic on left */ + else if (object_on_left && SvAMAGIC(d)) { + SV *tmpsv; + DEBUG_M(Perl_deb(aTHX_ " applying rule Object-Any\n")); + DEBUG_M(Perl_deb(aTHX_ " attempting overload\n")); + PUSHs(d); PUSHs(e); + PUTBACK; + tmpsv = amagic_call(d, e, smart_amg, AMGf_noright); + if (tmpsv) { + SPAGAIN; + (void)POPs; + SETs(tmpsv); + RETURN; + } + SP -= 2; + DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; falling back...\n")); + goto sm_any_scalar; + } + else if (!SvOK(d)) { + /* undef ~~ scalar ; we already know that the scalar is SvOK */ + DEBUG_M(Perl_deb(aTHX_ " applying rule undef-Any\n")); + RETPUSHNO; + } + else + sm_any_scalar: + if (SvNIOK(e) || (SvPOK(e) && looks_like_number(e) && SvNIOK(d))) { + DEBUG_M(if (SvNIOK(e)) + Perl_deb(aTHX_ " applying rule Any-Num\n"); + else + Perl_deb(aTHX_ " applying rule Num-numish\n"); + ); + /* numeric comparison */ + PUSHs(d); PUSHs(e); + PUTBACK; + if (CopHINTS_get(PL_curcop) & HINT_INTEGER) + (void) Perl_pp_i_eq(aTHX); + else + (void) Perl_pp_eq(aTHX); + SPAGAIN; + if (SvTRUEx(POPs)) + RETPUSHYES; + else + RETPUSHNO; + } + + /* As a last resort, use string comparison */ + DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Any\n")); + PUSHs(d); PUSHs(e); + PUTBACK; + return Perl_pp_seq(aTHX); +} diff --git a/t/basic.t b/t/basic.t deleted file mode 100644 index 1de7d8f..0000000 --- a/t/basic.t +++ /dev/null @@ -1,20 +0,0 @@ -#!/usr/bin/env perl -use strict; -use warnings; -use Test::More; - -ok(1 ~~ 1); -{ - use smartmatch sub { 0 }; - ok(!(1 ~~ 1)); - ok(!(1 ~~ 2)); -} -ok(1 ~~ 1); - -{ - use smartmatch 'core'; - ok(1 ~~ 1); - ok(!(1 ~~ 2)); -} - -done_testing; diff --git a/t/lexical.t b/t/lexical.t deleted file mode 100644 index 036fe8a..0000000 --- a/t/lexical.t +++ /dev/null @@ -1,69 +0,0 @@ -#!/usr/bin/env perl -use strict; -use warnings; -use Test::More; - -{ - ok(1 ~~ 1); - ok(!(1 ~~ 0)); - { - ok(1 ~~ 1); - ok(!(1 ~~ 0)); - use smartmatch sub { 0 }; - ok(!(1 ~~ 1)); - ok(!(1 ~~ 0)); - { - ok(!(1 ~~ 1)); - ok(!(1 ~~ 0)); - use smartmatch sub { 1 }; - ok(1 ~~ 1); - ok(1 ~~ 0); - use smartmatch sub { 0 }; - ok(!(1 ~~ 1)); - ok(!(1 ~~ 0)); - use smartmatch sub { 1 }; - ok(1 ~~ 1); - ok(1 ~~ 0); - } - ok(!(1 ~~ 1)); - ok(!(1 ~~ 0)); - } - ok(1 ~~ 1); - ok(!(1 ~~ 0)); -} - -{ - ok(eval "1 ~~ 1"); - ok(!eval "1 ~~ 0"); - { - ok(eval "1 ~~ 1"); - ok(!eval "1 ~~ 0"); - use smartmatch sub { 0 }; - ok(!eval "1 ~~ 1"); - ok(!eval "1 ~~ 0"); - { - ok(!eval "1 ~~ 1"); - ok(!eval "1 ~~ 0"); - use smartmatch sub { 1 }; - ok(eval "1 ~~ 1"); - ok(eval "1 ~~ 0"); - use smartmatch sub { 0 }; - ok(!eval "1 ~~ 1"); - ok(!eval "1 ~~ 0"); - use smartmatch sub { 1 }; - ok(eval "1 ~~ 1"); - ok(eval "1 ~~ 0"); - } - ok(!eval "1 ~~ 1"); - ok(!eval "1 ~~ 0"); - } - ok(eval "1 ~~ 1"); - ok(!eval "1 ~~ 0"); -} - -{ - use smartmatch sub { 0 }; - require 't/lib/lexical.pl'; -} - -done_testing; diff --git a/t/lib/lexical.pl b/t/lib/lexical.pl deleted file mode 100644 index d004c3f..0000000 --- a/t/lib/lexical.pl +++ /dev/null @@ -1,8 +0,0 @@ -#!/usr/bin/env perl -use strict; -use warnings; - -Test::More::ok(1 ~~ 1); -Test::More::ok(!(1 ~~ 0)); - -1; diff --git a/t/rjbs.t b/t/rjbs.t deleted file mode 100644 index b94e893..0000000 --- a/t/rjbs.t +++ /dev/null @@ -1,154 +0,0 @@ -#!/usr/bin/env perl -use strict; -use warnings; -use Test::More; - -use smartmatch 'rjbs'; - -{ - package SmartOverload; - use overload '~~' => sub { - no warnings 'uninitialized'; - return $_[1] eq ${ $_[0] }; - }, fallback => 1; -} - -{ - package RegexOverload; - use overload 'qr' => sub { - return $_[0]->[0]; - }, fallback => 1; -} - -{ - package StringOverload; - use overload '""' => sub { - return $_[0]->{val}; - }, fallback => 1; -} - -sub smart { my $val = shift; bless \$val, SmartOverload:: } -sub regex { my $val = shift; bless [qr/$val/], RegexOverload:: } -sub string { my $val = shift; bless { val => $val }, StringOverload:: } - -my @tests = ( - # undef - [ 1, undef, undef ], - [ 0, '', undef ], - [ 0, 0, undef ], - [ 0, '0', undef ], - [ 0, '0.0', undef ], - [ 0, '0 but true', undef ], - [ 0, 1, undef ], - [ 0, 'x', undef ], - [ 0, [], undef ], - [ 0, {}, undef ], - [ 0, sub {}, undef ], - [ 0, smart(''), undef ], - [ 0, regex(''), undef ], - [ 0, string(''), undef ], - # smart match overload - [ 1, "smart", smart('smart') ], - [ 1, string('smart'), smart('smart') ], - [ 0, "SMART", smart('smart') ], - [ 0, string('SMART'), smart('smart') ], - [ 0, smart('smart'), smart('smart') ], - [ 0, undef, smart('smart') ], - [ 0, 1, smart('smart') ], - # regex - [ 0, undef, qr/a/ ], - [ 1, undef, qr/a?/ ], - [ 1, "foo", qr/f/ ], - [ 0, "foo", qr/g/ ], - [ 1, 1, qr/1/ ], - [ 0, ['z'], qr/z/ ], - [ 1, ['z'], qr/^ARRAY/ ], - [ 0, {'y' => 'y'}, qr/y/ ], - [ 1, {'y' => 'y'}, qr/^HASH/ ], - [ 1, string('foo'), qr/^foo$/ ], - [ 0, regex('foo'), qr/foo/ ], - [ 1, regex('foo'), qr/^Regex/ ], - [ 1, qr/foo/, qr/\(\?\^\:foo\)/ ], - # regex overload - [ 0, undef, regex('a') ], - [ 1, undef, regex('a?') ], - [ 1, "foo", regex('f') ], - [ 0, "foo", regex('g') ], - [ 1, 1, regex('1') ], - [ 0, ['z'], regex('z') ], - [ 1, ['z'], regex('^ARRAY') ], - [ 0, {'y' => 'y'}, regex('y') ], - [ 1, {'y' => 'y'}, regex('^HASH') ], - [ 1, string('foo'), regex('^foo$') ], - [ 0, regex('foo'), regex('foo') ], - [ 1, regex('foo'), regex('^Regex') ], - [ 1, qr/foo/, regex('\(\?\^\:foo\)') ], - # code - [ 1, undef, sub { 1 } ], - [ 1, '', sub { 1 } ], - [ 1, 0, sub { 1 } ], - [ 1, '0', sub { 1 } ], - [ 1, '0.0', sub { 1 } ], - [ 1, '0 but true', sub { 1 } ], - [ 1, 1, sub { 1 } ], - [ 1, 'x', sub { 1 } ], - [ 1, [], sub { 1 } ], - [ 1, {}, sub { 1 } ], - [ 1, sub {}, sub { 1 } ], - [ 1, smart(''), sub { 1 } ], - [ 1, regex(''), sub { 1 } ], - [ 1, string(''), sub { 1 } ], - [ 0, undef, sub { 0 } ], - [ 0, '', sub { 0 } ], - [ 0, 0, sub { 0 } ], - [ 0, '0', sub { 0 } ], - [ 0, '0.0', sub { 0 } ], - [ 0, '0 but true', sub { 0 } ], - [ 0, 1, sub { 0 } ], - [ 0, 'x', sub { 0 } ], - [ 0, [], sub { 0 } ], - [ 0, {}, sub { 0 } ], - [ 0, sub {}, sub { 0 } ], - [ 0, smart(''), sub { 0 } ], - [ 0, regex(''), sub { 0 } ], - [ 0, string(''), sub { 0 } ], - [ 1, ['a', 'b'], sub { ref $_[0] eq 'ARRAY' } ], - [ 1, ['a', 'b'], sub { $_[0]->[0] eq 'a' } ], - [ 1, string('x'), sub { $_[0] eq 'x' } ], - [ 1, smart('x'), sub { 'x' ~~ $_[0] } ], - [ 0, smart('x'), sub { 'y' ~~ $_[0] } ], - # any - [ 'die', undef, '' ], - [ 'die', undef, 0 ], - [ 'die', undef, '0' ], - [ 'die', undef, '0.0' ], - [ 'die', undef, '0 but true' ], - [ 'die', undef, 1 ], - [ 'die', undef, 'x' ], - [ 'die', undef, [] ], - [ 'die', undef, {} ], - [ 0, undef, sub {} ], - [ 1, undef, smart('') ], - [ 1, undef, regex('') ], - [ 'die', undef, string('') ], -); - -for my $test (@tests) { - # shut up warnings about undef =~ regex - $SIG{__WARN__} = sub { } unless defined $test->[1]; - - if ($test->[0] eq 'die') { - ok(!eval { $test->[1] ~~ $test->[2]; 1 }); - like($@, qr/invalid smart match/); - } - elsif ($test->[0]) { - ok($test->[1] ~~ $test->[2]); - } - else { - ok(!($test->[1] ~~ $test->[2])); - } - - delete $SIG{__WARN__}; -} - -done_testing; -- cgit v1.2.3