t/lib/xs-typemap.t

   1 use Test;
   2 BEGIN { plan tests => 78 }
   3
   4 use strict;
   5 use warnings;
   6 use XS::Typemap;
   7
   8 ok(1);
   9
  10 # Some inheritance trees to check ISA relationships
  11 BEGIN {
  12   package intObjPtr::SubClass;
  13   use base qw/ intObjPtr /;
  14   sub xxx { 1; }
  15 }
  16
  17 BEGIN {
  18   package intRefIvPtr::SubClass;
  19   use base qw/ intRefIvPtr /;
  20   sub xxx { 1 }
  21 }
  22
  23 # T_SV - standard perl scalar value
  24 print "# T_SV\n";
  25
  26 my $sv = "Testing T_SV";
  27 ok( T_SV($sv), $sv);
  28
  29 # T_SVREF - reference to Scalar
  30 print "# T_SVREF\n";
  31
  32 $sv .= "REF";
  33 my $svref = \$sv;
  34 ok( T_SVREF($svref), $svref );
  35
  36 # Now test that a non reference is rejected
  37 # the typemaps croak
  38 eval { T_SVREF( "fail - not ref" ) };
  39 ok( $@ );
  40
  41 # T_AVREF - reference to a perl Array
  42 print "# T_AVREF\n";
  43
  44 my @array;
  45 ok( T_AVREF(\@array), \@array);
  46
  47 # Now test that a non array ref is rejected
  48 eval { T_AVREF( \$sv ) };
  49 ok( $@ );
  50
  51 # T_HVREF - reference to a perl Hash
  52 print "# T_HVREF\n";
  53
  54 my %hash;
  55 ok( T_HVREF(\%hash), \%hash);
  56
  57 # Now test that a non hash ref is rejected
  58 eval { T_HVREF( \@array ) };
  59 ok( $@ );
  60
  61
  62 # T_CVREF - reference to perl subroutine
  63 print "# T_CVREF\n";
  64 my $sub = sub { 1 };
  65 ok( T_CVREF($sub), $sub );
  66
  67 # Now test that a non code ref is rejected
  68 eval { T_CVREF( \@array ) };
  69 ok( $@ );
  70
  71 # T_SYSRET - system return values
  72 print "# T_SYSRET\n";
  73
  74 # first check success
  75 ok( T_SYSRET_pass );
  76
  77 # ... now failure
  78 ok( T_SYSRET_fail, undef);
  79
  80 # T_UV - unsigned integer
  81 print "# T_UV\n";
  82
  83 ok( T_UV(5), 5 );    # pass
  84 ok( T_UV(-4) != -4); # fail
  85
  86 # T_IV - signed integer
  87 print "# T_IV\n";
  88
  89 ok( T_IV(5), 5);
  90 ok( T_IV(-4), -4);
  91 ok( T_IV(4.1), int(4.1));
  92 ok( T_IV("52"), "52");
  93 ok( T_IV(4.5) != 4.5); # failure
  94
  95
  96 # Skip T_INT
  97
  98 # T_ENUM - enum list
  99 print "# T_ENUM\n";
 100
 101 ok( T_ENUM() ); # just hope for a true value
 102
 103 # T_BOOL - boolean
 104 print "# T_BOOL\n";
 105
 106 ok( T_BOOL(52) );
 107 ok( ! T_BOOL(0) );
 108 ok( ! T_BOOL('') );
 109 ok( ! T_BOOL(undef) );
 110
 111 # Skip T_U_INT
 112
 113 # Skip T_SHORT
 114
 115 # T_U_SHORT aka U16
 116
 117 print "# T_U_SHORT\n";
 118
 119 ok( T_U_SHORT(32000), 32000);
 120 ok( T_U_SHORT(65536) != 65536); # probably dont want to test edge cases
 121
 122 # T_U_LONG aka U32
 123
 124 print "# T_U_LONG\n";
 125
 126 ok( T_U_LONG(65536), 65536);
 127 ok( T_U_LONG(-1) != -1);
 128
 129 # T_CHAR
 130
 131 print "# T_CHAR\n";
 132
 133 ok( T_CHAR("a"), "a");
 134 ok( T_CHAR("-"), "-");
 135 ok( T_CHAR(chr(128)),chr(128));
 136 ok( T_CHAR(chr(256)) ne chr(256));
 137
 138 # T_U_CHAR
 139
 140 print "# T_U_CHAR\n";
 141
 142 ok( T_U_CHAR(127), 127);
 143 ok( T_U_CHAR(128), 128);
 144 ok( T_U_CHAR(-1) != -1);
 145 ok( T_U_CHAR(300) != 300);
 146
 147 # T_FLOAT
 148 print "# T_FLOAT\n";
 149
 150 # limited precision
 151 ok( sprintf("%6.3f",T_FLOAT(52.345)), 52.345);
 152
 153 # T_NV
 154 print "# T_NV\n";
 155
 156 ok( T_NV(52.345), 52.345);
 157
 158 # T_DOUBLE
 159 print "# T_DOUBLE\n";
 160
 161 ok( T_DOUBLE(52.345), 52.345);
 162
 163 # T_PV
 164 print "# T_PV\n";
 165
 166 ok( T_PV("a string"), "a string");
 167 ok( T_PV(52), 52);
 168
 169 # T_PTR
 170 print "# T_PTR\n";
 171
 172 my $t = 5;
 173 my $ptr = T_PTR_OUT($t);
 174 ok( T_PTR_IN( $ptr ), $t );
 175
 176 # T_PTRREF
 177 print "# T_PTRREF\n";
 178
 179 $t = -52;
 180 $ptr = T_PTRREF_OUT( $t );
 181 ok( ref($ptr), "SCALAR");
 182 ok( T_PTRREF_IN( $ptr ), $t );
 183
 184 # test that a non-scalar ref is rejected
 185 eval { T_PTRREF_IN( $t ); };
 186 ok( $@ );
 187
 188 # T_PTROBJ
 189 print "# T_PTROBJ\n";
 190
 191 $t = 256;
 192 $ptr = T_PTROBJ_OUT( $t );
 193 ok( ref($ptr), "intObjPtr");
 194 ok( $ptr->T_PTROBJ_IN, $t );
 195
 196 # check that normal scalar refs fail
 197 eval {intObjPtr::T_PTROBJ_IN( \$t );};
 198 ok( $@ );
 199
 200 # check that inheritance works
 201 bless $ptr, "intObjPtr::SubClass";
 202 ok( ref($ptr), "intObjPtr::SubClass");
 203 ok( $ptr->T_PTROBJ_IN, $t );
 204
 205 # Skip T_REF_IV_REF
 206
 207 # T_REF_IV_PTR
 208 print "# T_REF_IV_PTR\n";
 209
 210 $t = -365;
 211 $ptr = T_REF_IV_PTR_OUT( $t );
 212 ok( ref($ptr), "intRefIvPtr");
 213 ok( $ptr->T_REF_IV_PTR_IN(), $t);
 214
 215 # inheritance should not work
 216 bless $ptr, "intRefIvPtr::SubClass";
 217 eval { $ptr->T_REF_IV_PTR_IN };
 218 ok( $@ );
 219
 220 # Skip T_PTRDESC
 221
 222 # Skip T_REFREF
 223
 224 # Skip T_REFOBJ
 225
 226 # T_OPAQUEPTR
 227 print "# T_OPAQUEPTR\n";
 228
 229 $t = 22;
 230 $ptr = T_OPAQUEPTR_IN( $t );
 231 ok( T_OPAQUEPTR_OUT($ptr), $t);
 232
 233 # T_OPAQUE
 234 print "# T_OPAQUE\n";
 235
 236 $t = 48;
 237 $ptr = T_OPAQUE_IN( $t );
 238 ok(T_OPAQUEPTR_OUT( $ptr ), $t);
 239
 240 # T_OPAQUE_array
 241 my @opq = (2,4,8);
 242 my $packed = T_OPAQUE_array(@opq);
 243 my @uopq = unpack("i*",$packed);
 244 for (0..$#opq) {
 245   ok( $uopq[$_], $opq[$_]);
 246 }
 247
 248 # Skip T_PACKED
 249
 250 # Skip T_PACKEDARRAY
 251
 252 # Skip T_DATAUNIT
 253
 254 # Skip T_CALLBACK
 255
 256 # T_ARRAY
 257 print "# T_ARRAY\n";
 258 my @inarr = (1,2,3,4,5,6,7,8,9,10);
 259 my @outarr = T_ARRAY( 5, @inarr );
 260 ok(scalar(@outarr), scalar(@inarr));
 261
 262 for (0..$#inarr) {
 263   ok($outarr[$_], $inarr[$_]);
 264 }
 265
 266
 267
 268 # T_STDIO
 269 print "# T_STDIO\n";
 270
 271 # open a file in XS for write
 272 my $testfile= "stdio.tmp";
 273 my $fh = T_STDIO_open( $testfile );
 274 ok( $fh );
 275
 276 # write to it using perl
 277 if (defined $fh) {
 278
 279   my @lines = ("NormalSTDIO\n", "PerlIO\n");
 280
 281   # print to it using FILE* through XS
 282   ok( T_STDIO_print($fh, $lines[0]), length($lines[0]));
 283
 284   # print to it using normal perl
 285   ok(print $fh "$lines[1]");
 286
 287   # close it using XS
 288   # This works fine but causes a segmentation fault during global
 289   # destruction when the glob associated with this filehandle is
 290   # tidied up.
 291 #  ok( T_STDIO_close( $fh ) );
 292   ok(close($fh)); # using perlio to close the glob works fine
 293
 294   # open from perl, and check contents
 295   open($fh, "< $testfile");
 296   ok($fh);
 297   my $line = <$fh>;
 298   ok($line,$lines[0]);
 299   $line = <$fh>;
 300   ok($line,$lines[1]);
 301
 302   ok(close($fh));
 303   ok(unlink($testfile));
 304
 305 } else {
 306   for (1..8) {
 307     skip("Skip Test not relevant since file was not opened correctly",0);
 308   }
 309 }
 310