=head1 NAME

  CFX5::DefFile::DataSet - An object representing a CFX-5 Solver Input File dataset

=head1 SYNOPSIS

  # get a dataset object
  $ds = $DefFile->read_dataset(-what => 'G/CBQUAN');

  print join(' ',"Got data set",
                 $ds->header('WHAT'),
                 $ds->header('WHERE'),
                 $ds->header('WHEN'),"\n");

  # read some attributes: what is its storage class?
  print "Storage class is ", $ds->header('CLASS'), "\n";

  # get the data as a string list
  for $q ($ds->data()) {
    print " * $q\n";
  }

=head1 DESCRIPTION

This class is a companion to L<CFX5::DefFile>, and provides access to
individual data sets from the definition file in an object-oriented
manner.

It should normally be created via the C<new_dataset>, C<read_dataset>
and C<write_dataset> calls from a C<CFX5::DefFile> object, but once
obtained may be manipulated directly.

Overloaders of L<CFX5::DefFile> will probably want to overload this
class as well.

=cut

package CFX5::DefFile::DataSet;

use strict;
use Carp;

use CFX5::Output qw(:all);
use CFX5::Config qw(%Config);

=head2 CONSTRUCTORS

=head3 new

Returns a new object of this type.  This function should not normally
be used.

=cut

sub new {
  my $this = shift;
  my $class = ref($this) || $this;
  my $self = { 
              header => {},
              control => {
                          uptodate => 0,
                          modified => 0,
                          mode => 'cfx5-io-base',
                         },
              lheader => [qw(WHAT WHERE WHEN DATATYPE NUMBER BLOCKFACTOR)],
              lattribs => [],
             };
  bless $self, $class;
  #$self->initialize(@_) or $self=undef;
  return $self;
}

=head2 INITIALISATION

=head3 from_hdr_data

I<Internal function>

  $ds->from_hdr_data($hdr,$data);

Initialises the dataset object from L<CFX5::IO::Header> and
L<CFX5::IO::Data> objects, which are returned by the IO library access
routines in L<CFX5::IO::Base>.

When an object is instantiated like this, the header and data objects
are cached internally.  The headers are parsed and treated internally
in the same way as if data comes from the IO tool helper, but the data
is kept in the data object and extracted as needed.

The C<$data> parameter may be undef, in which case, only the header
parts of this object are valid.  If you do this, don't try to access
the data!

=cut

sub from_hdr_data {
  my $self=shift;

  my $hdr=shift;
  my $data=shift;

  # we don't generate all the same header fields as for the
  # from_helper_text call, as some of them (eg, NUMATTRB) should be
  # implicit in other data, and others (eg, DATATYPE) don't seem to
  # make an awful lot of sense ...
  $self->{header} = {
                     WHAT => $hdr->what(),
                     WHERE => $hdr->where(),
                     WHEN => $hdr->when(),
                     BLOCKFACTOR => $hdr->blockfactor(),
                    };
  $self->{lheader} = [qw(WHAT WHERE WHEN DATATYPE NUMBER BLOCKFACTOR)];

  # read the attributes, if there are any
  $self->{attribs} = {};
  $self->{lattribs} = [];
  if ($hdr->nattrb()) {
    my $sep=CFX5::IO::Const::IO_STR_TERMINATOR();
    for (my $i=0; $i < $hdr->nattrb(); $i++) {
      my $at=$hdr->attrb($i);
      # different writers separate them differently ...
      my ($atn,$atv)=split(/[=$sep]/,$at,2);
      $self->{attribs}{$atn}=$atv;
      push @{$self->{lattribs}}, $atn;
    }
  }

  $self->{header}{DATATYPE}=$hdr->istrct();
  $self->{header}{NUMBER}=$hdr->nstrct();

  $self->{control}{mode}='cfx5-io-base';
  $self->{control}{hdrok}=1;
  $self->{control}{dataok}=1;

  $self->{iobase}{hdr}=$hdr;
  $self->{iobase}{data}=$data;

  $self;
}

=head3 to_hdr_data

I<Internal function>

  ($hdr,$data)=$ds->to_hdr_data();

Initialises L<CFX5::IO::Header> and L<CFX5::IO::Data> objects from the
dataset object, which are user by the IO library access routines in
L<CFX5::IO::Base>.

If the dataset object was set up by a call to C<from_hdr_data>, the
cached internal objects will be reused and replaced.

=cut

sub to_hdr_data {
  my $self=shift;

  #
  # find some header and data objects, and an indication of whether
  # they are up to date or not.
  #

  my ($hdr,$data);
  if (exists $self->{iobase}{hdr}) {
    $hdr=$self->{iobase}{hdr};
  } else {
    $hdr=CFX5::IO::Header->new();
    $self->{control}{hdrok}=0;
  }
  
  if (exists $self->{iobase}{data}) {
    $data=$self->{iobase}{data};
  } else {
    $data=CFX5::IO::Data->new();
    $self->{control}{dataok}=0;
  }

  #
  # now plug our data into them
  #

  # transfer the header fields if necessary
  unless ($self->{control}{hdrok}) {
    $hdr->what($self->header('WHAT'));
    $hdr->where($self->header('WHERE'));
    $hdr->when($self->header('WHEN'));
    $hdr->blockfactor($self->header('BLOCKFACTOR'))
      if defined $self->header('BLOCKFACTOR');
    $hdr->istrct($self->header('DATATYPE'));
    $hdr->nstrct($self->header('NUMBER'));

    $hdr->nattrb(scalar @{$self->{lattribs}});
    if ($hdr->nattrb()) {
      my $c=0;
      for my $a (@{$self->{lattribs}}) {
        $hdr->attrb($c++,$a 
                    . CFX5::IO::Const::IO_STR_TERMINATOR() 
                    . $self->{attribs}{$a});
      }
    }
  }
  
  #
  # set up the memory for the data based on values in the header
  #
  my %callsNum=(
             INTR => 'numintr',
             STRI => 'numstring',
             REAL => 'numreal',
             DBLE => 'numdble',
             LOGL => 'numlogl',
            );
  unless ($self->{control}{hdrok} and $self->{control}{dataok}) {
    my $type=$self->header('DATATYPE');

    #
    # Handle datasets in callsNum hash
    if (exists $callsNum{$type}) {
      my $call=$callsNum{$type};
      $data->$call($self->header('NUMBER'));
    }
    
    #
    # Handle character datasets
    elsif ($type eq 'CHAR') {
      # NUMBER is 1, we just ignore it, it will be handled later
      1;
    }
    
    #
    # Handle structures 
    elsif ($type =~ /(STRC\{)(.*)(\})/ ) {
      my $strcDef = $2 ;
      
      my $NStrc   = $self->header('NUMBER') ;
      my %NValType=(INTR => 0,STRI => 0,REAL => 0,DBLE => 0,
                    LOGL => 0,CHAR => 0,);
   
      foreach my $dataTypeDef (split(' ',$strcDef)) {
        $dataTypeDef =~ /(.*):(.*)/ ;
        my $typeName = $1 ; 
        my $typeNVal = $2 ; 
        # SR - Remove this once the IO module no longer treats 
        #      STRI:n as one string of length n
        if ($typeName eq 'STRI') {
          $typeNVal = 1; 
        }  
        
        $NValType{$typeName} = $NValType{$typeName}+$typeNVal ; 
      }

      while (my ($typeName,$callNumName) = each %callsNum) {
        $data->$callNumName($NValType{$typeName}*$NStrc) ;
      }
    }
    
    #
    # Unhandled dataset...  
    else {
      internal_error("Unknown type $type");
    }
  }

  #
  # insert the data!  We have no 'raw data' for cfx5-io-base mode,
  # so users must always use the structured data access.  If there
  # is no structured data, dataok should *always* be true.
  #
  unless ($self->{control}{dataok}) {
    unless (exists $self->{strdata}) {
      internal_error("!dataok but no user data");
    }
    my %calls=(
               INTR => 'intrelt',
               STRI => 'stringelt',
               REAL => 'realelt',
               DBLE => 'dbleelt',
               LOGL => 'loglelt',
              );
    my $type=$self->header('DATATYPE');

    #
    # Handle datasets in calls hash
    if (exists $calls{$type}) {
      my $call=$calls{$type};
      my $c=0;
      for my $i (@{$self->{strdata}}) {
        $data->$call($c++,$i);
      }
    } 
    
    #
    # Handle pure character datasets
    # --> Break structure entries using newline
    elsif ($type eq 'CHAR') {
      my $str=join("\n",@{$self->{strdata}});
      $data->char($str);
      $hdr->nstrct(length($str));
    } 

    #
    # Handle structures 
    elsif ($type =~ /(STRC\{)(.*)(\})/) {
      my $strcDef = $2 ;
      my $NStrc   = $self->header('NUMBER') ;

      my %NValType=(INTR => 0,STRI => 0,REAL => 0,DBLE => 0,
                    LOGL => 0,CHAR => 0,);

      my @chars ;
      for (my $iStrc=0; $iStrc<$NStrc; $iStrc++) {
        my @dataStrc = @{${$self->{strdata}}[$iStrc]};
        my $iValStrc = 0 ;
        foreach my $dataTypeDef (split(' ',$strcDef)) {
          $dataTypeDef =~ /(.*):(.*)/ ;
          my $typeName = $1 ; 
          my $typeNVal = $2 ; 
          # SR - Remove this once the IO module no longer treats 
          #      STRI:n as one string of length n
          if ($typeName eq 'STRI') {
            $typeNVal = 1; 
          }  
          my $callName = $calls{$typeName} ;
          my $NValName = $NValType{$typeName} ; 
          
          if ($typeName eq 'CHAR') {
            my $Val = $dataStrc[$iValStrc++] ;
            my $clipped = substr($Val,0,$typeNVal); 
            my $rightPadded = sprintf("%-*s",$typeNVal,$clipped);
            push (@chars,$rightPadded); 
            $NValName += $typeNVal ; 
          }
          else {
            for (my $iVal=0; $iVal<$typeNVal; $iVal++) {
              my $Val = $dataStrc[$iValStrc++] ;
              $data->$callName($NValName++,$Val) ;
            }
          }
          $NValType{$typeName} = $NValName ;
        }
      }
      
      if ($NValType{CHAR}) {
        $data->char(join("",@chars)) ;
      }
    } 

    #
    # Unhandled dataset...  
    else {
      internal_error("Unknown type $type");
    }
  }

  # even if we weren't before, revert to this mode now ...
  $self->{control}{mode}='cfx5-io-base';
  
  # record the new header and data entries ...
  $self->{iobase}{hdr}=$hdr;
  $self->{iobase}{data}=$data;
  # ... and note that they are up to date.
  $self->{control}{hdrok}=1;
  $self->{control}{dataok}=1;

  # finally, return them
  return ($hdr, $data);
}

=head3 from_helper_text

I<Internal function>

  $ds->from_helper_text(@lines);

Another internal function.  This one initialises the object from the
text output by the IOtool helper.

Actually, this is quite similar to the internal storage format inside
the definition file: the major difference is that this output is
guaranteed to be unformatted.  There are differences in line endings
too, I believe.

=cut

sub from_helper_text {
  my $self=shift;

  $self->{control}{mode}='iotool-helper';

  # we know that, on NT, the iotool_helper program writes in text
  # mode, and further that there are no binary characters in the
  # output.  So we assume that all lines are CRLF-terminated on NT,
  # and modify our count of bytes read accordingly.
  my $crlf = $Config{windows_nt} ? 2 : 1;
  
  # lineify the text
  my @lines;
  for (@_) {
    push @lines,split(/\n\r?/,$_);
  }

  # wipe the interesting bits
  $self->{header} = {};
  $self->{lheader} = [];
  $self->{attribs} = {};
  $self->{lattribs} = [];

  my $line;
  my $sread=0;

  # first read the header
  $line=shift @lines;
  unless (defined $line and $line eq 'F ') {
    # sorry, no can do
    _error("Unable to read data set: output was not Formatted (first line was $line)");
    return 0;
  }

  # the first size line
  $line=shift @lines;
  unless (defined $line and $line =~ m/^\s*([0-9]+)\s*$/) {
    _error("Unable to read data set: bad size (second line was $line)");
    return 0;
  }
  my $size=$1;
    
  # *DATASET
  $line=shift @lines;
  $sread += length($line) + $crlf;
  unless (defined $line and $line =~ m/^\*DATASET\s*$/) {
    _error("Unable to read data set: missing *DATASET (third line was $line)");
    return 0;
  }

  # *HEADER
  $line=shift @lines;
  $sread += length($line) + $crlf;
  unless (defined $line and $line =~ m/^\*HEADER\s*$/) {
    _error("Unable to read data set: missing *HEADER (fourth line was $line)");
    return 0;
  }
  
  # WHAT/WHERE/WHEN/NUMATTRB occur in that order
  for my $www (qw(WHAT WHERE WHEN NUMATTRB)) {
    $line=shift @lines;
    $sread += length($line) + $crlf;
    unless (defined $line and $line =~ s/^$www=//) {
      _error("Unable to read data set: missing $www (line was $line)");
      return 0;
    }
    $line =~ s/^\s*|\s*$//g;
    $self->{header}{$www} = $line;
    push @{$self->{lheader}}, $www;
  }

  my $me=($self->{header}{WHAT} . '/' . 
          $self->{header}{WHERE} . '/' . 
          $self->{header}{WHEN});

  unless ($self->{header}{WHEN} =~ m/^[0-9]+$/) {
    _error("Unable to read data set $me: bad WHEN value $self->{header}{WHEN}");
    return 0;
  }

  unless ($self->{header}{NUMATTRB} =~ m/^[0-9]+$/) {
    _error("Unable to read data set $me: bad NUMATTRB value $self->{header}{NUMATTRB}");
    return 0;
  }

  if ($self->{header}{NUMATTRB}) {
    my $total=$self->{header}{NUMATTRB};
    $self->{attribs}={};
    for (my $c=0; $c < $total; $c++) {
      $line=shift @lines;
      $sread += length($line) + $crlf;
      unless (defined $line and $line =~ m/^([^\s]+)\|(.*?)\s*$/) {
        _error("Unable to read data set $me: bad attribute line $line");
        return 0;
      }
      $self->{attribs}{$1} = $2;
      push @{$self->{lattribs}}, $1;
    }
  }

  # WHAT/WHERE/WHEN/NUMATTRB occur in that order
  for my $www (qw(DATATYPE NUMBER BLOCKFACTOR)) {
    $line=shift @lines;
    $sread += length($line) + $crlf;
    unless (defined $line and $line =~ s/^$www=//) {
      _error("Unable to read data set $me: missing $www (line was $line)");
      return 0;
    }
    $line =~ s/^\s*|\s*$//g;
    $self->{header}{$www} = $line;
    push @{$self->{lheader}}, $www;
  }

  # *DATA
  #
  # This line may not be present for all datasets, specifically those
  # where NUMBER=0.  This is not an error!
  if ($self->{header}{NUMBER} == 0) {
    if ($lines[$#lines] =~ m/^\*DATA\s*$/) {
      _error("Unable to read dataset $me: *DATA unexpected when NUMBER=0");
      return 0;
    }
  } else {
    # read the *DATA line
    $line=shift @lines;
    $sread += length($line) + $crlf;
    unless (defined $line and $line =~ m/^\*DATA\s*$/) {
      _error("Unable to read data set $me: missing *DATA (line was $line)");
      return 0;
    }
  }
  
  # read the data.  We assume that the size we were given is correct.
  # If there is no data in this dataset, this will read only the
  # *ENDDATASET line, leaving @data empty; we can then happily assign
  # an empty list to $self->{data}.
  my @data;
  while (@lines and $sread < $size) {
    $line=shift @lines;
    $sread += length($line) + $crlf;
    push @data, $line;
  }
  if ($sread > $size) {
    _error("Dataset $me did not finish on a line boundary, probably corrupt.  (Read $sread > $size");
    return 0;
  }
  if ($sread < $size) {
    _error("Unexpected end of input reading $me after $sread/$size bytes");
    return 0;
  }
  
  # OK, now strip off the trailing *ENDDATASET
  unless ($data[$#data] eq "*ENDDATASET") {
    _error("Unable to read data set $me: missing *ENDDATASET (found $data[$#data])");
    return 0;
  }
  pop @data;

  $self->{data} = \@data;

  # the final size line should say the same!
  $line=shift @lines;
  unless (defined $line and $line =~ m/^\s*([0-9]+)\s*$/) {
    _error("Unable to read data set $me: bad size line $line");
    return 0;
  }
  my $fsize=$1;

  unless ($fsize == $size) {
    _error("Unable to read data set $me: inconsistent leading/trailing sizes ($size != $fsize)");
    return 0;
  }    

  if (@lines) {
    _error join("Unable to read data set $me: additional data after EOF");
    return 0;
  }

  1;  
}

=head2 NAMING

=head3 short_name

  die "Error writing ", $ds->short_name();

Returns a short string giving an identifier for the dataset, for
example "G/COMMANDS:EVERY:0".  This string should only be used in
messages, and its format should not be relied upon.

=cut

sub short_name {
  my $self=shift;
  return join(':',
              $self->header('what'),
              $self->header('where'),
              $self->header('when')
             );
}

=head2 HEADERS AND ATTRIBUTES

The distinction between the headers -- WHAT, BLOCKFACTOR, DATATYPE and
the like -- and the attributes -- HOW, CLASS, etc -- in the io library
is not well-made.  Here we provide a unified set of functions capable
of using them interchangeably (with prefix C<>), and also functions to
access them individually if you would rather do it this way!

The distinction is made as follows: anything which was read from the
original data set as a "header" is treated as such from then on.
Headers may not be deleted or reordered, and no new headers may be
created via this route.  

Anything which was read from the definition file as an attribute, or
created via the attribute or unified functions, is treated as an
attribute.  Attributes may be freely created, destroyed and reordered.

Header and attribute names are all treated in the same way: in the
definition file, all names are assumed to be uppercase, and without
leading hyphens.  So lower- or mixed-case names may be passed in, and
will be translated to uppercase, and any leading hyphens will be
stripped.  The following are all valid ways of referring to the "HOW"
attribute:
  HOW
  -HOW
  How
  -how
along with some other, more bizarre ones!

=cut

sub normalize_key {
  my $key=shift;
  $key =~ s/^-*//g;
  uc($key);
}

=head3 header

This function gives unified access to the base IO library headers
(C<ioheader>) and the attributes (C<attribute>) associated with a data
set.

  $how = $ds->header('how');

  $ds->header(-how => 'EXPRESSION');

  %attrs = $ds->header();

Gives access to the headers associated with the dataset.  The first
form returns the current value of an header, the second sets an
header (but see the C<write_dataset> function).

The third form returns a list containing all the headers defined in
the dataset, in order of definition, along with their values; this
means that it is in a form which may be assigned to a hash (as
illustrated above), but it may also be processed in a loop to preserve
the ordering.  Any non-existant headers created are added to the end
of this ordering.  This always includes the IO library headers before
the attributes.

Header names are assumed all to be uppercase and without leading
hyphens, and any names passed in will be made to conform to this
before being added to the dataset.

Any new headers created will be treated as attributes rather than
IO-library headers.

=cut

sub header {
  my $self=shift;
  if (scalar(@_) == 1) {
    # return the value of a single header
    my $k=normalize_key($_[0]);
    if ($self->is_ioheader($k)) {
      return $self->ioheader($k);
    } else {
      return $self->attribute($k);
    }
  } elsif (scalar(@_)) {
    # set an header
    my $name = normalize_key(shift);
    my $value = shift;

    if ($^W and @_) {
      warn "Extra arguments to header() ignored";
    }

    if ($self->is_ioheader($name)) {
      return $self->ioheader($name,$value);
    } else {
      return $self->attribute($name,$value);
    }

  } else {
    return ($self->ioheader(), $self->attribute());
  }
}

=head3 delete_header

  $ds->delete_header('HOW');

Removes an header from the list associated with a dataset.  If the
header is not set, a warning is given under -w.  This also removes
the header from the ordering, so if the header is re-added, it
will be at the end again.

This only applies to attributes; it is an error to attempt to remove
an IO library standard header, which will cause the library to abort
with the C<internal_error> call.

=cut

sub delete_header {
  my $self=shift;
  for my $a (@_) {
    my $k = normalize_key($a);

    if ($self->is_ioheader($k)) {
      internal_error("Attempt to delete standard IO library header $k");
    }

    $self->delete_attribute($k);
  }
  1;
}

=head3 ioheader

This function manipulates the "IO library headers," those headers
which are built in to the IO library.  See also the "header" function
for the integrated header/attribute access.

  $how = $ds->ioheader('what');

  $ds->ioheader(-what => 'G/COMMANDS');

  %attrs = $ds->ioheader();

Gives access to the ioheaders associated with the dataset.  The first
form returns the current value of an ioheader, the second sets an
ioheader (but see the C<write_dataset> function).

The third form returns a list containing all the ioheaders defined in
the dataset, in order of definition, along with their values; this
means that it is in a form which may be assigned to a hash (as
illustrated above), but it may also be processed in a loop to preserve
the ordering.  Any non-existant ioheaders created are added to the
end of this ordering.

Ioheader names are assumed all to be uppercase and without leading
hyphens, and any names passed in will be made to conform to this
before being added to the dataset.

=cut

sub ioheader {
  my $self=shift;
  if (scalar(@_) == 1) {
    # return the value of a single ioheader
    return $self->{'header'}{normalize_key($_[0])};
  } elsif (scalar(@_)) {
    # set an ioheader
    my $name = normalize_key(shift);
    my $value = shift;

    if ($^W and @_) {
      warn "Extra arguments to ioheader() ignored";
    }

    my $old=$self->{'header'}{$name};

    unless (exists $self->{'header'}{$name}) {
      push @{$self->{lheader}}, $name;
    }
    $self->{'header'}{$name} = $value;

    $self->{control}{hdrok}=0;

    return $old;
  } else {
    my @l;
    for (@{$self->{lheader}}) {
      push @l, $_, $self->{'header'}{$_};
    }
    return @l;
  }
}

=head3 is_ioheader

  die "Dont want to modify IO library header" if $ds->is_ioheader($hdr);

Returns TRUE if the named header is one of the base IO library headers
(for this dataset), or FALSE otherwise.

=cut

sub is_ioheader {
  my $self=shift;
  my $hdr=normalize_key(shift);
  for my $h (@{$self->{lheader}}) {
    return 1 if $hdr eq normalize_key($h);
  }
  return '';
}

=head3 attribute

This function manipulates the "attributes," those headers which are
I<not> built in to the IO library.  See also the "header" function for
the integrated header/attribute access.

  $how = $ds->attribute('how');

  $ds->attribute(-how => 'EXPRESSION');

  %attrs = $ds->attribute();

Gives access to the attributes associated with the dataset.  The first
form returns the current value of an attribute, the second sets an
attribute (but see the C<write_dataset> function).

The third form returns a list containing all the attributes defined in
the dataset, in order of definition, along with their values; this
means that it is in a form which may be assigned to a hash (as
illustrated above), but it may also be processed in a loop to preserve
the ordering.  Any non-existant attributes created are added to the
end of this ordering.

Attribute names are assumed all to be uppercase and without leading
hyphens, and any names passed in will be made to conform to this
before being added to the dataset.

=cut

sub attribute {
  my $self=shift;
  if (scalar(@_) == 1) {
    # return the value of a single attribute
    return $self->{attribs}{normalize_key($_[0])};
  } elsif (scalar(@_)) {
    # set an attribute
    my $name = normalize_key(shift);
    my $value = shift;

    if ($^W and @_) {
      warn "Extra arguments to attribute() ignored";
    }

    my $old=$self->{attribs}{$name};

    unless (exists $self->{attribs}{$name}) {
      push @{$self->{lattribs}}, $name;
    }
    $self->{attribs}{$name} = $value;

    $self->{control}{hdrok}=0;

    return $old;
  } else {
    my @l;
    for (@{$self->{lattribs}}) {
      push @l, $_, $self->{attribs}{$_};
    }
    return @l;
  }
}

=head3 delete_attribute

  $ds->delete_attribute('HOW');

Removes an attribute from the list associated with a dataset.  If the
attribute is not set, a warning is given under -w.  This also removes
the attribute from the ordering, so if the attribute is re-added, it
will be at the end again.

=cut

sub delete_attribute {
  my $self=shift;
  for my $a (@_) {
    my $k = normalize_key($a);
    if ($^W) {
      warn "Deleting nonexistant attribute"
        unless exists $self->{attribs}{$k};
    }
    delete $self->{attribs}{$k};
    @{$self->{lattribs}} = grep { $_ ne $k } @{$self->{lattribs}};
  }

  $self->{control}{hdrok}=0;

  1;
}

=head2 DATA TYPES AND PARSING

The IO library supports a load of different data types, such as
strings, floating point numbers, and so on.  Perl, on the other hand,
supports a single polymorphic datatype, the "scalar".  This section
includes routines which access the data contained in a dataset.

The functionality available depends on the source of the data.  If it
came from the IO library directly, via L<CFX5::IO::Base>, it can be
read and written, but the "raw data access" functions are not
available (because they make no sense).  If the data originated with
the IO tool helper, it cannot be written back to the definition file,
but the "raw data access" functions will return the data as read from
the helper.

There are two sets of routines in this section.  If raw data access is
available, the C<raw_data> call allows the direct reading and
modification of the data as read from the IO tool helper.  The rest of
the section presents a set of calls for structured access to this
data.  These sets of functions are interlinked, and cache their
results intelligently, so you can safely intermix writes in one style
with reads in either style.  It makes less sense to write in both raw
and structured modes between reads, though, and so this is not
supported.

In iotool helper mode, this intermixing is implemented by storing a
"canonical" form of the data in the raw format, and caching the
structured version.  So a write via the structured access functions
will create the raw dataset and write that via C<raw_data>, and any
write via C<raw_data> will mark the cached structured interpretation
as dirty.

=head3 STRUCTURED DATA ACCESS

The IO library defines many different types of data which may be
stored.  Because of the expected usage of this library, we aim to make
the data available via a more "perlish" interface, and Perl does not
support all of the data types supported by the IO library; further,
Perl makes use of a single "polymorphic" (is this the right word?)
data types which covers most of the options given by the io library.

The empasis for these routines is reading and manipulating the data,
and the assumption is made that the programmer will do sensible things
with the data if she wants to write it back to the file.  When
writing, the DATATYPE header will be honoured to get the correct
representation.

At some point in the future, this library may be expandable to use
these datatypes explicitly, but in this set of functions we map from
the IO library data types in the following way:

=over

=item STRI

This is a string.  Trailing whitespace is stripped.

When a string is written, each string will be truncated to 80
characters.  This is C<IO_BUFSIZE>, but so far as I can tell is
unchangeable in the IO library if we want to maintain backwards
compatibility ...

=item DBLE, INTR, REAL

Numbers.  These are converted to standard Perl scalars (and we hope
that a DBLE will not overflow the scalar).

When these are written, integers will be rounded in an undefined
manner, so make sure you pass in integers!

=item LOGL

A logical variable will become 1 for TRUE and C<''> (the empty string)
for FALSE.  This is consistent with standard Perl usage.

=item CHAR

The CHAR datatype will be handled as a single string (rather than an
array of characters).

=item STRC

When I get around to it, a STRC structure will be returned as a
listref with one element for each entry in the structure.  This will
not be implemented in the initial version of this library.

=back

=head3 data

  @data=$ds->data();

  $ds->data(@data);

Gets and sets the data associated with a data set in a structured and
perlish manner.  The return value is a list of C<NUMBER> items, one
for each data entry; the individual items are encoded as above.  This
function I<should not> be called in a scalar context; under C<-w>,
this will trigger a warning.  If you want to read only a single item
(eg because you know there is only one), use a construction such as

  $item = ($ds->data())[0];

Really, though, one should check the C<NUMBER> field and do something
sensible ...

The C<NUMBER> header is updated with the new count of data.

An error is signified by an empty list.

=cut

sub data {
  my $self=shift;

  if (@_) {
    # we've got data

    # how much?
    my $number=$self->header('number');
    unless (defined $number and $number == scalar(@_)) {
      $self->header('NUMBER' => scalar(@_));
    }

    if ($self->{control}{mode} eq 'iotool-helper') {
      # OK, now convert it ...
      my @conv=cvt_to_datatype($self->header('datatype'),@_);
      # ... and record the new stuff
      $self->raw_data(@conv);
    } else {
      # for the CFX5::IO::Base mode, the strdata -- if present -- is
      # canonical
      $self->{strdata}=[@_];
    }

    # we're now no longer up to date with what we read
    $self->{control}{dataok}=0;
  } else {
    if ($^W and !wantarray) {
      carp "the data() method should only be called in a list context";
    }
    $self->get_str_data() unless exists $self->{strdata};

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

sub get_str_data() {
  my $self=shift;

  # we will be up to date with our 'raw' state after this exits
  $self->{control}{uptodate}=1;

  if ($self->{control}{mode} eq 'cfx5-io-base') {
    # need to read the data from wherever it is in the data object
    $self->{strdata}=[];
    my %callmap=(
                 STRI => 'string',
                 INTR => 'intr',
                 REAL => 'real',
                 DBLE => 'dble',
                 LOGL => 'logl',
                );
    my $data=$self->{iobase}{data};
    my $type=$self->header('datatype');
    
    #
    # Handle datasets in callmap
    if (exists $callmap{$type}) {
      my $callname=$callmap{$type};
      my $numattr="num$callname";
      my $attrelt="${callname}elt";
      my $num=$data->$numattr();
      my @rv;
      for (my $i=0; $i<$num; $i++) {
        push @rv, $data->$attrelt($i);
      }
      $self->{strdata}=\@rv;
      return;
    } 
    
    #
    # Handle character datasets
    # --> Split at new lines  
    elsif ($type eq 'CHAR') {
      $self->{strdata}=[ split(/\n/,$self->{iobase}{data}->char()) ];
      return;
    } 
      
    #
    # Handle structures 
    elsif ($type =~ /(STRC\{)(.*)(\})/ ) {
      my $strcDef = $2 ;
      my @rv;
      
      my $NStrc = $self->header('number') ;

      
      my %NValType=(INTR => 0,STRI => 0,REAL => 0,DBLE => 0,
                    LOGL => 0,CHAR => 0,);

      # Validate number of characters available
      my $chars = $data->char() ;
      my $NChars = 0 ;
      foreach my $dataTypeDef (split(' ',$strcDef)) {
        $dataTypeDef =~ /(.*):(.*)/ ;
        if ($1 eq 'CHAR') {
          $NChars += $2; 
        }
      }
      if (defined $chars) {
        my $totalChars     = length($chars) ; 
        my $totalCharsReqd = $NChars*$NStrc ;
        if ($totalChars != $totalCharsReqd) {
          _error("Structure dataset provides $totalChars characters but $totalCharsReqd required\n");
          return 0;
        }
      }

      for (my $iStrc=0; $iStrc<$NStrc; $iStrc++) {
        my @strcData ;
        my $iValStrc = 0 ;
        foreach my $dataTypeDef (split(' ',$strcDef)) {
          $dataTypeDef =~ /(.*):(.*)/ ;
          my $typeName = $1 ; 
          my $typeNVal = $2 ; 
          # SR - Remove this once the IO module no longer treats 
          #      STRI:n as one string of length n
          if ($typeName eq 'STRI') {
            $typeNVal = 1; 
          }  
          if ($typeName eq 'CHAR') {
            push ( @strcData, substr($chars,$NValType{$typeName},$typeNVal) );
            $NValType{$typeName} = $NValType{$typeName} + $typeNVal ; 
          }
          else {
            my $callType = $callmap{$typeName} ;
            my $callName="${callType}elt" ;
            my $NValName = $NValType{$typeName} ; 
            for (my $iVal=0; $iVal<$typeNVal; $iVal++) {
              push ( @strcData,$data->$callName($NValType{$typeName}++) ) ;
            }
          }
        }
        push (@rv,[@strcData]) ;
      }

      $self->{strdata}=\@rv ;
      return;           
    } 

    #
    # Unhandled dataset...  
    else {
      croak "Unknown type $type";
    }
  } elsif ($self->{control}{mode} eq 'iotool-helper') {
    my @l=cvt_from_datatype($self->header('datatype'),
                            $self->header('number'),
                            $self->raw_data());
    $self->{strdata}=\@l;
    return;
  } else {
    croak("Unknown mode $self->{control}{mode}");
  }
}

=head3 cvt_to_datatype

I<internal function>

  @encoded = cvt_to_datatype($type,@data);

The first argument is an IO library datatype; the remaining
argument(s) are data item(s) to convert.  The return value is a list
of the data item(s) expressed in the correct form for the IO library
to read.  Note that the list is not guaranteed to have the same number
of elements as the number of data items.

=cut

sub cvt_to_datatype {
  my $type=shift;
  my @data=@_;

  my ($basetype,$subtype) = ($type,undef);
  if ($type =~ m/^([^:]+):(.*)$/) {
    ($basetype,$subtype)=($1,$2);
  }
  $basetype = normalize_key($basetype);

  if      ($basetype eq 'INTR') {
    internal_error("Cannot encode INTR datasets yet");
  } elsif ($basetype eq 'REAL') {
    internal_error("Cannot encode REAL datasets yet");
  } elsif ($basetype eq 'DBLE') {
    internal_error("Cannot encode DBLE datasets yet");
  } elsif ($basetype eq 'STRI') {
    my $len=80;                        # default
    if (defined $subtype) {
      if ($subtype =~ m/^[0-9]+\s*$/) {
        $len=$subtype;
      } else {
        _error("Unrecognised $basetype subtype $subtype");
        return undef;
      }
    }
    my @rv;
    for my $datum (@data) {
      if (length $datum > $len) {
        _warn "Discarding end of overlong datum\n$datum\n(length > $len)";
        $datum=substr($datum,0,$len);
      }
      push @rv, $datum . (' ' x ($len - length($datum)));
    }
    return @rv;
  } elsif ($basetype eq 'SRTC') {
    internal_error("Cannot encode STRC datasets yet");
  } elsif ($basetype eq 'LOGL') {
    internal_error("Cannot encode LOGL datasets yet");
  } else {
    internal_error("Unrecognised datatype $type (base type $basetype)");
  }
}

=head3 cvt_from_datatype

I<internal function>

  @decoded = cvt_from_datatype($type,@data);

The first argument is an IO library datatype; the remaining
argument(s) are the data item(s) to convert, in the IO library format.
The return value is a list of Perl scalar(s) representing the data
item(s) (which may be a complex type).

=cut

sub cvt_from_datatype {
  my $type=shift;
  my $number=shift;
  my @data=@_;

  my ($basetype,$subtype) = ($type,undef);
  if ($type =~ m/^([^:{}]+):(.*)$/) {
    ($basetype,$subtype)=($1,$2);
  }
  if ($type =~ m/^([^:{}]+)\s*({.*})$/) {
    ($basetype,$subtype)=($1,$2);
  }    
  $basetype = normalize_key($basetype);

  if      ($basetype eq 'INTR'
           or $basetype eq 'REAL'
           or $basetype eq 'DBLE') {
    # a set of WS-separated numbers, with random newlines inserted
    # into various places
    my @rv;
    while (@data) {
      chomp $data[0];
      my $l=$data[0];
      $l =~ s/^\s*//;
      unless ($l =~ m/[^\s]/) {
        # unless we've still got something on this line, scrub it and
        # have another go
        shift @data;
        next;
      }
      # we have at least one number.  We assume that a "number" is
      # simply a space-separated token; this is a little lax on error
      # checking, but easier!
      unless ($l =~ s/^([^\s]+)//) {
        internal_error("Nothing in non-empty list!");
      }
      push @rv, $1;
      $data[0]=$l;
    }
    return @rv;
  } elsif ($basetype eq 'STRI' or $basetype eq 'CHAR') {
    # CHAR and STRI are similar; a CHAR dataset is like an STRI
    # dataset where NUMBER gives the length of the only string
    my $len=80;                        # default for STRI lines
    my $num=$number;
    if ($basetype eq 'STRI') {
      if (defined $subtype) {
        if ($subtype =~ m/^[0-9]+\s*$/) {
          $len=$subtype;
        } else {
          _error("Unrecognised $basetype subtype $subtype");
          return undef;
        }
      }
    } elsif ($basetype eq 'CHAR') {
      $len=$number;
      $num=1;
    }

    # STRI datasets seem to be written one-per-line, and space-padded.
    # I don't know if they can include CRs, but I'll assume for now
    # that they can't.
    my @rv;
    while (@data) {
      my $l=shift @data;
      chomp $l;
      if (length($l) > $len) {
        _warn("Discarding unexpected characters on reading string\n$l");
        # and do it
        $l = substr($l,0,$len);
      } elsif (length($l) < $len) {
        _warn("String read too short:\n$l");
        # this ensures we can do our stuff
        $l .= (' ' x $len);
      }
      # now we're in Perl, we don't want trailing blanks (but we
      # should preserve leading ones)
      $l =~ s/\s*$//;
      push @rv, $l;
    }
    if (@rv != $num) {
      _error("Wrong number of items (", scalar(@rv), " != $num");
    }
    return @rv;
  } elsif ($basetype eq 'STRC') {
    internal_error("Cannot decode STRC datasets yet");
  } elsif ($basetype eq 'LOGL') {
    internal_error("Cannot decode LOGL datasets yet");
  } else {
    internal_error("Unrecognised datatype $type (base type $basetype)");
  }
  internal_error("Control flow in unexpected place");
}

=head3 raw_data

  my @data=$ds->raw_data();

  $ds->raw_data(@new_data);

This call simply returns the data associated with a dataset as a list
of strings, with trailing newlines stripped.

Calls to C<raw_data> I<may be mixed> with calls to the more useful
C<data> function below.

=cut

sub raw_data {
  my $self=shift;
  unless ($self->{control}{mode} eq 'iotool-helper') {
    internal_error("raw_data called in $self->{control}{mode} mode");
  }
  if (@_) {
    # writing new data
    my @old;
    if (exists $self->{data}) {
      @old=@{$self->{data}};
    }
    delete $self->{strdata};
    $self->{data} = [@_];
    return @old;
  } else {
    return @{$self->{data}};
  }
}

=head2 HIGHER-LEVEL DATA ACCESS

This section is basically a set of conversion routines, between the
(fairly basic) formats supplied by the IO module and some more common
real-world formats.  Each routine will get the data, if given no
arguments, or set it if given argument(s).

=head3 data_text

  $ds->data_text(@lines);
  print join("\n",$ds->data_text());

General text, ie, a list of lines of text which may be longer than 80
characters.  Not newline-terminated.

In earlier releases, we would split this into a set of lines with
backslashses, and write it as STRI.  Now, for speed reasons, we write
it as a single CHAR dataset.  We still read either, though.

=cut

sub data_text {
  my $self=shift;

  if (@_) {
    # set
    $self->header(datatype => 'CHAR');

    $self->data(@_);

    return @_;
  }

  # trying to get, rather than set.  First off, check it's reasonable.
  if ($self->header('DATATYPE') eq 'STRI') {
    _debug("Decoding STRI data");
    return $self->data_text_decode($self->data());
  }
  if ($self->header('DATATYPE') eq 'CHAR') {
    _debug("Decoding CHAR data");
    return $self->data();
  }

  # nope
  _error("Unable to read text from dataset", $self->short_name()
         .": expected datatype of STRI or CHAR, got", $self->header('DATATYPE'));
  return ();
}

sub data_text_encode {
  my $self=shift;

  my @new;
  chomp (my @data=@_);
  for my $l (@data) {
    # first of all we double all the backslashes
    $l =~ s!\\!\\\\!g;
    while (length($l) > 78) {
      my $pos=78;
      while (substr($l,$pos-1,1) eq '\\' and $pos > 0) {
        # if the line ends with a backslash, we can't break here,
        # it's too confusing (think of the doubling we've just
        # done).
        $pos--;
      }
      if (not $pos) {
        # OK, we'll have to try.  We only do this if we have to, as
        # the above should be quicker and look better in the file (?)
        my $lastok;
        my $bsc=0;
        $pos=0;
        while ($pos < 78) {
          if (substr($l,$pos-1,1) eq '\\') {
            $bsc++;
          }
          if ($bsc % 2 == 0) {
            # even number, we're OK
            $lastok=$pos;
          }
          $pos++;
        }

        # now lastok should be defined to a usable split position,
        # as we do have at least 78 chars on the line ...
        unless (defined $lastok and $lastok) {
          internal_error("Last ditch split position location failed for line: $l");
        }

        $pos=$lastok;
      }
      my $sub=substr($l,0,$pos);
      push @new, $sub."\\";
      $l=substr($l,$pos);
    }
    # do this even if it's empty, to terminate the above line
    push @new, $l;
  }

  @new;
}

sub data_text_decode {
  my $self=shift;
  my @data=@_;

  my @text;

  # unwrap line-by-line.  The basic idea is, "if it ends in a
  # backslash and it's not a quoted one, join the lines", but in real
  # life it's of course not that easy.
  my $pos=0;
  for my $l (@data) {
    # first of all, we need to work out what $l actually is!
    unless ($l =~ m!\\$!) {
      # no trailing backslash, it's easy
      $l =~ s!\\\\!\\!g;
      $text[$pos++] .= $l;
      next;
    }

    if ($l =~ s!([^\\])\\$!$1!) {
      # there is a trailing backslash, but not one before it, so WMA
      # it's unquoted
      $l =~ s!\\\\!\\!g;
      $text[$pos] .= $l;
      next;
    }

    # otherwise, we'll have to be more careful.  The line ends with at
    # least two backslashes, so count them.  If the number is even,
    # they all quote each other and this is not a continuation line.
    # If the number is odd, they mostly quote each other and it *is* a
    # continuation line.
    unless ($l =~ m!(\\+)$!) {
      internal_error("I could have sworn there were backslashes on the end of $l");
    }
    my $count=length($1);
    if ($count % 2) {
      # odd
      $l =~ s!\\$!!;
      $l =~ s!\\\\!\\!g;
      $text[$pos] .= $l;
    } else {
      # even
      $l =~ s!\\\\!\\!g;
      $text[$pos++] .= $l;
    }
  }

  @text;
}

1;
