t/lib/xs-typemap.t

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