t/method-no-semi.t

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