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
bump patchlevel to 5.005_51
[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
NIS		 359 sv = &PL_sv_no;
360 if (PL_dowarn)
a0d0e21e
LW		 361 warn("Not enough format arguments");
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];
980 switch (cx->cx_type) {
981 case CXt_SUBST:
3280af22 982 if (PL_dowarn)
533c011a 983 warn("Exiting substitution via %s", op_name[PL_op->op_type]);
a0d0e21e
LW		 984 break;
985 case CXt_SUB:
3280af22 986 if (PL_dowarn)
533c011a 987 warn("Exiting subroutine via %s", op_name[PL_op->op_type]);
a0d0e21e
LW		 988 break;
989 case CXt_EVAL:
3280af22 990 if (PL_dowarn)
533c011a 991 warn("Exiting eval via %s", op_name[PL_op->op_type]);
a0d0e21e 992 break;
0a753a76 993 case CXt_NULL:
3280af22 994 if (PL_dowarn)
533c011a 995 warn("Exiting pseudo-block via %s", op_name[PL_op->op_type]);
0a753a76 996 return -1;
a0d0e21e
LW		 997 case CXt_LOOP:
998 if (!cx->blk_loop.label ||
999 strNE(label, cx->blk_loop.label) ) {
68dc0745 1000 DEBUG_l(deb("(Skipping label #%ld %s)\n",
1001 (long)i, cx->blk_loop.label));
a0d0e21e
LW		 1002 continue;
1003 }
68dc0745 1004 DEBUG_l( deb("(Found label #%ld %s)\n", (long)i, label));
a0d0e21e
LW		 1005 return i;
1006 }
1007 }
1008 return i;
1009}
1010
e50aee73 1011I32
8ac85365 1012dowantarray(void)
e50aee73 1013{
54310121 1014 I32 gimme = block_gimme();
1015 return (gimme == G_VOID) ? G_SCALAR : gimme;
1016}
1017
1018I32
8ac85365 1019block_gimme(void)
54310121 1020{
11343788 1021 dTHR;
e50aee73
AD		 1022 I32 cxix;
1023
1024 cxix = dopoptosub(cxstack_ix);
1025 if (cxix < 0)
46fc3d4c 1026 return G_VOID;
e50aee73 1027
54310121 1028 switch (cxstack[cxix].blk_gimme) {
d2719217
GS		 1029 case G_VOID:
1030 return G_VOID;
54310121 1031 case G_SCALAR:
e50aee73 1032 return G_SCALAR;
54310121 1033 case G_ARRAY:
1034 return G_ARRAY;
1035 default:
1036 croak("panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
d2719217
GS		 1037 /* NOTREACHED */
1038 return 0;
54310121 1039 }
e50aee73
AD		 1040}
1041
76e3520e 1042STATIC I32
8ac85365 1043dopoptosub(I32 startingblock)
a0d0e21e 1044{
11343788 1045 dTHR;
2c375eb9
GS		 1046 return dopoptosub_at(cxstack, startingblock);
1047}
1048
1049STATIC I32
1050dopoptosub_at(PERL_CONTEXT *cxstk, I32 startingblock)
1051{
1052 dTHR;
a0d0e21e 1053 I32 i;
c09156bb 1054 register PERL_CONTEXT *cx;
a0d0e21e 1055 for (i = startingblock; i >= 0; i--) {
2c375eb9 1056 cx = &cxstk[i];
a0d0e21e
LW		 1057 switch (cx->cx_type) {
1058 default:
1059 continue;
1060 case CXt_EVAL:
1061 case CXt_SUB:
68dc0745 1062 DEBUG_l( deb("(Found sub #%ld)\n", (long)i));
a0d0e21e
LW		 1063 return i;
1064 }
1065 }
1066 return i;
1067}
1068
76e3520e 1069STATIC I32
8ac85365 1070dopoptoeval(I32 startingblock)
a0d0e21e 1071{
11343788 1072 dTHR;
a0d0e21e 1073 I32 i;
c09156bb 1074 register PERL_CONTEXT *cx;
a0d0e21e
LW		 1075 for (i = startingblock; i >= 0; i--) {
1076 cx = &cxstack[i];
1077 switch (cx->cx_type) {
1078 default:
1079 continue;
1080 case CXt_EVAL:
68dc0745 1081 DEBUG_l( deb("(Found eval #%ld)\n", (long)i));
a0d0e21e
LW		 1082 return i;
1083 }
1084 }
1085 return i;
1086}
1087
76e3520e 1088STATIC I32
8ac85365 1089dopoptoloop(I32 startingblock)
a0d0e21e 1090{
11343788 1091 dTHR;
a0d0e21e 1092 I32 i;
c09156bb 1093 register PERL_CONTEXT *cx;
a0d0e21e
LW		 1094 for (i = startingblock; i >= 0; i--) {
1095 cx = &cxstack[i];
1096 switch (cx->cx_type) {
1097 case CXt_SUBST:
3280af22 1098 if (PL_dowarn)
533c011a 1099 warn("Exiting substitution via %s", op_name[PL_op->op_type]);
a0d0e21e
LW		 1100 break;
1101 case CXt_SUB:
3280af22 1102 if (PL_dowarn)
533c011a 1103 warn("Exiting subroutine via %s", op_name[PL_op->op_type]);
a0d0e21e
LW		 1104 break;
1105 case CXt_EVAL:
3280af22 1106 if (PL_dowarn)
533c011a 1107 warn("Exiting eval via %s", op_name[PL_op->op_type]);
a0d0e21e 1108 break;
0a753a76 1109 case CXt_NULL:
3280af22 1110 if (PL_dowarn)
533c011a 1111 warn("Exiting pseudo-block via %s", op_name[PL_op->op_type]);
0a753a76 1112 return -1;
a0d0e21e 1113 case CXt_LOOP:
68dc0745 1114 DEBUG_l( deb("(Found loop #%ld)\n", (long)i));
a0d0e21e
LW		 1115 return i;
1116 }
1117 }
1118 return i;
1119}
1120
1121void
8ac85365 1122dounwind(I32 cxix)
a0d0e21e 1123{
11343788 1124 dTHR;
c09156bb 1125 register PERL_CONTEXT *cx;
a0d0e21e
LW		 1126 SV **newsp;
1127 I32 optype;
1128
1129 while (cxstack_ix > cxix) {
c90c0ff4 1130 cx = &cxstack[cxstack_ix];
1131 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
301d9039 1132 (long) cxstack_ix, block_type[cx->cx_type]));
a0d0e21e
LW		 1133 /* Note: we don't need to restore the base context info till the end. */
1134 switch (cx->cx_type) {
c90c0ff4 1135 case CXt_SUBST:
1136 POPSUBST(cx);
1137 continue; /* not break */
a0d0e21e
LW		 1138 case CXt_SUB:
1139 POPSUB(cx);
1140 break;
1141 case CXt_EVAL:
1142 POPEVAL(cx);
1143 break;
1144 case CXt_LOOP:
1145 POPLOOP(cx);
1146 break;
0a753a76 1147 case CXt_NULL:
a0d0e21e
LW		 1148 break;
1149 }
c90c0ff4 1150 cxstack_ix--;
a0d0e21e
LW		 1151 }
1152}
1153
a0d0e21e 1154OP *
8ac85365 1155die_where(char *message)
a0d0e21e 1156{
e336de0d 1157 dSP;
3280af22 1158 if (PL_in_eval) {
a0d0e21e 1159 I32 cxix;
c09156bb 1160 register PERL_CONTEXT *cx;
a0d0e21e
LW		 1161 I32 gimme;
1162 SV **newsp;
1163
4e6ea2c3 1164 if (message) {
3280af22 1165 if (PL_in_eval & 4) {
4e6ea2c3
GS		 1166 SV **svp;
1167 STRLEN klen = strlen(message);
1168
1169 svp = hv_fetch(ERRHV, message, klen, TRUE);
1170 if (svp) {
1171 if (!SvIOK(*svp)) {
1172 static char prefix[] = "\t(in cleanup) ";
1173 SV *err = ERRSV;
1174 sv_upgrade(*svp, SVt_IV);
1175 (void)SvIOK_only(*svp);
1176 if (!SvPOK(err))
1177 sv_setpv(err,"");
1178 SvGROW(err, SvCUR(err)+sizeof(prefix)+klen);
1179 sv_catpvn(err, prefix, sizeof(prefix)-1);
1180 sv_catpvn(err, message, klen);
1181 }
1182 sv_inc(*svp);
4633a7c4 1183 }
4633a7c4 1184 }
4e6ea2c3
GS		 1185 else
1186 sv_setpv(ERRSV, message);
4633a7c4
LW		 1187 }
1188 else
3280af22 1189 message = SvPVx(ERRSV, PL_na);
4e6ea2c3 1190
3280af22 1191 while ((cxix = dopoptoeval(cxstack_ix)) < 0 && PL_curstackinfo->si_prev) {
bac4b2ad 1192 dounwind(-1);
d3acc0f7 1193 POPSTACK;
bac4b2ad 1194 }
e336de0d 1195
a0d0e21e
LW		 1196 if (cxix >= 0) {
1197 I32 optype;
1198
1199 if (cxix < cxstack_ix)
1200 dounwind(cxix);
1201
3280af22 1202 POPBLOCK(cx,PL_curpm);
a0d0e21e 1203 if (cx->cx_type != CXt_EVAL) {
760ac839 1204 PerlIO_printf(PerlIO_stderr(), "panic: die %s", message);
a0d0e21e
LW		 1205 my_exit(1);
1206 }
1207 POPEVAL(cx);
1208
1209 if (gimme == G_SCALAR)
3280af22
NIS		 1210 *++newsp = &PL_sv_undef;
1211 PL_stack_sp = newsp;
a0d0e21e
LW		 1212
1213 LEAVE;
748a9306 1214
7a2e2cd6 1215 if (optype == OP_REQUIRE) {
3280af22 1216 char* msg = SvPVx(ERRSV, PL_na);
7a2e2cd6 1217 DIE("%s", *msg ? msg : "Compilation failed in require");
1218 }
a0d0e21e
LW		 1219 return pop_return();
1220 }
1221 }
760ac839
LW		 1222 PerlIO_printf(PerlIO_stderr(), "%s",message);
1223 PerlIO_flush(PerlIO_stderr());
f86702cc 1224 my_failure_exit();
1225 /* NOTREACHED */
a0d0e21e
LW		 1226 return 0;
1227}
1228
1229PP(pp_xor)
1230{
4e35701f 1231 djSP; dPOPTOPssrl;
a0d0e21e
LW		 1232 if (SvTRUE(left) != SvTRUE(right))
1233 RETSETYES;
1234 else
1235 RETSETNO;
1236}
1237
1238PP(pp_andassign)
1239{
4e35701f 1240 djSP;
a0d0e21e
LW		 1241 if (!SvTRUE(TOPs))
1242 RETURN;
1243 else
1244 RETURNOP(cLOGOP->op_other);
1245}
1246
1247PP(pp_orassign)
1248{
4e35701f 1249 djSP;
a0d0e21e
LW		 1250 if (SvTRUE(TOPs))
1251 RETURN;
1252 else
1253 RETURNOP(cLOGOP->op_other);
1254}
1255
a0d0e21e
LW		 1256PP(pp_caller)
1257{
4e35701f 1258 djSP;
a0d0e21e 1259 register I32 cxix = dopoptosub(cxstack_ix);
c09156bb 1260 register PERL_CONTEXT *cx;
2c375eb9 1261 register PERL_CONTEXT *ccstack = cxstack;
3280af22 1262 PERL_SI *top_si = PL_curstackinfo;
a0d0e21e 1263 I32 dbcxix;
54310121 1264 I32 gimme;
49d8d3a1 1265 HV *hv;
a0d0e21e
LW		 1266 SV *sv;
1267 I32 count = 0;
1268
1269 if (MAXARG)
1270 count = POPi;
1271 EXTEND(SP, 6);
1272 for (;;) {
2c375eb9
GS		 1273 /* we may be in a higher stacklevel, so dig down deeper */
1274 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1275 top_si = top_si->si_prev;
1276 ccstack = top_si->si_cxstack;
1277 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1278 }
a0d0e21e
LW		 1279 if (cxix < 0) {
1280 if (GIMME != G_ARRAY)
1281 RETPUSHUNDEF;
1282 RETURN;
1283 }
3280af22
NIS		 1284 if (PL_DBsub && cxix >= 0 &&
1285 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
a0d0e21e
LW		 1286 count++;
1287 if (!count--)
1288 break;
2c375eb9 1289 cxix = dopoptosub_at(ccstack, cxix - 1);
a0d0e21e 1290 }
2c375eb9
GS		 1291
1292 cx = &ccstack[cxix];
1293 if (ccstack[cxix].cx_type == CXt_SUB) {
1294 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1295 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
06a5b730 1296 field below is defined for any cx. */
3280af22 1297 if (PL_DBsub && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
2c375eb9 1298 cx = &ccstack[dbcxix];
06a5b730 1299 }
1300
a0d0e21e 1301 if (GIMME != G_ARRAY) {
49d8d3a1
MB		 1302 hv = cx->blk_oldcop->cop_stash;
1303 if (!hv)
3280af22 1304 PUSHs(&PL_sv_undef);
49d8d3a1
MB		 1305 else {
1306 dTARGET;
1307 sv_setpv(TARG, HvNAME(hv));
1308 PUSHs(TARG);
1309 }
a0d0e21e
LW		 1310 RETURN;
1311 }
a0d0e21e 1312
49d8d3a1
MB		 1313 hv = cx->blk_oldcop->cop_stash;
1314 if (!hv)
3280af22 1315 PUSHs(&PL_sv_undef);
49d8d3a1
MB		 1316 else
1317 PUSHs(sv_2mortal(newSVpv(HvNAME(hv), 0)));
a0d0e21e
LW		 1318 PUSHs(sv_2mortal(newSVpv(SvPVX(GvSV(cx->blk_oldcop->cop_filegv)), 0)));
1319 PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->cop_line)));
1320 if (!MAXARG)
1321 RETURN;
2c375eb9 1322 if (cx->cx_type == CXt_SUB) { /* So is ccstack[dbcxix]. */
a0d0e21e 1323 sv = NEWSV(49, 0);
2c375eb9 1324 gv_efullname3(sv, CvGV(ccstack[cxix].blk_sub.cv), Nullch);
a0d0e21e
LW		 1325 PUSHs(sv_2mortal(sv));
1326 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1327 }
1328 else {
1329 PUSHs(sv_2mortal(newSVpv("(eval)",0)));
1330 PUSHs(sv_2mortal(newSViv(0)));
1331 }
54310121 1332 gimme = (I32)cx->blk_gimme;
1333 if (gimme == G_VOID)
3280af22 1334 PUSHs(&PL_sv_undef);
54310121 1335 else
1336 PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
4633a7c4 1337 if (cx->cx_type == CXt_EVAL) {
06a5b730 1338 if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
4633a7c4 1339 PUSHs(cx->blk_eval.cur_text);
3280af22 1340 PUSHs(&PL_sv_no);
06a5b730 1341 }
1342 else if (cx->blk_eval.old_name) { /* Try blocks have old_name == 0. */
1343 /* Require, put the name. */
1344 PUSHs(sv_2mortal(newSVpv(cx->blk_eval.old_name, 0)));
3280af22 1345 PUSHs(&PL_sv_yes);
06a5b730 1346 }
4633a7c4
LW		 1347 }
1348 else if (cx->cx_type == CXt_SUB &&
1349 cx->blk_sub.hasargs &&
3280af22 1350 PL_curcop->cop_stash == PL_debstash)
4633a7c4 1351 {
a0d0e21e
LW		 1352 AV *ary = cx->blk_sub.argarray;
1353 int off = AvARRAY(ary) - AvALLOC(ary);
1354
3280af22 1355 if (!PL_dbargs) {
a0d0e21e 1356 GV* tmpgv;
3280af22 1357 PL_dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE,
a0d0e21e 1358 SVt_PVAV)));
a5f75d66 1359 GvMULTI_on(tmpgv);
3280af22 1360 AvREAL_off(PL_dbargs); /* XXX Should be REIFY */
a0d0e21e
LW		 1361 }
1362
3280af22
NIS		 1363 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1364 av_extend(PL_dbargs, AvFILLp(ary) + off);
1365 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1366 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
a0d0e21e
LW		 1367 }
1368 RETURN;
1369}
1370
6b6eec5b 1371STATIC I32
745d3a65 1372sortcv(SV *a, SV *b)
a0d0e21e 1373{
11343788 1374 dTHR;
3280af22
NIS		 1375 I32 oldsaveix = PL_savestack_ix;
1376 I32 oldscopeix = PL_scopestack_ix;
a0d0e21e 1377 I32 result;
3280af22
NIS		 1378 GvSV(PL_firstgv) = a;
1379 GvSV(PL_secondgv) = b;
1380 PL_stack_sp = PL_stack_base;
533c011a 1381 PL_op = PL_sortcop;
76e3520e 1382 CALLRUNOPS();
3280af22 1383 if (PL_stack_sp != PL_stack_base + 1)
a0d0e21e 1384 croak("Sort subroutine didn't return single value");
3280af22 1385 if (!SvNIOKp(*PL_stack_sp))
a0d0e21e 1386 croak("Sort subroutine didn't return a numeric value");
3280af22
NIS		 1387 result = SvIV(*PL_stack_sp);
1388 while (PL_scopestack_ix > oldscopeix) {
a0d0e21e
LW		 1389 LEAVE;
1390 }
748a9306 1391 leave_scope(oldsaveix);
a0d0e21e
LW		 1392 return result;
1393}
1394
a0d0e21e
LW		 1395PP(pp_reset)
1396{
4e35701f 1397 djSP;
a0d0e21e
LW		 1398 char *tmps;
1399
1400 if (MAXARG < 1)
1401 tmps = "";
1402 else
1403 tmps = POPp;
3280af22
NIS		 1404 sv_reset(tmps, PL_curcop->cop_stash);
1405 PUSHs(&PL_sv_yes);
a0d0e21e
LW		 1406 RETURN;
1407}
1408
1409PP(pp_lineseq)
1410{
1411 return NORMAL;
1412}
1413
1414PP(pp_dbstate)
1415{
533c011a 1416 PL_curcop = (COP*)PL_op;
a0d0e21e 1417 TAINT_NOT; /* Each statement is presumed innocent */
3280af22 1418 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
a0d0e21e
LW		 1419 FREETMPS;
1420
533c011a 1421 if (PL_op->op_private || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
a0d0e21e 1422 {
924508f0 1423 djSP;
a0d0e21e 1424 register CV *cv;
c09156bb 1425 register PERL_CONTEXT *cx;
748a9306 1426 I32 gimme = G_ARRAY;
a0d0e21e
LW		 1427 I32 hasargs;
1428 GV *gv;
1429
3280af22 1430 gv = PL_DBgv;
a0d0e21e 1431 cv = GvCV(gv);
a0d0e21e
LW		 1432 if (!cv)
1433 DIE("No DB::DB routine defined");
1434
3280af22 1435 if (CvDEPTH(cv) >= 1 && !(PL_debug & (1<<30))) /* don't do recursive DB::DB call */
a0d0e21e 1436 return NORMAL;
748a9306 1437
4633a7c4
LW		 1438 ENTER;
1439 SAVETMPS;
1440
3280af22 1441 SAVEI32(PL_debug);
55497cff 1442 SAVESTACK_POS();
3280af22 1443 PL_debug = 0;
748a9306 1444 hasargs = 0;
924508f0 1445 SPAGAIN;
748a9306 1446
533c011a 1447 push_return(PL_op->op_next);
924508f0 1448 PUSHBLOCK(cx, CXt_SUB, SP);
a0d0e21e
LW		 1449 PUSHSUB(cx);
1450 CvDEPTH(cv)++;
1451 (void)SvREFCNT_inc(cv);
3280af22
NIS		 1452 SAVESPTR(PL_curpad);
1453 PL_curpad = AvARRAY((AV*)*av_fetch(CvPADLIST(cv),1,FALSE));
a0d0e21e
LW		 1454 RETURNOP(CvSTART(cv));
1455 }
1456 else
1457 return NORMAL;
1458}
1459
1460PP(pp_scope)
1461{
1462 return NORMAL;
1463}
1464
1465PP(pp_enteriter)
1466{
4e35701f 1467 djSP; dMARK;
c09156bb 1468 register PERL_CONTEXT *cx;
54310121 1469 I32 gimme = GIMME_V;
a0d0e21e
LW		 1470 SV **svp;
1471
4633a7c4
LW		 1472 ENTER;
1473 SAVETMPS;
1474
54b9620d 1475#ifdef USE_THREADS
533c011a
NIS		 1476 if (PL_op->op_flags & OPf_SPECIAL)
1477 svp = save_threadsv(PL_op->op_targ); /* per-thread variable */
a0d0e21e 1478 else
54b9620d 1479#endif /* USE_THREADS */
533c011a
NIS		 1480 if (PL_op->op_targ) {
1481 svp = &PL_curpad[PL_op->op_targ]; /* "my" variable */
54b9620d
MB		 1482 SAVESPTR(*svp);
1483 }
1484 else {
301d9039
GS		 1485 GV *gv = (GV*)POPs;
1486 (void)save_scalar(gv);
1487 svp = &GvSV(gv); /* symbol table variable */
54b9620d 1488 }
4633a7c4 1489
a0d0e21e
LW		 1490 ENTER;
1491
1492 PUSHBLOCK(cx, CXt_LOOP, SP);
1493 PUSHLOOP(cx, svp, MARK);
533c011a 1494 if (PL_op->op_flags & OPf_STACKED) {
44a8e56a 1495 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
89ea2908
GA		 1496 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1497 dPOPss;
1498 if (SvNIOKp(sv) || !SvPOKp(sv) ||
1499 (looks_like_number(sv) && *SvPVX(sv) != '0')) {
1500 if (SvNV(sv) < IV_MIN ||
1501 SvNV((SV*)cx->blk_loop.iterary) >= IV_MAX)
1502 croak("Range iterator outside integer range");
1503 cx->blk_loop.iterix = SvIV(sv);
1504 cx->blk_loop.itermax = SvIV((SV*)cx->blk_loop.iterary);
1505 }
1506 else
1507 cx->blk_loop.iterlval = newSVsv(sv);
1508 }
1509 }
4633a7c4 1510 else {
3280af22
NIS		 1511 cx->blk_loop.iterary = PL_curstack;
1512 AvFILLp(PL_curstack) = SP - PL_stack_base;
1513 cx->blk_loop.iterix = MARK - PL_stack_base;
4633a7c4 1514 }
a0d0e21e
LW		 1515
1516 RETURN;
1517}
1518
1519PP(pp_enterloop)
1520{
4e35701f 1521 djSP;
c09156bb 1522 register PERL_CONTEXT *cx;
54310121 1523 I32 gimme = GIMME_V;
a0d0e21e
LW		 1524
1525 ENTER;
1526 SAVETMPS;
1527 ENTER;
1528
1529 PUSHBLOCK(cx, CXt_LOOP, SP);
1530 PUSHLOOP(cx, 0, SP);
1531
1532 RETURN;
1533}
1534
1535PP(pp_leaveloop)
1536{
4e35701f 1537 djSP;
c09156bb 1538 register PERL_CONTEXT *cx;
f86702cc 1539 struct block_loop cxloop;
a0d0e21e
LW		 1540 I32 gimme;
1541 SV **newsp;
1542 PMOP *newpm;
1543 SV **mark;
1544
1545 POPBLOCK(cx,newpm);
4fdae800 1546 mark = newsp;
f86702cc 1547 POPLOOP1(cx); /* Delay POPLOOP2 until stack values are safe */
1548
a1f49e72 1549 TAINT_NOT;
54310121 1550 if (gimme == G_VOID)
1551 ; /* do nothing */
1552 else if (gimme == G_SCALAR) {
1553 if (mark < SP)
1554 *++newsp = sv_mortalcopy(*SP);
1555 else
3280af22 1556 *++newsp = &PL_sv_undef;
a0d0e21e
LW		 1557 }
1558 else {
a1f49e72 1559 while (mark < SP) {
a0d0e21e 1560 *++newsp = sv_mortalcopy(*++mark);
a1f49e72
CS		 1561 TAINT_NOT; /* Each item is independent */
1562 }
a0d0e21e 1563 }
f86702cc 1564 SP = newsp;
1565 PUTBACK;
1566
1567 POPLOOP2(); /* Stack values are safe: release loop vars ... */
3280af22 1568 PL_curpm = newpm; /* ... and pop $1 et al */
f86702cc 1569
a0d0e21e
LW		 1570 LEAVE;
1571 LEAVE;
1572
f86702cc 1573 return NORMAL;
a0d0e21e
LW		 1574}
1575
1576PP(pp_return)
1577{
4e35701f 1578 djSP; dMARK;
a0d0e21e 1579 I32 cxix;
c09156bb 1580 register PERL_CONTEXT *cx;
f86702cc 1581 struct block_sub cxsub;
1582 bool popsub2 = FALSE;
a0d0e21e
LW		 1583 I32 gimme;
1584 SV **newsp;
1585 PMOP *newpm;
1586 I32 optype = 0;
1587
3280af22
NIS		 1588 if (PL_curstackinfo->si_type == PERLSI_SORT) {
1589 if (cxstack_ix == PL_sortcxix || dopoptosub(cxstack_ix) <= PL_sortcxix) {
1590 if (cxstack_ix > PL_sortcxix)
1591 dounwind(PL_sortcxix);
1592 AvARRAY(PL_curstack)[1] = *SP;
1593 PL_stack_sp = PL_stack_base + 1;
a0d0e21e
LW		 1594 return 0;
1595 }
1596 }
1597
1598 cxix = dopoptosub(cxstack_ix);
1599 if (cxix < 0)
1600 DIE("Can't return outside a subroutine");
1601 if (cxix < cxstack_ix)
1602 dounwind(cxix);
1603
1604 POPBLOCK(cx,newpm);
1605 switch (cx->cx_type) {
1606 case CXt_SUB:
f86702cc 1607 POPSUB1(cx); /* Delay POPSUB2 until stack values are safe */
1608 popsub2 = TRUE;
a0d0e21e
LW		 1609 break;
1610 case CXt_EVAL:
1611 POPEVAL(cx);
748a9306
LW		 1612 if (optype == OP_REQUIRE &&
1613 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1614 {
54310121 1615 /* Unassume the success we assumed earlier. */
748a9306 1616 char *name = cx->blk_eval.old_name;
3280af22 1617 (void)hv_delete(GvHVn(PL_incgv), name, strlen(name), G_DISCARD);
748a9306
LW		 1618 DIE("%s did not return a true value", name);
1619 }
a0d0e21e
LW		 1620 break;
1621 default:
1622 DIE("panic: return");
a0d0e21e
LW		 1623 }
1624
a1f49e72 1625 TAINT_NOT;
a0d0e21e 1626 if (gimme == G_SCALAR) {
a29cdaf0
IZ		 1627 if (MARK < SP) {
1628 if (popsub2) {
1629 if (cxsub.cv && CvDEPTH(cxsub.cv) > 1) {
1630 if (SvTEMP(TOPs)) {
1631 *++newsp = SvREFCNT_inc(*SP);
1632 FREETMPS;
1633 sv_2mortal(*newsp);
1634 } else {
1635 FREETMPS;
1636 *++newsp = sv_mortalcopy(*SP);
1637 }
1638 } else
1639 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
1640 } else
1641 *++newsp = sv_mortalcopy(*SP);
1642 } else
3280af22 1643 *++newsp = &PL_sv_undef;
a0d0e21e 1644 }
54310121 1645 else if (gimme == G_ARRAY) {
a1f49e72 1646 while (++MARK <= SP) {
f86702cc 1647 *++newsp = (popsub2 && SvTEMP(*MARK))
1648 ? *MARK : sv_mortalcopy(*MARK);
a1f49e72
CS		 1649 TAINT_NOT; /* Each item is independent */
1650 }
a0d0e21e 1651 }
3280af22 1652 PL_stack_sp = newsp;
a0d0e21e 1653
f86702cc 1654 /* Stack values are safe: */
1655 if (popsub2) {
1656 POPSUB2(); /* release CV and @_ ... */
1657 }
3280af22 1658 PL_curpm = newpm; /* ... and pop $1 et al */
f86702cc 1659
a0d0e21e
LW		 1660 LEAVE;
1661 return pop_return();
1662}
1663
1664PP(pp_last)
1665{
4e35701f 1666 djSP;
a0d0e21e 1667 I32 cxix;
c09156bb 1668 register PERL_CONTEXT *cx;
f86702cc 1669 struct block_loop cxloop;
1670 struct block_sub cxsub;
1671 I32 pop2 = 0;
a0d0e21e
LW		 1672 I32 gimme;
1673 I32 optype;
1674 OP *nextop;
1675 SV **newsp;
1676 PMOP *newpm;
3280af22 1677 SV **mark = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
a0d0e21e 1678
533c011a 1679 if (PL_op->op_flags & OPf_SPECIAL) {
a0d0e21e
LW		 1680 cxix = dopoptoloop(cxstack_ix);
1681 if (cxix < 0)
1682 DIE("Can't \"last\" outside a block");
1683 }
1684 else {
1685 cxix = dopoptolabel(cPVOP->op_pv);
1686 if (cxix < 0)
1687 DIE("Label not found for \"last %s\"", cPVOP->op_pv);
1688 }
1689 if (cxix < cxstack_ix)
1690 dounwind(cxix);
1691
1692 POPBLOCK(cx,newpm);
1693 switch (cx->cx_type) {
1694 case CXt_LOOP:
f86702cc 1695 POPLOOP1(cx); /* Delay POPLOOP2 until stack values are safe */
1696 pop2 = CXt_LOOP;
4fdae800 1697 nextop = cxloop.last_op->op_next;
a0d0e21e 1698 break;
f86702cc 1699 case CXt_SUB:
1700 POPSUB1(cx); /* Delay POPSUB2 until stack values are safe */
1701 pop2 = CXt_SUB;
a0d0e21e
LW		 1702 nextop = pop_return();
1703 break;
f86702cc 1704 case CXt_EVAL:
1705 POPEVAL(cx);
a0d0e21e
LW		 1706 nextop = pop_return();
1707 break;
1708 default:
1709 DIE("panic: last");
a0d0e21e
LW		 1710 }
1711
a1f49e72 1712 TAINT_NOT;
a0d0e21e 1713 if (gimme == G_SCALAR) {
f86702cc 1714 if (MARK < SP)
1715 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
1716 ? *SP : sv_mortalcopy(*SP);
a0d0e21e 1717 else
3280af22 1718 *++newsp = &PL_sv_undef;
a0d0e21e 1719 }
54310121 1720 else if (gimme == G_ARRAY) {
a1f49e72 1721 while (++MARK <= SP) {
f86702cc 1722 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
1723 ? *MARK : sv_mortalcopy(*MARK);
a1f49e72
CS		 1724 TAINT_NOT; /* Each item is independent */
1725 }
f86702cc 1726 }
1727 SP = newsp;
1728 PUTBACK;
1729
1730 /* Stack values are safe: */
1731 switch (pop2) {
1732 case CXt_LOOP:
1733 POPLOOP2(); /* release loop vars ... */
4fdae800 1734 LEAVE;
f86702cc 1735 break;
1736 case CXt_SUB:
1737 POPSUB2(); /* release CV and @_ ... */
1738 break;
a0d0e21e 1739 }
3280af22 1740 PL_curpm = newpm; /* ... and pop $1 et al */
a0d0e21e
LW		 1741
1742 LEAVE;
f86702cc 1743 return nextop;
a0d0e21e
LW		 1744}
1745
1746PP(pp_next)
1747{
1748 I32 cxix;
c09156bb 1749 register PERL_CONTEXT *cx;
a0d0e21e
LW		 1750 I32 oldsave;
1751
533c011a 1752 if (PL_op->op_flags & OPf_SPECIAL) {
a0d0e21e
LW		 1753 cxix = dopoptoloop(cxstack_ix);
1754 if (cxix < 0)
1755 DIE("Can't \"next\" outside a block");
1756 }
1757 else {
1758 cxix = dopoptolabel(cPVOP->op_pv);
1759 if (cxix < 0)
1760 DIE("Label not found for \"next %s\"", cPVOP->op_pv);
1761 }
1762 if (cxix < cxstack_ix)
1763 dounwind(cxix);
1764
1765 TOPBLOCK(cx);
3280af22 1766 oldsave = PL_scopestack[PL_scopestack_ix - 1];
a0d0e21e
LW		 1767 LEAVE_SCOPE(oldsave);
1768 return cx->blk_loop.next_op;
1769}
1770
1771PP(pp_redo)
1772{
1773 I32 cxix;
c09156bb 1774 register PERL_CONTEXT *cx;
a0d0e21e
LW		 1775 I32 oldsave;
1776
533c011a 1777 if (PL_op->op_flags & OPf_SPECIAL) {
a0d0e21e
LW		 1778 cxix = dopoptoloop(cxstack_ix);
1779 if (cxix < 0)
1780 DIE("Can't \"redo\" outside a block");
1781 }
1782 else {
1783 cxix = dopoptolabel(cPVOP->op_pv);
1784 if (cxix < 0)
1785 DIE("Label not found for \"redo %s\"", cPVOP->op_pv);
1786 }
1787 if (cxix < cxstack_ix)
1788 dounwind(cxix);
1789
1790 TOPBLOCK(cx);
3280af22 1791 oldsave = PL_scopestack[PL_scopestack_ix - 1];
a0d0e21e
LW		 1792 LEAVE_SCOPE(oldsave);
1793 return cx->blk_loop.redo_op;
1794}
1795
0824fdcb 1796STATIC OP *
8ac85365 1797dofindlabel(OP *o, char *label, OP **opstack, OP **oplimit)
a0d0e21e
LW		 1798{
1799 OP *kid;
1800 OP **ops = opstack;
fc36a67e 1801 static char too_deep[] = "Target of goto is too deeply nested";
a0d0e21e 1802
fc36a67e 1803 if (ops >= oplimit)
1804 croak(too_deep);
11343788
MB		 1805 if (o->op_type == OP_LEAVE ||
1806 o->op_type == OP_SCOPE ||
1807 o->op_type == OP_LEAVELOOP ||
1808 o->op_type == OP_LEAVETRY)
fc36a67e 1809 {
5dc0d613 1810 *ops++ = cUNOPo->op_first;
fc36a67e 1811 if (ops >= oplimit)
1812 croak(too_deep);
1813 }
a0d0e21e 1814 *ops = 0;
11343788 1815 if (o->op_flags & OPf_KIDS) {
5c0ca799 1816 dTHR;
a0d0e21e 1817 /* First try all the kids at this level, since that's likeliest. */
11343788 1818 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
a0d0e21e
LW		 1819 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
1820 kCOP->cop_label && strEQ(kCOP->cop_label, label))
1821 return kid;
1822 }
11343788 1823 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
3280af22 1824 if (kid == PL_lastgotoprobe)
a0d0e21e 1825 continue;
fc36a67e 1826 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
1827 (ops == opstack ||
1828 (ops[-1]->op_type != OP_NEXTSTATE &&
1829 ops[-1]->op_type != OP_DBSTATE)))
1830 *ops++ = kid;
5dc0d613 1831 if (o = dofindlabel(kid, label, ops, oplimit))
11343788 1832 return o;
a0d0e21e
LW		 1833 }
1834 }
1835 *ops = 0;
1836 return 0;
1837}
1838
1839PP(pp_dump)
1840{
1841 return pp_goto(ARGS);
1842 /*NOTREACHED*/
1843}
1844
1845PP(pp_goto)
1846{
4e35701f 1847 djSP;
a0d0e21e
LW		 1848 OP *retop = 0;
1849 I32 ix;
c09156bb 1850 register PERL_CONTEXT *cx;
fc36a67e 1851#define GOTO_DEPTH 64
1852 OP *enterops[GOTO_DEPTH];
a0d0e21e 1853 char *label;
533c011a 1854 int do_dump = (PL_op->op_type == OP_DUMP);
a0d0e21e
LW		 1855
1856 label = 0;
533c011a 1857 if (PL_op->op_flags & OPf_STACKED) {
a0d0e21e
LW		 1858 SV *sv = POPs;
1859
1860 /* This egregious kludge implements goto &subroutine */
1861 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
1862 I32 cxix;
c09156bb 1863 register PERL_CONTEXT *cx;
a0d0e21e
LW		 1864 CV* cv = (CV*)SvRV(sv);
1865 SV** mark;
1866 I32 items = 0;
1867 I32 oldsave;
1868
4aa0a1f7
AD		 1869 if (!CvROOT(cv) && !CvXSUB(cv)) {
1870 if (CvGV(cv)) {
1871 SV *tmpstr = sv_newmortal();
e5cf08de 1872 gv_efullname3(tmpstr, CvGV(cv), Nullch);
4aa0a1f7
AD		 1873 DIE("Goto undefined subroutine &%s",SvPVX(tmpstr));
1874 }
1875 DIE("Goto undefined subroutine");
1876 }
1877
a0d0e21e
LW		 1878 /* First do some returnish stuff. */
1879 cxix = dopoptosub(cxstack_ix);
1880 if (cxix < 0)
1881 DIE("Can't goto subroutine outside a subroutine");
1882 if (cxix < cxstack_ix)
1883 dounwind(cxix);
1884 TOPBLOCK(cx);
b150fb22
RH		 1885 if (cx->cx_type == CXt_EVAL && cx->blk_eval.old_op_type == OP_ENTEREVAL)
1886 DIE("Can't goto subroutine from an eval-string");
3280af22 1887 mark = PL_stack_sp;
b150fb22
RH		 1888 if (cx->cx_type == CXt_SUB &&
1889 cx->blk_sub.hasargs) { /* put @_ back onto stack */
a0d0e21e
LW		 1890 AV* av = cx->blk_sub.argarray;
1891
93965878 1892 items = AvFILLp(av) + 1;
3280af22
NIS		 1893 PL_stack_sp++;
1894 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
1895 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
1896 PL_stack_sp += items;
6d4ff0d2 1897#ifndef USE_THREADS
3280af22
NIS		 1898 SvREFCNT_dec(GvAV(PL_defgv));
1899 GvAV(PL_defgv) = cx->blk_sub.savearray;
6d4ff0d2 1900#endif /* USE_THREADS */
a0d0e21e 1901 AvREAL_off(av);
4633a7c4 1902 av_clear(av);
a0d0e21e 1903 }
1fa4e549
AD		 1904 else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */
1905 AV* av;
1906 int i;
1907#ifdef USE_THREADS
533c011a 1908 av = (AV*)PL_curpad[0];
1fa4e549 1909#else
3280af22 1910 av = GvAV(PL_defgv);
1fa4e549
AD		 1911#endif
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;
1fa4e549 1917 }
b150fb22
RH		 1918 if (cx->cx_type == CXt_SUB &&
1919 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
a0d0e21e 1920 SvREFCNT_dec(cx->blk_sub.cv);
3280af22 1921 oldsave = PL_scopestack[PL_scopestack_ix - 1];
a0d0e21e
LW		 1922 LEAVE_SCOPE(oldsave);
1923
1924 /* Now do some callish stuff. */
1925 SAVETMPS;
1926 if (CvXSUB(cv)) {
1927 if (CvOLDSTYLE(cv)) {
ecfc5424 1928 I32 (*fp3)_((int,int,int));
924508f0
GS		 1929 while (SP > mark) {
1930 SP[1] = SP[0];
1931 SP--;
a0d0e21e 1932 }
ecfc5424
AD		 1933 fp3 = (I32(*)_((int,int,int)))CvXSUB(cv);
1934 items = (*fp3)(CvXSUBANY(cv).any_i32,
3280af22 1935 mark - PL_stack_base + 1,
ecfc5424 1936 items);
3280af22 1937 SP = PL_stack_base + items;
a0d0e21e
LW		 1938 }
1939 else {
1fa4e549
AD		 1940 SV **newsp;
1941 I32 gimme;
1942
3280af22 1943 PL_stack_sp--; /* There is no cv arg. */
1fa4e549
AD		 1944 /* Push a mark for the start of arglist */
1945 PUSHMARK(mark);
1d583055 1946 (void)(*CvXSUB(cv))(cv _PERL_OBJECT_THIS);
1fa4e549 1947 /* Pop the current context like a decent sub should */
3280af22 1948 POPBLOCK(cx, PL_curpm);
1fa4e549 1949 /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
a0d0e21e
LW		 1950 }
1951 LEAVE;
1952 return pop_return();
1953 }
1954 else {
1955 AV* padlist = CvPADLIST(cv);
1956 SV** svp = AvARRAY(padlist);
b150fb22 1957 if (cx->cx_type == CXt_EVAL) {
3280af22
NIS		 1958 PL_in_eval = cx->blk_eval.old_in_eval;
1959 PL_eval_root = cx->blk_eval.old_eval_root;
b150fb22
RH		 1960 cx->cx_type = CXt_SUB;
1961 cx->blk_sub.hasargs = 0;
1962 }
a0d0e21e
LW		 1963 cx->blk_sub.cv = cv;
1964 cx->blk_sub.olddepth = CvDEPTH(cv);
1965 CvDEPTH(cv)++;
1966 if (CvDEPTH(cv) < 2)
1967 (void)SvREFCNT_inc(cv);
1968 else { /* save temporaries on recursion? */
3280af22 1969 if (CvDEPTH(cv) == 100 && PL_dowarn)
44a8e56a 1970 sub_crush_depth(cv);
93965878 1971 if (CvDEPTH(cv) > AvFILLp(padlist)) {
a0d0e21e 1972 AV *newpad = newAV();
4aa0a1f7 1973 SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
93965878 1974 I32 ix = AvFILLp((AV*)svp[1]);
a0d0e21e 1975 svp = AvARRAY(svp[0]);
748a9306 1976 for ( ;ix > 0; ix--) {
3280af22 1977 if (svp[ix] != &PL_sv_undef) {
748a9306 1978 char *name = SvPVX(svp[ix]);
5f05dabc 1979 if ((SvFLAGS(svp[ix]) & SVf_FAKE)
1980 || *name == '&')
1981 {
1982 /* outer lexical or anon code */
748a9306 1983 av_store(newpad, ix,
4aa0a1f7 1984 SvREFCNT_inc(oldpad[ix]) );
748a9306
LW		 1985 }
1986 else { /* our own lexical */
1987 if (*name == '@')
1988 av_store(newpad, ix, sv = (SV*)newAV());
1989 else if (*name == '%')
1990 av_store(newpad, ix, sv = (SV*)newHV());
1991 else
1992 av_store(newpad, ix, sv = NEWSV(0,0));
1993 SvPADMY_on(sv);
1994 }
a0d0e21e
LW		 1995 }
1996 else {
748a9306 1997 av_store(newpad, ix, sv = NEWSV(0,0));
a0d0e21e
LW		 1998 SvPADTMP_on(sv);
1999 }
2000 }
2001 if (cx->blk_sub.hasargs) {
2002 AV* av = newAV();
2003 av_extend(av, 0);
2004 av_store(newpad, 0, (SV*)av);
2005 AvFLAGS(av) = AVf_REIFY;
2006 }
2007 av_store(padlist, CvDEPTH(cv), (SV*)newpad);
93965878 2008 AvFILLp(padlist) = CvDEPTH(cv);
a0d0e21e
LW		 2009 svp = AvARRAY(padlist);
2010 }
2011 }
6d4ff0d2
MB		 2012#ifdef USE_THREADS
2013 if (!cx->blk_sub.hasargs) {
533c011a 2014 AV* av = (AV*)PL_curpad[0];
6d4ff0d2 2015
93965878 2016 items = AvFILLp(av) + 1;
6d4ff0d2
MB		 2017 if (items) {
2018 /* Mark is at the end of the stack. */
924508f0
GS		 2019 EXTEND(SP, items);
2020 Copy(AvARRAY(av), SP + 1, items, SV*);
2021 SP += items;
6d4ff0d2
MB		 2022 PUTBACK ;
2023 }
2024 }
2025#endif /* USE_THREADS */
3280af22
NIS		 2026 SAVESPTR(PL_curpad);
2027 PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
6d4ff0d2
MB		 2028#ifndef USE_THREADS
2029 if (cx->blk_sub.hasargs)
2030#endif /* USE_THREADS */
2031 {
3280af22 2032 AV* av = (AV*)PL_curpad[0];
a0d0e21e
LW		 2033 SV** ary;
2034
6d4ff0d2 2035#ifndef USE_THREADS
3280af22
NIS		 2036 cx->blk_sub.savearray = GvAV(PL_defgv);
2037 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
6d4ff0d2
MB		 2038#endif /* USE_THREADS */
2039 cx->blk_sub.argarray = av;
a0d0e21e
LW		 2040 ++mark;
2041
2042 if (items >= AvMAX(av) + 1) {
2043 ary = AvALLOC(av);
2044 if (AvARRAY(av) != ary) {
2045 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2046 SvPVX(av) = (char*)ary;
2047 }
2048 if (items >= AvMAX(av) + 1) {
2049 AvMAX(av) = items - 1;
2050 Renew(ary,items+1,SV*);
2051 AvALLOC(av) = ary;
2052 SvPVX(av) = (char*)ary;
2053 }
2054 }
2055 Copy(mark,AvARRAY(av),items,SV*);
93965878 2056 AvFILLp(av) = items - 1;
a0d0e21e
LW		 2057
2058 while (items--) {
2059 if (*mark)
2060 SvTEMP_off(*mark);
2061 mark++;
2062 }
2063 }
491527d0 2064 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
44a8e56a 2065 /*
2066 * We do not care about using sv to call CV;
2067 * it's for informational purposes only.
2068 */
3280af22 2069 SV *sv = GvSV(PL_DBsub);
491527d0
GS		 2070 CV *gotocv;
2071
2072 if (PERLDB_SUB_NN) {
2073 SvIVX(sv) = (IV)cv; /* Already upgraded, saved */
2074 } else {
2075 save_item(sv);
2076 gv_efullname3(sv, CvGV(cv), Nullch);
2077 }
2078 if ( PERLDB_GOTO
2079 && (gotocv = perl_get_cv("DB::goto", FALSE)) ) {
3280af22 2080 PUSHMARK( PL_stack_sp );
491527d0 2081 perl_call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
3280af22 2082 PL_stack_sp--;
491527d0 2083 }
1ce6579f 2084 }
a0d0e21e
LW		 2085 RETURNOP(CvSTART(cv));
2086 }
2087 }
2088 else
3280af22 2089 label = SvPV(sv,PL_na);
a0d0e21e 2090 }
533c011a 2091 else if (PL_op->op_flags & OPf_SPECIAL) {
a0d0e21e
LW		 2092 if (! do_dump)
2093 DIE("goto must have label");
2094 }
2095 else
2096 label = cPVOP->op_pv;
2097
2098 if (label && *label) {
2099 OP *gotoprobe = 0;
2100
2101 /* find label */
2102
3280af22 2103 PL_lastgotoprobe = 0;
a0d0e21e
LW		 2104 *enterops = 0;
2105 for (ix = cxstack_ix; ix >= 0; ix--) {
2106 cx = &cxstack[ix];
2107 switch (cx->cx_type) {
a0d0e21e 2108 case CXt_EVAL:
3280af22 2109 gotoprobe = PL_eval_root; /* XXX not good for nested eval */
a0d0e21e
LW		 2110 break;
2111 case CXt_LOOP:
2112 gotoprobe = cx->blk_oldcop->op_sibling;
2113 break;
2114 case CXt_SUBST:
2115 continue;
2116 case CXt_BLOCK:
2117 if (ix)
2118 gotoprobe = cx->blk_oldcop->op_sibling;
2119 else
3280af22 2120 gotoprobe = PL_main_root;
a0d0e21e 2121 break;
b3933176
CS		 2122 case CXt_SUB:
2123 if (CvDEPTH(cx->blk_sub.cv)) {
2124 gotoprobe = CvROOT(cx->blk_sub.cv);
2125 break;
2126 }
2127 /* FALL THROUGH */
0a753a76 2128 case CXt_NULL:
2129 DIE("Can't \"goto\" outside a block");
a0d0e21e
LW		 2130 default:
2131 if (ix)
2132 DIE("panic: goto");
3280af22 2133 gotoprobe = PL_main_root;
a0d0e21e
LW		 2134 break;
2135 }
fc36a67e 2136 retop = dofindlabel(gotoprobe, label,
2137 enterops, enterops + GOTO_DEPTH);
a0d0e21e
LW		 2138 if (retop)
2139 break;
3280af22 2140 PL_lastgotoprobe = gotoprobe;
a0d0e21e
LW		 2141 }
2142 if (!retop)
2143 DIE("Can't find label %s", label);
2144
2145 /* pop unwanted frames */
2146
2147 if (ix < cxstack_ix) {
2148 I32 oldsave;
2149
2150 if (ix < 0)
2151 ix = 0;
2152 dounwind(ix);
2153 TOPBLOCK(cx);
3280af22 2154 oldsave = PL_scopestack[PL_scopestack_ix];
a0d0e21e
LW		 2155 LEAVE_SCOPE(oldsave);
2156 }
2157
2158 /* push wanted frames */
2159
748a9306 2160 if (*enterops && enterops[1]) {
533c011a 2161 OP *oldop = PL_op;
748a9306 2162 for (ix = 1; enterops[ix]; ix++) {
533c011a 2163 PL_op = enterops[ix];
84902520
TB		 2164 /* Eventually we may want to stack the needed arguments
2165 * for each op. For now, we punt on the hard ones. */
533c011a 2166 if (PL_op->op_type == OP_ENTERITER)
84902520
TB		 2167 DIE("Can't \"goto\" into the middle of a foreach loop",
2168 label);
0824fdcb 2169 (CALLOP->op_ppaddr)(ARGS);
a0d0e21e 2170 }
533c011a 2171 PL_op = oldop;
a0d0e21e
LW		 2172 }
2173 }
2174
2175 if (do_dump) {
a5f75d66 2176#ifdef VMS
6b88bc9c 2177 if (!retop) retop = PL_main_start;
a5f75d66 2178#endif
3280af22
NIS		 2179 PL_restartop = retop;
2180 PL_do_undump = TRUE;
a0d0e21e
LW		 2181
2182 my_unexec();
2183
3280af22
NIS		 2184 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2185 PL_do_undump = FALSE;
a0d0e21e
LW		 2186 }
2187
3280af22
NIS		 2188 if (PL_top_env->je_prev) {
2189 PL_restartop = retop;
6224f72b 2190 JMPENV_JUMP(3);
748a9306
LW		 2191 }
2192
a0d0e21e
LW		 2193 RETURNOP(retop);
2194}
2195
2196PP(pp_exit)
2197{
4e35701f 2198 djSP;
a0d0e21e
LW		 2199 I32 anum;
2200
2201 if (MAXARG < 1)
2202 anum = 0;
ff0cee69 2203 else {
a0d0e21e 2204 anum = SvIVx(POPs);
ff0cee69 2205#ifdef VMSISH_EXIT
2206 if (anum == 1 && VMSISH_EXIT)
2207 anum = 0;
2208#endif
2209 }
a0d0e21e 2210 my_exit(anum);
3280af22 2211 PUSHs(&PL_sv_undef);
a0d0e21e
LW		 2212 RETURN;
2213}
2214
2215#ifdef NOTYET
2216PP(pp_nswitch)
2217{
4e35701f 2218 djSP;
a0d0e21e
LW		 2219 double value = SvNVx(GvSV(cCOP->cop_gv));
2220 register I32 match = I_32(value);
2221
2222 if (value < 0.0) {
2223 if (((double)match) > value)
2224 --match; /* was fractional--truncate other way */
2225 }
2226 match -= cCOP->uop.scop.scop_offset;
2227 if (match < 0)
2228 match = 0;
2229 else if (match > cCOP->uop.scop.scop_max)
2230 match = cCOP->uop.scop.scop_max;
6b88bc9c
GS		 2231 PL_op = cCOP->uop.scop.scop_next[match];
2232 RETURNOP(PL_op);
a0d0e21e
LW		 2233}
2234
2235PP(pp_cswitch)
2236{
4e35701f 2237 djSP;
a0d0e21e
LW		 2238 register I32 match;
2239
6b88bc9c
GS		 2240 if (PL_multiline)
2241 PL_op = PL_op->op_next; /* can't assume anything */
a0d0e21e 2242 else {
6b88bc9c 2243 match = *(SvPVx(GvSV(cCOP->cop_gv), PL_na)) & 255;
a0d0e21e
LW		 2244 match -= cCOP->uop.scop.scop_offset;
2245 if (match < 0)
2246 match = 0;
2247 else if (match > cCOP->uop.scop.scop_max)
2248 match = cCOP->uop.scop.scop_max;
6b88bc9c 2249 PL_op = cCOP->uop.scop.scop_next[match];
a0d0e21e 2250 }
6b88bc9c 2251 RETURNOP(PL_op);
a0d0e21e
LW		 2252}
2253#endif
2254
2255/* Eval. */
2256
0824fdcb 2257STATIC void
8ac85365 2258save_lines(AV *array, SV *sv)
a0d0e21e
LW		 2259{
2260 register char *s = SvPVX(sv);
2261 register char *send = SvPVX(sv) + SvCUR(sv);
2262 register char *t;
2263 register I32 line = 1;
2264
2265 while (s && s < send) {
2266 SV *tmpstr = NEWSV(85,0);
2267
2268 sv_upgrade(tmpstr, SVt_PVMG);
2269 t = strchr(s, '\n');
2270 if (t)
2271 t++;
2272 else
2273 t = send;
2274
2275 sv_setpvn(tmpstr, s, t - s);
2276 av_store(array, line++, tmpstr);
2277 s = t;
2278 }
2279}
2280
0824fdcb 2281STATIC OP *
8ac85365 2282docatch(OP *o)
1e422769 2283{
e858de61 2284 dTHR;
6224f72b 2285 int ret;
533c011a 2286 OP *oldop = PL_op;
54310121 2287 dJMPENV;
1e422769 2288
533c011a 2289 PL_op = o;
1e422769 2290#ifdef DEBUGGING
54310121 2291 assert(CATCH_GET == TRUE);
3280af22 2292 DEBUG_l(deb("Setting up local jumplevel %p, was %p\n", &cur_env, PL_top_env));
1e422769 2293#endif
6224f72b
GS		 2294 JMPENV_PUSH(ret);
2295 switch (ret) {
1e422769 2296 default: /* topmost level handles it */
54310121 2297 JMPENV_POP;
533c011a 2298 PL_op = oldop;
6224f72b 2299 JMPENV_JUMP(ret);
1e422769 2300 /* NOTREACHED */
6224f72b 2301 case 3:
3280af22 2302 if (!PL_restartop) {
1e422769 2303 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
2304 break;
2305 }
533c011a 2306 PL_op = PL_restartop;
3280af22 2307 PL_restartop = 0;
1e422769 2308 /* FALL THROUGH */
6224f72b 2309 case 0:
0824fdcb 2310 CALLRUNOPS();
1e422769 2311 break;
2312 }
54310121 2313 JMPENV_POP;
533c011a 2314 PL_op = oldop;
1e422769 2315 return Nullop;
2316}
2317
c277df42
IZ		 2318OP *
2319sv_compile_2op(SV *sv, OP** startop, char *code, AV** avp)
2320/* sv Text to convert to OP tree. */
2321/* startop op_free() this to undo. */
2322/* code Short string id of the caller. */
2323{
2324 dSP; /* Make POPBLOCK work. */
2325 PERL_CONTEXT *cx;
2326 SV **newsp;
f987c7de 2327 I32 gimme = 0; /* SUSPECT - INITIALZE TO WHAT? NI-S */
c277df42
IZ		 2328 I32 optype;
2329 OP dummy;
533c011a 2330 OP *oop = PL_op, *rop;
c277df42
IZ		 2331 char tmpbuf[TYPE_DIGITS(long) + 12 + 10];
2332 char *safestr;
2333
2334 ENTER;
2335 lex_start(sv);
2336 SAVETMPS;
2337 /* switch to eval mode */
2338
cbce877f
IZ		 2339 if (PL_curcop == &PL_compiling) {
2340 SAVESPTR(PL_compiling.cop_stash);
2341 PL_compiling.cop_stash = PL_curstash;
2342 }
3280af22
NIS		 2343 SAVESPTR(PL_compiling.cop_filegv);
2344 SAVEI16(PL_compiling.cop_line);
2345 sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2346 PL_compiling.cop_filegv = gv_fetchfile(tmpbuf+2);
2347 PL_compiling.cop_line = 1;
c277df42
IZ		 2348 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2349 deleting the eval's FILEGV from the stash before gv_check() runs
2350 (i.e. before run-time proper). To work around the coredump that
2351 ensues, we always turn GvMULTI_on for any globals that were
2352 introduced within evals. See force_ident(). GSAR 96-10-12 */
2353 safestr = savepv(tmpbuf);
3280af22 2354 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
b3ac6de7 2355 SAVEHINTS();
d1ca3daa 2356#ifdef OP_IN_REGISTER
6b88bc9c 2357 PL_opsave = op;
d1ca3daa 2358#else
533c011a 2359 SAVEPPTR(PL_op);
d1ca3daa 2360#endif
3280af22 2361 PL_hints = 0;
c277df42 2362
533c011a
NIS		 2363 PL_op = &dummy;
2364 PL_op->op_type = 0; /* Avoid uninit warning. */
2365 PL_op->op_flags = 0; /* Avoid uninit warning. */
c277df42 2366 PUSHBLOCK(cx, CXt_EVAL, SP);
6b88bc9c 2367 PUSHEVAL(cx, 0, PL_compiling.cop_filegv);
c277df42 2368 rop = doeval(G_SCALAR, startop);
3280af22 2369 POPBLOCK(cx,PL_curpm);
c277df42
IZ		 2370 POPEVAL(cx);
2371
2372 (*startop)->op_type = OP_NULL;
2373 (*startop)->op_ppaddr = ppaddr[OP_NULL];
2374 lex_end();
3280af22 2375 *avp = (AV*)SvREFCNT_inc(PL_comppad);
c277df42 2376 LEAVE;
a0ed51b3
LW		 2377 if (curcop = &PL_compiling)
2378 PL_compiling.op_private = PL_hints;
d1ca3daa 2379#ifdef OP_IN_REGISTER
6b88bc9c 2380 op = PL_opsave;
d1ca3daa 2381#endif
c277df42
IZ		 2382 return rop;
2383}
2384
0f15f207 2385/* With USE_THREADS, eval_owner must be held on entry to doeval */
0824fdcb 2386STATIC OP *
c277df42 2387doeval(int gimme, OP** startop)
a0d0e21e
LW		 2388{
2389 dSP;
533c011a 2390 OP *saveop = PL_op;
a0d0e21e 2391 HV *newstash;
ff3ff8d1 2392 CV *caller;
748a9306 2393 AV* comppadlist;
67a38de0 2394 I32 i;
a0d0e21e 2395
3280af22 2396 PL_in_eval = 1;
a0d0e21e 2397
1ce6579f 2398 PUSHMARK(SP);
2399
a0d0e21e
LW		 2400 /* set up a scratch pad */
2401
3280af22
NIS		 2402 SAVEI32(PL_padix);
2403 SAVESPTR(PL_curpad);
2404 SAVESPTR(PL_comppad);
2405 SAVESPTR(PL_comppad_name);
2406 SAVEI32(PL_comppad_name_fill);
2407 SAVEI32(PL_min_intro_pending);
2408 SAVEI32(PL_max_intro_pending);
748a9306 2409
3280af22 2410 caller = PL_compcv;
bd28dd3c 2411 for (i = cxstack_ix; i >= 0; i--) {
67a38de0
NIS		 2412 PERL_CONTEXT *cx = &cxstack[i];
2413 if (cx->cx_type == CXt_EVAL)
2414 break;
2415 else if (cx->cx_type == CXt_SUB) {
2416 caller = cx->blk_sub.cv;
2417 break;
2418 }
2419 }
2420
3280af22
NIS		 2421 SAVESPTR(PL_compcv);
2422 PL_compcv = (CV*)NEWSV(1104,0);
2423 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2424 CvUNIQUE_on(PL_compcv);
11343788 2425#ifdef USE_THREADS
533c011a
NIS		 2426 CvOWNER(PL_compcv) = 0;
2427 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
2428 MUTEX_INIT(CvMUTEXP(PL_compcv));
11343788 2429#endif /* USE_THREADS */
748a9306 2430
3280af22
NIS		 2431 PL_comppad = newAV();
2432 av_push(PL_comppad, Nullsv);
2433 PL_curpad = AvARRAY(PL_comppad);
2434 PL_comppad_name = newAV();
2435 PL_comppad_name_fill = 0;
2436 PL_min_intro_pending = 0;
2437 PL_padix = 0;
11343788 2438#ifdef USE_THREADS
533c011a
NIS		 2439 av_store(PL_comppad_name, 0, newSVpv("@_", 2));
2440 PL_curpad[0] = (SV*)newAV();
2441 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
11343788 2442#endif /* USE_THREADS */
a0d0e21e 2443
748a9306
LW		 2444 comppadlist = newAV();
2445 AvREAL_off(comppadlist);
3280af22
NIS		 2446 av_store(comppadlist, 0, (SV*)PL_comppad_name);
2447 av_store(comppadlist, 1, (SV*)PL_comppad);
2448 CvPADLIST(PL_compcv) = comppadlist;
2c05e328 2449
c277df42 2450 if (!saveop || saveop->op_type != OP_REQUIRE)
3280af22 2451 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(caller);
07055b4c 2452
3280af22 2453 SAVEFREESV(PL_compcv);
748a9306 2454
a0d0e21e
LW		 2455 /* make sure we compile in the right package */
2456
3280af22
NIS		 2457 newstash = PL_curcop->cop_stash;
2458 if (PL_curstash != newstash) {
2459 SAVESPTR(PL_curstash);
2460 PL_curstash = newstash;
a0d0e21e 2461 }
3280af22
NIS		 2462 SAVESPTR(PL_beginav);
2463 PL_beginav = newAV();
2464 SAVEFREESV(PL_beginav);
a0d0e21e
LW		 2465
2466 /* try to compile it */
2467
3280af22
NIS		 2468 PL_eval_root = Nullop;
2469 PL_error_count = 0;
2470 PL_curcop = &PL_compiling;
2471 PL_curcop->cop_arybase = 0;
2472 SvREFCNT_dec(PL_rs);
2473 PL_rs = newSVpv("\n", 1);
c277df42 2474 if (saveop && saveop->op_flags & OPf_SPECIAL)
3280af22 2475 PL_in_eval |= 4;
1ce6579f 2476 else
38a03e6e 2477 sv_setpv(ERRSV,"");
3280af22 2478 if (yyparse() || PL_error_count || !PL_eval_root) {
a0d0e21e
LW		 2479 SV **newsp;
2480 I32 gimme;
c09156bb 2481 PERL_CONTEXT *cx;
c277df42 2482 I32 optype = 0; /* Might be reset by POPEVAL. */
a0d0e21e 2483
533c011a 2484 PL_op = saveop;
3280af22
NIS		 2485 if (PL_eval_root) {
2486 op_free(PL_eval_root);
2487 PL_eval_root = Nullop;
a0d0e21e 2488 }
3280af22 2489 SP = PL_stack_base + POPMARK; /* pop original mark */
c277df42 2490 if (!startop) {
3280af22 2491 POPBLOCK(cx,PL_curpm);
c277df42
IZ		 2492 POPEVAL(cx);
2493 pop_return();
2494 }
a0d0e21e
LW		 2495 lex_end();
2496 LEAVE;
7a2e2cd6 2497 if (optype == OP_REQUIRE) {
3280af22 2498 char* msg = SvPVx(ERRSV, PL_na);
7a2e2cd6 2499 DIE("%s", *msg ? msg : "Compilation failed in require");
c277df42 2500 } else if (startop) {
3280af22 2501 char* msg = SvPVx(ERRSV, PL_na);
c277df42 2502
3280af22 2503 POPBLOCK(cx,PL_curpm);
c277df42
IZ		 2504 POPEVAL(cx);
2505 croak("%sCompilation failed in regexp", (*msg ? msg : "Unknown error\n"));
7a2e2cd6 2506 }
3280af22
NIS		 2507 SvREFCNT_dec(PL_rs);
2508 PL_rs = SvREFCNT_inc(PL_nrs);
f2134d95 2509#ifdef USE_THREADS
533c011a
NIS		 2510 MUTEX_LOCK(&PL_eval_mutex);
2511 PL_eval_owner = 0;
2512 COND_SIGNAL(&PL_eval_cond);
2513 MUTEX_UNLOCK(&PL_eval_mutex);
f2134d95 2514#endif /* USE_THREADS */
a0d0e21e
LW		 2515 RETPUSHUNDEF;
2516 }
3280af22
NIS		 2517 SvREFCNT_dec(PL_rs);
2518 PL_rs = SvREFCNT_inc(PL_nrs);
2519 PL_compiling.cop_line = 0;
c277df42 2520 if (startop) {
3280af22
NIS		 2521 *startop = PL_eval_root;
2522 SvREFCNT_dec(CvOUTSIDE(PL_compcv));
2523 CvOUTSIDE(PL_compcv) = Nullcv;
c277df42 2524 } else
3280af22 2525 SAVEFREEOP(PL_eval_root);
54310121 2526 if (gimme & G_VOID)
3280af22 2527 scalarvoid(PL_eval_root);
54310121 2528 else if (gimme & G_ARRAY)
3280af22 2529 list(PL_eval_root);
a0d0e21e 2530 else
3280af22 2531 scalar(PL_eval_root);
a0d0e21e
LW		 2532
2533 DEBUG_x(dump_eval());
2534
55497cff 2535 /* Register with debugger: */
84902520 2536 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
55497cff 2537 CV *cv = perl_get_cv("DB::postponed", FALSE);
55497cff 2538 if (cv) {
2539 dSP;
924508f0 2540 PUSHMARK(SP);
3280af22 2541 XPUSHs((SV*)PL_compiling.cop_filegv);
55497cff 2542 PUTBACK;
2543 perl_call_sv((SV*)cv, G_DISCARD);
2544 }
2545 }
2546
a0d0e21e
LW		 2547 /* compiled okay, so do it */
2548
3280af22
NIS		 2549 CvDEPTH(PL_compcv) = 1;
2550 SP = PL_stack_base + POPMARK; /* pop original mark */
533c011a 2551 PL_op = saveop; /* The caller may need it. */
b35b2403 2552#ifdef USE_THREADS
533c011a
NIS		 2553 MUTEX_LOCK(&PL_eval_mutex);
2554 PL_eval_owner = 0;
2555 COND_SIGNAL(&PL_eval_cond);
2556 MUTEX_UNLOCK(&PL_eval_mutex);
b35b2403 2557#endif /* USE_THREADS */
5dc0d613 2558
3280af22 2559 RETURNOP(PL_eval_start);
a0d0e21e
LW		 2560}
2561
2562PP(pp_require)
2563{
4e35701f 2564 djSP;
c09156bb 2565 register PERL_CONTEXT *cx;
a0d0e21e
LW		 2566 SV *sv;
2567 char *name;
6132ea6c 2568 STRLEN len;
46fc3d4c 2569 char *tryname;
2570 SV *namesv = Nullsv;
a0d0e21e
LW		 2571 SV** svp;
2572 I32 gimme = G_SCALAR;
760ac839 2573 PerlIO *tryrsfp = 0;
a0d0e21e
LW		 2574
2575 sv = POPs;
4633a7c4 2576 if (SvNIOKp(sv) && !SvPOKp(sv)) {
36477c24 2577 SET_NUMERIC_STANDARD();
3280af22 2578 if (atof(PL_patchlevel) + 0.00000999 < SvNV(sv))
a5f75d66 2579 DIE("Perl %s required--this is only version %s, stopped",
3280af22 2580 SvPV(sv,PL_na),PL_patchlevel);
a0d0e21e
LW		 2581 RETPUSHYES;
2582 }
6132ea6c
GS		 2583 name = SvPV(sv, len);
2584 if (!(name && len > 0 && *name))
a0d0e21e 2585 DIE("Null filename used");
4633a7c4 2586 TAINT_PROPER("require");
533c011a 2587 if (PL_op->op_type == OP_REQUIRE &&
3280af22
NIS		 2588 (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0)) &&
2589 *svp != &PL_sv_undef)
a0d0e21e
LW		 2590 RETPUSHYES;
2591
2592 /* prepare to compile file */
2593
46fc3d4c 2594 if (*name == '/' ||
2595 (*name == '.' &&
2596 (name[1] == '/' ||
2597 (name[1] == '.' && name[2] == '/')))
4633a7c4 2598#ifdef DOSISH
46fc3d4c 2599 || (name[0] && name[1] == ':')
4633a7c4 2600#endif
ba42ef2f
WJ		 2601#ifdef WIN32
2602 || (name[0] == '\\' && name[1] == '\\') /* UNC path */
2603#endif
748a9306 2604#ifdef VMS
46fc3d4c 2605 || (strchr(name,':') || ((*name == '[' || *name == '<') &&
2606 (isALNUM(name[1]) || strchr("$-_]>",name[1]))))
748a9306
LW		 2607#endif
2608 )
a0d0e21e 2609 {
46fc3d4c 2610 tryname = name;
a868473f 2611 tryrsfp = PerlIO_open(name,PERL_SCRIPT_MODE);
a0d0e21e
LW		 2612 }
2613 else {
3280af22 2614 AV *ar = GvAVn(PL_incgv);
a0d0e21e 2615 I32 i;
748a9306 2616#ifdef VMS
46fc3d4c 2617 char *unixname;
2618 if ((unixname = tounixspec(name, Nullch)) != Nullch)
2619#endif
2620 {
2621 namesv = NEWSV(806, 0);
2622 for (i = 0; i <= AvFILL(ar); i++) {
3280af22 2623 char *dir = SvPVx(*av_fetch(ar, i, TRUE), PL_na);
46fc3d4c 2624#ifdef VMS
2625 char *unixdir;
2626 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
2627 continue;
2628 sv_setpv(namesv, unixdir);
2629 sv_catpv(namesv, unixname);
748a9306 2630#else
46fc3d4c 2631 sv_setpvf(namesv, "%s/%s", dir, name);
748a9306 2632#endif
46fc3d4c 2633 tryname = SvPVX(namesv);
a868473f 2634 tryrsfp = PerlIO_open(tryname, PERL_SCRIPT_MODE);
46fc3d4c 2635 if (tryrsfp) {
2636 if (tryname[0] == '.' && tryname[1] == '/')
2637 tryname += 2;
2638 break;
2639 }
a0d0e21e
LW		 2640 }
2641 }
2642 }
3280af22
NIS		 2643 SAVESPTR(PL_compiling.cop_filegv);
2644 PL_compiling.cop_filegv = gv_fetchfile(tryrsfp ? tryname : name);
46fc3d4c 2645 SvREFCNT_dec(namesv);
a0d0e21e 2646 if (!tryrsfp) {
533c011a 2647 if (PL_op->op_type == OP_REQUIRE) {
cca87523 2648 SV *msg = sv_2mortal(newSVpvf("Can't locate %s in @INC", name));
2683423c 2649 SV *dirmsgsv = NEWSV(0, 0);
3280af22 2650 AV *ar = GvAVn(PL_incgv);
2683423c 2651 I32 i;
46fc3d4c 2652 if (instr(SvPVX(msg), ".h "))
2653 sv_catpv(msg, " (change .h to .ph maybe?)");
2654 if (instr(SvPVX(msg), ".ph "))
2655 sv_catpv(msg, " (did you run h2ph?)");
3e3baf6d 2656 sv_catpv(msg, " (@INC contains:");
2683423c 2657 for (i = 0; i <= AvFILL(ar); i++) {
3280af22 2658 char *dir = SvPVx(*av_fetch(ar, i, TRUE), PL_na);
3e3baf6d 2659 sv_setpvf(dirmsgsv, " %s", dir);
2683423c
JA		 2660 sv_catsv(msg, dirmsgsv);
2661 }
3e3baf6d 2662 sv_catpvn(msg, ")", 1);
2683423c 2663 SvREFCNT_dec(dirmsgsv);
fc36a67e 2664 DIE("%_", msg);
a0d0e21e
LW		 2665 }
2666
2667 RETPUSHUNDEF;
2668 }
2669
2670 /* Assume success here to prevent recursive requirement. */
3280af22
NIS		 2671 (void)hv_store(GvHVn(PL_incgv), name, strlen(name),
2672 newSVsv(GvSV(PL_compiling.cop_filegv)), 0 );
a0d0e21e
LW		 2673
2674 ENTER;
2675 SAVETMPS;
2676 lex_start(sv_2mortal(newSVpv("",0)));
3280af22
NIS		 2677 if (PL_rsfp_filters){
2678 save_aptr(&PL_rsfp_filters);
2679 PL_rsfp_filters = NULL;
e50aee73
AD		 2680 }
2681
3280af22 2682 PL_rsfp = tryrsfp;
a0d0e21e
LW		 2683 name = savepv(name);
2684 SAVEFREEPV(name);
b3ac6de7 2685 SAVEHINTS();
3280af22 2686 PL_hints = 0;
a0d0e21e
LW		 2687
2688 /* switch to eval mode */
2689
533c011a 2690 push_return(PL_op->op_next);
a0d0e21e 2691 PUSHBLOCK(cx, CXt_EVAL, SP);
6b88bc9c 2692 PUSHEVAL(cx, name, PL_compiling.cop_filegv);
a0d0e21e 2693
3280af22 2694 PL_compiling.cop_line = 0;
a0d0e21e
LW		 2695
2696 PUTBACK;
0f15f207 2697#ifdef USE_THREADS
533c011a
NIS		 2698 MUTEX_LOCK(&PL_eval_mutex);
2699 if (PL_eval_owner && PL_eval_owner != thr)
2700 while (PL_eval_owner)
2701 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
2702 PL_eval_owner = thr;
2703 MUTEX_UNLOCK(&PL_eval_mutex);
0f15f207 2704#endif /* USE_THREADS */
c277df42 2705 return DOCATCH(doeval(G_SCALAR, NULL));
a0d0e21e
LW		 2706}
2707
2708PP(pp_dofile)
2709{
2710 return pp_require(ARGS);
2711}
2712
2713PP(pp_entereval)
2714{
4e35701f 2715 djSP;
c09156bb 2716 register PERL_CONTEXT *cx;
a0d0e21e 2717 dPOPss;
3280af22 2718 I32 gimme = GIMME_V, was = PL_sub_generation;
fc36a67e 2719 char tmpbuf[TYPE_DIGITS(long) + 12];
2720 char *safestr;
a0d0e21e 2721 STRLEN len;
55497cff 2722 OP *ret;
a0d0e21e
LW		 2723
2724 if (!SvPV(sv,len) || !len)
2725 RETPUSHUNDEF;
748a9306 2726 TAINT_PROPER("eval");
a0d0e21e
LW		 2727
2728 ENTER;
a0d0e21e 2729 lex_start(sv);
748a9306 2730 SAVETMPS;
a0d0e21e
LW		 2731
2732 /* switch to eval mode */
2733
3280af22
NIS		 2734 SAVESPTR(PL_compiling.cop_filegv);
2735 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
2736 PL_compiling.cop_filegv = gv_fetchfile(tmpbuf+2);
2737 PL_compiling.cop_line = 1;
55497cff 2738 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2739 deleting the eval's FILEGV from the stash before gv_check() runs
2740 (i.e. before run-time proper). To work around the coredump that
2741 ensues, we always turn GvMULTI_on for any globals that were
2742 introduced within evals. See force_ident(). GSAR 96-10-12 */
2743 safestr = savepv(tmpbuf);
3280af22 2744 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
b3ac6de7 2745 SAVEHINTS();
533c011a 2746 PL_hints = PL_op->op_targ;
a0d0e21e 2747
533c011a 2748 push_return(PL_op->op_next);
a0d0e21e 2749 PUSHBLOCK(cx, CXt_EVAL, SP);
6b88bc9c 2750 PUSHEVAL(cx, 0, PL_compiling.cop_filegv);
a0d0e21e
LW		 2751
2752 /* prepare to compile string */
2753
3280af22
NIS		 2754 if (PERLDB_LINE && PL_curstash != PL_debstash)
2755 save_lines(GvAV(PL_compiling.cop_filegv), PL_linestr);
a0d0e21e 2756 PUTBACK;
0f15f207 2757#ifdef USE_THREADS
533c011a
NIS		 2758 MUTEX_LOCK(&PL_eval_mutex);
2759 if (PL_eval_owner && PL_eval_owner != thr)
2760 while (PL_eval_owner)
2761 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
2762 PL_eval_owner = thr;
2763 MUTEX_UNLOCK(&PL_eval_mutex);
0f15f207 2764#endif /* USE_THREADS */
c277df42 2765 ret = doeval(gimme, NULL);
3280af22 2766 if (PERLDB_INTER && was != PL_sub_generation /* Some subs defined here. */
533c011a 2767 && ret != PL_op->op_next) { /* Successive compilation. */
55497cff 2768 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
2769 }
1e422769 2770 return DOCATCH(ret);
a0d0e21e
LW		 2771}
2772
2773PP(pp_leaveeval)
2774{
4e35701f 2775 djSP;
a0d0e21e
LW		 2776 register SV **mark;
2777 SV **newsp;
2778 PMOP *newpm;
2779 I32 gimme;
c09156bb 2780 register PERL_CONTEXT *cx;
a0d0e21e 2781 OP *retop;
533c011a 2782 U8 save_flags = PL_op -> op_flags;
a0d0e21e
LW		 2783 I32 optype;
2784
2785 POPBLOCK(cx,newpm);
2786 POPEVAL(cx);
2787 retop = pop_return();
2788
a1f49e72 2789 TAINT_NOT;
54310121 2790 if (gimme == G_VOID)
2791 MARK = newsp;
2792 else if (gimme == G_SCALAR) {
2793 MARK = newsp + 1;
2794 if (MARK <= SP) {
2795 if (SvFLAGS(TOPs) & SVs_TEMP)
2796 *MARK = TOPs;
2797 else
2798 *MARK = sv_mortalcopy(TOPs);
2799 }
a0d0e21e 2800 else {
54310121 2801 MEXTEND(mark,0);
3280af22 2802 *MARK = &PL_sv_undef;
a0d0e21e 2803 }
a0d0e21e
LW		 2804 }
2805 else {
a1f49e72
CS		 2806 /* in case LEAVE wipes old return values */
2807 for (mark = newsp + 1; mark <= SP; mark++) {
2808 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
a0d0e21e 2809 *mark = sv_mortalcopy(*mark);
a1f49e72
CS		 2810 TAINT_NOT; /* Each item is independent */
2811 }
2812 }
a0d0e21e 2813 }
3280af22 2814 PL_curpm = newpm; /* Don't pop $1 et al till now */
a0d0e21e 2815
84902520
TB		 2816 /*
2817 * Closures mentioned at top level of eval cannot be referenced
2818 * again, and their presence indirectly causes a memory leak.
2819 * (Note that the fact that compcv and friends are still set here
2820 * is, AFAIK, an accident.) --Chip
2821 */
3280af22
NIS		 2822 if (AvFILLp(PL_comppad_name) >= 0) {
2823 SV **svp = AvARRAY(PL_comppad_name);
84902520 2824 I32 ix;
3280af22 2825 for (ix = AvFILLp(PL_comppad_name); ix >= 0; ix--) {
84902520 2826 SV *sv = svp[ix];
3280af22 2827 if (sv && sv != &PL_sv_undef && *SvPVX(sv) == '&') {
84902520 2828 SvREFCNT_dec(sv);
3280af22 2829 svp[ix] = &PL_sv_undef;
84902520 2830
3280af22 2831 sv = PL_curpad[ix];
84902520
TB		 2832 if (CvCLONE(sv)) {
2833 SvREFCNT_dec(CvOUTSIDE(sv));
2834 CvOUTSIDE(sv) = Nullcv;
2835 }
2836 else {
2837 SvREFCNT_dec(sv);
2838 sv = NEWSV(0,0);
2839 SvPADTMP_on(sv);
3280af22 2840 PL_curpad[ix] = sv;
84902520
TB		 2841 }
2842 }
2843 }
2844 }
2845
4fdae800 2846#ifdef DEBUGGING
3280af22 2847 assert(CvDEPTH(PL_compcv) == 1);
4fdae800 2848#endif
3280af22 2849 CvDEPTH(PL_compcv) = 0;
f46d017c 2850 lex_end();
4fdae800 2851
1ce6579f 2852 if (optype == OP_REQUIRE &&
924508f0 2853 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
54310121 2854 {
1ce6579f 2855 /* Unassume the success we assumed earlier. */
54310121 2856 char *name = cx->blk_eval.old_name;
3280af22 2857 (void)hv_delete(GvHVn(PL_incgv), name, strlen(name), G_DISCARD);
1ce6579f 2858 retop = die("%s did not return a true value", name);
f46d017c
GS		 2859 /* die_where() did LEAVE, or we won't be here */
2860 }
2861 else {
2862 LEAVE;
2863 if (!(save_flags & OPf_SPECIAL))
2864 sv_setpv(ERRSV,"");
a0d0e21e 2865 }
a0d0e21e
LW		 2866
2867 RETURNOP(retop);
2868}
2869
a0d0e21e
LW		 2870PP(pp_entertry)
2871{
4e35701f 2872 djSP;
c09156bb 2873 register PERL_CONTEXT *cx;
54310121 2874 I32 gimme = GIMME_V;
a0d0e21e
LW		 2875
2876 ENTER;
2877 SAVETMPS;
2878
2879 push_return(cLOGOP->op_other->op_next);
2880 PUSHBLOCK(cx, CXt_EVAL, SP);
2881 PUSHEVAL(cx, 0, 0);
533c011a 2882 PL_eval_root = PL_op; /* Only needed so that goto works right. */
a0d0e21e 2883
3280af22 2884 PL_in_eval = 1;
38a03e6e 2885 sv_setpv(ERRSV,"");
1e422769 2886 PUTBACK;
533c011a 2887 return DOCATCH(PL_op->op_next);
a0d0e21e
LW		 2888}
2889
2890PP(pp_leavetry)
2891{
4e35701f 2892 djSP;
a0d0e21e
LW		 2893 register SV **mark;
2894 SV **newsp;
2895 PMOP *newpm;
2896 I32 gimme;
c09156bb 2897 register PERL_CONTEXT *cx;
a0d0e21e
LW		 2898 I32 optype;
2899
2900 POPBLOCK(cx,newpm);
2901 POPEVAL(cx);
2902 pop_return();
2903
a1f49e72 2904 TAINT_NOT;
54310121 2905 if (gimme == G_VOID)
2906 SP = newsp;
2907 else if (gimme == G_SCALAR) {
2908 MARK = newsp + 1;
2909 if (MARK <= SP) {
2910 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
2911 *MARK = TOPs;
2912 else
2913 *MARK = sv_mortalcopy(TOPs);
2914 }
a0d0e21e 2915 else {
54310121 2916 MEXTEND(mark,0);
3280af22 2917 *MARK = &PL_sv_undef;
a0d0e21e
LW		 2918 }
2919 SP = MARK;
2920 }
2921 else {
a1f49e72
CS		 2922 /* in case LEAVE wipes old return values */
2923 for (mark = newsp + 1; mark <= SP; mark++) {
2924 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
a0d0e21e 2925 *mark = sv_mortalcopy(*mark);
a1f49e72
CS		 2926 TAINT_NOT; /* Each item is independent */
2927 }
2928 }
a0d0e21e 2929 }
3280af22 2930 PL_curpm = newpm; /* Don't pop $1 et al till now */
a0d0e21e
LW		 2931
2932 LEAVE;
38a03e6e 2933 sv_setpv(ERRSV,"");
a0d0e21e
LW		 2934 RETURN;
2935}
2936
0824fdcb 2937STATIC void
8ac85365 2938doparseform(SV *sv)
a0d0e21e
LW		 2939{
2940 STRLEN len;
2941 register char *s = SvPV_force(sv, len);
2942 register char *send = s + len;
2943 register char *base;
2944 register I32 skipspaces = 0;
2945 bool noblank;
2946 bool repeat;
2947 bool postspace = FALSE;
2948 U16 *fops;
2949 register U16 *fpc;
2950 U16 *linepc;
2951 register I32 arg;
2952 bool ischop;
2953
55497cff 2954 if (len == 0)
bbce6d69 2955 croak("Null picture in formline");
55497cff 2956
2957 New(804, fops, (send - s)*3+10, U16); /* Almost certainly too long... */
a0d0e21e
LW		 2958 fpc = fops;
2959
2960 if (s < send) {
2961 linepc = fpc;
2962 *fpc++ = FF_LINEMARK;
2963 noblank = repeat = FALSE;
2964 base = s;
2965 }
2966
2967 while (s <= send) {
2968 switch (*s++) {
2969 default:
2970 skipspaces = 0;
2971 continue;
2972
2973 case '~':
2974 if (*s == '~') {
2975 repeat = TRUE;
2976 *s = ' ';
2977 }
2978 noblank = TRUE;
2979 s[-1] = ' ';
2980 /* FALL THROUGH */
2981 case ' ': case '\t':
2982 skipspaces++;
2983 continue;
2984
2985 case '\n': case 0:
2986 arg = s - base;
2987 skipspaces++;
2988 arg -= skipspaces;
2989 if (arg) {
5f05dabc 2990 if (postspace)
a0d0e21e 2991 *fpc++ = FF_SPACE;
a0d0e21e
LW		 2992 *fpc++ = FF_LITERAL;
2993 *fpc++ = arg;
2994 }
5f05dabc 2995 postspace = FALSE;
a0d0e21e
LW		 2996 if (s <= send)
2997 skipspaces--;
2998 if (skipspaces) {
2999 *fpc++ = FF_SKIP;
3000 *fpc++ = skipspaces;
3001 }
3002 skipspaces = 0;
3003 if (s <= send)
3004 *fpc++ = FF_NEWLINE;
3005 if (noblank) {
3006 *fpc++ = FF_BLANK;
3007 if (repeat)
3008 arg = fpc - linepc + 1;
3009 else
3010 arg = 0;
3011 *fpc++ = arg;
3012 }
3013 if (s < send) {
3014 linepc = fpc;
3015 *fpc++ = FF_LINEMARK;
3016 noblank = repeat = FALSE;
3017 base = s;
3018 }
3019 else
3020 s++;
3021 continue;
3022
3023 case '@':
3024 case '^':
3025 ischop = s[-1] == '^';
3026
3027 if (postspace) {
3028 *fpc++ = FF_SPACE;
3029 postspace = FALSE;
3030 }
3031 arg = (s - base) - 1;
3032 if (arg) {
3033 *fpc++ = FF_LITERAL;
3034 *fpc++ = arg;
3035 }
3036
3037 base = s - 1;
3038 *fpc++ = FF_FETCH;
3039 if (*s == '*') {
3040 s++;
3041 *fpc++ = 0;
3042 *fpc++ = FF_LINEGLOB;
3043 }
3044 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3045 arg = ischop ? 512 : 0;
3046 base = s - 1;
3047 while (*s == '#')
3048 s++;
3049 if (*s == '.') {
3050 char *f;
3051 s++;
3052 f = s;
3053 while (*s == '#')
3054 s++;
3055 arg |= 256 + (s - f);
3056 }
3057 *fpc++ = s - base; /* fieldsize for FETCH */
3058 *fpc++ = FF_DECIMAL;
3059 *fpc++ = arg;
3060 }
3061 else {
3062 I32 prespace = 0;
3063 bool ismore = FALSE;
3064
3065 if (*s == '>') {
3066 while (*++s == '>') ;
3067 prespace = FF_SPACE;
3068 }
3069 else if (*s == '|') {
3070 while (*++s == '|') ;
3071 prespace = FF_HALFSPACE;
3072 postspace = TRUE;
3073 }
3074 else {
3075 if (*s == '<')
3076 while (*++s == '<') ;
3077 postspace = TRUE;
3078 }
3079 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3080 s += 3;
3081 ismore = TRUE;
3082 }
3083 *fpc++ = s - base; /* fieldsize for FETCH */
3084
3085 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3086
3087 if (prespace)
3088 *fpc++ = prespace;
3089 *fpc++ = FF_ITEM;
3090 if (ismore)
3091 *fpc++ = FF_MORE;
3092 if (ischop)
3093 *fpc++ = FF_CHOP;
3094 }
3095 base = s;
3096 skipspaces = 0;
3097 continue;
3098 }
3099 }
3100 *fpc++ = FF_END;
3101
3102 arg = fpc - fops;
3103 { /* need to jump to the next word */
3104 int z;
3105 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3106 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U16) + 4);
3107 s = SvPVX(sv) + SvCUR(sv) + z;
3108 }
3109 Copy(fops, s, arg, U16);
3110 Safefree(fops);
55497cff 3111 sv_magic(sv, Nullsv, 'f', Nullch, 0);
a0d0e21e
LW		 3112 SvCOMPILED_on(sv);
3113}
4e35701f 3114
745d3a65
HM		 3115/*
3116 * The rest of this file was derived from source code contributed
3117 * by Tom Horsley.
3118 *
3119 * NOTE: this code was derived from Tom Horsley's qsort replacement
3120 * and should not be confused with the original code.
3121 */
3122
3123/* Copyright (C) Tom Horsley, 1997. All rights reserved.
3124
3125 Permission granted to distribute under the same terms as perl which are
3126 (briefly):
3127
3128 This program is free software; you can redistribute it and/or modify
3129 it under the terms of either:
3130
3131 a) the GNU General Public License as published by the Free
3132 Software Foundation; either version 1, or (at your option) any
3133 later version, or
3134
3135 b) the "Artistic License" which comes with this Kit.
3136
3137 Details on the perl license can be found in the perl source code which
3138 may be located via the www.perl.com web page.
3139
3140 This is the most wonderfulest possible qsort I can come up with (and
3141 still be mostly portable) My (limited) tests indicate it consistently
3142 does about 20% fewer calls to compare than does the qsort in the Visual
3143 C++ library, other vendors may vary.
3144
3145 Some of the ideas in here can be found in "Algorithms" by Sedgewick,
3146 others I invented myself (or more likely re-invented since they seemed
3147 pretty obvious once I watched the algorithm operate for a while).
3148
3149 Most of this code was written while watching the Marlins sweep the Giants
3150 in the 1997 National League Playoffs - no Braves fans allowed to use this
3151 code (just kidding :-).
3152
3153 I realize that if I wanted to be true to the perl tradition, the only
3154 comment in this file would be something like:
3155
3156 ...they shuffled back towards the rear of the line. 'No, not at the
3157 rear!' the slave-driver shouted. 'Three files up. And stay there...
3158
3159 However, I really needed to violate that tradition just so I could keep
3160 track of what happens myself, not to mention some poor fool trying to
3161 understand this years from now :-).
3162*/
3163
3164/* ********************************************************** Configuration */
3165
3166#ifndef QSORT_ORDER_GUESS
3167#define QSORT_ORDER_GUESS 2 /* Select doubling version of the netBSD trick */
3168#endif
3169
3170/* QSORT_MAX_STACK is the largest number of partitions that can be stacked up for
3171 future processing - a good max upper bound is log base 2 of memory size
3172 (32 on 32 bit machines, 64 on 64 bit machines, etc). In reality can
3173 safely be smaller than that since the program is taking up some space and
3174 most operating systems only let you grab some subset of contiguous
3175 memory (not to mention that you are normally sorting data larger than
3176 1 byte element size :-).
3177*/
3178#ifndef QSORT_MAX_STACK
3179#define QSORT_MAX_STACK 32
3180#endif
3181
3182/* QSORT_BREAK_EVEN is the size of the largest partition we should insertion sort.
3183 Anything bigger and we use qsort. If you make this too small, the qsort
3184 will probably break (or become less efficient), because it doesn't expect
3185 the middle element of a partition to be the same as the right or left -
3186 you have been warned).
3187*/
3188#ifndef QSORT_BREAK_EVEN
3189#define QSORT_BREAK_EVEN 6
3190#endif
3191
3192/* ************************************************************* Data Types */
3193
3194/* hold left and right index values of a partition waiting to be sorted (the
3195 partition includes both left and right - right is NOT one past the end or
3196 anything like that).
3197*/
3198struct partition_stack_entry {
3199 int left;
3200 int right;
3201#ifdef QSORT_ORDER_GUESS
3202 int qsort_break_even;
3203#endif
3204};
3205
3206/* ******************************************************* Shorthand Macros */
3207
3208/* Note that these macros will be used from inside the qsort function where
3209 we happen to know that the variable 'elt_size' contains the size of an
3210 array element and the variable 'temp' points to enough space to hold a
3211 temp element and the variable 'array' points to the array being sorted
3212 and 'compare' is the pointer to the compare routine.
3213
3214 Also note that there are very many highly architecture specific ways
3215 these might be sped up, but this is simply the most generally portable
3216 code I could think of.
3217*/
161b471a 3218
745d3a65
HM		 3219/* Return < 0 == 0 or > 0 as the value of elt1 is < elt2, == elt2, > elt2
3220*/
565764a8
DL		 3221#ifdef PERL_OBJECT
3222#define qsort_cmp(elt1, elt2) \
3223 ((this->*compare)(array[elt1], array[elt2]))
3224#else
745d3a65
HM		 3225#define qsort_cmp(elt1, elt2) \
3226 ((*compare)(array[elt1], array[elt2]))
565764a8 3227#endif
745d3a65
HM		 3228
3229#ifdef QSORT_ORDER_GUESS
3230#define QSORT_NOTICE_SWAP swapped++;
3231#else
3232#define QSORT_NOTICE_SWAP
3233#endif
3234
3235/* swaps contents of array elements elt1, elt2.
3236*/
3237#define qsort_swap(elt1, elt2) \
3238 STMT_START { \
3239 QSORT_NOTICE_SWAP \
3240 temp = array[elt1]; \
3241 array[elt1] = array[elt2]; \
3242 array[elt2] = temp; \
3243 } STMT_END
3244
3245/* rotate contents of elt1, elt2, elt3 such that elt1 gets elt2, elt2 gets
3246 elt3 and elt3 gets elt1.
3247*/
3248#define qsort_rotate(elt1, elt2, elt3) \
3249 STMT_START { \
3250 QSORT_NOTICE_SWAP \
3251 temp = array[elt1]; \
3252 array[elt1] = array[elt2]; \
3253 array[elt2] = array[elt3]; \
3254 array[elt3] = temp; \
3255 } STMT_END
3256
3257/* ************************************************************ Debug stuff */
3258
3259#ifdef QSORT_DEBUG
3260
3261static void
3262break_here()
3263{
3264 return; /* good place to set a breakpoint */
3265}
3266
3267#define qsort_assert(t) (void)( (t) || (break_here(), 0) )
3268
3269static void
3270doqsort_all_asserts(
3271 void * array,
3272 size_t num_elts,
3273 size_t elt_size,
3274 int (*compare)(const void * elt1, const void * elt2),
3275 int pc_left, int pc_right, int u_left, int u_right)
3276{
3277 int i;
3278
3279 qsort_assert(pc_left <= pc_right);
3280 qsort_assert(u_right < pc_left);
3281 qsort_assert(pc_right < u_left);
3282 for (i = u_right + 1; i < pc_left; ++i) {
3283 qsort_assert(qsort_cmp(i, pc_left) < 0);
3284 }
3285 for (i = pc_left; i < pc_right; ++i) {
3286 qsort_assert(qsort_cmp(i, pc_right) == 0);
3287 }
3288 for (i = pc_right + 1; i < u_left; ++i) {
3289 qsort_assert(qsort_cmp(pc_right, i) < 0);
3290 }
3291}
3292
3293#define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) \
3294 doqsort_all_asserts(array, num_elts, elt_size, compare, \
3295 PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT)
3296
3297#else
3298
3299#define qsort_assert(t) ((void)0)
3300
3301#define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) ((void)0)
3302
3303#endif
3304
3305/* ****************************************************************** qsort */
3306
6cc33c6d 3307STATIC void
565764a8
DL		 3308#ifdef PERL_OBJECT
3309qsortsv(SV ** array, size_t num_elts, SVCOMPARE compare)
3310#else
745d3a65
HM		 3311qsortsv(
3312 SV ** array,
3313 size_t num_elts,
3314 I32 (*compare)(SV *a, SV *b))
565764a8 3315#endif
745d3a65
HM		 3316{
3317 register SV * temp;
3318
3319 struct partition_stack_entry partition_stack[QSORT_MAX_STACK];
3320 int next_stack_entry = 0;
3321
3322 int part_left;
3323 int part_right;
3324#ifdef QSORT_ORDER_GUESS
3325 int qsort_break_even;
3326 int swapped;
3327#endif
161b471a 3328
745d3a65
HM		 3329 /* Make sure we actually have work to do.
3330 */
3331 if (num_elts <= 1) {
3332 return;
3333 }
3334
3335 /* Setup the initial partition definition and fall into the sorting loop
3336 */
3337 part_left = 0;
3338 part_right = (int)(num_elts - 1);
3339#ifdef QSORT_ORDER_GUESS
3340 qsort_break_even = QSORT_BREAK_EVEN;
3341#else
3342#define qsort_break_even QSORT_BREAK_EVEN
3343#endif
3344 for ( ; ; ) {
3345 if ((part_right - part_left) >= qsort_break_even) {
3346 /* OK, this is gonna get hairy, so lets try to document all the
3347 concepts and abbreviations and variables and what they keep
3348 track of:
3349
3350 pc: pivot chunk - the set of array elements we accumulate in the
3351 middle of the partition, all equal in value to the original
3352 pivot element selected. The pc is defined by:
3353
3354 pc_left - the leftmost array index of the pc
3355 pc_right - the rightmost array index of the pc
3356
3357 we start with pc_left == pc_right and only one element
3358 in the pivot chunk (but it can grow during the scan).
3359
3360 u: uncompared elements - the set of elements in the partition
3361 we have not yet compared to the pivot value. There are two
3362 uncompared sets during the scan - one to the left of the pc
3363 and one to the right.
3364
3365 u_right - the rightmost index of the left side's uncompared set
3366 u_left - the leftmost index of the right side's uncompared set
3367
3368 The leftmost index of the left sides's uncompared set
3369 doesn't need its own variable because it is always defined
3370 by the leftmost edge of the whole partition (part_left). The
3371 same goes for the rightmost edge of the right partition
3372 (part_right).
3373
3374 We know there are no uncompared elements on the left once we
3375 get u_right < part_left and no uncompared elements on the
3376 right once u_left > part_right. When both these conditions
3377 are met, we have completed the scan of the partition.
3378
3379 Any elements which are between the pivot chunk and the
3380 uncompared elements should be less than the pivot value on
3381 the left side and greater than the pivot value on the right
3382 side (in fact, the goal of the whole algorithm is to arrange
3383 for that to be true and make the groups of less-than and
3384 greater-then elements into new partitions to sort again).
3385
3386 As you marvel at the complexity of the code and wonder why it
3387 has to be so confusing. Consider some of the things this level
3388 of confusion brings:
3389
3390 Once I do a compare, I squeeze every ounce of juice out of it. I
3391 never do compare calls I don't have to do, and I certainly never
3392 do redundant calls.
3393
3394 I also never swap any elements unless I can prove there is a
3395 good reason. Many sort algorithms will swap a known value with
3396 an uncompared value just to get things in the right place (or
3397 avoid complexity :-), but that uncompared value, once it gets
3398 compared, may then have to be swapped again. A lot of the
3399 complexity of this code is due to the fact that it never swaps
3400 anything except compared values, and it only swaps them when the
3401 compare shows they are out of position.
3402 */
3403 int pc_left, pc_right;
3404 int u_right, u_left;
3405
3406 int s;
3407
3408 pc_left = ((part_left + part_right) / 2);
3409 pc_right = pc_left;
3410 u_right = pc_left - 1;
3411 u_left = pc_right + 1;
3412
3413 /* Qsort works best when the pivot value is also the median value
3414 in the partition (unfortunately you can't find the median value
3415 without first sorting :-), so to give the algorithm a helping
3416 hand, we pick 3 elements and sort them and use the median value
3417 of that tiny set as the pivot value.
3418
3419 Some versions of qsort like to use the left middle and right as
3420 the 3 elements to sort so they can insure the ends of the
3421 partition will contain values which will stop the scan in the
3422 compare loop, but when you have to call an arbitrarily complex
3423 routine to do a compare, its really better to just keep track of
3424 array index values to know when you hit the edge of the
3425 partition and avoid the extra compare. An even better reason to
3426 avoid using a compare call is the fact that you can drop off the
3427 edge of the array if someone foolishly provides you with an
3428 unstable compare function that doesn't always provide consistent
3429 results.
3430
3431 So, since it is simpler for us to compare the three adjacent
3432 elements in the middle of the partition, those are the ones we
3433 pick here (conveniently pointed at by u_right, pc_left, and
3434 u_left). The values of the left, center, and right elements
3435 are refered to as l c and r in the following comments.
3436 */
3437
3438#ifdef QSORT_ORDER_GUESS
3439 swapped = 0;
3440#endif
3441 s = qsort_cmp(u_right, pc_left);
3442 if (s < 0) {
3443 /* l < c */
3444 s = qsort_cmp(pc_left, u_left);
3445 /* if l < c, c < r - already in order - nothing to do */
3446 if (s == 0) {
3447 /* l < c, c == r - already in order, pc grows */
3448 ++pc_right;
3449 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3450 } else if (s > 0) {
3451 /* l < c, c > r - need to know more */
3452 s = qsort_cmp(u_right, u_left);
3453 if (s < 0) {
3454 /* l < c, c > r, l < r - swap c & r to get ordered */
3455 qsort_swap(pc_left, u_left);
3456 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3457 } else if (s == 0) {
3458 /* l < c, c > r, l == r - swap c&r, grow pc */
3459 qsort_swap(pc_left, u_left);
3460 --pc_left;
3461 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3462 } else {
3463 /* l < c, c > r, l > r - make lcr into rlc to get ordered */
3464 qsort_rotate(pc_left, u_right, u_left);
3465 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3466 }
3467 }
3468 } else if (s == 0) {
3469 /* l == c */
3470 s = qsort_cmp(pc_left, u_left);
3471 if (s < 0) {
3472 /* l == c, c < r - already in order, grow pc */
3473 --pc_left;
3474 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3475 } else if (s == 0) {
3476 /* l == c, c == r - already in order, grow pc both ways */
3477 --pc_left;
3478 ++pc_right;
3479 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3480 } else {
3481 /* l == c, c > r - swap l & r, grow pc */
3482 qsort_swap(u_right, u_left);
3483 ++pc_right;
3484 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3485 }
3486 } else {
3487 /* l > c */
3488 s = qsort_cmp(pc_left, u_left);
3489 if (s < 0) {
3490 /* l > c, c < r - need to know more */
3491 s = qsort_cmp(u_right, u_left);
3492 if (s < 0) {
3493 /* l > c, c < r, l < r - swap l & c to get ordered */
3494 qsort_swap(u_right, pc_left);
3495 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3496 } else if (s == 0) {
3497 /* l > c, c < r, l == r - swap l & c, grow pc */
3498 qsort_swap(u_right, pc_left);
3499 ++pc_right;
3500 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3501 } else {
3502 /* l > c, c < r, l > r - rotate lcr into crl to order */
3503 qsort_rotate(u_right, pc_left, u_left);
3504 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3505 }
3506 } else if (s == 0) {
3507 /* l > c, c == r - swap ends, grow pc */
3508 qsort_swap(u_right, u_left);
3509 --pc_left;
3510 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3511 } else {
3512 /* l > c, c > r - swap ends to get in order */
3513 qsort_swap(u_right, u_left);
3514 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3515 }
3516 }
3517 /* We now know the 3 middle elements have been compared and
3518 arranged in the desired order, so we can shrink the uncompared
3519 sets on both sides
3520 */
3521 --u_right;
3522 ++u_left;
3523 qsort_all_asserts(pc_left, pc_right, u_left, u_right);
3524
3525 /* The above massive nested if was the simple part :-). We now have
3526 the middle 3 elements ordered and we need to scan through the
3527 uncompared sets on either side, swapping elements that are on
3528 the wrong side or simply shuffling equal elements around to get
3529 all equal elements into the pivot chunk.
3530 */
3531
3532 for ( ; ; ) {
3533 int still_work_on_left;
3534 int still_work_on_right;
3535
3536 /* Scan the uncompared values on the left. If I find a value
3537 equal to the pivot value, move it over so it is adjacent to
3538 the pivot chunk and expand the pivot chunk. If I find a value
3539 less than the pivot value, then just leave it - its already
3540 on the correct side of the partition. If I find a greater
3541 value, then stop the scan.
3542 */
3543 while (still_work_on_left = (u_right >= part_left)) {
3544 s = qsort_cmp(u_right, pc_left);
3545 if (s < 0) {
3546 --u_right;
3547 } else if (s == 0) {
3548 --pc_left;
3549 if (pc_left != u_right) {
3550 qsort_swap(u_right, pc_left);
3551 }
3552 --u_right;
3553 } else {
3554 break;
3555 }
3556 qsort_assert(u_right < pc_left);
3557 qsort_assert(pc_left <= pc_right);
3558 qsort_assert(qsort_cmp(u_right + 1, pc_left) <= 0);
3559 qsort_assert(qsort_cmp(pc_left, pc_right) == 0);
3560 }
3561
3562 /* Do a mirror image scan of uncompared values on the right
3563 */
3564 while (still_work_on_right = (u_left <= part_right)) {
3565 s = qsort_cmp(pc_right, u_left);
3566 if (s < 0) {
3567 ++u_left;
3568 } else if (s == 0) {
3569 ++pc_right;
3570 if (pc_right != u_left) {
3571 qsort_swap(pc_right, u_left);
3572 }
3573 ++u_left;
3574 } else {
3575 break;
3576 }
3577 qsort_assert(u_left > pc_right);
3578 qsort_assert(pc_left <= pc_right);
3579 qsort_assert(qsort_cmp(pc_right, u_left - 1) <= 0);
3580 qsort_assert(qsort_cmp(pc_left, pc_right) == 0);
3581 }
3582
3583 if (still_work_on_left) {
3584 /* I know I have a value on the left side which needs to be
3585 on the right side, but I need to know more to decide
3586 exactly the best thing to do with it.
3587 */
3588 if (still_work_on_right) {
3589 /* I know I have values on both side which are out of
3590 position. This is a big win because I kill two birds
3591 with one swap (so to speak). I can advance the
3592 uncompared pointers on both sides after swapping both
3593 of them into the right place.
3594 */
3595 qsort_swap(u_right, u_left);
3596 --u_right;
3597 ++u_left;
3598 qsort_all_asserts(pc_left, pc_right, u_left, u_right);
3599 } else {
3600 /* I have an out of position value on the left, but the
3601 right is fully scanned, so I "slide" the pivot chunk
3602 and any less-than values left one to make room for the
3603 greater value over on the right. If the out of position
3604 value is immediately adjacent to the pivot chunk (there
3605 are no less-than values), I can do that with a swap,
3606 otherwise, I have to rotate one of the less than values
3607 into the former position of the out of position value
3608 and the right end of the pivot chunk into the left end
3609 (got all that?).
3610 */
3611 --pc_left;
3612 if (pc_left == u_right) {
3613 qsort_swap(u_right, pc_right);
3614 qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1);
3615 } else {
3616 qsort_rotate(u_right, pc_left, pc_right);
3617 qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1);
3618 }
3619 --pc_right;
3620 --u_right;
3621 }
3622 } else if (still_work_on_right) {
3623 /* Mirror image of complex case above: I have an out of
3624 position value on the right, but the left is fully
3625 scanned, so I need to shuffle things around to make room
3626 for the right value on the left.
3627 */
3628 ++pc_right;
3629 if (pc_right == u_left) {
3630 qsort_swap(u_left, pc_left);
3631 qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right);
3632 } else {
3633 qsort_rotate(pc_right, pc_left, u_left);
3634 qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right);
3635 }
3636 ++pc_left;
3637 ++u_left;
3638 } else {
3639 /* No more scanning required on either side of partition,
3640 break out of loop and figure out next set of partitions
3641 */
3642 break;
3643 }
3644 }
3645
3646 /* The elements in the pivot chunk are now in the right place. They
3647 will never move or be compared again. All I have to do is decide
3648 what to do with the stuff to the left and right of the pivot
3649 chunk.
3650
3651 Notes on the QSORT_ORDER_GUESS ifdef code:
3652
3653 1. If I just built these partitions without swapping any (or
3654 very many) elements, there is a chance that the elements are
3655 already ordered properly (being properly ordered will
3656 certainly result in no swapping, but the converse can't be
3657 proved :-).
3658
3659 2. A (properly written) insertion sort will run faster on
3660 already ordered data than qsort will.
3661
3662 3. Perhaps there is some way to make a good guess about
3663 switching to an insertion sort earlier than partition size 6
3664 (for instance - we could save the partition size on the stack
3665 and increase the size each time we find we didn't swap, thus
3666 switching to insertion sort earlier for partitions with a
3667 history of not swapping).
3668
3669 4. Naturally, if I just switch right away, it will make
3670 artificial benchmarks with pure ascending (or descending)
3671 data look really good, but is that a good reason in general?
3672 Hard to say...
3673 */
3674
3675#ifdef QSORT_ORDER_GUESS
3676 if (swapped < 3) {
3677#if QSORT_ORDER_GUESS == 1
3678 qsort_break_even = (part_right - part_left) + 1;
3679#endif
3680#if QSORT_ORDER_GUESS == 2
3681 qsort_break_even *= 2;
3682#endif
3683#if QSORT_ORDER_GUESS == 3
3684 int prev_break = qsort_break_even;
3685 qsort_break_even *= qsort_break_even;
3686 if (qsort_break_even < prev_break) {
3687 qsort_break_even = (part_right - part_left) + 1;
3688 }
3689#endif
3690 } else {
3691 qsort_break_even = QSORT_BREAK_EVEN;
3692 }
3693#endif
3694
3695 if (part_left < pc_left) {
3696 /* There are elements on the left which need more processing.
3697 Check the right as well before deciding what to do.
3698 */
3699 if (pc_right < part_right) {
3700 /* We have two partitions to be sorted. Stack the biggest one
3701 and process the smallest one on the next iteration. This
3702 minimizes the stack height by insuring that any additional
3703 stack entries must come from the smallest partition which
3704 (because it is smallest) will have the fewest
3705 opportunities to generate additional stack entries.
3706 */
3707 if ((part_right - pc_right) > (pc_left - part_left)) {
3708 /* stack the right partition, process the left */
3709 partition_stack[next_stack_entry].left = pc_right + 1;
3710 partition_stack[next_stack_entry].right = part_right;
3711#ifdef QSORT_ORDER_GUESS
3712 partition_stack[next_stack_entry].qsort_break_even = qsort_break_even;
3713#endif
3714 part_right = pc_left - 1;
3715 } else {
3716 /* stack the left partition, process the right */
3717 partition_stack[next_stack_entry].left = part_left;
3718 partition_stack[next_stack_entry].right = pc_left - 1;
3719#ifdef QSORT_ORDER_GUESS
3720 partition_stack[next_stack_entry].qsort_break_even = qsort_break_even;
3721#endif
3722 part_left = pc_right + 1;
3723 }
3724 qsort_assert(next_stack_entry < QSORT_MAX_STACK);
3725 ++next_stack_entry;
3726 } else {
3727 /* The elements on the left are the only remaining elements
3728 that need sorting, arrange for them to be processed as the
3729 next partition.
3730 */
3731 part_right = pc_left - 1;
3732 }
3733 } else if (pc_right < part_right) {
3734 /* There is only one chunk on the right to be sorted, make it
3735 the new partition and loop back around.
3736 */
3737 part_left = pc_right + 1;
3738 } else {
3739 /* This whole partition wound up in the pivot chunk, so
3740 we need to get a new partition off the stack.
3741 */
3742 if (next_stack_entry == 0) {
3743 /* the stack is empty - we are done */
3744 break;
3745 }
3746 --next_stack_entry;
3747 part_left = partition_stack[next_stack_entry].left;
3748 part_right = partition_stack[next_stack_entry].right;
3749#ifdef QSORT_ORDER_GUESS
3750 qsort_break_even = partition_stack[next_stack_entry].qsort_break_even;
3751#endif
3752 }
3753 } else {
3754 /* This partition is too small to fool with qsort complexity, just
3755 do an ordinary insertion sort to minimize overhead.
3756 */
3757 int i;
3758 /* Assume 1st element is in right place already, and start checking
3759 at 2nd element to see where it should be inserted.
3760 */
3761 for (i = part_left + 1; i <= part_right; ++i) {
3762 int j;
3763 /* Scan (backwards - just in case 'i' is already in right place)
3764 through the elements already sorted to see if the ith element
3765 belongs ahead of one of them.
3766 */
3767 for (j = i - 1; j >= part_left; --j) {
3768 if (qsort_cmp(i, j) >= 0) {
3769 /* i belongs right after j
3770 */
3771 break;
3772 }
3773 }
3774 ++j;
3775 if (j != i) {
3776 /* Looks like we really need to move some things
3777 */
b6917549 3778 int k;
745d3a65 3779 temp = array[i];
b6917549
HM		 3780 for (k = i - 1; k >= j; --k)
3781 array[k + 1] = array[k];
745d3a65
HM		 3782 array[j] = temp;
3783 }
3784 }
3785
3786 /* That partition is now sorted, grab the ne