cpan/Test-Simple/t/HashBase.t

   1 use strict;
   2 use warnings;
   3
   4 use Test::More;
   5
   6
   7 sub warnings(&) {
   8     my $code = shift;
   9     my @warnings;
  10     local $SIG{__WARN__} = sub { push @warnings => @_ };
  11     $code->();
  12     return \@warnings;
  13 }
  14
  15 sub 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
  23 BEGIN {
  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
  35 BEGIN {
  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
  48 my $one = main::HBase->new(foo => 'a', bar => 'b', baz => 'c');
  49 is($one->foo, 'a', "Accessor");
  50 is($one->bar, 'b', "Accessor");
  51 is($one->baz, 'c', "Accessor");
  52 $one->set_foo('x');
  53 is($one->foo, 'x', "Accessor set");
  54 $one->set_foo(undef);
  55
  56 is_deeply(
  57     $one,
  58     {
  59         foo => undef,
  60         bar => 'b',
  61         baz => 'c',
  62     },
  63     'hash'
  64 );
  65
  66 BEGIN {
  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
  79 my $pkg = 'main::Const::Test';
  80 is($pkg->do_it, 'const', "worked as expected");
  81 {
  82     local $SIG{__WARN__} = sub { };
  83     *main::Const::Test::FOO = sub { 0 };
  84 }
  85 ok(!$pkg->FOO, "overrode const sub");
  86 {
  87 local $TODO = "known to fail on $]" if $] le "5.006002";
  88 is($pkg->do_it, 'const', "worked as expected, const was constant");
  89 }
  90
  91 BEGIN {
  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
 107 BEGIN {
 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
 116 my $o = main::HBase::Wrapped::Inherit->new(foo => 1);
 117 my $foo = $o->foo;
 118 is($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
 131 is(Foo->new, 'foo', "Did not override existing 'new' method");
 132
 133 BEGIN {
 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
 148 my $ro = main::HBase2->new(foo => 'foo', bar => 'bar', baz => 'baz', bat => 'bat', ban => 'ban');
 149 is($ro->foo, 'foo', "got foo");
 150 is($ro->bar, 'bar', "got bar");
 151 is($ro->baz, 'baz', "got baz");
 152 is($ro->bat, 'bat', "got bat");
 153 ok(!$ro->can('set_bat'), "No setter for bat");
 154 ok(!$ro->can('ban'), "No reader for ban");
 155 ok(!$ro->can('boo'), "No reader for boo");
 156 ok(!$ro->can('set_boo'), "No setter for boo");
 157 is($ro->{ban}, 'ban', "ban attribute is set");
 158 $ro->set_ban('xxx');
 159 is($ro->{ban}, 'xxx', "ban attribute can be set");
 160
 161 is($ro->set_foo('xxx'), 'xxx', "Can set foo");
 162 is($ro->foo, 'xxx', "got foo");
 163
 164 like(exception { $ro->set_bar('xxx') }, qr/'bar' is read-only/, "Cannot set bar");
 165
 166 my $warnings = warnings { is($ro->set_baz('xxx'), 'xxx', 'set baz') };
 167 like($warnings->[0], qr/set_baz\(\) is deprecated/, "Deprecation warning");
 168
 169
 170
 171 is_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
 177 my $x = main::HBase::Wrapped::Inherit->new(foo => 1, baz => 2);
 178 is($x->foo, 1, "set foo via pairs");
 179 is($x->baz, 2, "set baz via pairs");
 180
 181 # Now with hashref
 182 my $y = main::HBase::Wrapped::Inherit->new({foo => 1, baz => 2});
 183 is($y->foo, 1, "set foo via hashref");
 184 is($y->baz, 2, "set baz via hashref");
 185
 186 # Now with hashref
 187 my $z = main::HBase::Wrapped::Inherit->new([
 188     1, # foo
 189     2, # bar
 190     3, # dup
 191     4, # baz
 192 ]);
 193 is($z->foo, 1, "set foo via arrayref");
 194 is($z->baz, 4, "set baz via arrayref");
 195
 196 like(
 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
 203 my $CAN_COUNT = 0;
 204 my $CAN_COUNT2 = 0;
 205 my $INIT_COUNT = 0;
 206 BEGIN {
 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
 232 is($CAN_COUNT, 0, "->can has not been called yet");
 233 my $it = main::HBase3->new;
 234 is($CAN_COUNT, 1, "->can has been called once to check for init");
 235 $it = main::HBase3->new;
 236 is($CAN_COUNT, 1, "->can was not called again, we cached it");
 237
 238 is($CAN_COUNT2, 0, "->can has not been called yet");
 239 is($INIT_COUNT, 0, "->init has not been called yet");
 240 $it = main::HBase4->new;
 241 is($CAN_COUNT2, 1, "->can has been called once to check for init");
 242 is($INIT_COUNT, 1, "->init has been called once");
 243 $it = main::HBase4->new;
 244 is($CAN_COUNT2, 1, "->can was not called again, we cached it");
 245 is($INIT_COUNT, 2, "->init has been called again");
 246
 247 done_testing;
 248
 249 1;