File Coverage

blib/lib/Term/Table/HashBase.pm
Criterion Covered Total %
statement 79 87 90.8
branch 28 34 82.3
condition 8 17 47.0
subroutine 14 15 93.3
pod 1 1 100.0
total 130 154 84.4


line stmt bran cond sub pod time code
1             package Term::Table::HashBase;
2 7     7   80635 use strict;
  7         30  
  7         196  
3 7     7   35 use warnings;
  7         15  
  7         334  
4              
5             our $VERSION = '0.015';
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 7     7   35 no warnings 'once';
  7         13  
  7         715  
19             $Term::Table::HashBase::HB_VERSION = '0.008';
20             *Term::Table::HashBase::ATTR_SUBS = \%Object::HashBase::ATTR_SUBS;
21             *Term::Table::HashBase::ATTR_LIST = \%Object::HashBase::ATTR_LIST;
22             *Term::Table::HashBase::VERSION = \%Object::HashBase::VERSION;
23             *Term::Table::HashBase::CAN_CACHE = \%Object::HashBase::CAN_CACHE;
24             }
25              
26              
27             require Carp;
28             {
29 7     7   50 no warnings 'once';
  7         13  
  7         527  
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 7     7   44 no strict 'refs';
  7         18  
  7         847  
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 7 50 33 7   3315 }
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 25     25   8170 my $class = shift;
57 25         51 my $into = caller;
58              
59             # Make sure we list the OLDEST version used to create this class.
60 25   33     68 my $ver = $Term::Table::HashBase::HB_VERSION || $Term::Table::HashBase::VERSION;
61 25 50 33     105 $Term::Table::HashBase::VERSION{$into} = $ver if !$Term::Table::HashBase::VERSION{$into} || $Term::Table::HashBase::VERSION{$into} > $ver;
62              
63 25         138 my $isa = _isa($into);
64 25   50     119 my $attr_list = $Term::Table::HashBase::ATTR_LIST{$into} ||= [];
65 25   50     103 my $attr_subs = $Term::Table::HashBase::ATTR_SUBS{$into} ||= {};
66              
67             my %subs = (
68             ($into->can('new') ? () : (new => \&_new)),
69 2 50       10 (map %{$Term::Table::HashBase::ATTR_SUBS{$_} || {}}, @{$isa}[1 .. $#$isa]),
  25         72  
70             (
71             map {
72 25 100       221 my $p = substr($_, 0, 1);
  142         252  
73 142         170 my $x = $_;
74              
75 142   100     464 my $spec = $SPEC{$p} || {reader => 1, writer => 1};
76              
77 142 100       252 substr($x, 0, 1) = '' if $spec->{strip};
78 142         226 push @$attr_list => $x;
79 142         252 my ($sub, $attr) = (uc $x, $x);
80              
81 142     0   820 $attr_subs->{$sub} = sub() { $attr };
  0         0  
82 142         300 my %out = ($sub => $attr_subs->{$sub});
83              
84 142 100   1263   473 $out{$attr} = sub { $_[0]->{$attr} } if $spec->{reader};
  1263         4315  
85 142 100   8   551 $out{"set_$attr"} = sub { $_[0]->{$attr} = $_[1] } if $spec->{writer};
  8         41  
86 142 100   1   267 $out{"set_$attr"} = sub { Carp::croak("'$attr' is read-only") } if $spec->{read_only};
  1         141  
87 142 100   1   212 $out{"set_$attr"} = sub { Carp::carp("set_$attr() is deprecated"); $_[0]->{$attr} = $_[1] } if $spec->{dep_writer};
  1         623  
  1         37  
88              
89 142         560 %out;
90             } @_
91             ),
92             );
93              
94 7     7   2258 no strict 'refs';
  7         14  
  7         3122  
95 25         160 *{"$into\::$_"} = $subs{$_} for keys %subs;
  449         11199  
96             }
97              
98             sub attr_list {
99 3     3 1 905 my $class = shift;
100              
101 3         10 my $isa = _isa($class);
102              
103 3         3 my %seen;
104 15         30 my @list = grep { !$seen{$_}++ } map {
105 3         7 my @out;
  6         9  
106              
107 6 50 50     16 if (0.004 > ($Term::Table::HashBase::VERSION{$_} || 0)) {
108 0         0 Carp::carp("$_ uses an inlined version of Term::Table::HashBase too old to support attr_list()");
109             }
110             else {
111 6         12 my $list = $Term::Table::HashBase::ATTR_LIST{$_};
112 6 50       12 @out = $list ? @$list : ()
113             }
114              
115 6         16 @out;
116             } reverse @$isa;
117              
118 3         13 return @list;
119             }
120              
121             sub _new {
122 307     307   58474 my $class = shift;
123              
124 307         426 my $self;
125              
126 307 100       584 if (@_ == 1) {
127 3         4 my $arg = shift;
128 3         5 my $type = ref($arg);
129              
130 3 100       7 if ($type eq 'HASH') {
131 1         4 $self = bless({%$arg}, $class)
132             }
133             else {
134 2 50       7 Carp::croak("Not sure what to do with '$type' in $class constructor")
135             unless $type eq 'ARRAY';
136              
137 2         2 my %proto;
138 2         4 my @attributes = attr_list($class);
139 2         4 while (@$arg) {
140 9         13 my $val = shift @$arg;
141 9 100       106 my $key = shift @attributes or Carp::croak("Too many arguments for $class constructor");
142 8         15 $proto{$key} = $val;
143             }
144              
145 1         3 $self = bless(\%proto, $class);
146             }
147             }
148             else {
149 304         776 $self = bless({@_}, $class);
150             }
151              
152             $Term::Table::HashBase::CAN_CACHE{$class} = $self->can('init')
153 306 100       759 unless exists $Term::Table::HashBase::CAN_CACHE{$class};
154              
155 306 100       1102 $self->init if $Term::Table::HashBase::CAN_CACHE{$class};
156              
157 306         852 $self;
158             }
159              
160             1;
161              
162             __END__