File Coverage

XS.xs.cc
Criterion Covered Total %
statement 25 28 89.2
branch 5 12 41.6
condition n/a
subroutine n/a
pod n/a
total 30 40 75.0


line stmt bran cond sub pod time code
1             /*
2             * This file was generated automatically by ExtUtils::ParseXS version 3.34 from the
3             * contents of XS.xs. Do not edit this file, edit XS.xs instead.
4             *
5             * ANY CHANGES MADE HERE WILL BE LOST!
6             *
7             */
8              
9             #line 1 "XS.xs"
10             #include
11             #include
12              
13             #define _TRYNEXT(code) { \
14             try { code; } \
15             catch (const std::logic_error& err) { croak_sv(newSVpvn_flags(err.what(), strlen(err.what()), SVf_UTF8 | SVs_TEMP)); } \
16             }
17              
18             static inline HV* proto_stash (pTHX_ SV* proto) {
19             if (SvROK(proto)) {
20             SV* val = SvRV(proto);
21             if (SvOBJECT(val)) return SvSTASH(val);
22             }
23             return gv_stashsv(proto, GV_ADD);
24             }
25              
26             #if PERL_VERSION < 22
27             #define optimize(a, ...)
28             #else
29              
30             #define PP_METHOD_EXEC(sub) { \
31             dSP; \
32             XPUSHs((SV*)sub); \
33             PUTBACK; \
34             return PL_op->op_next; \
35             }
36              
37             #define PP_SUB_EXEC(sub) { \
38             TOPs = (SV*)sub; \
39             return PL_ppaddr[OP_ENTERSUB](aTHX); \
40             }
41              
42             #define PP_EMPTY_RETURN { \
43             if (GIMME_V == G_SCALAR) *(PL_stack_sp = PL_stack_base + TOPMARK + 1) = &PL_sv_undef; \
44             else PL_stack_sp = PL_stack_base + TOPMARK; \
45             }
46              
47             #define PP_METHOD_MAYBE_EXEC(sub) { \
48             if (sub) { PP_METHOD_EXEC(sub); } \
49             else { \
50             PP_EMPTY_RETURN; \
51             return PL_op->op_next->op_next; \
52             } \
53             }
54              
55             #define PP_SUB_MAYBE_EXEC(sub) { \
56             if (sub) { PP_SUB_EXEC(sub); } \
57             else { \
58             PP_EMPTY_RETURN; \
59             return PL_op->op_next; \
60             } \
61             }
62              
63             #ifdef USE_ITHREADS
64             # define cGVOPx_gv_set(o,gv) (PAD_SVl(cPADOPx(o)->op_padix) = (SV*)gv)
65             #else
66             # define cGVOPx_gv_set(o,gv) (cSVOPx(o)->op_sv = (SV*)gv)
67             #endif
68              
69             static void optimize (pTHX_ OP* op, OP* (*pp_method)(pTHX), OP* (*pp_sub)(pTHX), CV* check, GV* payload = NULL) {
70             if ((op->op_spare & 1) || op->op_type != OP_ENTERSUB || !(op->op_flags & OPf_STACKED) || op->op_ppaddr != PL_ppaddr[OP_ENTERSUB]) return;
71             op->op_spare |= 1;
72             OP* curop = cUNOPx(op)->op_first;
73             if (!curop) return; /* Such op can be created by call_sv(G_METHOD_NAMED) */
74             while (OpHAS_SIBLING(curop)) curop = OpSIBLING(curop);
75            
76             // optimize METHOD_REDIR $self->next::method
77             if (curop->op_next == op && curop->op_type == OP_METHOD_REDIR && curop->op_ppaddr == PL_ppaddr[OP_METHOD_REDIR]) {
78             curop->op_ppaddr = pp_method;
79             if (!payload) return;
80             // payload will be in cMETHOPx_rclass(PL_op)
81             SV* old = cMETHOPx_rclass(curop);
82             cMETHOPx_rclass(curop) = (SV*)payload;
83             SvREFCNT_inc(payload);
84             SvREFCNT_dec(old);
85             return;
86             }
87            
88             // OPTIMIZE ENTERSUB FOR CASE next::method($self) - compile-time identified subroutines
89             if (!OP_TYPE_IS_OR_WAS(curop, OP_LIST)) return;
90             curop = cUNOPx(curop)->op_first;
91             if (!curop) return;
92            
93             while (OpHAS_SIBLING(curop)) curop = OpSIBLING(curop);
94             if (!OP_TYPE_IS_OR_WAS(curop, OP_RV2CV)) return;
95            
96             curop = cUNOPx(curop)->op_first;
97             if (!curop || curop->op_type != OP_GV) return;
98             GV* gv = cGVOPx_gv(curop);
99             if (GvCV(gv) != check) return;
100            
101             op->op_ppaddr = pp_sub;
102            
103             if (!payload) return;
104             // payload will be in TOPs
105             cGVOPx_gv_set(curop, payload);
106             SvREFCNT_inc(payload);
107             SvREFCNT_dec(gv);
108             }
109              
110             // $self->next::can
111             static OP* ppm_nextcan (pTHX) {
112             PL_stack_sp = PL_stack_base + TOPMARK + 1;
113             CV* sub;
114             _TRYNEXT({ sub = xs::next::method(aTHX_ proto_stash(aTHX_ *PL_stack_sp)); });
115             *PL_stack_sp = sub ? sv_2mortal(newRV((SV*)sub)) : &PL_sv_undef;
116             return PL_op->op_next->op_next; // skip ENTERSUB
117             }
118              
119             // next::can($self)
120             static OP* pps_nextcan (pTHX) {
121             PL_stack_sp = PL_stack_base + TOPMARK + 1;
122             CV* sub;
123             _TRYNEXT({ sub = xs::next::method(aTHX_ proto_stash(aTHX_ *PL_stack_sp)); });
124             *PL_stack_sp = sub ? sv_2mortal(newRV((SV*)sub)) : &PL_sv_undef;
125             return PL_op->op_next;
126             }
127              
128             // $self->next::method
129             static OP* ppm_next (pTHX) {
130             CV* sub;
131             _TRYNEXT({ sub = xs::next::method_strict(aTHX_ proto_stash(aTHX_ PL_stack_base[TOPMARK+1])); });
132             PP_METHOD_EXEC(sub);
133             }
134              
135             // next::method($self)
136             static OP* pps_next (pTHX) {
137             dSP;
138             CV* sub;
139             _TRYNEXT({ sub = xs::next::method_strict(aTHX_ proto_stash(aTHX_ PL_stack_base[TOPMARK+1])); });
140             PP_SUB_EXEC(sub);
141             }
142              
143             // $self->maybe::next::method
144             static OP* ppm_next_maybe (pTHX) {
145             CV* sub;
146             _TRYNEXT({ sub = xs::next::method(aTHX_ proto_stash(aTHX_ PL_stack_base[TOPMARK+1])); });
147             PP_METHOD_MAYBE_EXEC(sub);
148             }
149              
150             // maybe::next::method($self)
151             static OP* pps_next_maybe (pTHX) {
152             dSP;
153             CV* sub;
154             _TRYNEXT({ sub = xs::next::method(aTHX_ proto_stash(aTHX_ PL_stack_base[TOPMARK+1])); });
155             PP_SUB_MAYBE_EXEC(sub);
156             }
157              
158             // $self->super::subname
159             static OP* ppm_super (pTHX) {
160             CV* sub;
161             _TRYNEXT({ sub = xs::super::method_strict(aTHX_ proto_stash(aTHX_ PL_stack_base[TOPMARK+1]), (GV*)cMETHOPx_rclass(PL_op)); });
162             PP_METHOD_EXEC(sub);
163             }
164              
165             // super::subname($self)
166             static OP* pps_super (pTHX) {
167             dSP;
168             CV* sub;
169             _TRYNEXT({ sub = xs::super::method_strict(aTHX_ proto_stash(aTHX_ PL_stack_base[TOPMARK+1]), (GV*)TOPs); });
170             PP_SUB_EXEC(sub);
171             }
172              
173             // $self->super::maybe::subname
174             static OP* ppm_super_maybe (pTHX) {
175             CV* sub;
176             _TRYNEXT({ sub = xs::super::method(aTHX_ proto_stash(aTHX_ PL_stack_base[TOPMARK+1]), (GV*)cMETHOPx_rclass(PL_op)); });
177             PP_METHOD_MAYBE_EXEC(sub);
178             }
179              
180             // super::maybe::subname($self)
181             static OP* pps_super_maybe (pTHX) {
182             dSP;
183             CV* sub;
184             _TRYNEXT({ sub = xs::super::method(aTHX_ proto_stash(aTHX_ PL_stack_base[TOPMARK+1]), (GV*)TOPs); });
185             PP_SUB_MAYBE_EXEC(sub);
186             }
187              
188             #endif
189              
190             static inline GV* get_current_opsub (pTHX_ const char* name, STRLEN len, bool is_utf8, U32 hash) {
191             const HE* const ent = (HE*)hv_common(CopSTASH(PL_curcop), NULL, name, len, is_utf8, 0, NULL, hash);
192             if (ent) return (GV*)HeVAL(ent);
193            
194             SV* fqn = sv_newmortal();
195             sv_catpvn(fqn, HvNAME(CopSTASH(PL_curcop)), HvNAMELEN(CopSTASH(PL_curcop)));
196             sv_catpvs(fqn, "::");
197             sv_catpvn(fqn, name, len);
198             return gv_fetchpvn_flags(SvPVX(fqn), SvCUR(fqn), GV_ADD|(is_utf8 ? SVf_UTF8 : 0), SVt_PVCV);
199             }
200              
201             static void super_xsub (pTHX_ CV* cv) {
202             dXSARGS; dXSI32;
203             if (items < 1) croak_xs_usage(cv, "proto, ...");
204             SP -= items;
205             SV* proto = ST(0);
206            
207             GV* gv = CvGV(cv);
208             HEK* hek = GvNAME_HEK(gv);
209             GV* context = get_current_opsub(aTHX_ HEK_KEY(hek), HEK_LEN(hek), HEK_UTF8(hek), HEK_HASH(hek));
210            
211             CV* sub;
212             if (ix == 0) { // super
213             optimize(aTHX_ PL_op, &ppm_super, &pps_super, cv, context);
214             _TRYNEXT({ sub = xs::super::method_strict(aTHX_ proto_stash(aTHX_ proto), context); });
215             } else { // super::maybe
216             optimize(aTHX_ PL_op, &ppm_super_maybe, &pps_super_maybe, cv, context);
217             _TRYNEXT({ sub = xs::super::method(aTHX_ proto_stash(aTHX_ proto), context); });
218             if (!sub) XSRETURN_EMPTY;
219             }
220            
221             ENTER;
222             PUSHMARK(SP);
223             call_sv((SV*)sub, GIMME_V);
224             LEAVE;
225             }
226              
227             // This sub is defined by hand instead of XSUB syntax because we MUST NOT do POPMARK, because super_xsub will
228             static void super_AUTOLOAD (pTHX_ CV* cv) {
229             dXSI32;
230             SV* fqn = get_sv(ix == 0 ? "super::AUTOLOAD" : "super::maybe::AUTOLOAD", 0);
231             CV* xsub = newXS(SvPVX(fqn), super_xsub, __FILE__);
232             CvXSUBANY(xsub).any_i32 = ix;
233             super_xsub(aTHX_ xsub);
234             return;
235             }
236              
237             #line 238 "XS.xs.cc"
238             #ifndef PERL_UNUSED_VAR
239             # define PERL_UNUSED_VAR(var) if (0) var = var
240             #endif
241              
242             #ifndef dVAR
243             # define dVAR dNOOP
244             #endif
245              
246              
247             /* This stuff is not part of the API! You have been warned. */
248             #ifndef PERL_VERSION_DECIMAL
249             # define PERL_VERSION_DECIMAL(r,v,s) (r*1000000 + v*1000 + s)
250             #endif
251             #ifndef PERL_DECIMAL_VERSION
252             # define PERL_DECIMAL_VERSION \
253             PERL_VERSION_DECIMAL(PERL_REVISION,PERL_VERSION,PERL_SUBVERSION)
254             #endif
255             #ifndef PERL_VERSION_GE
256             # define PERL_VERSION_GE(r,v,s) \
257             (PERL_DECIMAL_VERSION >= PERL_VERSION_DECIMAL(r,v,s))
258             #endif
259             #ifndef PERL_VERSION_LE
260             # define PERL_VERSION_LE(r,v,s) \
261             (PERL_DECIMAL_VERSION <= PERL_VERSION_DECIMAL(r,v,s))
262             #endif
263              
264             /* XS_INTERNAL is the explicit static-linkage variant of the default
265             * XS macro.
266             *
267             * XS_EXTERNAL is the same as XS_INTERNAL except it does not include
268             * "STATIC", ie. it exports XSUB symbols. You probably don't want that
269             * for anything but the BOOT XSUB.
270             *
271             * See XSUB.h in core!
272             */
273              
274              
275             /* TODO: This might be compatible further back than 5.10.0. */
276             #if PERL_VERSION_GE(5, 10, 0) && PERL_VERSION_LE(5, 15, 1)
277             # undef XS_EXTERNAL
278             # undef XS_INTERNAL
279             # if defined(__CYGWIN__) && defined(USE_DYNAMIC_LOADING)
280             # define XS_EXTERNAL(name) __declspec(dllexport) XSPROTO(name)
281             # define XS_INTERNAL(name) STATIC XSPROTO(name)
282             # endif
283             # if defined(__SYMBIAN32__)
284             # define XS_EXTERNAL(name) EXPORT_C XSPROTO(name)
285             # define XS_INTERNAL(name) EXPORT_C STATIC XSPROTO(name)
286             # endif
287             # ifndef XS_EXTERNAL
288             # if defined(HASATTRIBUTE_UNUSED) && !defined(__cplusplus)
289             # define XS_EXTERNAL(name) void name(pTHX_ CV* cv __attribute__unused__)
290             # define XS_INTERNAL(name) STATIC void name(pTHX_ CV* cv __attribute__unused__)
291             # else
292             # ifdef __cplusplus
293             # define XS_EXTERNAL(name) extern "C" XSPROTO(name)
294             # define XS_INTERNAL(name) static XSPROTO(name)
295             # else
296             # define XS_EXTERNAL(name) XSPROTO(name)
297             # define XS_INTERNAL(name) STATIC XSPROTO(name)
298             # endif
299             # endif
300             # endif
301             #endif
302              
303             /* perl >= 5.10.0 && perl <= 5.15.1 */
304              
305              
306             /* The XS_EXTERNAL macro is used for functions that must not be static
307             * like the boot XSUB of a module. If perl didn't have an XS_EXTERNAL
308             * macro defined, the best we can do is assume XS is the same.
309             * Dito for XS_INTERNAL.
310             */
311             #ifndef XS_EXTERNAL
312             # define XS_EXTERNAL(name) XS(name)
313             #endif
314             #ifndef XS_INTERNAL
315             # define XS_INTERNAL(name) XS(name)
316             #endif
317              
318             /* Now, finally, after all this mess, we want an ExtUtils::ParseXS
319             * internal macro that we're free to redefine for varying linkage due
320             * to the EXPORT_XSUB_SYMBOLS XS keyword. This is internal, use
321             * XS_EXTERNAL(name) or XS_INTERNAL(name) in your code if you need to!
322             */
323              
324             #undef XS_EUPXS
325             #if defined(PERL_EUPXS_ALWAYS_EXPORT)
326             # define XS_EUPXS(name) XS_EXTERNAL(name)
327             #else
328             /* default to internal */
329             # define XS_EUPXS(name) XS_INTERNAL(name)
330             #endif
331              
332             #ifndef PERL_ARGS_ASSERT_CROAK_XS_USAGE
333             #define PERL_ARGS_ASSERT_CROAK_XS_USAGE assert(cv); assert(params)
334              
335             /* prototype to pass -Wmissing-prototypes */
336             STATIC void
337             S_croak_xs_usage(const CV *const cv, const char *const params);
338              
339             STATIC void
340             S_croak_xs_usage(const CV *const cv, const char *const params)
341             {
342             const GV *const gv = CvGV(cv);
343              
344             PERL_ARGS_ASSERT_CROAK_XS_USAGE;
345              
346             if (gv) {
347             const char *const gvname = GvNAME(gv);
348             const HV *const stash = GvSTASH(gv);
349             const char *const hvname = stash ? HvNAME(stash) : NULL;
350              
351             if (hvname)
352             Perl_croak_nocontext("Usage: %s::%s(%s)", hvname, gvname, params);
353             else
354             Perl_croak_nocontext("Usage: %s(%s)", gvname, params);
355             } else {
356             /* Pants. I don't think that it should be possible to get here. */
357             Perl_croak_nocontext("Usage: CODE(0x%" UVxf ")(%s)", PTR2UV(cv), params);
358             }
359             }
360             #undef PERL_ARGS_ASSERT_CROAK_XS_USAGE
361              
362             #define croak_xs_usage S_croak_xs_usage
363              
364             #endif
365              
366             /* NOTE: the prototype of newXSproto() is different in versions of perls,
367             * so we define a portable version of newXSproto()
368             */
369             #ifdef newXS_flags
370             #define newXSproto_portable(name, c_impl, file, proto) newXS_flags(name, c_impl, file, proto, 0)
371             #else
372             #define newXSproto_portable(name, c_impl, file, proto) (PL_Sv=(SV*)newXS(name, c_impl, file), sv_setpv(PL_Sv, proto), (CV*)PL_Sv)
373             #endif /* !defined(newXS_flags) */
374              
375             #if PERL_VERSION_LE(5, 21, 5)
376             # define newXS_deffile(a,b) Perl_newXS(aTHX_ a,b,file)
377             #else
378             # define newXS_deffile(a,b) Perl_newXS_deffile(aTHX_ a,b)
379             #endif
380              
381             #line 382 "XS.xs.cc"
382              
383              
384 7           XS_EUPXS(XS_next_can)
385             {
386 7           dVAR; dXSARGS;
387 7 50         if (items != 1)
388 0           croak_xs_usage(cv, "proto");
389             {
390             SV * RETVAL;
391 7           SV* proto = ST(0)
392             ;
393             #line 232 "XS.xs"
394             optimize(aTHX_ PL_op, &ppm_nextcan, &pps_nextcan, cv);
395             CV* sub;
396             _TRYNEXT({ sub = xs::next::method(aTHX_ proto_stash(aTHX_ proto)); });
397             RETVAL = sub ? newRV((SV*)sub) : &PL_sv_undef;
398             #line 399 "XS.xs.cc"
399 7           RETVAL = sv_2mortal(RETVAL);
400 7           ST(0) = RETVAL;
401             }
402 7 0         XSRETURN(1);
403             }
404              
405              
406              
407 31           XS_EUPXS(XS_next_method)
408             {
409 31           dVAR; dXSARGS;
410 31 50         if (items < 1)
411 0           croak_xs_usage(cv, "proto, ...");
412             PERL_UNUSED_VAR(ax); /* -Wall */
413 31           SP -= items;
414             {
415 31           SV* proto = ST(0)
416             ;
417             #line 239 "XS.xs"
418             optimize(aTHX_ PL_op, &ppm_next, &pps_next, cv);
419              
420             CV* sub;
421             _TRYNEXT({ sub = xs::next::method_strict(aTHX_ proto_stash(aTHX_ proto)); });
422              
423             ENTER;
424             PUSHMARK(SP);
425             call_sv((SV*)sub, GIMME_V);
426             LEAVE;
427             return;
428             #line 429 "XS.xs.cc"
429             PUTBACK;
430             return;
431             }
432             }
433              
434              
435              
436 8           XS_EUPXS(XS_maybe__next_method)
437             {
438 8           dVAR; dXSARGS;
439 8 50         if (items < 1)
440 0           croak_xs_usage(cv, "proto, ...");
441             PERL_UNUSED_VAR(ax); /* -Wall */
442 8           SP -= items;
443             {
444 8           SV* proto = ST(0)
445             ;
446             #line 255 "XS.xs"
447             optimize(aTHX_ PL_op, &ppm_next_maybe, &pps_next_maybe, cv);
448              
449             CV* sub;
450             _TRYNEXT({ sub = xs::next::method(aTHX_ proto_stash(aTHX_ proto)); });
451             if (!sub) XSRETURN_EMPTY;
452              
453             ENTER;
454             PUSHMARK(SP);
455             call_sv((SV*)sub, GIMME_V);
456             LEAVE;
457             return;
458             #line 459 "XS.xs.cc"
459             PUTBACK;
460             return;
461             }
462             }
463              
464             #ifdef __cplusplus
465             extern "C"
466             #endif
467              
468 18           XS_EXTERNAL(boot_next__XS)
469             {
470             #if PERL_VERSION_LE(5, 21, 5)
471             dVAR; dXSARGS;
472             #else
473 18 50         dVAR; dXSBOOTARGSXSAPIVERCHK;
    50          
474             #endif
475             #if (PERL_REVISION == 5 && PERL_VERSION < 9)
476             char* file = __FILE__;
477             #else
478 18           const char* file = __FILE__;
479             #endif
480              
481             PERL_UNUSED_VAR(file);
482              
483             PERL_UNUSED_VAR(cv); /* -W */
484             PERL_UNUSED_VAR(items); /* -W */
485             #if PERL_VERSION_LE(5, 21, 5)
486             XS_VERSION_BOOTCHECK;
487             # ifdef XS_APIVERSION_BOOTCHECK
488             XS_APIVERSION_BOOTCHECK;
489             # endif
490             #endif
491              
492 18           newXS_deffile("next::can", XS_next_can);
493 18           newXS_deffile("next::method", XS_next_method);
494 18           newXS_deffile("maybe::next::method", XS_maybe__next_method);
495              
496             /* Initialisation Section */
497              
498             #line 268 "XS.xs"
499             {
500             cv = newXS("super::AUTOLOAD", super_AUTOLOAD, __FILE__);
501             XSANY.any_i32 = 0;
502             cv = newXS("super::maybe::AUTOLOAD", super_AUTOLOAD, __FILE__);
503             XSANY.any_i32 = 1;
504             }
505              
506             #line 507 "XS.xs.cc"
507              
508             /* End of Initialisation Section */
509              
510             #if PERL_VERSION_LE(5, 21, 5)
511             # if PERL_VERSION_GE(5, 9, 0)
512             if (PL_unitcheckav)
513             call_list(PL_scopestack_ix, PL_unitcheckav);
514             # endif
515             XSRETURN_YES;
516             #else
517 18           Perl_xs_boot_epilog(aTHX_ ax);
518             #endif
519 18           }
520