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 <bat >ban +boo/;
139
140    main::is(FOO, 'foo', "FOO CONSTANT");
141    main::is(BAR, 'bar', "BAR CONSTANT");
142    main::is(BAZ, 'baz', "BAZ CONSTANT");
143    main::is(BAT, 'bat', "BAT CONSTANT");
144    main::is(BAN, 'ban', "BAN CONSTANT");
145    main::is(BOO, 'boo', "BOO CONSTANT");
146}
147
148my $ro = main::HBase2->new(foo => 'foo', bar => 'bar', baz => 'baz', bat => 'bat', ban => 'ban');
149is($ro->foo, 'foo', "got foo");
150is($ro->bar, 'bar', "got bar");
151is($ro->baz, 'baz', "got baz");
152is($ro->bat, 'bat', "got bat");
153ok(!$ro->can('set_bat'), "No setter for bat");
154ok(!$ro->can('ban'), "No reader for ban");
155ok(!$ro->can('boo'), "No reader for boo");
156ok(!$ro->can('set_boo'), "No setter for boo");
157is($ro->{ban}, 'ban', "ban attribute is set");
158$ro->set_ban('xxx');
159is($ro->{ban}, 'xxx', "ban attribute can be set");
160
161is($ro->set_foo('xxx'), 'xxx', "Can set foo");
162is($ro->foo, 'xxx', "got foo");
163
164like(exception { $ro->set_bar('xxx') }, qr/'bar' is read-only/, "Cannot set bar");
165
166my $warnings = warnings { is($ro->set_baz('xxx'), 'xxx', 'set baz') };
167like($warnings->[0], qr/set_baz\(\) is deprecated/, "Deprecation warning");
168
169
170
171is_deeply(
172    [Test2::Util::HashBase::attr_list('main::HBase::Wrapped::Inherit')],
173    [qw/foo bar dup baz/],
174    "Got a list of attributes in order starting from base class, duplicates removed",
175);
176
177my $x = main::HBase::Wrapped::Inherit->new(foo => 1, baz => 2);
178is($x->foo, 1, "set foo via pairs");
179is($x->baz, 2, "set baz via pairs");
180
181# Now with hashref
182my $y = main::HBase::Wrapped::Inherit->new({foo => 1, baz => 2});
183is($y->foo, 1, "set foo via hashref");
184is($y->baz, 2, "set baz via hashref");
185
186# Now with hashref
187my $z = main::HBase::Wrapped::Inherit->new([
188    1, # foo
189    2, # bar
190    3, # dup
191    4, # baz
192]);
193is($z->foo, 1, "set foo via arrayref");
194is($z->baz, 4, "set baz via arrayref");
195
196like(
197    exception { main::HBase::Wrapped::Inherit->new([1 .. 10]) },
198    qr/Too many arguments for main::HBase::Wrapped::Inherit constructor/,
199    "Too many args in array form"
200);
201
202
203my $CAN_COUNT = 0;
204my $CAN_COUNT2 = 0;
205my $INIT_COUNT = 0;
206BEGIN {
207    $INC{'Object/HashBase/Test/HBase3.pm'} = __FILE__;
208    package
209        main::HBase3;
210    use Test2::Util::HashBase qw/foo/;
211
212    sub can {
213        my $self = shift;
214        $CAN_COUNT++;
215        $self->SUPER::can(@_);
216    }
217
218    $INC{'Object/HashBase/Test/HBase4.pm'} = __FILE__;
219    package
220        main::HBase4;
221    use Test2::Util::HashBase qw/foo/;
222
223    sub can {
224        my $self = shift;
225        $CAN_COUNT2++;
226        $self->SUPER::can(@_);
227    }
228
229    sub init { $INIT_COUNT++ }
230}
231
232is($CAN_COUNT, 0, "->can has not been called yet");
233my $it = main::HBase3->new;
234is($CAN_COUNT, 1, "->can has been called once to check for init");
235$it = main::HBase3->new;
236is($CAN_COUNT, 1, "->can was not called again, we cached it");
237
238is($CAN_COUNT2, 0, "->can has not been called yet");
239is($INIT_COUNT, 0, "->init has not been called yet");
240$it = main::HBase4->new;
241is($CAN_COUNT2, 1, "->can has been called once to check for init");
242is($INIT_COUNT, 1, "->init has been called once");
243$it = main::HBase4->new;
244is($CAN_COUNT2, 1, "->can was not called again, we cached it");
245is($INIT_COUNT, 2, "->init has been called again");
246
247done_testing;
248
2491;
250