Astro::FITS::Header::Item - A card image from a FITS header

  $item = new Astro::FITS::Header::Item( Card => $card );

  $item = new Astro::FITS::Header::Item( Keyword => $keyword,
					 Value => $value,
					 Comment => $comment,
					 Type => 'int'
				       );

  $value = $item->value();
  $comment = $item->comment();

  $card = $item->card();

  $card = "$item";

package Astro::FITS::Header::Item;

use strict;
use overload (
	      '""'       =>   'overload_kluge'
	      );

use vars qw/ $VERSION /;
use Carp;

$VERSION = 3.01;

sub new {
  my $proto = shift;
  my $class = ref($proto) || $proto;

  my $item = {
	      Keyword => undef,
	      Comment => undef,
	      Value => undef,
	      Type => undef,
	      Card => undef,  # a cache
	     };

  bless $item, $class;

  # If we have arguments configure the object
  $item->configure( @_ ) if @_;

  return $item;
}

sub copy {
  my $self = shift;
  my %copy = %$self;
  return bless \%copy, ref( $self );
}

sub keyword {
  my $self = shift;
  if (@_) {
    $self->{Keyword} = uc(shift);
    $self->{Card} = undef;
  }
  return $self->{Keyword};
}

sub value {
  my $self = shift;
  if (@_) {
    my $value = shift;
    $self->{Value} = $value;
    $self->{Card} = undef;

    if (UNIVERSAL::isa($value,"Astro::FITS::Header" )) {
      $self->type( "HEADER" );
    } elsif (defined $self->type && $self->type eq 'HEADER') {
      # HEADER is only valid if we really are a HEADER
      $self->type(undef);
    }

  }
  return $self->{Value};
}

sub comment {
  my $self = shift;
  if (@_) {
    $self->{Comment} = shift;
    $self->{Card} = undef;
  }
  return $self->{Comment};
}

sub type {
  my $self = shift;
  if (@_) {
    my $type = shift;
    $type = uc($type) if defined $type;
    $self->{Type} = $type;
  }
  return $self->{Type};
}

# This is required because overloaded methods are called with
# extra arguments and card() can not tell the difference between
# an undef value and a stringify request
sub overload_kluge {
  my $self = shift;
  return $self->card;
}

sub card {
  my $self = shift;
  if (@_) {
    my $card = shift;
    if (defined $card) {
      my $clen = length($card);
      # force to 80 characters
      if ($clen < 80) {
	$card = $card . (" "x(80-$clen));
      } elsif ($clen > 80) {
	$card = substr($card, 0, 80);
      }
    }
    # can assign undef to clear
    $self->{Card} = $card;
  }
  # We are returning a value. Create if not present
  # Since we are being called by stringify to set the object
  # we need to make sure we don't get into an endless loop
  # trying to create the string but not having the correct info
  # Especially important since stringify calls card().
  $self->{Card} = $self->_stringify unless defined $self->{Card};
  return $self->{Card};
}

sub configure {
  my $self = shift;
  my %hash = @_;

  if (exists $hash{'Card'}) {
    if (ref($hash{Card}) && $hash{Card}->isa("Astro::FITS::Header::Item")) {
      # low level populate - can not use copy since we already have a copy
      for my $k (keys %{$hash{Card}}) {
        $self->{$k} = $hash{Card}->{$k};
      }
    } else {
      $self->parse_card( $hash{'Card'});
    }
  } else {
    # Loop over the allowed keys storing the values
    # in the object if they exist
    for my $key (qw/Keyword Type Comment Value/) {
      my $method = lc($key);
      $self->$method( $hash{$key}) if exists $hash{$key};
    }

    # only set type if we have not been given a type
    if (!$self->type) {
      if (!$self->keyword && !$self->value) {
	# completely blank
	$self->type("BLANK");
      } elsif (!$self->keyword || $self->keyword =~ /^(COMMENT|HISTORY)$/) {
	# COMMENT, HISTORY, and blank cards are special
	$self->type('COMMENT')
      } else {
        my $type = $self->guess_type( $self->value );
        $self->type( $type ) if defined $type;
      }
    }

    # End cards are special, need only do a Keyword => 'END' to configure
    $self->type('END') if $self->keyword() eq 'END';
  }
}

sub freeze {
  my $self = shift;
  return bless $self, 'Astro::FITS::Header::Item';
}

# Fits standard specifies
# Characters 1:8  KEYWORD (trailing spaces)  Comment cards: COMMENT,
#                 HISTORY, blank, and HIERARCH are special.
#            9:10 "= "  for a valid value (unless comment keyword)
#            11:80 The Value   "/" used to indicate a comment

# HIERARCH keywords
#      This is a comment but used to store values in an extended,
#      hierarchical name space.  The keyword is the string before
#      the equals sign and ignoring trailing spaces.  The value
#      follows the first equals sign.  The comment is delimited by a
#      solidus following a string or a single value.   The HIERARCH
#      keyword may follow a blank keyword in columns 1:8..
#
# The value can contain:
#  STRINGS:
#      '  starting at position 12
#      A single quote represented as ''
#      Closing quote must be at position 20 or greater (max 80)
#      Trailing blanks are removed. Leading spaces in the quotes
#      are significant
#  LOGICAL
#      T or F in column 30. Translated to 1 or 0
#  Numbers
#      D is an allowed exponent as well as E

sub parse_card {
  my $self = shift;
  return () unless @_;

  my $card = shift;
  my $equals_col = 8;

  # Remove new line and pad card to 80 characters
  chomp($card);
#  $card = sprintf("%-80s", $card);

  # Value is only present if an = is found in position 9
  my ($value, $comment) = ('', '');
  my $keyword = uc(substr($card, 0, $equals_col));

  # HIERARCH special case.  It's a comment, but want to treat it as
  # a multi-word keyword followed by a value and/or comment.
  if ( $keyword eq 'HIERARCH' || $card =~ /^\s+HIERARCH/ ) {
    $equals_col = index( $card, "=" );
    $keyword = uc(substr($card, 0, $equals_col ));
  }
  # Remove leading and trailing spaces, and replace interior spaces
  # between the keywords with a single .
  $keyword =~ s/^\s+// if ( $card =~ /^\s+HIERARCH/ );
  $keyword =~ s/\s+$//;
  $keyword =~ s/\s+/./g;

  # update object
  $self->keyword( $keyword );

  # END cards are special
  if ($keyword eq 'END') {
    $self->comment(undef);
    $self->value(undef);
    $self->type( "END" );
    $self->card( $card ); # store it after storing indiv components
    return("END", undef, undef);
  }

  # This will be a blank line but will not trigger here if we
  # are padding to 80 characters
  if (length($card) == 0) {
    $self->type( "BLANK" );
    return( undef, undef, undef);
  }

  # Check for comment or HISTORY
  # If the card is not padded this may trigger a warning on the
  # substr going out of bounds
  if ($keyword eq 'COMMENT' || $keyword eq 'HISTORY' ||
      (substr($card,8,2) ne "= " && $keyword !~ /^HIERARCH/)) {

    # Store the type
    $self->type( "COMMENT" );

    # We have comments
    unless ( length( $card) <= 8 ) {
       $comment = substr($card,8);
       $comment =~ s/\s+$//;  # Trailing spaces
    } else {
       $comment = "";
    }

    # Alasdair wanted to store this as a value
    $self->comment( $comment );

    $self->card( $card ); # store it after storing indiv components
    return ($keyword, undef, $comment);
  }

  # We must have a value after '= '
  my $rest = substr($card, $equals_col+1);

  # Remove leading spaces
  $rest =~ s/^\s+//;

  # Check to see if we have a string
  if (substr($rest,0,1) eq "'") {

    $self->type( "STRING" );

    # Check for empty (null) string ''
    if (substr($rest,1,1) eq "'") {
      $value = '';
      $comment = substr($rest,2);
      $comment =~ s/^\s+\///;  # Delete everything before the first slash

    } else {
      # '' needs to be treated as an escaped ' when inside the string
      # Use index to search for an isolated single quote
      my $pos = 1;
      my $end = -1;
      while ($pos = index $rest, "'", $pos) {
	last if $pos == -1; # could not find a close quote

	# Check for the position after this and if it is a '
	# increment and loop again
	if (substr($rest, $pos+1, 1) eq "'") {
	  $pos += 2; # Skip past next one
	  next;
	}

	# Isolated ' so this is the end of the string
	$end = $pos;
	last;

      }

      # At this point we should have the end of the string or the
      # position of the last quote
      if ($end != -1) {

	# Value
	$value = substr($rest,1, $pos-1);

	# Replace '' with '
	$value =~ s/''/'/; #; '

	# Special case a blank string
	if ($value =~ /^\s+$/) {
	  $value = " ";
	} else {
	  # Trim
	  $value =~ s/\s+$//;
	}

	# Comment
	$comment = substr($rest,$pos+1); # Extract post string
	$comment =~ s/^\s+\///;  # Delete everything before the first slash
	$comment =~ s/\///;  # In case there was no space before the slash

      } else {
	# Never found the end so include all of it
	$value = substr($rest,1);
	# Trim
	$value =~ s/\s+$//;

	$comment = '';
      }

    }

  } else {
    # Non string - simply read the first thing before a slash
    my $pos = index($rest, "/");
    if ($pos == 0) {

      # No value at all
      $value  = undef;
      $comment = substr($rest, $pos+2);
      $self->type("UNDEF");

    } elsif ($pos != -1) {
      # Found value and comment
      $value = substr($rest, 0, $pos-1);

      # Check for case where / is last character
      if (length($rest) > ($pos + 1)) {
        $comment = substr($rest, $pos+2);
        $comment =~ s/\s+$//;
      } else {
        $comment = undef;
      }

    } else {
      # Only found a value
      $value = $rest;
      $comment = undef;
    }

    if (defined $value) {

      # Replace D or E with and e - D is not allowed as an exponent in perl
      $value =~ tr/DE/ee/;

      # Need to work out the numeric type
      if ($value eq 'T') {
	$value = 1;
	$self->type('LOGICAL');
      } elsif ($value eq 'F') {
	$value = 0;
	$self->type('LOGICAL');
      } elsif ($value =~ /\.|e/) {
	# float
	$self->type("FLOAT");
      } else {
	$self->type("INT");
      }

      # Remove trailing spaces
      $value =~ s/\s+$//;
    }
  }

  # Tidy up comment
  if (defined $comment) {
    if ($comment =~ /^\s+$/) {
      $comment  = ' ';
    } else {
      # Trim it
      $comment =~ s/\s+$//;
      $comment =~ s/^\s+//;
    }
  }

  # Store in the object
  $self->value( $value );
  $self->comment( $comment );

  # Store the original card
  # Must be done after storing val, comm etc
  $self->card( $card );

  # Value is allowed to be ''
  return($keyword, $value, $comment);

}

sub equals {
  my $self = shift;
  my $ref = shift;

  # Loop over the string keywords
  for my $method (qw/ keyword type comment /) {
    my $val1 = $self->$method;
    my $val2 = $ref->$method;

    if (defined $val1 && defined $val2) {
      # These are all string comparisons
      if ($val1 ne $val2) {
	return 0;
      }
    } elsif (!defined $val1 && !defined $val2) {
      # both undef so equal
    } else {
      # one undef, the other defined
      return 0;
    }
  }

  # value comparison will depend on type
  # we know the types are the same
  my $val1 = $self->value;
  my $val2 = $ref->value;
  my $type = $self->type;

  return 0 if ((defined $val1 && !defined $val2) ||
	       (defined $val2 && !defined $val1));
  return 1 if (!defined $val1 && !defined $val2);

  if ($type eq 'FLOAT' || $type eq 'INT') {
    return ( $val1 == $val2 );
  } elsif ($type eq 'STRING') {
    return ( $val1 eq $val2 );
  } elsif ($type eq 'LOGICAL') {
    if (($val1 && $val2) || (!$val1 && !$val2)) {
      return 1;
    } else {
      return 0;
    }
  } elsif ($type eq 'COMMENT') {
    # if we get to here we have a defined value so we should
    # check it even if COMMENT is meant to use COMMENT
    return ($val1 eq $val2);

  } elsif ($type eq 'HEADER') {
    my @items1 = $val1->allitems;
    my @items2 = $val2->allitems;

    # count the items
    return 0 if @items1 != @items2;

    for my $i (0..$#items1) {
      return 0 if ! $items1[$i]->equals( $items2[$i] );
    }
    return 1;

  } elsif ($type eq 'UNDEF') {
    # both are undef...
    return 1;
  } else {
    croak "Unable to compare items of type '$type'\n";
  }

  # somehow we got to the end
  return 0;
}

sub _stringify {
  my $self = shift;

  # Get the components
  my $keyword = $self->keyword;
  my $value = $self->value;
  my $comment = $self->comment;
  my $type = $self->type;

  # Special case for HEADER type
  if (defined $type && $type eq 'HEADER') {
    $type = "COMMENT";
    $comment = "Contains a subsidiary header";
  }

  # Sort out the keyword. This always uses up the first 8 characters
  my $card = sprintf("%-8s", $keyword);

  # End card and Comments first
  if (defined $type && $type eq 'END' ) {
    $card = sprintf("%-10s%-70s", $card, "");

  } elsif (defined $type && $type eq 'BLANK') {
    $card = " " x 80;
  } elsif (defined $type && $type eq 'COMMENT') {

    # Comments are from character 9 - 80
    $card = sprintf("%-8s%-72s", $card, (defined $comment ? $comment : ''));

  } elsif (!defined $type && !defined $value && !defined $comment) {

    # This is a blank line
    $card = " " x 80;

  } else {
    # A real keyword/value so add the "= "
    $card .= "= ";

    # Try to sort out the type if we havent got one
    # We can not find LOGICAL this way since we can't
    # tell the difference between 'F' and F
    # an undefined value is typeless
    unless (defined $type) {
      $type = $self->guess_type( $value );
    }

    # Numbers behave identically whether they are float or int
    # Logical is a number formatted as a "T" or "F"
    if ($type eq 'INT' or $type eq 'FLOAT' or $type eq 'LOGICAL' or
       $type eq 'UNDEF') {

      # Change the value for logical
      if ($type eq 'LOGICAL') {
	$value = ( ($value && ($value ne 'F')) ? 'T' : 'F' );
      }

      # An undefined value should simply propogate as an empty
      $value = '' unless defined $value;

      # A number can only be up to 67 characters long but
      # Should we raise an error if it is longer? We should
      # not truncate
      $value = substr($value,0,67);

      $value = (' 'x(20-length($value))).$value;

      # Translate lower case e to upper
      # Probably should test length of exponent to decide
      # whether we should be using D instead of E
      # [depends whether the argument is stringified or not]
      $value =~ tr /ed/ED/;

    } elsif ($type eq 'STRING') {

      # Check that a value is there
      # There is a distinction between '''' and nothing ''
      if (defined $value) {

	# Escape single quotes
	$value =~ s/'/''/g;  #';

	# chop to 65 characters
	$value = substr($value,0, 65);

	# if the string has less than 8 characters pad it to put the
	# closing quote at CHAR 20
	if (length($value) < 8 ) {
	   $value = $value.(' 'x(8-length($value))) unless length($value) == 0;
	}
	$value = "'$value'";

      } else {
	$value = ''; # undef is an empty FITS string
      }

      # Pad goes reverse way to a number
      $value = $value.(' 'x(20-length($value)));

    } else {
      carp("Type '$type' is not a recognized type. Header creation may be incorrect");
    }

    # Add the comment
    if (defined $comment && length($comment) > 0) {
      $card .= $value . ' / ' . $comment;
    } else {
      $card .= $value;
    }

    # Fix at 80 characters
    $card = substr($card,0,80);
    $card .= ' 'x(80-length($card));

  }

  # Return the result
  return $card;

}

sub guess_type {
  my $self = shift;
  my $value = shift;
  my $type;
  if (!defined $value) {
    $type = "UNDEF";
  } elsif ($value =~ /^\d+$/) {
    $type = "INT";
  } elsif ($value =~ /^(-?)(\d*)(\.?)(\d*)([EeDd][-\+]?\d+)?$/) {
    $type = "FLOAT";
  } else {
    $type = "STRING";
  }
  return $type;
}

1;