t/method-no-semi.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   # 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     $^H |= 0x120000;
 104     $^H{DD_METHODHANDLERS} = Scope::Guard->new(sub {
 105       my $linestr = Devel::Declare::get_linestr;
 106       my $offset = Devel::Declare::get_linestr_offset;
 107       substr($linestr, $offset, 0) = ';';
 108       Devel::Declare::set_linestr($linestr);
 109     });
 110   }
 111 }
 112
 113 my ($test_method1, $test_method2, @test_list);
 114
 115 {
 116   package DeclareTest;
 117
 118   sub method (&);
 119
 120   BEGIN {
 121     Devel::Declare->setup_for(
 122       __PACKAGE__,
 123       { method => { const => \&MethodHandlers::parser } }
 124     );
 125   }
 126
 127   method new {
 128     my $class = ref $self || $self;
 129     return bless({ @_ }, $class);
 130   }
 131
 132   method foo ($foo) {
 133     return (ref $self).': Foo: '.$foo;
 134   }
 135
 136   method upgrade(){ # no spaces to make case pathological
 137     bless($self, 'DeclareTest2');
 138   }
 139
 140   method DeclareTest2::bar () {
 141     return 'DeclareTest2: bar';
 142   }
 143
 144   $test_method1 = method {
 145     return join(', ', $self->{attr}, $_[1]);
 146   };
 147
 148   $test_method2 = method ($what) {
 149     return join(', ', ref $self, $what);
 150   };
 151
 152   method main () { return "main"; }
 153
 154   @test_list = (method { 1 }, sub { 2 }, method () { 3 }, sub { 4 });
 155
 156 }
 157
 158 use Test::More 'no_plan';
 159
 160 my $o = DeclareTest->new(attr => "value");
 161
 162 isa_ok($o, 'DeclareTest');
 163
 164 is($o->{attr}, 'value', '@_ args ok');
 165
 166 is($o->foo('yay'), 'DeclareTest: Foo: yay', 'method with argument ok');
 167
 168 is($o->main, 'main', 'declaration of package named method ok');
 169
 170 $o->upgrade;
 171
 172 isa_ok($o, 'DeclareTest2');
 173
 174 is($o->bar, 'DeclareTest2: bar', 'absolute method declaration ok');
 175
 176 is($o->$test_method1('no', 'yes'), 'value, yes', 'anon method with @_ ok');
 177
 178 is($o->$test_method2('this'), 'DeclareTest2, this', 'anon method with proto ok');
 179
 180 is_deeply([ map { $_->() } @test_list ], [ 1, 2, 3, 4], 'binding ok');