1 /* 2 3 Library of typemap functions for C arrays, idea is to provide 4 automatic conversion between references to perl arrays and C arrays. 5 If the argument is a scalar this is automatically detected and handles 6 as a one element array. 7 8 Thanks go to Tim Bunce for the pointer to gv.h so I could figure 9 out how to handle glob values. 10 11 Karl Glazebrook [kgb@aaoepp.aao.gov.au] 12 13 14 Dec 95: Add double precision arrays - frossie@jach.hawaii.edu 15 Dec 96: Add 'ref to scalar is binary' handling - kgb@aaoepp.aao.gov.au 16 Jan 97: Handles undefined values as zero - kgb@aaoepp.aao.gov.au 17 Feb 97: Fixed a few type cast howlers+bugs - kgb@aaoepp.aao.gov.au 18 Apr 97: Add support for unsigned char and shorts- timj@jach.hawaii.edu 19 20 */ 21 22 23 #include "EXTERN.h" /* std perl include */ 24 #include "perl.h" /* std perl include */ 25 #include "XSUB.h" /* XSUB include */ 26 27 28 /* Functions defined in this module, see header comments on each one 29 for more details: */ 30 31 #include "arrays.h" 32 33 int is_scalar_ref (SV* arg) { /* Utility to determine if ref to scalar */ 34 SV* foo; 35 if (!SvROK(arg)) 36 return 0; 37 foo = SvRV(arg); 38 if (SvPOK(foo)) 39 return 1; 40 else 41 return 0; 42 } 43 44 45 /* #################################################################################### 46 47 pack1D - argument is perl scalar variable and one char pack type. 48 If it is a reference to a 1D array pack it and return pointer. 49 If it is a glob pack the 1D array of the same name. 50 If it is a scalar pack as 1 element array. 51 If it is a reference to a scalar then assume scalar is prepacked binary data 52 53 [1D-ness is checked - routine croaks if any of the array elements 54 themselves are references.] 55 56 Can be used in a typemap file (uses mortal scratch space and perl 57 arrays know how big they are), e.g.: 58 59 TYPEMAP 60 int * T_INTP 61 float * T_FLOATP 62 double * T_DOUBLEP 63 INPUT 64 65 T_INTP 66 $var = ($type)pack1D($arg,'i') 67 T_FLOATP 68 $var = ($type)pack1D($arg,'f') 69 T_DOUBLEP 70 $var = ($type)pack1D($arg,'d') 71 72 */ 73 74 void* pack1D ( SV* arg, char packtype ) { 75 76 int iscalar; 77 float scalar; 78 double dscalar; 79 short sscalar; 80 unsigned char uscalar; 81 AV* array; 82 I32 i,n; 83 SV* work; 84 SV** work2; 85 double nval; 86 STRLEN len; 87 88 if (is_scalar_ref(arg)) /* Scalar ref */ 89 return (void*) SvPV(SvRV(arg), len); 90 91 if (packtype!='f' && packtype!='i' && packtype!='d' && packtype!='s' 92 && packtype != 'u') 93 croak("Programming error: invalid type conversion specified to pack1D"); 94 95 /* 96 Create a work char variable - be cunning and make it a mortal *SV 97 which will go away automagically when we leave the current 98 context, i.e. no need to malloc and worry about freeing - thus 99 we can use pack1D in a typemap! 100 */ 101 102 work = sv_2mortal(newSVpv("", 0)); 103 104 /* Is arg a scalar? Return scalar*/ 105 106 if (!SvROK(arg) && SvTYPE(arg)!=SVt_PVGV) { 107 108 if (packtype=='f') { 109 scalar = (float) SvNV(arg); /* Get the scalar value */ 110 sv_setpvn(work, (char *) &scalar, sizeof(float)); /* Pack it in */ 111 } 112 if (packtype=='i') { 113 iscalar = (int) SvNV(arg); /* Get the scalar value */ 114 sv_setpvn(work, (char *) &iscalar, sizeof(int)); /* Pack it in */ 115 } 116 if (packtype=='d') { 117 dscalar = (double) SvNV(arg); /*Get the scalar value */ 118 sv_setpvn(work, (char *) &dscalar, sizeof(double)); /* Pack it in */ 119 } 120 if (packtype=='s') { 121 sscalar = (short) SvNV(arg); /*Get the scalar value */ 122 sv_setpvn(work, (char *) &sscalar, sizeof(short)); /* Pack it in */ 123 } 124 if (packtype=='u') { 125 uscalar = (unsigned char) SvNV(arg); /*Get the scalar value */ 126 sv_setpvn(work, (char *) &uscalar, sizeof(char)); /* Pack it in */ 127 } 128 return (void *) SvPV(work, PL_na); /* Return the pointer */ 129 } 130 131 /* Is it a glob or reference to an array? */ 132 133 if (SvTYPE(arg)==SVt_PVGV || (SvROK(arg) && SvTYPE(SvRV(arg))==SVt_PVAV)) { 134 135 if (SvTYPE(arg)==SVt_PVGV) { 136 array = (AV *) GvAVn((GV*) arg); /* glob */ 137 }else{ 138 array = (AV *) SvRV(arg); /* reference */ 139 } 140 141 n = av_len(array); 142 143 if (packtype=='f') 144 SvGROW( work, sizeof(float)*(n+1) ); /* Pregrow for efficiency */ 145 if (packtype=='i') 146 SvGROW( work, sizeof(int)*(n+1) ); 147 if (packtype=='d') 148 SvGROW( work, sizeof(double)*(n+1) ); 149 if (packtype=='s') 150 SvGROW( work, sizeof(short)*(n+1) ); 151 if (packtype=='u') 152 SvGROW( work, sizeof(char)*(n+1) ); 153 154 155 /* Pack array into string */ 156 157 for(i=0; i<=n; i++) { 158 159 work2 = av_fetch( array, i, 0 ); /* Fetch */ 160 if (work2==NULL) 161 nval = 0.0; /* Undefined */ 162 else { 163 if (SvROK(*work2)) 164 goto errexit; /* Croak if reference [i.e. not 1D] */ 165 nval = SvNV(*work2); 166 } 167 168 if (packtype=='f') { 169 scalar = (float) nval; 170 sv_catpvn( work, (char *) &scalar, sizeof(float)); 171 } 172 if (packtype=='i') { 173 iscalar = (int) nval; 174 sv_catpvn( work, (char *) &iscalar, sizeof(int)); 175 } 176 if (packtype=='d') { 177 dscalar = (double) nval; 178 sv_catpvn( work, (char *) &dscalar, sizeof(double)); 179 } 180 if (packtype=='s') { 181 sscalar = (short) nval; 182 sv_catpvn( work, (char *) &sscalar, sizeof(short)); 183 } 184 if (packtype=='u') { 185 uscalar = (unsigned char) nval; 186 sv_catpvn( work, (char *) &uscalar, sizeof(char)); 187 } 188 } 189 190 /* Return a pointer to the byte array */ 191 192 return (void *) SvPV(work, PL_na); 193 194 } 195 196 errexit: 197 198 croak("Routine can only handle scalar values or refs to 1D arrays of scalars"); 199 200 } 201 202 203 204 /* ##################################################################################### 205 206 pack2D - argument is perl scalar variable and one char pack type. 207 If it is a reference to a 1D/2D array pack it and return pointer. 208 If it is a glob pack the 1D/2D array of the same name. 209 If it is a scalar assume it is a prepacked array and return pointer 210 to char part of scalar. 211 If it is a reference to a scalar then assume scalar is prepacked binary data 212 213 [2Dness is checked - program croaks if any of the array elements 214 themselves are references. Packs each row sequentially even if 215 they are not all the same dimension - it is up to the programmer 216 to decide if this is sensible or not.] 217 218 Can be used in a typemap file (uses mortal scratch space and perl 219 arrays know how big they are), e.g.: 220 221 TYPEMAP 222 int2D * T_INT2DP 223 float2D * T_FLOAT2DP 224 225 INPUT 226 227 T_INT2DP 228 $var = ($type)pack2D($arg,'i') 229 T_FLOAT2DP 230 $var = ($type)pack2D($arg,'f') 231 232 [int2D/float2D would be typedef'd to int/float] 233 234 */ 235 236 237 void* pack2D ( SV* arg, char packtype ) { 238 239 int iscalar; 240 float scalar; 241 short sscalar; 242 double dscalar; 243 unsigned char uscalar; 244 AV* array; 245 AV* array2; 246 I32 i,j,n,m; 247 SV* work; 248 SV** work2; 249 double nval; 250 int isref; 251 STRLEN len; 252 253 if (is_scalar_ref(arg)) /* Scalar ref */ 254 return (void*) SvPV(SvRV(arg), len); 255 256 if (packtype!='f' && packtype!='i' && packtype!='d' && packtype!='s' 257 && packtype!='u') 258 croak("Programming error: invalid type conversion specified to pack2D"); 259 260 /* Is arg a scalar? Return pointer to char part */ 261 262 if (!SvROK(arg) && SvTYPE(arg)!=SVt_PVGV) { return (void *) SvPV(arg, PL_na); } 263 264 /* 265 Create a work char variable - be cunning and make it a mortal *SV 266 which will go away automagically when we leave the current 267 context, i.e. no need to malloc and worry about freeing - thus 268 we can use pack2D in a typemap! 269 */ 270 271 work = sv_2mortal(newSVpv("", 0)); 272 273 /* Is it a glob or reference to an array? */ 274 275 if (SvTYPE(arg)==SVt_PVGV || (SvROK(arg) && SvTYPE(SvRV(arg))==SVt_PVAV)) { 276 277 if (SvTYPE(arg)==SVt_PVGV) { 278 array = GvAVn((GV*) arg); /* glob */ 279 }else{ 280 array = (AV *) SvRV(arg); /* reference */ 281 } 282 283 n = av_len(array); 284 285 /* Pack array into string */ 286 287 for(i=0; i<=n; i++) { /* Loop over 1st dimension */ 288 289 work2 = av_fetch( array, i, 0 ); /* Fetch */ 290 291 isref = work2!=NULL && SvROK(*work2); /* Is is a reference */ 292 293 if (isref) { 294 array2 = (AV *) SvRV(*work2); /* array of 2nd dimension */ 295 m = av_len(array2); /* Length */ 296 }else{ 297 m=0; /* 1D array */ 298 nval = SvNV(*work2); 299 } 300 301 /* Pregrow storage for efficiency on first row - note assumes 302 array is rectangular but better than nothing */ 303 304 if (i==0) { 305 if (packtype=='f') 306 SvGROW( work, sizeof(float)*(n+1)*(m+1) ); 307 if (packtype=='i') 308 SvGROW( work, sizeof(int)*(n+1)*(m+1) ); 309 if (packtype=='s') 310 SvGROW( work, sizeof(short)*(n+1)*(m+1) ); 311 if (packtype=='u') 312 SvGROW( work, sizeof(char)*(n+1)*(m+1) ); 313 if (packtype=='d') 314 SvGROW( work, sizeof(double)*(n+1) ); 315 } 316 317 for(j=0; j<=m; j++) { /* Loop over 2nd dimension */ 318 319 if (isref) { 320 work2 = av_fetch( array2, j, 0 ); /* Fetch element */ 321 if (work2==NULL) 322 nval = 0.0; /* Undefined */ 323 else { 324 if (SvROK(*work2)) 325 goto errexit; /* Croak if reference [i.e. not 1D] */ 326 nval = SvNV(*work2); 327 } 328 } 329 330 if (packtype=='d') { 331 dscalar = (double) nval; 332 sv_catpvn( work, (char *) &dscalar, sizeof(double)); 333 } 334 if (packtype=='f') { 335 scalar = (float) nval; 336 sv_catpvn( work, (char *) &scalar, sizeof(float)); 337 } 338 if (packtype=='i') { 339 iscalar = (int) nval; 340 sv_catpvn( work, (char *) &iscalar, sizeof(int)); 341 } 342 if (packtype=='s') { 343 sscalar = (short) nval; 344 sv_catpvn( work, (char *) &sscalar, sizeof(short)); 345 } 346 if (packtype=='u') { 347 uscalar = (unsigned char) nval; 348 sv_catpvn( work, (char *) &uscalar, sizeof(char)); 349 } 350 } 351 } 352 353 /* Return a pointer to the byte array */ 354 355 return (void *) SvPV(work, PL_na); 356 357 } 358 359 errexit: 360 361 croak("Routine can only handle scalar packed char values or refs to 1D or 2D arrays"); 362 363 } 364 365 /* ################################################################################### 366 367 packND - argument is perl scalar variable and one char pack type. 368 arg is treated as a reference to an array of arbitrary dimensions. 369 Pointer to packed data is returned. 370 371 It is packed recursively, i.e. if an element is a scalar it is 372 packed on the end of the string, if it is a reference the array it 373 points to is packed on the end with further recursive traversal. For 374 a 2D input will produce the same result as pack2D though without, 375 obviously, dimensional checking. Since we don't know in advance how 376 big it is we can't preallocate the storage so this may be inefficient. 377 Note, as in other pack routines globs are handled as the equivalent 378 1D array. 379 380 e.g. [1,[2,2,[-4,-4]]],-1,0,1, 2,3,4] is packed as 1,2,2,-4,-4,-1,0,1,2,3,4 381 382 If arg is a reference to a scalar then assume scalar is prepacked binary data. 383 384 Can be used in a typemap file (uses mortal scratch space). 385 386 */ 387 388 void* packND ( SV* arg, char packtype ) { 389 390 SV* work; 391 STRLEN len; 392 void pack_element(SV* work, SV** arg, char packtype); /* Called by packND */ 393 394 if (is_scalar_ref(arg)) /* Scalar ref */ 395 return (void*) SvPV(SvRV(arg), len); 396 397 if (packtype!='f' && packtype!='i' && packtype!='d' 398 && packtype!='s' && packtype!='u') 399 croak("Programming error: invalid type conversion specified to packND"); 400 401 /* 402 Create a work char variable - be cunning and make it a mortal *SV 403 which will go away automagically when we leave the current 404 context, i.e. no need to malloc and worry about freeing - thus 405 we can use packND in a typemap! 406 */ 407 408 work = sv_2mortal(newSVpv("", 0)); 409 410 pack_element(work, &arg, packtype); 411 412 return (void *) SvPV(work, PL_na); 413 414 } 415 416 /* Internal function of packND - pack an element recursively */ 417 418 void pack_element(SV* work, SV** arg, char packtype) { 419 420 I32 i,n; 421 AV* array; 422 int iscalar; 423 float scalar; 424 short sscalar; 425 unsigned char uscalar; 426 double nval; 427 428 /* Pack element arg onto work recursively */ 429 430 /* Is arg a scalar? Pack and return */ 431 432 if (arg==NULL || (!SvROK(*arg) && SvTYPE(*arg)!=SVt_PVGV)) { 433 434 if (arg==NULL) 435 nval = 0.0; 436 else 437 nval = SvNV(*arg); 438 439 if (packtype=='f') { 440 scalar = (float) nval; /* Get the scalar value */ 441 sv_catpvn(work, (char *) &scalar, sizeof(float)); /* Pack it in */ 442 } 443 if (packtype=='i') { 444 iscalar = (int) nval; /* Get the scalar value */ 445 sv_catpvn(work, (char *) &iscalar, sizeof(int)); /* Pack it in */ 446 } 447 if (packtype=='d') { 448 sv_catpvn(work, (char *) &nval, sizeof(double)); /* Pack it in */ 449 } 450 if (packtype=='s') { 451 sscalar = (short) nval; /* Get the scalar value */ 452 sv_catpvn(work, (char *) &sscalar, sizeof(short)); /* Pack it in */ 453 } 454 if (packtype=='u') { 455 uscalar = (unsigned char) nval; 456 sv_catpvn(work, (char *) &uscalar, sizeof(char)); /* Pack it in */ 457 } 458 459 return; 460 } 461 462 /* Is it a glob or reference to an array? */ 463 464 if (SvTYPE(*arg)==SVt_PVGV || (SvROK(*arg) && SvTYPE(SvRV(*arg))==SVt_PVAV)) { 465 466 /* Dereference */ 467 468 if (SvTYPE(*arg)==SVt_PVGV) { 469 array = GvAVn((GV*)*arg); /* glob */ 470 }else{ 471 array = (AV *) SvRV(*arg); /* reference */ 472 } 473 474 /* Pack each array element */ 475 476 n = av_len(array); 477 478 for (i=0; i<=n; i++) { 479 480 /* To curse is human, to recurse divine */ 481 482 pack_element(work, av_fetch(array, i, 0), packtype ); 483 } 484 return; 485 } 486 487 errexit: 488 489 croak("Routine can only handle scalars or refs to N-D arrays of scalars"); 490 491 } 492 493 494 /* ################################################################################## 495 496 unpack1D - take packed string (C array) and write back into perl 1D array. 497 If 1st argument is a reference, unpack into this array. 498 If 1st argument is a glob, unpack into the 1D array of the same name. 499 500 Can only be used in a typemap if the size of the array is known 501 in advance or is the size of a preexisting perl array (n=0). If it 502 is determined by another variable you may have to put in in some 503 direct CODE: lines in the XSUB file. 504 505 */ 506 507 void unpack1D ( SV* arg, void * var, char packtype, int n ) { 508 509 /* n is the size of array var[] (n=1 for 1 element, etc.) If n=0 take 510 var[] as having the same dimension as array referenced by arg */ 511 512 int* ivar; 513 float* fvar; 514 double* dvar; 515 short* svar; 516 unsigned char* uvar; 517 SV* work; 518 AV* array; 519 I32 i,m; 520 521 /* Note in ref to scalar case data is already changed */ 522 523 if (is_scalar_ref(arg)) /* Do nothing */ 524 return; 525 526 if (packtype!='f' && packtype!='i' && packtype!= 'd' && 527 packtype!='u' && packtype!='s') 528 croak("Programming error: invalid type conversion specified to unpack1D"); 529 530 m=n; array = coerce1D( arg, m ); /* Get array ref and coerce */ 531 532 if (m==0) 533 m = av_len( array )+1; 534 535 if (packtype=='i') /* Cast void array var[] to appropriate type */ 536 ivar = (int *) var; 537 if (packtype=='f') 538 fvar = (float *) var; 539 if (packtype=='d') 540 dvar = (double *) var; 541 if (packtype=='u') 542 uvar = (unsigned char *) var; 543 if (packtype=='s') 544 svar = (short *) var; 545 546 /* Unpack into the array */ 547 548 for(i=0; i<m; i++) { 549 if (packtype=='i') 550 av_store( array, i, newSViv( (IV)ivar[i] ) ); 551 if (packtype=='f') 552 av_store( array, i, newSVnv( (double)fvar[i] ) ); 553 if (packtype=='d') 554 av_store( array, i, newSVnv( (double)dvar[i] ) ); 555 if (packtype=='u') 556 av_store( array, i, newSViv( (IV)uvar[i] ) ); 557 if (packtype=='s') 558 av_store( array, i, newSViv( (IV)svar[i] ) ); 559 } 560 561 return; 562 } 563 564 565 /* ################################################################################# 566 567 coerce1D - utility function. Make sure arg is a reference to a 1D array 568 of size at least n, creating/extending as necessary. Fill with zeroes. 569 Return reference to array. If n=0 just returns reference to array, 570 creating as necessary. 571 */ 572 573 AV* coerce1D ( SV* arg, int n ) { 574 575 /* n is the size of array var[] (n=1 for 1 element, etc.) */ 576 577 AV* array; 578 I32 i,m; 579 580 /* In ref to scalar case we can do nothing - we can only hope the 581 caller made the scalar the right size in the first place */ 582 583 if (is_scalar_ref(arg)) /* Do nothing */ 584 return (AV*)NULL; 585 586 /* Check what has been passed and create array reference whether it 587 exists or not */ 588 589 if (SvTYPE(arg)==SVt_PVGV) { 590 array = GvAVn((GV*)arg); /* glob */ 591 }else if (SvROK(arg) && SvTYPE(SvRV(arg))==SVt_PVAV) { 592 array = (AV *) SvRV(arg); /* reference */ 593 }else{ 594 array = (AV*)sv_2mortal((SV*)newAV()); /* Create */ 595 sv_setsv(arg, sv_2mortal(newRV((SV*) array))); 596 } 597 598 m = av_len(array); 599 600 for (i=m+1; i<n; i++) { 601 av_store( array, i, newSViv( (IV) 0 ) ); 602 } 603 604 return array; 605 } 606 607 608 /* ################################################################################ 609 610 get_mortalspace - utility to get temporary memory space. Uses 611 a mortal *SV for this so it is automatically freed when the current 612 context is terminated. Useful in typemap's for OUTPUT only arrays. 613 614 */ 615 616 617 void* get_mortalspace( int n, char packtype ) { 618 619 /* n is the number of elements of space required, packtype is 'f' or 'i' */ 620 621 SV* work; 622 623 if (packtype!='f' && packtype!='i' && packtype!='d' 624 && packtype!='u' && packtype!='s') 625 croak("Programming error: invalid type conversion specified to get_mortalspace"); 626 627 work = sv_2mortal(newSVpv("", 0)); 628 629 if (packtype=='f') 630 SvGROW( work, sizeof(float)*n ); /* Pregrow for efficiency */ 631 if (packtype=='i') 632 SvGROW( work, sizeof(int)*n ); 633 if (packtype=='d') 634 SvGROW( work, sizeof(double)*n); 635 if (packtype=='u') 636 SvGROW( work, sizeof(char)*n); 637 if (packtype=='s') 638 SvGROW( work, sizeof(short)*n); 639 640 return (void *) SvPV(work, PL_na); 641 } 642 643 644 645