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