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