File Coverage

lib/Shannon/Entropy/XS.xs
Criterion Covered Total %
statement 50 52 96.1
branch 19 30 63.3
condition n/a
subroutine n/a
pod n/a
total 69 82 84.1


line stmt bran cond sub pod time code
1             #define PERL_NO_GET_CONTEXT // we'll define thread context if necessary (faster)
2             #include "EXTERN.h" // globals/constant import locations
3             #include "perl.h" // Perl symbols, structures and constants definition
4             #include "XSUB.h" // xsubpp functions and macros
5             #include
6              
7             #ifndef OpSIBLING
8             # define OpSIBLING(o) ((o)->op_sibling)
9             #endif
10             #ifndef OpMORESIB_set
11             # define OpMORESIB_set(o, sib) ((o)->op_sibling = (sib))
12             #endif
13             #ifndef OpLASTSIB_set
14             # define OpLASTSIB_set(o, parent) ((o)->op_sibling = NULL)
15             #endif
16              
17             #if PERL_VERSION >= 14
18             static XOP entropy_xop;
19             #endif
20              
21 4           static int makehist(const unsigned char *str, int *hist, int len) {
22             int chars[256];
23 4           int histlen = 0, i;
24 1028 100         for (i = 0; i < 256; i++) chars[i] = -1;
25 67 100         for (i = 0; i < len; i++) {
26 63           int c = (int)str[i];
27 63 100         if (chars[c] == -1) {
28 57           chars[c] = histlen;
29 57           histlen++;
30             }
31 63           hist[chars[c]]++;
32             }
33 4           return histlen;
34             }
35              
36 5           static double entropy(const char *str) {
37 5           int len = strlen(str);
38 5           int hist[256] = {0}; /* Max 256 unique chars, stack allocated */
39             int histlen, i;
40 5           double out = 0.0;
41 5 100         if (len == 0) return 0.0;
42 4           histlen = makehist((const unsigned char *)str, hist, len);
43 61 100         for (i = 0; i < histlen; i++) {
44 57           double p = (double)hist[i] / len;
45 57           out -= p * log2(p);
46             }
47 4           return out;
48             }
49              
50             #if PERL_VERSION >= 14
51              
52 5           static OP* pp_entropy(pTHX) {
53 5           dSP;
54 5           SV *sv = TOPs;
55             STRLEN len;
56 5           const char *str = SvPV(sv, len);
57 5           double result = entropy(str);
58 5           POPs;
59 5           mPUSHn(result);
60 5           RETURN;
61             }
62              
63 5           static OP* entropy_call_checker(pTHX_ OP *entersubop, GV *namegv, SV *ckobj) {
64             OP *pushop, *argop, *nextop, *newop;
65             PERL_UNUSED_ARG(namegv);
66             PERL_UNUSED_ARG(ckobj);
67 5           pushop = cLISTOPx(entersubop)->op_first;
68 5 50         if (!pushop) return entersubop;
69 5 50         if (pushop->op_type == OP_NULL && cLISTOPx(pushop)->op_first) {
    50          
70 5           pushop = cLISTOPx(pushop)->op_first;
71             }
72 5 50         argop = OpSIBLING(pushop);
73 5 50         if (!argop) return entersubop;
74 5 50         nextop = OpSIBLING(argop);
75 5 50         if (!nextop) return entersubop;
76 5 50         if (OpSIBLING(nextop)) return entersubop;
    0          
77 5           OpMORESIB_set(pushop, nextop);
78 5           OpLASTSIB_set(argop, NULL);
79 5           newop = newUNOP(OP_CUSTOM, 0, argop);
80 5           newop->op_ppaddr = pp_entropy;
81 5           op_free(entersubop);
82 5           return newop;
83             }
84              
85             #endif
86              
87             MODULE = Shannon::Entropy::XS PACKAGE = Shannon::Entropy::XS
88             PROTOTYPES: ENABLE
89              
90             double
91             entropy(string)
92             SV *string
93             CODE:
94             STRLEN len;
95 0           const char *str = SvPV(string, len);
96 0           RETVAL = entropy(str);
97             OUTPUT:
98             RETVAL
99              
100             BOOT:
101             #if PERL_VERSION >= 14
102             {
103             CV *entropy_cv;
104 2           XopENTRY_set(&entropy_xop, xop_name, "entropy");
105 2           XopENTRY_set(&entropy_xop, xop_desc, "Shannon entropy calculation");
106 2           Perl_custom_op_register(aTHX_ pp_entropy, &entropy_xop);
107 2           entropy_cv = get_cv("Shannon::Entropy::XS::entropy", 0);
108 2 50         if (entropy_cv) {
109 2           cv_set_call_checker(entropy_cv, entropy_call_checker, (SV *)entropy_cv);
110             }
111             }
112             #endif