t/method-no-semi.t

   1 use Devel::Declare ();
   2
   3 {
   4   package MethodHandlers;
   5
   6   use strict;
   7   use warnings;
   8   use B::Hooks::EndOfScope;
   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   # undef  -> my ($self) = shift;
  54   # ''     -> my ($self) = @_;
  55   # '$foo' -> my ($self, $foo) = @_;
  56
  57   sub make_proto_unwrap {
  58     my ($proto) = @_;
  59     my $inject = 'my ($self';
  60     if (defined $proto) {
  61       $inject .= ", $proto" if length($proto);
  62       $inject .= ') = @_; ';
  63     } else {
  64       $inject .= ') = shift;';
  65     }
  66     return $inject;
  67   }
  68
  69   sub inject_if_block {
  70     my $inject = shift;
  71     skipspace;
  72     my $linestr = Devel::Declare::get_linestr;
  73     if (substr($linestr, $Offset, 1) eq '{') {
  74       substr($linestr, $Offset+1, 0) = $inject;
  75       Devel::Declare::set_linestr($linestr);
  76     }
  77   }
  78
  79   sub scope_injector_call {
  80     return ' BEGIN { MethodHandlers::inject_scope }; ';
  81   }
  82
  83   sub parser {
  84     local ($Declarator, $Offset) = @_;
  85     skip_declarator;
  86     my $name = strip_name;
  87     my $proto = strip_proto;
  88     my $inject = make_proto_unwrap($proto);
  89     if (defined $name) {
  90       $inject = scope_injector_call().$inject;
  91     }
  92     inject_if_block($inject);
  93     if (defined $name) {
  94       $name = join('::', Devel::Declare::get_curstash_name(), $name)
  95         unless ($name =~ /::/);
  96       shadow(sub (&) { no strict 'refs'; *{$name} = shift; });
  97     } else {
  98       shadow(sub (&) { shift });
  99     }
 100   }
 101
 102   sub inject_scope {
 103     on_scope_end {
 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 => \&MethodHandlers::parser } }
 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;
 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');
 180
 181 done_testing;