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