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


line stmt bran cond sub pod time code
1             #------------------------------------------------------------------------------
2             # File: FITS.pm
3             #
4             # Description: Read Flexible Image Transport System metadata
5             #
6             # Revisions: 2018/03/07 - P. Harvey Created
7             #
8             # References: 1) https://fits.gsfc.nasa.gov/fits_standard.html
9             #------------------------------------------------------------------------------
10              
11             package Image::ExifTool::FITS;
12              
13 1     1   4571 use strict;
  1         2  
  1         36  
14 1     1   5 use vars qw($VERSION);
  1         2  
  1         39  
15 1     1   5 use Image::ExifTool qw(:DataAccess :Utils);
  1         2  
  1         1072  
16              
17             $VERSION = '1.02';
18              
19             # FITS tags (ref 1)
20             %Image::ExifTool::FITS::Main = (
21             GROUPS => { 2 => 'Image' },
22             NOTES => q{
23             This table lists some standard Flexible Image Transport System (FITS) tags,
24             but ExifTool will extract any other tags found. See
25             L for the specification.
26             },
27             TELESCOP => 'Telescope',
28             BACKGRND => 'Background',
29             INSTRUME => 'Instrument',
30             OBJECT => 'Object',
31             OBSERVER => 'Observer',
32             DATE => { Name => 'CreateDate', Groups => { 2 => 'Time' } },
33             AUTHOR => { Name => 'Author', Groups => { 2 => 'Author' } },
34             REFERENC => 'Reference',
35             'DATE-OBS'=> { Name => 'ObservationDate', Groups => { 2 => 'Time' } },
36             'TIME-OBS'=> { Name => 'ObservationTime', Groups => { 2 => 'Time' } },
37             'DATE-END'=> { Name => 'ObservationDateEnd', Groups => { 2 => 'Time' } },
38             'TIME-END'=> { Name => 'ObservationTimeEnd', Groups => { 2 => 'Time' } },
39             COMMENT => { Name => 'Comment', PrintConv => '$val =~ s/^ +//; $val',
40             Notes => 'leading spaces are removed if L is enabled' },
41             HISTORY => { Name => 'History', PrintConv => '$val =~ s/^ +//; $val',
42             Notes => 'leading spaces are removed if L is enabled' },
43             );
44              
45             #------------------------------------------------------------------------------
46             # Read information in a FITS document
47             # Inputs: 0) ExifTool ref, 1) dirInfo ref
48             # Returns: 1 on success, 0 if this wasn't a valid FITS file
49             sub ProcessFITS($$)
50             {
51 1     1 0 4 my ($et, $dirInfo) = @_;
52 1         3 my $raf = $$dirInfo{RAF};
53 1         2 my ($buff, $tag, $continue);
54              
55 1 50 33     4 return 0 unless $raf->Read($buff, 80) == 80 and $buff =~ /^SIMPLE = {20}T/;
56 1         7 $et->SetFileType();
57 1         4 my $tagTablePtr = GetTagTable('Image::ExifTool::FITS::Main');
58              
59 1         3 for (;;) {
60 37 50       103 $raf->Read($buff, 80) == 80 or $et->Warn('Truncated FITS header'), last;
61 37         87 my $key = substr($buff, 0, 8);
62 37         127 $key =~ s/ +$//; # remove trailing space from key
63 37 50       67 if ($key eq 'CONTINUE') {
64 0 0       0 defined $continue or $et->WarnOnce('Unexpected FITS CONTINUE keyword'), next;
65             } else {
66 37 50       70 if (defined $continue) {
67             # the previous value wasn't continued, so store with the trailing '&'
68 0         0 $et->HandleTag($tagTablePtr, $tag, $continue . '&');
69 0         0 undef $continue;
70             }
71 37 100       83 last if $key eq 'END';
72             # make sure the key is valid
73 36 50       111 $key =~ /^[-_A-Z0-9]*$/ or $et->Warn('Format error in FITS header'), last;
74 36 100 66     119 if ($key eq 'COMMENT' or $key eq 'HISTORY') {
75 6         13 my $val = substr($buff, 8); # comments start in column 9
76 6         25 $val =~ s/ +$//; # remove trailing spaces
77 6         20 $et->HandleTag($tagTablePtr, $key, $val);
78 6         10 next;
79             }
80             # ignore other lines that aren't tags
81 30 50       65 next unless substr($buff,8,2) eq '= ';
82             # save tag name (avoiding potential conflict with ExifTool variables)
83 30 50       64 $tag = $Image::ExifTool::specialTags{$key} ? "_$key" : $key;
84             # add to tag table if necessary
85 30 100       63 unless ($$tagTablePtr{$tag}) {
86 23         52 my $name = ucfirst lc $tag; # make tag name lower case with leading capital
87 23         80 $name =~ s/_(.)/\U$1/g; # remove all '_' and capitalize subsequent letter
88 23         97 AddTagToTable($tagTablePtr, $tag, { Name => $name });
89             }
90             }
91 30         60 my $val = substr($buff, 10);
92             # parse quoted values
93 30 100       105 if ($val =~ /^'(.*?)'(.*)/) {
    50          
94 18         58 ($val, $buff) = ($1, $2);
95 18         47 while ($buff =~ /^('.*?)'(.*)/) { # handle escaped quotes
96 0         0 $val .= $1;
97 0         0 $buff = $2;
98             }
99 18         38 $val =~ s/ +$//; # remove trailing spaces
100 18 50       35 if (defined $continue) {
101 0         0 $val = $continue . $val;
102 0         0 undef $continue;
103             }
104             # check for possible continuation, removing trailing '&'
105 18 50       35 $val =~ s/\&$// and $continue = $val, next;
106             } elsif (defined $continue) {
107 0         0 $et->WarnOnce('Invalid FITS CONTINUE value');
108 0         0 next;
109             } else {
110 12         225 $val =~ s/ *(\/.*)?$//; # remove trailing spaces and comment
111 12 50       30 next unless length $val; # ignore undefined values
112 12         33 $val =~ s/^ +//; # remove leading spaces
113             # re-format floating-point values to use 'e'
114 12 100       59 $val =~ tr/DE/e/ if $val =~ /^[+-]?(?=\d|\.\d)\d*(\.\d*)?([ED]([+-]?\d+))?$/;
115             }
116 30         89 $et->HandleTag($tagTablePtr, $tag, $val);
117             }
118 1         6 return 1;
119             }
120              
121             1; # end
122              
123             __END__