File Coverage

blib/lib/Tie/FieldVals/Join.pm
Criterion Covered Total %
statement 129 172 75.0
branch 16 50 32.0
condition 3 6 50.0
subroutine 15 23 65.2
pod 3 3 100.0
total 166 254 65.3


line stmt bran cond sub pod time code
1             package Tie::FieldVals::Join;
2 2     2   2441 use strict;
  2         5  
  2         66  
3 2     2   12 use warnings;
  2         4  
  2         107  
4              
5             =head1 NAME
6              
7             Tie::FieldVals::Join - an array tie for two files of FieldVals data
8              
9             =head1 VERSION
10              
11             This describes version B<0.6203> of Tie::FieldVals::Join.
12              
13             =cut
14              
15             our $VERSION = '0.6203';
16              
17             =head1 SYNOPSIS
18              
19             use Tie::FieldVals;
20             use Tie::FieldVals::Row;
21             use Tie::FieldVals::Join;
22             use Tie::FieldVals::Row::Join;
23              
24             my @records;
25              
26             my $recs_obj = tie @records, 'Tie::FieldVals::Join',
27             datafile=>$datafile, joinfile=>$joinfile,
28             join_field=>$fieldname, selection=>{$key=>$value};
29              
30             =head1 DESCRIPTION
31              
32             This is a Tie object to map the records in two FieldVals data files
33             into an array.
34              
35             This depends on the Tie::FieldVals::Row::Join module.
36              
37             =cut
38              
39 2     2   42 use 5.006;
  2         8  
40 2     2   11 use strict;
  2         2  
  2         39  
41 2     2   10 use Carp;
  2         2  
  2         122  
42 2     2   10 use Tie::Array;
  2         3  
  2         91  
43 2     2   15 use Tie::FieldVals;
  2         4  
  2         42  
44 2     2   10 use Tie::FieldVals::Row;
  2         7  
  2         47  
45 2     2   559 use Tie::FieldVals::Row::Join;
  2         4  
  2         55  
46 2     2   10 use Fcntl qw(:DEFAULT);
  2         4  
  2         929  
47 2     2   11 use Data::Dumper;
  2         4  
  2         3482  
48              
49             our @ISA = qw(Tie::Array);
50              
51             # to make taint happy
52             $ENV{PATH} = "/bin:/usr/bin:/usr/local/bin";
53             $ENV{CDPATH} = '';
54             $ENV{BASH_ENV} = '';
55              
56             # for debugging
57             my $DEBUG = 0;
58              
59             #================================================================
60             # Methods
61              
62             =head1 OBJECT METHODS
63              
64             =head2 field_names
65              
66             Get the field names of this data.
67              
68             my @field_names = $recs_obj->field_names();
69              
70             =cut
71             sub field_names {
72 1 50   1 1 532 carp &whowasi if $DEBUG;
73 1         3 my $self = shift;
74              
75 1         4 @{$self->{all_field_names}};
  1         15  
76             }
77              
78             #================================================================
79             # Object interface
80              
81             =head1 Tie-Array METHODS
82              
83             =head2 TIEARRAY
84              
85             Create a new instance of the object as tied to an array.
86             This is a read-only array.
87              
88             tie %person, 'Tie::FieldVals::Join', datafile=>$datafile,
89             joinfile=>$joinfile, join_field=>$fieldname,
90             selection=>{$key=>$value...}, match_any=>$val2;
91              
92             tie %person, 'Tie::FieldVals::Join', datafile=>$datafile,
93             joinfile=>$joinfile, join_field=>$fieldname,
94             cache_size=>1000, memory=>0;
95              
96             tie %person, 'Tie::FieldVals::Join', datafile=>$datafile,
97             joinfile=>$joinfile, join_field=>$fieldname,
98             selection=>{$key=>$value...}, match_any=>$val2,
99             cache_all=>1;
100              
101             The datafile option is the first file, the joinfile is the second.
102             The join_field is the field which the two files have in common,
103             upon which they are joining. Only rows where both files have
104             the same value for the join_field will be put in this join.
105              
106             Note that is a very naieve join algorithm: it expects the B
107             file to have unique values for the B, and the B
108             file to have multiple values for the B -- if the order is
109             the other way around, the results will be messed up.
110              
111             The join array is read-only.
112              
113             See L and L for explanations of
114             the other arguments.
115              
116             =cut
117             sub TIEARRAY {
118 1 50   1   529 carp &whowasi if $DEBUG;
119 1         2 my $class = shift;
120 1         9 my %args = (
121             datafile=>'',
122             joinfile=>'',
123             join_field=>'',
124             cache_size=>100,
125             cache_all=>0,
126             memory=>10_000_000,
127             selection=>undef,
128             match_any=>undef,
129             @_
130             );
131              
132 1         2 my $self = {};
133 1         3 $self->{OPTIONS} = \%args;
134              
135             # find the field names
136 1         3 $self->{FIELD_NAMES} = [];
137 1         3 @{$self->{FIELD_NAMES}->[0]} =
138 1         5 Tie::FieldVals::find_field_names($args{datafile});
139 1         9 @{$self->{FIELD_NAMES}->[1]} =
140 1         5 Tie::FieldVals::find_field_names($args{joinfile});
141              
142             # set the combined field names
143 1         3 my @field_names = @{$self->{FIELD_NAMES}->[0]};
  1         7  
144 1         4 my %field_names_hash1 = ();
145 1         3 foreach my $fn (@{$self->{FIELD_NAMES}->[0]})
  1         5  
146             {
147 6         24 $field_names_hash1{$fn} = 1;
148             }
149              
150 1         3 my %field_names_hash2 = ();
151 1         3 foreach my $fn (@{$self->{FIELD_NAMES}->[1]})
  1         4  
152             {
153 11 100       44 if ($fn ne $args{join_field})
154             {
155 10         33 push @field_names, $fn;
156             }
157 11         41 $field_names_hash2{$fn} = 1;
158             }
159 1         4 $self->{all_field_names} = \@field_names;
160              
161             # split the selection, if any, into a selection for the first
162             # file and the selection for the second file.
163 1         3 my %sel1 = ();
164 1         3 my %sel2 = ();
165 1 50       7 if (defined $args{selection})
166             {
167 0         0 foreach my $key (keys %{$args{selection}})
  0         0  
168             {
169 0 0       0 if ($field_names_hash1{$key}) # in first file
170             {
171 0         0 $sel1{$key} = $args{selection}->{$key};
172             }
173 0 0       0 if ($field_names_hash2{$key}) # in second file
174             {
175 0         0 $sel2{$key} = $args{selection}->{$key};
176             }
177             }
178             }
179              
180             # make a selection from the files, so they can
181             # be sorted on the join_field
182 1         4 $self->{SEL_RECS} = [];
183 1         6 $self->{SEL_OBJS} = [];
184 1         4 my @sel_recs1;
185             $self->{SEL_OBJS}->[0] = tie @sel_recs1, 'Tie::FieldVals::Select',
186             datafile=>$args{datafile},
187             selection=>(%sel1 ? \%sel1 : undef),
188             match_any=>$args{match_any}
189 1 50       14 or die "Tie::FieldVals::Join - Could not select", $args{datafile}, ".";
    50          
190 1         4 $self->{SEL_RECS}->[0] = \@sel_recs1;
191 1         3 my @sel_recs2;
192             $self->{SEL_OBJS}->[1] = tie @sel_recs2, 'Tie::FieldVals::Select',
193             datafile=>$args{joinfile},
194             selection=>(%sel2 ? \%sel2 : undef),
195             match_any=>$args{match_any}
196 1 50       14 or die "Tie::FieldVals::Join - Could not select", $args{joinfile}, ".";
    50          
197 1         3 $self->{SEL_RECS}->[1] = \@sel_recs2;
198              
199             # sort on the join field
200 1         5 for (my $i = 0; $i < 2; $i++)
201             {
202             $self->{SEL_OBJS}->[$i]->sort_records(
203 2         20 sort_by=>[$args{join_field}]);
204             }
205            
206             # join the two files on the join field
207 1         3 my @join_recs = ();
208 1         2 my $i = 0;
209 1         3 my $j = 0;
210 1         8 foreach my $row1_ref (@sel_recs1)
211             {
212 52         75 my $row1_obj = tied %{$row1_ref};
  52         142  
213              
214 52         246 my $join_val = $row1_ref->{$args{join_field}};
215 52 50       141 if ($join_val)
216             {
217 52         129 $join_val = "eq $join_val"; # make an exact compare
218             }
219             else
220             {
221 0         0 $join_val = "eq ''";
222             }
223 52         88 my $row2_ref = undef;
224 52         58 my $row2_obj = undef;
225 52 50       145 if ($j < @sel_recs2)
226             {
227 52         202 $row2_ref = $sel_recs2[$j];
228 52         91 $row2_obj = tied %{$row2_ref};
  52         100  
229             }
230             # since these are sorted, just keep going until no match
231 52   100     154 while ($j < @sel_recs2
232             && $row2_obj->match($args{join_field}=>$join_val))
233             {
234             # we have a value for both tables!
235 119         285 push @join_recs, [$i, $j];
236 119         161 $j++;
237 119         404 $row2_ref = $sel_recs2[$j];
238 119         207 $row2_obj = tied %{$row2_ref};
  119         439  
239             }
240 52         184 $i++;
241             }
242 1         4 $self->{JOIN_RECS} = \@join_recs;
243 1         69 $self->{REC_CACHE} = {};
244 1 50       6 if ($args{cache_all}) # set the cache to the size of the file
245             {
246 0         0 my $count = @join_recs;
247 0         0 $self->{OPTIONS}->{cache_size} = $count;
248             }
249              
250 1         16 bless $self, $class;
251             } # TIEARRAY
252              
253             =head2 FETCH
254              
255             Get a row from the array.
256              
257             $val = $array[$ind];
258              
259             Returns a reference to a Tie::FieldVals::Row::Join hash, or undef.
260              
261             =cut
262             sub FETCH {
263 1 50   1   579 carp &whowasi if $DEBUG;
264 1         2 my ($self, $ind) = @_;
265              
266 1 50       6 if (defined $self->{REC_CACHE}->{$ind})
267             {
268 0         0 return $self->{REC_CACHE}->{$ind};
269             }
270             else # not cached, add to cache
271             {
272             # remove one from cache if cache full
273 1         2 my @cached = keys %{$self->{REC_CACHE}};
  1         5  
274 1 50       5 if (@cached >= $self->{OPTIONS}->{cache_size})
275             {
276 0         0 delete $self->{REC_CACHE}->{shift @cached};
277             }
278             # get the records from the files
279 1         3 my $file_ind_ar_ref = $self->{JOIN_RECS}->[$ind];
280 1         2 my @rec_strs = ();
281 1         3 my @rows = ();
282              
283 1         2 my $find = ${$file_ind_ar_ref}[0];
  1         3  
284 1         6 my $srow_ref = $self->{SEL_RECS}->[0]->[$find];
285 1         3 my $srow_obj = tied %{$srow_ref};
  1         3  
286              
287 1         2 %{$self->{REC_CACHE}->{$ind}} = ();
  1         4  
288 1         2 my $row_obj = tie %{$self->{REC_CACHE}->{$ind}},
  1         12  
289             'Tie::FieldVals::Row::Join',
290             row=>$srow_obj;
291              
292 1         2 for (my $fnum=1; $fnum < @{$file_ind_ar_ref}; $fnum++)
  2         9  
293             {
294 1         2 $find = ${$file_ind_ar_ref}[$fnum];
  1         2  
295 1         4 $srow_ref = $self->{SEL_RECS}->[$fnum]->[$find];
296 1         3 $srow_obj = tied %{$srow_ref};
  1         3  
297 1         3 $row_obj->merge_rows($srow_obj);
298             }
299 1         5 return $self->{REC_CACHE}->{$ind};
300             }
301 0         0 return undef;
302             } # FETCH
303              
304             =head2 STORE
305              
306             Add a value to the array. Does nothing -- this is read-only.
307              
308             =cut
309             sub STORE {
310 0 0   0   0 carp &whowasi if $DEBUG;
311 0         0 my ($self, $ind, $val) = @_;
312              
313 0         0 return undef;
314             } # STORE
315              
316             =head2 FETCHSIZE
317              
318             Get the size of the array.
319              
320             =cut
321             sub FETCHSIZE {
322 2 50   2   783 carp &whowasi if $DEBUG;
323 2         3 my $self = shift;
324              
325 2         4 return scalar @{$self->{JOIN_RECS}};
  2         9  
326             } # FETCHSIZE
327              
328             =head2 STORESIZE
329              
330             Does nothing.
331              
332             =cut
333             sub STORESIZE {
334 0 0   0     carp &whowasi if $DEBUG;
335 0           my $self = shift;
336 0           my $count = shift;
337              
338             } # STORESIZE
339              
340             =head2 EXISTS
341              
342             exists $array[$ind];
343              
344             =cut
345             sub EXISTS {
346 0 0   0     carp &whowasi if $DEBUG;
347 0           my $self = shift;
348 0           my $ind = shift;
349              
350 0 0 0       if ($ind >= 0 && $ind < @{$self->{JOIN_RECS}})
  0            
351             {
352 0           return exists ${$self->{JOIN_RECS}}[$ind];
  0            
353             }
354 0           return 0;
355             } # EXISTS
356              
357             =head2 DELETE
358              
359             delete $array[$ind];
360              
361             Does nothing -- this array is read-only.
362              
363             =cut
364             sub DELETE {
365 0 0   0     carp &whowasi if $DEBUG;
366 0           my $self = shift;
367 0           my $ind = shift;
368              
369 0           return undef;
370             } # DELETE
371              
372             =head2 CLEAR
373              
374             @array = ();
375              
376             Does nothing -- this array is read-only.
377              
378             =cut
379             sub CLEAR {
380 0 0   0     carp &whowasi if $DEBUG;
381 0           my $self = shift;
382              
383             } # CLEAR
384              
385             =head2 UNTIE
386              
387             untie @array;
388              
389             Untie the array.
390              
391             =cut
392             sub UNTIE {
393 0 0   0     carp &whowasi if $DEBUG;
394 0           my $self = shift;
395              
396 0           $self->{REC_CACHE} = {};
397 0           $self->{JOIN_RECS} = [];
398 0           for (my $i = 0; $i < @{$self->{SEL_RECS}}; $i++)
  0            
399             {
400 0           undef $self->{SEL_OBJS}->[$i];
401 0           untie @{$self->{SEL_RECS}->[$i]};
  0            
402             }
403             } # UNTIE
404              
405             =head1 PRIVATE METHODS
406              
407             For developer reference only.
408              
409             =head2 debug
410              
411             Set debugging on.
412              
413             =cut
414 0 0   0 1   sub debug { $DEBUG = @_ ? shift : 1 }
415              
416             =head2 whowasi
417              
418             For debugging: say who called this
419              
420             =cut
421 0     0 1   sub whowasi { (caller(1))[3] . '()' }
422              
423             =head1 REQUIRES
424              
425             Test::More
426             Carp
427             Data::Dumper
428             Tie::Array
429             Fcntl
430             Tie::FieldVals
431             Tie::FieldVals::Row
432             Tie::FieldVals::Row::Join
433             Tie::FieldVals::Select
434              
435             =head1 SEE ALSO
436              
437             perl(1).
438             L
439             L
440             L
441             L
442              
443             =head1 BUGS
444              
445             Please report any bugs or feature requests to the author.
446              
447             =head1 AUTHOR
448              
449             Kathryn Andersen (RUBYKAT)
450             perlkat AT katspace dot com
451             http://www.katspace.com
452              
453             =head1 COPYRIGHT AND LICENCE
454              
455             Copyright (c) 2004 by Kathryn Andersen
456              
457             This program is free software; you can redistribute it and/or modify it
458             under the same terms as Perl itself.
459              
460              
461             =cut
462              
463             1; # End of Tie::FieldVals::Join
464             # vim: ts=8 sts=4 sw=4
465             __END__