« back to all changes in this revision
Viewing changes to util.c
- browse files at revision 1
- compare with another revision
- download diff
- download tarball
- view history from revision 1
- Committer: Bazaar Package Importer
- Author(s): Gunnar Wolf
- Date: 2004-05-28 13:06:54 UTC
- Revision ID: james.westby@ubuntu.com-20040528130654-ajp6vlorvz0ckvfy
Tags: upstream-1.02
Import upstream version 1.02
- files added:
- examples
- testprog
added
removed
util.c
1
#include "EXTERN.h"
2
#include "perl.h"
3
#include "XSUB.h"
4
5
#include <stdlib.h>
6
#include <stdio.h>
7
#include "fitsio.h"
8
#include "util.h"
9
10
/* newSVuv seems to be perl 5.6.0-ism */
11
#ifndef newSVuv
12
#define newSVuv newSViv
13
#endif
14
15
static int perly_unpacking = 1; /* state variable */
16
17
18
/*
19
* Get the width of a string column in an ASCII or binary table
20
*/
21
long column_width(fitsfile * fptr, int colnum) {
22
int hdutype, status=0, tfields;
23
long repeat, size;
24
long start_col,end_col; /* starting and ending positions for ASCII tables */
25
long rowlen, nrows, *tbcol;
26
char typechar[FLEN_VALUE];
27
28
fits_get_hdu_type(fptr,&hdutype,&status);
29
check_status(status);
30
switch (hdutype) {
31
case ASCII_TBL:
32
33
/* Get starting column of field */
34
fits_get_acolparms(
35
fptr,colnum,NULL,&start_col,NULL,NULL,NULL,NULL,NULL,NULL,
36
&status
37
);
38
check_status(status);
39
40
/* Get length of each row and number of fields */
41
fits_read_atblhdr(
42
fptr,0,&rowlen,&nrows,&tfields,NULL,NULL,NULL,NULL,NULL,&status
43
);
44
check_status(status);
45
46
if (colnum == tfields) {
47
end_col = rowlen + 1;
48
}
49
else {
50
tbcol = get_mortalspace(tfields,TLONG);
51
fits_read_atblhdr(
52
fptr,tfields,&rowlen,&nrows,&tfields,NULL,
53
tbcol,NULL,NULL,NULL,&status
54
);
55
check_status(status);
56
end_col = tbcol[colnum] + 1;
57
}
58
size = end_col - start_col;
59
break;
60
61
/* Get the typechar parameter, which should be of form 'An', where
62
* n is an the width of the field
63
*/
64
case BINARY_TBL:
65
fits_get_bcolparms(
66
fptr,colnum,NULL,NULL,typechar,&repeat,NULL,NULL,
67
NULL,NULL,&status
68
);
69
check_status(status);
70
if (typechar[0] != 'A') { /* perhaps variable size? */
71
fits_read_key_lng(fptr,"NAXIS2",&rowlen,NULL,&status);
72
check_status(status);
73
size = rowlen+1;
74
}
75
else
76
size = repeat;
77
break;
78
default:
79
croak("column_width() - unrecognized HDU type (%d)",hdutype);
80
}
81
return size;
82
}
83
84
/*
85
* croaks() if the argument is non-zero, useful for checking on cfitsio
86
* routines.
87
*/
88
void check_status(int status) {
89
if (status != 0) {
90
fits_report_error(stderr,status);
91
croak("cfitsio library detected an error...I'm outta here");
92
}
93
}
94
95
/*
96
* Is argument a Perl reference? To a scalar?
97
*/
98
int is_scalar_ref (SV* arg) {
99
if (!SvROK(arg))
100
return 0;
101
if (SvPOK(SvRV(arg)))
102
return 1;
103
else
104
return 0;
105
}
106
107
/*
108
* Swap values in a long array inplace.
109
*/
110
void swap_dims(int ndims, long * dims) {
111
int i;
112
long tmp;
113
114
for (i=0; i<ndims/2; i++) {
115
tmp = dims[i];
116
dims[i] = dims[ndims-1-i];
117
dims[ndims-i-1] = tmp;
118
}
119
}
120
121
/*
122
* Returns the current value of perly_unpacking, if argument is non-negative
123
* the perly_unpacking is set to that value, as well.
124
*/
125
int PerlyUnpacking( int value ) {
126
if (value >= 0)
127
perly_unpacking=value;
128
return perly_unpacking;
129
}
130
131
/*
132
* Packs a Perl array reference into the appropriate C datatype
133
*/
134
void* pack1D ( SV* arg, int datatype ) {
135
int size;
136
char * stringscalar;
137
logical logscalar;
138
sbyte sbscalar;
139
byte bscalar;
140
unsigned short usscalar;
141
short sscalar;
142
unsigned int uiscalar;
143
int iscalar;
144
unsigned long ulscalar;
145
long lscalar;
146
LONGLONG llscalar;
147
float fscalar;
148
double dscalar;
149
float cmpval[2];
150
double dblcmpval[2];
151
AV* array;
152
I32 i,n;
153
SV* work;
154
SV** work2;
155
STRLEN len;
156
157
if (arg == &PL_sv_undef)
158
return (void *) NULL;
159
160
if (is_scalar_ref(arg)) /* Scalar ref */
161
return (void*) SvPV(SvRV(arg), len);
162
163
size = sizeof_datatype(datatype);
164
165
work = sv_2mortal(newSVpv("", 0));
166
167
/* Is arg a scalar? Return scalar*/
168
if (!SvROK(arg) && SvTYPE(arg)!=SVt_PVGV) {
169
switch (datatype) {
170
case TSTRING:
171
return (void *) SvPV(arg,PL_na);
172
case TLOGICAL:
173
logscalar = SvIV(arg);
174
sv_setpvn(work, (char *) &logscalar, size);
175
break;
176
case TSBYTE:
177
sbscalar = SvIV(arg);
178
sv_setpvn(work, (char *) &sbscalar, size);
179
break;
180
case TBYTE:
181
bscalar = SvUV(arg);
182
sv_setpvn(work, (char *) &bscalar, size);
183
break;
184
case TUSHORT:
185
usscalar = SvUV(arg);
186
sv_setpvn(work, (char *) &usscalar, size);
187
break;
188
case TSHORT:
189
sscalar = SvIV(arg);
190
sv_setpvn(work, (char *) &sscalar, size);
191
break;
192
case TUINT:
193
uiscalar = SvUV(arg);
194
sv_setpvn(work, (char *) &uiscalar, size);
195
break;
196
case TINT:
197
iscalar = SvIV(arg);
198
sv_setpvn(work, (char *) &iscalar, size);
199
break;
200
case TULONG:
201
ulscalar = SvUV(arg);
202
sv_setpvn(work, (char *) &ulscalar, size);
203
break;
204
case TLONG:
205
lscalar = SvIV(arg);
206
sv_setpvn(work, (char *) &lscalar, size);
207
break;
208
case TLONGLONG:
209
llscalar = SvIV(arg);
210
sv_setpvn(work, (char *) &llscalar, size);
211
break;
212
case TFLOAT:
213
fscalar = SvNV(arg);
214
sv_setpvn(work, (char *) &fscalar, size);
215
break;
216
case TDOUBLE:
217
dscalar = SvNV(arg);
218
sv_setpvn(work, (char *) &dscalar, size);
219
break;
220
case TCOMPLEX:
221
warn("pack1D() - packing scalar into TCOMPLEX...setting imaginary component to zero");
222
cmpval[0] = SvNV(arg);
223
cmpval[1] = 0.0;
224
sv_setpvn(work, (char *) cmpval, size);
225
break;
226
case TDBLCOMPLEX:
227
warn("pack1D() - packing scalar into TDBLCOMPLEX...setting imaginary component to zero");
228
dblcmpval[0] = SvNV(arg);
229
dblcmpval[1] = 0.0;
230
sv_setpvn(work, (char *) dblcmpval, size);
231
break;
232
default:
233
croak("pack1D() scalar code: unrecognized datatype (%d) was passed",datatype);
234
}
235
return (void *) SvPV(work,PL_na);
236
}
237
238
/* Is it a glob or reference to an array? */
239
if (SvTYPE(arg)==SVt_PVGV || (SvROK(arg) && SvTYPE(SvRV(arg))==SVt_PVAV)) {
240
241
if (SvTYPE(arg)==SVt_PVGV)
242
array = (AV *) GvAVn((GV*) arg); /* glob */
243
else
244
array = (AV *) SvRV(arg); /* reference */
245
246
n = av_len(array) + 1;
247
248
switch (datatype) {
249
case TSTRING:
250
SvGROW(work, size * n);
251
for (i=0; i<n; i++) {
252
if ((work2=av_fetch(array,i,0)) == NULL)
253
stringscalar = "";
254
else {
255
if (SvROK(*work2))
256
goto errexit;
257
stringscalar = SvPV(*work2,PL_na);
258
}
259
sv_catpvn(work, (char *) &stringscalar, size);
260
}
261
break;
262
case TLOGICAL:
263
SvGROW(work, size * n);
264
for (i=0; i<n; i++) {
265
if ((work2=av_fetch(array,i,0)) == NULL)
266
logscalar = 0;
267
else {
268
if (SvROK(*work2))
269
goto errexit;
270
logscalar = (logical) SvIV(*work2);
271
}
272
sv_catpvn(work, (char *) &logscalar, size);
273
}
274
break;
275
case TSBYTE:
276
SvGROW(work, size * n);
277
for (i=0; i<n; i++) {
278
if ((work2=av_fetch(array,i,0)) == NULL)
279
sbscalar = 0;
280
else {
281
if (SvROK(*work2))
282
goto errexit;
283
sbscalar = (sbyte) SvIV(*work2);
284
}
285
sv_catpvn(work, (char *) &sbscalar, size);
286
}
287
break;
288
case TBYTE:
289
SvGROW(work, size * n);
290
for (i=0; i<n; i++) {
291
if ((work2=av_fetch(array,i,0)) == NULL)
292
bscalar = 0;
293
else {
294
if (SvROK(*work2))
295
goto errexit;
296
bscalar = (byte) SvUV(*work2);
297
}
298
sv_catpvn(work, (char *) &bscalar, size);
299
}
300
break;
301
case TUSHORT:
302
SvGROW(work, size * n);
303
for (i=0; i<n; i++) {
304
if ((work2=av_fetch(array,i,0)) == NULL)
305
usscalar = 0;
306
else {
307
if (SvROK(*work2))
308
goto errexit;
309
usscalar = SvUV(*work2);
310
}
311
sv_catpvn(work, (char *) &usscalar, size);
312
}
313
break;
314
case TSHORT:
315
SvGROW(work, size * n);
316
for (i=0; i<n; i++) {
317
if ((work2=av_fetch(array,i,0)) == NULL)
318
sscalar = 0;
319
else {
320
if (SvROK(*work2))
321
goto errexit;
322
sscalar = SvIV(*work2);
323
}
324
sv_catpvn(work, (char *) &sscalar, size);
325
}
326
break;
327
case TUINT:
328
SvGROW(work, size * n);
329
for (i=0; i<n; i++) {
330
if ((work2=av_fetch(array,i,0)) == NULL)
331
uiscalar = 0;
332
else {
333
if (SvROK(*work2))
334
goto errexit;
335
uiscalar = SvUV(*work2);
336
}
337
sv_catpvn(work, (char *) &uiscalar, size);
338
}
339
break;
340
case TINT:
341
SvGROW(work, size * n);
342
for (i=0; i<n; i++) {
343
if ((work2=av_fetch(array,i,0)) == NULL)
344
iscalar = 0;
345
else {
346
if (SvROK(*work2))
347
goto errexit;
348
iscalar = SvIV(*work2);
349
}
350
sv_catpvn(work, (char *) &iscalar, size);
351
}
352
break;
353
case TULONG:
354
SvGROW(work, size * n);
355
for (i=0; i<n; i++) {
356
if ((work2=av_fetch(array,i,0)) == NULL)
357
ulscalar = 0;
358
else {
359
if (SvROK(*work2))
360
goto errexit;
361
ulscalar = SvUV(*work2);
362
}
363
sv_catpvn(work, (char *) &ulscalar, size);
364
}
365
break;
366
case TLONG:
367
SvGROW(work, size * n);
368
for (i=0; i<n; i++) {
369
if ((work2=av_fetch(array,i,0)) == NULL)
370
lscalar = 0;
371
else {
372
if (SvROK(*work2))
373
goto errexit;
374
lscalar = SvIV(*work2);
375
}
376
sv_catpvn(work, (char *) &lscalar, size);
377
}
378
break;
379
case TLONGLONG:
380
SvGROW(work, size * n);
381
for (i=0; i<n; i++) {
382
if ((work2=av_fetch(array,i,0)) == NULL)
383
llscalar = 0;
384
else {
385
if (SvROK(*work2))
386
goto errexit;
387
llscalar = SvIV(*work2);
388
}
389
sv_catpvn(work, (char *) &llscalar, size);
390
}
391
break;
392
case TCOMPLEX:
393
size /= 2;
394
case TFLOAT:
395
SvGROW(work, size * n);
396
for (i=0; i<n; i++) {
397
if ((work2=av_fetch(array,i,0)) == NULL)
398
fscalar = 0.0;
399
else {
400
if (SvROK(*work2))
401
goto errexit;
402
fscalar = SvNV(*work2);
403
}
404
sv_catpvn(work, (char *) &fscalar, size);
405
}
406
break;
407
case TDBLCOMPLEX:
408
size /= 2;
409
case TDOUBLE:
410
SvGROW(work, size);
411
for (i=0; i<n; i++) {
412
if ((work2=av_fetch(array,i,0)) == NULL)
413
dscalar = 0.0;
414
else {
415
if (SvROK(*work2))
416
goto errexit;
417
dscalar = SvNV(*work2);
418
}
419
sv_catpvn(work, (char *) &dscalar, size);
420
}
421
break;
422
default:
423
croak("pack1D() array code: unrecognized datatype (%d) was passed",datatype);
424
}
425
426
return (void *) SvPV(work, PL_na);
427
}
428
429
errexit:
430
croak("pack1D() - can only handle scalar values or refs to 1D arrays of scalars");
431
}
432
433
void* packND ( SV* arg, int datatype ) {
434
435
SV* work;
436
437
if (arg == &PL_sv_undef)
438
return (void *) NULL;
439
440
if (is_scalar_ref(arg))
441
return (void*) SvPV(SvRV(arg), PL_na);
442
443
work = sv_2mortal(newSVpv("", 0));
444
pack_element(work, &arg, datatype);
445
return (void *) SvPV(work, PL_na);
446
447
}
448
449
/* Internal function of packND - pack an element recursively */
450
451
void pack_element(SV* work, SV** arg, int datatype) {
452
453
char * stringscalar;
454
logical logscalar;
455
sbyte sbscalar;
456
byte bscalar;
457
unsigned short usscalar;
458
short sscalar;
459
unsigned int uiscalar;
460
int iscalar;
461
unsigned long ulscalar;
462
long lscalar;
463
LONGLONG llscalar;
464
float fscalar;
465
double dscalar;
466
467
int size;
468
I32 i,n;
469
AV* array;
470
471
size = sizeof_datatype(datatype);
472
473
/* Pack element arg onto work recursively */
474
475
/* Is arg a scalar? Pack and return */
476
if (arg==NULL || (!SvROK(*arg) && SvTYPE(*arg)!=SVt_PVGV)) {
477
switch (datatype) {
478
case TSTRING:
479
stringscalar = arg ? SvPV(*arg,PL_na) : "";
480
sv_catpvn(work, (char *) &stringscalar, size);
481
break;
482
case TLOGICAL:
483
logscalar = arg ? SvIV(*arg) : 0;
484
sv_catpvn(work, (char *) &logscalar, size);
485
break;
486
case TSBYTE:
487
sbscalar = arg ? SvIV(*arg) : 0;
488
sv_catpvn(work, (char *) &sbscalar, size);
489
break;
490
case TBYTE:
491
bscalar = arg ? SvUV(*arg) : 0;
492
sv_catpvn(work, (char *) &bscalar, size);
493
break;
494
case TUSHORT:
495
usscalar = arg ? SvUV(*arg) : 0;
496
sv_catpvn(work, (char *) &usscalar, size);
497
break;
498
case TSHORT:
499
sscalar = arg ? SvIV(*arg) : 0;
500
sv_catpvn(work, (char *) &sscalar, size);
501
break;
502
case TUINT:
503
uiscalar = arg ? SvUV(*arg) : 0;
504
sv_catpvn(work, (char *) &uiscalar, size);
505
break;
506
case TINT:
507
iscalar = arg ? SvIV(*arg) : 0;
508
sv_catpvn(work, (char *) &iscalar,size);
509
break;
510
case TULONG:
511
ulscalar = arg ? SvUV(*arg) : 0;
512
sv_catpvn(work, (char *) &ulscalar, size);
513
break;
514
case TLONG:
515
lscalar = arg ? SvIV(*arg) : 0;
516
sv_catpvn(work, (char *) &lscalar, size);
517
break;
518
case TLONGLONG:
519
llscalar = arg ? SvIV(*arg) : 0;
520
sv_catpvn(work, (char *) &llscalar, size);
521
break;
522
case TCOMPLEX:
523
size /= 2;
524
case TFLOAT:
525
fscalar = arg ? SvNV(*arg) : 0.0;
526
sv_catpvn(work, (char *) &fscalar, size);
527
break;
528
case TDBLCOMPLEX:
529
size /= 2;
530
case TDOUBLE:
531
dscalar = arg ? SvNV(*arg) : 0.0;
532
sv_catpvn(work, (char *) &dscalar, size);
533
break;
534
default:
535
croak("pack_element() - unrecognized datatype (%d) was passed",datatype);
536
}
537
}
538
539
/* Is it a glob or reference to an array? */
540
else if (SvTYPE(*arg)==SVt_PVGV || (SvROK(*arg) && SvTYPE(SvRV(*arg))==SVt_PVAV)) {
541
542
/* Dereference */
543
if (SvTYPE(*arg)==SVt_PVGV)
544
array = GvAVn((GV*)*arg); /* glob */
545
else
546
array = (AV *) SvRV(*arg); /* reference */
547
548
/* Pack each array element */
549
n = av_len(array) + 1;
550
for (i=0; i<n; i++)
551
pack_element(work, av_fetch(array, i, 0), datatype );
552
553
}
554
555
else
556
croak("pack_element() - can only handle scalars or refs to N-D arrays of scalars");
557
}
558
559
void unpack2D( SV * arg, void * var, long *dims, int datatype, int perlyunpack) {
560
long i,skip;
561
AV *array;
562
char * tmp_var = (char *)var;
563
564
if (! PERLYUNPACKING(perlyunpack) && datatype != TSTRING) {
565
unpack2scalar(arg,var,dims[0]*dims[1],datatype);
566
return;
567
}
568
569
coerce1D(arg,dims[0]);
570
array = (AV*)SvRV(arg);
571
572
skip = dims[1] * sizeof_datatype(datatype);
573
for (i=0;i<dims[0];i++) {
574
unpack1D(*av_fetch(array,i,0),tmp_var,dims[1],datatype,perlyunpack);
575
tmp_var += skip;
576
}
577
}
578
579
void unpack3D( SV * arg, void * var, long *dims, int datatype, int perlyunpack) {
580
long i,j,skip;
581
AV *array1,*array2;
582
SV *tmp_sv;
583
char *tmp_var = (char *)var;
584
585
if (! PERLYUNPACKING(perlyunpack) && datatype != TSTRING) {
586
unpack2scalar(arg,var,dims[0]*dims[1]*dims[2],datatype);
587
return;
588
}
589
590
coerce1D(arg,dims[0]);
591
array1 = (AV*)SvRV(arg);
592
593
skip = dims[2] * sizeof_datatype(datatype);
594
for (i=0; i<dims[0]; i++) {
595
tmp_sv = *av_fetch(array1,i,0);
596
coerce1D(tmp_sv,dims[1]);
597
array2 = (AV*)SvRV(tmp_sv);
598
for (j=0; j<dims[1]; j++) {
599
unpack1D(*av_fetch(array2,j,0),tmp_var,dims[2],datatype,perlyunpack);
600
tmp_var += skip;
601
}
602
}
603
}
604
605
/*
606
* This routine is known to have problems
607
*/
608
void unpackND ( SV * arg, void * var, int ndims, long *dims, int datatype,
609
int perlyunpack ) {
610
int i;
611
OFF_T ndata, nbytes, written, *places, skip;
612
AV **avs;
613
char *tmp_var = (char *)var;
614
615
/* number of pixels to read, number of bytes therein */
616
ndata = 1;
617
for (i=0;i<ndims;i++)
618
ndata *= dims[i];
619
nbytes = ndata * sizeof_datatype(datatype);
620
621
if (! PERLYUNPACKING(perlyunpack) && datatype != TSTRING) {
622
unpack2scalar(arg,var,ndata,datatype);
623
return;
624
}
625
626
places = calloc(ndims-1, sizeof(OFF_T));
627
avs = malloc((ndims-1) * sizeof(AV*));
628
629
coerceND(arg,ndims,dims);
630
631
avs[0] = (AV*)SvRV(arg);
632
skip = dims[ndims-1] * sizeof_datatype(datatype);
633
634
written = 0;
635
while (written < nbytes) {
636
637
for (i=1;i<ndims-1;i++)
638
avs[i] = (AV*)SvRV(*av_fetch(avs[i-1],places[i-1],0));
639
640
unpack1D(*av_fetch(avs[ndims-2],places[ndims-2],0),tmp_var,dims[ndims-1],datatype,perlyunpack);
641
tmp_var += skip;
642
written += skip;
643
644
places[ndims-2]++;
645
for (i=ndims-2;i>=0; i--) {
646
if (places[i] >= dims[i]) {
647
places[i] = 0;
648
if (i>0)
649
places[i-1]++;
650
}
651
else
652
break;
653
}
654
}
655
free(places);
656
free(avs);
657
}
658
659
/*
660
* Set argument's value to (copied) data.
661
*/
662
void unpack2scalar ( SV * arg, void * var, long n, int datatype ) {
663
long data_length;
664
665
if (datatype == TSTRING)
666
croak("unpack2scalar() - how did you manage to call me with a TSTRING datatype?!");
667
668
data_length = n * sizeof_datatype(datatype);
669
670
SvGROW(arg, data_length);
671
memcpy(SvPV(arg,PL_na), var, data_length);
672
673
return;
674
}
675
676
/*
677
* Takes a pointer to a single value of any given type, puts
678
* that value into the passed Perl scalar
679
*
680
* Note that type TSTRING does _not_ imply a (char **) was passed,
681
* but rather a (char *).
682
*/
683
void unpackScalar(SV * arg, void * var, int datatype) {
684
SV* tmp_sv[2];
685
686
if (var == NULL) {
687
sv_setpvn(arg,"",0);
688
return;
689
}
690
switch (datatype) {
691
case TSTRING:
692
sv_setpv(arg,(char *)var); break;
693
case TLOGICAL:
694
sv_setiv(arg,(IV)(*(logical *)var)); break;
695
case TSBYTE:
696
sv_setiv(arg,(IV)(*(sbyte *)var)); break;
697
case TBYTE:
698
sv_setuv(arg,(UV)(*(byte *)var)); break;
699
case TUSHORT:
700
sv_setuv(arg,(UV)(*(unsigned short *)var)); break;
701
case TSHORT:
702
sv_setiv(arg,(IV)(*(short *)var)); break;
703
case TUINT:
704
sv_setuv(arg,(UV)(*(unsigned int *)var)); break;
705
case TINT:
706
sv_setiv(arg,(IV)(*(int *)var)); break;
707
case TULONG:
708
sv_setuv(arg,(UV)(*(unsigned long *)var)); break;
709
case TLONG:
710
sv_setiv(arg,(IV)(*(long *)var)); break;
711
case TLONGLONG:
712
sv_setiv(arg,(IV)(*(LONGLONG *)var)); break;
713
case TFLOAT:
714
sv_setnv(arg,(double)(*(float *)var)); break;
715
case TDOUBLE:
716
sv_setnv(arg,(double)(*(double *)var)); break;
717
case TCOMPLEX:
718
tmp_sv[0] = newSVnv(*((float *)var));
719
tmp_sv[1] = newSVnv(*((float *)var+1));
720
sv_setsv(arg,newRV_noinc((SV*)av_make(2,tmp_sv)));
721
SvREFCNT_dec(tmp_sv[0]);
722
SvREFCNT_dec(tmp_sv[1]);
723
break;
724
case TDBLCOMPLEX:
725
tmp_sv[0] = newSVnv(*((double *)var));
726
tmp_sv[1] = newSVnv(*((double *)var+1));
727
sv_setsv(arg,newRV_noinc((SV*)av_make(2,tmp_sv)));
728
SvREFCNT_dec(tmp_sv[0]);
729
SvREFCNT_dec(tmp_sv[1]);
730
break;
731
default:
732
croak("unpackScalar() - invalid type (%d) given",datatype);
733
}
734
return;
735
}
736
737
void unpack1D ( SV * arg, void * var, long n, int datatype,
738
int perlyunpack ) {
739
740
char ** stringvar;
741
logical * logvar;
742
sbyte * sbvar;
743
byte * bvar;
744
unsigned short * usvar;
745
short * svar;
746
unsigned int * uivar;
747
int * ivar;
748
unsigned long * ulvar;
749
long * lvar;
750
LONGLONG * llvar;
751
float * fvar;
752
double * dvar;
753
SV *tmp_sv[2];
754
AV *array;
755
I32 i,m;
756
757
if (!PERLYUNPACKING(perlyunpack) && datatype != TSTRING) {
758
unpack2scalar(arg,var,n,datatype);
759
return;
760
}
761
762
m=n;
763
array = coerce1D( arg, m );
764
765
/* This could screw up routines like fits_read_imghdr */
766
/*
767
if (m==0)
768
m = av_len(array)+1;
769
*/
770
771
switch (datatype) {
772
case TSTRING: /* array of strings, I suppose */
773
stringvar = (char **)var;
774
for (i=0; i<m; i++)
775
av_store(array,i,newSVpv(stringvar[i],0));
776
break;
777
case TLOGICAL:
778
logvar = (logical *) var;
779
for(i=0; i<m; i++)
780
av_store(array, i, newSViv( (IV)logvar[i] ));
781
break;
782
case TSBYTE:
783
sbvar = (sbyte *) var;
784
for(i=0; i<m; i++)
785
av_store(array, i, newSViv( (IV)sbvar[i] ));
786
break;
787
case TBYTE:
788
bvar = (byte *) var;
789
for(i=0; i<m; i++)
790
av_store(array, i, newSVuv( (UV)bvar[i] ));
791
break;
792
case TUSHORT:
793
usvar = (unsigned short *) var;
794
for(i=0; i<m; i++)
795
av_store(array, i, newSVuv( (UV)usvar[i] ));
796
break;
797
case TSHORT:
798
svar = (short *) var;
799
for(i=0; i<m; i++)
800
av_store(array, i, newSViv( (IV)svar[i] ));
801
break;
802
case TUINT:
803
uivar = (unsigned int *) var;
804
for(i=0; i<m; i++)
805
av_store(array, i, newSVuv( (UV)uivar[i] ));
806
break;
807
case TINT:
808
ivar = (int *) var;
809
for(i=0; i<m; i++)
810
av_store(array, i, newSViv( (IV)ivar[i] ));
811
break;
812
case TULONG:
813
ulvar = (unsigned long *) var;
814
for(i=0; i<m; i++)
815
av_store(array, i, newSVuv( (UV)ulvar[i] ));
816
break;
817
case TLONG:
818
lvar = (long *) var;
819
for(i=0; i<m; i++)
820
av_store(array, i, newSViv( (IV)lvar[i] ));
821
break;
822
case TLONGLONG:
823
llvar = (LONGLONG *) var;
824
for(i=0; i<m; i++)
825
av_store(array, i, newSViv( (IV)llvar[i] ));
826
break;
827
case TFLOAT:
828
fvar = (float *) var;
829
for(i=0; i<m; i++)
830
av_store(array, i, newSVnv( (double)fvar[i] ));
831
break;
832
case TDOUBLE:
833
dvar = (double *) var;
834
for(i=0; i<m; i++)
835
av_store(array, i, newSVnv( (double)dvar[i] ));
836
break;
837
case TCOMPLEX:
838
fvar = (float *) var;
839
for (i=0; i<m; i++) {
840
tmp_sv[0] = newSVnv( (double)fvar[2*i] );
841
tmp_sv[1] = newSVnv( (double)fvar[2*i+1] );
842
av_store(array, i, newRV((SV *)av_make(2,tmp_sv)));
843
SvREFCNT_dec(tmp_sv[0]); SvREFCNT_dec(tmp_sv[1]);
844
}
845
break;
846
case TDBLCOMPLEX:
847
dvar = (double *) var;
848
for (i=0; i<m; i++) {
849
tmp_sv[0] = newSVnv( (double)dvar[2*i] );
850
tmp_sv[1] = newSVnv( (double)dvar[2*i+1] );
851
av_store(array, i, newRV_noinc((SV*)(av_make(2,tmp_sv))));
852
SvREFCNT_dec(tmp_sv[0]); SvREFCNT_dec(tmp_sv[1]);
853
}
854
break;
855
default:
856
croak("unpack1D() - invalid datatype (%d)",datatype);
857
}
858
return;
859
}
860
861
AV* coerce1D ( SV* arg, long n) {
862
AV* array;
863
I32 i;
864
865
if (is_scalar_ref(arg))
866
return (AV*)NULL;
867
868
if (SvTYPE(arg)==SVt_PVGV)
869
array = GvAVn((GV*)arg);
870
else if (SvROK(arg) && SvTYPE(SvRV(arg))==SVt_PVAV)
871
array = (AV *) SvRV(arg);
872
else {
873
array = (AV*)sv_2mortal((SV*)newAV());
874
sv_setsv(arg, sv_2mortal(newRV((SV*) array)));
875
}
876
877
for (i=av_len(array)+1; i<n; i++)
878
av_store( array, i, newSViv((IV) 0));
879
880
return array;
881
}
882
883
AV* coerceND (SV *arg, int ndims, long *dims) {
884
AV* array;
885
I32 j;
886
887
if (!ndims || (array=coerce1D(arg,dims[0])) == NULL)
888
return (AV *)NULL;
889
890
for (j=0; j<dims[0]; j++)
891
coerceND(*av_fetch(array,j,0),ndims-1,dims+1);
892
893
return array;
894
}
895
896
/*
897
* A way of getting temporary memory without having to free() it
898
* by making a mortal Perl variable of the appropriate size.
899
*/
900
void* get_mortalspace( long n, int datatype ) {
901
long datalen;
902
SV *work;
903
904
work = sv_2mortal(newSVpv("", 0));
905
datalen = sizeof_datatype(datatype) * n;
906
SvGROW(work,datalen);
907
908
/*
909
* One could imagine allocating some space with this routine,
910
* passing the pointer off to cfitsio, ending up with an error
911
* and then having xsubpp set the output SV to the contents
912
* of memory pointed to by this said pointer, which may or
913
* may not have a NUL in its random contents.
914
*/
915
if (datalen)
916
*((char *)SvPV(work,PL_na)) = '\0';
917
918
return (void *) SvPV(work, PL_na);
919
}
920
921
/*
922
* Return the number of bytes required for a datum of the given type.
923
*/
924
int sizeof_datatype(int datatype) {
925
switch (datatype) {
926
case TSTRING:
927
return sizeof(char *);
928
case TLOGICAL:
929
return sizeof(logical);
930
case TSBYTE:
931
return sizeof(sbyte);
932
case TBYTE:
933
return sizeof(byte);
934
case TUSHORT:
935
return sizeof(unsigned short);
936
case TSHORT:
937
return sizeof(short);
938
case TUINT:
939
return sizeof(unsigned int);
940
case TINT:
941
return sizeof(int);
942
case TULONG:
943
return sizeof(unsigned long);
944
case TLONG:
945
return sizeof(long);
946
case TLONGLONG:
947
return sizeof(LONGLONG);
948
case TFLOAT:
949
return sizeof(float);
950
case TDOUBLE:
951
return sizeof(double);
952
case TCOMPLEX:
953
return 2*sizeof(float);
954
case TDBLCOMPLEX:
955
return 2*sizeof(double);
956
default:
957
croak("sizeof_datatype() - invalid datatype (%d) given",datatype);
958
}
959
}
960
961
962
/* takes an array of longs, reversing their order inplace
963
* useful for reversing the order of naxes before passing them
964
* off to unpack?D() */
965
void order_reverse (int nelem, long *vals) {
966
long tmp;
967
int i;
968
for (i=0; i<nelem/2; i++) {
969
tmp = vals[i];
970
vals[i] = vals[nelem-i-1];
971
vals[nelem-i-1] = tmp;
972
}
973
}
Loggerhead is a web-based interface for Breezy
Version: 2.0.1