File Coverage

blib/lib/Test2/Util/HashBase.pm
Criterion Covered Total %
statement 79 87 90.8
branch 29 34 85.2
condition 8 17 47.0
subroutine 15 16 93.7
pod 1 1 100.0
total 132 155 85.1


line stmt bran cond sub pod time code
1             package Test2::Util::HashBase;
2 246     246   1621 use strict;
  246         444  
  246         6756  
3 246     246   1157 use warnings;
  246         434  
  246         10882  
4              
5             our $VERSION = '1.302181';
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 246     246   1403 no warnings 'once';
  246         519  
  246         28185  
19             $Test2::Util::HashBase::HB_VERSION = '0.009';
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              
27             require Carp;
28             {
29 246     246   1804 no warnings 'once';
  246         506  
  246         21809  
30             $Carp::Internal{+__PACKAGE__} = 1;
31             }
32              
33             BEGIN {
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 246     246   1712 no strict 'refs';
  246         524  
  246         31861  
38 0         0 my @packages = ($_[0]);
39 0         0 my %seen;
40 0         0 for my $package (@packages) {
41 0         0 push @packages, grep !$seen{$_}++, @{"$package\::ISA"};
  0         0  
42             }
43 0         0 return \@packages;
44             }
45 246 50 33 246   121180 }
46              
47             my %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              
55             sub import {
56 7762     7762   20893 my $class = shift;
57 7762         16606 my $into = caller;
58              
59             # Make sure we list the OLDEST version used to create this class.
60 7762   33     21648 my $ver = $Test2::Util::HashBase::HB_VERSION || $Test2::Util::HashBase::VERSION;
61 7762 50 33     30011 $Test2::Util::HashBase::VERSION{$into} = $ver if !$Test2::Util::HashBase::VERSION{$into} || $Test2::Util::HashBase::VERSION{$into} > $ver;
62              
63 7762         36709 my $isa = _isa($into);
64 7762   50     38902 my $attr_list = $Test2::Util::HashBase::ATTR_LIST{$into} ||= [];
65 7762   50     29805 my $attr_subs = $Test2::Util::HashBase::ATTR_SUBS{$into} ||= {};
66              
67             my %subs = (
68             ($into->can('new') ? () : (new => \&_new)),
69 6832 100       44767 (map %{$Test2::Util::HashBase::ATTR_SUBS{$_} || {}}, @{$isa}[1 .. $#$isa]),
  7762         22179  
70             (
71             map {
72 7762 100       86880 my $p = substr($_, 0, 1);
  35246         68619  
73 35246         47417 my $x = $_;
74              
75 35246   100     104882 my $spec = $SPEC{$p} || {reader => 1, writer => 1};
76              
77 35246 100       74328 substr($x, 0, 1) = '' if $spec->{strip};
78 35246         69194 push @$attr_list => $x;
79 35246         76488 my ($sub, $attr) = (uc $x, $x);
80              
81 35246     0   230969 $attr_subs->{$sub} = sub() { $attr };
  0         0  
82 35246         86433 my %out = ($sub => $attr_subs->{$sub});
83              
84 35246 100   45380   138455 $out{$attr} = sub { $_[0]->{$attr} } if $spec->{reader};
  45380     45338   156601  
85 35246 100   2097   128819 $out{"set_$attr"} = sub { $_[0]->{$attr} = $_[1] } if $spec->{writer};
  2097         6084  
86 35246 100   1   110724 $out{"set_$attr"} = sub { Carp::croak("'$attr' is read-only") } if $spec->{read_only};
  1         205  
87 35246 100   1   67916 $out{"set_$attr"} = sub { Carp::carp("set_$attr() is deprecated"); $_[0]->{$attr} = $_[1] } if $spec->{dep_writer};
  1         106  
  1         46  
88              
89 35246         163183 %out;
90             } @_
91             ),
92             );
93              
94 246     246   300674 no strict 'refs';
  246         553  
  246         124409  
95 7762         44011 *{"$into\::$_"} = $subs{$_} for keys %subs;
  138842         2502496  
96             }
97              
98             sub attr_list {
99 3     3 1 13 my $class = shift;
100              
101 3         11 my $isa = _isa($class);
102              
103 3         7 my %seen;
104 15         39 my @list = grep { !$seen{$_}++ } map {
105 3         8 my @out;
  6         10  
106              
107 6 50 50     21 if (0.004 > ($Test2::Util::HashBase::VERSION{$_} || 0)) {
108 0         0 Carp::carp("$_ uses an inlined version of Test2::Util::HashBase too old to support attr_list()");
109             }
110             else {
111 6         10 my $list = $Test2::Util::HashBase::ATTR_LIST{$_};
112 6 50       18 @out = $list ? @$list : ()
113             }
114              
115 6         18 @out;
116             } reverse @$isa;
117              
118 3         17 return @list;
119             }
120              
121             sub _new {
122 6121     6121   20113 my $class = shift;
123              
124 6121         9308 my $self;
125              
126 6121 100       14041 if (@_ == 1) {
127 469         683 my $arg = shift;
128 469         775 my $type = ref($arg);
129              
130 469 100       883 if ($type eq 'HASH') {
131 467         1749 $self = bless({%$arg}, $class)
132             }
133             else {
134 2 50       8 Carp::croak("Not sure what to do with '$type' in $class constructor")
135             unless $type eq 'ARRAY';
136              
137 2         4 my %proto;
138 2         6 my @attributes = attr_list($class);
139 2         7 while (@$arg) {
140 9         11 my $val = shift @$arg;
141 9 100       121 my $key = shift @attributes or Carp::croak("Too many arguments for $class constructor");
142 8         20 $proto{$key} = $val;
143             }
144              
145 1         3 $self = bless(\%proto, $class);
146             }
147             }
148             else {
149 5652         16823 $self = bless({@_}, $class);
150             }
151              
152             $Test2::Util::HashBase::CAN_CACHE{$class} = $self->can('init')
153 6120 100       25466 unless exists $Test2::Util::HashBase::CAN_CACHE{$class};
154              
155 6120 100       27154 $self->init if $Test2::Util::HashBase::CAN_CACHE{$class};
156              
157 6105         48209 $self;
158             }
159              
160             1;
161              
162             __END__
163              
164             =pod
165              
166             =encoding UTF-8
167              
168             =head1 NAME
169              
170             Test2::Util::HashBase - Build hash based classes.
171              
172             =head1 SYNOPSIS
173              
174             A class:
175              
176             package My::Class;
177             use strict;
178             use warnings;
179              
180             # Generate 3 accessors
181             use Test2::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              
198             Subclass 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::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              
218             use 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              
255             This package is used to generate classes based on hashrefs. Using this class
256             will give you a C<new()> method, as well as generating accessors you request.
257             Generated accessors will be getters, C<set_ACCESSOR> setters will also be
258             generated for you. You also get constants for each accessor (all caps) which
259             return the key into the hash for that accessor. Single inheritance is also
260             supported.
261              
262             =head1 THIS IS A BUNDLED COPY OF HASHBASE
263              
264             This is a bundled copy of L<Object::HashBase>. This file was generated using
265             the
266             C</home/exodist/perl5/perlbrew/perls/main/bin/hashbase_inc.pl>
267             script.
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              
281             Create a new instance.
282              
283             HashBase will not export C<new()> if there is already a C<new()> method in your
284             packages inheritance chain.
285              
286             B<If you do not want this method you can define your own> you just have to
287             declare it before loading L<Test2::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::Util::HashBase qw/foo bar baz/;
295              
296             # Now we define our own new method.
297             sub new { ... }
298              
299             This makes it so that HashBase sees that you have your own C<new()> method.
300             Alternatively you can define the method before loading HashBase instead of just
301             declaring it, but that scatters your use statements.
302              
303             The most common way to create an object is to pass in key/value pairs where
304             each key is an attribute and each value is what you want assigned to that
305             attribute. No checking is done to verify the attributes or values are valid,
306             you may do that in C<init()> if desired.
307              
308             If you would like, you can pass in a hashref instead of pairs. When you do so
309             the hashref will be copied, and the copy will be returned blessed as an object.
310             There is no way to ask HashBase to bless a specific hashref.
311              
312             In some cases an object may only have 1 or 2 attributes, in which case a
313             hashref may be too verbose for your liking. In these cases you can pass in an
314             arrayref with only values. The values will be assigned to attributes in the
315             order the attributes were listed. When there is inheritance involved the
316             attributes from parent classes will come before subclasses.
317              
318             =back
319              
320             =head2 HOOKS
321              
322             =over 4
323              
324             =item $self->init()
325              
326             This gives you the chance to set some default values to your fields. The only
327             argument is C<$self> with its indexes already set from the constructor.
328              
329             B<Note:> Test2::Util::HashBase checks for an init using C<< $class->can('init') >>
330             during construction. It DOES NOT call C<can()> on the created object. Also note
331             that the result of the check is cached, it is only ever checked once, the first
332             time an instance of your class is created. This means that adding an C<init()>
333             method AFTER the first construction will result in it being ignored.
334              
335             =back
336              
337             =head1 ACCESSORS
338              
339             =head2 READ/WRITE
340              
341             To generate accessors you list them when using the module:
342              
343             use Test2::Util::HashBase qw/foo/;
344              
345             This will generate the following subs in your namespace:
346              
347             =over 4
348              
349             =item foo()
350              
351             Getter, used to get the value of the C<foo> field.
352              
353             =item set_foo()
354              
355             Setter, used to set the value of the C<foo> field.
356              
357             =item FOO()
358              
359             Constant, returns the field C<foo>'s key into the class hashref. Subclasses will
360             also get this function as a constant, not simply a method, that means it is
361             copied into the subclass namespace.
362              
363             The main reason for using these constants is to help avoid spelling mistakes
364             and 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::Util::HashBase qw/-foo/;
371              
372             =over 4
373              
374             =item set_foo()
375              
376             Throws an exception telling you the attribute is read-only. This is exported to
377             override any active setters for the attribute in a parent class.
378              
379             =back
380              
381             =head2 DEPRECATED SETTER
382              
383             use Test2::Util::HashBase qw/^foo/;
384              
385             =over 4
386              
387             =item set_foo()
388              
389             This will set the value, but it will also warn you that the method is
390             deprecated.
391              
392             =back
393              
394             =head2 NO SETTER
395              
396             use Test2::Util::HashBase qw/<foo/;
397              
398             Only gives you a reader, no C<set_foo> method is defined at all.
399              
400             =head2 NO READER
401              
402             use Test2::Util::HashBase qw/>foo/;
403              
404             Only gives you a write (C<set_foo>), no C<foo> method is defined at all.
405              
406             =head2 CONSTANT ONLY
407              
408             use Test2::Util::HashBase qw/+foo/;
409              
410             This does not create any methods for you, it just adds the C<FOO> constant.
411              
412             =head1 SUBCLASSING
413              
414             You can subclass an existing HashBase class.
415              
416             use base 'Another::HashBase::Class';
417             use Test2::Util::HashBase qw/foo bar baz/;
418              
419             The base class is added to C<@ISA> for you, and all constants from base classes
420             are added to subclasses automatically.
421              
422             =head1 GETTING A LIST OF ATTRIBUTES FOR A CLASS
423              
424             Test2::Util::HashBase provides a function for retrieving a list of attributes for an
425             Test2::Util::HashBase class.
426              
427             =over 4
428              
429             =item @list = Test2::Util::HashBase::attr_list($class)
430              
431             =item @list = $class->Test2::Util::HashBase::attr_list()
432              
433             Either form above will work. This will return a list of attributes defined on
434             the object. This list is returned in the attribute definition order, parent
435             class attributes are listed before subclass attributes. Duplicate attributes
436             will be removed before the list is returned.
437              
438             B<Note:> This list is used in the C<< $class->new(\@ARRAY) >> constructor to
439             determine the attribute to which each value will be paired.
440              
441             =back
442              
443             =head1 SOURCE
444              
445             The source code repository for HashBase can be found at
446             F<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              
466             Copyright 2017 Chad Granum E<lt>exodist@cpan.orgE<gt>.
467              
468             This program is free software; you can redistribute it and/or
469             modify it under the same terms as Perl itself.
470              
471             See F<http://dev.perl.org/licenses/>
472              
473             =cut