X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/e9b8343fa465fe1f17441bfe1c1349ea013e9288..dc3c11c5b3d54ab8fc396c19fa05e08481207107:/universal.c

diff --git a/universal.c b/universal.c
index 95934ca..30b70ac 100644
--- 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;
 
@@ -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);
     }
@@ -568,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;
 	}
@@ -824,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;
@@ -857,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;
@@ -988,6 +986,34 @@ XS(XS_re_regexp_pattern)
     NOT_REACHED; /* NOTREACHED */
 }
 
+XS(XS_Regexp_smartmatch); /* prototype to pass -Wmissing-prototypes */
+XS(XS_Regexp_smartmatch)
+{
+    dXSARGS;
+    SV *regexp_sv, *matchee_sv;
+    REGEXP *rx;
+    regexp *prog;
+    const char *strstart, *strend;
+    STRLEN len;
+
+    if (items != 3)
+	croak_xs_usage(cv, "regexp, matchee, swap");
+    matchee_sv = SP[-1];
+    regexp_sv = SP[-2];
+    SP -= 2;
+    PUTBACK;
+    assert(SvROK(regexp_sv));
+    rx = (REGEXP*)SvRV(regexp_sv);
+    assert(SvTYPE((SV*)rx) == SVt_REGEXP);
+    prog = ReANY(rx);
+    strstart = SvPV_const(matchee_sv, len);
+    assert(strstart);
+    strend = strstart + len;
+    TOPs = boolSV((RXp_MINLEN(prog) < 0 || len >= (STRLEN)RXp_MINLEN(prog)) &&
+		CALLREGEXEC(rx, (char*)strstart, (char *)strend,
+		    (char*)strstart, 0, matchee_sv, NULL, 0));
+}
+
 #include "vutil.h"
 #include "vxs.inc"
 
@@ -1022,6 +1048,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, "$"},
+    {"Regexp::((", XS_Regexp_smartmatch, NULL},
+    {"Regexp::()", XS_Regexp_smartmatch, NULL},
+    {"Regexp::(~~", XS_Regexp_smartmatch, NULL},
 };
 
 STATIC OP*
@@ -1091,12 +1120,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
 
@@ -1110,6 +1139,9 @@ Perl_boot_core_UNIVERSAL(pTHX)
 	*cvfile = (char *)file;
 	Safefree(oldfile);
     }
+
+    /* overload fallback flag for Regexp */
+    sv_setiv(get_sv("Regexp::()", GV_ADD), 1);
 }
 
 /*