make wfits handle multi HISTORY

PDLPorters · Aug 22, 2024 · 5ab5a9f · 5ab5a9f
1 parent af35165
commit 5ab5a9f
Show file tree

Hide file tree

Showing 3 changed files with 19 additions and 14 deletions.
diff --git a/Changes b/Changes
@@ -10,6 +10,7 @@
 - add demo of GSL::RNG
 - fix MatrixOps::eigens for asymmetric case inc complex eigenvectors
 - fix GSL problem on Windows (#493) - thanks @shawnlaffan for report
+- wfits fixed to handle multi HISTORY (#488, #489) - thanks @d-lamb for report
 
 2.089_02 2024-06-26
 - PDL::VectorValued::vcos into Primitive - thanks @moocow-the-bovine

diff --git a/IO/FITS/FITS.pm b/IO/FITS/FITS.pm
@@ -1619,8 +1619,9 @@ sub wheader {
     my ($fh, $k, $hdr, $nbytes) = @_;
     if ($k =~ m/(HISTORY|COMMENT)/) {
 	my $hc = $1;
-	return $nbytes unless ref($hdr->{$k}) eq 'ARRAY';
-	foreach my $line (@{$hdr->{$k}}) {
+	return $nbytes unless exists $hdr->{$k};
+	my @vals = ref($hdr->{$k}) eq 'ARRAY' ? @{$hdr->{$k}} : grep length, split /\n+/, $hdr->{$k};
+	foreach my $line (@vals) {
 	    printf $fh "$hc %-72s", substr($line,0,72);
 	    $nbytes += 80;
 	}
@@ -1925,7 +1926,9 @@ sub PDL::wfits {
 	  }
 	  # Make sure that the HISTORY lines all come at the end
 	  my @hindex = $afhdr->index('HISTORY');
-	  $afhdr->insert(-1-$_, $afhdr->remove($hindex[-1-$_])) for 0..$#hindex;
+	  my @hitems = map $afhdr->item($_), @hindex;
+	  $afhdr->remove($_) for reverse @hindex; # remove from back as from front disrupts numbering
+	  $afhdr->insert(-1, $_) for @hitems;
 	  # Make sure the last card is an END
 	  $afhdr->insert(scalar($afhdr->cards),
 		       Astro::FITS::Header::Item->new(Keyword=>'END'));

diff --git a/IO/FITS/t/fits.t b/IO/FITS/t/fits.t
@@ -348,25 +348,26 @@ ok all(approx $m51, $m51_2), 'read back written-out compressed FITS file' or dia
 }
 }
 
-#multi-line HISTORY header writing
-{   my $f_out;
-    my $hstr = join("\n",'A'..'G');
-
-    $f_out = 'long_history.fits';
+{
+    my $hstr = join("\n",'A'..'G',''); # must end in newline
+    (undef, my $f_out) = File::Temp::tempfile( 'delmeXXXXX', SUFFIX => '.fits', %tmp_opts );
     my $x = xvals(10);
     $x->hdr->{'HISTORY'} = $hstr;
     $x->wfits($f_out);
     my $xr = rfits($f_out);
-    is($xr->hdr->{'HISTORY'}, $hstr, 'multi-line HISTORY correct with fresh header');
-    unlink($f_out) or die "couldn't delete $f_out";
-
-    $f_out = 'm51_longhist.fits';
+    my $hist = $xr->hdr->{'HISTORY'};
+    $hist = join '', map "$_\n", @$hist if ref $hist eq 'ARRAY';
+    $hist =~ s/ +$//gm;
+    is($hist, $hstr, 'multi-line HISTORY correct with fresh header');
+    (undef, $f_out) = File::Temp::tempfile( 'delmeXXXXX', SUFFIX => '.fits', %tmp_opts ); # new one as Windows unable to remove
     my $m51 = rfits('t/m51.fits.fz');
     $m51->hdr->{HISTORY} = $hstr;
     $m51->wfits($f_out);
     my $m51r = rfits($f_out);
-    is($m51r->hdr->{'HISTORY'}, $hstr, 'multi-line HISTORY correct with pre-existing header');
-    unlink($f_out) or die "couldn't delete $f_out";
+    $hist = $m51r->hdr->{'HISTORY'};
+    $hist = join '', map "$_\n", @$hist if ref $hist eq 'ARRAY';
+    $hist =~ s/ +$//gm;
+    is($hist, $hstr, 'multi-line HISTORY correct with pre-existing header');
 }
 
 done_testing();