File Coverage

blib/lib/Geo/TigerLine/Record/Accessor.pm
Criterion Covered Total %
statement 43 49 87.7
branch 9 18 50.0
condition 3 9 33.3
subroutine 9 9 100.0
pod 3 4 75.0
total 67 89 75.2


line stmt bran cond sub pod time code
1             package Geo::TigerLine::Record::Accessor;
2              
3 1     1   7 use strict;
  1         2  
  1         40  
4 1     1   6 use vars qw($VERSION);
  1         1  
  1         48  
5             $VERSION = '0.03';
6              
7 1     1   6 use base qw(Class::Accessor Class::Data::Inheritable);
  1         2  
  1         1046  
8              
9 1     1   4245 use Carp::Assert;
  1         3  
  1         11  
10              
11              
12             =pod
13              
14             =head1 NAME
15              
16             Geo::TigerLine::Record::Accessor - Accessor generation for Geo::TigerLine::Record::*
17              
18             =head1 SYNOPSIS
19              
20             package Geo::TigerLine::Record::1001001;
21              
22             use base qw(Geo::TigerLine::Record::Accessor);
23              
24             # Generate accessors for each field of the record.
25             foreach my $def (values %{__PACKAGE__->Fields}) {
26             __PACKAGE__->mk_accessor($def);
27             }
28              
29             # Turn off input checks, makes inserting raw data faster.
30             __PACKAGE__->input_checks(0);
31              
32             =head1 DESCRIPTION
33              
34             Allows accessor generation for all the fields of each TIGER/Line record type.
35             You probabably shouldn't be here.
36              
37             This is a subclass of Class::Accessor.
38              
39             =cut
40              
41             #'#
42             {
43 1     1   174 no strict 'refs';
  1         3  
  1         643  
44              
45             sub mk_accessor {
46 44     44 0 58 my($self, $def) = @_;
47            
48 44   33     168 my $class = ref $self || $self;
49 44         142 my $field = $def->{field};
50              
51 44 50       83 if( $field eq 'DESTROY' ) {
52 0         0 require Carp;
53 0         0 &Carp::carp("Having a data accessor named DESTROY in ".
54             "'$class' is unwise.");
55             }
56              
57 44         123 my $accessor = $self->make_accessor($def);
58 44         442 my $alias = "_${field}_accessor";
59            
60 44         181 *{$class."\:\:$field"} = $accessor
  44         239  
61 44 50       45 unless defined &{$class."\:\:$field"};
62            
63 44         293 *{$class."\:\:$alias"} = $accessor
  44         254  
64 44 50       44 unless defined &{$class."\:\:$alias"};
65             }
66             }
67              
68              
69             sub get {
70 116     116 1 17319 my($self, $def) = @_;
71 116         679 return $self->{$def->{field}};
72             }
73              
74              
75             sub set {
76 1     1 1 1076 my($self, $def, $val) = @_;
77              
78 1 50       9 if( $self->input_check ) {
79 1 0 33     11 if ( $val !~ /\S/ && !$def->{bv} ) {
80 0         0 Carp::carp("$def->{field} is not allowed to be blank.");
81             }
82            
83 1 50 33     7 if ( $val =~ /[^\d+\-]/ && $def->{type} eq 'N' ) {
84 0         0 Carp::carp("$def->{field} can contain only numbers. ('$val')");
85             }
86            
87 1 50       5 if ( $val =~ /[^A-Z'\/()&\d+\-\]\[\# ]/i ) { #']) {
88 0         0 Carp::carp("$def->{field} can only contain alphanumeric ".
89             "characters. ('$val')");
90             }
91            
92 1 50       7 if ( length $val > $def->{len} ) {
93 0         0 Carp::carp("$def->{field} can only be $def->{len} characters long. ".
94             "('$val')");
95             }
96             }
97              
98 1         5 $self->{$def->{field}} = $val;
99             }
100              
101             =head2 Additional Methods
102              
103             =over 4
104              
105             =item B
106              
107             Class->input_check($true_or_false);
108             $true_or_false = Class->input_check;
109             $true_or_false = $obj->input_check;
110              
111             If true, turns on the input checks done each time a value is set.
112             False turns them off.
113              
114             This setting is inherited.
115              
116             By default, the checks are on.
117              
118             =cut
119              
120             #'#
121             __PACKAGE__->mk_classdata('__Input_Check');
122             __PACKAGE__->input_check(1); # Start out doing the checks.
123             sub input_check {
124 2     2 1 6 my($class) = shift;
125 2         5 my($check) = @_;
126              
127 2 100       8 if( @_ ) {
128 1         6 assert( !ref $class ) if DEBUG;
129 1         7 $class->__Input_Check($check);
130             }
131             else {
132 1         13 $check = $class->__Input_Check;
133             }
134              
135 2         33 return $check;
136             }
137              
138             =pod
139              
140             =back
141              
142             =head1 AUTHOR
143              
144             Michael G Schwern
145              
146             =head1 SEE ALSO
147              
148             L, L
149              
150             =cut
151              
152              
153             return 'Bloody balls up';