//
// SWIG pointer conversion and utility library
//
// Dave Beazley
// April 19, 1997
//
// Perl5 specific implementation. This file is included
// by the file ../pointer.i
%{
#ifdef WIN32
#undef isspace
#define isspace(c) (c == ' ')
#endif
/*------------------------------------------------------------------
ptrcast(value,type)
Constructs a new pointer value. Value may either be a string
or an integer. Type is a string corresponding to either the
C datatype or mangled datatype.
ptrcast(0,"Vector *")
or
ptrcast(0,"Vector_p")
------------------------------------------------------------------ */
#ifdef PERL_OBJECT
static SV *_ptrcast(CPerl *pPerl, SV *_PTRVALUE, char *type) {
#define ptrcast(a,b) _ptrcast(pPerl,a,b)
#else
static SV *_ptrcast(SV *_PTRVALUE, char *type) {
#define ptrcast(a,b) _ptrcast(a,b)
#endif
char *r,*s;
void *ptr;
SV *obj;
char *typestr,*c;
/* Produce a "mangled" version of the type string. */
typestr = (char *) malloc(strlen(type)+20);
/* Go through and munge the typestring */
r = typestr;
c = type;
while (*c) {
if (!isspace(*c)) {
if ((*c == '*') || (*c == '&')) {
strcpy(r,"Ptr");
r+=3;
} else *(r++) = *c;
}
c++;
}
*(r++) = 0;
/* Check to see if the input value is an integer */
if (SvIOK(_PTRVALUE)) {
ptr = (void *) SvIV(_PTRVALUE);
/* Received a numerical value. Make a pointer out of it */
obj = sv_newmortal();
sv_setref_pv(obj,typestr,ptr);
} else if (sv_isobject(_PTRVALUE)) {
/* Have a real pointer value now. Try to strip out the pointer value */
/* Now extract the pointer value */
if (!SWIG_GetPtr(_PTRVALUE,&ptr,0)) {
obj = sv_newmortal();
sv_setref_pv(obj,typestr,ptr);
}
} else {
croak("ptrcast(). Not a reference.");
}
free(typestr);
return obj;
}
/*------------------------------------------------------------------
ptrvalue(ptr,type = 0)
Attempts to dereference a pointer value. If type is given, it
will try to use that type. Otherwise, this function will attempt
to "guess" the proper datatype by checking against all of the
builtin C datatypes.
------------------------------------------------------------------ */
#ifdef PERL_OBJECT
static SV *_ptrvalue(CPerl *pPerl,SV *_PTRVALUE, int index, char *type) {
#define ptrvalue(a,b,c) _ptrvalue(pPerl,a,b,c)
#else
static SV *_ptrvalue(SV *_PTRVALUE, int index, char *type) {
#define ptrvalue(a,b,c) _ptrvalue(a,b,c)
#endif
void *ptr;
SV *obj = 0;
if (SWIG_GetPtr(_PTRVALUE,&ptr,0)) {
croak("Type error it ptrvalue. Argument is not a valid pointer value.");
} else {
/* If no datatype was passed, try a few common datatypes first */
if (!type) {
/* No datatype was passed. Type to figure out if it's a common one */
if (!SWIG_GetPtr(_PTRVALUE,&ptr,"intPtr")) {
type = "int";
} else if (!SWIG_GetPtr(_PTRVALUE,&ptr,"doublePtr")) {
type = "double";
} else if (!SWIG_GetPtr(_PTRVALUE,&ptr,"shortPtr")) {
type = "short";
} else if (!SWIG_GetPtr(_PTRVALUE,&ptr,"longPtr")) {
type = "long";
} else if (!SWIG_GetPtr(_PTRVALUE,&ptr,"floatPtr")) {
type = "float";
} else if (!SWIG_GetPtr(_PTRVALUE,&ptr,"charPtr")) {
type = "char";
} else if (!SWIG_GetPtr(_PTRVALUE,&ptr,"charPtrPtr")) {
type = "char *";
} else {
type = "unknown";
}
}
if (!ptr) {
croak("Unable to dereference NULL pointer.");
return 0;
}
/* Now we have a datatype. Try to figure out what to do about it */
if (strcmp(type,"int") == 0) {
obj = sv_newmortal();
sv_setiv(obj,(IV) *(((int *) ptr) + index));
} else if (strcmp(type,"double") == 0) {
obj = sv_newmortal();
sv_setnv(obj,(double) *(((double *) ptr)+index));
} else if (strcmp(type,"short") == 0) {
obj = sv_newmortal();
sv_setiv(obj,(IV) *(((short *) ptr) + index));
} else if (strcmp(type,"long") == 0) {
obj = sv_newmortal();
sv_setiv(obj,(IV) *(((long *) ptr) + index));
} else if (strcmp(type,"float") == 0) {
obj = sv_newmortal();
sv_setnv(obj,(double) *(((float *) ptr)+index));
} else if (strcmp(type,"char") == 0) {
obj = sv_newmortal();
sv_setpv(obj,((char *) ptr)+index);
} else if (strcmp(type,"char *") == 0) {
char *c = *(((char **) ptr)+index);
obj = sv_newmortal();
if (c)
sv_setpv(obj,c);
else
sv_setpv(obj,"NULL");
} else {
croak("Unable to dereference unsupported datatype.");
obj = 0;
}
}
return obj;
}
/*------------------------------------------------------------------
ptrcreate(type,value = 0,numelements = 1)
Attempts to create a new object of given type. Type must be
a basic C datatype. Will not create complex objects.
------------------------------------------------------------------ */
#ifdef PERL_OBJECT
static SV *_ptrcreate(CPerl *pPerl, char *type, SV *value, int numelements) {
#define ptrcreate(a,b,c) _ptrcreate(pPerl,a,b,c)
#else
static SV *_ptrcreate(char *type, SV *value, int numelements) {
#define ptrcreate(a,b,c) _ptrcreate(a,b,c)
#endif
void *ptr;
SV *obj;
int sz;
char *cast;
char temp[40];
/* Check the type string against a variety of possibilities */
if (strcmp(type,"int") == 0) {
sz = sizeof(int)*numelements;
cast = "intPtr";
} else if (strcmp(type,"short") == 0) {
sz = sizeof(short)*numelements;
cast = "shortPtr";
} else if (strcmp(type,"long") == 0) {
sz = sizeof(long)*numelements;
cast = "longPtr";
} else if (strcmp(type,"double") == 0) {
sz = sizeof(double)*numelements;
cast = "doublePtr";
} else if (strcmp(type,"float") == 0) {
sz = sizeof(float)*numelements;
cast = "floatPtr";
} else if (strcmp(type,"char") == 0) {
sz = sizeof(char)*numelements;
cast = "charPtr";
} else if (strcmp(type,"char *") == 0) {
sz = sizeof(char *)*(numelements+1);
cast = "charPtrPtr";
} else if (strcmp(type,"void") == 0) {
sz = numelements;
cast = "voidPtr";
} else {
croak("Unable to create unknown datatype.");
return 0;
}
/* Create the new object */
ptr = (void *) malloc(sz);
if (!ptr) {
croak("Out of memory in ptrcreate.");
return 0;
}
/* Now try to set its default value */
if (value) {
if (strcmp(type,"int") == 0) {
int *ip,i,ivalue;
ivalue = (int) SvIV(value);
ip = (int *) ptr;
for (i = 0; i < numelements; i++)
ip[i] = ivalue;
} else if (strcmp(type,"short") == 0) {
short *ip,ivalue;
int i;
ivalue = (short) SvIV(value);
ip = (short *) ptr;
for (i = 0; i < numelements; i++)
ip[i] = ivalue;
} else if (strcmp(type,"long") == 0) {
long *ip,ivalue;
int i;
ivalue = (long) SvIV(value);
ip = (long *) ptr;
for (i = 0; i < numelements; i++)
ip[i] = ivalue;
} else if (strcmp(type,"double") == 0) {
double *ip,ivalue;
int i;
ivalue = (double) SvNV(value);
ip = (double *) ptr;
for (i = 0; i < numelements; i++)
ip[i] = ivalue;
} else if (strcmp(type,"float") == 0) {
float *ip,ivalue;
int i;
ivalue = (float) SvNV(value);
ip = (float *) ptr;
for (i = 0; i < numelements; i++)
ip[i] = ivalue;
} else if (strcmp(type,"char") == 0) {
char *ip,*ivalue;
ivalue = (char *) SvPV(value,na);
ip = (char *) ptr;
strncpy(ip,ivalue,numelements-1);
} else if (strcmp(type,"char *") == 0) {
char **ip, *ivalue;
int i;
ivalue = (char *) SvPV(value,na);
ip = (char **) ptr;
for (i = 0; i < numelements; i++) {
if (ivalue) {
ip[i] = (char *) malloc(strlen(ivalue)+1);
strcpy(ip[i],ivalue);
} else {
ip[i] = 0;
}
}
ip[numelements] = 0;
}
}
/* Create the pointer value */
SWIG_MakePtr(temp,ptr,cast);
obj = sv_newmortal();
sv_setref_pv(obj,cast,ptr);
return obj;
}
/*------------------------------------------------------------------
ptrset(ptr,value,index = 0,type = 0)
Attempts to set the value of a pointer variable. If type is
given, we will use that type. Otherwise, we'll guess the datatype.
------------------------------------------------------------------ */
#ifdef PERL_OBJECT
static void _ptrset(CPerl *pPerl,SV *_PTRVALUE, SV *value, int index, char *type) {
#define ptrset(a,b,c,d) _ptrset(pPerl,a,b,c,d)
#else
static void _ptrset(SV *_PTRVALUE, SV *value, int index, char *type) {
#define ptrset(a,b,c,d) _ptrset(a,b,c,d)
#endif
void *ptr;
SV *obj;
if (SWIG_GetPtr(_PTRVALUE,&ptr,0)) {
croak("Type error in ptrset. Argument is not a valid pointer value.");
return;
}
/* If no datatype was passed, try a few common datatypes first */
if (!type) {
/* No datatype was passed. Type to figure out if it's a common one */
if (!SWIG_GetPtr(_PTRVALUE,&ptr,"intPtr")) {
type = "int";
} else if (!SWIG_GetPtr(_PTRVALUE,&ptr,"doublePtr")) {
type = "double";
} else if (!SWIG_GetPtr(_PTRVALUE,&ptr,"shortPtr")) {
type = "short";
} else if (!SWIG_GetPtr(_PTRVALUE,&ptr,"longPtr")) {
type = "long";
} else if (!SWIG_GetPtr(_PTRVALUE,&ptr,"floatPtr")) {
type = "float";
} else if (!SWIG_GetPtr(_PTRVALUE,&ptr,"charPtr")) {
type = "char";
} else if (!SWIG_GetPtr(_PTRVALUE,&ptr,"charPtrPtr")) {
type = "char *";
} else {
type = "unknown";
}
}
if (!ptr) {
croak("Unable to set NULL pointer.");
return;
}
/* Now we have a datatype. Try to figure out what to do about it */
if (strcmp(type,"int") == 0) {
*(((int *) ptr)+index) = (int) SvIV(value);
} else if (strcmp(type,"double") == 0) {
*(((double *) ptr)+index) = (double) SvNV(value);
} else if (strcmp(type,"short") == 0) {
*(((short *) ptr)+index) = (short) SvIV(value);
} else if (strcmp(type,"long") == 0) {
*(((long *) ptr)+index) = (long) SvIV(value);
} else if (strcmp(type,"float") == 0) {
*(((float *) ptr)+index) = (float) SvNV(value);
} else if (strcmp(type,"char") == 0) {
char *c = SvPV(value,na);
strcpy(((char *) ptr)+index, c);
} else if (strcmp(type,"char *") == 0) {
char *c = SvPV(value,na);
char **ca = (char **) ptr;
if (ca[index]) free(ca[index]);
if (strcmp(c,"NULL") == 0) {
ca[index] = 0;
} else {
ca[index] = (char *) malloc(strlen(c)+1);
strcpy(ca[index],c);
}
} else {
croak("Unable to set unsupported datatype.");
return;
}
}
/*------------------------------------------------------------------
ptradd(ptr,offset)
Adds a value to an existing pointer value. Will do a type-dependent
add for basic datatypes. For other datatypes, will do a byte-add.
------------------------------------------------------------------ */
#ifdef PERL_OBJECT
static SV *_ptradd(CPerl *pPerl, SV *_PTRVALUE, int offset) {
#define ptradd(a,b) _ptradd(pPerl,a,b)
#else
static SV *_ptradd(SV *_PTRVALUE, int offset) {
#define ptradd(a,b) _ptradd(a,b)
#endif
void *ptr,*junk;
SV *obj;
char *type;
/* Try to handle a few common datatypes first */
if (!SWIG_GetPtr(_PTRVALUE,&ptr,"intPtr")) {
ptr = (void *) (((int *) ptr) + offset);
} else if (!SWIG_GetPtr(_PTRVALUE,&ptr,"doublePtr")) {
ptr = (void *) (((double *) ptr) + offset);
} else if (!SWIG_GetPtr(_PTRVALUE,&ptr,"shortPtr")) {
ptr = (void *) (((short *) ptr) + offset);
} else if (!SWIG_GetPtr(_PTRVALUE,&ptr,"longPtr")) {
ptr = (void *) (((long *) ptr) + offset);
} else if (!SWIG_GetPtr(_PTRVALUE,&ptr,"floatPtr")) {
ptr = (void *) (((float *) ptr) + offset);
} else if (!SWIG_GetPtr(_PTRVALUE,&ptr,"charPtr")) {
ptr = (void *) (((char *) ptr) + offset);
} else if (!SWIG_GetPtr(_PTRVALUE,&ptr,0)) {
ptr = (void *) (((char *) ptr) + offset);
} else {
croak("Type error in ptradd. Argument is not a valid pointer value.");
return 0;
}
type = SWIG_GetPtr(_PTRVALUE,&junk,"INVALID POINTER");
obj = sv_newmortal();
sv_setref_pv(obj,type,ptr);
return obj;
}
/*------------------------------------------------------------------
ptrmap(type1,type2)
Allows a mapping between type1 and type2. (Like a typedef)
------------------------------------------------------------------ */
#ifdef PERL_OBJECT
static void _ptrmap(CPerl *pPerl,char *type1, char *type2) {
#define ptrmap(a,b) _ptrmap(pPerl,a,b)
#else
static void _ptrmap(char *type1, char *type2) {
#define ptrmap(a,b) _ptrmap(a,b)
#endif
char *typestr1,*typestr2,*c,*r;
/* Produce a "mangled" version of the type string. */
typestr1 = (char *) malloc(strlen(type1)+20);
/* Go through and munge the typestring */
r = typestr1;
*(r++) = '_';
c = type1;
while (*c) {
if (!isspace(*c)) {
if ((*c == '*') || (*c == '&')) {
strcpy(r,"Ptr");
r+=3;
}
else *(r++) = *c;
}
c++;
}
*(r++) = 0;
typestr2 = (char *) malloc(strlen(type2)+20);
/* Go through and munge the typestring */
r = typestr2;
*(r++) = '_';
c = type2;
while (*c) {
if (!isspace(*c)) {
if ((*c == '*') || (*c == '&')) {
strcpy(r,"Ptr");
r+=3;
}
else *(r++) = *c;
}
c++;
}
*(r++) = 0;
SWIG_RegisterMapping(typestr1,typestr2,0);
SWIG_RegisterMapping(typestr2,typestr1,0);
}
/*------------------------------------------------------------------
ptrfree(ptr)
Destroys a pointer value
------------------------------------------------------------------ */
#ifdef PERL_OBJECT
void _ptrfree(CPerl *pPerl, SV *_PTRVALUE) {
#define ptrfree(a) _ptrfree(pPerl, a)
#else
void _ptrfree(SV *_PTRVALUE) {
#define ptrfree(a) _ptrfree(a)
#endif
void *ptr, *junk;
if (SWIG_GetPtr(_PTRVALUE,&ptr,0)) {
croak("Type error in ptrfree. Argument is not a valid pointer value.");
return;
}
/* Check to see if this pointer is a char ** */
if (!SWIG_GetPtr(_PTRVALUE,&junk,"charPtrPtr")) {
char **c = (char **) ptr;
if (c) {
int i = 0;
while (c[i]) {
free(c[i]);
i++;
}
}
}
if (ptr)
free((char *) ptr);
}
%}
%typemap(perl5,in) SV *ptr, SV *value {
$target = $source;
}
%typemap(perl5,out) SV *ptrcast,
SV *ptrvalue,
SV *ptrcreate,
SV *ptradd
{
$target = $source;
argvi++;
}
%typemap(perl5,ret) int ptrset {
if ($source == -1) return NULL;
}
SV *ptrcast(SV *ptr, char *type);
// Casts a pointer ptr to a new datatype given by the string type.
// type may be either the SWIG generated representation of a datatype
// or the C representation. For example :
//
// ptrcast($ptr,"doublePtr"); # Perl5 representation
// ptrcast($ptr,"double *"); # C representation
//
// A new pointer value is returned. ptr may also be an integer
// value in which case the value will be used to set the pointer
// value. For example :
//
// $a = ptrcast(0,"VectorPtr");
//
// Will create a NULL pointer of type "VectorPtr"
//
// The casting operation is sensitive to formatting. As a result,
// "double *" is different than "double*". As a result of thumb,
// there should always be exactly one space between the C datatype
// and any pointer specifiers (*).
SV *ptrvalue(SV *ptr, int index = 0, char *type = 0);
// Returns the value that a pointer is pointing to (ie. dereferencing).
// The type is automatically inferred by the pointer type--thus, an
// integer pointer will return an integer, a double will return a double,
// and so on. The index and type fields are optional parameters. When
// an index is specified, this function returns the value of ptr[index].
// This allows array access. When a type is specified, it overrides
// the given pointer type. Examples :
//
// ptrvalue($a) # Returns the value *a
// ptrvalue($a,10) # Returns the value a[10]
// ptrvalue($a,10,"double") # Returns a[10] assuming a is a double *
void ptrset(SV *ptr, SV *value, int index = 0, char *type = 0);
// Sets the value pointed to by a pointer. The type is automatically
// inferred from the pointer type so this function will work for
// integers, floats, doubles, etc... The index and type fields are
// optional. When an index is given, it provides array access. When
// type is specified, it overrides the given pointer type. Examples :
//
// ptrset($a,3) # Sets the value *a = 3
// ptrset($a,3,10) # Sets a[10] = 3
// ptrset($a,3,10,"int") # Sets a[10] = 3 assuming a is a int *
SV *ptrcreate(char *type, SV *value = 0, int nitems = 1);
// Creates a new object and returns a pointer to it. This function
// can be used to create various kinds of objects for use in C functions.
// type specifies the basic C datatype to create and value is an
// optional parameter that can be used to set the initial value of the
// object. nitems is an optional parameter that can be used to create
// an array. This function results in a memory allocation using
// malloc(). Examples :
//
// $a = ptrcreate("double") # Create a new double, return pointer
// $a = ptrcreate("int",7) # Create an integer, set value to 7
// $a = ptrcreate("int",0,1000) # Create an integer array with initial
// # values all set to zero
//
// This function only recognizes a few common C datatypes as listed below :
//
// int, short, long, float, double, char, char *, void
//
// All other datatypes will result in an error. However, other
// datatypes can be created by using the ptrcast function. For
// example:
//
// $a = ptrcast(ptrcreate("int",0,100),"unsigned int *")
void ptrfree(SV *ptr);
// Destroys the memory pointed to by ptr. This function calls free()
// and should only be used with objects created by ptrcreate(). Since
// this function calls free, it may work with other objects, but this
// is generally discouraged unless you absolutely know what you're
// doing.
SV *ptradd(SV *ptr, int offset);
// Adds a value to the current pointer value. For the C datatypes of
// int, short, long, float, double, and char, the offset value is the
// number of objects and works in exactly the same manner as in C. For
// example, the following code steps through the elements of an array
//
// $a = ptrcreate("double",0,100); # Create an array double a[100]
// $b = $a;
// for ($i = 0; $i < 100; $i++) {
// ptrset($b,0.0025*$i); # set *b = 0.0025*i
// $b = ptradd($b,1); # b++ (go to next double)
// }
//
// In this case, adding one to b goes to the next double.
//
// For all other datatypes (including all complex datatypes), the
// offset corresponds to bytes. This function does not perform any
// bounds checking and negative offsets are perfectly legal.
void ptrmap(char *type1, char *type2);
// This is a rarely used function that performs essentially the same
// operation as a C typedef. To manage datatypes at run-time, SWIG
// modules manage an internal symbol table of type mappings. This
// table keeps track of which types are equivalent to each other. The
// ptrmap() function provides a mechanism for scripts to add symbols
// to this table. For example :
//
// ptrmap("doublePtr","RealPtr");
//
// would make the types "doublePtr" and "RealPtr" equivalent to each
// other. Pointers of either type could now be used interchangably.
//
// Normally this function is not needed, but it can be used to
// circumvent SWIG's normal type-checking behavior or to work around
// weird type-handling problems.
syntax highlighted by Code2HTML, v. 0.9.1