1
2# Test routine for PDL::IO::Misc module
3
4use strict;
5
6use PDL::LiteF;
7use PDL::IO::Misc;
8
9use File::Temp qw( tempfile tempdir );
10
11kill 'INT',$$  if $ENV{UNDER_DEBUGGER}; # Useful for debugging.
12
13use Test::More tests => 23;
14
15sub tapprox {
16        my($a,$b) = @_;
17        my $c = abs($a-$b);
18        my $d = max($c);
19        $d < 0.0001;
20}
21
22my $tempd = tempdir( CLEANUP => 1 ) or die "Couldn't get tempdir\n";
23my ($fileh,$file) = tempfile( DIR => $tempd );
24
25############# Test rcols with colsep and missing fields ###################
26
27print $fileh <<EOD;
281,6,11
292,7,
303,8,13
314,,14
325,10,15
33EOD
34close($fileh);
35
36{
37   local $PDL::undefval = -1;
38   $a = rcols $file, [], { colsep=>',' };
39}
40
41is( (sum($a<0)==2 && $a->getdim(0)==5 && $a->getdim(1)==3), 1, "rcols with undefval and missing cols" );
42unlink $file || warn "Could not unlink $file: $!";
43
44############# Test rcols with filename and pattern #############
45
46($fileh,$file) = tempfile( DIR => $tempd );
47print $fileh <<EOD;
481 2
492 33 FOO
503 7
514 9  FOO
525 66
53EOD
54close($fileh);
55
56($a,$b) = rcols $file,0,1;
57$a = long($a); $b=long($b);
58
59is( (sum($a)==15 && max($b)==66 && $b->getdim(0)==5), 1, "rcols with filename" );
60
61($a,$b) = rcols $file, "/FOO/",0,1;
62$a = long($a);
63$b=long($b);
64
65is( (sum($a)==6 && max($b)==33 && $b->getdim(0)==2), 1, "rcols with filename + pattern" );
66
67############# Test rcols with file handle with nothing left #############
68
69open my $fh, '<', $file;
70# Pull in everything:
71my @slurp = <$fh>;
72# Now apply rcols:
73$@ = '';
74$a = eval { rcols $fh };
75is($@, '', 'rcols does not die on a used file handle');
76close $fh;
77
78############### Test rgrep with FILEHANDLE #####################
79
80($fileh,$file) = tempfile( DIR => $tempd );
81print $fileh <<EOD;
82foo"1" -2-
83foo"2"  Test -33-
84foo"3" jvjtvbjktrbv -7-
85foo"4" -9-
86fjrhfiurhe foo"5" jjjj -66-
87EOD
88close($fileh);
89
90open(OUT, $file) || die "Can not open $file for reading\n";
91($a,$b) = rgrep {/foo"(.*)".*-(.*)-/} *OUT;
92$a = long($a); $b=long($b);
93close(OUT);
94
95is( (sum($a)==15 && max($b)==66 && $b->getdim(0)==5), 1, "rgrep" );
96
97########### Explicit test of byte swapping #################
98
99$a = short(3); $b = long(3); # $c=long([3,3]);
100bswap2($a); bswap4($b);
101is(sum($a)==768 && sum($b)==50331648,1,"bswap2");
102
103############# Test rasc  #############
104
105($fileh,$file) = tempfile( DIR => $tempd );
106print $fileh <<EOD;
1070.231862613
1080.20324005
1090.067813045
1100.040103501
1110.438047631
1120.283293628
1130.375427346
1140.195821617
1150.189897617
1160.035941205
1170.339051483
1180.096540854
1190.25047197
1200.579782013
1210.236164184
1220.221568561
1230.009776015
1240.290377604
1250.785569601
1260.260724391
127
128EOD
129close($fileh);
130
131$a = PDL->null;
132$a->rasc($file,20);
133is( abs($a->sum - 5.13147) < .01, 1, "rasc on null piddle" );
134
135$b = zeroes(float,20,2);
136$b->rasc($file);
137is( abs($b->sum - 5.13147) < .01, 1, "rasc on existing piddle" );
138
139eval '$b->rasc("file_that_does_not_exist")';
140like( $@, qr/Can't open/, "rasc on non-existant file" );
141
142unlink $file || warn "Could not unlink $file: $!"; # clean up
143
144#######################################################
145# Tests of rcols() options
146#   EXCLUDE/INCLUDE/LINES/DEFTYPE/TYPES
147
148($fileh,$file) = tempfile( DIR => $tempd );
149print $fileh <<EOD;
1501 2
151# comment line
1523 4
153-5 6
1547 8
155EOD
156close($fileh);
157
158($a,$b) = rcols $file,0,1;
159is( $a->nelem==4 && sum($a)==6 && sum($b)==20, 1,
160    "rcols: default" );
161
162($a,$b) = rcols \*DATA,0,1;
163is( $a->nelem==4 && sum($a)==6 && sum($b)==20, 1,
164    "rcols: pipe" );
165
166($a,$b) = rcols $file,0,1, { INCLUDE => '/^-/' };
167is( $a->nelem==1 && $a->at(0)==-5 && $b->at(0)==6, 1,
168    "rcols: include pattern" );
169
170($a,$b) = rcols $file,0,1, { LINES => '-2:0' };
171is( $a->nelem==3 && tapprox($a,pdl(-5,3,1)) && tapprox($b,pdl(6,4,2)), 1,
172    "rcols: lines option" );
173
174use PDL::Types;
175($a,$b) = rcols $file, { DEFTYPE => long };
176is( $a->nelem==4 && $a->get_datatype==$PDL_L && $b->get_datatype==$PDL_L, 1,
177    "rcols: deftype option" );
178
179($a,$b) = rcols $file, { TYPES => [ ushort ] };
180is( $a->nelem==4 && $a->get_datatype==$PDL_US && $b->get_datatype==$PDL_D, 1,
181    "rcols: types option" );
182
183is( UNIVERSAL::isa($PDL::IO::Misc::deftype,"PDL::Type"), 1,
184    "PDL::IO::Misc::deftype is a PDL::Type object" );
185is( $PDL::IO::Misc::deftype->[0], double->[0],
186    "PDL::IO::Misc::deftype check" );
187
188$PDL::IO::Misc::deftype = short;
189($a,$b) = rcols $file;
190is( $a->get_datatype, short->[0], "rcols: can read in as 'short'" );
191
192unlink $file || warn "Could not unlink $file: $!";
193
194($fileh,$file) = tempfile( DIR => $tempd );
195eval { wcols $a, $b, $fileh };
196is(!$@,1, "wcols" );
197unlink $file || warn "Could not unlink $file: $!";
198
199($fileh,$file) = tempfile( DIR => $tempd );
200eval { wcols $a, $b, $fileh, {FORMAT=>"%0.3d %0.3d"}};
201is(!$@,1, "wcols FORMAT option");
202unlink $file || warn "Could not unlink $file: $!";
203
204($fileh,$file) = tempfile( DIR => $tempd );
205eval { wcols "%d %d", $a, $b, $fileh;};
206is(!$@,1, "wcols format_string");
207unlink $file || warn "Could not unlink $file: $!";
208
209($fileh,$file) = tempfile( DIR => $tempd );
210eval { wcols "arg %d %d", $a, $b, $fileh, {FORMAT=>"option %d %d"};};
211is(!$@,1, "wcols format_string override");
212
213open($fileh,"<",$file) or warn "Can't open $file: $!";
214chomp(my $line=readline(*$fileh));
215like(my $line=readline($fileh),qr/^arg/, "wcols format_string obeyed");
216unlink $file || warn "Could not unlink $file: $!";
217
2181;
219
220__DATA__
2211 2
222# comment line
2233 4
224-5 6
2257 8
226