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