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