t/buildargs.t

   1 use strictures 1;
   2 use Test::More;
   3
   4 {
   5     package Qux;
   6     use Moo;
   7
   8     has bar => ( is => "rw" );
   9     has baz => ( is => "rw" );
  10
  11     package Quux;
  12     use Moo;
  13
  14     extends qw(Qux);
  15 }
  16 {
  17     package Foo;
  18     use Moo;
  19
  20     has bar => ( is => "rw" );
  21     has baz => ( is => "rw" );
  22
  23     sub BUILDARGS {
  24         my ( $class, @args ) = @_;
  25         unshift @args, "bar" if @args % 2 == 1;
  26         return $class->SUPER::BUILDARGS(@args);
  27     }
  28
  29     package Bar;
  30     use Moo;
  31
  32     extends qw(Foo);
  33 }
  34
  35 {
  36     package Baz;
  37     use Moo;
  38
  39     has bar => ( is => "rw" );
  40     has baz => ( is => "rw" );
  41
  42     around BUILDARGS => sub {
  43         my $orig = shift;
  44         my ( $class, @args ) = @_;
  45
  46         unshift @args, "bar" if @args % 2 == 1;
  47
  48         return $class->$orig(@args);
  49     };
  50
  51     package Biff;
  52     use Moo;
  53
  54     extends qw(Baz);
  55 }
  56
  57 foreach my $class (qw(Foo Bar Baz Biff)) {
  58     is( $class->new->bar, undef, "no args" );
  59     is( $class->new( bar => 42 )->bar, 42, "normal args" );
  60     is( $class->new( 37 )->bar, 37, "single arg" );
  61     {
  62         my $o = $class->new(bar => 42, baz => 47);
  63         is($o->bar, 42, '... got the right bar');
  64         is($o->baz, 47, '... got the right baz');
  65     }
  66     {
  67         my $o = $class->new(42, baz => 47);
  68         is($o->bar, 42, '... got the right bar');
  69         is($o->baz, 47, '... got the right baz');
  70     }
  71 }
  72
  73 foreach my $class (qw(Qux Quux)) {
  74     my $o = $class->new(bar => 42, baz => 47);
  75     is($o->bar, 42, '... got the right bar');
  76     is($o->baz, 47, '... got the right baz');
  77
  78     eval {
  79         $class->new( 37 );
  80     };
  81     like( $@, qr/Single parameters to new\(\) must be a HASH ref/,
  82         "new() requires a list or a HASH ref"
  83     );
  84
  85     eval {
  86         $class->new( [ 37 ] );
  87     };
  88     like( $@, qr/Single parameters to new\(\) must be a HASH ref/,
  89         "new() requires a list or a HASH ref"
  90     );
  91 }
  92
  93 done_testing;
  94