File Coverage

File:Nary.xs
Coverage:93.0%

linestmtbranpathcondsubtimecode
1/* This file is part of the Sub::Nary Perl module.
2 * See http://search.cpan.org/dist/Sub::Nary/ */
3
4#define PERL_NO_GET_CONTEXT
5#include "EXTERN.h"
6#include "perl.h"
7#include "XSUB.h"
8
9#ifndef mPUSHi
10# define mPUSHi(I) PUSHs(sv_2mortal(newSViv(I)))
11#endif /* !mPUSHi */
12
13typedef struct {
14 UV k;
15 NV v;
16} sn_combcache;
17
18STATIC U32 sn_hash_list = 0;
19
20/* --- XS ------------------------------------------------------------------ */
21
22MODULE = Sub::Nary PACKAGE = Sub::Nary
23
24PROTOTYPES: ENABLE
25
26BOOT:
27{
28
13
 PERL_HASH(sn_hash_list, "list", 4);
29}
30
31void
32tag(SV *op)
33PROTOTYPE: $
34CODE:
35
332
 ST(0) = sv_2mortal(newSVuv(SvUV(SvRV(op))));
36
332
 XSRETURN(1);
37
38void
39null(SV *op)
40PROTOTYPE: $
41PREINIT:
42 OP *o;
43CODE:
44
3983
 o = INT2PTR(OP *, SvUV(SvRV(op)));
45
3983
 ST(0) = sv_2mortal(newSVuv(o == NULL));
46
3983
 XSRETURN(1);
47
48void
49zero(SV *sv)
50PROTOTYPE: $
51PREINIT:
52 HV *hv;
53 IV res;
54CODE:
55
36
 if (!SvOK(sv))
56
15
  XSRETURN_IV(1);
57
21
 if (!SvROK(sv)) {
58
6
  res = SvNOK(sv) ? SvNV(sv) == 0.0 : SvUV(sv) == 0;
59
6
  XSRETURN_IV(res);
60 }
61
15
 hv = (HV *) SvRV(sv);
62
15
 res = hv_iterinit(hv) == 1 && hv_exists(hv, "0", 1);
63
15
 XSRETURN_IV(res);
64
65void
66count(SV *sv)
67PROTOTYPE: $
68PREINIT:
69 HV *hv;
70 HE *key;
71
2299
 NV c = 0;
72CODE:
73
2299
 if (!SvOK(sv))
74
1866
  XSRETURN_IV(0);
75
433
 if (!SvROK(sv))
76
84
  XSRETURN_IV(1);
77
349
 hv = (HV *) SvRV(sv);
78
349
 hv_iterinit(hv);
79
1112
 while (key = hv_iternext(hv)) {
80
414
  c += SvNV(HeVAL(key));
81 }
82
349
 XSRETURN_NV(c);
83
84void
85normalize(SV *sv)
86PROTOTYPE: $
87PREINIT:
88 HV *hv, *res;
89 HE *key;
90 SV *val;
91
894
 NV c = 0;
92CODE:
93
894
 if (!SvOK(sv))
94
205
  XSRETURN_UNDEF;
95
689
 res = newHV();
96
689
 if (!SvROK(sv)) {
97
1
  val = newSVuv(1);
98
1
  if (!hv_store_ent(res, sv, val, 0))
99
0
   SvREFCNT_dec(val);
100 } else {
101
688
  hv = (HV *) SvRV(sv);
102
688
  if (!hv_iterinit(hv)) {
103
1
   val = newSVuv(1);
104
1
   if (!hv_store(res, "0", 1, val, 0))
105
0
    SvREFCNT_dec(val);
106  } else {
107
2190
   while (key = hv_iternext(hv)) {
108
816
    c += SvNV(HeVAL(key));
109   }
110
687
   hv_iterinit(hv);
111
2190
   while (key = hv_iternext(hv)) {
112
816
    val = newSVnv(SvNV(HeVAL(key)) / c);
113
816
    if (!hv_store_ent(res, HeSVKEY_force(key), val, HeHASH(key)))
114
0
     SvREFCNT_dec(val);
115   }
116  }
117 }
118
689
 ST(0) = sv_2mortal(newRV_noinc((SV *) res));
119
689
 XSRETURN(1);
120
121void
122scale(SV *csv, SV *sv)
123PROTOTYPE: $;$
124PREINIT:
125 HV *hv, *res;
126 HE *key;
127 SV *val;
128
2469
 NV c = 1;
129CODE:
130
2469
 if (!SvOK(sv))
131
280
  XSRETURN_UNDEF;
132
2189
 if (SvOK(csv))
133
2189
  c = SvNV(csv);
134
2189
 res = newHV();
135
2189
 if (!SvROK(sv)) {
136
564
  val = newSVnv(c);
137
564
  if (!hv_store_ent(res, sv, val, 0))
138
0
   SvREFCNT_dec(val);
139 } else {
140
1625
  hv = (HV *) SvRV(sv);
141
1625
  if (!hv_iterinit(hv)) {
142
1
   val = newSVnv(c);
143
1
   if (!hv_store(res, "0", 1, val, 0))
144
0
    SvREFCNT_dec(val);
145  } else {
146
1624
   hv_iterinit(hv);
147
5214
   while (key = hv_iternext(hv)) {
148
1966
    val = newSVnv(SvNV(HeVAL(key)) * c);
149
1966
    if (!hv_store_ent(res, HeSVKEY_force(key), val, HeHASH(key)))
150
0
     SvREFCNT_dec(val);
151   }
152  }
153 }
154
2189
 ST(0) = sv_2mortal(newRV_noinc((SV *) res));
155
2189
 XSRETURN(1);
156
157void
158add(...)
159PROTOTYPE: @
160PREINIT:
161 HV *res;
162 SV *cur, *val;
163 HE *key, *old;
164 I32 i;
165CODE:
166
904
 if (!items)
167
1
  XSRETURN_UNDEF;
168
903
 res = newHV();
169
2680
 for (i = 0; i < items; ++i) {
170
1781
  cur = ST(i);
171
1781
  if (!SvOK(cur))
172
913
   continue;
173
868
  if (!SvROK(cur)) {
174
38
   if (strEQ(SvPV_nolen(cur), "list")) {
175
4
    hv_clear(res);
176
4
    val = newSVuv(1);
177
4
    if (!hv_store(res, "list", 4, val, sn_hash_list))
178
0
     SvREFCNT_dec(val);
179
4
    break;
180   } else {
181
34
    NV v = 1;
182
34
    if ((old = hv_fetch_ent(res, cur, 1, 0)) && SvOK(val = HeVAL(old)))
183
1
     v += SvNV(val);
184
34
    val = newSVnv(v);
185
34
    if (!hv_store_ent(res, cur, val, 0))
186
0
     SvREFCNT_dec(val);
187
34
    continue;
188   }
189  }
190
830
  cur = SvRV(cur);
191
830
  hv_iterinit((HV *) cur);
192
2644
  while (key = hv_iternext((HV *) cur)) {
193
984
   SV *k = HeSVKEY_force(key);
194
984
   NV v = SvNV(HeVAL(key));
195
984
   if ((old = hv_fetch_ent(res, k, 1, 0)) && SvOK(val = HeVAL(old)))
196
14
    v += SvNV(val);
197
984
   val = newSVnv(v);
198
984
   if (!hv_store_ent(res, k, val, 0))
199
0
    SvREFCNT_dec(val);
200  }
201 }
202
903
 if (!hv_iterinit(res)) {
203
90
  SvREFCNT_dec(res);
204
90
  XSRETURN_UNDEF;
205 }
206
813
 ST(0) = sv_2mortal(newRV_noinc((SV *) res));
207
813
 XSRETURN(1);
208
209void
210cumulate(SV *sv, SV *nsv, SV *csv)
211PROTOTYPE: $$$
212PREINIT:
213 HV *res;
214 SV *val;
215 HE *key;
216 NV c0, c, a;
217 UV i, n;
218CODE:
219
28
 if (!SvOK(sv))
220
21
  XSRETURN_UNDEF;
221
7
 n = SvUV(nsv);
222
7
 c0 = SvNV(csv);
223
7
 if (!n) {
224
2
  ST(0) = sv_2mortal(newSVuv(0));
225
2
  XSRETURN(1);
226 }
227
5
 if (!SvROK(sv) || !c0) {
228
2
  ST(0) = sv;
229
2
  XSRETURN(1);
230 }
231
3
 sv = SvRV(sv);
232
3
 if (!hv_iterinit((HV *) sv))
233
1
  XSRETURN_UNDEF;
234
2
 c = 1;
235
2
 a = c0;
236
6
 for (; n > 0; n /= 2) {
237
4
  if (n % 2)
238
2
   c *= a;
239
4
  a *= a;
240 }
241
2
 c = (1 - c) / (1 - c0);
242
2
 res = newHV();
243
6
 while (key = hv_iternext((HV *) sv)) {
244
2
  SV *k = HeSVKEY_force(key);
245
2
  val = newSVnv(c * SvNV(HeVAL(key)));
246
2
  if (!hv_store_ent(res, k, val, 0))
247
0
   SvREFCNT_dec(val);
248 }
249
2
 ST(0) = sv_2mortal(newRV_noinc((SV *) res));
250
2
 XSRETURN(1);
251
252void
253combine(...)
254PROTOTYPE: @
255PREINIT:
256 HV *res[2];
257 SV *cur, *val;
258 SV *list1, *list2;
259 SV *temp;
260 HE *key, *old;
261 I32 i;
262
914
 I32 n = 0, o;
263 I32 j, n1, n2;
264
914
 UV shift = 0, do_shift = 0;
265
914
 sn_combcache *cache = NULL;
266
914
 I32 cachelen = 0;
267CODE:
268
914
 if (!items)
269
205
  XSRETURN_UNDEF;
270
709
 res[0] = res[1] = NULL;
271
731
 for (i = 0; i < items; ++i) {
272
724
  cur = ST(i);
273
724
  if (!SvOK(cur))
274
5
   continue;
275
719
  if (!SvROK(cur)) {
276
22
   if (strEQ(SvPV_nolen(cur), "list")) {
277
5
    res[0] = newHV();
278
5
    n = 0;
279
5
    val = newSVuv(1);
280
5
    if (!hv_store(res[0], "list", 4, val, sn_hash_list))
281
0
     SvREFCNT_dec(val);
282
5
    i = items;
283
5
    if (!shift)
284
2
     do_shift = 0;
285
5
    break;
286   } else {
287
17
    shift += SvUV(cur);
288
17
    do_shift = 1;
289
17
    continue;
290   }
291  }
292
697
  cur = SvRV(cur);
293
697
  res[0] = newHV();
294
2219
  while (key = hv_iternext((HV *) cur)) {
295
825
   val = newSVsv(HeVAL(key));
296
825
   if (!hv_store_ent(res[0], HeSVKEY_force(key), val, 0))
297
0
    SvREFCNT_dec(val);
298  }
299
697
  n = 0;
300
697
  if (!shift)
301
694
   do_shift = 0;
302
697
  break;
303 }
304
709
 temp = sv_2mortal(newSViv(0));
305
917
 for (++i; i < items; ++i) {
306
225
  cur = ST(i);
307
225
  if (!SvOK(cur))
308
1
   continue;
309
224
  if (!SvROK(cur)) {
310
9
   if (strEQ(SvPV_nolen(cur), "list")) {
311
2
    hv_clear(res[n]);
312
2
    val = newSVuv(1);
313
2
    if (!hv_store(res[n], "list", 4, val, sn_hash_list))
314
0
     SvREFCNT_dec(val);
315
2
    shift = 0;
316
2
    do_shift = 0;
317
2
    break;
318   } else {
319
7
    shift += SvUV(cur);
320
7
    continue;
321   }
322  }
323
215
  cur = SvRV(cur);
324
215
  o = 1 - n;
325
215
  if (!res[o])
326
183
   res[o] = newHV();
327  else
328
32
   hv_clear(res[o]);
329
215
  list1 = hv_delete((HV *) cur, "list", 4, 0);
330
215
  n1 = hv_iterinit((HV *) cur);
331
215
  list2 = hv_delete(res[n], "list", 4, 0);
332
215
  n2 = hv_iterinit(res[n]);
333
215
  if ((list1 && !n1) || (list2 && !n2)) {
334
15
   val = newSViv(1);
335
15
   if (!hv_store(res[o], "list", 4, val, sn_hash_list))
336
0
    SvREFCNT_dec(val);
337
15
   n = o;
338
15
   break;
339
200
  } else if (list1 || list2) {
340
3
   NV l1 = list1 ? SvNV(list1) : 0;
341
3
   NV l2 = list2 ? SvNV(list2) : 0;
342
3
   val = newSVnv(l1 + l2 - l1 * l2);
343
3
   if (!hv_store(res[o], "list", 4, val, sn_hash_list))
344
0
    SvREFCNT_dec(val);
345  }
346
200
  if (n2 > cachelen) {
347
171
   Renew(cache, n2, sn_combcache);
348
171
   cachelen = n2;
349  }
350
200
  j = 0;
351
617
  while (key = hv_iternext(res[n])) {
352
217
   cache[j].k = SvUV(HeSVKEY_force(key));
353
217
   cache[j].v = SvNV(HeVAL(key));
354
217
   ++j;
355  }
356
615
  while (key = hv_iternext((HV *) cur)) {
357
215
   IV k = SvUV(HeSVKEY_force(key));
358
215
   NV v = SvNV(HeVAL(key));
359
464
   for (j = 0; j < n2; ++j) {
360
249
    sv_setiv(temp, k + cache[j].k);
361
266
    if ((old = hv_fetch_ent(res[o], temp, 1, 0)) && SvOK(val = HeVAL(old))) {
362
17
     val = newSVnv(SvNV(val) + v * cache[j].v);
363    } else {
364
232
     val = newSVnv(v * cache[j].v);
365    }
366
249
    if (!hv_store_ent(res[o], temp, val, 0))
367
0
     SvREFCNT_dec(val);
368   }
369  }
370
200
  n = o;
371 }
372
709
 Safefree(cache);
373
725
 if (shift || do_shift) {
374
16
  if (!res[n]) {
375
6
   res[n] = newHV();
376
6
   sv_setiv(temp, shift);
377
6
   val = newSViv(1);
378
6
   if (!hv_store_ent(res[n], temp, val, 0))
379
0
    SvREFCNT_dec(val);
380  } else {
381
10
   o = 1 - n;
382
10
   if (!res[o])
383
7
    res[o] = newHV();
384   else
385
3
    hv_clear(res[o]);
386
10
   list1 = hv_delete(res[n], "list", 4, 0);
387
10
   hv_iterinit(res[n]);
388
37
   while (key = hv_iternext(res[n])) {
389
17
    sv_setiv(temp, SvUV(HeSVKEY_force(key)) + shift);
390
17
    val = newSVsv(HeVAL(key));
391
17
    if (!hv_store_ent(res[o], temp, val, 0))
392
0
     SvREFCNT_dec(val);
393   }
394
10
   if (list1) {
395
3
    val = newSVsv(list1);
396
3
    if (!hv_store(res[o], "list", 4, val, sn_hash_list))
397
0
     SvREFCNT_dec(val);
398   }
399
10
   n = o;
400  }
401
693
 } else if (!res[0] && !res[1])
402
1
  XSRETURN_UNDEF;
403
708
 if (n == 1)
404
157
  SvREFCNT_dec(res[0]);
405
551
 else if (res[1])
406
33
  SvREFCNT_dec(res[1]);
407
708
 ST(0) = sv_2mortal(newRV_noinc((SV *) res[n]));
408
708
 XSRETURN(1);
409
410void
411scalops()
412PROTOTYPE:
413PREINIT:
414 U32 cxt;
415
15
 int i, count = 0;
416CODE:
417
15
 cxt = GIMME_V;
418
15
 if (cxt == G_SCALAR) {
419
353
  for (i = 0; i < OP_max; ++i) {
420
352
   count += (PL_opargs[i] & (OA_RETSCALAR | OA_RETINTEGER)) != 0;
421  }
422
1
  EXTEND(SP, 1);
423
1
  mPUSHi(count);
424
1
  XSRETURN(1);
425
14
 } else if (cxt == G_ARRAY) {
426
4942
  for (i = 0; i < OP_max; ++i) {
427
4928
   if (PL_opargs[i] & (OA_RETSCALAR | OA_RETINTEGER)) {
428
3668
    const char *name = PL_op_name[i];
429
3668
    XPUSHs(sv_2mortal(newSVpvn_share(name, strlen(name), 0)));
430
3668
    ++count;
431   }
432  }
433
14
  XSRETURN(count);
434 }
435