From ac2ed20f35b14875a0febe68360ccfd67ef101a0 Mon Sep 17 00:00:00 2001 From: Diab Jerius Date: Wed, 16 Apr 2025 17:25:52 -0400 Subject: [PATCH 01/14] use subtests to modularize/isolate tests. use File::Temp auto-unlinking; fix temp file race conditions; fix tilde expansion test; - Tests are now better isolated by using subtests and not reusing variables between tests - ile::Temp's automatic file unlinking is now used, rather than explicitly unlinking the temp files bugfixes; - use of unique temporary file names could fail due to race conditions. File::Temp creates the temporary file and returns a handle to it. The file is detroyed when the handle is destroyed, and the filename can then be reused by another process. The code kept the name of the temporary file, but not the handle, so the file was destroyed before the code could use it, and thus a race condition could have ensued. - the tilde expansion tests did not actually run The tests should be skipped if the '~' expanded directory was not writeable. The test for that was essentially -w '~' which checks for writeability of a path which is exactly the character '~', not the expanded path. --- t/fits.t | 654 +++++++++++++++++++++++++++++++------------------------ 1 file changed, 367 insertions(+), 287 deletions(-) diff --git a/t/fits.t b/t/fits.t index 0751d87c7..9e9f6778b 100644 --- a/t/fits.t +++ b/t/fits.t @@ -2,7 +2,7 @@ use strict; use warnings; use File::Basename; use PDL::LiteF; -use PDL::Core ':Internal'; # For howbig() +use PDL::Core ':Internal'; # For howbig() use Test::More; use Test::PDL; use Test::Exception; @@ -10,332 +10,412 @@ use PDL::IO::FITS; require File::Spec; require File::Temp; -my $fs = 'File::Spec'; -sub cfile { return $fs->catfile(@_)} - -my %tmp_opts = (TMPDIR => 1, UNLINK => 1); -my (undef, $file) = File::Temp::tempfile(%tmp_opts); +sub tfile { + my $fh = File::Temp->new(@_); + return ( $fh, $fh->filename ); +} ################ Test rfits/wfits ######################## -my $t = long xvals(zeroes(11,20))-5; -wfits($t, $file); # without a header -my $t2 = rfits $file; -unlike $t2->hdr->{COMMENT}//'', qr/HASH/, 'no "HASH" garbage in written header'; -# note: keywords are converted to uppercase -my %hdr = ('Foo'=>'foo', 'Bar'=>42, 'NUM'=>'0123',NUMSTR=>['0123']); -$t->sethdr(\%hdr); -wfits($t, $file); -$t2 = rfits $file; -is_pdl $t2, $t, 'w/rfits round-trip'; -my $h = $t2->gethdr; -is $$h{FOO}, "foo", "header check on FOO"; -is $$h{BAR}, 42, "header check on BAR"; -is $$h{'NUM'}+1, 124, "header check on NUM"; -is $$h{'NUMSTR'}, '0123', "header check on NUMSTR"; -unlink $file; - -SKIP: { - eval { require Astro::FITS::Header }; - - skip "Astro::FITS::Header not installed", 79 if $@; +subtest 'header check' => sub { + + my $t = long xvals( zeroes( 11, 20 ) ) - 5; + my ( $fh, $file ) = tfile; + wfits( $t, $file ); # without a header + my $t2 = rfits $file; + unlike $t2->hdr->{COMMENT} // '', qr/HASH/, + 'no "HASH" garbage in written header'; + + # note: keywords are converted to uppercase + my %hdr = + ( 'Foo' => 'foo', 'Bar' => 42, 'NUM' => '0123', NUMSTR => ['0123'] ); + $t->sethdr( \%hdr ); + wfits( $t, $file ); + $t2 = rfits $file; + is_pdl $t2, $t, 'w/rfits round-trip'; + my $h = $t2->gethdr; + subtest 'header items' => sub { + is $$h{FOO}, "foo", "FOO"; + is $$h{BAR}, 42, "BAR"; + is $$h{'NUM'} + 1, 124, "NUM"; + is $$h{'NUMSTR'}, '0123', "NUMSTR"; + }; +}; ########### Rudimentary table tests ################ +subtest 'Astro::FITS::Header' => sub { + SKIP: { + + skip "Astro::FITS::Header not installed", 79 + if !$PDL::Astro_FITS_Header; + + # note: + # the tests do not directly test the output file, + # instead they write out a file, read it back in, and + # compare to the data used to create the file. + # So it is more of a "self consistent" test. + + subtest 'auto column names, auto column types' => sub { + + my $x = long( 1, 4, 9, 32 ); + my $y = double( 2.3, 4.3, -999.0, 42 ); + my $table2 = do { + my $table = { COLA => $x, COLB => $y }; + my ( $fh, $file ) = tfile; + wfits $table, $file; + rfits $file; + }; + + ok( defined $table2, "Read of table returned something" ); + is( ref($table2), "HASH", "which is a hash reference" ); + is( $$table2{tbl}, "binary", "and appears to be a binary TABLE" ); + + ok( exists $$table2{COLA} && exists $$table2{COLB}, + "columns COLA and COLB exist" ); + is( $$table2{hdr}{TTYPE1}, "COLA", "column #1 is COLA" ); + is( $$table2{hdr}{TFORM1}, "1J", " stored as 1J" ); + is( $$table2{hdr}{TTYPE2}, "COLB", "column #2 is COLB" ); + is( $$table2{hdr}{TFORM2}, "1D", " stored as 1D" ); + + is_pdl $x, $$table2{COLA}, "COLA"; + is_pdl $y, $$table2{COLB}, "COLB"; + + }; + + subtest 'explicit column name, auto column type' => sub { + + my $x = long( 1, 4, 9, 32 ); + my $y = double( 2.3, 4.3, -999.0, 42 ); + + my $table2 = do { + my $table = { + BAR => $x, + FOO => $y, + hdr => { TTYPE1 => 'FOO', TTYPE2 => 'BAR' } + }; + my ( $fh, $file ) = tfile; + wfits $table, $file; + rfits $file; + }; + + ok( + defined $table2 + && ref($table2) eq "HASH" + && $$table2{tbl} eq "binary", + "Read in binary table" + ); + is( $$table2{hdr}{TTYPE1}, "FOO", "column #1 is FOO" ); + is( $$table2{hdr}{TFORM1}, "1D", " stored as 1D" ); + is( $$table2{hdr}{TTYPE2}, "BAR", "column #2 is BAR" ); + is( $$table2{hdr}{TFORM2}, "1J", " stored as 1J" ); + + is_pdl $x, $$table2{BAR}, "BAR"; + is_pdl $y, $$table2{FOO}, "FOO"; + }; + + # try out more "exotic" data types + + subtest 'exotic data types' => sub { + my $x = byte( 12, 45, 23, 0 ); + my $y = short( -99, 100, 0, 32767 ); + my $c = ushort( 99, 32768, 65535, 0 ); + my $d = [ "A string", "b", "", "The last string" ]; + my $e = float( -999.0, 0, 0, 12.3 ); + ##my $f = float(1,0,-1,2) + i * float( 0,1,2,-1 ); + + my $table2 = do { + my $table = { + ACOL => $x, + BCOL => $y, + CCOL => $c, + DCOL => $d, + ECOL => $e, + ## FCOL => $f, + }; + my ( $fh, $file ) = tfile; + wfits $table, $file; + rfits $file; + }; + + ok( + defined $table2 + && ref($table2) eq "HASH" + && $$table2{tbl} eq "binary", + "Read in the binary table" + ); + my @elem = sort keys %$table2; + my @expected = sort(qw( ACOL BCOL CCOL DCOL ECOL hdr tbl )); + is_deeply \@elem, \@expected, "hash contains expected keys"; + + # convert the string array so that each element has the same length + # (and calculate the maximum length to use in the check below) + # + my $dlen = 0; + foreach my $str (@$d) { + my $len = length($str); + $dlen = $len > $dlen ? $len : $dlen; + } + foreach my $str (@$d) { + $str .= ' ' x ( $dlen - length($str) ); + } + + # note that, for now, ushort data is written out as a long (Int4) + # instead of being written out as an Int2 using TSCALE/TZERO + # + my $i = 1; + foreach my $colinfo ( + ( + [ "ACOL", "1B", $x ], + [ "BCOL", "1I", $y ], + [ "CCOL", "1J", $c->long ], + [ "DCOL", "${dlen}A", $d ], + [ "ECOL", "1E", $e ], + ## ["FCOL","1M",$f] + ) + ) + { + is( $$table2{hdr}{"TTYPE$i"}, + $$colinfo[0], "column $i is $$colinfo[0]" ); + is( $$table2{hdr}{"TFORM$i"}, + $$colinfo[1], " and is stored as $$colinfo[1]" ); + my $col = $$table2{ $$colinfo[0] }; + if ( UNIVERSAL::isa( $col, "PDL" ) ) { + is_pdl $col, $$colinfo[2], $$colinfo[0]; + } + else { + # Need to somehow handle the arrays since the data read in from the + # file all have 15-character length strings (or whatever the length is) + # + is_deeply $col, $$colinfo[2], + "$$colinfo[0] values agree (as an array reference)"; + } + $i++; + } + }; + } # end of SKIP block +}; -# note: -# the tests do not directly test the output file, -# instead they write out a file, read it back in, and -# compare to the data used to create the file. -# So it is more of a "self consistent" test. - -unless($PDL::Astro_FITS_Header) { - # Astro::FITS::Header is not present, ignore table tests - for(1..59){ok(1,"Test skipped (no binary table support without Astro::FITS::Header)");} -} else { # Astro::FITS::Header exists - - my $x = long( 1, 4, 9, 32 ); - my $y = double( 2.3, 4.3, -999.0, 42 ); - my $table = { COLA => $x, COLB => $y }; - wfits $table, $file; - - my $table2 = rfits $file; - unlink $file; - - ok( defined $table2, "Read of table returned something" ); #5 - is( ref($table2), "HASH", "which is a hash reference" ); #6 - is( $$table2{tbl}, "binary", "and appears to be a binary TABLE" );#7 - - ok( exists $$table2{COLA} && exists $$table2{COLB}, "columns COLA and COLB exist" ); #8 - is( $$table2{hdr}{TTYPE1}, "COLA", "column #1 is COLA" ); #9 - is( $$table2{hdr}{TFORM1}, "1J", " stored as 1J" ); #10 - is( $$table2{hdr}{TTYPE2}, "COLB", "column #2 is COLB" ); #11 - is( $$table2{hdr}{TFORM2}, "1D", " stored as 1D" ); #12 - - is_pdl $x, $$table2{COLA}, "COLA"; #13-16 - is_pdl $y, $$table2{COLB}, "COLB"; #17-20 - - $table = { BAR => $x, FOO => $y, - hdr => { TTYPE1 => 'FOO', TTYPE2 => 'BAR' } }; - $table2 = {}; - - wfits $table, $file; - $table2 = rfits $file; - - ok( defined $table2 && ref($table2) eq "HASH" && $$table2{tbl} eq "binary", - "Read in the second binary table" ); #21 - is( $$table2{hdr}{TTYPE1}, "FOO", "column #1 is FOO" ); #22 - is( $$table2{hdr}{TFORM1}, "1D", " stored as 1D" ); #23 - is( $$table2{hdr}{TTYPE2}, "BAR", "column #2 is BAR" ); #24 - is( $$table2{hdr}{TFORM2}, "1J", " stored as 1J" ); #25 - - is_pdl $x, $$table2{BAR}, "BAR"; #26-29 - is_pdl $y, $$table2{FOO}, "FOO"; #30-33 - - # try out more "exotic" data types - - $x = byte(12,45,23,0); - $y = short(-99,100,0,32767); - my $c = ushort(99,32768,65535,0); - my $d = [ "A string", "b", "", "The last string" ]; - my $e = float(-999.0,0,0,12.3); - ##my $f = float(1,0,-1,2) + i * float( 0,1,2,-1 ); - $table = { - ACOL => $x, BCOL => $y, CCOL => $c, DCOL => $d, ECOL => $e, - ## FCOL => $f, - }; - $table2 = {}; - - wfits $table, $file; - $table2 = rfits $file; - - ok( defined $table2 && ref($table2) eq "HASH" && $$table2{tbl} eq "binary", - "Read in the third binary table" ); #34 - my @elem = sort keys %$table2; - my @expected = sort( qw( ACOL BCOL CCOL DCOL ECOL hdr tbl ) ); - is_deeply \@elem, \@expected, "hash contains expected keys"; - - # convert the string array so that each element has the same length - # (and calculate the maximum length to use in the check below) - # - my $dlen = 0; - foreach my $str ( @$d ) { - my $len = length($str); - $dlen = $len > $dlen ? $len : $dlen; - } - foreach my $str ( @$d ) { - $str .= ' ' x ($dlen-length($str)); - } - - # note that, for now, ushort data is written out as a long (Int4) - # instead of being written out as an Int2 using TSCALE/TZERO - # - my $i = 1; - foreach my $colinfo ( ( ["ACOL","1B",$x], - ["BCOL","1I",$y], - ["CCOL","1J",$c->long], - ["DCOL","${dlen}A",$d], - ["ECOL","1E",$e], - ## ["FCOL","1M",$f] - ) ) { - is( $$table2{hdr}{"TTYPE$i"}, $$colinfo[0], "column $i is $$colinfo[0]" ); #37,43,49,55,58 - is( $$table2{hdr}{"TFORM$i"}, $$colinfo[1], " and is stored as $$colinfo[1]" ); #38,44,50,56,59 - my $col = $$table2{$$colinfo[0]}; - if ( UNIVERSAL::isa($col,"PDL") ) { - is_pdl $col, $$colinfo[2], $$colinfo[0]; #39-42,45-48,51-54,60-63 - } else { - # Need to somehow handle the arrays since the data read in from the - # file all have 15-character length strings (or whatever the length is) - # - is_deeply $col, $$colinfo[2], "$$colinfo[0] values agree (as an array reference)"; - } - $i++; - } -} ########### Check if r/wfits bugs are fixed ################ -{ - local $| = 1; - my $a1 = [1,2]; - my $a2 = [[1,2],[1,2]]; - my $p; - my $q; - my @target_bitpix = (8,16,32,-32,-64); - my $bp_i = 0; - for my $cref ( \(&byte, &short, &long, &float, &double) ) { - for my $x ($a1,$a2) { - $p = &$cref($x); - unlink $file; - $p->wfits($file); - $q = PDL->rfits($file); - my $flag = 1; - if ( ${$p->get_dataref} ne ${$q->get_dataref} ) { - $flag = 0; - diag "\tnelem=",$p->nelem,"datatype=",$p->get_datatype; - diag "\tp:", unpack("c" x ($p->nelem*howbig($p->get_datatype)), ${$p->get_dataref}); - diag "\tq:", unpack("c" x ($q->nelem*howbig($q->get_datatype)), ${$q->get_dataref}); +subtest 'Internal FITS Header regression tests' => sub { + + local $PDL::Astro_FITS_HEADER = 0; + + subtest 'r/wfits bug #1' => sub { + local $| = 1; + my $a1 = [ 1, 2 ]; + my $a2 = [ [ 1, 2 ], [ 1, 2 ] ]; + my $p; + my $q; + my @target_bitpix = ( 8, 16, 32, -32, -64 ); + my $bp_i = 0; + for my $cref ( \( &byte, &short, &long, &float, &double ) ) { + for my $x ( $a1, $a2 ) { + $p = &$cref($x); + my ( $fh, $file ) = tfile; + $p->wfits($file); + $q = PDL->rfits($file); + my $flag = 1; + if ( ${ $p->get_dataref } ne ${ $q->get_dataref } ) { + $flag = 0; + diag "\tnelem=", $p->nelem, "datatype=", $p->get_datatype; + diag "\tp:", + unpack( "c" x ( $p->nelem * howbig( $p->get_datatype ) ), + ${ $p->get_dataref } ); + diag "\tq:", + unpack( "c" x ( $q->nelem * howbig( $q->get_datatype ) ), + ${ $q->get_dataref } ); + } + is( $q->hdr->{BITPIX}, $target_bitpix[$bp_i], + "BITPIX implicitly set to " . $target_bitpix[$bp_i] ); + ok( $flag, "hash reference - type check: " . &$cref ); } - is($q->hdr->{BITPIX},$target_bitpix[$bp_i],"BITPIX implicitly set to " . $target_bitpix[$bp_i]); - ok($flag,"hash reference - type check: " . &$cref ); #64-73 + $bp_i++; } - $bp_i++; - } -} - -{ - local $| = 1; - my $p1= pdl [1,2]; - my $p2= pdl [[1,2],[1,2]]; - my $q; - my @s; - for my $i (8,16,32,-32,-64) { - for my $p ($p2, $p1) { - unlink $file; - $p->wfits($file,$i); - $q = PDL->rfits($file); - @s = $q->stats; - my $flag; - if ($s[0] == 1.5 and $s[1] < 0.7072 and $s[1]>0.577) { - $flag = 1; - } else { - $flag = 0; - diag "s=@s\n"; - diag "\tBITPIX=$i, nelem=", $p->nelem; - diag "\tbug: $s[0] == 1.5 and $s[1] == 0.5"; - diag "\tp:", unpack("c8" x $p->nelem, ${$p->get_dataref}); - diag "\tq:", unpack("c" x abs($i/8*$q->nelem), ${$q->get_dataref}); + }; + + subtest 'r/wfits bug #1' => sub { + local $| = 1; + my $p1 = pdl [ 1, 2 ]; + my $p2 = pdl [ [ 1, 2 ], [ 1, 2 ] ]; + my $q; + my @s; + for my $i ( 8, 16, 32, -32, -64 ) { + for my $p ( $p2, $p1 ) { + my ( $fh, $file ) = tfile; + $p->wfits( $file, $i ); + $q = PDL->rfits($file); + @s = $q->stats; + my $flag; + if ( $s[0] == 1.5 and $s[1] < 0.7072 and $s[1] > 0.577 ) { + $flag = 1; + } + else { + $flag = 0; + diag "s=@s\n"; + diag "\tBITPIX=$i, nelem=", $p->nelem; + diag "\tbug: $s[0] == 1.5 and $s[1] == 0.5"; + diag "\tp:", + unpack( "c8" x $p->nelem, ${ $p->get_dataref } ); + diag "\tq:", + unpack( "c" x abs( $i / 8 * $q->nelem ), + ${ $q->get_dataref } ); + } + is( $q->hdr->{BITPIX}, $i, + "BITPIX explicitly set to $i works" ); + ok( $flag, "ndarray - bitpix=$i" ); + } } - is($q->hdr->{BITPIX},$i,"BITPIX explicitly set to $i works"); - ok($flag,"ndarray - bitpix=$i" ); #74-83 - } - } -}; + }; -}; # end of SKIP block +}; #### Check that discontinuous data (e.g. from fftnd) get written correctly. #### (Sourceforge bug 3299611) it is possible to store data in a PDL non-contiguously #### through the C API, by manipulating dimincs; fft uses this technique, which #### used to hose up fits output. -SKIP:{ - eval "use PDL::FFT"; - skip "PDL::FFT not installed", 79 if $@; - - my $ar = sequence(10,10,10); - my $ai = zeroes($ar); - fftnd($ar,$ai); - unlink $file; - wfits($ar,$file); - my $y = rfits($file); - is_pdl $ar, $y, "fftnd output (non-contiguous in memory) is written correctly"; - unlink $file; -} +subtest 'PDL::FFT' => sub { + SKIP: { + skip "PDL::FFT not installed", 79 + if !eval 'use PDL::FFT; 1;'; + + my $ar = sequence( 10, 10, 10 ); + my $ai = zeroes($ar); + fftnd( $ar, $ai ); + my ( $fh, $file ) = tfile; + wfits( $ar, $file ); + my $y = rfits($file); + is_pdl $ar, $y, + "fftnd output (non-contiguous in memory) is written correctly"; + } +}; ############################## # Check multi-HDU read/write -my $x = sequence(5,5); -my $y = rvals(5,5); +subtest 'multi-HDU read/write' => sub { + my $x = sequence( 5, 5 ); + my $y = rvals( 5, 5 ); -our @aa; + my @aa; -lives_ok { wfits([$x,$y],$file) } "wfits with multiple HDUs didn't fail"; + my ( $fh, $file ) = tfile; + lives_ok { wfits( [ $x, $y ], $file ) } + "wfits with multiple HDUs didn't fail"; -lives_ok { @aa = rfits($file) } "rfits in list context didn't fail"; + lives_ok { @aa = rfits($file) } "rfits in list context didn't fail"; -is_pdl $aa[0], $x, "first element reproduces written one"; -is_pdl $aa[1], $y, "Second element reproduces written one"; - -unlink $file; + is_pdl $aa[0], $x, "first element reproduces written one"; + is_pdl $aa[1], $y, "Second element reproduces written one"; +}; ############################## # Rudimentary check for longlong support -SKIP:{ - eval "use PDL::Types"; - our $PDL_LL; - skip "Longlong not supported",5 unless ($PDL_LL//0); - - $x = rvals(longlong,7,7); - eval { wfits($x, $file); }; - is $@, '', "writing a longlong image succeeded"; - eval { $y = rfits($file); }; - is $@, '', "Reading the longlong image succeeded"; - isa_ok $y->hdr, "HASH", "Reading the longlong image produced a PDL with a hash header"; - is $y->hdr->{BITPIX}, 64, "BITPIX value was correct"; - is_pdl $y, $x, "The new image matches the old one (longlong)"; - unlink $file; -} +subtest 'longlong image' => sub { + my ( $fh, $file ) = tfile; + + my $x = rvals( longlong, 7, 7 ); + lives_ok { wfits( $x, $file ) } 'write'; + my $y; + lives_ok { $y = rfits($file); } 'read'; + isa_ok $y->hdr, "HASH", "header is hash"; + is $y->hdr->{BITPIX}, 64, "BITPIX value was correct"; + is_pdl $y, $x, "The new image matches the old one"; + +}; ############################### # Check that tilde expansion works -my $tildefile = cfile('~',"PDL-IO-FITS-test_$$.fits"); +subtest 'tilde path expansion' => sub { # Only read/write the tildefile if the directory is writable. # Some build environments, like the Debian pbuilder chroots, use a non-existent $HOME. # See: https://github.com/PDLPorters/pdl/issues/238 -if(-w dirname($tildefile)) { - lives_ok { sequence(3,5,2)->wfits($tildefile) } "wfits tilde expansion didn't fail"; - lives_ok { rfits($tildefile) } "rfits tilde expansion didn't fail"; - $tildefile =~ s/^(~)/glob($1)/e; #use the same trick as in FITS.pm to resolve this filename. - unlink($tildefile) or warn "Could not delete $tildefile: $!\n"; #clean up. -} + SKIP: { + my $tilde_dir = <~>; + + skip '~ directory is not writeable' + unless -w $tilde_dir; + + my ( $fh, $file ) = tfile( DIR => $tilde_dir, SUFFIX => '.fits' ); + ok( -z $file, "output file is empty" ); + my $tildefile = File::Spec->catfile( '~', basename($file) ); + lives_ok { sequence( 3, 5, 2 )->wfits($tildefile) } "write succeeded"; + ok( -s $file, "output file is not empty" ); + lives_ok { rfits($tildefile) } "rfits succeeded."; + } +}; +############################### # test bad with r/wfits -{ -(undef, my $fname) = File::Temp::tempfile( 'delmeXXXXX', SUFFIX => '.fits', %tmp_opts ); -my $x = sequence(10)->setbadat(0); -$x->wfits($fname); -my $y = rfits($fname); -is_pdl $y, $x, "wfits/rfits propagated bad flag and values"; -# now force to integer -$x->wfits($fname,16); -$y = rfits($fname); -is_pdl $y, $x->short, "integer wfits/rfits propagated bad flag and values"; -} - -{ -my $m51 = rfits('t/m51.fits.fz'); -is_pdl $m51->shape, indx([384,384]), 'right dims from compressed FITS file'; -(undef, my $fname) = File::Temp::tempfile( 'delmeXXXXX', SUFFIX => '.fits', %tmp_opts ); -if ($PDL::Astro_FITS_Header) { -my $m51_tbl = rfits('t/m51.fits.fz',{expand=>0}); -wfits($m51_tbl, $fname); -my $m51_2 = rfits($fname); -is_pdl $m51_2, $m51, 'read back written-out bintable FITS file'; -$m51->wfits($fname, {compress=>1}); -$m51_2 = rfits($fname); -is_pdl $m51_2, $m51, 'read back written-out compressed FITS file'; -$m51_2->hdrcpy(1); -$m51_2 = $m51_2->dummy(2,3)->sever; -$m51_2->hdr->{NAXIS} = 3; -$m51_2->hdr->{NAXIS3} = 3; -$m51_2->wfits($fname, {compress=>1}); -my $m51_3 = rfits($fname); -is_pdl $m51_3, $m51_2, 'read back written-out compressed RGB FITS file'; -} -} +subtest 'bad with r/wfits' => sub { + my ( $fh, $fname ) = tfile; + my $x = sequence(10)->setbadat(0); + $x->wfits($fname); + my $y = rfits($fname); + is_pdl $y, $x, "wfits/rfits propagated bad flag and values"; + + # now force to integer + $x->wfits( $fname, 16 ); + $y = rfits($fname); + is_pdl $y, $x->short, "integer wfits/rfits propagated bad flag and values"; +}; -{ - 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); - 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 +############################### +subtest 'compressed fits file' => sub { my $m51 = rfits('t/m51.fits.fz'); - $m51->hdr->{HISTORY} = $hstr; - $m51->wfits($f_out); - my $m51r = rfits($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'); -} + is_pdl $m51->shape, indx( [ 384, 384 ] ), + 'right dims from compressed FITS file'; + my ( $fh, $fname ) = tfile; + if ($PDL::Astro_FITS_Header) { + my $m51_tbl = rfits( 't/m51.fits.fz', { expand => 0 } ); + wfits( $m51_tbl, $fname ); + my $m51_2 = rfits($fname); + is_pdl $m51_2, $m51, 'read back written-out bintable FITS file'; + $m51->wfits( $fname, { compress => 1 } ); + $m51_2 = rfits($fname); + is_pdl $m51_2, $m51, 'read back written-out compressed FITS file'; + $m51_2->hdrcpy(1); + $m51_2 = $m51_2->dummy( 2, 3 )->sever; + $m51_2->hdr->{NAXIS} = 3; + $m51_2->hdr->{NAXIS3} = 3; + $m51_2->wfits( $fname, { compress => 1 } ); + my $m51_3 = rfits($fname); + is_pdl $m51_3, $m51_2, 'read back written-out compressed RGB FITS file'; + } +}; + +############################### +subtest 'multi-line HISTORY' => sub { + + my $hstr = join( "\n", 'A' .. 'G', '' ); # must end in newline + + subtest 'fresh header' => sub { + my ( $fh, $file ) = tfile; + my $x = xvals(10); + $x->hdr->{'HISTORY'} = $hstr; + $x->wfits($file); + my $xr = rfits($file); + my $hist = $xr->hdr->{'HISTORY'}; + $hist = join '', map "$_\n", @$hist if ref $hist eq 'ARRAY'; + $hist =~ s/ +$//gm; + is( $hist, $hstr, 'correct with fresh header' ); + }; + + subtest 'pre-existing header' => sub { + my ( $fh, $file ) = tfile; + my $m51 = rfits('t/m51.fits.fz'); + $m51->hdr->{HISTORY} = $hstr; + $m51->wfits($file); + my $m51r = rfits($file); + my $hist = $m51r->hdr->{'HISTORY'}; + $hist = join '', map "$_\n", @$hist if ref $hist eq 'ARRAY'; + $hist =~ s/ +$//gm; + is( $hist, $hstr, 'correct with pre-existing header' ); + }; + +}; done_testing(); From 48dc933ab410b00edd1d0557993facd48f91d5bc Mon Sep 17 00:00:00 2001 From: Diab Jerius Date: Thu, 17 Apr 2025 12:44:17 -0400 Subject: [PATCH 02/14] test that FITS null hdu is written using correct legacy/non-legacy code path --- t/fits.t | 37 +++++++++++++++++++++++++++++++++++++ 1 file changed, 37 insertions(+) diff --git a/t/fits.t b/t/fits.t index 9e9f6778b..2fcc72743 100644 --- a/t/fits.t +++ b/t/fits.t @@ -418,4 +418,41 @@ subtest 'multi-line HISTORY' => sub { }; +############################### +subtest 'write null hdu with and without Astro::FITS::Header' => sub { + + subtest 'with' => sub { + SKIP: { + skip 'Astro::FITS::Header not available' + unless $PDL::Astro_FITS_Header; + my ( $fh, $file ) = tfile; + my $x = pdl(3); + lives_ok { wfits [pdl([3])], $file } 'create file'; + + my $contents = do { + local $/; + open my $fh, '<', $file + or die("unable to open $file"); + <$fh>; + }; + unlike( $contents, qr/legacy code/, "didn't use legacy code" ); + } + }; + + subtest 'without' => sub { + local $PDL::Astro_FITS_Header = 0; + my ( $fh, $file ) = tfile; + my $x = pdl(3); + lives_ok { wfits [pdl( [3] )], $file } 'create file'; + my $contents = do { + local $/; + open my $fh, '<', $file + or die("unable to open $file"); + <$fh>; + }; + like( $contents, qr/legacy code/, "used legacy code" ); + }; + +}; + done_testing(); From 158fa3b48da24c5d9681ae75cd3c1fabe4175e20 Mon Sep 17 00:00:00 2001 From: Diab Jerius Date: Thu, 17 Apr 2025 12:53:18 -0400 Subject: [PATCH 03/14] use correct name of flag used to determine if Astro::FITS::Header was available --- lib/PDL/IO/FITS.pm | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/lib/PDL/IO/FITS.pm b/lib/PDL/IO/FITS.pm index a38c1e543..d3190af6d 100644 --- a/lib/PDL/IO/FITS.pm +++ b/lib/PDL/IO/FITS.pm @@ -2480,7 +2480,8 @@ sub _wfits_table { sub _wfits_nullhdu { my $fh = shift; - if($Astro::FITS::Header) { + + if($PDL::Astro_FITS_Header) { my $h = Astro::FITS::Header->new(); reset_hdr_ctr(); From 2661f9a659989054bd6a84d6877df057af8dffa4 Mon Sep 17 00:00:00 2001 From: Diab Jerius Date: Thu, 17 Apr 2025 11:27:33 -0400 Subject: [PATCH 04/14] add test for regression: exception when writing scalar ndarrays --- t/fits.t | 23 +++++++++++++++++++++++ 1 file changed, 23 insertions(+) diff --git a/t/fits.t b/t/fits.t index 2fcc72743..b987220e7 100644 --- a/t/fits.t +++ b/t/fits.t @@ -455,4 +455,27 @@ subtest 'write null hdu with and without Astro::FITS::Header' => sub { }; +############################### +subtest 'accept scalar (0D) ndarrays' => sub { + + subtest 'bintable' => sub { + my ( $fh, $file ) = tfile; + lives_ok { wfits { x => pdl(3) }, $file } 'write column'; + my $got = rfits($file); + is_pdl( $got->{X}, pdl( [3] ), "got data" ); + + }; + + subtest 'image' => sub { + my ( $fh, $file ) = tfile( UNLINK => 0 ); + diag $file; + lives_ok { wfits pdl(3), $file } 'write image'; + my $got; + lives_ok { $got = rfits($file) } 'read image'; + is_pdl( $got, pdl( [3] ), "got data" ); + + }; + +}; + done_testing(); From 41ec96f5ff1fe924122bd9b31adaed81a0d0a77e Mon Sep 17 00:00:00 2001 From: Diab Jerius Date: Thu, 17 Apr 2025 14:53:05 -0400 Subject: [PATCH 05/14] regression fix: write fits files from scalar ndarrays --- lib/PDL/IO/FITS.pm | 13 +++++++++---- 1 file changed, 9 insertions(+), 4 deletions(-) diff --git a/lib/PDL/IO/FITS.pm b/lib/PDL/IO/FITS.pm index d3190af6d..1bc82c10f 100644 --- a/lib/PDL/IO/FITS.pm +++ b/lib/PDL/IO/FITS.pm @@ -1725,6 +1725,10 @@ sub PDL::wfits { # Not a PDL and not a hash ref barf("wfits: unknown data type - quitting"); } + + # scalar ndarrays are 0D + my $ndims = $pdl->getndims || 1; + ### Regular image writing. $BITPIX = "" unless defined $BITPIX; if ($BITPIX eq "") { @@ -1816,9 +1820,9 @@ sub PDL::wfits { ? qw(XTENSION IMAGE) : (qw(SIMPLE T LOGICAL), 'Created with PDL (http://pdl.perl.org)')); _k_add($ohash, 'BITPIX', $BITPIX); - _k_add($ohash, 'NAXIS', $pdl->getndims); + _k_add($ohash, 'NAXIS', $ndims); my $correction = 0; - for (1..$pdl->getndims) { + for (1..$ndims) { $correction ||= exists $ohdr{"NAXIS$_"} && $ohdr{"NAXIS$_"} != $pdl->dim($_-1); _k_add($ohash, "NAXIS$_", $pdl->getdim($_-1)); @@ -1838,7 +1842,7 @@ sub PDL::wfits { my $kw = $kw_base; $kw .= ++$kn; # NAXIS1 -> NAXIS last if !exists $ohdr{$kw}; - next if $kn <= $pdl->getndims; + next if $kn <= $ndims; #remove e.g. NAXIS3 from afhdr if NAXIS==2 delete $ohdr{$kw}; delete $h->{$kw} if $use_afh; @@ -1861,7 +1865,7 @@ sub PDL::wfits { _k_add($ohash, 'ZCMPTYPE', $cmptype); _k_add($ohash, $wfits_zpreserve{$_}, delete $ohdr{$_}) for sort grep exists $ohdr{$_}, keys %wfits_zpreserve; - _k_add($ohash, "ZNAXIS$_", $ohdr{"NAXIS$_"}) for 1..$pdl->getndims; + _k_add($ohash, "ZNAXIS$_", $ohdr{"NAXIS$_"}) for 1..$ndims; $tc->[0]->( $pdl, \%ohdr, $opt ); my %tbl; $tbl{$_} = delete $ohdr{$_} for map $_."COMPRESSED_DATA", '', 'len_'; @@ -2222,6 +2226,7 @@ sub _prep_table { $internaltype[$i] = 'P'; my $dims = $var->shape; + $dims = pdl(indx,1) if $dims->isempty; (my $t = $dims->slice("(0)")) .= pdl($dims->type, 1); $rpt = $dims->prod; From 509d265cd3f29708640ae00f7746e273263ce905 Mon Sep 17 00:00:00 2001 From: Diab Jerius Date: Thu, 17 Apr 2025 18:22:07 -0400 Subject: [PATCH 06/14] legacy Perl header reader did not handle multiple comments correctly --- lib/PDL/IO/FITS.pm | 8 +++++++- t/fits.t | 43 +++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 50 insertions(+), 1 deletion(-) diff --git a/lib/PDL/IO/FITS.pm b/lib/PDL/IO/FITS.pm index 1bc82c10f..7e86f0825 100644 --- a/lib/PDL/IO/FITS.pm +++ b/lib/PDL/IO/FITS.pm @@ -334,6 +334,7 @@ sub PDL::rfits { my $ext_type = 'IMAGE'; # Gets the type of XTENSION if one is detected. my $foo={}; # To go in pdl my @history=(); + my @comment=(); my @cards = (); $pdl = $class->new; @@ -437,7 +438,11 @@ sub PDL::rfits { if ($name =~ m/^HISTORY/) { push @history, $rest; - } else { + } + elsif ($name =~ m/^COMMENT/) { + push @comment, $rest; + } + else { $$foo{$name} = ""; $$foo{$name}=$1 if $rest =~ m|^= +([^\/\' ][^\/ ]*) *( +/(.*))?$| ; @@ -450,6 +455,7 @@ sub PDL::rfits { # Clean up HISTORY card $$foo{HISTORY} = \@history if $#history >= 0; + $$foo{COMMENT} = \@comment if $#comment >= 0; # Step to end of header block in file my $skip = 2879 - ($nbytes-1)%2880; diff --git a/t/fits.t b/t/fits.t index b987220e7..190d824a5 100644 --- a/t/fits.t +++ b/t/fits.t @@ -478,4 +478,47 @@ subtest 'accept scalar (0D) ndarrays' => sub { }; +############################### +subtest 'handle multiple COMMENT and HISTORY cards' => sub { + + my $cards = join q{}, map { sprintf( '%-80s', $_ ) } + q{SIMPLE = T}, + q{BITPIX = -32}, + q{NAXIS = 1}, + q{NAXIS1 = 0}, + q{COMMENT comment1}, + q{COMMENT comment2}, + q{HISTORY history1}, + q{HISTORY history2}, + q{END}; + + my $fits = sprintf( '%-2880s', $cards ); + + my ( $fh, $file ) = tfile; + $fh->print($fits); + $fh->flush; + + my $hdr = rfitshdr($file); + + for my $keyword ( 'COMMENT', 'HISTORY' ) { + ok( defined $hdr->{$keyword}, "got $keyword 'card'" ) + or next; + + my $arr = $hdr->{$keyword}; + + if ($PDL::Astro_FITS_Header) { + $arr = [ split /\n/, $arr ]; + } + else { + is( ref($arr), 'ARRAY', 'is array' ) + or next; + } + s/\s+$// for @$arr; + + is( $arr->[0], lc($keyword) . '1', 'first card' ); + is( $arr->[1], lc($keyword) . '2', 'second card' ); + } + +}; + done_testing(); From 1a7a973306d4c6c0c1f9a7a63751a27c79001c32 Mon Sep 17 00:00:00 2001 From: Diab Jerius Date: Thu, 17 Apr 2025 18:53:01 -0400 Subject: [PATCH 07/14] order of got,expected was reversed --- t/fits.t | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/t/fits.t b/t/fits.t index 190d824a5..8bf7777da 100644 --- a/t/fits.t +++ b/t/fits.t @@ -77,8 +77,8 @@ subtest 'Astro::FITS::Header' => sub { is( $$table2{hdr}{TTYPE2}, "COLB", "column #2 is COLB" ); is( $$table2{hdr}{TFORM2}, "1D", " stored as 1D" ); - is_pdl $x, $$table2{COLA}, "COLA"; - is_pdl $y, $$table2{COLB}, "COLB"; + is_pdl $$table2{COLA}, $x, "COLA"; + is_pdl $$table2{COLB}, $y, "COLB"; }; @@ -109,8 +109,8 @@ subtest 'Astro::FITS::Header' => sub { is( $$table2{hdr}{TTYPE2}, "BAR", "column #2 is BAR" ); is( $$table2{hdr}{TFORM2}, "1J", " stored as 1J" ); - is_pdl $x, $$table2{BAR}, "BAR"; - is_pdl $y, $$table2{FOO}, "FOO"; + is_pdl $$table2{BAR}, $x, "BAR"; + is_pdl $$table2{FOO}, $y, "FOO"; }; # try out more "exotic" data types From a600f67a1012f2c17e2b84acec5ece74e913583b Mon Sep 17 00:00:00 2001 From: Diab Jerius Date: Thu, 17 Apr 2025 18:55:24 -0400 Subject: [PATCH 08/14] split complex test into several --- t/fits.t | 20 ++++++++------------ 1 file changed, 8 insertions(+), 12 deletions(-) diff --git a/t/fits.t b/t/fits.t index 8bf7777da..3d2cabebd 100644 --- a/t/fits.t +++ b/t/fits.t @@ -98,12 +98,10 @@ subtest 'Astro::FITS::Header' => sub { rfits $file; }; - ok( - defined $table2 - && ref($table2) eq "HASH" - && $$table2{tbl} eq "binary", - "Read in binary table" - ); + ok( defined $table2, "Read of table returned something" ); + is( ref($table2), "HASH", "which is a hash reference" ); + is( $$table2{tbl}, "binary", "and appears to be a binary TABLE" ); + is( $$table2{hdr}{TTYPE1}, "FOO", "column #1 is FOO" ); is( $$table2{hdr}{TFORM1}, "1D", " stored as 1D" ); is( $$table2{hdr}{TTYPE2}, "BAR", "column #2 is BAR" ); @@ -137,12 +135,10 @@ subtest 'Astro::FITS::Header' => sub { rfits $file; }; - ok( - defined $table2 - && ref($table2) eq "HASH" - && $$table2{tbl} eq "binary", - "Read in the binary table" - ); + ok( defined $table2, "Read of table returned something" ); + is( ref($table2), "HASH", "which is a hash reference" ); + is( $$table2{tbl}, "binary", "and appears to be a binary TABLE" ); + my @elem = sort keys %$table2; my @expected = sort(qw( ACOL BCOL CCOL DCOL ECOL hdr tbl )); is_deeply \@elem, \@expected, "hash contains expected keys"; From 028f1770d91aca4ee7556b86ae37893b07f7a82a Mon Sep 17 00:00:00 2001 From: Diab Jerius Date: Thu, 17 Apr 2025 18:56:33 -0400 Subject: [PATCH 09/14] rewrite unnecessarily complex test --- t/fits.t | 13 ++----------- 1 file changed, 2 insertions(+), 11 deletions(-) diff --git a/t/fits.t b/t/fits.t index 3d2cabebd..df359553d 100644 --- a/t/fits.t +++ b/t/fits.t @@ -207,21 +207,12 @@ subtest 'Internal FITS Header regression tests' => sub { my $bp_i = 0; for my $cref ( \( &byte, &short, &long, &float, &double ) ) { for my $x ( $a1, $a2 ) { - $p = &$cref($x); + $p = $cref->($x); my ( $fh, $file ) = tfile; $p->wfits($file); $q = PDL->rfits($file); my $flag = 1; - if ( ${ $p->get_dataref } ne ${ $q->get_dataref } ) { - $flag = 0; - diag "\tnelem=", $p->nelem, "datatype=", $p->get_datatype; - diag "\tp:", - unpack( "c" x ( $p->nelem * howbig( $p->get_datatype ) ), - ${ $p->get_dataref } ); - diag "\tq:", - unpack( "c" x ( $q->nelem * howbig( $q->get_datatype ) ), - ${ $q->get_dataref } ); - } + is_pdl( $p, $q, 'round-trip data' ); is( $q->hdr->{BITPIX}, $target_bitpix[$bp_i], "BITPIX implicitly set to " . $target_bitpix[$bp_i] ); ok( $flag, "hash reference - type check: " . &$cref ); From f4f5acaf675d213793cfa03c7be638ca8bcb7a43 Mon Sep 17 00:00:00 2001 From: Diab Jerius Date: Thu, 17 Apr 2025 18:58:05 -0400 Subject: [PATCH 10/14] rewrite in light of t/fits-noah.t, read header instead of searching the raw fits file Unify with/without Astro::FITS::Header tests for writing nullhdu, as patht/fits-noah.t takes care of running without Astro::FITS::Header. Scanning the raw fits file for expected COMMENT strings results in horrendous garbage output if the tests fail. Instead use rfitshdr to extract the header and scan the comments. --- t/fits.t | 56 ++++++++++++++++++++++++-------------------------------- 1 file changed, 24 insertions(+), 32 deletions(-) diff --git a/t/fits.t b/t/fits.t index df359553d..a386a4caa 100644 --- a/t/fits.t +++ b/t/fits.t @@ -9,6 +9,7 @@ use Test::Exception; use PDL::IO::FITS; require File::Spec; require File::Temp; +use List::Util; sub tfile { my $fh = File::Temp->new(@_); @@ -406,39 +407,30 @@ subtest 'multi-line HISTORY' => sub { }; ############################### -subtest 'write null hdu with and without Astro::FITS::Header' => sub { - - subtest 'with' => sub { - SKIP: { - skip 'Astro::FITS::Header not available' - unless $PDL::Astro_FITS_Header; - my ( $fh, $file ) = tfile; - my $x = pdl(3); - lives_ok { wfits [pdl([3])], $file } 'create file'; - - my $contents = do { - local $/; - open my $fh, '<', $file - or die("unable to open $file"); - <$fh>; - }; - unlike( $contents, qr/legacy code/, "didn't use legacy code" ); - } - }; +subtest 'write null hdu with correct module' => sub { - subtest 'without' => sub { - local $PDL::Astro_FITS_Header = 0; - my ( $fh, $file ) = tfile; - my $x = pdl(3); - lives_ok { wfits [pdl( [3] )], $file } 'create file'; - my $contents = do { - local $/; - open my $fh, '<', $file - or die("unable to open $file"); - <$fh>; - }; - like( $contents, qr/legacy code/, "used legacy code" ); - }; + my ( $fh, $file ) = tfile; + wfits [ pdl(3) ], $file; + + my ($hdr) = rfitshdr( $file . '[0]' ); + + my $found; + if ( my $comments = $hdr->{COMMENT} ) { + $comments = [ split( /\n/, $comments ) ] + if $PDL::Astro_FITS_Header; + + $comments = [$comments] + unless ref($comments) eq 'ARRAY'; + + $found = !!List::Util::first { /legacy code/ } @{$comments}; + } + + if ($PDL::Astro_FITS_Header) { + ok( !$found, "used Astro::FITS::Header" ); + } + else { + ok( $found, "used internal legacy code" ); + } }; From 5196adf35d10b8076b8043c27a6bd27a6a9da094 Mon Sep 17 00:00:00 2001 From: Diab Jerius Date: Thu, 17 Apr 2025 19:04:29 -0400 Subject: [PATCH 11/14] writing bintables is not supported without Astro::FITS::Header --- t/fits.t | 16 +++++++++------- 1 file changed, 9 insertions(+), 7 deletions(-) diff --git a/t/fits.t b/t/fits.t index a386a4caa..d6e900a4e 100644 --- a/t/fits.t +++ b/t/fits.t @@ -438,16 +438,18 @@ subtest 'write null hdu with correct module' => sub { subtest 'accept scalar (0D) ndarrays' => sub { subtest 'bintable' => sub { - my ( $fh, $file ) = tfile; - lives_ok { wfits { x => pdl(3) }, $file } 'write column'; - my $got = rfits($file); - is_pdl( $got->{X}, pdl( [3] ), "got data" ); - + SKIP: { + skip 'require Astro::FITS::Header for bintables', 2 + unless $PDL::Astro_FITS_Header; + my ( $fh, $file ) = tfile; + lives_ok { wfits { x => pdl(3) }, $file } 'write column'; + my $got = rfits($file); + is_pdl( $got->{X}, pdl( [3] ), "got data" ); + } }; subtest 'image' => sub { - my ( $fh, $file ) = tfile( UNLINK => 0 ); - diag $file; + my ( $fh, $file ) = tfile; lives_ok { wfits pdl(3), $file } 'write image'; my $got; lives_ok { $got = rfits($file) } 'read image'; From 1bbcaa504e8efb09ed4038ffe895d134851b18bb Mon Sep 17 00:00:00 2001 From: Diab Jerius Date: Thu, 17 Apr 2025 19:05:21 -0400 Subject: [PATCH 12/14] let t/fits-noaht.t take care of the case where Astro::FITS::Header is not present --- t/fits.t | 2 -- 1 file changed, 2 deletions(-) diff --git a/t/fits.t b/t/fits.t index d6e900a4e..388063abd 100644 --- a/t/fits.t +++ b/t/fits.t @@ -196,8 +196,6 @@ subtest 'Astro::FITS::Header' => sub { subtest 'Internal FITS Header regression tests' => sub { - local $PDL::Astro_FITS_HEADER = 0; - subtest 'r/wfits bug #1' => sub { local $| = 1; my $a1 = [ 1, 2 ]; From ea098c3ec75155ca1e246a06fe83481363ff9334 Mon Sep 17 00:00:00 2001 From: Diab Jerius Date: Thu, 17 Apr 2025 19:06:07 -0400 Subject: [PATCH 13/14] non Test2 provided skip requires the number of tests skipped --- t/fits.t | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/t/fits.t b/t/fits.t index 388063abd..a46501001 100644 --- a/t/fits.t +++ b/t/fits.t @@ -322,7 +322,7 @@ subtest 'tilde path expansion' => sub { SKIP: { my $tilde_dir = <~>; - skip '~ directory is not writeable' + skip '~ directory is not writeable', 4 unless -w $tilde_dir; my ( $fh, $file ) = tfile( DIR => $tilde_dir, SUFFIX => '.fits' ); From d9a7413c6ead2374dcd979de24019466749e3709 Mon Sep 17 00:00:00 2001 From: Diab Jerius Date: Thu, 17 Apr 2025 19:06:32 -0400 Subject: [PATCH 14/14] simplify --- t/fits.t | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) diff --git a/t/fits.t b/t/fits.t index a46501001..ff60c7cfc 100644 --- a/t/fits.t +++ b/t/fits.t @@ -123,16 +123,15 @@ subtest 'Astro::FITS::Header' => sub { ##my $f = float(1,0,-1,2) + i * float( 0,1,2,-1 ); my $table2 = do { - my $table = { + my ( $fh, $file ) = tfile; + wfits { ACOL => $x, BCOL => $y, CCOL => $c, DCOL => $d, ECOL => $e, - ## FCOL => $f, - }; - my ( $fh, $file ) = tfile; - wfits $table, $file; + }, + $file; rfits $file; };