From: Vincent Pit Date: Tue, 20 Apr 2010 21:26:57 +0000 (+0200) Subject: Add support for prototypes X-Git-Url: http://git.vpit.fr/?p=perl%2Fmodules%2FSub-Op.git;a=commitdiff_plain;h=32384f24279ef75bc0b95279c093cf90d8c47195 Add support for prototypes --- diff --git a/MANIFEST b/MANIFEST index e5142fd..7dfbb96 100644 --- a/MANIFEST +++ b/MANIFEST @@ -11,6 +11,7 @@ sub_op.h samples/try.pl t/10-base.t t/11-existing.t +t/12-prototype.t t/20-deparse.t t/21-monkeypatch.t t/91-pod.t diff --git a/Op.xs b/Op.xs index d6dc30c..16b9f46 100644 --- a/Op.xs +++ b/Op.xs @@ -114,11 +114,13 @@ typedef struct { #include "sub_op.h" void sub_op_init(sub_op_config_t *c) { - c->name = NULL; - c->namelen = 0; - c->pp = 0; - c->check = 0; - c->ud = NULL; + c->name = NULL; + c->namelen = 0; + c->proto = NULL; + c->protolen = 0; + c->pp = 0; + c->check = 0; + c->ud = NULL; return; } @@ -159,6 +161,15 @@ sub_op_config_t *sub_op_dup(pTHX_ const sub_op_config_t *orig) { } dupe->namelen = len; + len = orig->protolen; + if (orig->proto) { + dupe->proto = PerlMemShared_malloc(len + 1); + Copy(orig->proto, dupe->proto, len, char); + ((char *) dupe->proto)[len] = '\0'; + } else { + dupe->proto = NULL; + } + dupe->protolen = len; dupe->pp = orig->pp; dupe->check = orig->check; @@ -425,3 +436,20 @@ PPCODE: XSRETURN_UNDEF; ST(0) = sv_2mortal(newSVuv(CvCONST(sv))); XSRETURN(1); + +SV * +_get_prototype(SV *name) +PROTOTYPE: $ +PREINIT: + HE *he; + const sub_op_config_t *c; +PPCODE: + dMY_CXT; + he = hv_fetch_ent(MY_CXT.map, name, 0, 0); + if (!he) + XSRETURN_UNDEF; + c = INT2PTR(const sub_op_config_t *, SvIVX(HeVAL(he))); + if (!c->proto) + XSRETURN_UNDEF; + ST(0) = sv_2mortal(newSVpvn(c->proto, c->protolen)); + XSRETURN(1); diff --git a/lib/Sub/Op.pm b/lib/Sub/Op.pm index 44b3e9b..a0f25a9 100644 --- a/lib/Sub/Op.pm +++ b/lib/Sub/Op.pm @@ -51,11 +51,13 @@ In your XS file : { sub_op_config_t c; sub_op_init(&c); - c.name = "reftype"; - c.namelen = sizeof("reftype")-1; - c.pp = scalar_util_reftype; - c.check = 0; - c.ud = NULL; + c.name = "reftype"; + c.namelen = sizeof("reftype")-1; + c.proto = "$"; + c.protolen = sizeof("$")-1; + c.pp = scalar_util_reftype; + c.check = 0; + c.ud = NULL; sub_op_register(aTHX_ &c, 0); } @@ -148,10 +150,16 @@ my $sw = Variable::Magic::wizard( CORE::warn(@_) unless $_[0] =~ /^Constant subroutine.*redefined/; } if _constant_sub(do { no strict 'refs'; \&$fqn }); no strict 'refs'; - no warnings 'redefine'; + no warnings qw/prototype redefine/; *$fqn = $placeholder; } + { + my $proto = _get_prototype($name); + no strict 'refs'; + Scalar::Util::set_prototype(\&$fqn, $proto); + } + return; }, ); @@ -222,6 +230,19 @@ C's length, in bytes. =item * +C + +The prototype you want to apply to the subroutine, or C if none. +Allowed to be static. + +=item * + +C + +C's length, in bytes. + +=item * + C The pp function that will be called instead of the subroutine. diff --git a/sub_op.h b/sub_op.h index 34d5571..12db025 100644 --- a/sub_op.h +++ b/sub_op.h @@ -9,6 +9,8 @@ typedef OP *(*sub_op_check_t)(pTHX_ OP *, void *); typedef struct { const char *name; STRLEN namelen; + const char *proto; + STRLEN protolen; Perl_ppaddr_t pp; sub_op_check_t check; void *ud; diff --git a/t/12-prototype.t b/t/12-prototype.t new file mode 100644 index 0000000..d4f1c82 --- /dev/null +++ b/t/12-prototype.t @@ -0,0 +1,162 @@ +#!perl + +use 5.010; + +use strict; +use warnings; + +use blib 't/Sub-Op-LexicalSub'; + +use Test::More tests => 1 * 11 + 3 * 12 + 2 * 18 + 4; + +my @array = (1 .. 4); +my %hash = (a => 'b'); + +our $called; + +{ + local $/ = "####\n"; + while () { + chomp; + s/\s*$//; + + my ($code, $params) = split /----\s*/, $_; + my ($names, $ret, $exp, $seq) = split /\s*#\s*/, $params; + + my @names = split /\s*,\s*/, $names; + my @protos; + for my $i (0 .. $#names) { + my $name = $names[$i]; + if ($name =~ /^\s*([^\s\(]+)\s*(\([^\)]*\))\s*$/) { + $names[$i] = $1; + $protos[$i] = $2; + } + } + + my @exp = eval $exp; + if ($@) { + fail "@names: unable to get expected values: $@"; + next; + } + my $calls = @exp; + + 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 $i (0 .. $#names) { + my $name = $names[$i]; + my $proto = $protos[$i] // ''; + $test .= <<" INIT" + use Sub::Op::LexicalSub $name => sub $proto { + ++\$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 + } + $test .= "{\n$code\n}\n"; + for my $name (@names) { + $test .= <<" CHECK_VIVID" + BEGIN { + no warnings 'uninitialized'; # Test::Builder can't get the file name + ok !exists &main::${name}, '$name: not stubbed'; + ok !defined &main::${name}, '$name: body not defined'; + is *main::${name}\{CODE\}, undef, '$name: empty symbol table entry'; + } + CHECK_VIVID + } + $test .= "}\n"; + + local $called = 0; + eval $test; + if ($@) { + fail "@names: unable to evaluate test case: $@"; + diag $test; + } + + is $called, $calls, "@names: the hook was called the right number of times"; + if ($called < $calls) { + fail, fail for $called + 1 .. $calls; + } + } +} + +{ + eval <<' TEST'; + use Sub::Op::LexicalSub foo => sub (&) { $_[0]->() }; + foo { pass 'block called'; }; + TEST + fail $@ if $@; +} + +{ + eval <<' TEST'; + use Sub::Op::LexicalSub foo => sub (&@) { my $cb = shift; goto &$cb }; + foo { is_deeply \@_, [ ], 'block called without arguments' }; + foo { is_deeply \@_, [ 1 ], 'block called without 1 argument' } 1; + foo { is_deeply \@_, [ 2, 3 ], 'block called without 2 argument' } 2, 3; + TEST + fail $@ if $@; +} + +__DATA__ +foo(); +---- +foo() # () # [ ] +#### +foo; +---- +foo() # () # [ ] +#### +foo(1); +---- +foo($) # () # [ 1 ] +#### +foo 2; +---- +foo($) # () # [ 2 ] +#### +my @stuff = (foo 3, 4); +---- +foo($) # () # [ 3 ] +#### +foo @array; +---- +foo($) # () # [ scalar @array ] +#### +my @stuff = (foo 5, 6); +bar 7, 8; +@stuff = (foo 9, 10); +---- +foo($), bar($$) # () # [ 5 ], [ 7, 8 ], [ 9 ] # foo, bar, foo +#### +foo @array; +---- +foo(\@) # () # [ \@array ] +#### +foo @array; +foo %hash; +---- +foo(\[@%]) # () # [ \@array ], [ \%hash ] +#### +foo @array, 13; +foo %hash, 14; +---- +foo(\[@%]$) # () # [ \@array, 13 ], [ \%hash, 14 ] +#### +foo @array; +foo @array, 15; +foo %hash; +foo %hash, 16; +---- +foo(\[@%];$) # () # [ \@array ], [ \@array, 15 ], [ \%hash ], [ \%hash, 16 ] diff --git a/t/Sub-Op-LexicalSub/LexicalSub.xs b/t/Sub-Op-LexicalSub/LexicalSub.xs index a9b1344..a60fa20 100644 --- a/t/Sub-Op-LexicalSub/LexicalSub.xs +++ b/t/Sub-Op-LexicalSub/LexicalSub.xs @@ -63,10 +63,13 @@ PPCODE: cb = SvRV(cb); if (SvTYPE(cb) >= SVt_PVCV) { sub_op_init(&c); - c.name = SvPV_const(name, c.namelen); - c.check = sols_check; - c.ud = SvREFCNT_inc(cb); - c.pp = sols_pp; + c.name = SvPV_const(name, c.namelen); + if (SvPOK(cb)) { /* Sub is prototyped */ + c.proto = SvPV_const(cb, c.protolen); + } + c.check = sols_check; + c.ud = SvREFCNT_inc(cb); + c.pp = sols_pp; sub_op_register(aTHX_ &c, 0); } }