[p5sagit/p5-mst-13.2.git] / doop.c

/* $RCSfile: doarg.c,v $$Revision: 4.1 $$Date: 92/08/07 17:19:37 $
 *
 *    Copyright (c) 1991, 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.
 *
 * $Log:	doarg.c,v $
 * Revision 4.1  92/08/07  17:19:37  lwall
 * Stage 6 Snapshot
 * 
 * Revision 4.0.1.7  92/06/11  21:07:11  lwall
 * patch34: join with null list attempted negative allocation
 * patch34: sprintf("%6.4s", "abcdefg") didn't print "abcd  "
 * 
 * Revision 4.0.1.6  92/06/08  12:34:30  lwall
 * patch20: removed implicit int declarations on funcions
 * patch20: pattern modifiers i and o didn't interact right
 * patch20: join() now pre-extends target string to avoid excessive copying
 * patch20: fixed confusion between a *var's real name and its effective name
 * patch20: subroutines didn't localize $`, $&, $', $1 et al correctly
 * patch20: usersub routines didn't reclaim temp values soon enough
 * patch20: ($<,$>) = ... didn't work on some architectures
 * patch20: added Atari ST portability
 * 
 * Revision 4.0.1.5  91/11/11  16:31:58  lwall
 * patch19: added little-endian pack/unpack options
 * 
 * Revision 4.0.1.4  91/11/05  16:35:06  lwall
 * patch11: /$foo/o optimizer could access deallocated data
 * patch11: minimum match length calculation in regexp is now cumulative
 * patch11: added some support for 64-bit integers
 * patch11: prepared for ctype implementations that don't define isascii()
 * patch11: sprintf() now supports any length of s field
 * patch11: indirect subroutine calls through magic vars (e.g. &$1) didn't work
 * patch11: defined(&$foo) and undef(&$foo) didn't work
 * 
 * Revision 4.0.1.3  91/06/10  01:18:41  lwall
 * patch10: pack(hh,1) dumped core
 * 
 * Revision 4.0.1.2  91/06/07  10:42:17  lwall
 * patch4: new copyright notice
 * patch4: // wouldn't use previous pattern if it started with a null character
 * patch4: //o and s///o now optimize themselves fully at runtime
 * patch4: added global modifier for pattern matches
 * patch4: undef @array disabled "@array" interpolation
 * patch4: chop("") was returning "\0" rather than ""
 * patch4: vector logical operations &, | and ^ sometimes returned null string
 * patch4: syscall couldn't pass numbers with most significant bit set on sparcs
 * 
 * Revision 4.0.1.1  91/04/11  17:40:14  lwall
 * patch1: fixed undefined environ problem
 * patch1: fixed debugger coredump on subroutines
 * 
 * Revision 4.0  91/03/20  01:06:42  lwall
 * 4.0 baseline.
 * 
 */

#include "EXTERN.h"
#include "perl.h"

#if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX)
#include <signal.h>
#endif

#ifdef BUGGY_MSC
 #pragma function(memcmp)
#endif /* BUGGY_MSC */

static void doencodes();

#ifdef BUGGY_MSC
 #pragma intrinsic(memcmp)
#endif /* BUGGY_MSC */

I32
do_trans(sv,arg)
SV *sv;
OP *arg;
{
    register short *tbl;
    register char *s;
    register I32 matches = 0;
    register I32 ch;
    register char *send;
    register char *d;
    register I32 squash = op->op_private & OPpTRANS_SQUASH;
    STRLEN len;

    tbl = (short*) cPVOP->op_pv;
    s = SvPV(sv, len);
    send = s + len;
    if (!tbl || !s)
	croak("panic: do_trans");
    DEBUG_t( deb("2.TBL\n"));
    if (!op->op_private) {
	while (s < send) {
	    if ((ch = tbl[*s & 0377]) >= 0) {
		matches++;
		*s = ch;
	    }
	    s++;
	}
    }
    else {
	d = s;
	while (s < send) {
	    if ((ch = tbl[*s & 0377]) >= 0) {
		*d = ch;
		if (matches++ && squash) {
		    if (d[-1] == *d)
			matches--;
		    else
			d++;
		}
		else
		    d++;
	    }
	    else if (ch == -1)		/* -1 is unmapped character */
		*d++ = *s;		/* -2 is delete character */
	    s++;
	}
	matches += send - d;	/* account for disappeared chars */
	*d = '\0';
	SvCUR_set(sv, d - SvPVX(sv));
    }
    SvSETMAGIC(sv);
    return matches;
}

void
do_join(sv,del,mark,sp)
register SV *sv;
SV *del;
register SV **mark;
register SV **sp;
{
    SV **oldmark = mark;
    register I32 items = sp - mark;
    register STRLEN len;
    STRLEN delimlen;
    register char *delim = SvPV(del, delimlen);
    STRLEN tmplen;

    mark++;
    len = (items > 0 ? (delimlen * (items - 1) ) : 0);
    if (SvTYPE(sv) < SVt_PV)
	sv_upgrade(sv, SVt_PV);
    if (SvLEN(sv) < len + items) {	/* current length is way too short */
	while (items-- > 0) {
	    if (*mark) {
		SvPV(*mark, tmplen);
		len += tmplen;
	    }
	    mark++;
	}
	SvGROW(sv, len + 1);		/* so try to pre-extend */

	mark = oldmark;
	items = sp - mark;;
	++mark;
    }

    if (items-- > 0) {
	char *s;

	if (*mark) {
	    s = SvPV(*mark, tmplen);
	    sv_setpvn(sv, s, tmplen);
	}
	else
	    sv_setpv(sv, "");
	mark++;
    }
    else
	sv_setpv(sv,"");
    len = delimlen;
    if (len) {
	for (; items > 0; items--,mark++) {
	    sv_catpvn(sv,delim,len);
	    sv_catsv(sv,*mark);
	}
    }
    else {
	for (; items > 0; items--,mark++)
	    sv_catsv(sv,*mark);
    }
    SvSETMAGIC(sv);
}

void
do_sprintf(sv,len,sarg)
register SV *sv;
register I32 len;
register SV **sarg;
{
    register char *s;
    register char *t;
    register char *f;
    bool dolong;
#ifdef QUAD
    bool doquad;
#endif /* QUAD */
    char ch;
    register char *send;
    register SV *arg;
    char *xs;
    I32 xlen;
    I32 pre;
    I32 post;
    double value;
    STRLEN arglen;

    sv_setpv(sv,"");
    len--;			/* don't count pattern string */
    t = s = SvPV(*sarg, arglen);
    send = s + arglen;
    sarg++;
    for ( ; ; len--) {

	/*SUPPRESS 560*/
	if (len <= 0 || !(arg = *sarg++))
	    arg = &sv_no;

	/*SUPPRESS 530*/
	for ( ; t < send && *t != '%'; t++) ;
	if (t >= send)
	    break;		/* end of run_format string, ignore extra args */
	f = t;
	*buf = '\0';
	xs = buf;
#ifdef QUAD
	doquad =
#endif /* QUAD */
	dolong = FALSE;
	pre = post = 0;
	for (t++; t < send; t++) {
	    switch (*t) {
	    default:
		ch = *(++t);
		*t = '\0';
		(void)sprintf(xs,f);
		len++, sarg--;
		xlen = strlen(xs);
		break;
	    case '0': case '1': case '2': case '3': case '4':
	    case '5': case '6': case '7': case '8': case '9': 
	    case '.': case '#': case '-': case '+': case ' ':
		continue;
	    case 'l':
#ifdef QUAD
		if (dolong) {
		    dolong = FALSE;
		    doquad = TRUE;
		} else
#endif
		dolong = TRUE;
		continue;
	    case 'c':
		ch = *(++t);
		*t = '\0';
		xlen = SvIV(arg);
		if (strEQ(f,"%c")) { /* some printfs fail on null chars */
		    *xs = xlen;
		    xs[1] = '\0';
		    xlen = 1;
		}
		else {
		    (void)sprintf(xs,f,xlen);
		    xlen = strlen(xs);
		}
		break;
	    case 'D':
		dolong = TRUE;
		/* FALL THROUGH */
	    case 'd':
		ch = *(++t);
		*t = '\0';
#ifdef QUAD
		if (doquad)
		    (void)sprintf(buf,s,(quad)SvNV(arg));
		else
#endif
		if (dolong)
		    (void)sprintf(xs,f,(long)SvNV(arg));
		else
		    (void)sprintf(xs,f,SvIV(arg));
		xlen = strlen(xs);
		break;
	    case 'X': case 'O':
		dolong = TRUE;
		/* FALL THROUGH */
	    case 'x': case 'o': case 'u':
		ch = *(++t);
		*t = '\0';
		value = SvNV(arg);
#ifdef QUAD
		if (doquad)
		    (void)sprintf(buf,s,(unsigned quad)value);
		else
#endif
		if (dolong)
		    (void)sprintf(xs,f,U_L(value));
		else
		    (void)sprintf(xs,f,U_I(value));
		xlen = strlen(xs);
		break;
	    case 'E': case 'e': case 'f': case 'G': case 'g':
		ch = *(++t);
		*t = '\0';
		(void)sprintf(xs,f,SvNV(arg));
		xlen = strlen(xs);
		break;
	    case 's':
		ch = *(++t);
		*t = '\0';
		xs = SvPV(arg, arglen);
		xlen = (I32)arglen;
		if (strEQ(f,"%s")) {	/* some printfs fail on >128 chars */
		    break;		/* so handle simple cases */
		}
		else if (f[1] == '-') {
		    char *mp = strchr(f, '.');
		    I32 min = atoi(f+2);

		    if (mp) {
			I32 max = atoi(mp+1);

			if (xlen > max)
			    xlen = max;
		    }
		    if (xlen < min)
			post = min - xlen;
		    break;
		}
		else if (isDIGIT(f[1])) {
		    char *mp = strchr(f, '.');
		    I32 min = atoi(f+1);

		    if (mp) {
			I32 max = atoi(mp+1);

			if (xlen > max)
			    xlen = max;
		    }
		    if (xlen < min)
			pre = min - xlen;
		    break;
		}
		strcpy(tokenbuf+64,f);	/* sprintf($s,...$s...) */
		*t = ch;
		(void)sprintf(buf,tokenbuf+64,xs);
		xs = buf;
		xlen = strlen(xs);
		break;
	    }
	    /* end of switch, copy results */
	    *t = ch;
	    SvGROW(sv, SvCUR(sv) + (f - s) + xlen + 1 + pre + post);
	    sv_catpvn(sv, s, f - s);
	    if (pre) {
		repeatcpy(SvPVX(sv) + SvCUR(sv), " ", 1, pre);
		SvCUR(sv) += pre;
	    }
	    sv_catpvn(sv, xs, xlen);
	    if (post) {
		repeatcpy(SvPVX(sv) + SvCUR(sv), " ", 1, post);
		SvCUR(sv) += post;
	    }
	    s = t;
	    break;		/* break from for loop */
	}
    }
    sv_catpvn(sv, s, t - s);
    SvSETMAGIC(sv);
}

void
do_vecset(sv)
SV *sv;
{
    SV *targ = LvTARG(sv);
    register I32 offset;
    register I32 size;
    register unsigned char *s;
    register unsigned long lval;
    I32 mask;

    if (!targ)
	return;
    s = (unsigned char*)SvPVX(targ);
    lval = U_L(SvNV(sv));
    offset = LvTARGOFF(sv);
    size = LvTARGLEN(sv);
    if (size < 8) {
	mask = (1 << size) - 1;
	size = offset & 7;
	lval &= mask;
	offset >>= 3;
	s[offset] &= ~(mask << size);
	s[offset] |= lval << size;
    }
    else {
	if (size == 8)
	    s[offset] = lval & 255;
	else if (size == 16) {
	    s[offset] = (lval >> 8) & 255;
	    s[offset+1] = lval & 255;
	}
	else if (size == 32) {
	    s[offset] = (lval >> 24) & 255;
	    s[offset+1] = (lval >> 16) & 255;
	    s[offset+2] = (lval >> 8) & 255;
	    s[offset+3] = lval & 255;
	}
    }
}

void
do_chop(astr,sv)
register SV *astr;
register SV *sv;
{
    register char *tmps;
    register I32 i;
    AV *ary;
    HV *hv;
    HE *entry;
    STRLEN len;

    if (!sv)
	return;
    if (SvTHINKFIRST(sv)) {
	if (SvREADONLY(sv))
	    croak("Can't chop readonly value");
	if (SvROK(sv))
	    sv_unref(sv);
    }
    if (SvTYPE(sv) == SVt_PVAV) {
	I32 max;
	SV **array = AvARRAY(sv);
	max = AvFILL(sv);
	for (i = 0; i <= max; i++)
	    do_chop(astr,array[i]);
	return;
    }
    if (SvTYPE(sv) == SVt_PVHV) {
	hv = (HV*)sv;
	(void)hv_iterinit(hv);
	/*SUPPRESS 560*/
	while (entry = hv_iternext(hv))
	    do_chop(astr,hv_iterval(hv,entry));
	return;
    }
    tmps = SvPV(sv, len);
    if (tmps && len) {
	tmps += len - 1;
	sv_setpvn(astr,tmps,1);	/* remember last char */
	*tmps = '\0';				/* wipe it out */
	SvCUR_set(sv, tmps - SvPVX(sv));
	SvNOK_off(sv);
	SvSETMAGIC(sv);
    }
    else
	sv_setpvn(astr,"",0);
}

void
do_vop(optype,sv,left,right)
I32 optype;
SV *sv;
SV *left;
SV *right;
{
#ifdef LIBERAL
    register long *dl;
    register long *ll;
    register long *rl;
#endif
    register char *dc;
    STRLEN leftlen;
    STRLEN rightlen;
    register char *lc = SvPV(left, leftlen);
    register char *rc = SvPV(right, rightlen);
    register I32 len;

    if (SvTHINKFIRST(sv)) {
	if (SvREADONLY(sv))
	    croak("Can't do %s to readonly value", op_name[optype]);
	if (SvROK(sv))
	    sv_unref(sv);
    }
    len = leftlen < rightlen ? leftlen : rightlen;
    if (SvTYPE(sv) < SVt_PV)
	sv_upgrade(sv, SVt_PV);
    if (SvCUR(sv) > len)
	SvCUR_set(sv, len);
    else if (SvCUR(sv) < len) {
	SvGROW(sv,len);
	(void)memzero(SvPVX(sv) + SvCUR(sv), len - SvCUR(sv));
	SvCUR_set(sv, len);
    }
    SvPOK_only(sv);
    dc = SvPVX(sv);
    if (!dc) {
	sv_setpvn(sv,"",0);
	dc = SvPVX(sv);
    }
#ifdef LIBERAL
    if (len >= sizeof(long)*4 &&
	!((long)dc % sizeof(long)) &&
	!((long)lc % sizeof(long)) &&
	!((long)rc % sizeof(long)))	/* It's almost always aligned... */
    {
	I32 remainder = len % (sizeof(long)*4);
	len /= (sizeof(long)*4);

	dl = (long*)dc;
	ll = (long*)lc;
	rl = (long*)rc;

	switch (optype) {
	case OP_BIT_AND:
	    while (len--) {
		*dl++ = *ll++ & *rl++;
		*dl++ = *ll++ & *rl++;
		*dl++ = *ll++ & *rl++;
		*dl++ = *ll++ & *rl++;
	    }
	    break;
	case OP_XOR:
	    while (len--) {
		*dl++ = *ll++ ^ *rl++;
		*dl++ = *ll++ ^ *rl++;
		*dl++ = *ll++ ^ *rl++;
		*dl++ = *ll++ ^ *rl++;
	    }
	    break;
	case OP_BIT_OR:
	    while (len--) {
		*dl++ = *ll++ | *rl++;
		*dl++ = *ll++ | *rl++;
		*dl++ = *ll++ | *rl++;
		*dl++ = *ll++ | *rl++;
	    }
	}

	dc = (char*)dl;
	lc = (char*)ll;
	rc = (char*)rl;

	len = remainder;
    }
#endif
    switch (optype) {
    case OP_BIT_AND:
	while (len--)
	    *dc++ = *lc++ & *rc++;
	break;
    case OP_XOR:
	while (len--)
	    *dc++ = *lc++ ^ *rc++;
	goto mop_up;
    case OP_BIT_OR:
	while (len--)
	    *dc++ = *lc++ | *rc++;
      mop_up:
	len = SvCUR(sv);
	if (rightlen > len)
	    sv_catpvn(sv, SvPVX(right) + len, rightlen - len);
	else if (leftlen > len)
	    sv_catpvn(sv, SvPVX(left) + len, leftlen - len);
	break;
    }
}

OP *
do_kv(ARGS)
dARGS
{
    dSP;
    HV *hv = (HV*)POPs;
    register AV *ary = stack;
    I32 i;
    register HE *entry;
    char *tmps;
    SV *tmpstr;
    I32 dokeys =   (op->op_type == OP_KEYS   || op->op_type == OP_RV2HV);
    I32 dovalues = (op->op_type == OP_VALUES || op->op_type == OP_RV2HV);

    if (!hv)
	RETURN;
    if (GIMME != G_ARRAY) {
	dTARGET;

	if (!SvRMAGICAL(hv) || !mg_find((SV*)hv,'P'))
	    i = HvKEYS(hv);
	else {
	    i = 0;
	    (void)hv_iterinit(hv);
	    /*SUPPRESS 560*/
	    while (entry = hv_iternext(hv)) {
		i++;
	    }
	}
	PUSHi( i );
	RETURN;
    }

    /* Guess how much room we need.  hv_max may be a few too many.  Oh well. */
    EXTEND(sp, HvMAX(hv) * (dokeys + dovalues));

    (void)hv_iterinit(hv);

    PUTBACK;	/* hv_iternext and hv_iterval might clobber stack_sp */
    while (entry = hv_iternext(hv)) {
	SPAGAIN;
	if (dokeys) {
	    tmps = hv_iterkey(entry,&i);	/* won't clobber stack_sp */
	    if (!i)
		tmps = "";
	    XPUSHs(sv_2mortal(newSVpv(tmps,i)));
	}
	if (dovalues) {
	    tmpstr = NEWSV(45,0);
	    PUTBACK;
	    sv_setsv(tmpstr,hv_iterval(hv,entry));
	    SPAGAIN;
	    DEBUG_H( {
		sprintf(buf,"%d%%%d=%d\n",entry->hent_hash,
		    HvMAX(hv)+1,entry->hent_hash & HvMAX(hv));
		sv_setpv(tmpstr,buf);
	    } )
	    XPUSHs(sv_2mortal(tmpstr));
	}
	PUTBACK;
    }
    return NORMAL;
}
Commit	Line	Data
79072805	1	/* $RCSfile: doarg.c,v $$Revision: 4.1 $$Date: 92/08/07 17:19:37 $
	2	*
	3	* Copyright (c) 1991, Larry Wall
	4	*
	5	* You may distribute under the terms of either the GNU General Public
	6	* License or the Artistic License, as specified in the README file.
	7	*
	8	* $Log: doarg.c,v $
	9	* Revision 4.1 92/08/07 17:19:37 lwall
	10	* Stage 6 Snapshot
	11	*
	12	* Revision 4.0.1.7 92/06/11 21:07:11 lwall
	13	* patch34: join with null list attempted negative allocation
	14	* patch34: sprintf("%6.4s", "abcdefg") didn't print "abcd "
	15	*
	16	* Revision 4.0.1.6 92/06/08 12:34:30 lwall
	17	* patch20: removed implicit int declarations on funcions
	18	* patch20: pattern modifiers i and o didn't interact right
	19	* patch20: join() now pre-extends target string to avoid excessive copying
	20	* patch20: fixed confusion between a *var's real name and its effective name
	21	* patch20: subroutines didn't localize $`, $&, $', $1 et al correctly
	22	* patch20: usersub routines didn't reclaim temp values soon enough
	23	* patch20: ($<,$>) = ... didn't work on some architectures
	24	* patch20: added Atari ST portability
	25	*
	26	* Revision 4.0.1.5 91/11/11 16:31:58 lwall
	27	* patch19: added little-endian pack/unpack options
	28	*
	29	* Revision 4.0.1.4 91/11/05 16:35:06 lwall
	30	* patch11: /$foo/o optimizer could access deallocated data
	31	* patch11: minimum match length calculation in regexp is now cumulative
	32	* patch11: added some support for 64-bit integers
	33	* patch11: prepared for ctype implementations that don't define isascii()
	34	* patch11: sprintf() now supports any length of s field
	35	* patch11: indirect subroutine calls through magic vars (e.g. &$1) didn't work
	36	* patch11: defined(&$foo) and undef(&$foo) didn't work
	37	*
	38	* Revision 4.0.1.3 91/06/10 01:18:41 lwall
	39	* patch10: pack(hh,1) dumped core
	40	*
	41	* Revision 4.0.1.2 91/06/07 10:42:17 lwall
	42	* patch4: new copyright notice
	43	* patch4: // wouldn't use previous pattern if it started with a null character
	44	* patch4: //o and s///o now optimize themselves fully at runtime
	45	* patch4: added global modifier for pattern matches
	46	* patch4: undef @array disabled "@array" interpolation
	47	* patch4: chop("") was returning "\0" rather than ""
	48	* patch4: vector logical operations &, \| and ^ sometimes returned null string
	49	* patch4: syscall couldn't pass numbers with most significant bit set on sparcs
	50	*
	51	* Revision 4.0.1.1 91/04/11 17:40:14 lwall
	52	* patch1: fixed undefined environ problem
	53	* patch1: fixed debugger coredump on subroutines
	54	*
	55	* Revision 4.0 91/03/20 01:06:42 lwall
	56	* 4.0 baseline.
	57	*
	58	*/
	59
	60	#include "EXTERN.h"
	61	#include "perl.h"
	62
	63	#if !defined(NSIG) \|\| defined(M_UNIX) \|\| defined(M_XENIX)
	64	#include <signal.h>
65	#endif
66
67	#ifdef BUGGY_MSC
68	#pragma function(memcmp)
69	#endif /* BUGGY_MSC */
70
71	static void doencodes();
72
73	#ifdef BUGGY_MSC
74	#pragma intrinsic(memcmp)
75	#endif /* BUGGY_MSC */
76
77	I32
78	do_trans(sv,arg)
79	SV *sv;
80	OP *arg;
81	{
82	register short *tbl;
83	register char *s;
84	register I32 matches = 0;
85	register I32 ch;
86	register char *send;
87	register char *d;
88	register I32 squash = op->op_private & OPpTRANS_SQUASH;
463ee0b2	89	STRLEN len;
79072805	90
79072805	91	tbl = (short*) cPVOP->op_pv;
463ee0b2	92	s = SvPV(sv, len);
463ee0b2	93	send = s + len;
79072805	94	if (!tbl \|\| !s)
463ee0b2	95	croak("panic: do_trans");
79072805	96	DEBUG_t( deb("2.TBL\n"));
	97	if (!op->op_private) {
	98	while (s < send) {
	99	if ((ch = tbl[*s & 0377]) >= 0) {
	100	matches++;
	101	*s = ch;
	102	}
	103	s++;
	104	}
	105	}
	106	else {
	107	d = s;
	108	while (s < send) {
	109	if ((ch = tbl[*s & 0377]) >= 0) {
	110	*d = ch;
	111	if (matches++ && squash) {
	112	if (d[-1] == *d)
	113	matches--;
	114	else
	115	d++;
	116	}
	117	else
	118	d++;
	119	}
	120	else if (ch == -1) /* -1 is unmapped character */
	121	d++ = s; /* -2 is delete character */
	122	s++;
	123	}
	124	matches += send - d; /* account for disappeared chars */
	125	*d = '\0';
463ee0b2	126	SvCUR_set(sv, d - SvPVX(sv));
79072805	127	}
	128	SvSETMAGIC(sv);
	129	return matches;
	130	}
	131
	132	void
	133	do_join(sv,del,mark,sp)
	134	register SV *sv;
	135	SV *del;
	136	register SV **mark;
	137	register SV **sp;
	138	{
	139	SV **oldmark = mark;
	140	register I32 items = sp - mark;
79072805	141	register STRLEN len;
463ee0b2	142	STRLEN delimlen;
	143	register char *delim = SvPV(del, delimlen);
	144	STRLEN tmplen;
79072805	145
	146	mark++;
	147	len = (items > 0 ? (delimlen * (items - 1) ) : 0);
	148	if (SvTYPE(sv) < SVt_PV)
	149	sv_upgrade(sv, SVt_PV);
	150	if (SvLEN(sv) < len + items) { /* current length is way too short */
	151	while (items-- > 0) {
	152	if (*mark) {
463ee0b2	153	SvPV(*mark, tmplen);
463ee0b2	154	len += tmplen;
79072805	155	}
	156	mark++;
	157	}
	158	SvGROW(sv, len + 1); /* so try to pre-extend */
	159
	160	mark = oldmark;
	161	items = sp - mark;;
	162	++mark;
	163	}
	164
463ee0b2	165	if (items-- > 0) {
8990e307	166	char *s;
	167
	168	if (*mark) {
	169	s = SvPV(*mark, tmplen);
	170	sv_setpvn(sv, s, tmplen);
	171	}
	172	else
	173	sv_setpv(sv, "");
463ee0b2	174	mark++;
463ee0b2	175	}
79072805	176	else
	177	sv_setpv(sv,"");
	178	len = delimlen;
	179	if (len) {
	180	for (; items > 0; items--,mark++) {
	181	sv_catpvn(sv,delim,len);
	182	sv_catsv(sv,*mark);
	183	}
	184	}
	185	else {
	186	for (; items > 0; items--,mark++)
	187	sv_catsv(sv,*mark);
	188	}
	189	SvSETMAGIC(sv);
	190	}
	191
	192	void
	193	do_sprintf(sv,len,sarg)
	194	register SV *sv;
	195	register I32 len;
	196	register SV **sarg;
	197	{
	198	register char *s;
	199	register char *t;
	200	register char *f;
	201	bool dolong;
	202	#ifdef QUAD
	203	bool doquad;
	204	#endif /* QUAD */
	205	char ch;
	206	register char *send;
	207	register SV *arg;
	208	char *xs;
	209	I32 xlen;
	210	I32 pre;
	211	I32 post;
	212	double value;
463ee0b2	213	STRLEN arglen;
79072805	214
	215	sv_setpv(sv,"");
	216	len--; /* don't count pattern string */
463ee0b2	217	t = s = SvPV(*sarg, arglen);
463ee0b2	218	send = s + arglen;
79072805	219	sarg++;
	220	for ( ; ; len--) {
	221
	222	/SUPPRESS 560/
	223	if (len <= 0 \|\| !(arg = *sarg++))
	224	arg = &sv_no;
	225
	226	/SUPPRESS 530/
	227	for ( ; t < send && *t != '%'; t++) ;
	228	if (t >= send)
	229	break; /* end of run_format string, ignore extra args */
	230	f = t;
	231	*buf = '\0';
	232	xs = buf;
	233	#ifdef QUAD
	234	doquad =
	235	#endif /* QUAD */
	236	dolong = FALSE;
	237	pre = post = 0;
	238	for (t++; t < send; t++) {
	239	switch (*t) {
	240	default:
	241	ch = *(++t);
	242	*t = '\0';
	243	(void)sprintf(xs,f);
	244	len++, sarg--;
	245	xlen = strlen(xs);
	246	break;
	247	case '0': case '1': case '2': case '3': case '4':
	248	case '5': case '6': case '7': case '8': case '9':
	249	case '.': case '#': case '-': case '+': case ' ':
	250	continue;
463ee0b2	251	case 'l':
79072805	252	#ifdef QUAD
	253	if (dolong) {
	254	dolong = FALSE;
	255	doquad = TRUE;
	256	} else
	257	#endif
	258	dolong = TRUE;
	259	continue;
	260	case 'c':
	261	ch = *(++t);
	262	*t = '\0';
463ee0b2	263	xlen = SvIV(arg);
79072805	264	if (strEQ(f,"%c")) { /* some printfs fail on null chars */
	265	*xs = xlen;
	266	xs[1] = '\0';
	267	xlen = 1;
	268	}
	269	else {
	270	(void)sprintf(xs,f,xlen);
	271	xlen = strlen(xs);
	272	}
	273	break;
	274	case 'D':
	275	dolong = TRUE;
	276	/* FALL THROUGH */
	277	case 'd':
	278	ch = *(++t);
	279	*t = '\0';
	280	#ifdef QUAD
	281	if (doquad)
463ee0b2	282	(void)sprintf(buf,s,(quad)SvNV(arg));
79072805	283	else
	284	#endif
	285	if (dolong)
463ee0b2	286	(void)sprintf(xs,f,(long)SvNV(arg));
79072805	287	else
463ee0b2	288	(void)sprintf(xs,f,SvIV(arg));
79072805	289	xlen = strlen(xs);
	290	break;
	291	case 'X': case 'O':
	292	dolong = TRUE;
	293	/* FALL THROUGH */
	294	case 'x': case 'o': case 'u':
	295	ch = *(++t);
	296	*t = '\0';
463ee0b2	297	value = SvNV(arg);
79072805	298	#ifdef QUAD
	299	if (doquad)
	300	(void)sprintf(buf,s,(unsigned quad)value);
	301	else
	302	#endif
	303	if (dolong)
	304	(void)sprintf(xs,f,U_L(value));
	305	else
	306	(void)sprintf(xs,f,U_I(value));
	307	xlen = strlen(xs);
	308	break;
	309	case 'E': case 'e': case 'f': case 'G': case 'g':
	310	ch = *(++t);
	311	*t = '\0';
463ee0b2	312	(void)sprintf(xs,f,SvNV(arg));
79072805	313	xlen = strlen(xs);
	314	break;
	315	case 's':
	316	ch = *(++t);
	317	*t = '\0';
463ee0b2	318	xs = SvPV(arg, arglen);
463ee0b2	319	xlen = (I32)arglen;
79072805	320	if (strEQ(f,"%s")) { /* some printfs fail on >128 chars */
	321	break; /* so handle simple cases */
	322	}
	323	else if (f[1] == '-') {
93a17b20	324	char *mp = strchr(f, '.');
79072805	325	I32 min = atoi(f+2);
	326
	327	if (mp) {
	328	I32 max = atoi(mp+1);
	329
	330	if (xlen > max)
	331	xlen = max;
	332	}
	333	if (xlen < min)
	334	post = min - xlen;
	335	break;
	336	}
	337	else if (isDIGIT(f[1])) {
93a17b20	338	char *mp = strchr(f, '.');
79072805	339	I32 min = atoi(f+1);
	340
	341	if (mp) {
	342	I32 max = atoi(mp+1);
	343
	344	if (xlen > max)
	345	xlen = max;
	346	}
	347	if (xlen < min)
	348	pre = min - xlen;
	349	break;
	350	}
	351	strcpy(tokenbuf+64,f); /* sprintf($s,...$s...) */
	352	*t = ch;
	353	(void)sprintf(buf,tokenbuf+64,xs);
	354	xs = buf;
	355	xlen = strlen(xs);
	356	break;
	357	}
	358	/* end of switch, copy results */
	359	*t = ch;
	360	SvGROW(sv, SvCUR(sv) + (f - s) + xlen + 1 + pre + post);
	361	sv_catpvn(sv, s, f - s);
	362	if (pre) {
463ee0b2	363	repeatcpy(SvPVX(sv) + SvCUR(sv), " ", 1, pre);
79072805	364	SvCUR(sv) += pre;
	365	}
	366	sv_catpvn(sv, xs, xlen);
	367	if (post) {
463ee0b2	368	repeatcpy(SvPVX(sv) + SvCUR(sv), " ", 1, post);
79072805	369	SvCUR(sv) += post;
	370	}
	371	s = t;
	372	break; /* break from for loop */
	373	}
	374	}
	375	sv_catpvn(sv, s, t - s);
	376	SvSETMAGIC(sv);
	377	}
	378
	379	void
	380	do_vecset(sv)
	381	SV *sv;
	382	{
	383	SV *targ = LvTARG(sv);
	384	register I32 offset;
	385	register I32 size;
8990e307	386	register unsigned char *s;
8990e307	387	register unsigned long lval;
79072805	388	I32 mask;
79072805	389
8990e307	390	if (!targ)
	391	return;
	392	s = (unsigned char*)SvPVX(targ);
	393	lval = U_L(SvNV(sv));
79072805	394	offset = LvTARGOFF(sv);
	395	size = LvTARGLEN(sv);
	396	if (size < 8) {
	397	mask = (1 << size) - 1;
	398	size = offset & 7;
	399	lval &= mask;
	400	offset >>= 3;
	401	s[offset] &= ~(mask << size);
	402	s[offset] \|= lval << size;
	403	}
	404	else {
	405	if (size == 8)
	406	s[offset] = lval & 255;
	407	else if (size == 16) {
	408	s[offset] = (lval >> 8) & 255;
	409	s[offset+1] = lval & 255;
	410	}
	411	else if (size == 32) {
	412	s[offset] = (lval >> 24) & 255;
	413	s[offset+1] = (lval >> 16) & 255;
	414	s[offset+2] = (lval >> 8) & 255;
	415	s[offset+3] = lval & 255;
	416	}
	417	}
	418	}
	419
	420	void
	421	do_chop(astr,sv)
	422	register SV *astr;
	423	register SV *sv;
	424	{
	425	register char *tmps;
	426	register I32 i;
	427	AV *ary;
463ee0b2	428	HV *hv;
79072805	429	HE *entry;
463ee0b2	430	STRLEN len;
79072805	431
	432	if (!sv)
	433	return;
ed6116ce	434	if (SvTHINKFIRST(sv)) {
	435	if (SvREADONLY(sv))
	436	croak("Can't chop readonly value");
	437	if (SvROK(sv))
	438	sv_unref(sv);
	439	}
79072805	440	if (SvTYPE(sv) == SVt_PVAV) {
	441	I32 max;
	442	SV **array = AvARRAY(sv);
	443	max = AvFILL(sv);
	444	for (i = 0; i <= max; i++)
	445	do_chop(astr,array[i]);
	446	return;
	447	}
	448	if (SvTYPE(sv) == SVt_PVHV) {
463ee0b2	449	hv = (HV*)sv;
463ee0b2	450	(void)hv_iterinit(hv);
79072805	451	/SUPPRESS 560/
463ee0b2	452	while (entry = hv_iternext(hv))
463ee0b2	453	do_chop(astr,hv_iterval(hv,entry));
79072805	454	return;
79072805	455	}
463ee0b2	456	tmps = SvPV(sv, len);
	457	if (tmps && len) {
	458	tmps += len - 1;
79072805	459	sv_setpvn(astr,tmps,1); /* remember last char */
79072805	460	tmps = '\0'; / wipe it out */
463ee0b2	461	SvCUR_set(sv, tmps - SvPVX(sv));
79072805	462	SvNOK_off(sv);
	463	SvSETMAGIC(sv);
	464	}
	465	else
	466	sv_setpvn(astr,"",0);
	467	}
	468
	469	void
	470	do_vop(optype,sv,left,right)
	471	I32 optype;
	472	SV *sv;
	473	SV *left;
	474	SV *right;
	475	{
	476	#ifdef LIBERAL
	477	register long *dl;
	478	register long *ll;
	479	register long *rl;
	480	#endif
	481	register char *dc;
463ee0b2	482	STRLEN leftlen;
	483	STRLEN rightlen;
	484	register char *lc = SvPV(left, leftlen);
	485	register char *rc = SvPV(right, rightlen);
79072805	486	register I32 len;
79072805	487
ed6116ce	488	if (SvTHINKFIRST(sv)) {
	489	if (SvREADONLY(sv))
	490	croak("Can't do %s to readonly value", op_name[optype]);
	491	if (SvROK(sv))
	492	sv_unref(sv);
	493	}
93a17b20	494	len = leftlen < rightlen ? leftlen : rightlen;
79072805	495	if (SvTYPE(sv) < SVt_PV)
	496	sv_upgrade(sv, SVt_PV);
	497	if (SvCUR(sv) > len)
	498	SvCUR_set(sv, len);
	499	else if (SvCUR(sv) < len) {
	500	SvGROW(sv,len);
463ee0b2	501	(void)memzero(SvPVX(sv) + SvCUR(sv), len - SvCUR(sv));
79072805	502	SvCUR_set(sv, len);
	503	}
	504	SvPOK_only(sv);
463ee0b2	505	dc = SvPVX(sv);
79072805	506	if (!dc) {
79072805	507	sv_setpvn(sv,"",0);
463ee0b2	508	dc = SvPVX(sv);
79072805	509	}
	510	#ifdef LIBERAL
	511	if (len >= sizeof(long)*4 &&
	512	!((long)dc % sizeof(long)) &&
	513	!((long)lc % sizeof(long)) &&
	514	!((long)rc % sizeof(long))) /* It's almost always aligned... */
	515	{
	516	I32 remainder = len % (sizeof(long)*4);
	517	len /= (sizeof(long)*4);
	518
	519	dl = (long*)dc;
	520	ll = (long*)lc;
	521	rl = (long*)rc;
	522
	523	switch (optype) {
	524	case OP_BIT_AND:
	525	while (len--) {
	526	dl++ = ll++ & *rl++;
	527	dl++ = ll++ & *rl++;
	528	dl++ = ll++ & *rl++;
	529	dl++ = ll++ & *rl++;
	530	}
	531	break;
	532	case OP_XOR:
	533	while (len--) {
	534	dl++ = ll++ ^ *rl++;
	535	dl++ = ll++ ^ *rl++;
	536	dl++ = ll++ ^ *rl++;
	537	dl++ = ll++ ^ *rl++;
	538	}
	539	break;
	540	case OP_BIT_OR:
	541	while (len--) {
	542	dl++ = ll++ \| *rl++;
	543	dl++ = ll++ \| *rl++;
	544	dl++ = ll++ \| *rl++;
	545	dl++ = ll++ \| *rl++;
	546	}
	547	}
	548
	549	dc = (char*)dl;
	550	lc = (char*)ll;
	551	rc = (char*)rl;
	552
	553	len = remainder;
	554	}
	555	#endif
	556	switch (optype) {
	557	case OP_BIT_AND:
	558	while (len--)
	559	dc++ = lc++ & *rc++;
	560	break;
	561	case OP_XOR:
	562	while (len--)
	563	dc++ = lc++ ^ *rc++;
	564	goto mop_up;
	565	case OP_BIT_OR:
	566	while (len--)
	567	dc++ = lc++ \| *rc++;
	568	mop_up:
	569	len = SvCUR(sv);
93a17b20	570	if (rightlen > len)
463ee0b2	571	sv_catpvn(sv, SvPVX(right) + len, rightlen - len);
93a17b20	572	else if (leftlen > len)
463ee0b2	573	sv_catpvn(sv, SvPVX(left) + len, leftlen - len);
79072805	574	break;
	575	}
	576	}
463ee0b2	577
	578	OP *
	579	do_kv(ARGS)
	580	dARGS
	581	{
	582	dSP;
	583	HV hv = (HV)POPs;
	584	register AV *ary = stack;
	585	I32 i;
	586	register HE *entry;
	587	char *tmps;
	588	SV *tmpstr;
	589	I32 dokeys = (op->op_type == OP_KEYS \|\| op->op_type == OP_RV2HV);
	590	I32 dovalues = (op->op_type == OP_VALUES \|\| op->op_type == OP_RV2HV);
	591
	592	if (!hv)
	593	RETURN;
	594	if (GIMME != G_ARRAY) {
	595	dTARGET;
	596
8990e307	597	if (!SvRMAGICAL(hv) \|\| !mg_find((SV*)hv,'P'))
463ee0b2	598	i = HvKEYS(hv);
	599	else {
	600	i = 0;
	601	(void)hv_iterinit(hv);
	602	/SUPPRESS 560/
	603	while (entry = hv_iternext(hv)) {
	604	i++;
	605	}
	606	}
	607	PUSHi( i );
	608	RETURN;
	609	}
	610
	611	/* Guess how much room we need. hv_max may be a few too many. Oh well. */
	612	EXTEND(sp, HvMAX(hv) * (dokeys + dovalues));
	613
	614	(void)hv_iterinit(hv);
	615
	616	PUTBACK; /* hv_iternext and hv_iterval might clobber stack_sp */
	617	while (entry = hv_iternext(hv)) {
	618	SPAGAIN;
	619	if (dokeys) {
	620	tmps = hv_iterkey(entry,&i); /* won't clobber stack_sp */
	621	if (!i)
	622	tmps = "";
	623	XPUSHs(sv_2mortal(newSVpv(tmps,i)));
	624	}
	625	if (dovalues) {
	626	tmpstr = NEWSV(45,0);
	627	PUTBACK;
	628	sv_setsv(tmpstr,hv_iterval(hv,entry));
	629	SPAGAIN;
	630	DEBUG_H( {
	631	sprintf(buf,"%d%%%d=%d\n",entry->hent_hash,
	632	HvMAX(hv)+1,entry->hent_hash & HvMAX(hv));
	633	sv_setpv(tmpstr,buf);
	634	} )
	635	XPUSHs(sv_2mortal(tmpstr));
	636	}
	637	PUTBACK;
	638	}
	639	return NORMAL;
	640	}
	641