#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)
{
*/
if (vivify_sv && sv != &PL_sv_undef) {
GV *gv;
+ HV *stash;
if (SvREADONLY(sv))
Perl_croak_no_modify();
+ gv = MUTABLE_GV(newSV(0));
+ stash = CopSTASH(PL_curcop);
+ if (SvTYPE(stash) != SVt_PVHV) stash = NULL;
if (cUNOP->op_targ) {
SV * const namesv = PAD_SV(cUNOP->op_targ);
- HV *stash = CopSTASH(PL_curcop);
- if (SvTYPE(stash) != SVt_PVHV) stash = NULL;
- gv = MUTABLE_GV(newSV(0));
gv_init_sv(gv, stash, namesv, 0);
}
else {
- const char * const name = CopSTASHPV(PL_curcop);
- gv = newGVgen_flags(name,
- HvNAMEUTF8(CopSTASH(PL_curcop)) ? SVf_UTF8 : 0 );
- SvREFCNT_inc_simple_void_NN(gv);
+ gv_init_pv(gv, stash, "__ANONIO__", 0);
}
prepare_SV_for_RV(sv);
SvRV_set(sv, MUTABLE_SV(gv));
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);
if (SvGMAGICAL(TOPs)) SETs(sv_mortalcopy(TOPs));
if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
const char * s = SvPVX_const(TOPs);
- if (strnEQ(s, "CORE::", 6)) {
+ if (memBEGINs(s, SvCUR(TOPs), "CORE::")) {
const int code = keyword(s + 6, SvCUR(TOPs) - 6, 1);
if (!code)
DIE(aTHX_ "Can't find an opnumber for \"%" UTF8f "\"",
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;
can be too large to preserve, so don't need to compile the code to
test the size of UVs. */
-#ifdef SLOPPYDIVIDE
+#if defined(SLOPPYDIVIDE) || (defined(PERL_PRESERVE_IVUV) && !defined(NV_PRESERVES_UV))
# define PERL_TRY_UV_DIVIDE
/* ensure that 20./5. == 4. */
-#else
-# ifdef PERL_PRESERVE_IVUV
-# ifndef NV_PRESERVES_UV
-# define PERL_TRY_UV_DIVIDE
-# endif
-# endif
#endif
#ifdef PERL_TRY_UV_DIVIDE
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;
/* avoid a large UV being wrapped to a negative value */
if (SvIOK_UV(offsetsv) && SvUVX(offsetsv) > (UV)IV_MAX)
- errflags = 4; /* out of range */
+ errflags = LVf_OUT_OF_RANGE;
else if (iv < 0)
- errflags = (1|4); /* negative offset, out of range */
+ errflags = (LVf_NEG_OFF|LVf_OUT_OF_RANGE);
#if PTRSIZE < IVSIZE
else if (iv > Size_t_MAX)
- errflags = 4; /* out of range */
+ errflags = LVf_OUT_OF_RANGE;
#endif
else
offset = (STRLEN)iv;
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;
}
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,
{
I32 markidx = POPMARK;
if (GIMME_V != G_ARRAY) {
- SV **mark = PL_stack_base + markidx;
+ /* don't initialize mark here, EXTEND() may move the stack */
+ SV **mark;
dSP;
+ EXTEND(SP, 1); /* in case no arguments, as in @empty */
+ mark = PL_stack_base + markidx;
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) {
SV * const tmp = *begin;
*begin++ = *end;
*end-- = tmp;
+
+ if (tmp && SvWEAKREF(tmp))
+ sv_rvunweaken(tmp);
}
+
+ /* make sure we catch the middle element */
+ if (begin == end && *begin && SvWEAKREF(*begin))
+ sv_rvunweaken(*begin);
}
}
}
STRLEN len;
SvUTF8_off(TARG); /* decontaminate */
- if (SP - MARK > 1)
+ if (SP - MARK > 1) {
do_join(TARG, &PL_sv_no, MARK, SP);
- else {
- sv_setsv(TARG, SP > MARK ? *SP : DEFSV);
+ SP = MARK + 1;
+ SETs(TARG);
+ } else if (SP > MARK) {
+ sv_setsv(TARG, *SP);
+ SETs(TARG);
+ } else {
+ sv_setsv(TARG, DEFSV);
+ XPUSHs(TARG);
}
up = SvPV_force(TARG, len);
}
(void)SvPOK_only_UTF8(TARG);
}
- SP = MARK + 1;
- SETTARG;
}
RETURN;
}
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;