t/ctx-simple-like-mxms.t

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