t/method.t

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