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