From: Ilya Zakharevich <ilya@math.berkeley.edu>
Date: Thu, 26 Nov 1998 02:46:20 +0000 (-0500)
Subject: applied suggested patch with PERL_OBJECT tweaks
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=9661b5442a5f8dacc64d54eb1de98575f21de5f2;p=p5sagit%2Fp5-mst-13.2.git

applied suggested patch with PERL_OBJECT tweaks
	Message-Id: <199811260746.CAA23164@monk.mps.ohio-state.edu>
	Subject: [PATCH 5.005_53] Enable $_ and pos() inside (?{ CODE }) in RExen

p4raw-id: //depot/perl@2367
---

diff --git a/embed.h b/embed.h
index d6aca6d..c2c1119 100644
--- a/embed.h
+++ b/embed.h
@@ -1926,6 +1926,7 @@
 #define restore_expect		CPerlObj::Perl_restore_expect
 #define restore_lex_expect	CPerlObj::Perl_restore_lex_expect
 #define restore_magic		CPerlObj::Perl_restore_magic
+#define restore_pos		CPerlObj::Perl_restore_pos
 #define restore_rsfp		CPerlObj::Perl_restore_rsfp
 #define rninstr			CPerlObj::Perl_rninstr
 #define rsignal			CPerlObj::Perl_rsignal
diff --git a/embed.pl b/embed.pl
index f309c3b..4017a05 100755
--- a/embed.pl
+++ b/embed.pl
@@ -360,6 +360,7 @@ my @staticfuncs = qw(
     regcppop
     regcp_set_to
     cache_re
+    restore_pos
     reghop
     reghopmaybe
     dump
diff --git a/embedvar.h b/embedvar.h
index 733347d..b1aad3a 100644
--- a/embedvar.h
+++ b/embedvar.h
@@ -56,6 +56,8 @@
 #define PL_reg_eval_set		(PL_curinterp->Treg_eval_set)
 #define PL_reg_flags		(PL_curinterp->Treg_flags)
 #define PL_reg_ganch		(PL_curinterp->Treg_ganch)
+#define PL_reg_magic		(PL_curinterp->Treg_magic)
+#define PL_reg_oldpos		(PL_curinterp->Treg_oldpos)
 #define PL_reg_re		(PL_curinterp->Treg_re)
 #define PL_reg_start_tmp	(PL_curinterp->Treg_start_tmp)
 #define PL_reg_start_tmpl	(PL_curinterp->Treg_start_tmpl)
@@ -442,6 +444,8 @@
 #define PL_Treg_eval_set	PL_reg_eval_set
 #define PL_Treg_flags		PL_reg_flags
 #define PL_Treg_ganch		PL_reg_ganch
+#define PL_Treg_magic		PL_reg_magic
+#define PL_Treg_oldpos		PL_reg_oldpos
 #define PL_Treg_re		PL_reg_re
 #define PL_Treg_start_tmp	PL_reg_start_tmp
 #define PL_Treg_start_tmpl	PL_reg_start_tmpl
@@ -571,6 +575,8 @@
 #define PL_reg_eval_set		(thr->Treg_eval_set)
 #define PL_reg_flags		(thr->Treg_flags)
 #define PL_reg_ganch		(thr->Treg_ganch)
+#define PL_reg_magic		(thr->Treg_magic)
+#define PL_reg_oldpos		(thr->Treg_oldpos)
 #define PL_reg_re		(thr->Treg_re)
 #define PL_reg_start_tmp	(thr->Treg_start_tmp)
 #define PL_reg_start_tmpl	(thr->Treg_start_tmpl)
diff --git a/objXSUB.h b/objXSUB.h
index d4d101d..ae1dab5 100644
--- a/objXSUB.h
+++ b/objXSUB.h
@@ -500,6 +500,10 @@
 #define PL_reg_flags		pPerl->PL_reg_flags
 #undef  PL_reg_ganch
 #define PL_reg_ganch		pPerl->PL_reg_ganch
+#undef  PL_reg_magic
+#define PL_reg_magic		pPerl->PL_reg_magic
+#undef  PL_reg_oldpos
+#define PL_reg_oldpos		pPerl->PL_reg_oldpos
 #undef  PL_reg_re
 #define PL_reg_re		pPerl->PL_reg_re
 #undef  PL_reg_start_tmp
@@ -2643,6 +2647,8 @@
 #define restore_lex_expect	pPerl->Perl_restore_lex_expect
 #undef  restore_magic
 #define restore_magic		pPerl->Perl_restore_magic
+#undef  restore_pos
+#define restore_pos		pPerl->Perl_restore_pos
 #undef  restore_rsfp
 #define restore_rsfp		pPerl->Perl_restore_rsfp
 #undef  rninstr
diff --git a/pp_ctl.c b/pp_ctl.c
index f2cee37..a4fabd2 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -164,7 +164,7 @@ PP(pp_substcont)
 
 	/* Are we done */
 	if (cx->sb_once || !CALLREGEXEC(rx, s, cx->sb_strend, orig,
-				     s == m, Nullsv, cx->sb_targ,
+				     s == m, cx->sb_targ, NULL,
 				     ((cx->sb_rflags & REXEC_COPY_STR)
 				      ? 0 : REXEC_COPY_STR)))
 	{
diff --git a/proto.h b/proto.h
index b0c7f9b..818c8c7 100644
--- a/proto.h
+++ b/proto.h
@@ -873,6 +873,7 @@ CHECKPOINT regcppush _((I32 parenfloor));
 char * regcppop _((void));
 char * regcp_set_to _((I32 ss));
 void cache_re _((regexp *prog));
+void restore_pos _((void *arg));
 U8 * reghop _((U8 *pos, I32 off));
 U8 * reghopmaybe _((U8 *pos, I32 off));
 void dump _((char *pat,...));
diff --git a/regexec.c b/regexec.c
index 46833c2..b590f0e 100644
--- a/regexec.c
+++ b/regexec.c
@@ -108,6 +108,7 @@ static CHECKPOINT regcppush _((I32 parenfloor));
 static char * regcppop _((void));
 static char * regcp_set_to _((I32 ss));
 static void cache_re _((regexp *prog));
+static void restore_pos _((void *arg));
 #endif
 
 #define REGINCLASS(p,c)  (*(p) ? reginclass(p,c) : ANYOF_TEST(p,c))
@@ -260,6 +261,16 @@ cache_re(regexp *prog)
     PL_reg_re = prog;    
 }
 
+STATIC void
+restore_pos(void *arg)
+{	
+    if (PL_reg_eval_set) {    
+	PL_reg_magic->mg_len = PL_reg_oldpos;
+	PL_reg_eval_set = 0;
+    }	
+}
+
+
 /*
  - regexec_flags - match a regexp against a string
  */
@@ -327,6 +338,7 @@ regexec_flags(register regexp *prog, char *stringarg, register char *strend,
     /* Mark beginning of line for ^ and lookbehind. */
     PL_regbol = startpos;
     PL_bostr  = strbeg;
+    PL_reg_sv = sv;
 
     /* Mark end of line for $ (and such) */
     PL_regeol = strend;
@@ -1002,9 +1014,13 @@ got_it:
 					   restored, the value remains
 					   the same. */
     }
+    if (PL_reg_eval_set)
+	restore_pos(0);
     return 1;
 
 phooey:
+    if (PL_reg_eval_set)
+	restore_pos(0);
     return 0;
 }
 
@@ -1021,6 +1037,8 @@ regtry(regexp *prog, char *startpos)
     CHECKPOINT lastcp;
 
     if ((prog->reganch & ROPT_EVAL_SEEN) && !PL_reg_eval_set) {
+	MAGIC *mg;
+
 	PL_reg_eval_set = RS_init;
 	DEBUG_r(DEBUG_s(
 	    PerlIO_printf(Perl_debug_log, "  setting stack tmpbase at %i\n",
@@ -1033,6 +1051,25 @@ regtry(regexp *prog, char *startpos)
 	/* Apparently this is not needed, judging by wantarray. */
 	/* SAVEINT(cxstack[cxstack_ix].blk_gimme);
 	   cxstack[cxstack_ix].blk_gimme = G_SCALAR; */
+
+	if (PL_reg_sv) {
+	    /* Make $_ available to executed code. */
+	    if (PL_reg_sv != GvSV(PL_defgv)) {
+		SAVESPTR(GvSV(PL_defgv));
+		GvSV(PL_defgv) = PL_reg_sv;
+	    }
+	
+	    if (!(SvTYPE(PL_reg_sv) >= SVt_PVMG && SvMAGIC(PL_reg_sv) 
+		  && (mg = mg_find(PL_reg_sv, 'g')))) {
+		/* prepare for quick setting of pos */
+		sv_magic(PL_reg_sv, (SV*)0, 'g', Nullch, 0);
+		mg = mg_find(PL_reg_sv, 'g');
+		mg->mg_len = -1;
+	    }
+	    PL_reg_magic    = mg;
+	    PL_reg_oldpos   = mg->mg_len;
+	    SAVEDESTRUCTOR(restore_pos, 0);
+        }
     }
     PL_reginput = startpos;
     PL_regstartp = prog->startp;
@@ -1604,6 +1641,7 @@ regmatch(regnode *prog)
 	    PL_op = (OP_4tree*)PL_regdata->data[n];
 	    DEBUG_r( PerlIO_printf(Perl_debug_log, "  re_eval 0x%x\n", PL_op) );
 	    PL_curpad = AvARRAY((AV*)PL_regdata->data[n + 1]);
+	    PL_reg_magic->mg_len = locinput - PL_bostr;
 
 	    CALLRUNOPS();			/* Scalar context. */
 	    SPAGAIN;
diff --git a/t/op/pat.t b/t/op/pat.t
index 12b9397..7b8dc59 100755
--- a/t/op/pat.t
+++ b/t/op/pat.t
@@ -4,7 +4,7 @@
 # the format supported by op/regexp.t.  If you want to add a test
 # that does fit that format, add it to op/re_tests, not here.
 
-print "1..168\n";
+print "1..174\n";
 
 BEGIN {
     chdir 't' if -d 't';
@@ -719,6 +719,53 @@ print "not " unless $str =~ /\G../ and $& eq 'cd';
 print "ok $test\n";
 $test++;
 
+undef $foo; undef $bar;
+print "#'$str','$foo','$bar'\nnot "
+    unless $str =~ /b(?{$foo = $_; $bar = pos})c/ 
+	and $foo eq 'abcde' and $bar eq 2;
+print "ok $test\n";
+$test++;
+
+undef $foo; undef $bar;
+pos $str = undef;
+print "#'$str','$foo','$bar'\nnot "
+    unless $str =~ /b(?{$foo = $_; $bar = pos})c/g 
+	and $foo eq 'abcde' and $bar eq 2 and pos $str eq 3;
+print "ok $test\n";
+$test++;
+
+$_ = $str;
+
+undef $foo; undef $bar;
+print "#'$str','$foo','$bar'\nnot "
+    unless /b(?{$foo = $_; $bar = pos})c/ 
+	and $foo eq 'abcde' and $bar eq 2;
+print "ok $test\n";
+$test++;
+
+undef $foo; undef $bar;
+print "#'$str','$foo','$bar'\nnot "
+    unless /b(?{$foo = $_; $bar = pos})c/g 
+	and $foo eq 'abcde' and $bar eq 2 and pos eq 3;
+print "ok $test\n";
+$test++;
+
+undef $foo; undef $bar;
+pos = undef;
+1 while /b(?{$foo = $_; $bar = pos})c/g;
+print "#'$str','$foo','$bar'\nnot "
+    unless $foo eq 'abcde' and $bar eq 2 and not defined pos;
+print "ok $test\n";
+$test++;
+
+undef $foo; undef $bar;
+$_ = 'abcde|abcde';
+print "#'$str','$foo','$bar','$_'\nnot "
+    unless s/b(?{$foo = $_; $bar = pos})c/x/g and $foo eq 'abcde|abcde' 
+	and $bar eq 8 and $_ eq 'axde|axde';
+print "ok $test\n";
+$test++;
+
 # see if matching against temporaries (created via pp_helem()) is safe
 { foo => "ok $test\n".$^X }->{foo} =~ /^(.*)\n/g;
 print "$1\n";
diff --git a/thrdvar.h b/thrdvar.h
index 3e71fb5..7c72259 100644
--- a/thrdvar.h
+++ b/thrdvar.h
@@ -158,6 +158,8 @@ PERLVAR(Treg_call_cc,	struct re_cc_state *)	/* from regexec.c */
 PERLVAR(Treg_re,	regexp *)	/* from regexec.c */
 PERLVAR(Treg_ganch,	char *)		/* position of \G */
 PERLVAR(Treg_sv,	SV *)		/* what we match against */
+PERLVAR(Treg_magic,	MAGIC *)	/* pos-magic of what we match */
+PERLVAR(Treg_oldpos,	I32)		/* old pos of what we match */
 
 PERLVARI(Tregcompp,	regcomp_t, FUNC_NAME_TO_PTR(pregcomp))
 					/* Pointer to RE compiler */