File Coverage

blib/lib/Image/ExifTool/FITS.pm

Criterion	Covered	Total	%
statement	47	56	83.9
branch	21	34	61.7
condition	3	6	50.0
subroutine	4	4	100.0
pod	0	1	0.0
total	75	101	74.2

#------------------------------------------------------------------------------
# File:         FITS.pm
#
# Description:  Read Flexible Image Transport System metadata
#
# Revisions:    2018/03/07 - P. Harvey Created
#
# References:   1) https://fits.gsfc.nasa.gov/fits_standard.html
#------------------------------------------------------------------------------

package Image::ExifTool::FITS;

use strict;
use vars qw($VERSION);
use Image::ExifTool qw(:DataAccess :Utils);

$VERSION = '1.02';

# FITS tags (ref 1)
%Image::ExifTool::FITS::Main = (
    GROUPS => { 2 => 'Image' },
    NOTES => q{
        This table lists some standard Flexible Image Transport System (FITS) tags,
        but ExifTool will extract any other tags found.  See
        L for the specification.
    },
    TELESCOP => 'Telescope',
    BACKGRND => 'Background',
    INSTRUME => 'Instrument',
    OBJECT   => 'Object',
    OBSERVER => 'Observer',
    DATE     => { Name => 'CreateDate', Groups => { 2 => 'Time' } },
    AUTHOR   => { Name => 'Author',     Groups => { 2 => 'Author' } },
    REFERENC => 'Reference',
   'DATE-OBS'=> { Name => 'ObservationDate',    Groups => { 2 => 'Time' } },
   'TIME-OBS'=> { Name => 'ObservationTime',    Groups => { 2 => 'Time' } },
   'DATE-END'=> { Name => 'ObservationDateEnd', Groups => { 2 => 'Time' } },
   'TIME-END'=> { Name => 'ObservationTimeEnd', Groups => { 2 => 'Time' } },
    COMMENT  => { Name => 'Comment', PrintConv => '$val =~ s/^ +//; $val',
                  Notes => 'leading spaces are removed if L is enabled' },
    HISTORY  => { Name => 'History', PrintConv => '$val =~ s/^ +//; $val',
                  Notes => 'leading spaces are removed if L is enabled' },
);

#------------------------------------------------------------------------------
# Read information in a FITS document
# Inputs: 0) ExifTool ref, 1) dirInfo ref
# Returns: 1 on success, 0 if this wasn't a valid FITS file
sub ProcessFITS($$)
{
    my ($et, $dirInfo) = @_;
    my $raf = $$dirInfo{RAF};
    my ($buff, $tag, $continue);

    return 0 unless $raf->Read($buff, 80) == 80 and $buff =~ /^SIMPLE  = {20}T/;
    $et->SetFileType();
    my $tagTablePtr = GetTagTable('Image::ExifTool::FITS::Main');

    for (;;) {
        $raf->Read($buff, 80) == 80 or $et->Warn('Truncated FITS header'), last;
        my $key = substr($buff, 0, 8);
        $key =~ s/ +$//;    # remove trailing space from key
        if ($key eq 'CONTINUE') {
            defined $continue or $et->WarnOnce('Unexpected FITS CONTINUE keyword'), next;
        } else {
            if (defined $continue) {
                # the previous value wasn't continued, so store with the trailing '&'
                $et->HandleTag($tagTablePtr, $tag, $continue . '&');
                undef $continue;
            }
            last if $key eq 'END';
            # make sure the key is valid
            $key =~ /^[-_A-Z0-9]*$/ or $et->Warn('Format error in FITS header'), last;
            if ($key eq 'COMMENT' or $key eq 'HISTORY') {
                my $val = substr($buff, 8); # comments start in column 9
                $val =~ s/ +$//;            # remove trailing spaces
                $et->HandleTag($tagTablePtr, $key, $val);
                next;
            }
            # ignore other lines that aren't tags
            next unless substr($buff,8,2) eq '= ';
            # save tag name (avoiding potential conflict with ExifTool variables)
            $tag = $Image::ExifTool::specialTags{$key} ? "_$key" : $key;
            # add to tag table if necessary
            unless ($$tagTablePtr{$tag}) {
                my $name = ucfirst lc $tag; # make tag name lower case with leading capital
                $name =~ s/_(.)/\U$1/g;     # remove all '_' and capitalize subsequent letter
                AddTagToTable($tagTablePtr, $tag, { Name => $name });
            }
        }
        my $val = substr($buff, 10);
        # parse quoted values
        if ($val =~ /^'(.*?)'(.*)/) {
            ($val, $buff) = ($1, $2);
            while ($buff =~ /^('.*?)'(.*)/) {   # handle escaped quotes
                $val .= $1;
                $buff = $2;
            }
            $val =~ s/ +$//;            # remove trailing spaces
            if (defined $continue) {
                $val = $continue . $val;
                undef $continue;
            }
            # check for possible continuation, removing trailing '&'
            $val =~ s/\&$// and $continue = $val, next;
        } elsif (defined $continue) {
            $et->WarnOnce('Invalid FITS CONTINUE value');
            next;
        } else {
            $val =~ s/ *(\/.*)?$//;     # remove trailing spaces and comment
            next unless length $val;    # ignore undefined values
            $val =~ s/^ +//;            # remove leading spaces
            # re-format floating-point values to use 'e'
            $val =~ tr/DE/e/ if $val =~ /^[+-]?(?=\d|\.\d)\d*(\.\d*)?([ED]([+-]?\d+))?$/;
        }
        $et->HandleTag($tagTablePtr, $tag, $val);
    }
    return 1;
}

1;  # end

__END__