File Coverage

hax/perl-additions.c.inc
Criterion Covered Total %
statement 2 2 100.0
branch 2 6 33.3
condition n/a
subroutine n/a
pod n/a
total 4 8 50.0


line stmt bran cond sub pod time code
1             /* vi: set ft=c : */
2              
3             #if HAVE_PERL_VERSION(5, 22, 0)
4             # define PadnameIsNULL(pn) (!(pn))
5             #else
6             # define PadnameIsNULL(pn) (!(pn) || (pn) == &PL_sv_undef)
7             #endif
8              
9             #ifndef hv_deletes
10             # define hv_deletes(hv, skey, flags) hv_delete((hv), ("" skey ""), (sizeof(skey) - 1), flags)
11             #endif
12              
13             #if HAVE_PERL_VERSION(5, 22, 0)
14             # define PadnameOUTER_off(pn) (PadnameFLAGS(pn) &= ~PADNAMEt_OUTER)
15             #else
16             /* PadnameOUTER is really the SvFAKE flag */
17             # define PadnameOUTER_off(pn) SvFAKE_off(pn)
18             #endif
19              
20             #define save_strndup(s, l) S_save_strndup(aTHX_ s, l)
21             static char *S_save_strndup(pTHX_ char *s, STRLEN l)
22             {
23             /* savepvn doesn't put anything on the save stack, despite its name */
24             char *ret = savepvn(s, l);
25             SAVEFREEPV(ret);
26             return ret;
27             }
28              
29             static char *PL_savetype_name[] PERL_UNUSED_DECL = {
30             /* These have been present since 5.16 */
31             [SAVEt_ADELETE] = "ADELETE",
32             [SAVEt_AELEM] = "AELEM",
33             [SAVEt_ALLOC] = "ALLOC",
34             [SAVEt_APTR] = "APTR",
35             [SAVEt_AV] = "AV",
36             [SAVEt_BOOL] = "BOOL",
37             [SAVEt_CLEARSV] = "CLEARSV",
38             [SAVEt_COMPILE_WARNINGS] = "COMPILE_WARNINGS",
39             [SAVEt_COMPPAD] = "COMPPAD",
40             [SAVEt_DELETE] = "DELETE",
41             [SAVEt_DESTRUCTOR] = "DESTRUCTOR",
42             [SAVEt_DESTRUCTOR_X] = "DESTRUCTOR_X",
43             [SAVEt_FREECOPHH] = "FREECOPHH",
44             [SAVEt_FREEOP] = "FREEOP",
45             [SAVEt_FREEPV] = "FREEPV",
46             [SAVEt_FREESV] = "FREESV",
47             [SAVEt_GENERIC_PVREF] = "GENERIC_PVREF",
48             [SAVEt_GENERIC_SVREF] = "GENERIC_SVREF",
49             [SAVEt_GP] = "GP",
50             [SAVEt_GVSV] = "GVSV",
51             [SAVEt_HELEM] = "HELEM",
52             [SAVEt_HINTS] = "HINTS",
53             [SAVEt_HPTR] = "HPTR",
54             [SAVEt_HV] = "HV",
55             [SAVEt_I16] = "I16",
56             [SAVEt_I32] = "I32",
57             [SAVEt_I32_SMALL] = "I32_SMALL",
58             [SAVEt_I8] = "I8",
59             [SAVEt_INT] = "INT",
60             [SAVEt_INT_SMALL] = "INT_SMALL",
61             [SAVEt_ITEM] = "ITEM",
62             [SAVEt_IV] = "IV",
63             [SAVEt_LONG] = "LONG",
64             [SAVEt_MORTALIZESV] = "MORTALIZESV",
65             [SAVEt_NSTAB] = "NSTAB",
66             [SAVEt_OP] = "OP",
67             [SAVEt_PADSV_AND_MORTALIZE] = "PADSV_AND_MORTALIZE",
68             [SAVEt_PARSER] = "PARSER",
69             [SAVEt_PPTR] = "PPTR",
70             [SAVEt_REGCONTEXT] = "REGCONTEXT",
71             [SAVEt_SAVESWITCHSTACK] = "SAVESWITCHSTACK",
72             [SAVEt_SET_SVFLAGS] = "SET_SVFLAGS",
73             [SAVEt_SHARED_PVREF] = "SHARED_PVREF",
74             [SAVEt_SPTR] = "SPTR",
75             [SAVEt_STACK_POS] = "STACK_POS",
76             [SAVEt_SVREF] = "SVREF",
77             [SAVEt_SV] = "SV",
78             [SAVEt_VPTR] = "VPTR",
79              
80             #if HAVE_PERL_VERSION(5,18,0)
81             [SAVEt_CLEARPADRANGE] = "CLEARPADRANGE",
82             [SAVEt_GVSLOT] = "GVSLOT",
83             #endif
84              
85             #if HAVE_PERL_VERSION(5,20,0)
86             [SAVEt_READONLY_OFF] = "READONLY_OFF",
87             [SAVEt_STRLEN] = "STRLEN",
88             #endif
89              
90             #if HAVE_PERL_VERSION(5,22,0)
91             [SAVEt_FREEPADNAME] = "FREEPADNAME",
92             #endif
93              
94             #if HAVE_PERL_VERSION(5,24,0)
95             [SAVEt_TMPSFLOOR] = "TMPSFLOOR",
96             #endif
97              
98             #if HAVE_PERL_VERSION(5,34,0)
99             [SAVEt_STRLEN_SMALL] = "STRLEN_SMALL",
100             [SAVEt_HINTS_HH] = "HINTS_HH",
101             #endif
102             };
103              
104             #define dKWARG(count) \
105             U32 kwargi = count; \
106             U32 kwarg; \
107             SV *kwval; \
108             /* TODO: complain about odd number of args */
109              
110             #define KWARG_NEXT(args) \
111             S_kwarg_next(aTHX_ args, &kwargi, items, ax, &kwarg, &kwval)
112             static bool S_kwarg_next(pTHX_ const char *args[], U32 *kwargi, U32 argc, U32 ax, U32 *kwarg, SV **kwval)
113             {
114             if(*kwargi >= argc)
115             return FALSE;
116              
117             SV *argname = ST(*kwargi); (*kwargi)++;
118             if(!SvOK(argname))
119             croak("Expected string for next argument name, got undef");
120              
121             *kwarg = 0;
122             while(args[*kwarg]) {
123             if(strEQ(SvPV_nolen(argname), args[*kwarg])) {
124             *kwval = ST(*kwargi); (*kwargi)++;
125             return TRUE;
126             }
127             (*kwarg)++;
128             }
129              
130             croak("Unrecognised argument name '%" SVf "'", SVfARG(argname));
131             }
132              
133             #define import_pragma(pragma, arg) S_import_pragma(aTHX_ pragma, arg)
134             static void S_import_pragma(pTHX_ const char *pragma, const char *arg)
135             {
136             dSP;
137             bool unimport = FALSE;
138              
139             if(pragma[0] == '-') {
140             unimport = TRUE;
141             pragma++;
142             }
143              
144             SAVETMPS;
145              
146             EXTEND(SP, 2);
147             PUSHMARK(SP);
148             mPUSHp(pragma, strlen(pragma));
149             if(arg)
150             mPUSHp(arg, strlen(arg));
151             PUTBACK;
152              
153             call_method(unimport ? "unimport" : "import", G_VOID);
154              
155             FREETMPS;
156             }
157              
158             #define ensure_module_version(module, version) S_ensure_module_version(aTHX_ module, version)
159             static void S_ensure_module_version(pTHX_ SV *module, SV *version)
160             {
161             dSP;
162              
163             ENTER;
164              
165             PUSHMARK(SP);
166             PUSHs(module);
167             PUSHs(version);
168             PUTBACK;
169              
170             call_method("VERSION", G_VOID);
171              
172             LEAVE;
173             }
174              
175             #if HAVE_PERL_VERSION(5, 16, 0)
176             # define fetch_superclass_method_pv(stash, pv, len, level) S_fetch_superclass_method_pv(aTHX_ stash, pv, len, level)
177             static CV *S_fetch_superclass_method_pv(pTHX_ HV *stash, const char *pv, STRLEN len, U32 level)
178             {
179             #if HAVE_PERL_VERSION(5, 18, 0)
180             GV *gv = gv_fetchmeth_pvn(stash, pv, len, level, GV_SUPER);
181             #else
182             SV *superclassname = newSVpvf("%*s::SUPER", HvNAMELEN_get(stash), HvNAME_get(stash));
183             if(HvNAMEUTF8(stash))
184             SvUTF8_on(superclassname);
185             SAVEFREESV(superclassname);
186              
187             HV *superstash = gv_stashsv(superclassname, GV_ADD);
188             GV *gv = gv_fetchmeth_pvn(superstash, pv, len, level, 0);
189             #endif
190              
191             if(!gv)
192             return NULL;
193             return GvCV(gv);
194             }
195             #endif
196              
197             #define get_class_isa(stash) S_get_class_isa(aTHX_ stash)
198             static AV *S_get_class_isa(pTHX_ HV *stash)
199             {
200             GV **gvp = (GV **)hv_fetchs(stash, "ISA", 0);
201             if(!gvp || !GvAV(*gvp))
202             croak("Expected %s to have a @ISA list", HvNAME(stash));
203              
204             return GvAV(*gvp);
205             }
206              
207             #define find_cop_for_lvintro(padix, o, copp) S_find_cop_for_lvintro(aTHX_ padix, o, copp)
208             static COP *S_find_cop_for_lvintro(pTHX_ PADOFFSET padix, OP *o, COP **copp)
209             {
210             for( ; o; o = OpSIBLING(o)) {
211             if(OP_CLASS(o) == OA_COP) {
212             *copp = (COP *)o;
213             }
214             else if(o->op_type == OP_PADSV && o->op_targ == padix && o->op_private & OPpLVAL_INTRO) {
215             return *copp;
216             }
217             else if(o->op_flags & OPf_KIDS) {
218             COP *ret = find_cop_for_lvintro(padix, cUNOPx(o)->op_first, copp);
219             if(ret)
220             return ret;
221             }
222             }
223              
224             return NULL;
225             }
226              
227             #define lex_consume_unichar(c) MY_lex_consume_unichar(aTHX_ c)
228             static bool MY_lex_consume_unichar(pTHX_ U32 c)
229             {
230 80 50         if(lex_peek_unichar(0) != c)
    0          
    50          
231             return FALSE;
232              
233 80           lex_read_unichar(0);
234             return TRUE;
235             }
236              
237             #if HAVE_PERL_VERSION(5, 16, 0)
238             # define sv_derived_from_hv(sv, hv) MY_sv_derived_from_hv(aTHX_ sv, hv)
239             static bool MY_sv_derived_from_hv(pTHX_ SV *sv, HV *hv)
240             {
241             char *hvname = HvNAME(hv);
242             if(!hvname)
243             return FALSE;
244              
245             return sv_derived_from_pvn(sv, hvname, HvNAMELEN(hv), HvNAMEUTF8(hv) ? SVf_UTF8 : 0);
246             }
247             #endif
248              
249             #define av_push_from_av_inc(dst, src) S_av_push_from_av(aTHX_ dst, src, TRUE)
250             #define av_push_from_av_noinc(dst, src) S_av_push_from_av(aTHX_ dst, src, FALSE)
251             static void S_av_push_from_av(pTHX_ AV *dst, AV *src, bool refcnt_inc)
252             {
253             SSize_t count = av_count(src);
254             SSize_t i;
255              
256             av_extend(dst, av_count(dst) + count - 1);
257              
258             SV **vals = AvARRAY(src);
259              
260             for(i = 0; i < count; i++) {
261             SV *sv = vals[i];
262             av_push(dst, refcnt_inc ? SvREFCNT_inc(sv) : sv);
263             }
264             }