This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
compatibility fix: magic non-propagation in foreach implicit localization
[perl5.git] / pp_ctl.c
CommitLineData
a0d0e21e
LW
1/* pp_ctl.c
2 *
9607fc9c 3 * Copyright (c) 1991-1997, Larry Wall
a0d0e21e
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 *
8 */
9
10/*
11 * Now far ahead the Road has gone,
12 * And I must follow, if I can,
13 * Pursuing it with eager feet,
14 * Until it joins some larger way
15 * Where many paths and errands meet.
16 * And whither then? I cannot say.
17 */
18
19#include "EXTERN.h"
20#include "perl.h"
21
22#ifndef WORD_ALIGN
23#define WORD_ALIGN sizeof(U16)
24#endif
25
54310121 26#define DOCATCH(o) ((CATCH_GET == TRUE) ? docatch(o) : (o))
1e422769 27
76e3520e 28#ifdef PERL_OBJECT
4c2891ed 29#define CALLOP this->*PL_op
76e3520e 30#else
533c011a 31#define CALLOP *PL_op
1e422769 32static OP *docatch _((OP *o));
5dc0d613 33static OP *dofindlabel _((OP *o, char *label, OP **opstack, OP **oplimit));
a0d0e21e
LW
34static void doparseform _((SV *sv));
35static I32 dopoptoeval _((I32 startingblock));
36static I32 dopoptolabel _((char *label));
37static I32 dopoptoloop _((I32 startingblock));
38static I32 dopoptosub _((I32 startingblock));
2c375eb9 39static I32 dopoptosub_at _((PERL_CONTEXT *cxstk, I32 startingblock));
a0d0e21e 40static void save_lines _((AV *array, SV *sv));
745d3a65
HM
41static I32 sortcv _((SV *a, SV *b));
42static void qsortsv _((SV **array, size_t num_elts, I32 (*fun)(SV *a, SV *b)));
c277df42 43static OP *doeval _((int gimme, OP** startop));
9c007264
JH
44static I32 sv_ncmp _((SV *a, SV *b));
45static I32 sv_i_ncmp _((SV *a, SV *b));
46static I32 amagic_ncmp _((SV *a, SV *b));
47static I32 amagic_i_ncmp _((SV *a, SV *b));
a0964cd6
GS
48static I32 amagic_cmp _((SV *str1, SV *str2));
49static I32 amagic_cmp_locale _((SV *str1, SV *str2));
76e3520e 50#endif
a0d0e21e 51
a0d0e21e
LW
52PP(pp_wantarray)
53{
4e35701f 54 djSP;
a0d0e21e
LW
55 I32 cxix;
56 EXTEND(SP, 1);
57
58 cxix = dopoptosub(cxstack_ix);
59 if (cxix < 0)
60 RETPUSHUNDEF;
61
54310121
PP
62 switch (cxstack[cxix].blk_gimme) {
63 case G_ARRAY:
a0d0e21e 64 RETPUSHYES;
54310121 65 case G_SCALAR:
a0d0e21e 66 RETPUSHNO;
54310121
PP
67 default:
68 RETPUSHUNDEF;
69 }
a0d0e21e
LW
70}
71
72PP(pp_regcmaybe)
73{
74 return NORMAL;
75}
76
2cd61cdb
IZ
77PP(pp_regcreset)
78{
79 /* XXXX Should store the old value to allow for tie/overload - and
80 restore in regcomp, where marked with XXXX. */
3280af22 81 PL_reginterp_cnt = 0;
2cd61cdb
IZ
82 return NORMAL;
83}
84
b3eb6a9b
GS
85PP(pp_regcomp)
86{
4e35701f 87 djSP;
a0d0e21e
LW
88 register PMOP *pm = (PMOP*)cLOGOP->op_other;
89 register char *t;
90 SV *tmpstr;
91 STRLEN len;
c277df42 92 MAGIC *mg = Null(MAGIC*);
a0d0e21e
LW
93
94 tmpstr = POPs;
b3eb6a9b 95 if (SvROK(tmpstr)) {
227a8b4b 96 SV *sv = SvRV(tmpstr);
c277df42
IZ
97 if(SvMAGICAL(sv))
98 mg = mg_find(sv, 'r');
99 }
b3eb6a9b 100 if (mg) {
c277df42
IZ
101 regexp *re = (regexp *)mg->mg_obj;
102 ReREFCNT_dec(pm->op_pmregexp);
103 pm->op_pmregexp = ReREFCNT_inc(re);
104 }
105 else {
106 t = SvPV(tmpstr, len);
107
20408e3c 108 /* Check against the last compiled regexp. */
85aff577 109 if (!pm->op_pmregexp || !pm->op_pmregexp->precomp ||
20408e3c
GS
110 pm->op_pmregexp->prelen != len ||
111 memNE(pm->op_pmregexp->precomp, t, len))
85aff577 112 {
c277df42
IZ
113 if (pm->op_pmregexp) {
114 ReREFCNT_dec(pm->op_pmregexp);
115 pm->op_pmregexp = Null(REGEXP*); /* crucial if regcomp aborts */
116 }
533c011a 117 if (PL_op->op_flags & OPf_SPECIAL)
3280af22 118 PL_reginterp_cnt = I32_MAX; /* Mark as safe. */
a0d0e21e 119
c277df42 120 pm->op_pmflags = pm->op_pmpermflags; /* reset case sensitivity */
15e52e56 121 pm->op_pmregexp = CALLREGCOMP(t, t + len, pm);
3280af22 122 PL_reginterp_cnt = 0; /* XXXX Be extra paranoid - needed
2cd61cdb 123 inside tie/overload accessors. */
c277df42 124 }
4633a7c4 125 }
a0d0e21e 126
72311751 127#ifndef INCOMPLETE_TAINTS
3280af22
NIS
128 if (PL_tainting) {
129 if (PL_tainted)
72311751
GS
130 pm->op_pmdynflags |= PMdf_TAINTED;
131 else
132 pm->op_pmdynflags &= ~PMdf_TAINTED;
133 }
134#endif
135
3280af22
NIS
136 if (!pm->op_pmregexp->prelen && PL_curpm)
137 pm = PL_curpm;
a0d0e21e
LW
138 else if (strEQ("\\s+", pm->op_pmregexp->precomp))
139 pm->op_pmflags |= PMf_WHITE;
140
141 if (pm->op_pmflags & PMf_KEEP) {
c90c0ff4 142 pm->op_private &= ~OPpRUNTIME; /* no point compiling again */
533c011a 143 cLOGOP->op_first->op_next = PL_op->op_next;
a0d0e21e
LW
144 }
145 RETURN;
146}
147
148PP(pp_substcont)
149{
4e35701f 150 djSP;
a0d0e21e 151 register PMOP *pm = (PMOP*) cLOGOP->op_other;
c09156bb 152 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
a0d0e21e
LW
153 register SV *dstr = cx->sb_dstr;
154 register char *s = cx->sb_s;
155 register char *m = cx->sb_m;
156 char *orig = cx->sb_orig;
d9f97599 157 register REGEXP *rx = cx->sb_rx;
a0d0e21e 158
d9f97599 159 rxres_restore(&cx->sb_rxres, rx);
c90c0ff4 160
a0d0e21e
LW
161 if (cx->sb_iters++) {
162 if (cx->sb_iters > cx->sb_maxiters)
163 DIE("Substitution loop");
164
48c036b1
GS
165 if (!(cx->sb_rxtainted & 2) && SvTAINTED(TOPs))
166 cx->sb_rxtainted |= 2;
a0d0e21e 167 sv_catsv(dstr, POPs);
a0d0e21e
LW
168
169 /* Are we done */
15e52e56 170 if (cx->sb_once || !CALLREGEXEC(rx, s, cx->sb_strend, orig,
9661b544 171 s == m, cx->sb_targ, NULL,
22e551b9 172 ((cx->sb_rflags & REXEC_COPY_STR)
ad94a511
IZ
173 ? REXEC_IGNOREPOS
174 : (REXEC_COPY_STR|REXEC_IGNOREPOS))))
a0d0e21e
LW
175 {
176 SV *targ = cx->sb_targ;
177 sv_catpvn(dstr, s, cx->sb_strend - s);
748a9306 178
48c036b1 179 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
9212bbba 180
4633a7c4 181 (void)SvOOK_off(targ);
cb0b1708 182 Safefree(SvPVX(targ));
748a9306
LW
183 SvPVX(targ) = SvPVX(dstr);
184 SvCUR_set(targ, SvCUR(dstr));
185 SvLEN_set(targ, SvLEN(dstr));
186 SvPVX(dstr) = 0;
187 sv_free(dstr);
48c036b1
GS
188
189 TAINT_IF(cx->sb_rxtainted & 1);
190 PUSHs(sv_2mortal(newSViv((I32)cx->sb_iters - 1)));
191
a0d0e21e 192 (void)SvPOK_only(targ);
48c036b1 193 TAINT_IF(cx->sb_rxtainted);
a0d0e21e 194 SvSETMAGIC(targ);
9212bbba 195 SvTAINT(targ);
5cd24f17 196
4633a7c4 197 LEAVE_SCOPE(cx->sb_oldsave);
a0d0e21e
LW
198 POPSUBST(cx);
199 RETURNOP(pm->op_next);
200 }
201 }
d9f97599 202 if (rx->subbase && rx->subbase != orig) {
a0d0e21e
LW
203 m = s;
204 s = orig;
d9f97599 205 cx->sb_orig = orig = rx->subbase;
a0d0e21e
LW
206 s = orig + (m - s);
207 cx->sb_strend = s + (cx->sb_strend - m);
208 }
d9f97599 209 cx->sb_m = m = rx->startp[0];
a0d0e21e 210 sv_catpvn(dstr, s, m-s);
d9f97599
GS
211 cx->sb_s = rx->endp[0];
212 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
213 rxres_save(&cx->sb_rxres, rx);
a0d0e21e
LW
214 RETURNOP(pm->op_pmreplstart);
215}
216
c90c0ff4 217void
d9f97599 218rxres_save(void **rsp, REGEXP *rx)
c90c0ff4
PP
219{
220 UV *p = (UV*)*rsp;
221 U32 i;
222
d9f97599
GS
223 if (!p || p[1] < rx->nparens) {
224 i = 6 + rx->nparens * 2;
c90c0ff4
PP
225 if (!p)
226 New(501, p, i, UV);
227 else
228 Renew(p, i, UV);
229 *rsp = (void*)p;
230 }
231
d9f97599
GS
232 *p++ = (UV)rx->subbase;
233 rx->subbase = Nullch;
c90c0ff4 234
d9f97599 235 *p++ = rx->nparens;
c90c0ff4 236
d9f97599
GS
237 *p++ = (UV)rx->subbeg;
238 *p++ = (UV)rx->subend;
239 for (i = 0; i <= rx->nparens; ++i) {
240 *p++ = (UV)rx->startp[i];
241 *p++ = (UV)rx->endp[i];
c90c0ff4
PP
242 }
243}
244
245void
d9f97599 246rxres_restore(void **rsp, REGEXP *rx)
c90c0ff4
PP
247{
248 UV *p = (UV*)*rsp;
249 U32 i;
250
d9f97599
GS
251 Safefree(rx->subbase);
252 rx->subbase = (char*)(*p);
c90c0ff4
PP
253 *p++ = 0;
254
d9f97599 255 rx->nparens = *p++;
c90c0ff4 256
d9f97599
GS
257 rx->subbeg = (char*)(*p++);
258 rx->subend = (char*)(*p++);
259 for (i = 0; i <= rx->nparens; ++i) {
260 rx->startp[i] = (char*)(*p++);
261 rx->endp[i] = (char*)(*p++);
c90c0ff4
PP
262 }
263}
264
265void
8ac85365 266rxres_free(void **rsp)
c90c0ff4
PP
267{
268 UV *p = (UV*)*rsp;
269
270 if (p) {
271 Safefree((char*)(*p));
272 Safefree(p);
273 *rsp = Null(void*);
274 }
275}
276
a0d0e21e
LW
277PP(pp_formline)
278{
4e35701f 279 djSP; dMARK; dORIGMARK;
76e3520e 280 register SV *tmpForm = *++MARK;
a0d0e21e
LW
281 register U16 *fpc;
282 register char *t;
283 register char *f;
284 register char *s;
285 register char *send;
286 register I32 arg;
287 register SV *sv;
288 char *item;
289 I32 itemsize;
290 I32 fieldsize;
291 I32 lines = 0;
3280af22 292 bool chopspace = (strchr(PL_chopset, ' ') != Nullch);
a0d0e21e
LW
293 char *chophere;
294 char *linemark;
a0d0e21e
LW
295 double value;
296 bool gotsome;
297 STRLEN len;
a0ed51b3 298 STRLEN fudge = SvCUR(tmpForm) * (IN_UTF8 ? 3 : 1) + 1;
a0d0e21e 299
76e3520e
GS
300 if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
301 SvREADONLY_off(tmpForm);
302 doparseform(tmpForm);
a0d0e21e
LW
303 }
304
3280af22 305 SvPV_force(PL_formtarget, len);
a0ed51b3 306 t = SvGROW(PL_formtarget, len + fudge + 1); /* XXX SvCUR bad */
a0d0e21e 307 t += len;
76e3520e 308 f = SvPV(tmpForm, len);
a0d0e21e 309 /* need to jump to the next word */
76e3520e 310 s = f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN;
a0d0e21e
LW
311
312 fpc = (U16*)s;
313
314 for (;;) {
315 DEBUG_f( {
316 char *name = "???";
317 arg = -1;
318 switch (*fpc) {
319 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
320 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
321 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
322 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
323 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
324
325 case FF_CHECKNL: name = "CHECKNL"; break;
326 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
327 case FF_SPACE: name = "SPACE"; break;
328 case FF_HALFSPACE: name = "HALFSPACE"; break;
329 case FF_ITEM: name = "ITEM"; break;
330 case FF_CHOP: name = "CHOP"; break;
331 case FF_LINEGLOB: name = "LINEGLOB"; break;
332 case FF_NEWLINE: name = "NEWLINE"; break;
333 case FF_MORE: name = "MORE"; break;
334 case FF_LINEMARK: name = "LINEMARK"; break;
335 case FF_END: name = "END"; break;
336 }
337 if (arg >= 0)
760ac839 338 PerlIO_printf(PerlIO_stderr(), "%-16s%ld\n", name, (long) arg);
a0d0e21e 339 else
760ac839 340 PerlIO_printf(PerlIO_stderr(), "%-16s\n", name);
a0d0e21e
LW
341 } )
342 switch (*fpc++) {
343 case FF_LINEMARK:
344 linemark = t;
a0d0e21e
LW
345 lines++;
346 gotsome = FALSE;
347 break;
348
349 case FF_LITERAL:
350 arg = *fpc++;
351 while (arg--)
352 *t++ = *f++;
353 break;
354
355 case FF_SKIP:
356 f += *fpc++;
357 break;
358
359 case FF_FETCH:
360 arg = *fpc++;
361 f += arg;
362 fieldsize = arg;
363
364 if (MARK < SP)
365 sv = *++MARK;
366 else {
3280af22 367 sv = &PL_sv_no;
599cee73
PM
368 if (ckWARN(WARN_SYNTAX))
369 warner(WARN_SYNTAX, "Not enough format arguments");
a0d0e21e
LW
370 }
371 break;
372
373 case FF_CHECKNL:
374 item = s = SvPV(sv, len);
375 itemsize = len;
a0ed51b3
LW
376 if (IN_UTF8) {
377 itemsize = sv_len_utf8(sv);
378 if (itemsize != len) {
379 I32 itembytes;
380 if (itemsize > fieldsize) {
381 itemsize = fieldsize;
382 itembytes = itemsize;
383 sv_pos_u2b(sv, &itembytes, 0);
384 }
385 else
386 itembytes = len;
387 send = chophere = s + itembytes;
388 while (s < send) {
389 if (*s & ~31)
390 gotsome = TRUE;
391 else if (*s == '\n')
392 break;
393 s++;
394 }
395 itemsize = s - item;
396 sv_pos_b2u(sv, &itemsize);
397 break;
398 }
399 }
a0d0e21e
LW
400 if (itemsize > fieldsize)
401 itemsize = fieldsize;
402 send = chophere = s + itemsize;
403 while (s < send) {
404 if (*s & ~31)
405 gotsome = TRUE;
406 else if (*s == '\n')
407 break;
408 s++;
409 }
410 itemsize = s - item;
411 break;
412
413 case FF_CHECKCHOP:
414 item = s = SvPV(sv, len);
415 itemsize = len;
a0ed51b3
LW
416 if (IN_UTF8) {
417 itemsize = sv_len_utf8(sv);
418 if (itemsize != len) {
419 I32 itembytes;
420 if (itemsize <= fieldsize) {
421 send = chophere = s + itemsize;
422 while (s < send) {
423 if (*s == '\r') {
424 itemsize = s - item;
425 break;
426 }
427 if (*s++ & ~31)
428 gotsome = TRUE;
429 }
430 }
431 else {
432 itemsize = fieldsize;
433 itembytes = itemsize;
434 sv_pos_u2b(sv, &itembytes, 0);
435 send = chophere = s + itembytes;
436 while (s < send || (s == send && isSPACE(*s))) {
437 if (isSPACE(*s)) {
438 if (chopspace)
439 chophere = s;
440 if (*s == '\r')
441 break;
442 }
443 else {
444 if (*s & ~31)
445 gotsome = TRUE;
446 if (strchr(PL_chopset, *s))
447 chophere = s + 1;
448 }
449 s++;
450 }
451 itemsize = chophere - item;
452 sv_pos_b2u(sv, &itemsize);
453 }
454 break;
455 }
456 }
a0d0e21e
LW
457 if (itemsize <= fieldsize) {
458 send = chophere = s + itemsize;
459 while (s < send) {
460 if (*s == '\r') {
461 itemsize = s - item;
462 break;
463 }
464 if (*s++ & ~31)
465 gotsome = TRUE;
466 }
467 }
468 else {
469 itemsize = fieldsize;
470 send = chophere = s + itemsize;
471 while (s < send || (s == send && isSPACE(*s))) {
472 if (isSPACE(*s)) {
473 if (chopspace)
474 chophere = s;
475 if (*s == '\r')
476 break;
477 }
478 else {
479 if (*s & ~31)
480 gotsome = TRUE;
3280af22 481 if (strchr(PL_chopset, *s))
a0d0e21e
LW
482 chophere = s + 1;
483 }
484 s++;
485 }
486 itemsize = chophere - item;
487 }
488 break;
489
490 case FF_SPACE:
491 arg = fieldsize - itemsize;
492 if (arg) {
493 fieldsize -= arg;
494 while (arg-- > 0)
495 *t++ = ' ';
496 }
497 break;
498
499 case FF_HALFSPACE:
500 arg = fieldsize - itemsize;
501 if (arg) {
502 arg /= 2;
503 fieldsize -= arg;
504 while (arg-- > 0)
505 *t++ = ' ';
506 }
507 break;
508
509 case FF_ITEM:
510 arg = itemsize;
511 s = item;
a0ed51b3
LW
512 if (IN_UTF8) {
513 while (arg--) {
514 if (*s & 0x80) {
515 switch (UTF8SKIP(s)) {
516 case 7: *t++ = *s++;
517 case 6: *t++ = *s++;
518 case 5: *t++ = *s++;
519 case 4: *t++ = *s++;
520 case 3: *t++ = *s++;
521 case 2: *t++ = *s++;
522 case 1: *t++ = *s++;
523 }
524 }
525 else {
526 if ( !((*t++ = *s++) & ~31) )
527 t[-1] = ' ';
528 }
529 }
530 break;
531 }
a0d0e21e 532 while (arg--) {
9d116dd7 533#ifdef EBCDIC
a0d0e21e 534 int ch = *t++ = *s++;
9d116dd7 535 if (iscntrl(ch))
a0d0e21e
LW
536#else
537 if ( !((*t++ = *s++) & ~31) )
a0d0e21e 538#endif
9d116dd7 539 t[-1] = ' ';
a0d0e21e
LW
540 }
541 break;
542
543 case FF_CHOP:
544 s = chophere;
545 if (chopspace) {
546 while (*s && isSPACE(*s))
547 s++;
548 }
549 sv_chop(sv,s);
550 break;
551
552 case FF_LINEGLOB:
553 item = s = SvPV(sv, len);
554 itemsize = len;
555 if (itemsize) {
556 gotsome = TRUE;
557 send = s + itemsize;
558 while (s < send) {
559 if (*s++ == '\n') {
560 if (s == send)
561 itemsize--;
562 else
563 lines++;
564 }
565 }
3280af22
NIS
566 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
567 sv_catpvn(PL_formtarget, item, itemsize);
a0ed51b3 568 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
3280af22 569 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
a0d0e21e
LW
570 }
571 break;
572
573 case FF_DECIMAL:
574 /* If the field is marked with ^ and the value is undefined,
575 blank it out. */
576 arg = *fpc++;
577 if ((arg & 512) && !SvOK(sv)) {
578 arg = fieldsize;
579 while (arg--)
580 *t++ = ' ';
581 break;
582 }
583 gotsome = TRUE;
584 value = SvNV(sv);
bbce6d69 585 /* Formats aren't yet marked for locales, so assume "yes". */
36477c24 586 SET_NUMERIC_LOCAL();
a0d0e21e
LW
587 if (arg & 256) {
588 sprintf(t, "%#*.*f", (int) fieldsize, (int) arg & 255, value);
589 } else {
590 sprintf(t, "%*.0f", (int) fieldsize, value);
591 }
592 t += fieldsize;
593 break;
594
595 case FF_NEWLINE:
596 f++;
597 while (t-- > linemark && *t == ' ') ;
598 t++;
599 *t++ = '\n';
600 break;
601
602 case FF_BLANK:
603 arg = *fpc++;
604 if (gotsome) {
605 if (arg) { /* repeat until fields exhausted? */
606 *t = '\0';
3280af22
NIS
607 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
608 lines += FmLINES(PL_formtarget);
a0d0e21e
LW
609 if (lines == 200) {
610 arg = t - linemark;
611 if (strnEQ(linemark, linemark - arg, arg))
612 DIE("Runaway format");
613 }
3280af22 614 FmLINES(PL_formtarget) = lines;
a0d0e21e
LW
615 SP = ORIGMARK;
616 RETURNOP(cLISTOP->op_first);
617 }
618 }
619 else {
620 t = linemark;
621 lines--;
622 }
623 break;
624
625 case FF_MORE:
7056ecde
URCI
626 s = chophere;
627 send = item + len;
628 if (chopspace) {
629 while (*s && isSPACE(*s) && s < send)
630 s++;
631 }
632 if (s < send) {
a0d0e21e
LW
633 arg = fieldsize - itemsize;
634 if (arg) {
635 fieldsize -= arg;
636 while (arg-- > 0)
637 *t++ = ' ';
638 }
639 s = t - 3;
640 if (strnEQ(s," ",3)) {
3280af22 641 while (s > SvPVX(PL_formtarget) && isSPACE(s[-1]))
a0d0e21e
LW
642 s--;
643 }
644 *s++ = '.';
645 *s++ = '.';
646 *s++ = '.';
647 }
648 break;
649
650 case FF_END:
651 *t = '\0';
3280af22
NIS
652 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
653 FmLINES(PL_formtarget) += lines;
a0d0e21e
LW
654 SP = ORIGMARK;
655 RETPUSHYES;
656 }
657 }
658}
659
660PP(pp_grepstart)
661{
4e35701f 662 djSP;
a0d0e21e
LW
663 SV *src;
664
3280af22 665 if (PL_stack_base + *PL_markstack_ptr == SP) {
a0d0e21e 666 (void)POPMARK;
54310121 667 if (GIMME_V == G_SCALAR)
3280af22 668 XPUSHs(&PL_sv_no);
533c011a 669 RETURNOP(PL_op->op_next->op_next);
a0d0e21e 670 }
3280af22 671 PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
11343788
MB
672 pp_pushmark(ARGS); /* push dst */
673 pp_pushmark(ARGS); /* push src */
a0d0e21e
LW
674 ENTER; /* enter outer scope */
675
676 SAVETMPS;
127ad2b7
GS
677 /* SAVE_DEFSV does *not* suffice here for USE_THREADS */
678 SAVESPTR(DEFSV);
a0d0e21e 679 ENTER; /* enter inner scope */
3280af22 680 SAVESPTR(PL_curpm);
a0d0e21e 681
3280af22 682 src = PL_stack_base[*PL_markstack_ptr];
a0d0e21e 683 SvTEMP_off(src);
54b9620d 684 DEFSV = src;
a0d0e21e
LW
685
686 PUTBACK;
533c011a 687 if (PL_op->op_type == OP_MAPSTART)
11343788 688 pp_pushmark(ARGS); /* push top */
533c011a 689 return ((LOGOP*)PL_op->op_next)->op_other;
a0d0e21e
LW
690}
691
692PP(pp_mapstart)
693{
694 DIE("panic: mapstart"); /* uses grepstart */
695}
696
697PP(pp_mapwhile)
698{
4e35701f 699 djSP;
3280af22 700 I32 diff = (SP - PL_stack_base) - *PL_markstack_ptr;
a0d0e21e
LW
701 I32 count;
702 I32 shift;
703 SV** src;
704 SV** dst;
705
3280af22 706 ++PL_markstack_ptr[-1];
a0d0e21e 707 if (diff) {
3280af22
NIS
708 if (diff > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
709 shift = diff - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
710 count = (SP - PL_stack_base) - PL_markstack_ptr[-1] + 2;
a0d0e21e 711
924508f0
GS
712 EXTEND(SP,shift);
713 src = SP;
714 dst = (SP += shift);
3280af22
NIS
715 PL_markstack_ptr[-1] += shift;
716 *PL_markstack_ptr += shift;
a0d0e21e
LW
717 while (--count)
718 *dst-- = *src--;
719 }
3280af22 720 dst = PL_stack_base + (PL_markstack_ptr[-2] += diff) - 1;
a0d0e21e
LW
721 ++diff;
722 while (--diff)
723 *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
724 }
725 LEAVE; /* exit inner scope */
726
727 /* All done yet? */
3280af22 728 if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
a0d0e21e 729 I32 items;
54310121 730 I32 gimme = GIMME_V;
a0d0e21e
LW
731
732 (void)POPMARK; /* pop top */
733 LEAVE; /* exit outer scope */
734 (void)POPMARK; /* pop src */
3280af22 735 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
a0d0e21e 736 (void)POPMARK; /* pop dst */
3280af22 737 SP = PL_stack_base + POPMARK; /* pop original mark */
54310121 738 if (gimme == G_SCALAR) {
a0d0e21e
LW
739 dTARGET;
740 XPUSHi(items);
a0d0e21e 741 }
54310121
PP
742 else if (gimme == G_ARRAY)
743 SP += items;
a0d0e21e
LW
744 RETURN;
745 }
746 else {
747 SV *src;
748
749 ENTER; /* enter inner scope */
3280af22 750 SAVESPTR(PL_curpm);
a0d0e21e 751
3280af22 752 src = PL_stack_base[PL_markstack_ptr[-1]];
a0d0e21e 753 SvTEMP_off(src);
54b9620d 754 DEFSV = src;
a0d0e21e
LW
755
756 RETURNOP(cLOGOP->op_other);
757 }
758}
759
9c007264
JH
760STATIC I32
761sv_ncmp (SV *a, SV *b)
762{
763 double nv1 = SvNV(a);
764 double nv2 = SvNV(b);
765 return nv1 < nv2 ? -1 : nv1 > nv2 ? 1 : 0;
766}
767STATIC I32
768sv_i_ncmp (SV *a, SV *b)
769{
770 IV iv1 = SvIV(a);
771 IV iv2 = SvIV(b);
772 return iv1 < iv2 ? -1 : iv1 > iv2 ? 1 : 0;
773}
d0ecd44c
IZ
774#define tryCALL_AMAGICbin(left,right,meth,svp) STMT_START { \
775 *svp = Nullsv; \
776 if (PL_amagic_generation) { \
777 if (SvAMAGIC(left)||SvAMAGIC(right))\
778 *svp = amagic_call(left, \
779 right, \
780 CAT2(meth,_amg), \
781 0); \
782 } \
783 } STMT_END
784
9c007264
JH
785STATIC I32
786amagic_ncmp(register SV *a, register SV *b)
787{
788 SV *tmpsv;
789 tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
790 if (tmpsv) {
791 double d;
792
793 if (SvIOK(tmpsv)) {
794 I32 i = SvIVX(tmpsv);
795 if (i > 0)
796 return 1;
797 return i? -1 : 0;
798 }
799 d = SvNV(tmpsv);
800 if (d > 0)
801 return 1;
802 return d? -1 : 0;
803 }
804 return sv_ncmp(a, b);
805}
806
807STATIC I32
808amagic_i_ncmp(register SV *a, register SV *b)
809{
810 SV *tmpsv;
811 tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
812 if (tmpsv) {
813 double d;
814
815 if (SvIOK(tmpsv)) {
816 I32 i = SvIVX(tmpsv);
817 if (i > 0)
818 return 1;
819 return i? -1 : 0;
820 }
821 d = SvNV(tmpsv);
822 if (d > 0)
823 return 1;
824 return d? -1 : 0;
825 }
826 return sv_i_ncmp(a, b);
827}
828
a0964cd6 829STATIC I32
d0ecd44c
IZ
830amagic_cmp(register SV *str1, register SV *str2)
831{
832 SV *tmpsv;
833 tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
834 if (tmpsv) {
835 double d;
836
837 if (SvIOK(tmpsv)) {
838 I32 i = SvIVX(tmpsv);
839 if (i > 0)
840 return 1;
841 return i? -1 : 0;
842 }
843 d = SvNV(tmpsv);
844 if (d > 0)
845 return 1;
846 return d? -1 : 0;
847 }
848 return sv_cmp(str1, str2);
849}
850
a0964cd6 851STATIC I32
d0ecd44c
IZ
852amagic_cmp_locale(register SV *str1, register SV *str2)
853{
854 SV *tmpsv;
855 tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
856 if (tmpsv) {
857 double d;
858
859 if (SvIOK(tmpsv)) {
860 I32 i = SvIVX(tmpsv);
861 if (i > 0)
862 return 1;
863 return i? -1 : 0;
864 }
865 d = SvNV(tmpsv);
866 if (d > 0)
867 return 1;
868 return d? -1 : 0;
869 }
870 return sv_cmp_locale(str1, str2);
871}
872
a0d0e21e
LW
873PP(pp_sort)
874{
4e35701f 875 djSP; dMARK; dORIGMARK;
a0d0e21e
LW
876 register SV **up;
877 SV **myorigmark = ORIGMARK;
878 register I32 max;
879 HV *stash;
880 GV *gv;
881 CV *cv;
882 I32 gimme = GIMME;
533c011a 883 OP* nextop = PL_op->op_next;
d0ecd44c 884 I32 overloading = 0;
a0d0e21e
LW
885
886 if (gimme != G_ARRAY) {
887 SP = MARK;
888 RETPUSHUNDEF;
889 }
890
d0abe6c5 891 ENTER;
3280af22 892 SAVEPPTR(PL_sortcop);
533c011a
NIS
893 if (PL_op->op_flags & OPf_STACKED) {
894 if (PL_op->op_flags & OPf_SPECIAL) {
a0d0e21e
LW
895 OP *kid = cLISTOP->op_first->op_sibling; /* pass pushmark */
896 kid = kUNOP->op_first; /* pass rv2gv */
897 kid = kUNOP->op_first; /* pass leave */
3280af22
NIS
898 PL_sortcop = kid->op_next;
899 stash = PL_curcop->cop_stash;
a0d0e21e
LW
900 }
901 else {
902 cv = sv_2cv(*++MARK, &stash, &gv, 0);
903 if (!(cv && CvROOT(cv))) {
904 if (gv) {
905 SV *tmpstr = sv_newmortal();
e5cf08de 906 gv_efullname3(tmpstr, gv, Nullch);
a0d0e21e
LW
907 if (cv && CvXSUB(cv))
908 DIE("Xsub \"%s\" called in sort", SvPVX(tmpstr));
909 DIE("Undefined sort subroutine \"%s\" called",
910 SvPVX(tmpstr));
911 }
912 if (cv) {
913 if (CvXSUB(cv))
914 DIE("Xsub called in sort");
915 DIE("Undefined subroutine in sort");
916 }
917 DIE("Not a CODE reference in sort");
918 }
3280af22 919 PL_sortcop = CvSTART(cv);
a0d0e21e 920 SAVESPTR(CvROOT(cv)->op_ppaddr);
22c35a8c 921 CvROOT(cv)->op_ppaddr = PL_ppaddr[OP_NULL];
b3933176 922
3280af22
NIS
923 SAVESPTR(PL_curpad);
924 PL_curpad = AvARRAY((AV*)AvARRAY(CvPADLIST(cv))[1]);
a0d0e21e
LW
925 }
926 }
927 else {
3280af22
NIS
928 PL_sortcop = Nullop;
929 stash = PL_curcop->cop_stash;
a0d0e21e
LW
930 }
931
932 up = myorigmark + 1;
933 while (MARK < SP) { /* This may or may not shift down one here. */
934 /*SUPPRESS 560*/
935 if (*up = *++MARK) { /* Weed out nulls. */
9f8d30d5 936 SvTEMP_off(*up);
d0ecd44c 937 if (!PL_sortcop && !SvPOK(*up)) {
2d8e6c8d 938 STRLEN n_a;
d0ecd44c
IZ
939 if (SvAMAGIC(*up))
940 overloading = 1;
941 else
2d8e6c8d 942 (void)sv_2pv(*up, &n_a);
d0ecd44c 943 }
a0d0e21e
LW
944 up++;
945 }
946 }
947 max = --up - myorigmark;
3280af22 948 if (PL_sortcop) {
a0d0e21e 949 if (max > 1) {
c09156bb 950 PERL_CONTEXT *cx;
a0d0e21e 951 SV** newsp;
54310121 952 bool oldcatch = CATCH_GET;
a0d0e21e
LW
953
954 SAVETMPS;
462e5cf6 955 SAVEOP();
a0d0e21e 956
54310121 957 CATCH_SET(TRUE);
e788e7d3 958 PUSHSTACKi(PERLSI_SORT);
3280af22
NIS
959 if (PL_sortstash != stash) {
960 PL_firstgv = gv_fetchpv("a", TRUE, SVt_PV);
961 PL_secondgv = gv_fetchpv("b", TRUE, SVt_PV);
962 PL_sortstash = stash;
a0d0e21e
LW
963 }
964
3280af22
NIS
965 SAVESPTR(GvSV(PL_firstgv));
966 SAVESPTR(GvSV(PL_secondgv));
b3933176 967
3280af22 968 PUSHBLOCK(cx, CXt_NULL, PL_stack_base);
533c011a 969 if (!(PL_op->op_flags & OPf_SPECIAL)) {
b3933176
CS
970 bool hasargs = FALSE;
971 cx->cx_type = CXt_SUB;
972 cx->blk_gimme = G_SCALAR;
973 PUSHSUB(cx);
974 if (!CvDEPTH(cv))
3e3baf6d 975 (void)SvREFCNT_inc(cv); /* in preparation for POPSUB */
b3933176 976 }
3280af22 977 PL_sortcxix = cxstack_ix;
ac4c12e7 978 qsortsv((myorigmark+1), max, FUNC_NAME_TO_PTR(sortcv));
a0d0e21e 979
3280af22 980 POPBLOCK(cx,PL_curpm);
ebafeae7 981 PL_stack_sp = newsp;
d3acc0f7 982 POPSTACK;
54310121 983 CATCH_SET(oldcatch);
a0d0e21e 984 }
a0d0e21e
LW
985 }
986 else {
987 if (max > 1) {
988 MEXTEND(SP, 20); /* Can't afford stack realloc on signal. */
745d3a65 989 qsortsv(ORIGMARK+1, max,
9c007264
JH
990 (PL_op->op_private & OPpSORT_NUMERIC)
991 ? ( (PL_op->op_private & OPpSORT_INTEGER)
992 ? ( overloading
993 ? FUNC_NAME_TO_PTR(amagic_i_ncmp)
994 : FUNC_NAME_TO_PTR(sv_i_ncmp))
995 : ( overloading
996 ? FUNC_NAME_TO_PTR(amagic_ncmp)
997 : FUNC_NAME_TO_PTR(sv_ncmp)))
998 : ( (PL_op->op_private & OPpLOCALE)
999 ? ( overloading
1000 ? FUNC_NAME_TO_PTR(amagic_cmp_locale)
1001 : FUNC_NAME_TO_PTR(sv_cmp_locale))
1002 : ( overloading
1003 ? FUNC_NAME_TO_PTR(amagic_cmp)
1004 : FUNC_NAME_TO_PTR(sv_cmp) )));
1005 if (PL_op->op_private & OPpSORT_REVERSE) {
1006 SV **p = ORIGMARK+1;
1007 SV **q = ORIGMARK+max;
1008 while (p < q) {
1009 SV *tmp = *p;
1010 *p++ = *q;
1011 *q-- = tmp;
1012 }
1013 }
a0d0e21e
LW
1014 }
1015 }
d0abe6c5 1016 LEAVE;
3280af22 1017 PL_stack_sp = ORIGMARK + max;
a0d0e21e
LW
1018 return nextop;
1019}
1020
1021/* Range stuff. */
1022
1023PP(pp_range)
1024{
1025 if (GIMME == G_ARRAY)
1026 return cCONDOP->op_true;
533c011a 1027 return SvTRUEx(PAD_SV(PL_op->op_targ)) ? cCONDOP->op_false : cCONDOP->op_true;
a0d0e21e
LW
1028}
1029
1030PP(pp_flip)
1031{
4e35701f 1032 djSP;
a0d0e21e
LW
1033
1034 if (GIMME == G_ARRAY) {
1035 RETURNOP(((CONDOP*)cUNOP->op_first)->op_false);
1036 }
1037 else {
1038 dTOPss;
533c011a 1039 SV *targ = PAD_SV(PL_op->op_targ);
a0d0e21e 1040
533c011a 1041 if ((PL_op->op_private & OPpFLIP_LINENUM)
3280af22 1042 ? (PL_last_in_gv && SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv)))
a0d0e21e
LW
1043 : SvTRUE(sv) ) {
1044 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
533c011a 1045 if (PL_op->op_flags & OPf_SPECIAL) {
a0d0e21e 1046 sv_setiv(targ, 1);
3e3baf6d 1047 SETs(targ);
a0d0e21e
LW
1048 RETURN;
1049 }
1050 else {
1051 sv_setiv(targ, 0);
924508f0 1052 SP--;
a0d0e21e
LW
1053 RETURNOP(((CONDOP*)cUNOP->op_first)->op_false);
1054 }
1055 }
1056 sv_setpv(TARG, "");
1057 SETs(targ);
1058 RETURN;
1059 }
1060}
1061
1062PP(pp_flop)
1063{
4e35701f 1064 djSP;
a0d0e21e
LW
1065
1066 if (GIMME == G_ARRAY) {
1067 dPOPPOPssrl;
1068 register I32 i;
1069 register SV *sv;
1070 I32 max;
1071
4633a7c4 1072 if (SvNIOKp(left) || !SvPOKp(left) ||
bbce6d69
PP
1073 (looks_like_number(left) && *SvPVX(left) != '0') )
1074 {
89ea2908
GA
1075 if (SvNV(left) < IV_MIN || SvNV(right) >= IV_MAX)
1076 croak("Range iterator outside integer range");
a0d0e21e
LW
1077 i = SvIV(left);
1078 max = SvIV(right);
bbce6d69
PP
1079 if (max >= i) {
1080 EXTEND_MORTAL(max - i + 1);
a0d0e21e 1081 EXTEND(SP, max - i + 1);
bbce6d69 1082 }
a0d0e21e 1083 while (i <= max) {
bbce6d69 1084 sv = sv_2mortal(newSViv(i++));
a0d0e21e
LW
1085 PUSHs(sv);
1086 }
1087 }
1088 else {
1089 SV *final = sv_mortalcopy(right);
2d8e6c8d 1090 STRLEN len, n_a;
a0d0e21e
LW
1091 char *tmps = SvPV(final, len);
1092
1093 sv = sv_mortalcopy(left);
2d8e6c8d 1094 SvPV_force(sv,n_a);
89ea2908 1095 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
a0d0e21e 1096 XPUSHs(sv);
89ea2908
GA
1097 if (strEQ(SvPVX(sv),tmps))
1098 break;
a0d0e21e
LW
1099 sv = sv_2mortal(newSVsv(sv));
1100 sv_inc(sv);
1101 }
a0d0e21e
LW
1102 }
1103 }
1104 else {
1105 dTOPss;
1106 SV *targ = PAD_SV(cUNOP->op_first->op_targ);
1107 sv_inc(targ);
533c011a 1108 if ((PL_op->op_private & OPpFLIP_LINENUM)
3280af22 1109 ? (PL_last_in_gv && SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv)))
a0d0e21e
LW
1110 : SvTRUE(sv) ) {
1111 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1112 sv_catpv(targ, "E0");
1113 }
1114 SETs(targ);
1115 }
1116
1117 RETURN;
1118}
1119
1120/* Control. */
1121
76e3520e 1122STATIC I32
8ac85365 1123dopoptolabel(char *label)
a0d0e21e 1124{
11343788 1125 dTHR;
a0d0e21e 1126 register I32 i;
c09156bb 1127 register PERL_CONTEXT *cx;
a0d0e21e
LW
1128
1129 for (i = cxstack_ix; i >= 0; i--) {
1130 cx = &cxstack[i];
6b35e009 1131 switch (CxTYPE(cx)) {
a0d0e21e 1132 case CXt_SUBST:
599cee73
PM
1133 if (ckWARN(WARN_UNSAFE))
1134 warner(WARN_UNSAFE, "Exiting substitution via %s",
22c35a8c 1135 PL_op_name[PL_op->op_type]);
a0d0e21e
LW
1136 break;
1137 case CXt_SUB:
599cee73
PM
1138 if (ckWARN(WARN_UNSAFE))
1139 warner(WARN_UNSAFE, "Exiting subroutine via %s",
22c35a8c 1140 PL_op_name[PL_op->op_type]);
a0d0e21e
LW
1141 break;
1142 case CXt_EVAL:
599cee73
PM
1143 if (ckWARN(WARN_UNSAFE))
1144 warner(WARN_UNSAFE, "Exiting eval via %s",
22c35a8c 1145 PL_op_name[PL_op->op_type]);
a0d0e21e 1146 break;
0a753a76 1147 case CXt_NULL:
599cee73
PM
1148 if (ckWARN(WARN_UNSAFE))
1149 warner(WARN_UNSAFE, "Exiting pseudo-block via %s",
22c35a8c 1150 PL_op_name[PL_op->op_type]);
0a753a76 1151 return -1;
a0d0e21e
LW
1152 case CXt_LOOP:
1153 if (!cx->blk_loop.label ||
1154 strNE(label, cx->blk_loop.label) ) {
68dc0745
PP
1155 DEBUG_l(deb("(Skipping label #%ld %s)\n",
1156 (long)i, cx->blk_loop.label));
a0d0e21e
LW
1157 continue;
1158 }
68dc0745 1159 DEBUG_l( deb("(Found label #%ld %s)\n", (long)i, label));
a0d0e21e
LW
1160 return i;
1161 }
1162 }
1163 return i;
1164}
1165
e50aee73 1166I32
8ac85365 1167dowantarray(void)
e50aee73 1168{
54310121
PP
1169 I32 gimme = block_gimme();
1170 return (gimme == G_VOID) ? G_SCALAR : gimme;
1171}
1172
1173I32
8ac85365 1174block_gimme(void)
54310121 1175{
11343788 1176 dTHR;
e50aee73
AD
1177 I32 cxix;
1178
1179 cxix = dopoptosub(cxstack_ix);
1180 if (cxix < 0)
46fc3d4c 1181 return G_VOID;
e50aee73 1182
54310121 1183 switch (cxstack[cxix].blk_gimme) {
d2719217
GS
1184 case G_VOID:
1185 return G_VOID;
54310121 1186 case G_SCALAR:
e50aee73 1187 return G_SCALAR;
54310121
PP
1188 case G_ARRAY:
1189 return G_ARRAY;
1190 default:
1191 croak("panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
d2719217
GS
1192 /* NOTREACHED */
1193 return 0;
54310121 1194 }
e50aee73
AD
1195}
1196
76e3520e 1197STATIC I32
8ac85365 1198dopoptosub(I32 startingblock)
a0d0e21e 1199{
11343788 1200 dTHR;
2c375eb9
GS
1201 return dopoptosub_at(cxstack, startingblock);
1202}
1203
1204STATIC I32
1205dopoptosub_at(PERL_CONTEXT *cxstk, I32 startingblock)
1206{
1207 dTHR;
a0d0e21e 1208 I32 i;
c09156bb 1209 register PERL_CONTEXT *cx;
a0d0e21e 1210 for (i = startingblock; i >= 0; i--) {
2c375eb9 1211 cx = &cxstk[i];
6b35e009 1212 switch (CxTYPE(cx)) {
a0d0e21e
LW
1213 default:
1214 continue;
1215 case CXt_EVAL:
1216 case CXt_SUB:
68dc0745 1217 DEBUG_l( deb("(Found sub #%ld)\n", (long)i));
a0d0e21e
LW
1218 return i;
1219 }
1220 }
1221 return i;
1222}
1223
76e3520e 1224STATIC I32
8ac85365 1225dopoptoeval(I32 startingblock)
a0d0e21e 1226{
11343788 1227 dTHR;
a0d0e21e 1228 I32 i;
c09156bb 1229 register PERL_CONTEXT *cx;
a0d0e21e
LW
1230 for (i = startingblock; i >= 0; i--) {
1231 cx = &cxstack[i];
6b35e009 1232 switch (CxTYPE(cx)) {
a0d0e21e
LW
1233 default:
1234 continue;
1235 case CXt_EVAL:
68dc0745 1236 DEBUG_l( deb("(Found eval #%ld)\n", (long)i));
a0d0e21e
LW
1237 return i;
1238 }
1239 }
1240 return i;
1241}
1242
76e3520e 1243STATIC I32
8ac85365 1244dopoptoloop(I32 startingblock)
a0d0e21e 1245{
11343788 1246 dTHR;
a0d0e21e 1247 I32 i;
c09156bb 1248 register PERL_CONTEXT *cx;
a0d0e21e
LW
1249 for (i = startingblock; i >= 0; i--) {
1250 cx = &cxstack[i];
6b35e009 1251 switch (CxTYPE(cx)) {
a0d0e21e 1252 case CXt_SUBST:
599cee73
PM
1253 if (ckWARN(WARN_UNSAFE))
1254 warner(WARN_UNSAFE, "Exiting substitution via %s",
22c35a8c 1255 PL_op_name[PL_op->op_type]);
a0d0e21e
LW
1256 break;
1257 case CXt_SUB:
599cee73
PM
1258 if (ckWARN(WARN_UNSAFE))
1259 warner(WARN_UNSAFE, "Exiting subroutine via %s",
22c35a8c 1260 PL_op_name[PL_op->op_type]);
a0d0e21e
LW
1261 break;
1262 case CXt_EVAL:
599cee73
PM
1263 if (ckWARN(WARN_UNSAFE))
1264 warner(WARN_UNSAFE, "Exiting eval via %s",
22c35a8c 1265 PL_op_name[PL_op->op_type]);
a0d0e21e 1266 break;
0a753a76 1267 case CXt_NULL:
599cee73
PM
1268 if (ckWARN(WARN_UNSAFE))
1269 warner(WARN_UNSAFE, "Exiting pseudo-block via %s",
22c35a8c 1270 PL_op_name[PL_op->op_type]);
0a753a76 1271 return -1;
a0d0e21e 1272 case CXt_LOOP:
68dc0745 1273 DEBUG_l( deb("(Found loop #%ld)\n", (long)i));
a0d0e21e
LW
1274 return i;
1275 }
1276 }
1277 return i;
1278}
1279
1280void
8ac85365 1281dounwind(I32 cxix)
a0d0e21e 1282{
11343788 1283 dTHR;
c09156bb 1284 register PERL_CONTEXT *cx;
a0d0e21e
LW
1285 SV **newsp;
1286 I32 optype;
1287
1288 while (cxstack_ix > cxix) {
c90c0ff4
PP
1289 cx = &cxstack[cxstack_ix];
1290 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
22c35a8c 1291 (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
a0d0e21e 1292 /* Note: we don't need to restore the base context info till the end. */
6b35e009 1293 switch (CxTYPE(cx)) {
c90c0ff4
PP
1294 case CXt_SUBST:
1295 POPSUBST(cx);
1296 continue; /* not break */
a0d0e21e
LW
1297 case CXt_SUB:
1298 POPSUB(cx);
1299 break;
1300 case CXt_EVAL:
1301 POPEVAL(cx);
1302 break;
1303 case CXt_LOOP:
1304 POPLOOP(cx);
1305 break;
0a753a76 1306 case CXt_NULL:
a0d0e21e
LW
1307 break;
1308 }
c90c0ff4 1309 cxstack_ix--;
a0d0e21e
LW
1310 }
1311}
1312
a0d0e21e 1313OP *
8ac85365 1314die_where(char *message)
a0d0e21e 1315{
e336de0d 1316 dSP;
2d8e6c8d 1317 STRLEN n_a;
3280af22 1318 if (PL_in_eval) {
a0d0e21e 1319 I32 cxix;
c09156bb 1320 register PERL_CONTEXT *cx;
a0d0e21e
LW
1321 I32 gimme;
1322 SV **newsp;
1323
4e6ea2c3 1324 if (message) {
3280af22 1325 if (PL_in_eval & 4) {
4e6ea2c3
GS
1326 SV **svp;
1327 STRLEN klen = strlen(message);
1328
1329 svp = hv_fetch(ERRHV, message, klen, TRUE);
1330 if (svp) {
1331 if (!SvIOK(*svp)) {
1332 static char prefix[] = "\t(in cleanup) ";
1333 SV *err = ERRSV;
1334 sv_upgrade(*svp, SVt_IV);
1335 (void)SvIOK_only(*svp);
1336 if (!SvPOK(err))
1337 sv_setpv(err,"");
1338 SvGROW(err, SvCUR(err)+sizeof(prefix)+klen);
1339 sv_catpvn(err, prefix, sizeof(prefix)-1);
1340 sv_catpvn(err, message, klen);
b5d92ff4
GS
1341 if (ckWARN(WARN_UNSAFE)) {
1342 STRLEN start = SvCUR(err)-klen-sizeof(prefix)+1;
1343 warner(WARN_UNSAFE, SvPVX(err)+start);
1344 }
4e6ea2c3
GS
1345 }
1346 sv_inc(*svp);
4633a7c4 1347 }
4633a7c4 1348 }
4e6ea2c3
GS
1349 else
1350 sv_setpv(ERRSV, message);
4633a7c4
LW
1351 }
1352 else
2d8e6c8d 1353 message = SvPVx(ERRSV, n_a);
4e6ea2c3 1354
3280af22 1355 while ((cxix = dopoptoeval(cxstack_ix)) < 0 && PL_curstackinfo->si_prev) {
bac4b2ad 1356 dounwind(-1);
d3acc0f7 1357 POPSTACK;
bac4b2ad 1358 }
e336de0d 1359
a0d0e21e
LW
1360 if (cxix >= 0) {
1361 I32 optype;
1362
1363 if (cxix < cxstack_ix)
1364 dounwind(cxix);
1365
3280af22 1366 POPBLOCK(cx,PL_curpm);
6b35e009 1367 if (CxTYPE(cx) != CXt_EVAL) {
760ac839 1368 PerlIO_printf(PerlIO_stderr(), "panic: die %s", message);
a0d0e21e
LW
1369 my_exit(1);
1370 }
1371 POPEVAL(cx);
1372
1373 if (gimme == G_SCALAR)
3280af22
NIS
1374 *++newsp = &PL_sv_undef;
1375 PL_stack_sp = newsp;
a0d0e21e
LW
1376
1377 LEAVE;
748a9306 1378
7a2e2cd6 1379 if (optype == OP_REQUIRE) {
2d8e6c8d 1380 char* msg = SvPVx(ERRSV, n_a);
7a2e2cd6
PP
1381 DIE("%s", *msg ? msg : "Compilation failed in require");
1382 }
a0d0e21e
LW
1383 return pop_return();
1384 }
1385 }
9cc2fdd3 1386 if (!message)
2d8e6c8d 1387 message = SvPVx(ERRSV, n_a);
760ac839
LW
1388 PerlIO_printf(PerlIO_stderr(), "%s",message);
1389 PerlIO_flush(PerlIO_stderr());
f86702cc
PP
1390 my_failure_exit();
1391 /* NOTREACHED */
a0d0e21e
LW
1392 return 0;
1393}
1394
1395PP(pp_xor)
1396{
4e35701f 1397 djSP; dPOPTOPssrl;
a0d0e21e
LW
1398 if (SvTRUE(left) != SvTRUE(right))
1399 RETSETYES;
1400 else
1401 RETSETNO;
1402}
1403
1404PP(pp_andassign)
1405{
4e35701f 1406 djSP;
a0d0e21e
LW
1407 if (!SvTRUE(TOPs))
1408 RETURN;
1409 else
1410 RETURNOP(cLOGOP->op_other);
1411}
1412
1413PP(pp_orassign)
1414{
4e35701f 1415 djSP;
a0d0e21e
LW
1416 if (SvTRUE(TOPs))
1417 RETURN;
1418 else
1419 RETURNOP(cLOGOP->op_other);
1420}
1421
a0d0e21e
LW
1422PP(pp_caller)
1423{
4e35701f 1424 djSP;
a0d0e21e 1425 register I32 cxix = dopoptosub(cxstack_ix);
c09156bb 1426 register PERL_CONTEXT *cx;
2c375eb9 1427 register PERL_CONTEXT *ccstack = cxstack;
3280af22 1428 PERL_SI *top_si = PL_curstackinfo;
a0d0e21e 1429 I32 dbcxix;
54310121 1430 I32 gimme;
49d8d3a1 1431 HV *hv;
a0d0e21e
LW
1432 SV *sv;
1433 I32 count = 0;
1434
1435 if (MAXARG)
1436 count = POPi;
1437 EXTEND(SP, 6);
1438 for (;;) {
2c375eb9
GS
1439 /* we may be in a higher stacklevel, so dig down deeper */
1440 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1441 top_si = top_si->si_prev;
1442 ccstack = top_si->si_cxstack;
1443 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1444 }
a0d0e21e
LW
1445 if (cxix < 0) {
1446 if (GIMME != G_ARRAY)
1447 RETPUSHUNDEF;
1448 RETURN;
1449 }
3280af22
NIS
1450 if (PL_DBsub && cxix >= 0 &&
1451 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
a0d0e21e
LW
1452 count++;
1453 if (!count--)
1454 break;
2c375eb9 1455 cxix = dopoptosub_at(ccstack, cxix - 1);
a0d0e21e 1456 }
2c375eb9
GS
1457
1458 cx = &ccstack[cxix];
6b35e009 1459 if (CxTYPE(cx) == CXt_SUB) {
2c375eb9
GS
1460 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1461 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
06a5b730 1462 field below is defined for any cx. */
3280af22 1463 if (PL_DBsub && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
2c375eb9 1464 cx = &ccstack[dbcxix];
06a5b730
PP
1465 }
1466
a0d0e21e 1467 if (GIMME != G_ARRAY) {
49d8d3a1
MB
1468 hv = cx->blk_oldcop->cop_stash;
1469 if (!hv)
3280af22 1470 PUSHs(&PL_sv_undef);
49d8d3a1
MB
1471 else {
1472 dTARGET;
1473 sv_setpv(TARG, HvNAME(hv));
1474 PUSHs(TARG);
1475 }
a0d0e21e
LW
1476 RETURN;
1477 }
a0d0e21e 1478
49d8d3a1
MB
1479 hv = cx->blk_oldcop->cop_stash;
1480 if (!hv)
3280af22 1481 PUSHs(&PL_sv_undef);
49d8d3a1
MB
1482 else
1483 PUSHs(sv_2mortal(newSVpv(HvNAME(hv), 0)));
a0d0e21e
LW
1484 PUSHs(sv_2mortal(newSVpv(SvPVX(GvSV(cx->blk_oldcop->cop_filegv)), 0)));
1485 PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->cop_line)));
1486 if (!MAXARG)
1487 RETURN;
6b35e009 1488 if (CxTYPE(cx) == CXt_SUB) { /* So is ccstack[dbcxix]. */
a0d0e21e 1489 sv = NEWSV(49, 0);
2c375eb9 1490 gv_efullname3(sv, CvGV(ccstack[cxix].blk_sub.cv), Nullch);
a0d0e21e
LW
1491 PUSHs(sv_2mortal(sv));
1492 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1493 }
1494 else {
1495 PUSHs(sv_2mortal(newSVpv("(eval)",0)));
1496 PUSHs(sv_2mortal(newSViv(0)));
1497 }
54310121
PP
1498 gimme = (I32)cx->blk_gimme;
1499 if (gimme == G_VOID)
3280af22 1500 PUSHs(&PL_sv_undef);
54310121
PP
1501 else
1502 PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
6b35e009 1503 if (CxTYPE(cx) == CXt_EVAL) {
06a5b730 1504 if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
4633a7c4 1505 PUSHs(cx->blk_eval.cur_text);
3280af22 1506 PUSHs(&PL_sv_no);
06a5b730
PP
1507 }
1508 else if (cx->blk_eval.old_name) { /* Try blocks have old_name == 0. */
1509 /* Require, put the name. */
1510 PUSHs(sv_2mortal(newSVpv(cx->blk_eval.old_name, 0)));
3280af22 1511 PUSHs(&PL_sv_yes);
06a5b730 1512 }
4633a7c4 1513 }
6b35e009 1514 else if (CxTYPE(cx) == CXt_SUB &&
4633a7c4 1515 cx->blk_sub.hasargs &&
3280af22 1516 PL_curcop->cop_stash == PL_debstash)
4633a7c4 1517 {
a0d0e21e
LW
1518 AV *ary = cx->blk_sub.argarray;
1519 int off = AvARRAY(ary) - AvALLOC(ary);
1520
3280af22 1521 if (!PL_dbargs) {
a0d0e21e 1522 GV* tmpgv;
3280af22 1523 PL_dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE,
a0d0e21e 1524 SVt_PVAV)));
a5f75d66 1525 GvMULTI_on(tmpgv);
3280af22 1526 AvREAL_off(PL_dbargs); /* XXX Should be REIFY */
a0d0e21e
LW
1527 }
1528
3280af22
NIS
1529 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1530 av_extend(PL_dbargs, AvFILLp(ary) + off);
1531 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1532 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
a0d0e21e
LW
1533 }
1534 RETURN;
1535}
1536
6b6eec5b 1537STATIC I32
745d3a65 1538sortcv(SV *a, SV *b)
a0d0e21e 1539{
11343788 1540 dTHR;
3280af22
NIS
1541 I32 oldsaveix = PL_savestack_ix;
1542 I32 oldscopeix = PL_scopestack_ix;
a0d0e21e 1543 I32 result;
3280af22
NIS
1544 GvSV(PL_firstgv) = a;
1545 GvSV(PL_secondgv) = b;
1546 PL_stack_sp = PL_stack_base;
533c011a 1547 PL_op = PL_sortcop;
76e3520e 1548 CALLRUNOPS();
3280af22 1549 if (PL_stack_sp != PL_stack_base + 1)
a0d0e21e 1550 croak("Sort subroutine didn't return single value");
3280af22 1551 if (!SvNIOKp(*PL_stack_sp))
a0d0e21e 1552 croak("Sort subroutine didn't return a numeric value");
3280af22
NIS
1553 result = SvIV(*PL_stack_sp);
1554 while (PL_scopestack_ix > oldscopeix) {
a0d0e21e
LW
1555 LEAVE;
1556 }
748a9306 1557 leave_scope(oldsaveix);
a0d0e21e
LW
1558 return result;
1559}
1560
a0d0e21e
LW
1561PP(pp_reset)
1562{
4e35701f 1563 djSP;
a0d0e21e 1564 char *tmps;
2d8e6c8d 1565 STRLEN n_a;
a0d0e21e
LW
1566
1567 if (MAXARG < 1)
1568 tmps = "";
1569 else
2d8e6c8d 1570 tmps = POPpx;
3280af22
NIS
1571 sv_reset(tmps, PL_curcop->cop_stash);
1572 PUSHs(&PL_sv_yes);
a0d0e21e
LW
1573 RETURN;
1574}
1575
1576PP(pp_lineseq)
1577{
1578 return NORMAL;
1579}
1580
1581PP(pp_dbstate)
1582{
533c011a 1583 PL_curcop = (COP*)PL_op;
a0d0e21e 1584 TAINT_NOT; /* Each statement is presumed innocent */
3280af22 1585 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
a0d0e21e
LW
1586 FREETMPS;
1587
533c011a 1588 if (PL_op->op_private || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
a0d0e21e 1589 {
924508f0 1590 djSP;
a0d0e21e 1591 register CV *cv;
c09156bb 1592 register PERL_CONTEXT *cx;
748a9306 1593 I32 gimme = G_ARRAY;
a0d0e21e
LW
1594 I32 hasargs;
1595 GV *gv;
1596
3280af22 1597 gv = PL_DBgv;
a0d0e21e 1598 cv = GvCV(gv);
a0d0e21e
LW
1599 if (!cv)
1600 DIE("No DB::DB routine defined");
1601
3280af22 1602 if (CvDEPTH(cv) >= 1 && !(PL_debug & (1<<30))) /* don't do recursive DB::DB call */
a0d0e21e 1603 return NORMAL;
748a9306 1604
4633a7c4
LW
1605 ENTER;
1606 SAVETMPS;
1607
3280af22 1608 SAVEI32(PL_debug);
55497cff 1609 SAVESTACK_POS();
3280af22 1610 PL_debug = 0;
748a9306 1611 hasargs = 0;
924508f0 1612 SPAGAIN;
748a9306 1613
533c011a 1614 push_return(PL_op->op_next);
924508f0 1615 PUSHBLOCK(cx, CXt_SUB, SP);
a0d0e21e
LW
1616 PUSHSUB(cx);
1617 CvDEPTH(cv)++;
1618 (void)SvREFCNT_inc(cv);
3280af22
NIS
1619 SAVESPTR(PL_curpad);
1620 PL_curpad = AvARRAY((AV*)*av_fetch(CvPADLIST(cv),1,FALSE));
a0d0e21e
LW
1621 RETURNOP(CvSTART(cv));
1622 }
1623 else
1624 return NORMAL;
1625}
1626
1627PP(pp_scope)
1628{
1629 return NORMAL;
1630}
1631
1632PP(pp_enteriter)
1633{
4e35701f 1634 djSP; dMARK;
c09156bb 1635 register PERL_CONTEXT *cx;
54310121 1636 I32 gimme = GIMME_V;
a0d0e21e
LW
1637 SV **svp;
1638
4633a7c4
LW
1639 ENTER;
1640 SAVETMPS;
1641
54b9620d 1642#ifdef USE_THREADS
0214ae40
GS
1643 if (PL_op->op_flags & OPf_SPECIAL) {
1644 dTHR;
1645 svp = &THREADSV(PL_op->op_targ); /* per-thread variable */
1646 SAVEGENERICSV(*svp);
1647 *svp = NEWSV(0,0);
1648 }
a0d0e21e 1649 else
54b9620d 1650#endif /* USE_THREADS */
533c011a
NIS
1651 if (PL_op->op_targ) {
1652 svp = &PL_curpad[PL_op->op_targ]; /* "my" variable */
54b9620d
MB
1653 SAVESPTR(*svp);
1654 }
1655 else {
0214ae40
GS
1656 svp = &GvSV((GV*)POPs); /* symbol table variable */
1657 SAVEGENERICSV(*svp);
1658 *svp = NEWSV(0,0);
54b9620d 1659 }
4633a7c4 1660
a0d0e21e
LW
1661 ENTER;
1662
1663 PUSHBLOCK(cx, CXt_LOOP, SP);
1664 PUSHLOOP(cx, svp, MARK);
533c011a 1665 if (PL_op->op_flags & OPf_STACKED) {
44a8e56a 1666 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
89ea2908
GA
1667 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1668 dPOPss;
1669 if (SvNIOKp(sv) || !SvPOKp(sv) ||
1670 (looks_like_number(sv) && *SvPVX(sv) != '0')) {
1671 if (SvNV(sv) < IV_MIN ||
1672 SvNV((SV*)cx->blk_loop.iterary) >= IV_MAX)
1673 croak("Range iterator outside integer range");
1674 cx->blk_loop.iterix = SvIV(sv);
1675 cx->blk_loop.itermax = SvIV((SV*)cx->blk_loop.iterary);
1676 }
1677 else
1678 cx->blk_loop.iterlval = newSVsv(sv);
1679 }
1680 }
4633a7c4 1681 else {
3280af22
NIS
1682 cx->blk_loop.iterary = PL_curstack;
1683 AvFILLp(PL_curstack) = SP - PL_stack_base;
1684 cx->blk_loop.iterix = MARK - PL_stack_base;
4633a7c4 1685 }
a0d0e21e
LW
1686
1687 RETURN;
1688}
1689
1690PP(pp_enterloop)
1691{
4e35701f 1692 djSP;
c09156bb 1693 register PERL_CONTEXT *cx;
54310121 1694 I32 gimme = GIMME_V;
a0d0e21e
LW
1695
1696 ENTER;
1697 SAVETMPS;
1698 ENTER;
1699
1700 PUSHBLOCK(cx, CXt_LOOP, SP);
1701 PUSHLOOP(cx, 0, SP);
1702
1703 RETURN;
1704}
1705
1706PP(pp_leaveloop)
1707{
4e35701f 1708 djSP;
c09156bb 1709 register PERL_CONTEXT *cx;
f86702cc 1710 struct block_loop cxloop;
a0d0e21e
LW
1711 I32 gimme;
1712 SV **newsp;
1713 PMOP *newpm;
1714 SV **mark;
1715
1716 POPBLOCK(cx,newpm);
4fdae800 1717 mark = newsp;
f86702cc
PP
1718 POPLOOP1(cx); /* Delay POPLOOP2 until stack values are safe */
1719
a1f49e72 1720 TAINT_NOT;
54310121
PP
1721 if (gimme == G_VOID)
1722 ; /* do nothing */
1723 else if (gimme == G_SCALAR) {
1724 if (mark < SP)
1725 *++newsp = sv_mortalcopy(*SP);
1726 else
3280af22 1727 *++newsp = &PL_sv_undef;
a0d0e21e
LW
1728 }
1729 else {
a1f49e72 1730 while (mark < SP) {
a0d0e21e 1731 *++newsp = sv_mortalcopy(*++mark);
a1f49e72
CS
1732 TAINT_NOT; /* Each item is independent */
1733 }
a0d0e21e 1734 }
f86702cc
PP
1735 SP = newsp;
1736 PUTBACK;
1737
1738 POPLOOP2(); /* Stack values are safe: release loop vars ... */
3280af22 1739 PL_curpm = newpm; /* ... and pop $1 et al */
f86702cc 1740
a0d0e21e
LW
1741 LEAVE;
1742 LEAVE;
1743
f86702cc 1744 return NORMAL;
a0d0e21e
LW
1745}
1746
1747PP(pp_return)
1748{
4e35701f 1749 djSP; dMARK;
a0d0e21e 1750 I32 cxix;
c09156bb 1751 register PERL_CONTEXT *cx;
f86702cc
PP
1752 struct block_sub cxsub;
1753 bool popsub2 = FALSE;
a0d0e21e
LW
1754 I32 gimme;
1755 SV **newsp;
1756 PMOP *newpm;
1757 I32 optype = 0;
1758
3280af22
NIS
1759 if (PL_curstackinfo->si_type == PERLSI_SORT) {
1760 if (cxstack_ix == PL_sortcxix || dopoptosub(cxstack_ix) <= PL_sortcxix) {
1761 if (cxstack_ix > PL_sortcxix)
1762 dounwind(PL_sortcxix);
1763 AvARRAY(PL_curstack)[1] = *SP;
1764 PL_stack_sp = PL_stack_base + 1;
a0d0e21e
LW
1765 return 0;
1766 }
1767 }
1768
1769 cxix = dopoptosub(cxstack_ix);
1770 if (cxix < 0)
1771 DIE("Can't return outside a subroutine");
1772 if (cxix < cxstack_ix)
1773 dounwind(cxix);
1774
1775 POPBLOCK(cx,newpm);
6b35e009 1776 switch (CxTYPE(cx)) {
a0d0e21e 1777 case CXt_SUB:
f86702cc
PP
1778 POPSUB1(cx); /* Delay POPSUB2 until stack values are safe */
1779 popsub2 = TRUE;
a0d0e21e
LW
1780 break;
1781 case CXt_EVAL:
1782 POPEVAL(cx);
748a9306
LW
1783 if (optype == OP_REQUIRE &&
1784 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1785 {
54310121 1786 /* Unassume the success we assumed earlier. */
748a9306 1787 char *name = cx->blk_eval.old_name;
3280af22 1788 (void)hv_delete(GvHVn(PL_incgv), name, strlen(name), G_DISCARD);
748a9306
LW
1789 DIE("%s did not return a true value", name);
1790 }
a0d0e21e
LW
1791 break;
1792 default:
1793 DIE("panic: return");
a0d0e21e
LW
1794 }
1795
a1f49e72 1796 TAINT_NOT;
a0d0e21e 1797 if (gimme == G_SCALAR) {
a29cdaf0
IZ
1798 if (MARK < SP) {
1799 if (popsub2) {
1800 if (cxsub.cv && CvDEPTH(cxsub.cv) > 1) {
1801 if (SvTEMP(TOPs)) {
1802 *++newsp = SvREFCNT_inc(*SP);
1803 FREETMPS;
1804 sv_2mortal(*newsp);
1805 } else {
1806 FREETMPS;
1807 *++newsp = sv_mortalcopy(*SP);
1808 }
1809 } else
1810 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
1811 } else
1812 *++newsp = sv_mortalcopy(*SP);
1813 } else
3280af22 1814 *++newsp = &PL_sv_undef;
a0d0e21e 1815 }
54310121 1816 else if (gimme == G_ARRAY) {
a1f49e72 1817 while (++MARK <= SP) {
f86702cc
PP
1818 *++newsp = (popsub2 && SvTEMP(*MARK))
1819 ? *MARK : sv_mortalcopy(*MARK);
a1f49e72
CS
1820 TAINT_NOT; /* Each item is independent */
1821 }
a0d0e21e 1822 }
3280af22 1823 PL_stack_sp = newsp;
a0d0e21e 1824
f86702cc
PP
1825 /* Stack values are safe: */
1826 if (popsub2) {
1827 POPSUB2(); /* release CV and @_ ... */
1828 }
3280af22 1829 PL_curpm = newpm; /* ... and pop $1 et al */
f86702cc 1830
a0d0e21e
LW
1831 LEAVE;
1832 return pop_return();
1833}
1834
1835PP(pp_last)
1836{
4e35701f 1837 djSP;
a0d0e21e 1838 I32 cxix;
c09156bb 1839 register PERL_CONTEXT *cx;
f86702cc
PP
1840 struct block_loop cxloop;
1841 struct block_sub cxsub;
1842 I32 pop2 = 0;
a0d0e21e
LW
1843 I32 gimme;
1844 I32 optype;
1845 OP *nextop;
1846 SV **newsp;
1847 PMOP *newpm;
3280af22 1848 SV **mark = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
a0d0e21e 1849
533c011a 1850 if (PL_op->op_flags & OPf_SPECIAL) {
a0d0e21e
LW
1851 cxix = dopoptoloop(cxstack_ix);
1852 if (cxix < 0)
1853 DIE("Can't \"last\" outside a block");
1854 }
1855 else {
1856 cxix = dopoptolabel(cPVOP->op_pv);
1857 if (cxix < 0)
1858 DIE("Label not found for \"last %s\"", cPVOP->op_pv);
1859 }
1860 if (cxix < cxstack_ix)
1861 dounwind(cxix);
1862
1863 POPBLOCK(cx,newpm);
6b35e009 1864 switch (CxTYPE(cx)) {
a0d0e21e 1865 case CXt_LOOP:
f86702cc
PP
1866 POPLOOP1(cx); /* Delay POPLOOP2 until stack values are safe */
1867 pop2 = CXt_LOOP;
4fdae800 1868 nextop = cxloop.last_op->op_next;
a0d0e21e 1869 break;
f86702cc
PP
1870 case CXt_SUB:
1871 POPSUB1(cx); /* Delay POPSUB2 until stack values are safe */
1872 pop2 = CXt_SUB;
a0d0e21e
LW
1873 nextop = pop_return();
1874 break;
f86702cc
PP
1875 case CXt_EVAL:
1876 POPEVAL(cx);
a0d0e21e
LW
1877 nextop = pop_return();
1878 break;
1879 default:
1880 DIE("panic: last");
a0d0e21e
LW
1881 }
1882
a1f49e72 1883 TAINT_NOT;
a0d0e21e 1884 if (gimme == G_SCALAR) {
f86702cc
PP
1885 if (MARK < SP)
1886 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
1887 ? *SP : sv_mortalcopy(*SP);
a0d0e21e 1888 else
3280af22 1889 *++newsp = &PL_sv_undef;
a0d0e21e 1890 }
54310121 1891 else if (gimme == G_ARRAY) {
a1f49e72 1892 while (++MARK <= SP) {
f86702cc
PP
1893 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
1894 ? *MARK : sv_mortalcopy(*MARK);
a1f49e72
CS
1895 TAINT_NOT; /* Each item is independent */
1896 }
f86702cc
PP
1897 }
1898 SP = newsp;
1899 PUTBACK;
1900
1901 /* Stack values are safe: */
1902 switch (pop2) {
1903 case CXt_LOOP:
1904 POPLOOP2(); /* release loop vars ... */
4fdae800 1905 LEAVE;
f86702cc
PP
1906 break;
1907 case CXt_SUB:
1908 POPSUB2(); /* release CV and @_ ... */
1909 break;
a0d0e21e 1910 }
3280af22 1911 PL_curpm = newpm; /* ... and pop $1 et al */
a0d0e21e
LW
1912
1913 LEAVE;
f86702cc 1914 return nextop;
a0d0e21e
LW
1915}
1916
1917PP(pp_next)
1918{
1919 I32 cxix;
c09156bb 1920 register PERL_CONTEXT *cx;
a0d0e21e
LW
1921 I32 oldsave;
1922
533c011a 1923 if (PL_op->op_flags & OPf_SPECIAL) {
a0d0e21e
LW
1924 cxix = dopoptoloop(cxstack_ix);
1925 if (cxix < 0)
1926 DIE("Can't \"next\" outside a block");
1927 }
1928 else {
1929 cxix = dopoptolabel(cPVOP->op_pv);
1930 if (cxix < 0)
1931 DIE("Label not found for \"next %s\"", cPVOP->op_pv);
1932 }
1933 if (cxix < cxstack_ix)
1934 dounwind(cxix);
1935
1936 TOPBLOCK(cx);
3280af22 1937 oldsave = PL_scopestack[PL_scopestack_ix - 1];
a0d0e21e
LW
1938 LEAVE_SCOPE(oldsave);
1939 return cx->blk_loop.next_op;
1940}
1941
1942PP(pp_redo)
1943{
1944 I32 cxix;
c09156bb 1945 register PERL_CONTEXT *cx;
a0d0e21e
LW
1946 I32 oldsave;
1947
533c011a 1948 if (PL_op->op_flags & OPf_SPECIAL) {
a0d0e21e
LW
1949 cxix = dopoptoloop(cxstack_ix);
1950 if (cxix < 0)
1951 DIE("Can't \"redo\" outside a block");
1952 }
1953 else {
1954 cxix = dopoptolabel(cPVOP->op_pv);
1955 if (cxix < 0)
1956 DIE("Label not found for \"redo %s\"", cPVOP->op_pv);
1957 }
1958 if (cxix < cxstack_ix)
1959 dounwind(cxix);
1960
1961 TOPBLOCK(cx);
3280af22 1962 oldsave = PL_scopestack[PL_scopestack_ix - 1];
a0d0e21e
LW
1963 LEAVE_SCOPE(oldsave);
1964 return cx->blk_loop.redo_op;
1965}
1966
0824fdcb 1967STATIC OP *
8ac85365 1968dofindlabel(OP *o, char *label, OP **opstack, OP **oplimit)
a0d0e21e
LW
1969{
1970 OP *kid;
1971 OP **ops = opstack;
fc36a67e 1972 static char too_deep[] = "Target of goto is too deeply nested";
a0d0e21e 1973
fc36a67e
PP
1974 if (ops >= oplimit)
1975 croak(too_deep);
11343788
MB
1976 if (o->op_type == OP_LEAVE ||
1977 o->op_type == OP_SCOPE ||
1978 o->op_type == OP_LEAVELOOP ||
1979 o->op_type == OP_LEAVETRY)
fc36a67e 1980 {
5dc0d613 1981 *ops++ = cUNOPo->op_first;
fc36a67e
PP
1982 if (ops >= oplimit)
1983 croak(too_deep);
1984 }
a0d0e21e 1985 *ops = 0;
11343788 1986 if (o->op_flags & OPf_KIDS) {
5c0ca799 1987 dTHR;
a0d0e21e 1988 /* First try all the kids at this level, since that's likeliest. */
11343788 1989 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
a0d0e21e
LW
1990 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
1991 kCOP->cop_label && strEQ(kCOP->cop_label, label))
1992 return kid;
1993 }
11343788 1994 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
3280af22 1995 if (kid == PL_lastgotoprobe)
a0d0e21e 1996 continue;
fc36a67e
PP
1997 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
1998 (ops == opstack ||
1999 (ops[-1]->op_type != OP_NEXTSTATE &&
2000 ops[-1]->op_type != OP_DBSTATE)))
2001 *ops++ = kid;
5dc0d613 2002 if (o = dofindlabel(kid, label, ops, oplimit))
11343788 2003 return o;
a0d0e21e
LW
2004 }
2005 }
2006 *ops = 0;
2007 return 0;
2008}
2009
2010PP(pp_dump)
2011{
2012 return pp_goto(ARGS);
2013 /*NOTREACHED*/
2014}
2015
2016PP(pp_goto)
2017{
4e35701f 2018 djSP;
a0d0e21e
LW
2019 OP *retop = 0;
2020 I32 ix;
c09156bb 2021 register PERL_CONTEXT *cx;
fc36a67e
PP
2022#define GOTO_DEPTH 64
2023 OP *enterops[GOTO_DEPTH];
a0d0e21e 2024 char *label;
533c011a 2025 int do_dump = (PL_op->op_type == OP_DUMP);
a0d0e21e
LW
2026
2027 label = 0;
533c011a 2028 if (PL_op->op_flags & OPf_STACKED) {
a0d0e21e 2029 SV *sv = POPs;
2d8e6c8d 2030 STRLEN n_a;
a0d0e21e
LW
2031
2032 /* This egregious kludge implements goto &subroutine */
2033 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2034 I32 cxix;
c09156bb 2035 register PERL_CONTEXT *cx;
a0d0e21e
LW
2036 CV* cv = (CV*)SvRV(sv);
2037 SV** mark;
2038 I32 items = 0;
2039 I32 oldsave;
62b1ebc2 2040 int arg_was_real = 0;
a0d0e21e 2041
e8f7dd13 2042 retry:
4aa0a1f7 2043 if (!CvROOT(cv) && !CvXSUB(cv)) {
e8f7dd13
GS
2044 GV *gv = CvGV(cv);
2045 GV *autogv;
2046 if (gv) {
2047 SV *tmpstr;
2048 /* autoloaded stub? */
2049 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2050 goto retry;
2051 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2052 GvNAMELEN(gv), FALSE);
2053 if (autogv && (cv = GvCV(autogv)))
2054 goto retry;
2055 tmpstr = sv_newmortal();
2056 gv_efullname3(tmpstr, gv, Nullch);
4aa0a1f7
AD
2057 DIE("Goto undefined subroutine &%s",SvPVX(tmpstr));
2058 }
2059 DIE("Goto undefined subroutine");
2060 }
2061
a0d0e21e
LW
2062 /* First do some returnish stuff. */
2063 cxix = dopoptosub(cxstack_ix);
2064 if (cxix < 0)
2065 DIE("Can't goto subroutine outside a subroutine");
2066 if (cxix < cxstack_ix)
2067 dounwind(cxix);
2068 TOPBLOCK(cx);
6b35e009 2069 if (CxTYPE(cx) == CXt_EVAL && cx->blk_eval.old_op_type == OP_ENTEREVAL)
b150fb22 2070 DIE("Can't goto subroutine from an eval-string");
3280af22 2071 mark = PL_stack_sp;
6b35e009 2072 if (CxTYPE(cx) == CXt_SUB &&
b150fb22 2073 cx->blk_sub.hasargs) { /* put @_ back onto stack */
a0d0e21e
LW
2074 AV* av = cx->blk_sub.argarray;
2075
93965878 2076 items = AvFILLp(av) + 1;
3280af22
NIS
2077 PL_stack_sp++;
2078 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2079 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2080 PL_stack_sp += items;
6d4ff0d2 2081#ifndef USE_THREADS
3280af22
NIS
2082 SvREFCNT_dec(GvAV(PL_defgv));
2083 GvAV(PL_defgv) = cx->blk_sub.savearray;
6d4ff0d2 2084#endif /* USE_THREADS */
62b1ebc2
GS
2085 if (AvREAL(av)) {
2086 arg_was_real = 1;
2087 AvREAL_off(av); /* so av_clear() won't clobber elts */
2088 }
4633a7c4 2089 av_clear(av);
a0d0e21e 2090 }
1fa4e549
AD
2091 else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2092 AV* av;
2093 int i;
2094#ifdef USE_THREADS
533c011a 2095 av = (AV*)PL_curpad[0];
1fa4e549 2096#else
3280af22 2097 av = GvAV(PL_defgv);
1fa4e549
AD
2098#endif
2099 items = AvFILLp(av) + 1;
3280af22
NIS
2100 PL_stack_sp++;
2101 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2102 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2103 PL_stack_sp += items;
1fa4e549 2104 }
6b35e009 2105 if (CxTYPE(cx) == CXt_SUB &&
b150fb22 2106 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
a0d0e21e 2107 SvREFCNT_dec(cx->blk_sub.cv);
3280af22 2108 oldsave = PL_scopestack[PL_scopestack_ix - 1];
a0d0e21e
LW
2109 LEAVE_SCOPE(oldsave);
2110
2111 /* Now do some callish stuff. */
2112 SAVETMPS;
2113 if (CvXSUB(cv)) {
2114 if (CvOLDSTYLE(cv)) {
ecfc5424 2115 I32 (*fp3)_((int,int,int));
924508f0
GS
2116 while (SP > mark) {
2117 SP[1] = SP[0];
2118 SP--;
a0d0e21e 2119 }
ecfc5424
AD
2120 fp3 = (I32(*)_((int,int,int)))CvXSUB(cv);
2121 items = (*fp3)(CvXSUBANY(cv).any_i32,
3280af22 2122 mark - PL_stack_base + 1,
ecfc5424 2123 items);
3280af22 2124 SP = PL_stack_base + items;
a0d0e21e
LW
2125 }
2126 else {
1fa4e549
AD
2127 SV **newsp;
2128 I32 gimme;
2129
3280af22 2130 PL_stack_sp--; /* There is no cv arg. */
1fa4e549
AD
2131 /* Push a mark for the start of arglist */
2132 PUSHMARK(mark);
1d583055 2133 (void)(*CvXSUB(cv))(cv _PERL_OBJECT_THIS);
1fa4e549 2134 /* Pop the current context like a decent sub should */
3280af22 2135 POPBLOCK(cx, PL_curpm);
1fa4e549 2136 /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
a0d0e21e
LW
2137 }
2138 LEAVE;
2139 return pop_return();
2140 }
2141 else {
2142 AV* padlist = CvPADLIST(cv);
2143 SV** svp = AvARRAY(padlist);
6b35e009 2144 if (CxTYPE(cx) == CXt_EVAL) {
3280af22
NIS
2145 PL_in_eval = cx->blk_eval.old_in_eval;
2146 PL_eval_root = cx->blk_eval.old_eval_root;
b150fb22
RH
2147 cx->cx_type = CXt_SUB;
2148 cx->blk_sub.hasargs = 0;
2149 }
a0d0e21e
LW
2150 cx->blk_sub.cv = cv;
2151 cx->blk_sub.olddepth = CvDEPTH(cv);
2152 CvDEPTH(cv)++;
2153 if (CvDEPTH(cv) < 2)
2154 (void)SvREFCNT_inc(cv);
2155 else { /* save temporaries on recursion? */
599cee73 2156 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
44a8e56a 2157 sub_crush_depth(cv);
93965878 2158 if (CvDEPTH(cv) > AvFILLp(padlist)) {
a0d0e21e 2159 AV *newpad = newAV();
4aa0a1f7 2160 SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
93965878 2161 I32 ix = AvFILLp((AV*)svp[1]);
a0d0e21e 2162 svp = AvARRAY(svp[0]);
748a9306 2163 for ( ;ix > 0; ix--) {
3280af22 2164 if (svp[ix] != &PL_sv_undef) {
748a9306 2165 char *name = SvPVX(svp[ix]);
5f05dabc
PP
2166 if ((SvFLAGS(svp[ix]) & SVf_FAKE)
2167 || *name == '&')
2168 {
2169 /* outer lexical or anon code */
748a9306 2170 av_store(newpad, ix,
4aa0a1f7 2171 SvREFCNT_inc(oldpad[ix]) );
748a9306
LW
2172 }
2173 else { /* our own lexical */
2174 if (*name == '@')
2175 av_store(newpad, ix, sv = (SV*)newAV());
2176 else if (*name == '%')
2177 av_store(newpad, ix, sv = (SV*)newHV());
2178 else
2179 av_store(newpad, ix, sv = NEWSV(0,0));
2180 SvPADMY_on(sv);
2181 }
a0d0e21e
LW
2182 }
2183 else {
748a9306 2184 av_store(newpad, ix, sv = NEWSV(0,0));
a0d0e21e
LW
2185 SvPADTMP_on(sv);
2186 }
2187 }
2188 if (cx->blk_sub.hasargs) {
2189 AV* av = newAV();
2190 av_extend(av, 0);
2191 av_store(newpad, 0, (SV*)av);
2192 AvFLAGS(av) = AVf_REIFY;
2193 }
2194 av_store(padlist, CvDEPTH(cv), (SV*)newpad);
93965878 2195 AvFILLp(padlist) = CvDEPTH(cv);
a0d0e21e
LW
2196 svp = AvARRAY(padlist);
2197 }
2198 }
6d4ff0d2
MB
2199#ifdef USE_THREADS
2200 if (!cx->blk_sub.hasargs) {
533c011a 2201 AV* av = (AV*)PL_curpad[0];
6d4ff0d2 2202
93965878 2203 items = AvFILLp(av) + 1;
6d4ff0d2
MB
2204 if (items) {
2205 /* Mark is at the end of the stack. */
924508f0
GS
2206 EXTEND(SP, items);
2207 Copy(AvARRAY(av), SP + 1, items, SV*);
2208 SP += items;
6d4ff0d2
MB
2209 PUTBACK ;
2210 }
2211 }
2212#endif /* USE_THREADS */
3280af22
NIS
2213 SAVESPTR(PL_curpad);
2214 PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
6d4ff0d2
MB
2215#ifndef USE_THREADS
2216 if (cx->blk_sub.hasargs)
2217#endif /* USE_THREADS */
2218 {
3280af22 2219 AV* av = (AV*)PL_curpad[0];
a0d0e21e
LW
2220 SV** ary;
2221
6d4ff0d2 2222#ifndef USE_THREADS
3280af22
NIS
2223 cx->blk_sub.savearray = GvAV(PL_defgv);
2224 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
6d4ff0d2
MB
2225#endif /* USE_THREADS */
2226 cx->blk_sub.argarray = av;
a0d0e21e
LW
2227 ++mark;
2228
2229 if (items >= AvMAX(av) + 1) {
2230 ary = AvALLOC(av);
2231 if (AvARRAY(av) != ary) {
2232 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2233 SvPVX(av) = (char*)ary;
2234 }
2235 if (items >= AvMAX(av) + 1) {
2236 AvMAX(av) = items - 1;
2237 Renew(ary,items+1,SV*);
2238 AvALLOC(av) = ary;
2239 SvPVX(av) = (char*)ary;
2240 }
2241 }
2242 Copy(mark,AvARRAY(av),items,SV*);
93965878 2243 AvFILLp(av) = items - 1;
62b1ebc2
GS
2244 /* preserve @_ nature */
2245 if (arg_was_real) {
2246 AvREIFY_off(av);
2247 AvREAL_on(av);
2248 }
a0d0e21e
LW
2249 while (items--) {
2250 if (*mark)
2251 SvTEMP_off(*mark);
2252 mark++;
2253 }
2254 }
491527d0 2255 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
44a8e56a
PP
2256 /*
2257 * We do not care about using sv to call CV;
2258 * it's for informational purposes only.
2259 */
3280af22 2260 SV *sv = GvSV(PL_DBsub);
491527d0
GS
2261 CV *gotocv;
2262
2263 if (PERLDB_SUB_NN) {
2264 SvIVX(sv) = (IV)cv; /* Already upgraded, saved */
2265 } else {
2266 save_item(sv);
2267 gv_efullname3(sv, CvGV(cv), Nullch);
2268 }
2269 if ( PERLDB_GOTO
2270 && (gotocv = perl_get_cv("DB::goto", FALSE)) ) {
3280af22 2271 PUSHMARK( PL_stack_sp );
491527d0 2272 perl_call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
3280af22 2273 PL_stack_sp--;
491527d0 2274 }
1ce6579f 2275 }
a0d0e21e
LW
2276 RETURNOP(CvSTART(cv));
2277 }
2278 }
2279 else
2d8e6c8d 2280 label = SvPV(sv,n_a);
a0d0e21e 2281 }
533c011a 2282 else if (PL_op->op_flags & OPf_SPECIAL) {
a0d0e21e
LW
2283 if (! do_dump)
2284 DIE("goto must have label");
2285 }
2286 else
2287 label = cPVOP->op_pv;
2288
2289 if (label && *label) {
2290 OP *gotoprobe = 0;
2291
2292 /* find label */
2293
3280af22 2294 PL_lastgotoprobe = 0;
a0d0e21e
LW
2295 *enterops = 0;
2296 for (ix = cxstack_ix; ix >= 0; ix--) {
2297 cx = &cxstack[ix];
6b35e009 2298 switch (CxTYPE(cx)) {
a0d0e21e 2299 case CXt_EVAL:
3280af22 2300 gotoprobe = PL_eval_root; /* XXX not good for nested eval */
a0d0e21e
LW
2301 break;
2302 case CXt_LOOP:
2303 gotoprobe = cx->blk_oldcop->op_sibling;
2304 break;
2305 case CXt_SUBST:
2306 continue;
2307 case CXt_BLOCK:
2308 if (ix)
2309 gotoprobe = cx->blk_oldcop->op_sibling;
2310 else
3280af22 2311 gotoprobe = PL_main_root;
a0d0e21e 2312 break;
b3933176
CS
2313 case CXt_SUB:
2314 if (CvDEPTH(cx->blk_sub.cv)) {
2315 gotoprobe = CvROOT(cx->blk_sub.cv);
2316 break;
2317 }
2318 /* FALL THROUGH */
0a753a76
PP
2319 case CXt_NULL:
2320 DIE("Can't \"goto\" outside a block");
a0d0e21e
LW
2321 default:
2322 if (ix)
2323 DIE("panic: goto");
3280af22 2324 gotoprobe = PL_main_root;
a0d0e21e
LW
2325 break;
2326 }
fc36a67e
PP
2327 retop = dofindlabel(gotoprobe, label,
2328 enterops, enterops + GOTO_DEPTH);
a0d0e21e
LW
2329 if (retop)
2330 break;
3280af22 2331 PL_lastgotoprobe = gotoprobe;
a0d0e21e
LW
2332 }
2333 if (!retop)
2334 DIE("Can't find label %s", label);
2335
2336 /* pop unwanted frames */
2337
2338 if (ix < cxstack_ix) {
2339 I32 oldsave;
2340
2341 if (ix < 0)
2342 ix = 0;
2343 dounwind(ix);
2344 TOPBLOCK(cx);
3280af22 2345 oldsave = PL_scopestack[PL_scopestack_ix];
a0d0e21e
LW
2346 LEAVE_SCOPE(oldsave);
2347 }
2348
2349 /* push wanted frames */
2350
748a9306 2351 if (*enterops && enterops[1]) {
533c011a 2352 OP *oldop = PL_op;
748a9306 2353 for (ix = 1; enterops[ix]; ix++) {
533c011a 2354 PL_op = enterops[ix];
84902520
TB
2355 /* Eventually we may want to stack the needed arguments
2356 * for each op. For now, we punt on the hard ones. */
533c011a 2357 if (PL_op->op_type == OP_ENTERITER)
84902520
TB
2358 DIE("Can't \"goto\" into the middle of a foreach loop",
2359 label);
0824fdcb 2360 (CALLOP->op_ppaddr)(ARGS);
a0d0e21e 2361 }
533c011a 2362 PL_op = oldop;
a0d0e21e
LW
2363 }
2364 }
2365
2366 if (do_dump) {
a5f75d66 2367#ifdef VMS
6b88bc9c 2368 if (!retop) retop = PL_main_start;
a5f75d66 2369#endif
3280af22
NIS
2370 PL_restartop = retop;
2371 PL_do_undump = TRUE;
a0d0e21e
LW
2372
2373 my_unexec();
2374
3280af22
NIS
2375 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2376 PL_do_undump = FALSE;
a0d0e21e
LW
2377 }
2378
2379 RETURNOP(retop);
2380}
2381
2382PP(pp_exit)
2383{
4e35701f 2384 djSP;
a0d0e21e
LW
2385 I32 anum;
2386
2387 if (MAXARG < 1)
2388 anum = 0;
ff0cee69 2389 else {
a0d0e21e 2390 anum = SvIVx(POPs);
ff0cee69
PP
2391#ifdef VMSISH_EXIT
2392 if (anum == 1 && VMSISH_EXIT)
2393 anum = 0;
2394#endif
2395 }
a0d0e21e 2396 my_exit(anum);
3280af22 2397 PUSHs(&PL_sv_undef);
a0d0e21e
LW
2398 RETURN;
2399}
2400
2401#ifdef NOTYET
2402PP(pp_nswitch)
2403{
4e35701f 2404 djSP;
a0d0e21e
LW
2405 double value = SvNVx(GvSV(cCOP->cop_gv));
2406 register I32 match = I_32(value);
2407
2408 if (value < 0.0) {
2409 if (((double)match) > value)
2410 --match; /* was fractional--truncate other way */
2411 }
2412 match -= cCOP->uop.scop.scop_offset;
2413 if (match < 0)
2414 match = 0;
2415 else if (match > cCOP->uop.scop.scop_max)
2416 match = cCOP->uop.scop.scop_max;
6b88bc9c
GS
2417 PL_op = cCOP->uop.scop.scop_next[match];
2418 RETURNOP(PL_op);
a0d0e21e
LW
2419}
2420
2421PP(pp_cswitch)
2422{
4e35701f 2423 djSP;
a0d0e21e
LW
2424 register I32 match;
2425
6b88bc9c
GS
2426 if (PL_multiline)
2427 PL_op = PL_op->op_next; /* can't assume anything */
a0d0e21e 2428 else {
2d8e6c8d
GS
2429 STRLEN n_a;
2430 match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255;
a0d0e21e
LW
2431 match -= cCOP->uop.scop.scop_offset;
2432 if (match < 0)
2433 match = 0;
2434 else if (match > cCOP->uop.scop.scop_max)
2435 match = cCOP->uop.scop.scop_max;
6b88bc9c 2436 PL_op = cCOP->uop.scop.scop_next[match];
a0d0e21e 2437 }
6b88bc9c 2438 RETURNOP(PL_op);
a0d0e21e
LW
2439}
2440#endif
2441
2442/* Eval. */
2443
0824fdcb 2444STATIC void
8ac85365 2445save_lines(AV *array, SV *sv)
a0d0e21e
LW
2446{
2447 register char *s = SvPVX(sv);
2448 register char *send = SvPVX(sv) + SvCUR(sv);
2449 register char *t;
2450 register I32 line = 1;
2451
2452 while (s && s < send) {
2453 SV *tmpstr = NEWSV(85,0);
2454
2455 sv_upgrade(tmpstr, SVt_PVMG);
2456 t = strchr(s, '\n');
2457 if (t)
2458 t++;
2459 else
2460 t = send;
2461
2462 sv_setpvn(tmpstr, s, t - s);
2463 av_store(array, line++, tmpstr);
2464 s = t;
2465 }
2466}
2467
0824fdcb 2468STATIC OP *
8ac85365 2469docatch(OP *o)
1e422769 2470{
e858de61 2471 dTHR;
6224f72b 2472 int ret;
533c011a 2473 OP *oldop = PL_op;
54310121 2474 dJMPENV;
1e422769 2475
533c011a 2476 PL_op = o;
1e422769 2477#ifdef DEBUGGING
54310121 2478 assert(CATCH_GET == TRUE);
3280af22 2479 DEBUG_l(deb("Setting up local jumplevel %p, was %p\n", &cur_env, PL_top_env));
1e422769 2480#endif
6224f72b
GS
2481 JMPENV_PUSH(ret);
2482 switch (ret) {
1e422769 2483 default: /* topmost level handles it */
ebf99b04 2484pass_the_buck:
54310121 2485 JMPENV_POP;
533c011a 2486 PL_op = oldop;
6224f72b 2487 JMPENV_JUMP(ret);
1e422769 2488 /* NOTREACHED */
6224f72b 2489 case 3:
ebf99b04
GS
2490 if (!PL_restartop)
2491 goto pass_the_buck;
533c011a 2492 PL_op = PL_restartop;
3280af22 2493 PL_restartop = 0;
1e422769 2494 /* FALL THROUGH */
6224f72b 2495 case 0:
0824fdcb 2496 CALLRUNOPS();
1e422769
PP
2497 break;
2498 }
54310121 2499 JMPENV_POP;
533c011a 2500 PL_op = oldop;
1e422769
PP
2501 return Nullop;
2502}
2503
c277df42
IZ
2504OP *
2505sv_compile_2op(SV *sv, OP** startop, char *code, AV** avp)
2506/* sv Text to convert to OP tree. */
2507/* startop op_free() this to undo. */
2508/* code Short string id of the caller. */
2509{
2510 dSP; /* Make POPBLOCK work. */
2511 PERL_CONTEXT *cx;
2512 SV **newsp;
f987c7de 2513 I32 gimme = 0; /* SUSPECT - INITIALZE TO WHAT? NI-S */
c277df42
IZ
2514 I32 optype;
2515 OP dummy;
533c011a 2516 OP *oop = PL_op, *rop;
c277df42
IZ
2517 char tmpbuf[TYPE_DIGITS(long) + 12 + 10];
2518 char *safestr;
2519
2520 ENTER;
2521 lex_start(sv);
2522 SAVETMPS;
2523 /* switch to eval mode */
2524
cbce877f
IZ
2525 if (PL_curcop == &PL_compiling) {
2526 SAVESPTR(PL_compiling.cop_stash);
2527 PL_compiling.cop_stash = PL_curstash;
2528 }
3280af22
NIS
2529 SAVESPTR(PL_compiling.cop_filegv);
2530 SAVEI16(PL_compiling.cop_line);
2531 sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2532 PL_compiling.cop_filegv = gv_fetchfile(tmpbuf+2);
2533 PL_compiling.cop_line = 1;
c277df42
IZ
2534 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2535 deleting the eval's FILEGV from the stash before gv_check() runs
2536 (i.e. before run-time proper). To work around the coredump that
2537 ensues, we always turn GvMULTI_on for any globals that were
2538 introduced within evals. See force_ident(). GSAR 96-10-12 */
2539 safestr = savepv(tmpbuf);
3280af22 2540 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
b3ac6de7 2541 SAVEHINTS();
d1ca3daa 2542#ifdef OP_IN_REGISTER
6b88bc9c 2543 PL_opsave = op;
d1ca3daa 2544#else
533c011a 2545 SAVEPPTR(PL_op);
d1ca3daa 2546#endif
3280af22 2547 PL_hints = 0;
c277df42 2548
533c011a 2549 PL_op = &dummy;
13b51b79 2550 PL_op->op_type = OP_ENTEREVAL;
533c011a 2551 PL_op->op_flags = 0; /* Avoid uninit warning. */
c277df42 2552 PUSHBLOCK(cx, CXt_EVAL, SP);
6b88bc9c 2553 PUSHEVAL(cx, 0, PL_compiling.cop_filegv);
c277df42 2554 rop = doeval(G_SCALAR, startop);
13b51b79 2555 POPBLOCK(cx,PL_curpm);
e84b9f1f 2556 POPEVAL(cx);
c277df42
IZ
2557
2558 (*startop)->op_type = OP_NULL;
22c35a8c 2559 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
c277df42 2560 lex_end();
3280af22 2561 *avp = (AV*)SvREFCNT_inc(PL_comppad);
c277df42 2562 LEAVE;
13b51b79 2563 if (PL_curcop == &PL_compiling)
a0ed51b3 2564 PL_compiling.op_private = PL_hints;
d1ca3daa 2565#ifdef OP_IN_REGISTER
6b88bc9c 2566 op = PL_opsave;
d1ca3daa 2567#endif
c277df42
IZ
2568 return rop;
2569}
2570
0f15f207 2571/* With USE_THREADS, eval_owner must be held on entry to doeval */
0824fdcb 2572STATIC OP *
c277df42 2573doeval(int gimme, OP** startop)
a0d0e21e
LW
2574{
2575 dSP;
533c011a 2576 OP *saveop = PL_op;
a0d0e21e 2577 HV *newstash;
ff3ff8d1 2578 CV *caller;
748a9306 2579 AV* comppadlist;
67a38de0 2580 I32 i;
a0d0e21e 2581
3280af22 2582 PL_in_eval = 1;
a0d0e21e 2583
1ce6579f
PP
2584 PUSHMARK(SP);
2585
a0d0e21e
LW
2586 /* set up a scratch pad */
2587
3280af22
NIS
2588 SAVEI32(PL_padix);
2589 SAVESPTR(PL_curpad);
2590 SAVESPTR(PL_comppad);
2591 SAVESPTR(PL_comppad_name);
2592 SAVEI32(PL_comppad_name_fill);
2593 SAVEI32(PL_min_intro_pending);
2594 SAVEI32(PL_max_intro_pending);
748a9306 2595
3280af22 2596 caller = PL_compcv;
6b35e009 2597 for (i = cxstack_ix - 1; i >= 0; i--) {
67a38de0 2598 PERL_CONTEXT *cx = &cxstack[i];
6b35e009 2599 if (CxTYPE(cx) == CXt_EVAL)
67a38de0 2600 break;
6b35e009 2601 else if (CxTYPE(cx) == CXt_SUB) {
67a38de0
NIS
2602 caller = cx->blk_sub.cv;
2603 break;
2604 }
2605 }
2606
3280af22
NIS
2607 SAVESPTR(PL_compcv);
2608 PL_compcv = (CV*)NEWSV(1104,0);
2609 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2610 CvUNIQUE_on(PL_compcv);
11343788 2611#ifdef USE_THREADS
533c011a
NIS
2612 CvOWNER(PL_compcv) = 0;
2613 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
2614 MUTEX_INIT(CvMUTEXP(PL_compcv));
11343788 2615#endif /* USE_THREADS */
748a9306 2616
3280af22
NIS
2617 PL_comppad = newAV();
2618 av_push(PL_comppad, Nullsv);
2619 PL_curpad = AvARRAY(PL_comppad);
2620 PL_comppad_name = newAV();
2621 PL_comppad_name_fill = 0;
2622 PL_min_intro_pending = 0;
2623 PL_padix = 0;
11343788 2624#ifdef USE_THREADS
533c011a
NIS
2625 av_store(PL_comppad_name, 0, newSVpv("@_", 2));
2626 PL_curpad[0] = (SV*)newAV();
2627 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
11343788 2628#endif /* USE_THREADS */
a0d0e21e 2629
748a9306
LW
2630 comppadlist = newAV();
2631 AvREAL_off(comppadlist);
3280af22
NIS
2632 av_store(comppadlist, 0, (SV*)PL_comppad_name);
2633 av_store(comppadlist, 1, (SV*)PL_comppad);
2634 CvPADLIST(PL_compcv) = comppadlist;
2c05e328 2635
c277df42 2636 if (!saveop || saveop->op_type != OP_REQUIRE)
3280af22 2637 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(caller);
07055b4c 2638
3280af22 2639 SAVEFREESV(PL_compcv);
748a9306 2640
a0d0e21e
LW
2641 /* make sure we compile in the right package */
2642
3280af22
NIS
2643 newstash = PL_curcop->cop_stash;
2644 if (PL_curstash != newstash) {
2645 SAVESPTR(PL_curstash);
2646 PL_curstash = newstash;
a0d0e21e 2647 }
3280af22
NIS
2648 SAVESPTR(PL_beginav);
2649 PL_beginav = newAV();
2650 SAVEFREESV(PL_beginav);
a0d0e21e
LW
2651
2652 /* try to compile it */
2653
3280af22
NIS
2654 PL_eval_root = Nullop;
2655 PL_error_count = 0;
2656 PL_curcop = &PL_compiling;
2657 PL_curcop->cop_arybase = 0;
2658 SvREFCNT_dec(PL_rs);
2659 PL_rs = newSVpv("\n", 1);
c277df42 2660 if (saveop && saveop->op_flags & OPf_SPECIAL)
3280af22 2661 PL_in_eval |= 4;
1ce6579f 2662 else
38a03e6e 2663 sv_setpv(ERRSV,"");
3280af22 2664 if (yyparse() || PL_error_count || !PL_eval_root) {
a0d0e21e
LW
2665 SV **newsp;
2666 I32 gimme;
c09156bb 2667 PERL_CONTEXT *cx;
c277df42 2668 I32 optype = 0; /* Might be reset by POPEVAL. */
2d8e6c8d 2669 STRLEN n_a;
a0d0e21e 2670
533c011a 2671 PL_op = saveop;
3280af22
NIS
2672 if (PL_eval_root) {
2673 op_free(PL_eval_root);
2674 PL_eval_root = Nullop;
a0d0e21e 2675 }
3280af22 2676 SP = PL_stack_base + POPMARK; /* pop original mark */
c277df42 2677 if (!startop) {
3280af22 2678 POPBLOCK(cx,PL_curpm);
c277df42
IZ
2679 POPEVAL(cx);
2680 pop_return();
2681 }
a0d0e21e
LW
2682 lex_end();
2683 LEAVE;
7a2e2cd6 2684 if (optype == OP_REQUIRE) {
2d8e6c8d 2685 char* msg = SvPVx(ERRSV, n_a);
7a2e2cd6 2686 DIE("%s", *msg ? msg : "Compilation failed in require");
c277df42 2687 } else if (startop) {
2d8e6c8d 2688 char* msg = SvPVx(ERRSV, n_a);
c277df42 2689
3280af22 2690 POPBLOCK(cx,PL_curpm);
c277df42
IZ
2691 POPEVAL(cx);
2692 croak("%sCompilation failed in regexp", (*msg ? msg : "Unknown error\n"));
7a2e2cd6 2693 }
3280af22
NIS
2694 SvREFCNT_dec(PL_rs);
2695 PL_rs = SvREFCNT_inc(PL_nrs);
f2134d95 2696#ifdef USE_THREADS
533c011a
NIS
2697 MUTEX_LOCK(&PL_eval_mutex);
2698 PL_eval_owner = 0;
2699 COND_SIGNAL(&PL_eval_cond);
2700 MUTEX_UNLOCK(&PL_eval_mutex);
f2134d95 2701#endif /* USE_THREADS */
a0d0e21e
LW
2702 RETPUSHUNDEF;
2703 }
3280af22
NIS
2704 SvREFCNT_dec(PL_rs);
2705 PL_rs = SvREFCNT_inc(PL_nrs);
2706 PL_compiling.cop_line = 0;
c277df42 2707 if (startop) {
3280af22
NIS
2708 *startop = PL_eval_root;
2709 SvREFCNT_dec(CvOUTSIDE(PL_compcv));
2710 CvOUTSIDE(PL_compcv) = Nullcv;
c277df42 2711 } else
3280af22 2712 SAVEFREEOP(PL_eval_root);
54310121 2713 if (gimme & G_VOID)
3280af22 2714 scalarvoid(PL_eval_root);
54310121 2715 else if (gimme & G_ARRAY)
3280af22 2716 list(PL_eval_root);
a0d0e21e 2717 else
3280af22 2718 scalar(PL_eval_root);
a0d0e21e
LW
2719
2720 DEBUG_x(dump_eval());
2721
55497cff 2722 /* Register with debugger: */
84902520 2723 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
55497cff 2724 CV *cv = perl_get_cv("DB::postponed", FALSE);
55497cff
PP
2725 if (cv) {
2726 dSP;
924508f0 2727 PUSHMARK(SP);
3280af22 2728 XPUSHs((SV*)PL_compiling.cop_filegv);
55497cff
PP
2729 PUTBACK;
2730 perl_call_sv((SV*)cv, G_DISCARD);
2731 }
2732 }
2733
a0d0e21e
LW
2734 /* compiled okay, so do it */
2735
3280af22
NIS
2736 CvDEPTH(PL_compcv) = 1;
2737 SP = PL_stack_base + POPMARK; /* pop original mark */
533c011a 2738 PL_op = saveop; /* The caller may need it. */
b35b2403 2739#ifdef USE_THREADS
533c011a
NIS
2740 MUTEX_LOCK(&PL_eval_mutex);
2741 PL_eval_owner = 0;
2742 COND_SIGNAL(&PL_eval_cond);
2743 MUTEX_UNLOCK(&PL_eval_mutex);
b35b2403 2744#endif /* USE_THREADS */
5dc0d613 2745
3280af22 2746 RETURNOP(PL_eval_start);
a0d0e21e
LW
2747}
2748
2749PP(pp_require)
2750{
4e35701f 2751 djSP;
c09156bb 2752 register PERL_CONTEXT *cx;
a0d0e21e
LW
2753 SV *sv;
2754 char *name;
6132ea6c 2755 STRLEN len;
46fc3d4c
PP
2756 char *tryname;
2757 SV *namesv = Nullsv;
a0d0e21e
LW
2758 SV** svp;
2759 I32 gimme = G_SCALAR;
760ac839 2760 PerlIO *tryrsfp = 0;
2d8e6c8d 2761 STRLEN n_a;
a0d0e21e
LW
2762
2763 sv = POPs;
4633a7c4 2764 if (SvNIOKp(sv) && !SvPOKp(sv)) {
36477c24 2765 SET_NUMERIC_STANDARD();
3280af22 2766 if (atof(PL_patchlevel) + 0.00000999 < SvNV(sv))
a5f75d66 2767 DIE("Perl %s required--this is only version %s, stopped",
2d8e6c8d 2768 SvPV(sv,n_a),PL_patchlevel);
a0d0e21e
LW
2769 RETPUSHYES;
2770 }
6132ea6c
GS
2771 name = SvPV(sv, len);
2772 if (!(name && len > 0 && *name))
a0d0e21e 2773 DIE("Null filename used");
4633a7c4 2774 TAINT_PROPER("require");
533c011a 2775 if (PL_op->op_type == OP_REQUIRE &&
3280af22
NIS
2776 (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0)) &&
2777 *svp != &PL_sv_undef)
a0d0e21e
LW
2778 RETPUSHYES;
2779
2780 /* prepare to compile file */
2781
46fc3d4c
PP
2782 if (*name == '/' ||
2783 (*name == '.' &&
2784 (name[1] == '/' ||
2785 (name[1] == '.' && name[2] == '/')))
4633a7c4 2786#ifdef DOSISH
46fc3d4c 2787 || (name[0] && name[1] == ':')
4633a7c4 2788#endif
ba42ef2f
WJ
2789#ifdef WIN32
2790 || (name[0] == '\\' && name[1] == '\\') /* UNC path */
2791#endif
748a9306 2792#ifdef VMS
46fc3d4c
PP
2793 || (strchr(name,':') || ((*name == '[' || *name == '<') &&
2794 (isALNUM(name[1]) || strchr("$-_]>",name[1]))))
748a9306
LW
2795#endif
2796 )
a0d0e21e 2797 {
46fc3d4c 2798 tryname = name;
a868473f 2799 tryrsfp = PerlIO_open(name,PERL_SCRIPT_MODE);
a0d0e21e
LW
2800 }
2801 else {
3280af22 2802 AV *ar = GvAVn(PL_incgv);
a0d0e21e 2803 I32 i;
748a9306 2804#ifdef VMS
46fc3d4c
PP
2805 char *unixname;
2806 if ((unixname = tounixspec(name, Nullch)) != Nullch)
2807#endif
2808 {
2809 namesv = NEWSV(806, 0);
2810 for (i = 0; i <= AvFILL(ar); i++) {
2d8e6c8d 2811 char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
46fc3d4c
PP
2812#ifdef VMS
2813 char *unixdir;
2814 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
2815 continue;
2816 sv_setpv(namesv, unixdir);
2817 sv_catpv(namesv, unixname);
748a9306 2818#else
46fc3d4c 2819 sv_setpvf(namesv, "%s/%s", dir, name);
748a9306 2820#endif
0cf10dd2 2821 TAINT_PROPER("require");
46fc3d4c 2822 tryname = SvPVX(namesv);
a868473f 2823 tryrsfp = PerlIO_open(tryname, PERL_SCRIPT_MODE);
46fc3d4c
PP
2824 if (tryrsfp) {
2825 if (tryname[0] == '.' && tryname[1] == '/')
2826 tryname += 2;
2827 break;
2828 }
a0d0e21e
LW
2829 }
2830 }
2831 }
3280af22
NIS
2832 SAVESPTR(PL_compiling.cop_filegv);
2833 PL_compiling.cop_filegv = gv_fetchfile(tryrsfp ? tryname : name);
46fc3d4c 2834 SvREFCNT_dec(namesv);
a0d0e21e 2835 if (!tryrsfp) {
533c011a 2836 if (PL_op->op_type == OP_REQUIRE) {
cca87523 2837 SV *msg = sv_2mortal(newSVpvf("Can't locate %s in @INC", name));
2683423c 2838 SV *dirmsgsv = NEWSV(0, 0);
3280af22 2839 AV *ar = GvAVn(PL_incgv);
2683423c 2840 I32 i;
46fc3d4c
PP
2841 if (instr(SvPVX(msg), ".h "))
2842 sv_catpv(msg, " (change .h to .ph maybe?)");
2843 if (instr(SvPVX(msg), ".ph "))
2844 sv_catpv(msg, " (did you run h2ph?)");
3e3baf6d 2845 sv_catpv(msg, " (@INC contains:");
2683423c 2846 for (i = 0; i <= AvFILL(ar); i++) {
2d8e6c8d 2847 char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
3e3baf6d 2848 sv_setpvf(dirmsgsv, " %s", dir);
2683423c
JA
2849 sv_catsv(msg, dirmsgsv);
2850 }
3e3baf6d 2851 sv_catpvn(msg, ")", 1);
2683423c 2852 SvREFCNT_dec(dirmsgsv);
fc36a67e 2853 DIE("%_", msg);
a0d0e21e
LW
2854 }
2855
2856 RETPUSHUNDEF;
2857 }
d8bfb8bd 2858 else
aba27d88 2859 SETERRNO(0, SS$_NORMAL);
a0d0e21e
LW
2860
2861 /* Assume success here to prevent recursive requirement. */
3280af22
NIS
2862 (void)hv_store(GvHVn(PL_incgv), name, strlen(name),
2863 newSVsv(GvSV(PL_compiling.cop_filegv)), 0 );
a0d0e21e
LW
2864
2865 ENTER;
2866 SAVETMPS;
2867 lex_start(sv_2mortal(newSVpv("",0)));
b9d12d37
GS
2868 SAVEGENERICSV(PL_rsfp_filters);
2869 PL_rsfp_filters = Nullav;
e50aee73 2870
3280af22 2871 PL_rsfp = tryrsfp;
a0d0e21e
LW
2872 name = savepv(name);
2873 SAVEFREEPV(name);
b3ac6de7 2874 SAVEHINTS();
3280af22 2875 PL_hints = 0;
599cee73
PM
2876 SAVEPPTR(PL_compiling.cop_warnings);
2877 PL_compiling.cop_warnings = ((PL_dowarn & G_WARN_ALL_ON) ? WARN_ALL
2878 : WARN_NONE);
a0d0e21e
LW
2879
2880 /* switch to eval mode */
2881
533c011a 2882 push_return(PL_op->op_next);
a0d0e21e 2883 PUSHBLOCK(cx, CXt_EVAL, SP);
6b88bc9c 2884 PUSHEVAL(cx, name, PL_compiling.cop_filegv);
a0d0e21e 2885
63eb823a 2886 SAVEI16(PL_compiling.cop_line);
3280af22 2887 PL_compiling.cop_line = 0;
a0d0e21e
LW
2888
2889 PUTBACK;
0f15f207 2890#ifdef USE_THREADS
533c011a
NIS
2891 MUTEX_LOCK(&PL_eval_mutex);
2892 if (PL_eval_owner && PL_eval_owner != thr)
2893 while (PL_eval_owner)
2894 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
2895 PL_eval_owner = thr;
2896 MUTEX_UNLOCK(&PL_eval_mutex);
0f15f207 2897#endif /* USE_THREADS */
c277df42 2898 return DOCATCH(doeval(G_SCALAR, NULL));
a0d0e21e
LW
2899}
2900
2901PP(pp_dofile)
2902{
2903 return pp_require(ARGS);
2904}
2905
2906PP(pp_entereval)
2907{
4e35701f 2908 djSP;
c09156bb 2909 register PERL_CONTEXT *cx;
a0d0e21e 2910 dPOPss;
3280af22 2911 I32 gimme = GIMME_V, was = PL_sub_generation;
fc36a67e
PP
2912 char tmpbuf[TYPE_DIGITS(long) + 12];
2913 char *safestr;
a0d0e21e 2914 STRLEN len;
55497cff 2915 OP *ret;
a0d0e21e
LW
2916
2917 if (!SvPV(sv,len) || !len)
2918 RETPUSHUNDEF;
748a9306 2919 TAINT_PROPER("eval");
a0d0e21e
LW
2920
2921 ENTER;
a0d0e21e 2922 lex_start(sv);
748a9306 2923 SAVETMPS;
a0d0e21e
LW
2924
2925 /* switch to eval mode */
2926
3280af22
NIS
2927 SAVESPTR(PL_compiling.cop_filegv);
2928 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
2929 PL_compiling.cop_filegv = gv_fetchfile(tmpbuf+2);
2930 PL_compiling.cop_line = 1;
55497cff
PP
2931 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2932 deleting the eval's FILEGV from the stash before gv_check() runs
2933 (i.e. before run-time proper). To work around the coredump that
2934 ensues, we always turn GvMULTI_on for any globals that were
2935 introduced within evals. See force_ident(). GSAR 96-10-12 */
2936 safestr = savepv(tmpbuf);
3280af22 2937 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
b3ac6de7 2938 SAVEHINTS();
533c011a 2939 PL_hints = PL_op->op_targ;
e24b16f9 2940 SAVEPPTR(PL_compiling.cop_warnings);
599cee73
PM
2941 if (PL_compiling.cop_warnings != WARN_ALL
2942 && PL_compiling.cop_warnings != WARN_NONE){
2943 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
2944 SAVEFREESV(PL_compiling.cop_warnings) ;
2945 }
a0d0e21e 2946
533c011a 2947 push_return(PL_op->op_next);
6b35e009 2948 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
6b88bc9c 2949 PUSHEVAL(cx, 0, PL_compiling.cop_filegv);
a0d0e21e
LW
2950
2951 /* prepare to compile string */
2952
3280af22
NIS
2953 if (PERLDB_LINE && PL_curstash != PL_debstash)
2954 save_lines(GvAV(PL_compiling.cop_filegv), PL_linestr);
a0d0e21e 2955 PUTBACK;
0f15f207 2956#ifdef USE_THREADS
533c011a
NIS
2957 MUTEX_LOCK(&PL_eval_mutex);
2958 if (PL_eval_owner && PL_eval_owner != thr)
2959 while (PL_eval_owner)
2960 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
2961 PL_eval_owner = thr;
2962 MUTEX_UNLOCK(&PL_eval_mutex);
0f15f207 2963#endif /* USE_THREADS */
c277df42 2964 ret = doeval(gimme, NULL);
3280af22 2965 if (PERLDB_INTER && was != PL_sub_generation /* Some subs defined here. */
533c011a 2966 && ret != PL_op->op_next) { /* Successive compilation. */
55497cff
PP
2967 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
2968 }
1e422769 2969 return DOCATCH(ret);
a0d0e21e
LW
2970}
2971
2972PP(pp_leaveeval)
2973{
4e35701f 2974 djSP;
a0d0e21e
LW
2975 register SV **mark;
2976 SV **newsp;
2977 PMOP *newpm;
2978 I32 gimme;
c09156bb 2979 register PERL_CONTEXT *cx;
a0d0e21e 2980 OP *retop;
533c011a 2981 U8 save_flags = PL_op -> op_flags;
a0d0e21e
LW
2982 I32 optype;
2983
2984 POPBLOCK(cx,newpm);
2985 POPEVAL(cx);
2986 retop = pop_return();
2987
a1f49e72 2988 TAINT_NOT;
54310121
PP
2989 if (gimme == G_VOID)
2990 MARK = newsp;
2991 else if (gimme == G_SCALAR) {
2992 MARK = newsp + 1;
2993 if (MARK <= SP) {
2994 if (SvFLAGS(TOPs) & SVs_TEMP)
2995 *MARK = TOPs;
2996 else
2997 *MARK = sv_mortalcopy(TOPs);
2998 }
a0d0e21e 2999 else {
54310121 3000 MEXTEND(mark,0);
3280af22 3001 *MARK = &PL_sv_undef;
a0d0e21e 3002 }
a0d0e21e
LW
3003 }
3004 else {
a1f49e72
CS
3005 /* in case LEAVE wipes old return values */
3006 for (mark = newsp + 1; mark <= SP; mark++) {
3007 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
a0d0e21e 3008 *mark = sv_mortalcopy(*mark);
a1f49e72
CS
3009 TAINT_NOT; /* Each item is independent */
3010 }
3011 }
a0d0e21e 3012 }
3280af22 3013 PL_curpm = newpm; /* Don't pop $1 et al till now */
a0d0e21e 3014
84902520
TB
3015 /*
3016 * Closures mentioned at top level of eval cannot be referenced
3017 * again, and their presence indirectly causes a memory leak.
3018 * (Note that the fact that compcv and friends are still set here
3019 * is, AFAIK, an accident.) --Chip
3020 */
3280af22
NIS
3021 if (AvFILLp(PL_comppad_name) >= 0) {
3022 SV **svp = AvARRAY(PL_comppad_name);
84902520 3023 I32 ix;
3280af22 3024 for (ix = AvFILLp(PL_comppad_name); ix >= 0; ix--) {
84902520 3025 SV *sv = svp[ix];
3280af22 3026 if (sv && sv != &PL_sv_undef && *SvPVX(sv) == '&') {
84902520 3027 SvREFCNT_dec(sv);
3280af22 3028 svp[ix] = &PL_sv_undef;
84902520 3029
3280af22 3030 sv = PL_curpad[ix];
84902520
TB
3031 if (CvCLONE(sv)) {
3032 SvREFCNT_dec(CvOUTSIDE(sv));
3033 CvOUTSIDE(sv) = Nullcv;
3034 }
3035 else {
3036 SvREFCNT_dec(sv);
3037 sv = NEWSV(0,0);
3038 SvPADTMP_on(sv);
3280af22 3039 PL_curpad[ix] = sv;
84902520
TB
3040 }
3041 }
3042 }
3043 }
3044
4fdae800 3045#ifdef DEBUGGING
3280af22 3046 assert(CvDEPTH(PL_compcv) == 1);
4fdae800 3047#endif
3280af22 3048 CvDEPTH(PL_compcv) = 0;
f46d017c 3049 lex_end();
4fdae800 3050
1ce6579f 3051 if (optype == OP_REQUIRE &&
924508f0 3052 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
54310121 3053 {
1ce6579f 3054 /* Unassume the success we assumed earlier. */
54310121 3055 char *name = cx->blk_eval.old_name;
3280af22 3056 (void)hv_delete(GvHVn(PL_incgv), name, strlen(name), G_DISCARD);
1ce6579f 3057 retop = die("%s did not return a true value", name);
f46d017c
GS
3058 /* die_where() did LEAVE, or we won't be here */
3059 }
3060 else {
3061 LEAVE;
3062 if (!(save_flags & OPf_SPECIAL))
3063 sv_setpv(ERRSV,"");
a0d0e21e 3064 }
a0d0e21e
LW
3065
3066 RETURNOP(retop);
3067}
3068
a0d0e21e
LW
3069PP(pp_entertry)
3070{
4e35701f 3071 djSP;
c09156bb 3072 register PERL_CONTEXT *cx;
54310121 3073 I32 gimme = GIMME_V;
a0d0e21e
LW
3074
3075 ENTER;
3076 SAVETMPS;
3077
3078 push_return(cLOGOP->op_other->op_next);
3079 PUSHBLOCK(cx, CXt_EVAL, SP);
3080 PUSHEVAL(cx, 0, 0);
533c011a 3081 PL_eval_root = PL_op; /* Only needed so that goto works right. */
a0d0e21e 3082
3280af22 3083 PL_in_eval = 1;
38a03e6e 3084 sv_setpv(ERRSV,"");
1e422769 3085 PUTBACK;
533c011a 3086 return DOCATCH(PL_op->op_next);
a0d0e21e
LW
3087}
3088
3089PP(pp_leavetry)
3090{
4e35701f 3091 djSP;
a0d0e21e
LW
3092 register SV **mark;
3093 SV **newsp;
3094 PMOP *newpm;
3095 I32 gimme;
c09156bb 3096 register PERL_CONTEXT *cx;
a0d0e21e
LW
3097 I32 optype;
3098
3099 POPBLOCK(cx,newpm);
3100 POPEVAL(cx);
3101 pop_return();
3102
a1f49e72 3103 TAINT_NOT;
54310121
PP
3104 if (gimme == G_VOID)
3105 SP = newsp;
3106 else if (gimme == G_SCALAR) {
3107 MARK = newsp + 1;
3108 if (MARK <= SP) {
3109 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3110 *MARK = TOPs;
3111 else
3112 *MARK = sv_mortalcopy(TOPs);
3113 }
a0d0e21e 3114 else {
54310121 3115 MEXTEND(mark,0);
3280af22 3116 *MARK = &PL_sv_undef;
a0d0e21e
LW
3117 }
3118 SP = MARK;
3119 }
3120 else {
a1f49e72
CS
3121 /* in case LEAVE wipes old return values */
3122 for (mark = newsp + 1; mark <= SP; mark++) {
3123 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
a0d0e21e 3124 *mark = sv_mortalcopy(*mark);
a1f49e72
CS
3125 TAINT_NOT; /* Each item is independent */
3126 }
3127 }
a0d0e21e 3128 }
3280af22 3129 PL_curpm = newpm; /* Don't pop $1 et al till now */
a0d0e21e
LW
3130
3131 LEAVE;
38a03e6e 3132 sv_setpv(ERRSV,"");
a0d0e21e
LW
3133 RETURN;
3134}
3135
0824fdcb 3136STATIC void
8ac85365 3137doparseform(SV *sv)
a0d0e21e
LW
3138{
3139 STRLEN len;
3140 register char *s = SvPV_force(sv, len);
3141 register char *send = s + len;
3142 register char *base;
3143 register I32 skipspaces = 0;
3144 bool noblank;
3145 bool repeat;
3146 bool postspace = FALSE;
3147 U16 *fops;
3148 register U16 *fpc;
3149 U16 *linepc;
3150 register I32 arg;
3151 bool ischop;
3152
55497cff 3153 if (len == 0)
bbce6d69 3154 croak("Null picture in formline");
55497cff
PP
3155
3156 New(804, fops, (send - s)*3+10, U16); /* Almost certainly too long... */
a0d0e21e
LW
3157 fpc = fops;
3158
3159 if (s < send) {
3160 linepc = fpc;
3161 *fpc++ = FF_LINEMARK;
3162 noblank = repeat = FALSE;
3163 base = s;
3164 }
3165
3166 while (s <= send) {
3167 switch (*s++) {
3168 default:
3169 skipspaces = 0;
3170 continue;
3171
3172 case '~':
3173 if (*s == '~') {
3174 repeat = TRUE;
3175 *s = ' ';
3176 }
3177 noblank = TRUE;
3178 s[-1] = ' ';
3179 /* FALL THROUGH */
3180 case ' ': case '\t':
3181 skipspaces++;
3182 continue;
3183
3184 case '\n': case 0:
3185 arg = s - base;
3186 skipspaces++;
3187 arg -= skipspaces;
3188 if (arg) {
5f05dabc 3189 if (postspace)
a0d0e21e 3190 *fpc++ = FF_SPACE;
a0d0e21e
LW
3191 *fpc++ = FF_LITERAL;
3192 *fpc++ = arg;
3193 }
5f05dabc 3194 postspace = FALSE;
a0d0e21e
LW
3195 if (s <= send)
3196 skipspaces--;
3197 if (skipspaces) {
3198 *fpc++ = FF_SKIP;
3199 *fpc++ = skipspaces;
3200 }
3201 skipspaces = 0;
3202 if (s <= send)
3203 *fpc++ = FF_NEWLINE;
3204 if (noblank) {
3205 *fpc++ = FF_BLANK;
3206 if (repeat)
3207 arg = fpc - linepc + 1;
3208 else
3209 arg = 0;
3210 *fpc++ = arg;
3211 }
3212 if (s < send) {
3213 linepc = fpc;
3214 *fpc++ = FF_LINEMARK;
3215 noblank = repeat = FALSE;
3216 base = s;
3217 }
3218 else
3219 s++;
3220 continue;
3221
3222 case '@':
3223 case '^':
3224 ischop = s[-1] == '^';
3225
3226 if (postspace) {
3227 *fpc++ = FF_SPACE;
3228 postspace = FALSE;
3229 }
3230 arg = (s - base) - 1;
3231 if (arg) {
3232 *fpc++ = FF_LITERAL;
3233 *fpc++ = arg;
3234 }
3235
3236 base = s - 1;
3237 *fpc++ = FF_FETCH;
3238 if (*s == '*') {
3239 s++;
3240 *fpc++ = 0;
3241 *fpc++ = FF_LINEGLOB;
3242 }
3243 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3244 arg = ischop ? 512 : 0;
3245 base = s - 1;
3246 while (*s == '#')
3247 s++;
3248 if (*s == '.') {
3249 char *f;
3250 s++;
3251 f = s;
3252 while (*s == '#')
3253 s++;
3254 arg |= 256 + (s - f);
3255 }
3256 *fpc++ = s - base; /* fieldsize for FETCH */
3257 *fpc++ = FF_DECIMAL;
3258 *fpc++ = arg;
3259 }
3260 else {
3261 I32 prespace = 0;
3262 bool ismore = FALSE;
3263
3264 if (*s == '>') {
3265 while (*++s == '>') ;
3266 prespace = FF_SPACE;
3267 }
3268 else if (*s == '|') {
3269 while (*++s == '|') ;
3270 prespace = FF_HALFSPACE;
3271 postspace = TRUE;
3272 }
3273 else {
3274 if (*s == '<')
3275 while (*++s == '<') ;
3276 postspace = TRUE;
3277 }
3278 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3279 s += 3;
3280 ismore = TRUE;
3281 }
3282 *fpc++ = s - base; /* fieldsize for FETCH */
3283
3284 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3285
3286 if (prespace)
3287 *fpc++ = prespace;
3288 *fpc++ = FF_ITEM;
3289 if (ismore)
3290 *fpc++ = FF_MORE;
3291 if (ischop)
3292 *fpc++ = FF_CHOP;
3293 }
3294 base = s;
3295 skipspaces = 0;
3296 continue;
3297 }
3298 }
3299 *fpc++ = FF_END;
3300
3301 arg = fpc - fops;
3302 { /* need to jump to the next word */
3303 int z;
3304 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3305 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U16) + 4);
3306 s = SvPVX(sv) + SvCUR(sv) + z;
3307 }
3308 Copy(fops, s, arg, U16);
3309 Safefree(fops);
55497cff 3310 sv_magic(sv, Nullsv, 'f', Nullch, 0);
a0d0e21e
LW
3311 SvCOMPILED_on(sv);
3312}
4e35701f 3313
745d3a65
HM
3314/*
3315 * The rest of this file was derived from source code contributed
3316 * by Tom Horsley.
3317 *
3318 * NOTE: this code was derived from Tom Horsley's qsort replacement
3319 * and should not be confused with the original code.
3320 */
3321
3322/* Copyright (C) Tom Horsley, 1997. All rights reserved.
3323
3324 Permission granted to distribute under the same terms as perl which are
3325 (briefly):
3326
3327 This program is free software; you can redistribute it and/or modify
3328 it under the terms of either:
3329
3330 a) the GNU General Public License as published by the Free
3331 Software Foundation; either version 1, or (at your option) any
3332 later version, or
3333
3334 b) the "Artistic License" which comes with this Kit.
3335
3336 Details on the perl license can be found in the perl source code which
3337 may be located via the www.perl.com web page.
3338
3339 This is the most wonderfulest possible qsort I can come up with (and
3340 still be mostly portable) My (limited) tests indicate it consistently
3341 does about 20% fewer calls to compare than does the qsort in the Visual
3342 C++ library, other vendors may vary.
3343
3344 Some of the ideas in here can be found in "Algorithms" by Sedgewick,
3345 others I invented myself (or more likely re-invented since they seemed
3346 pretty obvious once I watched the algorithm operate for a while).
3347
3348 Most of this code was written while watching the Marlins sweep the Giants
3349 in the 1997 National League Playoffs - no Braves fans allowed to use this
3350 code (just kidding :-).
3351
3352 I realize that if I wanted to be true to the perl tradition, the only
3353 comment in this file would be something like:
3354
3355 ...they shuffled back towards the rear of the line. 'No, not at the
3356 rear!' the slave-driver shouted. 'Three files up. And stay there...
3357
3358 However, I really needed to violate that tradition just so I could keep
3359 track of what happens myself, not to mention some poor fool trying to
3360 understand this years from now :-).
3361*/
3362
3363/* ********************************************************** Configuration */
3364
3365#ifndef QSORT_ORDER_GUESS
3366#define QSORT_ORDER_GUESS 2 /* Select doubling version of the netBSD trick */
3367#endif
3368
3369/* QSORT_MAX_STACK is the largest number of partitions that can be stacked up for
3370 future processing - a good max upper bound is log base 2 of memory size
3371 (32 on 32 bit machines, 64 on 64 bit machines, etc). In reality can
3372 safely be smaller than that since the program is taking up some space and
3373 most operating systems only let you grab some subset of contiguous
3374 memory (not to mention that you are normally sorting data larger than
3375 1 byte element size :-).
3376*/
3377#ifndef QSORT_MAX_STACK
3378#define QSORT_MAX_STACK 32
3379#endif
3380
3381/* QSORT_BREAK_EVEN is the size of the largest partition we should insertion sort.
3382 Anything bigger and we use qsort. If you make this too small, the qsort
3383 will probably break (or become less efficient), because it doesn't expect
3384 the middle element of a partition to be the same as the right or left -
3385 you have been warned).
3386*/
3387#ifndef QSORT_BREAK_EVEN
3388#define QSORT_BREAK_EVEN 6
3389#endif
3390
3391/* ************************************************************* Data Types */
3392
3393/* hold left and right index values of a partition waiting to be sorted (the
3394 partition includes both left and right - right is NOT one past the end or
3395 anything like that).
3396*/
3397struct partition_stack_entry {
3398 int left;
3399 int right;
3400#ifdef QSORT_ORDER_GUESS
3401 int qsort_break_even;
3402#endif
3403};
3404
3405/* ******************************************************* Shorthand Macros */
3406
3407/* Note that these macros will be used from inside the qsort function where
3408 we happen to know that the variable 'elt_size' contains the size of an
3409 array element and the variable 'temp' points to enough space to hold a
3410 temp element and the variable 'array' points to the array being sorted
3411 and 'compare' is the pointer to the compare routine.
3412
3413 Also note that there are very many highly architecture specific ways
3414 these might be sped up, but this is simply the most generally portable
3415 code I could think of.
3416*/
161b471a 3417
745d3a65
HM
3418/* Return < 0 == 0 or > 0 as the value of elt1 is < elt2, == elt2, > elt2
3419*/
565764a8
DL
3420#ifdef PERL_OBJECT
3421#define qsort_cmp(elt1, elt2) \
3422 ((this->*compare)(array[elt1], array[elt2]))
3423#else
745d3a65
HM
3424#define qsort_cmp(elt1, elt2) \
3425 ((*compare)(array[elt1], array[elt2]))
565764a8 3426#endif
745d3a65
HM
3427
3428#ifdef QSORT_ORDER_GUESS
3429#define QSORT_NOTICE_SWAP swapped++;
3430#else
3431#define QSORT_NOTICE_SWAP
3432#endif
3433
3434/* swaps contents of array elements elt1, elt2.
3435*/
3436#define qsort_swap(elt1, elt2) \
3437 STMT_START { \
3438 QSORT_NOTICE_SWAP \
3439 temp = array[elt1]; \
3440 array[elt1] = array[elt2]; \
3441 array[elt2] = temp; \
3442 } STMT_END
3443
3444/* rotate contents of elt1, elt2, elt3 such that elt1 gets elt2, elt2 gets
3445 elt3 and elt3 gets elt1.
3446*/
3447#define qsort_rotate(elt1, elt2, elt3) \
3448 STMT_START { \
3449 QSORT_NOTICE_SWAP \
3450 temp = array[elt1]; \
3451 array[elt1] = array[elt2]; \
3452 array[elt2] = array[elt3]; \
3453 array[elt3] = temp; \
3454 } STMT_END
3455
3456/* ************************************************************ Debug stuff */
3457
3458#ifdef QSORT_DEBUG
3459
3460static void
3461break_here()
3462{
3463 return; /* good place to set a breakpoint */
3464}
3465
3466#define qsort_assert(t) (void)( (t) || (break_here(), 0) )
3467
3468static void
3469doqsort_all_asserts(
3470 void * array,
3471 size_t num_elts,
3472 size_t elt_size,
3473 int (*compare)(const void * elt1, const void * elt2),
3474 int pc_left, int pc_right, int u_left, int u_right)
3475{
3476 int i;
3477
3478 qsort_assert(pc_left <= pc_right);
3479 qsort_assert(u_right < pc_left);
3480 qsort_assert(pc_right < u_left);
3481 for (i = u_right + 1; i < pc_left; ++i) {
3482 qsort_assert(qsort_cmp(i, pc_left) < 0);
3483 }
3484 for (i = pc_left; i < pc_right; ++i) {
3485 qsort_assert(qsort_cmp(i, pc_right) == 0);
3486 }
3487 for (i = pc_right + 1; i < u_left; ++i) {
3488 qsort_assert(qsort_cmp(pc_right, i) < 0);
3489 }
3490}
3491
3492#define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) \
3493 doqsort_all_asserts(array, num_elts, elt_size, compare, \
3494 PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT)
3495
3496#else
3497
3498#define qsort_assert(t) ((void)0)
3499
3500#define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) ((void)0)
3501
3502#endif
3503
3504/* ****************************************************************** qsort */
3505
6cc33c6d 3506STATIC void
565764a8
DL
3507#ifdef PERL_OBJECT
3508qsortsv(SV ** array, size_t num_elts, SVCOMPARE compare)
3509#else
745d3a65
HM
3510qsortsv(
3511 SV ** array,
3512 size_t num_elts,
3513 I32 (*compare)(SV *a, SV *b))
565764a8 3514#endif
745d3a65
HM
3515{
3516 register SV * temp;
3517
3518 struct partition_stack_entry partition_stack[QSORT_MAX_STACK];
3519 int next_stack_entry = 0;
3520
3521 int part_left;
3522 int part_right;
3523#ifdef QSORT_ORDER_GUESS
3524 int qsort_break_even;
3525 int swapped;
3526#endif
161b471a 3527
745d3a65
HM
3528 /* Make sure we actually have work to do.
3529 */
3530 if (num_elts <= 1) {
3531 return;
3532 }
3533
3534 /* Setup the initial partition definition and fall into the sorting loop
3535 */
3536 part_left = 0;
3537 part_right = (int)(num_elts - 1);
3538#ifdef QSORT_ORDER_GUESS
3539 qsort_break_even = QSORT_BREAK_EVEN;
3540#else
3541#define qsort_break_even QSORT_BREAK_EVEN
3542#endif
3543 for ( ; ; ) {
3544 if ((part_right - part_left) >= qsort_break_even) {
3545 /* OK, this is gonna get hairy, so lets try to document all the
3546 concepts and abbreviations and variables and what they keep
3547 track of:
3548
3549 pc: pivot chunk - the set of array elements we accumulate in the
3550 middle of the partition, all equal in value to the original
3551 pivot element selected. The pc is defined by:
3552
3553 pc_left - the leftmost array index of the pc
3554 pc_right - the rightmost array index of the pc
3555
3556 we start with pc_left == pc_right and only one element
3557 in the pivot chunk (but it can grow during the scan).
3558
3559 u: uncompared elements - the set of elements in the partition
3560 we have not yet compared to the pivot value. There are two
3561 uncompared sets during the scan - one to the left of the pc
3562 and one to the right.
3563
3564 u_right - the rightmost index of the left side's uncompared set
3565 u_left - the leftmost index of the right side's uncompared set
3566
3567 The leftmost index of the left sides's uncompared set
3568 doesn't need its own variable because it is always defined
3569 by the leftmost edge of the whole partition (part_left). The
3570 same goes for the rightmost edge of the right partition
3571 (part_right).
3572
3573 We know there are no uncompared elements on the left once we
3574 get u_right < part_left and no uncompared elements on the
3575 right once u_left > part_right. When both these conditions
3576 are met, we have completed the scan of the partition.
3577
3578 Any elements which are between the pivot chunk and the
3579 uncompared elements should be less than the pivot value on
3580 the left side and greater than the pivot value on the right
3581 side (in fact, the goal of the whole algorithm is to arrange
3582 for that to be true and make the groups of less-than and
3583 greater-then elements into new partitions to sort again).
3584
3585 As you marvel at the complexity of the code and wonder why it
3586 has to be so confusing. Consider some of the things this level
3587 of confusion brings:
3588
3589 Once I do a compare, I squeeze every ounce of juice out of it. I
3590 never do compare calls I don't have to do, and I certainly never
3591 do redundant calls.
3592
3593 I also never swap any elements unless I can prove there is a
3594 good reason. Many sort algorithms will swap a known value with
3595 an uncompared value just to get things in the right place (or
3596 avoid complexity :-), but that uncompared value, once it gets
3597 compared, may then have to be swapped again. A lot of the
3598 complexity of this code is due to the fact that it never swaps
3599 anything except compared values, and it only swaps them when the
3600 compare shows they are out of position.
3601 */
3602 int pc_left, pc_right;
3603 int u_right, u_left;
3604
3605 int s;
3606
3607 pc_left = ((part_left + part_right) / 2);
3608 pc_right = pc_left;
3609 u_right = pc_left - 1;
3610 u_left = pc_right + 1;
3611
3612 /* Qsort works best when the pivot value is also the median value
3613 in the partition (unfortunately you can't find the median value
3614 without first sorting :-), so to give the algorithm a helping
3615 hand, we pick 3 elements and sort them and use the median value
3616 of that tiny set as the pivot value.
3617
3618 Some versions of qsort like to use the left middle and right as
3619 the 3 elements to sort so they can insure the ends of the
3620 partition will contain values which will stop the scan in the
3621 compare loop, but when you have to call an arbitrarily complex
3622 routine to do a compare, its really better to just keep track of
3623 array index values to know when you hit the edge of the
3624 partition and avoid the extra compare. An even better reason to
3625 avoid using a compare call is the fact that you can drop off the
3626 edge of the array if someone foolishly provides you with an
3627 unstable compare function that doesn't always provide consistent
3628 results.
3629
3630 So, since it is simpler for us to compare the three adjacent
3631 elements in the middle of the partition, those are the ones we
3632 pick here (conveniently pointed at by u_right, pc_left, and
3633 u_left). The values of the left, center, and right elements
3634 are refered to as l c and r in the following comments.
3635 */
3636
3637#ifdef QSORT_ORDER_GUESS
3638 swapped = 0;
3639#endif
3640 s = qsort_cmp(u_right, pc_left);
3641 if (s < 0) {
3642 /* l < c */
3643 s = qsort_cmp(pc_left, u_left);
3644 /* if l < c, c < r - already in order - nothing to do */
3645 if (s == 0) {
3646 /* l < c, c == r - already in order, pc grows */
3647 ++pc_right;
3648 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3649 } else if (s > 0) {
3650 /* l < c, c > r - need to know more */
3651 s = qsort_cmp(u_right, u_left);
3652 if (s < 0) {
3653 /* l < c, c > r, l < r - swap c & r to get ordered */
3654 qsort_swap(pc_left, u_left);
3655 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3656 } else if (s == 0) {
3657 /* l < c, c > r, l == r - swap c&r, grow pc */
3658 qsort_swap(pc_left, u_left);
3659 --pc_left;
3660 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3661 } else {
3662 /* l < c, c > r, l > r - make lcr into rlc to get ordered */
3663 qsort_rotate(pc_left, u_right, u_left);
3664 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3665 }
3666 }
3667 } else if (s == 0) {
3668 /* l == c */
3669 s = qsort_cmp(pc_left, u_left);
3670 if (s < 0) {
3671 /* l == c, c < r - already in order, grow pc */
3672 --pc_left;
3673 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3674 } else if (s == 0) {
3675 /* l == c, c == r - already in order, grow pc both ways */
3676 --pc_left;
3677 ++pc_right;
3678 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3679 } else {
3680 /* l == c, c > r - swap l & r, grow pc */
3681 qsort_swap(u_right, u_left);
3682 ++pc_right;
3683 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3684 }
3685 } else {
3686 /* l > c */
3687 s = qsort_cmp(pc_left, u_left);
3688 if (s < 0) {
3689 /* l > c, c < r - need to know more */
3690 s = qsort_cmp(u_right, u_left);
3691 if (s < 0) {
3692 /* l > c, c < r, l < r - swap l & c to get ordered */
3693 qsort_swap(u_right, pc_left);
3694 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3695 } else if (s == 0) {
3696 /* l > c, c < r, l == r - swap l & c, grow pc */
3697 qsort_swap(u_right, pc_left);
3698 ++pc_right;
3699 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3700 } else {
3701 /* l > c, c < r, l > r - rotate lcr into crl to order */
3702 qsort_rotate(u_right, pc_left, u_left);
3703 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3704 }
3705 } else if (s == 0) {
3706 /* l > c, c == r - swap ends, grow pc */
3707 qsort_swap(u_right, u_left);
3708 --pc_left;
3709 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3710 } else {
3711 /* l > c, c > r - swap ends to get in order */
3712 qsort_swap(u_right, u_left);
3713 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3714 }
3715 }
3716 /* We now know the 3 middle elements have been compared and
3717 arranged in the desired order, so we can shrink the uncompared
3718 sets on both sides
3719 */
3720 --u_right;
3721 ++u_left;
3722 qsort_all_asserts(pc_left, pc_right, u_left, u_right);
3723
3724 /* The above massive nested if was the simple part :-). We now have
3725 the middle 3 elements ordered and we need to scan through the
3726 uncompared sets on either side, swapping elements that are on
3727 the wrong side or simply shuffling equal elements around to get
3728 all equal elements into the pivot chunk.
3729 */
3730
3731 for ( ; ; ) {
3732 int still_work_on_left;
3733 int still_work_on_right;
3734
3735 /* Scan the uncompared values on the left. If I find a value
3736 equal to the pivot value, move it over so it is adjacent to
3737 the pivot chunk and expand the pivot chunk. If I find a value
3738 less than the pivot value, then just leave it - its already
3739 on the correct side of the partition. If I find a greater
3740 value, then stop the scan.
3741 */
3742 while (still_work_on_left = (u_right >= part_left)) {
3743 s = qsort_cmp(u_right, pc_left);
3744 if (s < 0) {
3745 --u_right;
3746 } else if (s == 0) {
3747 --pc_left;
3748