1package Test2::Util::HashBase;
2use strict;
3use warnings;
4
5our $VERSION = '1.302162';
6
7#################################################################
8#                                                               #
9#  This is a generated file! Do not modify this file directly!  #
10#  Use hashbase_inc.pl script to regenerate this file.          #
11#  The script is part of the Object::HashBase distribution.     #
12#  Note: You can modify the version number above this comment   #
13#  if needed, that is fine.                                     #
14#                                                               #
15#################################################################
16
17{
18    no warnings 'once';
19    $Test2::Util::HashBase::HB_VERSION = '0.006';
20    *Test2::Util::HashBase::ATTR_SUBS = \%Object::HashBase::ATTR_SUBS;
21    *Test2::Util::HashBase::ATTR_LIST = \%Object::HashBase::ATTR_LIST;
22    *Test2::Util::HashBase::VERSION   = \%Object::HashBase::VERSION;
23    *Test2::Util::HashBase::CAN_CACHE = \%Object::HashBase::CAN_CACHE;
24}
25
26
27require Carp;
28{
29    no warnings 'once';
30    $Carp::Internal{+__PACKAGE__} = 1;
31}
32
33BEGIN {
34    # these are not strictly equivalent, but for out use we don't care
35    # about order
36    *_isa = ($] >= 5.010 && require mro) ? \&mro::get_linear_isa : sub {
37        no strict 'refs';
38        my @packages = ($_[0]);
39        my %seen;
40        for my $package (@packages) {
41            push @packages, grep !$seen{$_}++, @{"$package\::ISA"};
42        }
43        return \@packages;
44    }
45}
46
47my %STRIP = (
48    '^' => 1,
49    '-' => 1,
50);
51
52sub import {
53    my $class = shift;
54    my $into  = caller;
55
56    # Make sure we list the OLDEST version used to create this class.
57    my $ver = $Test2::Util::HashBase::HB_VERSION || $Test2::Util::HashBase::VERSION;
58    $Test2::Util::HashBase::VERSION{$into} = $ver if !$Test2::Util::HashBase::VERSION{$into} || $Test2::Util::HashBase::VERSION{$into} > $ver;
59
60    my $isa = _isa($into);
61    my $attr_list = $Test2::Util::HashBase::ATTR_LIST{$into} ||= [];
62    my $attr_subs = $Test2::Util::HashBase::ATTR_SUBS{$into} ||= {};
63
64    my %subs = (
65        ($into->can('new') ? () : (new => \&_new)),
66        (map %{$Test2::Util::HashBase::ATTR_SUBS{$_} || {}}, @{$isa}[1 .. $#$isa]),
67        (
68            map {
69                my $p = substr($_, 0, 1);
70                my $x = $_;
71                substr($x, 0, 1) = '' if $STRIP{$p};
72                push @$attr_list => $x;
73                my ($sub, $attr) = (uc $x, $x);
74                $sub => ($attr_subs->{$sub} = sub() { $attr }),
75                    $attr => sub { $_[0]->{$attr} },
76                      $p eq '-' ? ("set_$attr" => sub { Carp::croak("'$attr' is read-only") })
77                    : $p eq '^' ? ("set_$attr" => sub { Carp::carp("set_$attr() is deprecated"); $_[0]->{$attr} = $_[1] })
78                    : ("set_$attr" => sub { $_[0]->{$attr} = $_[1] }),
79            } @_
80        ),
81    );
82
83    no strict 'refs';
84    *{"$into\::$_"} = $subs{$_} for keys %subs;
85}
86
87sub attr_list {
88    my $class = shift;
89
90    my $isa = _isa($class);
91
92    my %seen;
93    my @list = grep { !$seen{$_}++ } map {
94        my @out;
95
96        if (0.004 > ($Test2::Util::HashBase::VERSION{$_} || 0)) {
97            Carp::carp("$_ uses an inlined version of Test2::Util::HashBase too old to support attr_list()");
98        }
99        else {
100            my $list = $Test2::Util::HashBase::ATTR_LIST{$_};
101            @out = $list ? @$list : ()
102        }
103
104        @out;
105    } reverse @$isa;
106
107    return @list;
108}
109
110sub _new {
111    my $class = shift;
112
113    my $self;
114
115    if (@_ == 1) {
116        my $arg = shift;
117        my $type = ref($arg);
118
119        if ($type eq 'HASH') {
120            $self = bless({%$arg}, $class)
121        }
122        else {
123            Carp::croak("Not sure what to do with '$type' in $class constructor")
124                unless $type eq 'ARRAY';
125
126            my %proto;
127            my @attributes = attr_list($class);
128            while (@$arg) {
129                my $val = shift @$arg;
130                my $key = shift @attributes or Carp::croak("Too many arguments for $class constructor");
131                $proto{$key} = $val;
132            }
133
134            $self = bless(\%proto, $class);
135        }
136    }
137    else {
138        $self = bless({@_}, $class);
139    }
140
141    $Test2::Util::HashBase::CAN_CACHE{$class} = $self->can('init')
142        unless exists $Test2::Util::HashBase::CAN_CACHE{$class};
143
144    $self->init if $Test2::Util::HashBase::CAN_CACHE{$class};
145
146    $self;
147}
148
1491;
150
151__END__
152
153=pod
154
155=encoding UTF-8
156
157=head1 NAME
158
159Test2::Util::HashBase - Build hash based classes.
160
161=head1 SYNOPSIS
162
163A class:
164
165    package My::Class;
166    use strict;
167    use warnings;
168
169    # Generate 3 accessors
170    use Test2::Util::HashBase qw/foo -bar ^baz/;
171
172    # Chance to initialize defaults
173    sub init {
174        my $self = shift;    # No other args
175        $self->{+FOO} ||= "foo";
176        $self->{+BAR} ||= "bar";
177        $self->{+BAZ} ||= "baz";
178    }
179
180    sub print {
181        print join ", " => map { $self->{$_} } FOO, BAR, BAZ;
182    }
183
184Subclass it
185
186    package My::Subclass;
187    use strict;
188    use warnings;
189
190    # Note, you should subclass before loading HashBase.
191    use base 'My::Class';
192    use Test2::Util::HashBase qw/bat/;
193
194    sub init {
195        my $self = shift;
196
197        # We get the constants from the base class for free.
198        $self->{+FOO} ||= 'SubFoo';
199        $self->{+BAT} ||= 'bat';
200
201        $self->SUPER::init();
202    }
203
204use it:
205
206    package main;
207    use strict;
208    use warnings;
209    use My::Class;
210
211    # These are all functionally identical
212    my $one   = My::Class->new(foo => 'MyFoo', bar => 'MyBar');
213    my $two   = My::Class->new({foo => 'MyFoo', bar => 'MyBar'});
214    my $three = My::Class->new(['MyFoo', 'MyBar']);
215
216    # Accessors!
217    my $foo = $one->foo;    # 'MyFoo'
218    my $bar = $one->bar;    # 'MyBar'
219    my $baz = $one->baz;    # Defaulted to: 'baz'
220
221    # Setters!
222    $one->set_foo('A Foo');
223
224    #'-bar' means read-only, so the setter will throw an exception (but is defined).
225    $one->set_bar('A bar');
226
227    # '^baz' means deprecated setter, this will warn about the setter being
228    # deprecated.
229    $one->set_baz('A Baz');
230
231    $one->{+FOO} = 'xxx';
232
233=head1 DESCRIPTION
234
235This package is used to generate classes based on hashrefs. Using this class
236will give you a C<new()> method, as well as generating accessors you request.
237Generated accessors will be getters, C<set_ACCESSOR> setters will also be
238generated for you. You also get constants for each accessor (all caps) which
239return the key into the hash for that accessor. Single inheritance is also
240supported.
241
242=head1 THIS IS A BUNDLED COPY OF HASHBASE
243
244This is a bundled copy of L<Object::HashBase>. This file was generated using
245the
246C</home/exodist/perl5/perlbrew/perls/main/bin/hashbase_inc.pl>
247script.
248
249=head1 METHODS
250
251=head2 PROVIDED BY HASH BASE
252
253=over 4
254
255=item $it = $class->new(%PAIRS)
256
257=item $it = $class->new(\%PAIRS)
258
259=item $it = $class->new(\@ORDERED_VALUES)
260
261Create a new instance.
262
263HashBase will not export C<new()> if there is already a C<new()> method in your
264packages inheritance chain.
265
266B<If you do not want this method you can define your own> you just have to
267declare it before loading L<Test2::Util::HashBase>.
268
269    package My::Package;
270
271    # predeclare new() so that HashBase does not give us one.
272    sub new;
273
274    use Test2::Util::HashBase qw/foo bar baz/;
275
276    # Now we define our own new method.
277    sub new { ... }
278
279This makes it so that HashBase sees that you have your own C<new()> method.
280Alternatively you can define the method before loading HashBase instead of just
281declaring it, but that scatters your use statements.
282
283The most common way to create an object is to pass in key/value pairs where
284each key is an attribute and each value is what you want assigned to that
285attribute. No checking is done to verify the attributes or values are valid,
286you may do that in C<init()> if desired.
287
288If you would like, you can pass in a hashref instead of pairs. When you do so
289the hashref will be copied, and the copy will be returned blessed as an object.
290There is no way to ask HashBase to bless a specific hashref.
291
292In some cases an object may only have 1 or 2 attributes, in which case a
293hashref may be too verbose for your liking. In these cases you can pass in an
294arrayref with only values. The values will be assigned to attributes in the
295order the attributes were listed. When there is inheritance involved the
296attributes from parent classes will come before subclasses.
297
298=back
299
300=head2 HOOKS
301
302=over 4
303
304=item $self->init()
305
306This gives you the chance to set some default values to your fields. The only
307argument is C<$self> with its indexes already set from the constructor.
308
309B<Note:> Test2::Util::HashBase checks for an init using C<< $class->can('init') >>
310during construction. It DOES NOT call C<can()> on the created object. Also note
311that the result of the check is cached, it is only ever checked once, the first
312time an instance of your class is created. This means that adding an C<init()>
313method AFTER the first construction will result in it being ignored.
314
315=back
316
317=head1 ACCESSORS
318
319=head2 READ/WRITE
320
321To generate accessors you list them when using the module:
322
323    use Test2::Util::HashBase qw/foo/;
324
325This will generate the following subs in your namespace:
326
327=over 4
328
329=item foo()
330
331Getter, used to get the value of the C<foo> field.
332
333=item set_foo()
334
335Setter, used to set the value of the C<foo> field.
336
337=item FOO()
338
339Constant, returns the field C<foo>'s key into the class hashref. Subclasses will
340also get this function as a constant, not simply a method, that means it is
341copied into the subclass namespace.
342
343The main reason for using these constants is to help avoid spelling mistakes
344and similar typos. It will not help you if you forget to prefix the '+' though.
345
346=back
347
348=head2 READ ONLY
349
350    use Test2::Util::HashBase qw/-foo/;
351
352=over 4
353
354=item set_foo()
355
356Throws an exception telling you the attribute is read-only. This is exported to
357override any active setters for the attribute in a parent class.
358
359=back
360
361=head2 DEPRECATED SETTER
362
363    use Test2::Util::HashBase qw/^foo/;
364
365=over 4
366
367=item set_foo()
368
369This will set the value, but it will also warn you that the method is
370deprecated.
371
372=back
373
374=head1 SUBCLASSING
375
376You can subclass an existing HashBase class.
377
378    use base 'Another::HashBase::Class';
379    use Test2::Util::HashBase qw/foo bar baz/;
380
381The base class is added to C<@ISA> for you, and all constants from base classes
382are added to subclasses automatically.
383
384=head1 GETTING A LIST OF ATTRIBUTES FOR A CLASS
385
386Test2::Util::HashBase provides a function for retrieving a list of attributes for an
387Test2::Util::HashBase class.
388
389=over 4
390
391=item @list = Test2::Util::HashBase::attr_list($class)
392
393=item @list = $class->Test2::Util::HashBase::attr_list()
394
395Either form above will work. This will return a list of attributes defined on
396the object. This list is returned in the attribute definition order, parent
397class attributes are listed before subclass attributes. Duplicate attributes
398will be removed before the list is returned.
399
400B<Note:> This list is used in the C<< $class->new(\@ARRAY) >> constructor to
401determine the attribute to which each value will be paired.
402
403=back
404
405=head1 SOURCE
406
407The source code repository for HashBase can be found at
408F<http://github.com/Test-More/HashBase/>.
409
410=head1 MAINTAINERS
411
412=over 4
413
414=item Chad Granum E<lt>exodist@cpan.orgE<gt>
415
416=back
417
418=head1 AUTHORS
419
420=over 4
421
422=item Chad Granum E<lt>exodist@cpan.orgE<gt>
423
424=back
425
426=head1 COPYRIGHT
427
428Copyright 2019 Chad Granum E<lt>exodist@cpan.orgE<gt>.
429
430This program is free software; you can redistribute it and/or
431modify it under the same terms as Perl itself.
432
433See F<http://dev.perl.org/licenses/>
434
435=cut
436