File Coverage

blib/lib/wildproto.pm
Criterion Covered Total %
statement 3 3 100.0
branch n/a
condition n/a
subroutine 1 1 100.0
pod n/a
total 4 4 100.0


line stmt bran cond sub pod time code
1             package wildproto;
2             $VERSION = '1.0.1';
3              
4 1     1   435 use base pragmatic;
  1         2  
  1         632  
5              
6             bootstrap xsub;
7              
8             use xsub q{
9             static bool active = FALSE;
10              
11             OP *(*old_ck_entersub)(pTHX_ OP *);
12              
13             static OP *new_ck_entersub(pTHX_ OP *o) {
14             OP *op;
15             char *real_proto = NULL;
16             char *copy_proto = NULL;
17              
18             if (active) {
19             UNOP *uno = (UNOP *)o;
20             OP *prev;
21             OP *argop;
22             OP *cvop;
23             char *proto = 0;
24             CV *cv = 0;
25             SVOP *tmpop;
26              
27             if (o->op_private & OPpENTERSUB_AMPER)
28             goto real_op;
29              
30             prev = uno->op_first->op_sibling ? o : uno->op_first;
31             prev = ((UNOP *)prev)->op_first;
32             argop = prev->op_sibling;
33              
34             for (cvop = argop; cvop->op_sibling; cvop = cvop->op_sibling);
35            
36             if (cvop->op_type != OP_RV2CV)
37             goto real_op;
38             if (cvop->op_private & OPpENTERSUB_AMPER)
39             goto real_op;
40             tmpop = (SVOP*)((UNOP*)cvop)->op_first;
41             if (tmpop->op_type != OP_GV)
42             goto real_op;
43            
44             cv = GvCVu(cGVOPx_gv(tmpop));
45             if (!cv || !SvPOK(cv))
46             goto real_op;
47             proto = SvPV_nolen((SV*)cv);
48            
49             while (argop != cvop) {
50             #ifdef WACKYPROTO
51             int type = 0;
52             #endif
53              
54             while (*proto == ' ' || *proto == ';')
55             proto++;
56             if (!*proto || *proto == '@' || *proto == '%')
57             break;
58              
59             if (*proto == '\\\\' && *(proto+1) == '?')
60             #ifdef WACKYPROTO
61             type = 1;
62             else if (*(proto+0) == '(' && *(proto+1) == ')')
63             type = 2;
64             else if (*(proto+0) == '[' && *(proto+1) == ']') type = 3;
65             else if (*(proto+0) == '{' && *(proto+1) == '}') type = 4;
66             else type = 0;
67              
68             if (type)
69             #endif
70             {
71             OP *next = argop->op_sibling;
72             argop->op_sibling = 0;
73              
74             #ifdef WACKYPROTO
75             switch (type) {
76             case 1:
77             #endif
78             argop = newUNOP(OP_REFGEN, 0, mod(argop, OP_REFGEN));
79             #ifdef WACKYPROTO
80             break;
81             case 2:
82             argop = newUNOP(OP_REFGEN, 0, mod(argop, OP_REFGEN));
83             argop = newANONLIST(argop);
84             break;
85             case 3:
86             argop = newANONLIST(argop);
87             break;
88             case 4:
89             argop = newANONHASH(argop);
90             break;
91             }
92             #endif
93              
94             argop->op_sibling = next;
95             prev->op_sibling = argop;
96             if (!real_proto) {
97             real_proto = proto;
98             copy_proto = savepv(proto);
99             }
100             *proto++ = ' ';
101             *proto = '$';
102             }
103              
104             if (*proto == '\\\\')
105             if (!*++proto)
106             break;
107            
108             proto++;
109             prev = argop;
110             argop = argop->op_sibling;
111             }
112             }
113              
114             real_op:
115             op = old_ck_entersub(aTHX_ o);
116             if (real_proto)
117             strcpy(real_proto, copy_proto);
118             return op;
119             }
120             };
121              
122             use xsub enable => q($), q{
123             if (active)
124             return &PL_sv_yes;
125              
126             old_ck_entersub = PL_check[OP_ENTERSUB];
127             PL_check[OP_ENTERSUB] = new_ck_entersub;
128              
129             active = TRUE;
130             return &PL_sv_yes;
131             };
132              
133             use xsub disable => q($), q{
134             if (!active)
135             return &PL_sv_yes;
136              
137             active = FALSE;
138             if (PL_check[OP_ENTERSUB] == new_ck_entersub) {
139             PL_check[OP_ENTERSUB] = old_ck_entersub;
140             } else {
141             Perl_warn(aTHX_ "PL_check[OP_ENTERSUB] apparently hijacked at %s line %d\n",
142             __FILE__, __LINE__);
143             }
144              
145             return &PL_sv_no;
146             };
147              
148             1