t/method.t

   1 use Devel::Declare ();
   2 use Scope::Guard;
   3
   4 {
   5   package MethodHandlers;
   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 parser {
  70     my $pack = shift;
  71     local ($Declarator, $Offset) = @_;
  72     skip_declarator;
  73     skipspace;
  74     my $name = strip_name;
  75     skipspace if defined($name);
  76     my $proto = strip_proto;
  77     skipspace if defined($proto);
  78     my $linestr = Devel::Declare::get_linestr;
  79     if (substr($linestr, $Offset, 1) eq '{') {
  80       my $inject = 'my ($self';
  81       if (defined $proto) {
  82         $inject .= ", $proto" if length($proto);
  83         $inject .= ') = @_; ';
  84       } else {
  85         $inject .= ') = shift;';
  86       }
  87       if (defined $name) {
  88         $inject = ' BEGIN { MethodHandlers::inject_scope }; '.$inject;
  89       }
  90       substr($linestr, $Offset+1, 0) = $inject;
  91       Devel::Declare::set_linestr($linestr);
  92     }
  93     if (defined $name) {
  94       $name = join('::', $pack, $name) unless ($name =~ /::/);
  95       shadow(sub (&) { no strict 'refs'; *{$name} = shift; });
  96     } else {
  97       shadow(sub (&) { shift });
  98     }
  99   }
 100
 101   sub inject_scope {
 102     $^H |= 0x120000;
 103     $^H{DD_METHODHANDLERS} = Scope::Guard->new(sub {
 104       my $linestr = Devel::Declare::get_linestr;
 105       my $offset = Devel::Declare::get_linestr_offset;
 106       substr($linestr, $offset, 0) = ';';
 107       Devel::Declare::set_linestr($linestr);
 108     });
 109   }
 110 }
 111
 112 my ($test_method1, $test_method2, @test_list);
 113
 114 {
 115   package DeclareTest;
 116
 117   sub method (&);
 118
 119   BEGIN {
 120     Devel::Declare->setup_for(
 121       __PACKAGE__,
 122       { method => { const => sub { MethodHandlers::parser(__PACKAGE__, @_) } } }
 123     );
 124   }
 125
 126   method new {
 127     my $class = ref $self || $self;
 128     return bless({ @_ }, $class);
 129   }
 130
 131   method foo ($foo) {
 132     return (ref $self).': Foo: '.$foo;
 133   }
 134
 135   method upgrade(){ # no spaces to make case pathological
 136     bless($self, 'DeclareTest2');
 137   }
 138
 139   method DeclareTest2::bar () {
 140     return 'DeclareTest2: bar';
 141   }
 142
 143   $test_method1 = method {
 144     return join(', ', $self->{attr}, $_[1]);
 145   };
 146
 147   $test_method2 = method ($what) {
 148     return join(', ', ref $self, $what);
 149   };
 150
 151   method main () { return "main"; }
 152
 153   @test_list = (method { 1 }, sub { 2 }, method () { 3 }, sub { 4 });
 154
 155 }
 156
 157 use Test::More 'no_plan';
 158
 159 my $o = DeclareTest->new(attr => "value");
 160
 161 isa_ok($o, 'DeclareTest');
 162
 163 is($o->{attr}, 'value', '@_ args ok');
 164
 165 is($o->foo('yay'), 'DeclareTest: Foo: yay', 'method with argument ok');
 166
 167 is($o->main, 'main', 'declaration of package named method ok');
 168
 169 $o->upgrade;
 170
 171 isa_ok($o, 'DeclareTest2');
 172
 173 is($o->bar, 'DeclareTest2: bar', 'absolute method declaration ok');
 174
 175 is($o->$test_method1('no', 'yes'), 'value, yes', 'anon method with @_ ok');
 176
 177 is($o->$test_method2('this'), 'DeclareTest2, this', 'anon method with proto ok');
 178
 179 is_deeply([ map { $_->() } @test_list ], [ 1, 2, 3, 4], 'binding ok');