1use strict; 2use warnings; 3 4use Test::More; 5 6 7sub warnings(&) { 8 my $code = shift; 9 my @warnings; 10 local $SIG{__WARN__} = sub { push @warnings => @_ }; 11 $code->(); 12 return \@warnings; 13} 14 15sub exception(&) { 16 my $code = shift; 17 local ($@, $!, $SIG{__DIE__}); 18 my $ok = eval { $code->(); 1 }; 19 my $error = $@ || 'SQUASHED ERROR'; 20 return $ok ? undef : $error; 21} 22 23BEGIN { 24 $INC{'Object/HashBase/Test/HBase.pm'} = __FILE__; 25 26 package 27 main::HBase; 28 use Test2::Util::HashBase qw/foo bar baz/; 29 30 main::is(FOO, 'foo', "FOO CONSTANT"); 31 main::is(BAR, 'bar', "BAR CONSTANT"); 32 main::is(BAZ, 'baz', "BAZ CONSTANT"); 33} 34 35BEGIN { 36 package 37 main::HBaseSub; 38 use base 'main::HBase'; 39 use Test2::Util::HashBase qw/apple pear/; 40 41 main::is(FOO, 'foo', "FOO CONSTANT"); 42 main::is(BAR, 'bar', "BAR CONSTANT"); 43 main::is(BAZ, 'baz', "BAZ CONSTANT"); 44 main::is(APPLE, 'apple', "APPLE CONSTANT"); 45 main::is(PEAR, 'pear', "PEAR CONSTANT"); 46} 47 48my $one = main::HBase->new(foo => 'a', bar => 'b', baz => 'c'); 49is($one->foo, 'a', "Accessor"); 50is($one->bar, 'b', "Accessor"); 51is($one->baz, 'c', "Accessor"); 52$one->set_foo('x'); 53is($one->foo, 'x', "Accessor set"); 54$one->set_foo(undef); 55 56is_deeply( 57 $one, 58 { 59 foo => undef, 60 bar => 'b', 61 baz => 'c', 62 }, 63 'hash' 64); 65 66BEGIN { 67 package 68 main::Const::Test; 69 use Test2::Util::HashBase qw/foo/; 70 71 sub do_it { 72 if (FOO()) { 73 return 'const'; 74 } 75 return 'not const' 76 } 77} 78 79my $pkg = 'main::Const::Test'; 80is($pkg->do_it, 'const', "worked as expected"); 81{ 82 local $SIG{__WARN__} = sub { }; 83 *main::Const::Test::FOO = sub { 0 }; 84} 85ok(!$pkg->FOO, "overrode const sub"); 86{ 87local $TODO = "known to fail on $]" if $] le "5.006002"; 88is($pkg->do_it, 'const', "worked as expected, const was constant"); 89} 90 91BEGIN { 92 $INC{'Object/HashBase/Test/HBase/Wrapped.pm'} = __FILE__; 93 94 package 95 main::HBase::Wrapped; 96 use Test2::Util::HashBase qw/foo bar dup/; 97 98 my $foo = __PACKAGE__->can('foo'); 99 no warnings 'redefine'; 100 *foo = sub { 101 my $self = shift; 102 $self->set_bar(1); 103 $self->$foo(@_); 104 }; 105} 106 107BEGIN { 108 $INC{'Object/HashBase/Test/HBase/Wrapped/Inherit.pm'} = __FILE__; 109 110 package 111 main::HBase::Wrapped::Inherit; 112 use base 'main::HBase::Wrapped'; 113 use Test2::Util::HashBase qw/baz dup/; 114} 115 116my $o = main::HBase::Wrapped::Inherit->new(foo => 1); 117my $foo = $o->foo; 118is($o->bar, 1, 'parent attribute sub not overridden'); 119 120{ 121 package 122 Foo; 123 124 sub new; 125 126 use Test2::Util::HashBase qw/foo bar baz/; 127 128 sub new { 'foo' }; 129} 130 131is(Foo->new, 'foo', "Did not override existing 'new' method"); 132 133BEGIN { 134 $INC{'Object/HashBase/Test/HBase2.pm'} = __FILE__; 135 136 package 137 main::HBase2; 138 use Test2::Util::HashBase qw/foo -bar ^baz/; 139 140 main::is(FOO, 'foo', "FOO CONSTANT"); 141 main::is(BAR, 'bar', "BAR CONSTANT"); 142 main::is(BAZ, 'baz', "BAZ CONSTANT"); 143} 144 145my $ro = main::HBase2->new(foo => 'foo', bar => 'bar', baz => 'baz'); 146is($ro->foo, 'foo', "got foo"); 147is($ro->bar, 'bar', "got bar"); 148is($ro->baz, 'baz', "got baz"); 149 150is($ro->set_foo('xxx'), 'xxx', "Can set foo"); 151is($ro->foo, 'xxx', "got foo"); 152 153like(exception { $ro->set_bar('xxx') }, qr/'bar' is read-only/, "Cannot set bar"); 154 155my $warnings = warnings { is($ro->set_baz('xxx'), 'xxx', 'set baz') }; 156like($warnings->[0], qr/set_baz\(\) is deprecated/, "Deprecation warning"); 157 158 159 160is_deeply( 161 [Test2::Util::HashBase::attr_list('main::HBase::Wrapped::Inherit')], 162 [qw/foo bar dup baz/], 163 "Got a list of attributes in order starting from base class, duplicates removed", 164); 165 166my $x = main::HBase::Wrapped::Inherit->new(foo => 1, baz => 2); 167is($x->foo, 1, "set foo via pairs"); 168is($x->baz, 2, "set baz via pairs"); 169 170# Now with hashref 171my $y = main::HBase::Wrapped::Inherit->new({foo => 1, baz => 2}); 172is($y->foo, 1, "set foo via hashref"); 173is($y->baz, 2, "set baz via hashref"); 174 175# Now with hashref 176my $z = main::HBase::Wrapped::Inherit->new([ 177 1, # foo 178 2, # bar 179 3, # dup 180 4, # baz 181]); 182is($z->foo, 1, "set foo via arrayref"); 183is($z->baz, 4, "set baz via arrayref"); 184 185like( 186 exception { main::HBase::Wrapped::Inherit->new([1 .. 10]) }, 187 qr/Too many arguments for main::HBase::Wrapped::Inherit constructor/, 188 "Too many args in array form" 189); 190 191 192my $CAN_COUNT = 0; 193my $CAN_COUNT2 = 0; 194my $INIT_COUNT = 0; 195BEGIN { 196 $INC{'Object/HashBase/Test/HBase3.pm'} = __FILE__; 197 package 198 main::HBase3; 199 use Test2::Util::HashBase qw/foo/; 200 201 sub can { 202 my $self = shift; 203 $CAN_COUNT++; 204 $self->SUPER::can(@_); 205 } 206 207 $INC{'Object/HashBase/Test/HBase4.pm'} = __FILE__; 208 package 209 main::HBase4; 210 use Test2::Util::HashBase qw/foo/; 211 212 sub can { 213 my $self = shift; 214 $CAN_COUNT2++; 215 $self->SUPER::can(@_); 216 } 217 218 sub init { $INIT_COUNT++ } 219} 220 221is($CAN_COUNT, 0, "->can has not been called yet"); 222my $it = main::HBase3->new; 223is($CAN_COUNT, 1, "->can has been called once to check for init"); 224$it = main::HBase3->new; 225is($CAN_COUNT, 1, "->can was not called again, we cached it"); 226 227is($CAN_COUNT2, 0, "->can has not been called yet"); 228is($INIT_COUNT, 0, "->init has not been called yet"); 229$it = main::HBase4->new; 230is($CAN_COUNT2, 1, "->can has been called once to check for init"); 231is($INIT_COUNT, 1, "->init has been called once"); 232$it = main::HBase4->new; 233is($CAN_COUNT2, 1, "->can was not called again, we cached it"); 234is($INIT_COUNT, 2, "->init has been called again"); 235 236done_testing; 237 2381; 239