t/method.t

   1 use strict;
   2 use warnings;
   3 use Devel::Declare ();
   4
   5 {
   6   package MethodHandlers;
   7
   8   use strict;
   9   use warnings;
  10
  11   our ($Declarator, $Offset);
  12
  13   sub skip_declarator {
  14     $Offset += Devel::Declare::toke_move_past_token($Offset);
  15   }
  16
  17   sub skipspace {
  18     $Offset += Devel::Declare::toke_skipspace($Offset);
  19   }
  20
  21   sub strip_name {
  22     skipspace;
  23     if (my $len = Devel::Declare::toke_scan_word($Offset, 1)) {
  24       my $linestr = Devel::Declare::get_linestr();
  25       my $name = substr($linestr, $Offset, $len);
  26       substr($linestr, $Offset, $len) = '';
  27       Devel::Declare::set_linestr($linestr);
  28       return $name;
  29     }
  30     return;
  31   }
  32
  33   sub strip_proto {
  34     skipspace;
  35
  36     my $linestr = Devel::Declare::get_linestr();
  37     if (substr($linestr, $Offset, 1) eq '(') {
  38       my $length = Devel::Declare::toke_scan_str($Offset);
  39       my $proto = Devel::Declare::get_lex_stuff();
  40       Devel::Declare::clear_lex_stuff();
  41       $linestr = Devel::Declare::get_linestr();
  42       substr($linestr, $Offset, $length) = '';
  43       Devel::Declare::set_linestr($linestr);
  44       return $proto;
  45     }
  46     return;
  47   }
  48
  49   sub shadow {
  50     my $pack = Devel::Declare::get_curstash_name;
  51     Devel::Declare::shadow_sub("${pack}::${Declarator}", $_[0]);
  52   }
  53
  54   # undef  -> my ($self) = shift;
  55   # ''     -> my ($self) = @_;
  56   # '$foo' -> my ($self, $foo) = @_;
  57
  58   sub make_proto_unwrap {
  59     my ($proto) = @_;
  60     my $inject = 'my ($self';
  61     if (defined $proto) {
  62       $inject .= ", $proto" if length($proto);
  63       $inject .= ') = @_; ';
  64     } else {
  65       $inject .= ') = shift;';
  66     }
  67     return $inject;
  68   }
  69
  70   sub inject_if_block {
  71     my $inject = shift;
  72     skipspace;
  73     my $linestr = Devel::Declare::get_linestr;
  74     if (substr($linestr, $Offset, 1) eq '{') {
  75       substr($linestr, $Offset+1, 0) = $inject;
  76       Devel::Declare::set_linestr($linestr);
  77     }
  78   }
  79
  80   sub parser {
  81     local ($Declarator, $Offset) = @_;
  82     skip_declarator;
  83     my $name = strip_name;
  84     my $proto = strip_proto;
  85     inject_if_block(
  86       make_proto_unwrap($proto)
  87     );
  88     if (defined $name) {
  89       $name = join('::', Devel::Declare::get_curstash_name(), $name)
  90         unless ($name =~ /::/);
  91       shadow(sub (&) { no strict 'refs'; *{$name} = shift; });
  92     } else {
  93       shadow(sub (&) { shift });
  94     }
  95   }
  96 }
  97
  98 my ($test_method1, $test_method2, @test_list);
  99
 100 {
 101   package DeclareTest;
 102
 103   sub method (&);
 104
 105   BEGIN {
 106     Devel::Declare->setup_for(
 107       __PACKAGE__,
 108       { method => { const => \&MethodHandlers::parser } }
 109     );
 110   }
 111
 112   method new {
 113     my $class = ref $self || $self;
 114     return bless({ @_ }, $class);
 115   };
 116
 117   method foo ($foo) {
 118     return (ref $self).': Foo: '.$foo;
 119   };
 120
 121   method upgrade(){ # no spaces to make case pathological
 122     bless($self, 'DeclareTest2');
 123   };
 124
 125   method DeclareTest2::bar () {
 126     return 'DeclareTest2: bar';
 127   };
 128
 129   $test_method1 = method {
 130     return join(', ', $self->{attr}, $_[1]);
 131   };
 132
 133   $test_method2 = method ($what) {
 134     return join(', ', ref $self, $what);
 135   };
 136
 137   method main () { return "main"; };
 138
 139   @test_list = (method { 1 }, sub { 2 }, method () { 3 }, sub { 4 });
 140
 141 }
 142
 143 use Test::More 0.88;
 144
 145 my $o = DeclareTest->new(attr => "value");
 146
 147 isa_ok($o, 'DeclareTest');
 148
 149 is($o->{attr}, 'value', '@_ args ok');
 150
 151 is($o->foo('yay'), 'DeclareTest: Foo: yay', 'method with argument ok');
 152
 153 is($o->main, 'main', 'declaration of package named method ok');
 154
 155 $o->upgrade;
 156
 157 isa_ok($o, 'DeclareTest2');
 158
 159 is($o->bar, 'DeclareTest2: bar', 'absolute method declaration ok');
 160
 161 is($o->$test_method1('no', 'yes'), 'value, yes', 'anon method with @_ ok');
 162
 163 is($o->$test_method2('this'), 'DeclareTest2, this', 'anon method with proto ok');
 164
 165 is_deeply([ map { $_->() } @test_list ], [ 1, 2, 3, 4], 'binding ok');
 166
 167 done_testing;