support match indices via special variables @- and @+

	Message-Id: <199807220300.XAA16081@monk.mps.ohio-state.edu>
	Subject: [PATCH 5.004_76] @- and @+

p4raw-id: //depot/perl@1800

13 files changed, 188 insertions, 5 deletions

diff --git a/av.c b/av.c
index b5c9bc20aa..af463cb3aa 100644
--- a/av.c
+++ b/av.c
@@ -162,7 +162,7 @@ av_fetch(register AV *av, I32 key, I32 lval)
     }
 
     if (SvRMAGICAL(av)) {
-	if (mg_find((SV*)av,'P')) {
+	if (mg_find((SV*)av,'P') || mg_find((SV*)av,'D')) {
 	    dTHR;
 	    sv = sv_newmortal();
 	    mg_copy((SV*)av, sv, 0, key);
diff --git a/embed.h b/embed.h
index 48c4289670..c5338d323f 100644
--- a/embed.h
+++ b/embed.h
@@ -319,6 +319,8 @@
 #define magic_len		Perl_magic_len
 #define magic_mutexfree		Perl_magic_mutexfree
 #define magic_nextpack		Perl_magic_nextpack
+#define magic_regdata_cnt	Perl_magic_regdata_cnt
+#define magic_regdatum_get	Perl_magic_regdatum_get
 #define magic_set		Perl_magic_set
 #define magic_set_all_env	Perl_magic_set_all_env
 #define magic_setamagic		Perl_magic_setamagic
diff --git a/global.sym b/global.sym
index 09667da410..c4f2229f92 100644
--- a/global.sym
+++ b/global.sym
@@ -417,6 +417,8 @@ magic_getvec
 magic_len
 magic_mutexfree
 magic_nextpack
+magic_regdata_cnt
+magic_regdatum_get
 magic_set
 magic_set_all_env
 magic_setamagic
diff --git a/gv.c b/gv.c
index 03b90c0fc1..a7e2b8091b 100644
--- a/gv.c
+++ b/gv.c
@@ -729,6 +729,14 @@ gv_fetchpv(char *nambeg, I32 add, I32 sv_type)
 	    }
 	}
 	goto magicalize;
+    case '-':
+	if (len > 1)
+	    break;
+	else {
+            AV* av = GvAVn(gv);
+            sv_magic((SV*)av, Nullsv, 'D', Nullch, 0);
+        }
+	goto magicalize;
     case '#':
     case '*':
 	if (ckWARN(WARN_DEPRECATED) && len == 1 && sv_type == SVt_PV)
@@ -738,7 +746,6 @@ gv_fetchpv(char *nambeg, I32 add, I32 sv_type)
     case '^':
     case '~':
     case '=':
-    case '-':
     case '%':
     case '.':
     case '(':
@@ -763,8 +770,19 @@ gv_fetchpv(char *nambeg, I32 add, I32 sv_type)
 	if (len > 1)
 	    break;
 	goto magicalize;
+    case '\023':
+	if (len > 1)
+	    break;
+	goto ro_magicalize;
 
     case '+':
+	if (len > 1)
+	    break;
+	else {
+            AV* av = GvAVn(gv);
+            sv_magic((SV*)av, (SV*)av, 'D', Nullch, 0);
+        }
+	/* FALL THROUGH */
     case '1':
     case '2':
     case '3':
@@ -774,7 +792,6 @@ gv_fetchpv(char *nambeg, I32 add, I32 sv_type)
     case '7':
     case '8':
     case '9':
-    case '\023':
       ro_magicalize:
 	SvREADONLY_on(GvSV(gv));
       magicalize:
diff --git a/mg.c b/mg.c
index f0039056cb..185b4f54a9 100644
--- a/mg.c
+++ b/mg.c
@@ -282,6 +282,48 @@ mg_free(SV *sv)
 #include <signal.h>
 #endif
 
+int
+magic_regdata_cnt(SV *sv, MAGIC *mg)
+{
+    dTHR;
+    register char *s;
+    register I32 i;
+    register REGEXP *rx;
+    char *t;
+
+    if (PL_curpm && (rx = PL_curpm->op_pmregexp))
+	return rx->lastparen;
+    return -1;
+}
+
+int
+magic_regdatum_get(SV *sv, MAGIC *mg)
+{
+    dTHR;
+    register I32 paren;
+    register char *s;
+    register I32 i;
+    register REGEXP *rx;
+    char *t;
+
+    if (PL_curpm && (rx = PL_curpm->op_pmregexp)) {
+	paren = mg->mg_len;
+	if (paren < 0)
+	    return 0;
+	if (paren <= rx->nparens &&
+	    (s = rx->startp[paren]) &&
+	    (t = rx->endp[paren]))
+	    {
+		if (mg->mg_obj)		/* @+ */
+		    i = t - rx->subbase;
+		else			/* @- */
+		    i = s - rx->subbase;
+		sv_setiv(sv,i);
+	    }
+    }
+    return 0;
+}
+
 U32
 magic_len(SV *sv, MAGIC *mg)
 {
diff --git a/objXSUB.h b/objXSUB.h
index a3ddde701f..eee11787c5 100644
--- a/objXSUB.h
+++ b/objXSUB.h
@@ -1198,6 +1198,10 @@
 #define magic_mutexfree     pPerl->Perl_magic_mutexfree
 #undef  magic_nextpack
 #define magic_nextpack      pPerl->Perl_magic_nextpack
+#undef  magic_regdata_cnt
+#define magic_regdata_cnt   pPerl->Perl_magic_regdata_cnt
+#undef  magic_regdatum_get
+#define magic_regdatum_get  pPerl->Perl_magic_regdatum_get
 #undef  magic_set
 #define magic_set           pPerl->Perl_magic_set
 #undef  magic_set_all_env
diff --git a/objpp.h b/objpp.h
index d10bfe7565..ea4ab7a353 100644
--- a/objpp.h
+++ b/objpp.h
@@ -640,6 +640,10 @@
 #define magic_methpack    CPerlObj::magic_methpack
 #undef  magic_nextpack
 #define magic_nextpack    CPerlObj::Perl_magic_nextpack
+#undef  magic_regdata_cnt
+#define magic_regdata_cnt   CPerlObj::Perl_magic_regdata_cnt
+#undef  magic_regdatum_get
+#define magic_regdatum_get  CPerlObj::Perl_magic_regdatum_get
 #undef  magic_set
 #define magic_set         CPerlObj::Perl_magic_set
 #undef  magic_set_all_env
diff --git a/perl.h b/perl.h
index 547dc87f04..0f7fe6de94 100644
--- a/perl.h
+++ b/perl.h
@@ -2179,6 +2179,8 @@ EXT MGVTBL vtbl_defelem = {magic_getdefelem,magic_setdefelem,
 					0,	0,	0};
 
 EXT MGVTBL vtbl_regexp = {0,0,0,0, magic_freeregexp};
+EXT MGVTBL vtbl_regdata = {0, 0, magic_regdata_cnt, 0, 0};
+EXT MGVTBL vtbl_regdatum = {magic_regdatum_get, 0, 0, 0, 0};
 
 #ifdef USE_LOCALE_COLLATE
 EXT MGVTBL vtbl_collxfrm = {0,
@@ -2223,6 +2225,8 @@ EXT MGVTBL vtbl_mutex;
 
 EXT MGVTBL vtbl_defelem;
 EXT MGVTBL vtbl_regexp;
+EXT MGVTBL vtbl_regdata;
+EXT MGVTBL vtbl_regdatum;
 
 #ifdef USE_LOCALE_COLLATE
 EXT MGVTBL vtbl_collxfrm;
diff --git a/pod/perlvar.pod b/pod/perlvar.pod
index 2ed3e97f77..739dd55cd2 100644
--- a/pod/perlvar.pod
+++ b/pod/perlvar.pod
@@ -164,6 +164,18 @@ example:
 (Mnemonic: be positive and forward looking.)
 This variable is read-only.
 
+=item @+
+
+$+[0] is the offset of the end of the last successfull match.
+C<$+[>I<n>C<]> is the offset of the end of the substring matched by
+I<n>-th subpattern.  
+
+Thus after a match against $_, $& coincides with C<substr $_, $-[0],
+$+[0]>.  Similarly, C<$>I<n> coincides with C<substr $_, $-[>I<n>C<],
+$+[>I<0>C<]> if C<$-[>I<n>C<]> is defined, and $+ conincides with
+C<substr $_, $-[-1], $+[-1]>.  One can use C<$#+> to find the last
+matched subgroup in the last successful match.  Compare with L<"@-">.
+
 =item $MULTILINE_MATCHING
 
 =item $*
@@ -373,6 +385,18 @@ output channel.  Default is 60.  (Mnemonic: = has horizontal lines.)
 The number of lines left on the page of the currently selected output
 channel.  (Mnemonic: lines_on_page - lines_printed.)
 
+=item @-
+
+$-[0] is the offset of the start of the last successfull match.
+C<$-[>I<n>C<]> is the offset of the start of the substring matched by
+I<n>-th subpattern.  
+
+Thus after a match against $_, $& coincides with C<substr $_, $-[0],
+$+[0]>.  Similarly, C<$>I<n> coincides with C<substr $_, $-[>I<n>C<],
+$+[>I<0>C<]> if C<$-[>I<n>C<]> is defined, and $+ conincides with
+C<substr $_, $-[-1], $+[-1]>.  One can use C<$#-> to find the last
+matched subgroup in the last successful match.  Compare with L<"@+">.
+
 =item format_name HANDLE EXPR
 
 =item $FORMAT_NAME
diff --git a/proto.h b/proto.h
index 96bb15cb6a..02d7a7e786 100644
--- a/proto.h
+++ b/proto.h
@@ -267,6 +267,8 @@ VIRTUAL U32	magic_len	_((SV* sv, MAGIC* mg));
 VIRTUAL int	magic_mutexfree	_((SV* sv, MAGIC* mg));
 #endif /* USE_THREADS */
 VIRTUAL int	magic_nextpack	_((SV* sv, MAGIC* mg, SV* key));
+VIRTUAL int	magic_regdata_cnt	_((SV* sv, MAGIC* mg));
+VIRTUAL int	magic_regdatum_get	_((SV* sv, MAGIC* mg));
 VIRTUAL int	magic_set	_((SV* sv, MAGIC* mg));
 #ifdef OVERLOAD
 VIRTUAL int	magic_setamagic	_((SV* sv, MAGIC* mg));
diff --git a/sv.c b/sv.c
index c87189c72e..c2e5fa7f3b 100644
--- a/sv.c
+++ b/sv.c
@@ -2605,6 +2605,12 @@ sv_magic(register SV *sv, SV *obj, int how, char *name, I32 namlen)
     case 'B':
 	mg->mg_virtual = &vtbl_bm;
 	break;
+    case 'D':
+	mg->mg_virtual = &vtbl_regdata;
+	break;
+    case 'd':
+	mg->mg_virtual = &vtbl_regdatum;
+	break;
     case 'E':
 	mg->mg_virtual = &vtbl_env;
 	break;
diff --git a/t/op/pat.t b/t/op/pat.t
index 7d4278f38a..aec5f31d73 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..141\n";
+print "1..158\n";
 
 BEGIN {
     chdir 't' if -d 't';
@@ -595,3 +595,79 @@ print "not " if @_;
 print "ok $test\n";
 $test++;
 
+/a(?=.$)/;
+print "not " if $#+ != 0 or $#- != 0;
+print "ok $test\n";
+$test++;
+
+print "not " if $+[0] != 2 or $-[0] != 1;
+print "ok $test\n";
+$test++;
+
+print "not " 
+   if defined $+[1] or defined $-[1] or defined $+[2] or defined $-[2];
+print "ok $test\n";
+$test++;
+
+/a(a)(a)/;
+print "not " if $#+ != 2 or $#- != 2;
+print "ok $test\n";
+$test++;
+
+print "not " if $+[0] != 3 or $-[0] != 0;
+print "ok $test\n";
+$test++;
+
+print "not " if $+[1] != 2 or $-[1] != 1;
+print "ok $test\n";
+$test++;
+
+print "not " if $+[2] != 3 or $-[2] != 2;
+print "ok $test\n";
+$test++;
+
+print "not " 
+   if defined $+[3] or defined $-[3] or defined $+[4] or defined $-[4];
+print "ok $test\n";
+$test++;
+
+/.(a)(b)?(a)/;
+print "not " if $#+ != 3 or $#- != 3;
+print "ok $test\n";
+$test++;
+
+print "not " if $+[0] != 3 or $-[0] != 0;
+print "ok $test\n";
+$test++;
+
+print "not " if $+[1] != 2 or $-[1] != 1;
+print "ok $test\n";
+$test++;
+
+print "not " if $+[3] != 3 or $-[3] != 2;
+print "ok $test\n";
+$test++;
+
+print "not " 
+   if defined $+[2] or defined $-[2] or defined $+[4] or defined $-[4];
+print "ok $test\n";
+$test++;
+
+/.(a)/;
+print "not " if $#+ != 1 or $#- != 1;
+print "ok $test\n";
+$test++;
+
+print "not " if $+[0] != 2 or $-[0] != 0;
+print "ok $test\n";
+$test++;
+
+print "not " if $+[1] != 2 or $-[1] != 1;
+print "ok $test\n";
+$test++;
+
+print "not " 
+   if defined $+[2] or defined $-[2] or defined $+[3] or defined $-[3];
+print "ok $test\n";
+$test++;
+
diff --git a/toke.c b/toke.c
index 62d54c635d..2381be3cda 100644
--- a/toke.c
+++ b/toke.c
@@ -2612,7 +2612,7 @@ yylex(void)
 	    }
 	}
 
-	if (s[1] == '#' && (isALPHA(s[2]) || strchr("_{$:", s[2]))) {
+	if (s[1] == '#' && (isALPHA(s[2]) || strchr("_{$:+-", s[2]))) {
 	    if (PL_expect == XOPERATOR)
 		no_op("Array length", PL_bufptr);
 	    PL_tokenbuf[0] = '@';