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 {
  18     package t::non_moo;
  19
  20     sub new {
  21         my ($class, $arg) = @_;
  22         bless { attr => $arg }, $class;
  23     }
  24
  25     sub attr { shift->{attr} }
  26
  27     package t::ext_non_moo::with_attr;
  28     use Moo;
  29     extends qw( t::non_moo );
  30
  31     has 'attr2' => ( is => 'ro' );
  32
  33     sub BUILDARGS {
  34         my ( $class, @args ) = @_;
  35         shift @args if @args % 2 == 1;
  36         return { @args };
  37     }
  38 }
  39
  40
  41 {
  42     package Foo;
  43     use Moo;
  44
  45     has bar => ( is => "rw" );
  46     has baz => ( is => "rw" );
  47
  48     sub BUILDARGS {
  49         my ( $class, @args ) = @_;
  50         unshift @args, "bar" if @args % 2 == 1;
  51         return $class->SUPER::BUILDARGS(@args);
  52     }
  53
  54     package Bar;
  55     use Moo;
  56
  57     extends qw(Foo);
  58 }
  59
  60 {
  61     package Baz;
  62     use Moo;
  63
  64     has bar => ( is => "rw" );
  65     has baz => ( is => "rw" );
  66
  67     around BUILDARGS => sub {
  68         my $orig = shift;
  69         my ( $class, @args ) = @_;
  70
  71         unshift @args, "bar" if @args % 2 == 1;
  72
  73         return $class->$orig(@args);
  74     };
  75
  76     package Biff;
  77     use Moo;
  78
  79     extends qw(Baz);
  80 }
  81
  82 foreach my $class (qw(Foo Bar Baz Biff)) {
  83     is( $class->new->bar, undef, "no args" );
  84     is( $class->new( bar => 42 )->bar, 42, "normal args" );
  85     is( $class->new( 37 )->bar, 37, "single arg" );
  86     {
  87         my $o = $class->new(bar => 42, baz => 47);
  88         is($o->bar, 42, '... got the right bar');
  89         is($o->baz, 47, '... got the right baz');
  90     }
  91     {
  92         my $o = $class->new(42, baz => 47);
  93         is($o->bar, 42, '... got the right bar');
  94         is($o->baz, 47, '... got the right baz');
  95     }
  96 }
  97
  98 foreach my $class (qw(Qux Quux)) {
  99     my $o = $class->new(bar => 42, baz => 47);
 100     is($o->bar, 42, '... got the right bar');
 101     is($o->baz, 47, '... got the right baz');
 102
 103     eval {
 104         $class->new( 37 );
 105     };
 106     like( $@, qr/Single parameters to new\(\) must be a HASH ref/,
 107         "new() requires a list or a HASH ref"
 108     );
 109
 110     eval {
 111         $class->new( [ 37 ] );
 112     };
 113     like( $@, qr/Single parameters to new\(\) must be a HASH ref/,
 114         "new() requires a list or a HASH ref"
 115     );
 116
 117     eval {
 118         $class->new( bar => 42, baz => 47, 'quux' );
 119     };
 120     like( $@, qr/You passed an odd number of arguments/,
 121         "new() requires a list or a HASH ref"
 122     );
 123 }
 124
 125 my $non_moo = t::non_moo->new( 'bar' );
 126 my $ext_non_moo = t::ext_non_moo::with_attr->new( 'bar', attr2 => 'baz' );
 127
 128 is $non_moo->attr, 'bar',
 129     "non-moo accepts params";
 130 is $ext_non_moo->attr, 'bar',
 131     "extended non-moo passes params";
 132 is $ext_non_moo->attr2, 'baz',
 133     "extended non-moo has own attributes";
 134
 135
 136 done_testing;
 137