File Coverage

blib/lib/Tie/FieldVals/Row.pm
Criterion Covered Total %
statement 165 335 49.2
branch 63 164 38.4
condition 12 36 33.3
subroutine 21 29 72.4
pod 13 13 100.0
total 274 577 47.4


line stmt bran cond sub pod time code
1             package Tie::FieldVals::Row;
2 8     8   43 use strict;
  8         15  
  8         226  
3 8     8   44 use warnings;
  8         16  
  8         498  
4              
5             =head1 NAME
6              
7             Tie::FieldVals::Row - a hash tie for rows (records) of Tie::FieldVals data
8              
9             =head1 VERSION
10              
11             This describes version B<0.6203> of Tie::FieldVals::Row.
12              
13             =cut
14              
15             our $VERSION = '0.6203';
16              
17             =head1 SYNOPSIS
18              
19             use Tie::FieldVals::Row;
20              
21             my %person;
22             my @keys = qw(Forename Surname DateOfBirth Gender);
23             my $row_obj = tie %person, 'Tie::FieldVals::Row', fields=>\@keys;
24              
25             # set the row
26             $row_obj->set_from_string($row_str,override_keys=>1);
27              
28             # compare the row
29             if ($row_obj->match(Forename=>'Mary'))
30             {
31             # do something
32             }
33              
34             =head1 DESCRIPTION
35              
36             This is a Tie object to map a row (record) of enhanced Field:Value data to
37             a hash. This sets fixed keys so that they match the columns of the data.
38             Values can go over more than one line. Fields can have multiple values.
39              
40             Field names cannot have spaces in them, indeed, they must consist of plain
41             alphanumeric characters or underscores. They are case-sensitive.
42              
43             =cut
44              
45 8     8   152 use 5.006;
  8         31  
46 8     8   38 use strict;
  8         16  
  8         168  
47 8     8   45 use Carp;
  8         18  
  8         16335  
48              
49             # to make taint happy
50             $ENV{PATH} = "/bin:/usr/bin:/usr/local/bin";
51             $ENV{CDPATH} = '';
52             $ENV{BASH_ENV} = '';
53              
54             # for debugging
55             my $DEBUG = 0;
56              
57             =head1 OBJECT METHODS
58              
59             =head2 set_from_hash
60              
61             Set the hash data from a simple untied hash.
62              
63             $row_obj->set_from_hash(\%hash);
64              
65             $row_obj->set_from_hash(\%hash
66             override_keys=>1,
67             append_keys=>0);
68              
69             Arguments:
70              
71             =over
72              
73             =item append_keys
74              
75             Append to the list of official fields with the Field: contents
76             of this string.
77             (default: false)
78              
79             =item override_keys
80              
81             If override_keys is true, then the official fields, the legal
82             keys to this hash, are reset from the Field: contents of this
83             string.
84             (default: false)
85              
86             =back
87              
88             =cut
89             sub set_from_hash ($$;%) {
90 0     0 1 0 my $self = shift;
91 0         0 my $hash_ref = shift;
92 0         0 my %args = (
93             override_keys=>0,
94             append_keys=>0,
95             @_
96             );
97              
98             # if we are overriding the keys, simply clear
99             # the whole self-hash
100 0 0       0 if ($args{override_keys})
101             {
102 0         0 %{$self->{FIELDS}} = ();
  0         0  
103 0         0 $self->{OPTIONS}->{fields} = [];
104             }
105             else
106             {
107             # otherwise, just clear the existing data
108 0         0 $self->CLEAR();
109             }
110              
111 0         0 my @fields = ();
112 0         0 my $cur_field = '';
113 0         0 foreach my $field (sort keys %{$hash_ref})
  0         0  
114             {
115 0         0 my $val = $hash_ref->{$field};
116 0 0 0     0 if ($args{override_keys}
      0        
117             || $args{append_keys}
118             || exists $self->{FIELDS}->{$field})
119             {
120 0         0 $cur_field = $field;
121 0 0       0 if (!defined $self->{FIELDS}->{$field})
122             {
123 0         0 $self->{FIELDS}->{$field} = [];
124             }
125 0 0       0 if (ref $val)
126             {
127 0         0 push @{$self->{FIELDS}->{$field}}, @{$val};
  0         0  
  0         0  
128             }
129             else
130             {
131 0         0 push @{$self->{FIELDS}->{$field}}, $val;
  0         0  
132             }
133 0 0       0 if ($args{override_keys})
134             {
135 0         0 push @{$self->{OPTIONS}->{fields}}, $field;
  0         0  
136             }
137             }
138             else
139             {
140 0         0 carp "unknown field $field in hash";
141             }
142             }
143             } # set_from_hash
144              
145             =head2 set_from_string
146              
147             Set the hash data from an enhanced Field:Value data string.
148              
149             $row_obj->set_from_string($record_str);
150              
151             $row_obj->set_from_string($record_str,
152             override_keys=>1,
153             append_keys=>0);
154              
155             The format of the string is basically a multi-line string
156             in Field:Value format, with the addition that if a line does
157             not start with a known fieldname followed by a colon, that
158             the contents of that line is added to the value of the previous
159             field.
160              
161             If a particular FieldName is repeated, its value is added to
162             the existing value of that FieldName, and it becomes a
163             multi-value field.
164              
165             Arguments:
166              
167             =over
168              
169             =item append_keys
170              
171             Append to the list of official fields with the Field: contents
172             of this string.
173             (default: false)
174              
175             =item override_keys
176              
177             If override_keys is true, then the official fields, the legal
178             keys to this hash, are reset from the Field: contents of this
179             string.
180             (default: false)
181              
182             =back
183              
184             =cut
185             sub set_from_string ($$;%) {
186 625     625 1 873 my $self = shift;
187 625         947 my $record_str = shift;
188 625         1805 my %args = (
189             override_keys=>0,
190             append_keys=>0,
191             @_
192             );
193              
194             # if we are overriding the keys, simply clear
195             # the whole self-hash
196 625 100       1308 if ($args{override_keys})
197             {
198 11         22 %{$self->{FIELDS}} = ();
  11         49  
199 11         39 $self->{OPTIONS}->{fields} = [];
200             }
201             else
202             {
203             # otherwise, just clear the existing data
204 614         1204 $self->CLEAR();
205             }
206              
207             # the lines contain either field:value pairs
208             # or continuations of the previous field's value
209 625         1450 my @fields = ();
210 625         3349 my @lines = split(/\n/, $record_str);
211 625         972 my $cur_field = '';
212 625         1526 while (@lines)
213             {
214 7699         10933 my $line = shift @lines;
215 7699 100       28361 if ($line =~ /^([a-zA-Z][-_a-zA-Z0-9]*):(.*)$/)
    50          
216             {
217 6607         11494 my $field = $1;
218 6607         10134 my $val = $2;
219 6607 50 66     29346 if ($args{override_keys}
    0 33        
220             || $args{append_keys}
221             || exists $self->{FIELDS}->{$field})
222             {
223 6607         8047 $cur_field = $field;
224 6607 100       14898 if (!defined $self->{FIELDS}->{$field})
225             {
226 6605         12862 $self->{FIELDS}->{$field} = [];
227             }
228 6607         8175 push @{$self->{FIELDS}->{$field}}, $val;
  6607         16078  
229 6607 100       25266 if ($args{override_keys})
230             {
231 111         151 push @{$self->{OPTIONS}->{fields}}, $field;
  111         517  
232             }
233             }
234             elsif ($cur_field)
235             {
236             # not a field -- must be a value
237             # append the current line to the last field
238 0         0 my $count = @{$self->{FIELDS}->{$cur_field}};
  0         0  
239 0         0 ${$self->{FIELDS}->{$cur_field}}[$count - 1] .= "\n$line";
  0         0  
240             }
241             }
242             elsif ($cur_field)
243             {
244             # append the current line to the last field
245 1092         1156 my $count = @{$self->{FIELDS}->{$cur_field}};
  1092         1979  
246 1092         1228 ${$self->{FIELDS}->{$cur_field}}[$count - 1] .= "\n$line";
  1092         4381  
247             }
248             }
249             } # set_from_string
250              
251             =head2 set_from_xml_string
252              
253             Set the hash data from an XML string.
254              
255             $row_obj->set_from_xml_string($record_str);
256              
257             $row_obj->set_from_xml_string($record_str,
258             override_keys=>1,
259             clear=>1);
260              
261             The format of this XML string is as follows:
262              
263            
264             Value
265             AnotherValue
266             ...
267            
268              
269             If a particular FieldName is repeated, its value is added to
270             the existing value of that FieldName, and it becomes a
271             multi-value field.
272              
273             Arguments:
274              
275             =over
276              
277             =item append_keys
278              
279             Append to the list of official fields with the contents
280             of this string.
281             (default: false)
282              
283             =item override_keys
284              
285             If override_keys is true, then the official fields, the legal
286             keys to this hash, are reset from the contents of this
287             string.
288             (default: false)
289              
290             =back
291              
292             =cut
293             sub set_from_xml_string ($$;%) {
294 0     0 1 0 my $self = shift;
295 0         0 my $record_str = shift;
296 0         0 my %args = (
297             override_keys=>0,
298             append_keys=>0,
299             @_
300             );
301              
302             # if we are overriding the keys, simply clear
303             # the whole self-hash
304 0 0       0 if ($args{override_keys})
305             {
306 0         0 %{$self->{FIELDS}} = ();
  0         0  
307 0         0 $self->{OPTIONS}->{fields} = [];
308             }
309             else
310             {
311             # otherwise, just clear the existing data
312 0         0 $self->CLEAR();
313             }
314              
315             # record_str should contain ......
316             # or just the fields
317 0 0       0 if ($record_str =~ m#(.*)#s)
318             {
319 0         0 $record_str = $1;
320             }
321             # now record_str should just contain the fields
322             # eg ........
323 0         0 my @all_fields = split(/(<[a-zA-Z][-_a-zA-Z0-9]*>|<\/[a-zA-Z][-_a-zA-Z0-9]*>)/, $record_str);
324 0         0 while (@all_fields)
325             {
326 0         0 my $fld = shift @all_fields;
327             # is this a valid start-tag?
328 0 0       0 if ($fld =~ m#<([a-zA-Z][-_a-zA-Z0-9]*)>#)
329             {
330 0         0 my $field = $1;
331             # is this a legal key?
332 0 0 0     0 if ($args{override_keys}
      0        
333             || $args{append_keys}
334             || exists $self->{FIELDS}->{$field})
335             {
336 0         0 my $val = shift @all_fields;
337             # restore the special characters to their real meanings
338 0         0 $val =~ s/>/>/g;
339 0         0 $val =~ s/</
340 0         0 $val =~ s/"/"/g;
341 0         0 $val =~ s/'/'/g;
342 0         0 $val =~ s/&/&/g;
343 0 0       0 if (!defined $self->{FIELDS}->{$field})
344             {
345 0         0 $self->{FIELDS}->{$field} = [];
346             }
347 0         0 push @{$self->{FIELDS}->{$field}}, $val;
  0         0  
348             }
349 0 0       0 if ($args{override_keys})
350             {
351 0         0 push @{$self->{OPTIONS}->{fields}}, $field;
  0         0  
352             }
353             }
354             }
355             } # set_from_xml_string
356              
357             =head2 get_as_string
358              
359             Returns the hash data as a string in the same format as
360             expected by L.
361              
362             my $str = $row_obj->get_as_string();
363              
364             my $str = $row_obj->get_as_string(fields=>\@fields);
365              
366             If B is defined, then return a string which is made up
367             of only that subset of the fields given by the @fields array.
368              
369             =cut
370             sub get_as_string ($;%) {
371 11     11 1 1859 my $self = shift;
372 11         31 my %args = (
373             fields=>undef,
374             @_
375             );
376              
377 11         18 my $out = '';
378             my $fields_ref = (defined $args{fields}
379 11 50       46 ? $args{fields} : $self->{OPTIONS}->{fields});
380 11         18 foreach my $field (@{$fields_ref})
  11         23  
381             {
382 114 50       227 if ($self->EXISTS($field))
383             {
384 114         228 my $num_vals = $self->field_count($field);
385 114         250 my $aref = $self->FETCH(\$field);
386 114         278 for (my $i=0; $i < $num_vals; $i++)
387             {
388 114         162 my $val = $aref->[$i];
389 114         184 $out .= "${field}:";
390 114         144 $out .= $val;
391 114         385 $out .= "\n";
392             }
393             }
394             }
395 11         59 $out =~ s/\n$//;
396              
397 11         41 return $out;
398             } # get_as_string
399              
400             =head2 get_xml_string
401              
402             Returns the hash data as an XML string in the same
403             format as expected by L.
404              
405             my $str = $row_obj->get_xml_string();
406              
407             my $str = $row_obj->get_xml_string(fields=>\@fields);
408              
409             If B is defined, then return a string which is made up
410             of only that subset of the fields given by the @fields array.
411              
412             =cut
413             sub get_xml_string ($;%) {
414 0     0 1 0 my $self = shift;
415 0         0 my %args = (
416             fields=>undef,
417             @_
418             );
419              
420 0         0 my $out = '';
421 0         0 $out .= "\n";
422             my $fields_ref = (defined $args{fields}
423 0 0       0 ? $args{fields} : $self->{OPTIONS}->{fields});
424 0         0 foreach my $field (@{$fields_ref})
  0         0  
425             {
426 0 0       0 if ($self->EXISTS($field))
427             {
428 0         0 my $num_vals = $self->field_count($field);
429 0         0 my $aref = $self->FETCH(\$field);
430 0         0 for (my $i=0; $i < $num_vals; $i++)
431             {
432 0         0 my $val = $$aref[$i];
433 0         0 $val =~ s/&/&/g;
434 0         0 $val =~ s/
435 0         0 $val =~ s/>/>/g;
436 0         0 $out .= "<${field}>";
437 0         0 $out .= $val;
438 0         0 $out .= "";
439 0         0 $out .= "\n";
440             }
441             }
442             }
443 0         0 $out .= "\n";
444              
445 0         0 return $out;
446             } # get_xml_string
447              
448             =head2 field_names
449              
450             my @field_names = @{$row_obj->field_names()};
451              
452             Return the names of the fields in the order they were defined,
453             rather than the random order that "keys" would give.
454             This will either be the array which was used when the hash
455             was tied, or the order that fields were read from a string
456             if set_from_string or set_from_xml_string is called with
457             override_fields true.
458              
459             =cut
460             sub field_names ($) {
461 13     13 1 24 my $self = shift;
462              
463 13         77 return $self->{OPTIONS}->{fields};
464             } # field_names
465              
466             =head2 field_count
467              
468             my $cnt = $row_obj->field_count($field_name);
469              
470             Return the number of different field values for the
471             given field in the given Row. A multi-valued field
472             will give a count greater than 1.
473              
474             If there is no value defined for the given field, then returns zero.
475              
476             =cut
477             sub field_count ($$) {
478 114     114 1 134 my $self = shift;
479 114         129 my $field_name = shift;
480              
481 114         129 my $count = 0;
482 114 50 33     476 if (!exists $self->{FIELDS}->{$field_name}
483             || !defined $self->{FIELDS}->{$field_name})
484             {
485 0         0 return 0;
486             }
487              
488 114 50       270 if (ref($self->{FIELDS}->{$field_name}) eq 'ARRAY')
    0          
489             {
490 114         119 $count = @{$self->{FIELDS}->{$field_name}};
  114         221  
491             }
492             elsif (!ref($self->{FIELDS}->{$field_name}))
493             {
494 0         0 $count = 1;
495             }
496             else
497             {
498 0         0 warn "record->${field_name} not array";
499 0         0 warn Dumper($self->{FIELDS});
500             }
501              
502 114         191 return $count;
503             } # field_count
504              
505             =head2 set_fields_as_vars
506              
507             $row_obj->set_fields_as_vars($package_name);
508              
509             $row_obj->set_fields_as_vars($package_name,
510             field_ind=>$field_ind);
511              
512             Sets the data of the hash as variables with the same name as the
513             field name; multi-valued fields have arrays of the field name.
514              
515             These are set in the given package.
516              
517             Arguments:
518              
519             =over
520              
521             =item field_ind
522              
523             For multi-valued fields, the @I variable is set, but also the
524             $I variable will be set, to the value of the variable with
525             B index. (default: 0)
526              
527             =back
528              
529             =cut
530             sub set_fields_as_vars ($;%) {
531 0     0 1 0 my $self = shift;
532 0         0 my $pkg_name = shift;
533 0         0 my %args = (
534             field_ind=>0,
535             @_
536             );
537              
538 0         0 my $field_ind = $args{field_ind};
539              
540 0         0 while (my ($key, $value) = each %{$self->{FIELDS}})
  0         0  
541             {
542 0         0 $key =~ m#([a-zA-Z0-9][-_a-zA-Z0-9]*)#; # keep taint happy
543 0         0 my $field = $1;
544 0         0 my $varname = "${pkg_name}::${field}";
545 0 0       0 if (ref $value eq 'ARRAY')
    0          
546             {
547 8     8   50 no strict 'refs';
  8         17  
  8         1285  
548 0         0 my $num_vals = @{$value};
  0         0  
549 0         0 for (my $i=0; $i < $num_vals; $i++)
550             {
551 0         0 my $tval = ${$value}[$i];
  0         0  
552 0         0 $tval =~ m#([^`]*)#s;
553 0         0 my $val = $1;
554 0 0       0 if ($num_vals > 0)
555             {
556 0 0       0 if ($i == 0)
    0          
557             {
558 0         0 $$varname = $val;
559 0         0 @$varname = ();
560             }
561             elsif ($i == $field_ind)
562             {
563 0         0 $$varname = $val;
564             }
565 0         0 $$varname[$i] = $val;
566             }
567             else
568             {
569 0         0 $$varname = $val;
570             }
571             }
572             }
573             elsif (!ref $value)
574             {
575 8     8   56 no strict 'refs';
  8         23  
  8         13996  
576 0         0 $value =~ m#([^`]*)#s;
577 0         0 my $val = $1;
578 0         0 $$varname = $val;
579             }
580             }
581             } # set_fields_as_vars
582              
583             =head2 match
584              
585             $row_obj->match(Author=>qr/Li.a/,
586             Universe=>'Buffy',
587             Year=>'> 2001')
588              
589             Checks if this row matches the hash.
590             The hash is in the form of Field => value pairs, where
591             the value can be a plain value,
592             a comparison (< > = eq ne ...)
593             or a regular expression.
594              
595             If the plain value or the comparison starts with '!'
596             then the sense of the comparison is reversed.
597              
598             Returns:
599             1 if matches all conditions, 0 if fails
600              
601             =cut
602             sub match ($%) {
603 552     552 1 718 my $self = shift;
604 552         1238 my %match = (@_);
605 552         784 my $fields = $self->{FIELDS};
606 552         641 my $retval = 0;
607              
608 552         616 my $found = 0;
609 552         1679 while (my ($fn, $re) = each %match)
610             {
611 552         1164 my $val = $self->FETCH($fn);
612 552 100 66     1767 if (defined $val and is_matched($val, $re))
613             {
614 164         639 $found++;
615             }
616             }
617 552 100       1242 $retval = 1 if $found == scalar keys %match;
618              
619 552         2479 return $retval;
620             } # match
621              
622             =head2 match_any
623              
624             $row_obj->match_any($match_str);
625              
626             Checks if any field in this row matches the string.
627              
628             Returns:
629             1 if any field matches the string, 0 if fails
630              
631             =cut
632             sub match_any ($$) {
633 0     0 1 0 my $self = shift;
634 0         0 my $match_str = shift;
635 0         0 my $fields = $self->{FIELDS};
636 0         0 my $retval = 0;
637              
638 0         0 my $found = 0;
639 0         0 while (my $fn = each %{$fields})
  0         0  
640             {
641 0         0 my $val = $self->FETCH($fn);
642 0 0 0     0 if (defined $val and is_matched($val, $match_str))
643             {
644 0         0 $found++;
645             }
646             }
647 0 0       0 $retval = 1 if ($found > 0);
648              
649 0         0 return $retval;
650             } # match_any
651              
652             =head1 Tie-Hash METHODS
653              
654             =head2 TIEHASH
655              
656             Create a new instance of the object as tied to a hash.
657              
658             tie %person, 'Tie::FieldVals::Row', fields=>\@keys;
659              
660             The B argument defines the names of the legal fields.
661             Legal fields can also be set from a string when using the B
662             argument to L or L.
663              
664             =cut
665             sub TIEHASH {
666 627 50   627   1314 carp &whowasi if $DEBUG;
667 627         851 my $class = shift;
668 627         1872 my %args = (
669             fields=>undef,
670             @_
671             );
672 627 50       1505 if (!defined $args{fields})
673             {
674 0         0 croak "Tie::FieldVals::Row -- no fields given";
675             }
676 627         680 my @keys = @{$args{fields}};
  627         2664  
677              
678 627         836 my %hash;
679              
680 627         4005 @hash{@keys} = (undef) x @keys;
681 627         1153 my $self = {};
682 627         1339 $self->{FIELDS} = \%hash;
683 627         1009 $self->{OPTIONS} = \%args;
684              
685 627         3128 bless $self, $class;
686             } # TIEHASH
687              
688             =head2 FETCH
689              
690             Get a key=>value from the hash.
691             Some values may be multi-values, and can either be gotten as an array
692             reference or joined together.
693             If a key is not an official key, undefined is returned.
694              
695             $val = $hash{$key}
696              
697             Gets the value, or if it is a multi-value, gets the values joined
698             by spaces.
699              
700             $val = $hash{\$key}
701              
702             Gets the whole key field as an array ref.
703              
704             $match = {$key=>'##'};
705             $val = $hash{$match};
706              
707             $match = [$key, '##'];
708             $val = $hash{$match};
709              
710             Gets the value, or if it is a multi-value, gets the values joined
711             by the given string (in this case, '##').
712              
713             See also L to determine whether a field is a multi-valued
714             field.
715              
716             =cut
717             sub FETCH {
718 1230 50   1230   2756 carp &whowasi if $DEBUG;
719 1230         1753 my ($self, $match) = @_;
720 1230         1580 my $key = '';
721 1230         1365 my $separator = ' ';
722 1230         1347 my $return_array = 0;
723              
724 1230 100       2118 if (ref $match) {
725 478 50       927 if (ref $match eq 'SCALAR') {
    0          
    0          
726 478         653 $key = $$match;
727 478         658 $return_array = 1;
728             }
729             elsif (ref $match eq 'HASH') {
730 0         0 my @keys = keys %{$match};
  0         0  
731 0         0 $key = shift @keys;
732 0         0 $separator = $match->{$key};
733             }
734             elsif (ref $match eq 'ARRAY') {
735 0         0 $key = shift @{$match};
  0         0  
736 0         0 $separator = shift @{$match};
  0         0  
737             }
738             else {
739 0         0 carp "invalid match '", ref $match, "' to FETCH hash";
740 0         0 return undef;
741             }
742             }
743             else {
744 752         1129 $key = $match; # just a plain key
745             }
746              
747 1230 50       2880 unless (exists $self->{FIELDS}->{$key}) {
748 0         0 return undef;
749             }
750              
751 1230 50       2935 if (ref $self->{FIELDS}->{$key} eq 'ARRAY') {
752 1230         1289 my $count = @{$self->{FIELDS}->{$key}};
  1230         2420  
753              
754 1230 100       2738 if ($return_array)
    50          
755             {
756 478         1988 return $self->{FIELDS}->{$key};
757             }
758             # if there's only one, return it
759             elsif ($count == 1) {
760 752         861 return @{$self->{FIELDS}->{$key}}[0];
  752         2592  
761             }
762             else {
763             # otherwise, return the values joined together
764 0         0 return join($separator, @{$self->{FIELDS}->{$key}});
  0         0  
765             }
766             }
767             else {
768 0         0 return $self->{FIELDS}->{$key};
769             }
770              
771             } # FETCH
772              
773             =head2 STORE
774              
775             Add a key=>value to the hash.
776             Either add a single value, or an array reference to create a
777             multi-value.
778              
779             If a key is not an official key, nothing is set, and it
780             complains of error.
781              
782             $hash{$key} = $val;
783             $hash{$key} = [$v1,$v2,$v3];
784              
785             =cut
786             sub STORE {
787 4 50   4   9 carp &whowasi if $DEBUG;
788 4         8 my ($self, $match, $val) = @_;
789 4         5 my $key = '';
790              
791 4 50       8 if (ref $match) {
792 0         0 carp "invalid match '", ref $match, "' to STORE hash";
793 0         0 return undef;
794             }
795             else {
796 4         6 $key = $match; # just a plain key
797             }
798 4 50       13 unless (exists $self->{FIELDS}->{$key}) {
799              
800 0         0 carp "invalid key [$key] in hash\n";
801 0         0 return undef;
802             }
803              
804 4 50       8 if (ref $val) {
805 0 0       0 if (ref $val eq 'ARRAY') {
806 0         0 $self->{FIELDS}->{$key} = $val;
807             }
808             else
809             {
810 0         0 carp "invalid value reference '", ref $val, "' to STORE hash";
811 0         0 return undef;
812             }
813             }
814             else {
815 4         18 $self->{FIELDS}->{$key} = [$val];
816             }
817              
818             } # STORE
819              
820             =head2 DELETE
821              
822             Remove a key=>value from the hash, only if it exists.
823              
824             =cut
825             sub DELETE {
826 0 0   0   0 carp &whowasi if $DEBUG;
827 0         0 my ($self, $key) = @_;
828              
829 0 0       0 return unless exists $self->{FIELDS}->{$key};
830              
831 0         0 my $ret = $self->{FIELDS}->{$key};
832              
833 0         0 $self->{FIELDS}->{$key} = undef;
834              
835 0         0 return $ret;
836             } # DELETE
837              
838             =head2 CLEAR
839              
840             Remove all the data from the hash.
841              
842             =cut
843             sub CLEAR {
844 614 50   614   1210 carp &whowasi if $DEBUG;
845 614         795 my $self = shift;
846              
847 614         694 $self->{FIELDS}->{$_} = undef foreach keys %{$self->{FIELDS}};
  614         6125  
848             } # CLEAR
849              
850             =head2 EXISTS
851              
852             Does this key exist?
853              
854             =cut
855             sub EXISTS {
856 224 50   224   1163 carp &whowasi if $DEBUG;
857 224         265 my $self = shift;
858 224         288 my $key = shift;
859              
860 224         691 return exists $self->{FIELDS}->{$key};
861             } # EXISTS
862              
863             =head2 FIRSTKEY
864              
865             Get the first key of this hash.
866              
867             =cut
868             sub FIRSTKEY {
869 18 50   18   3872 carp &whowasi if $DEBUG;
870 18         33 my $self = shift;
871              
872 18         23 my $a = keys %{$self->{FIELDS}}; # reset each() iterator
  18         36  
873 18         23 each %{$self->{FIELDS}};
  18         75  
874             } # FIRSTKEY
875              
876             =head2 NEXTKEY
877              
878             Get the next key of this hash.
879              
880             =cut
881             sub NEXTKEY {
882 203 50   203   386 carp &whowasi if $DEBUG;
883 203         263 my $self = shift;
884 203         234 my $lastkey = shift; # previous key
885              
886 203         198 each %{$self->{FIELDS}};
  203         606  
887             } # NEXTKEY
888              
889             sub DESTROY {
890 627 50   627   9382 carp &whowasi if $DEBUG;
891             }
892              
893             =head1 PRIVATE METHODS
894              
895             For developer reference only.
896              
897             =head2 debug
898              
899             Set debugging on.
900              
901             =cut
902 0 0   0 1 0 sub debug { $DEBUG = @_ ? shift : 1 }
903              
904             =head2 whowasi
905              
906             For debugging: say who called this
907              
908             =cut
909 0     0 1 0 sub whowasi { (caller(1))[3] . '()' }
910              
911             =head2 is_matched($str,$re)
912              
913             Check if the string matches the expression.
914              
915             =cut
916             sub is_matched {
917 552     552 1 812 my($str,$re)=@_;
918 552 50       1148 if (ref $re eq 'Regexp') {
919 0 0       0 return $str =~ /$re/ ? 1 : 0;
920             }
921 552         580 my $op;
922             my $val;
923 552         617 my $negate = 0;
924 552         607 my $retval = 0;
925              
926             # if it starts with a ! and isn't !=
927             # then negate the match
928 552 50 33     2449 if ($re and $re =~ /^![^=]/)
929             {
930 0         0 $negate = 1;
931 0         0 $re =~ s/^!//;
932             }
933 552 100 66     3261 if ( $re and $re =~/^(\S*)\s+(.*)/ ) {
    50          
934 314         554 $op = $1;
935 314         618 $val = $2;
936              
937 314         393 my $numop = '< > == != <= >=';
938 314         352 my $chrop = 'lt gt eq ne le ge';
939 314 100 100     1799 if (!($numop =~ /$op/) and !($chrop =~ /$op/)) {
    100          
940 25 100       74 $retval = ($str =~ /$re/ ? 1 : 0);
941             }
942             elsif ($numop =~ /$op/) {
943 119 100       212 my $num = ($str ? $str : 0);
944 119 50       586 if ($op eq '<' ) { $retval = ($num < $val); }
  0 50       0  
    50          
    50          
    50          
    50          
945 0         0 elsif ($op eq '>' ) { $retval = ($num > $val); }
946 0         0 elsif ($op eq '==') { $retval = ($num == $val); }
947 0         0 elsif ($op eq '!=') { $retval = ($num != $val); }
948 0         0 elsif ($op eq '<=') { $retval = ($num <= $val); }
949 119         273 elsif ($op eq '>=') { $retval = ($num >= $val); }
950             } else {
951 170 50       520 if ($op eq 'lt') { $retval = ($str lt $val); }
  0 50       0  
    50          
    0          
    0          
    0          
952 0         0 elsif ($op eq 'gt') { $retval = ($str gt $val); }
953 170         336 elsif ($op eq 'eq') { $retval = ($str eq $val); }
954 0         0 elsif ($op eq 'ne') { $retval = ($str ne $val); }
955 0         0 elsif ($op eq 'le') { $retval = ($str le $val); }
956 0         0 elsif ($op eq 'ge') { $retval = ($str ge $val); }
957             }
958              
959             }
960             elsif ($re) {
961 238 100       728 $retval = ($str =~ /$re/ ? 1 : 0);
962             }
963             else {
964 0 0       0 $retval = ($str eq '' ? 1 : 0);
965             }
966              
967 552 50       1086 if ($negate)
968             {
969 0         0 return (!$retval);
970             }
971 552         3193 return $retval;
972             }
973              
974             =head1 REQUIRES
975              
976             Test::More
977             Carp
978              
979             =head1 SEE ALSO
980              
981             perl(1).
982             L
983              
984             =head1 BUGS
985              
986             Please report any bugs or feature requests to the author.
987              
988             =head1 AUTHOR
989              
990             Kathryn Andersen (RUBYKAT)
991             perlkat AT katspace dot com
992             http://www.katspace.com
993              
994             =head1 COPYRIGHT AND LICENCE
995              
996             Copyright (c) 2004 by Kathryn Andersen
997              
998             This program is free software; you can redistribute it and/or modify it
999             under the same terms as Perl itself.
1000              
1001              
1002             =cut
1003              
1004             1; # End of Tie::FieldVals::Row
1005             __END__