perldelta for 368ac47cccd4
[perl.git] / ext / XS-Typemap / t / Typemap.t
1 BEGIN {
2     require Config; import Config;
3     if ($Config{'extensions'} !~ /\bXS\/Typemap\b/) {
4         print "1..0 # Skip: XS::Typemap was not built\n";
5         exit 0;
6     }
7 }
8
9 use Test::More tests => 156;
10
11 use strict;
12 #catch WARN_INTERNAL type errors, and anything else unexpected
13 use warnings FATAL => 'all';
14 use XS::Typemap;
15
16 pass();
17
18 # Some inheritance trees to check ISA relationships
19 BEGIN {
20   package intObjPtr::SubClass;
21   use parent '-norequire', qw/ intObjPtr /;
22   sub xxx { 1; }
23 }
24
25 BEGIN {
26   package intRefIvPtr::SubClass;
27   use parent '-norequire', qw/ intRefIvPtr /;
28   sub xxx { 1 }
29 }
30
31 # T_SV - standard perl scalar value
32 note("T_SV");
33 my $sv = "Testing T_SV";
34 is( T_SV($sv), $sv);
35
36 # T_SVREF - reference to Scalar
37 note("T_SVREF");
38 $sv .= "REF";
39 my $svref = \$sv;
40 is( T_SVREF($svref), $svref );
41 is( ${ T_SVREF($svref) }, $$svref );
42
43 # Now test that a non reference is rejected
44 # the typemaps croak
45 eval { T_SVREF( "fail - not ref" ) };
46 ok( $@ );
47
48 note("T_SVREF_REFCOUNT_FIXED");
49 is( T_SVREF_REFCOUNT_FIXED($svref), $svref );
50 is( ${ T_SVREF_REFCOUNT_FIXED($svref) }, $$svref );
51 eval { T_SVREF_REFCOUNT_FIXED( "fail - not ref" ) };
52 ok( $@ );
53
54
55 # T_AVREF - reference to a perl Array
56 note("T_AVREF");
57 my @array;
58 is( T_AVREF(\@array), \@array);
59 # Now test that a non array ref is rejected
60 eval { T_AVREF( \$sv ) };
61 ok( $@ );
62
63 # T_AVREF_REFCOUNT_FIXED  - reference to a perl Array, refcount fixed
64 note("T_AVREF_REFCOUNT_FIXED");
65 is( T_AVREF_REFCOUNT_FIXED(\@array), \@array);
66 # Now test that a non array ref is rejected
67 eval { T_AVREF_REFCOUNT_FIXED( \$sv ) };
68 ok( $@ );
69
70
71 # T_HVREF - reference to a perl Hash
72 note("T_HVREF");
73 my %hash;
74 is( T_HVREF(\%hash), \%hash);
75 # Now test that a non hash ref is rejected
76 eval { T_HVREF( \@array ) };
77 ok( $@ );
78
79
80 # T_HVREF_REFCOUNT_FIXED - reference to a perl Hash, refcount fixed
81 note("T_HVREF_REFCOUNT_FIXED");
82 is( T_HVREF_REFCOUNT_FIXED(\%hash), \%hash);
83 # Now test that a non hash ref is rejected
84 eval { T_HVREF_REFCOUNT_FIXED( \@array ) };
85 ok( $@ );
86
87
88 # T_CVREF - reference to perl subroutine
89 note("T_CVREF");
90 my $sub = sub { 1 };
91 is( T_CVREF($sub), $sub );
92 # Now test that a non code ref is rejected
93 eval { T_CVREF( \@array ) };
94 ok( $@ );
95
96 is( T_CVREF_REFCOUNT_FIXED($sub), $sub );
97 # Now test that a non code ref is rejected
98 eval { T_CVREF_REFCOUNT_FIXED( \@array ) };
99 ok( $@ );
100
101
102 # T_SYSRET - system return values
103 note("T_SYSRET");
104 # first check success
105 ok( T_SYSRET_pass );
106 # ... now failure
107 is( T_SYSRET_fail, undef);
108
109 # T_UV - unsigned integer
110 note("T_UV");
111 is( T_UV(5), 5 );    # pass
112 isnt( T_UV(-4), -4); # fail
113
114 # T_U_INT - unsigned integer with (unsigned int) cast
115 note("T_U_INT");
116 is( T_U_INT(5), 5 );    # pass
117 isnt( T_U_INT(-4), -4); # fail
118
119 # T_IV - signed integer
120 # T_INT - signed integer with cast
121 # T_LONG - signed integer with cast to IV
122 # T_SHORT - signed short
123 for my $t (['T_IV', \&T_IV],
124            ['T_INT', \&T_INT],
125            ['T_LONG', \&T_LONG],
126            ['T_SHORT', \&T_SHORT])
127 {
128   note($t->[0]);
129   is( $t->[1]->(5), 5);
130   is( $t->[1]->(-4), -4);
131   is( $t->[1]->(4.1), int(4.1));
132   is( $t->[1]->("52"), "52");
133   isnt( $t->[1]->(4.5), 4.5); # failure
134 }
135
136 if ($Config{shortsize} == 2) {
137   isnt( T_SHORT(32801), 32801 );
138 }
139 else {
140   pass(); # e.g. Crays have shortsize 4 (T3X) or 8 (CXX and SVX)
141 }
142
143 # T_ENUM - enum list
144 ok( T_ENUM(), 'T_ENUM' ); # just hope for a true value
145
146 # T_BOOL - boolean
147 note("T_BOOL");
148
149 ok( T_BOOL(52) );
150 ok( ! T_BOOL(0) );
151 ok( ! T_BOOL('') );
152 ok( ! T_BOOL(undef) );
153
154 {
155   # these attempt to modify a read-only value
156   ok( !eval { T_BOOL_2(52); 1 } );
157   ok( !eval { T_BOOL_2(0); 1 } );
158   ok( !eval { T_BOOL_2(''); 1 } );
159   ok( !eval { T_BOOL_2(undef); 1 } );
160 }
161
162 {
163     my ($in, $out);
164     $in = 1;
165     T_BOOL_OUT($out, $in);
166     ok($out, "T_BOOL_OUT, true in");
167     $in = 0;
168     $out = 1;
169     T_BOOL_OUT($out, $in);
170     ok(!$out, "T_BOOL_OUT, false in");
171 }
172
173 # T_U_SHORT aka U16
174 note("T_U_SHORT");
175 is( T_U_SHORT(32000), 32000);
176 if ($Config{shortsize} == 2) {
177   isnt( T_U_SHORT(65536), 65536); # probably dont want to test edge cases
178 } else {
179   ok(1); # e.g. Crays have shortsize 4 (T3X) or 8 (CXX and SVX)
180 }
181
182 # T_U_LONG aka U32
183 note("T_U_LONG");
184 is( T_U_LONG(65536), 65536);
185 isnt( T_U_LONG(-1), -1);
186
187 # T_CHAR
188 note("T_CHAR");
189 is( T_CHAR("a"), "a");
190 is( T_CHAR("-"), "-");
191 is( T_CHAR(chr(128)),chr(128));
192 isnt( T_CHAR(chr(256)), chr(256));
193
194 # T_U_CHAR
195 note("T_U_CHAR");
196 is( T_U_CHAR(127), 127);
197 is( T_U_CHAR(128), 128);
198 isnt( T_U_CHAR(-1), -1);
199 isnt( T_U_CHAR(300), 300);
200
201 # T_FLOAT
202 # limited precision
203 is( sprintf("%6.3f",T_FLOAT(52.345)), sprintf("%6.3f",52.345), "T_FLOAT");
204
205 # T_NV
206 is( T_NV(52.345), 52.345, "T_NV" );
207
208 # T_DOUBLE
209 is( sprintf("%6.3f",T_DOUBLE(52.345)), sprintf("%6.3f",52.345), "T_DOUBLE" );
210
211 # T_PV
212 note("T_PV");
213 is( T_PV("a string"), "a string");
214 is( T_PV(52), 52);
215 ok !defined T_PV_null, 'RETVAL = NULL returns undef for char*';
216 {
217     use warnings NONFATAL => 'all';
218     my $uninit;
219     local $SIG{__WARN__} = sub { ++$uninit if shift =~ /uninit/ };
220     () = ''.T_PV_null;
221     is $uninit, 1, 'uninit warning from NULL returned from char* func';
222 }
223
224 # T_PTR
225 my $t = 5;
226 my $ptr = T_PTR_OUT($t);
227 is( T_PTR_IN( $ptr ), $t, "T_PTR" );
228
229 # T_PTRREF
230 note("T_PTRREF");
231 $t = -52;
232 $ptr = T_PTRREF_OUT( $t );
233 is( ref($ptr), "SCALAR");
234 is( T_PTRREF_IN( $ptr ), $t );
235
236 # test that a non-scalar ref is rejected
237 eval { T_PTRREF_IN( $t ); };
238 ok( $@ );
239
240 # T_PTROBJ
241 note("T_PTROBJ");
242 $t = 256;
243 $ptr = T_PTROBJ_OUT( $t );
244 is( ref($ptr), "intObjPtr");
245 is( $ptr->T_PTROBJ_IN, $t );
246
247 # check that normal scalar refs fail
248 eval {intObjPtr::T_PTROBJ_IN( \$t );};
249 ok( $@ );
250
251 # check that inheritance works
252 bless $ptr, "intObjPtr::SubClass";
253 is( ref($ptr), "intObjPtr::SubClass");
254 is( $ptr->T_PTROBJ_IN, $t );
255
256 # Skip T_REF_IV_REF
257
258 # T_REF_IV_PTR
259 note("T_REF_IV_PTR");
260 $t = -365;
261 $ptr = T_REF_IV_PTR_OUT( $t );
262 is( ref($ptr), "intRefIvPtr");
263 is( $ptr->T_REF_IV_PTR_IN(), $t);
264
265 # inheritance should not work
266 bless $ptr, "intRefIvPtr::SubClass";
267 eval { $ptr->T_REF_IV_PTR_IN };
268 ok( $@ );
269
270 # Skip T_PTRDESC
271
272 # Skip T_REFREF
273
274 # Skip T_REFOBJ
275
276 # T_OPAQUEPTR
277 note("T_OPAQUEPTR");
278 $t = 22;
279 my $p = T_OPAQUEPTR_IN( $t );
280 is( T_OPAQUEPTR_OUT($p), $t);
281
282 # T_OPAQUEPTR with a struct
283 note("T_OPAQUEPTR with a struct");
284 my @test = (5,6,7);
285 $p = T_OPAQUEPTR_IN_struct(@test);
286 my @result = T_OPAQUEPTR_OUT_struct($p);
287 is(scalar(@result),scalar(@test));
288 for (0..$#test) {
289   is($result[$_], $test[$_]);
290 }
291
292 # T_OPAQUE
293 note("T_OPAQUE");
294 $t = 48;
295 $p = T_OPAQUE_IN( $t );
296 is(T_OPAQUEPTR_OUT_short( $p ), $t); # Test using T_OPAQUEPTR
297 is(T_OPAQUE_OUT( $p ), $t );         # Test using T_OPQAQUE
298
299 # T_OPAQUE_array
300 note("T_OPAQUE: A packed array");
301
302 my @opq = (2,4,8);
303 my $packed = T_OPAQUE_array(@opq);
304 my @uopq = unpack("i*",$packed);
305 is(scalar(@uopq), scalar(@opq));
306 for (0..$#opq) {
307   is( $uopq[$_], $opq[$_]);
308 }
309
310 # T_PACKED
311 note("T_PACKED");
312 my $struct = T_PACKED_out(-4, 3, 2.1);
313 ok(ref($struct) eq 'HASH');
314 is_approx($struct->{a}, -4);
315 is_approx($struct->{b}, 3);
316 is_approx($struct->{c}, 2.1);
317 my @rv = T_PACKED_in($struct);
318 is(scalar(@rv), 3);
319 is_approx($rv[0], -4);
320 is_approx($rv[1], 3);
321 is_approx($rv[2], 2.1);
322
323 # T_PACKEDARRAY
324 SCOPE: {
325   note("T_PACKED_ARRAY");
326   my @d = (
327     -4, 3, 2.1,
328     2, 1, -15.3,
329     1,1,1
330   );
331   my @out;
332   push @out, {a => $d[$_*3], b => $d[$_*3+1], c => $d[$_*3+2]} for (0..2);
333   my $structs = T_PACKEDARRAY_out(@d);
334   ok(ref($structs) eq 'ARRAY');
335   is(scalar(@$structs), 3);
336   foreach my $i (0..2) {
337     my $s = $structs->[$i];
338     is(ref($s), 'HASH');
339     is_approx($s->{a}, $d[$i*3+0]);
340     is_approx($s->{b}, $d[$i*3+1]);
341     is_approx($s->{c}, $d[$i*3+2]);
342   }
343   my @rv = T_PACKEDARRAY_in($structs);
344   is(scalar(@rv), scalar(@d));
345   foreach my $i (0..$#d) {
346     is_approx($rv[$i], $d[$i]);
347   }
348 }
349
350 # Skip T_DATAUNIT
351
352 # Skip T_CALLBACK
353
354 # T_ARRAY
355 my @inarr = (1,2,3,4,5,6,7,8,9,10);
356 my @outarr = T_ARRAY( 5, @inarr );
357 is_deeply(\@outarr, \@inarr, "T_ARRAY");
358
359 # T_STDIO
360 note("T_STDIO");
361
362 # open a file in XS for write
363 my $testfile= "stdio.tmp";
364 # not everything below cleans up
365 END { 1 while unlink $testfile; }
366 my $fh = T_STDIO_open( $testfile );
367 ok( $fh );
368
369 # write to it using perl
370 if (defined $fh) {
371
372   my @lines = ("NormalSTDIO\n", "PerlIO\n");
373
374   # print to it using FILE* through XS
375   is( T_STDIO_print($fh, $lines[0]), length($lines[0]));
376
377   # print to it using normal perl
378   ok(print $fh "$lines[1]");
379
380   # close it using XS if using perlio, using Perl otherwise
381   ok( $Config{useperlio} ? T_STDIO_close( $fh ) : close( $fh ) );
382
383   # open from perl, and check contents
384   open($fh, '<', $testfile);
385   ok($fh);
386   my $line = <$fh>;
387   is($line,$lines[0]);
388   $line = <$fh>;
389   is($line,$lines[1]);
390
391   ok(close($fh));
392   ok(unlink($testfile));
393
394 } else {
395   for (1..8) {
396     skip("Skip Test not relevant since file was not opened correctly",0);
397   }
398 }
399
400 $fh = "FOO";
401 T_STDIO_open_ret_in_arg( $testfile, $fh);
402 ok( $fh ne "FOO", 'return io in arg open succeeds');
403 ok( print($fh "first line\n"), 'can print to return io in arg');
404 ok( close($fh), 'can close return io in arg');
405 $fh = "FOO";
406 #now with a bad file name to make sure $fh is written to on failure
407 my $badfile = $^O eq 'VMS' ? '?' : '';
408 T_STDIO_open_ret_in_arg( $badfile, $fh);
409 ok( !defined$fh, 'return io in arg open failed successfully');
410
411 # T_INOUT
412 note("T_INOUT");
413 SCOPE: {
414   my $buf = '';
415   local $| = 1;
416   open my $fh, "+<", \$buf or die $!;
417   my $str = "Fooo!\n";
418   print $fh $str;
419   my $fh2 = T_INOUT($fh);
420   seek($fh2, 0, 0);
421   is(readline($fh2), $str);
422   ok(print $fh2 "foo\n");
423   ok(close $fh);
424   # this fails because the underlying shared handle is already closed
425   ok(!close $fh2);
426 }
427
428 # T_IN
429 note("T_IN");
430 SCOPE: {
431   my $buf = "Hello!\n";
432   local $| = 1;
433   open my $fh, "<", \$buf or die $!;
434   my $fh2 = T_IN($fh);
435   is(readline($fh2), $buf);
436   local $SIG{__WARN__} = sub {die};
437   ok(not(eval {print $fh2 "foo\n"; 1}));
438 }
439
440 # T_OUT
441 note("T_OUT");
442 SCOPE: {
443   my $buf = '';
444   local $| = 1;
445   open my $fh, "+<", \$buf or die $!;
446   my $str = "Fooo!\n";
447   print $fh $str;
448   my $fh2 = T_OUT($fh);
449   seek($fh2, 0, 0);
450   is(readline($fh2), $str);
451   ok(eval {print $fh2 "foo\n"; 1});
452   ok(close $fh);
453   # this fails because the underlying shared handle is already closed
454   ok(!close $fh2);
455 }
456
457 # Perl RT #124181 SEGV due to double free in typemap
458 # "Attempt to free unreferenced scalar"
459 %{*{main::XS::}{HASH}} = ();
460
461 sub is_approx {
462   my ($l, $r, $n) = @_;
463   if (not defined $l or not defined $r) {
464     fail(defined($n) ? $n : ());
465   }
466   else {
467     ok($l < $r+1e-6 && $r < $l+1e-6, defined($n) ? $n : ())
468       or note("$l and $r seem to be different given a fuzz of 1e-6");
469   }
470 }