/* pp.c
*
- * Copyright (c) 1991-2001, Larry Wall
+ * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
+ * 2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
* and no knowing what you'll find around a corner. And Elves, sir!" --Samwise
*/
+/* This file contains general pp ("push/pop") functions that execute the
+ * opcodes that make up a perl program. A typical pp function expects to
+ * find its arguments on the stack, and usually pushes its results onto
+ * the stack, hence the 'pp' terminology. Each OP structure contains
+ * a pointer to the relevant pp_foo() function.
+ */
+
#include "EXTERN.h"
#define PERL_IN_PP_C
#include "perl.h"
+#include "keywords.h"
-/* variations on pp_null */
+#include "reentr.h"
/* XXX I can't imagine anyone who doesn't have this actually _needs_
it, since pid_t is an integral type.
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
+
+/* variations on pp_null */
+
PP(pp_stub)
{
+ dVAR;
dSP;
if (GIMME_V == G_SCALAR)
XPUSHs(&PL_sv_undef);
RETURN;
}
-PP(pp_scalar)
-{
- return NORMAL;
-}
-
/* Pushy stuff. */
PP(pp_padav)
{
- dSP; dTARGET;
+ dVAR; dSP; dTARGET;
+ I32 gimme;
if (PL_op->op_private & OPpLVAL_INTRO)
- SAVECLEARSV(PL_curpad[PL_op->op_targ]);
+ SAVECLEARSV(PAD_SVl(PL_op->op_targ));
EXTEND(SP, 1);
if (PL_op->op_flags & OPf_REF) {
PUSHs(TARG);
PUSHs(TARG);
RETURN;
}
- if (GIMME == G_ARRAY) {
- I32 maxarg = AvFILL((AV*)TARG) + 1;
+ gimme = GIMME_V;
+ if (gimme == G_ARRAY) {
+ const I32 maxarg = AvFILL((AV*)TARG) + 1;
EXTEND(SP, maxarg);
if (SvMAGICAL(TARG)) {
U32 i;
- for (i=0; i < maxarg; i++) {
- SV **svp = av_fetch((AV*)TARG, i, FALSE);
+ for (i=0; i < (U32)maxarg; i++) {
+ SV * const * const svp = av_fetch((AV*)TARG, i, FALSE);
SP[i+1] = (svp) ? *svp : &PL_sv_undef;
}
}
}
SP += maxarg;
}
- else {
- SV* sv = sv_newmortal();
- I32 maxarg = AvFILL((AV*)TARG) + 1;
+ else if (gimme == G_SCALAR) {
+ SV* const sv = sv_newmortal();
+ const I32 maxarg = AvFILL((AV*)TARG) + 1;
sv_setiv(sv, maxarg);
PUSHs(sv);
}
PP(pp_padhv)
{
- dSP; dTARGET;
+ dVAR; dSP; dTARGET;
I32 gimme;
XPUSHs(TARG);
if (PL_op->op_private & OPpLVAL_INTRO)
- SAVECLEARSV(PL_curpad[PL_op->op_targ]);
+ SAVECLEARSV(PAD_SVl(PL_op->op_targ));
if (PL_op->op_flags & OPf_REF)
RETURN;
else if (LVRET) {
RETURNOP(do_kv());
}
else if (gimme == G_SCALAR) {
- SV* sv = sv_newmortal();
- if (HvFILL((HV*)TARG))
- Perl_sv_setpvf(aTHX_ sv, "%ld/%ld",
- (long)HvFILL((HV*)TARG), (long)HvMAX((HV*)TARG) + 1);
- else
- sv_setiv(sv, 0);
+ SV* const sv = Perl_hv_scalar(aTHX_ (HV*)TARG);
SETs(sv);
}
RETURN;
}
-PP(pp_padany)
-{
- DIE(aTHX_ "NOT IMPL LINE %d",__LINE__);
-}
-
/* Translations. */
PP(pp_rv2gv)
{
- dSP; dTOPss;
+ dVAR; dSP; dTOPss;
if (SvROK(sv)) {
wasref:
sv = SvRV(sv);
if (SvTYPE(sv) == SVt_PVIO) {
- GV *gv = (GV*) sv_newmortal();
+ GV * const gv = (GV*) sv_newmortal();
gv_init(gv, 0, "", 0, 0);
GvIOp(gv) = (IO *)sv;
(void)SvREFCNT_inc(sv);
}
else {
if (SvTYPE(sv) != SVt_PVGV) {
- char *sym;
- STRLEN len;
-
if (SvGMAGICAL(sv)) {
mg_get(sv);
if (SvROK(sv))
/* If this is a 'my' scalar and flag is set then vivify
* NI-S 1999/05/07
*/
+ if (SvREADONLY(sv))
+ Perl_croak(aTHX_ PL_no_modify);
if (PL_op->op_private & OPpDEREF) {
- char *name;
GV *gv;
if (cUNOP->op_targ) {
STRLEN len;
- SV *namesv = PL_curpad[cUNOP->op_targ];
- name = SvPV(namesv, len);
+ SV * const namesv = PAD_SV(cUNOP->op_targ);
+ const char * const name = SvPV(namesv, len);
gv = (GV*)NEWSV(0,0);
gv_init(gv, CopSTASH(PL_curcop), name, len, 0);
}
else {
- name = CopSTASHPV(PL_curcop);
+ const char * const name = CopSTASHPV(PL_curcop);
gv = newGVgen(name);
}
if (SvTYPE(sv) < SVt_RV)
sv_upgrade(sv, SVt_RV);
- SvRV(sv) = (SV*)gv;
+ if (SvPVX_const(sv)) {
+ SvPV_free(sv);
+ SvLEN_set(sv, 0);
+ SvCUR_set(sv, 0);
+ }
+ SvRV_set(sv, (SV*)gv);
SvROK_on(sv);
SvSETMAGIC(sv);
goto wasref;
PL_op->op_private & HINT_STRICT_REFS)
DIE(aTHX_ PL_no_usym, "a symbol");
if (ckWARN(WARN_UNINITIALIZED))
- report_uninit();
+ report_uninit(sv);
RETSETUNDEF;
}
- sym = SvPV(sv,len);
if ((PL_op->op_flags & OPf_SPECIAL) &&
!(PL_op->op_flags & OPf_MOD))
{
- sv = (SV*)gv_fetchpv(sym, FALSE, SVt_PVGV);
- if (!sv
- && (!is_gv_magical(sym,len,0)
- || !(sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV))))
- {
+ SV * const temp = (SV*)gv_fetchsv(sv, 0, SVt_PVGV);
+ if (!temp
+ && (!is_gv_magical_sv(sv,0)
+ || !(sv = (SV*)gv_fetchsv(sv, GV_ADD, SVt_PVGV)))) {
RETSETUNDEF;
}
+ sv = temp;
}
else {
if (PL_op->op_private & HINT_STRICT_REFS)
- DIE(aTHX_ PL_no_symref, sym, "a symbol");
- sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV);
+ DIE(aTHX_ PL_no_symref_sv, sv, "a symbol");
+ if ((PL_op->op_private & (OPpLVAL_INTRO|OPpDONT_INIT_GV))
+ == OPpDONT_INIT_GV) {
+ /* We are the target of a coderef assignment. Return
+ the scalar unchanged, and let pp_sasssign deal with
+ things. */
+ RETURN;
+ }
+ sv = (SV*)gv_fetchsv(sv, GV_ADD, SVt_PVGV);
}
}
}
PP(pp_rv2sv)
{
- dSP; dTOPss;
+ dVAR; dSP; dTOPss;
+ GV *gv = NULL;
if (SvROK(sv)) {
wasref:
}
}
else {
- GV *gv = (GV*)sv;
- char *sym;
- STRLEN len;
+ gv = (GV*)sv;
if (SvTYPE(gv) != SVt_PVGV) {
if (SvGMAGICAL(sv)) {
if (SvROK(sv))
goto wasref;
}
+ if (PL_op->op_private & HINT_STRICT_REFS) {
+ if (SvOK(sv))
+ DIE(aTHX_ PL_no_symref_sv, sv, "a SCALAR");
+ else
+ DIE(aTHX_ PL_no_usym, "a SCALAR");
+ }
if (!SvOK(sv)) {
- if (PL_op->op_flags & OPf_REF ||
- PL_op->op_private & HINT_STRICT_REFS)
+ if (PL_op->op_flags & OPf_REF)
DIE(aTHX_ PL_no_usym, "a SCALAR");
if (ckWARN(WARN_UNINITIALIZED))
- report_uninit();
+ report_uninit(sv);
RETSETUNDEF;
}
- sym = SvPV(sv, len);
if ((PL_op->op_flags & OPf_SPECIAL) &&
!(PL_op->op_flags & OPf_MOD))
{
- gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PV);
+ gv = (GV*)gv_fetchsv(sv, 0, SVt_PV);
if (!gv
- && (!is_gv_magical(sym,len,0)
- || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV))))
+ && (!is_gv_magical_sv(sv, 0)
+ || !(gv = (GV*)gv_fetchsv(sv, GV_ADD, SVt_PV))))
{
RETSETUNDEF;
}
}
else {
- if (PL_op->op_private & HINT_STRICT_REFS)
- DIE(aTHX_ PL_no_symref, sym, "a SCALAR");
- gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV);
+ gv = (GV*)gv_fetchsv(sv, GV_ADD, SVt_PV);
}
}
- sv = GvSV(gv);
+ sv = GvSVn(gv);
}
if (PL_op->op_flags & OPf_MOD) {
- if (PL_op->op_private & OPpLVAL_INTRO)
- sv = save_scalar((GV*)TOPs);
+ if (PL_op->op_private & OPpLVAL_INTRO) {
+ if (cUNOP->op_first->op_type == OP_NULL)
+ sv = save_scalar((GV*)TOPs);
+ else if (gv)
+ sv = save_scalar(gv);
+ else
+ Perl_croak(aTHX_ PL_no_localize_ref);
+ }
else if (PL_op->op_private & OPpDEREF)
vivify_ref(sv, PL_op->op_private & OPpDEREF);
}
PP(pp_av2arylen)
{
- dSP;
- AV *av = (AV*)TOPs;
- SV *sv = AvARYLEN(av);
- if (!sv) {
- AvARYLEN(av) = sv = NEWSV(0,0);
- sv_upgrade(sv, SVt_IV);
- sv_magic(sv, (SV*)av, PERL_MAGIC_arylen, Nullch, 0);
- }
- SETs(sv);
+ dVAR; dSP;
+ AV * const av = (AV*)TOPs;
+ SV ** const sv = Perl_av_arylen_p(aTHX_ (AV*)av);
+ if (!*sv) {
+ *sv = NEWSV(0,0);
+ sv_upgrade(*sv, SVt_PVMG);
+ sv_magic(*sv, (SV*)av, PERL_MAGIC_arylen, NULL, 0);
+ }
+ SETs(*sv);
RETURN;
}
PP(pp_pos)
{
- dSP; dTARGET; dPOPss;
+ dVAR; dSP; dTARGET; dPOPss;
if (PL_op->op_flags & OPf_MOD || LVRET) {
if (SvTYPE(TARG) < SVt_PVLV) {
sv_upgrade(TARG, SVt_PVLV);
- sv_magic(TARG, Nullsv, PERL_MAGIC_pos, Nullch, 0);
+ sv_magic(TARG, NULL, PERL_MAGIC_pos, NULL, 0);
}
LvTYPE(TARG) = '.';
RETURN;
}
else {
- MAGIC* mg;
-
if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
- mg = mg_find(sv, PERL_MAGIC_regex_global);
+ const MAGIC * const mg = mg_find(sv, PERL_MAGIC_regex_global);
if (mg && mg->mg_len >= 0) {
I32 i = mg->mg_len;
if (DO_UTF8(sv))
PP(pp_rv2cv)
{
- dSP;
+ dVAR; dSP;
GV *gv;
HV *stash;
-
+ const I32 flags = (PL_op->op_flags & OPf_SPECIAL)
+ ? 0
+ : ((PL_op->op_private & (OPpLVAL_INTRO|OPpMAY_RETURN_CONSTANT)) == OPpMAY_RETURN_CONSTANT)
+ ? GV_ADD|GV_NOEXPAND
+ : GV_ADD;
/* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
/* (But not in defined().) */
- CV *cv = sv_2cv(TOPs, &stash, &gv, !(PL_op->op_flags & OPf_SPECIAL));
+
+ CV *cv = sv_2cv(TOPs, &stash, &gv, flags);
if (cv) {
if (CvCLONE(cv))
cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
DIE(aTHX_ "Can't modify non-lvalue subroutine call");
}
}
+ else if ((flags == (GV_ADD|GV_NOEXPAND)) && gv && SvROK(gv)) {
+ cv = (CV*)gv;
+ }
else
cv = (CV*)&PL_sv_undef;
SETs((SV*)cv);
PP(pp_prototype)
{
- dSP;
+ dVAR; dSP;
CV *cv;
HV *stash;
GV *gv;
- SV *ret;
+ SV *ret = &PL_sv_undef;
- ret = &PL_sv_undef;
if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
- char *s = SvPVX(TOPs);
+ const char * const s = SvPVX_const(TOPs);
if (strnEQ(s, "CORE::", 6)) {
- int code;
-
- code = keyword(s + 6, SvCUR(TOPs) - 6);
+ const int code = keyword(s + 6, SvCUR(TOPs) - 6);
if (code < 0) { /* Overridable. */
#define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
int i = 0, n = 0, seen_question = 0;
I32 oa;
char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
+ if (code == -KEY_chop || code == -KEY_chomp
+ || code == -KEY_exec || code == -KEY_system)
+ goto set;
while (i < MAXO) { /* The slow way. */
if (strEQ(s + 6, PL_op_name[i])
|| strEQ(s + 6, PL_op_desc[i]))
seen_question = 1;
str[n++] = ';';
}
- else if (n && str[0] == ';' && seen_question)
- goto set; /* XXXX system, exec */
if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
&& (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
/* But globs are already references (kinda) */
}
}
}
- cv = sv_2cv(TOPs, &stash, &gv, FALSE);
+ cv = sv_2cv(TOPs, &stash, &gv, 0);
if (cv && SvPOK(cv))
- ret = sv_2mortal(newSVpvn(SvPVX(cv), SvCUR(cv)));
+ ret = sv_2mortal(newSVpvn(SvPVX_const(cv), SvCUR(cv)));
set:
SETs(ret);
RETURN;
PP(pp_anoncode)
{
- dSP;
- CV* cv = (CV*)PL_curpad[PL_op->op_targ];
+ dVAR; dSP;
+ CV* cv = (CV*)PAD_SV(PL_op->op_targ);
if (CvCLONE(cv))
cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
EXTEND(SP,1);
PP(pp_srefgen)
{
- dSP;
+ dVAR; dSP;
*SP = refto(*SP);
RETURN;
}
PP(pp_refgen)
{
- dSP; dMARK;
+ dVAR; dSP; dMARK;
if (GIMME != G_ARRAY) {
if (++MARK <= SP)
*MARK = *SP;
STATIC SV*
S_refto(pTHX_ SV *sv)
{
+ dVAR;
SV* rv;
if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
}
rv = sv_newmortal();
sv_upgrade(rv, SVt_RV);
- SvRV(rv) = sv;
+ SvRV_set(rv, sv);
SvROK_on(rv);
return rv;
}
PP(pp_ref)
{
- dSP; dTARGET;
- SV *sv;
- char *pv;
-
- sv = POPs;
+ dVAR; dSP; dTARGET;
+ const char *pv;
+ SV * const sv = POPs;
- if (sv && SvGMAGICAL(sv))
- mg_get(sv);
+ if (sv)
+ SvGETMAGIC(sv);
if (!sv || !SvROK(sv))
RETPUSHNO;
- sv = SvRV(sv);
- pv = sv_reftype(sv,TRUE);
+ pv = sv_reftype(SvRV(sv),TRUE);
PUSHp(pv, strlen(pv));
RETURN;
}
PP(pp_bless)
{
- dSP;
+ dVAR; dSP;
HV *stash;
if (MAXARG == 1)
stash = CopSTASH(PL_curcop);
else {
- SV *ssv = POPs;
+ SV * const ssv = POPs;
STRLEN len;
- char *ptr;
+ const char *ptr;
if (ssv && !SvGMAGICAL(ssv) && !SvAMAGIC(ssv) && SvROK(ssv))
Perl_croak(aTHX_ "Attempt to bless into a reference");
- ptr = SvPV(ssv,len);
- if (ckWARN(WARN_MISC) && len == 0)
- Perl_warner(aTHX_ WARN_MISC,
+ ptr = SvPV_const(ssv,len);
+ if (len == 0 && ckWARN(WARN_MISC))
+ Perl_warner(aTHX_ packWARN(WARN_MISC),
"Explicit blessing to '' (assuming package main)");
stash = gv_stashpvn(ptr, len, TRUE);
}
PP(pp_gelem)
{
- GV *gv;
- SV *sv;
- SV *tmpRef;
- char *elem;
- dSP;
- STRLEN n_a;
+ dVAR; dSP;
- sv = POPs;
- elem = SvPV(sv, n_a);
- gv = (GV*)POPs;
- tmpRef = Nullsv;
- sv = Nullsv;
- switch (elem ? *elem : '\0')
- {
- case 'A':
- if (strEQ(elem, "ARRAY"))
- tmpRef = (SV*)GvAV(gv);
- break;
- case 'C':
- if (strEQ(elem, "CODE"))
- tmpRef = (SV*)GvCVu(gv);
- break;
- case 'F':
- if (strEQ(elem, "FILEHANDLE")) {
- /* finally deprecated in 5.8.0 */
- deprecate("*glob{FILEHANDLE}");
- tmpRef = (SV*)GvIOp(gv);
+ SV *sv = POPs;
+ const char * const elem = SvPV_nolen_const(sv);
+ GV * const gv = (GV*)POPs;
+ SV * tmpRef = NULL;
+
+ sv = NULL;
+ if (elem) {
+ /* elem will always be NUL terminated. */
+ const char * const second_letter = elem + 1;
+ switch (*elem) {
+ case 'A':
+ if (strEQ(second_letter, "RRAY"))
+ tmpRef = (SV*)GvAV(gv);
+ break;
+ case 'C':
+ if (strEQ(second_letter, "ODE"))
+ tmpRef = (SV*)GvCVu(gv);
+ break;
+ case 'F':
+ if (strEQ(second_letter, "ILEHANDLE")) {
+ /* finally deprecated in 5.8.0 */
+ deprecate("*glob{FILEHANDLE}");
+ tmpRef = (SV*)GvIOp(gv);
+ }
+ else
+ if (strEQ(second_letter, "ORMAT"))
+ tmpRef = (SV*)GvFORM(gv);
+ break;
+ case 'G':
+ if (strEQ(second_letter, "LOB"))
+ tmpRef = (SV*)gv;
+ break;
+ case 'H':
+ if (strEQ(second_letter, "ASH"))
+ tmpRef = (SV*)GvHV(gv);
+ break;
+ case 'I':
+ if (*second_letter == 'O' && !elem[2])
+ tmpRef = (SV*)GvIOp(gv);
+ break;
+ case 'N':
+ if (strEQ(second_letter, "AME"))
+ sv = newSVpvn(GvNAME(gv), GvNAMELEN(gv));
+ break;
+ case 'P':
+ if (strEQ(second_letter, "ACKAGE")) {
+ const HV * const stash = GvSTASH(gv);
+ const HEK * const hek = stash ? HvNAME_HEK(stash) : NULL;
+ sv = hek ? newSVhek(hek) : newSVpvs("__ANON__");
+ }
+ break;
+ case 'S':
+ if (strEQ(second_letter, "CALAR"))
+ tmpRef = GvSV(gv);
+ break;
}
- else
- if (strEQ(elem, "FORMAT"))
- tmpRef = (SV*)GvFORM(gv);
- break;
- case 'G':
- if (strEQ(elem, "GLOB"))
- tmpRef = (SV*)gv;
- break;
- case 'H':
- if (strEQ(elem, "HASH"))
- tmpRef = (SV*)GvHV(gv);
- break;
- case 'I':
- if (strEQ(elem, "IO"))
- tmpRef = (SV*)GvIOp(gv);
- break;
- case 'N':
- if (strEQ(elem, "NAME"))
- sv = newSVpvn(GvNAME(gv), GvNAMELEN(gv));
- break;
- case 'P':
- if (strEQ(elem, "PACKAGE"))
- sv = newSVpv(HvNAME(GvSTASH(gv)), 0);
- break;
- case 'S':
- if (strEQ(elem, "SCALAR"))
- tmpRef = GvSV(gv);
- break;
}
if (tmpRef)
sv = newRV(tmpRef);
PP(pp_study)
{
- dSP; dPOPss;
+ dVAR; dSP; dPOPss;
register unsigned char *s;
register I32 pos;
register I32 ch;
if (pos > PL_maxscream) {
if (PL_maxscream < 0) {
PL_maxscream = pos + 80;
- New(301, PL_screamfirst, 256, I32);
- New(302, PL_screamnext, PL_maxscream, I32);
+ Newx(PL_screamfirst, 256, I32);
+ Newx(PL_screamnext, PL_maxscream, I32);
}
else {
PL_maxscream = pos + pos / 4;
sfirst -= 256;
while (--pos >= 0) {
- ch = s[pos];
+ register const I32 ch = s[pos];
if (sfirst[ch] >= 0)
snext[pos] = sfirst[ch] - pos;
else
SvSCREAM_on(sv);
/* piggyback on m//g magic */
- sv_magic(sv, Nullsv, PERL_MAGIC_regex_global, Nullch, 0);
+ sv_magic(sv, NULL, PERL_MAGIC_regex_global, NULL, 0);
RETPUSHYES;
}
PP(pp_trans)
{
- dSP; dTARG;
+ dVAR; dSP; dTARG;
SV *sv;
if (PL_op->op_flags & OPf_STACKED)
sv = POPs;
+ else if (PL_op->op_private & OPpTARGET_MY)
+ sv = GETTARGET;
else {
sv = DEFSV;
EXTEND(SP,1);
PP(pp_schop)
{
- dSP; dTARGET;
+ dVAR; dSP; dTARGET;
do_chop(TARG, TOPs);
SETTARG;
RETURN;
PP(pp_chop)
{
- dSP; dMARK; dTARGET; dORIGMARK;
+ dVAR; dSP; dMARK; dTARGET; dORIGMARK;
while (MARK < SP)
do_chop(TARG, *++MARK);
SP = ORIGMARK;
- PUSHTARG;
+ XPUSHTARG;
RETURN;
}
PP(pp_schomp)
{
- dSP; dTARGET;
+ dVAR; dSP; dTARGET;
SETi(do_chomp(TOPs));
RETURN;
}
PP(pp_chomp)
{
- dSP; dMARK; dTARGET;
+ dVAR; dSP; dMARK; dTARGET;
register I32 count = 0;
while (SP > MARK)
count += do_chomp(POPs);
- PUSHi(count);
+ XPUSHi(count);
RETURN;
}
-PP(pp_defined)
-{
- dSP;
- register SV* sv;
-
- sv = POPs;
- if (!sv || !SvANY(sv))
- RETPUSHNO;
- switch (SvTYPE(sv)) {
- case SVt_PVAV:
- if (AvMAX(sv) >= 0 || SvGMAGICAL(sv)
- || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
- RETPUSHYES;
- break;
- case SVt_PVHV:
- if (HvARRAY(sv) || SvGMAGICAL(sv)
- || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
- RETPUSHYES;
- break;
- case SVt_PVCV:
- if (CvROOT(sv) || CvXSUB(sv))
- RETPUSHYES;
- break;
- default:
- if (SvGMAGICAL(sv))
- mg_get(sv);
- if (SvOK(sv))
- RETPUSHYES;
- }
- RETPUSHNO;
-}
-
PP(pp_undef)
{
- dSP;
+ dVAR; dSP;
SV *sv;
if (!PL_op->op_private) {
if (!sv)
RETPUSHUNDEF;
- if (SvTHINKFIRST(sv))
- sv_force_normal(sv);
+ SV_CHECK_THINKFIRST_COW_DROP(sv);
switch (SvTYPE(sv)) {
case SVt_NULL:
hv_undef((HV*)sv);
break;
case SVt_PVCV:
- if (ckWARN(WARN_MISC) && cv_const_sv((CV*)sv))
- Perl_warner(aTHX_ WARN_MISC, "Constant subroutine %s undefined",
+ if (cv_const_sv((CV*)sv) && ckWARN(WARN_MISC))
+ Perl_warner(aTHX_ packWARN(WARN_MISC), "Constant subroutine %s undefined",
CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv)));
/* FALL THROUGH */
case SVt_PVFM:
{
/* let user-undef'd sub keep its identity */
- GV* gv = CvGV((CV*)sv);
+ GV* const gv = CvGV((CV*)sv);
cv_undef((CV*)sv);
CvGV((CV*)sv) = gv;
}
else {
GP *gp;
gp_free((GV*)sv);
- Newz(602, gp, 1, GP);
+ Newxz(gp, 1, GP);
GvGP(sv) = gp_ref(gp);
GvSV(sv) = NEWSV(72,0);
GvLINE(sv) = CopLINE(PL_curcop);
}
break;
default:
- if (SvTYPE(sv) >= SVt_PV && SvPVX(sv) && SvLEN(sv)) {
- (void)SvOOK_off(sv);
- Safefree(SvPVX(sv));
- SvPV_set(sv, Nullch);
+ if (SvTYPE(sv) >= SVt_PV && SvPVX_const(sv) && SvLEN(sv)) {
+ SvPV_free(sv);
+ SvPV_set(sv, NULL);
SvLEN_set(sv, 0);
}
- (void)SvOK_off(sv);
+ SvOK_off(sv);
SvSETMAGIC(sv);
}
PP(pp_predec)
{
- dSP;
- if (SvTYPE(TOPs) > SVt_PVLV)
+ dVAR; dSP;
+ if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
DIE(aTHX_ PL_no_modify);
if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
&& SvIVX(TOPs) != IV_MIN)
{
- --SvIVX(TOPs);
+ SvIV_set(TOPs, SvIVX(TOPs) - 1);
SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
}
else
PP(pp_postinc)
{
- dSP; dTARGET;
- if (SvTYPE(TOPs) > SVt_PVLV)
+ dVAR; dSP; dTARGET;
+ if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
DIE(aTHX_ PL_no_modify);
sv_setsv(TARG, TOPs);
if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
&& SvIVX(TOPs) != IV_MAX)
{
- ++SvIVX(TOPs);
+ SvIV_set(TOPs, SvIVX(TOPs) + 1);
SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
}
else
sv_inc(TOPs);
SvSETMAGIC(TOPs);
+ /* special case for undef: see thread at 2003-03/msg00536.html in archive */
if (!SvOK(TARG))
sv_setiv(TARG, 0);
SETs(TARG);
PP(pp_postdec)
{
- dSP; dTARGET;
- if (SvTYPE(TOPs) > SVt_PVLV)
+ dVAR; dSP; dTARGET;
+ if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
DIE(aTHX_ PL_no_modify);
sv_setsv(TARG, TOPs);
if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
&& SvIVX(TOPs) != IV_MIN)
{
- --SvIVX(TOPs);
+ SvIV_set(TOPs, SvIVX(TOPs) - 1);
SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
}
else
PP(pp_pow)
{
- dSP; dATARGET; tryAMAGICbin(pow,opASSIGN);
+ dVAR; dSP; dATARGET;
+#ifdef PERL_PRESERVE_IVUV
+ bool is_int = 0;
+#endif
+ tryAMAGICbin(pow,opASSIGN);
+#ifdef PERL_PRESERVE_IVUV
+ /* For integer to integer power, we do the calculation by hand wherever
+ we're sure it is safe; otherwise we call pow() and try to convert to
+ integer afterwards. */
{
- dPOPTOPnnrl;
- SETn( Perl_pow( left, right) );
- RETURN;
+ SvIV_please(TOPs);
+ if (SvIOK(TOPs)) {
+ SvIV_please(TOPm1s);
+ if (SvIOK(TOPm1s)) {
+ UV power;
+ bool baseuok;
+ UV baseuv;
+
+ if (SvUOK(TOPs)) {
+ power = SvUVX(TOPs);
+ } else {
+ const IV iv = SvIVX(TOPs);
+ if (iv >= 0) {
+ power = iv;
+ } else {
+ goto float_it; /* Can't do negative powers this way. */
+ }
+ }
+
+ baseuok = SvUOK(TOPm1s);
+ if (baseuok) {
+ baseuv = SvUVX(TOPm1s);
+ } else {
+ const IV iv = SvIVX(TOPm1s);
+ if (iv >= 0) {
+ baseuv = iv;
+ baseuok = TRUE; /* effectively it's a UV now */
+ } else {
+ baseuv = -iv; /* abs, baseuok == false records sign */
+ }
+ }
+ /* now we have integer ** positive integer. */
+ is_int = 1;
+
+ /* foo & (foo - 1) is zero only for a power of 2. */
+ if (!(baseuv & (baseuv - 1))) {
+ /* We are raising power-of-2 to a positive integer.
+ The logic here will work for any base (even non-integer
+ bases) but it can be less accurate than
+ pow (base,power) or exp (power * log (base)) when the
+ intermediate values start to spill out of the mantissa.
+ With powers of 2 we know this can't happen.
+ And powers of 2 are the favourite thing for perl
+ programmers to notice ** not doing what they mean. */
+ NV result = 1.0;
+ NV base = baseuok ? baseuv : -(NV)baseuv;
+
+ if (power & 1) {
+ result *= base;
+ }
+ while (power >>= 1) {
+ base *= base;
+ if (power & 1) {
+ result *= base;
+ }
+ }
+ SP--;
+ SETn( result );
+ SvIV_please(TOPs);
+ RETURN;
+ } else {
+ register unsigned int highbit = 8 * sizeof(UV);
+ register unsigned int diff = 8 * sizeof(UV);
+ while (diff >>= 1) {
+ highbit -= diff;
+ if (baseuv >> highbit) {
+ highbit += diff;
+ }
+ }
+ /* we now have baseuv < 2 ** highbit */
+ if (power * highbit <= 8 * sizeof(UV)) {
+ /* result will definitely fit in UV, so use UV math
+ on same algorithm as above */
+ register UV result = 1;
+ register UV base = baseuv;
+ const bool odd_power = (bool)(power & 1);
+ if (odd_power) {
+ result *= base;
+ }
+ while (power >>= 1) {
+ base *= base;
+ if (power & 1) {
+ result *= base;
+ }
+ }
+ SP--;
+ if (baseuok || !odd_power)
+ /* answer is positive */
+ SETu( result );
+ else if (result <= (UV)IV_MAX)
+ /* answer negative, fits in IV */
+ SETi( -(IV)result );
+ else if (result == (UV)IV_MIN)
+ /* 2's complement assumption: special case IV_MIN */
+ SETi( IV_MIN );
+ else
+ /* answer negative, doesn't fit */
+ SETn( -(NV)result );
+ RETURN;
+ }
+ }
+ }
+ }
+ }
+ float_it:
+#endif
+ {
+ dPOPTOPnnrl;
+ SETn( Perl_pow( left, right) );
+#ifdef PERL_PRESERVE_IVUV
+ if (is_int)
+ SvIV_please(TOPs);
+#endif
+ RETURN;
}
}
PP(pp_multiply)
{
- dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
+ dVAR; dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
#ifdef PERL_PRESERVE_IVUV
SvIV_please(TOPs);
if (SvIOK(TOPs)) {
if (auvok) {
alow = SvUVX(TOPm1s);
} else {
- IV aiv = SvIVX(TOPm1s);
+ const IV aiv = SvIVX(TOPm1s);
if (aiv >= 0) {
alow = aiv;
auvok = TRUE; /* effectively it's a UV now */
if (buvok) {
blow = SvUVX(TOPs);
} else {
- IV biv = SvIVX(TOPs);
+ const IV biv = SvIVX(TOPs);
if (biv >= 0) {
blow = biv;
buvok = TRUE; /* effectively it's a UV now */
} else if (!ahigh && !bhigh) {
/* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
so the unsigned multiply cannot overflow. */
- UV product = alow * blow;
+ const UV product = alow * blow;
if (auvok == buvok) {
/* -ve * -ve or +ve * +ve gives a +ve result. */
SP--;
PP(pp_divide)
{
- dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
+ dVAR; dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
/* Only try to do UV divide first
- if ((SLOPPYDIVIDE is true) or
+ if ((SLOPPYDIVIDE is true) or
(PERL_PRESERVE_IVUV is true and one or both SV is a UV too large
to preserve))
The assumption is that it is better to use floating point divide
right = SvUVX(TOPs);
}
else {
- IV biv = SvIVX(TOPs);
+ const IV biv = SvIVX(TOPs);
if (biv >= 0) {
right = biv;
right_non_neg = TRUE; /* effectively it's a UV now */
left = SvUVX(TOPm1s);
}
else {
- IV aiv = SvIVX(TOPm1s);
+ const IV aiv = SvIVX(TOPm1s);
if (aiv >= 0) {
left = aiv;
left_non_neg = TRUE; /* effectively it's a UV now */
#endif
) {
/* Integer division can't overflow, but it can be imprecise. */
- UV result = left / right;
+ const UV result = left / right;
if (result * right == left) {
SP--; /* result is valid */
if (left_non_neg == right_non_neg) {
}
/* 2s complement assumption */
if (result <= (UV)IV_MIN)
- SETi( -result );
+ SETi( -(IV)result );
else {
/* It's exact but too negative for IV. */
SETn( -(NV)result );
}
RETURN;
} /* tried integer divide but it was not an integer result */
- } /* else (abs(result) < 1.0) or (both UVs in range for NV) */
+ } /* else (PERL_ABS(result) < 1.0) or (both UVs in range for NV) */
} /* left wasn't SvIOK */
} /* right wasn't SvIOK */
#endif /* PERL_TRY_UV_DIVIDE */
PP(pp_modulo)
{
- dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
+ dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
{
UV left = 0;
UV right = 0;
- bool left_neg;
- bool right_neg;
+ bool left_neg = FALSE;
+ bool right_neg = FALSE;
bool use_double = FALSE;
bool dright_valid = FALSE;
NV dright = 0.0;
if (!right_neg) {
right = SvUVX(POPs);
} else {
- IV biv = SvIVX(POPs);
+ const IV biv = SvIVX(POPs);
if (biv >= 0) {
right = biv;
right_neg = FALSE; /* effectively it's a UV now */
if (!left_neg) {
left = SvUVX(POPs);
} else {
- IV aiv = SvIVX(POPs);
+ const IV aiv = SvIVX(POPs);
if (aiv >= 0) {
left = aiv;
left_neg = FALSE; /* effectively it's a UV now */
PP(pp_repeat)
{
- dSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
+ dVAR; dSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
{
- register IV count = POPi;
+ register IV count;
+ dPOPss;
+ SvGETMAGIC(sv);
+ if (SvIOKp(sv)) {
+ if (SvUOK(sv)) {
+ const UV uv = SvUV(sv);
+ if (uv > IV_MAX)
+ count = IV_MAX; /* The best we can do? */
+ else
+ count = uv;
+ } else {
+ const IV iv = SvIV(sv);
+ if (iv < 0)
+ count = 0;
+ else
+ count = iv;
+ }
+ }
+ else if (SvNOKp(sv)) {
+ const NV nv = SvNV(sv);
+ if (nv < 0.0)
+ count = 0;
+ else
+ count = (IV)nv;
+ }
+ else
+ count = SvIVx(sv);
if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
dMARK;
- I32 items = SP - MARK;
- I32 max;
-
- max = items * count;
+ static const char oom_list_extend[] = "Out of memory during list extend";
+ const I32 items = SP - MARK;
+ const I32 max = items * count;
+
+ MEM_WRAP_CHECK_1(max, SV*, oom_list_extend);
+ /* Did the max computation overflow? */
+ if (items > 0 && max > 0 && (max < items || max < count))
+ Perl_croak(aTHX_ oom_list_extend);
MEXTEND(MARK, max);
if (count > 1) {
while (SP > MARK) {
SP -= items;
}
else { /* Note: mark already snarfed by pp_list */
- SV *tmpstr = POPs;
+ SV * const tmpstr = POPs;
STRLEN len;
bool isutf;
+ static const char oom_string_extend[] =
+ "Out of memory during string extend";
SvSetSV(TARG, tmpstr);
SvPV_force(TARG, len);
if (count < 1)
SvCUR_set(TARG, 0);
else {
- SvGROW(TARG, (count * len) + 1);
+ const STRLEN max = (UV)count * len;
+ if (len > ((MEM_SIZE)~0)/count)
+ Perl_croak(aTHX_ oom_string_extend);
+ MEM_WRAP_CHECK_1(max, char, oom_string_extend);
+ SvGROW(TARG, max + 1);
repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
- SvCUR(TARG) *= count;
+ SvCUR_set(TARG, SvCUR(TARG) * count);
}
*SvEND(TARG) = '\0';
}
PP(pp_subtract)
{
- dSP; dATARGET; bool useleft; tryAMAGICbin(subtr,opASSIGN);
+ dVAR; dSP; dATARGET; bool useleft; tryAMAGICbin(subtr,opASSIGN);
useleft = USE_LEFT(TOPm1s);
#ifdef PERL_PRESERVE_IVUV
/* See comments in pp_add (in pp_hot.c) about Overflow, and how
if ((auvok = SvUOK(TOPm1s)))
auv = SvUVX(TOPm1s);
else {
- register IV aiv = SvIVX(TOPm1s);
+ register const IV aiv = SvIVX(TOPm1s);
if (aiv >= 0) {
auv = aiv;
auvok = 1; /* Now acting as a sign flag. */
if (buvok)
buv = SvUVX(TOPs);
else {
- register IV biv = SvIVX(TOPs);
+ register const IV biv = SvIVX(TOPs);
if (biv >= 0) {
buv = biv;
buvok = 1;
buv = (UV)-biv;
}
/* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
- else "IV" now, independant of how it came in.
+ else "IV" now, independent of how it came in.
if a, b represents positive, A, B negative, a maps to -A etc
a - b => (a - b)
A - b => -(a + b)
PP(pp_left_shift)
{
- dSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
+ dVAR; dSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
{
- IV shift = POPi;
+ const IV shift = POPi;
if (PL_op->op_private & HINT_INTEGER) {
- IV i = TOPi;
+ const IV i = TOPi;
SETi(i << shift);
}
else {
- UV u = TOPu;
+ const UV u = TOPu;
SETu(u << shift);
}
RETURN;
PP(pp_right_shift)
{
- dSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
+ dVAR; dSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
{
- IV shift = POPi;
+ const IV shift = POPi;
if (PL_op->op_private & HINT_INTEGER) {
- IV i = TOPi;
+ const IV i = TOPi;
SETi(i >> shift);
}
else {
- UV u = TOPu;
+ const UV u = TOPu;
SETu(u >> shift);
}
RETURN;
PP(pp_lt)
{
- dSP; tryAMAGICbinSET(lt,0);
+ dVAR; dSP; tryAMAGICbinSET(lt,0);
#ifdef PERL_PRESERVE_IVUV
SvIV_please(TOPs);
if (SvIOK(TOPs)) {
bool buvok = SvUOK(TOPs);
if (!auvok && !buvok) { /* ## IV < IV ## */
- IV aiv = SvIVX(TOPm1s);
- IV biv = SvIVX(TOPs);
+ const IV aiv = SvIVX(TOPm1s);
+ const IV biv = SvIVX(TOPs);
SP--;
SETs(boolSV(aiv < biv));
RETURN;
}
if (auvok && buvok) { /* ## UV < UV ## */
- UV auv = SvUVX(TOPm1s);
- UV buv = SvUVX(TOPs);
+ const UV auv = SvUVX(TOPm1s);
+ const UV buv = SvUVX(TOPs);
SP--;
SETs(boolSV(auv < buv));
}
if (auvok) { /* ## UV < IV ## */
UV auv;
- IV biv;
-
- biv = SvIVX(TOPs);
+ const IV biv = SvIVX(TOPs);
SP--;
if (biv < 0) {
/* As (a) is a UV, it's >=0, so it cannot be < */
RETURN;
}
{ /* ## IV < UV ## */
- IV aiv;
+ const IV aiv = SvIVX(TOPm1s);
UV buv;
- aiv = SvIVX(TOPm1s);
if (aiv < 0) {
/* As (b) is a UV, it's >=0, so it must be < */
SP--;
#ifdef PERL_PRESERVE_IVUV
else
#endif
- if (SvROK(TOPs) && SvROK(TOPm1s)) {
- SP--;
- SETs(boolSV(SvRV(TOPs) < SvRV(TOPp1s)));
- RETURN;
- }
+ if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
+ SP--;
+ SETs(boolSV(SvRV(TOPs) < SvRV(TOPp1s)));
+ RETURN;
+ }
#endif
{
dPOPnv;
PP(pp_gt)
{
- dSP; tryAMAGICbinSET(gt,0);
+ dVAR; dSP; tryAMAGICbinSET(gt,0);
#ifdef PERL_PRESERVE_IVUV
SvIV_please(TOPs);
if (SvIOK(TOPs)) {
bool buvok = SvUOK(TOPs);
if (!auvok && !buvok) { /* ## IV > IV ## */
- IV aiv = SvIVX(TOPm1s);
- IV biv = SvIVX(TOPs);
-
+ const IV aiv = SvIVX(TOPm1s);
+ const IV biv = SvIVX(TOPs);
+
SP--;
SETs(boolSV(aiv > biv));
RETURN;
}
if (auvok && buvok) { /* ## UV > UV ## */
- UV auv = SvUVX(TOPm1s);
- UV buv = SvUVX(TOPs);
+ const UV auv = SvUVX(TOPm1s);
+ const UV buv = SvUVX(TOPs);
SP--;
SETs(boolSV(auv > buv));
}
if (auvok) { /* ## UV > IV ## */
UV auv;
- IV biv;
-
- biv = SvIVX(TOPs);
+ const IV biv = SvIVX(TOPs);
+
SP--;
if (biv < 0) {
/* As (a) is a UV, it's >=0, so it must be > */
RETURN;
}
{ /* ## IV > UV ## */
- IV aiv;
+ const IV aiv = SvIVX(TOPm1s);
UV buv;
- aiv = SvIVX(TOPm1s);
if (aiv < 0) {
/* As (b) is a UV, it's >=0, so it cannot be > */
SP--;
#ifdef PERL_PRESERVE_IVUV
else
#endif
- if (SvROK(TOPs) && SvROK(TOPm1s)) {
+ if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
SP--;
SETs(boolSV(SvRV(TOPs) > SvRV(TOPp1s)));
RETURN;
PP(pp_le)
{
- dSP; tryAMAGICbinSET(le,0);
+ dVAR; dSP; tryAMAGICbinSET(le,0);
#ifdef PERL_PRESERVE_IVUV
SvIV_please(TOPs);
if (SvIOK(TOPs)) {
bool buvok = SvUOK(TOPs);
if (!auvok && !buvok) { /* ## IV <= IV ## */
- IV aiv = SvIVX(TOPm1s);
- IV biv = SvIVX(TOPs);
+ const IV aiv = SvIVX(TOPm1s);
+ const IV biv = SvIVX(TOPs);
SP--;
SETs(boolSV(aiv <= biv));
}
if (auvok) { /* ## UV <= IV ## */
UV auv;
- IV biv;
-
- biv = SvIVX(TOPs);
+ const IV biv = SvIVX(TOPs);
+
SP--;
if (biv < 0) {
/* As (a) is a UV, it's >=0, so a cannot be <= */
RETURN;
}
{ /* ## IV <= UV ## */
- IV aiv;
+ const IV aiv = SvIVX(TOPm1s);
UV buv;
-
- aiv = SvIVX(TOPm1s);
+
if (aiv < 0) {
/* As (b) is a UV, it's >=0, so a must be <= */
SP--;
#ifdef PERL_PRESERVE_IVUV
else
#endif
- if (SvROK(TOPs) && SvROK(TOPm1s)) {
+ if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
SP--;
SETs(boolSV(SvRV(TOPs) <= SvRV(TOPp1s)));
RETURN;
PP(pp_ge)
{
- dSP; tryAMAGICbinSET(ge,0);
+ dVAR; dSP; tryAMAGICbinSET(ge,0);
#ifdef PERL_PRESERVE_IVUV
SvIV_please(TOPs);
if (SvIOK(TOPs)) {
bool buvok = SvUOK(TOPs);
if (!auvok && !buvok) { /* ## IV >= IV ## */
- IV aiv = SvIVX(TOPm1s);
- IV biv = SvIVX(TOPs);
-
+ const IV aiv = SvIVX(TOPm1s);
+ const IV biv = SvIVX(TOPs);
+
SP--;
SETs(boolSV(aiv >= biv));
RETURN;
}
if (auvok && buvok) { /* ## UV >= UV ## */
- UV auv = SvUVX(TOPm1s);
- UV buv = SvUVX(TOPs);
-
+ const UV auv = SvUVX(TOPm1s);
+ const UV buv = SvUVX(TOPs);
+
SP--;
SETs(boolSV(auv >= buv));
RETURN;
}
if (auvok) { /* ## UV >= IV ## */
UV auv;
- IV biv;
-
- biv = SvIVX(TOPs);
+ const IV biv = SvIVX(TOPs);
+
SP--;
if (biv < 0) {
/* As (a) is a UV, it's >=0, so it must be >= */
RETURN;
}
{ /* ## IV >= UV ## */
- IV aiv;
+ const IV aiv = SvIVX(TOPm1s);
UV buv;
-
- aiv = SvIVX(TOPm1s);
+
if (aiv < 0) {
/* As (b) is a UV, it's >=0, so a cannot be >= */
SP--;
#ifdef PERL_PRESERVE_IVUV
else
#endif
- if (SvROK(TOPs) && SvROK(TOPm1s)) {
+ if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
SP--;
SETs(boolSV(SvRV(TOPs) >= SvRV(TOPp1s)));
RETURN;
PP(pp_ne)
{
- dSP; tryAMAGICbinSET(ne,0);
+ dVAR; dSP; tryAMAGICbinSET(ne,0);
#ifndef NV_PRESERVES_UV
- if (SvROK(TOPs) && SvROK(TOPm1s)) {
+ if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
SP--;
SETs(boolSV(SvRV(TOPs) != SvRV(TOPp1s)));
RETURN;
if (SvIOK(TOPs)) {
SvIV_please(TOPm1s);
if (SvIOK(TOPm1s)) {
- bool auvok = SvUOK(TOPm1s);
- bool buvok = SvUOK(TOPs);
+ const bool auvok = SvUOK(TOPm1s);
+ const bool buvok = SvUOK(TOPs);
if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
/* Casting IV to UV before comparison isn't going to matter
differ from normal zero. As I understand it. (Need to
check - is negative zero implementation defined behaviour
anyway?). NWC */
- UV buv = SvUVX(POPs);
- UV auv = SvUVX(TOPs);
-
+ const UV buv = SvUVX(POPs);
+ const UV auv = SvUVX(TOPs);
+
SETs(boolSV(auv != buv));
RETURN;
}
PP(pp_ncmp)
{
- dSP; dTARGET; tryAMAGICbin(ncmp,0);
+ dVAR; dSP; dTARGET; tryAMAGICbin(ncmp,0);
#ifndef NV_PRESERVES_UV
- if (SvROK(TOPs) && SvROK(TOPm1s)) {
- UV right = PTR2UV(SvRV(POPs));
- UV left = PTR2UV(SvRV(TOPs));
+ if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
+ const UV right = PTR2UV(SvRV(POPs));
+ const UV left = PTR2UV(SvRV(TOPs));
SETi((left > right) - (left < right));
RETURN;
}
if (SvIOK(TOPs)) {
SvIV_please(TOPm1s);
if (SvIOK(TOPm1s)) {
- bool leftuvok = SvUOK(TOPm1s);
- bool rightuvok = SvUOK(TOPs);
+ const bool leftuvok = SvUOK(TOPm1s);
+ const bool rightuvok = SvUOK(TOPs);
I32 value;
if (!leftuvok && !rightuvok) { /* ## IV <=> IV ## */
- IV leftiv = SvIVX(TOPm1s);
- IV rightiv = SvIVX(TOPs);
+ const IV leftiv = SvIVX(TOPm1s);
+ const IV rightiv = SvIVX(TOPs);
if (leftiv > rightiv)
value = 1;
else
value = 0;
} else if (leftuvok && rightuvok) { /* ## UV <=> UV ## */
- UV leftuv = SvUVX(TOPm1s);
- UV rightuv = SvUVX(TOPs);
+ const UV leftuv = SvUVX(TOPm1s);
+ const UV rightuv = SvUVX(TOPs);
if (leftuv > rightuv)
value = 1;
else
value = 0;
} else if (leftuvok) { /* ## UV <=> IV ## */
- UV leftuv;
- IV rightiv;
-
- rightiv = SvIVX(TOPs);
+ const IV rightiv = SvIVX(TOPs);
if (rightiv < 0) {
/* As (a) is a UV, it's >=0, so it cannot be < */
value = 1;
} else {
- leftuv = SvUVX(TOPm1s);
+ const UV leftuv = SvUVX(TOPm1s);
if (leftuv > (UV)rightiv) {
value = 1;
} else if (leftuv < (UV)rightiv) {
}
}
} else { /* ## IV <=> UV ## */
- IV leftiv;
- UV rightuv;
-
- leftiv = SvIVX(TOPm1s);
+ const IV leftiv = SvIVX(TOPm1s);
if (leftiv < 0) {
/* As (b) is a UV, it's >=0, so it must be < */
value = -1;
} else {
- rightuv = SvUVX(TOPs);
+ const UV rightuv = SvUVX(TOPs);
if ((UV)leftiv > rightuv) {
value = 1;
} else if ((UV)leftiv < rightuv) {
}
}
-PP(pp_slt)
+PP(pp_sle)
{
- dSP; tryAMAGICbinSET(slt,0);
- {
- dPOPTOPssrl;
- int cmp = (IN_LOCALE_RUNTIME
- ? sv_cmp_locale(left, right)
- : sv_cmp(left, right));
- SETs(boolSV(cmp < 0));
- RETURN;
- }
-}
+ dVAR; dSP;
-PP(pp_sgt)
-{
- dSP; tryAMAGICbinSET(sgt,0);
- {
- dPOPTOPssrl;
- int cmp = (IN_LOCALE_RUNTIME
- ? sv_cmp_locale(left, right)
- : sv_cmp(left, right));
- SETs(boolSV(cmp > 0));
- RETURN;
- }
-}
+ int amg_type = sle_amg;
+ int multiplier = 1;
+ int rhs = 1;
-PP(pp_sle)
-{
- dSP; tryAMAGICbinSET(sle,0);
- {
- dPOPTOPssrl;
- int cmp = (IN_LOCALE_RUNTIME
- ? sv_cmp_locale(left, right)
- : sv_cmp(left, right));
- SETs(boolSV(cmp <= 0));
- RETURN;
+ switch (PL_op->op_type) {
+ case OP_SLT:
+ amg_type = slt_amg;
+ /* cmp < 0 */
+ rhs = 0;
+ break;
+ case OP_SGT:
+ amg_type = sgt_amg;
+ /* cmp > 0 */
+ multiplier = -1;
+ rhs = 0;
+ break;
+ case OP_SGE:
+ amg_type = sge_amg;
+ /* cmp >= 0 */
+ multiplier = -1;
+ break;
}
-}
-PP(pp_sge)
-{
- dSP; tryAMAGICbinSET(sge,0);
+ tryAMAGICbinSET_var(amg_type,0);
{
dPOPTOPssrl;
- int cmp = (IN_LOCALE_RUNTIME
+ const int cmp = (IN_LOCALE_RUNTIME
? sv_cmp_locale(left, right)
: sv_cmp(left, right));
- SETs(boolSV(cmp >= 0));
+ SETs(boolSV(cmp * multiplier < rhs));
RETURN;
}
}
PP(pp_seq)
{
- dSP; tryAMAGICbinSET(seq,0);
+ dVAR; dSP; tryAMAGICbinSET(seq,0);
{
dPOPTOPssrl;
SETs(boolSV(sv_eq(left, right)));
PP(pp_sne)
{
- dSP; tryAMAGICbinSET(sne,0);
+ dVAR; dSP; tryAMAGICbinSET(sne,0);
{
dPOPTOPssrl;
SETs(boolSV(!sv_eq(left, right)));
PP(pp_scmp)
{
- dSP; dTARGET; tryAMAGICbin(scmp,0);
+ dVAR; dSP; dTARGET; tryAMAGICbin(scmp,0);
{
dPOPTOPssrl;
- int cmp = (IN_LOCALE_RUNTIME
+ const int cmp = (IN_LOCALE_RUNTIME
? sv_cmp_locale(left, right)
: sv_cmp(left, right));
SETi( cmp );
PP(pp_bit_and)
{
- dSP; dATARGET; tryAMAGICbin(band,opASSIGN);
+ dVAR; dSP; dATARGET; tryAMAGICbin(band,opASSIGN);
{
dPOPTOPssrl;
+ SvGETMAGIC(left);
+ SvGETMAGIC(right);
if (SvNIOKp(left) || SvNIOKp(right)) {
if (PL_op->op_private & HINT_INTEGER) {
- IV i = SvIV(left) & SvIV(right);
+ const IV i = SvIV_nomg(left) & SvIV_nomg(right);
SETi(i);
}
else {
- UV u = SvUV(left) & SvUV(right);
+ const UV u = SvUV_nomg(left) & SvUV_nomg(right);
SETu(u);
}
}
PP(pp_bit_xor)
{
- dSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
+ dVAR; dSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
{
dPOPTOPssrl;
+ SvGETMAGIC(left);
+ SvGETMAGIC(right);
if (SvNIOKp(left) || SvNIOKp(right)) {
if (PL_op->op_private & HINT_INTEGER) {
- IV i = (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right);
+ const IV i = (USE_LEFT(left) ? SvIV_nomg(left) : 0) ^ SvIV_nomg(right);
SETi(i);
}
else {
- UV u = (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right);
+ const UV u = (USE_LEFT(left) ? SvUV_nomg(left) : 0) ^ SvUV_nomg(right);
SETu(u);
}
}
PP(pp_bit_or)
{
- dSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
+ dVAR; dSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
{
dPOPTOPssrl;
+ SvGETMAGIC(left);
+ SvGETMAGIC(right);
if (SvNIOKp(left) || SvNIOKp(right)) {
if (PL_op->op_private & HINT_INTEGER) {
- IV i = (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right);
+ const IV i = (USE_LEFT(left) ? SvIV_nomg(left) : 0) | SvIV_nomg(right);
SETi(i);
}
else {
- UV u = (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right);
+ const UV u = (USE_LEFT(left) ? SvUV_nomg(left) : 0) | SvUV_nomg(right);
SETu(u);
}
}
PP(pp_negate)
{
- dSP; dTARGET; tryAMAGICun(neg);
+ dVAR; dSP; dTARGET; tryAMAGICun(neg);
{
dTOPss;
- int flags = SvFLAGS(sv);
- if (SvGMAGICAL(sv))
- mg_get(sv);
+ const int flags = SvFLAGS(sv);
+ SvGETMAGIC(sv);
if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
/* It's publicly an integer, or privately an integer-not-float */
oops_its_an_int:
SETn(-SvNV(sv));
else if (SvPOKp(sv)) {
STRLEN len;
- char *s = SvPV(sv, len);
+ const char * const s = SvPV_const(sv, len);
if (isIDFIRST(*s)) {
sv_setpvn(TARG, "-", 1);
sv_catsv(TARG, sv);
PP(pp_not)
{
- dSP; tryAMAGICunSET(not);
+ dVAR; dSP; tryAMAGICunSET(not);
*PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
return NORMAL;
}
PP(pp_complement)
{
- dSP; dTARGET; tryAMAGICun(compl);
+ dVAR; dSP; dTARGET; tryAMAGICun(compl);
{
dTOPss;
+ SvGETMAGIC(sv);
if (SvNIOKp(sv)) {
if (PL_op->op_private & HINT_INTEGER) {
- IV i = ~SvIV(sv);
+ const IV i = ~SvIV_nomg(sv);
SETi(i);
}
else {
- UV u = ~SvUV(sv);
+ const UV u = ~SvUV_nomg(sv);
SETu(u);
}
}
register I32 anum;
STRLEN len;
- SvSetSV(TARG, sv);
+ (void)SvPV_nomg_const(sv,len); /* force check for uninit var */
+ sv_setsv_nomg(TARG, sv);
tmps = (U8*)SvPV_force(TARG, len);
anum = len;
if (SvUTF8(TARG)) {
send = tmps + len;
while (tmps < send) {
- UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
+ const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
tmps += UTF8SKIP(tmps);
targlen += UNISKIP(~c);
nchar++;
tmps -= len;
if (nwide) {
- Newz(0, result, targlen + 1, U8);
+ Newxz(result, targlen + 1, U8);
while (tmps < send) {
- UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
+ const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
tmps += UTF8SKIP(tmps);
- result = uvchr_to_utf8(result, ~c);
+ result = uvchr_to_utf8_flags(result, ~c, UNICODE_ALLOW_ANY);
}
*result = '\0';
result -= targlen;
SvUTF8_on(TARG);
}
else {
- Newz(0, result, nchar + 1, U8);
+ Newxz(result, nchar + 1, U8);
while (tmps < send) {
- U8 c = (U8)utf8n_to_uvchr(tmps, 0, &l, UTF8_ALLOW_ANY);
+ const U8 c = (U8)utf8n_to_uvchr(tmps, 0, &l, UTF8_ALLOW_ANY);
tmps += UTF8SKIP(tmps);
*result++ = ~c;
}
*result = '\0';
result -= nchar;
sv_setpvn(TARG, (char*)result, nchar);
+ SvUTF8_off(TARG);
}
Safefree(result);
SETs(TARG);
PP(pp_i_multiply)
{
- dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
+ dVAR; dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
{
dPOPTOPiirl;
SETi( left * right );
PP(pp_i_divide)
{
- dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
+ dVAR; dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
{
dPOPiv;
if (value == 0)
}
}
+STATIC
+PP(pp_i_modulo_0)
+{
+ /* This is the vanilla old i_modulo. */
+ dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
+ {
+ dPOPTOPiirl;
+ if (!right)
+ DIE(aTHX_ "Illegal modulus zero");
+ SETi( left % right );
+ RETURN;
+ }
+}
+
+#if defined(__GLIBC__) && IVSIZE == 8
+STATIC
+PP(pp_i_modulo_1)
+{
+ /* This is the i_modulo with the workaround for the _moddi3 bug
+ * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
+ * See below for pp_i_modulo. */
+ dVAR; dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
+ {
+ dPOPTOPiirl;
+ if (!right)
+ DIE(aTHX_ "Illegal modulus zero");
+ SETi( left % PERL_ABS(right) );
+ RETURN;
+ }
+}
+#endif
+
PP(pp_i_modulo)
{
- dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
- {
- dPOPTOPiirl;
- if (!right)
- DIE(aTHX_ "Illegal modulus zero");
- SETi( left % right );
- RETURN;
- }
+ dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
+ {
+ dPOPTOPiirl;
+ if (!right)
+ DIE(aTHX_ "Illegal modulus zero");
+ /* The assumption is to use hereafter the old vanilla version... */
+ PL_op->op_ppaddr =
+ PL_ppaddr[OP_I_MODULO] =
+ Perl_pp_i_modulo_0;
+ /* .. but if we have glibc, we might have a buggy _moddi3
+ * (at least glicb 2.2.5 is known to have this bug), in other
+ * words our integer modulus with negative quad as the second
+ * argument might be broken. Test for this and re-patch the
+ * opcode dispatch table if that is the case, remembering to
+ * also apply the workaround so that this first round works
+ * right, too. See [perl #9402] for more information. */
+#if defined(__GLIBC__) && IVSIZE == 8
+ {
+ IV l = 3;
+ IV r = -10;
+ /* Cannot do this check with inlined IV constants since
+ * that seems to work correctly even with the buggy glibc. */
+ if (l % r == -3) {
+ /* Yikes, we have the bug.
+ * Patch in the workaround version. */
+ PL_op->op_ppaddr =
+ PL_ppaddr[OP_I_MODULO] =
+ &Perl_pp_i_modulo_1;
+ /* Make certain we work right this time, too. */
+ right = PERL_ABS(right);
+ }
+ }
+#endif
+ SETi( left % right );
+ RETURN;
+ }
}
PP(pp_i_add)
{
- dSP; dATARGET; tryAMAGICbin(add,opASSIGN);
+ dVAR; dSP; dATARGET; tryAMAGICbin(add,opASSIGN);
{
dPOPTOPiirl_ul;
SETi( left + right );
PP(pp_i_subtract)
{
- dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
+ dVAR; dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
{
dPOPTOPiirl_ul;
SETi( left - right );
PP(pp_i_lt)
{
- dSP; tryAMAGICbinSET(lt,0);
+ dVAR; dSP; tryAMAGICbinSET(lt,0);
{
dPOPTOPiirl;
SETs(boolSV(left < right));
PP(pp_i_gt)
{
- dSP; tryAMAGICbinSET(gt,0);
+ dVAR; dSP; tryAMAGICbinSET(gt,0);
{
dPOPTOPiirl;
SETs(boolSV(left > right));
PP(pp_i_le)
{
- dSP; tryAMAGICbinSET(le,0);
+ dVAR; dSP; tryAMAGICbinSET(le,0);
{
dPOPTOPiirl;
SETs(boolSV(left <= right));
PP(pp_i_ge)
{
- dSP; tryAMAGICbinSET(ge,0);
+ dVAR; dSP; tryAMAGICbinSET(ge,0);
{
dPOPTOPiirl;
SETs(boolSV(left >= right));
PP(pp_i_eq)
{
- dSP; tryAMAGICbinSET(eq,0);
+ dVAR; dSP; tryAMAGICbinSET(eq,0);
{
dPOPTOPiirl;
SETs(boolSV(left == right));
PP(pp_i_ne)
{
- dSP; tryAMAGICbinSET(ne,0);
+ dVAR; dSP; tryAMAGICbinSET(ne,0);
{
dPOPTOPiirl;
SETs(boolSV(left != right));
PP(pp_i_ncmp)
{
- dSP; dTARGET; tryAMAGICbin(ncmp,0);
+ dVAR; dSP; dTARGET; tryAMAGICbin(ncmp,0);
{
dPOPTOPiirl;
I32 value;
PP(pp_i_negate)
{
- dSP; dTARGET; tryAMAGICun(neg);
+ dVAR; dSP; dTARGET; tryAMAGICun(neg);
SETi(-TOPi);
RETURN;
}
PP(pp_atan2)
{
- dSP; dTARGET; tryAMAGICbin(atan2,0);
+ dVAR; dSP; dTARGET; tryAMAGICbin(atan2,0);
{
dPOPTOPnnrl;
SETn(Perl_atan2(left, right));
PP(pp_sin)
{
- dSP; dTARGET; tryAMAGICun(sin);
+ dVAR; dSP; dTARGET; tryAMAGICun(sin);
{
- NV value;
- value = POPn;
- value = Perl_sin(value);
- XPUSHn(value);
+ const NV value = POPn;
+ XPUSHn(Perl_sin(value));
RETURN;
}
}
PP(pp_cos)
{
- dSP; dTARGET; tryAMAGICun(cos);
+ dVAR; dSP; dTARGET; tryAMAGICun(cos);
{
- NV value;
- value = POPn;
- value = Perl_cos(value);
- XPUSHn(value);
+ const NV value = POPn;
+ XPUSHn(Perl_cos(value));
RETURN;
}
}
PP(pp_rand)
{
- dSP; dTARGET;
+ dVAR; dSP; dTARGET;
NV value;
if (MAXARG < 1)
value = 1.0;
PP(pp_srand)
{
- dSP;
- UV anum;
- if (MAXARG < 1)
- anum = seed();
- else
- anum = POPu;
+ dVAR; dSP;
+ const UV anum = (MAXARG < 1) ? seed() : POPu;
(void)seedDrand01((Rand_seed_t)anum);
PL_srand_called = TRUE;
EXTEND(SP, 1);
RETPUSHYES;
}
-STATIC U32
-S_seed(pTHX)
-{
- /*
- * This is really just a quick hack which grabs various garbage
- * values. It really should be a real hash algorithm which
- * spreads the effect of every input bit onto every output bit,
- * if someone who knows about such things would bother to write it.
- * Might be a good idea to add that function to CORE as well.
- * No numbers below come from careful analysis or anything here,
- * except they are primes and SEED_C1 > 1E6 to get a full-width
- * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
- * probably be bigger too.
- */
-#if RANDBITS > 16
-# define SEED_C1 1000003
-#define SEED_C4 73819
-#else
-# define SEED_C1 25747
-#define SEED_C4 20639
-#endif
-#define SEED_C2 3
-#define SEED_C3 269
-#define SEED_C5 26107
-
-#ifndef PERL_NO_DEV_RANDOM
- int fd;
-#endif
- U32 u;
-#ifdef VMS
-# include <starlet.h>
- /* when[] = (low 32 bits, high 32 bits) of time since epoch
- * in 100-ns units, typically incremented ever 10 ms. */
- unsigned int when[2];
-#else
-# ifdef HAS_GETTIMEOFDAY
- struct timeval when;
-# else
- Time_t when;
-# endif
-#endif
-
-/* This test is an escape hatch, this symbol isn't set by Configure. */
-#ifndef PERL_NO_DEV_RANDOM
-#ifndef PERL_RANDOM_DEVICE
- /* /dev/random isn't used by default because reads from it will block
- * if there isn't enough entropy available. You can compile with
- * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
- * is enough real entropy to fill the seed. */
-# define PERL_RANDOM_DEVICE "/dev/urandom"
-#endif
- fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
- if (fd != -1) {
- if (PerlLIO_read(fd, &u, sizeof u) != sizeof u)
- u = 0;
- PerlLIO_close(fd);
- if (u)
- return u;
- }
-#endif
-
-#ifdef VMS
- _ckvmssts(sys$gettim(when));
- u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
-#else
-# ifdef HAS_GETTIMEOFDAY
- gettimeofday(&when,(struct timezone *) 0);
- u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
-# else
- (void)time(&when);
- u = (U32)SEED_C1 * when;
-# endif
-#endif
- u += SEED_C3 * (U32)PerlProc_getpid();
- u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
-#ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
- u += SEED_C5 * (U32)PTR2UV(&when);
-#endif
- return u;
-}
-
PP(pp_exp)
{
- dSP; dTARGET; tryAMAGICun(exp);
+ dVAR; dSP; dTARGET; tryAMAGICun(exp);
{
NV value;
value = POPn;
PP(pp_log)
{
- dSP; dTARGET; tryAMAGICun(log);
+ dVAR; dSP; dTARGET; tryAMAGICun(log);
{
- NV value;
- value = POPn;
+ const NV value = POPn;
if (value <= 0.0) {
SET_NUMERIC_STANDARD();
- DIE(aTHX_ "Can't take log of %g", value);
+ DIE(aTHX_ "Can't take log of %"NVgf, value);
}
- value = Perl_log(value);
- XPUSHn(value);
+ XPUSHn(Perl_log(value));
RETURN;
}
}
PP(pp_sqrt)
{
- dSP; dTARGET; tryAMAGICun(sqrt);
+ dVAR; dSP; dTARGET; tryAMAGICun(sqrt);
{
- NV value;
- value = POPn;
+ const NV value = POPn;
if (value < 0.0) {
SET_NUMERIC_STANDARD();
- DIE(aTHX_ "Can't take sqrt of %g", value);
+ DIE(aTHX_ "Can't take sqrt of %"NVgf, value);
}
- value = Perl_sqrt(value);
- XPUSHn(value);
+ XPUSHn(Perl_sqrt(value));
RETURN;
}
}
-/*
- * There are strange code-generation bugs caused on sparc64 by gcc-2.95.2.
- * These need to be revisited when a newer toolchain becomes available.
- */
-#if defined(__sparc64__) && defined(__GNUC__)
-# if __GNUC__ < 2 || (__GNUC__ == 2 && __GNUC_MINOR__ < 96)
-# undef SPARC64_MODF_WORKAROUND
-# define SPARC64_MODF_WORKAROUND 1
-# endif
-#endif
-
-#if defined(SPARC64_MODF_WORKAROUND)
-static NV
-sparc64_workaround_modf(NV theVal, NV *theIntRes)
-{
- NV res, ret;
- ret = Perl_modf(theVal, &res);
- *theIntRes = res;
- return ret;
-}
-#endif
-
PP(pp_int)
{
- dSP; dTARGET; tryAMAGICun(int);
+ dVAR; dSP; dTARGET; tryAMAGICun(int);
{
- NV value;
- IV iv = TOPi; /* attempt to convert to IV if possible. */
+ const IV iv = TOPi; /* attempt to convert to IV if possible. */
/* XXX it's arguable that compiler casting to IV might be subtly
different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
else preferring IV has introduced a subtle behaviour change bug. OTOH
relying on floating point to be accurate is a bug. */
- if (SvIOK(TOPs)) {
+ if (!SvOK(TOPs))
+ SETu(0);
+ else if (SvIOK(TOPs)) {
if (SvIsUV(TOPs)) {
- UV uv = TOPu;
+ const UV uv = TOPu;
SETu(uv);
} else
SETi(iv);
} else {
- value = TOPn;
+ const NV value = TOPn;
if (value >= 0.0) {
if (value < (NV)UV_MAX + 0.5) {
SETu(U_V(value));
} else {
-#if defined(SPARC64_MODF_WORKAROUND)
- (void)sparc64_workaround_modf(value, &value);
-#else
-# if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE)
-# ifdef HAS_MODFL_POW32_BUG
-/* some versions of glibc split (i + d) into (i-1, d+1) for 2^32 <= i < 2^64 */
- {
- NV offset = Perl_modf(value, &value);
- (void)Perl_modf(offset, &offset);
- value += offset;
- }
-# else
- (void)Perl_modf(value, &value);
-# endif
-# else
- double tmp = (double)value;
- (void)Perl_modf(tmp, &tmp);
- value = (NV)tmp;
-# endif
-#endif
- SETn(value);
+ SETn(Perl_floor(value));
}
}
else {
if (value > (NV)IV_MIN - 0.5) {
SETi(I_V(value));
} else {
-#if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE)
-# ifdef HAS_MODFL_POW32_BUG
-/* some versions of glibc split (i + d) into (i-1, d+1) for 2^32 <= i < 2^64 */
- {
- NV offset = Perl_modf(-value, &value);
- (void)Perl_modf(offset, &offset);
- value += offset;
- }
-# else
- (void)Perl_modf(-value, &value);
-# endif
- value = -value;
-#else
- double tmp = (double)value;
- (void)Perl_modf(-tmp, &tmp);
- value = -(NV)tmp;
-#endif
- SETn(value);
+ SETn(Perl_ceil(value));
}
}
}
PP(pp_abs)
{
- dSP; dTARGET; tryAMAGICun(abs);
+ dVAR; dSP; dTARGET; tryAMAGICun(abs);
{
/* This will cache the NV value if string isn't actually integer */
- IV iv = TOPi;
+ const IV iv = TOPi;
- if (SvIOK(TOPs)) {
+ if (!SvOK(TOPs))
+ SETu(0);
+ else if (SvIOK(TOPs)) {
/* IVX is precise */
if (SvIsUV(TOPs)) {
SETu(TOPu); /* force it to be numeric only */
}
}
} else{
- NV value = TOPn;
+ const NV value = TOPn;
if (value < 0.0)
- value = -value;
- SETn(value);
+ SETn(-value);
+ else
+ SETn(value);
}
}
RETURN;
PP(pp_hex)
{
- dSP; dTARGET;
- char *tmps;
+ dVAR; dSP; dTARGET;
+ const char *tmps;
I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
STRLEN len;
NV result_nv;
UV result_uv;
+ SV* const sv = POPs;
- tmps = (SvPVx(POPs, len));
+ tmps = (SvPV_const(sv, len));
+ if (DO_UTF8(sv)) {
+ /* If Unicode, try to downgrade
+ * If not possible, croak. */
+ SV* const tsv = sv_2mortal(newSVsv(sv));
+
+ SvUTF8_on(tsv);
+ sv_utf8_downgrade(tsv, FALSE);
+ tmps = SvPV_const(tsv, len);
+ }
result_uv = grok_hex (tmps, &len, &flags, &result_nv);
if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
XPUSHn(result_nv);
PP(pp_oct)
{
- dSP; dTARGET;
- char *tmps;
+ dVAR; dSP; dTARGET;
+ const char *tmps;
I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
STRLEN len;
NV result_nv;
UV result_uv;
+ SV* const sv = POPs;
- tmps = (SvPVx(POPs, len));
+ tmps = (SvPV_const(sv, len));
+ if (DO_UTF8(sv)) {
+ /* If Unicode, try to downgrade
+ * If not possible, croak. */
+ SV* const tsv = sv_2mortal(newSVsv(sv));
+
+ SvUTF8_on(tsv);
+ sv_utf8_downgrade(tsv, FALSE);
+ tmps = SvPV_const(tsv, len);
+ }
while (*tmps && len && isSPACE(*tmps))
tmps++, len--;
if (*tmps == '0')
PP(pp_length)
{
- dSP; dTARGET;
- SV *sv = TOPs;
+ dVAR; dSP; dTARGET;
+ SV * const sv = TOPs;
if (DO_UTF8(sv))
SETi(sv_len_utf8(sv));
PP(pp_substr)
{
- dSP; dTARGET;
+ dVAR; dSP; dTARGET;
SV *sv;
I32 len = 0;
STRLEN curlen;
I32 pos;
I32 rem;
I32 fail;
- I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
- char *tmps;
- I32 arybase = PL_curcop->cop_arybase;
+ const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
+ const char *tmps;
+ const I32 arybase = PL_curcop->cop_arybase;
SV *repl_sv = NULL;
- char *repl = 0;
+ const char *repl = NULL;
STRLEN repl_len;
- int num_args = PL_op->op_private & 7;
+ const int num_args = PL_op->op_private & 7;
bool repl_need_utf8_upgrade = FALSE;
bool repl_is_utf8 = FALSE;
if (num_args > 2) {
if (num_args > 3) {
repl_sv = POPs;
- repl = SvPV(repl_sv, repl_len);
+ repl = SvPV_const(repl_sv, repl_len);
repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv);
}
len = POPi;
else if (DO_UTF8(sv))
repl_need_utf8_upgrade = TRUE;
}
- tmps = SvPV(sv, curlen);
+ tmps = SvPV_const(sv, curlen);
if (DO_UTF8(sv)) {
utf8_curlen = sv_len_utf8(sv);
if (utf8_curlen == curlen)
if (lvalue || repl)
Perl_croak(aTHX_ "substr outside of string");
if (ckWARN(WARN_SUBSTR))
- Perl_warner(aTHX_ WARN_SUBSTR, "substr outside of string");
+ Perl_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
RETPUSHUNDEF;
}
else {
- I32 upos = pos;
- I32 urem = rem;
+ const I32 upos = pos;
+ const I32 urem = rem;
if (utf8_curlen)
sv_pos_u2b(sv, &pos, &rem);
tmps += pos;
+ /* we either return a PV or an LV. If the TARG hasn't been used
+ * before, or is of that type, reuse it; otherwise use a mortal
+ * instead. Note that LVs can have an extended lifetime, so also
+ * dont reuse if refcount > 1 (bug #20933) */
+ if (SvTYPE(TARG) > SVt_NULL) {
+ if ( (SvTYPE(TARG) == SVt_PVLV)
+ ? (!lvalue || SvREFCNT(TARG) > 1)
+ : lvalue)
+ {
+ TARG = sv_newmortal();
+ }
+ }
+
sv_setpvn(TARG, tmps, rem);
#ifdef USE_LOCALE_COLLATE
sv_unmagic(TARG, PERL_MAGIC_collxfrm);
if (repl_need_utf8_upgrade) {
repl_sv_copy = newSVsv(repl_sv);
sv_utf8_upgrade(repl_sv_copy);
- repl = SvPV(repl_sv_copy, repl_len);
+ repl = SvPV_const(repl_sv_copy, repl_len);
repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv);
}
sv_insert(sv, pos, rem, repl, repl_len);
else if (lvalue) { /* it's an lvalue! */
if (!SvGMAGICAL(sv)) {
if (SvROK(sv)) {
- STRLEN n_a;
- SvPV_force(sv,n_a);
+ SvPV_force_nolen(sv);
if (ckWARN(WARN_SUBSTR))
- Perl_warner(aTHX_ WARN_SUBSTR,
+ Perl_warner(aTHX_ packWARN(WARN_SUBSTR),
"Attempt to use reference as lvalue in substr");
}
if (SvOK(sv)) /* is it defined ? */
if (SvTYPE(TARG) < SVt_PVLV) {
sv_upgrade(TARG, SVt_PVLV);
- sv_magic(TARG, Nullsv, PERL_MAGIC_substr, Nullch, 0);
+ sv_magic(TARG, NULL, PERL_MAGIC_substr, NULL, 0);
}
+ else
+ SvOK_off(TARG);
LvTYPE(TARG) = 'x';
if (LvTARG(TARG) != sv) {
PP(pp_vec)
{
- dSP; dTARGET;
- register IV size = POPi;
- register IV offset = POPi;
- register SV *src = POPs;
- I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
+ dVAR; dSP; dTARGET;
+ register const IV size = POPi;
+ register const IV offset = POPi;
+ register SV * const src = POPs;
+ const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
SvTAINTED_off(TARG); /* decontaminate */
if (lvalue) { /* it's an lvalue! */
+ if (SvREFCNT(TARG) > 1) /* don't share the TARG (#20933) */
+ TARG = sv_newmortal();
if (SvTYPE(TARG) < SVt_PVLV) {
sv_upgrade(TARG, SVt_PVLV);
- sv_magic(TARG, Nullsv, PERL_MAGIC_vec, Nullch, 0);
+ sv_magic(TARG, NULL, PERL_MAGIC_vec, NULL, 0);
}
LvTYPE(TARG) = 'v';
if (LvTARG(TARG) != src) {
PP(pp_index)
{
- dSP; dTARGET;
+ dVAR; dSP; dTARGET;
SV *big;
SV *little;
+ SV *temp = NULL;
I32 offset;
I32 retval;
- char *tmps;
- char *tmps2;
+ const char *tmps;
+ const char *tmps2;
STRLEN biglen;
- I32 arybase = PL_curcop->cop_arybase;
+ const I32 arybase = PL_curcop->cop_arybase;
+ int big_utf8;
+ int little_utf8;
if (MAXARG < 3)
offset = 0;
offset = POPi - arybase;
little = POPs;
big = POPs;
- tmps = SvPV(big, biglen);
- if (offset > 0 && DO_UTF8(big))
+ big_utf8 = DO_UTF8(big);
+ little_utf8 = DO_UTF8(little);
+ if (big_utf8 ^ little_utf8) {
+ /* One needs to be upgraded. */
+ SV * const bytes = little_utf8 ? big : little;
+ STRLEN len;
+ const char * const p = SvPV_const(bytes, len);
+
+ temp = newSVpvn(p, len);
+
+ if (PL_encoding) {
+ sv_recode_to_utf8(temp, PL_encoding);
+ } else {
+ sv_utf8_upgrade(temp);
+ }
+ if (little_utf8) {
+ big = temp;
+ big_utf8 = TRUE;
+ } else {
+ little = temp;
+ }
+ }
+ if (big_utf8 && offset > 0)
sv_pos_u2b(big, &offset, 0);
+ tmps = SvPV_const(big, biglen);
if (offset < 0)
offset = 0;
- else if (offset > biglen)
+ else if (offset > (I32)biglen)
offset = biglen;
if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
(unsigned char*)tmps + biglen, little, 0)))
retval = -1;
else
retval = tmps2 - tmps;
- if (retval > 0 && DO_UTF8(big))
+ if (retval > 0 && big_utf8)
sv_pos_b2u(big, &retval);
+ if (temp)
+ SvREFCNT_dec(temp);
PUSHi(retval + arybase);
RETURN;
}
PP(pp_rindex)
{
- dSP; dTARGET;
+ dVAR; dSP; dTARGET;
SV *big;
SV *little;
+ SV *temp = NULL;
STRLEN blen;
STRLEN llen;
I32 offset;
I32 retval;
- char *tmps;
- char *tmps2;
- I32 arybase = PL_curcop->cop_arybase;
+ const char *tmps;
+ const char *tmps2;
+ const I32 arybase = PL_curcop->cop_arybase;
+ int big_utf8;
+ int little_utf8;
if (MAXARG >= 3)
offset = POPi;
little = POPs;
big = POPs;
- tmps2 = SvPV(little, llen);
- tmps = SvPV(big, blen);
+ big_utf8 = DO_UTF8(big);
+ little_utf8 = DO_UTF8(little);
+ if (big_utf8 ^ little_utf8) {
+ /* One needs to be upgraded. */
+ SV * const bytes = little_utf8 ? big : little;
+ STRLEN len;
+ const char *p = SvPV_const(bytes, len);
+
+ temp = newSVpvn(p, len);
+
+ if (PL_encoding) {
+ sv_recode_to_utf8(temp, PL_encoding);
+ } else {
+ sv_utf8_upgrade(temp);
+ }
+ if (little_utf8) {
+ big = temp;
+ big_utf8 = TRUE;
+ } else {
+ little = temp;
+ }
+ }
+ tmps2 = SvPV_const(little, llen);
+ tmps = SvPV_const(big, blen);
+
if (MAXARG < 3)
offset = blen;
else {
- if (offset > 0 && DO_UTF8(big))
+ if (offset > 0 && big_utf8)
sv_pos_u2b(big, &offset, 0);
offset = offset - arybase + llen;
}
if (offset < 0)
offset = 0;
- else if (offset > blen)
+ else if (offset > (I32)blen)
offset = blen;
if (!(tmps2 = rninstr(tmps, tmps + offset,
tmps2, tmps2 + llen)))
retval = -1;
else
retval = tmps2 - tmps;
- if (retval > 0 && DO_UTF8(big))
+ if (retval > 0 && big_utf8)
sv_pos_b2u(big, &retval);
+ if (temp)
+ SvREFCNT_dec(temp);
PUSHi(retval + arybase);
RETURN;
}
PP(pp_sprintf)
{
- dSP; dMARK; dORIGMARK; dTARGET;
+ dVAR; dSP; dMARK; dORIGMARK; dTARGET;
do_sprintf(TARG, SP-MARK, MARK+1);
TAINT_IF(SvTAINTED(TARG));
- if (DO_UTF8(*(MARK+1)))
- SvUTF8_on(TARG);
SP = ORIGMARK;
PUSHTARG;
RETURN;
PP(pp_ord)
{
- dSP; dTARGET;
+ dVAR; dSP; dTARGET;
SV *argsv = POPs;
STRLEN len;
- U8 *s = (U8*)SvPVx(argsv, len);
+ const U8 *s = (U8*)SvPV_const(argsv, len);
SV *tmpsv;
- if (PL_encoding && !DO_UTF8(argsv)) {
+ if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
tmpsv = sv_2mortal(newSVsv(argsv));
- s = (U8*)Perl_sv_recode_to_utf8(aTHX_ tmpsv, PL_encoding);
+ s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
argsv = tmpsv;
}
- XPUSHu(DO_UTF8(argsv) ? utf8_to_uvchr(s, 0) : (*s & 0xff));
-
+ XPUSHu(DO_UTF8(argsv) ?
+ utf8n_to_uvchr(s, UTF8_MAXBYTES, 0, UTF8_ALLOW_ANYUV) :
+ (*s & 0xff));
+
RETURN;
}
PP(pp_chr)
{
- dSP; dTARGET;
+ dVAR; dSP; dTARGET;
char *tmps;
- UV value = POPu;
+ UV value;
- (void)SvUPGRADE(TARG,SVt_PV);
+ if (((SvIOK_notUV(TOPs) && SvIV(TOPs) < 0)
+ ||
+ (SvNOK(TOPs) && SvNV(TOPs) < 0.0))) {
+ if (IN_BYTES) {
+ value = POPu; /* chr(-1) eq chr(0xff), etc. */
+ } else {
+ (void) POPs; /* Ignore the argument value. */
+ value = UNICODE_REPLACEMENT;
+ }
+ } else {
+ value = POPu;
+ }
+
+ SvUPGRADE(TARG,SVt_PV);
if (value > 255 && !IN_BYTES) {
- SvGROW(TARG, UNISKIP(value)+1);
- tmps = (char*)uvchr_to_utf8((U8*)SvPVX(TARG), value);
- SvCUR_set(TARG, tmps - SvPVX(TARG));
+ SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
+ tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
+ SvCUR_set(TARG, tmps - SvPVX_const(TARG));
*tmps = '\0';
(void)SvPOK_only(TARG);
SvUTF8_on(TARG);
SvGROW(TARG,2);
SvCUR_set(TARG, 1);
tmps = SvPVX(TARG);
- *tmps++ = value;
+ *tmps++ = (char)value;
*tmps = '\0';
(void)SvPOK_only(TARG);
- if (PL_encoding)
- Perl_sv_recode_to_utf8(aTHX_ TARG, PL_encoding);
+ if (PL_encoding && !IN_BYTES) {
+ sv_recode_to_utf8(TARG, PL_encoding);
+ tmps = SvPVX(TARG);
+ if (SvCUR(TARG) == 0 || !is_utf8_string((U8*)tmps, SvCUR(TARG)) ||
+ memEQ(tmps, "\xef\xbf\xbd\0", 4)) {
+ SvGROW(TARG, 3);
+ tmps = SvPVX(TARG);
+ SvCUR_set(TARG, 2);
+ *tmps++ = (U8)UTF8_EIGHT_BIT_HI(value);
+ *tmps++ = (U8)UTF8_EIGHT_BIT_LO(value);
+ *tmps = '\0';
+ SvUTF8_on(TARG);
+ }
+ }
XPUSHs(TARG);
RETURN;
}
PP(pp_crypt)
{
- dSP; dTARGET;
#ifdef HAS_CRYPT
+ dVAR; dSP; dTARGET;
dPOPTOPssrl;
- STRLEN n_a;
STRLEN len;
- char *tmps = SvPV(left, len);
- char *t = 0;
+ const char *tmps = SvPV_const(left, len);
+
if (DO_UTF8(left)) {
- /* If Unicode take the crypt() of the low 8 bits
- * of the characters of the string. */
- char *s = tmps;
- char *send = tmps + len;
- STRLEN i = 0;
- Newz(688, t, len, char);
- while (s < send) {
- t[i++] = utf8_to_uvchr((U8*)s, 0) & 0xFF;
- s += UTF8SKIP(s);
- }
- tmps = t;
+ /* If Unicode, try to downgrade.
+ * If not possible, croak.
+ * Yes, we made this up. */
+ SV* const tsv = sv_2mortal(newSVsv(left));
+
+ SvUTF8_on(tsv);
+ sv_utf8_downgrade(tsv, FALSE);
+ tmps = SvPV_const(tsv, len);
+ }
+# ifdef USE_ITHREADS
+# ifdef HAS_CRYPT_R
+ if (!PL_reentrant_buffer->_crypt_struct_buffer) {
+ /* This should be threadsafe because in ithreads there is only
+ * one thread per interpreter. If this would not be true,
+ * we would need a mutex to protect this malloc. */
+ PL_reentrant_buffer->_crypt_struct_buffer =
+ (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
+#if defined(__GLIBC__) || defined(__EMX__)
+ if (PL_reentrant_buffer->_crypt_struct_buffer) {
+ PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
+ /* work around glibc-2.2.5 bug */
+ PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
+ }
+#endif
}
+# endif /* HAS_CRYPT_R */
+# endif /* USE_ITHREADS */
# ifdef FCRYPT
- sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
+ sv_setpv(TARG, fcrypt(tmps, SvPV_nolen_const(right)));
# else
- sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
+ sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right)));
# endif
- Safefree(t);
+ SETs(TARG);
+ RETURN;
#else
DIE(aTHX_
"The crypt() function is unimplemented due to excessive paranoia.");
#endif
- SETs(TARG);
- RETURN;
}
PP(pp_ucfirst)
{
+ dVAR;
dSP;
SV *sv = TOPs;
- register U8 *s;
+ const U8 *s;
STRLEN slen;
+ const int op_type = PL_op->op_type;
- if (DO_UTF8(sv)) {
- U8 tmpbuf[UTF8_MAXLEN*2+1];
+ SvGETMAGIC(sv);
+ if (DO_UTF8(sv) &&
+ (s = (const U8*)SvPV_nomg_const(sv, slen)) && slen &&
+ UTF8_IS_START(*s)) {
+ U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
STRLEN ulen;
STRLEN tculen;
- s = (U8*)SvPV(sv, slen);
utf8_to_uvchr(s, &ulen);
+ if (op_type == OP_UCFIRST) {
+ toTITLE_utf8(s, tmpbuf, &tculen);
+ } else {
+ toLOWER_utf8(s, tmpbuf, &tculen);
+ }
- toTITLE_utf8(s, tmpbuf, &tculen);
- utf8_to_uvchr(tmpbuf, 0);
-
- if (!SvPADTMP(sv) || SvREADONLY(sv)) {
+ if (!SvPADTMP(sv) || SvREADONLY(sv) || ulen != tculen) {
dTARGET;
+ /* slen is the byte length of the whole SV.
+ * ulen is the byte length of the original Unicode character
+ * stored as UTF-8 at s.
+ * tculen is the byte length of the freshly titlecased (or
+ * lowercased) Unicode character stored as UTF-8 at tmpbuf.
+ * We first set the result to be the titlecased (/lowercased)
+ * character, and then append the rest of the SV data. */
sv_setpvn(TARG, (char*)tmpbuf, tculen);
- sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
+ if (slen > ulen)
+ sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
SvUTF8_on(TARG);
SETs(TARG);
}
else {
- s = (U8*)SvPV_force(sv, slen);
+ s = (U8*)SvPV_force_nomg(sv, slen);
Copy(tmpbuf, s, tculen, U8);
}
}
else {
+ U8 *s1;
if (!SvPADTMP(sv) || SvREADONLY(sv)) {
dTARGET;
SvUTF8_off(TARG); /* decontaminate */
- sv_setsv(TARG, sv);
+ sv_setsv_nomg(TARG, sv);
sv = TARG;
SETs(sv);
}
- s = (U8*)SvPV_force(sv, slen);
- if (*s) {
+ s1 = (U8*)SvPV_force_nomg(sv, slen);
+ if (*s1) {
if (IN_LOCALE_RUNTIME) {
TAINT;
SvTAINTED_on(sv);
- *s = toUPPER_LC(*s);
+ *s1 = (op_type == OP_UCFIRST)
+ ? toUPPER_LC(*s1) : toLOWER_LC(*s1);
}
else
- *s = toUPPER(*s);
+ *s1 = (op_type == OP_UCFIRST) ? toUPPER(*s1) : toLOWER(*s1);
}
}
- if (SvSMAGICAL(sv))
- mg_set(sv);
- RETURN;
-}
-
-PP(pp_lcfirst)
-{
- dSP;
- SV *sv = TOPs;
- register U8 *s;
- STRLEN slen;
-
- if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && UTF8_IS_START(*s)) {
- STRLEN ulen;
- U8 tmpbuf[UTF8_MAXLEN*2+1];
- U8 *tend;
- UV uv;
-
- toLOWER_utf8(s, tmpbuf, &ulen);
- uv = utf8_to_uvchr(tmpbuf, 0);
-
- tend = uvchr_to_utf8(tmpbuf, uv);
-
- if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) {
- dTARGET;
- sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
- sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
- SvUTF8_on(TARG);
- SETs(TARG);
- }
- else {
- s = (U8*)SvPV_force(sv, slen);
- Copy(tmpbuf, s, ulen, U8);
- }
- }
- else {
- if (!SvPADTMP(sv) || SvREADONLY(sv)) {
- dTARGET;
- SvUTF8_off(TARG); /* decontaminate */
- sv_setsv(TARG, sv);
- sv = TARG;
- SETs(sv);
- }
- s = (U8*)SvPV_force(sv, slen);
- if (*s) {
- if (IN_LOCALE_RUNTIME) {
- TAINT;
- SvTAINTED_on(sv);
- *s = toLOWER_LC(*s);
- }
- else
- *s = toLOWER(*s);
- }
- }
- if (SvSMAGICAL(sv))
- mg_set(sv);
+ SvSETMAGIC(sv);
RETURN;
}
PP(pp_uc)
{
+ dVAR;
dSP;
SV *sv = TOPs;
- register U8 *s;
STRLEN len;
+ SvGETMAGIC(sv);
if (DO_UTF8(sv)) {
dTARGET;
STRLEN ulen;
register U8 *d;
- U8 *send;
- U8 tmpbuf[UTF8_MAXLEN*2+1];
+ const U8 *s;
+ const U8 *send;
+ U8 tmpbuf[UTF8_MAXBYTES+1];
- s = (U8*)SvPV(sv,len);
+ s = (const U8*)SvPV_nomg_const(sv,len);
if (!len) {
SvUTF8_off(TARG); /* decontaminate */
sv_setpvn(TARG, "", 0);
SETs(TARG);
}
else {
- (void)SvUPGRADE(TARG, SVt_PV);
- SvGROW(TARG, (len * 2) + 1);
+ STRLEN min = len + 1;
+
+ SvUPGRADE(TARG, SVt_PV);
+ SvGROW(TARG, min);
(void)SvPOK_only(TARG);
d = (U8*)SvPVX(TARG);
send = s + len;
while (s < send) {
+ STRLEN u = UTF8SKIP(s);
+
toUPPER_utf8(s, tmpbuf, &ulen);
+ if (ulen > u && (SvLEN(TARG) < (min += ulen - u))) {
+ /* If the eventually required minimum size outgrows
+ * the available space, we need to grow. */
+ const UV o = d - (U8*)SvPVX_const(TARG);
+
+ /* If someone uppercases one million U+03B0s we
+ * SvGROW() one million times. Or we could try
+ * guessing how much to allocate without allocating
+ * too much. Such is life. */
+ SvGROW(TARG, min);
+ d = (U8*)SvPVX(TARG) + o;
+ }
Copy(tmpbuf, d, ulen, U8);
d += ulen;
- s += UTF8SKIP(s);
+ s += u;
}
*d = '\0';
SvUTF8_on(TARG);
- SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
+ SvCUR_set(TARG, d - (U8*)SvPVX_const(TARG));
SETs(TARG);
}
}
else {
+ U8 *s;
if (!SvPADTMP(sv) || SvREADONLY(sv)) {
dTARGET;
SvUTF8_off(TARG); /* decontaminate */
- sv_setsv(TARG, sv);
+ sv_setsv_nomg(TARG, sv);
sv = TARG;
SETs(sv);
}
- s = (U8*)SvPV_force(sv, len);
+ s = (U8*)SvPV_force_nomg(sv, len);
if (len) {
- register U8 *send = s + len;
+ register const U8 *send = s + len;
if (IN_LOCALE_RUNTIME) {
TAINT;
}
}
}
- if (SvSMAGICAL(sv))
- mg_set(sv);
+ SvSETMAGIC(sv);
RETURN;
}
PP(pp_lc)
{
+ dVAR;
dSP;
SV *sv = TOPs;
- register U8 *s;
STRLEN len;
+ SvGETMAGIC(sv);
if (DO_UTF8(sv)) {
dTARGET;
+ const U8 *s;
STRLEN ulen;
register U8 *d;
- U8 *send;
- U8 tmpbuf[UTF8_MAXLEN*2+1];
+ const U8 *send;
+ U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
- s = (U8*)SvPV(sv,len);
+ s = (const U8*)SvPV_nomg_const(sv,len);
if (!len) {
SvUTF8_off(TARG); /* decontaminate */
sv_setpvn(TARG, "", 0);
SETs(TARG);
}
else {
- (void)SvUPGRADE(TARG, SVt_PV);
- SvGROW(TARG, (len * 2) + 1);
+ STRLEN min = len + 1;
+
+ SvUPGRADE(TARG, SVt_PV);
+ SvGROW(TARG, min);
(void)SvPOK_only(TARG);
d = (U8*)SvPVX(TARG);
send = s + len;
while (s < send) {
- UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
-#define GREEK_CAPITAL_LETTER_SIGMA 0x03A3 /* Unicode */
+ const STRLEN u = UTF8SKIP(s);
+ const UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
+
+#define GREEK_CAPITAL_LETTER_SIGMA 0x03A3 /* Unicode U+03A3 */
if (uv == GREEK_CAPITAL_LETTER_SIGMA) {
/*
* Now if the sigma is NOT followed by
* then it should be mapped to 0x03C2,
* (GREEK SMALL LETTER FINAL SIGMA),
* instead of staying 0x03A3.
- * See lib/unicore/SpecCase.txt.
+ * "should be": in other words,
+ * this is not implemented yet.
+ * See lib/unicore/SpecialCasing.txt.
*/
}
+ if (ulen > u && (SvLEN(TARG) < (min += ulen - u))) {
+ /* If the eventually required minimum size outgrows
+ * the available space, we need to grow. */
+ const UV o = d - (U8*)SvPVX_const(TARG);
+
+ /* If someone lowercases one million U+0130s we
+ * SvGROW() one million times. Or we could try
+ * guessing how much to allocate without allocating.
+ * too much. Such is life. */
+ SvGROW(TARG, min);
+ d = (U8*)SvPVX(TARG) + o;
+ }
Copy(tmpbuf, d, ulen, U8);
d += ulen;
- s += UTF8SKIP(s);
+ s += u;
}
*d = '\0';
SvUTF8_on(TARG);
- SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
+ SvCUR_set(TARG, d - (U8*)SvPVX_const(TARG));
SETs(TARG);
}
}
else {
+ U8 *s;
if (!SvPADTMP(sv) || SvREADONLY(sv)) {
dTARGET;
SvUTF8_off(TARG); /* decontaminate */
- sv_setsv(TARG, sv);
+ sv_setsv_nomg(TARG, sv);
sv = TARG;
SETs(sv);
}
- s = (U8*)SvPV_force(sv, len);
+ s = (U8*)SvPV_force_nomg(sv, len);
if (len) {
- register U8 *send = s + len;
+ register const U8 * const send = s + len;
if (IN_LOCALE_RUNTIME) {
TAINT;
}
}
}
- if (SvSMAGICAL(sv))
- mg_set(sv);
+ SvSETMAGIC(sv);
RETURN;
}
PP(pp_quotemeta)
{
- dSP; dTARGET;
- SV *sv = TOPs;
+ dVAR; dSP; dTARGET;
+ SV * const sv = TOPs;
STRLEN len;
- register char *s = SvPV(sv,len);
- register char *d;
+ register const char *s = SvPV_const(sv,len);
SvUTF8_off(TARG); /* decontaminate */
if (len) {
- (void)SvUPGRADE(TARG, SVt_PV);
+ register char *d;
+ SvUPGRADE(TARG, SVt_PV);
SvGROW(TARG, (len * 2) + 1);
d = SvPVX(TARG);
if (DO_UTF8(sv)) {
}
}
*d = '\0';
- SvCUR_set(TARG, d - SvPVX(TARG));
+ SvCUR_set(TARG, d - SvPVX_const(TARG));
(void)SvPOK_only_UTF8(TARG);
}
else
PP(pp_aslice)
{
- dSP; dMARK; dORIGMARK;
- register SV** svp;
- register AV* av = (AV*)POPs;
- register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
- I32 arybase = PL_curcop->cop_arybase;
- I32 elem;
+ dVAR; dSP; dMARK; dORIGMARK;
+ register AV* const av = (AV*)POPs;
+ register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
if (SvTYPE(av) == SVt_PVAV) {
+ const I32 arybase = PL_curcop->cop_arybase;
if (lval && PL_op->op_private & OPpLVAL_INTRO) {
+ register SV **svp;
I32 max = -1;
for (svp = MARK + 1; svp <= SP; svp++) {
- elem = SvIVx(*svp);
+ const I32 elem = SvIVx(*svp);
if (elem > max)
max = elem;
}
av_extend(av, max);
}
while (++MARK <= SP) {
- elem = SvIVx(*MARK);
+ register SV **svp;
+ I32 elem = SvIVx(*MARK);
if (elem > 0)
elem -= arybase;
}
if (GIMME != G_ARRAY) {
MARK = ORIGMARK;
- *++MARK = *SP;
+ *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
SP = MARK;
}
RETURN;
PP(pp_each)
{
+ dVAR;
dSP;
- HV *hash = (HV*)POPs;
+ HV * const hash = (HV*)POPs;
HE *entry;
- I32 gimme = GIMME_V;
- I32 realhv = (SvTYPE(hash) == SVt_PVHV);
+ const I32 gimme = GIMME_V;
PUTBACK;
/* might clobber stack_sp */
- entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash);
+ entry = hv_iternext(hash);
SPAGAIN;
EXTEND(SP, 2);
if (entry) {
- PUSHs(hv_iterkeysv(entry)); /* won't clobber stack_sp */
+ SV* const sv = hv_iterkeysv(entry);
+ PUSHs(sv); /* won't clobber stack_sp */
if (gimme == G_ARRAY) {
SV *val;
PUTBACK;
/* might clobber stack_sp */
- val = realhv ?
- hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry);
+ val = hv_iterval(hash, entry);
SPAGAIN;
PUSHs(val);
}
RETURN;
}
-PP(pp_values)
-{
- return do_kv();
-}
-
-PP(pp_keys)
-{
- return do_kv();
-}
-
PP(pp_delete)
{
+ dVAR;
dSP;
- I32 gimme = GIMME_V;
- I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
- SV *sv;
- HV *hv;
+ const I32 gimme = GIMME_V;
+ const I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
if (PL_op->op_private & OPpSLICE) {
dMARK; dORIGMARK;
- U32 hvtype;
- hv = (HV*)POPs;
- hvtype = SvTYPE(hv);
+ HV * const hv = (HV*)POPs;
+ const U32 hvtype = SvTYPE(hv);
if (hvtype == SVt_PVHV) { /* hash element */
while (++MARK <= SP) {
- sv = hv_delete_ent(hv, *MARK, discard, 0);
+ SV * const sv = hv_delete_ent(hv, *MARK, discard, 0);
*MARK = sv ? sv : &PL_sv_undef;
}
}
- else if (hvtype == SVt_PVAV) {
- if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
- while (++MARK <= SP) {
- sv = av_delete((AV*)hv, SvIV(*MARK), discard);
- *MARK = sv ? sv : &PL_sv_undef;
- }
- }
- else { /* pseudo-hash element */
- while (++MARK <= SP) {
- sv = avhv_delete_ent((AV*)hv, *MARK, 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((AV*)hv, SvIV(*MARK), discard);
+ *MARK = sv ? sv : &PL_sv_undef;
+ }
+ }
}
else
DIE(aTHX_ "Not a HASH reference");
SP = ORIGMARK;
else if (gimme == G_SCALAR) {
MARK = ORIGMARK;
- *++MARK = *SP;
+ if (SP > MARK)
+ *++MARK = *SP;
+ else
+ *++MARK = &PL_sv_undef;
SP = MARK;
}
}
else {
SV *keysv = POPs;
- hv = (HV*)POPs;
+ HV * const hv = (HV*)POPs;
+ SV *sv;
if (SvTYPE(hv) == SVt_PVHV)
sv = hv_delete_ent(hv, keysv, discard, 0);
else if (SvTYPE(hv) == SVt_PVAV) {
if (PL_op->op_flags & OPf_SPECIAL)
sv = av_delete((AV*)hv, SvIV(keysv), discard);
else
- sv = avhv_delete_ent((AV*)hv, keysv, discard, 0);
+ DIE(aTHX_ "panic: avhv_delete no longer supported");
}
else
DIE(aTHX_ "Not a HASH reference");
PP(pp_exists)
{
+ dVAR;
dSP;
SV *tmpsv;
HV *hv;
if (PL_op->op_private & OPpEXISTS_SUB) {
GV *gv;
- CV *cv;
- SV *sv = POPs;
- cv = sv_2cv(sv, &hv, &gv, FALSE);
+ SV * const sv = POPs;
+ CV * const cv = sv_2cv(sv, &hv, &gv, 0);
if (cv)
RETPUSHYES;
if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
if (av_exists((AV*)hv, SvIV(tmpsv)))
RETPUSHYES;
}
- else if (avhv_exists_ent((AV*)hv, tmpsv, 0)) /* pseudo-hash element */
- RETPUSHYES;
}
else {
DIE(aTHX_ "Not a HASH reference");
PP(pp_hslice)
{
- dSP; dMARK; dORIGMARK;
- register HV *hv = (HV*)POPs;
- register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
- I32 realhv = (SvTYPE(hv) == SVt_PVHV);
+ dVAR; dSP; dMARK; dORIGMARK;
+ register HV * const hv = (HV*)POPs;
+ register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
+ const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
+ bool other_magic = FALSE;
+
+ if (localizing) {
+ MAGIC *mg;
+ HV *stash;
+
+ other_magic = mg_find((SV*)hv, PERL_MAGIC_env) ||
+ ((mg = mg_find((SV*)hv, PERL_MAGIC_tied))
+ /* Try to preserve the existenceness of a tied hash
+ * element by using EXISTS and DELETE if possible.
+ * Fallback to FETCH and STORE otherwise */
+ && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
+ && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
+ && gv_fetchmethod_autoload(stash, "DELETE", TRUE));
+ }
+
+ while (++MARK <= SP) {
+ SV * const keysv = *MARK;
+ SV **svp;
+ HE *he;
+ bool preeminent = FALSE;
+
+ if (localizing) {
+ preeminent = SvRMAGICAL(hv) && !other_magic ? 1 :
+ hv_exists_ent(hv, keysv, 0);
+ }
- if (!realhv && PL_op->op_private & OPpLVAL_INTRO)
- DIE(aTHX_ "Can't localize pseudo-hash element");
+ he = hv_fetch_ent(hv, keysv, lval, 0);
+ svp = he ? &HeVAL(he) : 0;
- if (realhv || SvTYPE(hv) == SVt_PVAV) {
- while (++MARK <= SP) {
- SV *keysv = *MARK;
- SV **svp;
- I32 preeminent = SvRMAGICAL(hv) ? 1 :
- realhv ? hv_exists_ent(hv, keysv, 0)
- : avhv_exists_ent((AV*)hv, keysv, 0);
- if (realhv) {
- HE *he = hv_fetch_ent(hv, keysv, lval, 0);
- svp = he ? &HeVAL(he) : 0;
- }
- else {
- svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0);
- }
- if (lval) {
- if (!svp || *svp == &PL_sv_undef) {
- STRLEN n_a;
- DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
- }
- if (PL_op->op_private & OPpLVAL_INTRO) {
- if (preeminent)
- save_helem(hv, keysv, svp);
- else {
- STRLEN keylen;
- char *key = SvPV(keysv, keylen);
- SAVEDELETE(hv, savepvn(key,keylen), keylen);
- }
+ if (lval) {
+ if (!svp || *svp == &PL_sv_undef) {
+ DIE(aTHX_ PL_no_helem_sv, keysv);
+ }
+ if (localizing) {
+ if (preeminent)
+ save_helem(hv, keysv, svp);
+ else {
+ STRLEN keylen;
+ const char *key = SvPV_const(keysv, keylen);
+ SAVEDELETE(hv, savepvn(key,keylen), keylen);
}
- }
- *MARK = svp ? *svp : &PL_sv_undef;
- }
+ }
+ }
+ *MARK = svp ? *svp : &PL_sv_undef;
}
if (GIMME != G_ARRAY) {
MARK = ORIGMARK;
- *++MARK = *SP;
+ *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
SP = MARK;
}
RETURN;
PP(pp_list)
{
- dSP; dMARK;
+ dVAR; dSP; dMARK;
if (GIMME != G_ARRAY) {
if (++MARK <= SP)
*MARK = *SP; /* unwanted list, return last item */
PP(pp_lslice)
{
+ dVAR;
dSP;
- SV **lastrelem = PL_stack_sp;
- SV **lastlelem = PL_stack_base + POPMARK;
- SV **firstlelem = PL_stack_base + POPMARK + 1;
- register SV **firstrelem = lastlelem + 1;
- I32 arybase = PL_curcop->cop_arybase;
- I32 lval = PL_op->op_flags & OPf_MOD;
- I32 is_something_there = lval;
-
- register I32 max = lastrelem - lastlelem;
+ SV ** const lastrelem = PL_stack_sp;
+ SV ** const lastlelem = PL_stack_base + POPMARK;
+ SV ** const firstlelem = PL_stack_base + POPMARK + 1;
+ register SV ** const firstrelem = lastlelem + 1;
+ const I32 arybase = PL_curcop->cop_arybase;
+ I32 is_something_there = PL_op->op_flags & OPf_MOD;
+
+ register const I32 max = lastrelem - lastlelem;
register SV **lelem;
- register I32 ix;
if (GIMME != G_ARRAY) {
- ix = SvIVx(*lastlelem);
+ I32 ix = SvIVx(*lastlelem);
if (ix < 0)
ix += max;
else
}
for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
- ix = SvIVx(*lelem);
+ I32 ix = SvIVx(*lelem);
if (ix < 0)
ix += max;
else
PP(pp_anonlist)
{
- dSP; dMARK; dORIGMARK;
- I32 items = SP - MARK;
- SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
+ dVAR; dSP; dMARK; dORIGMARK;
+ const I32 items = SP - MARK;
+ SV * const av = sv_2mortal((SV*)av_make(items, MARK+1));
SP = ORIGMARK; /* av_make() might realloc stack_sp */
XPUSHs(av);
RETURN;
PP(pp_anonhash)
{
- dSP; dMARK; dORIGMARK;
- HV* hv = (HV*)sv_2mortal((SV*)newHV());
+ dVAR; dSP; dMARK; dORIGMARK;
+ HV* const hv = (HV*)sv_2mortal((SV*)newHV());
while (MARK < SP) {
- SV* key = *++MARK;
- SV *val = NEWSV(46, 0);
+ SV * const key = *++MARK;
+ SV * const val = NEWSV(46, 0);
if (MARK < SP)
sv_setsv(val, *++MARK);
else if (ckWARN(WARN_MISC))
- Perl_warner(aTHX_ WARN_MISC, "Odd number of elements in hash assignment");
+ Perl_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
(void)hv_store_ent(hv,key,val,0);
}
SP = ORIGMARK;
PP(pp_splice)
{
- dSP; dMARK; dORIGMARK;
+ dVAR; dSP; dMARK; dORIGMARK;
register AV *ary = (AV*)*++MARK;
register SV **src;
register SV **dst;
I32 newlen;
I32 after;
I32 diff;
- SV **tmparyval = 0;
- MAGIC *mg;
+ SV **tmparyval = NULL;
+ const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied);
- if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
+ if (mg) {
*MARK-- = SvTIED_obj((SV*)ary, mg);
PUSHMARK(MARK);
PUTBACK;
offset = 0;
length = AvMAX(ary) + 1;
}
- if (offset > AvFILLp(ary) + 1)
+ if (offset > AvFILLp(ary) + 1) {
+ if (ckWARN(WARN_MISC))
+ Perl_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
offset = AvFILLp(ary) + 1;
+ }
after = AvFILLp(ary) + 1 - (offset + length);
if (after < 0) { /* not that much array */
length += after; /* offset+length now in array */
if (newlen && !AvREAL(ary) && AvREIFY(ary))
av_reify(ary);
+ /* make new elements SVs now: avoid problems if they're from the array */
+ for (dst = MARK, i = newlen; i; i--) {
+ SV * const h = *dst;
+ *dst++ = newSVsv(h);
+ }
+
if (diff < 0) { /* shrinking the area */
if (newlen) {
- New(451, tmparyval, newlen, SV*); /* so remember insertion */
+ Newx(tmparyval, newlen, SV*); /* so remember insertion */
Copy(MARK, tmparyval, newlen, SV*);
}
*dst-- = *src--;
}
dst = AvARRAY(ary);
- SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
+ SvPV_set(ary, (char*)(AvARRAY(ary) - diff)); /* diff is negative */
AvMAX(ary) += diff;
}
else {
dst[--i] = &PL_sv_undef;
if (newlen) {
- for (src = tmparyval, dst = AvARRAY(ary) + offset;
- newlen; newlen--) {
- *dst = NEWSV(46, 0);
- sv_setsv(*dst++, *src++);
- }
+ Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* );
Safefree(tmparyval);
}
}
else { /* no, expanding (or same) */
if (length) {
- New(452, tmparyval, length, SV*); /* so remember deletion */
+ Newx(tmparyval, length, SV*); /* so remember deletion */
Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
}
dst = src - diff;
Move(src, dst, offset, SV*);
}
- SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
+ SvPV_set(ary, (char*)(AvARRAY(ary) - diff));/* diff is positive */
AvMAX(ary) += diff;
AvFILLp(ary) += diff;
}
}
}
- for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
- *dst = NEWSV(46, 0);
- sv_setsv(*dst++, *src++);
+ if (newlen) {
+ Copy( MARK, AvARRAY(ary) + offset, newlen, SV* );
}
+
MARK = ORIGMARK + 1;
if (GIMME == G_ARRAY) { /* copy return vals to stack */
if (length) {
PP(pp_push)
{
- dSP; dMARK; dORIGMARK; dTARGET;
+ dVAR; dSP; dMARK; dORIGMARK; dTARGET;
register AV *ary = (AV*)*++MARK;
- register SV *sv = &PL_sv_undef;
- MAGIC *mg;
+ const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied);
- if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
+ if (mg) {
*MARK-- = SvTIED_obj((SV*)ary, mg);
PUSHMARK(MARK);
PUTBACK;
call_method("PUSH",G_SCALAR|G_DISCARD);
LEAVE;
SPAGAIN;
+ SP = ORIGMARK;
+ PUSHi( AvFILL(ary) + 1 );
}
else {
- /* Why no pre-extend of ary here ? */
for (++MARK; MARK <= SP; MARK++) {
- sv = NEWSV(51, 0);
+ SV * const sv = NEWSV(51, 0);
if (*MARK)
sv_setsv(sv, *MARK);
- av_push(ary, sv);
+ av_store(ary, AvFILLp(ary)+1, sv);
}
+ SP = ORIGMARK;
+ PUSHi( AvFILLp(ary) + 1 );
}
- SP = ORIGMARK;
- PUSHi( AvFILL(ary) + 1 );
RETURN;
}
PP(pp_pop)
{
+ dVAR;
dSP;
- AV *av = (AV*)POPs;
- SV *sv = av_pop(av);
+ AV * const av = (AV*)POPs;
+ SV * const sv = av_pop(av);
if (AvREAL(av))
(void)sv_2mortal(sv);
PUSHs(sv);
PP(pp_shift)
{
+ dVAR;
dSP;
- AV *av = (AV*)POPs;
- SV *sv = av_shift(av);
+ AV * const av = (AV*)POPs;
+ SV * const sv = av_shift(av);
EXTEND(SP, 1);
if (!sv)
RETPUSHUNDEF;
PP(pp_unshift)
{
- dSP; dMARK; dORIGMARK; dTARGET;
+ dVAR; dSP; dMARK; dORIGMARK; dTARGET;
register AV *ary = (AV*)*++MARK;
- register SV *sv;
- register I32 i = 0;
- MAGIC *mg;
+ const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied);
- if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
+ if (mg) {
*MARK-- = SvTIED_obj((SV*)ary, mg);
PUSHMARK(MARK);
PUTBACK;
SPAGAIN;
}
else {
+ register I32 i = 0;
av_unshift(ary, SP - MARK);
while (MARK < SP) {
- sv = NEWSV(27, 0);
- sv_setsv(sv, *++MARK);
+ SV * const sv = newSVsv(*++MARK);
(void)av_store(ary, i++, sv);
}
}
PP(pp_reverse)
{
- dSP; dMARK;
- register SV *tmp;
- SV **oldsp = SP;
+ dVAR; dSP; dMARK;
+ SV ** const oldsp = SP;
if (GIMME == G_ARRAY) {
MARK++;
while (MARK < SP) {
- tmp = *MARK;
+ register SV * const tmp = *MARK;
*MARK++ = *SP;
*SP-- = tmp;
}
register I32 tmp;
dTARGET;
STRLEN len;
+ I32 padoff_du;
SvUTF8_off(TARG); /* decontaminate */
if (SP - MARK > 1)
do_join(TARG, &PL_sv_no, MARK, SP);
else
- sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
+ sv_setsv(TARG, (SP > MARK)
+ ? *SP
+ : (padoff_du = find_rundefsvoffset(),
+ (padoff_du == NOT_IN_PAD || PAD_COMPNAME_FLAGS(padoff_du) & SVpad_OUR)
+ ? DEFSV : PAD_SVl(padoff_du)));
up = SvPV_force(TARG, len);
if (len > 1) {
if (DO_UTF8(TARG)) { /* first reverse each character */
U8* s = (U8*)SvPVX(TARG);
- U8* send = (U8*)(s + len);
+ const U8* send = (U8*)(s + len);
while (s < send) {
if (UTF8_IS_INVARIANT(*s)) {
s++;
while (down > up) {
tmp = *up;
*up++ = *down;
- *down-- = tmp;
+ *down-- = (char)tmp;
}
}
}
while (down > up) {
tmp = *up;
*up++ = *down;
- *down-- = tmp;
+ *down-- = (char)tmp;
}
(void)SvPOK_only_UTF8(TARG);
}
PP(pp_split)
{
- dSP; dTARG;
+ dVAR; dSP; dTARG;
AV *ary;
register IV limit = POPi; /* note, negative is forever */
- SV *sv = POPs;
+ SV * const sv = POPs;
STRLEN len;
- register char *s = SvPV(sv, len);
- bool do_utf8 = DO_UTF8(sv);
- char *strend = s + len;
+ register const char *s = SvPV_const(sv, len);
+ const bool do_utf8 = DO_UTF8(sv);
+ const char *strend = s + len;
register PMOP *pm;
register REGEXP *rx;
register SV *dstr;
- register char *m;
+ register const char *m;
I32 iters = 0;
- STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (strend - s);
+ const STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (strend - s);
I32 maxiters = slen + 10;
- I32 i;
- char *orig;
- I32 origlimit = limit;
+ const char *orig;
+ const I32 origlimit = limit;
I32 realarray = 0;
I32 base;
- AV *oldstack = PL_curstack;
- I32 gimme = GIMME_V;
- I32 oldsave = PL_savestack_ix;
+ const I32 gimme = GIMME_V;
+ const I32 oldsave = PL_savestack_ix;
I32 make_mortal = 1;
+ bool multiline = 0;
MAGIC *mg = (MAGIC *) NULL;
#ifdef DEBUGGING
TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
(pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
- PL_reg_match_utf8 = do_utf8;
+ RX_MATCH_UTF8_set(rx, do_utf8);
if (pm->op_pmreplroot) {
#ifdef USE_ITHREADS
- ary = GvAVn((GV*)PL_curpad[INT2PTR(PADOFFSET, pm->op_pmreplroot)]);
+ ary = GvAVn((GV*)PAD_SVl(INT2PTR(PADOFFSET, pm->op_pmreplroot)));
#else
ary = GvAVn((GV*)pm->op_pmreplroot);
#endif
}
else if (gimme != G_ARRAY)
-#ifdef USE_5005THREADS
- ary = (AV*)PL_curpad[0];
-#else
ary = GvAVn(PL_defgv);
-#endif /* USE_5005THREADS */
else
- ary = Nullav;
+ ary = NULL;
if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
realarray = 1;
PUTBACK;
}
else {
if (!AvREAL(ary)) {
+ I32 i;
AvREAL_on(ary);
AvREIFY_off(ary);
for (i = AvFILLp(ary); i >= 0; i--)
AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
}
/* temporarily switch stacks */
- SWITCHSTACK(PL_curstack, ary);
+ SAVESWITCHSTACK(PL_curstack, ary);
make_mortal = 0;
}
}
s++;
}
}
- if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
- SAVEINT(PL_multiline);
- PL_multiline = pm->op_pmflags & PMf_MULTILINE;
+ if (pm->op_pmflags & PMf_MULTILINE) {
+ multiline = 1;
}
if (!limit)
if (m >= strend)
break;
- dstr = NEWSV(30, m-s);
- sv_setpvn(dstr, s, m-s);
+ dstr = newSVpvn(s, m-s);
if (make_mortal)
sv_2mortal(dstr);
if (do_utf8)
++s;
}
}
- else if (strEQ("^", rx->precomp)) {
+ else if (rx->precomp[0] == '^' && rx->precomp[1] == '\0') {
while (--limit) {
- /*SUPPRESS 530*/
- for (m = s; m < strend && *m != '\n'; m++) ;
+ for (m = s; m < strend && *m != '\n'; m++)
+ ;
m++;
if (m >= strend)
break;
- dstr = NEWSV(30, m-s);
- sv_setpvn(dstr, s, m-s);
+ dstr = newSVpvn(s, m-s);
if (make_mortal)
sv_2mortal(dstr);
if (do_utf8)
(rx->reganch & RE_USE_INTUIT) && !rx->nparens
&& (rx->reganch & ROPT_CHECK_ALL)
&& !(rx->reganch & ROPT_ANCH)) {
- int tail = (rx->reganch & RE_INTUIT_TAIL);
- SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
+ const int tail = (rx->reganch & RE_INTUIT_TAIL);
+ SV * const csv = CALLREG_INTUIT_STRING(aTHX_ rx);
len = rx->minlen;
if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
- STRLEN n_a;
- char c = *SvPV(csv, n_a);
+ const char c = *SvPV_nolen_const(csv);
while (--limit) {
- /*SUPPRESS 530*/
- for (m = s; m < strend && *m != c; m++) ;
+ for (m = s; m < strend && *m != c; m++)
+ ;
if (m >= strend)
break;
- dstr = NEWSV(30, m-s);
- sv_setpvn(dstr, s, m-s);
+ dstr = newSVpvn(s, m-s);
if (make_mortal)
sv_2mortal(dstr);
if (do_utf8)
}
}
else {
-#ifndef lint
while (s < strend && --limit &&
(m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
- csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
-#endif
+ csv, multiline ? FBMrf_MULTILINE : 0)) )
{
- dstr = NEWSV(31, m-s);
- sv_setpvn(dstr, s, m-s);
+ dstr = newSVpvn(s, m-s);
if (make_mortal)
sv_2mortal(dstr);
if (do_utf8)
}
else {
maxiters += slen * rx->nparens;
- while (s < strend && --limit
-/* && (!rx->check_substr
- || ((s = CALLREG_INTUIT_START(aTHX_ rx, sv, s, strend,
- 0, NULL))))
-*/ && CALLREGEXEC(aTHX_ rx, s, strend, orig,
- 1 /* minend */, sv, NULL, 0))
+ while (s < strend && --limit)
{
+ I32 rex_return;
+ PUTBACK;
+ rex_return = CALLREGEXEC(aTHX_ rx, (char*)s, (char*)strend, (char*)orig, 1 ,
+ sv, NULL, 0);
+ SPAGAIN;
+ if (rex_return == 0)
+ break;
TAINT_IF(RX_MATCH_TAINTED(rx));
if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
m = s;
strend = s + (strend - m);
}
m = rx->startp[0] + orig;
- dstr = NEWSV(32, m-s);
- sv_setpvn(dstr, s, m-s);
+ dstr = newSVpvn(s, m-s);
if (make_mortal)
sv_2mortal(dstr);
if (do_utf8)
(void)SvUTF8_on(dstr);
XPUSHs(dstr);
if (rx->nparens) {
- for (i = 1; i <= rx->nparens; i++) {
+ I32 i;
+ for (i = 1; i <= (I32)rx->nparens; i++) {
s = rx->startp[i] + orig;
m = rx->endp[i] + orig;
parens that didn't match -- they should be set to
undef, not the empty string */
if (m >= orig && s >= orig) {
- dstr = NEWSV(33, m-s);
- sv_setpvn(dstr, s, m-s);
+ dstr = newSVpvn(s, m-s);
}
else
dstr = &PL_sv_undef; /* undef, not "" */
}
}
- LEAVE_SCOPE(oldsave);
iters = (SP - PL_stack_base) - base;
if (iters > maxiters)
DIE(aTHX_ "Split loop");
/* keep field after final delim? */
if (s < strend || (iters && origlimit)) {
- STRLEN l = strend - s;
- dstr = NEWSV(34, l);
- sv_setpvn(dstr, s, l);
+ const STRLEN l = strend - s;
+ dstr = newSVpvn(s, l);
if (make_mortal)
sv_2mortal(dstr);
if (do_utf8)
iters++;
}
else if (!origlimit) {
- while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
- iters--, SP--;
+ while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
+ if (TOPs && !make_mortal)
+ sv_2mortal(TOPs);
+ iters--;
+ *SP-- = &PL_sv_undef;
+ }
}
+ PUTBACK;
+ LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */
+ SPAGAIN;
if (realarray) {
if (!mg) {
- SWITCHSTACK(ary, oldstack);
if (SvSMAGICAL(ary)) {
PUTBACK;
mg_set((SV*)ary);
LEAVE;
SPAGAIN;
if (gimme == G_ARRAY) {
+ I32 i;
/* EXTEND should not be needed - we just popped them */
EXTEND(SP, iters);
for (i=0; i < iters; i++) {
if (gimme == G_ARRAY)
RETURN;
}
- if (iters || !pm->op_pmreplroot) {
- GETTARGET;
- PUSHi(iters);
- RETURN;
- }
- RETPUSHUNDEF;
-}
-#ifdef USE_5005THREADS
-void
-Perl_unlock_condpair(pTHX_ void *svv)
-{
- MAGIC *mg = mg_find((SV*)svv, PERL_MAGIC_mutex);
-
- if (!mg)
- Perl_croak(aTHX_ "panic: unlock_condpair unlocking non-mutex");
- MUTEX_LOCK(MgMUTEXP(mg));
- if (MgOWNER(mg) != thr)
- Perl_croak(aTHX_ "panic: unlock_condpair unlocking mutex that we don't own");
- MgOWNER(mg) = 0;
- COND_SIGNAL(MgOWNERCONDP(mg));
- DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": unlock 0x%"UVxf"\n",
- PTR2UV(thr), PTR2UV(svv)));
- MUTEX_UNLOCK(MgMUTEXP(mg));
+ GETTARGET;
+ PUSHi(iters);
+ RETURN;
}
-#endif /* USE_5005THREADS */
PP(pp_lock)
{
+ dVAR;
dSP;
dTOPss;
SV *retsv = sv;
-#ifdef USE_5005THREADS
- sv_lock(sv);
-#endif /* USE_5005THREADS */
-#ifdef USE_ITHREADS
- shared_sv *ssv = Perl_sharedsv_find(aTHX_ sv);
- if(ssv)
- Perl_sharedsv_lock(aTHX_ ssv);
-#endif /* USE_ITHREADS */
+ SvLOCK(sv);
if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
|| SvTYPE(retsv) == SVt_PVCV) {
retsv = refto(retsv);
RETURN;
}
-PP(pp_threadsv)
+
+PP(unimplemented_op)
{
-#ifdef USE_5005THREADS
- dSP;
- EXTEND(SP, 1);
- if (PL_op->op_private & OPpLVAL_INTRO)
- PUSHs(*save_threadsv(PL_op->op_targ));
- else
- PUSHs(THREADSV(PL_op->op_targ));
- RETURN;
-#else
- DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
-#endif /* USE_5005THREADS */
+ dVAR;
+ DIE(aTHX_ "panic: unimplemented op %s (#%d) called", OP_NAME(PL_op),
+ PL_op->op_type);
}
+
+/*
+ * Local variables:
+ * c-indentation-style: bsd
+ * c-basic-offset: 4
+ * indent-tabs-mode: t
+ * End:
+ *
+ * ex: set ts=8 sts=4 sw=4 noet:
+ */
https://perl5.git.perl.org / perl5.git / blobdiff