]>
Commit | Line | Data |
---|---|---|
83d20a45 CS |
1 | package Class::Accessor::Faster; |
2 | use base 'Class::Accessor'; | |
3 | use strict; | |
4 | $Class::Accessor::Faster::VERSION = '0.31'; | |
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 | my($class, $field) = @_; | |
34 | my $n = $slot{$class}->{$field}; | |
35 | return $n if defined $n; | |
36 | $n = keys %{$slot{$class}}; | |
37 | $slot{$class}->{$field} = $n; | |
38 | return $n; | |
39 | } | |
40 | ||
41 | sub new { | |
42 | my($proto, $fields) = @_; | |
43 | my($class) = ref $proto || $proto; | |
44 | my $self = bless [], $class; | |
45 | ||
46 | $fields = {} unless defined $fields; | |
47 | for my $k (keys %$fields) { | |
48 | my $n = $class->_slot($k); | |
49 | $self->[$n] = $fields->{$k}; | |
50 | } | |
51 | return $self; | |
52 | } | |
53 | ||
54 | sub make_accessor { | |
55 | my($class, $field) = @_; | |
56 | my $n = $class->_slot($field); | |
57 | return sub { | |
58 | return $_[0]->[$n] if @_ == 1; | |
59 | return $_[0]->[$n] = $_[1] if @_ == 2; | |
60 | return (shift)->[$n] = \@_; | |
61 | }; | |
62 | } | |
63 | ||
64 | ||
65 | sub make_ro_accessor { | |
66 | my($class, $field) = @_; | |
67 | my $n = $class->_slot($field); | |
68 | return sub { | |
69 | return $_[0]->[$n] if @_ == 1; | |
70 | my $caller = caller; | |
71 | $_[0]->_croak("'$caller' cannot alter the value of '$field' on objects of class '$class'"); | |
72 | }; | |
73 | } | |
74 | ||
75 | ||
76 | sub make_wo_accessor { | |
77 | my($class, $field) = @_; | |
78 | my $n = $class->_slot($field); | |
79 | return sub { | |
80 | if (@_ == 1) { | |
81 | my $caller = caller; | |
82 | $_[0]->_croak("'$caller' cannot access the value of '$field' on objects of class '$class'"); | |
83 | } else { | |
84 | return $_[0]->[$n] = $_[1] if @_ == 2; | |
85 | return (shift)->[$n] = \@_; | |
86 | } | |
87 | }; | |
88 | } | |
89 | ||
90 | ||
91 | =head1 AUTHORS | |
92 | ||
93 | Copyright 2007 Marty Pauley <marty+perl@kasei.com> | |
94 | ||
95 | This program is free software; you can redistribute it and/or modify it under | |
96 | the same terms as Perl itself. That means either (a) the GNU General Public | |
97 | License or (b) the Artistic License. | |
98 | ||
99 | =head1 SEE ALSO | |
100 | ||
101 | L<Class::Accessor> | |
102 | ||
103 | =cut | |
104 | ||
105 | 1; |