File Coverage

blib/lib/Geo/TigerLine/Record/Parser.pm
Criterion Covered Total %
statement 32 32 100.0
branch 2 2 100.0
condition 2 6 33.3
subroutine 4 4 100.0
pod 2 2 100.0
total 42 46 91.3


line stmt bran cond sub pod time code
1             package Geo::TigerLine::Record::Parser;
2              
3 1     1   6 use Carp::Assert;
  1         3  
  1         6  
4 1     1   123 use vars qw($VERSION);
  1         2  
  1         504  
5             $VERSION = '0.01';
6              
7             =pod
8              
9             =head1 NAME
10              
11             Geo::TigerLine::Record::Parser - Parsing superclass for TIGER/Line records.
12              
13              
14             =head1 SYNOPSIS
15              
16             package Geo::TigerLine::Record::23;
17             use base qw(Geo::TigerLine::Record::Parser);
18              
19             @records = __PACKAGE__->parse_file($fh);
20             __PACKAGE__->parse_file($fh, \&callback);
21              
22             $record = __PACKAGE__->parse($row);
23              
24              
25             =head1 DESCRIPTION
26              
27             Parses raw TIGER/Line data into Geo::TigerLine::Record objects. This
28             is intended to be used as a superclass of Geo::TigerLine::Record
29             objects and not used directly.
30              
31             You shouldn't be here.
32              
33              
34             =head2 Methods
35              
36             =over 4
37              
38             =item B
39              
40             @records = __PACKAGE__->parse_file($fh);
41             __PACKAGE__->parse_file($fh, \&callback);
42              
43             Parses a given filehandle as a TIGER/Line data file. The data
44             definition is taken from __PACKAGE__->Pack_Tmpl, __PACKAGE__->Dict and
45             __PACKAGE__->Fields. Returns an array of objects of type __PACKAGE__.
46              
47             &callback will be called for each record and given a record object and
48             its position in the file (ie. 1 for the first, 2 for the second, etc...).
49             A sample callback...
50              
51             sub callback {
52             my($record, $pos) = @_;
53              
54             printf "Record #$pos is %s\n", $record->tlid;
55             }
56              
57             If a &callback is given, a list of records will B be returned.
58             It is assumed you'll be taking care of arrangements to store the
59             records in your callback and @records can eat up huge amounds of
60             memory for a typical TIGER/Line data file.
61              
62             =cut
63              
64             #'#
65             sub parse_file {
66 2     2 1 1122 my($proto, $fh, $callback) = @_;
67 2   33     16 my($class) = ref $proto || $proto;
68              
69 2         4 my @records = ();
70              
71 2         4 my $num = 1;
72 2         60 while(<$fh>) {
73 12         26 chomp;
74 12         52 my $record = $class->parse($_);
75              
76 12 100       38 if( defined $callback ) {
77 6         21 $callback->($record, $num);
78             }
79             else {
80 6         14 push @records, $record;
81             }
82              
83 12         3497 $num++;
84             }
85              
86 2         10 return @records;
87             }
88              
89             =pod
90              
91             =item B
92              
93             $record = __PACKAGE__->parse($line);
94              
95             Parses a single record of TIGER/Line data.
96              
97             =cut
98              
99             sub parse {
100 12     12 1 23 my($proto, $line) = @_;
101 12   33     62 my($class) = ref $proto || $proto;
102              
103 12         53 my $data_def = $class->Dict;
104 12         118 my $data_fields = $class->Fields;
105 12         123 my @fields = unpack($class->Pack_Tmpl, $line);
106              
107 12         339 assert(@fields == keys %$data_def);
108              
109 12         67 my %fields = map { ($_ => shift @fields) } @$data_fields;
  528         4152  
110              
111             # Clip leading whitespace off right justified fields.
112 12         274 foreach my $field ( map { $_->{field} } grep { $_->{fmt} eq 'R' }
  120         220  
  528         3430  
113             values %$data_def )
114             {
115 120         920 $fields{$field} =~ s/^\s+//;
116             }
117              
118 12         77 my $obj = $class->new(\%fields);
119 12         534 return $obj;
120             }
121              
122             =pod
123              
124             =back
125              
126             =head1 AUTHOR
127              
128             Michael G Schwern
129              
130             =head1 SEE ALSO
131              
132             L
133              
134             =cut
135              
136             1;
137