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

15 files changed, 120 insertions, 15 deletions

diff --git a/MANIFEST b/MANIFEST
index 5f59a7fe6a..8211870fc5 100644
--- 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 a664d46dc6..06c53b3408 100644
--- 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
index 0000000000..c6a55a6f44
--- /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
index b7375e3e71..53873fca4c 100644
--- 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
index 0000000000..7b9fb379cd
--- /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 44c8dbcc3b..35934acae3 100644
--- 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 2e76cc4a39..6270324e90 100644
--- 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 75fb556596..9c105b22dd 100644
--- 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 ab7a056b3f..caa8fe1918 100644
--- 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 9d982ec4de..69776abea1 100644
--- 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 44ddd26807..c388b610bb 100644
--- 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 b1d2f68dc2..464e20daea 100644
--- 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 f7183a8f12..c64393e2fd 100644
--- 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 b18740cbec..6292466929 100644
--- 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 77b9f2d8d2..505bc28ee8 100644
--- 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