return; /* various ok barewords are hidden in extra OP_NULL */
qerror(Perl_mess(aTHX_
"Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
- cSVOPo_sv));
+ (void*)cSVOPo_sv));
}
/* "register" allocation */
p = strchr(name, '\0');
/* The next block assumes the buffer is at least 205 chars
long. At present, it's always at least 256 chars. */
- if (p-name > 200) {
- strcpy(name+200, "...");
- p = name+199;
+ if (p - name > 200) {
+#ifdef HAS_STRLCPY
+ strlcpy(name + 200, "...", 4);
+#else
+ strcpy(name + 200, "...");
+#endif
+ p = name + 199;
}
else {
p[1] = '\0';
PerlMemShared_free(cop->cop_warnings);
if (! specialCopIO(cop->cop_io)) {
#ifdef USE_ITHREADS
- /*EMPTY*/
+ NOOP;
#else
SvREFCNT_dec(cop->cop_io);
#endif
/* Don't force the C<use> if we don't need it. */
SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
if (svp && *svp != &PL_sv_undef)
- /*EMPTY*/; /* already in %INC */
+ NOOP; /* already in %INC */
else
Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
newSVpvs(ATTRSMODULE), NULL);
S_newDEFSVOP(pTHX)
{
dVAR;
- const I32 offset = pad_findmy("$_");
+ const PADOFFSET offset = pad_findmy("$_");
if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
}
#if 0
list(o);
#else
- /*EMPTY*/;
+ NOOP;
#endif
else {
if ( PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ','
repl_has_vars = 1;
}
else if (curop->op_type == OP_PUSHRE)
- /*EMPTY*/; /* Okay here, dangerous in newASSIGNOP */
+ NOOP; /* Okay here, dangerous in newASSIGNOP */
else
break;
}
iterpflags |= OPpITER_DEF;
}
else {
- const I32 offset = pad_findmy("$_");
+ const PADOFFSET offset = pad_findmy("$_");
if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
sv = newGVOP(OP_GV, 0, PL_defgv);
}
gv_efullname3(name = sv_newmortal(), gv, NULL);
sv_setpv(msg, "Prototype mismatch:");
if (name)
- Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
+ Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, (void*)name);
if (SvPOK(cv))
- Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (const SV *)cv);
+ Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (void*)cv);
else
sv_catpvs(msg, ": none");
sv_catpvs(msg, " vs ");
Perl_sv_catpvf(aTHX_ msg, "(%.*s)", (int) len, p);
else
sv_catpvs(msg, "none");
- Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, msg);
+ Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, (void*)msg);
}
}
else {
/* force display of errors found but not reported */
sv_catpv(ERRSV, not_safe);
- Perl_croak(aTHX_ "%"SVf, ERRSV);
+ Perl_croak(aTHX_ "%"SVf, (void*)ERRSV);
}
}
}
/* file becomes the CvFILE. For an XS, it's supposed to be static storage,
and so doesn't get free()d. (It's expected to be from the C pre-
processor __FILE__ directive). But we need a dynamically allocated one,
- and we need it to get freed. So we cheat, and take advantage of the
- fact that the first 0 bytes of any string always look the same. */
- cv = newXS(name, const_sv_xsub, file);
+ and we need it to get freed. */
+ cv = newXS_flags(name, const_sv_xsub, file, "", XS_DYNAMIC_FILENAME);
CvXSUBANY(cv).any_ptr = sv;
CvCONST_on(cv);
- /* prototype is "". But this gets free()d. :-) */
- sv_usepvn_flags((SV*)cv, file, len, SV_HAS_TRAILING_NUL);
- /* This gives us a prototype of "", rather than the file name. */
- SvCUR_set(cv, 0);
#ifdef USE_ITHREADS
if (stash)
return cv;
}
+CV *
+Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
+ const char *const filename, const char *const proto,
+ U32 flags)
+{
+ CV *cv = newXS(name, subaddr, filename);
+
+ if (flags & XS_DYNAMIC_FILENAME) {
+ /* We need to "make arrangements" (ie cheat) to ensure that the
+ filename lasts as long as the PVCV we just created, but also doesn't
+ leak */
+ STRLEN filename_len = strlen(filename);
+ STRLEN proto_and_file_len = filename_len;
+ char *proto_and_file;
+ STRLEN proto_len;
+
+ if (proto) {
+ proto_len = strlen(proto);
+ proto_and_file_len += proto_len;
+
+ Newx(proto_and_file, proto_and_file_len + 1, char);
+ Copy(proto, proto_and_file, proto_len, char);
+ Copy(filename, proto_and_file + proto_len, filename_len + 1, char);
+ } else {
+ proto_len = 0;
+ proto_and_file = savepvn(filename, filename_len);
+ }
+
+ /* This gets free()d. :-) */
+ sv_usepvn_flags((SV*)cv, proto_and_file, proto_and_file_len,
+ SV_HAS_TRAILING_NUL);
+ if (proto) {
+ /* This gives us the correct prototype, rather than one with the
+ file name appended. */
+ SvCUR_set(cv, proto_len);
+ } else {
+ SvPOK_off(cv);
+ }
+ } else {
+ sv_setpv((SV *)cv, proto);
+ }
+ return cv;
+}
+
/*
=for apidoc U||newXS
-Used by C<xsubpp> to hook up XSUBs as Perl subs.
+Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
+static storage, as it is used directly as CvFILE(), without a copy being made.
=cut
*/
CopLINE_set(PL_curcop, PL_copline);
Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
o ? "Format %"SVf" redefined"
- : "Format STDOUT redefined" ,cSVOPo->op_sv);
+ : "Format STDOUT redefined", (void*)cSVOPo->op_sv);
CopLINE_set(PL_curcop, oldline);
}
SvREFCNT_dec(cv);
}
if (badthing)
Perl_croak(aTHX_
- "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
- kidsv, badthing);
+ "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
+ (void*)kidsv, badthing);
}
/*
* This is a little tricky. We only want to add the symbol if we
const I32 type = o->op_type;
if (o->op_flags & OPf_REF) {
- /*EMPTY*/;
+ NOOP;
}
else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
SVOP * const kid = (SVOP*)cUNOPo->op_first;
if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
"Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
- ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
+ (void*)((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
#ifdef PERL_MAD
op_getmad(kid,newop,'K');
#else
if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
"Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
- ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
+ (void*)((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
#ifdef PERL_MAD
op_getmad(kid,newop,'K');
#else
LOGOP *gwop = NULL;
OP *kid;
const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
- I32 offset;
+ PADOFFSET offset;
o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
/* don't allocate gwop here, as we may leak it if PL_error_count > 0 */
{
dVAR;
if (o->op_type != OP_QR && PL_compcv) {
- const I32 offset = pad_findmy("$_");
+ const PADOFFSET offset = pad_findmy("$_");
if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
o->op_targ = offset;
o->op_private |= OPpTARGET_MY;
default:
oops:
Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
- gv_ename(namegv), cv);
+ gv_ename(namegv), (void*)cv);
}
}
else
gv_efullname3(sv, gv, NULL);
Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
"%"SVf"() called too early to check prototype",
- sv);
+ (void*)sv);
}
}
else if (o->op_next->op_type == OP_READLINE
if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
key = SvPV_const(sv, keylen);
lexname = newSVpvn_share(key,
- SvUTF8(sv) ? -(I32)keylen : keylen,
+ SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
0);
SvREFCNT_dec(sv);
*svp = lexname;
break;
key = SvPV_const(*svp, keylen);
if (!hv_fetch(GvHV(*fields), key,
- SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
+ SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
{
Perl_croak(aTHX_ "No such class field \"%s\" "
"in variable %s of type %s",
svp = cSVOPx_svp(key_op);
key = SvPV_const(*svp, keylen);
if (!hv_fetch(GvHV(*fields), key,
- SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
+ SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
{
Perl_croak(aTHX_ "No such class field \"%s\" "
"in variable %s of type %s",
dVAR;
dXSARGS;
if (items != 0) {
- /*EMPTY*/;
+ NOOP;
#if 0
Perl_croak(aTHX_ "usage: %s::%s()",
HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));