File Coverage

blib/lib/DBI/Util/_accessor.pm
Criterion Covered Total %
statement 37 39 94.8
branch 7 14 50.0
condition 6 13 46.1
subroutine 10 10 100.0
pod 0 5 0.0
total 60 81 74.0


line stmt bran cond sub pod time code
1             package DBI::Util::_accessor;
2 56     56   435 use strict;
  56         117  
  56         1513  
3 56     56   272 use Carp;
  56         109  
  56         13819  
4             our $VERSION = "0.009479";
5              
6             # inspired by Class::Accessor::Fast
7              
8             sub new {
9 7225     7225 0 16331 my($proto, $fields) = @_;
10 7225   33     26222 my($class) = ref $proto || $proto;
11 7225   50     15503 $fields ||= {};
12              
13 7225   33     29050 my @dubious = grep { !m/^_/ && !$proto->can($_) } keys %$fields;
  40378         204137  
14 7225 50       19993 carp "$class doesn't have accessors for fields: @dubious" if @dubious;
15              
16             # make a (shallow) copy of $fields.
17 7225         46528 bless {%$fields}, $class;
18             }
19              
20             sub mk_accessors {
21 352     352 0 1508 my($self, @fields) = @_;
22 352         2176 $self->mk_accessors_using('make_accessor', @fields);
23             }
24              
25             sub mk_accessors_using {
26 520     520 0 1574 my($self, $maker, @fields) = @_;
27 520   33     2316 my $class = ref $self || $self;
28              
29             # So we don't have to do lots of lookups inside the loop.
30 520 50       4397 $maker = $self->can($maker) unless ref $maker;
31              
32 56     56   463 no strict 'refs';
  56         115  
  56         14849  
33 520         1348 foreach my $field (@fields) {
34 2880         4805 my $accessor = $self->$maker($field);
35 2880         9795 *{$class."\:\:$field"} = $accessor
36 2880 50       4077 unless defined &{$class."\:\:$field"};
  2880         11622  
37             }
38             #my $hash_ref = \%{$class."\:\:_accessors_hash};
39             #$hash_ref->{$_}++ for @fields;
40             # XXX also copy down _accessors_hash of base class(es)
41             # so one in this class is complete
42 520         1679 return;
43             }
44              
45             sub make_accessor {
46 2712     2712 0 4308 my($class, $field) = @_;
47             return sub {
48 262098     262098   398232 my $self = shift;
49 262098 100       926769 return $self->{$field} unless @_;
50 41325 50       80465 croak "Too many arguments to $field" if @_ > 1;
51 41325         199255 return $self->{$field} = shift;
52 2712         9144 };
53             }
54              
55             sub make_accessor_autoviv_hashref {
56 168     168 0 429 my($class, $field) = @_;
57             return sub {
58 200     200   2357 my $self = shift;
59 200 50 100     759 return $self->{$field} ||= {} unless @_;
60 0 0         croak "Too many arguments to $field" if @_ > 1;
61 0           return $self->{$field} = shift;
62 168         650 };
63             }
64              
65             1;