From: Vincent Pit Date: Fri, 1 Jan 2010 21:11:22 +0000 (+0100) Subject: Add support for the check hook and test multiple keywords X-Git-Tag: v0.01~18 X-Git-Url: http://git.vpit.fr/?p=perl%2Fmodules%2FSub-Op.git;a=commitdiff_plain;h=0661466030b3dd0fb805da10aaed883fbe931093 Add support for the check hook and test multiple keywords --- diff --git a/Op.xs b/Op.xs index 490dc2d..5c9413b 100644 --- a/Op.xs +++ b/Op.xs @@ -107,6 +107,12 @@ void sub_op_register(pTHX_ const sub_op_keyword *k) { PL_custom_op_descs = newHV(); (void) hv_store_ent(PL_custom_op_descs, key, newSVpv(k->name, k->len), 0); + if (k->check) { + SV *check = newSViv(PTR2IV(k->check)); + sv_magicext(key, check, PERL_MAGIC_ext, NULL, k->ud, 0); + SvREFCNT_dec(check); + } + { dMY_CXT; (void) hv_store(MY_CXT.map, k->name, k->len, key, 0); @@ -267,6 +273,14 @@ STATIC OP *sub_op_ck_entersub(pTHX_ OP *o) { last_arg->op_sibling = NULL; op_free(rv2cv); + { + MAGIC *mg = mg_find(pp_sv, PERL_MAGIC_ext); + if (mg) { + sub_op_check_t check = INT2PTR(sub_op_check_t, SvIVX(mg->mg_obj)); + o = CALL_FPTR(check)(aTHX_ o, mg->mg_ptr); + } + } + sub_op_linklist(o); } } diff --git a/lib/Sub/Op.pm b/lib/Sub/Op.pm index dbcdcd2..a7ad9f9 100644 --- a/lib/Sub/Op.pm +++ b/lib/Sub/Op.pm @@ -52,8 +52,9 @@ In your XS file : sub_op_keyword k; k.name = "reftype"; k.len = sizeof("reftype")-1; - k.check = 0; k.pp = scalar_util_reftype; + k.check = 0; + k.ud = NULL; sub_op_register(aTHX_ &k); } diff --git a/sub_op.h b/sub_op.h index 161d147..c7fc83f 100644 --- a/sub_op.h +++ b/sub_op.h @@ -4,11 +4,14 @@ #ifndef SUB_OP_H #define SUB_OP_H 1 +typedef OP *(*sub_op_check_t)(pTHX_ OP *, void *); + typedef struct { - const char *name; - STRLEN len; - Perl_ppaddr_t pp; - void (*check)(pTHX_ OP *); + const char *name; + STRLEN len; + Perl_ppaddr_t pp; + sub_op_check_t check; + void *ud; } sub_op_keyword; void sub_op_register(pTHX_ const sub_op_keyword *k); diff --git a/t/10-base.t b/t/10-base.t index 86042b3..891a8cb 100644 --- a/t/10-base.t +++ b/t/10-base.t @@ -5,49 +5,66 @@ use warnings; use blib 't/Sub-Op-Test'; -use Test::More tests => 2 * 15 + 21; +use Test::More tests => 2 * 15 + 3 * 1 + 2 * 23; our $called; { local $/ = "####\n"; while () { - my ($code, $params) = split /----\s*/, $_; - my ($name, $ret, $exp) = split /\s*#\s*/, $params; + my ($code, $params) = split /----\s*/, $_; + my ($names, $ret, $exp, $seq) = split /\s*#\s*/, $params; + + my @names = split /\s*,\s*/, $names; my @exp = eval $exp; if ($@) { - fail "unable to get expected values: $@"; + fail "@names: unable to get expected values: $@"; next; } my $calls = @exp; - $code = <<" WRAPPER"; - { - use Sub::Op::Test $name => sub { - ++\$called; - my \$exp = shift \@exp; - is_deeply \\\@_, \$exp, '$name: arguments are correct'; - $ret; - }; - { - $code - } - BEGIN { - no warnings 'uninitialized'; # Test::Builder can't get the file name - is *main::${name}{CODE}, undef, '$name: no symbol table vivification'; - } + my @seq; + if ($seq) { + s/^\s*//, s/\s*$// for $seq; + @seq = split /\s*,\s*/, $seq; + die "calls and seq length mismatch" unless @seq == $calls; + } else { + @seq = ($names[0]) x $calls; + } + + my $test = "{\n"; + for my $name (@names) { + $test .= <<" INIT" + use Sub::Op::Test $name => sub { + ++\$called; + my \$exp = shift \@exp; + is_deeply \\\@_, \$exp, '$name: arguments are correct'; + my \$seq = shift \@seq; + is \$seq, '$name', '$name: sequence is correct'; + $ret; + }; + INIT } - WRAPPER + $test .= "{\n$code\n}\n"; + for my $name (@names) { + $test .= <<" CHECK_VIVID" + BEGIN { + no warnings 'uninitialized'; # Test::Builder can't get the file name + is *main::${name}\{CODE\}, undef, '$name: no symbol table vivification'; + } + CHECK_VIVID + } + $test .= "}\n"; local $called = 0; - eval $code; + eval $test; if ($@) { - fail "$name: unable to evaluate test case: $@"; - diag $code; + fail "@names: unable to evaluate test case: $@"; + diag $test; } - is $called, $calls, "$name: the hook was called the right number of times"; + is $called, $calls, "@names: the hook was called the right number of times"; if ($called < $calls) { fail for $called + 1 .. $calls; } @@ -120,3 +137,8 @@ our %hash = (x => 4); hash $hash{x}; ---- hash # () # [ 4 ] +#### +foo 1; +bar 2; +---- +foo, bar # () # [ 1 ], [ 2 ] # foo, bar diff --git a/t/Sub-Op-Test/Test.xs b/t/Sub-Op-Test/Test.xs index 4750507..b317969 100644 --- a/t/Sub-Op-Test/Test.xs +++ b/t/Sub-Op-Test/Test.xs @@ -11,19 +11,38 @@ #include "sub_op.h" -STATIC SV *sub_op_test_cb = NULL; +STATIC HV *sub_op_test_map = NULL; + +STATIC OP *sub_op_test_check(pTHX_ OP *o, void *ud_) { + char buf[sizeof(void*)*2+1]; + SV *cb = ud_; + + (void) hv_store(sub_op_test_map, buf, sprintf(buf, "%"UVxf, PTR2UV(o)), cb, 0); + + return o; +} STATIC OP *sub_op_test_pp(pTHX) { dSP; dMARK; + SV *cb; int i, items; + { + char buf[sizeof(void*)*2+1]; + SV **svp; + svp = hv_fetch(sub_op_test_map, buf, sprintf(buf, "%"UVxf, PTR2UV(PL_op)), 0); + if (!svp) + RETURN; + cb = *svp; + } + ENTER; SAVETMPS; PUSHMARK(MARK); - items = call_sv(sub_op_test_cb, G_ARRAY); + items = call_sv(cb, G_ARRAY); SPAGAIN; for (i = 0; i < items; ++i) @@ -42,27 +61,25 @@ MODULE = Sub::Op::Test PACKAGE = Sub::Op::Test PROTOTYPES: ENABLE +BOOT: +{ + sub_op_test_map = newHV(); +} + void -_init(SV *name) -PROTOTYPE: $ +_init(SV *name, SV *cb) +PROTOTYPE: $$ PREINIT: sub_op_keyword k; -PPCODE: - k.name = SvPV_const(name, k.len); - k.check = 0; - k.pp = sub_op_test_pp; - sub_op_register(aTHX_ &k); - XSRETURN(0); - -void -_callback(SV *cb) -PROTOTYPE: $ PPCODE: if (SvROK(cb)) { cb = SvRV(cb); if (SvTYPE(cb) >= SVt_PVCV) { - SvREFCNT_dec(sub_op_test_cb); - sub_op_test_cb = SvREFCNT_inc(cb); + k.name = SvPV_const(name, k.len); + k.check = sub_op_test_check; + k.ud = SvREFCNT_inc(cb); + k.pp = sub_op_test_pp; + sub_op_register(aTHX_ &k); } } XSRETURN(0); diff --git a/t/Sub-Op-Test/lib/Sub/Op/Test.pm b/t/Sub-Op-Test/lib/Sub/Op/Test.pm index a8bd2bf..ad379a3 100644 --- a/t/Sub-Op-Test/lib/Sub/Op/Test.pm +++ b/t/Sub-Op-Test/lib/Sub/Op/Test.pm @@ -19,8 +19,7 @@ sub import { my ($name, $cb) = @_; - _init($name); - _callback($cb); + _init($name, $cb); Sub::Op::enable($name => scalar caller); }