/* pp.c
*
- * Copyright (c) 1991-1994, Larry Wall
+ * Copyright (c) 1991-1997, 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 "perl.h"
/*
+ * The compiler on Concurrent CX/UX systems has a subtle bug which only
+ * seems to show up when compiling pp.c - it generates the wrong double
+ * precision constant value for (double)UV_MAX when used inline in the body
+ * of the code below, so this makes a static variable up front (which the
+ * compiler seems to get correct) and uses it in place of UV_MAX below.
+ */
+#ifdef CXUX_BROKEN_CONSTANT_CONVERT
+static double UV_MAX_cxux = ((double)UV_MAX);
+#endif
+
+/*
* Types used in bitwise operations.
*
* Normally we'd just use IV and UV. However, some hardware and
* floating-point type to use for NV that has adequate bits to fully
* hold an IV/UV. (In other words, sizeof(long) == sizeof(double).)
*
- * It just so happens that "int" is the right size everywhere, at
- * least today.
+ * It just so happens that "int" is the right size almost everywhere.
*/
typedef int IBW;
typedef unsigned UBW;
-static SV* refto _((SV* sv));
+/*
+ * Mask used after bitwise operations.
+ *
+ * There is at least one realm (Cray word machines) that doesn't
+ * have an integral type (except char) small enough to be represented
+ * in a double without loss; that is, it has no 32-bit type.
+ */
+#if BYTEORDER > 0xFFFF && defined(_CRAY) && !defined(_CRAYMPP)
+# define BW_BITS 32
+# define BW_MASK ((1 << BW_BITS) - 1)
+# define BW_SIGN (1 << (BW_BITS - 1))
+# define BWi(i) (((i) & BW_SIGN) ? ((i) | ~BW_MASK) : ((i) & BW_MASK))
+# define BWu(u) ((u) & BW_MASK)
+#else
+# define BWi(i) (i)
+# define BWu(u) (u)
+#endif
+
+/*
+ * Offset for integer pack/unpack.
+ *
+ * On architectures where I16 and I32 aren't really 16 and 32 bits,
+ * which for now are all Crays, pack and unpack have to play games.
+ */
+
+/*
+ * These values are required for portability of pack() output.
+ * If they're not right on your machine, then pack() and unpack()
+ * wouldn't work right anyway; you'll need to apply the Cray hack.
+ * (I'd like to check them with #if, but you can't use sizeof() in
+ * the preprocessor.)
+ */
+#define SIZE16 2
+#define SIZE32 4
+
+#if BYTEORDER > 0xFFFF && defined(_CRAY) && !defined(_CRAYMPP)
+# if BYTEORDER == 0x12345678
+# define OFF16(p) (char*)(p)
+# define OFF32(p) (char*)(p)
+# else
+# if BYTEORDER == 0x87654321
+# define OFF16(p) ((char*)(p) + (sizeof(U16) - SIZE16))
+# define OFF32(p) ((char*)(p) + (sizeof(U32) - SIZE32))
+# else
+ }}}} bad cray byte order
+# endif
+# endif
+# define COPY16(s,p) (*(p) = 0, Copy(s, OFF16(p), SIZE16, char))
+# define COPY32(s,p) (*(p) = 0, Copy(s, OFF32(p), SIZE32, char))
+# define CAT16(sv,p) sv_catpvn(sv, OFF16(p), SIZE16)
+# define CAT32(sv,p) sv_catpvn(sv, OFF32(p), SIZE32)
+#else
+# define COPY16(s,p) Copy(s, p, SIZE16, char)
+# define COPY32(s,p) Copy(s, p, SIZE32, char)
+# define CAT16(sv,p) sv_catpvn(sv, (char*)(p), SIZE16)
+# define CAT32(sv,p) sv_catpvn(sv, (char*)(p), SIZE32)
+#endif
+
static void doencodes _((SV* sv, char* s, I32 len));
+static SV* refto _((SV* sv));
+static U32 seed _((void));
+
+static bool srand_called = FALSE;
/* variations on pp_null */
+#ifdef DONT_DECLARE_STD
+#ifdef I_UNISTD
+#include <unistd.h>
+#endif
+#else
+extern pid_t getpid (void);
+#endif
+
PP(pp_stub)
{
- dSP;
- if (GIMME != G_ARRAY) {
+ djSP;
+ if (GIMME_V == G_SCALAR)
XPUSHs(&sv_undef);
- }
RETURN;
}
PP(pp_padav)
{
- dSP; dTARGET;
+ djSP; dTARGET;
if (op->op_private & OPpLVAL_INTRO)
SAVECLEARSV(curpad[op->op_targ]);
EXTEND(SP, 1);
PP(pp_padhv)
{
- dSP; dTARGET;
+ djSP; dTARGET;
+ I32 gimme;
+
XPUSHs(TARG);
if (op->op_private & OPpLVAL_INTRO)
SAVECLEARSV(curpad[op->op_targ]);
if (op->op_flags & OPf_REF)
RETURN;
- if (GIMME == G_ARRAY) { /* array wanted */
+ gimme = GIMME_V;
+ if (gimme == G_ARRAY) {
RETURNOP(do_kv(ARGS));
}
- else {
+ else if (gimme == G_SCALAR) {
SV* sv = sv_newmortal();
- if (HvFILL((HV*)TARG)) {
- sprintf(buf, "%d/%d", HvFILL((HV*)TARG), HvMAX((HV*)TARG)+1);
- sv_setpv(sv, buf);
- }
+ if (HvFILL((HV*)TARG))
+ sv_setpvf(sv, "%ld/%ld",
+ (long)HvFILL((HV*)TARG), (long)HvMAX((HV*)TARG) + 1);
else
sv_setiv(sv, 0);
SETs(sv);
- RETURN;
}
+ RETURN;
}
PP(pp_padany)
PP(pp_rv2gv)
{
- dSP; dTOPss;
+ djSP; dTOPss;
if (SvROK(sv)) {
wasref:
GV *gv = (GV*) sv_newmortal();
gv_init(gv, 0, "", 0, 0);
GvIOp(gv) = (IO *)sv;
- SvREFCNT_inc(sv);
+ (void)SvREFCNT_inc(sv);
sv = (SV*) gv;
} else if (SvTYPE(sv) != SVt_PVGV)
DIE("Not a GLOB reference");
if (op->op_flags & OPf_REF ||
op->op_private & HINT_STRICT_REFS)
DIE(no_usym, "a symbol");
+ if (dowarn)
+ warn(warn_uninit);
RETSETUNDEF;
}
sym = SvPV(sv, na);
PP(pp_rv2sv)
{
- dSP; dTOPss;
+ djSP; dTOPss;
if (SvROK(sv)) {
wasref:
if (op->op_flags & OPf_REF ||
op->op_private & HINT_STRICT_REFS)
DIE(no_usym, "a SCALAR");
+ if (dowarn)
+ warn(warn_uninit);
RETSETUNDEF;
}
sym = SvPV(sv, na);
if (op->op_private & OPpLVAL_INTRO)
sv = save_scalar((GV*)TOPs);
else if (op->op_private & OPpDEREF)
- provide_ref(op, sv);
+ vivify_ref(sv, op->op_private & OPpDEREF);
}
SETs(sv);
RETURN;
PP(pp_av2arylen)
{
- dSP;
+ djSP;
AV *av = (AV*)TOPs;
SV *sv = AvARYLEN(av);
if (!sv) {
PP(pp_pos)
{
- dSP; dTARGET; dPOPss;
+ djSP; dTARGET; dPOPss;
if (op->op_flags & OPf_MOD) {
if (SvTYPE(TARG) < SVt_PVLV) {
PP(pp_rv2cv)
{
- dSP;
+ djSP;
GV *gv;
HV *stash;
PP(pp_prototype)
{
- dSP;
+ djSP;
CV *cv;
HV *stash;
GV *gv;
PP(pp_anoncode)
{
- dSP;
+ djSP;
CV* cv = (CV*)curpad[op->op_targ];
if (CvCLONE(cv))
cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
PP(pp_srefgen)
{
- dSP;
+ djSP;
*SP = refto(*SP);
RETURN;
}
PP(pp_refgen)
{
- dSP; dMARK;
+ djSP; dMARK;
if (GIMME != G_ARRAY) {
MARK[1] = *SP;
SP = MARK + 1;
}
static SV*
-refto(sv)
-SV* sv;
+refto(SV *sv)
{
SV* rv;
if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
if (LvTARGLEN(sv))
- vivify_itervar(sv);
- if (LvTARG(sv))
- sv = LvTARG(sv);
+ vivify_defelem(sv);
+ if (!(sv = LvTARG(sv)))
+ sv = &sv_undef;
}
else if (SvPADTMP(sv))
sv = newSVsv(sv);
PP(pp_ref)
{
- dSP; dTARGET;
+ djSP; dTARGET;
SV *sv;
char *pv;
PP(pp_bless)
{
- dSP;
+ djSP;
HV *stash;
if (MAXARG == 1)
RETURN;
}
+PP(pp_gelem)
+{
+ GV *gv;
+ SV *sv;
+ SV *ref;
+ char *elem;
+ djSP;
+
+ sv = POPs;
+ elem = SvPV(sv, na);
+ gv = (GV*)POPs;
+ ref = Nullsv;
+ sv = Nullsv;
+ switch (elem ? *elem : '\0')
+ {
+ case 'A':
+ if (strEQ(elem, "ARRAY"))
+ ref = (SV*)GvAV(gv);
+ break;
+ case 'C':
+ if (strEQ(elem, "CODE"))
+ ref = (SV*)GvCVu(gv);
+ break;
+ case 'F':
+ if (strEQ(elem, "FILEHANDLE")) /* XXX deprecate in 5.005 */
+ ref = (SV*)GvIOp(gv);
+ break;
+ case 'G':
+ if (strEQ(elem, "GLOB"))
+ ref = (SV*)gv;
+ break;
+ case 'H':
+ if (strEQ(elem, "HASH"))
+ ref = (SV*)GvHV(gv);
+ break;
+ case 'I':
+ if (strEQ(elem, "IO"))
+ ref = (SV*)GvIOp(gv);
+ break;
+ case 'N':
+ if (strEQ(elem, "NAME"))
+ sv = newSVpv(GvNAME(gv), GvNAMELEN(gv));
+ break;
+ case 'P':
+ if (strEQ(elem, "PACKAGE"))
+ sv = newSVpv(HvNAME(GvSTASH(gv)), 0);
+ break;
+ case 'S':
+ if (strEQ(elem, "SCALAR"))
+ ref = GvSV(gv);
+ break;
+ }
+ if (ref)
+ sv = newRV(ref);
+ if (sv)
+ sv_2mortal(sv);
+ else
+ sv = &sv_undef;
+ XPUSHs(sv);
+ RETURN;
+}
+
/* Pattern matching */
PP(pp_study)
{
- dSP; dPOPss;
+ djSP; dPOPss;
register unsigned char *s;
register I32 pos;
register I32 ch;
register I32 *sfirst;
register I32 *snext;
- I32 retval;
STRLEN len;
- s = (unsigned char*)(SvPV(sv, len));
- pos = len;
- if (sv == lastscream)
- SvSCREAM_off(sv);
+ if (sv == lastscream) {
+ if (SvSCREAM(sv))
+ RETPUSHYES;
+ }
else {
if (lastscream) {
SvSCREAM_off(lastscream);
}
lastscream = SvREFCNT_inc(sv);
}
- if (pos <= 0) {
- retval = 0;
- goto ret;
- }
+
+ s = (unsigned char*)(SvPV(sv, len));
+ pos = len;
+ if (pos <= 0)
+ RETPUSHNO;
if (pos > maxscream) {
if (maxscream < 0) {
maxscream = pos + 80;
SvSCREAM_on(sv);
sv_magic(sv, Nullsv, 'g', Nullch, 0); /* piggyback on m//g magic */
- retval = 1;
- ret:
- XPUSHs(sv_2mortal(newSViv((I32)retval)));
- RETURN;
+ RETPUSHYES;
}
PP(pp_trans)
{
- dSP; dTARG;
+ djSP; dTARG;
SV *sv;
if (op->op_flags & OPf_STACKED)
PP(pp_schop)
{
- dSP; dTARGET;
+ djSP; dTARGET;
do_chop(TARG, TOPs);
SETTARG;
RETURN;
PP(pp_chop)
{
- dSP; dMARK; dTARGET;
+ djSP; dMARK; dTARGET;
while (SP > MARK)
do_chop(TARG, POPs);
PUSHTARG;
PP(pp_schomp)
{
- dSP; dTARGET;
+ djSP; dTARGET;
SETi(do_chomp(TOPs));
RETURN;
}
PP(pp_chomp)
{
- dSP; dMARK; dTARGET;
+ djSP; dMARK; dTARGET;
register I32 count = 0;
while (SP > MARK)
PP(pp_defined)
{
- dSP;
+ djSP;
register SV* sv;
sv = POPs;
RETPUSHNO;
switch (SvTYPE(sv)) {
case SVt_PVAV:
- if (AvMAX(sv) >= 0 || SvRMAGICAL(sv))
+ if (AvMAX(sv) >= 0 || SvGMAGICAL(sv))
RETPUSHYES;
break;
case SVt_PVHV:
- if (HvARRAY(sv) || SvRMAGICAL(sv))
+ if (HvARRAY(sv) || SvGMAGICAL(sv))
RETPUSHYES;
break;
case SVt_PVCV:
PP(pp_undef)
{
- dSP;
+ djSP;
SV *sv;
- if (!op->op_private)
+ if (!op->op_private) {
+ EXTEND(SP, 1);
RETPUSHUNDEF;
+ }
sv = POPs;
if (!sv)
hv_undef((HV*)sv);
break;
case SVt_PVCV:
- cv_undef((CV*)sv);
+ if (cv_const_sv((CV*)sv))
+ warn("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 */
break;
case SVt_PVGV:
if (SvFAKE(sv))
sv_setsv(sv, &sv_undef);
break;
default:
- if (SvPOK(sv) && SvLEN(sv)) {
+ if (SvTYPE(sv) >= SVt_PV && SvPVX(sv) && SvLEN(sv)) {
(void)SvOOK_off(sv);
Safefree(SvPVX(sv));
SvPV_set(sv, Nullch);
PP(pp_predec)
{
- dSP;
- if (SvREADONLY(TOPs))
+ djSP;
+ if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
croak(no_modify);
if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
SvIVX(TOPs) != IV_MIN)
PP(pp_postinc)
{
- dSP; dTARGET;
- if (SvREADONLY(TOPs))
+ djSP; dTARGET;
+ if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
croak(no_modify);
sv_setsv(TARG, TOPs);
if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
PP(pp_postdec)
{
- dSP; dTARGET;
- if(SvREADONLY(TOPs))
+ djSP; dTARGET;
+ if(SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
croak(no_modify);
sv_setsv(TARG, TOPs);
if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
PP(pp_pow)
{
- dSP; dATARGET; tryAMAGICbin(pow,opASSIGN);
+ djSP; dATARGET; tryAMAGICbin(pow,opASSIGN);
{
dPOPTOPnnrl;
SETn( pow( left, right) );
PP(pp_multiply)
{
- dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
+ djSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
{
dPOPTOPnnrl;
SETn( left * right );
PP(pp_divide)
{
- dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
+ djSP; dATARGET; tryAMAGICbin(div,opASSIGN);
{
dPOPPOPnnrl;
double value;
PP(pp_modulo)
{
- dSP; dATARGET; tryAMAGICbin(mod,opASSIGN);
+ djSP; dATARGET; tryAMAGICbin(mod,opASSIGN);
{
- register UV right;
+ UV left;
+ UV right;
+ bool left_neg;
+ bool right_neg;
+ UV ans;
- right = POPu;
- if (!right)
- DIE("Illegal modulus zero");
+ 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);
+ }
if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
- register IV left = SvIVX(TOPs);
- if (left < 0)
- SETu( (right - ((UV)(-left) - 1) % right) - 1 );
- else
- SETi( left % right );
+ IV i = SvIVX(POPs);
+ left = (left_neg = (i < 0)) ? -i : i;
}
else {
- register double left = TOPn;
- if (left < 0.0)
- SETu( (right - (U_V(-left) - 1) % right) - 1 );
+ double n = POPn;
+ left = U_V((left_neg = (n < 0)) ? -n : n);
+ }
+
+ 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
- SETu( U_V(left) % right );
+ sv_setnv(TARG, -(double)ans);
}
+ else
+ sv_setuv(TARG, ans);
+ PUSHTARG;
RETURN;
}
}
PP(pp_repeat)
{
- dSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
+ djSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
{
register I32 count = POPi;
if (GIMME == G_ARRAY && op->op_private & OPpREPEAT_DOLIST) {
PP(pp_subtract)
{
- dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
+ djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
{
dPOPTOPnnrl_ul;
SETn( left - right );
PP(pp_left_shift)
{
- dSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
+ djSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
{
IBW shift = POPi;
if (op->op_private & HINT_INTEGER) {
IBW i = TOPi;
- SETi( i << shift );
+ i = BWi(i) << shift;
+ SETi(BWi(i));
}
else {
UBW u = TOPu;
- SETu( u << shift );
+ u <<= shift;
+ SETu(BWu(u));
}
RETURN;
}
PP(pp_right_shift)
{
- dSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
+ djSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
{
IBW shift = POPi;
if (op->op_private & HINT_INTEGER) {
IBW i = TOPi;
- SETi( i >> shift );
+ i = BWi(i) >> shift;
+ SETi(BWi(i));
}
else {
UBW u = TOPu;
- SETu( u >> shift );
+ u >>= shift;
+ SETu(BWu(u));
}
RETURN;
}
PP(pp_lt)
{
- dSP; tryAMAGICbinSET(lt,0);
+ djSP; tryAMAGICbinSET(lt,0);
{
dPOPnv;
- SETs((TOPn < value) ? &sv_yes : &sv_no);
+ SETs(boolSV(TOPn < value));
RETURN;
}
}
PP(pp_gt)
{
- dSP; tryAMAGICbinSET(gt,0);
+ djSP; tryAMAGICbinSET(gt,0);
{
dPOPnv;
- SETs((TOPn > value) ? &sv_yes : &sv_no);
+ SETs(boolSV(TOPn > value));
RETURN;
}
}
PP(pp_le)
{
- dSP; tryAMAGICbinSET(le,0);
+ djSP; tryAMAGICbinSET(le,0);
{
dPOPnv;
- SETs((TOPn <= value) ? &sv_yes : &sv_no);
+ SETs(boolSV(TOPn <= value));
RETURN;
}
}
PP(pp_ge)
{
- dSP; tryAMAGICbinSET(ge,0);
+ djSP; tryAMAGICbinSET(ge,0);
{
dPOPnv;
- SETs((TOPn >= value) ? &sv_yes : &sv_no);
+ SETs(boolSV(TOPn >= value));
RETURN;
}
}
PP(pp_ne)
{
- dSP; tryAMAGICbinSET(ne,0);
+ djSP; tryAMAGICbinSET(ne,0);
{
dPOPnv;
- SETs((TOPn != value) ? &sv_yes : &sv_no);
+ SETs(boolSV(TOPn != value));
RETURN;
}
}
PP(pp_ncmp)
{
- dSP; dTARGET; tryAMAGICbin(ncmp,0);
+ djSP; dTARGET; tryAMAGICbin(ncmp,0);
{
dPOPTOPnnrl;
I32 value;
- if (left < right)
- value = -1;
- else if (left == right)
+ if (left == right)
value = 0;
+ else if (left < right)
+ value = -1;
else if (left > right)
value = 1;
else {
PP(pp_slt)
{
- dSP; tryAMAGICbinSET(slt,0);
+ djSP; tryAMAGICbinSET(slt,0);
{
dPOPTOPssrl;
int cmp = ((op->op_private & OPpLOCALE)
? sv_cmp_locale(left, right)
: sv_cmp(left, right));
- SETs( cmp < 0 ? &sv_yes : &sv_no );
+ SETs(boolSV(cmp < 0));
RETURN;
}
}
PP(pp_sgt)
{
- dSP; tryAMAGICbinSET(sgt,0);
+ djSP; tryAMAGICbinSET(sgt,0);
{
dPOPTOPssrl;
int cmp = ((op->op_private & OPpLOCALE)
? sv_cmp_locale(left, right)
: sv_cmp(left, right));
- SETs( cmp > 0 ? &sv_yes : &sv_no );
+ SETs(boolSV(cmp > 0));
RETURN;
}
}
PP(pp_sle)
{
- dSP; tryAMAGICbinSET(sle,0);
+ djSP; tryAMAGICbinSET(sle,0);
{
dPOPTOPssrl;
int cmp = ((op->op_private & OPpLOCALE)
? sv_cmp_locale(left, right)
: sv_cmp(left, right));
- SETs( cmp <= 0 ? &sv_yes : &sv_no );
+ SETs(boolSV(cmp <= 0));
RETURN;
}
}
PP(pp_sge)
{
- dSP; tryAMAGICbinSET(sge,0);
+ djSP; tryAMAGICbinSET(sge,0);
{
dPOPTOPssrl;
int cmp = ((op->op_private & OPpLOCALE)
? sv_cmp_locale(left, right)
: sv_cmp(left, right));
- SETs( cmp >= 0 ? &sv_yes : &sv_no );
+ SETs(boolSV(cmp >= 0));
RETURN;
}
}
PP(pp_seq)
{
- dSP; tryAMAGICbinSET(seq,0);
+ djSP; tryAMAGICbinSET(seq,0);
{
dPOPTOPssrl;
- SETs( sv_eq(left, right) ? &sv_yes : &sv_no );
+ SETs(boolSV(sv_eq(left, right)));
RETURN;
}
}
PP(pp_sne)
{
- dSP; tryAMAGICbinSET(sne,0);
+ djSP; tryAMAGICbinSET(sne,0);
{
dPOPTOPssrl;
- SETs( !sv_eq(left, right) ? &sv_yes : &sv_no );
+ SETs(boolSV(!sv_eq(left, right)));
RETURN;
}
}
PP(pp_scmp)
{
- dSP; dTARGET; tryAMAGICbin(scmp,0);
+ djSP; dTARGET; tryAMAGICbin(scmp,0);
{
dPOPTOPssrl;
int cmp = ((op->op_private & OPpLOCALE)
PP(pp_bit_and)
{
- dSP; dATARGET; tryAMAGICbin(band,opASSIGN);
+ djSP; dATARGET; tryAMAGICbin(band,opASSIGN);
{
dPOPTOPssrl;
if (SvNIOKp(left) || SvNIOKp(right)) {
if (op->op_private & HINT_INTEGER) {
IBW value = SvIV(left) & SvIV(right);
- SETi( value );
+ SETi(BWi(value));
}
else {
UBW value = SvUV(left) & SvUV(right);
- SETu( value );
+ SETu(BWu(value));
}
}
else {
PP(pp_bit_xor)
{
- dSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
+ djSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
{
dPOPTOPssrl;
if (SvNIOKp(left) || SvNIOKp(right)) {
if (op->op_private & HINT_INTEGER) {
IBW value = (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right);
- SETi( value );
+ SETi(BWi(value));
}
else {
UBW value = (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right);
- SETu( value );
+ SETu(BWu(value));
}
}
else {
PP(pp_bit_or)
{
- dSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
+ djSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
{
dPOPTOPssrl;
if (SvNIOKp(left) || SvNIOKp(right)) {
if (op->op_private & HINT_INTEGER) {
IBW value = (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right);
- SETi( value );
+ SETi(BWi(value));
}
else {
UBW value = (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right);
- SETu( value );
+ SETu(BWu(value));
}
}
else {
PP(pp_negate)
{
- dSP; dTARGET; tryAMAGICun(neg);
+ djSP; dTARGET; tryAMAGICun(neg);
{
dTOPss;
if (SvGMAGICAL(sv))
PP(pp_not)
{
#ifdef OVERLOAD
- dSP; tryAMAGICunSET(not);
+ djSP; tryAMAGICunSET(not);
#endif /* OVERLOAD */
- *stack_sp = SvTRUE(*stack_sp) ? &sv_no : &sv_yes;
+ *stack_sp = boolSV(!SvTRUE(*stack_sp));
return NORMAL;
}
PP(pp_complement)
{
- dSP; dTARGET; tryAMAGICun(compl);
+ djSP; dTARGET; tryAMAGICun(compl);
{
dTOPss;
if (SvNIOKp(sv)) {
if (op->op_private & HINT_INTEGER) {
IBW value = ~SvIV(sv);
- SETi( value );
+ SETi(BWi(value));
}
else {
UBW value = ~SvUV(sv);
- SETu( value );
+ SETu(BWu(value));
}
}
else {
PP(pp_i_multiply)
{
- dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
+ djSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
{
dPOPTOPiirl;
SETi( left * right );
PP(pp_i_divide)
{
- dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
+ djSP; dATARGET; tryAMAGICbin(div,opASSIGN);
{
dPOPiv;
if (value == 0)
PP(pp_i_modulo)
{
- dSP; dATARGET; tryAMAGICbin(mod,opASSIGN);
+ djSP; dATARGET; tryAMAGICbin(mod,opASSIGN);
{
dPOPTOPiirl;
+ if (!right)
+ DIE("Illegal modulus zero");
SETi( left % right );
RETURN;
}
PP(pp_i_add)
{
- dSP; dATARGET; tryAMAGICbin(add,opASSIGN);
+ djSP; dATARGET; tryAMAGICbin(add,opASSIGN);
{
dPOPTOPiirl;
SETi( left + right );
PP(pp_i_subtract)
{
- dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
+ djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
{
dPOPTOPiirl;
SETi( left - right );
PP(pp_i_lt)
{
- dSP; tryAMAGICbinSET(lt,0);
+ djSP; tryAMAGICbinSET(lt,0);
{
dPOPTOPiirl;
- SETs((left < right) ? &sv_yes : &sv_no);
+ SETs(boolSV(left < right));
RETURN;
}
}
PP(pp_i_gt)
{
- dSP; tryAMAGICbinSET(gt,0);
+ djSP; tryAMAGICbinSET(gt,0);
{
dPOPTOPiirl;
- SETs((left > right) ? &sv_yes : &sv_no);
+ SETs(boolSV(left > right));
RETURN;
}
}
PP(pp_i_le)
{
- dSP; tryAMAGICbinSET(le,0);
+ djSP; tryAMAGICbinSET(le,0);
{
dPOPTOPiirl;
- SETs((left <= right) ? &sv_yes : &sv_no);
+ SETs(boolSV(left <= right));
RETURN;
}
}
PP(pp_i_ge)
{
- dSP; tryAMAGICbinSET(ge,0);
+ djSP; tryAMAGICbinSET(ge,0);
{
dPOPTOPiirl;
- SETs((left >= right) ? &sv_yes : &sv_no);
+ SETs(boolSV(left >= right));
RETURN;
}
}
PP(pp_i_eq)
{
- dSP; tryAMAGICbinSET(eq,0);
+ djSP; tryAMAGICbinSET(eq,0);
{
dPOPTOPiirl;
- SETs((left == right) ? &sv_yes : &sv_no);
+ SETs(boolSV(left == right));
RETURN;
}
}
PP(pp_i_ne)
{
- dSP; tryAMAGICbinSET(ne,0);
+ djSP; tryAMAGICbinSET(ne,0);
{
dPOPTOPiirl;
- SETs((left != right) ? &sv_yes : &sv_no);
+ SETs(boolSV(left != right));
RETURN;
}
}
PP(pp_i_ncmp)
{
- dSP; dTARGET; tryAMAGICbin(ncmp,0);
+ djSP; dTARGET; tryAMAGICbin(ncmp,0);
{
dPOPTOPiirl;
I32 value;
PP(pp_i_negate)
{
- dSP; dTARGET; tryAMAGICun(neg);
+ djSP; dTARGET; tryAMAGICun(neg);
SETi(-TOPi);
RETURN;
}
PP(pp_atan2)
{
- dSP; dTARGET; tryAMAGICbin(atan2,0);
+ djSP; dTARGET; tryAMAGICbin(atan2,0);
{
dPOPTOPnnrl;
SETn(atan2(left, right));
PP(pp_sin)
{
- dSP; dTARGET; tryAMAGICun(sin);
+ djSP; dTARGET; tryAMAGICun(sin);
{
double value;
value = POPn;
PP(pp_cos)
{
- dSP; dTARGET; tryAMAGICun(cos);
+ djSP; dTARGET; tryAMAGICun(cos);
{
double value;
value = POPn;
PP(pp_rand)
{
- dSP; dTARGET;
+ djSP; dTARGET;
double value;
if (MAXARG < 1)
value = 1.0;
value = POPn;
if (value == 0.0)
value = 1.0;
+ if (!srand_called) {
+ (void)srand((unsigned)seed());
+ srand_called = TRUE;
+ }
#if RANDBITS == 31
value = rand() * value / 2147483648.0;
#else
PP(pp_srand)
{
- dSP;
- I32 anum;
+ djSP;
+ UV anum;
+ if (MAXARG < 1)
+ anum = seed();
+ else
+ anum = POPu;
+ (void)srand((unsigned)anum);
+ srand_called = TRUE;
+ EXTEND(SP, 1);
+ RETPUSHYES;
+}
+
+static U32
+seed(void)
+{
+ /*
+ * 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 tings 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 anyting 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
- if (MAXARG < 1) {
+ dTHR;
+ U32 u;
#ifdef VMS
# include <starlet.h>
- unsigned int when[2];
- _ckvmssts(sys$gettim(when));
- anum = when[0] ^ when[1];
+ /* when[] = (low 32 bits, high 32 bits) of time since epoch
+ * in 100-ns units, typically incremented ever 10 ms. */
+ unsigned int when[2];
+ _ckvmssts(sys$gettim(when));
+ u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
#else
# ifdef HAS_GETTIMEOFDAY
- struct timeval when;
- gettimeofday(&when,(struct timezone *) 0);
- anum = when.tv_sec ^ when.tv_usec;
+ struct timeval when;
+ gettimeofday(&when,(struct timezone *) 0);
+ u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
# else
- Time_t when;
- (void)time(&when);
- anum = when;
+ Time_t when;
+ (void)time(&when);
+ u = (U32)SEED_C1 * when;
# endif
#endif
-#if !defined(PLAN9) /* XXX Plan9 assembler chokes on this; fix coming soon */
- /* 17-Jul-1996 bailey@genetics.upenn.edu */
- /* What is a good hashing algorithm here? */
- anum ^= ( ( 269 * (U32)getpid())
- ^ (26107 * (U32)&when)
- ^ (73819 * (U32)stack_sp));
+ u += SEED_C3 * (U32)getpid();
+ u += SEED_C4 * (U32)(UV)stack_sp;
+#ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
+ u += SEED_C5 * (U32)(UV)&when;
#endif
- }
- else
- anum = POPi;
- (void)srand(anum);
- EXTEND(SP, 1);
- RETPUSHYES;
+ return u;
}
PP(pp_exp)
{
- dSP; dTARGET; tryAMAGICun(exp);
+ djSP; dTARGET; tryAMAGICun(exp);
{
double value;
value = POPn;
PP(pp_log)
{
- dSP; dTARGET; tryAMAGICun(log);
+ djSP; dTARGET; tryAMAGICun(log);
{
double value;
value = POPn;
PP(pp_sqrt)
{
- dSP; dTARGET; tryAMAGICun(sqrt);
+ djSP; dTARGET; tryAMAGICun(sqrt);
{
double value;
value = POPn;
PP(pp_int)
{
- dSP; dTARGET;
- double value;
- value = POPn;
- if (value >= 0.0)
- (void)modf(value, &value);
- else {
- (void)modf(-value, &value);
- value = -value;
+ djSP; dTARGET;
+ {
+ double value = TOPn;
+ IV iv;
+
+ if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs)) {
+ iv = SvIVX(TOPs);
+ SETi(iv);
+ }
+ else {
+ if (value >= 0.0)
+ (void)modf(value, &value);
+ else {
+ (void)modf(-value, &value);
+ value = -value;
+ }
+ iv = I_V(value);
+ if (iv == value)
+ SETi(iv);
+ else
+ SETn(value);
+ }
}
- XPUSHn(value);
RETURN;
}
PP(pp_abs)
{
- dSP; dTARGET; tryAMAGICun(abs);
+ djSP; dTARGET; tryAMAGICun(abs);
{
- double value;
- value = POPn;
-
- if (value < 0.0)
- value = -value;
-
- XPUSHn(value);
- RETURN;
+ double value = TOPn;
+ IV iv;
+
+ if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs) &&
+ (iv = SvIVX(TOPs)) != IV_MIN) {
+ if (iv < 0)
+ iv = -iv;
+ SETi(iv);
+ }
+ else {
+ if (value < 0.0)
+ value = -value;
+ SETn(value);
+ }
}
+ RETURN;
}
PP(pp_hex)
{
- dSP; dTARGET;
+ djSP; dTARGET;
char *tmps;
I32 argtype;
PP(pp_oct)
{
- dSP; dTARGET;
+ djSP; dTARGET;
UV value;
I32 argtype;
char *tmps;
PP(pp_length)
{
- dSP; dTARGET;
+ djSP; dTARGET;
SETi( sv_len(TOPs) );
RETURN;
}
PP(pp_substr)
{
- dSP; dTARGET;
+ djSP; dTARGET;
SV *sv;
I32 len;
STRLEN curlen;
I32 pos;
I32 rem;
+ I32 fail;
I32 lvalue = op->op_flags & OPf_MOD;
char *tmps;
I32 arybase = curcop->cop_arybase;
if (MAXARG > 2)
len = POPi;
- pos = POPi - arybase;
+ pos = POPi;
sv = POPs;
tmps = SvPV(sv, curlen);
- if (pos < 0)
- pos += curlen + arybase;
- if (pos < 0 || pos > curlen) {
- if (dowarn || lvalue)
+ if (pos >= arybase) {
+ pos -= arybase;
+ rem = curlen-pos;
+ fail = rem;
+ if (MAXARG > 2) {
+ if (len < 0) {
+ rem += len;
+ if (rem < 0)
+ rem = 0;
+ }
+ else if (rem > len)
+ rem = len;
+ }
+ }
+ else {
+ pos += curlen;
+ if (MAXARG < 3)
+ rem = curlen;
+ else if (len >= 0) {
+ rem = pos+len;
+ if (rem > (I32)curlen)
+ rem = curlen;
+ }
+ else {
+ rem = curlen+len;
+ if (rem < pos)
+ rem = pos;
+ }
+ if (pos < 0)
+ pos = 0;
+ fail = rem;
+ rem -= pos;
+ }
+ if (fail < 0) {
+ if (dowarn || lvalue)
warn("substr outside of string");
RETPUSHUNDEF;
}
else {
- if (MAXARG < 3)
- len = curlen;
- else if (len < 0) {
- len += curlen - pos;
- if (len < 0)
- len = 0;
- }
tmps += pos;
- rem = curlen - pos; /* rem=how many bytes left*/
- if (rem > len)
- rem = len;
sv_setpvn(TARG, tmps, rem);
if (lvalue) { /* it's an lvalue! */
if (!SvGMAGICAL(sv)) {
PP(pp_vec)
{
- dSP; dTARGET;
+ djSP; dTARGET;
register I32 size = POPi;
register I32 offset = POPi;
register SV *src = POPs;
}
}
- sv_setiv(TARG, (I32)retnum);
+ sv_setiv(TARG, (IV)retnum);
PUSHs(TARG);
RETURN;
}
PP(pp_index)
{
- dSP; dTARGET;
+ djSP; dTARGET;
SV *big;
SV *little;
I32 offset;
PP(pp_rindex)
{
- dSP; dTARGET;
+ djSP; dTARGET;
SV *big;
SV *little;
STRLEN blen;
PP(pp_sprintf)
{
- dSP; dMARK; dORIGMARK; dTARGET;
+ djSP; dMARK; dORIGMARK; dTARGET;
#ifdef USE_LOCALE_NUMERIC
if (op->op_private & OPpLOCALE)
SET_NUMERIC_LOCAL();
PP(pp_ord)
{
- dSP; dTARGET;
+ djSP; dTARGET;
I32 value;
char *tmps;
PP(pp_chr)
{
- dSP; dTARGET;
+ djSP; dTARGET;
char *tmps;
(void)SvUPGRADE(TARG,SVt_PV);
PP(pp_crypt)
{
- dSP; dTARGET; dPOPTOPssrl;
+ djSP; dTARGET; dPOPTOPssrl;
#ifdef HAS_CRYPT
char *tmps = SvPV(left, na);
#ifdef FCRYPT
PP(pp_ucfirst)
{
- dSP;
+ djSP;
SV *sv = TOPs;
register char *s;
PP(pp_lcfirst)
{
- dSP;
+ djSP;
SV *sv = TOPs;
register char *s;
PP(pp_uc)
{
- dSP;
+ djSP;
SV *sv = TOPs;
register char *s;
STRLEN len;
PP(pp_lc)
{
- dSP;
+ djSP;
SV *sv = TOPs;
register char *s;
STRLEN len;
PP(pp_quotemeta)
{
- dSP; dTARGET;
+ djSP; dTARGET;
SV *sv = TOPs;
STRLEN len;
register char *s = SvPV(sv,len);
PP(pp_aslice)
{
- dSP; dMARK; dORIGMARK;
+ djSP; dMARK; dORIGMARK;
register SV** svp;
register AV* av = (AV*)POPs;
register I32 lval = op->op_flags & OPf_MOD;
PP(pp_each)
{
- dSP; dTARGET;
+ djSP; dTARGET;
HV *hash = (HV*)POPs;
HE *entry;
+ I32 gimme = GIMME_V;
+ I32 realhv = (SvTYPE(hash) == SVt_PVHV);
PUTBACK;
- entry = hv_iternext(hash); /* might clobber stack_sp */
+ /* might clobber stack_sp */
+ entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash);
SPAGAIN;
EXTEND(SP, 2);
if (entry) {
- PUSHs(hv_iterkeysv(entry)); /* won't clobber stack_sp */
- if (GIMME == G_ARRAY) {
+ PUSHs(hv_iterkeysv(entry)); /* won't clobber stack_sp */
+ if (gimme == G_ARRAY) {
PUTBACK;
- sv_setsv(TARG, hv_iterval(hash, entry)); /* might clobber stack_sp */
+ /* might clobber stack_sp */
+ sv_setsv(TARG, realhv ?
+ hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry));
SPAGAIN;
PUSHs(TARG);
}
}
- else if (GIMME == G_SCALAR)
+ else if (gimme == G_SCALAR)
RETPUSHUNDEF;
RETURN;
PP(pp_delete)
{
- dSP;
+ djSP;
+ I32 gimme = GIMME_V;
+ I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
SV *sv;
HV *hv;
if (op->op_private & OPpSLICE) {
dMARK; dORIGMARK;
+ U32 hvtype;
hv = (HV*)POPs;
- if (SvTYPE(hv) != SVt_PVHV)
- DIE("Not a HASH reference");
+ hvtype = SvTYPE(hv);
while (++MARK <= SP) {
- sv = hv_delete_ent(hv, *MARK,
- (op->op_private & OPpLEAVE_VOID ? G_DISCARD : 0), 0);
+ if (hvtype == SVt_PVHV)
+ sv = hv_delete_ent(hv, *MARK, discard, 0);
+ else if (hvtype == SVt_PVAV)
+ sv = avhv_delete_ent((AV*)hv, *MARK, discard, 0);
+ else
+ DIE("Not a HASH reference");
*MARK = sv ? sv : &sv_undef;
}
- if (GIMME != G_ARRAY) {
+ if (discard)
+ SP = ORIGMARK;
+ else if (gimme == G_SCALAR) {
MARK = ORIGMARK;
*++MARK = *SP;
SP = MARK;
else {
SV *keysv = POPs;
hv = (HV*)POPs;
- if (SvTYPE(hv) != SVt_PVHV)
+ if (SvTYPE(hv) == SVt_PVHV)
+ sv = hv_delete_ent(hv, keysv, discard, 0);
+ else if (SvTYPE(hv) == SVt_PVAV)
+ sv = avhv_delete_ent((AV*)hv, keysv, discard, 0);
+ else
DIE("Not a HASH reference");
- sv = hv_delete_ent(hv, keysv,
- (op->op_private & OPpLEAVE_VOID ? G_DISCARD : 0), 0);
if (!sv)
sv = &sv_undef;
- PUSHs(sv);
+ if (!discard)
+ PUSHs(sv);
}
RETURN;
}
PP(pp_exists)
{
- dSP;
+ djSP;
SV *tmpsv = POPs;
HV *hv = (HV*)POPs;
- STRLEN len;
- if (SvTYPE(hv) != SVt_PVHV) {
+ if (SvTYPE(hv) == SVt_PVHV) {
+ if (hv_exists_ent(hv, tmpsv, 0))
+ RETPUSHYES;
+ } else if (SvTYPE(hv) == SVt_PVAV) {
+ if (avhv_exists_ent((AV*)hv, tmpsv, 0))
+ RETPUSHYES;
+ } else {
DIE("Not a HASH reference");
}
- if (hv_exists_ent(hv, tmpsv, 0))
- RETPUSHYES;
RETPUSHNO;
}
PP(pp_hslice)
{
- dSP; dMARK; dORIGMARK;
+ djSP; dMARK; dORIGMARK;
register HE *he;
register HV *hv = (HV*)POPs;
register I32 lval = op->op_flags & OPf_MOD;
+ I32 realhv = (SvTYPE(hv) == SVt_PVHV);
- if (SvTYPE(hv) == SVt_PVHV) {
+ if (realhv || SvTYPE(hv) == SVt_PVAV) {
while (++MARK <= SP) {
SV *keysv = *MARK;
-
- he = hv_fetch_ent(hv, keysv, lval, 0);
+ SV **svp;
+ if (realhv) {
+ 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 (!he || HeVAL(he) == &sv_undef)
DIE(no_helem, SvPV(keysv, na));
PP(pp_list)
{
- dSP; dMARK;
+ djSP; dMARK;
if (GIMME != G_ARRAY) {
if (++MARK <= SP)
*MARK = *SP; /* unwanted list, return last item */
PP(pp_lslice)
{
- dSP;
+ djSP;
SV **lastrelem = stack_sp;
SV **lastlelem = stack_base + POPMARK;
SV **firstlelem = stack_base + POPMARK + 1;
if (ix >= max || !(*lelem = firstrelem[ix]))
*lelem = &sv_undef;
}
- if (!is_something_there && (SvOKp(*lelem) || SvGMAGICAL(*lelem)))
+ if (!is_something_there && (SvOK(*lelem) || SvGMAGICAL(*lelem)))
is_something_there = TRUE;
}
if (is_something_there)
PP(pp_anonlist)
{
- dSP; dMARK; dORIGMARK;
+ djSP; dMARK; dORIGMARK;
I32 items = SP - MARK;
SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
SP = ORIGMARK; /* av_make() might realloc stack_sp */
PP(pp_anonhash)
{
- dSP; dMARK; dORIGMARK;
+ djSP; dMARK; dORIGMARK;
HV* hv = (HV*)sv_2mortal((SV*)newHV());
while (MARK < SP) {
SV *val = NEWSV(46, 0);
if (MARK < SP)
sv_setsv(val, *++MARK);
- else
+ else if (dowarn)
warn("Odd number of elements in hash list");
(void)hv_store_ent(hv,key,val,0);
}
PP(pp_splice)
{
- dSP; dMARK; dORIGMARK;
+ djSP; dMARK; dORIGMARK;
register AV *ary = (AV*)*++MARK;
register SV **src;
register SV **dst;
SP++;
if (++MARK < SP) {
- offset = SvIVx(*MARK);
+ offset = i = SvIVx(*MARK);
if (offset < 0)
offset += AvFILL(ary) + 1;
else
offset -= curcop->cop_arybase;
+ if (offset < 0)
+ DIE(no_aelem, i);
if (++MARK < SP) {
length = SvIVx(*MARK++);
if (length < 0)
offset = 0;
length = AvMAX(ary) + 1;
}
- if (offset < 0) {
- length += offset;
- offset = 0;
- if (length < 0)
- length = 0;
- }
if (offset > AvFILL(ary) + 1)
offset = AvFILL(ary) + 1;
after = AvFILL(ary) + 1 - (offset + length);
newlen = SP - MARK;
diff = newlen - length;
+ if (newlen && !AvREAL(ary)) {
+ if (AvREIFY(ary))
+ av_reify(ary);
+ else
+ assert(AvREAL(ary)); /* would leak, so croak */
+ }
if (diff < 0) { /* shrinking the area */
if (newlen) {
PP(pp_push)
{
- dSP; dMARK; dORIGMARK; dTARGET;
+ djSP; dMARK; dORIGMARK; dTARGET;
register AV *ary = (AV*)*++MARK;
register SV *sv = &sv_undef;
PP(pp_pop)
{
- dSP;
+ djSP;
AV *av = (AV*)POPs;
SV *sv = av_pop(av);
if (!SvIMMORTAL(sv) && AvREAL(av))
PP(pp_shift)
{
- dSP;
+ djSP;
AV *av = (AV*)POPs;
SV *sv = av_shift(av);
EXTEND(SP, 1);
PP(pp_unshift)
{
- dSP; dMARK; dORIGMARK; dTARGET;
+ djSP; dMARK; dORIGMARK; dTARGET;
register AV *ary = (AV*)*++MARK;
register SV *sv;
register I32 i = 0;
PP(pp_reverse)
{
- dSP; dMARK;
+ djSP; dMARK;
register SV *tmp;
SV **oldsp = SP;
if (SP - MARK > 1)
do_join(TARG, &sv_no, MARK, SP);
else
- sv_setsv(TARG, *SP);
+ sv_setsv(TARG, (SP > MARK) ? *SP : GvSV(defgv));
up = SvPV_force(TARG, len);
if (len > 1) {
down = SvPVX(TARG) + len - 1;
}
static SV *
-mul128(sv, m)
- SV *sv;
- U8 m;
+mul128(SV *sv, U8 m)
{
STRLEN len;
char *s = SvPV(sv, len);
U32 i = 0;
if (!strnEQ(s, "0000", 4)) { /* need to grow sv */
- SV *new = newSVpv("0000000000", 10);
+ SV *New = newSVpv("0000000000", 10);
- sv_catsv(new, sv);
+ sv_catsv(New, sv);
SvREFCNT_dec(sv); /* free old sv */
- sv = new;
+ sv = New;
s = SvPV(sv, len);
}
t = s + len - 1;
PP(pp_unpack)
{
- dSP;
+ djSP;
dPOPPOPssrl;
SV **oldsp = sp;
+ I32 gimme = GIMME_V;
SV *sv;
STRLEN llen;
STRLEN rlen;
register U32 culong;
double cdouble;
static char* bitcount = 0;
+ int commas = 0;
- if (GIMME != G_ARRAY) { /* arrange to do first one only */
+ if (gimme != G_ARRAY) { /* arrange to do first one only */
/*SUPPRESS 530*/
for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ;
if (strchr("aAbBhHP", *patend) || *pat == '%') {
}
while (pat < patend) {
reparse:
- datumtype = *pat++;
+ datumtype = *pat++ & 0xFF;
+ if (isSPACE(datumtype))
+ continue;
if (pat >= patend)
len = 1;
else if (*pat == '*') {
len = (datumtype != '@');
switch(datumtype) {
default:
+ croak("Invalid type in unpack: '%c'", (int)datumtype);
+ case ',': /* grandfather in commas but with a warning */
+ if (commas++ == 0 && dowarn)
+ warn("Invalid type in unpack: '%c'", (int)datumtype);
break;
case '%':
if (len == 1 && pat[-1] != '1')
if (aint >= 128) /* fake up signed chars */
aint -= 256;
sv = NEWSV(36, 0);
- sv_setiv(sv, (I32)aint);
+ sv_setiv(sv, (IV)aint);
PUSHs(sv_2mortal(sv));
}
}
while (len-- > 0) {
auint = *s++ & 255;
sv = NEWSV(37, 0);
- sv_setiv(sv, (I32)auint);
+ sv_setiv(sv, (IV)auint);
PUSHs(sv_2mortal(sv));
}
}
break;
case 's':
- along = (strend - s) / sizeof(I16);
+ along = (strend - s) / SIZE16;
if (len > along)
len = along;
if (checksum) {
while (len-- > 0) {
- Copy(s, &ashort, 1, I16);
- s += sizeof(I16);
+ COPY16(s, &ashort);
+ s += SIZE16;
culong += ashort;
}
}
EXTEND(SP, len);
EXTEND_MORTAL(len);
while (len-- > 0) {
- Copy(s, &ashort, 1, I16);
- s += sizeof(I16);
+ COPY16(s, &ashort);
+ s += SIZE16;
sv = NEWSV(38, 0);
- sv_setiv(sv, (I32)ashort);
+ sv_setiv(sv, (IV)ashort);
PUSHs(sv_2mortal(sv));
}
}
case 'v':
case 'n':
case 'S':
- along = (strend - s) / sizeof(U16);
+ along = (strend - s) / SIZE16;
if (len > along)
len = along;
if (checksum) {
while (len-- > 0) {
- Copy(s, &aushort, 1, U16);
- s += sizeof(U16);
+ COPY16(s, &aushort);
+ s += SIZE16;
#ifdef HAS_NTOHS
if (datumtype == 'n')
aushort = ntohs(aushort);
EXTEND(SP, len);
EXTEND_MORTAL(len);
while (len-- > 0) {
- Copy(s, &aushort, 1, U16);
- s += sizeof(U16);
+ COPY16(s, &aushort);
+ s += SIZE16;
sv = NEWSV(39, 0);
#ifdef HAS_NTOHS
if (datumtype == 'n')
if (datumtype == 'v')
aushort = vtohs(aushort);
#endif
- sv_setiv(sv, (I32)aushort);
+ sv_setiv(sv, (IV)aushort);
PUSHs(sv_2mortal(sv));
}
}
Copy(s, &aint, 1, int);
s += sizeof(int);
sv = NEWSV(40, 0);
- sv_setiv(sv, (I32)aint);
+ sv_setiv(sv, (IV)aint);
PUSHs(sv_2mortal(sv));
}
}
Copy(s, &auint, 1, unsigned int);
s += sizeof(unsigned int);
sv = NEWSV(41, 0);
- if (auint <= I32_MAX)
- sv_setiv(sv, (I32)auint);
- else
- sv_setnv(sv, (double)auint);
+ sv_setuv(sv, (UV)auint);
PUSHs(sv_2mortal(sv));
}
}
break;
case 'l':
- along = (strend - s) / sizeof(I32);
+ along = (strend - s) / SIZE32;
if (len > along)
len = along;
if (checksum) {
while (len-- > 0) {
- Copy(s, &along, 1, I32);
- s += sizeof(I32);
+ COPY32(s, &along);
+ s += SIZE32;
if (checksum > 32)
cdouble += (double)along;
else
EXTEND(SP, len);
EXTEND_MORTAL(len);
while (len-- > 0) {
- Copy(s, &along, 1, I32);
- s += sizeof(I32);
+ COPY32(s, &along);
+ s += SIZE32;
sv = NEWSV(42, 0);
- sv_setiv(sv, (I32)along);
+ sv_setiv(sv, (IV)along);
PUSHs(sv_2mortal(sv));
}
}
case 'V':
case 'N':
case 'L':
- along = (strend - s) / sizeof(U32);
+ along = (strend - s) / SIZE32;
if (len > along)
len = along;
if (checksum) {
while (len-- > 0) {
- Copy(s, &aulong, 1, U32);
- s += sizeof(U32);
+ COPY32(s, &aulong);
+ s += SIZE32;
#ifdef HAS_NTOHL
if (datumtype == 'N')
aulong = ntohl(aulong);
EXTEND(SP, len);
EXTEND_MORTAL(len);
while (len-- > 0) {
- Copy(s, &aulong, 1, U32);
- s += sizeof(U32);
- sv = NEWSV(43, 0);
+ COPY32(s, &aulong);
+ s += SIZE32;
#ifdef HAS_NTOHL
if (datumtype == 'N')
aulong = ntohl(aulong);
if (datumtype == 'V')
aulong = vtohl(aulong);
#endif
- sv_setnv(sv, (double)aulong);
+ sv = NEWSV(43, 0);
+ sv_setuv(sv, (UV)aulong);
PUSHs(sv_2mortal(sv));
}
}
auv = 0;
}
else if (++bytes >= sizeof(UV)) { /* promote to string */
- char decn[sizeof(UV) * 3 + 1];
char *t;
- (void) sprintf(decn, "%0*ld", sizeof(decn) - 1, auv);
- sv = newSVpv(decn, 0);
+ sv = newSVpvf("%.*Vu", (int)TYPE_DIGITS(UV), auv);
while (s < strend) {
sv = mul128(sv, *s & 0x7f);
if (!(*s++ & 0x80)) {
s += sizeof(Quad_t);
}
sv = NEWSV(42, 0);
- sv_setiv(sv, (IV)aquad);
+ if (aquad >= IV_MIN && aquad <= IV_MAX)
+ sv_setiv(sv, (IV)aquad);
+ else
+ sv_setnv(sv, (double)aquad);
PUSHs(sv_2mortal(sv));
}
break;
s += sizeof(unsigned Quad_t);
}
sv = NEWSV(43, 0);
- sv_setiv(sv, (IV)auquad);
+ if (aquad <= UV_MAX)
+ sv_setuv(sv, (UV)auquad);
+ else
+ sv_setnv(sv, (double)auquad);
PUSHs(sv_2mortal(sv));
}
break;
d = (*s++ - ' ') & 077;
else
d = 0;
- hunk[0] = a << 2 | b >> 4;
- hunk[1] = b << 4 | c >> 2;
- hunk[2] = c << 6 | d;
- sv_catpvn(sv, hunk, len > 3 ? 3 : len);
+ hunk[0] = (a << 2) | (b >> 4);
+ hunk[1] = (b << 4) | (c >> 2);
+ hunk[2] = (c << 6) | d;
+ sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
len -= 3;
}
if (*s == '\n')
}
else {
if (checksum < 32) {
- along = (1 << checksum) - 1;
- culong &= (U32)along;
+ aulong = (1 << checksum) - 1;
+ culong &= aulong;
}
- sv_setnv(sv, (double)culong);
+ sv_setuv(sv, (UV)culong);
}
XPUSHs(sv_2mortal(sv));
checksum = 0;
}
}
- if (sp == oldsp && GIMME != G_ARRAY)
+ if (sp == oldsp && gimme == G_SCALAR)
PUSHs(&sv_undef);
RETURN;
}
static void
-doencodes(sv, s, len)
-register SV *sv;
-register char *s;
-register I32 len;
+doencodes(register SV *sv, register char *s, register I32 len)
{
char hunk[5];
hunk[4] = '\0';
while (len > 0) {
hunk[0] = ' ' + (077 & (*s >> 2));
- hunk[1] = ' ' + (077 & ((*s << 4) & 060 | (s[1] >> 4) & 017));
- hunk[2] = ' ' + (077 & ((s[1] << 2) & 074 | (s[2] >> 6) & 03));
+ hunk[1] = ' ' + (077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)));
+ hunk[2] = ' ' + (077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)));
hunk[3] = ' ' + (077 & (s[2] & 077));
sv_catpvn(sv, hunk, 4);
s += 3;
}
static SV *
-is_an_int(s, l)
- char *s;
- STRLEN l;
+is_an_int(char *s, STRLEN l)
{
SV *result = newSVpv("", l);
char *result_c = SvPV(result, na); /* convenience */
}
static int
-div128(pnum, done)
- SV *pnum; /* must be '\0' terminated */
- bool *done;
+div128(SV *pnum, char *done)
+ /* must be '\0' terminated */
+
{
STRLEN len;
char *s = SvPV(pnum, len);
PP(pp_pack)
{
- dSP; dMARK; dORIGMARK; dTARGET;
+ djSP; dMARK; dORIGMARK; dTARGET;
register SV *cat = TARG;
register I32 items;
STRLEN fromlen;
char *aptr;
float afloat;
double adouble;
+ int commas = 0;
items = SP - MARK;
MARK++;
sv_setpvn(cat, "", 0);
while (pat < patend) {
#define NEXTFROM (items-- > 0 ? *MARK++ : &sv_no)
- datumtype = *pat++;
+ datumtype = *pat++ & 0xFF;
+ if (isSPACE(datumtype))
+ continue;
if (*pat == '*') {
len = strchr("@Xxu", datumtype) ? 0 : items;
pat++;
len = 1;
switch(datumtype) {
default:
+ croak("Invalid type in pack: '%c'", (int)datumtype);
+ case ',': /* grandfather in commas but with a warning */
+ if (commas++ == 0 && dowarn)
+ warn("Invalid type in pack: '%c'", (int)datumtype);
break;
case '%':
DIE("%% may only be used in unpack");
#ifdef HAS_HTONS
ashort = htons(ashort);
#endif
- sv_catpvn(cat, (char*)&ashort, sizeof(I16));
+ CAT16(cat, &ashort);
}
break;
case 'v':
#ifdef HAS_HTOVS
ashort = htovs(ashort);
#endif
- sv_catpvn(cat, (char*)&ashort, sizeof(I16));
+ CAT16(cat, &ashort);
}
break;
case 'S':
while (len-- > 0) {
fromstr = NEXTFROM;
ashort = (I16)SvIV(fromstr);
- sv_catpvn(cat, (char*)&ashort, sizeof(I16));
+ CAT16(cat, &ashort);
}
break;
case 'I':
while (len-- > 0) {
fromstr = NEXTFROM;
- auint = U_I(SvNV(fromstr));
+ auint = SvUV(fromstr);
sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
}
break;
if (adouble < 0)
croak("Cannot compress negative numbers");
- if (adouble <= UV_MAX) {
+ if (
+#ifdef BW_BITS
+ adouble <= BW_MASK
+#else
+#ifdef CXUX_BROKEN_CONSTANT_CONVERT
+ adouble <= UV_MAX_cxux
+#else
+ adouble <= UV_MAX
+#endif
+#endif
+ )
+ {
char buf[1 + sizeof(UV)];
char *in = buf + sizeof(buf);
UV auv = U_V(adouble);;
case 'N':
while (len-- > 0) {
fromstr = NEXTFROM;
- aulong = U_L(SvNV(fromstr));
+ aulong = SvUV(fromstr);
#ifdef HAS_HTONL
aulong = htonl(aulong);
#endif
- sv_catpvn(cat, (char*)&aulong, sizeof(U32));
+ CAT32(cat, &aulong);
}
break;
case 'V':
while (len-- > 0) {
fromstr = NEXTFROM;
- aulong = U_L(SvNV(fromstr));
+ aulong = SvUV(fromstr);
#ifdef HAS_HTOVL
aulong = htovl(aulong);
#endif
- sv_catpvn(cat, (char*)&aulong, sizeof(U32));
+ CAT32(cat, &aulong);
}
break;
case 'L':
while (len-- > 0) {
fromstr = NEXTFROM;
- aulong = U_L(SvNV(fromstr));
- sv_catpvn(cat, (char*)&aulong, sizeof(U32));
+ aulong = SvUV(fromstr);
+ CAT32(cat, &aulong);
}
break;
case 'l':
while (len-- > 0) {
fromstr = NEXTFROM;
along = SvIV(fromstr);
- sv_catpvn(cat, (char*)&along, sizeof(I32));
+ CAT32(cat, &along);
}
break;
#ifdef HAS_QUAD
case 'p':
while (len-- > 0) {
fromstr = NEXTFROM;
- aptr = SvPV_force(fromstr, na); /* XXX Error if TEMP? */
+ if (fromstr == &sv_undef)
+ aptr = NULL;
+ else {
+ /* XXX better yet, could spirit away the string to
+ * a safe spot and hang on to it until the result
+ * of pack() (and all copies of the result) are
+ * gone.
+ */
+ if (dowarn && (SvTEMP(fromstr) || SvPADTMP(fromstr)))
+ warn("Attempt to pack pointer to temporary value");
+ if (SvPOK(fromstr) || SvNIOK(fromstr))
+ aptr = SvPV(fromstr,na);
+ else
+ aptr = SvPV_force(fromstr,na);
+ }
sv_catpvn(cat, (char*)&aptr, sizeof(char*));
}
break;
PP(pp_split)
{
- dSP; dTARG;
+ djSP; dTARG;
AV *ary;
register I32 limit = POPi; /* note, negative is forever */
SV *sv = POPs;
I32 realarray = 0;
I32 base;
AV *oldstack = curstack;
- I32 gimme = GIMME;
+ I32 gimme = GIMME_V;
I32 oldsave = savestack_ix;
#ifdef DEBUGGING
if (pm->op_pmreplroot)
ary = GvAVn((GV*)pm->op_pmreplroot);
else if (gimme != G_ARRAY)
+#ifdef USE_THREADS
+ ary = (AV*)curpad[0];
+#else
ary = GvAVn(defgv);
+#endif /* USE_THREADS */
else
ary = Nullav;
if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
}
if (realarray) {
SWITCHSTACK(ary, oldstack);
+ if (SvSMAGICAL(ary)) {
+ PUTBACK;
+ mg_set((SV*)ary);
+ SPAGAIN;
+ }
if (gimme == G_ARRAY) {
EXTEND(SP, iters);
Copy(AvARRAY(ary), SP + 1, iters, SV*);
RETPUSHUNDEF;
}
+#ifdef USE_THREADS
+void
+unlock_condpair(void *svv)
+{
+ dTHR;
+ MAGIC *mg = mg_find((SV*)svv, 'm');
+
+ if (!mg)
+ croak("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");
+ MgOWNER(mg) = 0;
+ COND_SIGNAL(MgOWNERCONDP(mg));
+ DEBUG_L(PerlIO_printf(PerlIO_stderr(), "0x%lx: unlock 0x%lx\n",
+ (unsigned long)thr, (unsigned long)svv);)
+ MUTEX_UNLOCK(MgMUTEXP(mg));
+}
+#endif /* USE_THREADS */
+
+PP(pp_lock)
+{
+ djSP;
+ dTOPss;
+ SV *retsv = sv;
+#ifdef USE_THREADS
+ MAGIC *mg;
+
+ if (SvROK(sv))
+ sv = SvRV(sv);
+
+ mg = condpair_magic(sv);
+ MUTEX_LOCK(MgMUTEXP(mg));
+ if (MgOWNER(mg) == thr)
+ MUTEX_UNLOCK(MgMUTEXP(mg));
+ else {
+ while (MgOWNER(mg))
+ COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
+ MgOWNER(mg) = thr;
+ DEBUG_L(PerlIO_printf(PerlIO_stderr(), "0x%lx: pp_lock lock 0x%lx\n",
+ (unsigned long)thr, (unsigned long)sv);)
+ MUTEX_UNLOCK(MgMUTEXP(mg));
+ SvREFCNT_inc(sv); /* keep alive until magic_mutexfree */
+ save_destructor(unlock_condpair, sv);
+ }
+#endif /* USE_THREADS */
+ if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
+ || SvTYPE(retsv) == SVt_PVCV) {
+ retsv = refto(retsv);
+ }
+ SETs(retsv);
+ RETURN;
+}
+
+PP(pp_specific)
+{
+#ifdef USE_THREADS
+ djSP;
+ SV **svp = av_fetch(thr->magicals, op->op_targ, FALSE);
+ if (!svp)
+ croak("panic: pp_specific");
+ EXTEND(sp, 1);
+ if (op->op_private & OPpLVAL_INTRO)
+ PUSHs(save_svref(svp));
+ else
+ PUSHs(*svp);
+#else
+ DIE("tried to access thread-specific data in non-threaded perl");
+#endif /* USE_THREADS */
+ RETURN;
+}
+
+
projects / p5sagit/p5-mst-13.2.git / blobdiff