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