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
is_scalar_ref(SV * arg)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
pack1D(SV * arg,char packtype)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
pack2D(SV * arg,char packtype)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 = NULL;
245 AV* array2 = NULL;
246 I32 i,j,n,m;
247 SV* work = NULL;
248 SV** work2 = NULL;
249 double nval = 0.0;
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
packND(SV * arg,char packtype)388 void* packND ( SV* arg, char packtype ) {
389
390 SV* work = NULL;
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
pack_element(SV * work,SV ** arg,char packtype)418 void pack_element(SV* work, SV** arg, char packtype) {
419
420 I32 i,n;
421 AV* array = NULL;
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 croak("Routine can only handle scalars or refs to N-D arrays of scalars");
488
489 }
490
491
492 /* ##################################################################################
493
494 unpack1D - take packed string (C array) and write back into perl 1D array.
495 If 1st argument is a reference, unpack into this array.
496 If 1st argument is a glob, unpack into the 1D array of the same name.
497
498 Can only be used in a typemap if the size of the array is known
499 in advance or is the size of a preexisting perl array (n=0). If it
500 is determined by another variable you may have to put in in some
501 direct CODE: lines in the XSUB file.
502
503 */
504
unpack1D(SV * arg,void * var,char packtype,int n)505 void unpack1D ( SV* arg, void * var, char packtype, int n ) {
506
507 /* n is the size of array var[] (n=1 for 1 element, etc.) If n=0 take
508 var[] as having the same dimension as array referenced by arg */
509
510 int* ivar = NULL;
511 float* fvar = NULL;
512 double* dvar = NULL;
513 short* svar = NULL;
514 unsigned char* uvar = NULL;
515 double foo;
516 SV* work = NULL;
517 AV* array = NULL;
518 I32 i,m;
519
520 /* Note in ref to scalar case data is already changed */
521
522 if (is_scalar_ref(arg)) /* Do nothing */
523 return;
524
525 if (packtype!='f' && packtype!='i' && packtype!= 'd' &&
526 packtype!='u' && packtype!='s')
527 croak("Programming error: invalid type conversion specified to unpack1D");
528
529 m=n; array = coerce1D( arg, m ); /* Get array ref and coerce */
530
531 if (m==0)
532 m = av_len( array )+1;
533
534 if (packtype=='i') /* Cast void array var[] to appropriate type */
535 ivar = (int *) var;
536 if (packtype=='f')
537 fvar = (float *) var;
538 if (packtype=='d')
539 dvar = (double *) var;
540 if (packtype=='u')
541 uvar = (unsigned char *) var;
542 if (packtype=='s')
543 svar = (short *) var;
544
545 /* Unpack into the array */
546
547 for(i=0; i<m; i++) {
548 if (packtype=='i')
549 av_store( array, i, newSViv( (IV)ivar[i] ) );
550 if (packtype=='f')
551 av_store( array, i, newSVnv( (double)fvar[i] ) );
552 if (packtype=='d')
553 av_store( array, i, newSVnv( (double)dvar[i] ) );
554 if (packtype=='u')
555 av_store( array, i, newSViv( (IV)uvar[i] ) );
556 if (packtype=='s')
557 av_store( array, i, newSViv( (IV)svar[i] ) );
558 }
559
560 return;
561 }
562
563
564 /* #################################################################################
565
566 coerce1D - utility function. Make sure arg is a reference to a 1D array
567 of size at least n, creating/extending as necessary. Fill with zeroes.
568 Return reference to array. If n=0 just returns reference to array,
569 creating as necessary.
570 */
571
coerce1D(SV * arg,int n)572 AV* coerce1D ( SV* arg, int n ) {
573
574 /* n is the size of array var[] (n=1 for 1 element, etc.) */
575
576 AV* array = NULL;
577 I32 i,m;
578
579 /* In ref to scalar case we can do nothing - we can only hope the
580 caller made the scalar the right size in the first place */
581
582 if (is_scalar_ref(arg)) /* Do nothing */
583 return (AV*)NULL;
584
585 /* Check what has been passed and create array reference whether it
586 exists or not */
587
588 if (SvTYPE(arg)==SVt_PVGV) {
589 array = GvAVn((GV*)arg); /* glob */
590 }else if (SvROK(arg) && SvTYPE(SvRV(arg))==SVt_PVAV) {
591 array = (AV *) SvRV(arg); /* reference */
592 }else{
593 array = newAV(); /* Create */
594 sv_setsv(arg, newRV((SV*) array));
595 }
596
597 m = av_len(array);
598
599 for (i=m+1; i<n; i++) {
600 av_store( array, i, newSViv( (IV) 0 ) );
601 }
602
603 return array;
604 }
605
606
607 /* ################################################################################
608
609 get_mortalspace - utility to get temporary memory space. Uses
610 a mortal *SV for this so it is automatically freed when the current
611 context is terminated. Useful in typemap's for OUTPUT only arrays.
612
613 */
614
615
get_mortalspace(int n,char packtype)616 void* get_mortalspace( int n, char packtype ) {
617
618 /* n is the number of elements of space required, packtype is 'f' or 'i' */
619
620 SV* work = NULL;
621
622 if (packtype!='f' && packtype!='i' && packtype!='d'
623 && packtype!='u' && packtype!='s')
624 croak("Programming error: invalid type conversion specified to get_mortalspace");
625
626 work = sv_2mortal(newSVpv("", 0));
627
628 if (packtype=='f')
629 SvGROW( work, sizeof(float)*n ); /* Pregrow for efficiency */
630 if (packtype=='i')
631 SvGROW( work, sizeof(int)*n );
632 if (packtype=='d')
633 SvGROW( work, sizeof(double)*n);
634 if (packtype=='u')
635 SvGROW( work, sizeof(char)*n);
636 if (packtype=='s')
637 SvGROW( work, sizeof(short)*n);
638
639 return (void *) SvPV(work, PL_na);
640 }
641
642
643
644