/* info returned by S_sprintf_is_multiconcatable() */
struct sprintf_ismc_info {
- UV nargs; /* num of args to sprintf (not including the format) */
+ SSize_t nargs; /* num of args to sprintf (not including the format) */
char *start; /* start of raw format string */
char *end; /* bytes after end of raw format string */
STRLEN total_len; /* total length (in bytes) of format string, not
OP *pm, *constop, *kid;
SV *sv;
char *s, *e, *p;
- UV nargs, nformats;
+ SSize_t nargs, nformats;
STRLEN cur, total_len, variant;
bool utf8;
for (p = s; p < e; p++) {
if (*p != '%') {
total_len++;
- if (UTF8_IS_INVARIANT(*p))
+ if (!UTF8_IS_INVARIANT(*p))
variant++;
continue;
}
STRLEN len; /* ... len set to SvPV(..., len) */
} *argp, *toparg, args[PERL_MULTICONCAT_MAXARG*2 + 1];
- UV nargs = 0;
- UV nconst = 0;
+ SSize_t nargs = 0;
+ SSize_t nconst = 0;
STRLEN variant;
bool utf8 = FALSE;
bool kid_is_last = FALSE; /* most args will be the RHS kid of a concat op;
+ ((nargs + 1) * (variant ? 2 : 1))
)
);
- const_str = (char *)PerlMemShared_malloc(total_len);
+ const_str = (char *)PerlMemShared_malloc(total_len ? total_len : 1);
/* Extract all the non-const expressions from the concat tree then
* dispose of the old tree, e.g. convert the tree from this:
if (*p == '%') {
p++;
if (*p != '%') {
- (lenp++)->uv = q - oldq;
+ (lenp++)->ssize = q - oldq;
oldq = q;
continue;
}
}
*q++ = *p;
}
- lenp->uv = q - oldq;
+ lenp->ssize = q - oldq;
assert((STRLEN)(q - const_str) == total_len);
/* Attach all the args (i.e. the kids of the sprintf) to o (which
p = const_str;
lenp = aux + PERL_MULTICONCAT_IX_LENGTHS;
- lenp->size = -1;
+ lenp->ssize = -1;
/* Concatenate all const strings into const_str.
* Note that args[] contains the RHS args in reverse order, so
for (argp = toparg; argp >= args; argp--) {
if (!argp->p)
/* not a const op */
- (++lenp)->size = -1;
+ (++lenp)->ssize = -1;
else {
STRLEN l = argp->len;
Copy(argp->p, p, l, char);
p += l;
- if (lenp->size == -1)
- lenp->size = l;
+ if (lenp->ssize == -1)
+ lenp->ssize = l;
else
- lenp->size += l;
+ lenp->ssize += l;
}
}
/* Populate the aux struct */
- aux[PERL_MULTICONCAT_IX_NARGS].uv = nargs;
+ aux[PERL_MULTICONCAT_IX_NARGS].ssize = nargs;
aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv = utf8 ? NULL : const_str;
- aux[PERL_MULTICONCAT_IX_PLAIN_LEN].size = utf8 ? 0 : total_len;
+ aux[PERL_MULTICONCAT_IX_PLAIN_LEN].ssize = utf8 ? 0 : total_len;
aux[PERL_MULTICONCAT_IX_UTF8_PV].pv = const_str;
- aux[PERL_MULTICONCAT_IX_UTF8_LEN].size = total_len;
+ aux[PERL_MULTICONCAT_IX_UTF8_LEN].ssize = total_len;
/* if variant > 0, calculate a variant const string and lengths where
* the utf8 version of the string will take 'variant' more bytes than
UNOP_AUX_item *lens = aux + PERL_MULTICONCAT_IX_LENGTHS;
UNOP_AUX_item *ulens = lens + (nargs + 1);
char *up = (char*)PerlMemShared_malloc(ulen);
- UV n;
+ SSize_t n;
aux[PERL_MULTICONCAT_IX_UTF8_PV].pv = up;
- aux[PERL_MULTICONCAT_IX_UTF8_LEN].size = ulen;
+ aux[PERL_MULTICONCAT_IX_UTF8_LEN].ssize = ulen;
for (n = 0; n < (nargs + 1); n++) {
- SSize_t l, ul, i;
- l = ul = (lens++)->size;
- for (i = 0; i < l; i++) {
+ SSize_t i;
+ char * orig_up = up;
+ for (i = (lens++)->ssize; i > 0; i--) {
U8 c = *p++;
- if (UTF8_IS_INVARIANT(c))
- *up++ = c;
- else {
- *up++ = UTF8_EIGHT_BIT_HI(c);
- *up++ = UTF8_EIGHT_BIT_LO(c);
- ul++;
- }
+ append_utf8_from_native_byte(c, (U8**)&up);
}
- (ulens++)->size = ul;
+ (ulens++)->ssize = (i < 0) ? i : up - orig_up;
}
}
o = *attrs;
if (o->op_type == OP_CONST) {
pv = SvPV(cSVOPo_sv, pvlen);
- if (pvlen >= 10 && memEQ(pv, "prototype(", 10)) {
+ if (memBEGINs(pv, pvlen, "prototype(")) {
SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
SV ** const tmpo = cSVOPx_svp(o);
SvREFCNT_dec(cSVOPo_sv);
for (o = OpSIBLING(lasto); o; o = OpSIBLING(o)) {
if (o->op_type == OP_CONST) {
pv = SvPV(cSVOPo_sv, pvlen);
- if (pvlen >= 10 && memEQ(pv, "prototype(", 10)) {
+ if (memBEGINs(pv, pvlen, "prototype(")) {
SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
SV ** const tmpo = cSVOPx_svp(o);
SvREFCNT_dec(cSVOPo_sv);
Constructs, checks, and returns an op of any type that involves an
embedded C-level pointer (PV). C<type> is the opcode. C<flags> gives
-the eight bits of C<op_flags>. C<pv> supplies the C-level pointer, which
-must have been allocated using C<PerlMemShared_malloc>; the memory will
-be freed when the op is destroyed.
+the eight bits of C<op_flags>. C<pv> supplies the C-level pointer.
+Depending on the op type, the memory referenced by C<pv> may be freed
+when the op is destroyed. If the op is of a freeing type, C<pv> must
+have been allocated using C<PerlMemShared_malloc>.
=cut
*/
return ret;
}
+static OP *
+S_newONCEOP(pTHX_ OP *initop, OP *padop)
+{
+ const PADOFFSET target = padop->op_targ;
+ OP *const other = newOP(OP_PADSV,
+ padop->op_flags
+ | ((padop->op_private & ~OPpLVAL_INTRO) << 8));
+ OP *const first = newOP(OP_NULL, 0);
+ OP *const nullop = newCONDOP(0, first, initop, other);
+ /* XXX targlex disabled for now; see ticket #124160
+ newCONDOP(0, first, S_maybe_targlex(aTHX_ initop), other);
+ */
+ OP *const condop = first->op_next;
+
+ OpTYPE_set(condop, OP_ONCE);
+ other->op_targ = target;
+ nullop->op_flags |= OPf_WANT_SCALAR;
+
+ /* Store the initializedness of state vars in a separate
+ pad entry. */
+ condop->op_targ =
+ pad_add_name_pvn("$",1,padadd_NO_DUP_CHECK|padadd_STATE,0,0);
+ /* hijacking PADSTALE for uninitialized state variables */
+ SvPADSTALE_on(PAD_SVl(condop->op_targ));
+
+ return nullop;
+}
/*
=for apidoc Am|OP *|newASSIGNOP|I32 flags|OP *left|I32 optype|OP *right
}
if ((assign_type = assignment_type(left)) == ASSIGN_LIST) {
+ OP *state_var_op = NULL;
static const char no_list_state[] = "Initialization of state variables"
- " in list context currently forbidden";
+ " in list currently forbidden";
OP *curop;
if (left->op_type == OP_ASLICE || left->op_type == OP_HSLICE)
if (OP_TYPE_IS_OR_WAS(left, OP_LIST))
{
- OP* lop = ((LISTOP*)left)->op_first;
- while (lop) {
- if ((lop->op_type == OP_PADSV ||
- lop->op_type == OP_PADAV ||
- lop->op_type == OP_PADHV ||
- lop->op_type == OP_PADANY)
- && (lop->op_private & OPpPAD_STATE)
- )
- yyerror(no_list_state);
- lop = OpSIBLING(lop);
+ OP *lop = ((LISTOP*)left)->op_first, *vop, *eop;
+ if (!(left->op_flags & OPf_PARENS) &&
+ lop->op_type == OP_PUSHMARK &&
+ (vop = OpSIBLING(lop)) &&
+ (vop->op_type == OP_PADAV || vop->op_type == OP_PADHV) &&
+ !(vop->op_flags & OPf_PARENS) &&
+ (vop->op_private & (OPpLVAL_INTRO|OPpPAD_STATE)) ==
+ (OPpLVAL_INTRO|OPpPAD_STATE) &&
+ (eop = OpSIBLING(vop)) &&
+ eop->op_type == OP_ENTERSUB &&
+ !OpHAS_SIBLING(eop)) {
+ state_var_op = vop;
+ } else {
+ while (lop) {
+ if ((lop->op_type == OP_PADSV ||
+ lop->op_type == OP_PADAV ||
+ lop->op_type == OP_PADHV ||
+ lop->op_type == OP_PADANY)
+ && (lop->op_private & OPpPAD_STATE)
+ )
+ yyerror(no_list_state);
+ lop = OpSIBLING(lop);
+ }
}
}
else if ( (left->op_private & OPpLVAL_INTRO)
state (%a) = ...
(state %a) = ...
*/
- yyerror(no_list_state);
+ if (left->op_flags & OPf_PARENS)
+ yyerror(no_list_state);
+ else
+ state_var_op = left;
}
/* optimise @a = split(...) into:
}
}
}
+
+ if (state_var_op)
+ o = S_newONCEOP(aTHX_ o, state_var_op);
return o;
}
if (assign_type == ASSIGN_REF)
=for apidoc Am|OP *|newGIVENOP|OP *cond|OP *block|PADOFFSET defsv_off
Constructs, checks, and returns an op tree expressing a C<given> block.
-C<cond> supplies the expression that will be locally assigned to a lexical
-variable, and C<block> supplies the body of the C<given> construct; they
+C<cond> supplies the expression to whose value C<$_> will be locally
+aliased, and C<block> supplies the body of the C<given> construct; they
are consumed by this function and become part of the constructed op tree.
C<defsv_off> must be zero (it used to identity the pad slot of lexical $_).
PERL_UNUSED_ARG(defsv_off);
assert(!defsv_off);
- return newGIVWHENOP(
- ref_array_or_hash(cond),
- block,
- OP_ENTERGIVEN, OP_LEAVEGIVEN,
- 0);
+ return newGIVWHENOP(cond, block, OP_ENTERGIVEN, OP_LEAVEGIVEN, 0);
}
/*
PERL_ARGS_ASSERT_NEWMYSUB;
+ PL_hints |= HINT_BLOCK_SCOPE;
+
/* Find the pad slot for storing the new sub.
We cannot use PL_comppad, as it is the pad owned by the new sub. We
need to look in CvOUTSIDE and find the pad belonging to the enclos-
sub is stored in. */
const I32 flags =
ec ? GV_NOADD_NOINIT
- : PL_curstash != CopSTASH(PL_curcop)
+ : (IN_PERL_RUNTIME && PL_curstash != CopSTASH(PL_curcop))
|| memchr(name, ':', namlen) || memchr(name, '\'', namlen)
? gv_fetch_flags
: GV_ADDMULTI | GV_NOINIT | GV_NOTQUAL;
PL_compcv = 0;
if (name && block) {
- const char *s = strrchr(name, ':');
+ const char *s = (char *) my_memrchr(name, ':', namlen);
s = s ? s+1 : name;
if (strEQ(s, "BEGIN")) {
if (PL_in_eval & EVAL_KEEPERR)
)
&& (kkid->op_private & (OPpLVAL_INTRO|OPpPAD_STATE))
== (OPpLVAL_INTRO|OPpPAD_STATE)) {
- const PADOFFSET target = kkid->op_targ;
- OP *const other = newOP(OP_PADSV,
- kkid->op_flags
- | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
- OP *const first = newOP(OP_NULL, 0);
- OP *const nullop =
- newCONDOP(0, first, o, other);
- /* XXX targlex disabled for now; see ticket #124160
- newCONDOP(0, first, S_maybe_targlex(aTHX_ o), other);
- */
- OP *const condop = first->op_next;
-
- OpTYPE_set(condop, OP_ONCE);
- other->op_targ = target;
- nullop->op_flags |= OPf_WANT_SCALAR;
-
- /* Store the initializedness of state vars in a separate
- pad entry. */
- condop->op_targ =
- pad_add_name_pvn("$",1,padadd_NO_DUP_CHECK|padadd_STATE,0,0);
- /* hijacking PADSTALE for uninitialized state variables */
- SvPADSTALE_on(PAD_SVl(condop->op_targ));
-
- return nullop;
+ return S_newONCEOP(aTHX_ o, kkid);
}
}
return S_maybe_targlex(aTHX_ o);
sv = kSVOP->op_sv;
/* replace ' with :: */
- while ((compatptr = strchr(SvPVX(sv), '\''))) {
+ while ((compatptr = (char *) memchr(SvPVX(sv), '\'',
+ SvEND(sv) - SvPVX(sv) )))
+ {
*compatptr = ':';
sv_insert(sv, compatptr - SvPVX_const(sv), 0, ":", 1);
}
return newMETHOP_named(OP_METHOD_NAMED, 0, methsv);
}
- if (nsplit == 7 && memEQ(method, "SUPER::", nsplit)) { /* $proto->SUPER::method() */
+ if (memEQs(method, nsplit, "SUPER::")) { /* $proto->SUPER::method() */
op_free(o);
return newMETHOP_named(OP_METHOD_SUPER, 0, methsv);
}
/* $proto->MyClass::method() and $proto->MyClass::SUPER::method() */
- if (nsplit >= 9 && strnEQ(method+nsplit-9, "::SUPER::", 9)) {
+ if (nsplit >= 9 && strBEGINs(method+nsplit-9, "::SUPER::")) {
rclass = newSVpvn_share(method, utf8*(nsplit-9), 0);
new_op = newMETHOP_named(OP_METHOD_REDIR_SUPER, 0, methsv);
} else {
SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
if (svp) {
const I32 sorthints = (I32)SvIV(*svp);
- if ((sorthints & HINT_SORT_QUICKSORT) != 0)
- o->op_private |= OPpSORT_QSORT;
if ((sorthints & HINT_SORT_STABLE) != 0)
o->op_private |= OPpSORT_STABLE;
if ((sorthints & HINT_SORT_UNSTABLE) != 0)
switch (*proto++) {
case '[':
if (contextclass++ == 0) {
- e = strchr(proto, ']');
+ e = (char *) memchr(proto, ']', proto_end - proto);
if (!e || e == proto)
goto oops;
}
if (kid->op_type == OP_NULL)
kid = OpSIBLING(kid);
if (kid)
- kid->op_flags |= OPf_MOD;
+ op_lvalue(kid, o->op_type);
}
return o;
https://perl5.git.perl.org / perl5.git / blobdiff