First class regexps.

[perl5.git] / sv.c

diff --git a/sv.c b/sv.c
index 577c134..3e7c3ff 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -916,8 +916,10 @@ static const struct body_details bodies_by_type[] = {
     { sizeof(XPVMG), copy_length(XPVMG, xmg_stash), 0, SVt_PVMG, FALSE, HADNV,
       HASARENA, FIT_ARENA(0, sizeof(XPVMG)) },
 
-    /* There are plans for this  */
-    { 0, 0, 0, SVt_ORANGE, FALSE, NONV, NOARENA, 0 },
+    /* 32 */
+    { sizeof(struct xregexp), copy_length(struct xregexp, xrx_regexp), 0,
+      SVt_REGEXP, FALSE, HADNV, HASARENA, FIT_ARENA(0, sizeof(struct xregexp))
+    },
 
     /* 48 */
     { sizeof(XPVGV), sizeof(XPVGV), 0, SVt_PVGV, TRUE, HADNV,
@@ -1095,6 +1097,9 @@ S_new_body(pTHX_ svtype sv_type)
 
 #endif
 
+static const struct body_details fake_rv =
+    { 0, 0, 0, SVt_IV, FALSE, NONV, NOARENA, 0 };
+
 /*
 =for apidoc sv_upgrade
 
@@ -1113,7 +1118,7 @@ Perl_sv_upgrade(pTHX_ register SV *sv, svtype new_type)
     void*      new_body;
     const svtype old_type = SvTYPE(sv);
     const struct body_details *new_type_details;
-    const struct body_details *const old_type_details
+    const struct body_details *old_type_details
        = bodies_by_type + old_type;
     SV *referant = NULL;
 
@@ -1170,11 +1175,9 @@ Perl_sv_upgrade(pTHX_ register SV *sv, svtype new_type)
     case SVt_IV:
        if (SvROK(sv)) {
            referant = SvRV(sv);
-           if (new_type < SVt_PVIV) {
-               new_type = SVt_PVIV;
-               /* FIXME to check SvROK(sv) ? SVt_PV : and fake up
-                  old_body_details */
-           }
+           old_type_details = &fake_rv;
+           if (new_type == SVt_NV)
+               new_type = SVt_PVNV;
        } else {
            if (new_type < SVt_PVIV) {
                new_type = (new_type == SVt_NV)
@@ -1308,6 +1311,7 @@ Perl_sv_upgrade(pTHX_ register SV *sv, svtype new_type)
     case SVt_PVGV:
     case SVt_PVCV:
     case SVt_PVLV:
+    case SVt_REGEXP:
     case SVt_PVMG:
     case SVt_PVNV:
     case SVt_PV:
@@ -2689,22 +2693,20 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags)
                STRLEN len;
                char *retval;
                char *buffer;
-               MAGIC *mg;
                const SV *const referent = (SV*)SvRV(sv);
 
                if (!referent) {
                    len = 7;
                    retval = buffer = savepvn("NULLREF", len);
-               } else if (SvTYPE(referent) == SVt_PVMG
-                          && ((SvFLAGS(referent) &
-                               (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
-                              == (SVs_OBJECT|SVs_SMG))
-                          && (mg = mg_find(referent, PERL_MAGIC_qr)))
-                {
+               } else if (SvTYPE(referent) == SVt_REGEXP) {
                     char *str = NULL;
                     I32 haseval = 0;
                     U32 flags = 0;
-                    (str) = CALLREG_AS_STR(mg,lp,&flags,&haseval);
+                   struct magic temp;
+                   temp.mg_obj
+                       = (SV*)((struct xregexp *)SvANY(referent))->xrx_regexp;
+                   assert(temp.mg_obj);
+                    (str) = CALLREG_AS_STR(&temp,lp,&flags,&haseval);
                     if (flags & 1)
                        SvUTF8_on(sv);
                     else
@@ -5203,6 +5205,9 @@ Perl_sv_clear(pTHX_ register SV *sv)
        Safefree(IoFMT_NAME(sv));
        Safefree(IoBOTTOM_NAME(sv));
        goto freescalar;
+    case SVt_REGEXP:
+       ReREFCNT_dec(((struct xregexp *)SvANY(sv))->xrx_regexp);
+       goto freescalar;
     case SVt_PVCV:
     case SVt_PVFM:
        cv_undef((CV*)sv);
@@ -7662,7 +7667,8 @@ Perl_sv_pvn_force_flags(pTHX_ SV *sv, STRLEN *lp, I32 flags)
            else
                Perl_croak(aTHX_ "Can't coerce readonly %s to string", ref);
        }
-       if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM)
+       if ((SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM)
+           || isGV_with_GP(sv))
            Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
                OP_NAME(PL_op));
        s = sv_2pv_flags(sv, &len, flags);
@@ -7767,6 +7773,7 @@ Perl_sv_reftype(pTHX_ const SV *sv, int ob)
        case SVt_PVFM:          return "FORMAT";
        case SVt_PVIO:          return "IO";
        case SVt_BIND:          return "BIND";
+       case SVt_REGEXP:        return "Regexp"; /* FIXME? to "REGEXP"  */
        default:                return "UNKNOWN";
        }
     }
@@ -10116,6 +10123,7 @@ Perl_sv_dup(pTHX_ const SV *sstr, CLONE_PARAMS* param)
            case SVt_PVAV:
            case SVt_PVCV:
            case SVt_PVLV:
+           case SVt_REGEXP:
            case SVt_PVMG:
            case SVt_PVNV:
            case SVt_PVIV:
@@ -10170,6 +10178,11 @@ Perl_sv_dup(pTHX_ const SV *sstr, CLONE_PARAMS* param)
                break;
            case SVt_PVMG:
                break;
+           case SVt_REGEXP:
+               ((struct xregexp *)SvANY(dstr))->xrx_regexp
+                   = CALLREGDUPE(((struct xregexp *)SvANY(dstr))->xrx_regexp,
+                                 param);
+               break;
            case SVt_PVLV:
                /* XXX LvTARGOFF sometimes holds PMOP* when DEBUGGING */
                if (LvTYPE(dstr) == 't') /* for tie: unrefcnted fake (SV**) */