[perl5.git] / doop.c

/*    doop.c
 *
 *    Copyright (c) 1991-1997, Larry Wall
 *
 *    You may distribute under the terms of either the GNU General Public
 *    License or the Artistic License, as specified in the README file.
 *
 */

/*
 * "'So that was the job I felt I had to do when I started,' thought Sam."
 */

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

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

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

    if (SvREADONLY(sv))
	croak(no_modify);
    tbl = (short*)cPVOP->op_pv;
    s = (U8*)SvPV(sv, len);
    if (!len)
	return 0;
    if (!SvPOKp(sv))
	s = (U8*)SvPV_force(sv, len);
    (void)SvPOK_only(sv);
    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]) >= 0) {
		matches++;
		*s = ch;
	    }
	    s++;
	}
    }
    else {
	d = s;
	while (s < send) {
	    if ((ch = tbl[*s]) >= 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 - (U8*)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;
    char dotype;
    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);	/* XXX Don't know t is writeable */
    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;
	dotype = '\0';
	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 'n': case '*':
		croak("Use of %c in printf format not supported", *t);

	    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 HAS_QUAD
		if (dotype == 'l')
		    dotype = 'q';
		else
#endif
		    dotype = 'l';
		continue;
	    case 'h':
		dotype = 's';
		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':
		dotype = 'l';
		/* FALL THROUGH */
	    case 'd':
	    case 'i':
		ch = *(++t);
		*t = '\0';
		switch (dotype) {
#ifdef HAS_QUAD
		case 'q':
		    /* perl.h says that if quad is available, IV is quad */
		    (void)sprintf(xs,f,(Quad_t)SvIV(arg));
		    break;
#endif
		case 'l':
		    (void)sprintf(xs,f,(long)SvIV(arg));
		    break;
		default:
		    (void)sprintf(xs,f,(int)SvIV(arg));
		    break;
		case 's':
		    (void)sprintf(xs,f,(short)SvIV(arg));
		    break;
		}
		xlen = strlen(xs);
		break;
	    case 'X': case 'O':
		dotype = 'l';
		/* FALL THROUGH */
	    case 'x': case 'o': case 'u':
		ch = *(++t);
		*t = '\0';
		switch (dotype) {
#ifdef HAS_QUAD
		case 'q':
		    /* perl.h says that if quad is available, UV is quad */
		    (void)sprintf(xs,f,(unsigned Quad_t)SvUV(arg));
		    break;
#endif
		case 'l':
		    (void)sprintf(xs,f,(unsigned long)SvUV(arg));
		    break;
		default:
		    (void)sprintf(xs,f,(unsigned int)SvUV(arg));
		    break;
		case 's':
		    (void)sprintf(xs,f,(unsigned short)SvUV(arg));
		    break;
		}
		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);
#ifdef LC_NUMERIC
		/*
		 * User-defined locales may include arbitrary characters.
		 * And, unfortunately, some system may alloc the "C" locale
		 * to be overridden by a malicious user.
		 */
		if (op->op_type == OP_SPRINTF)
		    SvTAINTED_on(sv);
#endif /* LC_NUMERIC */
		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;
	    if (xs == buf && xlen >= sizeof(buf)) {	/* Ooops! */
		PerlIO_puts(PerlIO_stderr(),"panic: sprintf overflow - memory corrupted!\n");
		my_exit(1);
	    }
	    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;
    STRLEN targlen;
    STRLEN len;

    if (!targ)
	return;
    s = (unsigned char*)SvPV_force(targ, targlen);
    lval = U_L(SvNV(sv));
    offset = LvTARGOFF(sv);
    size = LvTARGLEN(sv);
    
    len = (offset + size + 7) / 8;
    if (len > targlen) {
	s = (unsigned char*)SvGROW(targ, len + 1);
	(void)memzero(s + targlen, len - targlen + 1);
	SvCUR_set(targ, len);
    }
    
    if (size < 8) {
	mask = (1 << size) - 1;
	size = offset & 7;
	lval &= mask;
	offset >>= 3;
	s[offset] &= ~(mask << size);
	s[offset] |= lval << size;
    }
    else {
	offset >>= 3;
	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;
{
    STRLEN len;
    char *s;
    
    if (SvTYPE(sv) == SVt_PVAV) {
	register I32 i;
        I32 max;
	AV* av = (AV*)sv;
        max = AvFILL(av);
        for (i = 0; i <= max; i++) {
	    sv = (SV*)av_fetch(av, i, FALSE);
	    if (sv && ((sv = *(SV**)sv), sv != &sv_undef))
		do_chop(astr, sv);
	}
        return;
    }
    if (SvTYPE(sv) == SVt_PVHV) {
        HV* hv = (HV*)sv;
	HE* entry;
        (void)hv_iterinit(hv);
        /*SUPPRESS 560*/
        while (entry = hv_iternext(hv))
            do_chop(astr,hv_iterval(hv,entry));
        return;
    }
    s = SvPV(sv, len);
    if (len && !SvPOK(sv))
	s = SvPV_force(sv, len);
    if (s && len) {
	s += --len;
	sv_setpvn(astr, s, 1);
	*s = '\0';
	SvCUR_set(sv, len);
	SvNIOK_off(sv);
    }
    else
	sv_setpvn(astr, "", 0);
    SvSETMAGIC(sv);
} 

I32
do_chomp(sv)
register SV *sv;
{
    register I32 count;
    STRLEN len;
    char *s;

    if (RsSNARF(rs))
	return 0;
    count = 0;
    if (SvTYPE(sv) == SVt_PVAV) {
	register I32 i;
        I32 max;
	AV* av = (AV*)sv;
        max = AvFILL(av);
        for (i = 0; i <= max; i++) {
	    sv = (SV*)av_fetch(av, i, FALSE);
	    if (sv && ((sv = *(SV**)sv), sv != &sv_undef))
		count += do_chomp(sv);
	}
        return count;
    }
    if (SvTYPE(sv) == SVt_PVHV) {
        HV* hv = (HV*)sv;
	HE* entry;
        (void)hv_iterinit(hv);
        /*SUPPRESS 560*/
        while (entry = hv_iternext(hv))
            count += do_chomp(hv_iterval(hv,entry));
        return count;
    }
    s = SvPV(sv, len);
    if (len && !SvPOKp(sv))
	s = SvPV_force(sv, len);
    if (s && len) {
	s += --len;
	if (RsPARA(rs)) {
	    if (*s != '\n')
		goto nope;
	    ++count;
	    while (len && s[-1] == '\n') {
		--len;
		--s;
		++count;
	    }
	}
	else {
	    STRLEN rslen;
	    char *rsptr = SvPV(rs, rslen);
	    if (rslen == 1) {
		if (*s != *rsptr)
		    goto nope;
		++count;
	    }
	    else {
		if (len < rslen - 1)
		    goto nope;
		len -= rslen - 1;
		s -= rslen - 1;
		if (memNE(s, rsptr, rslen))
		    goto nope;
		count += rslen;
	    }
	}
	*s = '\0';
	SvCUR_set(sv, len);
	SvNIOK_off(sv);
    }
  nope:
    SvSETMAGIC(sv);
    return count;
} 

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;
    register char *rc;
    register I32 len;
    I32 lensave;
    char *lsave;
    char *rsave;

    if (sv != left || (optype != OP_BIT_AND && !SvOK(sv) && !SvGMAGICAL(sv)))
	sv_setpvn(sv, "", 0);	/* avoid undef warning on |= and ^= */
    lsave = lc = SvPV(left, leftlen);
    rsave = rc = SvPV(right, rightlen);
    len = leftlen < rightlen ? leftlen : rightlen;
    lensave = len;
    if (SvOK(sv) || SvTYPE(sv) > SVt_PVMG) {
	dc = SvPV_force(sv, na);
	if (SvCUR(sv) < len) {
	    dc = SvGROW(sv, len + 1);
	    (void)memzero(dc + SvCUR(sv), len - SvCUR(sv) + 1);
	}
    }
    else {
	I32 needlen = ((optype == OP_BIT_AND)
			? len : (leftlen > rightlen ? leftlen : rightlen));
	Newz(801, dc, needlen + 1, char);
	(void)sv_usepvn(sv, dc, needlen);
	dc = SvPVX(sv);		/* sv_usepvn() calls Renew() */
    }
    SvCUR_set(sv, len);
    (void)SvPOK_only(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_BIT_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_BIT_XOR:
	    while (len--)
		*dc++ = *lc++ ^ *rc++;
	    goto mop_up;
	case OP_BIT_OR:
	    while (len--)
		*dc++ = *lc++ | *rc++;
	  mop_up:
	    len = lensave;
	    if (rightlen > len)
		sv_catpvn(sv, rsave + len, rightlen - len);
	    else if (leftlen > len)
		sv_catpvn(sv, lsave + len, leftlen - len);
	    else
		*SvEND(sv) = '\0';
	    break;
	}
    }
}

OP *
do_kv(ARGS)
dARGS
{
    dSP;
    HV *hv = (HV*)POPs;
    register HE *entry;
    SV *tmpstr;
    I32 gimme = GIMME_V;
    I32 dokeys =   (op->op_type == OP_KEYS);
    I32 dovalues = (op->op_type == OP_VALUES);

    if (op->op_type == OP_RV2HV || op->op_type == OP_PADHV) 
	dokeys = dovalues = TRUE;

    if (!hv) {
	if (op->op_flags & OPf_MOD) {	/* lvalue */
	    dTARGET;		/* make sure to clear its target here */
	    if (SvTYPE(TARG) == SVt_PVLV)
		LvTARG(TARG) = Nullsv;
	    PUSHs(TARG);
	}
	RETURN;
    }

    (void)hv_iterinit(hv);	/* always reset iterator regardless */

    if (gimme == G_VOID)
	RETURN;

    if (gimme == G_SCALAR) {
	I32 i;
	dTARGET;

	if (op->op_flags & OPf_MOD) {	/* lvalue */
	    if (SvTYPE(TARG) < SVt_PVLV) {
		sv_upgrade(TARG, SVt_PVLV);
		sv_magic(TARG, Nullsv, 'k', Nullch, 0);
	    }
	    LvTYPE(TARG) = 'k';
	    LvTARG(TARG) = (SV*)hv;
	    PUSHs(TARG);
	    RETURN;
	}

	if (!SvRMAGICAL(hv) || !mg_find((SV*)hv,'P'))
	    i = HvKEYS(hv);
	else {
	    i = 0;
	    /*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));

    PUTBACK;	/* hv_iternext and hv_iterval might clobber stack_sp */
    while (entry = hv_iternext(hv)) {
	SPAGAIN;
	if (dokeys)
	    XPUSHs(hv_iterkeysv(entry));	/* won't clobber stack_sp */
	if (dovalues) {
	    tmpstr = NEWSV(45,0);
	    PUTBACK;
	    sv_setsv(tmpstr,hv_iterval(hv,entry));
	    SPAGAIN;
	    DEBUG_H( {
			sprintf(buf,"%lu%%%d=%lu\n",
				(unsigned long)HeHASH(entry),
				HvMAX(hv)+1,
				(unsigned long)(HeHASH(entry) & HvMAX(hv)));
			sv_setpv(tmpstr,buf);
	    } )
	    XPUSHs(sv_2mortal(tmpstr));
	}
	PUTBACK;
    }
    return NORMAL;
}
Commit	Line	Data
a0d0e21e	1	/* doop.c
79072805	2	*
9607fc9c	3	* Copyright (c) 1991-1997, Larry Wall
79072805 LW	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	*
a0d0e21e LW	8	*/
	9
	10	/*
	11	* "'So that was the job I felt I had to do when I started,' thought Sam."
79072805 LW	12	*/
	13
	14	#include "EXTERN.h"
	15	#include "perl.h"
	16
	17	#if !defined(NSIG) \|\| defined(M_UNIX) \|\| defined(M_XENIX)
	18	#include <signal.h>
	19	#endif
	20
79072805 LW	21	I32
	22	do_trans(sv,arg)
	23	SV *sv;
	24	OP *arg;
	25	{
	26	register short *tbl;
1476d272	27	register U8 *s;
	28	register U8 *send;
	29	register U8 *d;
79072805	30	register I32 ch;
1476d272	31	register I32 matches = 0;
79072805	32	register I32 squash = op->op_private & OPpTRANS_SQUASH;
463ee0b2	33	STRLEN len;
79072805	34
a0d0e21e LW	35	if (SvREADONLY(sv))
a0d0e21e LW	36	croak(no_modify);
1476d272	37	tbl = (short*)cPVOP->op_pv;
1476d272	38	s = (U8*)SvPV(sv, len);
a0d0e21e LW	39	if (!len)
	40	return 0;
	41	if (!SvPOKp(sv))
1476d272	42	s = (U8*)SvPV_force(sv, len);
a0d0e21e	43	(void)SvPOK_only(sv);
463ee0b2	44	send = s + len;
79072805	45	if (!tbl \|\| !s)
463ee0b2	46	croak("panic: do_trans");
79072805 LW	47	DEBUG_t( deb("2.TBL\n"));
	48	if (!op->op_private) {
	49	while (s < send) {
1476d272	50	if ((ch = tbl[*s]) >= 0) {
79072805 LW	51	matches++;
	52	*s = ch;
	53	}
	54	s++;
	55	}
	56	}
	57	else {
	58	d = s;
	59	while (s < send) {
1476d272	60	if ((ch = tbl[*s]) >= 0) {
79072805 LW	61	*d = ch;
	62	if (matches++ && squash) {
	63	if (d[-1] == *d)
	64	matches--;
	65	else
	66	d++;
	67	}
	68	else
	69	d++;
	70	}
	71	else if (ch == -1) /* -1 is unmapped character */
	72	d++ = s; /* -2 is delete character */
	73	s++;
	74	}
	75	matches += send - d; /* account for disappeared chars */
	76	*d = '\0';
1476d272	77	SvCUR_set(sv, d - (U8*)SvPVX(sv));
79072805 LW	78	}
	79	SvSETMAGIC(sv);
	80	return matches;
	81	}
	82
	83	void
	84	do_join(sv,del,mark,sp)
	85	register SV *sv;
	86	SV *del;
	87	register SV **mark;
	88	register SV **sp;
	89	{
	90	SV **oldmark = mark;
	91	register I32 items = sp - mark;
79072805	92	register STRLEN len;
463ee0b2 LW	93	STRLEN delimlen;
	94	register char *delim = SvPV(del, delimlen);
	95	STRLEN tmplen;
79072805 LW	96
	97	mark++;
	98	len = (items > 0 ? (delimlen * (items - 1) ) : 0);
	99	if (SvTYPE(sv) < SVt_PV)
	100	sv_upgrade(sv, SVt_PV);
	101	if (SvLEN(sv) < len + items) { /* current length is way too short */
	102	while (items-- > 0) {
	103	if (*mark) {
463ee0b2 LW	104	SvPV(*mark, tmplen);
463ee0b2 LW	105	len += tmplen;
79072805 LW	106	}
	107	mark++;
	108	}
	109	SvGROW(sv, len + 1); /* so try to pre-extend */
	110
	111	mark = oldmark;
	112	items = sp - mark;;
	113	++mark;
	114	}
	115
463ee0b2	116	if (items-- > 0) {
8990e307 LW	117	char *s;
	118
	119	if (*mark) {
	120	s = SvPV(*mark, tmplen);
	121	sv_setpvn(sv, s, tmplen);
	122	}
	123	else
	124	sv_setpv(sv, "");
463ee0b2 LW	125	mark++;
463ee0b2 LW	126	}
79072805 LW	127	else
	128	sv_setpv(sv,"");
	129	len = delimlen;
	130	if (len) {
	131	for (; items > 0; items--,mark++) {
	132	sv_catpvn(sv,delim,len);
	133	sv_catsv(sv,*mark);
	134	}
	135	}
	136	else {
	137	for (; items > 0; items--,mark++)
	138	sv_catsv(sv,*mark);
	139	}
	140	SvSETMAGIC(sv);
	141	}
	142
	143	void
	144	do_sprintf(sv,len,sarg)
	145	register SV *sv;
	146	register I32 len;
	147	register SV **sarg;
	148	{
	149	register char *s;
	150	register char *t;
	151	register char *f;
046ff0ed	152	char dotype;
79072805 LW	153	char ch;
	154	register char *send;
	155	register SV *arg;
	156	char *xs;
	157	I32 xlen;
	158	I32 pre;
	159	I32 post;
	160	double value;
463ee0b2	161	STRLEN arglen;
79072805 LW	162
	163	sv_setpv(sv,"");
	164	len--; /* don't count pattern string */
a0d0e21e	165	t = s = SvPV(sarg, arglen); / XXX Don't know t is writeable */
463ee0b2	166	send = s + arglen;
79072805 LW	167	sarg++;
	168	for ( ; ; len--) {
	169
	170	/SUPPRESS 560/
	171	if (len <= 0 \|\| !(arg = *sarg++))
	172	arg = &sv_no;
	173
	174	/SUPPRESS 530/
	175	for ( ; t < send && *t != '%'; t++) ;
	176	if (t >= send)
	177	break; /* end of run_format string, ignore extra args */
	178	f = t;
	179	*buf = '\0';
	180	xs = buf;
046ff0ed	181	dotype = '\0';
79072805 LW	182	pre = post = 0;
	183	for (t++; t < send; t++) {
	184	switch (*t) {
	185	default:
	186	ch = *(++t);
	187	*t = '\0';
	188	(void)sprintf(xs,f);
	189	len++, sarg--;
	190	xlen = strlen(xs);
	191	break;
748a9306 LW	192	case 'n': case '*':
	193	croak("Use of %c in printf format not supported", *t);
	194
79072805 LW	195	case '0': case '1': case '2': case '3': case '4':
	196	case '5': case '6': case '7': case '8': case '9':
	197	case '.': case '#': case '-': case '+': case ' ':
	198	continue;
463ee0b2	199	case 'l':
ecfc5424	200	#ifdef HAS_QUAD
046ff0ed CS	201	if (dotype == 'l')
	202	dotype = 'q';
	203	else
79072805	204	#endif
046ff0ed CS	205	dotype = 'l';
	206	continue;
	207	case 'h':
	208	dotype = 's';
79072805 LW	209	continue;
	210	case 'c':
	211	ch = *(++t);
	212	*t = '\0';
463ee0b2	213	xlen = SvIV(arg);
79072805 LW	214	if (strEQ(f,"%c")) { /* some printfs fail on null chars */
	215	*xs = xlen;
	216	xs[1] = '\0';
	217	xlen = 1;
	218	}
	219	else {
	220	(void)sprintf(xs,f,xlen);
	221	xlen = strlen(xs);
	222	}
	223	break;
	224	case 'D':
046ff0ed	225	dotype = 'l';
79072805 LW	226	/* FALL THROUGH */
79072805 LW	227	case 'd':
046ff0ed	228	case 'i':
79072805 LW	229	ch = *(++t);
79072805 LW	230	*t = '\0';
046ff0ed	231	switch (dotype) {
ecfc5424	232	#ifdef HAS_QUAD
046ff0ed CS	233	case 'q':
	234	/* perl.h says that if quad is available, IV is quad */
	235	(void)sprintf(xs,f,(Quad_t)SvIV(arg));
	236	break;
79072805	237	#endif
046ff0ed CS	238	case 'l':
	239	(void)sprintf(xs,f,(long)SvIV(arg));
	240	break;
	241	default:
	242	(void)sprintf(xs,f,(int)SvIV(arg));
	243	break;
	244	case 's':
	245	(void)sprintf(xs,f,(short)SvIV(arg));
	246	break;
	247	}
79072805 LW	248	xlen = strlen(xs);
	249	break;
	250	case 'X': case 'O':
046ff0ed	251	dotype = 'l';
79072805 LW	252	/* FALL THROUGH */
	253	case 'x': case 'o': case 'u':
	254	ch = *(++t);
	255	*t = '\0';
046ff0ed	256	switch (dotype) {
ecfc5424	257	#ifdef HAS_QUAD
046ff0ed CS	258	case 'q':
	259	/* perl.h says that if quad is available, UV is quad */
	260	(void)sprintf(xs,f,(unsigned Quad_t)SvUV(arg));
	261	break;
79072805	262	#endif
046ff0ed CS	263	case 'l':
	264	(void)sprintf(xs,f,(unsigned long)SvUV(arg));
	265	break;
	266	default:
	267	(void)sprintf(xs,f,(unsigned int)SvUV(arg));
	268	break;
	269	case 's':
	270	(void)sprintf(xs,f,(unsigned short)SvUV(arg));
	271	break;
	272	}
79072805 LW	273	xlen = strlen(xs);
	274	break;
	275	case 'E': case 'e': case 'f': case 'G': case 'g':
	276	ch = *(++t);
	277	*t = '\0';
463ee0b2	278	(void)sprintf(xs,f,SvNV(arg));
79072805	279	xlen = strlen(xs);
bbce6d69	280	#ifdef LC_NUMERIC
ff68c719	281	/*
	282	* User-defined locales may include arbitrary characters.
	283	* And, unfortunately, some system may alloc the "C" locale
	284	* to be overridden by a malicious user.
	285	*/
	286	if (op->op_type == OP_SPRINTF)
bbce6d69	287	SvTAINTED_on(sv);
ff68c719	288	#endif /* LC_NUMERIC */
79072805 LW	289	break;
	290	case 's':
	291	ch = *(++t);
	292	*t = '\0';
463ee0b2 LW	293	xs = SvPV(arg, arglen);
463ee0b2 LW	294	xlen = (I32)arglen;
79072805 LW	295	if (strEQ(f,"%s")) { /* some printfs fail on >128 chars */
	296	break; /* so handle simple cases */
	297	}
	298	else if (f[1] == '-') {
93a17b20	299	char *mp = strchr(f, '.');
79072805 LW	300	I32 min = atoi(f+2);
	301
	302	if (mp) {
	303	I32 max = atoi(mp+1);
	304
	305	if (xlen > max)
	306	xlen = max;
	307	}
	308	if (xlen < min)
	309	post = min - xlen;
	310	break;
	311	}
	312	else if (isDIGIT(f[1])) {
93a17b20	313	char *mp = strchr(f, '.');
79072805 LW	314	I32 min = atoi(f+1);
	315
	316	if (mp) {
	317	I32 max = atoi(mp+1);
	318
	319	if (xlen > max)
	320	xlen = max;
	321	}
	322	if (xlen < min)
	323	pre = min - xlen;
	324	break;
	325	}
	326	strcpy(tokenbuf+64,f); /* sprintf($s,...$s...) */
	327	*t = ch;
	328	(void)sprintf(buf,tokenbuf+64,xs);
	329	xs = buf;
	330	xlen = strlen(xs);
	331	break;
	332	}
	333	/* end of switch, copy results */
	334	*t = ch;
4633a7c4	335	if (xs == buf && xlen >= sizeof(buf)) { /* Ooops! */
760ac839	336	PerlIO_puts(PerlIO_stderr(),"panic: sprintf overflow - memory corrupted!\n");
4633a7c4 LW	337	my_exit(1);
4633a7c4 LW	338	}
79072805 LW	339	SvGROW(sv, SvCUR(sv) + (f - s) + xlen + 1 + pre + post);
	340	sv_catpvn(sv, s, f - s);
	341	if (pre) {
463ee0b2	342	repeatcpy(SvPVX(sv) + SvCUR(sv), " ", 1, pre);
79072805 LW	343	SvCUR(sv) += pre;
	344	}
	345	sv_catpvn(sv, xs, xlen);
	346	if (post) {
463ee0b2	347	repeatcpy(SvPVX(sv) + SvCUR(sv), " ", 1, post);
79072805 LW	348	SvCUR(sv) += post;
	349	}
	350	s = t;
	351	break; /* break from for loop */
	352	}
	353	}
	354	sv_catpvn(sv, s, t - s);
	355	SvSETMAGIC(sv);
	356	}
	357
	358	void
	359	do_vecset(sv)
	360	SV *sv;
	361	{
	362	SV *targ = LvTARG(sv);
	363	register I32 offset;
	364	register I32 size;
8990e307 LW	365	register unsigned char *s;
8990e307 LW	366	register unsigned long lval;
79072805	367	I32 mask;
a0d0e21e LW	368	STRLEN targlen;
a0d0e21e LW	369	STRLEN len;
79072805	370
8990e307 LW	371	if (!targ)
8990e307 LW	372	return;
a0d0e21e	373	s = (unsigned char*)SvPV_force(targ, targlen);
8990e307	374	lval = U_L(SvNV(sv));
79072805 LW	375	offset = LvTARGOFF(sv);
79072805 LW	376	size = LvTARGLEN(sv);
a0d0e21e LW	377
	378	len = (offset + size + 7) / 8;
	379	if (len > targlen) {
	380	s = (unsigned char*)SvGROW(targ, len + 1);
	381	(void)memzero(s + targlen, len - targlen + 1);
	382	SvCUR_set(targ, len);
	383	}
	384
79072805 LW	385	if (size < 8) {
	386	mask = (1 << size) - 1;
	387	size = offset & 7;
	388	lval &= mask;
	389	offset >>= 3;
	390	s[offset] &= ~(mask << size);
	391	s[offset] \|= lval << size;
	392	}
	393	else {
a0d0e21e	394	offset >>= 3;
79072805 LW	395	if (size == 8)
	396	s[offset] = lval & 255;
	397	else if (size == 16) {
	398	s[offset] = (lval >> 8) & 255;
	399	s[offset+1] = lval & 255;
	400	}
	401	else if (size == 32) {
	402	s[offset] = (lval >> 24) & 255;
	403	s[offset+1] = (lval >> 16) & 255;
	404	s[offset+2] = (lval >> 8) & 255;
	405	s[offset+3] = lval & 255;
	406	}
	407	}
	408	}
	409
	410	void
	411	do_chop(astr,sv)
	412	register SV *astr;
	413	register SV *sv;
	414	{
463ee0b2	415	STRLEN len;
a0d0e21e LW	416	char *s;
a0d0e21e LW	417
79072805	418	if (SvTYPE(sv) == SVt_PVAV) {
a0d0e21e LW	419	register I32 i;
	420	I32 max;
	421	AV* av = (AV*)sv;
	422	max = AvFILL(av);
	423	for (i = 0; i <= max; i++) {
	424	sv = (SV*)av_fetch(av, i, FALSE);
	425	if (sv && ((sv = (SV*)sv), sv != &sv_undef))
	426	do_chop(astr, sv);
	427	}
	428	return;
79072805 LW	429	}
79072805 LW	430	if (SvTYPE(sv) == SVt_PVHV) {
a0d0e21e LW	431	HV* hv = (HV*)sv;
	432	HE* entry;
	433	(void)hv_iterinit(hv);
	434	/SUPPRESS 560/
	435	while (entry = hv_iternext(hv))
	436	do_chop(astr,hv_iterval(hv,entry));
	437	return;
79072805	438	}
a0d0e21e	439	s = SvPV(sv, len);
748a9306	440	if (len && !SvPOK(sv))
a0d0e21e LW	441	s = SvPV_force(sv, len);
	442	if (s && len) {
	443	s += --len;
	444	sv_setpvn(astr, s, 1);
	445	*s = '\0';
	446	SvCUR_set(sv, len);
	447	SvNIOK_off(sv);
79072805 LW	448	}
79072805 LW	449	else
a0d0e21e LW	450	sv_setpvn(astr, "", 0);
	451	SvSETMAGIC(sv);
	452	}
	453
	454	I32
	455	do_chomp(sv)
	456	register SV *sv;
	457	{
c07a80fd	458	register I32 count;
a0d0e21e LW	459	STRLEN len;
a0d0e21e LW	460	char *s;
c07a80fd	461
	462	if (RsSNARF(rs))
	463	return 0;
	464	count = 0;
a0d0e21e LW	465	if (SvTYPE(sv) == SVt_PVAV) {
	466	register I32 i;
	467	I32 max;
	468	AV* av = (AV*)sv;
	469	max = AvFILL(av);
	470	for (i = 0; i <= max; i++) {
	471	sv = (SV*)av_fetch(av, i, FALSE);
	472	if (sv && ((sv = (SV*)sv), sv != &sv_undef))
	473	count += do_chomp(sv);
	474	}
	475	return count;
	476	}
	477	if (SvTYPE(sv) == SVt_PVHV) {
	478	HV* hv = (HV*)sv;
	479	HE* entry;
	480	(void)hv_iterinit(hv);
	481	/SUPPRESS 560/
	482	while (entry = hv_iternext(hv))
	483	count += do_chomp(hv_iterval(hv,entry));
	484	return count;
	485	}
	486	s = SvPV(sv, len);
	487	if (len && !SvPOKp(sv))
	488	s = SvPV_force(sv, len);
	489	if (s && len) {
	490	s += --len;
c07a80fd	491	if (RsPARA(rs)) {
a0d0e21e LW	492	if (*s != '\n')
	493	goto nope;
	494	++count;
	495	while (len && s[-1] == '\n') {
	496	--len;
	497	--s;
	498	++count;
	499	}
	500	}
a0d0e21e	501	else {
c07a80fd	502	STRLEN rslen;
	503	char *rsptr = SvPV(rs, rslen);
	504	if (rslen == 1) {
	505	if (s != rsptr)
	506	goto nope;
	507	++count;
	508	}
	509	else {
8c2cee6f	510	if (len < rslen - 1)
c07a80fd	511	goto nope;
	512	len -= rslen - 1;
	513	s -= rslen - 1;
36477c24	514	if (memNE(s, rsptr, rslen))
c07a80fd	515	goto nope;
	516	count += rslen;
	517	}
a0d0e21e	518	}
a0d0e21e LW	519	*s = '\0';
	520	SvCUR_set(sv, len);
	521	SvNIOK_off(sv);
	522	}
	523	nope:
	524	SvSETMAGIC(sv);
	525	return count;
	526	}
79072805 LW	527
	528	void
	529	do_vop(optype,sv,left,right)
	530	I32 optype;
	531	SV *sv;
	532	SV *left;
	533	SV *right;
	534	{
	535	#ifdef LIBERAL
	536	register long *dl;
	537	register long *ll;
	538	register long *rl;
	539	#endif
	540	register char *dc;
463ee0b2 LW	541	STRLEN leftlen;
463ee0b2 LW	542	STRLEN rightlen;
7a4c00b4	543	register char *lc;
7a4c00b4	544	register char *rc;
79072805	545	register I32 len;
a0d0e21e	546	I32 lensave;
7a4c00b4	547	char *lsave;
7a4c00b4	548	char *rsave;
79072805	549
1fbd88dc CS	550	if (sv != left \|\| (optype != OP_BIT_AND && !SvOK(sv) && !SvGMAGICAL(sv)))
1fbd88dc CS	551	sv_setpvn(sv, "", 0); /* avoid undef warning on \|= and ^= */
7a4c00b4	552	lsave = lc = SvPV(left, leftlen);
7a4c00b4	553	rsave = rc = SvPV(right, rightlen);
93a17b20	554	len = leftlen < rightlen ? leftlen : rightlen;
a0d0e21e	555	lensave = len;
7a4c00b4	556	if (SvOK(sv) \|\| SvTYPE(sv) > SVt_PVMG) {
ff68c719	557	dc = SvPV_force(sv, na);
	558	if (SvCUR(sv) < len) {
	559	dc = SvGROW(sv, len + 1);
	560	(void)memzero(dc + SvCUR(sv), len - SvCUR(sv) + 1);
	561	}
	562	}
	563	else {
	564	I32 needlen = ((optype == OP_BIT_AND)
	565	? len : (leftlen > rightlen ? leftlen : rightlen));
	566	Newz(801, dc, needlen + 1, char);
	567	(void)sv_usepvn(sv, dc, needlen);
	568	dc = SvPVX(sv); /* sv_usepvn() calls Renew() */
79072805	569	}
a0d0e21e LW	570	SvCUR_set(sv, len);
a0d0e21e LW	571	(void)SvPOK_only(sv);
79072805 LW	572	#ifdef LIBERAL
	573	if (len >= sizeof(long)*4 &&
	574	!((long)dc % sizeof(long)) &&
	575	!((long)lc % sizeof(long)) &&
	576	!((long)rc % sizeof(long))) /* It's almost always aligned... */
	577	{
	578	I32 remainder = len % (sizeof(long)*4);
	579	len /= (sizeof(long)*4);
	580
	581	dl = (long*)dc;
	582	ll = (long*)lc;
	583	rl = (long*)rc;
	584
	585	switch (optype) {
	586	case OP_BIT_AND:
	587	while (len--) {
	588	dl++ = ll++ & *rl++;
	589	dl++ = ll++ & *rl++;
	590	dl++ = ll++ & *rl++;
	591	dl++ = ll++ & *rl++;
	592	}
	593	break;
a0d0e21e	594	case OP_BIT_XOR:
79072805 LW	595	while (len--) {
	596	dl++ = ll++ ^ *rl++;
	597	dl++ = ll++ ^ *rl++;
	598	dl++ = ll++ ^ *rl++;
	599	dl++ = ll++ ^ *rl++;
	600	}
	601	break;
	602	case OP_BIT_OR:
	603	while (len--) {
	604	dl++ = ll++ \| *rl++;
	605	dl++ = ll++ \| *rl++;
	606	dl++ = ll++ \| *rl++;
	607	dl++ = ll++ \| *rl++;
	608	}
	609	}
	610
	611	dc = (char*)dl;
	612	lc = (char*)ll;
	613	rc = (char*)rl;
	614
	615	len = remainder;
	616	}
	617	#endif
a0d0e21e	618	{
a0d0e21e LW	619	switch (optype) {
	620	case OP_BIT_AND:
	621	while (len--)
	622	dc++ = lc++ & *rc++;
	623	break;
	624	case OP_BIT_XOR:
	625	while (len--)
	626	dc++ = lc++ ^ *rc++;
	627	goto mop_up;
	628	case OP_BIT_OR:
	629	while (len--)
	630	dc++ = lc++ \| *rc++;
	631	mop_up:
	632	len = lensave;
	633	if (rightlen > len)
	634	sv_catpvn(sv, rsave + len, rightlen - len);
	635	else if (leftlen > len)
	636	sv_catpvn(sv, lsave + len, leftlen - len);
4633a7c4 LW	637	else
4633a7c4 LW	638	*SvEND(sv) = '\0';
a0d0e21e LW	639	break;
a0d0e21e LW	640	}
79072805 LW	641	}
79072805 LW	642	}
463ee0b2 LW	643
	644	OP *
	645	do_kv(ARGS)
	646	dARGS
	647	{
	648	dSP;
	649	HV hv = (HV)POPs;
463ee0b2	650	register HE *entry;
463ee0b2	651	SV *tmpstr;
54310121	652	I32 gimme = GIMME_V;
a0d0e21e LW	653	I32 dokeys = (op->op_type == OP_KEYS);
	654	I32 dovalues = (op->op_type == OP_VALUES);
	655
	656	if (op->op_type == OP_RV2HV \|\| op->op_type == OP_PADHV)
	657	dokeys = dovalues = TRUE;
463ee0b2	658
85581909 SB	659	if (!hv) {
	660	if (op->op_flags & OPf_MOD) { /* lvalue */
	661	dTARGET; /* make sure to clear its target here */
	662	if (SvTYPE(TARG) == SVt_PVLV)
	663	LvTARG(TARG) = Nullsv;
	664	PUSHs(TARG);
	665	}
463ee0b2	666	RETURN;
85581909	667	}
748a9306 LW	668
	669	(void)hv_iterinit(hv); /* always reset iterator regardless */
	670
54310121	671	if (gimme == G_VOID)
aa689395	672	RETURN;
aa689395	673
54310121	674	if (gimme == G_SCALAR) {
8c2cee6f	675	I32 i;
463ee0b2 LW	676	dTARGET;
463ee0b2 LW	677
85581909 SB	678	if (op->op_flags & OPf_MOD) { /* lvalue */
	679	if (SvTYPE(TARG) < SVt_PVLV) {
	680	sv_upgrade(TARG, SVt_PVLV);
	681	sv_magic(TARG, Nullsv, 'k', Nullch, 0);
	682	}
	683	LvTYPE(TARG) = 'k';
	684	LvTARG(TARG) = (SV*)hv;
	685	PUSHs(TARG);
	686	RETURN;
	687	}
	688
8990e307	689	if (!SvRMAGICAL(hv) \|\| !mg_find((SV*)hv,'P'))
463ee0b2 LW	690	i = HvKEYS(hv);
	691	else {
	692	i = 0;
463ee0b2 LW	693	/SUPPRESS 560/
	694	while (entry = hv_iternext(hv)) {
	695	i++;
	696	}
	697	}
	698	PUSHi( i );
	699	RETURN;
	700	}
	701
	702	/* Guess how much room we need. hv_max may be a few too many. Oh well. */
	703	EXTEND(sp, HvMAX(hv) * (dokeys + dovalues));
	704
463ee0b2 LW	705	PUTBACK; /* hv_iternext and hv_iterval might clobber stack_sp */
	706	while (entry = hv_iternext(hv)) {
	707	SPAGAIN;
8c2cee6f	708	if (dokeys)
8c2cee6f	709	XPUSHs(hv_iterkeysv(entry)); /* won't clobber stack_sp */
463ee0b2 LW	710	if (dovalues) {
	711	tmpstr = NEWSV(45,0);
	712	PUTBACK;
	713	sv_setsv(tmpstr,hv_iterval(hv,entry));
	714	SPAGAIN;
	715	DEBUG_H( {
68dc0745	716	sprintf(buf,"%lu%%%d=%lu\n",
	717	(unsigned long)HeHASH(entry),
	718	HvMAX(hv)+1,
	719	(unsigned long)(HeHASH(entry) & HvMAX(hv)));
8c2cee6f	720	sv_setpv(tmpstr,buf);
463ee0b2 LW	721	} )
	722	XPUSHs(sv_2mortal(tmpstr));
	723	}
	724	PUTBACK;
	725	}
	726	return NORMAL;
	727	}
	728