Generate HashBase form Object::Hashbase

This also fixes #743
Test-More · Dec 9, 2016 · ecf7612 · ecf7612
1 parent 28b527d
commit ecf7612
Show file tree

Hide file tree

Showing 3 changed files with 127 additions and 38 deletions.
diff --git a/Changes b/Changes
@@ -1,5 +1,6 @@
 {{$NEXT}}
 
+    - Generate HashBase from Object::HashBase whcih has been split out
     - When a subtest is marked as todo, all of its contained Ok and Subtest
       events are now updated so that they return true for
       $e->effective_pass. Implemented by Dave Rolsky. (#742)

diff --git a/lib/Test2/Util/HashBase.pm b/lib/Test2/Util/HashBase.pm
@@ -2,13 +2,26 @@ package Test2::Util::HashBase;
 use strict;
 use warnings;
 
-our $VERSION = '1.302069';
+#################################################################
+#                                                               #
+#  This is a generated file! Do not modify this file directly!  #
+#  Use hashbase_inc.pl script to regenerate this file.          #
+#  The script is part of the Object::HashBase distribution.     #
+#                                                               #
+#################################################################
+
+{
+    no warnings 'once';
+    $Test2::Util::HashBase::VERSION = '0.002';
+    *Test2::Util::HashBase::ATTR_SUBS = \%Object::HashBase::ATTR_SUBS;
+}
 
 
 require Carp;
-$Carp::Internal{+__PACKAGE__} = 1;
-
-my %ATTR_SUBS;
+{
+    no warnings 'once';
+    $Carp::Internal{+__PACKAGE__} = 1;
+}
 
 BEGIN {
     # these are not strictly equivalent, but for out use we don't care
@@ -24,21 +37,33 @@ BEGIN {
     }
 }
 
+my %STRIP = (
+    '^' => 1,
+    '-' => 1,
+);
+
 sub import {
     my $class = shift;
-    my $into = caller;
+    my $into  = caller;
 
-    my $isa = _isa($into);
-    my $attr_subs = $ATTR_SUBS{$into} ||= {};
-    my %subs = (
+    my $isa       = _isa($into);
+    my $attr_subs = $Test2::Util::HashBase::ATTR_SUBS{$into} ||= {};
+    my %subs      = (
         ($into->can('new') ? () : (new => \&_new)),
-        (map %{ $ATTR_SUBS{$_}||{} }, @{$isa}[1 .. $#$isa]),
-        (map {
-            my ($sub, $attr) = (uc $_, $_);
-            $sub => ($attr_subs->{$sub} = sub() { $attr }),
-            $attr => sub { $_[0]->{$attr} },
-            "set_$attr" => sub { $_[0]->{$attr} = $_[1] },
-        } @_),
+        (map %{$Test2::Util::HashBase::ATTR_SUBS{$_} || {}}, @{$isa}[1 .. $#$isa]),
+        (
+            map {
+                my $p = substr($_, 0, 1);
+                my $x = $_;
+                substr($x, 0, 1) = '' if $STRIP{$p};
+                my ($sub, $attr) = (uc $x, $x);
+                $sub => ($attr_subs->{$sub} = sub() { $attr }),
+                $attr => sub { $_[0]->{$attr} },
+                  $p eq '-' ? ("set_$attr" => sub { Carp::croak("'$attr' is read-only") })
+                : $p eq '^' ? ("set_$attr" => sub { Carp::carp("set_$attr() is deprecated"); $_[0]->{$attr} = $_[1] })
+                :             ("set_$attr" => sub { $_[0]->{$attr} = $_[1] }),
+            } @_
+        ),
     );
 
     no strict 'refs';
@@ -62,8 +87,7 @@ __END__
 
 =head1 NAME
 
-Test2::Util::HashBase - Base class for classes that use a hashref
-of a hash.
+Test2::Util::HashBase - Build hash based classes.
 
 =head1 SYNOPSIS
 
@@ -74,7 +98,7 @@ A class:
     use warnings;
 
     # Generate 3 accessors
-    use Test2::Util::HashBase qw/foo bar baz/;
+    use Test2::Util::HashBase qw/foo -bar ^baz/;
 
     # Chance to initialize defaults
     sub init {
@@ -103,7 +127,7 @@ Subclass it
 
         # We get the constants from the base class for free.
         $self->{+FOO} ||= 'SubFoo';
-        $self->{+BAT} || = 'bat';
+        $self->{+BAT} ||= 'bat';
 
         $self->SUPER::init();
     }
@@ -124,7 +148,12 @@ use it:
 
     # Setters!
     $one->set_foo('A Foo');
-    $one->set_bar('A Bar');
+
+    #'-bar' means read-only, so the setter will throw an exception (but is defined).
+    $one->set_bar('A bar');
+
+    # '^baz' means deprecated setter, this will warn about the setter being
+    # deprecated.
     $one->set_baz('A Baz');
 
     $one->{+FOO} = 'xxx';
@@ -138,6 +167,13 @@ generated for you. You also get constants for each accessor (all caps) which
 return the key into the hash for that accessor. Single inheritance is also
 supported.
 
+=head1 THIS IS A BUNDLED COPY OF HASHBASE
+
+This is a bundled copy of L<Object::HashBase>. This file was generated using
+the
+C</home/exodist/perl5/perlbrew/perls/main/bin/hashbase_inc.pl>
+script.
+
 =head1 METHODS
 
 =head2 PROVIDED BY HASH BASE
@@ -222,8 +258,8 @@ are added to subclasses automatically.
 
 =head1 SOURCE
 
-The source code repository for Test2 can be found at
-F<http://github.com/Test-More/test-more/>.
+The source code repository for HashBase can be found at
+F<http://github.com/Test-More/HashBase/>.
 
 =head1 MAINTAINERS
 

diff --git a/t/Test2/modules/Util/HashBase.t b/t/Test2/modules/Util/HashBase.t
@@ -1,10 +1,30 @@
 use strict;
 use warnings;
-BEGIN { require "t/tools.pl" };
+
+use Test::More;
+
+
+sub warnings(&) {
+    my $code = shift;
+    my @warnings;
+    local $SIG{__WARN__} = sub { push @warnings => @_ };
+    $code->();
+    return \@warnings;
+}
+
+sub exception(&) {
+    my $code = shift;
+    local ($@, $!, $SIG{__DIE__});
+    my $ok = eval { $code->(); 1 };
+    my $error = $@ || 'SQUASHED ERROR';
+    return $ok ? undef : $error;
+}
+
 BEGIN {
-    $INC{'My/HBase.pm'} = __FILE__;
+    $INC{'Object/HashBase/Test/HBase.pm'} = __FILE__;
 
-    package My::HBase;
+    package
+        main::HBase;
     use Test2::Util::HashBase qw/foo bar baz/;
 
     main::is(FOO, 'foo', "FOO CONSTANT");
@@ -13,8 +33,9 @@ BEGIN {
 }
 
 BEGIN {
-    package My::HBaseSub;
-    use base 'My::HBase';
+    package
+        main::HBaseSub;
+    use base 'main::HBase';
     use Test2::Util::HashBase qw/apple pear/;
 
     main::is(FOO,   'foo',   "FOO CONSTANT");
@@ -24,7 +45,7 @@ BEGIN {
     main::is(PEAR,  'pear',  "PEAR CONSTANT");
 }
 
-my $one = My::HBase->new(foo => 'a', bar => 'b', baz => 'c');
+my $one = main::HBase->new(foo => 'a', bar => 'b', baz => 'c');
 is($one->foo, 'a', "Accessor");
 is($one->bar, 'b', "Accessor");
 is($one->baz, 'c', "Accessor");
@@ -43,7 +64,8 @@ is_deeply(
 );
 
 BEGIN {
-    package My::Const::Test;
+    package
+        main::Const::Test;
     use Test2::Util::HashBase qw/foo/;
 
     sub do_it {
@@ -54,19 +76,20 @@ BEGIN {
     }
 }
 
-my $pkg = 'My::Const::Test';
+my $pkg = 'main::Const::Test';
 is($pkg->do_it, 'const', "worked as expected");
 {
     local $SIG{__WARN__} = sub { };
-    *My::Const::Test::FOO = sub { 0 };
+    *main::Const::Test::FOO = sub { 0 };
 }
 ok(!$pkg->FOO, "overrode const sub");
 is($pkg->do_it, 'const', "worked as expected, const was constant");
 
 BEGIN {
-    $INC{'My/HBase/Wrapped.pm'} = __FILE__;
+    $INC{'Object/HashBase/Test/HBase/Wrapped.pm'} = __FILE__;
 
-    package My::HBase::Wrapped;
+    package
+        main::HBase::Wrapped;
     use Test2::Util::HashBase qw/foo bar/;
 
     my $foo = __PACKAGE__->can('foo');
@@ -79,19 +102,21 @@ BEGIN {
 }
 
 BEGIN {
-    $INC{'My/HBase/Wrapped/Inherit.pm'} = __FILE__;
+    $INC{'Object/HashBase/Test/HBase/Wrapped/Inherit.pm'} = __FILE__;
 
-    package My::HBase::Wrapped::Inherit;
-    use base 'My::HBase::Wrapped';
+    package
+        main::HBase::Wrapped::Inherit;
+    use base 'main::HBase::Wrapped';
     use Test2::Util::HashBase;
 }
 
-my $o = My::HBase::Wrapped::Inherit->new(foo => 1);
+my $o = main::HBase::Wrapped::Inherit->new(foo => 1);
 my $foo = $o->foo;
 is($o->bar, 1, 'parent attribute sub not overridden');
 
 {
-    package Foo;
+    package
+        Foo;
 
     sub new;
 
@@ -102,4 +127,31 @@ is($o->bar, 1, 'parent attribute sub not overridden');
 
 is(Foo->new, 'foo', "Did not override existing 'new' method");
 
+BEGIN {
+    $INC{'Object/HashBase/Test/HBase2.pm'} = __FILE__;
+
+    package
+        main::HBase2;
+    use Test2::Util::HashBase qw/foo -bar ^baz/;
+
+    main::is(FOO, 'foo', "FOO CONSTANT");
+    main::is(BAR, 'bar', "BAR CONSTANT");
+    main::is(BAZ, 'baz', "BAZ CONSTANT");
+}
+
+my $ro = main::HBase2->new(foo => 'foo', bar => 'bar', baz => 'baz');
+is($ro->foo, 'foo', "got foo");
+is($ro->bar, 'bar', "got bar");
+is($ro->baz, 'baz', "got baz");
+
+is($ro->set_foo('xxx'), 'xxx', "Can set foo");
+is($ro->foo, 'xxx', "got foo");
+
+like(exception { $ro->set_bar('xxx') }, qr/'bar' is read-only/, "Cannot set bar");
+
+my $warnings = warnings { is($ro->set_baz('xxx'), 'xxx', 'set baz') };
+like($warnings->[0], qr/set_baz\(\) is deprecated/, "Deprecation warning");
+
 done_testing;
+
+1;