#define PERL_IN_PP_C
#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
-
-/*
- * 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.) --???
- */
-/*
- The appropriate SHORTSIZE, INTSIZE, LONGSIZE, and LONGLONGSIZE
- defines are now in config.h. --Andy Dougherty April 1998
- */
-#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 LONGSIZE > 4 && defined(_CRAY)
-# 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 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
-
/* variations on pp_null */
/* XXX I can't imagine anyone who doesn't have this actually _needs_
SvTEMP_off(sv);
(void)SvREFCNT_inc(sv);
}
- else if (SvPADTMP(sv))
- sv = newSVsv(sv);
+ else if (SvPADTMP(sv) && !IS_PADGV(sv))
+ sv = newSVsv(sv);
else {
SvTEMP_off(sv);
(void)SvREFCNT_inc(sv);
tmpRef = (SV*)GvCVu(gv);
break;
case 'F':
- if (strEQ(elem, "FILEHANDLE")) /* XXX deprecate in 5.005 */
+ if (strEQ(elem, "FILEHANDLE")) {
+ /* finally deprecated in 5.8.0 */
+ deprecate("*glob{FILEHANDLE}");
tmpRef = (SV*)GvIOp(gv);
+ }
else
if (strEQ(elem, "FORMAT"))
tmpRef = (SV*)GvFORM(gv);
/* 2s complement assumption that (UV)-IV_MIN is correct. */
/* -ve result, which could overflow an IV */
SP--;
- SETi( -product );
+ SETi( -(IV)product );
RETURN;
} /* else drop to NVs below. */
} else {
/* 2s complement assumption again */
/* -ve result, which could overflow an IV */
SP--;
- SETi( -product_low );
+ SETi( -(IV)product_low );
RETURN;
} /* else drop to NVs below. */
}
PP(pp_divide)
{
dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
- {
- dPOPPOPnnrl;
- NV value;
- if (right == 0.0)
- DIE(aTHX_ "Illegal division by zero");
+ /* Only try to do UV divide first
+ if ((SLOPPYDIVIDE is true) or
+ (PERL_PRESERVE_IVUV is true and one or both SV is a UV too large
+ to preserve))
+ The assumption is that it is better to use floating point divide
+ whenever possible, only doing integer divide first if we can't be sure.
+ If NV_PRESERVES_UV is true then we know at compile time that no UV
+ can be too large to preserve, so don't need to compile the code to
+ test the size of UVs. */
+
#ifdef SLOPPYDIVIDE
- /* insure that 20./5. == 4. */
- {
- IV k;
- if ((NV)I_V(left) == left &&
- (NV)I_V(right) == right &&
- (k = I_V(left)/I_V(right))*I_V(right) == I_V(left)) {
- value = k;
- }
- else {
- value = left / right;
- }
- }
+# define PERL_TRY_UV_DIVIDE
+ /* ensure that 20./5. == 4. */
#else
- value = left / right;
+# ifdef PERL_PRESERVE_IVUV
+# ifndef NV_PRESERVES_UV
+# define PERL_TRY_UV_DIVIDE
+# endif
+# endif
#endif
- PUSHn( value );
- RETURN;
+
+#ifdef PERL_TRY_UV_DIVIDE
+ SvIV_please(TOPs);
+ if (SvIOK(TOPs)) {
+ SvIV_please(TOPm1s);
+ if (SvIOK(TOPm1s)) {
+ bool left_non_neg = SvUOK(TOPm1s);
+ bool right_non_neg = SvUOK(TOPs);
+ UV left;
+ UV right;
+
+ if (right_non_neg) {
+ right = SvUVX(TOPs);
+ }
+ else {
+ IV biv = SvIVX(TOPs);
+ if (biv >= 0) {
+ right = biv;
+ right_non_neg = TRUE; /* effectively it's a UV now */
+ }
+ else {
+ right = -biv;
+ }
+ }
+ /* historically undef()/0 gives a "Use of uninitialized value"
+ warning before dieing, hence this test goes here.
+ If it were immediately before the second SvIV_please, then
+ DIE() would be invoked before left was even inspected, so
+ no inpsection would give no warning. */
+ if (right == 0)
+ DIE(aTHX_ "Illegal division by zero");
+
+ if (left_non_neg) {
+ left = SvUVX(TOPm1s);
+ }
+ else {
+ IV aiv = SvIVX(TOPm1s);
+ if (aiv >= 0) {
+ left = aiv;
+ left_non_neg = TRUE; /* effectively it's a UV now */
+ }
+ else {
+ left = -aiv;
+ }
+ }
+
+ if (left >= right
+#ifdef SLOPPYDIVIDE
+ /* For sloppy divide we always attempt integer division. */
+#else
+ /* Otherwise we only attempt it if either or both operands
+ would not be preserved by an NV. If both fit in NVs
+ we fall through to the NV divide code below. */
+ && ((left > ((UV)1 << NV_PRESERVES_UV_BITS))
+ || (right > ((UV)1 << NV_PRESERVES_UV_BITS)))
+#endif
+ ) {
+ /* Integer division can't overflow, but it can be imprecise. */
+ UV result = left / right;
+ if (result * right == left) {
+ SP--; /* result is valid */
+ if (left_non_neg == right_non_neg) {
+ /* signs identical, result is positive. */
+ SETu( result );
+ RETURN;
+ }
+ /* 2s complement assumption */
+ if (result <= (UV)IV_MIN)
+ SETi( -result );
+ else {
+ /* It's exact but too negative for IV. */
+ SETn( -(NV)result );
+ }
+ RETURN;
+ } /* tried integer divide but it was not an integer result */
+ } /* else (abs(result) < 1.0) or (both UVs in range for NV) */
+ } /* left wasn't SvIOK */
+ } /* right wasn't SvIOK */
+#endif /* PERL_TRY_UV_DIVIDE */
+ {
+ dPOPPOPnnrl;
+ if (right == 0.0)
+ DIE(aTHX_ "Illegal division by zero");
+ PUSHn( left / right );
+ RETURN;
}
}
UV right = 0;
bool left_neg;
bool right_neg;
- bool use_double = 0;
+ bool use_double = FALSE;
+ bool dright_valid = FALSE;
NV dright = 0.0;
NV dleft = 0.0;
- if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
- IV i = SvIVX(POPs);
- right = (right_neg = (i < 0)) ? -i : i;
- }
- else {
+ SvIV_please(TOPs);
+ if (SvIOK(TOPs)) {
+ right_neg = !SvUOK(TOPs);
+ if (!right_neg) {
+ right = SvUVX(POPs);
+ } else {
+ IV biv = SvIVX(POPs);
+ if (biv >= 0) {
+ right = biv;
+ right_neg = FALSE; /* effectively it's a UV now */
+ } else {
+ right = -biv;
+ }
+ }
+ }
+ else {
dright = POPn;
- use_double = 1;
right_neg = dright < 0;
if (right_neg)
dright = -dright;
+ if (dright < UV_MAX_P1) {
+ right = U_V(dright);
+ dright_valid = TRUE; /* In case we need to use double below. */
+ } else {
+ use_double = TRUE;
+ }
}
- if (!use_double && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
- IV i = SvIVX(POPs);
- left = (left_neg = (i < 0)) ? -i : i;
- }
+ /* At this point use_double is only true if right is out of range for
+ a UV. In range NV has been rounded down to nearest UV and
+ use_double false. */
+ SvIV_please(TOPs);
+ if (!use_double && SvIOK(TOPs)) {
+ if (SvIOK(TOPs)) {
+ left_neg = !SvUOK(TOPs);
+ if (!left_neg) {
+ left = SvUVX(POPs);
+ } else {
+ IV aiv = SvIVX(POPs);
+ if (aiv >= 0) {
+ left = aiv;
+ left_neg = FALSE; /* effectively it's a UV now */
+ } else {
+ left = -aiv;
+ }
+ }
+ }
+ }
else {
dleft = POPn;
- if (!use_double) {
- use_double = 1;
- dright = right;
- }
left_neg = dleft < 0;
if (left_neg)
dleft = -dleft;
- }
+ /* This should be exactly the 5.6 behaviour - if left and right are
+ both in range for UV then use U_V() rather than floor. */
+ if (!use_double) {
+ if (dleft < UV_MAX_P1) {
+ /* right was in range, so is dleft, so use UVs not double.
+ */
+ left = U_V(dleft);
+ }
+ /* left is out of range for UV, right was in range, so promote
+ right (back) to double. */
+ else {
+ /* The +0.5 is used in 5.6 even though it is not strictly
+ consistent with the implicit +0 floor in the U_V()
+ inside the #if 1. */
+ dleft = Perl_floor(dleft + 0.5);
+ use_double = TRUE;
+ if (dright_valid)
+ dright = Perl_floor(dright + 0.5);
+ else
+ dright = right;
+ }
+ }
+ }
if (use_double) {
NV dans;
-#if 1
-/* Somehow U_V is pessimized even if CASTFLAGS is 0 */
-# if CASTFLAGS & 2
-# define CAST_D2UV(d) U_V(d)
-# else
-# define CAST_D2UV(d) ((UV)(d))
-# endif
- /* Tried to do this only in the case DOUBLESIZE <= UV_SIZE,
- * or, in other words, precision of UV more than of NV.
- * But in fact the approach below turned out to be an
- * optimization - floor() may be slow */
- if (dright <= UV_MAX && dleft <= UV_MAX) {
- right = CAST_D2UV(dright);
- left = CAST_D2UV(dleft);
- goto do_uv;
- }
-#endif
-
- /* Backward-compatibility clause: */
- dright = Perl_floor(dright + 0.5);
- dleft = Perl_floor(dleft + 0.5);
-
if (!dright)
DIE(aTHX_ "Illegal modulus zero");
else {
UV ans;
- do_uv:
if (!right)
DIE(aTHX_ "Illegal modulus zero");
MEXTEND(MARK, max);
if (count > 1) {
while (SP > MARK) {
- if (*SP)
- SvTEMP_off((*SP));
+ if (*SP) {
+ *SP = sv_2mortal(newSVsv(*SP));
+ SvREADONLY_on(*SP);
+ }
SP--;
}
MARK++;
SETu(U_V(value));
} else {
#if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE)
+# ifdef HAS_MODFL_POW32_BUG
+/* some versions of glibc split (i + d) into (i-1, d+1) for 2^32 <= i < 2^64 */
+ {
+ NV offset = Perl_modf(value, &value);
+ (void)Perl_modf(offset, &offset);
+ value += offset;
+ }
+# else
(void)Perl_modf(value, &value);
+# endif
#else
double tmp = (double)value;
(void)Perl_modf(tmp, &tmp);
SETi(I_V(value));
} else {
#if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE)
+# ifdef HAS_MODFL_POW32_BUG
+/* some versions of glibc split (i + d) into (i-1, d+1) for 2^32 <= i < 2^64 */
+ {
+ NV offset = Perl_modf(-value, &value);
+ (void)Perl_modf(offset, &offset);
+ value += offset;
+ }
+# else
(void)Perl_modf(-value, &value);
+# endif
value = -value;
#else
double tmp = (double)value;
RETURN;
}
+
PP(pp_hex)
{
dSP; dTARGET;
char *tmps;
- STRLEN argtype;
+ I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
STRLEN len;
+ NV result_nv;
+ UV result_uv;
tmps = (SvPVx(POPs, len));
- argtype = 1; /* allow underscores */
- XPUSHn(scan_hex(tmps, len, &argtype));
+ result_uv = grok_hex (tmps, &len, &flags, &result_nv);
+ if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
+ XPUSHn(result_nv);
+ }
+ else {
+ XPUSHu(result_uv);
+ }
RETURN;
}
PP(pp_oct)
{
dSP; dTARGET;
- NV value;
- STRLEN argtype;
char *tmps;
+ I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
STRLEN len;
+ NV result_nv;
+ UV result_uv;
tmps = (SvPVx(POPs, len));
while (*tmps && len && isSPACE(*tmps))
- tmps++, len--;
+ tmps++, len--;
if (*tmps == '0')
- tmps++, len--;
- argtype = 1; /* allow underscores */
+ tmps++, len--;
if (*tmps == 'x')
- value = scan_hex(++tmps, --len, &argtype);
+ result_uv = grok_hex (tmps, &len, &flags, &result_nv);
else if (*tmps == 'b')
- value = scan_bin(++tmps, --len, &argtype);
+ result_uv = grok_bin (tmps, &len, &flags, &result_nv);
else
- value = scan_oct(tmps, len, &argtype);
- XPUSHn(value);
+ result_uv = grok_oct (tmps, &len, &flags, &result_nv);
+
+ if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
+ XPUSHn(result_nv);
+ }
+ else {
+ XPUSHu(result_uv);
+ }
RETURN;
}
dSP; dMARK; dORIGMARK; dTARGET;
do_sprintf(TARG, SP-MARK, MARK+1);
TAINT_IF(SvTAINTED(TARG));
+ if (DO_UTF8(*(MARK+1)))
+ SvUTF8_on(TARG);
SP = ORIGMARK;
PUSHTARG;
RETURN;
dSP; dTARGET; dPOPTOPssrl;
STRLEN n_a;
#ifdef HAS_CRYPT
- char *tmps = SvPV(left, n_a);
+ STRLEN len;
+ char *tmps = SvPV(left, len);
+ char *t = 0;
+ if (DO_UTF8(left)) {
+ /* If Unicode take the crypt() of the low 8 bits
+ * of the characters of the string. */
+ char *s = tmps;
+ char *send = tmps + len;
+ STRLEN i = 0;
+ Newz(688, t, len, char);
+ while (s < send) {
+ t[i++] = utf8_to_uvchr((U8*)s, 0) & 0xFF;
+ s += UTF8SKIP(s);
+ }
+ tmps = t;
+ }
#ifdef FCRYPT
sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
#else
sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
#endif
+ Safefree(t);
#else
DIE(aTHX_
"The crypt() function is unimplemented due to excessive paranoia.");
if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && UTF8_IS_START(*s)) {
STRLEN ulen;
- U8 tmpbuf[UTF8_MAXLEN+1];
+ U8 tmpbuf[UTF8_MAXLEN*2+1];
U8 *tend;
UV uv;
- if (IN_LOCALE_RUNTIME) {
- TAINT;
- SvTAINTED_on(sv);
- uv = toTITLE_LC_uvchr(utf8n_to_uvchr(s, slen, &ulen, 0));
- }
- else
- uv = toTITLE_utf8(s);
+ toTITLE_utf8(s, tmpbuf, &ulen); /* XXX --jhi */
+ uv = utf8_to_uvchr(tmpbuf, 0);
tend = uvchr_to_utf8(tmpbuf, uv);
if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && UTF8_IS_START(*s)) {
STRLEN ulen;
- U8 tmpbuf[UTF8_MAXLEN+1];
+ U8 tmpbuf[UTF8_MAXLEN*2+1];
U8 *tend;
UV uv;
- if (IN_LOCALE_RUNTIME) {
- TAINT;
- SvTAINTED_on(sv);
- uv = toLOWER_LC_uvchr(utf8n_to_uvchr(s, slen, &ulen, 0));
- }
- else
- uv = toLOWER_utf8(s);
+ toLOWER_utf8(s, tmpbuf, &ulen); /* XXX --jhi */
+ uv = utf8_to_uvchr(tmpbuf, 0);
tend = uvchr_to_utf8(tmpbuf, uv);
STRLEN ulen;
register U8 *d;
U8 *send;
+ U8 tmpbuf[UTF8_MAXLEN*2+1];
s = (U8*)SvPV(sv,len);
if (!len) {
(void)SvPOK_only(TARG);
d = (U8*)SvPVX(TARG);
send = s + len;
- if (IN_LOCALE_RUNTIME) {
- TAINT;
- SvTAINTED_on(TARG);
- while (s < send) {
- d = uvchr_to_utf8(d, toUPPER_LC_uvchr( utf8n_to_uvchr(s, len, &ulen, 0)));
- s += ulen;
- }
- }
- else {
- while (s < send) {
- d = uvchr_to_utf8(d, toUPPER_utf8( s ));
- s += UTF8SKIP(s);
- }
+ while (s < send) {
+ toUPPER_utf8(s, tmpbuf, &ulen); /* XXX --jhi */
+ Copy(tmpbuf, d, ulen, U8);
+ d += ulen;
+ s += UTF8SKIP(s);
}
*d = '\0';
SvUTF8_on(TARG);
STRLEN ulen;
register U8 *d;
U8 *send;
+ U8 tmpbuf[UTF8_MAXLEN*2+1];
s = (U8*)SvPV(sv,len);
if (!len) {
(void)SvPOK_only(TARG);
d = (U8*)SvPVX(TARG);
send = s + len;
- if (IN_LOCALE_RUNTIME) {
- TAINT;
- SvTAINTED_on(TARG);
- while (s < send) {
- d = uvchr_to_utf8(d, toLOWER_LC_uvchr( utf8n_to_uvchr(s, len, &ulen, 0)));
- s += ulen;
- }
- }
- else {
- while (s < send) {
- d = uvchr_to_utf8(d, toLOWER_utf8(s));
- s += UTF8SKIP(s);
- }
+ while (s < send) {
+ toLOWER_utf8(s, tmpbuf, &ulen); /* XXX --jhi */
+ Copy(tmpbuf, d, ulen, U8);
+ d += ulen;
+ s += UTF8SKIP(s);
}
*d = '\0';
SvUTF8_on(TARG);
RETURN;
}
-STATIC SV *
-S_mul128(pTHX_ SV *sv, U8 m)
-{
- STRLEN len;
- char *s = SvPV(sv, len);
- char *t;
- U32 i = 0;
-
- if (!strnEQ(s, "0000", 4)) { /* need to grow sv */
- SV *tmpNew = newSVpvn("0000000000", 10);
-
- sv_catsv(tmpNew, sv);
- SvREFCNT_dec(sv); /* free old sv */
- sv = tmpNew;
- s = SvPV(sv, len);
- }
- t = s + len - 1;
- while (!*t) /* trailing '\0'? */
- t--;
- while (t > s) {
- i = ((*t - '0') << 7) + m;
- *(t--) = '0' + (i % 10);
- m = i / 10;
- }
- return (sv);
-}
-
-/* Explosives and implosives. */
-
-#if 'I' == 73 && 'J' == 74
-/* On an ASCII/ISO kind of system */
-#define ISUUCHAR(ch) ((ch) >= ' ' && (ch) < 'a')
-#else
-/*
- Some other sort of character set - use memchr() so we don't match
- the null byte.
- */
-#define ISUUCHAR(ch) (memchr(PL_uuemap, (ch), sizeof(PL_uuemap)-1) || (ch) == ' ')
-#endif
-
-
-PP(pp_unpack)
-{
- dSP;
- dPOPPOPssrl;
- I32 start_sp_offset = SP - PL_stack_base;
- I32 gimme = GIMME_V;
- SV *sv;
- STRLEN llen;
- STRLEN rlen;
- register char *pat = SvPV(left, llen);
-#ifdef PACKED_IS_OCTETS
- /* Packed side is assumed to be octets - so force downgrade if it
- has been UTF-8 encoded by accident
- */
- register char *s = SvPVbyte(right, rlen);
-#else
- register char *s = SvPV(right, rlen);
-#endif
- char *strend = s + rlen;
- char *strbeg = s;
- register char *patend = pat + llen;
- I32 datumtype;
- register I32 len;
- register I32 bits = 0;
- register char *str;
-
- /* These must not be in registers: */
- short ashort;
- int aint;
- long along;
-#ifdef HAS_QUAD
- Quad_t aquad;
-#endif
- U16 aushort;
- unsigned int auint;
- U32 aulong;
-#ifdef HAS_QUAD
- Uquad_t auquad;
-#endif
- char *aptr;
- float afloat;
- double adouble;
- I32 checksum = 0;
- register U32 culong = 0;
- NV cdouble = 0.0;
- int commas = 0;
- int star;
-#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("aAZbBhHP", *patend) || *pat == '%') {
- patend++;
- while (isDIGIT(*patend) || *patend == '*')
- patend++;
- }
- else
- patend++;
- }
- while (pat < patend) {
- reparse:
- datumtype = *pat++ & 0xFF;
-#ifdef PERL_NATINT_PACK
- natint = 0;
-#endif
- if (isSPACE(datumtype))
- continue;
- if (datumtype == '#') {
- while (pat < patend && *pat != '\n')
- pat++;
- continue;
- }
- if (*pat == '!') {
- char *natstr = "sSiIlL";
-
- if (strchr(natstr, datumtype)) {
-#ifdef PERL_NATINT_PACK
- natint = 1;
-#endif
- pat++;
- }
- else
- DIE(aTHX_ "'!' allowed only after types %s", natstr);
- }
- star = 0;
- if (pat >= patend)
- len = 1;
- else if (*pat == '*') {
- len = strend - strbeg; /* long enough */
- pat++;
- star = 1;
- }
- else if (isDIGIT(*pat)) {
- len = *pat++ - '0';
- while (isDIGIT(*pat)) {
- len = (len * 10) + (*pat++ - '0');
- if (len < 0)
- DIE(aTHX_ "Repeat count in unpack overflows");
- }
- }
- else
- len = (datumtype != '@');
- redo_switch:
- switch(datumtype) {
- default:
- DIE(aTHX_ "Invalid type in unpack: '%c'", (int)datumtype);
- case ',': /* grandfather in commas but with a warning */
- if (commas++ == 0 && ckWARN(WARN_UNPACK))
- Perl_warner(aTHX_ WARN_UNPACK,
- "Invalid type in unpack: '%c'", (int)datumtype);
- break;
- case '%':
- if (len == 1 && pat[-1] != '1')
- len = 16;
- checksum = len;
- culong = 0;
- cdouble = 0;
- if (pat < patend)
- goto reparse;
- break;
- case '@':
- if (len > strend - strbeg)
- DIE(aTHX_ "@ outside of string");
- s = strbeg + len;
- break;
- case 'X':
- if (len > s - strbeg)
- DIE(aTHX_ "X outside of string");
- s -= len;
- break;
- case 'x':
- if (len > strend - s)
- DIE(aTHX_ "x outside of string");
- s += len;
- break;
- case '/':
- if (start_sp_offset >= SP - PL_stack_base)
- DIE(aTHX_ "/ must follow a numeric type");
- datumtype = *pat++;
- if (*pat == '*')
- pat++; /* ignore '*' for compatibility with pack */
- if (isDIGIT(*pat))
- DIE(aTHX_ "/ cannot take a count" );
- len = POPi;
- star = 0;
- goto redo_switch;
- case 'A':
- case 'Z':
- case 'a':
- if (len > strend - s)
- len = strend - s;
- if (checksum)
- goto uchar_checksum;
- sv = NEWSV(35, len);
- sv_setpvn(sv, s, len);
- s += len;
- if (datumtype == 'A' || datumtype == 'Z') {
- aptr = s; /* borrow register */
- 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 */
- }
- XPUSHs(sv_2mortal(sv));
- break;
- case 'B':
- case 'b':
- if (star || len > (strend - s) * 8)
- len = (strend - s) * 8;
- if (checksum) {
- if (!PL_bitcount) {
- Newz(601, PL_bitcount, 256, char);
- for (bits = 1; bits < 256; 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 += PL_bitcount[*(unsigned char*)s++];
- len -= 8;
- }
- if (len) {
- bits = *s;
- if (datumtype == 'b') {
- while (len-- > 0) {
- if (bits & 1) culong++;
- bits >>= 1;
- }
- }
- else {
- while (len-- > 0) {
- if (bits & 128) culong++;
- bits <<= 1;
- }
- }
- }
- break;
- }
- sv = NEWSV(35, len + 1);
- SvCUR_set(sv, len);
- SvPOK_on(sv);
- str = SvPVX(sv);
- if (datumtype == 'b') {
- aint = len;
- for (len = 0; len < aint; len++) {
- if (len & 7) /*SUPPRESS 595*/
- bits >>= 1;
- else
- bits = *s++;
- *str++ = '0' + (bits & 1);
- }
- }
- else {
- aint = len;
- for (len = 0; len < aint; len++) {
- if (len & 7)
- bits <<= 1;
- else
- bits = *s++;
- *str++ = '0' + ((bits & 128) != 0);
- }
- }
- *str = '\0';
- XPUSHs(sv_2mortal(sv));
- break;
- case 'H':
- case 'h':
- if (star || len > (strend - s) * 2)
- len = (strend - s) * 2;
- sv = NEWSV(35, len + 1);
- SvCUR_set(sv, len);
- SvPOK_on(sv);
- str = SvPVX(sv);
- if (datumtype == 'h') {
- aint = len;
- for (len = 0; len < aint; len++) {
- if (len & 1)
- bits >>= 4;
- else
- bits = *s++;
- *str++ = PL_hexdigit[bits & 15];
- }
- }
- else {
- aint = len;
- for (len = 0; len < aint; len++) {
- if (len & 1)
- bits <<= 4;
- else
- bits = *s++;
- *str++ = PL_hexdigit[(bits >> 4) & 15];
- }
- }
- *str = '\0';
- XPUSHs(sv_2mortal(sv));
- break;
- case 'c':
- if (len > strend - s)
- len = strend - s;
- if (checksum) {
- while (len-- > 0) {
- aint = *s++;
- if (aint >= 128) /* fake up signed chars */
- aint -= 256;
- culong += aint;
- }
- }
- else {
- EXTEND(SP, len);
- EXTEND_MORTAL(len);
- while (len-- > 0) {
- aint = *s++;
- if (aint >= 128) /* fake up signed chars */
- aint -= 256;
- sv = NEWSV(36, 0);
- sv_setiv(sv, (IV)aint);
- PUSHs(sv_2mortal(sv));
- }
- }
- break;
- case 'C':
- if (len > strend - s)
- len = strend - s;
- if (checksum) {
- uchar_checksum:
- while (len-- > 0) {
- auint = *s++ & 255;
- culong += auint;
- }
- }
- else {
- EXTEND(SP, len);
- EXTEND_MORTAL(len);
- while (len-- > 0) {
- auint = *s++ & 255;
- sv = NEWSV(37, 0);
- sv_setiv(sv, (IV)auint);
- PUSHs(sv_2mortal(sv));
- }
- }
- break;
- case 'U':
- if (len > strend - s)
- len = strend - s;
- if (checksum) {
- while (len-- > 0 && s < strend) {
- STRLEN alen;
- auint = utf8n_to_uvchr((U8*)s, strend - s, &alen, 0);
- along = alen;
- s += along;
- if (checksum > 32)
- cdouble += (NV)auint;
- else
- culong += auint;
- }
- }
- else {
- EXTEND(SP, len);
- EXTEND_MORTAL(len);
- while (len-- > 0 && s < strend) {
- STRLEN alen;
- auint = utf8n_to_uvchr((U8*)s, strend - s, &alen, 0);
- along = alen;
- 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) {
-#if SHORTSIZE != SIZE16
- if (natint) {
- short ashort;
- 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);
-#if SHORTSIZE != SIZE16
- if (natint) {
- short ashort;
- 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) {
-#if SHORTSIZE != SIZE16
- if (unatint) {
- unsigned short aushort;
- 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);
-#endif
-#ifdef HAS_VTOHS
- if (datumtype == 'v')
- aushort = vtohs(aushort);
-#endif
- culong += aushort;
- }
- }
- }
- else {
- EXTEND(SP, len);
- EXTEND_MORTAL(len);
-#if SHORTSIZE != SIZE16
- if (unatint) {
- unsigned short aushort;
- 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);
-#endif
-#ifdef HAS_VTOHS
- if (datumtype == 'v')
- aushort = vtohs(aushort);
-#endif
- sv_setiv(sv, (UV)aushort);
- PUSHs(sv_2mortal(sv));
- }
- }
- }
- break;
- case 'i':
- along = (strend - s) / sizeof(int);
- if (len > along)
- len = along;
- if (checksum) {
- while (len-- > 0) {
- Copy(s, &aint, 1, int);
- s += sizeof(int);
- if (checksum > 32)
- cdouble += (NV)aint;
- else
- culong += aint;
- }
- }
- else {
- EXTEND(SP, len);
- EXTEND_MORTAL(len);
- while (len-- > 0) {
- Copy(s, &aint, 1, int);
- s += sizeof(int);
- sv = NEWSV(40, 0);
-#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.
- *
- * The bug was detected in
- * DEC C V5.8-009 on Digital UNIX V4.0 (Rev. 1091) (V4.0E)
- * with optimization (-O4) turned on.
- * DEC C V5.2-040 on Digital UNIX V4.0 (Rev. 564) (V4.0B)
- * does not have this problem even with -O4.
- *
- * This bug was reported as DECC_BUGS 1431
- * and tracked internally as GEM_BUGS 7775.
- *
- * The bug is fixed in
- * Tru64 UNIX V5.0: Compaq C V6.1-006 or later
- * UNIX V4.0F support: DEC C V5.9-006 or later
- * UNIX V4.0E support: DEC C V5.8-011 or later
- * and also in DTK.
- *
- * See also few lines later for the same bug.
- */
- (aint) ?
- sv_setiv(sv, (IV)aint) :
-#endif
- sv_setiv(sv, (IV)aint);
- PUSHs(sv_2mortal(sv));
- }
- }
- break;
- case 'I':
- along = (strend - s) / sizeof(unsigned int);
- if (len > along)
- len = along;
- if (checksum) {
- while (len-- > 0) {
- Copy(s, &auint, 1, unsigned int);
- s += sizeof(unsigned int);
- if (checksum > 32)
- cdouble += (NV)auint;
- else
- culong += auint;
- }
- }
- else {
- EXTEND(SP, len);
- EXTEND_MORTAL(len);
- while (len-- > 0) {
- 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) {
-#if LONGSIZE != SIZE32
- if (natint) {
- while (len-- > 0) {
- COPYNN(s, &along, sizeof(long));
- s += sizeof(long);
- if (checksum > 32)
- cdouble += (NV)along;
- else
- culong += along;
- }
- }
- else
-#endif
- {
- while (len-- > 0) {
-#if LONGSIZE > SIZE32 && INTSIZE == SIZE32
- I32 along;
-#endif
- COPY32(s, &along);
-#if LONGSIZE > SIZE32
- if (along > 2147483647)
- along -= 4294967296;
-#endif
- s += SIZE32;
- if (checksum > 32)
- cdouble += (NV)along;
- else
- culong += along;
- }
- }
- }
- else {
- EXTEND(SP, len);
- EXTEND_MORTAL(len);
-#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) {
-#if LONGSIZE > SIZE32 && INTSIZE == SIZE32
- I32 along;
-#endif
- 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) {
-#if LONGSIZE != SIZE32
- if (unatint) {
- unsigned long aulong;
- while (len-- > 0) {
- COPYNN(s, &aulong, sizeof(unsigned long));
- s += sizeof(unsigned long);
- if (checksum > 32)
- cdouble += (NV)aulong;
- else
- culong += aulong;
- }
- }
- else
-#endif
- {
- while (len-- > 0) {
- COPY32(s, &aulong);
- s += SIZE32;
-#ifdef HAS_NTOHL
- if (datumtype == 'N')
- aulong = PerlSock_ntohl(aulong);
-#endif
-#ifdef HAS_VTOHL
- if (datumtype == 'V')
- aulong = vtohl(aulong);
-#endif
- if (checksum > 32)
- cdouble += (NV)aulong;
- else
- culong += aulong;
- }
- }
- }
- else {
- EXTEND(SP, len);
- EXTEND_MORTAL(len);
-#if LONGSIZE != SIZE32
- if (unatint) {
- unsigned long aulong;
- 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);
-#endif
-#ifdef HAS_VTOHL
- if (datumtype == 'V')
- aulong = vtohl(aulong);
-#endif
- sv = NEWSV(43, 0);
- sv_setuv(sv, (UV)aulong);
- PUSHs(sv_2mortal(sv));
- }
- }
- }
- break;
- case 'p':
- along = (strend - s) / sizeof(char*);
- if (len > along)
- len = along;
- EXTEND(SP, len);
- EXTEND_MORTAL(len);
- while (len-- > 0) {
- if (sizeof(char*) > strend - s)
- break;
- else {
- Copy(s, &aptr, 1, char*);
- s += sizeof(char*);
- }
- sv = NEWSV(44, 0);
- if (aptr)
- sv_setpv(sv, aptr);
- PUSHs(sv_2mortal(sv));
- }
- break;
- case 'w':
- EXTEND(SP, len);
- EXTEND_MORTAL(len);
- {
- UV auv = 0;
- U32 bytes = 0;
-
- while ((len > 0) && (s < strend)) {
- auv = (auv << 7) | (*s & 0x7f);
- /* UTF8_IS_XXXXX not right here - using constant 0x80 */
- if ((U8)(*s++) < 0x80) {
- bytes = 0;
- sv = NEWSV(40, 0);
- sv_setuv(sv, auv);
- PUSHs(sv_2mortal(sv));
- len--;
- auv = 0;
- }
- else if (++bytes >= sizeof(UV)) { /* promote to string */
- char *t;
- STRLEN n_a;
-
- sv = Perl_newSVpvf(aTHX_ "%.*"UVf, (int)TYPE_DIGITS(UV), auv);
- while (s < strend) {
- sv = mul128(sv, *s & 0x7f);
- if (!(*s++ & 0x80)) {
- bytes = 0;
- break;
- }
- }
- t = SvPV(sv, n_a);
- while (*t == '0')
- t++;
- sv_chop(sv, t);
- PUSHs(sv_2mortal(sv));
- len--;
- auv = 0;
- }
- }
- if ((s >= strend) && bytes)
- DIE(aTHX_ "Unterminated compressed integer");
- }
- break;
- case 'P':
- EXTEND(SP, 1);
- if (sizeof(char*) > strend - s)
- break;
- else {
- Copy(s, &aptr, 1, char*);
- s += sizeof(char*);
- }
- sv = NEWSV(44, 0);
- if (aptr)
- sv_setpvn(sv, aptr, len);
- PUSHs(sv_2mortal(sv));
- break;
-#ifdef HAS_QUAD
- case 'q':
- along = (strend - s) / sizeof(Quad_t);
- if (len > along)
- len = along;
- EXTEND(SP, len);
- EXTEND_MORTAL(len);
- while (len-- > 0) {
- if (s + sizeof(Quad_t) > strend)
- aquad = 0;
- else {
- Copy(s, &aquad, 1, Quad_t);
- s += sizeof(Quad_t);
- }
- sv = NEWSV(42, 0);
- if (aquad >= IV_MIN && aquad <= IV_MAX)
- sv_setiv(sv, (IV)aquad);
- else
- sv_setnv(sv, (NV)aquad);
- PUSHs(sv_2mortal(sv));
- }
- break;
- case 'Q':
- along = (strend - s) / sizeof(Quad_t);
- if (len > along)
- len = along;
- EXTEND(SP, len);
- EXTEND_MORTAL(len);
- while (len-- > 0) {
- if (s + sizeof(Uquad_t) > strend)
- auquad = 0;
- else {
- Copy(s, &auquad, 1, Uquad_t);
- s += sizeof(Uquad_t);
- }
- sv = NEWSV(43, 0);
- if (auquad <= UV_MAX)
- sv_setuv(sv, (UV)auquad);
- else
- sv_setnv(sv, (NV)auquad);
- PUSHs(sv_2mortal(sv));
- }
- break;
-#endif
- /* float and double added gnb@melba.bby.oz.au 22/11/89 */
- case 'f':
- case 'F':
- along = (strend - s) / sizeof(float);
- if (len > along)
- len = along;
- if (checksum) {
- while (len-- > 0) {
- Copy(s, &afloat, 1, float);
- s += sizeof(float);
- cdouble += afloat;
- }
- }
- else {
- EXTEND(SP, len);
- EXTEND_MORTAL(len);
- while (len-- > 0) {
- Copy(s, &afloat, 1, float);
- s += sizeof(float);
- sv = NEWSV(47, 0);
- sv_setnv(sv, (NV)afloat);
- PUSHs(sv_2mortal(sv));
- }
- }
- break;
- case 'd':
- case 'D':
- along = (strend - s) / sizeof(double);
- if (len > along)
- len = along;
- if (checksum) {
- while (len-- > 0) {
- Copy(s, &adouble, 1, double);
- s += sizeof(double);
- cdouble += adouble;
- }
- }
- else {
- EXTEND(SP, len);
- EXTEND_MORTAL(len);
- while (len-- > 0) {
- Copy(s, &adouble, 1, double);
- s += sizeof(double);
- sv = NEWSV(48, 0);
- sv_setnv(sv, (NV)adouble);
- PUSHs(sv_2mortal(sv));
- }
- }
- break;
- case 'u':
- /* MKS:
- * Initialise the decode mapping. By using a table driven
- * algorithm, the code will be character-set independent
- * (and just as fast as doing character arithmetic)
- */
- if (PL_uudmap['M'] == 0) {
- int i;
-
- for (i = 0; i < sizeof(PL_uuemap); i += 1)
- PL_uudmap[(U8)PL_uuemap[i]] = i;
- /*
- * Because ' ' and '`' map to the same value,
- * we need to decode them both the same.
- */
- PL_uudmap[' '] = 0;
- }
-
- along = (strend - s) * 3 / 4;
- sv = NEWSV(42, along);
- if (along)
- SvPOK_on(sv);
- while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
- I32 a, b, c, d;
- char hunk[4];
-
- hunk[3] = '\0';
- len = PL_uudmap[*(U8*)s++] & 077;
- while (len > 0) {
- if (s < strend && ISUUCHAR(*s))
- a = PL_uudmap[*(U8*)s++] & 077;
- else
- a = 0;
- if (s < strend && ISUUCHAR(*s))
- b = PL_uudmap[*(U8*)s++] & 077;
- else
- b = 0;
- if (s < strend && ISUUCHAR(*s))
- c = PL_uudmap[*(U8*)s++] & 077;
- else
- c = 0;
- if (s < strend && ISUUCHAR(*s))
- d = PL_uudmap[*(U8*)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);
- len -= 3;
- }
- if (*s == '\n')
- s++;
- else if (s[1] == '\n') /* possible checksum byte */
- s += 2;
- }
- XPUSHs(sv_2mortal(sv));
- break;
- }
- if (checksum) {
- sv = NEWSV(42, 0);
- if (strchr("fFdD", datumtype) ||
- (checksum > 32 && strchr("iIlLNU", datumtype)) ) {
- NV trouble;
-
- adouble = 1.0;
- while (checksum >= 16) {
- checksum -= 16;
- adouble *= 65536.0;
- }
- while (checksum >= 4) {
- checksum -= 4;
- adouble *= 16.0;
- }
- while (checksum--)
- adouble *= 2.0;
- along = (1 << checksum) - 1;
- while (cdouble < 0.0)
- cdouble += adouble;
- cdouble = Perl_modf(cdouble / adouble, &trouble) * adouble;
- sv_setnv(sv, cdouble);
- }
- else {
- if (checksum < 32) {
- aulong = (1 << checksum) - 1;
- culong &= aulong;
- }
- sv_setuv(sv, (UV)culong);
- }
- XPUSHs(sv_2mortal(sv));
- checksum = 0;
- }
- }
- if (SP - PL_stack_base == start_sp_offset && gimme == G_SCALAR)
- PUSHs(&PL_sv_undef);
- RETURN;
-}
-
-STATIC void
-S_doencodes(pTHX_ register SV *sv, register char *s, register I32 len)
-{
- char hunk[5];
-
- *hunk = PL_uuemap[len];
- sv_catpvn(sv, hunk, 1);
- hunk[4] = '\0';
- while (len > 2) {
- 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] = 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 *
-S_is_an_int(pTHX_ char *s, STRLEN l)
-{
- 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;
-
- while (*s) {
- switch (*s) {
- case ' ':
- break;
- case '+':
- if (!skip) {
- SvREFCNT_dec(result);
- return (NULL);
- }
- break;
- case '0':
- case '1':
- case '2':
- case '3':
- case '4':
- case '5':
- case '6':
- case '7':
- case '8':
- case '9':
- skip = 0;
- if (!ignore) {
- *(out++) = *s;
- }
- break;
- case '.':
- ignore = 1;
- break;
- default:
- SvREFCNT_dec(result);
- return (NULL);
- }
- s++;
- }
- *(out++) = '\0';
- SvCUR_set(result, out - result_c);
- return (result);
-}
-
-/* pnum must be '\0' terminated */
-STATIC int
-S_div128(pTHX_ SV *pnum, bool *done)
-{
- STRLEN len;
- char *s = SvPV(pnum, len);
- int m = 0;
- int r = 0;
- char *t = s;
-
- *done = 1;
- while (*t) {
- int i;
-
- i = m * 10 + (*t - '0');
- m = i & 0x7F;
- r = (i >> 7); /* r < 10 */
- if (r) {
- *done = 0;
- }
- *(t++) = '0' + r;
- }
- *(t++) = '\0';
- SvCUR_set(pnum, (STRLEN) (t - s));
- return (m);
-}
-
-
-PP(pp_pack)
-{
- dSP; dMARK; dORIGMARK; dTARGET;
- register SV *cat = TARG;
- register I32 items;
- STRLEN fromlen;
- register char *pat = SvPVx(*++MARK, fromlen);
- char *patcopy;
- register char *patend = pat + fromlen;
- register I32 len;
- I32 datumtype;
- SV *fromstr;
- /*SUPPRESS 442*/
- static char null10[] = {0,0,0,0,0,0,0,0,0,0};
- static char *space10 = " ";
-
- /* These must not be in registers: */
- char achar;
- I16 ashort;
- int aint;
- unsigned int auint;
- I32 along;
- U32 aulong;
-#ifdef HAS_QUAD
- Quad_t aquad;
- 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++;
- sv_setpvn(cat, "", 0);
- patcopy = pat;
- while (pat < patend) {
- SV *lengthcode = Nullsv;
-#define NEXTFROM ( lengthcode ? lengthcode : items-- > 0 ? *MARK++ : &PL_sv_no)
- datumtype = *pat++ & 0xFF;
-#ifdef PERL_NATINT_PACK
- natint = 0;
-#endif
- if (isSPACE(datumtype)) {
- patcopy++;
- continue;
- }
-#ifndef PACKED_IS_OCTETS
- if (datumtype == 'U' && pat == patcopy+1)
- SvUTF8_on(cat);
-#endif
- if (datumtype == '#') {
- while (pat < patend && *pat != '\n')
- pat++;
- continue;
- }
- if (*pat == '!') {
- char *natstr = "sSiIlL";
-
- if (strchr(natstr, datumtype)) {
-#ifdef PERL_NATINT_PACK
- natint = 1;
-#endif
- pat++;
- }
- else
- DIE(aTHX_ "'!' allowed only after types %s", natstr);
- }
- if (*pat == '*') {
- len = strchr("@Xxu", datumtype) ? 0 : items;
- pat++;
- }
- else if (isDIGIT(*pat)) {
- len = *pat++ - '0';
- while (isDIGIT(*pat)) {
- len = (len * 10) + (*pat++ - '0');
- if (len < 0)
- DIE(aTHX_ "Repeat count in pack overflows");
- }
- }
- else
- len = 1;
- if (*pat == '/') {
- ++pat;
- if ((*pat != 'a' && *pat != 'A' && *pat != 'Z') || pat[1] != '*')
- DIE(aTHX_ "/ must be followed by a*, A* or Z*");
- lengthcode = sv_2mortal(newSViv(sv_len(items > 0
- ? *MARK : &PL_sv_no)
- + (*pat == 'Z' ? 1 : 0)));
- }
- switch(datumtype) {
- default:
- DIE(aTHX_ "Invalid type in pack: '%c'", (int)datumtype);
- case ',': /* grandfather in commas but with a warning */
- if (commas++ == 0 && ckWARN(WARN_PACK))
- Perl_warner(aTHX_ WARN_PACK,
- "Invalid type in pack: '%c'", (int)datumtype);
- break;
- case '%':
- DIE(aTHX_ "%% may only be used in unpack");
- case '@':
- len -= SvCUR(cat);
- if (len > 0)
- goto grow;
- len = -len;
- if (len > 0)
- goto shrink;
- break;
- case 'X':
- shrink:
- if (SvCUR(cat) < len)
- DIE(aTHX_ "X outside of string");
- SvCUR(cat) -= len;
- *SvEND(cat) = '\0';
- break;
- case 'x':
- grow:
- while (len >= 10) {
- sv_catpvn(cat, null10, 10);
- len -= 10;
- }
- sv_catpvn(cat, null10, len);
- break;
- case 'A':
- case 'Z':
- case 'a':
- fromstr = NEXTFROM;
- aptr = SvPV(fromstr, fromlen);
- if (pat[-1] == '*') {
- len = fromlen;
- if (datumtype == 'Z')
- ++len;
- }
- if (fromlen >= len) {
- sv_catpvn(cat, aptr, len);
- if (datumtype == 'Z')
- *(SvEND(cat)-1) = '\0';
- }
- else {
- sv_catpvn(cat, aptr, fromlen);
- len -= fromlen;
- if (datumtype == 'A') {
- while (len >= 10) {
- sv_catpvn(cat, space10, 10);
- len -= 10;
- }
- sv_catpvn(cat, space10, len);
- }
- else {
- while (len >= 10) {
- sv_catpvn(cat, null10, 10);
- len -= 10;
- }
- sv_catpvn(cat, null10, len);
- }
- }
- break;
- case 'B':
- case 'b':
- {
- register char *str;
- I32 saveitems;
-
- fromstr = NEXTFROM;
- saveitems = items;
- str = SvPV(fromstr, fromlen);
- if (pat[-1] == '*')
- len = fromlen;
- aint = SvCUR(cat);
- SvCUR(cat) += (len+7)/8;
- SvGROW(cat, SvCUR(cat) + 1);
- aptr = SvPVX(cat) + aint;
- if (len > fromlen)
- len = fromlen;
- aint = len;
- items = 0;
- if (datumtype == 'B') {
- for (len = 0; len++ < aint;) {
- items |= *str++ & 1;
- if (len & 7)
- items <<= 1;
- else {
- *aptr++ = items & 0xff;
- items = 0;
- }
- }
- }
- else {
- for (len = 0; len++ < aint;) {
- if (*str++ & 1)
- items |= 128;
- if (len & 7)
- items >>= 1;
- else {
- *aptr++ = items & 0xff;
- items = 0;
- }
- }
- }
- if (aint & 7) {
- if (datumtype == 'B')
- items <<= 7 - (aint & 7);
- else
- items >>= 7 - (aint & 7);
- *aptr++ = items & 0xff;
- }
- str = SvPVX(cat) + SvCUR(cat);
- while (aptr <= str)
- *aptr++ = '\0';
-
- items = saveitems;
- }
- break;
- case 'H':
- case 'h':
- {
- register char *str;
- I32 saveitems;
-
- fromstr = NEXTFROM;
- saveitems = items;
- str = SvPV(fromstr, fromlen);
- if (pat[-1] == '*')
- len = fromlen;
- aint = SvCUR(cat);
- SvCUR(cat) += (len+1)/2;
- SvGROW(cat, SvCUR(cat) + 1);
- aptr = SvPVX(cat) + aint;
- if (len > fromlen)
- len = fromlen;
- aint = len;
- items = 0;
- if (datumtype == 'H') {
- for (len = 0; len++ < aint;) {
- if (isALPHA(*str))
- items |= ((*str++ & 15) + 9) & 15;
- else
- items |= *str++ & 15;
- if (len & 1)
- items <<= 4;
- else {
- *aptr++ = items & 0xff;
- items = 0;
- }
- }
- }
- else {
- for (len = 0; len++ < aint;) {
- if (isALPHA(*str))
- items |= (((*str++ & 15) + 9) & 15) << 4;
- else
- items |= (*str++ & 15) << 4;
- if (len & 1)
- items >>= 4;
- else {
- *aptr++ = items & 0xff;
- items = 0;
- }
- }
- }
- if (aint & 1)
- *aptr++ = items & 0xff;
- str = SvPVX(cat) + SvCUR(cat);
- while (aptr <= str)
- *aptr++ = '\0';
-
- items = saveitems;
- }
- break;
- case 'C':
- case 'c':
- while (len-- > 0) {
- fromstr = NEXTFROM;
- switch (datumtype) {
- case 'C':
- aint = SvIV(fromstr);
- if ((aint < 0 || aint > 255) &&
- ckWARN(WARN_PACK))
- Perl_warner(aTHX_ WARN_PACK,
- "Character in \"C\" format wrapped");
- achar = aint & 255;
- sv_catpvn(cat, &achar, sizeof(char));
- break;
- case 'c':
- aint = SvIV(fromstr);
- if ((aint < -128 || aint > 127) &&
- ckWARN(WARN_PACK))
- Perl_warner(aTHX_ WARN_PACK,
- "Character in \"c\" format wrapped");
- achar = aint & 255;
- sv_catpvn(cat, &achar, sizeof(char));
- break;
- }
- }
- break;
- case 'U':
- while (len-- > 0) {
- fromstr = NEXTFROM;
- auint = SvUV(fromstr);
- SvGROW(cat, SvCUR(cat) + UTF8_MAXLEN + 1);
- SvCUR_set(cat, (char*)uvchr_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':
- while (len-- > 0) {
- fromstr = NEXTFROM;
- afloat = (float)SvNV(fromstr);
- sv_catpvn(cat, (char *)&afloat, sizeof (float));
- }
- break;
- case 'd':
- case 'D':
- while (len-- > 0) {
- fromstr = NEXTFROM;
- adouble = (double)SvNV(fromstr);
- sv_catpvn(cat, (char *)&adouble, sizeof (double));
- }
- break;
- case 'n':
- while (len-- > 0) {
- fromstr = NEXTFROM;
- ashort = (I16)SvIV(fromstr);
-#ifdef HAS_HTONS
- ashort = PerlSock_htons(ashort);
-#endif
- CAT16(cat, &ashort);
- }
- break;
- case 'v':
- while (len-- > 0) {
- fromstr = NEXTFROM;
- ashort = (I16)SvIV(fromstr);
-#ifdef HAS_HTOVS
- ashort = htovs(ashort);
-#endif
- CAT16(cat, &ashort);
- }
- 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':
-#if SHORTSIZE != SIZE16
- if (natint) {
- short ashort;
-
- 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':
- while (len-- > 0) {
- fromstr = NEXTFROM;
- auint = SvUV(fromstr);
- sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
- }
- break;
- case 'w':
- while (len-- > 0) {
- fromstr = NEXTFROM;
- adouble = Perl_floor(SvNV(fromstr));
-
- if (adouble < 0)
- DIE(aTHX_ "Cannot compress negative numbers");
-
- if (
-#if UVSIZE > 4 && UVSIZE >= NVSIZE
- adouble <= 0xffffffff
-#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);
-
- do {
- *--in = (auv & 0x7f) | 0x80;
- auv >>= 7;
- } while (auv);
- buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
- sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
- }
- else if (SvPOKp(fromstr)) { /* decimal string arithmetics */
- char *from, *result, *in;
- SV *norm;
- STRLEN len;
- bool done;
-
- /* Copy string and check for compliance */
- from = SvPV(fromstr, len);
- if ((norm = is_an_int(from, len)) == NULL)
- DIE(aTHX_ "can compress only unsigned integer");
-
- New('w', result, len, char);
- in = result + len;
- done = FALSE;
- while (!done)
- *--in = div128(norm, &done) | 0x80;
- result[len - 1] &= 0x7F; /* clear continue bit */
- sv_catpvn(cat, in, (result + len) - in);
- Safefree(result);
- SvREFCNT_dec(norm); /* free norm */
- }
- else if (SvNOKp(fromstr)) {
- char buf[sizeof(double) * 2]; /* 8/7 <= 2 */
- char *in = buf + sizeof(buf);
-
- do {
- double next = floor(adouble / 128);
- *--in = (unsigned char)(adouble - (next * 128)) | 0x80;
- if (in <= buf) /* this cannot happen ;-) */
- DIE(aTHX_ "Cannot compress integer");
- in--;
- adouble = next;
- } while (adouble > 0);
- buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
- sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
- }
- else
- DIE(aTHX_ "Cannot compress non integer");
- }
- break;
- case 'i':
- while (len-- > 0) {
- fromstr = NEXTFROM;
- aint = SvIV(fromstr);
- sv_catpvn(cat, (char*)&aint, sizeof(int));
- }
- break;
- case 'N':
- while (len-- > 0) {
- fromstr = NEXTFROM;
- aulong = SvUV(fromstr);
-#ifdef HAS_HTONL
- aulong = PerlSock_htonl(aulong);
-#endif
- CAT32(cat, &aulong);
- }
- break;
- case 'V':
- while (len-- > 0) {
- fromstr = NEXTFROM;
- aulong = SvUV(fromstr);
-#ifdef HAS_HTOVL
- aulong = htovl(aulong);
-#endif
- CAT32(cat, &aulong);
- }
- break;
- case 'L':
-#if LONGSIZE != SIZE32
- if (natint) {
- unsigned long aulong;
-
- 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':
-#if LONGSIZE != SIZE32
- if (natint) {
- long along;
-
- 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 = (Uquad_t)SvUV(fromstr);
- sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
- }
- break;
- case 'q':
- while (len-- > 0) {
- fromstr = NEXTFROM;
- aquad = (Quad_t)SvIV(fromstr);
- sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
- }
- break;
-#endif
- case 'P':
- len = 1; /* assume SV is correct length */
- /* FALL THROUGH */
- case 'p':
- while (len-- > 0) {
- fromstr = NEXTFROM;
- 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 (ckWARN(WARN_PACK) && (SvTEMP(fromstr)
- || (SvPADTMP(fromstr)
- && !SvREADONLY(fromstr))))
- {
- Perl_warner(aTHX_ WARN_PACK,
- "Attempt to pack pointer to temporary value");
- }
- if (SvPOK(fromstr) || SvNIOK(fromstr))
- aptr = SvPV(fromstr,n_a);
- else
- aptr = SvPV_force(fromstr,n_a);
- }
- sv_catpvn(cat, (char*)&aptr, sizeof(char*));
- }
- break;
- case 'u':
- fromstr = NEXTFROM;
- aptr = SvPV(fromstr, fromlen);
- SvGROW(cat, fromlen * 4 / 3);
- if (len <= 1)
- len = 45;
- else
- len = len / 3 * 3;
- while (fromlen > 0) {
- I32 todo;
-
- if (fromlen > len)
- todo = len;
- else
- todo = fromlen;
- doencodes(cat, aptr, todo);
- fromlen -= todo;
- aptr += todo;
- }
- break;
- }
- }
- SvSETMAGIC(cat);
- SP = ORIGMARK;
- PUSHs(cat);
- RETURN;
-}
-#undef NEXTFROM
-
-
PP(pp_split)
{
dSP; dTARG;
#endif
if (!pm || !s)
DIE(aTHX_ "panic: pp_split");
- rx = pm->op_pmregexp;
+ rx = PM_GETRE(pm);
TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
(pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
+ PL_reg_match_utf8 = do_utf8;
+
if (pm->op_pmreplroot) {
#ifdef USE_ITHREADS
- ary = GvAVn((GV*)PL_curpad[(PADOFFSET)pm->op_pmreplroot]);
+ ary = GvAVn((GV*)PL_curpad[INT2PTR(PADOFFSET, pm->op_pmreplroot)]);
#else
ary = GvAVn((GV*)pm->op_pmreplroot);
#endif
}
else if (gimme != G_ARRAY)
-#ifdef USE_THREADS
+#ifdef USE_5005THREADS
ary = (AV*)PL_curpad[0];
#else
ary = GvAVn(PL_defgv);
-#endif /* USE_THREADS */
+#endif /* USE_5005THREADS */
else
ary = Nullav;
if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
for (i = 1; i <= rx->nparens; i++) {
s = rx->startp[i] + orig;
m = rx->endp[i] + orig;
- if (m && s) {
+
+ /* japhy (07/27/01) -- the (m && s) test doesn't catch
+ parens that didn't match -- they should be set to
+ undef, not the empty string */
+ if (m >= orig && s >= orig) {
dstr = NEWSV(33, m-s);
sv_setpvn(dstr, s, m-s);
}
else
- dstr = NEWSV(33, 0);
+ dstr = &PL_sv_undef; /* undef, not "" */
if (make_mortal)
sv_2mortal(dstr);
if (do_utf8)
RETPUSHUNDEF;
}
-#ifdef USE_THREADS
+#ifdef USE_5005THREADS
void
Perl_unlock_condpair(pTHX_ void *svv)
{
MgOWNER(mg) = 0;
COND_SIGNAL(MgOWNERCONDP(mg));
DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": unlock 0x%"UVxf"\n",
- PTR2UV(thr), PTR2UV(svv));)
+ PTR2UV(thr), PTR2UV(svv)));
MUTEX_UNLOCK(MgMUTEXP(mg));
}
-#endif /* USE_THREADS */
+#endif /* USE_5005THREADS */
PP(pp_lock)
{
dSP;
dTOPss;
SV *retsv = sv;
-#ifdef USE_THREADS
+#ifdef USE_5005THREADS
sv_lock(sv);
-#endif /* USE_THREADS */
+#endif /* USE_5005THREADS */
+#ifdef USE_ITHREADS
+ shared_sv *ssv = Perl_sharedsv_find(aTHX_ sv);
+ if(ssv)
+ Perl_sharedsv_lock(aTHX_ ssv);
+#endif /* USE_ITHREADS */
if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
|| SvTYPE(retsv) == SVt_PVCV) {
retsv = refto(retsv);
PP(pp_threadsv)
{
-#ifdef USE_THREADS
+#ifdef USE_5005THREADS
dSP;
EXTEND(SP, 1);
if (PL_op->op_private & OPpLVAL_INTRO)
RETURN;
#else
DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
-#endif /* USE_THREADS */
+#endif /* USE_5005THREADS */
}
projects / p5sagit/p5-mst-13.2.git / blobdiff