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