summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--cop.h3
-rw-r--r--embed.fnc2
-rw-r--r--embed.h2
-rw-r--r--mg.c18
-rw-r--r--op.c16
-rw-r--r--perl.c9
-rw-r--r--pp_ctl.c21
-rw-r--r--proto.h5
-rw-r--r--scope.c15
-rw-r--r--scope.h21
-rw-r--r--sv.c3
-rw-r--r--util.c13
-rw-r--r--warnings.h12
-rw-r--r--warnings.pl12
14 files changed, 107 insertions, 45 deletions
diff --git a/cop.h b/cop.h
index fc69b916fe..a6749a06fa 100644
--- a/cop.h
+++ b/cop.h
@@ -146,7 +146,8 @@ struct cop {
U32 cop_seq; /* parse sequence number */
I32 cop_arybase; /* array base this line was compiled with */
line_t cop_line; /* line # of this command */
- SV * cop_warnings; /* lexical warnings bitmask */
+ /* Beware. mg.c and warnings.pl assume the type of this is STRLEN *: */
+ STRLEN * cop_warnings; /* lexical warnings bitmask */
SV * cop_io; /* lexical IO defaults */
/* compile time state of %^H. See the comment in op.c for how this is
used to recreate a hash to return from caller. */
diff --git a/embed.fnc b/embed.fnc
index 4d038e400e..954400710b 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -1666,6 +1666,8 @@ Ap |GV* |gv_SVadd |NN GV* gv
#endif
Apo |bool |ckwarn |U32 w
Apo |bool |ckwarn_d |U32 w
+nopMa |STRLEN *|new_warnings_bitfield|NULLOK STRLEN *buffer \
+ |NN const char *const bits|STRLEN size
p |void |offer_nice_chunk |NN void *chunk|U32 chunk_size
diff --git a/embed.h b/embed.h
index cfb43feee0..1f8d310e13 100644
--- a/embed.h
+++ b/embed.h
@@ -3907,6 +3907,8 @@
#define gv_SVadd(a) Perl_gv_SVadd(aTHX_ a)
#endif
#ifdef PERL_CORE
+#endif
+#ifdef PERL_CORE
#define offer_nice_chunk(a,b) Perl_offer_nice_chunk(aTHX_ a,b)
#endif
#ifndef SPRINTF_RETURNS_STRLEN
diff --git a/mg.c b/mg.c
index c0ebd1b6a5..19219026f5 100644
--- a/mg.c
+++ b/mg.c
@@ -826,7 +826,8 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
}
}
else {
- sv_setsv(sv, PL_compiling.cop_warnings);
+ sv_setpvn(sv, (char *) (PL_compiling.cop_warnings + 1),
+ *PL_compiling.cop_warnings);
}
SvPOK_only(sv);
}
@@ -2274,15 +2275,20 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
}
if (!accumulate)
PL_compiling.cop_warnings = pWARN_NONE;
- else if (isWARN_on(sv, WARN_ALL) && !any_fatals) {
+ /* Yuck. I can't see how to abstract this: */
+ else if (isWARN_on(((STRLEN *)SvPV_nolen_const(sv)) - 1,
+ WARN_ALL) && !any_fatals) {
PL_compiling.cop_warnings = pWARN_ALL;
PL_dowarn |= G_WARN_ONCE ;
}
else {
- if (specialWARN(PL_compiling.cop_warnings))
- PL_compiling.cop_warnings = newSVsv(sv) ;
- else
- sv_setsv(PL_compiling.cop_warnings, sv);
+ STRLEN len;
+ const char *const p = SvPV_const(sv, len);
+
+ PL_compiling.cop_warnings
+ = Perl_new_warnings_bitfield(PL_compiling.cop_warnings,
+ p, len);
+
if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
PL_dowarn |= G_WARN_ONCE ;
}
diff --git a/op.c b/op.c
index da99916d1f..3bb789b517 100644
--- a/op.c
+++ b/op.c
@@ -506,7 +506,7 @@ S_cop_free(pTHX_ COP* cop)
CopFILE_free(cop);
CopSTASH_free(cop);
if (! specialWARN(cop->cop_warnings))
- SvREFCNT_dec(cop->cop_warnings);
+ PerlMemShared_free(cop->cop_warnings);
if (! specialCopIO(cop->cop_io)) {
#ifdef USE_ITHREADS
/*EMPTY*/
@@ -1974,7 +1974,7 @@ Perl_scope(pTHX_ OP *o)
}
return o;
}
-
+
int
Perl_block_start(pTHX_ int full)
{
@@ -1983,11 +1983,8 @@ Perl_block_start(pTHX_ int full)
pad_block_start(full);
SAVEHINTS();
PL_hints &= ~HINT_BLOCK_SCOPE;
- SAVESPTR(PL_compiling.cop_warnings);
- if (! specialWARN(PL_compiling.cop_warnings)) {
- PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
- SAVEFREESV(PL_compiling.cop_warnings) ;
- }
+ SAVECOPWARNINGS(&PL_compiling);
+ PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
SAVESPTR(PL_compiling.cop_io);
if (! specialCopIO(PL_compiling.cop_io)) {
PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
@@ -3946,10 +3943,7 @@ Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
}
cop->cop_seq = seq;
CopARYBASE_set(cop, CopARYBASE_get(PL_curcop));
- if (specialWARN(PL_curcop->cop_warnings))
- cop->cop_warnings = PL_curcop->cop_warnings ;
- else
- cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
+ cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
if (specialCopIO(PL_curcop->cop_io))
cop->cop_io = PL_curcop->cop_io;
else
diff --git a/perl.c b/perl.c
index bd667eee7b..83baacea04 100644
--- a/perl.c
+++ b/perl.c
@@ -1035,7 +1035,7 @@ perl_destruct(pTHXx)
PL_utf8_idcont = NULL;
if (!specialWARN(PL_compiling.cop_warnings))
- SvREFCNT_dec(PL_compiling.cop_warnings);
+ PerlMemShared_free(PL_compiling.cop_warnings);
PL_compiling.cop_warnings = NULL;
if (!specialCopIO(PL_compiling.cop_io))
SvREFCNT_dec(PL_compiling.cop_io);
@@ -2037,7 +2037,8 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
#endif
if (PL_taint_warn && PL_dowarn != G_WARN_ALL_OFF) {
- PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
+ PL_compiling.cop_warnings
+ = Perl_new_warnings_bitfield(NULL, WARN_TAINTstring, WARNsize);
}
if (!scriptname)
@@ -3369,14 +3370,14 @@ Internet, point your browser at http://www.perl.org/, the Perl Home Page.\n\n");
case 'W':
PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
if (!specialWARN(PL_compiling.cop_warnings))
- SvREFCNT_dec(PL_compiling.cop_warnings);
+ PerlMemShared_free(PL_compiling.cop_warnings);
PL_compiling.cop_warnings = pWARN_ALL ;
s++;
return s;
case 'X':
PL_dowarn = G_WARN_ALL_OFF;
if (!specialWARN(PL_compiling.cop_warnings))
- SvREFCNT_dec(PL_compiling.cop_warnings);
+ PerlMemShared_free(PL_compiling.cop_warnings);
PL_compiling.cop_warnings = pWARN_NONE ;
s++;
return s;
diff --git a/pp_ctl.c b/pp_ctl.c
index 0cb37874c2..19c2ac5fa7 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -1698,7 +1698,7 @@ PP(pp_caller)
PUSHs(sv_2mortal(newSViv(CopHINTS_get(cx->blk_oldcop))));
{
SV * mask ;
- SV * const old_warnings = cx->blk_oldcop->cop_warnings ;
+ STRLEN * const old_warnings = cx->blk_oldcop->cop_warnings ;
if (old_warnings == pWARN_NONE ||
(old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
@@ -1717,7 +1717,7 @@ PP(pp_caller)
}
}
else
- mask = newSVsv(old_warnings);
+ mask = newSVpvn((char *) (old_warnings + 1), old_warnings[0]);
PUSHs(sv_2mortal(mask));
}
@@ -3363,13 +3363,15 @@ PP(pp_require)
PL_rsfp = tryrsfp;
SAVEHINTS();
PL_hints = 0;
- SAVESPTR(PL_compiling.cop_warnings);
+ SAVECOPWARNINGS(&PL_compiling);
if (PL_dowarn & G_WARN_ALL_ON)
PL_compiling.cop_warnings = pWARN_ALL ;
else if (PL_dowarn & G_WARN_ALL_OFF)
PL_compiling.cop_warnings = pWARN_NONE ;
- else if (PL_taint_warn)
- PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
+ else if (PL_taint_warn) {
+ PL_compiling.cop_warnings
+ = Perl_new_warnings_bitfield(NULL, WARN_TAINTstring, WARNsize);
+ }
else
PL_compiling.cop_warnings = pWARN_STD ;
SAVESPTR(PL_compiling.cop_io);
@@ -3461,13 +3463,8 @@ PP(pp_entereval)
PL_hints = PL_op->op_targ;
if (saved_hh)
GvHV(PL_hintgv) = saved_hh;
- SAVESPTR(PL_compiling.cop_warnings);
- if (specialWARN(PL_curcop->cop_warnings))
- PL_compiling.cop_warnings = PL_curcop->cop_warnings;
- else {
- PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
- SAVEFREESV(PL_compiling.cop_warnings);
- }
+ SAVECOPWARNINGS(&PL_compiling);
+ PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
SAVESPTR(PL_compiling.cop_io);
if (specialCopIO(PL_curcop->cop_io))
PL_compiling.cop_io = PL_curcop->cop_io;
diff --git a/proto.h b/proto.h
index 6b7324216b..30f1fb04c7 100644
--- a/proto.h
+++ b/proto.h
@@ -4293,6 +4293,11 @@ PERL_CALLCONV GV* Perl_gv_SVadd(pTHX_ GV* gv)
#endif
PERL_CALLCONV bool Perl_ckwarn(pTHX_ U32 w);
PERL_CALLCONV bool Perl_ckwarn_d(pTHX_ U32 w);
+PERL_CALLCONV STRLEN * Perl_new_warnings_bitfield(STRLEN *buffer, const char *const bits, STRLEN size)
+ __attribute__malloc__
+ __attribute__warn_unused_result__
+ __attribute__nonnull__(2);
+
PERL_CALLCONV void Perl_offer_nice_chunk(pTHX_ void *chunk, U32 chunk_size)
__attribute__nonnull__(pTHX_1);
diff --git a/scope.c b/scope.c
index be926c8f11..ebea9e13e9 100644
--- a/scope.c
+++ b/scope.c
@@ -764,6 +764,10 @@ Perl_leave_scope(pTHX_ I32 base)
ptr = SSPOPPTR;
Safefree(ptr);
break;
+ case SAVEt_FREESHAREDPV:
+ ptr = SSPOPPTR;
+ PerlMemShared_free(ptr);
+ break;
case SAVEt_CLEARSV:
ptr = (void*)&PL_curpad[SSPOPLONG];
sv = *(SV**)ptr;
@@ -984,6 +988,17 @@ Perl_leave_scope(pTHX_ I32 base)
i = SSPOPINT;
CopARYBASE_set((COP *)ptr, i);
break;
+ case SAVEt_COP_WARNINGS:
+ {
+ COP *const cop = SSPOPPTR;
+ ptr = SSPOPPTR;
+
+ if (!specialWARN(cop->cop_warnings))
+ PerlMemShared_free(cop->cop_warnings);
+
+ cop->cop_warnings = ptr;
+ }
+ break;
case SAVEt_RE_STATE:
{
const struct re_save_state *const state
diff --git a/scope.h b/scope.h
index e5160e1b36..5efb8fca53 100644
--- a/scope.h
+++ b/scope.h
@@ -51,6 +51,8 @@
#define SAVEt_SAVESWITCHSTACK 40
#define SAVEt_COP_ARYBASE 41
#define SAVEt_RE_STATE 42
+#define SAVEt_FREESHAREDPV 43
+#define SAVEt_COP_WARNINGS 44
#ifndef SCOPE_SAVES_SIGNAL_MASK
#define SCOPE_SAVES_SIGNAL_MASK 0
@@ -192,6 +194,25 @@ Closing bracket on a callback. See C<ENTER> and L<perlcall>.
SSPUSHINT(SAVEt_COP_ARYBASE); \
} STMT_END
+#define SAVEFREESHAREDPV(pv) \
+ STMT_START { \
+ SSCHECK(2); \
+ SSPUSHPTR(pv); \
+ SSPUSHINT(SAVEt_FREESHAREDPV); \
+ } STMT_END
+
+/* Need to do the cop warnings like this, rather than SAVEFREESHAREDPV,
+ because realloc() means that the value can actually change. Possibly
+ could have done savefreesharedpvREF, but this way actually seems cleaner,
+ as it simplifies the code that does the saves, and reduces the load on the
+ save stack. */
+#define SAVECOPWARNINGS(c) \
+ STMT_START { \
+ SSCHECK(3); \
+ SSPUSHPTR((c)->cop_warnings); \
+ SSPUSHPTR(c); \
+ SSPUSHINT(SAVEt_COP_WARNINGS); \
+ } STMT_END
#ifdef USE_ITHREADS
# define SAVECOPSTASH(c) SAVEPPTR(CopSTASHPV(c))
diff --git a/sv.c b/sv.c
index d6135eddac..b32121addc 100644
--- a/sv.c
+++ b/sv.c
@@ -10936,8 +10936,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_file, PL_compiling.cop_file);
ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
- if (!specialWARN(PL_compiling.cop_warnings))
- PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings, param);
+ PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
if (!specialCopIO(PL_compiling.cop_io))
PL_compiling.cop_io = sv_dup_inc(PL_compiling.cop_io, param);
if (PL_compiling.cop_hints) {
diff --git a/util.c b/util.c
index b4ed7f27ad..abd0db9c80 100644
--- a/util.c
+++ b/util.c
@@ -1531,7 +1531,18 @@ Perl_ckwarn_d(pTHX_ U32 w)
;
}
-
+/* Set buffer=NULL to get a new one. */
+STRLEN *
+Perl_new_warnings_bitfield(STRLEN *buffer, const char *const bits,
+ STRLEN size) {
+ const MEM_SIZE len_wanted = sizeof(STRLEN) + size;
+
+ buffer = specialWARN(buffer) ? PerlMemShared_malloc(len_wanted)
+ : PerlMemShared_realloc(buffer, len_wanted);
+ buffer[0] = size;
+ Copy(bits, (buffer + 1), size, char);
+ return buffer;
+}
/* since we've already done strlen() for both nam and val
* we can use that info to make things faster than
diff --git a/warnings.h b/warnings.h
index 7ef3c0495c..aa830c05fe 100644
--- a/warnings.h
+++ b/warnings.h
@@ -18,8 +18,8 @@
#define G_WARN_ALL_MASK (G_WARN_ALL_ON|G_WARN_ALL_OFF)
#define pWARN_STD NULL
-#define pWARN_ALL (((SV*)0)+1) /* use warnings 'all' */
-#define pWARN_NONE (((SV*)0)+2) /* no warnings 'all' */
+#define pWARN_ALL (((STRLEN*)0)+1) /* use warnings 'all' */
+#define pWARN_NONE (((STRLEN*)0)+2) /* no warnings 'all' */
#define specialWARN(x) ((x) == pWARN_STD || (x) == pWARN_ALL || \
(x) == pWARN_NONE)
@@ -85,8 +85,12 @@
#define isLEXWARN_on (PL_curcop->cop_warnings != pWARN_STD)
#define isLEXWARN_off (PL_curcop->cop_warnings == pWARN_STD)
#define isWARN_ONCE (PL_dowarn & (G_WARN_ON|G_WARN_ONCE))
-#define isWARN_on(c,x) (IsSet(SvPVX_const(c), 2*(x)))
-#define isWARNf_on(c,x) (IsSet(SvPVX_const(c), 2*(x)+1))
+#define isWARN_on(c,x) (IsSet((U8 *)(c + 1), 2*(x)))
+#define isWARNf_on(c,x) (IsSet((U8 *)(c + 1), 2*(x)+1))
+
+#define DUP_WARNINGS(p) \
+ specialWARN(p) ? (p) \
+ : CopyD(p, PerlMemShared_malloc(sizeof(*p)+*p), sizeof(*p)+*p, char)
#define ckWARN(w) Perl_ckwarn(aTHX_ packWARN(w))
#define ckWARN2(w1,w2) Perl_ckwarn(aTHX_ packWARN2(w1,w2))
diff --git a/warnings.pl b/warnings.pl
index 126597291a..853a04a1a7 100644
--- a/warnings.pl
+++ b/warnings.pl
@@ -277,8 +277,8 @@ print WARN <<'EOM' ;
#define G_WARN_ALL_MASK (G_WARN_ALL_ON|G_WARN_ALL_OFF)
#define pWARN_STD NULL
-#define pWARN_ALL (((SV*)0)+1) /* use warnings 'all' */
-#define pWARN_NONE (((SV*)0)+2) /* no warnings 'all' */
+#define pWARN_ALL (((STRLEN*)0)+1) /* use warnings 'all' */
+#define pWARN_NONE (((STRLEN*)0)+2) /* no warnings 'all' */
#define specialWARN(x) ((x) == pWARN_STD || (x) == pWARN_ALL || \
(x) == pWARN_NONE)
@@ -325,8 +325,12 @@ print WARN <<'EOM';
#define isLEXWARN_on (PL_curcop->cop_warnings != pWARN_STD)
#define isLEXWARN_off (PL_curcop->cop_warnings == pWARN_STD)
#define isWARN_ONCE (PL_dowarn & (G_WARN_ON|G_WARN_ONCE))
-#define isWARN_on(c,x) (IsSet(SvPVX_const(c), 2*(x)))
-#define isWARNf_on(c,x) (IsSet(SvPVX_const(c), 2*(x)+1))
+#define isWARN_on(c,x) (IsSet((U8 *)(c + 1), 2*(x)))
+#define isWARNf_on(c,x) (IsSet((U8 *)(c + 1), 2*(x)+1))
+
+#define DUP_WARNINGS(p) \
+ specialWARN(p) ? (p) \
+ : CopyD(p, PerlMemShared_malloc(sizeof(*p)+*p), sizeof(*p)+*p, char)
#define ckWARN(w) Perl_ckwarn(aTHX_ packWARN(w))
#define ckWARN2(w1,w2) Perl_ckwarn(aTHX_ packWARN2(w1,w2))
View Lorry Controller Status