#include "reentr.h"
#include "regcharclass.h"
-/* XXX I can't imagine anyone who doesn't have this actually _needs_
- it, since pid_t is an integral type.
- --AD 2/20/1998
-*/
-#ifdef NEED_GETPID_PROTO
-extern Pid_t getpid (void);
-#endif
-
-/*
- * Some BSDs and Cygwin default to POSIX math instead of IEEE.
- * This switches them over to IEEE.
- */
-#if defined(LIBM_LIB_VERSION)
- _LIB_VERSION_TYPE _LIB_VERSION = _IEEE_;
-#endif
-
static const STRLEN small_mu_len = sizeof(GREEK_SMALL_LETTER_MU_UTF8) - 1;
static const STRLEN capital_iota_len = sizeof(GREEK_CAPITAL_LETTER_IOTA_UTF8) - 1;
/* Pushy stuff. */
-/* This is also called directly by pp_lvavref. */
-PP(pp_padav)
-{
- dSP; dTARGET;
- U8 gimme;
- assert(SvTYPE(TARG) == SVt_PVAV);
- if (UNLIKELY( PL_op->op_private & OPpLVAL_INTRO ))
- if (LIKELY( !(PL_op->op_private & OPpPAD_STATE) ))
- SAVECLEARSV(PAD_SVl(PL_op->op_targ));
- EXTEND(SP, 1);
- if (PL_op->op_flags & OPf_REF) {
- PUSHs(TARG);
- RETURN;
- }
- else if (PL_op->op_private & OPpMAYBE_LVSUB) {
- const I32 flags = is_lvalue_sub();
- if (flags && !(flags & OPpENTERSUB_INARGS)) {
- if (GIMME_V == G_SCALAR)
- /* diag_listed_as: Can't return %s to lvalue scalar context */
- Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
- PUSHs(TARG);
- RETURN;
- }
- }
-
- gimme = GIMME_V;
- if (gimme == G_ARRAY) {
- /* XXX see also S_pushav in pp_hot.c */
- const SSize_t maxarg = AvFILL(MUTABLE_AV(TARG)) + 1;
- EXTEND(SP, maxarg);
- if (SvMAGICAL(TARG)) {
- SSize_t i;
- for (i=0; i < maxarg; i++) {
- SV * const * const svp = av_fetch(MUTABLE_AV(TARG), i, FALSE);
- SP[i+1] = (svp) ? *svp : &PL_sv_undef;
- }
- }
- else {
- SSize_t i;
- for (i=0; i < maxarg; i++) {
- SV * const sv = AvARRAY((const AV *)TARG)[i];
- SP[i+1] = sv ? sv : &PL_sv_undef;
- }
- }
- SP += maxarg;
- }
- else if (gimme == G_SCALAR) {
- SV* const sv = sv_newmortal();
- const SSize_t maxarg = AvFILL(MUTABLE_AV(TARG)) + 1;
- sv_setiv(sv, maxarg);
- PUSHs(sv);
- }
- RETURN;
-}
-
-PP(pp_padhv)
-{
- dSP; dTARGET;
- U8 gimme;
-
- assert(SvTYPE(TARG) == SVt_PVHV);
- XPUSHs(TARG);
- if (UNLIKELY( PL_op->op_private & OPpLVAL_INTRO ))
- if (LIKELY( !(PL_op->op_private & OPpPAD_STATE) ))
- SAVECLEARSV(PAD_SVl(PL_op->op_targ));
-
- if (PL_op->op_flags & OPf_REF)
- RETURN;
- else if (PL_op->op_private & OPpMAYBE_LVSUB) {
- const I32 flags = is_lvalue_sub();
- if (flags && !(flags & OPpENTERSUB_INARGS)) {
- if (GIMME_V == G_SCALAR)
- /* diag_listed_as: Can't return %s to lvalue scalar context */
- Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
- RETURN;
- }
- }
-
- gimme = GIMME_V;
- if (gimme == G_ARRAY) {
- RETURNOP(Perl_do_kv(aTHX));
- }
- else if ((PL_op->op_private & OPpTRUEBOOL
- || ( PL_op->op_private & OPpMAYBE_TRUEBOOL
- && block_gimme() == G_VOID ))
- && (!SvRMAGICAL(TARG) || !mg_find(TARG, PERL_MAGIC_tied))
- )
- SETs(HvUSEDKEYS(TARG) ? &PL_sv_yes : &PL_sv_no);
- else if (gimme == G_SCALAR) {
- SV* const sv = Perl_hv_scalar(aTHX_ MUTABLE_HV(TARG));
- SETs(sv);
- }
- RETURN;
-}
PP(pp_padcv)
{
else if (PL_op->op_private & OPpDEREF)
sv = vivify_ref(sv, PL_op->op_private & OPpDEREF);
}
+ SPAGAIN; /* in case chasing soft refs reallocated the stack */
SETs(sv);
RETURN;
}
else {
const MAGIC * const mg = mg_find_mglob(sv);
if (mg && mg->mg_len != -1) {
- dTARGET;
STRLEN i = mg->mg_len;
- if (mg->mg_flags & MGf_BYTES && DO_UTF8(sv))
- i = sv_pos_b2u_flags(sv, i, SV_GMAGIC|SV_CONST_RETURN);
- SETu(i);
+ if (PL_op->op_private & OPpTRUEBOOL)
+ SETs(i ? &PL_sv_yes : &PL_sv_zero);
+ else {
+ dTARGET;
+ if (mg->mg_flags & MGf_BYTES && DO_UTF8(sv))
+ i = sv_pos_b2u_flags(sv, i, SV_GMAGIC|SV_CONST_RETURN);
+ SETu(i);
+ }
return NORMAL;
}
SETs(&PL_sv_undef);
SV * const sv = TOPs;
SvGETMAGIC(sv);
- if (!SvROK(sv))
+ if (!SvROK(sv)) {
SETs(&PL_sv_no);
- else {
+ return NORMAL;
+ }
+
+ /* op is in boolean context? */
+ if ( (PL_op->op_private & OPpTRUEBOOL)
+ || ( (PL_op->op_private & OPpMAYBE_TRUEBOOL)
+ && block_gimme() == G_VOID))
+ {
+ /* refs are always true - unless it's to an object blessed into a
+ * class with a false name, i.e. "0". So we have to check for
+ * that remote possibility. The following is is basically an
+ * unrolled SvTRUE(sv_reftype(rv)) */
+ SV * const rv = SvRV(sv);
+ if (SvOBJECT(rv)) {
+ HV *stash = SvSTASH(rv);
+ HEK *hek = HvNAME_HEK(stash);
+ if (hek) {
+ I32 len = HEK_LEN(hek);
+ /* bail out and do it the hard way? */
+ if (UNLIKELY(
+ len == HEf_SVKEY
+ || (len == 1 && HEK_KEY(hek)[0] == '0')
+ ))
+ goto do_sv_ref;
+ }
+ }
+ SETs(&PL_sv_yes);
+ return NORMAL;
+ }
+
+ do_sv_ref:
+ {
dTARGET;
SETs(TARG);
- /* use the return value that is in a register, its the same as TARG */
- TARG = sv_ref(TARG,SvRV(sv),TRUE);
+ sv_ref(TARG, SvRV(sv), TRUE);
SvSETMAGIC(TARG);
+ return NORMAL;
}
- return NORMAL;
}
+
PP(pp_bless)
{
dSP;
PP(pp_not)
{
dSP;
+ SV *sv;
+
tryAMAGICun_MG(not_amg, AMGf_set);
- *PL_stack_sp = boolSV(!SvTRUE_nomg(*PL_stack_sp));
+ sv = *PL_stack_sp;
+ *PL_stack_sp = boolSV(!SvTRUE_nomg_NN(sv));
return NORMAL;
}
sv_copypv_nomg(TARG, sv);
tmps = (U8*)SvPV_nomg(TARG, len);
- anum = len;
+
if (SvUTF8(TARG)) {
- /* Calculate exact length, let's not estimate. */
- STRLEN targlen = 0;
- STRLEN l;
- UV nchar = 0;
- UV nwide = 0;
- U8 * const send = tmps + len;
- U8 * const origtmps = tmps;
- const UV utf8flags = UTF8_ALLOW_ANYUV;
-
- while (tmps < send) {
- const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
- tmps += l;
- targlen += UVCHR_SKIP(~c);
- nchar++;
- if (c > 0xff)
- nwide++;
- }
+ if (len && ! utf8_to_bytes(tmps, &len)) {
+ Perl_croak(aTHX_ fatal_above_ff_msg, PL_op_desc[PL_op->op_type]);
+ }
+ SvCUR(TARG) = len;
+ SvUTF8_off(TARG);
+ }
+
+ anum = len;
- /* Now rewind strings and write them. */
- tmps = origtmps;
-
- if (nwide) {
- U8 *result;
- U8 *p;
-
- Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
- deprecated_above_ff_msg, PL_op_desc[PL_op->op_type]);
- Newx(result, targlen + 1, U8);
- p = result;
- while (tmps < send) {
- const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
- tmps += l;
- p = uvchr_to_utf8_flags(p, ~c, UNICODE_ALLOW_ANY);
- }
- *p = '\0';
- sv_usepvn_flags(TARG, (char*)result, targlen,
- SV_HAS_TRAILING_NUL);
- SvUTF8_on(TARG);
- }
- else {
- U8 *result;
- U8 *p;
-
- Newx(result, nchar + 1, U8);
- p = result;
- while (tmps < send) {
- const U8 c = (U8)utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
- tmps += l;
- *p++ = ~c;
- }
- *p = '\0';
- sv_usepvn_flags(TARG, (char*)result, nchar, SV_HAS_TRAILING_NUL);
- SvUTF8_off(TARG);
- }
- return;
- }
#ifdef LIBERAL
{
long *tmpl;
/* String stuff. */
+
PP(pp_length)
{
dSP; dTARGET;
SV * const sv = TOPs;
U32 in_bytes = IN_BYTES;
- /* simplest case shortcut */
- /* turn off SVf_UTF8 in tmp flags if HINT_BYTES on*/
+ /* Simplest case shortcut:
+ * set svflags to just the SVf_POK|SVs_GMG|SVf_UTF8 from the SV,
+ * with the SVf_UTF8 flag inverted if under 'use bytes' (HINT_BYTES
+ * set)
+ */
U32 svflags = (SvFLAGS(sv) ^ (in_bytes << 26)) & (SVf_POK|SVs_GMG|SVf_UTF8);
- STATIC_ASSERT_STMT(HINT_BYTES == 0x00000008 && SVf_UTF8 == 0x20000000 && (SVf_UTF8 == HINT_BYTES << 26));
+
+ STATIC_ASSERT_STMT(SVf_UTF8 == (HINT_BYTES << 26));
SETs(TARG);
- if(LIKELY(svflags == SVf_POK))
+ if (LIKELY(svflags == SVf_POK))
goto simple_pv;
- if(svflags & SVs_GMG)
+
+ if (svflags & SVs_GMG)
mg_get(sv);
+
if (SvOK(sv)) {
- if (!IN_BYTES) /* reread to avoid using an C auto/register */
- sv_setiv(TARG, (IV)sv_len_utf8_nomg(sv));
- else
- {
- STRLEN len;
+ STRLEN len;
+ if (!IN_BYTES) { /* reread to avoid using an C auto/register */
+ if ((SvFLAGS(sv) & (SVf_POK|SVf_UTF8)) == SVf_POK)
+ goto simple_pv;
+ if ( SvPOK(sv) && (PL_op->op_private & OPpTRUEBOOL)) {
+ /* no need to convert from bytes to chars */
+ len = SvCUR(sv);
+ goto return_bool;
+ }
+ len = sv_len_utf8_nomg(sv);
+ }
+ else {
/* unrolled SvPV_nomg_const(sv,len) */
- if(SvPOK_nog(sv)){
- simple_pv:
+ if (SvPOK_nog(sv)) {
+ simple_pv:
len = SvCUR(sv);
- } else {
+ if (PL_op->op_private & OPpTRUEBOOL) {
+ return_bool:
+ SETs(len ? &PL_sv_yes : &PL_sv_zero);
+ return NORMAL;
+ }
+ }
+ else {
(void)sv_2pv_flags(sv, &len, 0|SV_CONST_RETURN);
}
- sv_setiv(TARG, (IV)(len));
}
- } else {
+ TARGi((IV)(len), 1);
+ }
+ else {
if (!SvPADTMP(TARG)) {
+ /* OPpTARGET_MY: targ is var in '$lex = length()' */
sv_set_undef(TARG);
- } else { /* TARG is on stack at this point and is overwriten by SETs.
- This branch is the odd one out, so put TARG by default on
- stack earlier to let local SP go out of liveness sooner */
+ SvSETMAGIC(TARG);
+ }
+ else
+ /* TARG is on stack at this point and is overwriten by SETs.
+ * This branch is the odd one out, so put TARG by default on
+ * stack earlier to let local SP go out of liveness sooner */
SETs(&PL_sv_undef);
- goto no_set_magic;
- }
}
- SvSETMAGIC(TARG);
- no_set_magic:
return NORMAL; /* no putback, SP didn't move in this opcode */
}
+
/* Returns false if substring is completely outside original string.
No length is indicated by len_iv = 0 and len_is_uv = 0. len_is_uv must
always be true for an explicit 0.
LvTARGOFF(ret) =
pos1_is_uv || pos1_iv >= 0
? (STRLEN)(UV)pos1_iv
- : (LvFLAGS(ret) |= 1, (STRLEN)(UV)-pos1_iv);
+ : (LvFLAGS(ret) |= LVf_NEG_OFF, (STRLEN)(UV)-pos1_iv);
LvTARGLEN(ret) =
len_is_uv || len_iv > 0
? (STRLEN)(UV)len_iv
- : (LvFLAGS(ret) |= 2, (STRLEN)(UV)-len_iv);
+ : (LvFLAGS(ret) |= LVf_NEG_LEN, (STRLEN)(UV)-len_iv);
PUSHs(ret); /* avoid SvSETMAGIC here */
RETURN;
tmps = SvPV_force_nomg(sv, curlen);
if (DO_UTF8(repl_sv) && repl_len) {
if (!DO_UTF8(sv)) {
+ /* Upgrade the dest, and recalculate tmps in case the buffer
+ * got reallocated; curlen may also have been changed */
sv_utf8_upgrade_nomg(sv);
- curlen = SvCUR(sv);
+ tmps = SvPV_nomg(sv, curlen);
}
}
else if (DO_UTF8(sv))
{
dSP;
const IV size = POPi;
- const IV offset = POPi;
+ SV* offsetsv = POPs;
SV * const src = POPs;
const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
SV * ret;
+ UV retuv;
+ STRLEN offset = 0;
+ char errflags = 0;
+
+ /* extract a STRLEN-ranged integer value from offsetsv into offset,
+ * or flag that its out of range */
+ {
+ IV iv = SvIV(offsetsv);
+
+ /* avoid a large UV being wrapped to a negative value */
+ if (SvIOK_UV(offsetsv) && SvUVX(offsetsv) > (UV)IV_MAX)
+ errflags = LVf_OUT_OF_RANGE;
+ else if (iv < 0)
+ errflags = (LVf_NEG_OFF|LVf_OUT_OF_RANGE);
+#if PTRSIZE < IVSIZE
+ else if (iv > Size_t_MAX)
+ errflags = LVf_OUT_OF_RANGE;
+#endif
+ else
+ offset = (STRLEN)iv;
+ }
+
+ retuv = errflags ? 0 : do_vecget(src, offset, size);
if (lvalue) { /* it's an lvalue! */
ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */
LvTARG(ret) = SvREFCNT_inc_simple(src);
LvTARGOFF(ret) = offset;
LvTARGLEN(ret) = size;
+ LvFLAGS(ret) = errflags;
}
else {
dTARGET;
ret = TARG;
}
- sv_setuv(ret, do_vecget(src, offset, size));
+ sv_setuv(ret, retuv);
if (!lvalue)
SvSETMAGIC(ret);
PUSHs(ret);
convert the small string to ISO-8859-1, then there is no
way that it could be found anywhere by index. */
retval = -1;
- goto fail;
+ goto push_result;
}
/* At this point, pv is a malloc()ed string. So donate it to temp
retval = sv_pos_b2u_flags(big, retval, SV_CONST_RETURN);
}
SvREFCNT_dec(temp);
- fail:
- PUSHi(retval);
+
+ push_result:
+ /* OPpTRUEBOOL indicates an '== -1' has been optimised away */
+ if (PL_op->op_private & OPpTRUEBOOL) {
+ PUSHs( ((retval != -1) ^ cBOOL(PL_op->op_private & OPpINDEX_BOOLNEG))
+ ? &PL_sv_yes : &PL_sv_no);
+ if (PL_op->op_private & OPpTARGET_MY)
+ /* $lex = (index() == -1) */
+ sv_setsv(TARG, TOPs);
+ }
+ else
+ PUSHi(retval);
RETURN;
}
gimme = GIMME_V;
discard = (gimme == G_VOID) ? G_DISCARD : 0;
- if (PL_op->op_private & OPpSLICE) {
+ if (PL_op->op_private & (OPpSLICE|OPpKVSLICE)) {
dMARK; dORIGMARK;
HV * const hv = MUTABLE_HV(POPs);
const U32 hvtype = SvTYPE(hv);
+ int skip = 0;
+ if (PL_op->op_private & OPpKVSLICE) {
+ SSize_t items = SP - MARK;
+
+ MEXTEND(SP,items);
+ while (items > 1) {
+ *(MARK+items*2-1) = *(MARK+items);
+ items--;
+ }
+ items = SP - MARK;
+ SP += items;
+ skip = 1;
+ }
if (hvtype == SVt_PVHV) { /* hash element */
- while (++MARK <= SP) {
- SV * const sv = hv_delete_ent(hv, *MARK, discard, 0);
+ while ((MARK += (1+skip)) <= SP) {
+ SV * const sv = hv_delete_ent(hv, *(MARK-skip), discard, 0);
*MARK = sv ? sv : &PL_sv_undef;
}
}
else if (hvtype == SVt_PVAV) { /* array element */
if (PL_op->op_flags & OPf_SPECIAL) {
- while (++MARK <= SP) {
- SV * const sv = av_delete(MUTABLE_AV(hv), SvIV(*MARK), discard);
+ while ((MARK += (1+skip)) <= SP) {
+ SV * const sv = av_delete(MUTABLE_AV(hv), SvIV(*(MARK-skip)), discard);
*MARK = sv ? sv : &PL_sv_undef;
}
}
DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
}
if (localizing) {
- if (HvNAME_get(hv) && isGV(*svp))
+ if (HvNAME_get(hv) && isGV_or_RVCV(*svp))
save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
else if (preeminent)
save_helem_flags(hv, keysv, svp,
if (GIMME_V != G_ARRAY) {
SV **mark = PL_stack_base + markidx;
dSP;
+ EXTEND(SP, 1); /* in case no arguments, as in @empty */
if (++MARK <= SP)
*MARK = *SP; /* unwanted list, return last item */
else
if (GIMME_V != G_ARRAY) {
if (lastlelem < firstlelem) {
+ EXTEND(SP, 1);
*firstlelem = &PL_sv_undef;
}
else {
sp - mark);
}
+ if (SvREADONLY(ary))
+ Perl_croak_no_modify();
+
SP++;
if (++MARK < SP) {
}
else {
char *up;
- char *down;
- I32 tmp;
dTARGET;
STRLEN len;
SvUTF8_off(TARG); /* decontaminate */
if (SP - MARK > 1)
do_join(TARG, &PL_sv_no, MARK, SP);
- else {
- sv_setsv(TARG, SP > MARK ? *SP : DEFSV);
+ else if (SP > MARK)
+ sv_setsv(TARG, *SP);
+ else {
+ sv_setsv(TARG, DEFSV);
+ EXTEND(SP, 1);
}
up = SvPV_force(TARG, len);
if (len > 1) {
+ char *down;
if (DO_UTF8(TARG)) { /* first reverse each character */
U8* s = (U8*)SvPVX(TARG);
const U8* send = (U8*)(s + len);
down = (char*)(s - 1);
/* reverse this character */
while (down > up) {
- tmp = *up;
+ const char tmp = *up;
*up++ = *down;
- *down-- = (char)tmp;
+ *down-- = tmp;
}
}
}
}
down = SvPVX(TARG) + len - 1;
while (down > up) {
- tmp = *up;
+ const char tmp = *up;
*up++ = *down;
- *down-- = (char)tmp;
+ *down-- = tmp;
}
(void)SvPOK_only_UTF8(TARG);
}
STRLEN len;
const char *s = SvPV_const(sv, len);
const bool do_utf8 = DO_UTF8(sv);
+ const bool in_uni_8_bit = IN_UNI_8_BIT;
const char *strend = s + len;
PMOP *pm = cPMOPx(PL_op);
REGEXP *rx;
while (s < strend && isSPACE_LC(*s))
s++;
}
+ else if (in_uni_8_bit) {
+ while (s < strend && isSPACE_L1(*s))
+ s++;
+ }
else {
while (s < strend && isSPACE(*s))
s++;
{
while (m < strend && !isSPACE_LC(*m))
++m;
+ }
+ else if (in_uni_8_bit) {
+ while (m < strend && !isSPACE_L1(*m))
+ ++m;
} else {
while (m < strend && !isSPACE(*m))
++m;
{
while (s < strend && isSPACE_LC(*s))
++s;
+ }
+ else if (in_uni_8_bit) {
+ while (s < strend && isSPACE_L1(*s))
+ ++s;
} else {
while (s < strend && isSPACE(*s))
++s;
RETURN;
}
+/* Implement CORE::keys(),values(),each().
+ *
+ * We won't know until run-time whether the arg is an array or hash,
+ * so this op calls
+ *
+ * pp_keys/pp_values/pp_each
+ * or
+ * pp_akeys/pp_avalues/pp_aeach
+ *
+ * as appropriate (or whatever pp function actually implements the OP_FOO
+ * functionality for each FOO).
+ */
+
PP(pp_avhvswitch)
{
dVAR; dSP;
}
+static SV *
+S_find_runcv_name(void)
+{
+ dTHX;
+ CV *cv;
+ GV *gv;
+ SV *sv;
+
+ cv = find_runcv(0);
+ if (!cv)
+ return &PL_sv_no;
+
+ gv = CvGV(cv);
+ if (!gv)
+ return &PL_sv_no;
+
+ sv = sv_2mortal(newSV(0));
+ gv_fullname4(sv, gv, NULL, TRUE);
+ return sv;
+}
/* Check a a subs arguments - i.e. that it has the correct number of args
* (and anything else we might think of in future). Typically used with
too_few = (argc < (params - opt_params));
if (UNLIKELY(too_few || (!slurpy && argc > params)))
- /* diag_listed_as: Too few arguments for subroutine */
- /* diag_listed_as: Too many arguments for subroutine */
- Perl_croak_caller("Too %s arguments for subroutine",
- too_few ? "few" : "many");
+ /* diag_listed_as: Too few arguments for subroutine '%s' */
+ /* diag_listed_as: Too many arguments for subroutine '%s' */
+ Perl_croak_caller("Too %s arguments for subroutine '%" SVf "'",
+ too_few ? "few" : "many", S_find_runcv_name());
if (UNLIKELY(slurpy == '%' && argc > params && (argc - params) % 2))
- Perl_croak_caller("Odd name/value argument for subroutine");
-
+ /* diag_listed_as: Odd name/value argument for subroutine '%s' */
+ Perl_croak_caller("Odd name/value argument for subroutine '%" SVf "'",
+ S_find_runcv_name());
return NORMAL;
}