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