/* pp.c
*
- * Copyright (c) 1991-1997, Larry Wall
+ * Copyright (c) 1991-1999, Larry Wall
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
*/
#include "EXTERN.h"
+#define PERL_IN_PP_C
#include "perl.h"
/*
#define SIZE16 2
#define SIZE32 4
+/* CROSSCOMPILE and MULTIARCH are going to affect pp_pack() and pp_unpack().
+ --jhi Feb 1999 */
+
#if SHORTSIZE != SIZE16 || LONGSIZE != SIZE32
# define PERL_NATINT_PACK
#endif
# define CAT32(sv,p) sv_catpvn(sv, (char*)(p), SIZE32)
#endif
-#ifndef PERL_OBJECT
-static void doencodes _((SV* sv, char* s, I32 len));
-static SV* refto _((SV* sv));
-static U32 seed _((void));
-#endif
-
/* variations on pp_null */
#ifdef I_UNISTD
RETURN;
gimme = GIMME_V;
if (gimme == G_ARRAY) {
- RETURNOP(do_kv(ARGS));
+ RETURNOP(do_kv());
}
else if (gimme == G_SCALAR) {
SV* sv = sv_newmortal();
if (HvFILL((HV*)TARG))
- sv_setpvf(sv, "%ld/%ld",
+ Perl_sv_setpvf(aTHX_ sv, "%ld/%ld",
(long)HvFILL((HV*)TARG), (long)HvMAX((HV*)TARG) + 1);
else
sv_setiv(sv, 0);
PP(pp_padany)
{
- DIE("NOT IMPL LINE %d",__LINE__);
+ DIE(aTHX_ "NOT IMPL LINE %d",__LINE__);
}
/* Translations. */
PP(pp_rv2gv)
{
- djSP; dTOPss;
+ djSP; dTOPss;
if (SvROK(sv)) {
wasref:
sv = (SV*) gv;
}
else if (SvTYPE(sv) != SVt_PVGV)
- DIE("Not a GLOB reference");
+ DIE(aTHX_ "Not a GLOB reference");
}
else {
if (SvTYPE(sv) != SVt_PVGV) {
goto wasref;
}
if (!SvOK(sv)) {
+ /* If this is a 'my' scalar and flag is set then vivify
+ * NI-S 1999/05/07
+ */
+ if (PL_op->op_private & OPpDEREF) {
+ GV *gv = (GV *) newSV(0);
+ STRLEN len = 0;
+ char *name = "";
+ if (cUNOP->op_first->op_type == OP_PADSV) {
+ SV *padname = *av_fetch(PL_comppad_name, cUNOP->op_first->op_targ, 4);
+ name = SvPV(padname,len);
+ }
+ gv_init(gv, PL_curcop->cop_stash, name, len, 0);
+ sv_upgrade(sv, SVt_RV);
+ SvRV(sv) = (SV *) gv;
+ SvROK_on(sv);
+ SvSETMAGIC(sv);
+ goto wasref;
+ }
if (PL_op->op_flags & OPf_REF ||
PL_op->op_private & HINT_STRICT_REFS)
- DIE(PL_no_usym, "a symbol");
+ DIE(aTHX_ PL_no_usym, "a symbol");
if (ckWARN(WARN_UNINITIALIZED))
- warner(WARN_UNINITIALIZED, PL_warn_uninit);
+ Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
RETSETUNDEF;
}
sym = SvPV(sv, n_a);
}
else {
if (PL_op->op_private & HINT_STRICT_REFS)
- DIE(PL_no_symref, sym, "a symbol");
+ DIE(aTHX_ PL_no_symref, sym, "a symbol");
sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV);
}
}
case SVt_PVAV:
case SVt_PVHV:
case SVt_PVCV:
- DIE("Not a SCALAR reference");
+ DIE(aTHX_ "Not a SCALAR reference");
}
}
else {
if (!SvOK(sv)) {
if (PL_op->op_flags & OPf_REF ||
PL_op->op_private & HINT_STRICT_REFS)
- DIE(PL_no_usym, "a SCALAR");
+ DIE(aTHX_ PL_no_usym, "a SCALAR");
if (ckWARN(WARN_UNINITIALIZED))
- warner(WARN_UNINITIALIZED, PL_warn_uninit);
+ Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
RETSETUNDEF;
}
sym = SvPV(sv, n_a);
}
else {
if (PL_op->op_private & HINT_STRICT_REFS)
- DIE(PL_no_symref, sym, "a SCALAR");
+ DIE(aTHX_ PL_no_symref, sym, "a SCALAR");
gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV);
}
}
oa = oa >> 4;
}
str[n++] = '\0';
- ret = sv_2mortal(newSVpv(str, n - 1));
+ ret = sv_2mortal(newSVpvn(str, n - 1));
}
else if (code) /* Non-Overridable */
goto set;
else { /* None such */
nonesuch:
- croak("Cannot find an opnumber for \"%s\"", s+6);
+ Perl_croak(aTHX_ "Can't find an opnumber for \"%s\"", s+6);
}
}
}
cv = sv_2cv(TOPs, &stash, &gv, FALSE);
if (cv && SvPOK(cv))
- ret = sv_2mortal(newSVpv(SvPVX(cv), SvCUR(cv)));
+ ret = sv_2mortal(newSVpvn(SvPVX(cv), SvCUR(cv)));
set:
SETs(ret);
RETURN;
}
STATIC SV*
-refto(SV *sv)
+S_refto(pTHX_ SV *sv)
{
SV* rv;
vivify_defelem(sv);
if (!(sv = LvTARG(sv)))
sv = &PL_sv_undef;
+ else
+ (void)SvREFCNT_inc(sv);
}
else if (SvPADTMP(sv))
sv = newSVsv(sv);
STRLEN len;
char *ptr = SvPV(ssv,len);
if (ckWARN(WARN_UNSAFE) && len == 0)
- warner(WARN_UNSAFE,
+ Perl_warner(aTHX_ WARN_UNSAFE,
"Explicit blessing to '' (assuming package main)");
stash = gv_stashpvn(ptr, len, TRUE);
}
break;
case 'N':
if (strEQ(elem, "NAME"))
- sv = newSVpv(GvNAME(gv), GvNAMELEN(gv));
+ sv = newSVpvn(GvNAME(gv), GvNAMELEN(gv));
break;
case 'P':
if (strEQ(elem, "PACKAGE"))
PP(pp_study)
{
djSP; dPOPss;
- register UNOP *unop = cUNOP;
register unsigned char *s;
register I32 pos;
register I32 ch;
snext = PL_screamnext;
if (!sfirst || !snext)
- DIE("do_study: out of memory");
+ DIE(aTHX_ "do_study: out of memory");
for (ch = 256; ch; --ch)
*sfirst++ = -1;
if (!sv)
RETPUSHUNDEF;
- if (SvTHINKFIRST(sv)) {
- if (SvREADONLY(sv)) {
- dTHR;
- if (PL_curcop != &PL_compiling)
- croak(PL_no_modify);
- }
- if (SvROK(sv))
- sv_unref(sv);
- }
+ if (SvTHINKFIRST(sv))
+ sv_force_normal(sv);
switch (SvTYPE(sv)) {
case SVt_NULL:
break;
case SVt_PVCV:
if (ckWARN(WARN_UNSAFE) && cv_const_sv((CV*)sv))
- warner(WARN_UNSAFE, "Constant subroutine %s undefined",
+ Perl_warner(aTHX_ WARN_UNSAFE, "Constant subroutine %s undefined",
CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv)));
/* FALL THROUGH */
case SVt_PVFM:
- { GV* gv = (GV*)SvREFCNT_inc(CvGV((CV*)sv));
- cv_undef((CV*)sv);
- CvGV((CV*)sv) = gv; } /* let user-undef'd sub keep its identity */
+ {
+ /* let user-undef'd sub keep its identity */
+ GV* gv = (GV*)SvREFCNT_inc(CvGV((CV*)sv));
+ cv_undef((CV*)sv);
+ CvGV((CV*)sv) = gv;
+ }
break;
case SVt_PVGV:
if (SvFAKE(sv))
{
djSP;
if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
- croak(PL_no_modify);
- if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
+ Perl_croak(aTHX_ PL_no_modify);
+ if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
SvIVX(TOPs) != IV_MIN)
{
--SvIVX(TOPs);
{
djSP; dTARGET;
if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
- croak(PL_no_modify);
+ Perl_croak(aTHX_ PL_no_modify);
sv_setsv(TARG, TOPs);
- if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
+ if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
SvIVX(TOPs) != IV_MAX)
{
++SvIVX(TOPs);
{
djSP; dTARGET;
if(SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
- croak(PL_no_modify);
+ Perl_croak(aTHX_ PL_no_modify);
sv_setsv(TARG, TOPs);
- if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
+ if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
SvIVX(TOPs) != IV_MIN)
{
--SvIVX(TOPs);
dPOPPOPnnrl;
double value;
if (right == 0.0)
- DIE("Illegal division by zero");
+ DIE(aTHX_ "Illegal division by zero");
#ifdef SLOPPYDIVIDE
/* insure that 20./5. == 4. */
{
{
djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
{
- UV left;
- UV right;
- bool left_neg;
- bool right_neg;
- UV ans;
-
- if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
- IV i = SvIVX(POPs);
- right = (right_neg = (i < 0)) ? -i : i;
- }
- else {
- double n = POPn;
- right = U_V((right_neg = (n < 0)) ? -n : n);
- }
+ UV left;
+ UV right;
+ bool left_neg;
+ bool right_neg;
+ bool use_double = 0;
+ double dright;
+ double dleft;
+
+ if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
+ IV i = SvIVX(POPs);
+ right = (right_neg = (i < 0)) ? -i : i;
+ }
+ else {
+ dright = POPn;
+ use_double = 1;
+ right_neg = dright < 0;
+ if (right_neg)
+ dright = -dright;
+ }
- if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
- IV i = SvIVX(POPs);
- left = (left_neg = (i < 0)) ? -i : i;
- }
- else {
- double n = POPn;
- left = U_V((left_neg = (n < 0)) ? -n : n);
- }
+ if (!use_double && SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
+ IV i = SvIVX(POPs);
+ left = (left_neg = (i < 0)) ? -i : i;
+ }
+ else {
+ dleft = POPn;
+ if (!use_double) {
+ use_double = 1;
+ dright = right;
+ }
+ left_neg = dleft < 0;
+ if (left_neg)
+ dleft = -dleft;
+ }
- if (!right)
- DIE("Illegal modulus zero");
-
- ans = left % right;
- if ((left_neg != right_neg) && ans)
- ans = right - ans;
- if (right_neg) {
- /* XXX may warn: unary minus operator applied to unsigned type */
- /* could change -foo to be (~foo)+1 instead */
- if (ans <= ~((UV)IV_MAX)+1)
- sv_setiv(TARG, ~ans+1);
- else
- sv_setnv(TARG, -(double)ans);
- }
- else
- sv_setuv(TARG, ans);
- PUSHTARG;
- RETURN;
+ if (use_double) {
+ double dans;
+
+#if 1
+/* Somehow U_V is pessimized even if CASTFLAGS is 0 */
+# if CASTFLAGS & 2
+# define CAST_D2UV(d) U_V(d)
+# else
+# define CAST_D2UV(d) ((UV)(d))
+# endif
+ /* Tried to do this only in the case DOUBLESIZE <= UV_SIZE,
+ * or, in other words, precision of UV more than of NV.
+ * But in fact the approach below turned out to be an
+ * optimization - floor() may be slow */
+ if (dright <= UV_MAX && dleft <= UV_MAX) {
+ right = CAST_D2UV(dright);
+ left = CAST_D2UV(dleft);
+ goto do_uv;
+ }
+#endif
+
+ /* Backward-compatibility clause: */
+ dright = floor(dright + 0.5);
+ dleft = floor(dleft + 0.5);
+
+ if (!dright)
+ DIE(aTHX_ "Illegal modulus zero");
+
+ dans = fmod(dleft, dright);
+ if ((left_neg != right_neg) && dans)
+ dans = dright - dans;
+ if (right_neg)
+ dans = -dans;
+ sv_setnv(TARG, dans);
+ }
+ else {
+ UV ans;
+
+ do_uv:
+ if (!right)
+ DIE(aTHX_ "Illegal modulus zero");
+
+ ans = left % right;
+ if ((left_neg != right_neg) && ans)
+ ans = right - ans;
+ if (right_neg) {
+ /* XXX may warn: unary minus operator applied to unsigned type */
+ /* could change -foo to be (~foo)+1 instead */
+ if (ans <= ~((UV)IV_MAX)+1)
+ sv_setiv(TARG, ~ans+1);
+ else
+ sv_setnv(TARG, -(double)ans);
+ }
+ else
+ sv_setuv(TARG, ans);
+ }
+ PUSHTARG;
+ RETURN;
}
}
STRLEN len;
tmpstr = POPs;
- if (TARG == tmpstr && SvTHINKFIRST(tmpstr)) {
- if (SvREADONLY(tmpstr) && PL_curcop != &PL_compiling)
- DIE("Can't x= to readonly value");
- if (SvROK(tmpstr))
- sv_unref(tmpstr);
- }
SvSetSV(TARG, tmpstr);
SvPV_force(TARG, len);
if (count != 1) {
{
dPOPiv;
if (value == 0)
- DIE("Illegal division by zero");
+ DIE(aTHX_ "Illegal division by zero");
value = POPi / value;
PUSHi( value );
RETURN;
{
dPOPTOPiirl;
if (!right)
- DIE("Illegal modulus zero");
+ DIE(aTHX_ "Illegal modulus zero");
SETi( left % right );
RETURN;
}
*/
#ifndef HAS_DRAND48_PROTO
-extern double drand48 _((void));
+extern double drand48 (void);
#endif
PP(pp_rand)
}
STATIC U32
-seed(void)
+S_seed(pTHX)
{
/*
* This is really just a quick hack which grabs various garbage
double value;
value = POPn;
if (value <= 0.0) {
- SET_NUMERIC_STANDARD();
- DIE("Can't take log of %g", value);
+ RESTORE_NUMERIC_STANDARD();
+ DIE(aTHX_ "Can't take log of %g", value);
}
value = log(value);
XPUSHn(value);
double value;
value = POPn;
if (value < 0.0) {
- SET_NUMERIC_STANDARD();
- DIE("Can't take sqrt of %g", value);
+ RESTORE_NUMERIC_STANDARD();
+ DIE(aTHX_ "Can't take sqrt of %g", value);
}
value = sqrt(value);
XPUSHn(value);
}
if (fail < 0) {
if (ckWARN(WARN_SUBSTR) || lvalue || repl)
- warner(WARN_SUBSTR, "substr outside of string");
+ Perl_warner(aTHX_ WARN_SUBSTR, "substr outside of string");
RETPUSHUNDEF;
}
else {
STRLEN n_a;
SvPV_force(sv,n_a);
if (ckWARN(WARN_SUBSTR))
- warner(WARN_SUBSTR,
+ Perl_warner(aTHX_ WARN_SUBSTR,
"Attempt to use reference as lvalue in substr");
}
if (SvOK(sv)) /* is it defined ? */
PP(pp_sprintf)
{
djSP; dMARK; dORIGMARK; dTARGET;
-#ifdef USE_LOCALE_NUMERIC
- if (PL_op->op_private & OPpLOCALE)
- SET_NUMERIC_LOCAL();
- else
- SET_NUMERIC_STANDARD();
-#endif
do_sprintf(TARG, SP-MARK, MARK+1);
TAINT_IF(SvTAINTED(TARG));
SP = ORIGMARK;
sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
#endif
#else
- DIE(
+ DIE(aTHX_
"The crypt() function is unimplemented due to excessive paranoia.");
#endif
SETs(TARG);
s = (U8*)SvPV_force(sv, slen);
Copy(tmpbuf, s, ulen, U8);
}
- RETURN;
- }
-
- if (!SvPADTMP(sv)) {
- dTARGET;
- sv_setsv(TARG, sv);
- sv = TARG;
- SETs(sv);
- }
- s = (U8*)SvPV_force(sv, slen);
- if (*s) {
- if (PL_op->op_private & OPpLOCALE) {
- TAINT;
- SvTAINTED_on(sv);
- *s = toUPPER_LC(*s);
+ } else {
+ if (!SvPADTMP(sv)) {
+ dTARGET;
+ sv_setsv(TARG, sv);
+ sv = TARG;
+ SETs(sv);
+ }
+ s = (U8*)SvPV_force(sv, slen);
+ if (*s) {
+ if (PL_op->op_private & OPpLOCALE) {
+ TAINT;
+ SvTAINTED_on(sv);
+ *s = toUPPER_LC(*s);
+ }
+ else
+ *s = toUPPER(*s);
}
- else
- *s = toUPPER(*s);
}
-
+ if (SvSMAGICAL(sv))
+ mg_set(sv);
RETURN;
}
s = (U8*)SvPV_force(sv, slen);
Copy(tmpbuf, s, ulen, U8);
}
- RETURN;
- }
-
- if (!SvPADTMP(sv)) {
- dTARGET;
- sv_setsv(TARG, sv);
- sv = TARG;
- SETs(sv);
- }
- s = (U8*)SvPV_force(sv, slen);
- if (*s) {
- if (PL_op->op_private & OPpLOCALE) {
- TAINT;
- SvTAINTED_on(sv);
- *s = toLOWER_LC(*s);
+ } else {
+ if (!SvPADTMP(sv)) {
+ dTARGET;
+ sv_setsv(TARG, sv);
+ sv = TARG;
+ SETs(sv);
}
- else
- *s = toLOWER(*s);
+ s = (U8*)SvPV_force(sv, slen);
+ if (*s) {
+ if (PL_op->op_private & OPpLOCALE) {
+ TAINT;
+ SvTAINTED_on(sv);
+ *s = toLOWER_LC(*s);
+ }
+ else
+ *s = toLOWER(*s);
+ }
+ SETs(sv);
}
-
- SETs(sv);
+ if (SvSMAGICAL(sv))
+ mg_set(sv);
RETURN;
}
if (!len) {
sv_setpvn(TARG, "", 0);
SETs(TARG);
- RETURN;
- }
-
- (void)SvUPGRADE(TARG, SVt_PV);
- SvGROW(TARG, (len * 2) + 1);
- (void)SvPOK_only(TARG);
- d = (U8*)SvPVX(TARG);
- send = s + len;
- if (PL_op->op_private & OPpLOCALE) {
- TAINT;
- SvTAINTED_on(TARG);
- while (s < send) {
- d = uv_to_utf8(d, toUPPER_LC_uni( utf8_to_uv(s, &ulen)));
- s += ulen;
+ } else {
+ (void)SvUPGRADE(TARG, SVt_PV);
+ SvGROW(TARG, (len * 2) + 1);
+ (void)SvPOK_only(TARG);
+ d = (U8*)SvPVX(TARG);
+ send = s + len;
+ if (PL_op->op_private & OPpLOCALE) {
+ TAINT;
+ SvTAINTED_on(TARG);
+ while (s < send) {
+ d = uv_to_utf8(d, toUPPER_LC_uni( utf8_to_uv(s, &ulen)));
+ s += ulen;
+ }
}
- }
- else {
- while (s < send) {
- d = uv_to_utf8(d, toUPPER_utf8( s ));
- s += UTF8SKIP(s);
+ else {
+ while (s < send) {
+ d = uv_to_utf8(d, toUPPER_utf8( s ));
+ s += UTF8SKIP(s);
+ }
}
+ *d = '\0';
+ SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
+ SETs(TARG);
}
- *d = '\0';
- SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
- SETs(TARG);
- RETURN;
- }
-
- if (!SvPADTMP(sv)) {
- dTARGET;
- sv_setsv(TARG, sv);
- sv = TARG;
- SETs(sv);
- }
-
- s = (U8*)SvPV_force(sv, len);
- if (len) {
- register U8 *send = s + len;
-
- if (PL_op->op_private & OPpLOCALE) {
- TAINT;
- SvTAINTED_on(sv);
- for (; s < send; s++)
- *s = toUPPER_LC(*s);
+ } else {
+ if (!SvPADTMP(sv)) {
+ dTARGET;
+ sv_setsv(TARG, sv);
+ sv = TARG;
+ SETs(sv);
}
- else {
- for (; s < send; s++)
- *s = toUPPER(*s);
+ s = (U8*)SvPV_force(sv, len);
+ if (len) {
+ register U8 *send = s + len;
+
+ if (PL_op->op_private & OPpLOCALE) {
+ TAINT;
+ SvTAINTED_on(sv);
+ for (; s < send; s++)
+ *s = toUPPER_LC(*s);
+ }
+ else {
+ for (; s < send; s++)
+ *s = toUPPER(*s);
+ }
}
}
+ if (SvSMAGICAL(sv))
+ mg_set(sv);
RETURN;
}
if (!len) {
sv_setpvn(TARG, "", 0);
SETs(TARG);
- RETURN;
- }
-
- (void)SvUPGRADE(TARG, SVt_PV);
- SvGROW(TARG, (len * 2) + 1);
- (void)SvPOK_only(TARG);
- d = (U8*)SvPVX(TARG);
- send = s + len;
- if (PL_op->op_private & OPpLOCALE) {
- TAINT;
- SvTAINTED_on(TARG);
- while (s < send) {
- d = uv_to_utf8(d, toLOWER_LC_uni( utf8_to_uv(s, &ulen)));
- s += ulen;
+ } else {
+ (void)SvUPGRADE(TARG, SVt_PV);
+ SvGROW(TARG, (len * 2) + 1);
+ (void)SvPOK_only(TARG);
+ d = (U8*)SvPVX(TARG);
+ send = s + len;
+ if (PL_op->op_private & OPpLOCALE) {
+ TAINT;
+ SvTAINTED_on(TARG);
+ while (s < send) {
+ d = uv_to_utf8(d, toLOWER_LC_uni( utf8_to_uv(s, &ulen)));
+ s += ulen;
+ }
}
- }
- else {
- while (s < send) {
- d = uv_to_utf8(d, toLOWER_utf8(s));
- s += UTF8SKIP(s);
+ else {
+ while (s < send) {
+ d = uv_to_utf8(d, toLOWER_utf8(s));
+ s += UTF8SKIP(s);
+ }
}
+ *d = '\0';
+ SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
+ SETs(TARG);
+ }
+ } else {
+ if (!SvPADTMP(sv)) {
+ dTARGET;
+ sv_setsv(TARG, sv);
+ sv = TARG;
+ SETs(sv);
}
- *d = '\0';
- SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
- SETs(TARG);
- RETURN;
- }
-
- if (!SvPADTMP(sv)) {
- dTARGET;
- sv_setsv(TARG, sv);
- sv = TARG;
- SETs(sv);
- }
- s = (U8*)SvPV_force(sv, len);
- if (len) {
- register U8 *send = s + len;
+ s = (U8*)SvPV_force(sv, len);
+ if (len) {
+ register U8 *send = s + len;
- if (PL_op->op_private & OPpLOCALE) {
- TAINT;
- SvTAINTED_on(sv);
- for (; s < send; s++)
- *s = toLOWER_LC(*s);
- }
- else {
- for (; s < send; s++)
- *s = toLOWER(*s);
+ if (PL_op->op_private & OPpLOCALE) {
+ TAINT;
+ SvTAINTED_on(sv);
+ for (; s < send; s++)
+ *s = toLOWER_LC(*s);
+ }
+ else {
+ for (; s < send; s++)
+ *s = toLOWER(*s);
+ }
}
}
+ if (SvSMAGICAL(sv))
+ mg_set(sv);
RETURN;
}
else
sv_setpvn(TARG, s, len);
SETs(TARG);
+ if (SvSMAGICAL(TARG))
+ mg_set(TARG);
RETURN;
}
svp = av_fetch(av, elem, lval);
if (lval) {
if (!svp || *svp == &PL_sv_undef)
- DIE(PL_no_aelem, elem);
+ DIE(aTHX_ PL_no_aelem, elem);
if (PL_op->op_private & OPpLVAL_INTRO)
save_aelem(av, elem, svp);
}
PP(pp_values)
{
- return do_kv(ARGS);
+ return do_kv();
}
PP(pp_keys)
{
- return do_kv(ARGS);
+ return do_kv();
}
PP(pp_delete)
if (hvtype == SVt_PVHV)
sv = hv_delete_ent(hv, *MARK, discard, 0);
else
- DIE("Not a HASH reference");
+ DIE(aTHX_ "Not a HASH reference");
*MARK = sv ? sv : &PL_sv_undef;
}
if (discard)
if (SvTYPE(hv) == SVt_PVHV)
sv = hv_delete_ent(hv, keysv, discard, 0);
else
- DIE("Not a HASH reference");
+ DIE(aTHX_ "Not a HASH reference");
if (!sv)
sv = &PL_sv_undef;
if (!discard)
RETPUSHYES;
}
else {
- DIE("Not a HASH reference");
+ DIE(aTHX_ "Not a HASH reference");
}
RETPUSHNO;
}
I32 realhv = (SvTYPE(hv) == SVt_PVHV);
if (!realhv && PL_op->op_private & OPpLVAL_INTRO)
- DIE("Can't localize pseudo-hash element");
+ DIE(aTHX_ "Can't localize pseudo-hash element");
if (realhv || SvTYPE(hv) == SVt_PVAV) {
while (++MARK <= SP) {
if (lval) {
if (!svp || *svp == &PL_sv_undef) {
STRLEN n_a;
- DIE(PL_no_helem, SvPV(keysv, n_a));
+ DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
}
if (PL_op->op_private & OPpLVAL_INTRO)
save_helem(hv, keysv, svp);
for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
ix = SvIVx(*lelem);
- if (ix < 0) {
+ if (ix < 0)
ix += max;
- if (ix < 0)
- *lelem = &PL_sv_undef;
- else if (!(*lelem = firstrelem[ix]))
- *lelem = &PL_sv_undef;
- }
- else {
+ else
ix -= arybase;
- if (ix >= max || !(*lelem = firstrelem[ix]))
+ if (ix < 0 || ix >= max)
+ *lelem = &PL_sv_undef;
+ else {
+ is_something_there = TRUE;
+ if (!(*lelem = firstrelem[ix]))
*lelem = &PL_sv_undef;
}
- if (!is_something_there && (SvOK(*lelem) || SvGMAGICAL(*lelem)))
- is_something_there = TRUE;
}
if (is_something_there)
SP = lastlelem;
if (MARK < SP)
sv_setsv(val, *++MARK);
else if (ckWARN(WARN_UNSAFE))
- warner(WARN_UNSAFE, "Odd number of elements in hash assignment");
+ Perl_warner(aTHX_ WARN_UNSAFE, "Odd number of elements in hash assignment");
(void)hv_store_ent(hv,key,val,0);
}
SP = ORIGMARK;
PUSHMARK(MARK);
PUTBACK;
ENTER;
- perl_call_method("SPLICE",GIMME_V);
+ call_method("SPLICE",GIMME_V);
LEAVE;
SPAGAIN;
RETURN;
else
offset -= PL_curcop->cop_arybase;
if (offset < 0)
- DIE(PL_no_aelem, i);
+ DIE(aTHX_ PL_no_aelem, i);
if (++MARK < SP) {
length = SvIVx(*MARK++);
if (length < 0) {
PUSHMARK(MARK);
PUTBACK;
ENTER;
- perl_call_method("PUSH",G_SCALAR|G_DISCARD);
+ call_method("PUSH",G_SCALAR|G_DISCARD);
LEAVE;
SPAGAIN;
}
PUSHMARK(MARK);
PUTBACK;
ENTER;
- perl_call_method("UNSHIFT",G_SCALAR|G_DISCARD);
+ call_method("UNSHIFT",G_SCALAR|G_DISCARD);
LEAVE;
SPAGAIN;
}
s += UTF8SKIP(s);
down = (char*)(s - 1);
if (s > send || !((*down & 0xc0) == 0x80)) {
- warn("Malformed UTF-8 character");
+ Perl_warn(aTHX_ "Malformed UTF-8 character");
break;
}
while (down > up) {
RETURN;
}
-STATIC SV *
-mul128(SV *sv, U8 m)
+STATIC SV *
+S_mul128(pTHX_ SV *sv, U8 m)
{
STRLEN len;
char *s = SvPV(sv, len);
U32 i = 0;
if (!strnEQ(s, "0000", 4)) { /* need to grow sv */
- SV *tmpNew = newSVpv("0000000000", 10);
+ SV *tmpNew = newSVpvn("0000000000", 10);
sv_catsv(tmpNew, sv);
SvREFCNT_dec(sv); /* free old sv */
#endif
if (isSPACE(datumtype))
continue;
- if (*pat == '_') {
+ if (*pat == '!') {
char *natstr = "sSiIlL";
if (strchr(natstr, datumtype)) {
pat++;
}
else
- croak("'_' allowed only after types %s", natstr);
+ Perl_croak(aTHX_ "'!' allowed only after types %s", natstr);
}
if (pat >= patend)
len = 1;
len = (datumtype != '@');
switch(datumtype) {
default:
- croak("Invalid type in unpack: '%c'", (int)datumtype);
+ Perl_croak(aTHX_ "Invalid type in unpack: '%c'", (int)datumtype);
case ',': /* grandfather in commas but with a warning */
if (commas++ == 0 && ckWARN(WARN_UNSAFE))
- warner(WARN_UNSAFE, "Invalid type in unpack: '%c'", (int)datumtype);
+ Perl_warner(aTHX_ WARN_UNSAFE, "Invalid type in unpack: '%c'", (int)datumtype);
break;
case '%':
if (len == 1 && pat[-1] != '1')
break;
case '@':
if (len > strend - strbeg)
- DIE("@ outside of string");
+ DIE(aTHX_ "@ outside of string");
s = strbeg + len;
break;
case 'X':
if (len > s - strbeg)
- DIE("X outside of string");
+ DIE(aTHX_ "X outside of string");
s -= len;
break;
case 'x':
if (len > strend - s)
- DIE("x outside of string");
+ DIE(aTHX_ "x outside of string");
s += len;
break;
case 'A':
#ifdef __osf__
/* Without the dummy below unpack("i", pack("i",-1))
* return 0xFFffFFff instead of -1 for Digital Unix V4.0
- * cc with optimization turned on */
+ * cc with optimization turned on.
+ *
+ * The bug was detected in
+ * DEC C V5.8-009 on Digital UNIX V4.0 (Rev. 1091) (V4.0E)
+ * with optimization (-O4) turned on.
+ * DEC C V5.2-040 on Digital UNIX V4.0 (Rev. 564) (V4.0B)
+ * does not have this problem even with -O4.
+ *
+ * This bug was reported as DECC_BUGS 1431
+ * and tracked internally as GEM_BUGS 7775.
+ *
+ * The bug is fixed in
+ * Tru64 UNIX V5.0: Compaq C V6.1-006 or later
+ * UNIX V4.0F support: DEC C V5.9-006 or later
+ * UNIX V4.0E support: DEC C V5.8-011 or later
+ * and also in DTK.
+ *
+ * See also few lines later for the same bug.
+ */
(aint) ?
sv_setiv(sv, (IV)aint) :
#endif
sv = NEWSV(41, 0);
#ifdef __osf__
/* Without the dummy below unpack("I", pack("I",0xFFFFFFFF))
- * returns 1.84467440737096e+19 instead of 0xFFFFFFFF for
- * DEC C V5.8-009 on Digital UNIX V4.0 (Rev. 1091) (aka V4.0D)
- * with optimization turned on.
- * (DEC C V5.2-040 on Digital UNIX V4.0 (Rev. 564) (aka V4.0B)
- * does not have this problem even with -O4)
- */
+ * returns 1.84467440737096e+19 instead of 0xFFFFFFFF.
+ * See details few lines earlier. */
(auint) ?
sv_setuv(sv, (UV)auint) :
#endif
char *t;
STRLEN n_a;
- sv = newSVpvf("%.*Vu", (int)TYPE_DIGITS(UV), auv);
+ sv = Perl_newSVpvf(aTHX_ "%.*Vu", (int)TYPE_DIGITS(UV), auv);
while (s < strend) {
sv = mul128(sv, *s & 0x7f);
if (!(*s++ & 0x80)) {
}
}
if ((s >= strend) && bytes)
- croak("Unterminated compressed integer");
+ Perl_croak(aTHX_ "Unterminated compressed integer");
}
break;
case 'P':
}
STATIC void
-doencodes(register SV *sv, register char *s, register I32 len)
+S_doencodes(pTHX_ register SV *sv, register char *s, register I32 len)
{
char hunk[5];
sv_catpvn(sv, "\n", 1);
}
-STATIC SV *
-is_an_int(char *s, STRLEN l)
+STATIC SV *
+S_is_an_int(pTHX_ char *s, STRLEN l)
{
STRLEN n_a;
- SV *result = newSVpv("", l);
+ SV *result = newSVpvn(s, l);
char *result_c = SvPV(result, n_a); /* convenience */
char *out = result_c;
bool skip = 1;
return (result);
}
+/* pnum must be '\0' terminated */
STATIC int
-div128(SV *pnum, bool *done)
- /* must be '\0' terminated */
-
+S_div128(pTHX_ SV *pnum, bool *done)
{
STRLEN len;
char *s = SvPV(pnum, len);
#endif
if (isSPACE(datumtype))
continue;
- if (*pat == '_') {
+ if (*pat == '!') {
char *natstr = "sSiIlL";
if (strchr(natstr, datumtype)) {
pat++;
}
else
- croak("'_' allowed only after types %s", natstr);
+ Perl_croak(aTHX_ "'!' allowed only after types %s", natstr);
}
if (*pat == '*') {
len = strchr("@Xxu", datumtype) ? 0 : items;
len = 1;
switch(datumtype) {
default:
- croak("Invalid type in pack: '%c'", (int)datumtype);
+ Perl_croak(aTHX_ "Invalid type in pack: '%c'", (int)datumtype);
case ',': /* grandfather in commas but with a warning */
if (commas++ == 0 && ckWARN(WARN_UNSAFE))
- warner(WARN_UNSAFE, "Invalid type in pack: '%c'", (int)datumtype);
+ Perl_warner(aTHX_ WARN_UNSAFE, "Invalid type in pack: '%c'", (int)datumtype);
break;
case '%':
- DIE("%% may only be used in unpack");
+ DIE(aTHX_ "%% may only be used in unpack");
case '@':
len -= SvCUR(cat);
if (len > 0)
case 'X':
shrink:
if (SvCUR(cat) < len)
- DIE("X outside of string");
+ DIE(aTHX_ "X outside of string");
SvCUR(cat) -= len;
*SvEND(cat) = '\0';
break;
adouble = floor(SvNV(fromstr));
if (adouble < 0)
- croak("Cannot compress negative numbers");
+ Perl_croak(aTHX_ "Cannot compress negative numbers");
if (
#ifdef BW_BITS
{
char buf[1 + sizeof(UV)];
char *in = buf + sizeof(buf);
- UV auv = U_V(adouble);;
+ UV auv = U_V(adouble);
do {
*--in = (auv & 0x7f) | 0x80;
/* Copy string and check for compliance */
from = SvPV(fromstr, len);
if ((norm = is_an_int(from, len)) == NULL)
- croak("can compress only unsigned integer");
+ Perl_croak(aTHX_ "can compress only unsigned integer");
New('w', result, len, char);
in = result + len;
double next = floor(adouble / 128);
*--in = (unsigned char)(adouble - (next * 128)) | 0x80;
if (--in < buf) /* this cannot happen ;-) */
- croak ("Cannot compress integer");
+ Perl_croak(aTHX_ "Cannot compress integer");
adouble = next;
} while (adouble > 0);
buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
}
else
- croak("Cannot compress non integer");
+ Perl_croak(aTHX_ "Cannot compress non integer");
}
break;
case 'i':
* gone.
*/
if (ckWARN(WARN_UNSAFE) && (SvTEMP(fromstr) || SvPADTMP(fromstr)))
- warner(WARN_UNSAFE,
+ Perl_warner(aTHX_ WARN_UNSAFE,
"Attempt to pack pointer to temporary value");
if (SvPOK(fromstr) || SvNIOK(fromstr))
aptr = SvPV(fromstr,n_a);
pm = (PMOP*)POPs;
#endif
if (!pm || !s)
- DIE("panic: do_split");
+ DIE(aTHX_ "panic: do_split");
rx = pm->op_pmregexp;
TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
else if (rx->check_substr && !rx->nparens
&& (rx->reganch & ROPT_CHECK_ALL)
&& !(rx->reganch & ROPT_ANCH)) {
+ int tail = SvTAIL(rx->check_substr) != 0;
+
i = SvCUR(rx->check_substr);
- if (i == 1 && !SvTAIL(rx->check_substr)) {
+ if (i == 1 && !tail) {
i = *SvPVX(rx->check_substr);
while (--limit) {
/*SUPPRESS 530*/
#ifndef lint
while (s < strend && --limit &&
(m=fbm_instr((unsigned char*)s, (unsigned char*)strend,
- rx->check_substr, 0)) )
+ rx->check_substr, PL_multiline ? FBMrf_MULTILINE : 0)) )
#endif
{
dstr = NEWSV(31, m-s);
if (make_mortal)
sv_2mortal(dstr);
XPUSHs(dstr);
- s = m + i;
+ s = m + i - tail; /* Fake \n at the end */
}
}
}
else {
maxiters += (strend - s) * rx->nparens;
while (s < strend && --limit &&
- CALLREGEXEC(rx, s, strend, orig, 1, sv, NULL, 0))
+ CALLREGEXEC(aTHX_ rx, s, strend, orig, 1, sv, NULL, 0))
{
TAINT_IF(RX_MATCH_TAINTED(rx));
- if (rx->subbase
- && rx->subbase != orig) {
+ if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
m = s;
s = orig;
- orig = rx->subbase;
+ orig = rx->subbeg;
s = orig + (m - s);
strend = s + (strend - m);
}
- m = rx->startp[0];
+ m = rx->startp[0] + orig;
dstr = NEWSV(32, m-s);
sv_setpvn(dstr, s, m-s);
if (make_mortal)
XPUSHs(dstr);
if (rx->nparens) {
for (i = 1; i <= rx->nparens; i++) {
- s = rx->startp[i];
- m = rx->endp[i];
+ s = rx->startp[i] + orig;
+ m = rx->endp[i] + orig;
if (m && s) {
dstr = NEWSV(33, m-s);
sv_setpvn(dstr, s, m-s);
XPUSHs(dstr);
}
}
- s = rx->endp[0];
+ s = rx->endp[0] + orig;
}
}
LEAVE_SCOPE(oldsave);
iters = (SP - PL_stack_base) - base;
if (iters > maxiters)
- DIE("Split loop");
+ DIE(aTHX_ "Split loop");
/* keep field after final delim? */
if (s < strend || (iters && origlimit)) {
else {
PUTBACK;
ENTER;
- perl_call_method("PUSH",G_SCALAR|G_DISCARD);
+ call_method("PUSH",G_SCALAR|G_DISCARD);
LEAVE;
SPAGAIN;
if (gimme == G_ARRAY) {
#ifdef USE_THREADS
void
-unlock_condpair(void *svv)
+Perl_unlock_condpair(pTHX_ void *svv)
{
dTHR;
MAGIC *mg = mg_find((SV*)svv, 'm');
if (!mg)
- croak("panic: unlock_condpair unlocking non-mutex");
+ Perl_croak(aTHX_ "panic: unlock_condpair unlocking non-mutex");
MUTEX_LOCK(MgMUTEXP(mg));
if (MgOWNER(mg) != thr)
- croak("panic: unlock_condpair unlocking mutex that we don't own");
+ Perl_croak(aTHX_ "panic: unlock_condpair unlocking mutex that we don't own");
MgOWNER(mg) = 0;
COND_SIGNAL(MgOWNERCONDP(mg));
DEBUG_S(PerlIO_printf(PerlIO_stderr(), "0x%lx: unlock 0x%lx\n",
DEBUG_S(PerlIO_printf(PerlIO_stderr(), "0x%lx: pp_lock lock 0x%lx\n",
(unsigned long)thr, (unsigned long)sv);)
MUTEX_UNLOCK(MgMUTEXP(mg));
- save_destructor(unlock_condpair, sv);
+ save_destructor(Perl_unlock_condpair, sv);
}
#endif /* USE_THREADS */
if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
PUSHs(THREADSV(PL_op->op_targ));
RETURN;
#else
- DIE("tried to access per-thread data in non-threaded perl");
+ DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
#endif /* USE_THREADS */
}