t/new.t

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