1 /*******************************************************************************
3 * !!!!! Do NOT edit this file directly! -- Edit PPPort_xs.PL instead. !!!!!
5 ********************************************************************************
7 * Perl/Pollution/Portability
9 ********************************************************************************
13 * $Date: 2006/01/14 18:07:55 +0100 $
15 ********************************************************************************
17 * Version 3.x, Copyright (C) 2004-2006, Marcus Holland-Moritz.
18 * Version 2.x, Copyright (C) 2001, Paul Marquess.
19 * Version 1.x, Copyright (C) 1999, Kenneth Albanowski.
21 * This program is free software; you can redistribute it and/or
22 * modify it under the same terms as Perl itself.
24 *******************************************************************************/
26 /* ========== BEGIN XSHEAD ================================================== */
30 /* =========== END XSHEAD =================================================== */
36 /* ========== BEGIN XSINIT ================================================== */
38 /* ---- from parts/inc/call ---- */
41 /* ---- from parts/inc/grok ---- */
42 #define NEED_grok_number
43 #define NEED_grok_numeric_radix
48 /* ---- from parts/inc/newCONSTSUB ---- */
49 #define NEED_newCONSTSUB
51 /* ---- from parts/inc/newRV ---- */
52 #define NEED_newRV_noinc
54 /* ---- from parts/inc/snprintf ---- */
55 #define NEED_my_snprintf
57 /* ---- from parts/inc/sv_xpvf ---- */
58 #define NEED_vnewSVpvf
59 #define NEED_sv_catpvf_mg
60 #define NEED_sv_catpvf_mg_nocontext
61 #define NEED_sv_setpvf_mg
62 #define NEED_sv_setpvf_mg_nocontext
64 /* ---- from parts/inc/SvPV ---- */
65 #define NEED_sv_2pv_nolen
66 #define NEED_sv_2pvbyte
68 /* ---- from parts/inc/variables ---- */
69 #define NEED_PL_signals
71 /* ---- from parts/inc/warn ---- */
74 /* =========== END XSINIT =================================================== */
78 /* ========== BEGIN XSMISC ================================================== */
80 /* ---- from parts/inc/exception ---- */
81 /* defined in module3.c */
82 int exception(int throw_e);
84 /* ---- from parts/inc/misc ---- */
85 XS(XS_Devel__PPPort_dXSTARG); /* prototype */
86 XS(XS_Devel__PPPort_dXSTARG)
97 XS(XS_Devel__PPPort_dAXMARK); /* prototype */
98 XS(XS_Devel__PPPort_dAXMARK)
105 iv = SvIV(ST(0)) - 1;
106 PUSHs(sv_2mortal(newSViv(iv)));
110 /* ---- from parts/inc/MY_CXT ---- */
111 #define MY_CXT_KEY "Devel::PPPort::_guts" XS_VERSION
114 /* Put Global Data in here */
120 /* ---- from parts/inc/newCONSTSUB ---- */
121 void call_newCONSTSUB_1(void)
123 #ifdef PERL_NO_GET_CONTEXT
126 newCONSTSUB(gv_stashpv("Devel::PPPort", FALSE), "test_value_1", newSViv(1));
129 extern void call_newCONSTSUB_2(void);
130 extern void call_newCONSTSUB_3(void);
132 /* ---- from parts/inc/sv_xpvf ---- */
133 static SV * test_vnewSVpvf(pTHX_ const char *pat, ...)
138 #if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0)))
139 sv = vnewSVpvf(pat, &args);
141 sv = newSVpv(pat, 0);
147 static void test_sv_vcatpvf(pTHX_ SV *sv, const char *pat, ...)
151 #if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0)))
152 sv_vcatpvf(sv, pat, &args);
159 static void test_sv_vsetpvf(pTHX_ SV *sv, const char *pat, ...)
163 #if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0)))
164 sv_vsetpvf(sv, pat, &args);
171 /* ---- from parts/inc/variables ---- */
172 U32 get_PL_signals_1(void)
177 extern U32 get_PL_signals_2(void);
178 extern U32 get_PL_signals_3(void);
180 /* =========== END XSMISC =================================================== */
182 MODULE = Devel::PPPort PACKAGE = Devel::PPPort
185 /* ---- from parts/inc/misc ---- */
186 newXS("Devel::PPPort::dXSTARG", XS_Devel__PPPort_dXSTARG, file);
187 newXS("Devel::PPPort::dAXMARK", XS_Devel__PPPort_dAXMARK, file);
189 /* ---- from parts/inc/MY_CXT ---- */
192 /* If any of the fields in the my_cxt_t struct need
193 * to be initialised, do it here.
199 ##----------------------------------------------------------------------
200 ## XSUBs from parts/inc/call
201 ##----------------------------------------------------------------------
232 i = eval_sv(sv, flags);
235 PUSHs(sv_2mortal(newSViv(i)));
238 eval_pv(p, croak_on_error)
244 PUSHs(eval_pv(p, croak_on_error));
247 call_sv(sv, flags, ...)
253 for (i=0; i<items-2; i++)
254 ST(i) = ST(i+2); /* pop first two args */
258 i = call_sv(sv, flags);
261 PUSHs(sv_2mortal(newSViv(i)));
264 call_pv(subname, flags, ...)
270 for (i=0; i<items-2; i++)
271 ST(i) = ST(i+2); /* pop first two args */
275 i = call_pv(subname, flags);
278 PUSHs(sv_2mortal(newSViv(i)));
281 call_argv(subname, flags, ...)
288 if (items > 8) /* play safe */
290 for (i=2; i<items; i++)
291 args[i-2] = SvPV_nolen(ST(i));
292 args[items-2] = NULL;
294 i = call_argv(subname, flags, args);
297 PUSHs(sv_2mortal(newSViv(i)));
300 call_method(methname, flags, ...)
306 for (i=0; i<items-2; i++)
307 ST(i) = ST(i+2); /* pop first two args */
311 i = call_method(methname, flags);
314 PUSHs(sv_2mortal(newSViv(i)));
316 ##----------------------------------------------------------------------
317 ## XSUBs from parts/inc/cop
318 ##----------------------------------------------------------------------
323 RETVAL = CopSTASHPV(PL_curcop);
330 RETVAL = CopFILE(PL_curcop);
334 ##----------------------------------------------------------------------
335 ## XSUBs from parts/inc/exception
336 ##----------------------------------------------------------------------
344 ##----------------------------------------------------------------------
345 ## XSUBs from parts/inc/grok
346 ##----------------------------------------------------------------------
355 pv = SvPV(string, len);
356 if (!grok_number(pv, len, &RETVAL))
369 pv = SvPV(string, len);
370 RETVAL = grok_bin(pv, &len, &flags, NULL);
382 pv = SvPV(string, len);
383 RETVAL = grok_hex(pv, &len, &flags, NULL);
395 pv = SvPV(string, len);
396 RETVAL = grok_oct(pv, &len, &flags, NULL);
401 Perl_grok_number(string)
407 pv = SvPV(string, len);
408 if (!Perl_grok_number(aTHX_ pv, len, &RETVAL))
414 Perl_grok_bin(string)
421 pv = SvPV(string, len);
422 RETVAL = Perl_grok_bin(aTHX_ pv, &len, &flags, NULL);
427 Perl_grok_hex(string)
434 pv = SvPV(string, len);
435 RETVAL = Perl_grok_hex(aTHX_ pv, &len, &flags, NULL);
440 Perl_grok_oct(string)
447 pv = SvPV(string, len);
448 RETVAL = Perl_grok_oct(aTHX_ pv, &len, &flags, NULL);
452 ##----------------------------------------------------------------------
453 ## XSUBs from parts/inc/limits
454 ##----------------------------------------------------------------------
459 RETVAL = IVSIZE == sizeof(IV);
466 RETVAL = UVSIZE == sizeof(UV);
473 RETVAL = sizeof(IVTYPE) == sizeof(IV);
480 RETVAL = sizeof(UVTYPE) == sizeof(UV);
484 ##----------------------------------------------------------------------
485 ## XSUBs from parts/inc/magic
486 ##----------------------------------------------------------------------
489 sv_catpv_mg(sv, string)
493 sv_catpv_mg(sv, string);
496 sv_catpvn_mg(sv, sv2)
503 str = SvPV(sv2, len);
504 sv_catpvn_mg(sv, str, len);
511 sv_catsv_mg(sv, sv2);
535 sv_setpvn_mg(sv, sv2)
542 str = SvPV(sv2, len);
543 sv_setpvn_mg(sv, str, len);
550 sv_setsv_mg(sv, sv2);
560 sv_usepvn_mg(sv, sv2)
567 str = SvPV(sv2, len);
568 New(42, copy, len+1, char);
569 Copy(str, copy, len+1, char);
570 sv_usepvn_mg(sv, copy, len);
576 RETVAL = SvVSTRING_mg(sv) != NULL;
580 ##----------------------------------------------------------------------
581 ## XSUBs from parts/inc/memory
582 ##----------------------------------------------------------------------
592 CopyD("Hello", p, 6, char);
593 if (memEQ(p, "Hello", 6))
596 if (memEQ(p, "\0\0\0\0\0\0", 6))
599 if (memNE(p, "\0\0\0\0\0\0", 6))
604 if (memEQ(p, "\0\0\0\0\0\0", 6))
608 Newxc(p, 3, short, char);
614 ##----------------------------------------------------------------------
615 ## XSUBs from parts/inc/misc
616 ##----------------------------------------------------------------------
619 gv_stashpvn(name, create)
623 RETVAL = gv_stashpvn(name, strlen(name), create) != NULL;
632 RETVAL = get_sv(name, create) != NULL;
641 RETVAL = get_av(name, create) != NULL;
650 RETVAL = get_hv(name, create) != NULL;
659 RETVAL = get_cv(name, create) != NULL;
666 XPUSHs(newSVpvn("test", 4));
667 XPUSHs(newSVpvn("test", 2));
668 XPUSHs(newSVpvn("test", 0));
669 XPUSHs(newSVpvn(NULL, 2));
670 XPUSHs(newSVpvn(NULL, 0));
677 XPUSHs(newSVpvn("test1", 5));
679 XPUSHs(newSVpvn("test2", 5));
688 RETVAL = newSVsv(&PL_sv_undef);
695 RETVAL = newSVsv(&PL_sv_yes);
702 RETVAL = newSVsv(&PL_sv_no);
710 PL_na = strlen(string);
719 RETVAL = newSVsv(boolSV(value));
726 RETVAL = newSVsv(DEFSV);
733 RETVAL = SvTRUE(ERRSV);
742 RETVAL = newSVsv(UNDERBAR);
765 #if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0)))
766 x = newSVpvf("[%"SVf"]", x);
771 ##----------------------------------------------------------------------
772 ## XSUBs from parts/inc/mPUSH
773 ##----------------------------------------------------------------------
843 ##----------------------------------------------------------------------
844 ## XSUBs from parts/inc/MY_CXT
845 ##----------------------------------------------------------------------
851 RETVAL = MY_CXT.dummy == 42;
860 RETVAL = MY_CXT.dummy == 43;
872 ##----------------------------------------------------------------------
873 ## XSUBs from parts/inc/newCONSTSUB
874 ##----------------------------------------------------------------------
885 ##----------------------------------------------------------------------
886 ## XSUBs from parts/inc/newRV
887 ##----------------------------------------------------------------------
897 RETVAL = SvREFCNT(sv);
908 rv = newRV_noinc(sv);
909 RETVAL = SvREFCNT(sv);
914 ##----------------------------------------------------------------------
915 ## XSUBs from parts/inc/pvs
916 ##----------------------------------------------------------------------
921 XPUSHs(newSVpvs("newSVpvs"));
928 sv_catpvs(sv, "sv_catpvs");
934 sv_setpvs(sv, "sv_setpvs");
942 s = hv_fetchs((HV *) SvRV(hv), "hv_fetchs", 0);
943 XPUSHs(sv_mortalcopy(*s));
951 hv_stores((HV *) SvRV(hv), "hv_stores", SvREFCNT_inc(sv), 0);
953 ##----------------------------------------------------------------------
954 ## XSUBs from parts/inc/snprintf
955 ##----------------------------------------------------------------------
963 len = my_snprintf(buf, sizeof buf, "foo%s%d", "bar", 42);
964 XPUSHs(newSViv(len));
965 XPUSHs(newSVpv(buf, 0));
968 ##----------------------------------------------------------------------
969 ## XSUBs from parts/inc/Sv_set
970 ##----------------------------------------------------------------------
973 TestSvUV_set(sv, val)
978 RETVAL = SvUVX(sv) == val ? 42 : -1;
986 RETVAL = strEQ(SvPVX_const(sv), "mhx") ? 43 : -1;
991 TestSvPVX_mutable(sv)
994 RETVAL = strEQ(SvPVX_mutable(sv), "mhx") ? 44 : -1;
999 TestSvSTASH_set(sv, name)
1004 SvREFCNT_dec(SvSTASH(sv));
1005 SvSTASH_set(sv, (HV*) SvREFCNT_inc(gv_stashpv(name, 0)));
1007 ##----------------------------------------------------------------------
1008 ## XSUBs from parts/inc/sv_xpvf
1009 ##----------------------------------------------------------------------
1014 RETVAL = test_vnewSVpvf(aTHX_ "%s-%d", "Perl", 42);
1022 RETVAL = newSVsv(sv);
1023 test_sv_vcatpvf(aTHX_ RETVAL, "%s-%d", "Perl", 42);
1031 RETVAL = newSVsv(sv);
1032 test_sv_vsetpvf(aTHX_ RETVAL, "%s-%d", "Perl", 42);
1040 #if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0)))
1041 sv_catpvf_mg(sv, "%s-%d", "Perl", 42);
1045 Perl_sv_catpvf_mg(sv)
1048 #if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0)))
1049 Perl_sv_catpvf_mg(aTHX_ sv, "%s-%d", "-Perl", 43);
1053 sv_catpvf_mg_nocontext(sv)
1056 #if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0)))
1057 #ifdef PERL_IMPLICIT_CONTEXT
1058 sv_catpvf_mg_nocontext(sv, "%s-%d", "-Perl", 44);
1060 sv_catpvf_mg(sv, "%s-%d", "-Perl", 44);
1068 #if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0)))
1069 sv_setpvf_mg(sv, "%s-%d", "mhx", 42);
1073 Perl_sv_setpvf_mg(sv)
1076 #if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0)))
1077 Perl_sv_setpvf_mg(aTHX_ sv, "%s-%d", "foo", 43);
1081 sv_setpvf_mg_nocontext(sv)
1084 #if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0)))
1085 #ifdef PERL_IMPLICIT_CONTEXT
1086 sv_setpvf_mg_nocontext(sv, "%s-%d", "bar", 44);
1088 sv_setpvf_mg(sv, "%s-%d", "bar", 44);
1092 ##----------------------------------------------------------------------
1093 ## XSUBs from parts/inc/SvPV
1094 ##----------------------------------------------------------------------
1103 str = SvPVbyte(sv, len);
1104 RETVAL = strEQ(str, "mhx") ? (IV) len : (IV) -1;
1114 str = SvPV_nolen(sv);
1115 RETVAL = strEQ(str, "mhx") ? 42 : 0;
1119 ##----------------------------------------------------------------------
1120 ## XSUBs from parts/inc/threads
1121 ##----------------------------------------------------------------------
1127 RETVAL = 1 + sv_2iv(sv);
1135 Perl_croak(aTHX_ "%s", error);
1137 ##----------------------------------------------------------------------
1138 ## XSUBs from parts/inc/uv
1139 ##----------------------------------------------------------------------
1145 RETVAL = newSViv(1);
1146 sv_setuv(RETVAL, uv);
1154 RETVAL = newSVuv(uv);
1162 RETVAL = sv_2uv(sv);
1171 RETVAL = SvUVx(++sv);
1185 TARG = sv_newmortal();
1195 TARG = sv_newmortal();
1199 ##----------------------------------------------------------------------
1200 ## XSUBs from parts/inc/variables
1201 ##----------------------------------------------------------------------
1204 compare_PL_signals()
1207 U32 ref = get_PL_signals_1();
1208 RETVAL = ref == get_PL_signals_2() && ref == get_PL_signals_3();
1213 ##----------------------------------------------------------------------
1214 ## XSUBs from parts/inc/warn
1215 ##----------------------------------------------------------------------
1220 #if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0)))
1221 warner(packWARN(WARN_MISC), "warner %s:%d", "bar", 42);
1227 #if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0)))
1228 Perl_warner(aTHX_ packWARN(WARN_MISC), "Perl_warner %s:%d", "bar", 42);
1232 Perl_warner_nocontext()
1234 #if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0)))
1235 Perl_warner_nocontext(packWARN(WARN_MISC), "Perl_warner_nocontext %s:%d", "bar", 42);
1241 #if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0)))
1242 if (ckWARN(WARN_MISC))
1243 Perl_warner_nocontext(packWARN(WARN_MISC), "ckWARN %s:%d", "bar", 42);