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