Some headway to testing float types in Simple.t
[perl-ctypes:perl-ctypes.git] / t / Simple.t
1 #!perl
2
3 use Test::More;
4 use Test::Warn;
5 use Carp;
6 BEGIN { use_ok( Ctypes ) }
7 use Ctypes::Util qw|create_range|;
8
9 use Math::BigFloat;
10 use Regexp::Common;
11
12
13 #
14 # Takes a hash of properties of Simple types
15 # and tests them.
16 #
17 sub SimpleTest {
18   my $typehash = shift;
19   croak( "One at a time please" ) if @_;
20
21   ok( defined $typehash, "OK!" );
22
23   # Required arguments
24
25   croak( "instantiator required" ) unless defined $typehash->{instantiator};
26   my $instantiator = $typehash->{instantiator};
27
28   croak( "packcode required" ) unless defined $typehash->{packcode};
29   my $packcode = $typehash->{packcode};
30
31   croak( "sizecode required" ) unless defined $typehash->{sizecode};
32   my $sizecode = $typehash->{sizecode};
33
34   croak( "typecode required" ) unless defined $typehash->{typecode};
35   my $typecode = $typehash->{typecode};
36
37   croak( "name required" ) unless defined $typehash->{name};
38   my $name = $typehash->{name};
39
40   croak( "MAX required" ) unless defined $typehash->{MAX};
41   my $MAX = $typehash->{MAX};
42
43   croak( "MIN required" ) unless defined $typehash->{MIN};
44   my $MIN = $typehash->{MIN};
45
46   # Optional arguments
47
48   my $extra = $typehash->{extra} or 100;
49   my $weight = $typehash->{weight} or 1;
50   my $cover = $typehash->{cover} or 100;
51   my $want_int = $typehash->{want_int} or 1;
52
53   # Is the type signed or unsigned?
54   # (Matters for overflow)
55
56   my( $is_signed, $is_unsigned );
57   $is_signed = $typehash->{is_signed} if exists $typehash->{is_signed};
58
59   # What does this type return?
60
61   my( $ret_input, $ret_char, $ret_num, $is_float, $epsilon );
62
63   $ret_input = $typehash->{ret_input} if exists $typehash->{ret_input};
64   $ret_char = $typehash->{ret_char} if exists $typehash->{ret_char};
65   $ret_num = $typehash->{ret_num} if exists $typehash->{ret_num};
66
67   $epsilon = $typehash->{epsilon} if exists $typehash->{epsilon};
68
69   my $ret_check =
70     $ret_input ? 1 : 0 +
71     $ret_char  ? 1 : 0 +
72     $ret_num   ? 1 : 0;
73
74   croak( "Only one default return type (numeric, character, or as-input)" )
75     if $ret_check > 1;
76
77   $ret_num = 1 if $ret_total < 1;
78   diag "ret_num: $ret_num" if $Ctypes::Type::Simple::Debug;
79   diag "ret_char: $ret_char" if $Ctypes::Type::Simple::Debug;
80   diag "ret_input: $ret_input" if $Ctypes::Type::Simple::Debug;
81
82   $is_float = 1 if exists $typehash->{is_float};
83
84   diag "is float: $is_float\n" if $Ctypes::Type::Simple::Debug;
85
86   $epsilon = 1 unless $epsilon;
87
88   my $get_return = sub {
89     my $input = shift;
90     if( $ret_input ) {
91       if( Ctypes::Type::is_a_number($input)
92         or ( ref($input) eq 'Math::BigInt' )
93         or ( ref($input) eq 'Math::BigFloat' ) ) {
94         unless( $is_float ) {
95           return int( $input );
96         } else {
97           return $input;
98         }
99       } else {
100         return substr($input, 0, 1);
101       }
102     }
103     if( $ret_char ) {
104       if( Ctypes::Type::is_a_number($input)
105         or ( ref($input) eq 'Math::BigInt' )
106         or ( ref($input) eq 'Math::BigFloat' ) ) {
107         return chr($input);
108       } else {
109         return substr($input, 0, 1);
110       }
111     }
112     if( $ret_num ) {
113       if( Ctypes::Type::is_a_number($input)
114         or ( ref($input) eq 'Math::BigInt' )
115         or ( ref($input) eq 'Math::BigFloat' ) ) {
116         unless( $is_float ) {
117           return int( $input );
118         } else {
119           return $input;
120         }
121       } else {
122         return ord( substr($input, 0, 1) );
123       }
124     }
125   };
126
127   my $x;
128   my $diff = $MAX - $MIN + 1;
129   my ( $input, $like );
130   my $range = \&Ctypes::Util::create_range;
131
132   {
133     no strict 'refs';
134     $x = &$instantiator;  # 'c_int()', etc
135   }
136
137   $x->strict_input(0);
138   Ctypes::Type::strict_input_all(0);
139
140   isa_ok( $x, 'Ctypes::Type::Simple' );
141   is( $x->typecode, $typecode, 'Correct typecode' );
142   is( $x->sizecode, $sizecode, 'Correct sizecode' );
143   is( $x->packcode, $packcode, 'Correct packcode' );
144   is( $x->name, $name, 'Correct name' );
145
146   subtest "$name will not accept references" => sub {
147     plan tests => 3;
148     $input = 95;
149     $$x = $input;
150     $@ = undef;
151     eval{  $$x = [1, 2, 3] };
152     is( $$x, $get_return->($input) );
153     is( unpack('b*',${$x->data}), unpack('b*', pack($x->packcode, $input)) );
154     like( $@, qr/$name: cannot take references \(got ARRAY.*\)/ );
155   };
156
157   unless( $is_float == 1 ) {
158     subtest "$name drops numbers after decimal point" => sub {
159       plan tests => 3;
160       $input = 95.2;
161       warnings_exist { $$x = $input }
162         [ { carped => qr/$name: numeric values must be integers $MIN <= x <= $MAX \(got $input\)/} ];
163       is( $$x, $get_return->($input) );
164       is( ${$x->data}, pack($x->packcode, 95 ) );
165     };
166   }
167
168   # Exceeding range on _signed_ variables is undefined in the standard,
169   # so these tests can't really be any better.
170   # **reference to the standard?
171   subtest "$name: number overflow" => sub {
172     for( $range->( $MIN - $extra, $MIN - $epsilon ) ) {
173       warnings_exist { $$x = $_ }
174         [ { carped => qr/
175                         $name:\ numeric\ values\ must\ be
176                         \ (integers\ )? $RE{num}{real}
177                         \ <=\ x\ <=\ $RE{num}{real}
178                         \ \(got\ $RE{num}{real}\)
179                         /x } ];
180       isnt( $$x, $get_return->($_) );
181       ok( $$x >= $MIN );
182     }
183     for( $range->( $MIN, $MAX, $cover, $weight, $want_int ) ) {
184       $$x = $_;
185     SKIP: {
186       skip "Todo: make this work for floats", 1 if $is_float;
187       is( $$x, $get_return->($_) );
188     }
189       is( ${$x->data}, pack($x->packcode, $_ ) );
190     }
191     for( $range->( $MAX + 1, $MAX + $extra ) ) {
192       warnings_exist { $$x = $_ }
193         [ { carped => qr/
194                         $name:\ numeric\ values\ must\ be
195                         \ (integers\ )? $RE{num}{real}
196                         \ <=\ x\ <=\ $RE{num}{real}
197                         \ \(got\ $RE{num}{real}\)
198                         /x } ];
199       isnt( $$x, $get_return->($_) );
200       ok( $$x <= $MAX );
201     }
202     done_testing();
203   };
204
205   subtest "$name: character overflow" => sub {
206     for( $range->( 0, $MAX, $cover, $weight, $want_int ) ) {
207       $input = chr($_);
208       $$x = $input;
209       is( $$x, $get_return->($input) );
210       is( ${$x->data}, pack($x->packcode, $_ ) );
211     }
212     for( $range->( $MAX + 1, $MAX + $extra) ) {
213       $input = chr($_);
214       warnings_exist { $$x = $input }
215         [ qr/$name: character values must be integers 0 <= ord\(x\) <= $MAX \(got $input\)/ ];
216       isnt( $$x, $get_return->($input) );
217       ok( $$x <= $MAX );
218     }
219     done_testing();
220   };
221
222   subtest "$name: characters after first discarded" => sub {
223     for( $range->( 0, $MAX, $cover, $weight, $want_int ) ) {
224       $input = chr($_) . 'oubi';
225       $like = "$name: single characters only";
226       warnings_exist { $$x = $input }
227         [ { carped => qr/$like/} ];
228       is( $$x, $get_return->($input) );
229       is( ${$x->data}, pack($x->packcode, $_ ) );
230     }
231     done_testing();
232   };
233
234   $x->strict_input(1);
235
236   subtest "$name->strict_input and decimal places" => sub {
237     plan tests => 3;
238     $input1 = 95;
239     $input2 = 100.2;
240     $$x = $input1;
241     undef $@;
242     eval { $$x = $input2 };
243     if( $is_float ) {
244       is( $$x, $get_return->($input2) );
245       is( ${$x->data}, pack($x->packcode, $input2 ) );
246       is( $@, undef );
247     } else {
248       is( $$x, $get_return->($input1) );
249       is( ${$x->data}, pack($x->packcode, $input1 ) );
250       like( $@, qr/$name: numeric values must be integers $MIN <= x <= $MAX \(got $input2\)/ );
251     }
252   };
253
254   subtest "$name->strict_input prevents numeric overflow" => sub {
255     $$x = 95;
256     for( $range->( $MIN - $extra, $MIN - 1 ) ) {
257       undef $@;
258       eval{ $$x = $_ };
259       is( $$x, $get_return->(95) );
260       is( ${$x->data}, pack($x->packcode, 95 ) );
261       like( $@, qr/$name: numeric values must be integers $MIN <= x <= $MAX \(got $_\)/ );
262     }
263     for( $range->( $MIN, $MAX, $cover, $weight, $want_int ) ) {
264       undef $@;
265       eval { $$x = $_ };
266       is( $$x, $get_return->($_) );
267       is( ${$x->data}, pack($x->packcode, $_ ) );
268       is( $@, '' );
269     }
270     $$x = $MAX;
271     for( $range->( $MAX + 1, $MAX + $extra ) ) {
272       undef $@;
273       eval { $$x = $_ };
274       is( $$x, $get_return->($MAX) );
275       is( ${$x->data}, pack($x->packcode, $MAX ) );
276       like( $@, qr/$name: numeric values must be integers $MIN <= x <= $MAX \(got $_\)/ );
277     }
278     done_testing();
279   };
280
281   subtest "$name->strict_input prevents overflow with characters" => sub {
282     for( $range->( 0, $MAX, $cover, $weight, $want_int ) ) {
283       $input = chr($_);
284       $$x = $input;
285       is( $$x, $get_return->($input) );
286       is( ${$x->data}, pack($x->packcode, $_ ) );
287     }
288     $$x = $MAX;
289     for( $range->( $MAX + 1, $MAX + $extra ) ) {
290       undef $@;
291       $input = chr($_);
292       eval { $$x = $input };
293       is( $$x, $get_return->($MAX) );
294       is( ${$x->data}, pack($x->packcode, $MAX ) );
295       like( $@, qr/$name: character values must be integers 0 <= ord\(x\) <= $MAX \(got .*\)/ );
296     }
297     done_testing();
298   };
299
300   subtest "$name->strict_input: multi-character error" => sub {
301     $$x = 95;
302     for( $range->( 0, $MAX, $cover, $weight, $want_int ) ) {
303       undef $@;
304       $input = chr($_) . 'oubi';
305       eval { $$x = $input };
306       is( $$x, $get_return->(95) );
307       is( ${$x->data}, pack($x->packcode, 95 ) );
308       $like = $name . ': single characters only';
309       # special regex characters cause problems, so escape them...
310       substr( $like, ( index($like, 'oubi') - 1 ), 0, '\\' )
311         if $input =~ qr{\^|\$|\.|\+|\*|\?|\(|\)|\[|\]|\\};
312       like( $@, qr/$like/ );
313     }
314     for( $range->( $MAX + 1, $MAX + $extra ) ) {
315       undef $@;
316       $input = chr($_) . 'oubi';
317       eval { $$x = $input };
318       is( $$x, $get_return->(95) );
319       is( ${$x->data}, pack($x->packcode, 95 ) );
320       $like = $name . ': single characters only, and must be integers 0 <= ord\(x\) <= ' . $MAX;
321       substr( $like, ( index($like, 'oubi') - 1 ), 0, '\\' )
322         if $input =~ qr{\^|\$|\.|\+|\*|\?|\(|\)|\[|\]|\\};
323       like( $@, qr/$like/ );
324     }
325     done_testing();
326   };
327
328   $x->strict_input(0);
329   Ctypes::Type::strict_input_all(1);
330
331   subtest "$name: strict_input_all prevents dropping decimal places" => sub {
332     plan tests => 3;
333     $$x = 95;
334     undef $@;
335     eval { $$x = 100.2 };
336     is( $$x, $get_return->(95) );
337     is( ${$x->data}, pack($x->packcode, 95 ) );
338     like( $@, qr/$name: numeric values must be integers $MIN <= x <= $MAX \(got 100\.2\)/ );
339   };
340
341   subtest "$name: strict_input_all prevents numeric overflow" => sub {
342     $$x = 95;
343     for( $range->( $MIN - $extra, $MIN - 1 ) ) {
344       undef $@;
345       eval{ $$x = $_ };
346       is( $$x, $get_return->(95) );
347       is( ${$x->data}, pack($x->packcode, 95 ) );
348       like( $@, qr/$name: numeric values must be integers $MIN <= x <= $MAX \(got $_\)/ );
349     }
350     for( $range->( $MIN, $MAX, $cover, $weight, $want_int ) ) {
351       undef $@;
352       eval { $$x = $_ };
353       is( $$x, $get_return->($_) );
354       is( ${$x->data}, pack($x->packcode, $_ ) );
355       is( $@, '' );
356     }
357     $$x = $MAX;
358     for( $range->( $MAX + 1, $MAX + $extra ) ) {
359       undef $@;
360       eval { $$x = $_ };
361       is( $$x, $get_return->($MAX) );
362       is( ${$x->data}, pack($x->packcode, $MAX ) );
363       like( $@, qr/$name: numeric values must be integers $MIN <= x <= $MAX \(got $_\)/ );
364     }
365     done_testing();
366   };
367
368   subtest "$name: strict_input_all prevents overflow with characters" => sub {
369     for( $range->( 0, $MAX, $cover, $weight, $want_int ) ) {
370       $input = chr($_);
371       $$x = $input;
372       is( $$x, $get_return->($input) );
373       is( ${$x->data}, pack($x->packcode, $_ ) );
374     }
375     $$x = $MAX;
376     for( $range->( $MAX + 1, $MAX + $extra ) ) {
377       undef $@;
378       $input = chr($_);
379       eval { $$x = $input };
380       is( $$x, $get_return->($MAX) );
381       is( ${$x->data}, pack($x->packcode, $MAX ) );
382       like( $@, qr/$name: character values must be integers 0 <= ord\(x\) <= $MAX \(got .*\)/ );
383     }
384     done_testing();
385   };
386
387   subtest "$name: strict_input_all: multi-character error" => sub {
388     $$x = 95;
389     for( $range->( 0, $MAX, $cover, $weight, $want_int ) ) {
390       undef $@;
391       $input = chr($_) . 'oubi';
392       eval { $$x = $input };
393       is( $$x, $get_return->(95) );
394       is( ${$x->data}, pack($x->packcode, 95 ) );
395       $like = $name . ': single characters only';
396       # special regex characters cause problems, so escape them...
397       substr( $like, ( index($like, 'oubi') - 1 ), 0, '\\' )
398         if $input =~ qr{\^|\$|\.|\+|\*|\?|\(|\)|\[|\]|\\};
399       like( $@, qr/$like/ );
400     }
401     for( $range->( $MAX + 1, $MAX + $extra ) ) {
402       undef $@;
403       $input = chr($_) . 'oubi';
404       eval { $$x = $input };
405       is( $$x, $get_return->(95) );
406       is( ${$x->data}, pack($x->packcode, 95 ) );
407       $like = $name . ': single characters only, and must be integers 0 <= ord\(x\) <= ' . $MAX;
408       substr( $like, ( index($like, 'oubi') - 1 ), 0, '\\' )
409         if $input =~ qr{\^|\$|\.|\+|\*|\?|\(|\)|\[|\]|\\};
410       like( $@, qr/$like/ );
411     }
412     done_testing();
413   };
414 }
415
416 my $MAX = Ctypes::constant('PERL_SHORT_MAX');
417 my $MIN = Ctypes::constant('PERL_SHORT_MIN');
418 my $types = [
419   { #0
420     instantiator => 'c_byte',
421     packcode     => 'c',
422     sizecode     => 'c',
423     typecode     => 'b',
424     name         => 'c_byte',
425     MAX          => 127,
426     MIN          => -128,
427
428     ret_input    => 1,
429     is_signed    => 1,
430     # For test value range:
431     extra        => 128,
432             },
433   { #1
434     instantiator => 'c_ubyte',
435     packcode     => 'C',
436     sizecode     => 'C',
437     typecode     => 'B',
438     name         => 'c_ubyte',
439     MAX          => 255,
440     MIN          => 0,
441
442     ret_input    => 1,
443     is_signed    => 0,
444     # For test value range:
445     extra        => 256,
446   },
447   { #2
448     instantiator => 'c_char',
449     packcode     => 'c',
450     sizecode     => 'c',
451     typecode     => 'c',
452     name         => 'c_char',
453     MAX          => 127,
454     MIN          => -128,
455
456     ret_char     => 1,
457     is_signed    => 1,
458     # For test value range:
459     extra        => 128,
460   },
461   { #3
462     instantiator => 'c_uchar',
463     packcode     => 'C',
464     sizecode     => 'C',
465     typecode     => 'C',
466     name         => 'c_uchar',
467     MAX          => 255,
468     MIN          => 0,
469
470     ret_char     => 1,
471     is_signed    => 0,
472     # For test value range:
473     extra        => 256,
474   },
475   { #4
476     instantiator => 'c_short',
477     packcode     => 's',
478     sizecode     => 's',
479     typecode     => 'h',
480     name         => 'c_short',
481     MAX          => (Ctypes::constant('PERL_SHORT_MAX'))[1],
482     MIN          => (Ctypes::constant('PERL_SHORT_MIN'))[1],
483
484     is_signed    => 1,
485     # For test value range:
486     extra        => 100,
487     cover        => 100,
488     weight       => 1,
489     want_int     => 1,
490   },
491   { #5
492     instantiator => 'c_ushort',
493     packcode     => 'S',
494     sizecode     => 'S',
495     typecode     => 'H',
496     name         => 'c_ushort',
497     MAX          => (Ctypes::constant('PERL_USHORT_MAX'))[1],
498     MIN          => (Ctypes::constant('PERL_USHORT_MIN'))[1],
499
500     is_signed    => 0,
501     # For test value range:
502     extra        => 100,
503     cover        => 100,
504     weight       => 1,
505     want_int     => 1,
506   },
507    { #6
508     instantiator => 'c_int',
509     packcode     => 'i',
510     sizecode     => 'i',
511     typecode     => 'i',
512     name         => 'c_int',
513     MAX          => (Ctypes::constant('PERL_INT_MAX'))[1],
514     MIN          => (Ctypes::constant('PERL_INT_MIN'))[1],
515
516     is_signed    => 1,
517     # For test value range:
518     extra        => 50,
519     cover        => 100,
520     weight       => 1,
521     want_int     => 1,
522   },
523   { #7
524     instantiator => 'c_uint',
525     packcode     => 'I',
526     sizecode     => 'i',
527     typecode     => 'I',
528     name         => 'c_uint',
529     MAX          => (Ctypes::constant('PERL_UINT_MAX'))[1],
530     MIN          => (Ctypes::constant('PERL_UINT_MIN'))[1],
531
532     is_signed    => 1,
533     # For test value range:
534     extra        => 100,
535     cover        => 100,
536     weight       => 1,
537     want_int     => 1,
538   },
539   { #8
540     instantiator => 'c_long',
541     packcode     => 'l',
542     sizecode     => 'l',
543     typecode     => 'l',
544     name         => 'c_long',
545     MAX          => (Ctypes::constant('PERL_LONG_MAX'))[1],
546     MIN          => (Ctypes::constant('PERL_LONG_MIN'))[1],
547
548     is_signed    => 1,
549     # For test value range:
550     extra        => 50,
551     cover        => 100,
552     weight       => 1,
553     want_int     => 1,
554   },
555   { #9
556     instantiator => 'c_ulong',
557     packcode     => 'L',
558     sizecode     => 'l',
559     typecode     => 'L',
560     name         => 'c_ulong',
561     MAX          => (Ctypes::constant('PERL_ULONG_MAX'))[1],
562     MIN          => (Ctypes::constant('PERL_ULONG_MIN'))[1],
563
564     is_signed    => 0,
565     # For test value range:
566     extra        => 50,
567     cover        => 100,
568     weight       => 1,
569     want_int     => 1,
570   },
571 # TODO: Various problems with testing float types
572 #      { #10
573 #        instantiator => 'c_float',
574 #        packcode     => 'f',
575 #        sizecode     => 'f',
576 #        typecode     => 'f',
577 #        name         => 'c_float',
578 #        MAX          => Math::BigFloat->new( (Ctypes::constant('FLT_MAX'))[1] ),
579 #        MIN          => Math::BigFloat->new( (Ctypes::constant('CTYPES_FLT_MIN'))[1] ),
580 #        epsilon      => Math::BigFloat->new( (Ctypes::constant('FLT_EPSILON'))[1] ),
581 #    
582 #        is_signed    => 1,
583 #        is_float     => 1,
584 #        # For test value range:
585 #        extra        => 10,
586 #        cover        => 100,
587 #        weight       => 1,
588 #        want_int     => 0,
589 #      },
590 ];
591
592 # Comment as appropriate
593 # SimpleTest( $types->[9] ); # convenient testing of new type
594 SimpleTest($_) for ( @$types ); # testing all types
595 done_testing();