mirror/perl
1
0
Fork 0
mirror of https://github.com/Perl/perl5.git synced 2026-01-26 16:39:36 +00:00
Code Issues Packages Projects Releases Wiki Activity

cop.h - get rid of the STRLEN* stuff from cop_warnings

Browse Source 
With RCPV strings we can use the RCPV_LEN() macro, and
make this logic a little less weird.
This commit is contained in:
Yves Orton 2022-11-01 15:31:24 +01:00
parent f0774ef1d0
commit f8552c1a7e
15 changed files with 46 additions and 68 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

19
cop.h
View File

@ -446,18 +446,13 @@ struct cop {
#endif
U32 cop_hints; /* hints bits from pragmata */
U32 cop_seq; /* parse sequence number */
/* Beware. mg.c and warnings.pl assume the type of this is STRLEN *: */
STRLEN * cop_warnings; /* Lexical warnings bitmask vector.
Munged copy of ${^WARNING_BITS}.
This is not actually an array of STRLEN,
it is a STRLEN followed by a certain
number of bytes, as determined by the
initial STRLEN. The pointer is either
to constant storage, or it is a rcpv
(refcounted string) style pointer similar
to cop_file under threads. The value
is read-only as it is shared amongst
many COP structures */
char * cop_warnings; /* Lexical warnings bitmask vector.
Refcounted shared copy of ${^WARNING_BITS}.
This pointer either points at one of the
magic values for warnings, or it points
at a buffer constructed with rcpv_new().
Use the RCPV_LEN() macro to get its length.
*/
/* compile time state of %^H. See the comment in op.c for how this is
used to recreate a hash to return from caller. */
COPHH * cop_hints_hash;

4
embed.fnc
View File

@ -3725,7 +3725,7 @@ S |bool |ckwarn_common |U32 w
CpoP |bool |ckwarn |U32 w
CpoP |bool |ckwarn_d |U32 w
: FIXME - exported for ByteLoader - public or private?
XEopxR |STRLEN *|new_warnings_bitfield|NULLOK STRLEN *buffer \
XEopxR |char *|new_warnings_bitfield|NULLOK char *buffer \
|NN const char *const bits|STRLEN size
AMpTdf |int |my_snprintf |NN char *buffer|const Size_t len|NN const char *format|...
@ -3883,7 +3883,7 @@ XEop |void |dtrace_probe_op |NN const OP *op
XEop |void |dtrace_probe_phase|enum perl_phase phase
#endif
XEop |STRLEN*|dup_warnings |NULLOK STRLEN* warnings
XEop |char *|dup_warnings |NULLOK char* warnings
#ifndef USE_ITHREADS
Amd |void |CopFILEGV_set |NN COP * c|NN GV * gv

4
ext/B/B.xs
View File

@ -188,7 +188,7 @@ make_temp_object(pTHX_ SV *temp)
static SV *
make_warnings_object(pTHX_ const COP *const cop)
{
const STRLEN *const warnings = cop->cop_warnings;
const char *const warnings = cop->cop_warnings;
const char *type = 0;
dMY_CXT;
IV iv = sizeof(specialsv_list)/sizeof(SV*);
@ -210,7 +210,7 @@ make_warnings_object(pTHX_ const COP *const cop)
} else {
/* B assumes that warnings are a regular SV. Seems easier to keep it
happy by making them into a regular SV. */
return make_temp_object(aTHX_ newSVpvn((char *)(warnings + 1), *warnings));
return make_temp_object(aTHX_ newSVpvn(warnings, RCPV_LEN(warnings)));
}
}

2
lib/warnings.pm generated
View File

@ -5,7 +5,7 @@
package warnings;
our $VERSION = "1.60";
our $VERSION = "1.61";
# Verify that we're called correctly so that warnings will work.
# Can't use Carp, since Carp uses us!

4
mg.c
View File

@ -1082,8 +1082,8 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
sv_setpvn(sv, WARN_ALLstring, WARNsize);
}
else {
sv_setpvn(sv, (char *) (PL_compiling.cop_warnings + 1),
*PL_compiling.cop_warnings);
sv_setpvn(sv, PL_compiling.cop_warnings,
RCPV_LEN(PL_compiling.cop_warnings));
}
}
break;

8
op.c
View File

@ -1331,7 +1331,7 @@ S_cop_free(pTHX_ COP* cop)
}
CopFILE_free(cop);
if (! specialWARN(cop->cop_warnings))
cop->cop_warnings = (STRLEN*)rcpv_free((char*)cop->cop_warnings);
cop->cop_warnings = rcpv_free(cop->cop_warnings);
cophh_free(CopHINTHASH_get(cop));
if (PL_curcop == cop)
@ -15230,13 +15230,13 @@ const_av_xsub(pTHX_ CV* cv)
* This is the e implementation for the DUP_WARNINGS() macro
*/
STRLEN*
Perl_dup_warnings(pTHX_ STRLEN* warnings)
char *
Perl_dup_warnings(pTHX_ char* warnings)
{
if (warnings == NULL || specialWARN(warnings))
return warnings;
return (STRLEN*)rcpv_copy((char*)warnings);
return rcpv_copy(warnings);
}
/*

4
perl.h
View File

@ -5405,9 +5405,9 @@ Indices outside the range 0..31 result in (bad) undedefined behavior.
EXTCONST char PL_hexdigit[]
INIT("0123456789abcdef0123456789ABCDEF");
EXTCONST STRLEN PL_WARN_ALL
EXT char PL_WARN_ALL
INIT(0);
EXTCONST STRLEN PL_WARN_NONE
EXT char PL_WARN_NONE
INIT(0);
/* This is constant on most architectures, a global on OS/2 */

4
pp_ctl.c
View File

@ -2074,7 +2074,7 @@ PP(pp_caller)
mPUSHi(CopHINTS_get(cx->blk_oldcop));
{
SV * mask ;
STRLEN * const old_warnings = cx->blk_oldcop->cop_warnings ;
char *old_warnings = cx->blk_oldcop->cop_warnings;
if (old_warnings == pWARN_NONE)
mask = newSVpvn(WARN_NONEstring, WARNsize) ;
@ -2085,7 +2085,7 @@ PP(pp_caller)
mask = newSVpvn(WARN_ALLstring, WARNsize) ;
}
else
mask = newSVpvn((char *) (old_warnings + 1), old_warnings[0]);
mask = newSVpvn(old_warnings, RCPV_LEN(old_warnings));
mPUSHs(mask);
}

4
proto.h
View File

@ -1219,7 +1219,7 @@ PERL_CALLCONV void Perl_dump_sub_perl(pTHX_ const GV* gv, bool justperl)
PERL_CALLCONV void Perl_dump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args);
#define PERL_ARGS_ASSERT_DUMP_VINDENT \
assert(file); assert(pat)
PERL_CALLCONV STRLEN* Perl_dup_warnings(pTHX_ STRLEN* warnings);
PERL_CALLCONV char * Perl_dup_warnings(pTHX_ char* warnings);
#define PERL_ARGS_ASSERT_DUP_WARNINGS
PERL_CALLCONV void Perl_emulate_cop_io(pTHX_ const COP *const c, SV *const sv);
#define PERL_ARGS_ASSERT_EMULATE_COP_IO \
@ -2954,7 +2954,7 @@ PERL_CALLCONV PERL_SI* Perl_new_stackinfo(pTHX_ I32 stitems, I32 cxitems)
PERL_CALLCONV SV* Perl_new_version(pTHX_ SV *ver);
#define PERL_ARGS_ASSERT_NEW_VERSION \
assert(ver)
PERL_CALLCONV STRLEN * Perl_new_warnings_bitfield(pTHX_ STRLEN *buffer, const char *const bits, STRLEN size)
PERL_CALLCONV char * Perl_new_warnings_bitfield(pTHX_ char *buffer, const char *const bits, STRLEN size)
__attribute__warn_unused_result__;
#define PERL_ARGS_ASSERT_NEW_WARNINGS_BITFIELD \
assert(bits)

15
regen/warnings.pl
View File

@ -16,7 +16,7 @@
#
# This script is normally invoked from regen.pl.
$VERSION = '1.60';
$VERSION = '1.61';
BEGIN {
require './regen/regen_lib.pl';
@ -541,7 +541,6 @@ sub warnings_h_boilerplate_1 { return <<'EOM'; }
#define Perl_Warn_Bit_(x) (1 << ((x) % 8))
#define PerlWarnIsSet_(a, x) ((a)[Perl_Warn_Off_(x)] & Perl_Warn_Bit_(x))
#define G_WARN_OFF 0 /* $^W == 0 */
#define G_WARN_ON 1 /* -w flag and $^W != 0 */
#define G_WARN_ALL_ON 2 /* -W flag */
@ -550,8 +549,8 @@ sub warnings_h_boilerplate_1 { return <<'EOM'; }
#define G_WARN_ALL_MASK (G_WARN_ALL_ON|G_WARN_ALL_OFF)
#define pWARN_STD NULL
#define pWARN_ALL (STRLEN *) &PL_WARN_ALL /* use warnings 'all' */
#define pWARN_NONE (STRLEN *) &PL_WARN_NONE /* no warnings 'all' */
#define pWARN_ALL &PL_WARN_ALL /* use warnings 'all' */
#define pWARN_NONE &PL_WARN_NONE /* no warnings 'all' */
#define specialWARN(x) ((x) == pWARN_STD || (x) == pWARN_ALL || \
(x) == pWARN_NONE)
@ -569,18 +568,18 @@ sub warnings_h_boilerplate_2 { return <<'EOM'; }
#define isLEXWARN_off \
cBOOL(!PL_curcop || PL_curcop->cop_warnings == pWARN_STD)
#define isWARN_ONCE (PL_dowarn & (G_WARN_ON|G_WARN_ONCE))
#define hasWARNBIT(c,x) ((c)[0] > (2*(x)/8))
#define hasWARNBIT(c,x) (RCPV_LEN(c) > (2*(x)/8))
#define isWARN_on(c,x) (hasWARNBIT(c,x) \
? PerlWarnIsSet_((U8 *)((c) + 1), 2*(x)) \
? PerlWarnIsSet_((U8 *)(c), 2*(x)) \
: 0)
#define isWARNf_on(c,x) (hasWARNBIT(c,x) \
? PerlWarnIsSet_((U8 *)((c) + 1), 2*(x)+1) \
? PerlWarnIsSet_((U8 *)(c), 2*(x)+1) \
: 0)
#define DUP_WARNINGS(p) Perl_dup_warnings(aTHX_ p)
#define free_and_set_cop_warnings(cmp,w) STMT_START { \
if (!specialWARN((cmp)->cop_warnings)) rcpv_free((char*)((cmp)->cop_warnings)); \
if (!specialWARN((cmp)->cop_warnings)) rcpv_free((cmp)->cop_warnings); \
(cmp)->cop_warnings = w; \
} STMT_END

2
scope.c
View File

@ -1640,7 +1640,7 @@ Perl_leave_scope(pTHX_ I32 base)
case SAVEt_COMPILE_WARNINGS:
a0 = ap[0]; a1 = ap[1];
free_and_set_cop_warnings((COP*)a0.any_ptr, (STRLEN*)a1.any_ptr);
free_and_set_cop_warnings((COP*)a0.any_ptr, a1.any_pv);
break;
case SAVEt_PARSER:

2
sv.c
View File

@ -15336,7 +15336,7 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param)
break;
case SAVEt_COMPILE_WARNINGS:
ptr = POPPTR(ss,ix);
TOPPTR(nss,ix) = DUP_WARNINGS((STRLEN*)ptr);
TOPPTR(nss,ix) = DUP_WARNINGS((char*)ptr);
break;
case SAVEt_PARSER:
ptr = POPPTR(ss,ix);

14
utf8.c
View File

@ -45,17 +45,6 @@ characters in the ASCII range are unmodified, and a zero byte never appears
within non-zero characters.
*/
/* helper for Perl__force_out_malformed_utf8_message(). Like
* SAVECOMPILEWARNINGS(), but works with PL_curcop rather than
* PL_compiling */
static void
S_restore_cop_warnings(pTHX_ void *p)
{
free_and_set_cop_warnings(PL_curcop, (STRLEN*) p);
}
void
Perl__force_out_malformed_utf8_message(pTHX_
const U8 *const p, /* First byte in UTF-8 sequence */
@ -89,8 +78,7 @@ Perl__force_out_malformed_utf8_message(pTHX_
if (PL_curcop) {
/* this is like SAVECOMPILEWARNINGS() except with PL_curcop rather
* than PL_compiling */
SAVEDESTRUCTOR_X(S_restore_cop_warnings,
(void*)PL_curcop->cop_warnings);
SAVECOPWARNINGS(PL_curcop);
PL_curcop->cop_warnings = pWARN_ALL;
}

15
util.c
View File

@ -2382,20 +2382,17 @@ S_ckwarn_common(pTHX_ U32 w)
return FALSE;
}
/* Set buffer=NULL to get a new one. */
STRLEN *
Perl_new_warnings_bitfield(pTHX_ STRLEN *buffer, const char *const bits,
char *
Perl_new_warnings_bitfield(pTHX_ char *buffer, const char *const bits,
STRLEN size) {
const MEM_SIZE len_wanted =
sizeof(STRLEN) + (size > WARNsize ? size : WARNsize);
const MEM_SIZE len_wanted = (size > WARNsize ? size : WARNsize);
PERL_UNUSED_CONTEXT;
PERL_ARGS_ASSERT_NEW_WARNINGS_BITFIELD;
buffer = (STRLEN*)rcpv_new(NULL, len_wanted, RCPVf_NO_COPY);
buffer[0] = size;
Copy(bits, (buffer + 1), size, char);
buffer = rcpv_new(buffer, len_wanted, RCPVf_NO_COPY);
Copy(bits, buffer, size, char);
if (size < WARNsize)
Zero((char *)(buffer + 1) + size, WARNsize - size, char);
Zero(buffer + size, WARNsize - size, char);
return buffer;
}

13
warnings.h generated
View File

@ -9,7 +9,6 @@
#define Perl_Warn_Bit_(x) (1 << ((x) % 8))
#define PerlWarnIsSet_(a, x) ((a)[Perl_Warn_Off_(x)] & Perl_Warn_Bit_(x))
#define G_WARN_OFF 0 /* $^W == 0 */
#define G_WARN_ON 1 /* -w flag and $^W != 0 */
#define G_WARN_ALL_ON 2 /* -W flag */
@ -18,8 +17,8 @@
#define G_WARN_ALL_MASK (G_WARN_ALL_ON|G_WARN_ALL_OFF)
#define pWARN_STD NULL
#define pWARN_ALL (STRLEN *) &PL_WARN_ALL /* use warnings 'all' */
#define pWARN_NONE (STRLEN *) &PL_WARN_NONE /* no warnings 'all' */
#define pWARN_ALL &PL_WARN_ALL /* use warnings 'all' */
#define pWARN_NONE &PL_WARN_NONE /* no warnings 'all' */
#define specialWARN(x) ((x) == pWARN_STD || (x) == pWARN_ALL || \
(x) == pWARN_NONE)
@ -141,18 +140,18 @@
#define isLEXWARN_off \
cBOOL(!PL_curcop || PL_curcop->cop_warnings == pWARN_STD)
#define isWARN_ONCE (PL_dowarn & (G_WARN_ON|G_WARN_ONCE))
#define hasWARNBIT(c,x) ((c)[0] > (2*(x)/8))
#define hasWARNBIT(c,x) (RCPV_LEN(c) > (2*(x)/8))
#define isWARN_on(c,x) (hasWARNBIT(c,x) \
? PerlWarnIsSet_((U8 *)((c) + 1), 2*(x)) \
? PerlWarnIsSet_((U8 *)(c), 2*(x)) \
: 0)
#define isWARNf_on(c,x) (hasWARNBIT(c,x) \
? PerlWarnIsSet_((U8 *)((c) + 1), 2*(x)+1) \
? PerlWarnIsSet_((U8 *)(c), 2*(x)+1) \
: 0)
#define DUP_WARNINGS(p) Perl_dup_warnings(aTHX_ p)
#define free_and_set_cop_warnings(cmp,w) STMT_START { \
if (!specialWARN((cmp)->cop_warnings)) rcpv_free((char*)((cmp)->cop_warnings)); \
if (!specialWARN((cmp)->cop_warnings)) rcpv_free((cmp)->cop_warnings); \
(cmp)->cop_warnings = w; \
} STMT_END