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