File Coverage

blib/lib/Fsdb/IO.pm
Criterion Covered Total %
statement 9 261 3.4
branch 0 118 0.0
condition 0 57 0.0
subroutine 3 35 8.5
pod 30 30 100.0
total 42 501 8.3


line stmt bran cond sub pod time code
1             #!/usr/bin/perl -w
2              
3             #
4             # Fsdb::IO.pm
5             # $Id: dac8ca3b6f469025184776b4fd18db3ba3c9b4a0 $
6             #
7             # Copyright (C) 2005-2013 by John Heidemann
8             #
9             # This program is free software; you can redistribute it and/or
10             # modify it under the terms of the GNU General Public License,
11             # version 2, as published by the Free Software Foundation.
12             #
13             # This program is distributed in the hope that it will be useful,
14             # but WITHOUT ANY WARRANTY; without even the implied warranty of
15             # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16             # GNU General Public License for more details.
17             #
18             # You should have received a copy of the GNU General Public License along
19             # with this program; if not, write to the Free Software Foundation, Inc.,
20             # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
21             #
22              
23             package Fsdb::IO;
24              
25             =head1 NAME
26              
27             Fsdb::IO - base class for Fsdb IO (FsdbReader and FsdbWriter)
28              
29              
30             =head1 EXAMPLES
31              
32             There are several ways to do IO. We look at several that compute
33             the product of x and y for this input:
34              
35             #fsdb x y product
36             1 10 -
37             2 20 -
38              
39             The following routes go from most easy-to-use to least,
40             and also from least efficient to most.
41             For IO-intensive work, if fastpath takes 1 unit of time,
42             then using hashes or arrays takes approximately 2 units of time,
43             all due to CPU overhead.
44              
45             =head2 Using A Hash
46              
47             use Fsdb::IO::Reader;
48             use Fsdb::IO::Writer;
49              
50             # preamble
51             my $out;
52             my $in = new Fsdb::IO::Reader(-file => '-', -comment_handler => \$out)
53             or die "cannot open stdin as fsdb\n";
54             $out = new Fsdb::IO::Writer(-file => '-', -clone => $in)
55             or die "cannot open stdin as fsdb\n";
56              
57             # core starts here
58             my %hrow;
59             while ($in->read_row_to_href(\%hrow)) {
60             $hrow{product} = $hrow{x} * $hrow{y};
61             $out->write_row_from_href(\%hrow);
62             };
63              
64             It can be convenient to use a hash because one can easily extract
65             fields using hash keys, but hashes can be slow.
66              
67              
68             =head2 Arrays Instead of Hashes
69              
70             We can add a bit to end of the preamble:
71              
72             my $x_i = $in->col_to_i('x') // die "no x column.\n";
73             my $y_i = $in->col_to_i('y') // die "no y column.\n";
74             my $product_i = $in->col_to_i('product') // die "no product column.\n";
75              
76             And then replace the core with arrays:
77              
78             my @arow;
79             while ($in->read_row_to_aref(\@arow)) {
80             $arow[$product_i] = $arow[$x_i] * $arow[$y_i];
81             $out->write_row_from_aref(\@arow);
82             };
83              
84             This code has two advantages over hrefs:
85             First, there is explicit error checking for presence of
86             the expected fields.
87             Second, arrays are likely a bit faster than hashes.
88              
89              
90             =head2 Objects Instead of Arrays
91              
92             Keeping the same preamble as for arrays,
93             we can directly get internal Fsdb "row objects"
94             with a new core:
95              
96             # core
97             my $rowobj;
98             while ($rowobj = $in->read_rowobj) {
99             if (!ref($rowobj)) {
100             # comment
101             &{$in->{_comment_sub}}($rowobj);
102             next;
103             };
104             $rowobj->[$product_i] = $rowobj->[$x_i] * $rowobj->[$y_i];
105             $out->write_rowobj($rowobj);
106             };
107              
108             This code is a bit faster because we just return the internal
109             representation (a rowobj),
110             rather than copy into an array.
111              
112             However, unfortunately it doesn't handle comment processing.
113              
114              
115             =head2 Fastpathing
116              
117             To go really fast, we can build a custom thunk
118             (a chunk of code) that does exactly what we want.
119             This approach is called a "fastpath".
120              
121             It requires a bit more in the preamble (building on the array version):
122              
123             my $in_fastpath_sub = $in->fastpath_sub();
124             my $out_fastpath_sub = $out->fastpath_sub();
125              
126             And it allows a shorter core (modeled on rowobjs),
127             since the fastpath includes comment processing:
128              
129             my $rowobj;
130             while ($rowobj = &$in_fastpath_sub) {
131             $rowobj->[$product_i] = $rowobj->[$x_i] * $rowobj->[$y_i];
132             &$out_fastpath_sub($rowobj);
133             };
134              
135             This code is the fastest way to implement this block
136             without evaling code.
137              
138              
139             =head1 FUNCTIONS
140              
141             =cut
142              
143             @ISA = ();
144             $VERSION = 2.0;
145              
146 2     2   8 use strict;
  2         2  
  2         42  
147 2     2   6 use IO::File;
  2         2  
  2         192  
148 2     2   8 use Carp;
  2         2  
  2         4374  
149              
150             =head2 new
151              
152             $fsdb = new Fsdb::IO;
153              
154             Creates a new IO object. Usually you should not create a FsdbIO object
155             directly, but instead create a C or C.
156              
157             Options:
158              
159             =over 4
160              
161             =item -fh FILE_HANDLE
162             Write IO to the given file handle.
163              
164             =item -header HEADER_LINE
165             Force the header to the given HEADER_LINE
166             (should be verbatim, including #h or whatever).
167             =back
168              
169             =item -fscode CODE
170             Define just the column (or field) separator fscode part of the header.
171             See L for a list of valid field separators.
172              
173             =item -rscode CODE
174             Define just the row separator part of the header.
175             See L for a list of valid row separators.
176              
177             =item -cols CODE
178             Define just the columns of the header.
179              
180             =item -compression CODE
181             Define the compression mode for the file
182             that will take effect after the header.
183              
184             =item -clone $fsdb
185             Copy the stream's configuration from $FSDB, another Fsdb::IO object.
186              
187             =back
188              
189             =cut
190              
191             sub new {
192 0     0 1   my $class = shift @_;
193 0           my $self = bless {
194             # i/o source: one of:
195             _fh => undef, # filehandle to file
196             _encoding => undef, # encoding (defaults to :utf8)
197             _compression => undef,
198             _queue => undef,# ref to queue
199              
200             _headerrow => undef,
201             _header_set => undef,
202             _header_prequel => undef,
203             # _attributes => {}, # arbitrary attributes for the file
204             # _attributes_set => undef,
205              
206             # field (i.e., column) separator
207             _fscode => 'D', # -C option code, (D=default)
208             _fs => ' ', # field separator
209             _fsre => '\s+', # field separator
210              
211             # row separators
212             _rscode => 'D', # -R (D=default, can be omitted; or R=rowized)
213              
214             _empty => '-',
215              
216             _cols => [], # array of names of the columns (fields)
217             _cols_to_i => {}, # reverse hash mapping names to offsets
218              
219             _fastpath_active => undef, # track fastpathing to avoid breaking it
220              
221             _codifier_sub => undef, # converting perl code with embedded column names
222              
223             _error => undef, # error status (should NEVER end in a newline)
224             }, $class;
225 0           return $self;
226             }
227              
228             =head2 _reset_cols
229              
230             $fsdb->_reset_cols
231              
232             Internal: zero all the mappings in the curren schema.
233             =cut
234              
235             sub _reset_cols {
236 0     0     my($self) = @_;
237             croak "Fsdb::IO::_reset_cols: attempted after _header_set\n"
238 0 0         if ($self->{_header_set});
239 0           $self->{_cols} = [];
240 0           $self->{_cols_to_i} = {};
241 0           $self->{_headerrow} = undef;
242 0           $self->{_debug} = undef;
243             }
244              
245             =head2 config_one
246              
247             $fsdb->config_one($arglist_aref);
248              
249             Parse the first configuration option on the list, removing it.
250              
251             Options are listed in new.
252              
253             =cut
254              
255             sub config_one {
256 0     0 1   my($self, $aaref) = @_;
257 0 0 0       if ($aaref->[0] eq '-fh') {
    0 0        
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
258 0           shift @$aaref;
259 0           $self->{_fh} = shift @$aaref;
260             # should probably check ref to confirm IO::Handle
261             } elsif ($aaref->[0] eq '-queue') {
262 0           shift @$aaref;
263 0           $self->{_queue} = shift @$aaref;
264 0 0         croak "bad -queue argument" if (ref($self->{_queue}) !~ /^Fsdb::BoundedQueue/);
265             } elsif ($aaref->[0] eq '-header') {
266 0           shift @$aaref;
267 0           $self->{_headerrow} = shift @$aaref;
268 0           $self->parse_headerrow; # fill in col mappings, etc.
269             } elsif ($aaref->[0] eq '-fscode' || $aaref->[0] eq '-F') {
270 0           shift @$aaref;
271 0           my $code = shift @$aaref;
272 0           $self->parse_fscode($code);
273 0           $self->update_headerrow;
274             } elsif ($aaref->[0] eq '-rscode' || $aaref->[0] eq '-C') {
275 0           shift @$aaref;
276 0           my $code = shift @$aaref;
277 0           $self->parse_rscode($code);
278 0           $self->update_headerrow;
279             } elsif ($aaref->[0] eq '-cols') {
280 0           shift @$aaref;
281 0           my $col_ref = $aaref->[0]; shift @$aaref;
  0            
282 0           $self->_reset_cols;
283 0           foreach (@$col_ref) {
284 0           $self->_internal_col_create($_);
285             };
286 0           $self->update_headerrow;
287             } elsif ($aaref->[0] eq '-clone') {
288 0           shift @$aaref;
289 0           my($clone) = shift @$aaref;
290 0           $self->_reset_cols;
291 0           $self->parse_fscode($clone->fscode());
292 0           $self->parse_rscode($clone->rscode());
293 0           foreach (@{$clone->cols()}) {
  0            
294 0           $self->_internal_col_create($_);
295             };
296 0           $self->{_encoding} = $clone->{_encoding};
297 0           $self->{_compression} = $clone->{_compression};
298 0           $self->update_headerrow;
299             } elsif ($aaref->[0] eq '-encoding') {
300 0           shift @$aaref;
301 0           $self->{_encoding} = shift @$aaref;
302             } elsif ($aaref->[0] eq '-compression') {
303 0           shift @$aaref;
304 0           $self->{_compression} = shift @$aaref;
305 0 0 0       $self->{_compression} = undef if ($self->{_compression} && $self->{_compression} eq 'none');
306 0           my(%valid_compressions) = qw(bz2 1 gz 1 xz 1);
307             $self->{_error} = "bad compression mode: " . $self->{_compression}
308 0 0 0       if ($self->{_compression} && !defined($valid_compressions{$self->{_compression}}));
309 0           $self->update_headerrow;
310             } elsif ($aaref->[0] eq '-debug') {
311 0           shift @$aaref;
312 0           $self->{_debug} = shift @$aaref;
313             } else {
314 0           croak("unknown option: " . $aaref->[0]);
315             };
316             }
317              
318             =head2 config
319              
320             $fsdb->config(-arg1 => $value1, -arg2 => $value2);
321              
322             Parse all options in the list.
323              
324             =cut
325              
326             sub config ($@) {
327 0     0 1   my($self) = shift @_;
328 0           my(@args) = @_;
329 0           while ($#args >= 0) {
330 0           $self->config_one(\@args);
331             };
332             }
333              
334             =head2 default_binmode
335              
336             $fsdb->default_binmode();
337              
338             Set the file to the correct binmode,
339             either given by C<-encoding> at setup,
340             or defaulting from C or C.
341              
342             If the file is compressed, we will reset binmode after reading the header.
343              
344             =cut
345              
346             sub default_binmode($) {
347 0     0 1   my($self) = shift @_;
348 0 0         if (!defined($self->{_encoding})) {
349             # foreach ($ENV{LC_CTYPE}, $ENV{LANG}, 'en.:utf8') {
350             # as of perl v5.16.3, UTF-8 segfaults
351 0           foreach ('en.:utf8') {
352 0 0         next if (!defined($_));
353 0           my($locale, $charset) = ($_ =~ /^([^\.]+)\.([^\.]+)/);
354 0 0         next if (!defined($charset));
355 0           $self->{_encoding} = $charset;
356 0           last;
357             };
358             };
359 0           my $mode = $self->{_encoding};
360 0 0         $mode = ":encoding($mode)" if ($mode !~ /^:/);
361 0           return $mode;
362             }
363              
364             =head2 compare
365              
366             $result = $fsdb->compare($other_fsdb)
367              
368             Compares two Fsdb::IO objects, returning the strings
369             "identical" (same field separator, columns, and column order),
370             or maybe "compatible" (same field separator but different columns), or
371             undef if they differ.
372              
373             =cut
374              
375             sub compare ($$) {
376 0     0 1   my($self, $other) = @_;
377 0 0 0       return undef if ($self->{_error} || $other->{_error});
378 0 0         return undef if ($self->{_fscode} ne $other->{_fscode});
379 0           my @self_cols = @{$self->{_cols}};
  0            
380 0           my @other_cols = @{$other->{_cols}};
  0            
381 0 0         return "compatible" if ($#self_cols != $#other_cols);
382 0           foreach (0..$#self_cols) {
383 0 0         return "compatible" if ($self_cols[$_] ne $other_cols[$_]);
384             };
385 0           return 'identical';
386             }
387              
388             =head2 close
389              
390             $fsdb->close;
391              
392             Closes the file, frees open file handle, or sends an EOF signal
393             (and undef) down the open queue.
394              
395             =cut
396              
397             sub close {
398 0     0 1   my($self) = @_;
399 0 0         return if ($self->{_error});
400 0 0         if (defined($self->{_fh})) {
401 0           $self->{_fh}->close;
402 0           delete $self->{_fh}; # help garbage collect auto-generated Symbols from IO::Handle
403             };
404 0 0         if (defined($self->{_queue})) {
405 0           $self->{_queue}->enqueue(undef);
406 0           delete $self->{_queue};
407             };
408 0           $self->{_error} = 'closed';
409             }
410              
411             =head2 error
412              
413             $fsdb->error;
414              
415             Returns a descriptive string if there is an error,
416             or undef if not.
417              
418             The string will never end in a newline or punctuation.
419              
420             =cut
421              
422             sub error {
423 0     0 1   my($self) = @_;
424 0           return $self->{_error};
425             }
426              
427             =head2 update_v1_headerrow
428              
429             internal: create the header the internal schema
430              
431             =cut
432             sub update_v1_headerrow {
433 0     0 1   my $self = shift @_;
434 0           my $h = "#h ";
435 0 0         $h = "#L " if ($self->{_rscode} ne 'D');
436 0 0 0       if ($self->{_fscode} && $self->{_fscode} ne 'D') {
437 0           $h .= "-F" . $self->{_fscode} . " ";
438             };
439 0 0 0       if ($self->{_rscode} && $self->{_rscode} eq 'I') { # xxx: should be ne 'D'
440 0           $h .= "-R" . $self->{_rscode} . " ";
441             };
442 0           $h .= join(" ", @{$self->{_cols}});
  0            
443 0           $self->{_headerrow} = $h;
444             }
445              
446              
447             =head2 parse_v1_headerrow
448              
449             internal: interpet the header
450              
451             =cut
452             sub parse_v1_headerrow ($) {
453 0     0 1   my($self) = @_;
454 0 0         return if ($self->{_error});
455 0           my(@f) = split(/\s+/, $self->{_headerrow});
456 0           my $tag = shift @f;
457 0 0         if ($tag eq '#L') {
    0          
458 0           $self->{_rscode} = 'C';
459             } elsif ($tag ne "#h") {
460 0           $self->{_error} = "header line is not fsdb format";
461 0           return;
462             };
463             #
464             # handle options
465             #
466 0   0       while ($#f >= 0 && $f[0] =~ /^-(.)(.*)/) {
467 0           my($key, $value) = ($1, $2);
468 0           shift @f;
469 0 0         if ($key eq 'F') {
470 0           $self->parse_v1_fscode($value);
471             }
472             };
473              
474             # create them!
475 0           foreach (@f) {
476 0           $self->_internal_col_create($_);
477             };
478             }
479              
480             =head2 update_headerrow
481              
482             internal: create the header the internal schema
483              
484             =cut
485             sub update_headerrow {
486 0     0 1   my $self = shift @_;
487 0           my $h = "#fsdb ";
488 0 0 0       if ($self->{_fscode} && $self->{_fscode} ne 'D') {
489 0           $h .= "-F " . $self->{_fscode} . " ";
490             };
491 0 0 0       if ($self->{_rscode} && $self->{_rscode} ne 'D') { # xxx: should be ne 'D'
492 0           $h .= "-R " . $self->{_rscode} . " ";
493             };
494 0 0 0       if ($self->{_compression} && $self->{_compression} ne 'none') { # xxx: should be ne 'D'
495 0           $h .= "-Z " . $self->{_compression} . " ";
496             };
497 0           $self->{_header_prequel} = $h; # save this aside for dbcolneaten
498 0           $h .= join(" ", @{$self->{_cols}});
  0            
499 0           $self->{_headerrow} = $h;
500             }
501              
502              
503             =head2 parse_headerrow
504              
505             internal: interpet the v2 header.
506             Format is:
507              
508             #fsdb [-F x] [-R x] [-Z x] columns
509              
510             All options must come first, start with dashes, and have an argument.
511             (More regular than the v1 header.)
512              
513             =cut
514             sub parse_headerrow($) {
515 0     0 1   my($self) = @_;
516 0 0         return if ($self->{_error});
517 0           my(@f) = split(/\s+/, $self->{_headerrow});
518 0           my $tag = shift @f;
519 0 0 0       if ($tag eq '#fsdb') {
    0          
520             # fall through
521             } elsif ($tag eq '#L' || $tag eq '#h') {
522 0           return $self->parse_v1_headerrow;
523             } else {
524 0           $self->{_error} = "header line is not fsdb format";
525 0           return;
526             };
527              
528             #
529             # handle options
530             #
531 0   0       while ($#f >= 0 && $f[0] =~ /^-/) {
532 0           my($key) = shift @f;
533 0           my($value) = shift @f;
534 0 0         if ($key eq '-F') {
    0          
    0          
535 0           $self->parse_fscode($value);
536             } elsif ($key eq '-R') {
537 0           $self->parse_rscode($value);
538             } elsif ($key eq '-Z') {
539 0           $self->parse_compression($value);
540             } else {
541 0           $self->{_error} = "header has unknown option " . $key;
542 0           return;
543             };
544             };
545              
546             # create them!
547 0           foreach (@f) {
548 0           $self->_internal_col_create($_);
549             };
550              
551             }
552              
553              
554             =head2 parse_v1_fscode
555              
556             internal
557              
558             =cut
559             sub parse_v1_fscode {
560 0     0 1   my $self = shift @_;
561 0           my $code = shift @_;
562 0 0         if ($code =~ /^[DsSt]$/) {
563 0           $self->parse_fscode($code);
564             } else {
565             # Ick. Old way. Not very safe.
566             # Take char itself as code.
567 0           $self->parse_fscode("C$code");
568             };
569             }
570              
571              
572             =head2 parse_fscode
573              
574             Parse the field separator.
575             See L for a list of valid values.
576              
577             =cut
578             sub parse_fscode {
579 0     0 1   my $self = shift @_;
580 0           my $code = shift @_;
581 0           my ($fsre, $outfs);
582 0 0 0       if (!defined($code) || $code eq 'D') { # default
    0          
    0          
    0          
    0          
    0          
583 0           $fsre = '\s+'; # "[ \t\n]+";
584 0           $outfs = "\t";
585 0           $code = 'D'; # always leave it defined so eq/ne work
586             } elsif ($code eq 's') { # single space
587 0           $fsre = '\s+';
588 0           $outfs = " ";
589             } elsif ($code eq 'S') { # double space
590 0           $fsre = '\s\s+';
591 0           $outfs = " ";
592             } elsif ($code eq 't') { # single tab
593 0           $fsre = "\t";
594 0           $outfs = "\t";
595             } elsif ($code =~ /^X(.*)$/) { # hex value
596 0           my $real_code = chr(hex($1));
597 0           $fsre = "[$real_code]+";
598 0           $outfs = $real_code;
599             } elsif ($code =~ /^C(.)$/) { # character value
600 0           my $real_code = $1;
601 0           $fsre = "[$real_code]+";
602 0           $outfs = $real_code;
603             } else {
604 0           $self->{_error} = "bad field separator given ($code)";
605 0           return;
606             };
607 0           $self->{_fscode} = $code;
608 0           $self->{_fsre} = $fsre;
609 0           $self->{_fs} = $outfs;
610             }
611              
612              
613             =head2 parse_rscode
614              
615             Internal: Interpret rscodes.
616              
617             See L for a list of valid values.
618              
619             =cut
620             sub parse_rscode($$) {
621 0     0 1   my($self, $code) = @_;
622 0 0         $code = 'D' if (!defined($code));
623 0 0 0       $self->{_error} = "invalid rscode: $code"
      0        
624             if (!($code eq 'D' || $code eq 'C' || $code eq 'I'));
625 0           $self->{_rscode} = $code;
626             }
627              
628             =head2 parse_compression
629              
630             Internal: Interpret compression.
631              
632             See L for a list of valid values.
633              
634             =cut
635             sub parse_compression($$) {
636 0     0 1   my($self, $code) = @_;
637 0 0         $code = 'none' if (!defined($code));
638 0 0 0       $self->{_error} = "invalid compression: $code"
      0        
      0        
639             if (!($code eq 'none' || $code eq 'gz' || $code eq 'xz' || $code eq 'bz2'));
640 0           $self->{_compression} = $code;
641             }
642              
643              
644             =head2 establish_new_col_mapping
645              
646             internal
647              
648             =cut
649             sub establish_new_col_mapping {
650 0     0 1   my($self, $colname) = @_;
651              
652 0           my $coli = $#{$self->{_cols}} + 1;
  0            
653 0           $self->{_cols}->[$coli] = $colname;
654 0           $self->{_cols_to_i}->{$colname} = $coli;
655             # Old.pm also registers _$colname, but that seems Wrong.
656 0           $self->{_cols_to_i}->{"$coli"} = $coli; # numeric synonym
657              
658 0           $self->{_codifier_sub} = undef; # clear cache
659             }
660              
661             =head2 col_create
662              
663             $fsdb->col_create($col_name)
664              
665             Add a new column named $COL_NAME to the schema.
666             Returns undef on failure, or 1 if sucessful.
667             (Note: does I return the column index on creation because
668             so that C can be used for error checking,
669             given that the column number could be zero.)
670             Also, update the header row to reflect this column
671             (compare to C<_internal_col_create>).
672              
673             =cut
674              
675             sub col_create {
676 0     0 1   my $self = shift @_;
677 0 0         $self->_internal_col_create(@_) and
678             $self->update_headerrow;
679             }
680              
681             =head2 _internal_col_create
682              
683             $fsdb->_internal_col_create($col_name)
684              
685             For internal C use only.
686             Create a new column $COL_NAME,
687             just like C,
688             but do I update the header row
689             (as that function does).
690              
691             =cut
692              
693             sub _internal_col_create {
694 0     0     my($self, $colname) = @_;
695 0 0         if ($self->{_header_set}) {
696 0           $self->{_error} = "attempt to add column to frozen fsdb handle (reader or writer that's been written to): $colname";
697 0           return undef;
698             };
699 0 0         if (defined($self->col_to_i($colname))) {
700 0           $self->{_error} = "duplicate col definition: $colname";
701 0           return undef;
702             };
703 0           $self->establish_new_col_mapping($colname);
704 0           return 1;
705             }
706              
707             =head2 field_contains_fs
708              
709             $boolean = $fsdb->field_contains_fs($field);
710              
711             Determine if the $FIELD contains $FSDB's fscode
712             (in which case it is malformed).
713              
714             =cut
715              
716             sub field_contains_fs {
717 0     0 1   my($self, $field) = @_;
718 0           return ($field =~ /$self->{_fsre}/);
719             }
720              
721             =head2 fref_contains_fs
722              
723             $boolean = $fsdb->fref_contains_fs($fref);
724              
725             Determine if any field in $FREF contains $FSDB's fscode
726             (in which case it is malformed).
727              
728             =cut
729              
730             sub fref_contains_fs {
731 0     0 1   my($self, $fref) = @_;
732 0           foreach (@$fref) {
733 0 0         return 1 if ($_ =~ /$self->{_fsre}/);
734             };
735 0           return 0;
736             }
737              
738             =head2 correct_fref_containing_fs
739              
740             $boolean = $fsdb->correct_fref_containing_fs($fref);
741              
742             Patch up any field in $FREF contains $FSDB's fscode, as best as possible,
743             but turning the field separator into underscores.
744             Updates $FREF in place, and returns if it was altered.
745             This function looses data.
746              
747             =cut
748              
749             sub correct_fref_containing_fs {
750 0     0 1   my($self, $fref) = @_;
751 0           my $changed = undef;
752 0           foreach (0..$#$fref) {
753 0 0         $changed = 1 if ($fref->[$_] =~ s/$self->{_fsre}/_/g);
754             };
755 0           return $changed;
756             }
757              
758             =head2 fscode
759              
760             $fscode = $fsdb->fscode;
761              
762             Returns the fscode of the given database.
763             (The encoded verison representing the field separator.)
764             See also fs to get the actual field separator.
765              
766             =cut
767              
768             sub fscode {
769 0     0 1   my($self) = @_;
770 0           return $self->{_fscode};
771             }
772              
773             =head2 fs
774              
775             $fscode = $fsdb->fs;
776              
777             Returns the field separator.
778             See C to get the "encoded" version.
779              
780             =cut
781              
782             sub fs {
783 0     0 1   my($self) = @_;
784 0           return $self->{_fs};
785             }
786              
787              
788             =head2 rscode
789              
790             $rscode = $fsdb->rscode;
791              
792             Returns the rscode of the given database.
793              
794             =cut
795              
796             sub rscode {
797 0     0 1   my($self) = @_;
798 0           return $self->{_rscode};
799             }
800              
801              
802             =head2 ncols
803              
804             @fields = $fsdb->ncols;
805              
806             Return the number of columns.
807              
808             =cut
809              
810             sub ncols {
811 0     0 1   my($self) = @_;
812 0           return $#{$self->{_cols}} + 1;
  0            
813             }
814              
815             =head2 cols
816              
817             $fields_aref = $fsdb->cols;
818              
819             Returns the column headings (the field names) of the open database
820             as an aref.
821              
822             =cut
823              
824             sub cols {
825 0     0 1   my($self) = @_;
826 0           return $self->{_cols};
827             }
828            
829              
830             =head2 col_to_i
831              
832             @fields = $fsdb->col_to_i($column_name);
833              
834             Returns the column index (0-based) of a given $COLUMN_NAME.
835              
836             Note: tests for existence of columns must use C,
837             since the index can be 0 which would be interpreted as false.
838              
839             =cut
840              
841             sub col_to_i {
842 0     0 1   my($self, $n) = @_;
843 0           return $self->{_cols_to_i}->{$n};
844             }
845              
846             =head2 i_to_col
847              
848             @fields = $fsdb->i_to_col($column_index);
849              
850             Return the name of the COLUMN_INDEX-th (0-based) column.
851              
852             =cut
853              
854             sub i_to_col {
855 0     0 1   my($self, $i) = @_;
856 0           return $self->{_cols}->[$i];
857             }
858              
859             # =head2 attributes
860             #
861             # %attributes = $fsdb->attributes;
862             #
863             # Returns (a copy of) all attributes for the file (if any).
864             #
865             # =cut
866             #
867             # sub attributes() {
868             # my $self = shift @_;
869             # $self->check_attributes;
870             # return %{$self->{_attributes}};
871             # }
872             #
873             # =head2 attribute
874             #
875             # $an_attribute = $fsdb->attribute('empty');
876             #
877             # Returns one attribute of the file (if any).
878             #
879             # =cut
880             #
881             # sub attribute() {
882             # my $self = shift @_;
883             # $self->check_attributes;
884             # return $self->{_attributes}{$_[0]};
885             # }
886             #
887             # =head2 set_attribute
888             #
889             # $fsdb->set_attribute('empty', '-');
890             #
891             # Sets one attribute of the file.
892             #
893             # =cut
894             #
895             # sub set_attribute() {
896             # my $self = shift @_;
897             # $self->check_attributes;
898             # $self->{_attributes}{$_[0]} = $_[1];
899             # }
900              
901             =head2 fastpath_cancel
902              
903             $fsdb->fastpath_cancel();
904              
905             Discard any active fastpath code and allow fastpath-incompatible operations.
906             =cut
907              
908             sub fastpath_cancel {
909 0     0 1   my $self = shift @_;
910             # Just an honor code, we can't actually reach out and invalidate
911             # the fastpath code. :-(
912 0           $self->{_fastpath_active} = undef;
913             }
914              
915             =head2 codify
916              
917             ($code, $has_last_refs) = $self->codify($underscored_pseudocode);
918              
919             Convert db-code C<$UNDERSCORED_PSEUDOCODE> into perl code
920             in the context of a given Fsdb stream.
921              
922             We return a string of code C<$CODE>
923             that refs C<@{$fref}> and C<@{$lfref}>
924             for the current and prior row arrays,
925             and a flag C<$HAS_LAST_REFS> if C<@{$lfref}> is needed.
926             It is the callers job to set these up,
927             probably by evaling the returned string in the context of those variables.n
928              
929             The conversion is a rename of all _foo's into
930             database fields.
931             For more perverse needs, _foo(N) means the Nth field after _foo.
932             Also, as of 29-Jan-00, _last_foo gives the last row's value
933             (_last_foo(N) is not supported).
934             To convert we eval $codify_code.
935              
936             20-Feb-07: _FROMFILE_foo opens the file called _foo and includes it in place.
937              
938             NEEDSWORK: Should make some attempt to catch misspellings of column
939             names.
940              
941             =cut
942              
943             sub codify {
944 0     0 1   my $self = shift @_;
945 0 0         if (!defined($self->{_codifier_sub})) {
946             #
947             # Here we generate an anon sub that takes
948             # its args (@_) as code and returns them
949             # as one string of fixed code that refs @{$fref} and @{$lfref}.
950             #
951 0           my $codify_code = "sub {\n" .
952             'my $has_lfrefs = undef;' . "\n" .
953             'my $c = join(";", @_);' . "\n";
954 0           foreach (@{$self->cols}) {
  0            
955             # xxx:
956             # # indirect @_foo
957             # $codify_code .= 'if ($c =~ m/\b\_FROMFILE\(\_' . quotemeta($_) . '\)\b/) { ' .
958             ## ' my $c = slurpfile($c[' . $colnametonum{$_} . ']); ' .
959             ## ' my $c = "foo"; ' .
960             ## ' s/\b\_FROMFILE\(\_' . quotemeta($_) . '\)\b/$c/g; ' .
961             # ' $c =~ s/\b\_FROMFILE\(\_' . quotemeta($_) . '\)\b/foo/g; ' .
962             # '};' . "\n";
963             # $codify_code .= '$c =~ s/\b\_FROMFILE\(\_' . quotemeta($_) . '\)\b/\$c\[' . $colnametonum{$_} . '\]/g;' . "\n";
964             # _foo(N) [perverse]
965 0           $codify_code .= "\t" . '$c =~ s/\b\_' . quotemeta($_) . '(\(.*\))/\$fref->\[' . $self->col_to_i($_) . '+$1\]/g;' . "\n";
966             # _foo
967 0           $codify_code .= "\t" . '$c =~ s/\b\_' . quotemeta($_) . '\b/\$fref->\[' . $self->col_to_i($_) . '\]/g;' . "\n";
968 0           $codify_code .= "\t" . '$has_lfrefs = 1 if ($c =~ /\b\_last\_' . quotemeta($_) . '\b/);' . "\n";
969             # _last_foo
970 0           $codify_code .= "\t" . '$c =~ s/\b\_last\_' . quotemeta($_) . '\b/\$lfref->\[' . $self->col_to_i($_) . '\]/g;' . "\n";
971             };
972             # print "CODE: $codify_code\n";
973 0           $codify_code .= "\t" . 'return ($c, $has_lfrefs);' . "\n};\n";
974 0           my $codify_sub;
975 0           eval "\$codify_sub = $codify_code;";
976 0 0         croak "cannot eval code:\n\t$@\n\t$codify_code\n" if ($@ ne '');
977 0           $self->{_codifier_sub} = $codify_sub;
978             };
979             #
980             # do it!
981             #
982 0           return &{$self->{_codifier_sub}}(@_);
  0            
983             }
984              
985             =head2 clean_potential_columns
986              
987             @clean = Fsdb::IO::clean_potential_columns(@dirty);
988              
989             Clean up user-provided column names.
990              
991             =cut
992              
993             sub clean_potential_columns {
994             # normalize field names
995 0     0 1   grep(s/^\s+//, @_);
996 0           grep(s/\s+$//, @_);
997 0           grep(s/\s+/_/g, @_);
998 0           return @_;
999             }
1000              
1001              
1002             1;