2 // SWIG pointer conversion and utility library
 
   7 // Perl5 specific implementation.   This file is included
 
   8 // by the file ../pointer.i
 
  14 #define isspace(c) (c == ' ')
 
  17 /*------------------------------------------------------------------
 
  20   Constructs a new pointer value.   Value may either be a string
 
  21   or an integer. Type is a string corresponding to either the
 
  22   C datatype or mangled datatype.
 
  27   ------------------------------------------------------------------ */
 
  29 static SV *_ptrcast(CPerlObj *pPerl, SV *_PTRVALUE, char *type) {
 
  30 #define ptrcast(a,b)  _ptrcast(pPerl,a,b)
 
  32 static SV *_ptrcast(SV *_PTRVALUE, char *type) {
 
  33 #define ptrcast(a,b)  _ptrcast(a,b)
 
  40   /* Produce a "mangled" version of the type string.  */
 
  42   typestr = (char *) malloc(strlen(type)+20);
 
  44   /* Go through and munge the typestring */
 
  50       if ((*c == '*') || (*c == '&')) {
 
  59   /* Check to see if the input value is an integer */
 
  60   if (SvIOK(_PTRVALUE)) {
 
  61     ptr = (void *) SvIV(_PTRVALUE);
 
  62     /* Received a numerical value. Make a pointer out of it */
 
  64     sv_setref_pv(obj,typestr,ptr);
 
  65   } else if (sv_isobject(_PTRVALUE)) {
 
  66     /* Have a real pointer value now.  Try to strip out the pointer value */
 
  67     /* Now extract the pointer value */
 
  68     if (!SWIG_GetPtr(_PTRVALUE,&ptr,0)) {
 
  70       sv_setref_pv(obj,typestr,ptr);
 
  73     croak("ptrcast(). Not a reference.");
 
  81 /*------------------------------------------------------------------
 
  82   ptrvalue(ptr,type = 0)
 
  84   Attempts to dereference a pointer value.  If type is given, it 
 
  85   will try to use that type.  Otherwise, this function will attempt
 
  86   to "guess" the proper datatype by checking against all of the 
 
  88   ------------------------------------------------------------------ */
 
  91 static SV *_ptrvalue(CPerlObj *pPerl,SV *_PTRVALUE, int index, char *type) {
 
  92 #define ptrvalue(a,b,c) _ptrvalue(pPerl,a,b,c)
 
  94 static SV *_ptrvalue(SV *_PTRVALUE, int index, char *type) {
 
  95 #define ptrvalue(a,b,c) _ptrvalue(a,b,c)
 
 102   if (SWIG_GetPtr(_PTRVALUE,&ptr,0)) {
 
 103     croak("Type error it ptrvalue. Argument is not a valid pointer value.");
 
 105     /* If no datatype was passed, try a few common datatypes first */
 
 108       /* No datatype was passed.   Type to figure out if it's a common one */
 
 110       if (!SWIG_GetPtr(_PTRVALUE,&ptr,"intPtr")) {
 
 112       } else if (!SWIG_GetPtr(_PTRVALUE,&ptr,"doublePtr")) {
 
 114       } else if (!SWIG_GetPtr(_PTRVALUE,&ptr,"shortPtr")) {
 
 116       } else if (!SWIG_GetPtr(_PTRVALUE,&ptr,"longPtr")) {
 
 118       } else if (!SWIG_GetPtr(_PTRVALUE,&ptr,"floatPtr")) {
 
 120       } else if (!SWIG_GetPtr(_PTRVALUE,&ptr,"charPtr")) {
 
 122       } else if (!SWIG_GetPtr(_PTRVALUE,&ptr,"charPtrPtr")) {
 
 130       croak("Unable to dereference NULL pointer.");
 
 134     /* Now we have a datatype.  Try to figure out what to do about it */
 
 135     if (strcmp(type,"int") == 0) {
 
 136       obj = sv_newmortal();
 
 137       sv_setiv(obj,(IV) *(((int *) ptr) + index));
 
 138     } else if (strcmp(type,"double") == 0) {
 
 139       obj = sv_newmortal();
 
 140       sv_setnv(obj,(double) *(((double *) ptr)+index));
 
 141     } else if (strcmp(type,"short") == 0) {
 
 142       obj = sv_newmortal();
 
 143       sv_setiv(obj,(IV) *(((short *) ptr) + index));
 
 144     } else if (strcmp(type,"long") == 0) {
 
 145       obj = sv_newmortal();
 
 146       sv_setiv(obj,(IV) *(((long *) ptr) + index));
 
 147     } else if (strcmp(type,"float") == 0) {
 
 148       obj = sv_newmortal();
 
 149       sv_setnv(obj,(double) *(((float *) ptr)+index));
 
 150     } else if (strcmp(type,"char") == 0) {
 
 151       obj = sv_newmortal();
 
 152       sv_setpv(obj,((char *) ptr)+index);
 
 153     } else if (strcmp(type,"char *") == 0) {
 
 154       char *c = *(((char **) ptr)+index);
 
 155       obj = sv_newmortal();
 
 159         sv_setpv(obj,"NULL");
 
 161       croak("Unable to dereference unsupported datatype.");
 
 168 /*------------------------------------------------------------------
 
 169   ptrcreate(type,value = 0,numelements = 1)
 
 171   Attempts to create a new object of given type.  Type must be
 
 172   a basic C datatype.  Will not create complex objects.
 
 173   ------------------------------------------------------------------ */
 
 175 static SV *_ptrcreate(CPerlObj *pPerl, char *type, SV *value, int numelements) {
 
 176 #define ptrcreate(a,b,c) _ptrcreate(pPerl,a,b,c)
 
 178 static SV *_ptrcreate(char *type, SV *value, int numelements) {
 
 179 #define ptrcreate(a,b,c) _ptrcreate(a,b,c)
 
 188   /* Check the type string against a variety of possibilities */
 
 190   if (strcmp(type,"int") == 0) {
 
 191     sz = sizeof(int)*numelements;
 
 193   } else if (strcmp(type,"short") == 0) {
 
 194     sz = sizeof(short)*numelements;
 
 196   } else if (strcmp(type,"long") == 0) {
 
 197     sz = sizeof(long)*numelements;
 
 199   } else if (strcmp(type,"double") == 0) {
 
 200     sz = sizeof(double)*numelements;
 
 202   } else if (strcmp(type,"float") == 0) {
 
 203     sz = sizeof(float)*numelements;
 
 205   } else if (strcmp(type,"char") == 0) {
 
 206     sz = sizeof(char)*numelements;
 
 208   } else if (strcmp(type,"char *") == 0) {
 
 209     sz = sizeof(char *)*(numelements+1);
 
 211   } else if (strcmp(type,"void") == 0) {
 
 215     croak("Unable to create unknown datatype."); 
 
 219   /* Create the new object */
 
 221   ptr = (void *) malloc(sz);
 
 223     croak("Out of memory in ptrcreate."); 
 
 227   /* Now try to set its default value */
 
 230     if (strcmp(type,"int") == 0) {
 
 232       ivalue = (int) SvIV(value);
 
 234       for (i = 0; i < numelements; i++)
 
 236     } else if (strcmp(type,"short") == 0) {
 
 239       ivalue = (short) SvIV(value);
 
 241       for (i = 0; i < numelements; i++)
 
 243     } else if (strcmp(type,"long") == 0) {
 
 246       ivalue = (long) SvIV(value);
 
 248       for (i = 0; i < numelements; i++)
 
 250     } else if (strcmp(type,"double") == 0) {
 
 253       ivalue = (double) SvNV(value);
 
 255       for (i = 0; i < numelements; i++)
 
 257     } else if (strcmp(type,"float") == 0) {
 
 260       ivalue = (float) SvNV(value);
 
 262       for (i = 0; i < numelements; i++)
 
 264     } else if (strcmp(type,"char") == 0) {
 
 266       ivalue = (char *) SvPV(value,PL_na);
 
 268       strncpy(ip,ivalue,numelements-1);
 
 269     } else if (strcmp(type,"char *") == 0) {
 
 272       ivalue = (char *) SvPV(value,PL_na);
 
 274       for (i = 0; i < numelements; i++) {
 
 276           ip[i] = (char *) malloc(strlen(ivalue)+1);
 
 277           strcpy(ip[i],ivalue);
 
 285   /* Create the pointer value */
 
 287   SWIG_MakePtr(temp,ptr,cast);
 
 288   obj = sv_newmortal();
 
 289   sv_setref_pv(obj,cast,ptr);
 
 293 /*------------------------------------------------------------------
 
 294   ptrset(ptr,value,index = 0,type = 0)
 
 296   Attempts to set the value of a pointer variable.  If type is
 
 297   given, we will use that type.  Otherwise, we'll guess the datatype.
 
 298   ------------------------------------------------------------------ */
 
 301 static void _ptrset(CPerlObj *pPerl,SV *_PTRVALUE, SV *value, int index, char *type) {
 
 302 #define ptrset(a,b,c,d) _ptrset(pPerl,a,b,c,d)
 
 304 static void _ptrset(SV *_PTRVALUE, SV *value, int index, char *type) {
 
 305 #define ptrset(a,b,c,d) _ptrset(a,b,c,d)
 
 310   if (SWIG_GetPtr(_PTRVALUE,&ptr,0)) {
 
 311     croak("Type error in ptrset. Argument is not a valid pointer value.");
 
 315   /* If no datatype was passed, try a few common datatypes first */
 
 319     /* No datatype was passed.   Type to figure out if it's a common one */
 
 321     if (!SWIG_GetPtr(_PTRVALUE,&ptr,"intPtr")) {
 
 323     } else if (!SWIG_GetPtr(_PTRVALUE,&ptr,"doublePtr")) {
 
 325     } else if (!SWIG_GetPtr(_PTRVALUE,&ptr,"shortPtr")) {
 
 327     } else if (!SWIG_GetPtr(_PTRVALUE,&ptr,"longPtr")) {
 
 329     } else if (!SWIG_GetPtr(_PTRVALUE,&ptr,"floatPtr")) {
 
 331     } else if (!SWIG_GetPtr(_PTRVALUE,&ptr,"charPtr")) {
 
 333     } else if (!SWIG_GetPtr(_PTRVALUE,&ptr,"charPtrPtr")) {
 
 341     croak("Unable to set NULL pointer.");
 
 345   /* Now we have a datatype.  Try to figure out what to do about it */
 
 346   if (strcmp(type,"int") == 0) {
 
 347     *(((int *) ptr)+index) = (int) SvIV(value);
 
 348   } else if (strcmp(type,"double") == 0) {
 
 349     *(((double *) ptr)+index) = (double) SvNV(value);
 
 350   } else if (strcmp(type,"short") == 0) {
 
 351     *(((short *) ptr)+index) = (short) SvIV(value);
 
 352   } else if (strcmp(type,"long") == 0) {
 
 353     *(((long *) ptr)+index) = (long) SvIV(value);
 
 354   } else if (strcmp(type,"float") == 0) {
 
 355     *(((float *) ptr)+index) = (float) SvNV(value);
 
 356   } else if (strcmp(type,"char") == 0) {
 
 357     char *c = SvPV(value,PL_na);
 
 358     strcpy(((char *) ptr)+index, c);
 
 359   } else if (strcmp(type,"char *") == 0) {
 
 360     char *c = SvPV(value,PL_na);
 
 361     char **ca = (char **) ptr;
 
 362     if (ca[index]) free(ca[index]);
 
 363     if (strcmp(c,"NULL") == 0) {
 
 366       ca[index] = (char *) malloc(strlen(c)+1);
 
 370     croak("Unable to set unsupported datatype.");
 
 375 /*------------------------------------------------------------------
 
 378   Adds a value to an existing pointer value.  Will do a type-dependent
 
 379   add for basic datatypes.  For other datatypes, will do a byte-add.
 
 380   ------------------------------------------------------------------ */
 
 383 static SV *_ptradd(CPerlObj *pPerl, SV *_PTRVALUE, int offset) {
 
 384 #define ptradd(a,b) _ptradd(pPerl,a,b)
 
 386 static SV *_ptradd(SV *_PTRVALUE, int offset) {
 
 387 #define ptradd(a,b) _ptradd(a,b)
 
 394   /* Try to handle a few common datatypes first */
 
 396   if (!SWIG_GetPtr(_PTRVALUE,&ptr,"intPtr")) {
 
 397     ptr = (void *) (((int *) ptr) + offset);
 
 398   } else if (!SWIG_GetPtr(_PTRVALUE,&ptr,"doublePtr")) {
 
 399     ptr = (void *) (((double *) ptr) + offset);
 
 400   } else if (!SWIG_GetPtr(_PTRVALUE,&ptr,"shortPtr")) {
 
 401     ptr = (void *) (((short *) ptr) + offset);
 
 402   } else if (!SWIG_GetPtr(_PTRVALUE,&ptr,"longPtr")) {
 
 403     ptr = (void *) (((long *) ptr) + offset);
 
 404   } else if (!SWIG_GetPtr(_PTRVALUE,&ptr,"floatPtr")) {
 
 405     ptr = (void *) (((float *) ptr) + offset);
 
 406   } else if (!SWIG_GetPtr(_PTRVALUE,&ptr,"charPtr")) {
 
 407     ptr = (void *) (((char *) ptr) + offset);
 
 408   } else if (!SWIG_GetPtr(_PTRVALUE,&ptr,0)) {
 
 409     ptr = (void *) (((char *) ptr) + offset);
 
 411     croak("Type error in ptradd. Argument is not a valid pointer value.");
 
 414   type = SWIG_GetPtr(_PTRVALUE,&junk,"INVALID POINTER");
 
 415   obj = sv_newmortal();
 
 416   sv_setref_pv(obj,type,ptr);
 
 420 /*------------------------------------------------------------------
 
 423   Allows a mapping between type1 and type2. (Like a typedef)
 
 424   ------------------------------------------------------------------ */
 
 427 static void _ptrmap(CPerlObj *pPerl,char *type1, char *type2) {
 
 428 #define ptrmap(a,b) _ptrmap(pPerl,a,b)
 
 430 static void _ptrmap(char *type1, char *type2) {
 
 431 #define ptrmap(a,b) _ptrmap(a,b)
 
 433   char *typestr1,*typestr2,*c,*r;
 
 434   /* Produce a "mangled" version of the type string.  */
 
 436   typestr1 = (char *) malloc(strlen(type1)+20);
 
 439   /* Go through and munge the typestring */
 
 447       if ((*c == '*') || (*c == '&')) {
 
 457   typestr2 = (char *) malloc(strlen(type2)+20);
 
 459   /* Go through and munge the typestring */
 
 466       if ((*c == '*') || (*c == '&')) {
 
 475   SWIG_RegisterMapping(typestr1,typestr2,0);
 
 476   SWIG_RegisterMapping(typestr2,typestr1,0);
 
 479 /*------------------------------------------------------------------
 
 482   Destroys a pointer value
 
 483   ------------------------------------------------------------------ */
 
 485 void _ptrfree(CPerlObj *pPerl, SV *_PTRVALUE) {
 
 486 #define ptrfree(a) _ptrfree(pPerl, a)
 
 488 void _ptrfree(SV *_PTRVALUE) {
 
 489 #define ptrfree(a) _ptrfree(a)
 
 494   if (SWIG_GetPtr(_PTRVALUE,&ptr,0)) {
 
 495     croak("Type error in ptrfree. Argument is not a valid pointer value.");
 
 499   /* Check to see if this pointer is a char ** */
 
 500   if (!SWIG_GetPtr(_PTRVALUE,&junk,"charPtrPtr")) {
 
 501     char **c = (char **) ptr;
 
 516 %typemap(perl5,in) SV *ptr, SV *value {
 
 521 %typemap(perl5,out) SV *ptrcast,
 
 530 %typemap(perl5,ret) int ptrset {
 
 531   if ($source == -1) return NULL;
 
 534 SV *ptrcast(SV *ptr, char *type);
 
 535 // Casts a pointer ptr to a new datatype given by the string type.
 
 536 // type may be either the SWIG generated representation of a datatype
 
 537 // or the C representation.  For example :
 
 539 //    ptrcast($ptr,"doublePtr");   # Perl5 representation
 
 540 //    ptrcast($ptr,"double *");    # C representation
 
 542 // A new pointer value is returned.   ptr may also be an integer
 
 543 // value in which case the value will be used to set the pointer
 
 544 // value.  For example :
 
 546 //    $a = ptrcast(0,"VectorPtr");
 
 548 // Will create a NULL pointer of type "VectorPtr"
 
 550 // The casting operation is sensitive to formatting.  As a result,
 
 551 // "double *" is different than "double*".  As a result of thumb,
 
 552 // there should always be exactly one space between the C datatype
 
 553 // and any pointer specifiers (*).
 
 555 SV *ptrvalue(SV *ptr, int index = 0, char *type = 0);
 
 556 // Returns the value that a pointer is pointing to (ie. dereferencing).
 
 557 // The type is automatically inferred by the pointer type--thus, an
 
 558 // integer pointer will return an integer, a double will return a double,
 
 559 // and so on.   The index and type fields are optional parameters.  When
 
 560 // an index is specified, this function returns the value of ptr[index].
 
 561 // This allows array access.   When a type is specified, it overrides
 
 562 // the given pointer type.   Examples :
 
 564 //    ptrvalue($a)             #  Returns the value *a
 
 565 //    ptrvalue($a,10)          #  Returns the value a[10]
 
 566 //    ptrvalue($a,10,"double") #  Returns a[10] assuming a is a double *
 
 569 void ptrset(SV *ptr, SV *value, int index = 0, char *type = 0);
 
 570 // Sets the value pointed to by a pointer.  The type is automatically
 
 571 // inferred from the pointer type so this function will work for
 
 572 // integers, floats, doubles, etc...  The index and type fields are
 
 573 // optional.  When an index is given, it provides array access.  When
 
 574 // type is specified, it overrides the given pointer type.  Examples :
 
 576 //   ptrset($a,3)            # Sets the value *a = 3
 
 577 //   ptrset($a,3,10)         # Sets a[10] = 3
 
 578 //   ptrset($a,3,10,"int")   # Sets a[10] = 3 assuming a is a int *
 
 581 SV *ptrcreate(char *type, SV *value = 0, int nitems = 1);
 
 582 // Creates a new object and returns a pointer to it.  This function 
 
 583 // can be used to create various kinds of objects for use in C functions.
 
 584 // type specifies the basic C datatype to create and value is an
 
 585 // optional parameter that can be used to set the initial value of the
 
 586 // object.  nitems is an optional parameter that can be used to create
 
 587 // an array.  This function results in a memory allocation using
 
 588 // malloc().  Examples :
 
 590 //   $a = ptrcreate("double")     # Create a new double, return pointer
 
 591 //   $a = ptrcreate("int",7)      # Create an integer, set value to 7
 
 592 //   $a = ptrcreate("int",0,1000) # Create an integer array with initial
 
 593 //                                # values all set to zero
 
 595 // This function only recognizes a few common C datatypes as listed below :
 
 597 //        int, short, long, float, double, char, char *, void
 
 599 // All other datatypes will result in an error.  However, other
 
 600 // datatypes can be created by using the ptrcast function.  For
 
 603 //  $a = ptrcast(ptrcreate("int",0,100),"unsigned int *")
 
 606 void ptrfree(SV *ptr);
 
 607 // Destroys the memory pointed to by ptr.  This function calls free()
 
 608 // and should only be used with objects created by ptrcreate().  Since
 
 609 // this function calls free, it may work with other objects, but this
 
 610 // is generally discouraged unless you absolutely know what you're
 
 613 SV *ptradd(SV *ptr, int offset);
 
 614 // Adds a value to the current pointer value.  For the C datatypes of
 
 615 // int, short, long, float, double, and char, the offset value is the
 
 616 // number of objects and works in exactly the same manner as in C.  For
 
 617 // example, the following code steps through the elements of an array
 
 619 //  $a = ptrcreate("double",0,100);    # Create an array double a[100]
 
 621 //  for ($i = 0; $i < 100; $i++) {
 
 622 //      ptrset($b,0.0025*$i);          # set *b = 0.0025*i
 
 623 //      $b = ptradd($b,1);             # b++ (go to next double)
 
 626 // In this case, adding one to b goes to the next double.
 
 628 // For all other datatypes (including all complex datatypes), the
 
 629 // offset corresponds to bytes.  This function does not perform any
 
 630 // bounds checking and negative offsets are perfectly legal.  
 
 632 void      ptrmap(char *type1, char *type2);
 
 633 // This is a rarely used function that performs essentially the same
 
 634 // operation as a C typedef.  To manage datatypes at run-time, SWIG
 
 635 // modules manage an internal symbol table of type mappings.  This
 
 636 // table keeps track of which types are equivalent to each other.  The
 
 637 // ptrmap() function provides a mechanism for scripts to add symbols
 
 638 // to this table.  For example :
 
 640 //    ptrmap("doublePtr","RealPtr");
 
 642 // would make the types "doublePtr" and "RealPtr" equivalent to each
 
 643 // other.  Pointers of either type could now be used interchangably.
 
 645 // Normally this function is not needed, but it can be used to
 
 646 // circumvent SWIG's normal type-checking behavior or to work around
 
 647 // weird type-handling problems.