Re: Proposed changes and to regular expression interfaces in core

From: "Ævar Arnfjörð Bjarmason" <avarab@gmail.com>
Message-ID: <51dd1af80703291552y1073bcb6r954b043eb68a4459@mail.gmail.com>

p4raw-id: //depot/perl@30849

diff --git a/embed.fnc b/embed.fnc
index 679b443..eb7817e 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -696,6 +696,7 @@ ApR |regnode*|regnext       |NN regnode* p
 
 EXp    |SV*|reg_named_buff_get |NN const REGEXP * const rx|NN SV* namesv|U32 flags
 EXp    |SV*|reg_numbered_buff_get|NN const REGEXP * const rx|I32 paren|NULLOK SV* usesv
+EXp    |SV*|reg_qr_pkg|NN const REGEXP * const rx
 
 Ep     |void   |regprop        |NULLOK const regexp *prog|NN SV* sv|NN const regnode* o
 Ap     |void   |repeatcpy      |NN char* to|NN const char* from|I32 len|I32 count

diff --git a/embed.h b/embed.h
index a41de9d..182afca 100644 (file)
--- a/embed.h
+++ b/embed.h
@@ -706,6 +706,7 @@
 #if defined(PERL_CORE) || defined(PERL_EXT)
 #define reg_named_buff_get     Perl_reg_named_buff_get
 #define reg_numbered_buff_get  Perl_reg_numbered_buff_get
+#define reg_qr_pkg             Perl_reg_qr_pkg
 #endif
 #if defined(PERL_CORE) || defined(PERL_EXT)
 #define regprop                        Perl_regprop
@@ -2949,6 +2950,7 @@
 #if defined(PERL_CORE) || defined(PERL_EXT)
 #define reg_named_buff_get(a,b,c)      Perl_reg_named_buff_get(aTHX_ a,b,c)
 #define reg_numbered_buff_get(a,b,c)   Perl_reg_numbered_buff_get(aTHX_ a,b,c)
+#define reg_qr_pkg(a)          Perl_reg_qr_pkg(aTHX_ a)
 #endif
 #if defined(PERL_CORE) || defined(PERL_EXT)
 #define regprop(a,b,c)         Perl_regprop(aTHX_ a,b,c)

diff --git a/ext/re/re.xs b/ext/re/re.xs
index 5ab5f7c..aa87bb6 100644 (file)
--- a/ext/re/re.xs
+++ b/ext/re/re.xs
@@ -24,6 +24,7 @@ extern SV*    my_re_intuit_string (pTHX_ regexp *prog);
 extern void    my_regfree (pTHX_ struct regexp* r);
 extern SV*      my_reg_numbered_buff_get(pTHX_ const REGEXP * const rx, I32 paren, SV* usesv);
 extern SV*      my_reg_named_buff_get(pTHX_ const REGEXP * const rx, SV* namesv, U32 flags);
+extern SV*      my_reg_qr_pkg(pTHX_ const REGEXP * const rx);
 #if defined(USE_ITHREADS)
 extern void*   my_regdupe (pTHX_ const regexp *r, CLONE_PARAMS *param);
 #endif
@@ -40,6 +41,7 @@ const struct regexp_engine my_reg_engine = {
         my_regfree, 
         my_reg_numbered_buff_get,
         my_reg_named_buff_get,
+        my_reg_qr_pkg,
 #if defined(USE_ITHREADS)
         my_regdupe 
 #endif

diff --git a/ext/re/re_top.h b/ext/re/re_top.h
index 7f53a74..39e0276 100644 (file)
--- a/ext/re/re_top.h
+++ b/ext/re/re_top.h
@@ -18,6 +18,7 @@
 #define Perl_regdupe_internal   my_regdupe
 #define Perl_reg_numbered_buff_get  my_reg_numbered_buff_get
 #define Perl_reg_named_buff_get  my_reg_named_buff_get
+#define Perl_reg_qr_pkg  my_reg_qr_pkg
 
 #define PERL_NO_GET_CONTEXT
 

diff --git a/global.sym b/global.sym
index 3ac17bc..57405d0 100644 (file)
--- a/global.sym
+++ b/global.sym
@@ -407,6 +407,7 @@ Perl_regexec_flags
 Perl_regnext
 Perl_reg_named_buff_get
 Perl_reg_numbered_buff_get
+Perl_reg_qr_pkg
 Perl_repeatcpy
 Perl_rninstr
 Perl_rsignal

diff --git a/perl.h b/perl.h
index d7d4f64..452b70d 100644 (file)
--- a/perl.h
+++ b/perl.h
@@ -225,6 +225,8 @@
 #define CALLREG_NAMEDBUF(rx,name,flags) \
     CALL_FPTR((rx)->engine->named_buff_get)(aTHX_ (rx),(name),(flags))
 
+#define CALLREG_QRPKG(rx) \
+    CALL_FPTR((rx)->engine->qr_pkg)(aTHX_ (rx))
 
 #if defined(USE_ITHREADS)         
 #define CALLREGDUPE(prog,param) \

diff --git a/pp_hot.c b/pp_hot.c
index 9e47946..9d0cf95 100644 (file)
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -1178,12 +1178,13 @@ PP(pp_qr)
 {
     dVAR; dSP;
     register PMOP * const pm = cPMOP;
+    REGEXP * rx = PM_GETRE(pm);
+    SV * const pkg = CALLREG_QRPKG(rx);
     SV * const rv = sv_newmortal();
-    SV * const sv = newSVrv(rv, "Regexp");
-    regexp *re = PM_GETRE(pm);
-    if (re->extflags & RXf_TAINTED)
+    SV * const sv = newSVrv(rv, SvPV_nolen(pkg));
+    if (rx->extflags & RXf_TAINTED)
         SvTAINTED_on(rv);
-    sv_magic(sv,(SV*)ReREFCNT_inc(re), PERL_MAGIC_qr,0,0);
+    sv_magic(sv,(SV*)ReREFCNT_inc(rx), PERL_MAGIC_qr,0,0);
     XPUSHs(rv);
     RETURN;
 }

diff --git a/proto.h b/proto.h
index a59cdd4..2fa2a0c 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -1902,6 +1902,9 @@ PERL_CALLCONV SV* Perl_reg_named_buff_get(pTHX_ const REGEXP * const rx, SV* nam
 PERL_CALLCONV SV*      Perl_reg_numbered_buff_get(pTHX_ const REGEXP * const rx, I32 paren, SV* usesv)
                        __attribute__nonnull__(pTHX_1);
 
+PERL_CALLCONV SV*      Perl_reg_qr_pkg(pTHX_ const REGEXP * const rx)
+                       __attribute__nonnull__(pTHX_1);
+
 
 PERL_CALLCONV void     Perl_regprop(pTHX_ const regexp *prog, SV* sv, const regnode* o)
                        __attribute__nonnull__(pTHX_2)

diff --git a/regcomp.c b/regcomp.c
index ae9efbf..2cf97ec 100644 (file)
--- a/regcomp.c
+++ b/regcomp.c
@@ -4836,6 +4836,12 @@ Perl_reg_numbered_buff_get(pTHX_ const REGEXP * const rx, I32 paren, SV* usesv)
     return sv;
 }
 
+SV*
+Perl_reg_qr_pkg(pTHX_ const REGEXP * const rx)
+{
+       PERL_UNUSED_ARG(rx);
+       return newSVpvs("Regexp");
+}
 
 /* Scans the name of a named buffer from the pattern.
  * If flags is REG_RSN_RETURN_NULL returns null.

diff --git a/regcomp.h b/regcomp.h
index a13d487..1a0916a 100644 (file)
--- a/regcomp.h
+++ b/regcomp.h
@@ -453,13 +453,14 @@ EXTCONST U8 PL_simple[] = {
 EXTCONST regexp_engine PL_core_reg_engine;
 #else /* DOINIT */
 EXTCONST regexp_engine PL_core_reg_engine = { 
-       Perl_re_compile,
+        Perl_re_compile,
         Perl_regexec_flags, 
         Perl_re_intuit_start,
         Perl_re_intuit_string, 
         Perl_regfree_internal, 
         Perl_reg_numbered_buff_get,
         Perl_reg_named_buff_get,
+        Perl_reg_qr_pkg,
 #if defined(USE_ITHREADS)        
         Perl_regdupe_internal
 #endif        

diff --git a/regexp.h b/regexp.h
index fb723b3..a833c6b 100644 (file)
--- a/regexp.h
+++ b/regexp.h
@@ -123,6 +123,7 @@ typedef struct regexp_engine {
     void    (*free) (pTHX_ struct regexp* r);
     SV*     (*numbered_buff_get) (pTHX_ const REGEXP * const rx, I32 paren, SV* usesv);
     SV*     (*named_buff_get)(pTHX_ const REGEXP * const rx, SV* namesv, U32 flags);
+    SV*     (*qr_pkg)(pTHX_ const REGEXP * const rx);
 #ifdef USE_ITHREADS
     void* (*dupe) (pTHX_ const regexp *r, CLONE_PARAMS *param);
 #endif