File Coverage

blib/lib/CAM/DBF.pm

Criterion	Covered	Total	%
statement	208	431	48.2
branch	42	154	27.2
condition	21	93	22.5
subroutine	20	41	48.7
pod	30	30	100.0
total	321	749	42.8

package CAM::DBF;

require 5.005_62;
use warnings;
use strict;
use Carp;

our $VERSION = '1.02';

## Package globals

# Performance tests showed that a rowcache of 100 is better than
# rowcaches of 10 or 1000 (presumably due to tradeoffs in overhead
# vs. processor data cache usage vs. memory allocation)

our $ROWCACHE = 100;  # how many rows to cache at a time
# Set that to 0 for debugging


=for stopwords Borland DBF XBase dBASE

=head1 NAME

CAM::DBF - Perl extension for reading and writing dBASE III DBF files

=head1 LICENSE

Copyright 2006 Clotho Advanced Media, Inc.,

This library is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.

=head1 SEE ALSO

Please see the L modules on CPAN for more complete
implementations of DBF file reading and writing.  This module differs
from those in that it is designed to be error-correcting for corrupted
DBF files.  If you already know how to use L, then L
will likely make you happier than this module.

I don't do much DBF work any longer, so updates to this module will be
infrequent.

=head1 SYNOPSIS

  use CAM::DBF;
  my $dbf = CAM::DBF->new($filename);

  # Read routines:

  print join('|', $dbf->fieldnames()),"\n";
  for my $row (0 .. $dbf->nrecords()-1) {
     print join('|', $dbf->fetchrow_array($row)),"\n";
  }

  my $row = 100;
  my $hashref = $dbf->fetchrow_hashref($row);
  my $arrayref = $dbf->fetchrow_hashref($row);

  # Write routines:

  $dbf->delete($row);
  $dbf->undelete($row);

=head1 DESCRIPTION

This package facilitates reading and writing dBASE III PLUS DBF files.
This is made possible by documentation generously released by Borland
at L

Currently, only version III PLUS files are readable.  This module does
not support dBASE version IV or 5.0 files.  See L for better
support.

=head1 CLASS METHODS

=over 4

=cut

#----------------

# Internal function, called by new() or create()

my %filemode_open_map = (
   'r'  => '<',
   'r+' => '+<',
   'w'  => '>',
   'w+' => '+>',
   'a'  => '>>',
   'a+' => '+>>',
);

sub _init
{
   my $pkg = shift;
   my $filename = shift;
   my $filemode = shift;

   my %flags;
   if (@_ % 2 == 0)
   {
      %flags = @_;
   }

   if (!defined $filemode || $filemode eq q{})
   {
      $filemode = 'r';
   }

   if (!$filemode_open_map{$filemode})
   {
      croak 'Invalid file mode';
   }

   my @times = localtime;
   my $year = $times[5]+1900;
   my $month = $times[4]+1;
   my $date = $times[3];

   my $self = bless {
      filename => $filename,
      filemode => $filemode,
      fh       => undef,
      fields   => [],
      columns  => [],

      valid        => 0x03,
      year         => $year,
      month        => $month,
      date         => $date,
      nrecords     => 0,
      nheaderbytes => 0,
      nrecordbytes => 0,
      packformat   => 'C',

      flags => \%flags,
   }, $pkg;

   $self->_open_fh();

   return $self;
}
sub _open_fh
{
   my $self = shift;

   if ($self->{filename} eq q{-})
   {
      # This might be fragile, since seek won't work
      if ($self->{filemode} =~ m/r/xms)
      {
         $self->{fh} = \*STDIN;
      }
      else
      {
         $self->{fh} = \*STDOUT;
      }
   }
   else
   {
      my $fh;
      if (open $fh, $filemode_open_map{$self->{filemode}}, $self->{filename})
      {
         $self->{fh} = $fh;
      }
   }
   if (!$self->{fh})
   {
      croak "Cannot open DBF file $self->{filename}: $!";
   }
   binmode $self->{fh};

   return;
}

#----------------

=item $pkg->new($filename)

=item $pkg->new($filename, $mode)

=item $pkg->new($filename, $mode, $key => $value, ...)

Open and read a dBASE file.  The optional mode parameter defaults to
C for read-only.  If you plan to alter the DBF, open it as C.

Additional behavior flags can be passed after the file mode.
Available flags are:

=over

=item C<< ignoreHeaderBytes => 0|1 >>

Looks for the 0x0D end-of-header marker instead of trusting the
stated header length. Default 0.

=item C<< allowOffByOne => 0|1 >>

Only matters if C is on.  If the computed header size
differs from the declared header size by one byte, use the
latter. Default 0.

=item C<< verbose => 0|1 >>

Print warning messages about header problems, or stay quiet. Default
0.

=back

=cut

sub new
{
   my $pkg = shift;
   my $filename = shift;
   my $filemode = shift;

   my $self = $pkg->_init($filename, $filemode, @_);

   ## Parse the header

   my $header;
   read $self->{fh}, $header, 32;
   ($self->{valid},
    $self->{year},
    $self->{month},
    $self->{date},
    $self->{nrecords},
    $self->{nheaderbytes},
    $self->{nrecordbytes}) = unpack 'CCCCVvv', $header;

   if (!$self->{valid} || $self->{valid} != 0x03 && $self->{valid} != 0x83)
   {
      croak "This does not appear to be a dBASE III PLUS file ($filename)";
   }

   my $filesize = ($self->{nheaderbytes} +
                   $self->{nrecords} * $self->{nrecordbytes});
   $self->{filesize} = -s $filename;

   if ($self->{filesize} < $self->{nheaderbytes})
   {
      if (!$self->{flags}->{ignoreHeaderBytes})
      {
         croak "DBF file $filename appears to be severely truncated:\n" .
               "Header says it should be $filesize bytes, but it's only $self->{filesize} bytes\n" .
               "  Records = $self->{nrecords}\n";
      }
   }

   # correct 2 digit year
   $self->{year} += 1900;
   if ($self->{year} < 1970)
   {
      $self->{year} += 100;  # Y2K fix
   }

   my $field;
   my $pos = 64;
   read $self->{fh}, $field, 1;

   # acording to the Borland spec 0x0D marks the end of the header block
   # however we have seen this fail so $pos ensures we do not read beyond
   # the header block for table columns
   # We've also found flaky files which use 0x0A instead of 0x0D
   while ($field && (0x0D != unpack 'C', $field) && (0x0A != unpack 'C', $field) &&
          ($self->{flags}->{ignoreHeaderBytes} || $pos < $self->{nheaderbytes}))
   {
      read $self->{fh}, $field, 31, 1;
      my ($name, $type, $len, $dec) = unpack 'a11a1xxxxCC', $field;

      $name =~ s/\A(\w+).*?\z/$1/xms;

      push @{$self->{fields}}, {
         name => $name,
         type => $type,
         length => $len,
         decimals => $dec,
      };
      push @{$self->{columns}}, $name;

      $pos += 32;
      read $self->{fh}, $field, 1;
   }

   if ($self->{flags}->{ignoreHeaderBytes})
   {
      # replace stated header size with the actual, computed value
      my $oldvalue = $self->{nheaderbytes};
      my $newvalue = (@{$self->{fields}} + 1) * 32 + 1;
      # skip the replacement if the flags say to be lenient
      unless ($self->{flags}->{allowOffByOne} && abs($oldvalue-$newvalue) <= 1) ## no critic
      {
         $self->{nheaderbytes} = $newvalue;
         if ($self->{flags}->{verbose} && $oldvalue != $self->{nheaderbytes})
         {
            warn "Corrected header size from $oldvalue to $self->{nheaderbytes} for $self->{filename}\n";
         }
      }
   }

   $self->{packformat} = 'C';
   for my $field (@{$self->{fields}})
   {
      if ($field->{type} =~ m/\A[CLND]\z/xms)
      {
         $self->{packformat} .= 'a' . $field->{length};
      }
      else
      {
         croak 'unrecognized field type ' . $field->{type} . ' in field ' . $field->{name};
      }
   }
   seek $self->{fh}, $self->{nheaderbytes}, 0;

   return $self;
}
#----------------

=item $pkg->create($filename, [flags,] $column, $column, ...)

=item $pkg->create($filename, $filemode, [flags,] $column, $column, ...)

Create a new DBF file in C<$filename>, initially empty.  The optional
C<$filemode> argument defaults to C.  We can't think of any reason to
use any other mode, but if you can think of one, go for it.

The column structure is specified as a list of hash references, each
containing the fields: name, type, length and decimals.  The name
should be 11 characters or shorted.  The type should be one of C, C,
C, or C (for character, number, date or logical).

The optional flags are:

  -quick => 0|1 (default 0) -- skips column format checking if set

Example:

   my $dbf = CAM::DBF->create('new.dbf',
                              {name=>'id',
                               type=>'N', length=>8,  decimals=>0},
                              {name=>'lastedit',
                               type=>'D', length=>8,  decimals=>0},
                              {name=>'firstname',
                               type=>'C', length=>15, decimals=>0},
                              {name=>'lastname',
                               type=>'C', length=>20, decimals=>0},
                              );

=cut

sub create
{
   my $pkg = shift;
   my $filename = shift;

   # Optional args:
   my $quick = 0;
   my $filemode = 'w+';
   while (@_ > 0 && $_[0] && (!ref $_[0]))
   {
      if ($_[0] eq '-quick')
      {
         shift;
         $quick = shift;
      }
      elsif ($filemode_open_map{$_[0]})
      {
         $filemode = shift;
      }
      else
      {
         carp "Argument $_[0] not understood";
         return;
      }
   }

   # The rest of the args are the data structure definition
   my @columns = @_;

   # Validate the column structure
   if ($quick)
   {
      if (!$pkg->validateColumns(@columns))
      {
         return;
      }
   }

   my $self = $pkg->_init($filename, $filemode);
   return if (!$self);

   $self->{fields} = [@columns];
   $self->{columns} = map {$_->{name}} @columns;
   $self->{packformat} = 'C' . join q{}, map {'a'.$_->{length}} @columns;

   if (!$self->writeHeader())
   {
      return;
   }

   return $self;
}
#----------------

=item $pkg_or_self->validateColumns($column, $column, ...)

=item $self->validateColumns()

Check an array of DBF columns structures for validity.  Emits warnings
and returns undef on failure.

=cut

sub validateColumns
{
   my $pkg_or_self = shift;
   my @columns = @_;

   if (@columns == 0 && ref $pkg_or_self)
   {
      my $self = $pkg_or_self;
      @columns = @{$self->{fields}};
   }

   my $n_columns = 0; # used solely for error messages
   my %col_names;  # used to detect duplicate column names
   for my $column (@columns)
   {
      $n_columns++;
      if (!$column || (!ref $column) || 'HASH' ne ref $column)
      {
         carp "Column $n_columns is not a hash reference";
         return;
      }
      for my $key ('name', 'type', 'length', 'decimals')
      {
         if (!defined $column->{$key} || $column->{$key} =~ m/\A\s*\z/xms)
         {
            carp "No $key field in column $n_columns";
            return;
         }
      }
      if (11 < length $column->{name})
      {
         carp "Column name '$column->{name}' is too long (max 11 characters)";
         return;
      }
      if ($col_names{$column->{name}}++)
      {
         carp "Duplicate column name '$column->{name}'";
         return;
      }
      if ($column->{type} !~ m/\A[CNDL]\z/xms)
      {
         carp "Unknown column type '$column->{type}'";
         return;
      }
      if ($column->{length} !~ m/\A\d+\z/xms)
      {
         carp "Column length must be an integer ('$column->{length}')";
         return;
      }
      if ($column->{decimals} !~ m/\A\d+\z/xms)
      {
         carp "Column decimals must be an integer ('$column->{decimals}')";
         return;
      }
      if ($column->{type} eq 'L' && $column->{length} != 1)
      {
         carp 'Columns of type L (logical) must have length 1';
         return;
      }
      if ($column->{type} eq 'D' && $column->{length} != 8)
      {
         carp 'Columns of type D (date) must have length 8';
         return;
      }
   }
   return $pkg_or_self;
}
#----------------

=back

=head1 INSTANCE METHODS

=over 4

=cut

#----------------

=item $self->writeHeader()

Write all of the DBF header data to the file.  This truncates the file first.

=cut

sub writeHeader
{
   my $self = shift;

   my $file_handle = $self->{fh};
   my $fields = q{};
   $self->{nrecordbytes} = 1; # allow one for the delete byte

   for my $column (@{$self->{fields}})
   {
      $self->{nrecordbytes} += $column->{length};
      $fields .= pack 'a11a1CCCCCCCCCCCCCCCCCCCC',
                      $column->{name}, $column->{type}, (0) x 4,
                      $column->{length}, $column->{decimals}, (0) x 14;
   }
   $fields .= pack 'C', 0x0D;

   my $header
       = pack 'CCCCVvvCCCCCCCCCCCCCCCCCCCC',
              $self->{valid},
              $self->{year}%100, $self->{month}, $self->{date},
              $self->{nrecords}, length($fields)+32,
              $self->{nrecordbytes}, (0)x20;

   truncate $file_handle, 0;
   print {$file_handle} $header;
   print {$file_handle} $fields;
   return $self;
}
#----------------

=item $self->appendrow_arrayref($data_arrayref)

Add a new row to the end of the DBF file immediately.  The argument
is treated as a reference of fields, in order. The DBF file is altered
as little as possible.

The record count is incremented but is NOT written to the file until
the C method is called (for speed increase).

=cut

sub appendrow_arrayref
{
   my $self = shift;
   my $row  = shift;

   $self->appendrows_arrayref([$row]);
   return;
}
#----------------

=item $self->appendrows_arrayref($arrayref_data_arrayrefs)

Add new rows to the end of the DBF file immediately.  The argument
is treated as a reference of references of fields, in order. The DBF
file is altered as little as possible. The record count is incremented
but is NOT written until the C method is called (for speed increase).

=cut

sub appendrows_arrayref
{
   my $self = shift;
   my $rows = shift;

   my $file_handle = $self->{fh};
   seek $file_handle, 0, 2;

   for my $row (@{$rows})
   {
      if (defined $row)
      {
         $self->{nrecords}++;
         print {$file_handle} $self->_packArrayRef($row);
      }
   }

   delete $self->{rowcache};  # wipe cache, just in case
   return;
}
#----------------

=item $self->appendrow_hashref($data_hashref)

Just like C, except the incoming data is in a
hash.  The DBF columns are used to reorder the data.  Missing values
are converted to blanks.

=cut

sub appendrow_hashref
{
   my $self = shift;
   my $row  = shift;

   $self->appendrows_hashref([$row]);
   return;
}
#----------------

=item $self->appendrows_hashref($arrayref_data_hashref)

Just like C, except the incoming data is in a
hash.  The DBF columns are used to reorder the data.  Missing values
are converted to blanks.

=cut

sub appendrows_hashref
{
   my $self = shift;
   my $hashrows = shift;

   # Convert hashes to arrays
   my @column_names = map {$_->{name}} @{$self->{fields}};
   my @arrayrows;
   for my $row (@{$hashrows})
   {
      push @arrayrows, [map {$row->{$_}} @column_names];
   }

   $self->appendrows_arrayref(\@arrayrows);
   return;
}
#----------------

sub _packArrayRef
{
   my $self = shift;
   my $A_row = shift;

   die 'Bad row' if (!$A_row);

   my $row = q{ };  # start with an undeleted flag
   for my $i (0 .. @{$self->{fields}}-1)
   {
      my $column = $self->{fields}->[$i];
      my $v = $A_row->[$i];

      if (defined $v)
      {
         $v = "$v"; # stringify
      }
      else
      {
         $v = q{};
      }

      my $l = length $v;
      if ($column->{type} eq 'N') ##no critic(ProhibitCascadingIfElse)
      {
         if ($v =~ m/\d/xms)
         {
            $v = sprintf "%$column->{length}.$column->{decimals}f", $v;
         }
         else
         {
            $v = q{ } x $column->{length};
         }
      }
      elsif ($column->{type} eq 'C')
      {
         $v = sprintf "%-$column->{length}s", $v;
      }
      elsif ($column->{type} eq 'L')
      {
         $v = !$v || $v =~ m/[nNfF]/xms ? 'F' : 'T';
      }
      elsif ($column->{type} eq 'D')
      {
         # pass on OK
      }
      else
      {
         die "Unknown type $column->{type}";
      }

      if ($l > $column->{length})
      {
         $v = substr $v, 0, $column->{length};
      }
      $row .= $v;
   }
   return $row;
}
#----------------

=item $self->closeDB()

Closes a DBF file after updating the record count.
This is only necessary if you append new rows.

=cut

sub closeDB
{
   my $self = shift;

   $self->writeRecordNumber();
   $self->{fh}->close();
   return $self;
}
#----------------

=item $self->writeRecordNumber()

Edits the DBF file to record the current value of nrecords().  This is
useful after appending rows.

=cut

sub writeRecordNumber
{
   my $self = shift;

   my $file_handle = $self->{fh};
   seek $file_handle, 4, 0;
   print {$file_handle} pack 'V', $self->{nrecords};
   return $self;
}
#----------------

sub _readrow
{
   my $self = shift;
   my $rownum = shift;

   if ($ROWCACHE == 0)
   {
      my $A_rows = $self->_readrows($rownum, 1);
      return $A_rows ? $A_rows->[0] : undef;
   }
   elsif ($self->{rowcache} && $rownum < $self->{rowcache2} && $rownum >= $self->{rowcache1})
   {
      return $self->{rowcache}->[$rownum - $self->{rowcache1}];
   }
   else
   {
      my $num = $ROWCACHE;
      if ($rownum + $num >= $self->{nrecords})
      {
         $num = $self->{nrecords} - $rownum;
      }
      $self->{rowcache} = $self->_readrows($rownum, $num);
      $self->{rowcache1} = $rownum;
      $self->{rowcache2} = $rownum + $num;

      return $self->{rowcache}->[0];
   }
}
#----------------

sub _readrows
{
   my $self = shift;
   my $row_start = shift;
   my $row_count = shift;

   my @data_rows;

   my $offset = $self->{nheaderbytes} + $row_start * $self->{nrecordbytes};
   seek $self->{fh}, $offset, 0;

   for (my $r=1; $r<=$row_count; $r++)
   {
      my $datarow;
      read $self->{fh}, $datarow, $self->{nrecordbytes};
      my @records = unpack $self->{packformat}, $datarow;
      my $delete = shift @records;
      if ($delete != 32) # 32 is decimal ascii for " "
      {
         # This is a deleted row
         push @data_rows, undef;
         next;
      }

      my $col = 0;
      for (@records)
      {
         my $type = $self->{fields}->[$col++]->{type};
         if ($type eq 'C')
         {
            s/[ ]*\z//xms;
         }
         elsif ($type eq 'N')
         {
            s/\A[ ]*//xms;
         }
         elsif ($type eq 'L')
         {
            tr/yYtTnNfF?/111100000/;
         }
      }
      push @data_rows, \@records;
   }

   return \@data_rows;
}
#----------------

=item $self->nfields()

Return the number of columns in the data table.

=cut

sub nfields
{
   my $self = shift;

   return scalar @{$self->{fields}};
}
#----------------

=item $self->fieldnames()

Return a list of field header names.

=cut

sub fieldnames
{
   my $self = shift;

   return @{$self->{columns}};
}

# Retrieve header metadata for the column spcified by name or number
sub _getfield
{
   my $self = shift;
   my $col = shift;

   if ($col =~ m/\D/xms)
   {
      for my $field (@{$self->{fields}})
      {
         return $field if ($field->{name} eq $col);
      }
      return;
   }
   else
   {
      return $self->{fields}->[$col];
   }
}
#----------------

=item $self->fieldname($column)

Return a the title of the specified column.  C<$column> can be a column
name or number.  Column numbers count from zero.

=cut

sub fieldname
{
   my $self = shift;
   my $col = shift;

   my $field = $self->_getfield($col);
   return if (!$field);
   return $field->{name};
}
#----------------

=item $self->fieldtype($column)

Return the dBASE field type for the specified column.  C<$column> can be a
column name or number.  Column numbers count from zero.

=cut

sub fieldtype
{
   my $self = shift;
   my $col = shift;

   my $field = $self->_getfield($col);
   return if (!$field);
   return $field->{type};
}
#----------------

=item $self->fieldlength($column)

Return the byte width for the specified column.  C<$column> can be a
column name or number.  Column numbers count from zero.

=cut

sub fieldlength
{
   my $self = shift;
   my $col = shift;

   my $field = $self->_getfield($col);
   return if (!$field);
   return $field->{length};
}
#----------------

=item $self->fielddecimals($column)

Return the decimals for the specified column.  C<$column> can be a column
name or number.  Column numbers count from zero.

=cut

sub fielddecimals
{
   my $self = shift;
   my $col = shift;

   my $field = $self->_getfield($col);
   return if (!$field);
   return $field->{decimals};
}
#----------------

=item $self->nrecords()

Return number of records in the file.

=cut

sub nrecords
{
   my $self = shift;

   return $self->{nrecords};
}
#----------------

=item $self->fetchrow_arrayref($rownumber)

Return a record as a reference to an array of fields.  Row numbers
count from zero.

=cut

sub fetchrow_arrayref
{
   my $self   = shift;
   my $rownum = shift;

   if ($rownum < 0 || $rownum >= $self->{nrecords})
   {
      carp "Invalid DBF row: $rownum";
      return;
   }

   return $self->_readrow($rownum);
}
#----------------

=item $self->fetchrows_arrayref($rownumber, $count)

Return array reference of records as a reference to an array of fields.
Row numbers start from zero and count is trimmed if it exceeds table
limits.

=cut

sub fetchrows_arrayref
{
   my $self = shift;
   my $row_start = shift;
   my $row_count = shift;

   if ($row_start + $row_count > $self->{nrecords})
   {
      $row_count = $self->{nrecords} - $row_start;
   }

   if ($row_start < 0 || $row_start >= $self->{nrecords})
   {
      if ($row_start >= $self->{nrecords})
      {
         carp "Invalid DBF row: $row_start";
      }
      return;
   }

   return $self->_readrows($row_start, $row_count);
}
#----------------

=item $self->fetchrow_hashref($rownum)

Return a record as a reference to a hash of C<(field name => field value)>
pairs.  Row numbers count from zero.

=cut

sub fetchrow_hashref
{
   my $self = shift;
   my $rownum = shift;

   my $ref = $self->fetchrow_arrayref($rownum);
   return if (!$ref);
   my %hash;
   for my $col (0 .. $#{$ref})
   {
      $hash{$self->{columns}->[$col]} = $ref->[$col];
   }
   return \%hash;
}
#----------------

=item $self->fetchrow_array($rownum)

Return a record as an array of fields.  Row numbers count from zero.

=cut

sub fetchrow_array
{
   my $self   = shift;
   my $rownum = shift;

   my $ref = $self->fetchrow_arrayref($rownum);
   return if (!$ref);
   return @{$ref};
}
#----------------

=item $self->delete($rownum);

Flags a row as deleted.  This alters the DBF file immediately.

=cut

sub delete  ##no critic(ProhibitBuiltinHomonyms)
{
   my $self   = shift;
   my $rownum = shift;

   return $self->_delete($rownum, q{*});
}
#----------------

=item $self->undelete($rownum)

Removes the deleted flag from a row.  This alters the DBF file
immediately.

=cut

sub undelete
{
   my $self   = shift;
   my $rownum = shift;

   return $self->_delete($rownum, q{ });
}

## Internal method only.  Use wrappers above.
sub _delete
{
   my $self   = shift;
   my $rownum = shift;
   my $flag   = shift;

   return if (!$rownum);
   return if ($rownum < 0 || $rownum >= $self->{nrecords});

   $self->{fh}->close();
   $self->{fh} = undef;

   my $fh;
   my $result;
   if (open $fh, '+<', $self->{filename})
   {
      binmode $fh;
      my $offset = $self->{nheaderbytes} + $rownum * $self->{nrecordbytes};
      seek $fh, $offset, 0;
      print {$fh} $flag;
      close $fh;
      $result = 1;
   }

   # Reopen main filehandle
   $self->_open_fh();

   delete $self->{rowcache};  # wipe cache, just in case
   return $result ? $self : ();
}
#----------------

=item $self->toText([$startrow,] [$endrow,] [C<-arg> => $value, ...])

Return the contents of the file in an ASCII character-separated
representation.  Possible arguments (with default values) are:

    -field      =>  ','
    -enclose    =>  '"'
    -escape     =>  '\'
    -record     =>  '\n'
    -showheader => 0
    -startrow   => 0
    -endrow     => nrecords()-1

Alternatively, if the C<-arg> switches are not used, the first two
arguments are interpreted as:

    $dbf->toText($startrow, $endrow)

Additional C<-arg> switches are permitted after these.  For example:

    print $dbf->toText(100, 100, -field => '\n', -record => '');
    print $dbf->toText(300, -field => '|');

=cut

sub toText
{
   my $self = shift;

   my %args = (
               field => q{,},
               enclose => q{'},
               escape => q{\\},
               record => "\n",
               showheader => 0,
               startrow => 0,
               endrow => $self->nrecords()-1,
               );

   for my $arg (qw(startrow endrow))
   {
      if (@_ > 0 && $_[0] !~ m/\A\-/xms)
      {
         $args{$arg} = shift;
      }
   }

   while (@_ > 0)
   {
      my $key = shift;
      if ($key =~ m/\A\-(\w+)\z/xms && exists $args{$1} && @_ > 0)
      {
         $args{$1} = shift;
      }
      else
      {
         carp "Unexpected tag '$key' in argument list";
         return;
      }
   }

   if ($args{startrow} < 0 || $args{endrow} >= $self->nrecords())
   {
      carp 'Invalid start and/or end row';
      return;
   }
   return if ($args{startrow} > $args{endrow});

   my $out = q{};
   if ($args{showheader}) {
      my @names = map {$args{enclose} eq q{} && $args{escape} eq q{} ?
                       $_ : _escape($_, $args{enclose}, $args{escape})} $self->fieldnames();
      $out .= join $args{field}, @names;
      $out .= $args{record};
   }
   for (my $row = $args{startrow}; $row <= $args{endrow}; $row++)
   {
      my $aref = $self->_readrow($row);
      next if (!$aref);
      if ($args{enclose} ne q{} || $args{escape} ne q{})
      {
         for (@{$aref})
         {
            $_ = _escape($_, $args{enclose}, $args{escape});
         }
      }
      $out .= join($args{field}, @{$aref}) . $args{record};
   }
   return $out;
}
#----------------

=item $self->computeRecordBytes()

Useful primarily for debugging.  Recompute the number of bytes needed
to store a record.

=cut

sub computeRecordBytes
{
   my $self = shift;

   my $length = 1;
   for my $column (@{$self->{fields}})
   {
      $length += $column->{length};
   }
   return $length;
}
#----------------

=item $self->computeHeaderBytes()

Useful primarily for debugging.  Recompute the number of bytes needed
to store the header.

=cut

sub computeHeaderBytes
{
   my $self = shift;

   my $fh = $self->{fh};
   my $length = 0;
   my ($buffer, $value);
   do
   {
      $length += 32;
      seek $fh, $length, 0;
      read $fh, $buffer, 1;
      $value = unpack 'C', $buffer;
   }
   while (defined $buffer && $value != 0x0D && $value != 0x0A); ##no critic(ProhibitPostfixControls)
   return $length + 1; # Add one for the terminator character
}
#----------------

=item $self->computeNumRecords()

Useful primarily for debugging.  Recompute the number of records in
the file, given the header size, file size and bytes needed to store a
record.

=cut

sub computeNumRecords
{
   my $self = shift;

   my $size = -s $self->{filename};
   my $num = ($size - $self->nHeaderBytes()) / $self->nRecordBytes();
   return int $num
}
#----------------

=item $self->nHeaderBytes()

Useful primarily for debugging.  Returns the number of bytes for the
file header.  This date is read from the header itself, not computed.

=cut

sub nHeaderBytes
{
   my $self = shift;
   return $self->{nheaderbytes};
}
#----------------

=item $self->nRecordBytes()

Useful primarily for debugging.  Returns the number of bytes for a
record.  This date is read from the header itself, not computed.

=cut

sub nRecordBytes
{
   my $self = shift;
   return $self->{nrecordbytes};
}
#----------------

=item $self->repairHeaderData()

Test and fix corruption of the C and C header
fields.  This does NOT alter the file, just the in-memory
representation of the header metadata.  Returns a boolean indicating
whether header repairs were necessary.

=cut

sub repairHeaderData
{
   my $self = shift;

   my $repairs = 0;

   my $row_size = $self->computeRecordBytes();
   if ($self->nRecordBytes() != $row_size)
   {
      $repairs++;
      $self->{nrecordbytes} = $row_size;
   }

   my $n_records = $self->computeNumRecords();
   if ($n_records != $self->nrecords())
   {
      $repairs++;
      $self->{nrecords} = $n_records;
   }

   return $repairs;
}
#----------------

# Internal function
sub _escape
{
   my $string = shift;
   my $enclose = shift;
   my $escape = shift;

   if ($escape ne q{})
   {
      $string =~ s/\Q$escape\E/$escape$escape/gxms;
      if ($enclose ne q{})
      {
         $string =~ s/\Q$enclose\E/$escape$enclose/gxms;
      }
   }
   return $enclose . $string . $enclose;
}

1;
__END__