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

diff --git a/av.c b/av.c
index b5c9bc2..af463cb 100644 (file)
--- 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 48c4289..c5338d3 100644 (file)
--- 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 09667da..c4f2229 100644 (file)
--- 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 03b90c0..a7e2b80 100644 (file)
--- 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 f003905..185b4f5 100644 (file)
--- 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 a3ddde7..eee1178 100644 (file)
--- 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 d10bfe7..ea4ab7a 100644 (file)
--- 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 547dc87..0f7fe6d 100644 (file)
--- 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 2ed3e97..739dd55 100644 (file)
--- 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 96bb15c..02d7a7e 100644 (file)
--- 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 c87189c..c2e5fa7 100644 (file)
--- 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 7d4278f..aec5f31 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..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 62d54c6..2381be3 100644 (file)
--- 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] = '@';