File Coverage

blib/lib/Astro/FITS/Header/Item.pm
Criterion Covered Total %
statement 212 250 84.8
branch 113 152 74.3
condition 53 87 60.9
subroutine 16 18 88.8
pod 12 13 92.3
total 406 520 78.0


line stmt bran cond sub pod time code
1             package Astro::FITS::Header::Item;
2              
3             =head1 NAME
4              
5             Astro::FITS::Header::Item - A card image from a FITS header
6              
7             =head1 SYNOPSIS
8              
9             $item = new Astro::FITS::Header::Item( Card => $card );
10              
11             $item = new Astro::FITS::Header::Item( Keyword => $keyword,
12             Value => $value,
13             Comment => $comment,
14             Type => 'int'
15             );
16              
17             $value = $item->value();
18             $comment = $item->comment();
19              
20             $card = $item->card();
21              
22             $card = "$item";
23              
24              
25             =head1 DESCRIPTION
26              
27             Stores information about a FITS header item (in the FITS standard these
28             are called B). FITS Card Images can be parsed and broken
29             into their component keyword, values and comments. Card Images can also
30             be created from its components keyword, value and comment.
31              
32             =cut
33              
34 11     11   765509 use strict;
  11         27  
  11         583  
35             use overload (
36 11         254 '""' => 'overload_kluge'
37 11     11   1649 );
  11         1048  
38              
39 11     11   1212 use vars qw/ $VERSION /;
  11         35  
  11         662  
40 11     11   72 use Carp;
  11         30  
  11         34703  
41              
42             $VERSION = 3.08;
43              
44             =head1 METHODS
45              
46             =head2 Constructor
47              
48             =over 4
49              
50             =item B
51              
52             Create a new instance. Optionally can be given a hash containing
53             information from a header item or the card image itself.
54              
55             $item = new Astro::FITS::Header::Item( Card => $card );
56              
57             $item = new Astro::FITS::Header::Item( Keyword => $keyword,
58             Value => $value );
59              
60             The list of allowed hash keys is documented in the
61             B method.
62              
63             Returns C if the information supplied was insufficient
64             to generate a valid header item.
65              
66             =cut
67              
68             sub new {
69 1245     1245 1 18443 my $proto = shift;
70 1245   33     3344 my $class = ref($proto) || $proto;
71              
72 1245         4579 my $item = {
73             Keyword => undef,
74             Comment => undef,
75             Value => undef,
76             Type => undef,
77             Card => undef, # a cache
78             };
79              
80 1245         2154 bless $item, $class;
81              
82             # If we have arguments configure the object
83 1245 50       3600 $item->configure( @_ ) if @_;
84              
85 1245         3204 return $item;
86             }
87              
88             =item B
89              
90             Make a copy of an Astro::FITS::Header::Item object.
91              
92             $newitem = $item->copy;
93              
94             =cut
95              
96             sub copy {
97 0     0 1 0 my $self = shift;
98 0         0 my %copy = %$self;
99 0         0 return bless \%copy, ref( $self );
100             }
101              
102             =back
103              
104             =head2 Accessor Methods
105              
106             =over 4
107              
108             =item B
109              
110             Return (or set) the value of the keyword associated with
111             the FITS card.
112              
113             $keyword = $item->keyword();
114             $item->keyword( $key );
115              
116             When a new value is supplied any C in the cache is invalidated.
117              
118             Supplied value is always upper-cased.
119              
120             =cut
121              
122             sub keyword {
123 6585     6585 1 13315 my $self = shift;
124 6585 100       11688 if (@_) {
125 1050         2422 $self->{Keyword} = uc(shift);
126 1050         1591 $self->{Card} = undef;
127             }
128 6585         14434 return $self->{Keyword};
129             }
130              
131             =item B
132              
133             Return (or set) the value of the value associated with
134             the FITS card.
135              
136             $value = $item->value();
137             $item->value( $val );
138              
139             When a new value is supplied any C in the cache is invalidated.
140              
141             If the value is an C object, the type is automatically
142             set to "HEADER".
143              
144             =cut
145              
146             sub value {
147 1954     1954 1 6083 my $self = shift;
148 1954 100       3602 if (@_) {
149 1020         1541 my $value = shift;
150 1020         1711 $self->{Value} = $value;
151 1020         1518 $self->{Card} = undef;
152              
153 1020 100 66     4023 if (UNIVERSAL::isa($value,"Astro::FITS::Header" )) {
    50          
154 5         11 $self->type( "HEADER" );
155             } elsif (defined $self->type && $self->type eq 'HEADER') {
156             # HEADER is only valid if we really are a HEADER
157 0         0 $self->type(undef);
158             }
159              
160             }
161 1954         4340 return $self->{Value};
162             }
163              
164             =item B
165              
166             Return (or set) the value of the comment associated with
167             the FITS card.
168              
169             $comment = $item->comment();
170             $item->comment( $comment );
171              
172             When a new value is supplied any C in the cache is invalidated.
173              
174             =cut
175              
176             sub comment {
177 1655     1655 1 7966 my $self = shift;
178 1655 100       2986 if (@_) {
179 1024         1631 $self->{Comment} = shift;
180 1024         1516 $self->{Card} = undef;
181             }
182 1655         2705 return $self->{Comment};
183             }
184              
185              
186             =item B
187              
188             Return (or set) the value of the variable type associated with
189             the FITS card.
190              
191             $type = $item->type();
192             $item->type( "INT" );
193              
194             Allowed types are "LOGICAL", "INT", "FLOAT", "STRING", "COMMENT",
195             "HEADER" and "UNDEF".
196              
197             The special type, "HEADER", is used to specify that this item refers to
198             a subsidiary header (eg a header in an MEFITS file or a header in an
199             NDF in an HDS container). See also the C method in
200             C for an alternative way of specifying a
201             sub-header.
202              
203             The type is case-insensitive, but will always be returned up-cased.
204              
205             =cut
206              
207             sub type {
208 4497     4497 1 10920 my $self = shift;
209 4497 100       7862 if (@_) {
210 1069         1566 my $type = shift;
211 1069 100       2256 $type = uc($type) if defined $type;
212 1069         2176 $self->{Type} = $type;
213             }
214 4497         10763 return $self->{Type};
215             }
216              
217              
218             =item B
219              
220             Return (or set) the 80 character header card associated with this
221             object. It is created if there is no cached version.
222              
223             $card = $item->card();
224              
225             If a new card is supplied it will only be accepted if it is 80
226             characters long or fewer. The string is padded with spaces if it is too
227             short. No attempt (yet) )is made to shorten the string if it is too
228             long since that may require a check to see if the value is a string
229             that must be shortened with a closing single quote. Returns C
230             on assignment failure (else returns the supplied string).
231              
232             $status = $item->card( $card );
233              
234             C is returned if there is insufficient information in the object
235             to create a new card. Can assign C to clear the cache.
236              
237             This method is called automatically when attempting to stringify
238             the object.
239              
240             $card = "$item";
241              
242             =cut
243              
244             # This is required because overloaded methods are called with
245             # extra arguments and card() can not tell the difference between
246             # an undef value and a stringify request
247             sub overload_kluge {
248 682     682 0 8349 my $self = shift;
249 682         1339 return $self->card;
250             }
251              
252             sub card {
253 1821     1821 1 2782 my $self = shift;
254 1821 100       3369 if (@_) {
255 1108         1547 my $card = shift;
256 1108 100       1937 if (defined $card) {
257 985         1316 my $clen = length($card);
258             # force to 80 characters
259 985 100       2081 if ($clen < 80) {
    50          
260 188         570 $card = $card . (" "x(80-$clen));
261             } elsif ($clen > 80) {
262 0         0 $card = substr($card, 0, 80);
263             }
264             }
265             # can assign undef to clear
266 1108         1941 $self->{Card} = $card;
267             }
268             # We are returning a value. Create if not present
269             # Since we are being called by stringify to set the object
270             # we need to make sure we don't get into an endless loop
271             # trying to create the string but not having the correct info
272             # Especially important since stringify calls card().
273 1821 100       3793 $self->{Card} = $self->_stringify unless defined $self->{Card};
274 1821         4082 return $self->{Card};
275             }
276              
277             =back
278              
279             =head2 General Methods
280              
281             =over 4
282              
283              
284             =item B
285              
286             Configures the object from multiple pieces of information.
287              
288             $item->configure( %options );
289              
290             Takes a hash as argument with the following keywords:
291              
292             =over 8
293              
294             =item B
295              
296             If supplied, the value is assumed to be a standard 80 character
297             FITS header card. This is sent to the C method directly.
298             Takes priority over any other key.
299              
300             If it is an C it will be copied rather
301             than parsed.
302              
303             =item B
304              
305             Used to specify the keyword associated with this object.
306              
307             =item B
308              
309             Used to specify the value associated with this FITS item.
310              
311             =item B
312              
313             Used to specify the comment associated with this FITS item.
314              
315             =item B
316              
317             Used to specify the variable type. See the C method
318             for more details. A type will be guessed if one is not supplied.
319             The guess may well be wrong.
320              
321             =back
322              
323             Does nothing if these keys are not supplied.
324              
325             =cut
326              
327             sub configure {
328 1245     1245 1 1769 my $self = shift;
329 1245         2715 my %hash = @_;
330              
331 1245 100       2319 if (exists $hash{'Card'}) {
332 1192 100 66     2898 if (ref($hash{Card}) && $hash{Card}->isa("Astro::FITS::Header::Item")) {
333             # low level populate - can not use copy since we already have a copy
334 207         301 for my $k (keys %{$hash{Card}}) {
  207         640  
335 1035         1849 $self->{$k} = $hash{Card}->{$k};
336             }
337             } else {
338 985         1915 $self->parse_card( $hash{'Card'});
339             }
340             } else {
341             # Loop over the allowed keys storing the values
342             # in the object if they exist
343 53         127 for my $key (qw/Keyword Type Comment Value/) {
344 212         346 my $method = lc($key);
345 212 100       644 $self->$method( $hash{$key}) if exists $hash{$key};
346             }
347              
348             # only set type if we have not been given a type
349 53 100       126 if (!$self->type) {
350 20 50 33     43 if (!$self->keyword && !$self->value) {
    100 66        
351             # completely blank
352 0         0 $self->type("BLANK");
353             } elsif (!$self->keyword || $self->keyword =~ /^(COMMENT|HISTORY)$/) {
354             # COMMENT, HISTORY, and blank cards are special
355 2         5 $self->type('COMMENT')
356             } else {
357 18         46 my $type = $self->guess_type( $self->value );
358 18 50       64 $self->type( $type ) if defined $type;
359             }
360             }
361              
362             # End cards are special, need only do a Keyword => 'END' to configure
363 53 100       125 $self->type('END') if $self->keyword() eq 'END';
364             }
365             }
366              
367             =item B
368              
369             Method to return a blessed reference to the object so that we can store
370             ths object on disk using Data::Dumper module.
371              
372             =cut
373              
374             sub freeze {
375 0     0 1 0 my $self = shift;
376 0         0 return bless $self, 'Astro::FITS::Header::Item';
377             }
378              
379             =item B
380              
381             Parse a FITS card image and store the keyword, value and comment
382             into the object.
383              
384             ($key, $val, $com) = $item->parse_card( $card );
385              
386             Returns an empty list on error.
387              
388             =cut
389              
390             # Fits standard specifies
391             # Characters 1:8 KEYWORD (trailing spaces) Comment cards: COMMENT,
392             # HISTORY, blank, and HIERARCH are special.
393             # 9:10 "= " for a valid value (unless comment keyword)
394             # 11:80 The Value "/" used to indicate a comment
395              
396             # HIERARCH keywords
397             # This is a comment but used to store values in an extended,
398             # hierarchical name space. The keyword is the string before
399             # the equals sign and ignoring trailing spaces. The value
400             # follows the first equals sign. The comment is delimited by a
401             # solidus following a string or a single value. The HIERARCH
402             # keyword may follow a blank keyword in columns 1:8..
403             #
404             # The value can contain:
405             # STRINGS:
406             # ' starting at position 12
407             # A single quote represented as ''
408             # Closing quote must be at position 20 or greater (max 80)
409             # Trailing blanks are removed. Leading spaces in the quotes
410             # are significant
411             # LOGICAL
412             # T or F in column 30. Translated to 1 or 0
413             # Numbers
414             # D is an allowed exponent as well as E
415              
416             sub parse_card {
417 985     985 1 1383 my $self = shift;
418 985 50       1762 return () unless @_;
419              
420 985         1435 my $card = shift;
421 985         1506 my $equals_col = 8;
422              
423             # Remove new line and pad card to 80 characters
424 985         1568 chomp($card);
425             # $card = sprintf("%-80s", $card);
426              
427             # Value is only present if an = is found in position 9
428 985         1623 my ($value, $comment) = ('', '');
429 985         1998 my $keyword = uc(substr($card, 0, $equals_col));
430              
431             # HIERARCH special case. It's a comment, but want to treat it as
432             # a multi-word keyword followed by a value and/or comment.
433 985 100 66     3204 if ( $keyword eq 'HIERARCH' || $card =~ /^\s+HIERARCH/ ) {
434 328         543 $equals_col = index( $card, "=" );
435 328         785 $keyword = uc(substr($card, 0, $equals_col ));
436             }
437             # Remove leading and trailing spaces, and replace interior spaces
438             # between the keywords with a single .
439 985 50       2418 $keyword =~ s/^\s+// if ( $card =~ /^\s+HIERARCH/ );
440 985         3721 $keyword =~ s/\s+$//;
441 985         2777 $keyword =~ s/\s+/./g;
442              
443             # update object
444 985         2368 $self->keyword( $keyword );
445              
446             # END cards are special
447 985 100       1920 if ($keyword eq 'END') {
448 6         20 $self->comment(undef);
449 6         19 $self->value(undef);
450 6         22 $self->type( "END" );
451 6         17 $self->card( $card ); # store it after storing indiv components
452 6         18 return("END", undef, undef);
453             }
454              
455             # This will be a blank line but will not trigger here if we
456             # are padding to 80 characters
457 979 50       1826 if (length($card) == 0) {
458 0         0 $self->type( "BLANK" );
459 0         0 return( undef, undef, undef);
460             }
461              
462             # Check for comment or HISTORY
463             # If the card is not padded this may trigger a warning on the
464             # substr going out of bounds
465 979 100 100     4977 if ($keyword eq 'COMMENT' || $keyword eq 'HISTORY' ||
      100        
      100        
466             (substr($card,8,2) ne "= " && $keyword !~ /^HIERARCH/)) {
467              
468             # Store the type
469 30         94 $self->type( "COMMENT" );
470              
471             # We have comments
472 30 50       82 unless ( length( $card) <= 8 ) {
473 30         100 $comment = substr($card,8);
474 30         191 $comment =~ s/\s+$//; # Trailing spaces
475             } else {
476 0         0 $comment = "";
477             }
478              
479             # Alasdair wanted to store this as a value
480 30         91 $self->comment( $comment );
481              
482 30         82 $self->card( $card ); # store it after storing indiv components
483 30         84 return ($keyword, undef, $comment);
484             }
485              
486             # We must have a value after '= '
487 949         2053 my $rest = substr($card, $equals_col+1);
488              
489             # Remove leading spaces
490 949         2937 $rest =~ s/^\s+//;
491              
492             # Check to see if we have a string
493 949 100       2109 if (substr($rest,0,1) eq "'") {
494              
495 249         621 $self->type( "STRING" );
496              
497             # Check for empty (null) string ''
498 249 100       463 if (substr($rest,1,1) eq "'") {
499 1         3 $value = '';
500 1         3 $comment = substr($rest,2);
501 1         6 $comment =~ s/^\s+\///; # Delete everything before the first slash
502              
503             } else {
504             # '' needs to be treated as an escaped ' when inside the string
505             # Use index to search for an isolated single quote
506 248         352 my $pos = 1;
507 248         346 my $end = -1;
508 248         624 while ($pos = index $rest, "'", $pos) {
509 249 50       450 last if $pos == -1; # could not find a close quote
510              
511             # Check for the position after this and if it is a '
512             # increment and loop again
513 249 100       550 if (substr($rest, $pos+1, 1) eq "'") {
514 1         2 $pos += 2; # Skip past next one
515 1         3 next;
516             }
517              
518             # Isolated ' so this is the end of the string
519 248         334 $end = $pos;
520 248         360 last;
521              
522             }
523              
524             # At this point we should have the end of the string or the
525             # position of the last quote
526 248 50       460 if ($end != -1) {
527              
528             # Value
529 248         473 $value = substr($rest,1, $pos-1);
530              
531             # Replace '' with '
532 248         495 $value =~ s/''/'/; #; '
533              
534             # Special case a blank string
535 248 100       666 if ($value =~ /^\s+$/) {
536 2         5 $value = " ";
537             } else {
538             # Trim
539 246         677 $value =~ s/\s+$//;
540             }
541              
542             # Comment
543 248         540 $comment = substr($rest,$pos+1); # Extract post string
544 248         828 $comment =~ s/^\s+\///; # Delete everything before the first slash
545 248         525 $comment =~ s/\///; # In case there was no space before the slash
546              
547             } else {
548             # Never found the end so include all of it
549 0         0 $value = substr($rest,1);
550             # Trim
551 0         0 $value =~ s/\s+$//;
552              
553 0         0 $comment = '';
554             }
555              
556             }
557              
558             } else {
559             # Non string - simply read the first thing before a slash
560 700         1202 my $pos = index($rest, "/");
561 700 100       1442 if ($pos == 0) {
    100          
562              
563             # No value at all
564 3         6 $value = undef;
565 3         9 $comment = substr($rest, $pos+2);
566 3         9 $self->type("UNDEF");
567              
568             } elsif ($pos != -1) {
569             # Found value and comment
570 693         1205 $value = substr($rest, 0, $pos);
571 693         1994 $value =~ s/\s+$//; # remove any gap to the comment
572              
573             # Check for case where / is last character
574 693 50       1544 if (length($rest) > ($pos + 1)) {
575 693         1292 $comment = substr($rest, $pos+2);
576 693         2317 $comment =~ s/\s+$//;
577             } else {
578 0         0 $comment = undef;
579             }
580              
581             } else {
582             # Only found a value
583 4         10 $value = $rest;
584 4         18 $comment = undef;
585             }
586              
587 700 100       1494 if (defined $value) {
588              
589             # Replace D or E with and e - D is not allowed as an exponent in perl
590 697         1145 $value =~ tr/DE/ee/;
591              
592             # Need to work out the numeric type
593 697 100       2740 if ($value eq 'T') {
    100          
    100          
594 18         77 $value = 1;
595 18         54 $self->type('LOGICAL');
596             } elsif ($value eq 'F') {
597 15         63 $value = 0;
598 15         148 $self->type('LOGICAL');
599             } elsif ($value =~ /\.|e/) {
600             # float
601 334         774 $self->type("FLOAT");
602             } else {
603 330         751 $self->type("INT");
604             }
605              
606             # Remove trailing spaces
607 697         1353 $value =~ s/\s+$//;
608             }
609             }
610              
611             # Tidy up comment
612 949 100       1747 if (defined $comment) {
613 945 50       2187 if ($comment =~ /^\s+$/) {
614 0         0 $comment = ' ';
615             } else {
616             # Trim it
617 945         2318 $comment =~ s/\s+$//;
618 945         1710 $comment =~ s/^\s+//;
619             }
620             }
621              
622             # Store in the object
623 949         2333 $self->value( $value );
624 949         2062 $self->comment( $comment );
625              
626             # Store the original card
627             # Must be done after storing val, comm etc
628 949         2052 $self->card( $card );
629              
630             # Value is allowed to be ''
631 949         2087 return($keyword, $value, $comment);
632              
633             }
634              
635             =item B
636              
637             Compares this Item with another and returns true if the keyword,
638             value, type and comment are all equal.
639              
640             $isident = $item->equals( $item2 );
641              
642             =cut
643              
644             sub equals {
645 221     221 1 325 my $self = shift;
646 221         308 my $ref = shift;
647              
648             # Loop over the string keywords
649 221         355 for my $method (qw/ keyword type comment /) {
650 663         1208 my $val1 = $self->$method;
651 663         1231 my $val2 = $ref->$method;
652              
653 663 100 66     1840 if (defined $val1 && defined $val2) {
    50 33        
654             # These are all string comparisons
655 661 50       1368 if ($val1 ne $val2) {
656 0         0 return 0;
657             }
658             } elsif (!defined $val1 && !defined $val2) {
659             # both undef so equal
660             } else {
661             # one undef, the other defined
662 0         0 return 0;
663             }
664             }
665              
666             # value comparison will depend on type
667             # we know the types are the same
668 221         380 my $val1 = $self->value;
669 221         386 my $val2 = $ref->value;
670 221         364 my $type = $self->type;
671              
672 221 50 66     1014 return 0 if ((defined $val1 && !defined $val2) ||
      66        
      33        
673             (defined $val2 && !defined $val1));
674 221 50 66     495 return 1 if (!defined $val1 && !defined $val2);
675              
676 195 100 100     535 if ($type eq 'FLOAT' || $type eq 'INT') {
    100          
    50          
    0          
    0          
    0          
677 174         608 return ( $val1 == $val2 );
678             } elsif ($type eq 'STRING') {
679 14         64 return ( $val1 eq $val2 );
680             } elsif ($type eq 'LOGICAL') {
681 7 50 33     32 if (($val1 && $val2) || (!$val1 && !$val2)) {
      0        
      33        
682 7         24 return 1;
683             } else {
684 0         0 return 0;
685             }
686             } elsif ($type eq 'COMMENT') {
687             # if we get to here we have a defined value so we should
688             # check it even if COMMENT is meant to use COMMENT
689 0         0 return ($val1 eq $val2);
690              
691             } elsif ($type eq 'HEADER') {
692 0         0 my @items1 = $val1->allitems;
693 0         0 my @items2 = $val2->allitems;
694              
695             # count the items
696 0 0       0 return 0 if @items1 != @items2;
697              
698 0         0 for my $i (0..$#items1) {
699 0 0       0 return 0 if ! $items1[$i]->equals( $items2[$i] );
700             }
701 0         0 return 1;
702              
703             } elsif ($type eq 'UNDEF') {
704             # both are undef...
705 0         0 return 1;
706             } else {
707 0         0 croak "Unable to compare items of type '$type'\n";
708             }
709              
710             # somehow we got to the end
711 0         0 return 0;
712             }
713              
714              
715             =begin __private
716              
717             =item B<_stringify>
718              
719             Internal routine to generate a FITS header card using the contents of
720             the object. This rouinte should not be called directly. Use the
721             C method to retrieve the contents.
722              
723             $card = $item->_stringify;
724              
725             The object state is not updated by this routine.
726              
727             This routine is only called if the card cache has been cleared.
728              
729             If this item points to a sub-header the stringification returns
730             a comment indicating that we have a sub header. In the future
731             this behaviour may change (either to return nothing, or
732             to return the stringified header itself).
733              
734             =cut
735              
736             sub _stringify {
737 152     152   227 my $self = shift;
738              
739             # Get the components
740 152         317 my $keyword = $self->keyword;
741 152         314 my $value = $self->value;
742 152         306 my $comment = $self->comment;
743 152         298 my $type = $self->type;
744              
745             # Special case for HEADER type
746 152 50 33     593 if (defined $type && $type eq 'HEADER') {
747 0         0 $type = "COMMENT";
748 0         0 $comment = "Contains a subsidiary header";
749             }
750              
751             # Sort out the keyword. This always uses up the first 8 characters
752 152         581 my $card = sprintf("%-8s", $keyword);
753              
754             # End card and Comments first
755 152 100 66     1195 if (defined $type && $type eq 'END' ) {
    50 33        
    100 66        
    50 0        
756 3         14 $card = sprintf("%-10s%-70s", $card, "");
757              
758             } elsif (defined $type && $type eq 'BLANK') {
759 0         0 $card = " " x 80;
760             } elsif (defined $type && $type eq 'COMMENT') {
761              
762             # Comments are from character 9 - 80
763 10 50       43 $card = sprintf("%-8s%-72s", $card, (defined $comment ? $comment : ''));
764              
765             } elsif (!defined $type && !defined $value && !defined $comment) {
766              
767             # This is a blank line
768 0         0 $card = " " x 80;
769              
770             } else {
771             # A real keyword/value so add the "= "
772 139         343 $card .= "= ";
773              
774             # Try to sort out the type if we havent got one
775             # We can not find LOGICAL this way since we can't
776             # tell the difference between 'F' and F
777             # an undefined value is typeless
778 139 50       279 unless (defined $type) {
779 0         0 $type = $self->guess_type( $value );
780             }
781              
782             # Numbers behave identically whether they are float or int
783             # Logical is a number formatted as a "T" or "F"
784 139 100 100     602 if ($type eq 'INT' or $type eq 'FLOAT' or $type eq 'LOGICAL' or
    50 100        
      100        
785             $type eq 'UNDEF') {
786              
787             # Change the value for logical
788 106 100       249 if ($type eq 'LOGICAL') {
789 7 100 66     43 $value = ( ($value && ($value ne 'F')) ? 'T' : 'F' );
790             }
791              
792             # An undefined value should simply propogate as an empty
793 106 100       195 $value = '' unless defined $value;
794              
795             # A number can only be up to 67 characters long but
796             # Should we raise an error if it is longer? We should
797             # not truncate
798 106         246 $value = substr($value,0,67);
799              
800 106         295 $value = (' 'x(20-length($value))).$value;
801              
802             # Translate lower case e to upper
803             # Probably should test length of exponent to decide
804             # whether we should be using D instead of E
805             # [depends whether the argument is stringified or not]
806 106         265 $value =~ tr /ed/ED/;
807              
808             } elsif ($type eq 'STRING') {
809              
810             # Check that a value is there
811             # There is a distinction between '''' and nothing ''
812 33 50       73 if (defined $value) {
813              
814             # Escape single quotes
815 33         95 $value =~ s/'/''/g; #';
816              
817             # chop to 65 characters
818 33         76 $value = substr($value,0, 65);
819              
820             # if the string has less than 8 characters pad it to put the
821             # closing quote at CHAR 20
822 33 100       87 if (length($value) < 8 ) {
823 20 100       111 $value = $value.(' 'x(8-length($value))) unless length($value) == 0;
824             }
825 33         79 $value = "'$value'";
826              
827             } else {
828 0         0 $value = ''; # undef is an empty FITS string
829             }
830              
831             # Pad goes reverse way to a number
832 33         169 $value = $value.(' 'x(20-length($value)));
833              
834             } else {
835 0         0 carp("Type '$type' is not a recognized type. Header creation may be incorrect");
836             }
837              
838             # Add the comment
839 139 100 66     506 if (defined $comment && length($comment) > 0) {
840 138         330 $card .= $value . ' / ' . $comment;
841             } else {
842 1         3 $card .= $value;
843             }
844              
845             # Fix at 80 characters
846 139         258 $card = substr($card,0,80);
847 139         301 $card .= ' 'x(80-length($card));
848              
849             }
850              
851             # Return the result
852 152         351 return $card;
853              
854             }
855              
856             =item B
857              
858             This class method can be used to guess the data type of a supplied value.
859             It is private but can be used by other classes in the Astro::FITS::Header
860             hierarchy.
861              
862             $type = Astro::FITS::Header::Item->guess_type( $value );
863              
864             Can not distinguish a string F from a LOGICAL F so will always guess
865             "string". Returns "string" if a type could not be determined.
866              
867             =cut
868              
869             sub guess_type {
870 18     18 1 35 my $self = shift;
871 18         30 my $value = shift;
872 18         27 my $type;
873 18 100       78 if (!defined $value) {
    50          
    0          
874 15         29 $type = "UNDEF";
875             } elsif ($value =~ /^\d+$/) {
876 3         6 $type = "INT";
877             } elsif ($value =~ /^(-?)(\d*)(\.?)(\d*)([EeDd][-\+]?\d+)?$/) {
878 0         0 $type = "FLOAT";
879             } else {
880 0         0 $type = "STRING";
881             }
882 18         44 return $type;
883             }
884              
885             =end __private
886              
887             =back
888              
889             =head1 SEE ALSO
890              
891             C
892              
893             =head1 COPYRIGHT
894              
895             Copyright (C) 2008-2009 Science and Technology Facilities Council.
896             Copyright (C) 2001-2007 Particle Physics and Astronomy Research Council.
897             All Rights Reserved.
898              
899             This program is free software; you can redistribute it and/or modify it under
900             the terms of the GNU General Public License as published by the Free Software
901             Foundation; either version 3 of the License, or (at your option) any later
902             version.
903              
904             This program is distributed in the hope that it will be useful,but WITHOUT ANY
905             WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A
906             PARTICULAR PURPOSE. See the GNU General Public License for more details.
907              
908             You should have received a copy of the GNU General Public License along with
909             this program; if not, write to the Free Software Foundation, Inc., 59 Temple
910             Place,Suite 330, Boston, MA 02111-1307, USA
911              
912             =head1 AUTHORS
913              
914             Tim Jenness Et.jenness@jach.hawaii.eduE,
915             Alasdair Allan Eaa@astro.ex.ac.ukE
916              
917             =cut
918              
919             1;