File Coverage

blib/lib/Test2/Util/HashBase.pm
Criterion Covered Total %
statement 42 43 97.6
branch 8 10 80.0
condition 2 2 100.0
subroutine 10 11 90.9
pod n/a
total 62 66 93.9


line stmt bran cond sub pod time code
1             package Test2::Util::HashBase;
2 54     54   168 use strict;
  54         51  
  54         1221  
3 54     54   146 use warnings;
  54         45  
  54         2095  
4              
5             our $VERSION = '0.000042';
6              
7             my %ATTRS;
8             my %META;
9              
10             sub _get_inherited_attrs {
11 54     54   179 no strict 'refs';
  54         50  
  54         14792  
12 919     919   869 my @todo = map @{"$_\::ISA"}, @_;
  919         3470  
13 919         801 my %seen;
14             my @all;
15 919         1989 while (my $pkg = shift @todo) {
16 676 50       1398 next if $seen{$pkg}++;
17 676         644 my $found = $META{$pkg};
18 676 50       2961 push @all => %$found if $found;
19              
20 676         668 my $isa = \@{"$pkg\::ISA"};
  676         1164  
21 676 100       2116 push @todo => @$isa if @$isa;
22             }
23              
24 919         10885 return \@all;
25             }
26              
27             sub _make_subs {
28 4528     4528   3701 my ($str) = @_;
29             return $ATTRS{$str} ||= {
30 0     0   0 uc($str) => sub() { $str },
31 2831     2831   9462 $str => sub { $_[0]->{$str} },
32 630     630   1113 "set_$str" => sub { $_[0]->{$str} = $_[1] },
33 4528   100     47086 };
34             }
35              
36             sub import {
37 919     919   9043 my $class = shift;
38 919         1123 my $into = caller;
39              
40 919         1226 my %attrs = map %{_make_subs($_)}, @_;
  4528         4611  
41              
42 919         5012 my @meta = map uc, @_;
43 919         2330 @{$META{$into}}{@meta} = map $attrs{$_}, @meta;
  919         3000  
44              
45             my %subs = (
46             %attrs,
47 919 100       2106 @{_get_inherited_attrs($into)},
  919         1220  
48             $into->can('new') ? () : (new => \&_new)
49             );
50              
51 54     54   204 no strict 'refs';
  54         52  
  54         5613  
52 919         3720 *{"$into\::$_"} = $subs{$_} for keys %subs;
  17807         306688  
53             }
54              
55             sub _new {
56 925     925   4451 my ($class, %params) = @_;
57 925         1200 my $self = bless \%params, $class;
58 925 100       4584 $self->init if $self->can('init');
59 916         4633 $self;
60             }
61              
62             1;
63              
64             __END__