t/new.t

   1 use strict;
   2 use warnings;
   3 use Devel::Declare ();
   4 use Test::More;
   5
   6 {
   7   package FoomHandlers;
   8
   9   use strict;
  10   use warnings;
  11
  12   our ($Declarator, $Offset);
  13
  14   sub skip_declarator {
  15     $Offset += Devel::Declare::toke_move_past_token($Offset);
  16   }
  17
  18   sub skipspace {
  19     $Offset += Devel::Declare::toke_skipspace($Offset);
  20   }
  21
  22   sub strip_name {
  23     skipspace;
  24     if (my $len = Devel::Declare::toke_scan_word($Offset, 1)) {
  25       my $linestr = Devel::Declare::get_linestr();
  26       my $name = substr($linestr, $Offset, $len);
  27       substr($linestr, $Offset, $len) = '';
  28       Devel::Declare::set_linestr($linestr);
  29       return $name;
  30     }
  31     return;
  32   }
  33
  34   sub strip_proto {
  35     skipspace;
  36
  37     my $linestr = Devel::Declare::get_linestr();
  38     if (substr($linestr, $Offset, 1) eq '(') {
  39       my $length = Devel::Declare::toke_scan_str($Offset);
  40       my $proto = Devel::Declare::get_lex_stuff();
  41       Devel::Declare::clear_lex_stuff();
  42       $linestr = Devel::Declare::get_linestr();
  43       substr($linestr, $Offset, $length) = '';
  44       Devel::Declare::set_linestr($linestr);
  45       return $proto;
  46     }
  47     return;
  48   }
  49
  50   sub shadow {
  51     my $pack = Devel::Declare::get_curstash_name;
  52     Devel::Declare::shadow_sub("${pack}::${Declarator}", $_[0]);
  53   }
  54
  55   sub inject_str {
  56     my $linestr = Devel::Declare::get_linestr;
  57     substr($linestr, $Offset, 0) = $_[0];
  58     Devel::Declare::set_linestr($linestr);
  59   }
  60
  61   sub strip_str {
  62     my $linestr = Devel::Declare::get_linestr;
  63     if (substr($linestr, $Offset, length($_[0])) eq $_[0]) {
  64       substr($linestr, $Offset, length($_[0])) = '';
  65       Devel::Declare::set_linestr($linestr);
  66       return 1;
  67     }
  68     return 0;
  69   }
  70
  71   sub const {
  72     local ($Declarator, $Offset) = @_;
  73     skip_declarator;
  74     my $name = strip_name;
  75     my $str = "happy ".(defined $name ? "foom: ${name}" : "anonymous foom");
  76     if (defined(my $proto = strip_proto)) {
  77       $str .= "; ${proto}";
  78     }
  79     shadow(sub { $str });
  80   }
  81
  82   package Foo;
  83
  84   use strict;
  85   use warnings;
  86
  87   sub foom { }
  88
  89   BEGIN {
  90     Devel::Declare->setup_for(
  91       __PACKAGE__,
  92       { foom => {
  93           const => \&FoomHandlers::const,
  94       } }
  95     );
  96   }
  97
  98   ::is(foom, "happy anonymous foom", "foom");
  99
 100   ::is(foom KABOOM, "happy foom: KABOOM", "foom KABOOM");
 101
 102   ::is(foom (zoom), "happy anonymous foom; zoom", "foom (zoom)");
 103
 104   ::is(foom KABOOM (zoom), "happy foom: KABOOM; zoom", "foom KABOOM (zoom)");
 105 }
 106
 107 done_testing;