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 (file)
--- 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 (executable)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (executable)
--- 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 (file)
--- 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 */