File Coverage

blib/lib/Class/Accessor/Faster.pm
Criterion Covered Total %
statement 42 42 100.0
branch 12 14 85.7
condition 1 3 33.3
subroutine 10 10 100.0
pod 4 4 100.0
total 69 73 94.5


line stmt bran cond sub pod time code
1             package Class::Accessor::Faster;
2 3     3   188 use base 'Class::Accessor';
  3         74  
  3         52  
3 3     3   57 use strict;
  3         28  
  3         45  
4             $Class::Accessor::Faster::VERSION = '0.30';
5              
6             =head1 NAME
7            
8             Class::Accessor::Faster - Even faster, but less expandable, accessors
9            
10             =head1 SYNOPSIS
11            
12             package Foo;
13             use base qw(Class::Accessor::Faster);
14            
15             =head1 DESCRIPTION
16            
17             This is a faster but less expandable version of Class::Accessor::Fast.
18            
19             Class::Accessor's generated accessors require two method calls to accompish
20             their task (one for the accessor, another for get() or set()).
21            
22             Class::Accessor::Fast eliminates calling set()/get() and does the access itself,
23             resulting in a somewhat faster accessor.
24            
25             Class::Accessor::Faster uses an array reference underneath to be faster.
26            
27             Read the documentation for Class::Accessor for more info.
28            
29             =cut
30              
31             my %slot;
32             sub _slot {
33 26     26   240     my($class, $field) = @_;
34 26         241     my $n = $slot{$class}->{$field};
35 26 100       327     return $n if defined $n;
36 16         125     $n = keys %{$slot{$class}};
  16         156  
37 16         157     $slot{$class}->{$field} = $n;
38 16         191     return $n;
39             }
40              
41             sub new {
42 4     4 1 84     my($proto, $fields) = @_;
43 4   33     120     my($class) = ref $proto || $proto;
44 4         50     my $self = bless [], $class;
45              
46 4 100       95     $fields = {} unless defined $fields;
47 4         52     for my $k (keys %$fields) {
48 8         218         my $n = $class->_slot($k);
49 8         89         $self->[$n] = $fields->{$k};
50                 }
51 4         47     return $self;
52             }
53              
54             sub make_accessor {
55 6     6 1 57     my($class, $field) = @_;
56 6         354     my $n = $class->_slot($field);
57                 return sub {
58 10 100   10   169         return $_[0]->[$n] unless @_ > 1;
59 3         29         my $self = shift;
60 3 50       43         $self->[$n] = (@_ == 1 ? $_[0] : [@_]);
61 6         94     };
62             }
63              
64              
65             sub make_ro_accessor {
66 6     6 1 62     my($class, $field) = @_;
67 6         79     my $n = $class->_slot($field);
68                 return sub {
69 6 100   6   127         return $_[0]->[$n] unless @_ > 1;
70 1         11         my $self = shift;
71 1         11         my $caller = caller;
72 1         30         $self->_croak("'$caller' cannot alter the value of '$field' on objects of class '$class'");
73 6         187     };
74             }
75              
76              
77             sub make_wo_accessor {
78 6     6 1 59     my($class, $field) = @_;
79 6         78     my $n = $class->_slot($field);
80                 return sub {
81 4     4   348         my $self = shift;
82              
83 4 100       71         unless (@_) {
84 1         11             my $caller = caller;
85 1         75             $self->_croak("'$caller' cannot access the value of '$field' on objects of class '$class'");
86                     }
87                     else {
88 3 50       118             return $self->[$n] = (@_ == 1 ? $_[0] : [@_]);
89                     }
90 6         151     };
91             }
92              
93              
94             =head1 AUTHORS
95            
96             Copyright 2006 Marty Pauley <marty+perl@kasei.com>
97            
98             This program is free software; you can redistribute it and/or modify it under
99             the same terms as Perl itself. That means either (a) the GNU General Public
100             License or (b) the Artistic License.
101            
102             =head1 SEE ALSO
103            
104             L<Class::Accessor>
105            
106             =cut
107              
108             1;
109