summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--embed.fnc1
-rw-r--r--embed.h2
-rw-r--r--ext/re/re.xs2
-rw-r--r--ext/re/re_top.h1
-rw-r--r--global.sym1
-rw-r--r--perl.h2
-rw-r--r--pp_hot.c9
-rw-r--r--proto.h3
-rw-r--r--regcomp.c6
-rw-r--r--regcomp.h3
-rw-r--r--regexp.h1
11 files changed, 26 insertions, 5 deletions
diff --git a/embed.fnc b/embed.fnc
index 679b443df4..eb7817ee6c 100644
--- 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 a41de9db2a..182afca6d4 100644
--- 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 5ab5f7c095..aa87bb688c 100644
--- 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 7f53a74631..39e02768de 100644
--- 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 3ac17bc029..57405d0791 100644
--- 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 d7d4f64f92..452b70de48 100644
--- 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 9e47946941..9d0cf95350 100644
--- 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 a59cdd4738..2fa2a0c3c6 100644
--- 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 ae9efbf53a..2cf97ecc21 100644
--- 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 a13d487535..1a0916adb0 100644
--- 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 fb723b3e5f..a833c6b2b1 100644
--- 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
View Lorry Controller Status