#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;
}
}
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;
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);
{
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);
}
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;
},
);
=item *
+C<const char *proto>
+
+The prototype you want to apply to the subroutine, or C<NULL> if none.
+Allowed to be static.
+
+=item *
+
+C<STRLEN protolen>
+
+C<proto>'s length, in bytes.
+
+=item *
+
C<Perl_ppaddr_t pp>
The pp function that will be called instead of the subroutine.
--- /dev/null
+#!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 (<DATA>) {
+ 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 ]
projects / perl / modules / Sub-Op.git / commitdiff