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 Term::Table::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 Term::Table::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 Term::Table::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");
86is($pkg->do_it, 'const', "worked as expected, const was constant");
87
88BEGIN {
89    $INC{'Object/HashBase/Test/HBase/Wrapped.pm'} = __FILE__;
90
91    package
92        main::HBase::Wrapped;
93    use Term::Table::HashBase qw/foo bar dup/;
94
95    my $foo = __PACKAGE__->can('foo');
96    no warnings 'redefine';
97    *foo = sub {
98        my $self = shift;
99        $self->set_bar(1);
100        $self->$foo(@_);
101    };
102}
103
104BEGIN {
105    $INC{'Object/HashBase/Test/HBase/Wrapped/Inherit.pm'} = __FILE__;
106
107    package
108        main::HBase::Wrapped::Inherit;
109    use base 'main::HBase::Wrapped';
110    use Term::Table::HashBase qw/baz dup/;
111}
112
113my $o = main::HBase::Wrapped::Inherit->new(foo => 1);
114my $foo = $o->foo;
115is($o->bar, 1, 'parent attribute sub not overridden');
116
117{
118    package
119        Foo;
120
121    sub new;
122
123    use Term::Table::HashBase qw/foo bar baz/;
124
125    sub new { 'foo' };
126}
127
128is(Foo->new, 'foo', "Did not override existing 'new' method");
129
130BEGIN {
131    $INC{'Object/HashBase/Test/HBase2.pm'} = __FILE__;
132
133    package
134        main::HBase2;
135    use Term::Table::HashBase qw/foo -bar ^baz <bat >ban +boo/;
136
137    main::is(FOO, 'foo', "FOO CONSTANT");
138    main::is(BAR, 'bar', "BAR CONSTANT");
139    main::is(BAZ, 'baz', "BAZ CONSTANT");
140    main::is(BAT, 'bat', "BAT CONSTANT");
141    main::is(BAN, 'ban', "BAN CONSTANT");
142    main::is(BOO, 'boo', "BOO CONSTANT");
143}
144
145my $ro = main::HBase2->new(foo => 'foo', bar => 'bar', baz => 'baz', bat => 'bat', ban => 'ban');
146is($ro->foo, 'foo', "got foo");
147is($ro->bar, 'bar', "got bar");
148is($ro->baz, 'baz', "got baz");
149is($ro->bat, 'bat', "got bat");
150ok(!$ro->can('set_bat'), "No setter for bat");
151ok(!$ro->can('ban'), "No reader for ban");
152ok(!$ro->can('boo'), "No reader for boo");
153ok(!$ro->can('set_boo'), "No setter for boo");
154is($ro->{ban}, 'ban', "ban attribute is set");
155$ro->set_ban('xxx');
156is($ro->{ban}, 'xxx', "ban attribute can be set");
157
158is($ro->set_foo('xxx'), 'xxx', "Can set foo");
159is($ro->foo, 'xxx', "got foo");
160
161like(exception { $ro->set_bar('xxx') }, qr/'bar' is read-only/, "Cannot set bar");
162
163my $warnings = warnings { is($ro->set_baz('xxx'), 'xxx', 'set baz') };
164like($warnings->[0], qr/set_baz\(\) is deprecated/, "Deprecation warning");
165
166
167
168is_deeply(
169    [Term::Table::HashBase::attr_list('main::HBase::Wrapped::Inherit')],
170    [qw/foo bar dup baz/],
171    "Got a list of attributes in order starting from base class, duplicates removed",
172);
173
174my $x = main::HBase::Wrapped::Inherit->new(foo => 1, baz => 2);
175is($x->foo, 1, "set foo via pairs");
176is($x->baz, 2, "set baz via pairs");
177
178# Now with hashref
179my $y = main::HBase::Wrapped::Inherit->new({foo => 1, baz => 2});
180is($y->foo, 1, "set foo via hashref");
181is($y->baz, 2, "set baz via hashref");
182
183# Now with hashref
184my $z = main::HBase::Wrapped::Inherit->new([
185    1, # foo
186    2, # bar
187    3, # dup
188    4, # baz
189]);
190is($z->foo, 1, "set foo via arrayref");
191is($z->baz, 4, "set baz via arrayref");
192
193like(
194    exception { main::HBase::Wrapped::Inherit->new([1 .. 10]) },
195    qr/Too many arguments for main::HBase::Wrapped::Inherit constructor/,
196    "Too many args in array form"
197);
198
199
200my $CAN_COUNT = 0;
201my $CAN_COUNT2 = 0;
202my $INIT_COUNT = 0;
203BEGIN {
204    $INC{'Object/HashBase/Test/HBase3.pm'} = __FILE__;
205    package
206        main::HBase3;
207    use Term::Table::HashBase qw/foo/;
208
209    sub can {
210        my $self = shift;
211        $CAN_COUNT++;
212        $self->SUPER::can(@_);
213    }
214
215    $INC{'Object/HashBase/Test/HBase4.pm'} = __FILE__;
216    package
217        main::HBase4;
218    use Term::Table::HashBase qw/foo/;
219
220    sub can {
221        my $self = shift;
222        $CAN_COUNT2++;
223        $self->SUPER::can(@_);
224    }
225
226    sub init { $INIT_COUNT++ }
227}
228
229is($CAN_COUNT, 0, "->can has not been called yet");
230my $it = main::HBase3->new;
231is($CAN_COUNT, 1, "->can has been called once to check for init");
232$it = main::HBase3->new;
233is($CAN_COUNT, 1, "->can was not called again, we cached it");
234
235is($CAN_COUNT2, 0, "->can has not been called yet");
236is($INIT_COUNT, 0, "->init has not been called yet");
237$it = main::HBase4->new;
238is($CAN_COUNT2, 1, "->can has been called once to check for init");
239is($INIT_COUNT, 1, "->init has been called once");
240$it = main::HBase4->new;
241is($CAN_COUNT2, 1, "->can was not called again, we cached it");
242is($INIT_COUNT, 2, "->init has been called again");
243
244done_testing;
245
2461;
247