my
$prog_iter
;
(
undef
,
my
$data
) = tempfile(
"rawXXXX"
,
SUFFIX
=>
'_data'
,
TMPDIR
=>1);
my
$hdr
=
$data
.
'.hdr'
;
(
my
$head
=
$data
) =~ s/_data$//;
$|=1;
my
$ndata
= 10;
my
$Verbose
= 0;
my
$DEBUG
= 0;
$PDL::Verbose
= 0;
$Verbose
|=
$PDL::Verbose
;
my
$null
=
' 2>'
. File::Spec->devnull;
my
$datalen
=
length
(
$data
);
eval
"use PDL::Slatec"
;
plan
skip_all
=>
"Skipped tests as no Slatec"
if
$@;
plan
skip_all
=>
"temp file path too long for f77 ($datalen chars), skipping all tests"
if
$datalen
> 70;
eval
"use ExtUtils::F77"
;
plan
skip_all
=>
"Skip all tests as ExtUtils::F77 not found"
if
$@;
my
$F77
;
my
$F77flags
;
if
(
$ExtUtils::F77::VERSION
> 1.03) {
$F77
= ExtUtils::F77::compiler();
$F77flags
= ExtUtils::F77::cflags();
}
else
{
$F77
=
'f77'
;
$F77flags
=
''
;
}
sub
byte4swap {
my
(
$file
) =
@_
;
my
(
$ofile
) =
$file
.
'~'
;
my
(
$word
);
open
my
$ifh
,
"<"
,
$file
or
die
"Can't open $file to read: $!"
;
open
my
$ofh
,
">"
,
$ofile
or
die
"Can't open $ofile to write: $!"
;
binmode
$ifh
;
binmode
$ofh
;
while
( !
eof
$ifh
) {
read
$ifh
,
$word
, 4;
$word
=
pack
'c4'
,
reverse
unpack
'c4'
,
$word
;
print
$ofh
$word
;
}
close
$ofh
;
close
$ifh
;
rename
$ofile
,
$file
;
}
sub
byte8swap {
my
(
$file
) =
@_
;
my
(
$ofile
) =
$file
.
'~'
;
my
(
$word
);
open
my
$ifh
,
"<"
,
$file
or
die
"Can't open $file to read: $!"
;
open
my
$ofh
,
">"
,
$ofile
or
die
"Can't open $ofile to write: $!"
;
binmode
$ifh
;
binmode
$ofh
;
while
( !
$ifh
->
eof
) {
read
$ifh
,
$word
, 8;
$word
=
pack
'c8'
,
reverse
unpack
'c8'
,
$word
;
print
$ofh
$word
;
}
$ofh
->
close
;
$ifh
->
close
;
rename
$ofile
,
$file
;
}
sub
codefold {
my
$oldcode
=
shift
;
my
$newcode
=
''
;
eval
{
my
$in
= IO::String->new(
$oldcode
);
my
$out
= IO::String->new(
$newcode
);
my
$line
=
''
;
while
(
$line
= <
$in
>) {
chomp
$line
;
print
$out
"$line\n"
if
$line
=~ /^\S/;
while
(
$line
ne
''
) {
print
$out
substr
(
$line
,0,72) .
"\n"
;
if
(
length
(
$line
) > 72 ) {
substr
(
$line
,0,72) =
' $'
;
}
else
{
$line
=
''
;
}
}
}
close
(
$in
);
close
(
$out
);
};
$newcode
=
$oldcode
if
$@;
return
$newcode
;
}
sub
createData {
my
$head
=
shift
;
my
$code
=
shift
;
if
($^O =~ /mswin32/i) {
die
'$head ['
.
$head
.
'] should match /^[A-Z]:/'
unless
$head
=~ /^[A-Z]:/;
}
else
{
die
'$head ['
.
$head
.
'] must start with a / or ./'
unless
$head
=~ /^(\/|\.\/)/;
}
my
$file
= ${head} .
'.f'
;
my
$prog
=
$head
;
open
my
$fh
,
">"
,
$file
or
die
"ERROR: Unable to write F77 code to $file: $!\n"
;
print
$fh
$code
;
close
$fh
;
if
(-e
"$prog$Config{_exe}"
) {
my
$success
=
unlink
"$prog$Config{_exe}"
;
if
(!
$success
) {
warn
"Unable to delete $prog$Config{_exe}, generating new name"
if
$Verbose
;
$prog_iter
++;
$prog
.=
$prog_iter
;
};
}
system
(
"$F77 $F77flags -o $prog$Config{_exe} $file"
.
((
$Verbose
||
$DEBUG
)?
''
:
$null
));
unlink
$data
if
-f
$data
;
system
(
$prog
);
die
"ERROR: code did not create data file $data\n"
unless
-e
$data
;
unlink
$prog
.
$Config
{_exe},
$file
;
}
my
%types
= (
'float'
=>
'real*4'
,
'double'
=>
'real*8'
,
'long'
=>
'integer*4'
,
'short'
=>
'integer*2'
,
'byte'
=>
'character'
);
my
$exprf
=
'100.*sin(0.01* i)'
;
my
$exprp
=
'100.*sin(0.01*$i)'
;
my
$expr2f
=
'100.*sin(0.01* i)*cos(0.01* j)'
;
my
$expr2p
=
'(outer(sin(0.01*$i),cos(0.01*$j),$c=null),$c*100.)'
;
my
$j
= sequence(
$ndata
)+1;
my
$i
=
$j
;
my
$c
;
foreach
my
$pdltype
(
'float'
,
'long'
) {
print
STDERR
"Type $pdltype swapped\n"
if
$Verbose
;
my
$f77type
=
$types
{
$pdltype
};
my
$val
=
$exprf
;
$val
=
"char(int($val))"
if
$pdltype
eq
'byte'
;
my
$code
=
<<"EOT";
c Program to test i/o of F77 unformatted files
program rawtest
implicit none
integer i
$f77type a($ndata)
do i = 1, $ndata
a(i) = $val
enddo
open(8,file=
\$'$data'
\$,status='new',form='unformatted')
i = $ndata
write (8) i
write (8) a
close(8)
end
EOT
createData
$head
, codefold(
$code
);
byte4swap(
$data
);
open
(FILE,
"> $hdr"
);
print
FILE
<<"EOT";
# FlexRaw file header
f77
long 1 1
# Data
$pdltype 1 $ndata
EOT
close
(FILE);
my
@a
= readflex(
$data
);
ok
my
$ok
= (
$a
[0]->at(0) ==
$ndata
);
my
$res
=
eval
"$pdltype $exprp"
;
is_pdl
$res
,
$a
[1],
"readflex $pdltype w hdr file"
;
open
(FILE,
">$hdr"
);
print
FILE
<<"EOT";
# FlexRaw file header
swap
f77
# now for data specifiers
long 1 1
# Data
$pdltype 1 $ndata
EOT
close
(FILE);
@a
= readflex(
$data
);
unlink
$hdr
;
ok
$ok
= (
$a
[0]->at(0) ==
$ndata
);
$res
=
eval
"$pdltype $exprp"
;
is_pdl
$res
,
$a
[1],
"readflex $pdltype w hdr file (explicit swap)"
;
$ok
= 1;
my
$header
= [ {
Type
=>
'f77'
},
{
Type
=>
'long'
,
NDims
=> 1,
Dims
=> [ 1 ] },
{
Type
=>
$pdltype
,
NDims
=> 1,
Dims
=> [
$ndata
] } ];
@a
= readflex(
$data
,
$header
);
unlink
$data
;
ok
$ok
= (
$a
[0]->at(0) ==
$ndata
);
$res
=
eval
"$pdltype $exprp"
;
is_pdl
$res
,
$a
[1],
"readflex $pdltype w hdr array"
;
}
foreach
my
$pdltype
(
sort
keys
%types
) {
print
STDERR
"Type $pdltype\n"
if
$Verbose
;
my
$f77type
=
$types
{
$pdltype
};
my
$val
=
$exprf
;
$val
=
"char(int($val))"
if
$pdltype
eq
'byte'
;
my
$code
=
<<"EOT";
c Program to test i/o of F77 unformatted files
program rawtest
implicit none
integer i
$f77type a($ndata)
do i = 1, $ndata
a(i) = $val
enddo
open(8,file=
\$'$data'
\$,status='new',form='unformatted')
i = $ndata
write (8) i,a
close(8)
end
EOT
createData
$head
, codefold(
$code
);
open
(FILE,
">$hdr"
);
print
FILE
<<"EOT";
# FlexRaw file header
f77
long 1 1
# Data
$pdltype 1 $ndata
EOT
close
(FILE);
my
@a
= readflex(
$data
);
unlink
$data
,
$hdr
;
ok
my
$ok
= (
$a
[0]->at(0) ==
$ndata
);
my
$res
=
eval
"$pdltype $exprp"
;
is_pdl
$res
,
$a
[1],
"f77 1D $pdltype data"
;
}
foreach
my
$pdltype
(
sort
keys
%types
) {
print
STDERR
"Type $pdltype\n"
if
$Verbose
;
my
$f77type
=
$types
{
$pdltype
};
my
$val
=
$exprf
;
$val
=
"char(int($val))"
if
$pdltype
eq
'byte'
;
my
$code
=
<<"EOT";
c Program to test i/o of F77 unformatted files
program rawtest
implicit none
integer i
$f77type a($ndata)
do i = 1, $ndata
a(i) = $val
enddo
open(8,file=
\$'$data'
\$,status='new',form='unformatted')
i = $ndata
write (8) i,a
close(8)
end
EOT
createData
$head
, codefold(
$code
);
open
(FILE,
">$hdr"
);
print
FILE
<<"EOT";
# FlexRaw header file
byte 1 4
long 1 # Test comments
1 Tricky comment
# Data
$pdltype 1 $ndata
byte 1 4
# and hanging EOF
EOT
close
(FILE);
my
@a
= readflex(
$data
);
unlink
$data
,
$hdr
;
ok
my
$ok
= (
$a
[1]->at(0) ==
$ndata
);
my
$res
=
eval
"$pdltype $exprp"
;
is_pdl
$res
,
$a
[2],
"no f77, 1D $pdltype data"
;
}
foreach
my
$pdltype
(
sort
keys
%types
) {
print
STDERR
"Type $pdltype\n"
if
$Verbose
;
my
$f77type
=
$types
{
$pdltype
};
my
$val
=
$expr2f
;
$val
=
"char(int($val))"
if
$pdltype
eq
'byte'
;
my
$code
=
<<"EOT";
c Program to test i/o of F77 unformatted files
program rawtest
implicit none
integer i, j
$f77type a($ndata, $ndata)
do i = 1, $ndata
do j = 1, $ndata
a(i,j) = $val
enddo
enddo
open(8,file=
\$'$data'
\$,status='new',form='unformatted')
i = $ndata
write (8) i,a
close(8)
end
EOT
createData
$head
, codefold(
$code
);
open
(FILE,
">$hdr"
);
print
FILE
<<"EOT";
# FlexRaw file header
f77
long 1 1
# Data
$pdltype 2 $ndata $ndata
EOT
close
(FILE);
my
@a
= readflex(
$data
);
unlink
$data
,
$hdr
;
ok
my
$ok
= (
$a
[0]->at(0) ==
$ndata
);
my
$res
=
eval
"$pdltype $expr2p"
;
is_pdl
$res
,
$a
[1],
"f77 format 2D $pdltype data"
;
}
print
STDERR
"Combined types case\n"
if
$Verbose
;
my
$code
=
<<"EOT";
c Program to test i/o of F77 unformatted files
program rawtest
implicit none
character a
integer*2 i
integer*4 l
real*4 f
real*8 d
d = 4*atan(1.)
f = d
l = 10**d
i = l
a = ' '
open(8,file=
\$'$data'
\$,status='new',form='unformatted')
c Choose bad boundaries...
write (8) a,i,l,f,d
close(8)
end
EOT
createData
$head
, codefold(
$code
);
open
(FILE,
">$hdr"
);
print
FILE
<<"EOT";
# FlexRaw file header
byte 1 4
byte 0
short 0
long 0
float 0
double 0
byte 1 4
EOT
close
(FILE);
my
@a
= readflex(
$data
);
shift
@a
;
my
$d
= double pdl (4
*atan2
(1,1));
my
$f
= float (
$d
);
my
$l
= long (10*
*$f
);
$i
= short (
$l
);
my
$x
= byte (32);
my
@req
= (
$x
,
$i
,
$l
,
$f
,
$d
);
foreach
(
@req
) {
my
$h
=
shift
@a
;
is_pdl
$h
,
$_
,
"readflex combined types"
;
}
SKIP: {
my
$compress
= File::Which::which(
'compress'
) ?
'compress'
:
'gzip'
;
$compress
=
'gzip'
if
$^O eq
'cygwin'
;
if
( $^O eq
'MSWin32'
) {
skip
"No compress or gzip command on MSWin32"
, 1
unless
File::Which::which(
$compress
) and $^O;
}
0 ==
system
"$compress -c $data > ${data}.Z"
or diag
"system $compress -c $data >${data}.Z failed: $?"
;
unlink
(
$data
);
@a
= readflex(
$data
);
ok
$#a
==6;
@a
= readflex(
"${data}.Z"
);
ok
$#a
==6;
my
$NULL
= File::Spec->devnull();
0 ==
system
"gunzip -q ${data}.Z >$NULL 2>&1"
or diag
"system gunzip -q ${data}.Z failed: $?"
;
0 ==
system
"gzip -q $data >$NULL 2>&1"
or diag
"system gzip -q $data failed: $?"
;
@a
= readflex(
$data
);
ok
$#a
==6;
@a
= readflex(
"${data}.gz"
);
ok
$#a
==6;
shift
@a
;
unlink
"${data}.gz"
,
$hdr
;
$d
= double pdl (4
*atan2
(1,1));
$f
= float (
$d
);
$l
= long (10*
*$f
);
$i
= short (
$l
);
$x
= byte (32);
@req
= (
$x
,
$i
,
$l
,
$f
,
$d
);
foreach
(
@req
) {
my
$h
=
shift
@a
;
is_pdl
$h
,
$_
,
"readflex compressed data"
;
}
}
my
$flexhdr
= writeflex(
$data
,
@req
);
writeflexhdr(
$data
,
$flexhdr
)
unless
$PDL::IO::FlexRaw::writeflexhdr
;
@a
= readflex(
$data
);
unlink
$hdr
;
foreach
(
@req
) {
is_pdl
shift
@a
,
$_
,
"writeflex combined data types, hdr file"
;
}
@a
= readflex(
$data
,
$flexhdr
);
foreach
(
@req
) {
is_pdl
shift
@a
,
$_
,
"writeflex combined data types, readflex hdr array"
;
}
unlink
$data
;
$#a
= -1;
foreach
(
@req
) {
push
@a
,
$_
->dummy(0,10);
}
$flexhdr
= writeflex(
$data
,
@a
);
$flexhdr
= [ {
Type
=>
'byte'
,
NDims
=> 1,
Dims
=> 10},
{
Type
=>
'short'
,
NDims
=> 1,
Dims
=> 10},
{
Type
=>
'long'
,
NDims
=> 1,
Dims
=> 10},
{
Type
=>
'float'
,
NDims
=> 1,
Dims
=> 10},
{
Type
=>
'double'
,
NDims
=> 1,
Dims
=> 10} ];
@a
= readflex(
$data
,
$flexhdr
);
unlink
$data
;
foreach
(
@req
) {
is_pdl slice(
shift
@a
,
"(0)"
),
$_
,
"writeflex combined types[10], readflex explicit hdr array"
;
}
map
{
$_
=
$_
->dummy(0,10)}
@req
;
$flexhdr
= writeflex(
$data
,
@req
);
writeflexhdr(
$data
,
$flexhdr
)
unless
$PDL::IO::FlexRaw::writeflexhdr
;
@a
= readflex(
$data
);
unlink
$data
;
unlink
$hdr
;
foreach
(
@req
) {
is_pdl
shift
@a
,
$_
,
"multidimensional data"
;
}
@req
= (byte(1..3),
long(5..10),
float(10..15)->reshape(3,2)/100,
double(0..99)/1e8);
$flexhdr
= writeflex(
$data
,
@req
);
open
(IN,
$data
);
@a
= readflex(\
*IN
,
$flexhdr
);
foreach
(
@req
) {
is_pdl
shift
@a
,
$_
,
"readflex with file handle"
;
}
close
(IN);
unlink
$data
;
open
(OUT,
">$data"
);
$flexhdr
= writeflex(\
*OUT
,
@req
);
close
(OUT);
@a
= readflex(
$data
,
$flexhdr
);
foreach
(
@req
) {
is_pdl
shift
@a
,
$_
,
"writeflex with file handle"
;
}
unlink
$data
;
done_testing;