Finishing off SNOBOL: $1 in (?{})

	Message-Id: <199811280533.AAA25654@monk.mps.ohio-state.edu>

p4raw-id: //depot/perl@2372

diff --git a/embedvar.h b/embedvar.h
index 9d82427..4d28711 100644 (file)
--- a/embedvar.h
+++ b/embedvar.h
@@ -53,10 +53,12 @@
 #define PL_op                  (PL_curinterp->Top)
 #define PL_opsave              (PL_curinterp->Topsave)
 #define PL_reg_call_cc         (PL_curinterp->Treg_call_cc)
+#define PL_reg_curpm           (PL_curinterp->Treg_curpm)
 #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_oldcurpm                (PL_curinterp->Treg_oldcurpm)
 #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)
@@ -442,10 +444,12 @@
 #define PL_Top                 PL_op
 #define PL_Topsave             PL_opsave
 #define PL_Treg_call_cc                PL_reg_call_cc
+#define PL_Treg_curpm          PL_reg_curpm
 #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_oldcurpm       PL_reg_oldcurpm
 #define PL_Treg_oldpos         PL_reg_oldpos
 #define PL_Treg_re             PL_reg_re
 #define PL_Treg_start_tmp      PL_reg_start_tmp
@@ -574,10 +578,12 @@
 #define PL_op                  (thr->Top)
 #define PL_opsave              (thr->Topsave)
 #define PL_reg_call_cc         (thr->Treg_call_cc)
+#define PL_reg_curpm           (thr->Treg_curpm)
 #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_oldcurpm                (thr->Treg_oldcurpm)
 #define PL_reg_oldpos          (thr->Treg_oldpos)
 #define PL_reg_re              (thr->Treg_re)
 #define PL_reg_start_tmp       (thr->Treg_start_tmp)

diff --git a/mg.c b/mg.c
index 360e304..e960c93 100644 (file)
--- a/mg.c
+++ b/mg.c
@@ -350,9 +350,9 @@ magic_regdatum_get(SV *sv, MAGIC *mg)
            (t = rx->endp[paren]))
            {
                if (mg->mg_obj)         /* @+ */
-                   i = t - rx->subbase;
+                   i = t - rx->subbeg;
                else                    /* @- */
-                   i = s - rx->subbase;
+                   i = s - rx->subbeg;
                sv_setiv(sv,i);
            }
     }

diff --git a/objXSUB.h b/objXSUB.h
index 3c154e4..75be465 100644 (file)
--- a/objXSUB.h
+++ b/objXSUB.h
@@ -494,6 +494,8 @@
 #define PL_profiledata         pPerl->PL_profiledata
 #undef  PL_reg_call_cc
 #define PL_reg_call_cc         pPerl->PL_reg_call_cc
+#undef  PL_reg_curpm
+#define PL_reg_curpm           pPerl->PL_reg_curpm
 #undef  PL_reg_eval_set
 #define PL_reg_eval_set                pPerl->PL_reg_eval_set
 #undef  PL_reg_flags
@@ -502,6 +504,8 @@
 #define PL_reg_ganch           pPerl->PL_reg_ganch
 #undef  PL_reg_magic
 #define PL_reg_magic           pPerl->PL_reg_magic
+#undef  PL_reg_oldcurpm
+#define PL_reg_oldcurpm                pPerl->PL_reg_oldcurpm
 #undef  PL_reg_oldpos
 #define PL_reg_oldpos          pPerl->PL_reg_oldpos
 #undef  PL_reg_re

diff --git a/perl.c b/perl.c
index 7659b7c..9ddf917 100644 (file)
--- a/perl.c
+++ b/perl.c
@@ -547,6 +547,8 @@ perl_destruct(register PerlInterpreter *sv_interp)
     Safefree(PL_origfilename);
     Safefree(PL_archpat_auto);
     Safefree(PL_reg_start_tmp);
+    if (PL_reg_curpm)
+       Safefree(PL_reg_curpm);
     Safefree(HeKEY_hek(&PL_hv_fetch_ent_mh));
     Safefree(PL_op_mask);
     nuke_stacks();

diff --git a/regexec.c b/regexec.c
index 36a35b0..173defa 100644 (file)
--- a/regexec.c
+++ b/regexec.c
@@ -268,6 +268,7 @@ restore_pos(void *arg)
     if (PL_reg_eval_set) {    
        PL_reg_magic->mg_len = PL_reg_oldpos;
        PL_reg_eval_set = 0;
+       PL_curpm = PL_reg_oldcurpm;
     }  
 }
 
@@ -1011,14 +1012,15 @@ got_it:
            }
        }
     }
-    /* Preserve the current value of $^R */
-    if (oreplsv != GvSV(PL_replgv)) {
-       sv_setsv(oreplsv, GvSV(PL_replgv));/* So that when GvSV(replgv) is
-                                          restored, the value remains
-                                          the same. */
-    }
-    if (PL_reg_eval_set)
+    if (PL_reg_eval_set) {
+       /* Preserve the current value of $^R */
+       if (oreplsv != GvSV(PL_replgv))
+           sv_setsv(oreplsv, GvSV(PL_replgv));/* So that when GvSV(replgv) is
+                                                 restored, the value remains
+                                                 the same. */
        restore_pos(0);
+    }
+    
     return 1;
 
 phooey:
@@ -1073,7 +1075,15 @@ regtry(regexp *prog, char *startpos)
            PL_reg_oldpos   = mg->mg_len;
            SAVEDESTRUCTOR(restore_pos, 0);
         }
+       if (!PL_reg_curpm)
+           New(22,PL_reg_curpm, 1, PMOP);
+       PL_reg_curpm->op_pmregexp = prog;
+       PL_reg_oldcurpm = PL_curpm;
+       PL_curpm = PL_reg_curpm;
+       prog->subbeg = PL_bostr;
+       prog->subend = PL_regeol;       /* strend may have been modified */
     }
+    prog->startp[0] = startpos;
     PL_reginput = startpos;
     PL_regstartp = prog->startp;
     PL_regendp = prog->endp;
@@ -1089,17 +1099,19 @@ regtry(regexp *prog, char *startpos)
             New(22,PL_reg_start_tmp, PL_reg_start_tmpl, char*);
     }
 
+    /* XXXX What this code is doing here?!!!  There should be no need
+       to do this again and again, PL_reglastparen should take care of
+       this!  */
     sp = prog->startp;
     ep = prog->endp;
     if (prog->nparens) {
-       for (i = prog->nparens; i >= 0; i--) {
-           *sp++ = NULL;
-           *ep++ = NULL;
+       for (i = prog->nparens; i >= 1; i--) {
+           *++sp = NULL;
+           *++ep = NULL;
        }
     }
     REGCP_SET;
     if (regmatch(prog->program + 1)) {
-       prog->startp[0] = startpos;
        prog->endp[0] = PL_reginput;
        return 1;
     }
@@ -1646,6 +1658,7 @@ regmatch(regnode *prog)
            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;
+           PL_regendp[0] = locinput;
 
            CALLRUNOPS();                       /* Scalar context. */
            SPAGAIN;

diff --git a/t/op/pat.t b/t/op/pat.t
index 7b8dc59..a289fbe 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..174\n";
+print "1..176\n";
 
 BEGIN {
     chdir 't' if -d 't';
@@ -766,6 +766,31 @@ print "#'$str','$foo','$bar','$_'\nnot "
 print "ok $test\n";
 $test++;
 
+@res = ();
+# List context:
+$_ = 'abcde|abcde';
+@dummy = /([ace]).(?{push @res, $1,$2})([ce])(?{push @res, $1,$2})/g;
+@res = map {defined $_ ? "'$_'" : 'undef'} @res;
+$res = "@res";
+print "#'@res' '$_'\nnot "
+    unless "@res" eq "'a' undef 'a' 'c' 'e' undef 'a' undef 'a' 'c'";
+print "ok $test\n";
+$test++;
+
+@res = ();
+@dummy = /([ace]).(?{push @res, $`,$&,$'})([ce])(?{push @res, $`,$&,$'})/g;
+@res = map {defined $_ ? "'$_'" : 'undef'} @res;
+$res = "@res";
+print "#'@res' '$_'\nnot "
+    unless "@res" eq
+  "'' 'ab' 'cde|abcde' " .
+  "'' 'abc' 'de|abcde' " .
+  "'abcd' 'e|' 'abcde' " .
+  "'abcde|' 'ab' 'cde' " .
+  "'abcde|' 'abc' 'de'" ;
+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 d9cb9c6..cb39d08 100644 (file)
--- a/thrdvar.h
+++ b/thrdvar.h
@@ -160,6 +160,8 @@ 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(Treg_oldcurpm,        PMOP*, NULL)    /* curpm before match */
+PERLVARI(Treg_curpm,   PMOP*, NULL)    /* curpm during match */
 
 PERLVARI(Tregcompp,    regcomp_t, FUNC_NAME_TO_PTR(pregcomp))
                                        /* Pointer to RE compiler */