/* 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.
#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
+
#if BYTEORDER > 0xFFFF && defined(_CRAY) && !defined(_CRAYMPP)
# if BYTEORDER == 0x12345678
# define OFF16(p) (char*)(p)
# 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 COPYNN(s,p,n) (*(p) = 0, Copy(s, (char *)(p), n, 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 COPYNN(s,p,n) Copy(s, (char *)(p), n, char)
# define CAT16(sv,p) sv_catpvn(sv, (char*)(p), SIZE16)
# define CAT32(sv,p) sv_catpvn(sv, (char*)(p), SIZE32)
#endif
static U32 seed _((void));
#endif
-static bool srand_called = FALSE;
-
/* variations on pp_null */
#ifdef I_UNISTD
PP(pp_rv2gv)
{
- djSP; dTOPss;
+ djSP; dTOPss;
if (SvROK(sv)) {
wasref:
+ tryAMAGICunDEREF(to_gv);
+
sv = SvRV(sv);
if (SvTYPE(sv) == SVt_PVIO) {
GV *gv = (GV*) sv_newmortal();
GvIOp(gv) = (IO *)sv;
(void)SvREFCNT_inc(sv);
sv = (SV*) gv;
- } else if (SvTYPE(sv) != SVt_PVGV)
+ }
+ else if (SvTYPE(sv) != SVt_PVGV)
DIE("Not a GLOB reference");
}
else {
if (SvTYPE(sv) != SVt_PVGV) {
char *sym;
+ STRLEN n_a;
if (SvGMAGICAL(sv)) {
mg_get(sv);
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(no_usym, "a symbol");
- if (PL_dowarn)
- warn(warn_uninit);
+ DIE(PL_no_usym, "a symbol");
+ if (ckWARN(WARN_UNINITIALIZED))
+ warner(WARN_UNINITIALIZED, PL_warn_uninit);
RETSETUNDEF;
}
- sym = SvPV(sv, PL_na);
- if (PL_op->op_private & HINT_STRICT_REFS)
- DIE(no_symref, sym, "a symbol");
- sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV);
+ sym = SvPV(sv, n_a);
+ if ((PL_op->op_flags & OPf_SPECIAL) &&
+ !(PL_op->op_flags & OPf_MOD))
+ {
+ sv = (SV*)gv_fetchpv(sym, FALSE, SVt_PVGV);
+ if (!sv)
+ RETSETUNDEF;
+ }
+ else {
+ if (PL_op->op_private & HINT_STRICT_REFS)
+ DIE(PL_no_symref, sym, "a symbol");
+ sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV);
+ }
}
}
if (PL_op->op_private & OPpLVAL_INTRO)
if (SvROK(sv)) {
wasref:
+ tryAMAGICunDEREF(to_sv);
+
sv = SvRV(sv);
switch (SvTYPE(sv)) {
case SVt_PVAV:
else {
GV *gv = (GV*)sv;
char *sym;
+ STRLEN n_a;
if (SvTYPE(gv) != SVt_PVGV) {
if (SvGMAGICAL(sv)) {
if (!SvOK(sv)) {
if (PL_op->op_flags & OPf_REF ||
PL_op->op_private & HINT_STRICT_REFS)
- DIE(no_usym, "a SCALAR");
- if (PL_dowarn)
- warn(warn_uninit);
+ DIE(PL_no_usym, "a SCALAR");
+ if (ckWARN(WARN_UNINITIALIZED))
+ warner(WARN_UNINITIALIZED, PL_warn_uninit);
RETSETUNDEF;
}
- sym = SvPV(sv, PL_na);
- if (PL_op->op_private & HINT_STRICT_REFS)
- DIE(no_symref, sym, "a SCALAR");
- gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV);
+ sym = SvPV(sv, n_a);
+ if ((PL_op->op_flags & OPf_SPECIAL) &&
+ !(PL_op->op_flags & OPf_MOD))
+ {
+ gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PV);
+ if (!gv)
+ RETSETUNDEF;
+ }
+ else {
+ if (PL_op->op_private & HINT_STRICT_REFS)
+ DIE(PL_no_symref, sym, "a SCALAR");
+ gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV);
+ }
}
sv = GvSV(gv);
}
if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
mg = mg_find(sv, 'g');
if (mg && mg->mg_len >= 0) {
- PUSHi(mg->mg_len + PL_curcop->cop_arybase);
+ I32 i = mg->mg_len;
+ if (IN_UTF8)
+ sv_pos_b2u(sv, &i);
+ PUSHi(i + PL_curcop->cop_arybase);
RETURN;
}
}
char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
while (i < MAXO) { /* The slow way. */
- if (strEQ(s + 6, op_name[i]) || strEQ(s + 6, op_desc[i]))
+ if (strEQ(s + 6, PL_op_name[i])
+ || strEQ(s + 6, PL_op_desc[i]))
+ {
goto found;
+ }
i++;
}
goto nonesuch; /* Should not happen... */
found:
- oa = opargs[i] >> OASHIFT;
+ oa = PL_opargs[i] >> OASHIFT;
while (oa) {
if (oa & OA_OPTIONAL) {
seen_question = 1;
str[n++] = ';';
- } else if (seen_question)
+ }
+ else if (seen_question)
goto set; /* XXXX system, exec */
if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
&& (oa & (OA_OPTIONAL - 1)) <= OA_HVREF) {
oa = oa >> 4;
}
str[n++] = '\0';
- ret = sv_2mortal(newSVpv(str, n - 1));
- } else if (code) /* Non-Overridable */
+ 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);
+ croak("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;
vivify_defelem(sv);
if (!(sv = LvTARG(sv)))
sv = &PL_sv_undef;
+ else
+ (void)SvREFCNT_inc(sv);
}
else if (SvPADTMP(sv))
sv = newSVsv(sv);
SV *ssv = POPs;
STRLEN len;
char *ptr = SvPV(ssv,len);
- if (PL_dowarn && len == 0)
- warn("Explicit blessing to '' (assuming package main)");
+ if (ckWARN(WARN_UNSAFE) && len == 0)
+ warner(WARN_UNSAFE,
+ "Explicit blessing to '' (assuming package main)");
stash = gv_stashpvn(ptr, len, TRUE);
}
SV *tmpRef;
char *elem;
djSP;
-
+ STRLEN n_a;
+
sv = POPs;
- elem = SvPV(sv, PL_na);
+ elem = SvPV(sv, n_a);
gv = (GV*)POPs;
tmpRef = Nullsv;
sv = Nullsv;
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;
EXTEND(SP,1);
}
TARG = sv_newmortal();
- PUSHi(do_trans(sv, PL_op));
+ PUSHi(do_trans(sv));
RETURN;
}
RETPUSHNO;
switch (SvTYPE(sv)) {
case SVt_PVAV:
- if (AvMAX(sv) >= 0 || SvGMAGICAL(sv))
+ if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv,'P')))
RETPUSHYES;
break;
case SVt_PVHV:
- if (HvARRAY(sv) || SvGMAGICAL(sv))
+ if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv,'P')))
RETPUSHYES;
break;
case SVt_PVCV:
if (!sv)
RETPUSHUNDEF;
- if (SvTHINKFIRST(sv)) {
- if (SvREADONLY(sv))
- RETPUSHUNDEF;
- if (SvROK(sv))
- sv_unref(sv);
- }
+ if (SvTHINKFIRST(sv))
+ sv_force_normal(sv);
switch (SvTYPE(sv)) {
case SVt_NULL:
hv_undef((HV*)sv);
break;
case SVt_PVCV:
- if (PL_dowarn && cv_const_sv((CV*)sv))
- warn("Constant subroutine %s undefined",
+ if (ckWARN(WARN_UNSAFE) && cv_const_sv((CV*)sv))
+ warner(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(no_modify);
- if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
+ croak(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(no_modify);
+ croak(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(no_modify);
+ croak(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);
(double)I_V(right) == right &&
(k = I_V(left)/I_V(right))*I_V(right) == I_V(left)) {
value = k;
- } else {
+ }
+ else {
value = left / right;
}
}
{
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");
+ if (use_double) {
+ double dans;
- 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 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("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("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) {
sv_setsv(TARG, sv);
*SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
}
+ else if (IN_UTF8 && *(U8*)s >= 0xc0 && isIDFIRST_utf8((U8*)s)) {
+ sv_setpvn(TARG, "-", 1);
+ sv_catsv(TARG, sv);
+ }
else
sv_setnv(TARG, -SvNV(sv));
SETTARG;
PP(pp_not)
{
-#ifdef OVERLOAD
djSP; tryAMAGICunSET(not);
-#endif /* OVERLOAD */
*PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
return NORMAL;
}
compatibility by calling rand() but allow the user to override it.
See INSTALL for details. --Andy Dougherty 15 July 1998
*/
-#ifndef my_rand
-# define my_rand rand
-#endif
-#ifndef my_srand
-# define my_srand srand
+/* Now it's after 5.005, and Configure supports drand48() and random(),
+ in addition to rand(). So the overrides should not be needed any more.
+ --Jarkko Hietaniemi 27 September 1998
+ */
+
+#ifndef HAS_DRAND48_PROTO
+extern double drand48 _((void));
#endif
PP(pp_rand)
value = POPn;
if (value == 0.0)
value = 1.0;
- if (!srand_called) {
- (void)my_srand((unsigned)seed());
- srand_called = TRUE;
+ if (!PL_srand_called) {
+ (void)seedDrand01((Rand_seed_t)seed());
+ PL_srand_called = TRUE;
}
-#if RANDBITS == 31
- value = my_rand() * value / 2147483648.0;
-#else
-#if RANDBITS == 16
- value = my_rand() * value / 65536.0;
-#else
-#if RANDBITS == 15
- value = my_rand() * value / 32768.0;
-#else
- value = my_rand() * value / (double)(((unsigned long)1) << RANDBITS);
-#endif
-#endif
-#endif
+ value *= Drand01();
XPUSHn(value);
RETURN;
}
anum = seed();
else
anum = POPu;
- (void)my_srand((unsigned)anum);
- srand_called = TRUE;
+ (void)seedDrand01((Rand_seed_t)anum);
+ PL_srand_called = TRUE;
EXTEND(SP, 1);
RETPUSHYES;
}
* 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.
+ * 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 anyting here,
+ * 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.
#define SEED_C5 26107
dTHR;
+#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
- 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);
u = (U32)SEED_C1 * when;
# endif
djSP; dTARGET;
char *tmps;
I32 argtype;
+ STRLEN n_a;
- tmps = POPp;
+ tmps = POPpx;
XPUSHu(scan_hex(tmps, 99, &argtype));
RETURN;
}
UV value;
I32 argtype;
char *tmps;
+ STRLEN n_a;
- tmps = POPp;
+ tmps = POPpx;
while (*tmps && isSPACE(*tmps))
tmps++;
if (*tmps == '0')
tmps++;
if (*tmps == 'x')
value = scan_hex(++tmps, 99, &argtype);
+ else if (*tmps == 'b')
+ value = scan_bin(++tmps, 99, &argtype);
else
value = scan_oct(tmps, 99, &argtype);
XPUSHu(value);
PP(pp_length)
{
djSP; dTARGET;
+
+ if (IN_UTF8) {
+ SETi( sv_len_utf8(TOPs) );
+ RETURN;
+ }
+
SETi( sv_len(TOPs) );
RETURN;
}
SV *sv;
I32 len;
STRLEN curlen;
+ STRLEN utfcurlen;
I32 pos;
I32 rem;
I32 fail;
sv = POPs;
PUTBACK;
tmps = SvPV(sv, curlen);
+ if (IN_UTF8) {
+ utfcurlen = sv_len_utf8(sv);
+ if (utfcurlen == curlen)
+ utfcurlen = 0;
+ else
+ curlen = utfcurlen;
+ }
+ else
+ utfcurlen = 0;
+
if (pos >= arybase) {
pos -= arybase;
rem = curlen-pos;
rem -= pos;
}
if (fail < 0) {
- if (PL_dowarn || lvalue || repl)
- warn("substr outside of string");
+ if (ckWARN(WARN_SUBSTR) || lvalue || repl)
+ warner(WARN_SUBSTR, "substr outside of string");
RETPUSHUNDEF;
}
else {
+ if (utfcurlen)
+ sv_pos_u2b(sv, &pos, &rem);
tmps += pos;
sv_setpvn(TARG, tmps, rem);
if (lvalue) { /* it's an lvalue! */
if (!SvGMAGICAL(sv)) {
if (SvROK(sv)) {
- SvPV_force(sv,PL_na);
- if (PL_dowarn)
- warn("Attempt to use reference as lvalue in substr");
+ STRLEN n_a;
+ SvPV_force(sv,n_a);
+ if (ckWARN(WARN_SUBSTR))
+ warner(WARN_SUBSTR,
+ "Attempt to use reference as lvalue in substr");
}
if (SvOK(sv)) /* is it defined ? */
(void)SvPOK_only(sv);
little = POPs;
big = POPs;
tmps = SvPV(big, biglen);
+ if (IN_UTF8 && offset > 0)
+ sv_pos_u2b(big, &offset, 0);
if (offset < 0)
offset = 0;
else if (offset > biglen)
offset = biglen;
if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
(unsigned char*)tmps + biglen, little, 0)))
- retval = -1 + arybase;
+ retval = -1;
else
- retval = tmps2 - tmps + arybase;
- PUSHi(retval);
+ retval = tmps2 - tmps;
+ if (IN_UTF8 && retval > 0)
+ sv_pos_b2u(big, &retval);
+ PUSHi(retval + arybase);
RETURN;
}
SV *little;
STRLEN blen;
STRLEN llen;
- SV *offstr;
I32 offset;
I32 retval;
char *tmps;
I32 arybase = PL_curcop->cop_arybase;
if (MAXARG >= 3)
- offstr = POPs;
+ offset = POPi;
little = POPs;
big = POPs;
tmps2 = SvPV(little, llen);
tmps = SvPV(big, blen);
if (MAXARG < 3)
offset = blen;
- else
- offset = SvIV(offstr) - arybase + llen;
+ else {
+ if (IN_UTF8 && offset > 0)
+ sv_pos_u2b(big, &offset, 0);
+ offset = offset - arybase + llen;
+ }
if (offset < 0)
offset = 0;
else if (offset > blen)
offset = blen;
if (!(tmps2 = rninstr(tmps, tmps + offset,
tmps2, tmps2 + llen)))
- retval = -1 + arybase;
+ retval = -1;
else
- retval = tmps2 - tmps + arybase;
- PUSHi(retval);
+ retval = tmps2 - tmps;
+ if (IN_UTF8 && retval > 0)
+ sv_pos_b2u(big, &retval);
+ PUSHi(retval + arybase);
RETURN;
}
PP(pp_ord)
{
djSP; dTARGET;
- I32 value;
- char *tmps;
+ UV value;
+ STRLEN n_a;
+ U8 *tmps = (U8*)POPpx;
+ I32 retlen;
-#ifndef I286
- tmps = POPp;
- value = (I32) (*tmps & 255);
-#else
- I32 anum;
- tmps = POPp;
- anum = (I32) *tmps;
- value = (I32) (anum & 255);
-#endif
- XPUSHi(value);
+ if (IN_UTF8 && (*tmps & 0x80))
+ value = utf8_to_uv(tmps, &retlen);
+ else
+ value = (UV)(*tmps & 255);
+ XPUSHu(value);
RETURN;
}
{
djSP; dTARGET;
char *tmps;
+ U32 value = POPu;
(void)SvUPGRADE(TARG,SVt_PV);
+
+ if (IN_UTF8 && value >= 128) {
+ SvGROW(TARG,8);
+ tmps = SvPVX(TARG);
+ tmps = (char*)uv_to_utf8((U8*)tmps, (UV)value);
+ SvCUR_set(TARG, tmps - SvPVX(TARG));
+ *tmps = '\0';
+ (void)SvPOK_only(TARG);
+ XPUSHs(TARG);
+ RETURN;
+ }
+
SvGROW(TARG,2);
SvCUR_set(TARG, 1);
tmps = SvPVX(TARG);
- *tmps++ = POPi;
+ *tmps++ = value;
*tmps = '\0';
(void)SvPOK_only(TARG);
XPUSHs(TARG);
PP(pp_crypt)
{
djSP; dTARGET; dPOPTOPssrl;
+ STRLEN n_a;
#ifdef HAS_CRYPT
- char *tmps = SvPV(left, PL_na);
+ char *tmps = SvPV(left, n_a);
#ifdef FCRYPT
- sv_setpv(TARG, fcrypt(tmps, SvPV(right, PL_na)));
+ sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
#else
- sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, PL_na)));
+ sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
#endif
#else
DIE(
{
djSP;
SV *sv = TOPs;
- register char *s;
+ register U8 *s;
+ STRLEN slen;
+
+ if (IN_UTF8 && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
+ I32 ulen;
+ U8 tmpbuf[10];
+ U8 *tend;
+ UV uv = utf8_to_uv(s, &ulen);
+
+ if (PL_op->op_private & OPpLOCALE) {
+ TAINT;
+ SvTAINTED_on(sv);
+ uv = toTITLE_LC_uni(uv);
+ }
+ else
+ uv = toTITLE_utf8(s);
+
+ tend = uv_to_utf8(tmpbuf, uv);
+
+ if (!SvPADTMP(sv) || tend - tmpbuf != ulen) {
+ dTARGET;
+ sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
+ sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
+ SETs(TARG);
+ }
+ else {
+ s = (U8*)SvPV_force(sv, slen);
+ Copy(tmpbuf, s, ulen, U8);
+ }
+ RETURN;
+ }
if (!SvPADTMP(sv)) {
dTARGET;
sv = TARG;
SETs(sv);
}
- s = SvPV_force(sv, PL_na);
+ s = (U8*)SvPV_force(sv, slen);
if (*s) {
if (PL_op->op_private & OPpLOCALE) {
TAINT;
{
djSP;
SV *sv = TOPs;
- register char *s;
+ register U8 *s;
+ STRLEN slen;
+
+ if (IN_UTF8 && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
+ I32 ulen;
+ U8 tmpbuf[10];
+ U8 *tend;
+ UV uv = utf8_to_uv(s, &ulen);
+
+ if (PL_op->op_private & OPpLOCALE) {
+ TAINT;
+ SvTAINTED_on(sv);
+ uv = toLOWER_LC_uni(uv);
+ }
+ else
+ uv = toLOWER_utf8(s);
+
+ tend = uv_to_utf8(tmpbuf, uv);
+
+ if (!SvPADTMP(sv) || tend - tmpbuf != ulen) {
+ dTARGET;
+ sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
+ sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
+ SETs(TARG);
+ }
+ else {
+ s = (U8*)SvPV_force(sv, slen);
+ Copy(tmpbuf, s, ulen, U8);
+ }
+ RETURN;
+ }
if (!SvPADTMP(sv)) {
dTARGET;
sv = TARG;
SETs(sv);
}
- s = SvPV_force(sv, PL_na);
+ s = (U8*)SvPV_force(sv, slen);
if (*s) {
if (PL_op->op_private & OPpLOCALE) {
TAINT;
{
djSP;
SV *sv = TOPs;
- register char *s;
+ register U8 *s;
STRLEN len;
+ if (IN_UTF8) {
+ dTARGET;
+ I32 ulen;
+ register U8 *d;
+ U8 *send;
+
+ s = (U8*)SvPV(sv,len);
+ 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 {
+ 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);
+ RETURN;
+ }
+
if (!SvPADTMP(sv)) {
dTARGET;
sv_setsv(TARG, sv);
SETs(sv);
}
- s = SvPV_force(sv, len);
+ s = (U8*)SvPV_force(sv, len);
if (len) {
- register char *send = s + len;
+ register U8 *send = s + len;
if (PL_op->op_private & OPpLOCALE) {
TAINT;
{
djSP;
SV *sv = TOPs;
- register char *s;
+ register U8 *s;
STRLEN len;
+ if (IN_UTF8) {
+ dTARGET;
+ I32 ulen;
+ register U8 *d;
+ U8 *send;
+
+ s = (U8*)SvPV(sv,len);
+ 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 {
+ 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);
+ RETURN;
+ }
+
if (!SvPADTMP(sv)) {
dTARGET;
sv_setsv(TARG, sv);
SETs(sv);
}
- s = SvPV_force(sv, len);
+ s = (U8*)SvPV_force(sv, len);
if (len) {
- register char *send = s + len;
+ register U8 *send = s + len;
if (PL_op->op_private & OPpLOCALE) {
TAINT;
(void)SvUPGRADE(TARG, SVt_PV);
SvGROW(TARG, (len * 2) + 1);
d = SvPVX(TARG);
- while (len--) {
- if (!isALNUM(*s))
- *d++ = '\\';
- *d++ = *s++;
+ if (IN_UTF8) {
+ while (len) {
+ if (*s & 0x80) {
+ STRLEN ulen = UTF8SKIP(s);
+ if (ulen > len)
+ ulen = len;
+ len -= ulen;
+ while (ulen--)
+ *d++ = *s++;
+ }
+ else {
+ if (!isALNUM(*s))
+ *d++ = '\\';
+ *d++ = *s++;
+ len--;
+ }
+ }
+ }
+ else {
+ while (len--) {
+ if (!isALNUM(*s))
+ *d++ = '\\';
+ *d++ = *s++;
+ }
}
*d = '\0';
SvCUR_set(TARG, d - SvPVX(TARG));
svp = av_fetch(av, elem, lval);
if (lval) {
if (!svp || *svp == &PL_sv_undef)
- DIE(no_aelem, elem);
+ DIE(PL_no_aelem, elem);
if (PL_op->op_private & OPpLVAL_INTRO)
save_aelem(av, elem, svp);
}
if (SvTYPE(hv) == SVt_PVHV) {
if (hv_exists_ent(hv, tmpsv, 0))
RETPUSHYES;
- } else if (SvTYPE(hv) == SVt_PVAV) {
+ }
+ else if (SvTYPE(hv) == SVt_PVAV) {
if (avhv_exists_ent((AV*)hv, tmpsv, 0))
RETPUSHYES;
- } else {
+ }
+ else {
DIE("Not a HASH reference");
}
RETPUSHNO;
if (realhv) {
HE *he = hv_fetch_ent(hv, keysv, lval, 0);
svp = he ? &HeVAL(he) : 0;
- } else {
+ }
+ else {
svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0);
}
if (lval) {
- if (!svp || *svp == &PL_sv_undef)
- DIE(no_helem, SvPV(keysv, PL_na));
+ if (!svp || *svp == &PL_sv_undef) {
+ STRLEN n_a;
+ DIE(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;
SV *val = NEWSV(46, 0);
if (MARK < SP)
sv_setsv(val, *++MARK);
- else if (PL_dowarn)
- warn("Odd number of elements in hash assignment");
+ else if (ckWARN(WARN_UNSAFE))
+ warner(WARN_UNSAFE, "Odd number of elements in hash assignment");
(void)hv_store_ent(hv,key,val,0);
}
SP = ORIGMARK;
SV **tmparyval = 0;
MAGIC *mg;
- if (SvRMAGICAL(ary) && (mg = mg_find((SV*)ary,'P'))) {
- *MARK-- = mg->mg_obj;
+ if (mg = SvTIED_mg((SV*)ary, 'P')) {
+ *MARK-- = SvTIED_obj((SV*)ary, mg);
PUSHMARK(MARK);
PUTBACK;
ENTER;
else
offset -= PL_curcop->cop_arybase;
if (offset < 0)
- DIE(no_aelem, i);
+ DIE(PL_no_aelem, i);
if (++MARK < SP) {
length = SvIVx(*MARK++);
if (length < 0) {
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 (newlen && !AvREAL(ary) && AvREIFY(ary))
+ av_reify(ary);
if (diff < 0) { /* shrinking the area */
if (newlen) {
register SV *sv = &PL_sv_undef;
MAGIC *mg;
- if (SvRMAGICAL(ary) && (mg = mg_find((SV*)ary,'P'))) {
- *MARK-- = mg->mg_obj;
+ if (mg = SvTIED_mg((SV*)ary, 'P')) {
+ *MARK-- = SvTIED_obj((SV*)ary, mg);
PUSHMARK(MARK);
PUTBACK;
ENTER;
register I32 i = 0;
MAGIC *mg;
- if (SvRMAGICAL(ary) && (mg = mg_find((SV*)ary,'P'))) {
- *MARK-- = mg->mg_obj;
+ if (mg = SvTIED_mg((SV*)ary, 'P')) {
+ *MARK-- = SvTIED_obj((SV*)ary, mg);
PUSHMARK(MARK);
PUTBACK;
ENTER;
sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
up = SvPV_force(TARG, len);
if (len > 1) {
+ if (IN_UTF8) { /* first reverse each character */
+ U8* s = (U8*)SvPVX(TARG);
+ U8* send = (U8*)(s + len);
+ while (s < send) {
+ if (*s < 0x80) {
+ s++;
+ continue;
+ }
+ else {
+ up = (char*)s;
+ s += UTF8SKIP(s);
+ down = (char*)(s - 1);
+ if (s > send || !((*down & 0xc0) == 0x80)) {
+ warn("Malformed UTF-8 character");
+ break;
+ }
+ while (down > up) {
+ tmp = *up;
+ *up++ = *down;
+ *down-- = tmp;
+ }
+ }
+ }
+ up = SvPVX(TARG);
+ }
down = SvPVX(TARG) + len - 1;
while (down > up) {
tmp = *up;
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 */
/* Explosives and implosives. */
-static const char uuemap[] =
- "`!\"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_";
-static char uudmap[256]; /* Initialised on first use */
#if 'I' == 73 && 'J' == 74
/* On an ASCII/ISO kind of system */
#define ISUUCHAR(ch) ((ch) >= ' ' && (ch) < 'a')
Some other sort of character set - use memchr() so we don't match
the null byte.
*/
-#define ISUUCHAR(ch) (memchr(uuemap, (ch), sizeof(uuemap)-1) || (ch) == ' ')
+#define ISUUCHAR(ch) (memchr(PL_uuemap, (ch), sizeof(PL_uuemap)-1) || (ch) == ' ')
#endif
PP(pp_unpack)
unsigned int auint;
U32 aulong;
#ifdef HAS_QUAD
- unsigned Quad_t auquad;
+ Uquad_t auquad;
#endif
char *aptr;
float afloat;
I32 checksum = 0;
register U32 culong;
double cdouble;
- static char* bitcount = 0;
int commas = 0;
+#ifdef PERL_NATINT_PACK
+ int natint; /* native integer */
+ int unatint; /* unsigned native integer */
+#endif
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 == '%') {
+ if (strchr("aAZbBhHP", *patend) || *pat == '%') {
patend++;
while (isDIGIT(*patend) || *patend == '*')
patend++;
while (pat < patend) {
reparse:
datumtype = *pat++ & 0xFF;
+#ifdef PERL_NATINT_PACK
+ natint = 0;
+#endif
if (isSPACE(datumtype))
continue;
+ if (*pat == '!') {
+ char *natstr = "sSiIlL";
+
+ if (strchr(natstr, datumtype)) {
+#ifdef PERL_NATINT_PACK
+ natint = 1;
+#endif
+ pat++;
+ }
+ else
+ croak("'!' allowed only after types %s", natstr);
+ }
if (pat >= patend)
len = 1;
else if (*pat == '*') {
default:
croak("Invalid type in unpack: '%c'", (int)datumtype);
case ',': /* grandfather in commas but with a warning */
- if (commas++ == 0 && PL_dowarn)
- warn("Invalid type in unpack: '%c'", (int)datumtype);
+ if (commas++ == 0 && ckWARN(WARN_UNSAFE))
+ warner(WARN_UNSAFE, "Invalid type in unpack: '%c'", (int)datumtype);
break;
case '%':
if (len == 1 && pat[-1] != '1')
s += len;
break;
case 'A':
+ case 'Z':
case 'a':
if (len > strend - s)
len = strend - s;
sv = NEWSV(35, len);
sv_setpvn(sv, s, len);
s += len;
- if (datumtype == 'A') {
+ if (datumtype == 'A' || datumtype == 'Z') {
aptr = s; /* borrow register */
- s = SvPVX(sv) + len - 1;
- while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
- s--;
- *++s = '\0';
+ if (datumtype == 'Z') { /* 'Z' strips stuff after first null */
+ s = SvPVX(sv);
+ while (*s)
+ s++;
+ }
+ else { /* 'A' strips both nulls and spaces */
+ s = SvPVX(sv) + len - 1;
+ while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
+ s--;
+ *++s = '\0';
+ }
SvCUR_set(sv, s - SvPVX(sv));
s = aptr; /* unborrow register */
}
if (pat[-1] == '*' || len > (strend - s) * 8)
len = (strend - s) * 8;
if (checksum) {
- if (!bitcount) {
- Newz(601, bitcount, 256, char);
+ if (!PL_bitcount) {
+ Newz(601, PL_bitcount, 256, char);
for (bits = 1; bits < 256; bits++) {
- if (bits & 1) bitcount[bits]++;
- if (bits & 2) bitcount[bits]++;
- if (bits & 4) bitcount[bits]++;
- if (bits & 8) bitcount[bits]++;
- if (bits & 16) bitcount[bits]++;
- if (bits & 32) bitcount[bits]++;
- if (bits & 64) bitcount[bits]++;
- if (bits & 128) bitcount[bits]++;
+ if (bits & 1) PL_bitcount[bits]++;
+ if (bits & 2) PL_bitcount[bits]++;
+ if (bits & 4) PL_bitcount[bits]++;
+ if (bits & 8) PL_bitcount[bits]++;
+ if (bits & 16) PL_bitcount[bits]++;
+ if (bits & 32) PL_bitcount[bits]++;
+ if (bits & 64) PL_bitcount[bits]++;
+ if (bits & 128) PL_bitcount[bits]++;
}
}
while (len >= 8) {
- culong += bitcount[*(unsigned char*)s++];
+ culong += PL_bitcount[*(unsigned char*)s++];
len -= 8;
}
if (len) {
}
}
break;
+ case 'U':
+ if (len > strend - s)
+ len = strend - s;
+ if (checksum) {
+ while (len-- > 0 && s < strend) {
+ auint = utf8_to_uv((U8*)s, &along);
+ s += along;
+ if (checksum > 32)
+ cdouble += (double)auint;
+ else
+ culong += auint;
+ }
+ }
+ else {
+ EXTEND(SP, len);
+ EXTEND_MORTAL(len);
+ while (len-- > 0 && s < strend) {
+ auint = utf8_to_uv((U8*)s, &along);
+ s += along;
+ sv = NEWSV(37, 0);
+ sv_setuv(sv, (UV)auint);
+ PUSHs(sv_2mortal(sv));
+ }
+ }
+ break;
case 's':
+#if SHORTSIZE == SIZE16
along = (strend - s) / SIZE16;
+#else
+ along = (strend - s) / (natint ? sizeof(short) : SIZE16);
+#endif
if (len > along)
len = along;
if (checksum) {
- while (len-- > 0) {
- COPY16(s, &ashort);
- s += SIZE16;
- culong += ashort;
+#if SHORTSIZE != SIZE16
+ if (natint) {
+ while (len-- > 0) {
+ COPYNN(s, &ashort, sizeof(short));
+ s += sizeof(short);
+ culong += ashort;
+
+ }
+ }
+ else
+#endif
+ {
+ while (len-- > 0) {
+ COPY16(s, &ashort);
+#if SHORTSIZE > SIZE16
+ if (ashort > 32767)
+ ashort -= 65536;
+#endif
+ s += SIZE16;
+ culong += ashort;
+ }
}
}
else {
EXTEND(SP, len);
EXTEND_MORTAL(len);
- while (len-- > 0) {
- COPY16(s, &ashort);
- s += SIZE16;
- sv = NEWSV(38, 0);
- sv_setiv(sv, (IV)ashort);
- PUSHs(sv_2mortal(sv));
+#if SHORTSIZE != SIZE16
+ if (natint) {
+ while (len-- > 0) {
+ COPYNN(s, &ashort, sizeof(short));
+ s += sizeof(short);
+ sv = NEWSV(38, 0);
+ sv_setiv(sv, (IV)ashort);
+ PUSHs(sv_2mortal(sv));
+ }
+ }
+ else
+#endif
+ {
+ while (len-- > 0) {
+ COPY16(s, &ashort);
+#if SHORTSIZE > SIZE16
+ if (ashort > 32767)
+ ashort -= 65536;
+#endif
+ s += SIZE16;
+ sv = NEWSV(38, 0);
+ sv_setiv(sv, (IV)ashort);
+ PUSHs(sv_2mortal(sv));
+ }
}
}
break;
case 'v':
case 'n':
case 'S':
+#if SHORTSIZE == SIZE16
along = (strend - s) / SIZE16;
+#else
+ unatint = natint && datumtype == 'S';
+ along = (strend - s) / (unatint ? sizeof(unsigned short) : SIZE16);
+#endif
if (len > along)
len = along;
if (checksum) {
- while (len-- > 0) {
- COPY16(s, &aushort);
- s += SIZE16;
+#if SHORTSIZE != SIZE16
+ if (unatint) {
+ while (len-- > 0) {
+ COPYNN(s, &aushort, sizeof(unsigned short));
+ s += sizeof(unsigned short);
+ culong += aushort;
+ }
+ }
+ else
+#endif
+ {
+ while (len-- > 0) {
+ COPY16(s, &aushort);
+ s += SIZE16;
#ifdef HAS_NTOHS
- if (datumtype == 'n')
- aushort = PerlSock_ntohs(aushort);
+ if (datumtype == 'n')
+ aushort = PerlSock_ntohs(aushort);
#endif
#ifdef HAS_VTOHS
- if (datumtype == 'v')
- aushort = vtohs(aushort);
+ if (datumtype == 'v')
+ aushort = vtohs(aushort);
#endif
- culong += aushort;
+ culong += aushort;
+ }
}
}
else {
EXTEND(SP, len);
EXTEND_MORTAL(len);
- while (len-- > 0) {
- COPY16(s, &aushort);
- s += SIZE16;
- sv = NEWSV(39, 0);
+#if SHORTSIZE != SIZE16
+ if (unatint) {
+ while (len-- > 0) {
+ COPYNN(s, &aushort, sizeof(unsigned short));
+ s += sizeof(unsigned short);
+ sv = NEWSV(39, 0);
+ sv_setiv(sv, (UV)aushort);
+ PUSHs(sv_2mortal(sv));
+ }
+ }
+ else
+#endif
+ {
+ while (len-- > 0) {
+ COPY16(s, &aushort);
+ s += SIZE16;
+ sv = NEWSV(39, 0);
#ifdef HAS_NTOHS
- if (datumtype == 'n')
- aushort = PerlSock_ntohs(aushort);
+ if (datumtype == 'n')
+ aushort = PerlSock_ntohs(aushort);
#endif
#ifdef HAS_VTOHS
- if (datumtype == 'v')
- aushort = vtohs(aushort);
+ if (datumtype == 'v')
+ aushort = vtohs(aushort);
#endif
- sv_setiv(sv, (IV)aushort);
- PUSHs(sv_2mortal(sv));
+ sv_setiv(sv, (UV)aushort);
+ PUSHs(sv_2mortal(sv));
+ }
}
}
break;
#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
Copy(s, &auint, 1, unsigned int);
s += sizeof(unsigned int);
sv = NEWSV(41, 0);
+#ifdef __osf__
+ /* Without the dummy below unpack("I", pack("I",0xFFFFFFFF))
+ * returns 1.84467440737096e+19 instead of 0xFFFFFFFF.
+ * See details few lines earlier. */
+ (auint) ?
+ sv_setuv(sv, (UV)auint) :
+#endif
sv_setuv(sv, (UV)auint);
PUSHs(sv_2mortal(sv));
}
}
break;
case 'l':
+#if LONGSIZE == SIZE32
along = (strend - s) / SIZE32;
+#else
+ along = (strend - s) / (natint ? sizeof(long) : SIZE32);
+#endif
if (len > along)
len = along;
if (checksum) {
- while (len-- > 0) {
- COPY32(s, &along);
- s += SIZE32;
- if (checksum > 32)
- cdouble += (double)along;
- else
- culong += along;
+#if LONGSIZE != SIZE32
+ if (natint) {
+ while (len-- > 0) {
+ COPYNN(s, &along, sizeof(long));
+ s += sizeof(long);
+ if (checksum > 32)
+ cdouble += (double)along;
+ else
+ culong += along;
+ }
+ }
+ else
+#endif
+ {
+ while (len-- > 0) {
+ COPY32(s, &along);
+#if LONGSIZE > SIZE32
+ if (along > 2147483647)
+ along -= 4294967296;
+#endif
+ s += SIZE32;
+ if (checksum > 32)
+ cdouble += (double)along;
+ else
+ culong += along;
+ }
}
}
else {
EXTEND(SP, len);
EXTEND_MORTAL(len);
- while (len-- > 0) {
- COPY32(s, &along);
- s += SIZE32;
- sv = NEWSV(42, 0);
- sv_setiv(sv, (IV)along);
- PUSHs(sv_2mortal(sv));
+#if LONGSIZE != SIZE32
+ if (natint) {
+ while (len-- > 0) {
+ COPYNN(s, &along, sizeof(long));
+ s += sizeof(long);
+ sv = NEWSV(42, 0);
+ sv_setiv(sv, (IV)along);
+ PUSHs(sv_2mortal(sv));
+ }
+ }
+ else
+#endif
+ {
+ while (len-- > 0) {
+ COPY32(s, &along);
+#if LONGSIZE > SIZE32
+ if (along > 2147483647)
+ along -= 4294967296;
+#endif
+ s += SIZE32;
+ sv = NEWSV(42, 0);
+ sv_setiv(sv, (IV)along);
+ PUSHs(sv_2mortal(sv));
+ }
}
}
break;
case 'V':
case 'N':
case 'L':
+#if LONGSIZE == SIZE32
along = (strend - s) / SIZE32;
+#else
+ unatint = natint && datumtype == 'L';
+ along = (strend - s) / (unatint ? sizeof(unsigned long) : SIZE32);
+#endif
if (len > along)
len = along;
if (checksum) {
- while (len-- > 0) {
- COPY32(s, &aulong);
- s += SIZE32;
+#if LONGSIZE != SIZE32
+ if (unatint) {
+ while (len-- > 0) {
+ COPYNN(s, &aulong, sizeof(unsigned long));
+ s += sizeof(unsigned long);
+ if (checksum > 32)
+ cdouble += (double)aulong;
+ else
+ culong += aulong;
+ }
+ }
+ else
+#endif
+ {
+ while (len-- > 0) {
+ COPY32(s, &aulong);
+ s += SIZE32;
#ifdef HAS_NTOHL
- if (datumtype == 'N')
- aulong = PerlSock_ntohl(aulong);
+ if (datumtype == 'N')
+ aulong = PerlSock_ntohl(aulong);
#endif
#ifdef HAS_VTOHL
- if (datumtype == 'V')
- aulong = vtohl(aulong);
+ if (datumtype == 'V')
+ aulong = vtohl(aulong);
#endif
- if (checksum > 32)
- cdouble += (double)aulong;
- else
- culong += aulong;
+ if (checksum > 32)
+ cdouble += (double)aulong;
+ else
+ culong += aulong;
+ }
}
}
else {
EXTEND(SP, len);
EXTEND_MORTAL(len);
- while (len-- > 0) {
- COPY32(s, &aulong);
- s += SIZE32;
+#if LONGSIZE != SIZE32
+ if (unatint) {
+ while (len-- > 0) {
+ COPYNN(s, &aulong, sizeof(unsigned long));
+ s += sizeof(unsigned long);
+ sv = NEWSV(43, 0);
+ sv_setuv(sv, (UV)aulong);
+ PUSHs(sv_2mortal(sv));
+ }
+ }
+ else
+#endif
+ {
+ while (len-- > 0) {
+ COPY32(s, &aulong);
+ s += SIZE32;
#ifdef HAS_NTOHL
- if (datumtype == 'N')
- aulong = PerlSock_ntohl(aulong);
+ if (datumtype == 'N')
+ aulong = PerlSock_ntohl(aulong);
#endif
#ifdef HAS_VTOHL
- if (datumtype == 'V')
- aulong = vtohl(aulong);
+ if (datumtype == 'V')
+ aulong = vtohl(aulong);
#endif
- sv = NEWSV(43, 0);
- sv_setuv(sv, (UV)aulong);
- PUSHs(sv_2mortal(sv));
+ sv = NEWSV(43, 0);
+ sv_setuv(sv, (UV)aulong);
+ PUSHs(sv_2mortal(sv));
+ }
}
}
break;
}
else if (++bytes >= sizeof(UV)) { /* promote to string */
char *t;
+ STRLEN n_a;
sv = newSVpvf("%.*Vu", (int)TYPE_DIGITS(UV), auv);
while (s < strend) {
break;
}
}
- t = SvPV(sv, PL_na);
+ t = SvPV(sv, n_a);
while (*t == '0')
t++;
sv_chop(sv, t);
EXTEND(SP, len);
EXTEND_MORTAL(len);
while (len-- > 0) {
- if (s + sizeof(unsigned Quad_t) > strend)
+ if (s + sizeof(Uquad_t) > strend)
auquad = 0;
else {
- Copy(s, &auquad, 1, unsigned Quad_t);
- s += sizeof(unsigned Quad_t);
+ Copy(s, &auquad, 1, Uquad_t);
+ s += sizeof(Uquad_t);
}
sv = NEWSV(43, 0);
if (auquad <= UV_MAX)
* algorithm, the code will be character-set independent
* (and just as fast as doing character arithmetic)
*/
- if (uudmap['M'] == 0) {
+ if (PL_uudmap['M'] == 0) {
int i;
- for (i = 0; i < sizeof(uuemap); i += 1)
- uudmap[uuemap[i]] = i;
+ for (i = 0; i < sizeof(PL_uuemap); i += 1)
+ PL_uudmap[PL_uuemap[i]] = i;
/*
* Because ' ' and '`' map to the same value,
* we need to decode them both the same.
*/
- uudmap[' '] = 0;
+ PL_uudmap[' '] = 0;
}
along = (strend - s) * 3 / 4;
char hunk[4];
hunk[3] = '\0';
- len = (*s++ - ' ') & 077;
+ len = PL_uudmap[*s++] & 077;
while (len > 0) {
if (s < strend && ISUUCHAR(*s))
- a = uudmap[*s++] & 077;
+ a = PL_uudmap[*s++] & 077;
else
a = 0;
if (s < strend && ISUUCHAR(*s))
- b = uudmap[*s++] & 077;
+ b = PL_uudmap[*s++] & 077;
else
b = 0;
if (s < strend && ISUUCHAR(*s))
- c = uudmap[*s++] & 077;
+ c = PL_uudmap[*s++] & 077;
else
c = 0;
if (s < strend && ISUUCHAR(*s))
- d = uudmap[*s++] & 077;
+ d = PL_uudmap[*s++] & 077;
else
d = 0;
hunk[0] = (a << 2) | (b >> 4);
if (checksum) {
sv = NEWSV(42, 0);
if (strchr("fFdD", datumtype) ||
- (checksum > 32 && strchr("iIlLN", datumtype)) ) {
+ (checksum > 32 && strchr("iIlLNU", datumtype)) ) {
double trouble;
adouble = 1.0;
{
char hunk[5];
- *hunk = uuemap[len];
+ *hunk = PL_uuemap[len];
sv_catpvn(sv, hunk, 1);
hunk[4] = '\0';
while (len > 2) {
- hunk[0] = uuemap[(077 & (*s >> 2))];
- hunk[1] = uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
- hunk[2] = uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
- hunk[3] = uuemap[(077 & (s[2] & 077))];
+ hunk[0] = PL_uuemap[(077 & (*s >> 2))];
+ hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
+ hunk[2] = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
+ hunk[3] = PL_uuemap[(077 & (s[2] & 077))];
sv_catpvn(sv, hunk, 4);
s += 3;
len -= 3;
}
if (len > 0) {
char r = (len > 1 ? s[1] : '\0');
- hunk[0] = uuemap[(077 & (*s >> 2))];
- hunk[1] = uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
- hunk[2] = uuemap[(077 & ((r << 2) & 074))];
- hunk[3] = uuemap[0];
+ hunk[0] = PL_uuemap[(077 & (*s >> 2))];
+ hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
+ hunk[2] = PL_uuemap[(077 & ((r << 2) & 074))];
+ hunk[3] = PL_uuemap[0];
sv_catpvn(sv, hunk, 4);
}
sv_catpvn(sv, "\n", 1);
}
-STATIC SV *
+STATIC SV *
is_an_int(char *s, STRLEN l)
{
- SV *result = newSVpv("", l);
- char *result_c = SvPV(result, PL_na); /* convenience */
+ STRLEN n_a;
+ SV *result = newSVpvn(s, l);
+ char *result_c = SvPV(result, n_a); /* convenience */
char *out = result_c;
bool skip = 1;
bool ignore = 0;
U32 aulong;
#ifdef HAS_QUAD
Quad_t aquad;
- unsigned Quad_t auquad;
+ Uquad_t auquad;
#endif
char *aptr;
float afloat;
double adouble;
int commas = 0;
+#ifdef PERL_NATINT_PACK
+ int natint; /* native integer */
+#endif
items = SP - MARK;
MARK++;
while (pat < patend) {
#define NEXTFROM (items-- > 0 ? *MARK++ : &PL_sv_no)
datumtype = *pat++ & 0xFF;
+#ifdef PERL_NATINT_PACK
+ natint = 0;
+#endif
if (isSPACE(datumtype))
continue;
+ if (*pat == '!') {
+ char *natstr = "sSiIlL";
+
+ if (strchr(natstr, datumtype)) {
+#ifdef PERL_NATINT_PACK
+ natint = 1;
+#endif
+ pat++;
+ }
+ else
+ croak("'!' allowed only after types %s", natstr);
+ }
if (*pat == '*') {
len = strchr("@Xxu", datumtype) ? 0 : items;
pat++;
default:
croak("Invalid type in pack: '%c'", (int)datumtype);
case ',': /* grandfather in commas but with a warning */
- if (commas++ == 0 && PL_dowarn)
- warn("Invalid type in pack: '%c'", (int)datumtype);
+ if (commas++ == 0 && ckWARN(WARN_UNSAFE))
+ warner(WARN_UNSAFE, "Invalid type in pack: '%c'", (int)datumtype);
break;
case '%':
DIE("%% may only be used in unpack");
sv_catpvn(cat, null10, len);
break;
case 'A':
+ case 'Z':
case 'a':
fromstr = NEXTFROM;
aptr = SvPV(fromstr, fromlen);
sv_catpvn(cat, &achar, sizeof(char));
}
break;
+ case 'U':
+ while (len-- > 0) {
+ fromstr = NEXTFROM;
+ auint = SvUV(fromstr);
+ SvGROW(cat, SvCUR(cat) + 10);
+ SvCUR_set(cat, (char*)uv_to_utf8((U8*)SvEND(cat),auint)
+ - SvPVX(cat));
+ }
+ *SvEND(cat) = '\0';
+ break;
/* Float and double added by gnb@melba.bby.oz.au 22/11/89 */
case 'f':
case 'F':
}
break;
case 'S':
+#if SHORTSIZE != SIZE16
+ if (natint) {
+ unsigned short aushort;
+
+ while (len-- > 0) {
+ fromstr = NEXTFROM;
+ aushort = SvUV(fromstr);
+ sv_catpvn(cat, (char *)&aushort, sizeof(unsigned short));
+ }
+ }
+ else
+#endif
+ {
+ U16 aushort;
+
+ while (len-- > 0) {
+ fromstr = NEXTFROM;
+ aushort = (U16)SvUV(fromstr);
+ CAT16(cat, &aushort);
+ }
+
+ }
+ break;
case 's':
- while (len-- > 0) {
- fromstr = NEXTFROM;
- ashort = (I16)SvIV(fromstr);
- CAT16(cat, &ashort);
+#if SHORTSIZE != SIZE16
+ if (natint) {
+ while (len-- > 0) {
+ fromstr = NEXTFROM;
+ ashort = SvIV(fromstr);
+ sv_catpvn(cat, (char *)&ashort, sizeof(short));
+ }
+ }
+ else
+#endif
+ {
+ while (len-- > 0) {
+ fromstr = NEXTFROM;
+ ashort = (I16)SvIV(fromstr);
+ CAT16(cat, &ashort);
+ }
}
break;
case 'I':
{
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;
}
break;
case 'L':
- while (len-- > 0) {
- fromstr = NEXTFROM;
- aulong = SvUV(fromstr);
- CAT32(cat, &aulong);
+#if LONGSIZE != SIZE32
+ if (natint) {
+ while (len-- > 0) {
+ fromstr = NEXTFROM;
+ aulong = SvUV(fromstr);
+ sv_catpvn(cat, (char *)&aulong, sizeof(unsigned long));
+ }
+ }
+ else
+#endif
+ {
+ while (len-- > 0) {
+ fromstr = NEXTFROM;
+ aulong = SvUV(fromstr);
+ CAT32(cat, &aulong);
+ }
}
break;
case 'l':
- while (len-- > 0) {
- fromstr = NEXTFROM;
- along = SvIV(fromstr);
- CAT32(cat, &along);
+#if LONGSIZE != SIZE32
+ if (natint) {
+ while (len-- > 0) {
+ fromstr = NEXTFROM;
+ along = SvIV(fromstr);
+ sv_catpvn(cat, (char *)&along, sizeof(long));
+ }
+ }
+ else
+#endif
+ {
+ while (len-- > 0) {
+ fromstr = NEXTFROM;
+ along = SvIV(fromstr);
+ CAT32(cat, &along);
+ }
}
break;
#ifdef HAS_QUAD
case 'Q':
while (len-- > 0) {
fromstr = NEXTFROM;
- auquad = (unsigned Quad_t)SvIV(fromstr);
- sv_catpvn(cat, (char*)&auquad, sizeof(unsigned Quad_t));
+ auquad = (Uquad_t)SvIV(fromstr);
+ sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
}
break;
case 'q':
if (fromstr == &PL_sv_undef)
aptr = NULL;
else {
+ STRLEN n_a;
/* 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 (PL_dowarn && (SvTEMP(fromstr) || SvPADTMP(fromstr)))
- warn("Attempt to pack pointer to temporary value");
+ if (ckWARN(WARN_UNSAFE) && (SvTEMP(fromstr) || SvPADTMP(fromstr)))
+ warner(WARN_UNSAFE,
+ "Attempt to pack pointer to temporary value");
if (SvPOK(fromstr) || SvNIOK(fromstr))
- aptr = SvPV(fromstr,PL_na);
+ aptr = SvPV(fromstr,n_a);
else
- aptr = SvPV_force(fromstr,PL_na);
+ aptr = SvPV_force(fromstr,n_a);
}
sv_catpvn(cat, (char*)&aptr, sizeof(char*));
}
av_extend(ary,0);
av_clear(ary);
SPAGAIN;
- if (SvRMAGICAL(ary) && (mg = mg_find((SV *) ary, 'P'))) {
+ if (mg = SvTIED_mg((SV*)ary, 'P')) {
PUSHMARK(SP);
- XPUSHs(mg->mg_obj);
+ XPUSHs(SvTIED_obj((SV*)ary, mg));
}
else {
if (!AvREAL(ary)) {
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, Nullsv, NULL, 0))
+ CALLREGEXEC(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;
}
}
DEBUG_S(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 */