add patch for C<use re 'debug'>

	Message-Id: <199807070224.WAA10318@monk.mps.ohio-state.edu>
	Subject: Re: _70 and Devel::RE

p4raw-id: //depot/perl@1371

diff --git a/MANIFEST b/MANIFEST
index 5f59a7f..8211870 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -308,6 +308,9 @@ ext/Thread/unsync4.t        Test thread implicit synchronisation
 ext/attrs/Makefile.PL  attrs extension makefile writer
 ext/attrs/attrs.pm     attrs extension Perl module
 ext/attrs/attrs.xs     attrs extension external subroutines
+ext/re/Makefile.PL     re extension makefile writer
+ext/re/re.pm           re extension Perl module
+ext/re/re.xs           re extension external subroutines
 ext/util/make_ext      Used by Makefile to execute extension Makefiles
 ext/util/mkbootstrap   Turns ext/*/*_BS into bootstrap info
 fakethr.h              Fake threads header
@@ -558,7 +561,6 @@ lib/open3.pl                Open a three-ended pipe (uses IPC::Open3)
 lib/overload.pm                Module for overloading perl operators
 lib/perl5db.pl         Perl debugging routines
 lib/pwd.pl             Routines to keep track of PWD environment variable
-lib/re.pm              Pragmas for regular expressions
 lib/shellwords.pl      Perl library to split into words with shell quoting
 lib/sigtrap.pm         For trapping an abort and giving traceback
 lib/stat.pl            Perl library supporting stat function

diff --git a/Makefile.SH b/Makefile.SH
index a664d46..06c53b3 100644 (file)
--- a/Makefile.SH
+++ b/Makefile.SH
@@ -381,7 +381,10 @@ lib/Config.pm: config.sh miniperl configpm
 lib/ExtUtils/Miniperl.pm: miniperlmain.c miniperl minimod.pl lib/Config.pm
        $(LDLIBPTH) ./miniperl minimod.pl > tmp && mv tmp $@
 
-$(plextract):  miniperl lib/Config.pm
+lib/re.pm: ext/re/re.pm
+       cat ext/re/re.pm > $@
+
+$(plextract):  miniperl lib/Config.pm lib/re.pm
        $(LDLIBPTH) ./miniperl -Ilib $@.PL
        
 install: all install.perl install.man

diff --git a/ext/re/Makefile.PL b/ext/re/Makefile.PL
new file mode 100644 (file)
index 0000000..c6a55a6
--- /dev/null
+++ b/ext/re/Makefile.PL
@@ -0,0 +1,22 @@
+use ExtUtils::MakeMaker;
+WriteMakefile(
+    NAME               => 're',
+    VERSION_FROM       => 're.pm',
+    MAN3PODS           => ' ',         # Pods will be built by installman.
+    XSPROTOARG         => '-noprototypes',
+    OBJECT             => 're_exec$(OBJ_EXT) re_comp$(OBJ_EXT) re$(OBJ_EXT)',
+    DEFINE             => '-DDEBUGGING -DIN_XSUB_RE',
+);
+
+sub MY::postamble {
+    return <<'EOF';
+re_comp.c: ../../regcomp.c
+       -$(RM) $@
+       $(CP) ../../regcomp.c $@
+
+re_exec.c: ../../regexec.c
+       -$(RM) $@
+       $(CP) ../../regexec.c $@
+
+EOF
+}

diff --git a/lib/re.pm b/ext/re/re.pm
similarity index 81%
rename from lib/re.pm
rename to ext/re/re.pm
index b7375e3..53873fc 100644 (file)
--- a/lib/re.pm
+++ b/ext/re/re.pm
@@ -1,5 +1,7 @@
 package re;
 
+$VERSION = 0.02;
+
 =head1 NAME
 
 re - Perl pragma to alter regular expression behaviour
@@ -45,23 +47,36 @@ eval        => 0x00200000,
 );
 
 sub bits {
+    my $on = shift;
     my $bits = 0;
     unless(@_) {
        require Carp;
        Carp::carp("Useless use of \"re\" pragma");
     }
-    foreach my $s (@_){ $bits |= $bitmask{$s} || 0; };
+    foreach my $s (@_){
+      if ($s eq 'debug') {
+         eval <<'EOE';
+           use DynaLoader;
+           @ISA = ('DynaLoader');
+           bootstrap re;
+EOE
+         install() if $on;
+         uninstall() unless $on;
+         next;
+      }
+      $bits |= $bitmask{$s} || 0;
+    }
     $bits;
 }
 
 sub import {
     shift;
-    $^H |= bits(@_);
+    $^H |= bits(1,@_);
 }
 
 sub unimport {
     shift;
-    $^H &= ~ bits(@_);
+    $^H &= ~ bits(0,@_);
 }
 
 1;

diff --git a/ext/re/re.xs b/ext/re/re.xs
new file mode 100644 (file)
index 0000000..7b9fb37
--- /dev/null
+++ b/ext/re/re.xs
@@ -0,0 +1,38 @@
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+
+extern regexp* my_regcomp _((char* exp, char* xend, PMOP* pm));
+extern I32     my_regexec _((regexp* prog, char* stringarg, char* strend,
+                             char* strbeg, I32 minend, SV* screamer,
+                             void* data, U32 flags));
+
+static int oldfl;
+
+#define R_DB 512
+
+static void
+deinstall(void)
+{
+    regexecp = &regexec_flags;
+    regcompp = &pregcomp;
+    if (!oldfl)
+       debug &= ~R_DB;
+}
+
+static void
+install(void)
+{
+    regexecp = &my_regexec;
+    regcompp = &my_regcomp;
+    oldfl = debug & R_DB;
+    debug |= R_DB;
+}
+
+MODULE = re    PACKAGE = re
+
+void
+install()
+
+void
+deinstall()

diff --git a/global.sym b/global.sym
index 44c8dbc..35934ac 100644 (file)
--- a/global.sym
+++ b/global.sym
@@ -81,7 +81,6 @@ psig_name
 psig_ptr
 rcsid
 reall_srchlen
-regexec_flags
 regkind
 repeat_amg
 repeat_ass_amg
@@ -884,6 +883,7 @@ q
 ref
 refkids
 regdump
+regexec_flags
 regnext
 regprop
 repeatcpy

diff --git a/interp.sym b/interp.sym
index 2e76cc4..6270324 100644 (file)
--- a/interp.sym
+++ b/interp.sym
@@ -133,6 +133,8 @@ reg_start_tmpl
 regbol
 regcc
 regcode
+regcompp
+regexecp
 regdata
 regdummy
 regendp

diff --git a/intrpvar.h b/intrpvar.h
index 75fb556..9c105b2 100644 (file)
--- a/intrpvar.h
+++ b/intrpvar.h
@@ -240,6 +240,11 @@ PERLVAR(Iregprogram,       regnode *)      /* from regexec.c */
 PERLVARI(Iregindent,   int,        0)  /* from regexec.c */
 
 PERLVAR(Iregcc,                CURCUR *)       /* from regexec.c */
+
+PERLVARI(Iregcompp,    regcomp_t, &pregcomp) /* Pointer to RE compiler */
+PERLVARI(Iregexecp,    regexec_t, &regexec_flags) /* Pointer to RE executer */
+
+
 PERLVARI(Iin_clean_objs,bool,    FALSE)        /* from sv.c */
 PERLVARI(Iin_clean_all,        bool,    FALSE) /* from sv.c */
 

diff --git a/op.c b/op.c
index ab7a056..caa8fe1 100644 (file)
--- a/op.c
+++ b/op.c
@@ -2140,7 +2140,7 @@ pmruntime(OP *o, OP *expr, OP *repl)
            p = SvPV(pat, plen);
            pm->op_pmflags |= PMf_SKIPWHITE;
        }
-       pm->op_pmregexp = pregcomp(p, p + plen, pm);
+       pm->op_pmregexp = (*regcompp)(p, p + plen, pm);
        if (strEQ("\\s+", pm->op_pmregexp->precomp))
            pm->op_pmflags |= PMf_WHITE;
        op_free(expr);

diff --git a/perl.h b/perl.h
index 9d982ec..69776ab 100644 (file)
--- a/perl.h
+++ b/perl.h
@@ -1832,6 +1832,12 @@ typedef enum {
 #define RsPARA(sv)    (SvOK(sv) && ! SvCUR(sv))
 #define RsRECORD(sv)  (SvROK(sv) && (SvIV(SvRV(sv)) > 0))
 
+/* Enable variables which are pointers to functions */
+typedef regexp*(*regcomp_t) _((char* exp, char* xend, PMOP* pm));
+typedef I32 (*regexec_t) _((regexp* prog, char* stringarg, char* strend, char*
+                           strbeg, I32 minend, SV* screamer, void* data, 
+                           U32 flags));
+
 /* Set up PERLVAR macros for populating structs */
 #define PERLVAR(var,type) type var;
 #define PERLVARI(var,type,init) type var;

diff --git a/pp.c b/pp.c
index 44ddd26..c388b61 100644 (file)
--- a/pp.c
+++ b/pp.c
@@ -4338,7 +4338,7 @@ PP(pp_split)
     else {
        maxiters += (strend - s) * rx->nparens;
        while (s < strend && --limit &&
-              regexec_flags(rx, s, strend, orig, 1, Nullsv, NULL, 0))
+              (*regexecp)(rx, s, strend, orig, 1, Nullsv, NULL, 0))
        {
            TAINT_IF(RX_MATCH_TAINTED(rx));
            if (rx->subbase

diff --git a/pp_ctl.c b/pp_ctl.c
index b1d2f68..464e20d 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -101,7 +101,7 @@ PP(pp_regcomp)
            }
 
            pm->op_pmflags = pm->op_pmpermflags;        /* reset case sensitivity */
-           pm->op_pmregexp = pregcomp(t, t + len, pm);
+           pm->op_pmregexp = (*regcompp)(t, t + len, pm);
        }
     }
 
@@ -148,7 +148,7 @@ PP(pp_substcont)
        sv_catsv(dstr, POPs);
 
        /* Are we done */
-       if (cx->sb_once || !regexec_flags(rx, s, cx->sb_strend, orig,
+       if (cx->sb_once || !(*regexecp)(rx, s, cx->sb_strend, orig,
                                     s == m, Nullsv, NULL,
                                     cx->sb_safebase ? 0 : REXEC_COPY_STR))
        {

diff --git a/pp_hot.c b/pp_hot.c
index f7183a8..c64393e 100644 (file)
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -905,7 +905,7 @@ play_it_again:
            rx->float_substr = Nullsv;
        }
     }
-    if (regexec_flags(rx, s, strend, truebase, minmatch,
+    if ((*regexecp)(rx, s, strend, truebase, minmatch,
                      screamer, NULL, safebase))
     {
        curpm = pm;
@@ -1624,7 +1624,7 @@ PP(pp_subst)
     /* can do inplace substitution? */
     if (c && clen <= rx->minlen && (once || !(safebase & REXEC_COPY_STR))
        && !(rx->reganch & ROPT_LOOKBEHIND_SEEN)) {
-       if (!regexec_flags(rx, s, strend, orig, 0, screamer, NULL, safebase)) {
+       if (!(*regexecp)(rx, s, strend, orig, 0, screamer, NULL, safebase)) {
            SPAGAIN;
            PUSHs(&sv_no);
            LEAVE_SCOPE(oldsave);
@@ -1701,7 +1701,7 @@ PP(pp_subst)
                    d += clen;
                }
                s = rx->endp[0];
-           } while (regexec_flags(rx, s, strend, orig, s == m,
+           } while ((*regexecp)(rx, s, strend, orig, s == m,
                              Nullsv, NULL, 0)); /* don't match same null twice */
            if (s != d) {
                i = strend - s;
@@ -1724,7 +1724,7 @@ PP(pp_subst)
        RETURN;
     }
 
-    if (regexec_flags(rx, s, strend, orig, 0, screamer, NULL, safebase)) {
+    if ((*regexecp)(rx, s, strend, orig, 0, screamer, NULL, safebase)) {
        if (force_on_match) {
            force_on_match = 0;
            s = SvPV_force(TARG, len);
@@ -1758,7 +1758,7 @@ PP(pp_subst)
                sv_catpvn(dstr, c, clen);
            if (once)
                break;
-       } while (regexec_flags(rx, s, strend, orig, s == m, Nullsv, NULL, safebase));
+       } while ((*regexecp)(rx, s, strend, orig, s == m, Nullsv, NULL, safebase));
        sv_catpvn(dstr, s, strend - s);
 
        (void)SvOOK_off(TARG);

diff --git a/regcomp.c b/regcomp.c
index b18740c..6292466 100644 (file)
--- a/regcomp.c
+++ b/regcomp.c
@@ -19,6 +19,12 @@
  * with the POSIX routines of the same names.
 */
 
+#ifdef IN_XSUB_RE
+#  define Perl_pregcomp my_regcomp
+#  define Perl_regdump my_regdump
+#  define Perl_regprop my_regprop
+#endif 
+
 /*SUPPRESS 112*/
 /*
  * pregcomp and pregexec -- regsub and regerror are not used in perl

diff --git a/regexec.c b/regexec.c
index 77b9f2d..505bc28 100644 (file)
--- a/regexec.c
+++ b/regexec.c
@@ -19,6 +19,12 @@
  * with the POSIX routines of the same names.
 */
 
+#ifdef IN_XSUB_RE
+#  define Perl_regexec_flags my_regexec
+#  define Perl_regdump my_regdump
+#  define Perl_regprop my_regprop
+#endif 
+
 /*SUPPRESS 112*/
 /*
  * pregcomp and pregexec -- regsub and regerror are not used in perl