File Coverage

blib/lib/Class/Accessor/Lite.pm
Criterion Covered Total %
statement 81 84 96.4
branch 18 20 90.0
condition 1 3 33.3
subroutine 24 25 96.0
pod 5 6 83.3
total 129 138 93.4


line stmt bran cond sub pod time code
1             package Class::Accessor::Lite;
2              
3 4     4   2265 use strict;
  4         8  
  4         1530  
4              
5             our $VERSION = '0.08';
6              
7 3     3 0 31 sub croak {require Carp; Carp::croak(@_)}
  3         413  
8              
9             sub import {
10 5     5   35 shift;
11 5         13 my %args = @_;
12 5         10 my $pkg = caller(0);
13 5         19 my %key_ctor = (
14             rw => \&_mk_accessors,
15             ro => \&_mk_ro_accessors,
16             wo => \&_mk_wo_accessors,
17             );
18 5         31 for my $key (sort keys %key_ctor) {
19 14 100       34 if (defined $args{$key}) {
20 4 100       11 croak("value of the '$key' parameter should be an arrayref")
21             unless ref($args{$key}) eq 'ARRAY';
22 3         8 $key_ctor{$key}->($pkg, @{$args{$key}});
  3         4  
23             }
24             }
25 4 100       13 _mk_new($pkg)
26             if $args{new};
27 4         65 1;
28             }
29              
30             sub mk_new_and_accessors {
31 1     1 1 306 (undef, my @properties) = @_;
32 1         2 my $pkg = caller(0);
33 1         3 _mk_new($pkg);
34 1         2 _mk_accessors($pkg, @properties);
35             }
36              
37             sub mk_new {
38 0     0 1 0 my $pkg = caller(0);
39 0         0 _mk_new($pkg);
40             }
41              
42             sub mk_accessors {
43 1     1 1 372 (undef, my @properties) = @_;
44 1         2 my $pkg = caller(0);
45 1         2 _mk_accessors($pkg, @properties);
46             }
47              
48             sub mk_ro_accessors {
49 1     1 1 3 (undef, my @properties) = @_;
50 1         2 my $pkg = caller(0);
51 1         2 _mk_ro_accessors($pkg, @properties);
52             }
53              
54             sub mk_wo_accessors {
55 1     1 1 3 (undef, my @properties) = @_;
56 1         2 my $pkg = caller(0);
57 1         2 _mk_wo_accessors($pkg, @properties);
58             }
59              
60             sub _mk_new {
61 2     2   2 my $pkg = shift;
62 4     4   17 no strict 'refs';
  4         3  
  4         197  
63 2         2 *{$pkg . '::new'} = __m_new($pkg);
  2         6  
64             }
65              
66             sub _mk_accessors {
67 3     3   4 my $pkg = shift;
68 4     4   30 no strict 'refs';
  4         4  
  4         212  
69 3         4 for my $n (@_) {
70 7         9 *{$pkg . '::' . $n} = __m($n);
  7         32  
71             }
72             }
73              
74             sub _mk_ro_accessors {
75 2     2   2 my $pkg = shift;
76 4     4   12 no strict 'refs';
  4         4  
  4         199  
77 2         2 for my $n (@_) {
78 2         3 *{$pkg . '::' . $n} = __m_ro($pkg, $n);
  2         12  
79             }
80             }
81              
82             sub _mk_wo_accessors {
83 2     2   3 my $pkg = shift;
84 4     4   15 no strict 'refs';
  4         7  
  4         204  
85 2         2 for my $n (@_) {
86 2         3 *{$pkg . '::' . $n} = __m_wo($pkg, $n);
  2         9  
87             }
88             }
89              
90             sub __m_new {
91 2     2   2 my $pkg = shift;
92 4     4   14 no strict 'refs';
  4         4  
  4         979  
93             return sub {
94 2     2   199 my $klass = shift;
95 0         0 bless {
96 2 50 33     16 (@_ == 1 && ref($_[0]) eq 'HASH' ? %{$_[0]} : @_),
97             }, $klass;
98 2         5 };
99             }
100              
101             sub __m {
102 7     7   5 my $n = shift;
103             sub {
104 12 100   12   1246 return $_[0]->{$n} if @_ == 1;
105 3 100       12 return $_[0]->{$n} = $_[1] if @_ == 2;
106 1         7 shift->{$n} = \@_;
107 7         12 };
108             }
109              
110             sub __m_ro {
111 2     2   3 my ($pkg, $n) = @_;
112             sub {
113 3 100   3   12 if (@_ == 1) {
114 2 50       14 return $_[0]->{$n} if @_ == 1;
115             } else {
116 1         2 my $caller = caller(0);
117 1         6 croak("'$caller' cannot access the value of '$n' on objects of class '$pkg'");
118             }
119 2         5 };
120             }
121              
122             sub __m_wo {
123 2     2   2 my ($pkg, $n) = @_;
124             sub {
125 4 100   4   740 if (@_ == 1) {
126 1         1 my $caller = caller(0);
127 1         6 croak("'$caller' cannot alter the value of '$n' on objects of class '$pkg'")
128             } else {
129 3 100       15 return $_[0]->{$n} = $_[1] if @_ == 2;
130 1         7 shift->{$n} = \@_;
131             }
132 2         5 };
133             }
134              
135              
136             1;
137              
138             __END__