File Coverage

blib/lib/Tie/FieldVals/Select.pm
Criterion Covered Total %
statement 130 290 44.8
branch 42 128 32.8
condition 21 61 34.4
subroutine 15 25 60.0
pod 7 7 100.0
total 215 511 42.0


line stmt bran cond sub pod time code
1             package Tie::FieldVals::Select;
2 6     6   8776 use strict;
  6         13  
  6         253  
3 6     6   30 use warnings;
  6         12  
  6         296  
4              
5             =head1 NAME
6              
7             Tie::FieldVals::Select - an array tie for a subset of Tie::FieldVals data
8              
9             =head1 VERSION
10              
11             This describes version B<0.6202> of Tie::FieldVals::Select.
12              
13             =cut
14              
15             our $VERSION = '0.6202';
16              
17             =head1 SYNOPSIS
18              
19             use Tie::FieldVals;
20             use Tie::FieldVals::Row;
21             use Tie::FieldVals::Select;
22              
23             my @sel_recs;
24             my $sel_obj = tie @sel_recs, 'Tie::FieldVals::Select',
25             datafile=>$datafile, selection=>{$key=>$value...};
26              
27             # sort the records
28             $sel_obj->sort_records(sort_by=>@sort_order);
29              
30             =head1 DESCRIPTION
31              
32             This is a Tie object to map a SUBSET of the records in a Tie::FieldVals
33             data file into an array. It is a sub-class of Tie::FieldVals. This is
34             useful as a separate object because one can do things to it without
35             affecting the underlying file, unlike with a Tie::FieldVals object. One
36             can re-select the data, sort the data, or take a temporary "slice" of the
37             data.
38              
39             This depends on the Tie::FieldVals and Tie::FieldVals::Row modules.
40              
41             =cut
42              
43 6     6   153 use 5.006;
  6         16  
  6         236  
44 6     6   28 use strict;
  6         10  
  6         187  
45 6     6   31 use Carp;
  6         9  
  6         393  
46 6     6   28 use Tie::FieldVals;
  6         24  
  6         119  
47 6     6   34 use Tie::FieldVals::Row;
  6         10  
  6         126  
48 6     6   31 use Fcntl qw(:DEFAULT);
  6         9  
  6         2827  
49 6     6   45 use Data::Dumper;
  6         23  
  6         17897  
50              
51             our @ISA = qw(Tie::FieldVals);
52              
53             # to make taint happy
54             $ENV{PATH} = "/bin:/usr/bin:/usr/local/bin";
55             $ENV{CDPATH} = '';
56             $ENV{BASH_ENV} = '';
57              
58             # for debugging
59             my $DEBUG = 0;
60              
61             #================================================================
62             # Methods
63              
64             =head1 OBJECT METHODS
65              
66             =head2 make_selection
67              
68             Select the records (again). Resets the selection and re-makes it
69             with the new selection criteria.
70              
71             $arr_obj->make_selection(selection=>{$key=>$value},
72             match_any=>$val2);
73              
74             $arr_obj->make_selection(selection=>$value);
75              
76             =cut
77             sub make_selection {
78 7     7 1 13 my $self = shift;
79 7         56 my %args = (
80             selection=>undef,
81             match_any=>undef,
82             @_
83             );
84 7         17 my $select = $args{selection};
85 7         16 my $match_any = $args{match_any};
86              
87             # now, apply the selection to the records
88 7         11 my @records = ();
89 7         100 my $count = $self->SUPER::FETCHSIZE();
90 7         7400 for (my $i=0; $i < $count; $i++)
91             {
92 578         544 my $add_this_row = 0;
93             # if there is no 'selection' then get all the records
94 578 100 66     3760 if ((!defined $select || !$select)
    50 33        
    50          
    50          
    50          
95             && (!defined $match_any || !$match_any))
96             {
97 196         169 $add_this_row = 1;
98             }
99             elsif (!ref $select) # match any
100             {
101 0         0 my $row_ref = $self->SUPER::FETCH($i);
102 0         0 my $row_obj = tied %{$row_ref};
  0         0  
103 0 0       0 if ($row_obj->match_any($select))
104             {
105 0         0 $add_this_row = 1;
106             }
107             }
108             elsif (defined $match_any && $match_any)
109             {
110 0         0 my $row_ref = $self->SUPER::FETCH($i);
111 0         0 my $row_obj = tied %{$row_ref};
  0         0  
112 0 0       0 if ($row_obj->match_any($match_any))
113             {
114 0         0 $add_this_row = 1;
115             }
116             }
117             elsif (ref $select eq 'ARRAY') # select a range
118             {
119 0         0 my $first = ${$select}[0];
  0         0  
120 0         0 my $last = ${$select}[1];
  0         0  
121 0 0 0     0 if ($i >= $first && $i <= $last)
122             {
123 0         0 $add_this_row = 1;
124             }
125             }
126             elsif (ref $select eq 'HASH')
127             {
128 382         1247 my $row_ref = $self->SUPER::FETCH($i);
129 382         457 my $row_obj = tied %{$row_ref};
  382         550  
130 382 100       421 if ($row_obj->match(%{$select}))
  382         1418  
131             {
132 45         80 $add_this_row = 1;
133             }
134             }
135             # add the index for this row to our records
136 578 100       1493 if ($add_this_row)
137             {
138 241         507 push @records, $i;
139             }
140             }
141 7         19 $self->{SEL_RECS} = \@records;
142             # set the full slice
143 7         23 $self->{OPTIONS}->{start_rec} = 0;
144 7         10 $self->{OPTIONS}->{num_recs} = scalar @{$self->{SEL_RECS}};
  7         41  
145              
146             } # make_selection
147              
148             =head2 set_sel_slice
149              
150             Set this selection to a sub-set of itself. In other words,
151             keep the original selection, but perform all operations
152             on a slice of it. Assumes the array is sorted, and that
153             the selection is related to the sort order (for example,
154             that I=>I where I is the first key of the sort
155             order).
156              
157             $arr_obj->set_sel_slice(selection=>{$key=>$value},
158             match_any=>$val2,
159             start_at_zero=>0);
160              
161             =cut
162             sub set_sel_slice {
163 0     0 1 0 my $self = shift;
164 0         0 my %args = (
165             selection=>undef,
166             match_any=>undef,
167             start_at_zero=>0,
168             @_
169             );
170              
171 0         0 my $select = $args{selection};
172 0         0 my $match_any = $args{match_any};
173 0 0       0 if ($DEBUG)
174             {
175 0         0 print STDERR "set_sel_slice:";
176 0         0 print STDERR " selection=";
177 0         0 print STDERR Dumper($select);
178             }
179              
180             # now, apply the sub-selection to the current selection
181 0         0 my @records = ();
182 0         0 my $count = @{$self->{SEL_RECS}};
  0         0  
183 0         0 my $start_range = 0;
184 0         0 my $start_offset;
185 0 0       0 if ($args{start_at_zero})
186             {
187 0         0 $self->{OPTIONS}->{start_rec} = 0;
188 0         0 $start_offset = 0;
189             }
190             else
191             {
192             # start from the next record after the current slice
193             # but only if we have been slicing
194 0 0       0 if ($self->{OPTIONS}->{num_recs} < $count)
195             {
196 0         0 $self->{OPTIONS}->{start_rec} +=
197             $self->{OPTIONS}->{num_recs};
198             }
199 0         0 $start_offset = $self->{OPTIONS}->{start_rec};
200             # set the count to be from the offset start
201             # to the end of the SEL_RECS array
202 0         0 $count = ($count - $self->{OPTIONS}->{start_rec});
203             }
204             # reset the curent slice to be as big as possible
205 0         0 $self->{OPTIONS}->{num_recs} = $count;
206              
207 0         0 my $end_range = 0;
208 0         0 my $matches = 0;
209 0         0 my $this_row_matches = 0;
210 0         0 my $match_found = 0;
211 0 0       0 if ($DEBUG)
212             {
213 0         0 print STDERR "set_sel_slice: checking $count records\n";
214             }
215 0         0 for (my $i=0; $i < $count; $i++)
216             {
217 0         0 $this_row_matches = 0;
218             # if there is no 'selection' then get all the records
219 0 0 0     0 if (!defined $select && !defined $match_any)
    0 0        
    0          
    0          
    0          
220             {
221 0         0 $this_row_matches = 1;
222             }
223             elsif (!ref $select) # match any
224             {
225 0         0 my $row_ref = $self->FETCH($i);
226 0         0 my $row_obj = tied %{$row_ref};
  0         0  
227 0 0       0 if ($row_obj->match_any($select))
228             {
229 0         0 $this_row_matches = 1;
230             }
231             }
232             elsif (ref $select eq 'ARRAY')
233             {
234 0         0 my $first = ${$select}[0];
  0         0  
235 0         0 my $last = ${$select}[1];
  0         0  
236 0 0 0     0 if ($i >= $first && $i <= $last)
237             {
238 0         0 $this_row_matches = 1;
239             }
240             }
241             elsif (ref $select eq 'HASH')
242             {
243 0         0 my $row_ref = $self->FETCH($i);
244 0         0 my $row_obj = tied %{$row_ref};
  0         0  
245 0 0       0 if ($row_obj->match(%{$select}))
  0         0  
246             {
247 0         0 $this_row_matches = 1;
248 0 0       0 if ($DEBUG)
249             {
250 0         0 print STDERR "row=[$i]";
251 0         0 print STDERR Dumper($row_ref);
252             }
253             }
254             }
255             elsif (defined $match_any && $match_any)
256             {
257 0         0 my $row_ref = $self->FETCH($i);
258 0         0 my $row_obj = tied %{$row_ref};
  0         0  
259 0 0       0 if ($row_obj->match_any($match_any))
260             {
261 0         0 $this_row_matches = 1;
262             }
263             }
264             # have we started matching?
265 0 0       0 if (!$matches)
266             {
267 0 0       0 if ($this_row_matches)
268             {
269 0         0 $start_range = $i;
270 0         0 $match_found = 1;
271 0         0 $matches = 1;
272             }
273             }
274             # the end-range is always increasing so long
275             # as the row matches
276 0 0       0 if ($this_row_matches)
277             {
278 0         0 $end_range = $i;
279             }
280             # have we stopped matching? If so, stop looking.
281 0 0       0 if ($matches)
282             {
283 0 0       0 if (!$this_row_matches)
284             {
285 0         0 $matches = 0;
286 0         0 last;
287             }
288             }
289             }
290 0         0 $self->{OPTIONS}->{start_rec} = $start_offset + $start_range;
291 0         0 $self->{OPTIONS}->{num_recs} = ($end_range - $start_range) + 1;
292 0 0       0 if (!$match_found)
293             {
294 0         0 $self->{OPTIONS}->{num_recs} = 0;
295             }
296 0 0       0 if ($DEBUG)
297             {
298 0         0 print STDERR "set_sel_slice:";
299 0         0 print STDERR " start_rec=", $self->{OPTIONS}->{start_rec};
300 0         0 print STDERR " end_range=", $end_range;
301 0         0 print STDERR " num_recs=", $self->{OPTIONS}->{num_recs};
302 0         0 print STDERR "\n";
303             }
304             } # set_sel_slice
305              
306             =head2 clear_sel_slice
307              
308             Restore this selection to the full selection (if it has been
309             previously "sliced"). If it hasn't been previously sliced, then
310             calling this makes no difference.
311              
312             $arr_obj->clear_sel_slice();
313              
314             =cut
315             sub clear_sel_slice {
316 0     0 1 0 my $self = shift;
317 0         0 my %args = (
318             @_
319             );
320              
321 0         0 $self->{OPTIONS}->{start_rec} = 0;
322 0         0 $self->{OPTIONS}->{num_recs} = scalar @{$self->{SEL_RECS}};
  0         0  
323             } # clear_sel_slice
324              
325             =head2 sort_records
326              
327             $sel->sort_records(
328             sort_by=>[qw(Author Series SeriesOrder Title Date)],
329             sort_numeric=>{ SeriesOrder=>1 },
330             sort_title=>{ Title=>1 },
331             sort_lastword=>{ Author=>1 },
332             sort_reversed=>{ Date=>1 });
333              
334             Take the current selected records array and sort it by field names.
335             The B array contains an array of field names for this data.
336             Yes, that's right, you can sort on multiple fields.
337              
338             The other arguments are for indications of changes to the type of sorting
339             done on the given fields.
340              
341             =over
342              
343             =item sort_numeric
344              
345             The given field(s) should be sorted as numbers.
346             Note that for multi-valued fields, this compares only the first value
347             in the set.
348              
349             =item sort_title
350              
351             The given field(s) should be treated as titles: any leading "The "
352             or "A " will be ignored.
353              
354             =item sort_lastword
355              
356             The given field(s) will be sorted with their last word first
357             (such as for surnames).
358              
359             =item sort_reversed
360              
361             The given field(s) will be sorted in reverse order.
362              
363             =back
364              
365             =cut
366             sub sort_records ($%) {
367 12     12 1 4634 my $self = shift;
368 12         67 my %args = (
369             sort_by => undef,
370             sort_numeric => undef,
371             sort_reversed => undef,
372             sort_title => undef,
373             sort_lastword => undef,
374             @_
375             );
376 12         22 my $records_ref = $self->{SEL_RECS};
377              
378 12         16 my @sort_fields = @{$args{sort_by}};
  12         26  
379 12         19 my @sort_order = ();
380 3         10 my %sort_numerically = (defined $args{sort_numeric}
381 12 100       35 ? %{$args{sort_numeric}} : ());
382 5         15 my %sort_reversed = (defined $args{sort_reversed}
383 12 100       29 ? %{$args{sort_reversed}} : ());
384 12 100       28 my %sort_title = (defined $args{sort_title} ? %{$args{sort_title}} : ());
  2         6  
385 2         5 my %sort_lastword = (defined $args{sort_lastword}
386 12 100       31 ? %{$args{sort_lastword}} : ());
387             # filter out any illegal fields
388 12         19 foreach my $sfname (@sort_fields)
389             {
390 15 50 33     129 if (exists $self->{field_names_hash}->{$sfname}
      33        
391             && defined $self->{field_names_hash}->{$sfname}
392             && $self->{field_names_hash}->{$sfname})
393             {
394 15         33 push @sort_order, $sfname;
395             }
396             }
397              
398             # pre-cache the actual comparison values
399 12         21 my %values = ();
400 12         15 foreach my $rec (@{$records_ref})
  12         20  
401             {
402 289         942 my $a_row = $self->SUPER::FETCH($rec);
403 289         766 $values{$rec} = {};
404 289         443 foreach my $fn (@sort_order)
405             {
406             # allow for multi-valued fields
407 364         347 my @a_arr = @{$a_row->{\$fn}};
  364         1479  
408 364 50       828 if (!@a_arr)
409             {
410 0 0 0     0 if (defined $sort_numerically{$fn}
411             && $sort_numerically{$fn})
412             {
413             # sort undefined as zero
414 0         0 $values{$rec}->{$fn} = 0;
415             }
416             else
417             {
418             # sort undefined as the empty string
419 0         0 $values{$rec}->{$fn} = '';
420             }
421             }
422             else
423             {
424 364         403 my $a_val = '';
425 364 100 66     1002 if (defined $sort_numerically{$fn}
426             && $sort_numerically{$fn})
427             {
428             # multi-valued fields don't make sense for
429             # numeric comparisons, so just take the first one
430 31         39 $a_val = $a_arr[0];
431 31         48 $a_val =~ s/\s//g; # remove any spaces
432             # non-numeric data should be compared as zero
433 31 100 66     181 if (!defined $a_val
      66        
434             || !$a_val
435             || $a_val =~ /\D/)
436             {
437 6         9 $a_val = 0;
438             }
439             }
440             else # strings
441             {
442             # allow for titles
443 333 100       600 if ($sort_title{$fn})
444             {
445 6         10 @a_arr = map { s/^(The\s+|A\s+)//; $_ } @a_arr;
  7         22  
  7         20  
446             }
447             # do lastword stuff
448 333 100       578 if ($sort_lastword{$fn})
449             {
450 50         60 @a_arr = map { s/^(.*)\s+(\w+)$/$2,$1/; $_ } @a_arr;
  50         279  
  50         150  
451             }
452 333         619 $a_val = join('###', @a_arr);
453             }
454 364         1487 $values{$rec}->{$fn} = $a_val;
455             }
456             }
457             }
458              
459 495         488 my @sorted_records = sort {
460 12         63 my $result = 0;
461 495         556 foreach my $fn (@sort_order)
462             {
463 551         845 my $a_val = $values{$a}->{$fn};
464 551         837 my $b_val = $values{$b}->{$fn};
465 551 100 66     2358 $result =
    50 66        
    100 33        
466             (
467             (defined $sort_reversed{$fn} && $sort_reversed{$fn})
468             ? (
469             (defined $sort_numerically{$fn} && $sort_numerically{$fn})
470             ? ($b_val <=> $a_val)
471             : ($b_val cmp $a_val)
472             )
473             : (
474             (defined $sort_numerically{$fn} && $sort_numerically{$fn})
475             ? ($a_val <=> $b_val)
476             : ($a_val cmp $b_val)
477             )
478             );
479 551 100       1033 if ($result != 0)
480             {
481 407         629 return $result;
482             }
483             }
484 88         147 $result;
485 12         23 } @{$records_ref};
486              
487 12         25 @{$self->{SEL_RECS}} = @sorted_records;
  12         345  
488              
489             } # sort_records
490              
491             =head2 get_column
492              
493             Get the data from a column.
494              
495             my @col = $obj->get_column(field_name=>$field_name,
496             unique=>1);
497              
498             If unique is true, then duplicate values will be eliminated.
499              
500             This can be useful in operating on subsets of the selection, for example if
501             one has sorted on a field, then one gets the column data for that field,
502             with "unique" to true, then calls L with each unique
503             value...
504              
505             =cut
506             sub get_column ($%) {
507 0     0 1 0 my $self = shift;
508 0         0 my %args = (
509             field_name =>'',
510             unique =>1,
511             @_
512             );
513              
514 0         0 my @col = ();
515 0         0 my %col_vals = ();
516 0         0 for (my $i=0; $i < @{$self->{SEL_RECS}}; $i++)
  0         0  
517             {
518 0         0 my $vals_ref = $self->FETCH($i);
519 0         0 my $val = $vals_ref->{$args{field_name}};
520 0 0       0 if ($args{unique})
521             {
522 0 0       0 if (!$col_vals{$val})
523             {
524 0         0 push @col, $val;
525             }
526             }
527             else
528             {
529 0         0 push @col, $val;
530             }
531 0         0 $col_vals{$val} = 1;
532             }
533 0         0 return @col;
534             } # get_column
535              
536             #================================================================
537             # Tie-Array interface
538              
539             =head1 TIE-ARRAY METHODS
540              
541             =head2 TIEARRAY
542              
543             Create a new instance of the object as tied to an array.
544              
545             tie @SEL_RECS, 'Tie::FieldVals::Select',
546             datafile=>$datafile, selection=>{$key=>$value},
547             match_any=>$val_any;
548              
549             The selection and match_any options are the selection criteria
550             used to define this sub-set; they have the same format as
551             those used in L and
552             L methods.
553              
554             Other options are the same as for L.
555              
556             =cut
557             sub TIEARRAY {
558 7     7   1088 my $class = shift;
559              
560             # make the parent tie
561 7         36 my $self = Tie::FieldVals::TIEARRAY($class, @_);
562             # now, FILE_OBJ, FILE_RECS, OPTIONS, REC_CACHE, field_names
563             # field_names_hash
564             # should be set
565            
566             # set the default additional options
567 7   100     77 $self->{OPTIONS}->{selection} ||= undef;
568 7   50     46 $self->{OPTIONS}->{match_any} ||= undef;
569              
570             # now, apply the selection to the records
571 7         11 $self->make_selection(%{$self->{OPTIONS}});
  7         48  
572              
573 7         47 return $self;
574             } # TIEARRAY
575              
576             =head2 FETCH
577              
578             Get a row from the array.
579              
580             $val = $array[$ind];
581              
582             Returns a reference to a Tie::FieldVals::Row hash, or undef.
583              
584             =cut
585             sub FETCH {
586 239 50   239   2722 carp &whowasi if $DEBUG;
587 239         291 my ($self, $ind) = @_;
588              
589 239 100 66     1060 if ($ind >= 0 && $ind < $self->{OPTIONS}->{num_recs})
590             {
591 238         361 my $s_ind = $ind + $self->{OPTIONS}->{start_rec};
592 238         238 my $real_ind = ${$self->{SEL_RECS}}[$s_ind];
  238         465  
593 238 50       479 if ($DEBUG)
594             {
595 0         0 print STDERR "ind=$ind";
596 0         0 print STDERR " s_ind=$s_ind";
597 0         0 print STDERR " real_ind=$real_ind";
598 0         0 print STDERR "\n";
599 0         0 print STDERR Dumper(${$self->{FILE_RECS}}[$real_ind]);
  0         0  
600             }
601 238         698 return $self->SUPER::FETCH($real_ind);
602             }
603 1         5 return undef;
604             } # FETCH
605              
606             =head2 STORE
607              
608             Set a value in the array.
609              
610             $array[$ind] = $val;
611              
612             If $ind is bigger than the array, then do nothing. (If you want to add a
613             new row to the data file, do it directly with the Tie::FieldVals array.)
614             The $val is expected to be a Tie::FieldVals::Row hash.
615             This I replace the given the data in the data file.
616              
617             =cut
618             sub STORE {
619 0 0   0   0 carp &whowasi if $DEBUG;
620 0         0 my ($self, $ind, $val) = @_;
621              
622 0 0 0     0 if ($ind >= 0 && $ind < $self->{OPTIONS}->{num_recs})
623             {
624 0         0 my $s_ind = $ind + $self->{OPTIONS}->{start_rec};
625 0         0 my $real_ind = ${$self->{SEL_RECS}}[$s_ind];
  0         0  
626 0         0 $self->SUPER::STORE($real_ind, $val);
627             }
628             } # STORE
629              
630             =head2 FETCHSIZE
631              
632             Get the apparent size of the array. This gives the
633             size of the current slice, not the size of the underlying
634             array. Of course if we are not in "slice" mode, the two values
635             will be the same.
636              
637             =cut
638             sub FETCHSIZE {
639 286 50   286   4283 carp &whowasi if $DEBUG;
640 286         300 my $self = shift;
641              
642 286         1383 return $self->{OPTIONS}->{num_recs};
643             } # FETCHSIZE
644              
645             =head2 STORESIZE
646              
647             Set the apparent size of the array.
648             This actually sets the size of the current slice of the array,
649             not the underlying array.
650              
651             =cut
652             sub STORESIZE {
653 0 0   0   0 carp &whowasi if $DEBUG;
654 0         0 my $self = shift;
655 0         0 my $count = shift;
656              
657 0 0       0 if ($count <= @{$self->{SEL_RECS}})
  0         0  
658             {
659 0         0 $self->{OPTIONS}->{num_recs} = $count;
660             }
661             } # STORESIZE
662              
663             =head2 EXISTS
664              
665             exists $array[$ind];
666              
667             Note that if the array is in "slice" mode, this will only
668             say whether the row exists in the slice.
669              
670             =cut
671             sub EXISTS {
672 0 0   0   0 carp &whowasi if $DEBUG;
673 0         0 my $self = shift;
674 0         0 my $ind = shift;
675              
676 0 0 0     0 if ($ind >= 0 && $ind < $self->{OPTIONS}->{num_recs})
677             {
678 0         0 my $s_ind = $ind + $self->{OPTIONS}->{start_rec};
679 0         0 my $real_ind = ${$self->{SEL_RECS}}[$s_ind];
  0         0  
680 0         0 return $self->SUPER::EXISTS($real_ind);
681             }
682 0         0 return 0;
683             } # EXISTS
684              
685             =head2 DELETE
686              
687             delete $array[$ind];
688              
689             Delete the value at $ind -- deletes from the selection.
690             Does not delete from the data file.
691              
692             =cut
693             sub DELETE {
694 0 0   0   0 carp &whowasi if $DEBUG;
695 0         0 my $self = shift;
696 0         0 my $ind = shift;
697              
698 0 0 0     0 if ($ind >= 0 && $ind < $self->{OPTIONS}->{num_recs})
699             {
700 0         0 my $s_ind = $ind + $self->{OPTIONS}->{start_rec};
701 0         0 delete ${$self->{SEL_RECS}}[$s_ind];
  0         0  
702 0         0 $self->{OPTIONS}->{num_recs}--;
703             }
704             } # DELETE
705              
706             =head2 CLEAR
707              
708             @array = ();
709              
710             Clear the array -- clears the selection.
711             Does not affect the data file.
712              
713             =cut
714             sub CLEAR {
715 0 0   0   0 carp &whowasi if $DEBUG;
716 0         0 my $self = shift;
717 0         0 my $ind = shift;
718              
719 0         0 @{$self->{SEL_RECS}} = ();
  0         0  
720 0         0 $self->{OPTIONS}->{start_rec} = 0;
721 0         0 $self->{OPTIONS}->{num_recs} = 0;
722             } # CLEAR
723              
724             =head2 UNTIE
725              
726             untie @array;
727              
728             Untie the array.
729              
730             =cut
731             sub UNTIE {
732 1 50   1   608 carp &whowasi if $DEBUG;
733 1         3 my $self = shift;
734 1         2 my $count = shift;
735              
736 1 50       6 carp "untie attempted while $count inner references still exist" if $count;
737 1         3 $self->{SEL_RECS} = [];
738 1         6 $self->{OPTIONS}->{start_rec} = 0;
739 1         2 $self->{OPTIONS}->{num_recs} = 0;
740 1         14 $self->SUPER::UNTIE($count);
741             } # UNTIE
742              
743             =head1 PRIVATE METHODS
744              
745             For developer reference only.
746              
747             =head2 debug
748              
749             Set debugging on.
750              
751             =cut
752 0 0   0 1   sub debug { $DEBUG = @_ ? shift : 1 }
753              
754             =head2 whowasi
755              
756             For debugging: say who called this
757              
758             =cut
759 0     0 1   sub whowasi { (caller(1))[3] . '()' }
760              
761             =head1 REQUIRES
762              
763             Test::More
764             Carp
765             Data::Dumper
766             Fcntl
767             Tie::FieldVals
768             Tie::FieldVals::Row
769              
770             =head1 SEE ALSO
771              
772             perl(1).
773             L
774             L
775              
776             =head1 BUGS
777              
778             Please report any bugs or feature requests to the author.
779              
780             =head1 AUTHOR
781              
782             Kathryn Andersen (RUBYKAT)
783             perlkat AT katspace dot com
784             http://www.katspace.com
785              
786             =head1 COPYRIGHT AND LICENCE
787              
788             Copyright (c) 2004 by Kathryn Andersen
789              
790             This program is free software; you can redistribute it and/or modify it
791             under the same terms as Perl itself.
792              
793              
794             =cut
795              
796             1; # End of Tie::FieldVals::Select
797             # vim: ts=8 sts=4 sw=4
798             __END__