perl5.git.perl.org Git - perl5.git/blame_incremental

... / ...

Commit	Line	Data
	1	/* doop.c
	2	*
	3	* Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
	4	* 2000, 2001, 2002, 2004, by Larry Wall and others
	5	*
	6	* You may distribute under the terms of either the GNU General Public
	7	* License or the Artistic License, as specified in the README file.
	8	*
	9	*/
	10
	11	/*
	12	* "'So that was the job I felt I had to do when I started,' thought Sam."
	13	*/
	14
	15	#include "EXTERN.h"
	16	#define PERL_IN_DOOP_C
	17	#include "perl.h"
	18
	19	#ifndef PERL_MICRO
	20	#include <signal.h>
	21	#endif
	22
	23	STATIC I32
	24	S_do_trans_simple(pTHX_ SV *sv)
	25	{
	26	U8 *s;
	27	U8 *d;
	28	U8 *send;
	29	U8 *dstart;
	30	I32 matches = 0;
	31	I32 grows = PL_op->op_private & OPpTRANS_GROWS;
	32	STRLEN len;
	33	short *tbl;
	34	I32 ch;
	35
	36	tbl = (short*)cPVOP->op_pv;
	37	if (!tbl)
	38	Perl_croak(aTHX_ "panic: do_trans_simple line %d",__LINE__);
	39
	40	s = (U8*)SvPV(sv, len);
	41	send = s + len;
	42
	43	/* First, take care of non-UTF-8 input strings, because they're easy */
	44	if (!SvUTF8(sv)) {
	45	while (s < send) {
	46	if ((ch = tbl[*s]) >= 0) {
	47	matches++;
	48	*s++ = (U8)ch;
	49	}
	50	else
	51	s++;
	52	}
	53	SvSETMAGIC(sv);
	54	return matches;
	55	}
	56
	57	/* Allow for expansion: $_="a".chr(400); tr/a/\xFE/, FE needs encoding */
	58	if (grows)
	59	New(0, d, len*2+1, U8);
	60	else
	61	d = s;
	62	dstart = d;
	63	while (s < send) {
	64	STRLEN ulen;
	65	UV c;
	66
	67	/* Need to check this, otherwise 128..255 won't match */
	68	c = utf8n_to_uvchr(s, send - s, &ulen, 0);
	69	if (c < 0x100 && (ch = tbl[c]) >= 0) {
	70	matches++;
	71	d = uvchr_to_utf8(d, ch);
	72	s += ulen;
	73	}
	74	else { /* No match -> copy */
	75	Move(s, d, ulen, U8);
	76	d += ulen;
	77	s += ulen;
	78	}
	79	}
	80	if (grows) {
	81	sv_setpvn(sv, (char*)dstart, d - dstart);
	82	Safefree(dstart);
	83	}
	84	else {
	85	*d = '\0';
	86	SvCUR_set(sv, d - dstart);
	87	}
	88	SvUTF8_on(sv);
	89	SvSETMAGIC(sv);
	90	return matches;
	91	}
	92
	93	STATIC I32
	94	S_do_trans_count(pTHX_ SV *sv)
	95	{
	96	U8 *s;
	97	U8 *send;
	98	I32 matches = 0;
	99	STRLEN len;
	100	short *tbl;
	101	I32 complement = PL_op->op_private & OPpTRANS_COMPLEMENT;
	102
	103	tbl = (short*)cPVOP->op_pv;
	104	if (!tbl)
	105	Perl_croak(aTHX_ "panic: do_trans_count line %d",__LINE__);
	106
	107	s = (U8*)SvPV(sv, len);
	108	send = s + len;
	109
	110	if (!SvUTF8(sv))
	111	while (s < send) {
	112	if (tbl[*s++] >= 0)
	113	matches++;
	114	}
	115	else
	116	while (s < send) {
	117	UV c;
	118	STRLEN ulen;
	119	c = utf8n_to_uvchr(s, send - s, &ulen, 0);
	120	if (c < 0x100) {
	121	if (tbl[c] >= 0)
	122	matches++;
	123	} else if (complement)
	124	matches++;
	125	s += ulen;
	126	}
	127
	128	return matches;
	129	}
	130
	131	STATIC I32
	132	S_do_trans_complex(pTHX_ SV *sv)
	133	{
	134	U8 *s;
	135	U8 *send;
	136	U8 *d;
	137	U8 *dstart;
	138	I32 isutf8;
	139	I32 matches = 0;
	140	I32 grows = PL_op->op_private & OPpTRANS_GROWS;
	141	I32 complement = PL_op->op_private & OPpTRANS_COMPLEMENT;
	142	I32 del = PL_op->op_private & OPpTRANS_DELETE;
	143	STRLEN len, rlen = 0;
	144	short *tbl;
	145	I32 ch;
	146
	147	tbl = (short*)cPVOP->op_pv;
	148	if (!tbl)
	149	Perl_croak(aTHX_ "panic: do_trans_complex line %d",__LINE__);
	150
	151	s = (U8*)SvPV(sv, len);
	152	isutf8 = SvUTF8(sv);
	153	send = s + len;
	154
	155	if (!isutf8) {
	156	dstart = d = s;
	157	if (PL_op->op_private & OPpTRANS_SQUASH) {
	158	U8* p = send;
	159	while (s < send) {
	160	if ((ch = tbl[*s]) >= 0) {
	161	*d = (U8)ch;
	162	matches++;
	163	if (p != d - 1 \|\| p != d)
	164	p = d++;
	165	}
	166	else if (ch == -1) /* -1 is unmapped character */
	167	d++ = s;
	168	else if (ch == -2) /* -2 is delete character */
	169	matches++;
	170	s++;
	171	}
	172	}
	173	else {
	174	while (s < send) {
	175	if ((ch = tbl[*s]) >= 0) {
	176	matches++;
	177	*d++ = (U8)ch;
	178	}
	179	else if (ch == -1) /* -1 is unmapped character */
	180	d++ = s;
	181	else if (ch == -2) /* -2 is delete character */
	182	matches++;
	183	s++;
	184	}
	185	}
	186	*d = '\0';
	187	SvCUR_set(sv, d - dstart);
	188	}
	189	else { /* isutf8 */
	190	if (grows)
	191	New(0, d, len*2+1, U8);
	192	else
	193	d = s;
	194	dstart = d;
	195	if (complement && !del)
	196	rlen = tbl[0x100];
	197
	198	#ifdef MACOS_TRADITIONAL
	199	#define comp CoMP /* "comp" is a keyword in some compilers ... */
	200	#endif
	201
	202	if (PL_op->op_private & OPpTRANS_SQUASH) {
	203	UV pch = 0xfeedface;
	204	while (s < send) {
	205	STRLEN len;
	206	UV comp = utf8_to_uvchr(s, &len);
	207
	208	if (comp > 0xff) {
	209	if (!complement) {
	210	Copy(s, d, len, U8);
	211	d += len;
	212	}
	213	else {
	214	matches++;
	215	if (!del) {
	216	ch = (rlen == 0) ? comp :
	217	(comp - 0x100 < rlen) ?
	218	tbl[comp+1] : tbl[0x100+rlen];
	219	if ((UV)ch != pch) {
	220	d = uvchr_to_utf8(d, ch);
	221	pch = (UV)ch;
	222	}
	223	s += len;
	224	continue;
	225	}
	226	}
	227	}
	228	else if ((ch = tbl[comp]) >= 0) {
	229	matches++;
	230	if ((UV)ch != pch) {
	231	d = uvchr_to_utf8(d, ch);
	232	pch = (UV)ch;
	233	}
	234	s += len;
	235	continue;
	236	}
	237	else if (ch == -1) { /* -1 is unmapped character */
	238	Copy(s, d, len, U8);
	239	d += len;
	240	}
	241	else if (ch == -2) /* -2 is delete character */
	242	matches++;
	243	s += len;
	244	pch = 0xfeedface;
	245	}
	246	}
	247	else {
	248	while (s < send) {
	249	STRLEN len;
	250	UV comp = utf8_to_uvchr(s, &len);
	251	if (comp > 0xff) {
	252	if (!complement) {
	253	Move(s, d, len, U8);
	254	d += len;
	255	}
	256	else {
	257	matches++;
	258	if (!del) {
	259	if (comp - 0x100 < rlen)
	260	d = uvchr_to_utf8(d, tbl[comp+1]);
	261	else
	262	d = uvchr_to_utf8(d, tbl[0x100+rlen]);
	263	}
	264	}
	265	}
	266	else if ((ch = tbl[comp]) >= 0) {
	267	d = uvchr_to_utf8(d, ch);
	268	matches++;
	269	}
	270	else if (ch == -1) { /* -1 is unmapped character */
	271	Copy(s, d, len, U8);
	272	d += len;
	273	}
	274	else if (ch == -2) /* -2 is delete character */
	275	matches++;
	276	s += len;
	277	}
	278	}
	279	if (grows) {
	280	sv_setpvn(sv, (char*)dstart, d - dstart);
	281	Safefree(dstart);
	282	}
	283	else {
	284	*d = '\0';
	285	SvCUR_set(sv, d - dstart);
	286	}
	287	SvUTF8_on(sv);
	288	}
	289	SvSETMAGIC(sv);
	290	return matches;
	291	}
	292
	293	STATIC I32
	294	S_do_trans_simple_utf8(pTHX_ SV *sv)
	295	{
	296	U8 *s;
	297	U8 *send;
	298	U8 *d;
	299	U8 *start;
	300	U8 dstart, dend;
	301	I32 matches = 0;
	302	I32 grows = PL_op->op_private & OPpTRANS_GROWS;
	303	STRLEN len;
	304
	305	SV* rv = (SV*)cSVOP->op_sv;
	306	HV* hv = (HV*)SvRV(rv);
	307	SV** svp = hv_fetch(hv, "NONE", 4, FALSE);
	308	UV none = svp ? SvUV(*svp) : 0x7fffffff;
	309	UV extra = none + 1;
	310	UV final = 0;
	311	UV uv;
	312	I32 isutf8;
	313	U8 hibit = 0;
	314
	315	s = (U8*)SvPV(sv, len);
	316	isutf8 = SvUTF8(sv);
	317	if (!isutf8) {
	318	U8 t = s, e = s + len;
	319	while (t < e) {
	320	U8 ch = *t++;
	321	if ((hibit = !NATIVE_IS_INVARIANT(ch)))
	322	break;
	323	}
	324	if (hibit)
	325	s = bytes_to_utf8(s, &len);
	326	}
	327	send = s + len;
	328	start = s;
	329
	330	svp = hv_fetch(hv, "FINAL", 5, FALSE);
	331	if (svp)
	332	final = SvUV(*svp);
	333
	334	if (grows) {
	335	/* d needs to be bigger than s, in case e.g. upgrading is required */
	336	New(0, d, len*3+UTF8_MAXLEN, U8);
	337	dend = d + len * 3;
	338	dstart = d;
	339	}
	340	else {
	341	dstart = d = s;
	342	dend = d + len;
	343	}
	344
	345	while (s < send) {
	346	if ((uv = swash_fetch(rv, s, TRUE)) < none) {
	347	s += UTF8SKIP(s);
	348	matches++;
	349	d = uvuni_to_utf8(d, uv);
	350	}
	351	else if (uv == none) {
	352	int i = UTF8SKIP(s);
	353	Move(s, d, i, U8);
	354	d += i;
	355	s += i;
	356	}
	357	else if (uv == extra) {
	358	int i = UTF8SKIP(s);
	359	s += i;
	360	matches++;
	361	d = uvuni_to_utf8(d, final);
	362	}
	363	else
	364	s += UTF8SKIP(s);
	365
	366	if (d > dend) {
	367	STRLEN clen = d - dstart;
	368	STRLEN nlen = dend - dstart + len + UTF8_MAXLEN;
	369	if (!grows)
	370	Perl_croak(aTHX_ "panic: do_trans_simple_utf8 line %d",__LINE__);
	371	Renew(dstart, nlen+UTF8_MAXLEN, U8);
	372	d = dstart + clen;
	373	dend = dstart + nlen;
	374	}
	375	}
	376	if (grows \|\| hibit) {
	377	sv_setpvn(sv, (char*)dstart, d - dstart);
	378	Safefree(dstart);
	379	if (grows && hibit)
	380	Safefree(start);
	381	}
	382	else {
	383	*d = '\0';
	384	SvCUR_set(sv, d - dstart);
	385	}
	386	SvSETMAGIC(sv);
	387	SvUTF8_on(sv);
	388
	389	return matches;
	390	}
	391
	392	STATIC I32
	393	S_do_trans_count_utf8(pTHX_ SV *sv)
	394	{
	395	U8 *s;
	396	U8 start = 0, send;
	397	I32 matches = 0;
	398	STRLEN len;
	399
	400	SV* rv = (SV*)cSVOP->op_sv;
	401	HV* hv = (HV*)SvRV(rv);
	402	SV** svp = hv_fetch(hv, "NONE", 4, FALSE);
	403	UV none = svp ? SvUV(*svp) : 0x7fffffff;
	404	UV extra = none + 1;
	405	UV uv;
	406	U8 hibit = 0;
	407
	408	s = (U8*)SvPV(sv, len);
	409	if (!SvUTF8(sv)) {
	410	U8 t = s, e = s + len;
	411	while (t < e) {
	412	U8 ch = *t++;
	413	if ((hibit = !NATIVE_IS_INVARIANT(ch)))
	414	break;
	415	}
	416	if (hibit)
	417	start = s = bytes_to_utf8(s, &len);
	418	}
	419	send = s + len;
	420
	421	while (s < send) {
	422	if ((uv = swash_fetch(rv, s, TRUE)) < none \|\| uv == extra)
	423	matches++;
	424	s += UTF8SKIP(s);
	425	}
	426	if (hibit)
	427	Safefree(start);
	428
	429	return matches;
	430	}
	431
	432	STATIC I32
	433	S_do_trans_complex_utf8(pTHX_ SV *sv)
	434	{
	435	U8 *s;
	436	U8 start, send;
	437	U8 *d;
	438	I32 matches = 0;
	439	I32 squash = PL_op->op_private & OPpTRANS_SQUASH;
	440	I32 del = PL_op->op_private & OPpTRANS_DELETE;
	441	I32 grows = PL_op->op_private & OPpTRANS_GROWS;
	442	SV* rv = (SV*)cSVOP->op_sv;
	443	HV* hv = (HV*)SvRV(rv);
	444	SV** svp = hv_fetch(hv, "NONE", 4, FALSE);
	445	UV none = svp ? SvUV(*svp) : 0x7fffffff;
	446	UV extra = none + 1;
	447	UV final = 0;
	448	bool havefinal = FALSE;
	449	UV uv;
	450	STRLEN len;
	451	U8 dstart, dend;
	452	I32 isutf8;
	453	U8 hibit = 0;
	454
	455	s = (U8*)SvPV(sv, len);
	456	isutf8 = SvUTF8(sv);
	457	if (!isutf8) {
	458	U8 t = s, e = s + len;
	459	while (t < e) {
	460	U8 ch = *t++;
	461	if ((hibit = !NATIVE_IS_INVARIANT(ch)))
	462	break;
	463	}
	464	if (hibit)
	465	s = bytes_to_utf8(s, &len);
	466	}
	467	send = s + len;
	468	start = s;
	469
	470	svp = hv_fetch(hv, "FINAL", 5, FALSE);
	471	if (svp) {
	472	final = SvUV(*svp);
	473	havefinal = TRUE;
	474	}
	475
	476	if (grows) {
	477	/* d needs to be bigger than s, in case e.g. upgrading is required */
	478	New(0, d, len*3+UTF8_MAXLEN, U8);
	479	dend = d + len * 3;
	480	dstart = d;
	481	}
	482	else {
	483	dstart = d = s;
	484	dend = d + len;
	485	}
	486
	487	if (squash) {
	488	UV puv = 0xfeedface;
	489	while (s < send) {
	490	uv = swash_fetch(rv, s, TRUE);
	491
	492	if (d > dend) {
	493	STRLEN clen = d - dstart;
	494	STRLEN nlen = dend - dstart + len + UTF8_MAXLEN;
	495	if (!grows)
	496	Perl_croak(aTHX_ "panic: do_trans_complex_utf8 line %d",__LINE__);
	497	Renew(dstart, nlen+UTF8_MAXLEN, U8);
	498	d = dstart + clen;
	499	dend = dstart + nlen;
	500	}
	501	if (uv < none) {
	502	matches++;
	503	s += UTF8SKIP(s);
	504	if (uv != puv) {
	505	d = uvuni_to_utf8(d, uv);
	506	puv = uv;
	507	}
	508	continue;
	509	}
	510	else if (uv == none) { /* "none" is unmapped character */
	511	int i = UTF8SKIP(s);
	512	Move(s, d, i, U8);
	513	d += i;
	514	s += i;
	515	puv = 0xfeedface;
	516	continue;
	517	}
	518	else if (uv == extra && !del) {
	519	matches++;
	520	if (havefinal) {
	521	s += UTF8SKIP(s);
	522	if (puv != final) {
	523	d = uvuni_to_utf8(d, final);
	524	puv = final;
	525	}
	526	}
	527	else {
	528	STRLEN len;
	529	uv = utf8_to_uvuni(s, &len);
	530	if (uv != puv) {
	531	Move(s, d, len, U8);
	532	d += len;
	533	puv = uv;
	534	}
	535	s += len;
	536	}
	537	continue;
	538	}
	539	matches++; /* "none+1" is delete character */
	540	s += UTF8SKIP(s);
	541	}
	542	}
	543	else {
	544	while (s < send) {
	545	uv = swash_fetch(rv, s, TRUE);
	546	if (d > dend) {
	547	STRLEN clen = d - dstart;
	548	STRLEN nlen = dend - dstart + len + UTF8_MAXLEN;
	549	if (!grows)
	550	Perl_croak(aTHX_ "panic: do_trans_complex_utf8 line %d",__LINE__);
	551	Renew(dstart, nlen+UTF8_MAXLEN, U8);
	552	d = dstart + clen;
	553	dend = dstart + nlen;
	554	}
	555	if (uv < none) {
	556	matches++;
	557	s += UTF8SKIP(s);
	558	d = uvuni_to_utf8(d, uv);
	559	continue;
	560	}
	561	else if (uv == none) { /* "none" is unmapped character */
	562	int i = UTF8SKIP(s);
	563	Move(s, d, i, U8);
	564	d += i;
	565	s += i;
	566	continue;
	567	}
	568	else if (uv == extra && !del) {
	569	matches++;
	570	s += UTF8SKIP(s);
	571	d = uvuni_to_utf8(d, final);
	572	continue;
	573	}
	574	matches++; /* "none+1" is delete character */
	575	s += UTF8SKIP(s);
	576	}
	577	}
	578	if (grows \|\| hibit) {
	579	sv_setpvn(sv, (char*)dstart, d - dstart);
	580	Safefree(dstart);
	581	if (grows && hibit)
	582	Safefree(start);
	583	}
	584	else {
	585	*d = '\0';
	586	SvCUR_set(sv, d - dstart);
	587	}
	588	SvUTF8_on(sv);
	589	SvSETMAGIC(sv);
	590
	591	return matches;
	592	}
	593
	594	I32
	595	Perl_do_trans(pTHX_ SV *sv)
	596	{
	597	STRLEN len;
	598	I32 hasutf = (PL_op->op_private &
	599	(OPpTRANS_FROM_UTF\|OPpTRANS_TO_UTF));
	600
	601	if (SvREADONLY(sv)) {
	602	if (SvIsCOW(sv))
	603	sv_force_normal_flags(sv, 0);
	604	if (SvREADONLY(sv) && !(PL_op->op_private & OPpTRANS_IDENTICAL))
	605	Perl_croak(aTHX_ PL_no_modify);
	606	}
	607	(void)SvPV(sv, len);
	608	if (!len)
	609	return 0;
	610	if (!(PL_op->op_private & OPpTRANS_IDENTICAL)) {
	611	if (!SvPOKp(sv))
	612	(void)SvPV_force(sv, len);
	613	(void)SvPOK_only_UTF8(sv);
	614	}
	615
	616	DEBUG_t( Perl_deb(aTHX_ "2.TBL\n"));
	617
	618	switch (PL_op->op_private & ~hasutf & (
	619	OPpTRANS_FROM_UTF\|OPpTRANS_TO_UTF\|OPpTRANS_IDENTICAL\|
	620	OPpTRANS_SQUASH\|OPpTRANS_DELETE\|OPpTRANS_COMPLEMENT)) {
	621	case 0:
	622	if (hasutf)
	623	return do_trans_simple_utf8(sv);
	624	else
	625	return do_trans_simple(sv);
	626
	627	case OPpTRANS_IDENTICAL:
	628	case OPpTRANS_IDENTICAL\|OPpTRANS_COMPLEMENT:
	629	if (hasutf)
	630	return do_trans_count_utf8(sv);
	631	else
	632	return do_trans_count(sv);
	633
	634	default:
	635	if (hasutf)
	636	return do_trans_complex_utf8(sv);
	637	else
	638	return do_trans_complex(sv);
	639	}
	640	}
	641
	642	void
	643	Perl_do_join(pTHX_ register SV sv, SV del, register SV mark, register SV sp)
	644	{
	645	SV **oldmark = mark;
	646	register I32 items = sp - mark;
	647	register STRLEN len;
	648	STRLEN delimlen;
	649	STRLEN tmplen;
	650
	651	(void) SvPV(del, delimlen); /* stringify and get the delimlen */
	652	/* SvCUR assumes it's SvPOK() and woe betide you if it's not. */
	653
	654	mark++;
	655	len = (items > 0 ? (delimlen * (items - 1) ) : 0);
	656	(void)SvUPGRADE(sv, SVt_PV);
	657	if (SvLEN(sv) < len + items) { /* current length is way too short */
	658	while (items-- > 0) {
	659	if (mark && !SvGAMAGIC(mark) && SvOK(*mark)) {
	660	SvPV(*mark, tmplen);
	661	len += tmplen;
	662	}
	663	mark++;
	664	}
	665	SvGROW(sv, len + 1); /* so try to pre-extend */
	666
	667	mark = oldmark;
	668	items = sp - mark;
	669	++mark;
	670	}
	671
	672	sv_setpvn(sv, "", 0);
	673	/* sv_setpv retains old UTF8ness [perl #24846] */
	674	if (SvUTF8(sv))
	675	SvUTF8_off(sv);
	676
	677	if (PL_tainting && SvMAGICAL(sv))
	678	SvTAINTED_off(sv);
	679
	680	if (items-- > 0) {
	681	if (*mark)
	682	sv_catsv(sv, *mark);
	683	mark++;
	684	}
	685
	686	if (delimlen) {
	687	for (; items > 0; items--,mark++) {
	688	sv_catsv(sv,del);
	689	sv_catsv(sv,*mark);
	690	}
	691	}
	692	else {
	693	for (; items > 0; items--,mark++)
	694	sv_catsv(sv,*mark);
	695	}
	696	SvSETMAGIC(sv);
	697	}
	698
	699	void
	700	Perl_do_sprintf(pTHX_ SV sv, I32 len, SV *sarg)
	701	{
	702	STRLEN patlen;
	703	char pat = SvPV(sarg, patlen);
	704	bool do_taint = FALSE;
	705
	706	SvUTF8_off(sv);
	707	if (DO_UTF8(*sarg))
	708	SvUTF8_on(sv);
	709	sv_vsetpvfn(sv, pat, patlen, Null(va_list*), sarg + 1, len - 1, &do_taint);
	710	SvSETMAGIC(sv);
	711	if (do_taint)
	712	SvTAINTED_on(sv);
	713	}
	714
	715	/* currently converts input to bytes if possible, but doesn't sweat failure */
	716	UV
	717	Perl_do_vecget(pTHX_ SV *sv, I32 offset, I32 size)
	718	{
	719	STRLEN srclen, len;
	720	unsigned char s = (unsigned char ) SvPV(sv, srclen);
	721	UV retnum = 0;
	722
	723	if (offset < 0)
	724	return retnum;
	725	if (size < 1 \|\| (size & (size-1))) /* size < 1 or not a power of two */
	726	Perl_croak(aTHX_ "Illegal number of bits in vec");
	727
	728	if (SvUTF8(sv))
	729	(void) Perl_sv_utf8_downgrade(aTHX_ sv, TRUE);
	730
	731	offset = size; / turn into bit offset */
	732	len = (offset + size + 7) / 8; /* required number of bytes */
	733	if (len > srclen) {
	734	if (size <= 8)
	735	retnum = 0;
	736	else {
	737	offset >>= 3; /* turn into byte offset */
	738	if (size == 16) {
	739	if ((STRLEN)offset >= srclen)
	740	retnum = 0;
	741	else
	742	retnum = (UV) s[offset] << 8;
	743	}
	744	else if (size == 32) {
	745	if ((STRLEN)offset >= srclen)
	746	retnum = 0;
	747	else if ((STRLEN)(offset + 1) >= srclen)
	748	retnum =
	749	((UV) s[offset ] << 24);
	750	else if ((STRLEN)(offset + 2) >= srclen)
	751	retnum =
	752	((UV) s[offset ] << 24) +
	753	((UV) s[offset + 1] << 16);
	754	else
	755	retnum =
	756	((UV) s[offset ] << 24) +
	757	((UV) s[offset + 1] << 16) +
	758	( s[offset + 2] << 8);
	759	}
	760	#ifdef UV_IS_QUAD
	761	else if (size == 64) {
	762	if (ckWARN(WARN_PORTABLE))
	763	Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
	764	"Bit vector size > 32 non-portable");
	765	if (offset >= srclen)
	766	retnum = 0;
	767	else if (offset + 1 >= srclen)
	768	retnum =
	769	(UV) s[offset ] << 56;
	770	else if (offset + 2 >= srclen)
	771	retnum =
	772	((UV) s[offset ] << 56) +
	773	((UV) s[offset + 1] << 48);
	774	else if (offset + 3 >= srclen)
	775	retnum =
	776	((UV) s[offset ] << 56) +
	777	((UV) s[offset + 1] << 48) +
	778	((UV) s[offset + 2] << 40);
	779	else if (offset + 4 >= srclen)
	780	retnum =
	781	((UV) s[offset ] << 56) +
	782	((UV) s[offset + 1] << 48) +
	783	((UV) s[offset + 2] << 40) +
	784	((UV) s[offset + 3] << 32);
	785	else if (offset + 5 >= srclen)
	786	retnum =
	787	((UV) s[offset ] << 56) +
	788	((UV) s[offset + 1] << 48) +
	789	((UV) s[offset + 2] << 40) +
	790	((UV) s[offset + 3] << 32) +
	791	( s[offset + 4] << 24);
	792	else if (offset + 6 >= srclen)
	793	retnum =
	794	((UV) s[offset ] << 56) +
	795	((UV) s[offset + 1] << 48) +
	796	((UV) s[offset + 2] << 40) +
	797	((UV) s[offset + 3] << 32) +
	798	((UV) s[offset + 4] << 24) +
	799	((UV) s[offset + 5] << 16);
	800	else
	801	retnum =
	802	((UV) s[offset ] << 56) +
	803	((UV) s[offset + 1] << 48) +
	804	((UV) s[offset + 2] << 40) +
	805	((UV) s[offset + 3] << 32) +
	806	((UV) s[offset + 4] << 24) +
	807	((UV) s[offset + 5] << 16) +
	808	( s[offset + 6] << 8);
	809	}
	810	#endif
	811	}
	812	}
	813	else if (size < 8)
	814	retnum = (s[offset >> 3] >> (offset & 7)) & ((1 << size) - 1);
	815	else {
	816	offset >>= 3; /* turn into byte offset */
	817	if (size == 8)
	818	retnum = s[offset];
	819	else if (size == 16)
	820	retnum =
	821	((UV) s[offset] << 8) +
	822	s[offset + 1];
	823	else if (size == 32)
	824	retnum =
	825	((UV) s[offset ] << 24) +
	826	((UV) s[offset + 1] << 16) +
	827	( s[offset + 2] << 8) +
	828	s[offset + 3];
	829	#ifdef UV_IS_QUAD
	830	else if (size == 64) {
	831	if (ckWARN(WARN_PORTABLE))
	832	Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
	833	"Bit vector size > 32 non-portable");
	834	retnum =
	835	((UV) s[offset ] << 56) +
	836	((UV) s[offset + 1] << 48) +
	837	((UV) s[offset + 2] << 40) +
	838	((UV) s[offset + 3] << 32) +
	839	((UV) s[offset + 4] << 24) +
	840	((UV) s[offset + 5] << 16) +
	841	( s[offset + 6] << 8) +
	842	s[offset + 7];
	843	}
	844	#endif
	845	}
	846
	847	return retnum;
	848	}
	849
	850	/* currently converts input to bytes if possible but doesn't sweat failures,
	851	* although it does ensure that the string it clobbers is not marked as
	852	* utf8-valid any more
	853	*/
	854	void
	855	Perl_do_vecset(pTHX_ SV *sv)
	856	{
	857	SV *targ = LvTARG(sv);
	858	register I32 offset;
	859	register I32 size;
	860	register unsigned char *s;
	861	register UV lval;
	862	I32 mask;
	863	STRLEN targlen;
	864	STRLEN len;
	865
	866	if (!targ)
	867	return;
	868	s = (unsigned char*)SvPV_force(targ, targlen);
	869	if (SvUTF8(targ)) {
	870	/* This is handled by the SvPOK_only below...
	871	if (!Perl_sv_utf8_downgrade(aTHX_ targ, TRUE))
	872	SvUTF8_off(targ);
	873	*/
	874	(void) Perl_sv_utf8_downgrade(aTHX_ targ, TRUE);
	875	}
	876
	877	(void)SvPOK_only(targ);
	878	lval = SvUV(sv);
	879	offset = LvTARGOFF(sv);
	880	if (offset < 0)
	881	Perl_croak(aTHX_ "Negative offset to vec in lvalue context");
	882	size = LvTARGLEN(sv);
	883	if (size < 1 \|\| (size & (size-1))) /* size < 1 or not a power of two */
	884	Perl_croak(aTHX_ "Illegal number of bits in vec");
	885
	886	offset = size; / turn into bit offset */
	887	len = (offset + size + 7) / 8; /* required number of bytes */
	888	if (len > targlen) {
	889	s = (unsigned char*)SvGROW(targ, len + 1);
	890	(void)memzero((char *)(s + targlen), len - targlen + 1);
	891	SvCUR_set(targ, len);
	892	}
	893
	894	if (size < 8) {
	895	mask = (1 << size) - 1;
	896	size = offset & 7;
	897	lval &= mask;
	898	offset >>= 3; /* turn into byte offset */
	899	s[offset] &= ~(mask << size);
	900	s[offset] \|= lval << size;
	901	}
	902	else {
	903	offset >>= 3; /* turn into byte offset */
	904	if (size == 8)
	905	s[offset ] = (U8)( lval & 0xff);
	906	else if (size == 16) {
	907	s[offset ] = (U8)((lval >> 8) & 0xff);
	908	s[offset+1] = (U8)( lval & 0xff);
	909	}
	910	else if (size == 32) {
	911	s[offset ] = (U8)((lval >> 24) & 0xff);
	912	s[offset+1] = (U8)((lval >> 16) & 0xff);
	913	s[offset+2] = (U8)((lval >> 8) & 0xff);
	914	s[offset+3] = (U8)( lval & 0xff);
	915	}
	916	#ifdef UV_IS_QUAD
	917	else if (size == 64) {
	918	if (ckWARN(WARN_PORTABLE))
	919	Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
	920	"Bit vector size > 32 non-portable");
	921	s[offset ] = (U8)((lval >> 56) & 0xff);
	922	s[offset+1] = (U8)((lval >> 48) & 0xff);
	923	s[offset+2] = (U8)((lval >> 40) & 0xff);
	924	s[offset+3] = (U8)((lval >> 32) & 0xff);
	925	s[offset+4] = (U8)((lval >> 24) & 0xff);
	926	s[offset+5] = (U8)((lval >> 16) & 0xff);
	927	s[offset+6] = (U8)((lval >> 8) & 0xff);
	928	s[offset+7] = (U8)( lval & 0xff);
	929	}
	930	#endif
	931	}
	932	SvSETMAGIC(targ);
	933	}
	934
	935	void
	936	Perl_do_chop(pTHX_ register SV astr, register SV sv)
	937	{
	938	STRLEN len;
	939	char *s;
	940
	941	if (SvTYPE(sv) == SVt_PVAV) {
	942	register I32 i;
	943	I32 max;
	944	AV* av = (AV*)sv;
	945	max = AvFILL(av);
	946	for (i = 0; i <= max; i++) {
	947	sv = (SV*)av_fetch(av, i, FALSE);
	948	if (sv && ((sv = (SV*)sv), sv != &PL_sv_undef))
	949	do_chop(astr, sv);
	950	}
	951	return;
	952	}
	953	else if (SvTYPE(sv) == SVt_PVHV) {
	954	HV* hv = (HV*)sv;
	955	HE* entry;
	956	(void)hv_iterinit(hv);
	957	/SUPPRESS 560/
	958	while ((entry = hv_iternext(hv)))
	959	do_chop(astr,hv_iterval(hv,entry));
	960	return;
	961	}
	962	else if (SvREADONLY(sv)) {
	963	if (SvFAKE(sv)) {
	964	/* SV is copy-on-write */
	965	sv_force_normal_flags(sv, 0);
	966	}
	967	if (SvREADONLY(sv))
	968	Perl_croak(aTHX_ PL_no_modify);
	969	}
	970	s = SvPV(sv, len);
	971	if (len && !SvPOK(sv))
	972	s = SvPV_force(sv, len);
	973	if (DO_UTF8(sv)) {
	974	if (s && len) {
	975	char *send = s + len;
	976	char *start = s;
	977	s = send - 1;
	978	while (s > start && UTF8_IS_CONTINUATION(*s))
	979	s--;
	980	if (utf8_to_uvchr((U8*)s, 0)) {
	981	sv_setpvn(astr, s, send - s);
	982	*s = '\0';
	983	SvCUR_set(sv, s - start);
	984	SvNIOK_off(sv);
	985	SvUTF8_on(astr);
	986	}
	987	}
	988	else
	989	sv_setpvn(astr, "", 0);
	990	}
	991	else if (s && len) {
	992	s += --len;
	993	sv_setpvn(astr, s, 1);
	994	*s = '\0';
	995	SvCUR_set(sv, len);
	996	SvUTF8_off(sv);
	997	SvNIOK_off(sv);
	998	}
	999	else
	1000	sv_setpvn(astr, "", 0);
	1001	SvSETMAGIC(sv);
	1002	}
	1003
	1004	I32
	1005	Perl_do_chomp(pTHX_ register SV *sv)
	1006	{
	1007	register I32 count;
	1008	STRLEN len;
	1009	STRLEN n_a;
	1010	char *s;
	1011	char *temp_buffer = NULL;
	1012	SV* svrecode = Nullsv;
	1013
	1014	if (RsSNARF(PL_rs))
	1015	return 0;
	1016	if (RsRECORD(PL_rs))
	1017	return 0;
	1018	count = 0;
	1019	if (SvTYPE(sv) == SVt_PVAV) {
	1020	register I32 i;
	1021	I32 max;
	1022	AV* av = (AV*)sv;
	1023	max = AvFILL(av);
	1024	for (i = 0; i <= max; i++) {
	1025	sv = (SV*)av_fetch(av, i, FALSE);
	1026	if (sv && ((sv = (SV*)sv), sv != &PL_sv_undef))
	1027	count += do_chomp(sv);
	1028	}
	1029	return count;
	1030	}
	1031	else if (SvTYPE(sv) == SVt_PVHV) {
	1032	HV* hv = (HV*)sv;
	1033	HE* entry;
	1034	(void)hv_iterinit(hv);
	1035	/SUPPRESS 560/
	1036	while ((entry = hv_iternext(hv)))
	1037	count += do_chomp(hv_iterval(hv,entry));
	1038	return count;
	1039	}
	1040	else if (SvREADONLY(sv)) {
	1041	if (SvFAKE(sv)) {
	1042	/* SV is copy-on-write */
	1043	sv_force_normal_flags(sv, 0);
	1044	}
	1045	if (SvREADONLY(sv))
	1046	Perl_croak(aTHX_ PL_no_modify);
	1047	}
	1048
	1049	if (PL_encoding) {
	1050	if (!SvUTF8(sv)) {
	1051	/* XXX, here sv is utf8-ized as a side-effect!
	1052	If encoding.pm is used properly, almost string-generating
	1053	operations, including literal strings, chr(), input data, etc.
	1054	should have been utf8-ized already, right?
	1055	*/
	1056	sv_recode_to_utf8(sv, PL_encoding);
	1057	}
	1058	}
	1059
	1060	s = SvPV(sv, len);
	1061	if (s && len) {
	1062	s += --len;
	1063	if (RsPARA(PL_rs)) {
	1064	if (*s != '\n')
	1065	goto nope;
	1066	++count;
	1067	while (len && s[-1] == '\n') {
	1068	--len;
	1069	--s;
	1070	++count;
	1071	}
	1072	}
	1073	else {
	1074	STRLEN rslen, rs_charlen;
	1075	char *rsptr = SvPV(PL_rs, rslen);
	1076
	1077	rs_charlen = SvUTF8(PL_rs)
	1078	? sv_len_utf8(PL_rs)
	1079	: rslen;
	1080
	1081	if (SvUTF8(PL_rs) != SvUTF8(sv)) {
	1082	/* Assumption is that rs is shorter than the scalar. */
	1083	if (SvUTF8(PL_rs)) {
	1084	/* RS is utf8, scalar is 8 bit. */
	1085	bool is_utf8 = TRUE;
	1086	temp_buffer = (char)bytes_from_utf8((U8)rsptr,
	1087	&rslen, &is_utf8);
	1088	if (is_utf8) {
	1089	/* Cannot downgrade, therefore cannot possibly match
	1090	*/
	1091	assert (temp_buffer == rsptr);
	1092	temp_buffer = NULL;
	1093	goto nope;
	1094	}
	1095	rsptr = temp_buffer;
	1096	}
	1097	else if (PL_encoding) {
	1098	/* RS is 8 bit, encoding.pm is used.
	1099	* Do not recode PL_rs as a side-effect. */
	1100	svrecode = newSVpvn(rsptr, rslen);
	1101	sv_recode_to_utf8(svrecode, PL_encoding);
	1102	rsptr = SvPV(svrecode, rslen);
	1103	rs_charlen = sv_len_utf8(svrecode);
	1104	}
	1105	else {
	1106	/* RS is 8 bit, scalar is utf8. */
	1107	temp_buffer = (char)bytes_to_utf8((U8)rsptr, &rslen);
	1108	rsptr = temp_buffer;
	1109	}
	1110	}
	1111	if (rslen == 1) {
	1112	if (s != rsptr)
	1113	goto nope;
	1114	++count;
	1115	}
	1116	else {
	1117	if (len < rslen - 1)
	1118	goto nope;
	1119	len -= rslen - 1;
	1120	s -= rslen - 1;
	1121	if (memNE(s, rsptr, rslen))
	1122	goto nope;
	1123	count += rs_charlen;
	1124	}
	1125	}
	1126	s = SvPV_force(sv, n_a);
	1127	SvCUR_set(sv, len);
	1128	*SvEND(sv) = '\0';
	1129	SvNIOK_off(sv);
	1130	SvSETMAGIC(sv);
	1131	}
	1132	nope:
	1133
	1134	if (svrecode)
	1135	SvREFCNT_dec(svrecode);
	1136
	1137	Safefree(temp_buffer);
	1138	return count;
	1139	}
	1140
	1141	void
	1142	Perl_do_vop(pTHX_ I32 optype, SV sv, SV left, SV *right)
	1143	{
	1144	#ifdef LIBERAL
	1145	register long *dl;
	1146	register long *ll;
	1147	register long *rl;
	1148	#endif
	1149	register char *dc;
	1150	STRLEN leftlen;
	1151	STRLEN rightlen;
	1152	register char *lc;
	1153	register char *rc;
	1154	register I32 len;
	1155	I32 lensave;
	1156	char *lsave;
	1157	char *rsave;
	1158	bool left_utf = DO_UTF8(left);
	1159	bool right_utf = DO_UTF8(right);
	1160	I32 needlen = 0;
	1161
	1162	if (left_utf && !right_utf)
	1163	sv_utf8_upgrade(right);
	1164	else if (!left_utf && right_utf)
	1165	sv_utf8_upgrade(left);
	1166
	1167	if (sv != left \|\| (optype != OP_BIT_AND && !SvOK(sv) && !SvGMAGICAL(sv)))
	1168	sv_setpvn(sv, "", 0); /* avoid undef warning on \|= and ^= */
	1169	lsave = lc = SvPV_nomg(left, leftlen);
	1170	rsave = rc = SvPV_nomg(right, rightlen);
	1171	len = leftlen < rightlen ? leftlen : rightlen;
	1172	lensave = len;
	1173	if ((left_utf \|\| right_utf) && (sv == left \|\| sv == right)) {
	1174	needlen = optype == OP_BIT_AND ? len : leftlen + rightlen;
	1175	Newz(801, dc, needlen + 1, char);
	1176	}
	1177	else if (SvOK(sv) \|\| SvTYPE(sv) > SVt_PVMG) {
	1178	STRLEN n_a;
	1179	dc = SvPV_force_nomg(sv, n_a);
	1180	if (SvCUR(sv) < (STRLEN)len) {
	1181	dc = SvGROW(sv, (STRLEN)(len + 1));
	1182	(void)memzero(dc + SvCUR(sv), len - SvCUR(sv) + 1);
	1183	}
	1184	if (optype != OP_BIT_AND && (left_utf \|\| right_utf))
	1185	dc = SvGROW(sv, leftlen + rightlen + 1);
	1186	}
	1187	else {
	1188	needlen = ((optype == OP_BIT_AND)
	1189	? len : (leftlen > rightlen ? leftlen : rightlen));
	1190	Newz(801, dc, needlen + 1, char);
	1191	(void)sv_usepvn(sv, dc, needlen);
	1192	dc = SvPVX(sv); /* sv_usepvn() calls Renew() */
	1193	}
	1194	SvCUR_set(sv, len);
	1195	(void)SvPOK_only(sv);
	1196	if (left_utf \|\| right_utf) {
	1197	UV duc, luc, ruc;
	1198	char *dcsave = dc;
	1199	STRLEN lulen = leftlen;
	1200	STRLEN rulen = rightlen;
	1201	STRLEN ulen;
	1202
	1203	switch (optype) {
	1204	case OP_BIT_AND:
	1205	while (lulen && rulen) {
	1206	luc = utf8n_to_uvchr((U8*)lc, lulen, &ulen, UTF8_ALLOW_ANYUV);
	1207	lc += ulen;
	1208	lulen -= ulen;
	1209	ruc = utf8n_to_uvchr((U8*)rc, rulen, &ulen, UTF8_ALLOW_ANYUV);
	1210	rc += ulen;
	1211	rulen -= ulen;
	1212	duc = luc & ruc;
	1213	dc = (char)uvchr_to_utf8((U8)dc, duc);
	1214	}
	1215	if (sv == left \|\| sv == right)
	1216	(void)sv_usepvn(sv, dcsave, needlen);
	1217	SvCUR_set(sv, dc - dcsave);
	1218	break;
	1219	case OP_BIT_XOR:
	1220	while (lulen && rulen) {
	1221	luc = utf8n_to_uvchr((U8*)lc, lulen, &ulen, UTF8_ALLOW_ANYUV);
	1222	lc += ulen;
	1223	lulen -= ulen;
	1224	ruc = utf8n_to_uvchr((U8*)rc, rulen, &ulen, UTF8_ALLOW_ANYUV);
	1225	rc += ulen;
	1226	rulen -= ulen;
	1227	duc = luc ^ ruc;
	1228	dc = (char)uvchr_to_utf8((U8)dc, duc);
	1229	}
	1230	goto mop_up_utf;
	1231	case OP_BIT_OR:
	1232	while (lulen && rulen) {
	1233	luc = utf8n_to_uvchr((U8*)lc, lulen, &ulen, UTF8_ALLOW_ANYUV);
	1234	lc += ulen;
	1235	lulen -= ulen;
	1236	ruc = utf8n_to_uvchr((U8*)rc, rulen, &ulen, UTF8_ALLOW_ANYUV);
	1237	rc += ulen;
	1238	rulen -= ulen;
	1239	duc = luc \| ruc;
	1240	dc = (char)uvchr_to_utf8((U8)dc, duc);
	1241	}
	1242	mop_up_utf:
	1243	if (sv == left \|\| sv == right)
	1244	(void)sv_usepvn(sv, dcsave, needlen);
	1245	SvCUR_set(sv, dc - dcsave);
	1246	if (rulen)
	1247	sv_catpvn(sv, rc, rulen);
	1248	else if (lulen)
	1249	sv_catpvn(sv, lc, lulen);
	1250	else
	1251	*SvEND(sv) = '\0';
	1252	break;
	1253	}
	1254	SvUTF8_on(sv);
	1255	goto finish;
	1256	}
	1257	else
	1258	#ifdef LIBERAL
	1259	if (len >= sizeof(long)*4 &&
	1260	!((long)dc % sizeof(long)) &&
	1261	!((long)lc % sizeof(long)) &&
	1262	!((long)rc % sizeof(long))) /* It's almost always aligned... */
	1263	{
	1264	I32 remainder = len % (sizeof(long)*4);
	1265	len /= (sizeof(long)*4);
	1266
	1267	dl = (long*)dc;
	1268	ll = (long*)lc;
	1269	rl = (long*)rc;
	1270
	1271	switch (optype) {
	1272	case OP_BIT_AND:
	1273	while (len--) {
	1274	dl++ = ll++ & *rl++;
	1275	dl++ = ll++ & *rl++;
	1276	dl++ = ll++ & *rl++;
	1277	dl++ = ll++ & *rl++;
	1278	}
	1279	break;
	1280	case OP_BIT_XOR:
	1281	while (len--) {
	1282	dl++ = ll++ ^ *rl++;
	1283	dl++ = ll++ ^ *rl++;
	1284	dl++ = ll++ ^ *rl++;
	1285	dl++ = ll++ ^ *rl++;
	1286	}
	1287	break;
	1288	case OP_BIT_OR:
	1289	while (len--) {
	1290	dl++ = ll++ \| *rl++;
	1291	dl++ = ll++ \| *rl++;
	1292	dl++ = ll++ \| *rl++;
	1293	dl++ = ll++ \| *rl++;
	1294	}
	1295	}
	1296
	1297	dc = (char*)dl;
	1298	lc = (char*)ll;
	1299	rc = (char*)rl;
	1300
	1301	len = remainder;
	1302	}
	1303	#endif
	1304	{
	1305	switch (optype) {
	1306	case OP_BIT_AND:
	1307	while (len--)
	1308	dc++ = lc++ & *rc++;
	1309	break;
	1310	case OP_BIT_XOR:
	1311	while (len--)
	1312	dc++ = lc++ ^ *rc++;
	1313	goto mop_up;
	1314	case OP_BIT_OR:
	1315	while (len--)
	1316	dc++ = lc++ \| *rc++;
	1317	mop_up:
	1318	len = lensave;
	1319	if (rightlen > (STRLEN)len)
	1320	sv_catpvn(sv, rsave + len, rightlen - len);
	1321	else if (leftlen > (STRLEN)len)
	1322	sv_catpvn(sv, lsave + len, leftlen - len);
	1323	else
	1324	*SvEND(sv) = '\0';
	1325	break;
	1326	}
	1327	}
	1328	finish:
	1329	SvTAINT(sv);
	1330	}
	1331
	1332	OP *
	1333	Perl_do_kv(pTHX)
	1334	{
	1335	dSP;
	1336	HV hv = (HV)POPs;
	1337	HV *keys;
	1338	register HE *entry;
	1339	SV *tmpstr;
	1340	I32 gimme = GIMME_V;
	1341	I32 dokeys = (PL_op->op_type == OP_KEYS);
	1342	I32 dovalues = (PL_op->op_type == OP_VALUES);
	1343
	1344	if (PL_op->op_type == OP_RV2HV \|\| PL_op->op_type == OP_PADHV)
	1345	dokeys = dovalues = TRUE;
	1346
	1347	if (!hv) {
	1348	if (PL_op->op_flags & OPf_MOD \|\| LVRET) { /* lvalue */
	1349	dTARGET; /* make sure to clear its target here */
	1350	if (SvTYPE(TARG) == SVt_PVLV)
	1351	LvTARG(TARG) = Nullsv;
	1352	PUSHs(TARG);
	1353	}
	1354	RETURN;
	1355	}
	1356
	1357	keys = hv;
	1358	(void)hv_iterinit(keys); /* always reset iterator regardless */
	1359
	1360	if (gimme == G_VOID)
	1361	RETURN;
	1362
	1363	if (gimme == G_SCALAR) {
	1364	IV i;
	1365	dTARGET;
	1366
	1367	if (PL_op->op_flags & OPf_MOD \|\| LVRET) { /* lvalue */
	1368	if (SvTYPE(TARG) < SVt_PVLV) {
	1369	sv_upgrade(TARG, SVt_PVLV);
	1370	sv_magic(TARG, Nullsv, PERL_MAGIC_nkeys, Nullch, 0);
	1371	}
	1372	LvTYPE(TARG) = 'k';
	1373	if (LvTARG(TARG) != (SV*)keys) {
	1374	if (LvTARG(TARG))
	1375	SvREFCNT_dec(LvTARG(TARG));
	1376	LvTARG(TARG) = SvREFCNT_inc(keys);
	1377	}
	1378	PUSHs(TARG);
	1379	RETURN;
	1380	}
	1381
	1382	if (! SvTIED_mg((SV*)keys, PERL_MAGIC_tied))
	1383	i = HvKEYS(keys);
	1384	else {
	1385	i = 0;
	1386	/SUPPRESS 560/
	1387	while (hv_iternext(keys)) i++;
	1388	}
	1389	PUSHi( i );
	1390	RETURN;
	1391	}
	1392
	1393	EXTEND(SP, HvKEYS(keys) * (dokeys + dovalues));
	1394
	1395	PUTBACK; /* hv_iternext and hv_iterval might clobber stack_sp */
	1396	while ((entry = hv_iternext(keys))) {
	1397	SPAGAIN;
	1398	if (dokeys) {
	1399	SV* sv = hv_iterkeysv(entry);
	1400	XPUSHs(sv); /* won't clobber stack_sp */
	1401	}
	1402	if (dovalues) {
	1403	PUTBACK;
	1404	tmpstr = hv_iterval(hv,entry);
	1405	DEBUG_H(Perl_sv_setpvf(aTHX_ tmpstr, "%lu%%%d=%lu",
	1406	(unsigned long)HeHASH(entry),
	1407	HvMAX(keys)+1,
	1408	(unsigned long)(HeHASH(entry) & HvMAX(keys))));
	1409	SPAGAIN;
	1410	XPUSHs(tmpstr);
	1411	}
	1412	PUTBACK;
	1413	}
	1414	return NORMAL;
	1415	}
	1416