t/methinstaller-simple.t

   1
   2 {
   3   package MethodHandlers;
   4
   5   use strict;
   6   use warnings;
   7   use base 'Devel::Declare::MethodInstaller::Simple';
   8
   9   # undef  -> my ($self) = shift;
  10   # ''     -> my ($self) = @_;
  11   # '$foo' -> my ($self, $foo) = @_;
  12
  13   sub parse_proto {
  14     my $ctx = shift;
  15     my ($proto) = @_;
  16     my $inject = 'my ($self';
  17     if (defined $proto) {
  18       $inject .= ", $proto" if length($proto);
  19       $inject .= ') = @_; ';
  20     } else {
  21       $inject .= ') = shift;';
  22     }
  23     return $inject;
  24   }
  25
  26 }
  27
  28 my ($test_method1, $test_method2, @test_list);
  29
  30 {
  31   package DeclareTest;
  32
  33   BEGIN { # normally, this'd go in MethodHandlers::import
  34   MethodHandlers->install_methodhandler(
  35     name => 'method',
  36     into => __PACKAGE__,
  37   );
  38   }
  39
  40   method new {
  41     my $class = ref $self || $self;
  42     return bless({ @_ }, $class);
  43   }
  44
  45   method foo ($foo) {
  46     return (ref $self).': Foo: '.$foo;
  47   }
  48
  49   method upgrade(){ # no spaces to make case pathological
  50     bless($self, 'DeclareTest2');
  51   }
  52
  53   method DeclareTest2::bar () {
  54     return 'DeclareTest2: bar';
  55   }
  56
  57   $test_method1 = method {
  58     return join(', ', $self->{attr}, $_[1]);
  59   };
  60
  61   $test_method2 = method ($what) {
  62     return join(', ', ref $self, $what);
  63   };
  64
  65   method main () { return "main"; }
  66
  67   @test_list = (method { 1 }, sub { 2 }, method () { 3 }, sub { 4 });
  68
  69   method leftie :lvalue { $self->{attributes} };
  70 }
  71
  72 use Test::More 'no_plan';
  73
  74 my $o = DeclareTest->new(attr => "value");
  75
  76 isa_ok($o, 'DeclareTest');
  77
  78 is($o->{attr}, 'value', '@_ args ok');
  79
  80 is($o->foo('yay'), 'DeclareTest: Foo: yay', 'method with argument ok');
  81
  82 is($o->main, 'main', 'declaration of package named method ok');
  83
  84 $o->leftie = 'attributes work';
  85 is($o->leftie, 'attributes work', 'code attributes intact');
  86
  87 $o->upgrade;
  88
  89 isa_ok($o, 'DeclareTest2');
  90
  91 is($o->bar, 'DeclareTest2: bar', 'absolute method declaration ok');
  92
  93 is($o->$test_method1('no', 'yes'), 'value, yes', 'anon method with @_ ok');
  94
  95 is($o->$test_method2('this'), 'DeclareTest2, this', 'anon method with proto ok');
  96
  97 is_deeply([ map { $_->() } @test_list ], [ 1, 2, 3, 4], 'binding ok');
  98