diff --git a/CHANGES.current b/CHANGES.current index 7fd77c3a4..71394e26f 100644 --- a/CHANGES.current +++ b/CHANGES.current @@ -4,6 +4,10 @@ See the RELEASENOTES file for a summary of changes in each release. Version 2.0.5 (in progress) =========================== +2011-09-10: talby + [perl5] SF bug #1481958 - Improve range checking for integer types. + Enhance li_typemaps_runme.pl + 2011-09-08: wsfulton Fix %extend on typedef classes in a namespace using the typedef name, for example: namespace Space { diff --git a/Examples/test-suite/perl5/li_typemaps_runme.pl b/Examples/test-suite/perl5/li_typemaps_runme.pl index c182cdbb1..194c98ca3 100644 --- a/Examples/test-suite/perl5/li_typemaps_runme.pl +++ b/Examples/test-suite/perl5/li_typemaps_runme.pl @@ -1,74 +1,99 @@ #!/usr/bin/perl use strict; use warnings; -use Test::More tests => 415; +use Test::More tests => 631; BEGIN { use_ok('li_typemaps') } require_ok('li_typemaps'); -sub batch { my($type, @values) = @_; - # this is a little ugly because I'm trying to be clever and save my - # wrists from hammering out all these tests. - for my $val (@values) { - for my $tst (qw( - in inr - out outr - inout inoutr - )) { - my $func = $tst . '_' . $type; - is(eval { li_typemaps->can($func)->($val) }, $val, "$func $val"); - if($@) { - my $err = $@; - $err =~ s/^/#\$\@# /mg; - print $err; - } +my @tests = qw( + in inr + out outr + inout inoutr +); + +sub should_pass { my($type, @values) = @_; + # verify that each value passes cleanly + for my $test (@tests) { + my $name = "${test}_${type}"; + my $func = li_typemaps->can($name); + for my $val (@values) { + my $rv = eval { $func->($val) }; + is($rv, $val, "$name $val"); } } } -batch('bool', '', 1); -# let's assume we're at least on a 32 bit machine -batch('int', -0x80000000, -1, 0, 1, 12, 0x7fffffff); -# long could be bigger, but it's at least this big -batch('long', -0x80000000, -1, 0, 1, 12, 0x7fffffff); -batch('short', -0x8000, -1, 0, 1, 12, 0x7fff); -batch('uint', 0, 1, 12, 0xffffffff); -batch('ushort', 0, 1, 12, 0xffff); -batch('ulong', 0, 1, 12, 0xffffffff); -batch('uchar', 0, 1, 12, 0xff); -batch('schar', -0x80, 0, 1, 12, 0x7f); - -{ - use Math::BigInt qw(); - # the pack dance is to get plain old NVs out of the - # Math::BigInt objects. - my $inf = unpack 'd', pack 'd', Math::BigInt->binf(); - my $nan = unpack 'd', pack 'd', Math::BigInt->bnan(); - batch('float', - -(2 - 2 ** -23) * 2 ** 127, - -1, -2 ** -149, 0, 2 ** -149, 1, - (2 - 2 ** -23) * 2 ** 127, - $nan); - { local $TODO = "float typemaps don't pass infinity"; - # it seems as though SWIG is unwilling to pass infinity around - # because that value always fails bounds checking. I think that - # is a bug. - batch('float', $inf); - } - batch('double', - -(2 - 2 ** -53) ** 1023, - -1, -2 ** -1074, 0, 2 ** 1074, - (2 - 2 ** -53) ** 1023, - $nan, $inf); +sub should_fail { my($type, @values) = @_; + # verify that all values trigger runtime errors + for my $test (@tests) { + my $name = "${test}_${type}"; + my $func = li_typemaps->can($name); + for my $val (@values) { + my $rv = eval { $func->($val) }; + like($@, qr/\b(?:Overflow|Type)Error\b/, "overflow $name $val"); + } + } } -batch('longlong', -1, 0, 1, 12); -batch('ulonglong', 0, 1, 12); + +sub pad { my($t, $s, $f) = @_; + my $nbytes = length pack $t, 0; + return unpack $t, $s . ($f x ($nbytes - 1)); +} + +# some edge case values: +my $nan = unpack 'f>', "\x7f\xc0\x00\x00"; +my $inf = unpack 'f>', "\x7f\x80\x00\x00"; +my $char_min = pad 'c', "\x80"; +my $char_max = pad 'c', "\x7f"; +my $char_umax = pad 'C', "\xff"; +my $short_min = pad 's!>', "\x80", "\x00"; +my $short_max = pad 's!>', "\x7f", "\xff"; +my $short_umax = pad 'S!>', "\xff", "\xff"; +my $int_min = pad 'i!>', "\x80", "\x00"; +my $int_max = pad 'i!>', "\x7f", "\xff"; +my $int_umax = pad 'I!>', "\xff", "\xff"; +my $long_min = pad 'l!>', "\x80", "\x00"; +my $long_max = pad 'l!>', "\x7f", "\xff"; +my $long_umax = pad 'L!>', "\xff", "\xff"; + +should_pass('bool', '', 1); +should_pass('int', $int_min, -1, 0, 1, 12, $int_max); +should_fail('int', $int_min - 1000, $int_max + 1000, $inf, $nan); +should_pass('long', $long_min, -1, 0, 1, 12, $long_max); +should_fail('long', $long_min - 8000, $long_max + 8000, $inf, $nan); +should_pass('short', $short_min, -1, 0, 1, 12, $short_max); +should_fail('short', $short_min - 1, $short_max + 1, $inf, $nan); +should_pass('uint', 0, 1, 12, $int_umax); +should_fail('uint', -1, $int_umax + 1000, $inf, $nan); +should_pass('ushort', 0, 1, 12, $short_umax); +should_fail('ushort', -1, $short_umax + 1, $inf, $nan); +should_pass('ulong', 0, 1, 12, $long_umax); +should_fail('ulong', -1, $long_umax + 8000, $inf, $nan); +should_pass('uchar', 0, 1, 12, $char_umax); +should_fail('uchar', -1, $char_umax + 1, $inf, $nan); +should_pass('schar', $char_min, -1, 0, 1, 12, $char_max); +should_fail('schar', $char_min - 1, $char_max + 1, $inf, $nan); +should_pass('float', -1, 0, 1, $nan); +TODO: { + local $TODO = "typemaps don't allow float infinity"; + should_pass('float', -$inf, $inf); +} +should_pass('double', -$inf, -1, 0, 1, $inf, $nan); +should_pass('longlong', -1, 0, 1, 12); +should_fail('longlong', $inf, $nan); +should_pass('ulonglong', 0, 1, 12); +should_fail('ulonglong', -1, $inf, $nan); SKIP: { - my $a = "8000000000000000"; - my $b = "7fffffffffffffff"; - my $c = "ffffffffffffffff"; - skip "not a 64bit Perl", 18 unless eval { pack 'q', 1 }; - batch('longlong', -hex($a), hex($b)); - batch('ulonglong', hex($c)); + my $llong_min = eval { pad 'q>', "\x80", "\x00" }; + my $llong_max = eval { pad 'q>', "\x7f", "\xff" }; + my $llong_umax = eval { pad 'Q>', "\xff", "\xff" }; + + skip 'not a 64 bit perl', 6 * 6 unless defined $llong_min; + + should_pass('longlong', $llong_min, $llong_max); + should_fail('longlong', $llong_min - 8000, $llong_max + 8000); + should_pass('ulonglong', $llong_umax); + should_fail('ulonglong', $llong_umax + 8000); } my($foo, $int) = li_typemaps::out_foo(10); @@ -79,4 +104,3 @@ is($int, 20); my($a, $b) = li_typemaps::inoutr_int2(13, 31); is($a, 13); is($b, 31); - diff --git a/Lib/perl5/perlprimtypes.swg b/Lib/perl5/perlprimtypes.swg index 86a78c5bf..b004d2f7c 100644 --- a/Lib/perl5/perlprimtypes.swg +++ b/Lib/perl5/perlprimtypes.swg @@ -7,19 +7,12 @@ %fragment(SWIG_From_frag(bool),"header") { SWIGINTERNINLINE SV * SWIG_From_dec(bool)(bool value) -{ - SV *obj = sv_newmortal(); - if (value) { - sv_setsv(obj, &PL_sv_yes); - } else { - sv_setsv(obj, &PL_sv_no); - } - return obj; +{ + return boolSV(value); } } -%fragment(SWIG_AsVal_frag(bool),"header", - fragment="SWIG_CanCastAsInteger") { +%fragment(SWIG_AsVal_frag(bool),"header") { SWIGINTERN int SWIG_AsVal_dec(bool)(SV *obj, bool* val) { @@ -30,10 +23,9 @@ SWIG_AsVal_dec(bool)(SV *obj, bool* val) if (val) *val = false; return SWIG_OK; } else { - if (val) *val = SvTRUE(obj) ? true: false; + if (val) *val = SvTRUE(obj); return SWIG_AddCast(SWIG_OK); } - return SWIG_TypeError; } } @@ -43,10 +35,13 @@ SWIG_AsVal_dec(bool)(SV *obj, bool* val) %fragment(SWIG_From_frag(long),"header") { SWIGINTERNINLINE SV * SWIG_From_dec(long)(long value) -{ - SV *obj = sv_newmortal(); - sv_setiv(obj, (IV) value); - return obj; +{ + SV *sv; + if (value >= IV_MIN && value <= IV_MAX) + sv = newSViv(value); + else + sv = newSVpvf("%ld", value); + return sv_2mortal(sv); } } @@ -55,9 +50,20 @@ SWIG_From_dec(long)(long value) SWIGINTERN int SWIG_AsVal_dec(long)(SV *obj, long* val) { - if (SvIOK(obj)) { - if (val) *val = SvIV(obj); - return SWIG_OK; + if (SvUOK(obj)) { + UV v = SvUV(obj); + if (v <= LONG_MAX) { + if (val) *val = v; + return SWIG_OK; + } + return SWIG_OverflowError; + } else if (SvIOK(obj)) { + IV v = SvIV(obj); + if (v >= LONG_MIN && v <= LONG_MAX) { + if(val) *val = v; + return SWIG_OK; + } + return SWIG_OverflowError; } else { int dispatch = 0; const char *nptr = SvPV_nolen(obj); @@ -91,14 +97,16 @@ SWIG_AsVal_dec(long)(SV *obj, long* val) /* unsigned long */ -%fragment(SWIG_From_frag(unsigned long),"header", - fragment=SWIG_AsVal_frag(double)) { +%fragment(SWIG_From_frag(unsigned long),"header") { SWIGINTERNINLINE SV * SWIG_From_dec(unsigned long)(unsigned long value) -{ - SV *obj = sv_newmortal(); - sv_setuv(obj, (UV) value); - return obj; +{ + SV *sv; + if (value <= UV_MAX) + sv = newSVuv(value); + else + sv = newSVpvf("%lu", value); + return sv_2mortal(sv); } } @@ -108,16 +116,19 @@ SWIGINTERN int SWIG_AsVal_dec(unsigned long)(SV *obj, unsigned long *val) { if (SvUOK(obj)) { - if (val) *val = SvUV(obj); - return SWIG_OK; - } else if (SvIOK(obj)) { - long v = SvIV(obj); - if (v >= 0) { + UV v = SvUV(obj); + if (v <= ULONG_MAX) { if (val) *val = v; return SWIG_OK; - } else { - return SWIG_OverflowError; } + return SWIG_OverflowError; + } else if (SvIOK(obj)) { + IV v = SvIV(obj); + if (v >= 0 && v <= ULONG_MAX) { + if (val) *val = v; + return SWIG_OK; + } + return SWIG_OverflowError; } else { int dispatch = 0; const char *nptr = SvPV_nolen(obj); @@ -158,15 +169,12 @@ SWIG_AsVal_dec(unsigned long)(SV *obj, unsigned long *val) SWIGINTERNINLINE SV * SWIG_From_dec(long long)(long long value) { - if (((long long) LONG_MIN <= value) && (value <= (long long) LONG_MAX)) { - return SWIG_From(long)(%numeric_cast(value,long)); - } else { - char temp[256]; - SV *obj = sv_newmortal(); - sprintf(temp, "%lld", value); - sv_setpv(obj, temp); - return obj; - } + SV *sv; + if (value >= IV_MIN && value <= IV_MAX) + sv = newSViv(value); + else + sv = newSVpvf("%lld", value); + return sv_2mortal(sv); } } @@ -178,9 +186,20 @@ SWIG_From_dec(long long)(long long value) SWIGINTERN int SWIG_AsVal_dec(long long)(SV *obj, long long *val) { - if (SvIOK(obj)) { - if (val) *val = SvIV(obj); - return SWIG_OK; + if (SvUOK(obj)) { + UV v = SvUV(obj); + if (v < LLONG_MAX) { + if (val) *val = v; + return SWIG_OK; + } + return SWIG_OverflowError; + } else if (SvIOK(obj)) { + IV v = SvIV(obj); + if (v >= LLONG_MIN && v <= LLONG_MAX) { + if (val) *val = v; + return SWIG_OK; + } + return SWIG_OverflowError; } else { int dispatch = 0; const char *nptr = SvPV_nolen(obj); @@ -223,15 +242,12 @@ SWIG_AsVal_dec(long long)(SV *obj, long long *val) SWIGINTERNINLINE SV * SWIG_From_dec(unsigned long long)(unsigned long long value) { - if (value < (unsigned long long) LONG_MAX) { - return SWIG_From(long long)(%numeric_cast(value, long long)); - } else { - char temp[256]; - SV *obj = sv_newmortal(); - sprintf(temp, "%llu", value); - sv_setpv(obj, temp); - return obj; - } + SV *sv; + if (value <= UV_MAX) + sv = newSVuv(value); + else + sv = newSVpvf("%llu", value); + return sv_2mortal(sv); } } @@ -241,13 +257,13 @@ SWIG_From_dec(unsigned long long)(unsigned long long value) fragment="SWIG_CanCastAsInteger") { SWIGINTERN int SWIG_AsVal_dec(unsigned long long)(SV *obj, unsigned long long *val) -{ +{ if (SvUOK(obj)) { if (val) *val = SvUV(obj); return SWIG_OK; } else if (SvIOK(obj)) { - long v = SvIV(obj); - if (v >= 0) { + IV v = SvIV(obj); + if (v >= 0 && v <= ULLONG_MAX) { if (val) *val = v; return SWIG_OK; } else { @@ -290,10 +306,8 @@ SWIG_AsVal_dec(unsigned long long)(SV *obj, unsigned long long *val) %fragment(SWIG_From_frag(double),"header") { SWIGINTERNINLINE SV * SWIG_From_dec(double)(double value) -{ - SV *obj = sv_newmortal(); - sv_setnv(obj, value); - return obj; +{ + return sv_2mortal(newSVnv(value)); } }