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