cpan/Test-Simple/lib/Test2/Util/HashBase.pm

   1 package Test2::Util::HashBase;
   2 use strict;
   3 use warnings;
   4
   5 our $VERSION = '1.302022';
   6
   7
   8 require Carp;
   9 $Carp::Internal{+__PACKAGE__} = 1;
  10
  11 my %ATTR_SUBS;
  12
  13 BEGIN {
  14     # these are not strictly equivalent, but for out use we don't care
  15     # about order
  16     *_isa = ($] >= 5.010 && require mro) ? \&mro::get_linear_isa : sub {
  17         no strict 'refs';
  18         my @packages = ($_[0]);
  19         my %seen;
  20         for my $package (@packages) {
  21             push @packages, grep !$seen{$_}++, @{"$package\::ISA"};
  22         }
  23         return \@packages;
  24     }
  25 }
  26
  27 sub import {
  28     my $class = shift;
  29     my $into = caller;
  30
  31     my $isa = _isa($into);
  32     my $attr_subs = $ATTR_SUBS{$into} ||= {};
  33     my %subs = (
  34         ($into->can('new') ? () : (new => \&_new)),
  35         (map %{ $ATTR_SUBS{$_}||{} }, @{$isa}[1 .. $#$isa]),
  36         (map {
  37             my ($sub, $attr) = (uc $_, $_);
  38             $sub => ($attr_subs->{$sub} = sub() { $attr }),
  39             $attr => sub { $_[0]->{$attr} },
  40             "set_$attr" => sub { $_[0]->{$attr} = $_[1] },
  41         } @_),
  42     );
  43
  44     no strict 'refs';
  45     *{"$into\::$_"} = $subs{$_} for keys %subs;
  46 }
  47
  48 sub _new {
  49     my ($class, %params) = @_;
  50     my $self = bless \%params, $class;
  51     $self->init if $self->can('init');
  52     $self;
  53 }
  54
  55 1;
  56
  57 __END__
  58
  59 =pod
  60
  61 =encoding UTF-8
  62
  63 =head1 NAME
  64
  65 Test2::Util::HashBase - Base class for classes that use a hashref
  66 of a hash.
  67
  68 =head1 SYNOPSIS
  69
  70 A class:
  71
  72     package My::Class;
  73     use strict;
  74     use warnings;
  75
  76     # Generate 3 accessors
  77     use Test2::Util::HashBase qw/foo bar baz/;
  78
  79     # Chance to initialize defaults
  80     sub init {
  81         my $self = shift;    # No other args
  82         $self->{+FOO} ||= "foo";
  83         $self->{+BAR} ||= "bar";
  84         $self->{+BAZ} ||= "baz";
  85     }
  86
  87     sub print {
  88         print join ", " => map { $self->{$_} } FOO, BAR, BAZ;
  89     }
  90
  91 Subclass it
  92
  93     package My::Subclass;
  94     use strict;
  95     use warnings;
  96
  97     # Note, you should subclass before loading HashBase.
  98     use base 'My::Class';
  99     use Test2::Util::HashBase qw/bat/;
 100
 101     sub init {
 102         my $self = shift;
 103
 104         # We get the constants from the base class for free.
 105         $self->{+FOO} ||= 'SubFoo';
 106         $self->{+BAT} || = 'bat';
 107
 108         $self->SUPER::init();
 109     }
 110
 111 use it:
 112
 113     package main;
 114     use strict;
 115     use warnings;
 116     use My::Class;
 117
 118     my $one = My::Class->new(foo => 'MyFoo', bar => 'MyBar');
 119
 120     # Accessors!
 121     my $foo = $one->foo;    # 'MyFoo'
 122     my $bar = $one->bar;    # 'MyBar'
 123     my $baz = $one->baz;    # Defaulted to: 'baz'
 124
 125     # Setters!
 126     $one->set_foo('A Foo');
 127     $one->set_bar('A Bar');
 128     $one->set_baz('A Baz');
 129
 130     $one->{+FOO} = 'xxx';
 131
 132 =head1 DESCRIPTION
 133
 134 This package is used to generate classes based on hashrefs. Using this class
 135 will give you a C<new()> method, as well as generating accessors you request.
 136 Generated accessors will be getters, C<set_ACCESSOR> setters will also be
 137 generated for you. You also get constants for each accessor (all caps) which
 138 return the key into the hash for that accessor. Single inheritance is also
 139 supported.
 140
 141 =head1 METHODS
 142
 143 =head2 PROVIDED BY HASH BASE
 144
 145 =over 4
 146
 147 =item $it = $class->new(@VALUES)
 148
 149 Create a new instance using key/value pairs.
 150
 151 HashBase will not export C<new()> if there is already a C<new()> method in your
 152 packages inheritance chain.
 153
 154 B<If you do not want this method you can define your own> you just have to
 155 declare it before loading L<Test2::Util::HashBase>.
 156
 157     package My::Package;
 158
 159     # predeclare new() so that HashBase does not give us one.
 160     sub new;
 161
 162     use Test2::Util::HashBase qw/foo bar baz/;
 163
 164     # Now we define our own new method.
 165     sub new { ... }
 166
 167 This makes it so that HashBase sees that you have your own C<new()> method.
 168 Alternatively you can define the method before loading HashBase instead of just
 169 declaring it, but that scatters your use statements.
 170
 171 =back
 172
 173 =head2 HOOKS
 174
 175 =over 4
 176
 177 =item $self->init()
 178
 179 This gives you the chance to set some default values to your fields. The only
 180 argument is C<$self> with its indexes already set from the constructor.
 181
 182 =back
 183
 184 =head1 ACCESSORS
 185
 186 To generate accessors you list them when using the module:
 187
 188     use Test2::Util::HashBase qw/foo/;
 189
 190 This will generate the following subs in your namespace:
 191
 192 =over 4
 193
 194 =item foo()
 195
 196 Getter, used to get the value of the C<foo> field.
 197
 198 =item set_foo()
 199
 200 Setter, used to set the value of the C<foo> field.
 201
 202 =item FOO()
 203
 204 Constant, returns the field C<foo>'s key into the class hashref. Subclasses will
 205 also get this function as a constant, not simply a method, that means it is
 206 copied into the subclass namespace.
 207
 208 The main reason for using these constants is to help avoid spelling mistakes
 209 and similar typos. It will not help you if you forget to prefix the '+' though.
 210
 211 =back
 212
 213 =head1 SUBCLASSING
 214
 215 You can subclass an existing HashBase class.
 216
 217     use base 'Another::HashBase::Class';
 218     use Test2::Util::HashBase qw/foo bar baz/;
 219
 220 The base class is added to C<@ISA> for you, and all constants from base classes
 221 are added to subclasses automatically.
 222
 223 =head1 SOURCE
 224
 225 The source code repository for Test2 can be found at
 226 F<http://github.com/Test-More/test-more/>.
 227
 228 =head1 MAINTAINERS
 229
 230 =over 4
 231
 232 =item Chad Granum E<lt>exodist@cpan.orgE<gt>
 233
 234 =back
 235
 236 =head1 AUTHORS
 237
 238 =over 4
 239
 240 =item Chad Granum E<lt>exodist@cpan.orgE<gt>
 241
 242 =back
 243
 244 =head1 COPYRIGHT
 245
 246 Copyright 2016 Chad Granum E<lt>exodist@cpan.orgE<gt>.
 247
 248 This program is free software; you can redistribute it and/or
 249 modify it under the same terms as Perl itself.
 250
 251 See F<http://dev.perl.org/licenses/>
 252
 253 =cut