Perl_re_dup()

Message-ID: <20010712235432.J24707@lustre.dyn.wiw.org>

p4raw-id: //depot/perl@11321

5 files changed, 109 insertions, 23 deletions

diff --git a/embed.h b/embed.h
index 0a12dcda6b..f6176db259 100644
--- a/embed.h
+++ b/embed.h
@@ -2352,7 +2352,7 @@
 #define ss_dup(a,b)		Perl_ss_dup(aTHX_ a,b)
 #define any_dup(a,b)		Perl_any_dup(aTHX_ a,b)
 #define he_dup(a,b,c)		Perl_he_dup(aTHX_ a,b,c)
-#define re_dup(a)		Perl_re_dup(aTHX_ a)
+#define re_dup(a,b)		Perl_re_dup(aTHX_ a,b)
 #define fp_dup(a,b)		Perl_fp_dup(aTHX_ a,b)
 #define dirp_dup(a)		Perl_dirp_dup(aTHX_ a)
 #define gp_dup(a,b)		Perl_gp_dup(aTHX_ a,b)
diff --git a/embed.pl b/embed.pl
index ee21f3efb6..f125ef0a49 100755
--- a/embed.pl
+++ b/embed.pl
@@ -2228,7 +2228,7 @@ Ap	|PERL_SI*|si_dup	|PERL_SI* si|clone_params* param
 Ap	|ANY*	|ss_dup		|PerlInterpreter* proto_perl|clone_params* param
 Ap	|void*	|any_dup	|void* v|PerlInterpreter* proto_perl
 Ap	|HE*	|he_dup		|HE* e|bool shared|clone_params* param
-Ap	|REGEXP*|re_dup		|REGEXP* r
+Ap	|REGEXP*|re_dup		|REGEXP* r|clone_params* param
 Ap	|PerlIO*|fp_dup		|PerlIO* fp|char type
 Ap	|DIR*	|dirp_dup	|DIR* dp
 Ap	|GP*	|gp_dup		|GP* gp|clone_params* param
diff --git a/perlapi.c b/perlapi.c
index df16150c70..fb5c40725d 100644
--- a/perlapi.c
+++ b/perlapi.c
@@ -4082,9 +4082,9 @@ Perl_he_dup(pTHXo_ HE* e, bool shared, clone_params* param)
 
 #undef  Perl_re_dup
 REGEXP*
-Perl_re_dup(pTHXo_ REGEXP* r)
+Perl_re_dup(pTHXo_ REGEXP* r, clone_params* param)
 {
-    return ((CPerlObj*)pPerl)->Perl_re_dup(r);
+    return ((CPerlObj*)pPerl)->Perl_re_dup(r, param);
 }
 
 #undef  Perl_fp_dup
diff --git a/proto.h b/proto.h
index 5110345ccf..d03b3daa86 100644
--- a/proto.h
+++ b/proto.h
@@ -961,7 +961,7 @@ PERL_CALLCONV PERL_SI*	Perl_si_dup(pTHX_ PERL_SI* si, clone_params* param);
 PERL_CALLCONV ANY*	Perl_ss_dup(pTHX_ PerlInterpreter* proto_perl, clone_params* param);
 PERL_CALLCONV void*	Perl_any_dup(pTHX_ void* v, PerlInterpreter* proto_perl);
 PERL_CALLCONV HE*	Perl_he_dup(pTHX_ HE* e, bool shared, clone_params* param);
-PERL_CALLCONV REGEXP*	Perl_re_dup(pTHX_ REGEXP* r);
+PERL_CALLCONV REGEXP*	Perl_re_dup(pTHX_ REGEXP* r, clone_params* param);
 PERL_CALLCONV PerlIO*	Perl_fp_dup(pTHX_ PerlIO* fp, char type);
 PERL_CALLCONV DIR*	Perl_dirp_dup(pTHX_ DIR* dp);
 PERL_CALLCONV GP*	Perl_gp_dup(pTHX_ GP* gp, clone_params* param);
@@ -1313,6 +1313,7 @@ STATIC char*	S_stdize_locale(pTHX_ char* locs);
 #endif
 
 #if defined(PERL_IN_UTIL_C) || defined(PERL_DECL_PROT)
+STATIC COP*	S_closest_cop(pTHX_ COP *cop, OP *o);
 STATIC SV*	S_mess_alloc(pTHX);
 #  if defined(LEAKTEST)
 STATIC void	S_xstat(pTHX_ int);
diff --git a/sv.c b/sv.c
index 496c02cefe..9dabaff097 100644
--- a/sv.c
+++ b/sv.c
@@ -19,6 +19,7 @@
 #include "EXTERN.h"
 #define PERL_IN_SV_C
 #include "perl.h"
+#include "regcomp.h"
 
 #define FCALL *f
 #define SV_CHECK_THINKFIRST(sv) if (SvTHINKFIRST(sv)) sv_force_normal(sv)
@@ -8339,14 +8340,99 @@ ptr_table_* functions.
 #define SAVEPVN(p,n)	(p ? savepvn(p,n) : Nullch)
  
 
-
-/* duplicate a regexp */
+/* Duplicate a regexp. Required reading: pregcomp() and pregfree() in
+   regcomp.c. AMS 20010712 */
 
 REGEXP *
-Perl_re_dup(pTHX_ REGEXP *r)
+Perl_re_dup(pTHX_ REGEXP *r, clone_params *param)
 {
-    /* XXX fix when pmop->op_pmregexp becomes shared */
-    return ReREFCNT_inc(r);
+    REGEXP *ret;
+    int i, len, npar;
+    struct reg_substr_datum *s;
+
+    if (!r)
+	return (REGEXP *)NULL;
+
+    if ((ret = (REGEXP *)ptr_table_fetch(PL_ptr_table, r)))
+	return ret;
+
+    len = r->offsets[0];
+    npar = r->nparens+1;
+
+    Newc(0, ret, sizeof(regexp) + (len+1)*sizeof(regnode), char, regexp);
+    Copy(r->program, ret->program, len+1, regnode);
+
+    New(0, ret->startp, npar, I32);
+    Copy(r->startp, ret->startp, npar, I32);
+    New(0, ret->endp, npar, I32);
+    Copy(r->startp, ret->startp, npar, I32);
+
+    if (r->regstclass) {
+	New(0, ret->regstclass, 1, regnode);
+	ret->regstclass->flags = r->regstclass->flags;
+    }
+    else
+	ret->regstclass = NULL;
+
+    New(0, ret->substrs, 1, struct reg_substr_data);
+    for (s = ret->substrs->data, i = 0; i < 3; i++, s++) {
+	s->min_offset = r->substrs->data[i].min_offset;
+	s->max_offset = r->substrs->data[i].max_offset;
+	s->substr     = sv_dup_inc(r->substrs->data[i].substr, param);
+    }
+
+    if (r->data) {
+	struct reg_data *d;
+	int count = r->data->count;
+
+	Newc(0, d, sizeof(struct reg_data) + count*sizeof(void *),
+		char, struct reg_data);
+	New(0, d->what, count, U8);
+
+	d->count = count;
+	for (i = 0; i < count; i++) {
+	    d->what[i] = r->data->what[i];
+	    switch (d->what[i]) {
+	    case 's':
+		d->data[i] = sv_dup_inc((SV *)r->data->data[i], param);
+		break;
+	    case 'p':
+		d->data[i] = av_dup_inc((AV *)r->data->data[i], param);
+		break;
+	    case 'f':
+		/* This is cheating. */
+		New(0, d->data[i], 1, struct regnode_charclass_class);
+		StructCopy(r->data->data[i], d->data[i],
+			    struct regnode_charclass_class);
+		break;
+	    case 'o':
+	    case 'n':
+		d->data[i] = r->data->data[i];
+		break;
+	    }
+	}
+
+	ret->data = d;
+    }
+    else
+	ret->data = NULL;
+
+    New(0, ret->offsets, 2*len+1, U32);
+    Copy(r->offsets, ret->offsets, 2*len+1, U32);
+
+    ret->precomp        = SAVEPV(r->precomp);
+    ret->subbeg         = SAVEPV(r->subbeg);
+    ret->sublen         = r->sublen;
+    ret->refcnt         = r->refcnt;
+    ret->minlen         = r->minlen;
+    ret->prelen         = r->prelen;
+    ret->nparens        = r->nparens;
+    ret->lastparen      = r->lastparen;
+    ret->lastcloseparen = r->lastcloseparen;
+    ret->reganch        = r->reganch;
+
+    ptr_table_store(PL_ptr_table, r, ret);
+    return ret;
 }
 
 /* duplicate a file handle */
@@ -8439,7 +8525,7 @@ Perl_mg_dup(pTHX_ MAGIC *mg, clone_params* param)
 	nmg->mg_type	= mg->mg_type;
 	nmg->mg_flags	= mg->mg_flags;
 	if (mg->mg_type == PERL_MAGIC_qr) {
-	    nmg->mg_obj	= (SV*)re_dup((REGEXP*)mg->mg_obj);
+	    nmg->mg_obj	= (SV*)re_dup((REGEXP*)mg->mg_obj, param);
 	}
 	else if(mg->mg_type == PERL_MAGIC_backref) {
 	     AV *av = (AV*) mg->mg_obj;
@@ -9698,18 +9784,17 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
     PL_statusvalue_vms	= proto_perl->Istatusvalue_vms;
 #endif
 
-        /* Clone the regex array */
-        PL_regex_padav = newAV();
-        {
-                I32 len = av_len((AV*)proto_perl->Iregex_padav);
-                SV** regexen = AvARRAY((AV*)proto_perl->Iregex_padav);
-                for(i = 0; i <= len; i++) {                             
-                        av_push(PL_regex_padav,
-                            newSViv((IV)re_dup((REGEXP*) SvIV(regexen[i])) ));
-                }
-        }
-        PL_regex_pad = AvARRAY(PL_regex_padav);
-        
+    /* Clone the regex array */
+    PL_regex_padav = newAV();
+    {
+	I32 len = av_len((AV*)proto_perl->Iregex_padav);
+	SV** regexen = AvARRAY((AV*)proto_perl->Iregex_padav);
+	for(i = 0; i <= len; i++) {                             
+	    av_push(PL_regex_padav,
+		    newSViv((IV)re_dup((REGEXP *)SvIV(regexen[i]), param)));
+	}
+    }
+    PL_regex_pad = AvARRAY(PL_regex_padav);
 
     /* shortcuts to various I/O objects */
     PL_stdingv		= gv_dup(proto_perl->Istdingv, param);