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