File Coverage

blib/lib/Tie/FieldVals/Row/Join.pm
Criterion Covered Total %
statement 40 56 71.4
branch 5 18 27.7
condition n/a
subroutine 7 11 63.6
pod 4 4 100.0
total 56 89 62.9


line stmt bran cond sub pod time code
1             package Tie::FieldVals::Row::Join;
2 2     2   1222 use strict;
  2         5  
  2         68  
3 2     2   11 use warnings;
  2         6  
  2         139  
4              
5             =head1 NAME
6              
7             Tie::FieldVals::Row::Join - a hash tie for merging rows of Tie::FieldVals data
8              
9             =head1 VERSION
10              
11             This describes version B<0.6203> of Tie::FieldVals::Row::Join.
12              
13             =cut
14              
15             our $VERSION = '0.6203';
16              
17             =head1 SYNOPSIS
18              
19             use Tie::FieldVals::Row;
20             use Tie::FieldVals::Row::Join;
21              
22             # just the keys
23             my %person_thing;
24             my $jr = tie %person_thing, 'Tie::FieldVals::Row::Join,
25             fields=>@keys;
26              
27             # keys and values
28             my %person;
29             my $rr = tie %person_thing, 'Tie::FieldVals::Row,
30             fields=>@keys;
31              
32             my %person_thing;
33             my $jr = tie %person_thing, 'Tie::FieldVals::Row::Join,
34             row=>$rr;
35              
36              
37             =head1 DESCRIPTION
38              
39             This is a Tie object to enable the merging of more than one
40             Tie::FieldVals::Row hashes into one hash.
41              
42             =cut
43              
44 2     2   35 use 5.006;
  2         6  
45 2     2   11 use strict;
  2         4  
  2         47  
46 2     2   10 use Carp;
  2         9  
  2         1346  
47              
48             our @ISA = qw(Tie::FieldVals::Row);
49              
50             # to make taint happy
51             $ENV{PATH} = "/bin:/usr/bin:/usr/local/bin";
52             $ENV{CDPATH} = '';
53             $ENV{BASH_ENV} = '';
54              
55             # for debugging
56             my $DEBUG = 0;
57              
58             =head1 OBJECT METHODS
59              
60             =head2 append_keys
61              
62             $row_obj->append_keys(@fields);
63              
64             Extend the legal fields definition by adding the given fields to it.
65             Sets the given fields to be undefined.
66              
67             =cut
68             sub append_keys ($@) {
69 0 0   0 1 0 carp &whowasi if $DEBUG;
70 0         0 my $self = shift;
71 0         0 my @keys = @_;
72              
73 0         0 foreach my $key (@keys)
74             {
75 0 0       0 if (!exists $self->{FIELDS}->{$key})
76             {
77 0         0 $self->{FIELDS}->{$key} = undef;
78 0         0 push @{$self->{OPTIONS}->{fields}}, $key;
  0         0  
79             }
80             }
81              
82             } # append_keys
83              
84             =head2 merge_rows
85              
86             $row_obj->merge_rows($row_obj2);
87              
88             Merge a Tie::FieldVals::Row object with this one. The second
89             row object has different Fields than this one, and this will
90             extend the legal fields definition by adding the given fields to it,
91             as well as adding the values of the second row to this row.
92              
93             =cut
94             sub merge_rows ($$) {
95 2 50   2 1 7 carp &whowasi if $DEBUG;
96 2         3 my $self = shift;
97 2         4 my $row_obj = shift;
98              
99 2         3 my @keys = @{$row_obj->field_names()};
  2         8  
100 2         6 foreach my $key (@keys)
101             {
102 17 100       40 if (!exists $self->{FIELDS}->{$key}) # only add new keys
103             {
104 16         31 $self->{FIELDS}->{$key} = [];
105 16         20 push @{$self->{FIELDS}->{$key}}, @{$row_obj->{FIELDS}->{$key}};
  16         31  
  16         36  
106 16         21 push @{$self->{OPTIONS}->{fields}}, $key;
  16         43  
107             }
108             }
109              
110             } # merge_rows
111              
112             =head1 TIE-HASH METHODS
113              
114             =head2 TIEHASH
115              
116             Create a new instance of the object as tied to a hash.
117              
118             my %person_thing;
119             my $jr = tie %person_thing, 'Tie::FieldVals::Row::Join,
120             fields=>@keys;
121              
122             my %person;
123             my $rr = tie %person_thing, 'Tie::FieldVals::Row,
124             fields=>@keys;
125              
126             my %person_thing;
127             my $jr = tie %person_thing, 'Tie::FieldVals::Row::Join,
128             row=>$rr;
129              
130             =cut
131             sub TIEHASH {
132 1 50   1   4 carp &whowasi if $DEBUG;
133 1         3 my $class = shift;
134 1         5 my %args = (
135             fields=>undef,
136             row=>undef,
137             @_
138             );
139              
140 1         2 my $self;
141 1 50       9 if (defined $args{row})
142             {
143 1         2 my $row_obj = $args{row};
144 1         3 delete $args{row};
145 1         6 $self = Tie::FieldVals::Row::TIEHASH($class,
146             fields=>[qw(dummy)]);
147             # merge the rows
148 1         2 %{$self->{FIELDS}} = ();
  1         8  
149 1         2 $self->{OPTIONS}->{fields} = [];
150 1         6 $self->merge_rows($row_obj);
151             }
152             else # just fields
153             {
154 0         0 $self = Tie::FieldVals::Row::TIEHASH($class, %args)
155             }
156              
157 1         5 return $self;
158             } # TIEHASH
159              
160             sub UNTIE {
161 0 0   0     carp &whowasi if $DEBUG;
162 0           my $self = shift;
163 0           my $count = shift;
164              
165 0 0         carp "untie attempted while $count inner references still exist" if $count;
166              
167 0           $self->SUPER::UNTIE($count);
168             }
169              
170             =head1 PRIVATE METHODS
171              
172             For developer reference only.
173              
174             =head2 debug
175              
176             Set debugging on.
177              
178             =cut
179 0 0   0 1   sub debug { $DEBUG = @_ ? shift : 1 }
180              
181             =head2 whowasi
182              
183             For debugging: say who called this
184              
185             =cut
186 0     0 1   sub whowasi { (caller(1))[3] . '()' }
187              
188             =head1 REQUIRES
189              
190             Test::More
191             Carp
192              
193             =head1 SEE ALSO
194              
195             perl(1).
196             L
197             L
198              
199             =head1 BUGS
200              
201             Please report any bugs or feature requests to the author.
202              
203             =head1 AUTHOR
204              
205             Kathryn Andersen (RUBYKAT)
206             perlkat AT katspace dot com
207             http://www.katspace.com
208              
209             =head1 COPYRIGHT AND LICENCE
210              
211             Copyright (c) 2004 by Kathryn Andersen
212              
213             This program is free software; you can redistribute it and/or modify it
214             under the same terms as Perl itself.
215              
216              
217             =cut
218              
219             1; # End of Tie::FieldVals::Row::Join
220             __END__