This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
https://perl5.git.perl.org / perl5.git / blobdiff
? search:
summary | shortlog | log | commit | commitdiff | tree
raw | inline | side by side
Perl5 git is on https
[perl5.git] / universal.c
diff --git a/universal.c b/universal.c
index a9d7514..66eafc5 100644 (file)
--- a/universal.c
+++ b/universal.c
@@ -184,10 +184,6 @@ The SV can be a Perl object or the name of a Perl class.
 
 #include "XSUB.h"
 
-/* a special string address whose value is "isa", but whicb perl knows
- * to treat as if it were really "DOES" */
-char PL_isa_DOES[] = "isa";
-
 bool
 Perl_sv_does_sv(pTHX_ SV *sv, SV *namesv, U32 flags)
 {
@@ -227,17 +223,17 @@ Perl_sv_does_sv(pTHX_ SV *sv, SV *namesv, U32 flags)
     PUTBACK;
 
     /* create a PV with value "isa", but with a special address
-     * so that perl knows were' realling doing "DOES" instead */
+     * so that perl knows we're really doing "DOES" instead */
     methodname = newSV_type(SVt_PV);
-    SvLEN(methodname) = 0;
-    SvCUR(methodname) = strlen(PL_isa_DOES);
-    SvPVX(methodname) = PL_isa_DOES;
+    SvLEN_set(methodname, 0);
+    SvCUR_set(methodname, strlen(PL_isa_DOES));
+    SvPVX(methodname) = (char *)PL_isa_DOES; /* discard 'const' qualifier */
     SvPOK_on(methodname);
     sv_2mortal(methodname);
     call_sv(methodname, G_SCALAR | G_METHOD);
     SPAGAIN;
 
-    does_it = SvTRUE( TOPs );
+    does_it = SvTRUE_NN( TOPs );
     FREETMPS;
     LEAVE;
 
@@ -301,7 +297,7 @@ A specialised variant of C<croak()> for emitting the usage message for xsubs
 works out the package name and subroutine name from C<cv>, and then calls
 C<croak()>.  Hence if C<cv> is C<&ouch::awk>, it would call C<croak> as:
 
- Perl_croak(aTHX_ "Usage: %"SVf"::%"SVf"(%s)", "ouch" "awk",
+ Perl_croak(aTHX_ "Usage: %" SVf "::%" SVf "(%s)", "ouch" "awk",
                                                      "eee_yow");
 
 =cut
@@ -320,13 +316,13 @@ Perl_croak_xs_usage(const CV *const cv, const char *const params)
 
        if (HvNAME_get(stash))
            /* diag_listed_as: SKIPME */
-           Perl_croak_nocontext("Usage: %"HEKf"::%"HEKf"(%s)",
+           Perl_croak_nocontext("Usage: %" HEKf "::%" HEKf "(%s)",
                                 HEKfARG(HvNAME_HEK(stash)),
                                 HEKfARG(GvNAME_HEK(gv)),
                                 params);
        else
            /* diag_listed_as: SKIPME */
-           Perl_croak_nocontext("Usage: %"HEKf"(%s)",
+           Perl_croak_nocontext("Usage: %" HEKf "(%s)",
                                 HEKfARG(GvNAME_HEK(gv)), params);
     } else {
         dTHX;
@@ -334,7 +330,7 @@ Perl_croak_xs_usage(const CV *const cv, const char *const params)
 
        /* Pants. I don't think that it should be possible to get here. */
        /* diag_listed_as: SKIPME */
-       Perl_croak(aTHX_ "Usage: CODE(0x%"UVxf")(%s)", PTR2UV(cv), params);
+       Perl_croak(aTHX_ "Usage: CODE(0x%" UVxf ")(%s)", PTR2UV(cv), params);
     }
 }
 
@@ -513,9 +509,10 @@ XS(XS_utf8_downgrade)
     if (items < 1 || items > 2)
        croak_xs_usage(cv, "sv, failok=0");
     else {
-       SV * const sv = ST(0);
-        const bool failok = (items < 2) ? 0 : SvTRUE(ST(1)) ? 1 : 0;
-        const bool RETVAL = sv_utf8_downgrade(sv, failok);
+       SV * const sv0 = ST(0);
+       SV * const sv1 = ST(1);
+        const bool failok = (items < 2) ? 0 : SvTRUE_NN(sv1) ? 1 : 0;
+        const bool RETVAL = sv_utf8_downgrade(sv0, failok);
 
        ST(0) = boolSV(RETVAL);
     }
@@ -554,7 +551,6 @@ XS(XS_Internals_SvREADONLY) /* This is dangerous stuff. */
     dXSARGS;
     SV * const svz = ST(0);
     SV * sv;
-    PERL_UNUSED_ARG(cv);
 
     /* [perl #77776] - called as &foo() not foo() */
     if (!SvROK(svz))
@@ -569,7 +565,8 @@ XS(XS_Internals_SvREADONLY) /* This is dangerous stuff. */
             XSRETURN_NO;
     }
     else if (items == 2) {
-       if (SvTRUE(ST(1))) {
+        SV *sv1 = ST(1);
+       if (SvTRUE_NN(sv1)) {
            SvFLAGS(sv) |= SVf_READONLY;
            XSRETURN_YES;
        }
@@ -588,7 +585,6 @@ XS(XS_constant__make_const) /* This is dangerous stuff. */
     dXSARGS;
     SV * const svz = ST(0);
     SV * sv;
-    PERL_UNUSED_ARG(cv);
 
     /* [perl #77776] - called as &foo() not foo() */
     if (!SvROK(svz) || items != 1)
@@ -616,7 +612,6 @@ XS(XS_Internals_SvREFCNT)   /* This is dangerous stuff. */
     SV * const svz = ST(0);
     SV * sv;
     U32 refcnt;
-    PERL_UNUSED_ARG(cv);
 
     /* [perl #77776] - called as &foo() not foo() */
     if ((items != 1 && items != 2) || !SvROK(svz))
@@ -744,7 +739,7 @@ XS(XS_PerlIO_get_layers)
                  }
                  else {
                       if (namok && argok)
-                           PUSHs(sv_2mortal(Perl_newSVpvf(aTHX_ "%"SVf"(%"SVf")",
+                           PUSHs(sv_2mortal(Perl_newSVpvf(aTHX_ "%" SVf "(%" SVf ")",
                                                 SVfARG(*namsvp),
                                                 SVfARG(*argsvp))));
                       else if (namok)
@@ -777,7 +772,6 @@ XS(XS_re_is_regexp); /* prototype to pass -Wmissing-prototypes */
 XS(XS_re_is_regexp)
 {
     dXSARGS;
-    PERL_UNUSED_VAR(cv);
 
     if (items != 1)
        croak_xs_usage(cv, "sv");
@@ -828,7 +822,7 @@ XS(XS_re_regname)
     if (!rx)
         XSRETURN_UNDEF;
 
-    if (items == 2 && SvTRUE(ST(1))) {
+    if (items == 2 && SvTRUE_NN(ST(1))) {
         flags = RXapif_ALL;
     } else {
         flags = RXapif_ONE;
@@ -861,7 +855,7 @@ XS(XS_re_regnames)
     if (!rx)
         XSRETURN_UNDEF;
 
-    if (items == 1 && SvTRUE(ST(0))) {
+    if (items == 1 && SvTRUE_NN(ST(0))) {
         flags = RXapif_ALL;
     } else {
         flags = RXapif_ONE;
@@ -992,6 +986,25 @@ XS(XS_re_regexp_pattern)
     NOT_REACHED; /* NOTREACHED */
 }
 
+#ifdef HAS_GETCWD
+
+XS(XS_Internals_getcwd)
+{
+    dXSARGS;
+    SV *sv = sv_newmortal();
+
+    if (items != 0)
+        croak_xs_usage(cv, "");
+
+    (void)getcwd_sv(sv);
+
+    SvTAINTED_on(sv);
+    PUSHs(sv);
+    XSRETURN(1);
+}
+
+#endif
+
 #include "vutil.h"
 #include "vxs.inc"
 
@@ -1001,7 +1014,7 @@ struct xsub_details {
     const char *proto;
 };
 
-static const struct xsub_details details[] = {
+static const struct xsub_details these_details[] = {
     {"UNIVERSAL::isa", XS_UNIVERSAL_isa, NULL},
     {"UNIVERSAL::can", XS_UNIVERSAL_can, NULL},
     {"UNIVERSAL::DOES", XS_UNIVERSAL_DOES, NULL},
@@ -1026,6 +1039,9 @@ static const struct xsub_details details[] = {
     {"re::regnames", XS_re_regnames, ";$"},
     {"re::regnames_count", XS_re_regnames_count, ""},
     {"re::regexp_pattern", XS_re_regexp_pattern, "$"},
+#ifdef HAS_GETCWD
+    {"Internals::getcwd", XS_Internals_getcwd, ""},
+#endif
 };
 
 STATIC OP*
@@ -1081,8 +1097,8 @@ void
 Perl_boot_core_UNIVERSAL(pTHX)
 {
     static const char file[] = __FILE__;
-    const struct xsub_details *xsub = details;
-    const struct xsub_details *end = C_ARRAY_END(details);
+    const struct xsub_details *xsub = these_details;
+    const struct xsub_details *end = C_ARRAY_END(these_details);
 
     do {
        newXS_flags(xsub->name, xsub->xsub, file, xsub->proto, 0);
@@ -1095,12 +1111,12 @@ Perl_boot_core_UNIVERSAL(pTHX)
         CV* to_native_cv = get_cv("utf8::unicode_to_native", 0);
         CV* to_unicode_cv = get_cv("utf8::native_to_unicode", 0);
 
-        cv_set_call_checker(to_native_cv,
+        cv_set_call_checker_flags(to_native_cv,
                             optimize_out_native_convert_function,
-                            (SV*) to_native_cv);
-        cv_set_call_checker(to_unicode_cv,
+                            (SV*) to_native_cv, 0);
+        cv_set_call_checker_flags(to_unicode_cv,
                             optimize_out_native_convert_function,
-                            (SV*) to_unicode_cv);
+                            (SV*) to_unicode_cv, 0);
     }
 #endif
 
Unnamed repository; edit this file 'description' to name the repository.