pp.c revision 7c478bd95313f5f23a4c958a745db2134aa03244
/* pp.c
*
* Copyright (c) 1991-2001, 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.
*
*/
/*
* "It's a big house this, and very peculiar. Always a bit more to discover,
* and no knowing what you'll find around a corner. And Elves, sir!" --Samwise
*/
#include "EXTERN.h"
#define PERL_IN_PP_C
#include "perl.h"
/*
* 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
/*
*
* 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 */
# define PERL_NATINT_PACK
#endif
# if BYTEORDER == 0x12345678
# define OFF16(p) (char*)(p)
# define OFF32(p) (char*)(p)
# else
# if BYTEORDER == 0x87654321
# else
# endif
# endif
#else
#endif
/* variations on pp_null */
/* XXX I can't imagine anyone who doesn't have this actually _needs_
it, since pid_t is an integral type.
--AD 2/20/1998
*/
#ifdef NEED_GETPID_PROTO
#endif
{
dSP;
}
{
return NORMAL;
}
/* Pushy stuff. */
{
} else if (LVRET) {
}
U32 i;
for (i=0; i < maxarg; i++) {
}
}
else {
}
}
else {
}
}
{
else if (LVRET) {
}
}
else
}
}
{
}
/* Translations. */
{
(void)SvREFCNT_inc(sv);
}
}
else {
char *sym;
if (SvGMAGICAL(sv)) {
goto wasref;
}
/* If this is a 'my' scalar and flag is set then vivify
* NI-S 1999/05/07
*/
char *name;
}
else {
}
SvSETMAGIC(sv);
goto wasref;
}
if (ckWARN(WARN_UNINITIALIZED))
}
{
if (!sv
{
}
}
else {
}
}
}
}
{
case SVt_PVAV:
case SVt_PVHV:
case SVt_PVCV:
}
}
else {
char *sym;
if (SvGMAGICAL(sv)) {
goto wasref;
}
if (ckWARN(WARN_UNINITIALIZED))
}
{
if (!gv
{
}
}
else {
}
}
}
}
}
{
dSP;
if (!sv) {
}
}
{
}
}
}
else {
sv_pos_b2u(sv, &i);
}
}
}
}
{
dSP;
/* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
/* (But not in defined().) */
if (cv) {
}
}
else
}
{
dSP;
ret = &PL_sv_undef;
int code;
if (code < 0) { /* Overridable. */
int i = 0, n = 0, seen_question = 0;
while (i < MAXO) { /* The slow way. */
{
goto found;
}
i++;
}
goto nonesuch; /* Should not happen... */
while (oa) {
if (oa & OA_OPTIONAL) {
seen_question = 1;
str[n++] = ';';
}
goto set; /* XXXX system, exec */
str[n++] = '\\';
}
/* What to do with R ((un)tie, tied, (sys)read, recv)? */
}
str[n++] = '\0';
}
else if (code) /* Non-Overridable */
goto set;
else { /* None such */
}
}
}
set:
}
{
dSP;
}
{
dSP;
}
{
else
*MARK = &PL_sv_undef;
}
}
{
sv = &PL_sv_undef;
else
(void)SvREFCNT_inc(sv);
}
SvTEMP_off(sv);
(void)SvREFCNT_inc(sv);
}
else {
SvTEMP_off(sv);
(void)SvREFCNT_inc(sv);
}
rv = sv_newmortal();
return rv;
}
{
char *pv;
}
{
dSP;
if (MAXARG == 1)
else {
"Explicit blessing to '' (assuming package main)");
}
}
{
char *elem;
dSP;
{
case 'A':
break;
case 'C':
break;
case 'F':
break;
case 'G':
break;
case 'H':
break;
case 'I':
break;
case 'N':
break;
case 'P':
break;
case 'S':
break;
}
if (tmpRef)
if (sv)
sv_2mortal(sv);
else
sv = &PL_sv_undef;
}
/* Pattern matching */
{
register unsigned char *s;
if (sv == PL_lastscream) {
}
else {
if (PL_lastscream) {
}
}
if (pos <= 0)
if (pos > PL_maxscream) {
if (PL_maxscream < 0) {
}
else {
}
}
*sfirst++ = -1;
sfirst -= 256;
while (--pos >= 0) {
else
}
}
{
else {
}
TARG = sv_newmortal();
}
/* Lvalue operators. */
{
}
{
}
{
}
{
}
{
dSP;
case SVt_PVAV:
break;
case SVt_PVHV:
break;
case SVt_PVCV:
break;
default:
if (SvGMAGICAL(sv))
}
}
{
dSP;
if (!PL_op->op_private) {
}
if (!sv)
if (SvTHINKFIRST(sv))
case SVt_NULL:
break;
case SVt_PVAV:
break;
case SVt_PVHV:
break;
case SVt_PVCV:
/* FALL THROUGH */
case SVt_PVFM:
{
/* let user-undef'd sub keep its identity */
}
break;
case SVt_PVGV:
else {
GvMULTI_on(sv);
}
break;
default:
}
SvSETMAGIC(sv);
}
}
{
dSP;
{
}
else
return NORMAL;
}
{
{
}
else
return NORMAL;
}
{
{
}
else
return NORMAL;
}
/* Ordinary operators. */
{
{
}
}
{
{
}
}
{
{
if (right == 0.0)
#ifdef SLOPPYDIVIDE
/* insure that 20./5. == 4. */
{
IV k;
value = k;
}
else {
}
}
#else
#endif
}
}
{
{
bool left_neg;
bool right_neg;
bool use_double = 0;
}
else {
use_double = 1;
if (right_neg)
}
}
else {
if (!use_double) {
use_double = 1;
}
if (left_neg)
}
if (use_double) {
#if 1
/* Somehow U_V is pessimized even if CASTFLAGS is 0 */
# if CASTFLAGS & 2
# else
# 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 */
goto do_uv;
}
#endif
/* Backward-compatibility clause: */
if (!dright)
if (right_neg)
}
else {
if (!right)
if (right_neg) {
/* XXX may warn: unary minus operator applied to unsigned type */
/* could change -foo to be (~foo)+1 instead */
else
}
else
}
}
}
{
{
if (count > 1) {
if (*SP)
SvTEMP_off((*SP));
SP--;
}
MARK++;
}
else if (count <= 0)
}
else { /* Note: mark already snarfed by pp_list */
bool isutf;
if (count != 1) {
if (count < 1)
else {
}
}
if (isutf)
(void)SvPOK_only_UTF8(TARG);
else
(void)SvPOK_only(TARG);
}
}
}
{
{
}
}
{
{
}
else {
}
}
}
{
{
}
else {
}
}
}
{
{
}
}
{
{
}
}
{
{
}
}
{
{
}
}
{
#ifndef NV_PRESERVES_UV
SP--;
}
#endif
{
}
}
{
#ifndef NV_PRESERVES_UV
}
#endif
{
#ifdef Perl_isnan
SETs(&PL_sv_undef);
}
#else
value = 0;
value = -1;
value = 1;
else {
SETs(&PL_sv_undef);
}
#endif
}
}
{
{
int cmp = (IN_LOCALE_RUNTIME
}
}
{
{
int cmp = (IN_LOCALE_RUNTIME
}
}
{
{
int cmp = (IN_LOCALE_RUNTIME
}
}
{
{
int cmp = (IN_LOCALE_RUNTIME
}
}
{
{
}
}
{
{
}
}
{
{
int cmp = (IN_LOCALE_RUNTIME
}
}
{
{
SETi(i);
}
else {
SETu(u);
}
}
else {
}
}
}
{
{
SETi(i);
}
else {
SETu(u);
}
}
else {
}
}
}
{
{
SETi(i);
}
else {
SETu(u);
}
}
else {
}
}
}
{
{
if (SvGMAGICAL(sv))
}
}
}
}
}
if (isIDFIRST(*s)) {
}
else if (*s == '+' || *s == '-') {
}
}
else
}
else
}
}
{
return NORMAL;
}
{
{
SETi(i);
}
else {
SETu(u);
}
}
else {
/* Calculate exact length, let's not estimate. */
STRLEN l;
nchar++;
if (c > 0xff)
nwide++;
}
/* Now rewind strings and write them. */
if (nwide) {
}
*result = '\0';
}
else {
*result++ = ~c;
}
*result = '\0';
}
}
#ifdef LIBERAL
{
register long *tmpl;
}
#endif
}
}
}
/* integer versions of some of the above */
{
{
}
}
{
{
if (value == 0)
}
}
{
{
if (!right)
}
}
{
{
}
}
{
{
}
}
{
{
}
}
{
{
}
}
{
{
}
}
{
{
}
}
{
{
}
}
{
{
}
}
{
{
value = 1;
value = -1;
else
value = 0;
}
}
{
}
/* High falutin' math. */
{
{
}
}
{
{
}
}
{
{
}
}
/* Support Configure command-line overrides for rand() functions.
After 5.005, perhaps we should replace this by Configure support
for drand48(), random(), or rand(). For 5.005, though, maintain
compatibility by calling rand() but allow the user to override it.
See INSTALL for details. --Andy Dougherty 15 July 1998
*/
/* 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
{
if (MAXARG < 1)
value = 1.0;
else
if (value == 0.0)
value = 1.0;
if (!PL_srand_called) {
}
}
{
dSP;
if (MAXARG < 1)
else
}
{
/*
* This is really just a quick hack which grabs various garbage
* values. It really should be a real hash algorithm which
* spreads the effect of every input bit onto every output bit,
* if someone who knows about such things would bother to write it.
* Might be a good idea to add that function to CORE as well.
* No numbers below come from careful analysis or anything here,
* except they are primes and SEED_C1 > 1E6 to get a full-width
* value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
* probably be bigger too.
*/
#if RANDBITS > 16
# define SEED_C1 1000003
#define SEED_C4 73819
#else
# define SEED_C1 25747
#define SEED_C4 20639
#endif
#define SEED_C2 3
#define SEED_C3 269
#define SEED_C5 26107
#ifndef PERL_NO_DEV_RANDOM
int fd;
#endif
U32 u;
#ifdef VMS
# include <starlet.h>
/* when[] = (low 32 bits, high 32 bits) of time since epoch
* in 100-ns units, typically incremented ever 10 ms. */
unsigned int when[2];
#else
# ifdef HAS_GETTIMEOFDAY
# else
# endif
#endif
/* This test is an escape hatch, this symbol isn't set by Configure. */
#ifndef PERL_NO_DEV_RANDOM
#ifndef PERL_RANDOM_DEVICE
* 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
if (fd != -1) {
if (PerlLIO_read(fd, &u, sizeof u) != sizeof u)
u = 0;
if (u)
return u;
}
#endif
#ifdef VMS
#else
# ifdef HAS_GETTIMEOFDAY
# else
# endif
#endif
#ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
#endif
return u;
}
{
{
}
}
{
{
if (value <= 0.0) {
}
}
}
{
{
if (value < 0.0) {
}
}
}
{
{
}
else {
if (value >= 0.0) {
#if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE)
#else
#endif
}
else {
#if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE)
#else
#endif
}
else
}
}
}
{
{
if (iv < 0)
}
else {
if (value < 0.0)
}
}
}
{
char *tmps;
}
{
char *tmps;
if (*tmps == '0')
if (*tmps == 'x')
else if (*tmps == 'b')
else
}
/* String stuff. */
{
else
}
{
char *tmps;
char *repl = 0;
bool repl_need_utf8_upgrade = FALSE;
bool repl_is_utf8 = FALSE;
if (num_args > 2) {
if (num_args > 3) {
}
}
if (repl_sv) {
if (repl_is_utf8) {
}
}
if (utf8_curlen == curlen)
utf8_curlen = 0;
else
}
else
utf8_curlen = 0;
if (num_args > 2) {
if (len < 0) {
if (rem < 0)
rem = 0;
}
}
}
else {
if (num_args < 3)
else if (len >= 0) {
}
else {
}
if (pos < 0)
pos = 0;
}
if (fail < 0) {
if (ckWARN(WARN_SUBSTR))
}
else {
if (utf8_curlen)
if (utf8_curlen)
if (repl) {
if (repl_need_utf8_upgrade) {
}
if (repl_is_utf8)
if (repl_sv_copy)
}
else if (lvalue) { /* it's an lvalue! */
if (!SvGMAGICAL(sv)) {
if (ckWARN(WARN_SUBSTR))
"Attempt to use reference as lvalue in substr");
}
(void)SvPOK_only_UTF8(sv);
else
}
}
}
}
}
}
{
if (lvalue) { /* it's an lvalue! */
}
}
}
}
{
char *tmps;
char *tmps2;
if (MAXARG < 3)
offset = 0;
else
if (offset < 0)
offset = 0;
retval = -1;
else
}
{
char *tmps;
char *tmps2;
if (MAXARG >= 3)
if (MAXARG < 3)
else {
}
if (offset < 0)
offset = 0;
retval = -1;
else
}
{
}
{
}
{
char *tmps;
*tmps = '\0';
(void)SvPOK_only(TARG);
}
*tmps = '\0';
(void)SvPOK_only(TARG);
}
{
#ifdef HAS_CRYPT
#ifdef FCRYPT
#else
#endif
#else
"The crypt() function is unimplemented due to excessive paranoia.");
#endif
}
{
dSP;
register U8 *s;
if (IN_LOCALE_RUNTIME) {
}
else
uv = toTITLE_utf8(s);
}
else {
}
}
else {
}
if (*s) {
if (IN_LOCALE_RUNTIME) {
*s = toUPPER_LC(*s);
}
else
*s = toUPPER(*s);
}
}
if (SvSMAGICAL(sv))
}
{
dSP;
register U8 *s;
if (IN_LOCALE_RUNTIME) {
}
else
uv = toLOWER_utf8(s);
}
else {
}
}
else {
}
if (*s) {
if (IN_LOCALE_RUNTIME) {
*s = toLOWER_LC(*s);
}
else
*s = toLOWER(*s);
}
}
if (SvSMAGICAL(sv))
}
{
dSP;
register U8 *s;
register U8 *d;
if (!len) {
}
else {
(void)SvPOK_only(TARG);
if (IN_LOCALE_RUNTIME) {
while (s < send) {
s += ulen;
}
}
else {
while (s < send) {
d = uv_to_utf8(d, toUPPER_utf8( s ));
s += UTF8SKIP(s);
}
}
*d = '\0';
}
}
else {
}
if (len) {
if (IN_LOCALE_RUNTIME) {
for (; s < send; s++)
*s = toUPPER_LC(*s);
}
else {
for (; s < send; s++)
*s = toUPPER(*s);
}
}
}
if (SvSMAGICAL(sv))
}
{
dSP;
register U8 *s;
register U8 *d;
if (!len) {
}
else {
(void)SvPOK_only(TARG);
if (IN_LOCALE_RUNTIME) {
while (s < send) {
s += ulen;
}
}
else {
while (s < send) {
d = uv_to_utf8(d, toLOWER_utf8(s));
s += UTF8SKIP(s);
}
}
*d = '\0';
}
}
else {
}
if (len) {
if (IN_LOCALE_RUNTIME) {
for (; s < send; s++)
*s = toLOWER_LC(*s);
}
else {
for (; s < send; s++)
*s = toLOWER(*s);
}
}
}
if (SvSMAGICAL(sv))
}
{
register char *d;
if (len) {
while (len) {
if (UTF8_IS_CONTINUED(*s)) {
while (ulen--)
*d++ = *s++;
}
else {
if (!isALNUM(*s))
*d++ = '\\';
*d++ = *s++;
len--;
}
}
}
else {
while (len--) {
if (!isALNUM(*s))
*d++ = '\\';
*d++ = *s++;
}
}
*d = '\0';
(void)SvPOK_only_UTF8(TARG);
}
else
if (SvSMAGICAL(TARG))
}
/* Arrays. */
{
}
}
if (elem > 0)
if (lval) {
}
}
}
}
}
/* Associative arrays. */
{
dSP;
/* might clobber stack_sp */
if (entry) {
/* might clobber stack_sp */
}
}
}
{
return do_kv();
}
{
return do_kv();
}
{
dSP;
}
}
}
}
else { /* pseudo-hash element */
}
}
}
else
if (discard)
}
}
else {
else
}
else
if (!sv)
sv = &PL_sv_undef;
if (!discard)
}
}
{
dSP;
if (cv)
}
}
}
}
else {
}
}
{
if (realhv) {
}
else {
}
if (lval) {
}
}
}
}
}
}
/* List operators. */
{
else
*MARK = &PL_sv_undef;
}
}
{
dSP;
if (ix < 0)
else
*firstlelem = &PL_sv_undef;
else
SP = firstlelem;
}
if (max == 0) {
}
if (ix < 0)
else
*lelem = &PL_sv_undef;
else {
*lelem = &PL_sv_undef;
}
}
if (is_something_there)
else
}
{
}
{
}
}
{
register I32 i;
}
SP++;
if (offset < 0)
else
if (offset < 0)
if (length < 0) {
if (length < 0)
length = 0;
}
}
else
}
else {
offset = 0;
}
if (after < 0) { /* not that much array */
after = 0;
}
/* At this point, MARK .. SP-1 is our new LIST */
if (diff < 0) { /* shrinking the area */
if (newlen) {
}
dst++;
}
}
}
else {
sv_2mortal(*MARK);
}
}
/* pull up or down? */
if (offset) { /* esp. if nothing to pull */
for (i = offset; i > 0; i--) /* can't trust Copy */
}
}
else {
if (after) { /* anything to pull down? */
}
/* avoid later double free */
}
i = -diff;
while (i)
dst[--i] = &PL_sv_undef;
if (newlen) {
}
}
}
else { /* no, expanding (or same) */
if (length) {
}
if (diff > 0) { /* expanding */
/* push up or down? */
if (offset) {
}
}
else {
if (after) {
for (i = after; i; i--) {
}
}
}
}
}
if (length) {
dst++;
}
}
}
}
else if (length--) {
sv_2mortal(*MARK);
while (length-- > 0)
}
}
else
*MARK = &PL_sv_undef;
}
}
{
}
else {
/* Why no pre-extend of ary here ? */
if (*MARK)
}
}
}
{
dSP;
(void)sv_2mortal(sv);
}
{
dSP;
if (!sv)
(void)sv_2mortal(sv);
}
{
register I32 i = 0;
}
else {
}
}
}
{
MARK++;
}
/* safe as long as stack cannot get extended in the above */
}
else {
register char *up;
register char *down;
else
if (len > 1) {
while (s < send) {
if (UTF8_IS_ASCII(*s)) {
s++;
continue;
}
else {
if (!utf8_to_uv_simple(s, 0))
break;
up = (char*)s;
s += UTF8SKIP(s);
down = (char*)(s - 1);
/* reverse this character */
}
}
}
}
}
(void)SvPOK_only_UTF8(TARG);
}
}
}
{
char *t;
U32 i = 0;
}
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
#else
/*
Some other sort of character set - use memchr() so we don't match
the null byte.
*/
#endif
{
dSP;
char *strbeg = s;
register char *str;
/* These must not be in registers: */
short ashort;
int aint;
long along;
#ifdef HAS_QUAD
#endif
unsigned int auint;
#ifdef HAS_QUAD
#endif
char *aptr;
float afloat;
double adouble;
int commas = 0;
int star;
#ifdef PERL_NATINT_PACK
int natint; /* native integer */
int unatint; /* unsigned native integer */
#endif
/*SUPPRESS 530*/
patend++;
patend++;
}
else
patend++;
}
#ifdef PERL_NATINT_PACK
natint = 0;
#endif
continue;
if (datumtype == '#') {
pat++;
continue;
}
if (*pat == '!') {
char *natstr = "sSiIlL";
#ifdef PERL_NATINT_PACK
natint = 1;
#endif
pat++;
}
else
}
star = 0;
len = 1;
else if (*pat == '*') {
pat++;
star = 1;
}
if (len < 0)
}
}
else
switch(datumtype) {
default:
case ',': /* grandfather in commas but with a warning */
"Invalid type in unpack: '%c'", (int)datumtype);
break;
case '%':
len = 16;
culong = 0;
cdouble = 0;
goto reparse;
break;
case '@':
break;
case 'X':
s -= len;
break;
case 'x':
s += len;
break;
case '/':
if (*pat == '*')
pat++; /* ignore '*' for compatibility with pack */
star = 0;
goto redo_switch;
case 'A':
case 'Z':
case 'a':
if (checksum)
goto uchar_checksum;
s += len;
aptr = s; /* borrow register */
while (*s)
s++;
}
else { /* 'A' strips both nulls and spaces */
s--;
*++s = '\0';
}
s = aptr; /* unborrow register */
}
break;
case 'B':
case 'b':
if (checksum) {
if (!PL_bitcount) {
}
}
while (len >= 8) {
culong += PL_bitcount[*(unsigned char*)s++];
len -= 8;
}
if (len) {
bits = *s;
if (datumtype == 'b') {
while (len-- > 0) {
bits >>= 1;
}
}
else {
while (len-- > 0) {
bits <<= 1;
}
}
}
break;
}
if (datumtype == 'b') {
bits >>= 1;
else
bits = *s++;
}
}
else {
if (len & 7)
bits <<= 1;
else
bits = *s++;
}
}
*str = '\0';
break;
case 'H':
case 'h':
if (datumtype == 'h') {
if (len & 1)
bits >>= 4;
else
bits = *s++;
}
}
else {
if (len & 1)
bits <<= 4;
else
bits = *s++;
}
}
*str = '\0';
break;
case 'c':
if (checksum) {
while (len-- > 0) {
aint = *s++;
aint -= 256;
}
}
else {
while (len-- > 0) {
aint = *s++;
aint -= 256;
}
}
break;
case 'C':
if (checksum) {
while (len-- > 0) {
auint = *s++ & 255;
}
}
else {
while (len-- > 0) {
auint = *s++ & 255;
}
}
break;
case 'U':
if (checksum) {
s += along;
if (checksum > 32)
else
}
}
else {
s += along;
}
}
break;
case 's':
#else
#endif
if (checksum) {
if (natint) {
short ashort;
while (len-- > 0) {
s += sizeof(short);
}
}
else
#endif
{
while (len-- > 0) {
if (ashort > 32767)
ashort -= 65536;
#endif
s += SIZE16;
}
}
}
else {
if (natint) {
short ashort;
while (len-- > 0) {
s += sizeof(short);
}
}
else
#endif
{
while (len-- > 0) {
if (ashort > 32767)
ashort -= 65536;
#endif
s += SIZE16;
}
}
}
break;
case 'v':
case 'n':
case 'S':
#else
#endif
if (checksum) {
if (unatint) {
unsigned short aushort;
while (len-- > 0) {
s += sizeof(unsigned short);
}
}
else
#endif
{
while (len-- > 0) {
s += SIZE16;
#ifdef HAS_NTOHS
if (datumtype == 'n')
#endif
#ifdef HAS_VTOHS
if (datumtype == 'v')
#endif
}
}
}
else {
if (unatint) {
unsigned short aushort;
while (len-- > 0) {
s += sizeof(unsigned short);
}
}
else
#endif
{
while (len-- > 0) {
s += SIZE16;
#ifdef HAS_NTOHS
if (datumtype == 'n')
#endif
#ifdef HAS_VTOHS
if (datumtype == 'v')
#endif
}
}
}
break;
case 'i':
if (checksum) {
while (len-- > 0) {
s += sizeof(int);
if (checksum > 32)
else
}
}
else {
while (len-- > 0) {
s += sizeof(int);
#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) ?
#endif
}
}
break;
case 'I':
if (checksum) {
while (len-- > 0) {
s += sizeof(unsigned int);
if (checksum > 32)
else
}
}
else {
while (len-- > 0) {
s += sizeof(unsigned int);
#ifdef __osf__
/* Without the dummy below unpack("I", pack("I",0xFFFFFFFF))
* returns 1.84467440737096e+19 instead of 0xFFFFFFFF.
* See details few lines earlier. */
(auint) ?
#endif
}
}
break;
case 'l':
#else
#endif
if (checksum) {
if (natint) {
while (len-- > 0) {
s += sizeof(long);
if (checksum > 32)
else
}
}
else
#endif
{
while (len-- > 0) {
#endif
if (along > 2147483647)
along -= 4294967296;
#endif
s += SIZE32;
if (checksum > 32)
else
}
}
}
else {
if (natint) {
while (len-- > 0) {
s += sizeof(long);
}
}
else
#endif
{
while (len-- > 0) {
#endif
if (along > 2147483647)
along -= 4294967296;
#endif
s += SIZE32;
}
}
}
break;
case 'V':
case 'N':
case 'L':
#else
#endif
if (checksum) {
if (unatint) {
unsigned long aulong;
while (len-- > 0) {
s += sizeof(unsigned long);
if (checksum > 32)
else
}
}
else
#endif
{
while (len-- > 0) {
s += SIZE32;
#ifdef HAS_NTOHL
if (datumtype == 'N')
#endif
#ifdef HAS_VTOHL
if (datumtype == 'V')
#endif
if (checksum > 32)
else
}
}
}
else {
if (unatint) {
unsigned long aulong;
while (len-- > 0) {
s += sizeof(unsigned long);
}
}
else
#endif
{
while (len-- > 0) {
s += SIZE32;
#ifdef HAS_NTOHL
if (datumtype == 'N')
#endif
#ifdef HAS_VTOHL
if (datumtype == 'V')
#endif
}
}
}
break;
case 'p':
while (len-- > 0) {
if (sizeof(char*) > strend - s)
break;
else {
s += sizeof(char*);
}
if (aptr)
}
break;
case 'w':
{
if (UTF8_IS_ASCII(*s++)) {
bytes = 0;
len--;
auv = 0;
}
char *t;
while (s < strend) {
if (!(*s++ & 0x80)) {
bytes = 0;
break;
}
}
while (*t == '0')
t++;
len--;
auv = 0;
}
}
}
break;
case 'P':
if (sizeof(char*) > strend - s)
break;
else {
s += sizeof(char*);
}
if (aptr)
break;
#ifdef HAS_QUAD
case 'q':
while (len-- > 0) {
aquad = 0;
else {
s += sizeof(Quad_t);
}
else
}
break;
case 'Q':
while (len-- > 0) {
auquad = 0;
else {
s += sizeof(Uquad_t);
}
else
}
break;
#endif
/* float and double added gnb@melba.bby.oz.au 22/11/89 */
case 'f':
case 'F':
if (checksum) {
while (len-- > 0) {
s += sizeof(float);
}
}
else {
while (len-- > 0) {
s += sizeof(float);
}
}
break;
case 'd':
case 'D':
if (checksum) {
while (len-- > 0) {
s += sizeof(double);
}
}
else {
while (len-- > 0) {
s += sizeof(double);
}
}
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)
/*
* Because ' ' and '`' map to the same value,
* we need to decode them both the same.
*/
PL_uudmap[' '] = 0;
}
if (along)
I32 a, b, c, d;
char hunk[4];
while (len > 0) {
else
a = 0;
else
b = 0;
else
c = 0;
else
d = 0;
len -= 3;
}
if (*s == '\n')
s++;
else if (s[1] == '\n') /* possible checksum byte */
s += 2;
}
break;
}
if (checksum) {
adouble = 1.0;
while (checksum >= 16) {
checksum -= 16;
adouble *= 65536.0;
}
while (checksum >= 4) {
checksum -= 4;
adouble *= 16.0;
}
while (checksum--)
adouble *= 2.0;
while (cdouble < 0.0)
}
else {
if (checksum < 32) {
}
}
checksum = 0;
}
}
PUSHs(&PL_sv_undef);
}
STATIC void
{
char hunk[5];
while (len > 2) {
s += 3;
len -= 3;
}
if (len > 0) {
}
}
{
bool skip = 1;
bool ignore = 0;
while (*s) {
switch (*s) {
case ' ':
break;
case '+':
if (!skip) {
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:
return (NULL);
}
s++;
}
*(out++) = '\0';
return (result);
}
/* pnum must be '\0' terminated */
STATIC int
{
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';
return (m);
}
{
char *patcopy;
/*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;
int aint;
unsigned int auint;
#ifdef HAS_QUAD
#endif
char *aptr;
float afloat;
double adouble;
int commas = 0;
#ifdef PERL_NATINT_PACK
int natint; /* native integer */
#endif
MARK++;
#ifdef PERL_NATINT_PACK
natint = 0;
#endif
patcopy++;
continue;
}
if (datumtype == '#') {
pat++;
continue;
}
if (*pat == '!') {
char *natstr = "sSiIlL";
#ifdef PERL_NATINT_PACK
natint = 1;
#endif
pat++;
}
else
}
if (*pat == '*') {
pat++;
}
if (len < 0)
}
}
else
len = 1;
if (*pat == '/') {
++pat;
}
switch(datumtype) {
default:
case ',': /* grandfather in commas but with a warning */
"Invalid type in pack: '%c'", (int)datumtype);
break;
case '%':
case '@':
if (len > 0)
goto grow;
if (len > 0)
goto shrink;
break;
case 'X':
break;
case 'x':
grow:
while (len >= 10) {
len -= 10;
}
break;
case 'A':
case 'Z':
case 'a':
if (datumtype == 'Z')
++len;
}
if (datumtype == 'Z')
}
else {
if (datumtype == 'A') {
while (len >= 10) {
len -= 10;
}
}
else {
while (len >= 10) {
len -= 10;
}
}
}
break;
case 'B':
case 'b':
{
register char *str;
items = 0;
if (datumtype == 'B') {
if (len & 7)
items <<= 1;
else {
items = 0;
}
}
}
else {
if (*str++ & 1)
items |= 128;
if (len & 7)
items >>= 1;
else {
items = 0;
}
}
}
if (aint & 7) {
if (datumtype == 'B')
else
}
*aptr++ = '\0';
}
break;
case 'H':
case 'h':
{
register char *str;
items = 0;
if (datumtype == 'H') {
else
if (len & 1)
items <<= 4;
else {
items = 0;
}
}
}
else {
else
if (len & 1)
items >>= 4;
else {
items = 0;
}
}
}
if (aint & 1)
*aptr++ = '\0';
}
break;
case 'C':
case 'c':
while (len-- > 0) {
}
break;
case 'U':
while (len-- > 0) {
}
break;
/* Float and double added by gnb@melba.bby.oz.au 22/11/89 */
case 'f':
case 'F':
while (len-- > 0) {
}
break;
case 'd':
case 'D':
while (len-- > 0) {
}
break;
case 'n':
while (len-- > 0) {
#ifdef HAS_HTONS
#endif
}
break;
case 'v':
while (len-- > 0) {
#ifdef HAS_HTOVS
#endif
}
break;
case 'S':
if (natint) {
unsigned short aushort;
while (len-- > 0) {
}
}
else
#endif
{
while (len-- > 0) {
}
}
break;
case 's':
if (natint) {
short ashort;
while (len-- > 0) {
}
}
else
#endif
{
while (len-- > 0) {
}
}
break;
case 'I':
while (len-- > 0) {
}
break;
case 'w':
while (len-- > 0) {
if (adouble < 0)
if (
adouble <= 0xffffffff
#else
# ifdef CXUX_BROKEN_CONSTANT_CONVERT
# else
# endif
#endif
)
{
do {
auv >>= 7;
} while (auv);
}
bool done;
/* Copy string and check for compliance */
while (!done)
}
do {
in--;
} while (adouble > 0);
}
else
}
break;
case 'i':
while (len-- > 0) {
}
break;
case 'N':
while (len-- > 0) {
#ifdef HAS_HTONL
#endif
}
break;
case 'V':
while (len-- > 0) {
#ifdef HAS_HTOVL
#endif
}
break;
case 'L':
if (natint) {
unsigned long aulong;
while (len-- > 0) {
}
}
else
#endif
{
while (len-- > 0) {
}
}
break;
case 'l':
if (natint) {
long along;
while (len-- > 0) {
}
}
else
#endif
{
while (len-- > 0) {
}
}
break;
#ifdef HAS_QUAD
case 'Q':
while (len-- > 0) {
}
break;
case 'q':
while (len-- > 0) {
}
break;
#endif
case 'P':
/* FALL THROUGH */
case 'p':
while (len-- > 0) {
if (fromstr == &PL_sv_undef)
else {
/* XXX better yet, could spirit away the string to
* a safe spot and hang on to it until the result
* of pack() (and all copies of the result) are
* gone.
*/
&& !SvREADONLY(fromstr))))
{
"Attempt to pack pointer to temporary value");
}
else
}
}
break;
case 'u':
if (len <= 1)
len = 45;
else
while (fromlen > 0) {
else
}
break;
}
}
}
{
register char *m;
I32 i;
char *orig;
#ifdef DEBUGGING
#else
#endif
if (!pm || !s)
if (pm->op_pmreplroot) {
#ifdef USE_ITHREADS
#else
#endif
}
#ifdef USE_THREADS
#else
#endif /* USE_THREADS */
else
realarray = 1;
}
else {
}
/* temporarily switch stacks */
make_mortal = 0;
}
}
orig = s;
while (isSPACE_LC(*s))
s++;
}
else {
while (isSPACE(*s))
s++;
}
}
}
if (!limit)
while (--limit) {
m = s;
while (m < strend &&
? isSPACE_LC(*m) : isSPACE(*m)))
++m;
if (m >= strend)
break;
if (make_mortal)
if (do_utf8)
s = m + 1;
while (s < strend &&
? isSPACE_LC(*s) : isSPACE(*s)))
++s;
}
}
while (--limit) {
/*SUPPRESS 530*/
for (m = s; m < strend && *m != '\n'; m++) ;
m++;
if (m >= strend)
break;
if (make_mortal)
if (do_utf8)
s = m;
}
}
while (--limit) {
/*SUPPRESS 530*/
for (m = s; m < strend && *m != c; m++) ;
if (m >= strend)
break;
if (make_mortal)
if (do_utf8)
/* The rx->minlen is in characters but we want to step
* s ahead by bytes. */
if (do_utf8)
else
s = m + len; /* Fake \n at the end */
}
}
else {
#ifndef lint
#endif
{
if (make_mortal)
if (do_utf8)
/* The rx->minlen is in characters but we want to step
* s ahead by bytes. */
if (do_utf8)
else
s = m + len; /* Fake \n at the end */
}
}
}
else {
/* && (!rx->check_substr
|| ((s = CALLREG_INTUIT_START(aTHX_ rx, sv, s, strend,
0, NULL))))
{
m = s;
s = orig;
s = orig + (m - s);
}
if (make_mortal)
if (do_utf8)
if (m && s) {
}
else
if (make_mortal)
if (do_utf8)
}
}
}
}
/* keep field after final delim? */
if (make_mortal)
if (do_utf8)
iters++;
}
else if (!origlimit) {
}
if (realarray) {
if (!mg) {
if (SvSMAGICAL(ary)) {
}
}
}
else {
/* EXTEND should not be needed - we just popped them */
for (i=0; i < iters; i++) {
}
}
}
}
else {
}
}
}
#ifdef USE_THREADS
void
{
if (!mg)
}
#endif /* USE_THREADS */
{
dSP;
#ifdef USE_THREADS
#endif /* USE_THREADS */
}
}
{
#ifdef USE_THREADS
dSP;
else
#else
#endif /* USE_THREADS */
}