From: Jarkko Hietaniemi Date: Tue, 27 Mar 2001 15:08:10 +0000 (+0000) Subject: Add Tim Jenness' XS::Typemap for exercizing the standard typemap. X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=ea035a6903a44a6856d789d8a40f47888278b7bb;p=p5sagit%2Fp5-mst-13.2.git Add Tim Jenness' XS::Typemap for exercizing the standard typemap. p4raw-id: //depot/perl@9381 --- diff --git a/MANIFEST b/MANIFEST index 0eb7845..a8fe7af 100644 --- a/MANIFEST +++ b/MANIFEST @@ -478,6 +478,12 @@ ext/Thread/unsync.t Test thread implicit synchronisation ext/Thread/unsync2.t Test thread implicit synchronisation ext/Thread/unsync3.t Test thread implicit synchronisation ext/Thread/unsync4.t Test thread implicit synchronisation +ext/XS/Typemap/Makefile.PL XS::Typemap extension +ext/XS/Typemap/README XS::Typemap extension +ext/XS/Typemap/Typemap.pm XS::Typemap extension +ext/XS/Typemap/Typemap.xs XS::Typemap extension +ext/XS/Typemap/stdio.c XS::Typemap extension +ext/XS/Typemap/typemap XS::Typemap extension ext/attrs/Makefile.PL attrs extension makefile writer ext/attrs/attrs.pm attrs extension Perl module ext/attrs/attrs.xs attrs extension external subroutines @@ -1583,6 +1589,7 @@ t/lib/tie-stdpush.t Test for Tie::StdArray t/lib/tie-substrhash.t Test for Tie::SubstrHash t/lib/timelocal.t See if Time::Local works t/lib/trig.t See if Math::Trig works +t/lib/xs-typemap.t test that typemaps work t/op/64bitint.t See if 64 bit integers work t/op/anonsub.t See if anonymous subroutines work t/op/append.t See if . works diff --git a/ext/XS/Typemap/Makefile.PL b/ext/XS/Typemap/Makefile.PL new file mode 100644 index 0000000..3b1ff51 --- /dev/null +++ b/ext/XS/Typemap/Makefile.PL @@ -0,0 +1,15 @@ +use ExtUtils::MakeMaker; + +WriteMakefile( + 'NAME' => 'XS::Typemap', + 'VERSION_FROM' => 'Typemap.pm', + 'dist' => { COMPRESS => "gzip -9f"}, + OBJECT => 'stdio.o Typemap.o', + ABSTRACT_FROM => 'Typemap.pm', + AUTHOR => 'Tim Jenness ', +); + + +# Nothing to install (except maybe the XS::Typemap.xs documentation) + +sub MY::install { "install ::\n" }; diff --git a/ext/XS/Typemap/README b/ext/XS/Typemap/README new file mode 100644 index 0000000..c6dd277 --- /dev/null +++ b/ext/XS/Typemap/README @@ -0,0 +1,35 @@ +XSTypemap +========= + +This module tests that the standard XS typemaps are working correctly. + + perl Makefile.PL + make + make test + +Nothing is installed. + +Currently not all the typemap entries have corresponding tests. + +Missing entries are + + T_REF_IV_REF + T_PTRDESC + T_REFREF + T_REFOBJ + T_PACKED + T_PACKEDARRAY + T_DATAUNIT + T_CALLBACK + T_IN + T_INOUT + T_OUT + +Author +------ + +Tim Jenness + +Copyright (C) 2001 Tim Jenness All Rights Reserved. This program is +free software; you can redistribute it and/or modify it under the same +terms as Perl itself. diff --git a/ext/XS/Typemap/Typemap.pm b/ext/XS/Typemap/Typemap.pm new file mode 100644 index 0000000..f14a0d2 --- /dev/null +++ b/ext/XS/Typemap/Typemap.pm @@ -0,0 +1,94 @@ +package XS::Typemap; + +=head1 NAME + +XS::Typemap - module to test the XS typemaps distributed with perl + +=head1 SYNOPSIS + + use XS::Typemap; + + $output = T_IV( $input ); + $output = T_PV( $input ); + @output = T_ARRAY( @input ); + +=head1 DESCRIPTION + +This module is used to test that the XS typemaps distributed +with perl are working as advertised. A function is available +for each typemap definition (eventually). In general each function +takes a variable, processes it through the OUTPUT typemap and then +returns it using the INPUT typemap. + +A test script can then compare the input and output to make sure they +are the expected values. When only an input or output function is +provided the function will be named after the typemap entry and have +either '_IN' or '_OUT' appended. + +All the functions are exported. There is no reason not to do this since +the entire purpose is for testing Perl. Namespace pollution will be limited +to the test script. + +=cut + +use base qw/ DynaLoader Exporter /; + + +use vars qw/ $VERSION @EXPORT /; + +$VERSION = '0.01'; + +@EXPORT = (qw/ + T_SV + T_SVREF + T_AVREF + T_HVREF + T_CVREF + T_SYSRET_fail T_SYSRET_pass + T_UV + T_IV + T_INT + T_ENUM + T_BOOL + T_U_INT + T_SHORT + T_U_SHORT + T_LONG + T_U_LONG + T_CHAR + T_U_CHAR + T_FLOAT + T_NV + T_DOUBLE + T_PV + T_PTR_IN T_PTR_OUT + T_PTRREF_IN T_PTRREF_OUT + T_REF_IV_REF + T_REF_IV_PTR_IN T_REF_IV_PTR_OUT + T_PTROBJ_IN T_PTROBJ_OUT + T_OPAQUE_IN T_OPAQUE_array + T_OPAQUEPTR_IN T_OPAQUEPTR_OUT + T_ARRAY + T_STDIO_open T_STDIO_close T_STDIO_print + /); + + +bootstrap XS::Typemap; + +=head1 NOTES + +This module is for testing only and should not normally be installed. + +=head1 AUTHOR + +Tim Jenness Et.jenness@jach.hawaii.eduE + +Copyright (C) 2001 Tim Jenness All Rights Reserved. This program is +free software; you can redistribute it and/or modify it under the same +terms as Perl itself. + +=cut + + +1; + diff --git a/ext/XS/Typemap/Typemap.xs b/ext/XS/Typemap/Typemap.xs new file mode 100644 index 0000000..d0d79d3 --- /dev/null +++ b/ext/XS/Typemap/Typemap.xs @@ -0,0 +1,775 @@ + +/* + XS code to test the typemap entries + + Copyright (C) 2001 Tim Jenness. + All Rights Reserved + +*/ + +#include "EXTERN.h" /* std perl include */ +#include "perl.h" /* std perl include */ +#include "XSUB.h" /* XSUB include */ + +/* Prototypes for external functions */ +FILE * xsfopen( const char * ); +int xsfclose( FILE * ); +int xsfprintf( FILE *, const char *); + +/* Type definitions required for the XS typemaps */ +typedef SV * SVREF; /* T_SVREF */ +typedef int SysRet; /* T_SYSRET */ +typedef int Int; /* T_INT */ +typedef int intRef; /* T_PTRREF */ +typedef int intObj; /* T_PTROBJ */ +typedef int intRefIv; /* T_REF_IV_PTR */ +typedef int intArray; /* T_ARRAY */ +typedef short shortOPQ; /* T_OPAQUE */ +typedef int intOpq; /* T_OPAQUEPTR */ + +/* Some static memory for the tests */ +I32 anint; +intRef anintref; +intObj anintobj; +intRefIv anintrefiv; +intOpq anintopq; + +/* Helper functions */ + +/* T_ARRAY - allocate some memory */ +intArray * intArrayPtr( int nelem ) { + intArray * array; + New(0, array, nelem, intArray); + return array; +} + + +MODULE = XS::Typemap PACKAGE = XS::Typemap + +PROTOTYPES: DISABLE + +=head1 TYPEMAPS + +Each C type is represented by an entry in the typemap file that +is responsible for converting perl variables (SV, AV, HV and CV) to +and from that type. + +=over 4 + +=item T_SV + +This simply passes the C representation of the Perl variable (an SV*) +in and out of the XS layer. This can be used if the C code wants +to deal directly with the Perl variable. + +=cut + +SV * +T_SV( sv ) + SV * sv + CODE: + /* create a new sv for return that is a copy of the input + do not simply copy the pointer since the SV will be marked + mortal by the INPUT typemap when it is pushed back onto the stack */ + RETVAL = sv_mortalcopy( sv ); + /* increment the refcount since the default INPUT typemap mortalizes + by default and we don't want to decrement the ref count twice + by mistake */ + SvREFCNT_inc(RETVAL); + OUTPUT: + RETVAL + +=item T_SVREF + +Used to pass in and return a reference to an SV. + +=cut + +SVREF +T_SVREF( svref ) + SVREF svref + CODE: + RETVAL = svref; + OUTPUT: + RETVAL + +=item T_AVREF + +From the perl level this is a reference to a perl array. +From the C level this is a pointer to an AV. + +=cut + +AV * +T_AVREF( av ) + AV * av + CODE: + RETVAL = av; + OUTPUT: + RETVAL + +=item T_HVREF + +From the perl level this is a reference to a perl hash. +From the C level this is a pointer to a HV. + +=cut + +HV * +T_HVREF( hv ) + HV * hv + CODE: + RETVAL = hv; + OUTPUT: + RETVAL + +=item T_CVREF + +From the perl level this is a reference to a perl subroutine +(e.g. $sub = sub { 1 };). From the C level this is a pointer +to a CV. + +=cut + +CV * +T_CVREF( cv ) + CV * cv + CODE: + RETVAL = cv; + OUTPUT: + RETVAL + + +=item T_SYSRET + +The T_SYSRET typemap is used to process return values from system calls. +It is only meaningful when passing values from C to perl (there is +no concept of passing a system return value from Perl to C). + +System calls return -1 on error (setting ERRNO with the reason) +and (usually) 0 on success. If the return value is -1 this typemap +returns C. If the return value is not -1, this typemap +translates a 0 (perl false) to "0 but true" (which +is perl true) or returns the value itself, to indicate that the +command succeeded. + +The L module makes extensive use of this type. + +=cut + +# Test a successful return + +SysRet +T_SYSRET_pass() + CODE: + RETVAL = 0; + OUTPUT: + RETVAL + +# Test failure + +SysRet +T_SYSRET_fail() + CODE: + RETVAL = -1; + OUTPUT: + RETVAL + +=item T_UV + +An unsigned integer. + +=cut + +unsigned int +T_UV( uv ) + unsigned int uv + CODE: + RETVAL = uv; + OUTPUT: + RETVAL + +=item T_IV + +A signed integer. This is cast to the required integer type when +passed to C and converted to a IV when passed back to Perl. + +=cut + +long +T_IV( iv ) + long iv + CODE: + RETVAL = iv; + OUTPUT: + RETVAL + +=item T_INT + +A signed integer. This typemap converts the Perl value to a native +integer type (the C type on the current platform). When returning +the value to perl it is processed in the same way as for T_IV. + +Its behaviour is identical to using an C type in XS with T_IV. + +=item T_ENUM + +An enum value. Used to transfer an enum component +from C. There is no reason to pass an enum value to C since +it is stored as an IV inside perl. + +=cut + +# The test should return the value for SVt_PVHV. +# 11 at the present time but we can't not rely on this +# for testing purposes. + +svtype +T_ENUM() + CODE: + RETVAL = SVt_PVHV; + OUTPUT: + RETVAL + +=item T_BOOL + +A boolean type. This can be used to pass true and false values to and +from C. + +=cut + +bool +T_BOOL( in ) + bool in + CODE: + RETVAL = in; + OUTPUT: + RETVAL + +=item T_U_INT + +This is for unsigned integers. It is equivalent to using T_UV +but explicitly casts the variable to type C. +The default type for C is T_UV. + +=item T_SHORT + +Short integers. This is equivalent to T_IV but explicitly casts +the return to type C. The default typemap for C +is T_IV. + +=item T_U_SHORT + +Unsigned short integers. This is equivalent to T_UV but explicitly +casts the return to type C. The default typemap for +C is T_UV. + +T_U_SHORT is used for type C in the standard typemap. + +=cut + +U16 +T_U_SHORT( in ) + U16 in + CODE: + RETVAL = in; + OUTPUT: + RETVAL + + +=item T_LONG + +Long integers. This is equivalent to T_IV but explicitly casts +the return to type C. The default typemap for C +is T_IV. + +=item T_U_LONG + +Unsigned long integers. This is equivalent to T_UV but explicitly +casts the return to type C. The default typemap for +C is T_UV. + +T_U_LONG is used for type C in the standard typemap. + +=cut + +U32 +T_U_LONG( in ) + U32 in + CODE: + RETVAL = in; + OUTPUT: + RETVAL + +=item T_CHAR + +Single 8-bit characters. + +=cut + +char +T_CHAR( in ); + char in + CODE: + RETVAL = in; + OUTPUT: + RETVAL + + +=item T_U_CHAR + +An unsigned byte. + +=cut + +unsigned char +T_U_CHAR( in ); + unsigned char in + CODE: + RETVAL = in; + OUTPUT: + RETVAL + + +=item T_FLOAT + +A floating point number. This typemap guarantees to return a variable +cast to a C. + +=cut + +float +T_FLOAT( in ) + float in + CODE: + RETVAL = in; + OUTPUT: + RETVAL + +=item T_NV + +A Perl floating point number. Similar to T_IV and T_UV in that the +return type is cast to the requested numeric type rather than +to a specific type. + +=cut + +NV +T_NV( in ) + NV in + CODE: + RETVAL = in; + OUTPUT: + RETVAL + +=item T_DOUBLE + +A double precision floating point number. This typemap guarantees to +return a variable cast to a C. + +=cut + +double +T_DOUBLE( in ) + double in + CODE: + RETVAL = in; + OUTPUT: + RETVAL + +=item T_PV + +A string (char *). + +=cut + +char * +T_PV( in ) + char * in + CODE: + RETVAL = in; + OUTPUT: + RETVAL + +=item T_PTR + +A memory address (pointer). Typically associated with a C +type. + +=cut + +# Pass in a value. Store the value in some static memory and +# then return the pointer + +void * +T_PTR_OUT( in ) + int in; + CODE: + anint = in; + RETVAL = &anint; + OUTPUT: + RETVAL + +# pass in the pointer and return the value + +int +T_PTR_IN( ptr ) + void * ptr + CODE: + RETVAL = *(int *)ptr; + OUTPUT: + RETVAL + +=item T_PTRREF + +Similar to T_PTR except that the pointer is stored in a scalar and the +reference to that scalar is returned to the caller. This can be used +to hide the actual pointer value from the programmer since it is usually +not required directly from within perl. + +The typemap checks that a scalar reference is passed from perl to XS. + +=cut + +# Similar test to T_PTR +# Pass in a value. Store the value in some static memory and +# then return the pointer + +intRef * +T_PTRREF_OUT( in ) + intRef in; + CODE: + anintref = in; + RETVAL = &anintref; + OUTPUT: + RETVAL + +# pass in the pointer and return the value + +intRef +T_PTRREF_IN( ptr ) + intRef * ptr + CODE: + RETVAL = *ptr; + OUTPUT: + RETVAL + + + +=item T_PTROBJ + +Similar to T_PTRREF except that the reference is blessed into a class. +This allows the pointer to be used as an object. Most commonly used to +deal with C structs. The typemap checks that the perl object passed +into the XS routine is of the correct class (or part of a subclass). + +The pointer is blessed into a class that is derived from the name +of type of the pointer but with all '*' in the name replaced with +'Ptr'. + +=cut + +# Similar test to T_PTRREF +# Pass in a value. Store the value in some static memory and +# then return the pointer + +intObj * +T_PTROBJ_OUT( in ) + intObj in; + CODE: + anintobj = in; + RETVAL = &anintobj; + OUTPUT: + RETVAL + +# pass in the pointer and return the value + +MODULE = XS::Typemap PACKAGE = intObjPtr + +intObj +T_PTROBJ_IN( ptr ) + intObj * ptr + CODE: + RETVAL = *ptr; + OUTPUT: + RETVAL + +MODULE = XS::Typemap PACKAGE = XS::Typemap + +=item T_REF_IV_REF + +NOT YET + +=item T_REF_IV_PTR + +Similar to T_PTROBJ in that the pointer is blessed into a scalar object. +The difference is that when the object is passed back into XS it must be +of the correct type (inheritance is not supported). + +The pointer is blessed into a class that is derived from the name +of type of the pointer but with all '*' in the name replaced with +'Ptr'. + +=cut + +# Similar test to T_PTROBJ +# Pass in a value. Store the value in some static memory and +# then return the pointer + +intRefIv * +T_REF_IV_PTR_OUT( in ) + intRefIv in; + CODE: + anintrefiv = in; + RETVAL = &anintrefiv; + OUTPUT: + RETVAL + +# pass in the pointer and return the value + +MODULE = XS::Typemap PACKAGE = intRefIvPtr + +intRefIv +T_REF_IV_PTR_IN( ptr ) + intRefIv * ptr + CODE: + RETVAL = *ptr; + OUTPUT: + RETVAL + + +MODULE = XS::Typemap PACKAGE = XS::Typemap + +=item T_PTRDESC + +NOT YET + +=item T_REFREF + +NOT YET + +=item T_REFOBJ + +NOT YET + +=item T_OPAQUEPTR + +This can be used to store a pointer in the string component of the +SV. Unlike T_PTR which stores the pointer in an IV that can be +printed, here the representation of the pointer is irrelevant and the +bytes themselves are just stored in the SV. If the pointer is +represented by 4 bytes then those 4 bytes are stored in the SV (and +length() will report a value of 4). This makes use of the fact that a +perl scalar can store arbritray data in its PV component. + +In principal the unpack() command can be used to convert the pointer +to a number. + +=cut + +intOpq * +T_OPAQUEPTR_IN( val ) + intOpq val + CODE: + anintopq = val; + RETVAL = &anintopq; + OUTPUT: + RETVAL + +intOpq +T_OPAQUEPTR_OUT( ptr ) + intOpq * ptr + CODE: + RETVAL = *ptr; + OUTPUT: + RETVAL + +=item T_OPAQUE + +This can be used to store pointers to non-pointer types in an SV. It +is similar to T_OPAQUEPTR except that the typemap retrieves the +pointer itself rather than assuming that it is to be given a +pointer. This approach hides the pointer as a byte stream in the +string part of the SV rather than making the actual pointer value +available to Perl. + +There is no reason to use T_OPAQUE to pass the data to C. Use +T_OPAQUEPTR to do that since once the pointer is stored in the SV +T_OPAQUE and T_OPAQUEPTR are identical. + +=cut + +shortOPQ +T_OPAQUE_IN( val ) + int val + CODE: + RETVAL = (shortOPQ)val; + OUTPUT: + RETVAL + +=item Implicit array + +xsubpp supports a special syntax for returning +packed C arrays to perl. If the XS return type is given as + + array(type, nelem) + +xsubpp will copy the contents of C bytes from +RETVAL to an SV and push it onto the stack. This is only really useful +if the number of items to be returned is known at compile time and you +don't mind having a string of bytes in your SV. Use T_ARRAY to push a +variable number of arguments onto the return stack (they won't be +packed as a single string though). + +This is similar to using T_OPAQUEPTR but can be used to process more than +one element. + +=cut + +array(int,3) +T_OPAQUE_array( a,b,c) + int a + int b + int c + PREINIT: + int array[2]; + CODE: + array[0] = a; + array[1] = b; + array[2] = c; + RETVAL = array; + OUTPUT: + RETVAL + + +=item T_PACKED + +NOT YET + +=item T_PACKEDARRAY + +NOT YET + +=item T_DATAUNIT + +NOT YET + +=item T_CALLBACK + +NOT YET + +=item T_ARRAY + +This is used to convert the perl argument list to a C array +and for pushing the contents of a C array onto the perl +argument stack. + +The usual calling signature is + + @out = array_func( @in ); + +Any number of arguments can occur in the list before the array but +the input and output arrays must be the last elements in the list. + +When used to pass a perl list to C the XS writer must provide a +function (named after the array type but with 'Ptr' substituted for +'*') to allocate the memory required to hold the list. A pointer +should be returned. It is up to the XS writer to free the memory on +exit from the function. The variable C is set to the number +of elements in the new array. + +When returning a C array to Perl the XS writer must provide an integer +variable called C containing the number of elements in the +array. This is used to determine how many elements should be pushed +onto the return argument stack. This is not required on input since +Perl knows how many arguments are on the stack when the routine is +called. Ordinarily this variable would be called C. + +Additionally, the type of each element is determined from the type of +the array. If the array uses type C xsubpp will +automatically work out that it contains variables of type C and +use that typemap entry to perform the copy of each element. All +pointer '*' and 'Array' tags are removed from the name to determine +the subtype. + +=cut + +# Test passes in an integer array and returns it along with +# the number of elements +# Pass in a dummy value to test offsetting + +# Problem is that xsubpp does XSRETURN(1) because we arent +# using PPCODE. This means that only the first element +# is returned. KLUGE this by using CLEANUP to return before the +# end. + +intArray * +T_ARRAY( dummy, array, ... ) + int dummy = NO_INIT + intArray * array + PREINIT: + U32 size_RETVAL; + CODE: + size_RETVAL = ix_array; + RETVAL = array; + OUTPUT: + RETVAL + CLEANUP: + Safefree(array); + XSRETURN(size_RETVAL); + + +=item T_STDIO + +This is used for passing perl filehandles to and from C using +C structures. + +=cut + +FILE * +T_STDIO_open( file ) + const char * file + CODE: + RETVAL = xsfopen( file ); + OUTPUT: + RETVAL + +SysRet +T_STDIO_close( stream ) + FILE * stream + CODE: + RETVAL = xsfclose( stream ); + OUTPUT: + RETVAL + +int +T_STDIO_print( stream, string ) + FILE * stream + const char * string + CODE: + RETVAL = xsfprintf( stream, string ); + OUTPUT: + RETVAL + + +=item T_IN + +NOT YET + +=item T_INOUT + +This is used for passing perl filehandles to and from C using +C structures. The file handle can used for reading and +writing. + +See L for more information on the Perl IO abstraction +layer. Perl must have been built with C<-Duseperlio>. + +=item T_OUT + +NOT YET + +=back + +=cut + diff --git a/ext/XS/Typemap/stdio.c b/ext/XS/Typemap/stdio.c new file mode 100644 index 0000000..fc4bf45 --- /dev/null +++ b/ext/XS/Typemap/stdio.c @@ -0,0 +1,28 @@ + +/* This provides a test of STDIO and emulates a library that + has been built outside of the PerlIO system and therefore is + built using FILE* rather than PerlIO * (a common occurrence + for XS). + + Use a separate file to make sure we are not contaminated by + PerlIO. +*/ + +#include + +/* Open a file for write */ +FILE * xsfopen ( const char * path ) { + FILE * stream; + stream = fopen( path, "w"); + return stream; +} + +int xsfclose ( FILE * stream ) { + return fclose( stream ); +} + + +int xsfprintf ( FILE * stream, const char * text ) { + return fprintf( stream, text ); +} + diff --git a/ext/XS/Typemap/typemap b/ext/XS/Typemap/typemap new file mode 100644 index 0000000..909221d --- /dev/null +++ b/ext/XS/Typemap/typemap @@ -0,0 +1,17 @@ +# Typemap file for typemap testing +# includes bonus typemap entries +# Mainly so that all the standard typemaps can be exercised even when +# there is not a corresponding type explicitly identified in the standard +# typemap + +svtype T_ENUM +intRef * T_PTRREF +intRef T_IV +intObj * T_PTROBJ +intObj T_IV +intRefIv * T_REF_IV_PTR +intRefIv T_IV +intArray * T_ARRAY +intOpq T_IV +intOpq * T_OPAQUEPTR +shortOPQ T_OPAQUE diff --git a/t/lib/xs-typemap.t b/t/lib/xs-typemap.t new file mode 100644 index 0000000..c6853c4 --- /dev/null +++ b/t/lib/xs-typemap.t @@ -0,0 +1,310 @@ +use Test; +BEGIN { plan tests => 78 } + +use strict; +use warnings; +use XS::Typemap; + +ok(1); + +# Some inheritance trees to check ISA relationships +BEGIN { + package intObjPtr::SubClass; + use base qw/ intObjPtr /; + sub xxx { 1; } +} + +BEGIN { + package intRefIvPtr::SubClass; + use base qw/ intRefIvPtr /; + sub xxx { 1 } +} + +# T_SV - standard perl scalar value +print "# T_SV\n"; + +my $sv = "Testing T_SV"; +ok( T_SV($sv), $sv); + +# T_SVREF - reference to Scalar +print "# T_SVREF\n"; + +$sv .= "REF"; +my $svref = \$sv; +ok( T_SVREF($svref), $svref ); + +# Now test that a non reference is rejected +# the typemaps croak +eval { T_SVREF( "fail - not ref" ) }; +ok( $@ ); + +# T_AVREF - reference to a perl Array +print "# T_AVREF\n"; + +my @array; +ok( T_AVREF(\@array), \@array); + +# Now test that a non array ref is rejected +eval { T_AVREF( \$sv ) }; +ok( $@ ); + +# T_HVREF - reference to a perl Hash +print "# T_HVREF\n"; + +my %hash; +ok( T_HVREF(\%hash), \%hash); + +# Now test that a non hash ref is rejected +eval { T_HVREF( \@array ) }; +ok( $@ ); + + +# T_CVREF - reference to perl subroutine +print "# T_CVREF\n"; +my $sub = sub { 1 }; +ok( T_CVREF($sub), $sub ); + +# Now test that a non code ref is rejected +eval { T_CVREF( \@array ) }; +ok( $@ ); + +# T_SYSRET - system return values +print "# T_SYSRET\n"; + +# first check success +ok( T_SYSRET_pass ); + +# ... now failure +ok( T_SYSRET_fail, undef); + +# T_UV - unsigned integer +print "# T_UV\n"; + +ok( T_UV(5), 5 ); # pass +ok( T_UV(-4) != -4); # fail + +# T_IV - signed integer +print "# T_IV\n"; + +ok( T_IV(5), 5); +ok( T_IV(-4), -4); +ok( T_IV(4.1), int(4.1)); +ok( T_IV("52"), "52"); +ok( T_IV(4.5) != 4.5); # failure + + +# Skip T_INT + +# T_ENUM - enum list +print "# T_ENUM\n"; + +ok( T_ENUM() ); # just hope for a true value + +# T_BOOL - boolean +print "# T_BOOL\n"; + +ok( T_BOOL(52) ); +ok( ! T_BOOL(0) ); +ok( ! T_BOOL('') ); +ok( ! T_BOOL(undef) ); + +# Skip T_U_INT + +# Skip T_SHORT + +# T_U_SHORT aka U16 + +print "# T_U_SHORT\n"; + +ok( T_U_SHORT(32000), 32000); +ok( T_U_SHORT(65536) != 65536); # probably dont want to test edge cases + +# T_U_LONG aka U32 + +print "# T_U_LONG\n"; + +ok( T_U_LONG(65536), 65536); +ok( T_U_LONG(-1) != -1); + +# T_CHAR + +print "# T_CHAR\n"; + +ok( T_CHAR("a"), "a"); +ok( T_CHAR("-"), "-"); +ok( T_CHAR(chr(128)),chr(128)); +ok( T_CHAR(chr(256)) ne chr(256)); + +# T_U_CHAR + +print "# T_U_CHAR\n"; + +ok( T_U_CHAR(127), 127); +ok( T_U_CHAR(128), 128); +ok( T_U_CHAR(-1) != -1); +ok( T_U_CHAR(300) != 300); + +# T_FLOAT +print "# T_FLOAT\n"; + +# limited precision +ok( sprintf("%6.3f",T_FLOAT(52.345)), 52.345); + +# T_NV +print "# T_NV\n"; + +ok( T_NV(52.345), 52.345); + +# T_DOUBLE +print "# T_DOUBLE\n"; + +ok( T_DOUBLE(52.345), 52.345); + +# T_PV +print "# T_PV\n"; + +ok( T_PV("a string"), "a string"); +ok( T_PV(52), 52); + +# T_PTR +print "# T_PTR\n"; + +my $t = 5; +my $ptr = T_PTR_OUT($t); +ok( T_PTR_IN( $ptr ), $t ); + +# T_PTRREF +print "# T_PTRREF\n"; + +$t = -52; +$ptr = T_PTRREF_OUT( $t ); +ok( ref($ptr), "SCALAR"); +ok( T_PTRREF_IN( $ptr ), $t ); + +# test that a non-scalar ref is rejected +eval { T_PTRREF_IN( $t ); }; +ok( $@ ); + +# T_PTROBJ +print "# T_PTROBJ\n"; + +$t = 256; +$ptr = T_PTROBJ_OUT( $t ); +ok( ref($ptr), "intObjPtr"); +ok( $ptr->T_PTROBJ_IN, $t ); + +# check that normal scalar refs fail +eval {intObjPtr::T_PTROBJ_IN( \$t );}; +ok( $@ ); + +# check that inheritance works +bless $ptr, "intObjPtr::SubClass"; +ok( ref($ptr), "intObjPtr::SubClass"); +ok( $ptr->T_PTROBJ_IN, $t ); + +# Skip T_REF_IV_REF + +# T_REF_IV_PTR +print "# T_REF_IV_PTR\n"; + +$t = -365; +$ptr = T_REF_IV_PTR_OUT( $t ); +ok( ref($ptr), "intRefIvPtr"); +ok( $ptr->T_REF_IV_PTR_IN(), $t); + +# inheritance should not work +bless $ptr, "intRefIvPtr::SubClass"; +eval { $ptr->T_REF_IV_PTR_IN }; +ok( $@ ); + +# Skip T_PTRDESC + +# Skip T_REFREF + +# Skip T_REFOBJ + +# T_OPAQUEPTR +print "# T_OPAQUEPTR\n"; + +$t = 22; +$ptr = T_OPAQUEPTR_IN( $t ); +ok( T_OPAQUEPTR_OUT($ptr), $t); + +# T_OPAQUE +print "# T_OPAQUE\n"; + +$t = 48; +$ptr = T_OPAQUE_IN( $t ); +ok(T_OPAQUEPTR_OUT( $ptr ), $t); + +# T_OPAQUE_array +my @opq = (2,4,8); +my $packed = T_OPAQUE_array(@opq); +my @uopq = unpack("i*",$packed); +for (0..$#opq) { + ok( $uopq[$_], $opq[$_]); +} + +# Skip T_PACKED + +# Skip T_PACKEDARRAY + +# Skip T_DATAUNIT + +# Skip T_CALLBACK + +# T_ARRAY +print "# T_ARRAY\n"; +my @inarr = (1,2,3,4,5,6,7,8,9,10); +my @outarr = T_ARRAY( 5, @inarr ); +ok(scalar(@outarr), scalar(@inarr)); + +for (0..$#inarr) { + ok($outarr[$_], $inarr[$_]); +} + + + +# T_STDIO +print "# T_STDIO\n"; + +# open a file in XS for write +my $testfile= "stdio.tmp"; +my $fh = T_STDIO_open( $testfile ); +ok( $fh ); + +# write to it using perl +if (defined $fh) { + + my @lines = ("NormalSTDIO\n", "PerlIO\n"); + + # print to it using FILE* through XS + ok( T_STDIO_print($fh, $lines[0]), length($lines[0])); + + # print to it using normal perl + ok(print $fh "$lines[1]"); + + # close it using XS + # This works fine but causes a segmentation fault during global + # destruction when the glob associated with this filehandle is + # tidied up. +# ok( T_STDIO_close( $fh ) ); + ok(close($fh)); # using perlio to close the glob works fine + + # open from perl, and check contents + open($fh, "< $testfile"); + ok($fh); + my $line = <$fh>; + ok($line,$lines[0]); + $line = <$fh>; + ok($line,$lines[1]); + + ok(close($fh)); + ok(unlink($testfile)); + +} else { + for (1..8) { + skip("Skip Test not relevant since file was not opened correctly",0); + } +} +