1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95
|
use strict;
use warnings;
use Test::More tests => 20;
# This test script is derived from a MooseX::Method::Signatures test,
# which is sensitive to some details of Devel::Declare behaviour that
# ctx-simple.t is not. In particular, the use of a paren immediately
# following the declarator, constructing a parenthesised function call,
# invokes a different parser path.
use Devel::Declare ();
use Devel::Declare::Context::Simple ();
use B::Hooks::EndOfScope qw(on_scope_end);
sub inject_after_scope($) {
my ($inject) = @_;
on_scope_end {
my $line = Devel::Declare::get_linestr();
return unless defined $line;
my $offset = Devel::Declare::get_linestr_offset();
substr($line, $offset, 0) = $inject;
Devel::Declare::set_linestr($line);
};
}
sub mtfnpy_parser(@) {
my $ctx = Devel::Declare::Context::Simple->new(into => __PACKAGE__);
$ctx->init(@_);
$ctx->skip_declarator;
my $name = $ctx->strip_name;
die "No name\n" unless defined $name;
my $proto = $ctx->strip_proto;
die "Wrong declarator\n" unless $ctx->declarator eq "mtfnpy";
$proto =~ s/\n/\\n/g;
$ctx->inject_if_block(qq[BEGIN { @{[__PACKAGE__]}::inject_after_scope(', q[${name}]);') } unshift \@_, "${proto}";], "(sub ");
my $compile_stash = $ctx->get_curstash_name;
$ctx->shadow(sub {
my ($code, $name, @args) = @_;
no strict "refs";
*{"${compile_stash}::${name}"} = $code;
});
}
BEGIN {
Devel::Declare->setup_for(__PACKAGE__, {
mtfnpy => { const => \&mtfnpy_parser },
});
*mtfnpy = sub {};
}
mtfnpy foo (extra) {
is scalar(@_), 4;
is $_[0], "extra";
is $_[1], "a";
is $_[2], "b";
is $_[3], "c";
}
foo(qw(a b c));
mtfnpy bar (ex
tra) {
is scalar(@_), 4;
is $_[0], "ex\ntra";
is $_[1], "a";
is $_[2], "b";
is $_[3], "c";
}
bar(qw(a b c));
mtfnpy baz (ex
tra extra extra) {
is scalar(@_), 4;
is $_[0], "ex\ntra extra extra";
is $_[1], "a";
is $_[2], "b";
is $_[3], "c";
}
baz(qw(a b c));
mtfnpy quux (ex
tra
extra) {
is scalar(@_), 4;
is $_[0], "ex\ntra\nextra";
is $_[1], "a";
is $_[2], "b";
is $_[3], "c";
}
quux(qw(a b c));
1;
|