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;
}
cont = append_elem(OP_LINESEQ, cont, unstack);
}
+ assert(block);
listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
+ assert(listop);
redo = LINKLIST(listop);
if (expr) {
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);
}
}
void
-Perl_cv_ckproto(pTHX_ const CV *cv, const GV *gv, const char *p)
-{
- if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX_const(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
+Perl_cv_ckproto_len(pTHX_ const CV *cv, const GV *gv, const char *p,
+ const STRLEN len)
+{
+ /* Can't just use a strcmp on the prototype, as CONSTSUBs "cheat" by
+ relying on SvCUR, and doubling up the buffer to hold CvFILE(). */
+ if (((!p != !SvPOK(cv)) /* One has prototype, one has not. */
+ || (p && (len != SvCUR(cv) /* Not the same length. */
+ || memNE(p, SvPVX_const(cv), len))))
+ && ckWARN_d(WARN_PROTOTYPE)) {
SV* const msg = sv_newmortal();
SV* name = NULL;
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 ");
if (p)
- Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
+ 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);
}
}
{
Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
}
- cv_ckproto((CV*)gv, NULL, ps);
+ cv_ckproto_len((CV*)gv, NULL, ps, ps_len);
}
if (ps)
sv_setpvn((SV*)gv, ps, ps_len);
* skipping the prototype check
*/
if (exists || SvPOK(cv))
- cv_ckproto(cv, gv, ps);
+ cv_ckproto_len(cv, gv, ps, ps_len);
/* already defined (or promised)? */
if (exists || GvASSUMECV(gv)) {
if ((!block
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);
}
}
}
{
dVAR;
CV* cv;
+#ifdef USE_ITHREADS
+ const char *const temp_p = CopFILE(PL_curcop);
+ const STRLEN len = temp_p ? strlen(temp_p) : 0;
+#else
+ SV *const temp_sv = CopFILESV(PL_curcop);
+ STRLEN len;
+ const char *const temp_p = temp_sv ? SvPV_const(temp_sv, len) : NULL;
+#endif
+ char *const file = savepvn(temp_p, temp_p ? len : 0);
ENTER;
CopSTASH_set(PL_curcop,stash);
}
- cv = newXS(name, const_sv_xsub, savepv(CopFILE(PL_curcop)));
+ /* 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);
CvXSUBANY(cv).any_ptr = sv;
CvCONST_on(cv);
- sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
+ /* 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)
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;
if (!kid->op_sibling)
append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
+ assert(kid->op_sibling);
kid = kid->op_sibling;
scalar(kid);
? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
OP *o2 = prev->op_sibling;
OP *cvop;
- char *proto = NULL;
+ const char *proto = NULL;
+ const char *proto_end = NULL;
CV *cv = NULL;
GV *namegv = NULL;
int optional = 0;
tmpop->op_private |= OPpEARLY_CV;
else {
if (SvPOK(cv)) {
+ STRLEN len;
namegv = CvANON(cv) ? gv : CvGV(cv);
- proto = SvPV_nolen((SV*)cv);
+ proto = SvPV((SV*)cv, len);
+ proto_end = proto + len;
}
if (CvASSERTION(cv)) {
if (PL_hints & HINT_ASSERTING) {
else
o3 = o2;
if (proto) {
- switch (*proto) {
- case '\0':
+ if (proto >= proto_end)
return too_many_arguments(o, gv_ename(namegv));
+
+ switch (*proto) {
case ';':
optional = 1;
proto++;
break;
case ']':
if (contextclass) {
- /* XXX We shouldn't be modifying proto, so we can const proto */
- char *p = proto;
- const char s = *p;
+ const char *p = proto;
+ const char *const end = proto;
contextclass = 0;
- *p = '\0';
while (*--p != '[');
- bad_type(arg, Perl_form(aTHX_ "one of %s", p),
- gv_ename(namegv), o3);
- *proto = s;
+ bad_type(arg, Perl_form(aTHX_ "one of %.*s",
+ (int)(end - p), p),
+ gv_ename(namegv), o3);
} else
goto oops;
break;
default:
oops:
Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
- gv_ename(namegv), cv);
+ gv_ename(namegv), (void*)cv);
}
}
else
prev = o2;
o2 = o2->op_sibling;
} /* while */
- if (proto && !optional &&
- (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
+ if (proto && !optional && proto_end > proto &&
+ (*proto != '@' && *proto != '%' && *proto != ';'))
return too_few_arguments(o, gv_ename(namegv));
if(delete_op) {
#ifdef PERL_MAD
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)));