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