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