t/foreign/Method-Signatures/method.t

   1 #!perl
   2 use warnings FATAL => 'all';
   3 use strict;
   4 use Test::More 'no_plan';
   5
   6 {
   7     package Foo;
   8     use Function::Parameters qw(:strict);
   9
  10     method new (%args) {
  11         return bless {%args}, $self;
  12     }
  13
  14     method set ($key, $val) {
  15         return $self->{$key} = $val;
  16     }
  17
  18     method get ($key) {
  19         return $self->{$key};
  20     }
  21
  22     method no_proto {
  23         return($self, @_);
  24     }
  25
  26     method empty_proto() {
  27         return($self, @_);
  28     }
  29
  30     method echo(@_) {
  31         return($self, @_);
  32     }
  33
  34     method caller($height = 0) {
  35         return (CORE::caller($height))[0..2];
  36     }
  37
  38 #line 39
  39     method warn($foo = undef) {
  40         my $warning = '';
  41         local $SIG{__WARN__} = sub { $warning = join '', @_; };
  42         CORE::warn "Testing warn";
  43
  44         return $warning;
  45     }
  46
  47     # Method with the same name as a loaded class.
  48     method strict () {
  49         42
  50     }
  51 }
  52
  53 my $obj = Foo->new( foo => 42, bar => 23 );
  54 isa_ok $obj, "Foo";
  55 is $obj->get("foo"), 42;
  56 is $obj->get("bar"), 23;
  57
  58 $obj->set(foo => 99);
  59 is $obj->get("foo"), 99;
  60
  61 is_deeply [$obj->no_proto], [$obj];
  62 for my $method (qw(empty_proto)) {
  63     is_deeply [$obj->$method], [$obj];
  64     ok !eval { $obj->$method(23); 1 };
  65     like $@, qr{\QToo many arguments};
  66 }
  67
  68 is_deeply [$obj->echo(1,2,3)], [$obj,1,2,3], "echo";
  69
  70 is_deeply [$obj->caller], [__PACKAGE__, $0, __LINE__], 'caller works';
  71
  72 is $obj->warn, "Testing warn at $0 line 42.\n";
  73
  74 is eval { $obj->strict }, 42;