t/ctx-simple.t

   1 use Devel::Declare ();
   2
   3 {
   4   package MethodHandlers;
   5
   6   use strict;
   7   use warnings;
   8   use Devel::Declare::Context::Simple;
   9
  10   # undef  -> my ($self) = shift;
  11   # ''     -> my ($self) = @_;
  12   # '$foo' -> my ($self, $foo) = @_;
  13
  14   sub make_proto_unwrap {
  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   sub parser {
  27     my $ctx = Devel::Declare::Context::Simple->new->init(@_);
  28
  29     $ctx->skip_declarator;
  30     my $name = $ctx->strip_name;
  31     my $proto = $ctx->strip_proto;
  32     my $inject = make_proto_unwrap($proto);
  33     if (defined $name) {
  34       $inject = $ctx->scope_injector_call().$inject;
  35     }
  36     $ctx->inject_if_block($inject);
  37     if (defined $name) {
  38       $name = join('::', Devel::Declare::get_curstash_name(), $name)
  39         unless ($name =~ /::/);
  40       $ctx->shadow(sub (&) { no strict 'refs'; *{$name} = shift; });
  41     } else {
  42       $ctx->shadow(sub (&) { shift });
  43     }
  44   }
  45
  46 }
  47
  48 my ($test_method1, $test_method2, @test_list);
  49
  50 {
  51   package DeclareTest;
  52
  53   sub method (&);
  54
  55   BEGIN {
  56     Devel::Declare->setup_for(
  57       __PACKAGE__,
  58       { method => { const => \&MethodHandlers::parser } }
  59     );
  60   }
  61
  62   method new {
  63     my $class = ref $self || $self;
  64     return bless({ @_ }, $class);
  65   }
  66
  67   method foo ($foo) {
  68     return (ref $self).': Foo: '.$foo;
  69   }
  70
  71   method upgrade(){ # no spaces to make case pathological
  72     bless($self, 'DeclareTest2');
  73   }
  74
  75   method DeclareTest2::bar () {
  76     return 'DeclareTest2: bar';
  77   }
  78
  79   $test_method1 = method {
  80     return join(', ', $self->{attr}, $_[1]);
  81   };
  82
  83   $test_method2 = method ($what) {
  84     return join(', ', ref $self, $what);
  85   };
  86
  87   method main () { return "main"; }
  88
  89   @test_list = (method { 1 }, sub { 2 }, method () { 3 }, sub { 4 });
  90
  91 }
  92
  93 use Test::More 'no_plan';
  94
  95 my $o = DeclareTest->new(attr => "value");
  96
  97 isa_ok($o, 'DeclareTest');
  98
  99 is($o->{attr}, 'value', '@_ args ok');
 100
 101 is($o->foo('yay'), 'DeclareTest: Foo: yay', 'method with argument ok');
 102
 103 is($o->main, 'main', 'declaration of package named method ok');
 104
 105 $o->upgrade;
 106
 107 isa_ok($o, 'DeclareTest2');
 108
 109 is($o->bar, 'DeclareTest2: bar', 'absolute method declaration ok');
 110
 111 is($o->$test_method1('no', 'yes'), 'value, yes', 'anon method with @_ ok');
 112
 113 is($o->$test_method2('this'), 'DeclareTest2, this', 'anon method with proto ok');
 114
 115 is_deeply([ map { $_->() } @test_list ], [ 1, 2, 3, 4], 'binding ok');
 116
 117 __END__
 118 /home/rhesa/perl/t/method-no-semi....
 119 ok 1 - The object isa DeclareTest
 120 ok 2 - @_ args ok
 121 ok 3 - method with argument ok
 122 ok 4 - declaration of package named method ok
 123 ok 5 - The object isa DeclareTest2
 124 ok 6 - absolute method declaration ok
 125 ok 7 - anon method with @_ ok
 126 ok 8 - anon method with proto ok
 127 ok 9 - binding ok
 128 1..9
 129 ok
 130 All tests successful.
 131 Files=1, Tests=9,  0 wallclock secs ( 0.04 usr  0.00 sys +  0.05 cusr  0.00 csys =  0.09 CPU)
 132 Result: PASS