diff options
| -rw-r--r-- | MANIFEST | 4 | ||||
| -rw-r--r-- | Makefile.SH | 5 | ||||
| -rw-r--r-- | ext/re/Makefile.PL | 22 | ||||
| -rw-r--r-- | ext/re/re.pm (renamed from lib/re.pm) | 21 | ||||
| -rw-r--r-- | ext/re/re.xs | 38 | ||||
| -rw-r--r-- | global.sym | 2 | ||||
| -rw-r--r-- | interp.sym | 2 | ||||
| -rw-r--r-- | intrpvar.h | 5 | ||||
| -rw-r--r-- | op.c | 2 | ||||
| -rw-r--r-- | perl.h | 6 | ||||
| -rw-r--r-- | pp.c | 2 | ||||
| -rw-r--r-- | pp_ctl.c | 4 | ||||
| -rw-r--r-- | pp_hot.c | 10 | ||||
| -rw-r--r-- | regcomp.c | 6 | ||||
| -rw-r--r-- | regexec.c | 6 |
15 files changed, 120 insertions, 15 deletions
@@ -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 = ®exec_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, ®exec_flags) /* Pointer to RE executer */ + + PERLVARI(Iin_clean_objs,bool, FALSE) /* from sv.c */ PERLVARI(Iin_clean_all, bool, FALSE) /* from sv.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); @@ -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; @@ -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 @@ -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)) { @@ -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); @@ -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 @@ -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 |