This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
more cleanups for change#4539
[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)));
cc49e20b 1448 PUSHs(sv_2mortal(newSVsv(CopFILESV(cx->blk_oldcop))));
a0d0e21e
LW
1449 PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->cop_line)));
1450 if (!MAXARG)
1451 RETURN;
6b35e009 1452 if (CxTYPE(cx) == CXt_SUB) { /* So is ccstack[dbcxix]. */
a0d0e21e 1453 sv = NEWSV(49, 0);
2c375eb9 1454 gv_efullname3(sv, CvGV(ccstack[cxix].blk_sub.cv), Nullch);
a0d0e21e
LW
1455 PUSHs(sv_2mortal(sv));
1456 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1457 }
1458 else {
79cb57f6 1459 PUSHs(sv_2mortal(newSVpvn("(eval)",6)));
a0d0e21e
LW
1460 PUSHs(sv_2mortal(newSViv(0)));
1461 }
54310121
PP
1462 gimme = (I32)cx->blk_gimme;
1463 if (gimme == G_VOID)
3280af22 1464 PUSHs(&PL_sv_undef);
54310121
PP
1465 else
1466 PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
6b35e009 1467 if (CxTYPE(cx) == CXt_EVAL) {
06a5b730 1468 if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
4633a7c4 1469 PUSHs(cx->blk_eval.cur_text);
3280af22 1470 PUSHs(&PL_sv_no);
06a5b730
PP
1471 }
1472 else if (cx->blk_eval.old_name) { /* Try blocks have old_name == 0. */
1473 /* Require, put the name. */
1474 PUSHs(sv_2mortal(newSVpv(cx->blk_eval.old_name, 0)));
3280af22 1475 PUSHs(&PL_sv_yes);
06a5b730 1476 }
4633a7c4 1477 }
a682de96
GS
1478 else {
1479 PUSHs(&PL_sv_undef);
1480 PUSHs(&PL_sv_undef);
1481 }
1482 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs
1483 && PL_curcop->cop_stash == PL_debstash)
4633a7c4 1484 {
a0d0e21e
LW
1485 AV *ary = cx->blk_sub.argarray;
1486 int off = AvARRAY(ary) - AvALLOC(ary);
1487
3280af22 1488 if (!PL_dbargs) {
a0d0e21e 1489 GV* tmpgv;
3280af22 1490 PL_dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE,
a0d0e21e 1491 SVt_PVAV)));
a5f75d66 1492 GvMULTI_on(tmpgv);
3280af22 1493 AvREAL_off(PL_dbargs); /* XXX Should be REIFY */
a0d0e21e
LW
1494 }
1495
3280af22
NIS
1496 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1497 av_extend(PL_dbargs, AvFILLp(ary) + off);
1498 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1499 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
a0d0e21e 1500 }
f3aa04c2
GS
1501 /* XXX only hints propagated via op_private are currently
1502 * visible (others are not easily accessible, since they
1503 * use the global PL_hints) */
1504 PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->op_private &
1505 HINT_PRIVATE_MASK)));
a0d0e21e
LW
1506 RETURN;
1507}
1508
a0d0e21e
LW
1509PP(pp_reset)
1510{
4e35701f 1511 djSP;
a0d0e21e 1512 char *tmps;
2d8e6c8d 1513 STRLEN n_a;
a0d0e21e
LW
1514
1515 if (MAXARG < 1)
1516 tmps = "";
1517 else
2d8e6c8d 1518 tmps = POPpx;
3280af22
NIS
1519 sv_reset(tmps, PL_curcop->cop_stash);
1520 PUSHs(&PL_sv_yes);
a0d0e21e
LW
1521 RETURN;
1522}
1523
1524PP(pp_lineseq)
1525{
1526 return NORMAL;
1527}
1528
1529PP(pp_dbstate)
1530{
533c011a 1531 PL_curcop = (COP*)PL_op;
a0d0e21e 1532 TAINT_NOT; /* Each statement is presumed innocent */
3280af22 1533 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
a0d0e21e
LW
1534 FREETMPS;
1535
533c011a 1536 if (PL_op->op_private || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
a0d0e21e 1537 {
924508f0 1538 djSP;
a0d0e21e 1539 register CV *cv;
c09156bb 1540 register PERL_CONTEXT *cx;
748a9306 1541 I32 gimme = G_ARRAY;
a0d0e21e
LW
1542 I32 hasargs;
1543 GV *gv;
1544
3280af22 1545 gv = PL_DBgv;
a0d0e21e 1546 cv = GvCV(gv);
a0d0e21e 1547 if (!cv)
cea2e8a9 1548 DIE(aTHX_ "No DB::DB routine defined");
a0d0e21e 1549
3280af22 1550 if (CvDEPTH(cv) >= 1 && !(PL_debug & (1<<30))) /* don't do recursive DB::DB call */
a0d0e21e 1551 return NORMAL;
748a9306 1552
4633a7c4
LW
1553 ENTER;
1554 SAVETMPS;
1555
3280af22 1556 SAVEI32(PL_debug);
55497cff 1557 SAVESTACK_POS();
3280af22 1558 PL_debug = 0;
748a9306 1559 hasargs = 0;
924508f0 1560 SPAGAIN;
748a9306 1561
533c011a 1562 push_return(PL_op->op_next);
924508f0 1563 PUSHBLOCK(cx, CXt_SUB, SP);
a0d0e21e
LW
1564 PUSHSUB(cx);
1565 CvDEPTH(cv)++;
1566 (void)SvREFCNT_inc(cv);
3280af22
NIS
1567 SAVESPTR(PL_curpad);
1568 PL_curpad = AvARRAY((AV*)*av_fetch(CvPADLIST(cv),1,FALSE));
a0d0e21e
LW
1569 RETURNOP(CvSTART(cv));
1570 }
1571 else
1572 return NORMAL;
1573}
1574
1575PP(pp_scope)
1576{
1577 return NORMAL;
1578}
1579
1580PP(pp_enteriter)
1581{
4e35701f 1582 djSP; dMARK;
c09156bb 1583 register PERL_CONTEXT *cx;
54310121 1584 I32 gimme = GIMME_V;
a0d0e21e
LW
1585 SV **svp;
1586
4633a7c4
LW
1587 ENTER;
1588 SAVETMPS;
1589
54b9620d 1590#ifdef USE_THREADS
0214ae40
GS
1591 if (PL_op->op_flags & OPf_SPECIAL) {
1592 dTHR;
1593 svp = &THREADSV(PL_op->op_targ); /* per-thread variable */
1594 SAVEGENERICSV(*svp);
1595 *svp = NEWSV(0,0);
1596 }
a0d0e21e 1597 else
54b9620d 1598#endif /* USE_THREADS */
533c011a
NIS
1599 if (PL_op->op_targ) {
1600 svp = &PL_curpad[PL_op->op_targ]; /* "my" variable */
54b9620d
MB
1601 SAVESPTR(*svp);
1602 }
1603 else {
0214ae40
GS
1604 svp = &GvSV((GV*)POPs); /* symbol table variable */
1605 SAVEGENERICSV(*svp);
1606 *svp = NEWSV(0,0);
54b9620d 1607 }
4633a7c4 1608
a0d0e21e
LW
1609 ENTER;
1610
1611 PUSHBLOCK(cx, CXt_LOOP, SP);
1612 PUSHLOOP(cx, svp, MARK);
533c011a 1613 if (PL_op->op_flags & OPf_STACKED) {
44a8e56a 1614 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
89ea2908
GA
1615 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1616 dPOPss;
1617 if (SvNIOKp(sv) || !SvPOKp(sv) ||
1618 (looks_like_number(sv) && *SvPVX(sv) != '0')) {
1619 if (SvNV(sv) < IV_MIN ||
1620 SvNV((SV*)cx->blk_loop.iterary) >= IV_MAX)
d470f89e 1621 DIE(aTHX_ "Range iterator outside integer range");
89ea2908
GA
1622 cx->blk_loop.iterix = SvIV(sv);
1623 cx->blk_loop.itermax = SvIV((SV*)cx->blk_loop.iterary);
1624 }
1625 else
1626 cx->blk_loop.iterlval = newSVsv(sv);
1627 }
1628 }
4633a7c4 1629 else {
3280af22
NIS
1630 cx->blk_loop.iterary = PL_curstack;
1631 AvFILLp(PL_curstack) = SP - PL_stack_base;
1632 cx->blk_loop.iterix = MARK - PL_stack_base;
4633a7c4 1633 }
a0d0e21e
LW
1634
1635 RETURN;
1636}
1637
1638PP(pp_enterloop)
1639{
4e35701f 1640 djSP;
c09156bb 1641 register PERL_CONTEXT *cx;
54310121 1642 I32 gimme = GIMME_V;
a0d0e21e
LW
1643
1644 ENTER;
1645 SAVETMPS;
1646 ENTER;
1647
1648 PUSHBLOCK(cx, CXt_LOOP, SP);
1649 PUSHLOOP(cx, 0, SP);
1650
1651 RETURN;
1652}
1653
1654PP(pp_leaveloop)
1655{
4e35701f 1656 djSP;
c09156bb 1657 register PERL_CONTEXT *cx;
a0d0e21e
LW
1658 I32 gimme;
1659 SV **newsp;
1660 PMOP *newpm;
1661 SV **mark;
1662
1663 POPBLOCK(cx,newpm);
4fdae800 1664 mark = newsp;
a8bba7fa 1665 newsp = PL_stack_base + cx->blk_loop.resetsp;
f86702cc 1666
a1f49e72 1667 TAINT_NOT;
54310121
PP
1668 if (gimme == G_VOID)
1669 ; /* do nothing */
1670 else if (gimme == G_SCALAR) {
1671 if (mark < SP)
1672 *++newsp = sv_mortalcopy(*SP);
1673 else
3280af22 1674 *++newsp = &PL_sv_undef;
a0d0e21e
LW
1675 }
1676 else {
a1f49e72 1677 while (mark < SP) {
a0d0e21e 1678 *++newsp = sv_mortalcopy(*++mark);
a1f49e72
CS
1679 TAINT_NOT; /* Each item is independent */
1680 }
a0d0e21e 1681 }
f86702cc
PP
1682 SP = newsp;
1683 PUTBACK;
1684
a8bba7fa 1685 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
3280af22 1686 PL_curpm = newpm; /* ... and pop $1 et al */
f86702cc 1687
a0d0e21e
LW
1688 LEAVE;
1689 LEAVE;
1690
f86702cc 1691 return NORMAL;
a0d0e21e
LW
1692}
1693
1694PP(pp_return)
1695{
4e35701f 1696 djSP; dMARK;
a0d0e21e 1697 I32 cxix;
c09156bb 1698 register PERL_CONTEXT *cx;
f86702cc 1699 bool popsub2 = FALSE;
a0d0e21e
LW
1700 I32 gimme;
1701 SV **newsp;
1702 PMOP *newpm;
1703 I32 optype = 0;
b0d9ce38 1704 SV *sv;
a0d0e21e 1705
3280af22
NIS
1706 if (PL_curstackinfo->si_type == PERLSI_SORT) {
1707 if (cxstack_ix == PL_sortcxix || dopoptosub(cxstack_ix) <= PL_sortcxix) {
1708 if (cxstack_ix > PL_sortcxix)
1709 dounwind(PL_sortcxix);
1710 AvARRAY(PL_curstack)[1] = *SP;
1711 PL_stack_sp = PL_stack_base + 1;
a0d0e21e
LW
1712 return 0;
1713 }
1714 }
1715
1716 cxix = dopoptosub(cxstack_ix);
1717 if (cxix < 0)
cea2e8a9 1718 DIE(aTHX_ "Can't return outside a subroutine");
a0d0e21e
LW
1719 if (cxix < cxstack_ix)
1720 dounwind(cxix);
1721
1722 POPBLOCK(cx,newpm);
6b35e009 1723 switch (CxTYPE(cx)) {
a0d0e21e 1724 case CXt_SUB:
f86702cc 1725 popsub2 = TRUE;
a0d0e21e
LW
1726 break;
1727 case CXt_EVAL:
1728 POPEVAL(cx);
067f92a0
GS
1729 if (AvFILLp(PL_comppad_name) >= 0)
1730 free_closures();
1731 lex_end();
748a9306
LW
1732 if (optype == OP_REQUIRE &&
1733 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1734 {
54310121 1735 /* Unassume the success we assumed earlier. */
748a9306 1736 char *name = cx->blk_eval.old_name;
3280af22 1737 (void)hv_delete(GvHVn(PL_incgv), name, strlen(name), G_DISCARD);
cea2e8a9 1738 DIE(aTHX_ "%s did not return a true value", name);
748a9306 1739 }
a0d0e21e
LW
1740 break;
1741 default:
cea2e8a9 1742 DIE(aTHX_ "panic: return");
a0d0e21e
LW
1743 }
1744
a1f49e72 1745 TAINT_NOT;
a0d0e21e 1746 if (gimme == G_SCALAR) {
a29cdaf0
IZ
1747 if (MARK < SP) {
1748 if (popsub2) {
a8bba7fa 1749 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
a29cdaf0
IZ
1750 if (SvTEMP(TOPs)) {
1751 *++newsp = SvREFCNT_inc(*SP);
1752 FREETMPS;
1753 sv_2mortal(*newsp);
1754 } else {
1755 FREETMPS;
1756 *++newsp = sv_mortalcopy(*SP);
1757 }
1758 } else
1759 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
1760 } else
1761 *++newsp = sv_mortalcopy(*SP);
1762 } else
3280af22 1763 *++newsp = &PL_sv_undef;
a0d0e21e 1764 }
54310121 1765 else if (gimme == G_ARRAY) {
a1f49e72 1766 while (++MARK <= SP) {
f86702cc
PP
1767 *++newsp = (popsub2 && SvTEMP(*MARK))
1768 ? *MARK : sv_mortalcopy(*MARK);
a1f49e72
CS
1769 TAINT_NOT; /* Each item is independent */
1770 }
a0d0e21e 1771 }
3280af22 1772 PL_stack_sp = newsp;
a0d0e21e 1773
f86702cc
PP
1774 /* Stack values are safe: */
1775 if (popsub2) {
b0d9ce38 1776 POPSUB(cx,sv); /* release CV and @_ ... */
f86702cc 1777 }
b0d9ce38
GS
1778 else
1779 sv = Nullsv;
3280af22 1780 PL_curpm = newpm; /* ... and pop $1 et al */
f86702cc 1781
a0d0e21e 1782 LEAVE;
b0d9ce38 1783 LEAVESUB(sv);
a0d0e21e
LW
1784 return pop_return();
1785}
1786
1787PP(pp_last)
1788{
4e35701f 1789 djSP;
a0d0e21e 1790 I32 cxix;
c09156bb 1791 register PERL_CONTEXT *cx;
f86702cc 1792 I32 pop2 = 0;
a0d0e21e
LW
1793 I32 gimme;
1794 I32 optype;
1795 OP *nextop;
1796 SV **newsp;
1797 PMOP *newpm;
a8bba7fa 1798 SV **mark;
b0d9ce38 1799 SV *sv = Nullsv;
a0d0e21e 1800
533c011a 1801 if (PL_op->op_flags & OPf_SPECIAL) {
a0d0e21e
LW
1802 cxix = dopoptoloop(cxstack_ix);
1803 if (cxix < 0)
cea2e8a9 1804 DIE(aTHX_ "Can't \"last\" outside a block");
a0d0e21e
LW
1805 }
1806 else {
1807 cxix = dopoptolabel(cPVOP->op_pv);
1808 if (cxix < 0)
cea2e8a9 1809 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
a0d0e21e
LW
1810 }
1811 if (cxix < cxstack_ix)
1812 dounwind(cxix);
1813
1814 POPBLOCK(cx,newpm);
a8bba7fa 1815 mark = newsp;
6b35e009 1816 switch (CxTYPE(cx)) {
a0d0e21e 1817 case CXt_LOOP:
f86702cc 1818 pop2 = CXt_LOOP;
a8bba7fa
GS
1819 newsp = PL_stack_base + cx->blk_loop.resetsp;
1820 nextop = cx->blk_loop.last_op->op_next;
a0d0e21e 1821 break;
f86702cc 1822 case CXt_SUB:
f86702cc 1823 pop2 = CXt_SUB;
a0d0e21e
LW
1824 nextop = pop_return();
1825 break;
f86702cc
PP
1826 case CXt_EVAL:
1827 POPEVAL(cx);
a0d0e21e
LW
1828 nextop = pop_return();
1829 break;
1830 default:
cea2e8a9 1831 DIE(aTHX_ "panic: last");
a0d0e21e
LW
1832 }
1833
a1f49e72 1834 TAINT_NOT;
a0d0e21e 1835 if (gimme == G_SCALAR) {
f86702cc
PP
1836 if (MARK < SP)
1837 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
1838 ? *SP : sv_mortalcopy(*SP);
a0d0e21e 1839 else
3280af22 1840 *++newsp = &PL_sv_undef;
a0d0e21e 1841 }
54310121 1842 else if (gimme == G_ARRAY) {
a1f49e72 1843 while (++MARK <= SP) {
f86702cc
PP
1844 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
1845 ? *MARK : sv_mortalcopy(*MARK);
a1f49e72
CS
1846 TAINT_NOT; /* Each item is independent */
1847 }
f86702cc
PP
1848 }
1849 SP = newsp;
1850 PUTBACK;
1851
1852 /* Stack values are safe: */
1853 switch (pop2) {
1854 case CXt_LOOP:
a8bba7fa 1855 POPLOOP(cx); /* release loop vars ... */
4fdae800 1856 LEAVE;
f86702cc
PP
1857 break;
1858 case CXt_SUB:
b0d9ce38 1859 POPSUB(cx,sv); /* release CV and @_ ... */
f86702cc 1860 break;
a0d0e21e 1861 }
3280af22 1862 PL_curpm = newpm; /* ... and pop $1 et al */
a0d0e21e
LW
1863
1864 LEAVE;
b0d9ce38 1865 LEAVESUB(sv);
f86702cc 1866 return nextop;
a0d0e21e
LW
1867}
1868
1869PP(pp_next)
1870{
1871 I32 cxix;
c09156bb 1872 register PERL_CONTEXT *cx;
a0d0e21e
LW
1873 I32 oldsave;
1874
533c011a 1875 if (PL_op->op_flags & OPf_SPECIAL) {
a0d0e21e
LW
1876 cxix = dopoptoloop(cxstack_ix);
1877 if (cxix < 0)
cea2e8a9 1878 DIE(aTHX_ "Can't \"next\" outside a block");
a0d0e21e
LW
1879 }
1880 else {
1881 cxix = dopoptolabel(cPVOP->op_pv);
1882 if (cxix < 0)
cea2e8a9 1883 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
a0d0e21e
LW
1884 }
1885 if (cxix < cxstack_ix)
1886 dounwind(cxix);
1887
1888 TOPBLOCK(cx);
3280af22 1889 oldsave = PL_scopestack[PL_scopestack_ix - 1];
a0d0e21e
LW
1890 LEAVE_SCOPE(oldsave);
1891 return cx->blk_loop.next_op;
1892}
1893
1894PP(pp_redo)
1895{
1896 I32 cxix;
c09156bb 1897 register PERL_CONTEXT *cx;
a0d0e21e
LW
1898 I32 oldsave;
1899
533c011a 1900 if (PL_op->op_flags & OPf_SPECIAL) {
a0d0e21e
LW
1901 cxix = dopoptoloop(cxstack_ix);
1902 if (cxix < 0)
cea2e8a9 1903 DIE(aTHX_ "Can't \"redo\" outside a block");
a0d0e21e
LW
1904 }
1905 else {
1906 cxix = dopoptolabel(cPVOP->op_pv);
1907 if (cxix < 0)
cea2e8a9 1908 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
a0d0e21e
LW
1909 }
1910 if (cxix < cxstack_ix)
1911 dounwind(cxix);
1912
1913 TOPBLOCK(cx);
3280af22 1914 oldsave = PL_scopestack[PL_scopestack_ix - 1];
a0d0e21e
LW
1915 LEAVE_SCOPE(oldsave);
1916 return cx->blk_loop.redo_op;
1917}
1918
0824fdcb 1919STATIC OP *
cea2e8a9 1920S_dofindlabel(pTHX_ OP *o, char *label, OP **opstack, OP **oplimit)
a0d0e21e
LW
1921{
1922 OP *kid;
1923 OP **ops = opstack;
fc36a67e 1924 static char too_deep[] = "Target of goto is too deeply nested";
a0d0e21e 1925
fc36a67e 1926 if (ops >= oplimit)
cea2e8a9 1927 Perl_croak(aTHX_ too_deep);
11343788
MB
1928 if (o->op_type == OP_LEAVE ||
1929 o->op_type == OP_SCOPE ||
1930 o->op_type == OP_LEAVELOOP ||
1931 o->op_type == OP_LEAVETRY)
fc36a67e 1932 {
5dc0d613 1933 *ops++ = cUNOPo->op_first;
fc36a67e 1934 if (ops >= oplimit)
cea2e8a9 1935 Perl_croak(aTHX_ too_deep);
fc36a67e 1936 }
c4aa4e48 1937 *ops = 0;
11343788 1938 if (o->op_flags & OPf_KIDS) {
5c0ca799 1939 dTHR;
a0d0e21e 1940 /* First try all the kids at this level, since that's likeliest. */
11343788 1941 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
c4aa4e48
GS
1942 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
1943 kCOP->cop_label && strEQ(kCOP->cop_label, label))
a0d0e21e
LW
1944 return kid;
1945 }
11343788 1946 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
3280af22 1947 if (kid == PL_lastgotoprobe)
a0d0e21e 1948 continue;
c4aa4e48
GS
1949 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
1950 (ops == opstack ||
1951 (ops[-1]->op_type != OP_NEXTSTATE &&
1952 ops[-1]->op_type != OP_DBSTATE)))
fc36a67e 1953 *ops++ = kid;
5dc0d613 1954 if (o = dofindlabel(kid, label, ops, oplimit))
11343788 1955 return o;
a0d0e21e
LW
1956 }
1957 }
c4aa4e48 1958 *ops = 0;
a0d0e21e
LW
1959 return 0;
1960}
1961
1962PP(pp_dump)
1963{
cea2e8a9 1964 return pp_goto();
a0d0e21e
LW
1965 /*NOTREACHED*/
1966}
1967
1968PP(pp_goto)
1969{
4e35701f 1970 djSP;
a0d0e21e
LW
1971 OP *retop = 0;
1972 I32 ix;
c09156bb 1973 register PERL_CONTEXT *cx;
fc36a67e
PP
1974#define GOTO_DEPTH 64
1975 OP *enterops[GOTO_DEPTH];
a0d0e21e 1976 char *label;
533c011a 1977 int do_dump = (PL_op->op_type == OP_DUMP);
1614b0e3 1978 static char must_have_label[] = "goto must have label";
a0d0e21e
LW
1979
1980 label = 0;
533c011a 1981 if (PL_op->op_flags & OPf_STACKED) {
a0d0e21e 1982 SV *sv = POPs;
2d8e6c8d 1983 STRLEN n_a;
a0d0e21e
LW
1984
1985 /* This egregious kludge implements goto &subroutine */
1986 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
1987 I32 cxix;
c09156bb 1988 register PERL_CONTEXT *cx;
a0d0e21e
LW
1989 CV* cv = (CV*)SvRV(sv);
1990 SV** mark;
1991 I32 items = 0;
1992 I32 oldsave;
1993
e8f7dd13 1994 retry:
4aa0a1f7 1995 if (!CvROOT(cv) && !CvXSUB(cv)) {
e8f7dd13
GS
1996 GV *gv = CvGV(cv);
1997 GV *autogv;
1998 if (gv) {
1999 SV *tmpstr;
2000 /* autoloaded stub? */
2001 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2002 goto retry;
2003 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2004 GvNAMELEN(gv), FALSE);
2005 if (autogv && (cv = GvCV(autogv)))
2006 goto retry;
2007 tmpstr = sv_newmortal();
2008 gv_efullname3(tmpstr, gv, Nullch);
cea2e8a9 2009 DIE(aTHX_ "Goto undefined subroutine &%s",SvPVX(tmpstr));
4aa0a1f7 2010 }
cea2e8a9 2011 DIE(aTHX_ "Goto undefined subroutine");
4aa0a1f7
AD
2012 }
2013
a0d0e21e
LW
2014 /* First do some returnish stuff. */
2015 cxix = dopoptosub(cxstack_ix);
2016 if (cxix < 0)
cea2e8a9 2017 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
a0d0e21e
LW
2018 if (cxix < cxstack_ix)
2019 dounwind(cxix);
2020 TOPBLOCK(cx);
6b35e009 2021 if (CxTYPE(cx) == CXt_EVAL && cx->blk_eval.old_op_type == OP_ENTEREVAL)
cea2e8a9 2022 DIE(aTHX_ "Can't goto subroutine from an eval-string");
3280af22 2023 mark = PL_stack_sp;
d8b46c1b
GS
2024 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2025 /* put @_ back onto stack */
a0d0e21e
LW
2026 AV* av = cx->blk_sub.argarray;
2027
93965878 2028 items = AvFILLp(av) + 1;
3280af22
NIS
2029 PL_stack_sp++;
2030 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2031 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2032 PL_stack_sp += items;
6d4ff0d2 2033#ifndef USE_THREADS
3280af22
NIS
2034 SvREFCNT_dec(GvAV(PL_defgv));
2035 GvAV(PL_defgv) = cx->blk_sub.savearray;
6d4ff0d2 2036#endif /* USE_THREADS */
d8b46c1b 2037 /* abandon @_ if it got reified */
62b1ebc2 2038 if (AvREAL(av)) {
d8b46c1b
GS
2039 (void)sv_2mortal((SV*)av); /* delay until return */
2040 av = newAV();
2041 av_extend(av, items-1);
2042 AvFLAGS(av) = AVf_REIFY;
2043 PL_curpad[0] = (SV*)(cx->blk_sub.argarray = av);
62b1ebc2 2044 }
a0d0e21e 2045 }
1fa4e549
AD
2046 else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2047 AV* av;
2048 int i;
2049#ifdef USE_THREADS
533c011a 2050 av = (AV*)PL_curpad[0];
1fa4e549 2051#else
3280af22 2052 av = GvAV(PL_defgv);
1fa4e549
AD
2053#endif
2054 items = AvFILLp(av) + 1;
3280af22
NIS
2055 PL_stack_sp++;
2056 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2057 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2058 PL_stack_sp += items;
1fa4e549 2059 }
6b35e009 2060 if (CxTYPE(cx) == CXt_SUB &&
b150fb22 2061 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
a0d0e21e 2062 SvREFCNT_dec(cx->blk_sub.cv);
3280af22 2063 oldsave = PL_scopestack[PL_scopestack_ix - 1];
a0d0e21e
LW
2064 LEAVE_SCOPE(oldsave);
2065
2066 /* Now do some callish stuff. */
2067 SAVETMPS;
2068 if (CvXSUB(cv)) {
67caa1fe 2069#ifdef PERL_XSUB_OLDSTYLE
a0d0e21e 2070 if (CvOLDSTYLE(cv)) {
20ce7b12 2071 I32 (*fp3)(int,int,int);
924508f0
GS
2072 while (SP > mark) {
2073 SP[1] = SP[0];
2074 SP--;
a0d0e21e 2075 }
20ce7b12 2076 fp3 = (I32(*)(int,int,int)))CvXSUB(cv;
ecfc5424 2077 items = (*fp3)(CvXSUBANY(cv).any_i32,
3280af22 2078 mark - PL_stack_base + 1,
ecfc5424 2079 items);
3280af22 2080 SP = PL_stack_base + items;
a0d0e21e 2081 }
67caa1fe
GS
2082 else
2083#endif /* PERL_XSUB_OLDSTYLE */
2084 {
1fa4e549
AD
2085 SV **newsp;
2086 I32 gimme;
2087
3280af22 2088 PL_stack_sp--; /* There is no cv arg. */
1fa4e549
AD
2089 /* Push a mark for the start of arglist */
2090 PUSHMARK(mark);
0cb96387 2091 (void)(*CvXSUB(cv))(aTHXo_ cv);
1fa4e549 2092 /* Pop the current context like a decent sub should */
3280af22 2093 POPBLOCK(cx, PL_curpm);
1fa4e549 2094 /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
a0d0e21e
LW
2095 }
2096 LEAVE;
2097 return pop_return();
2098 }
2099 else {
2100 AV* padlist = CvPADLIST(cv);
2101 SV** svp = AvARRAY(padlist);
6b35e009 2102 if (CxTYPE(cx) == CXt_EVAL) {
3280af22
NIS
2103 PL_in_eval = cx->blk_eval.old_in_eval;
2104 PL_eval_root = cx->blk_eval.old_eval_root;
b150fb22
RH
2105 cx->cx_type = CXt_SUB;
2106 cx->blk_sub.hasargs = 0;
2107 }
a0d0e21e
LW
2108 cx->blk_sub.cv = cv;
2109 cx->blk_sub.olddepth = CvDEPTH(cv);
2110 CvDEPTH(cv)++;
2111 if (CvDEPTH(cv) < 2)
2112 (void)SvREFCNT_inc(cv);
2113 else { /* save temporaries on recursion? */
599cee73 2114 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
44a8e56a 2115 sub_crush_depth(cv);
93965878 2116 if (CvDEPTH(cv) > AvFILLp(padlist)) {
a0d0e21e 2117 AV *newpad = newAV();
4aa0a1f7 2118 SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
93965878 2119 I32 ix = AvFILLp((AV*)svp[1]);
a0d0e21e 2120 svp = AvARRAY(svp[0]);
748a9306 2121 for ( ;ix > 0; ix--) {
3280af22 2122 if (svp[ix] != &PL_sv_undef) {
748a9306 2123 char *name = SvPVX(svp[ix]);
5f05dabc
PP
2124 if ((SvFLAGS(svp[ix]) & SVf_FAKE)
2125 || *name == '&')
2126 {
2127 /* outer lexical or anon code */
748a9306 2128 av_store(newpad, ix,
4aa0a1f7 2129 SvREFCNT_inc(oldpad[ix]) );
748a9306
LW
2130 }
2131 else { /* our own lexical */
2132 if (*name == '@')
2133 av_store(newpad, ix, sv = (SV*)newAV());
2134 else if (*name == '%')
2135 av_store(newpad, ix, sv = (SV*)newHV());
2136 else
2137 av_store(newpad, ix, sv = NEWSV(0,0));
2138 SvPADMY_on(sv);
2139 }
a0d0e21e 2140 }
743e66e6
GS
2141 else if (IS_PADGV(oldpad[ix])) {
2142 av_store(newpad, ix, sv = SvREFCNT_inc(oldpad[ix]));
2143 }
a0d0e21e 2144 else {
748a9306 2145 av_store(newpad, ix, sv = NEWSV(0,0));
a0d0e21e
LW
2146 SvPADTMP_on(sv);
2147 }
2148 }
2149 if (cx->blk_sub.hasargs) {
2150 AV* av = newAV();
2151 av_extend(av, 0);
2152 av_store(newpad, 0, (SV*)av);
2153 AvFLAGS(av) = AVf_REIFY;
2154 }
2155 av_store(padlist, CvDEPTH(cv), (SV*)newpad);
93965878 2156 AvFILLp(padlist) = CvDEPTH(cv);
a0d0e21e
LW
2157 svp = AvARRAY(padlist);
2158 }
2159 }
6d4ff0d2
MB
2160#ifdef USE_THREADS
2161 if (!cx->blk_sub.hasargs) {
533c011a 2162 AV* av = (AV*)PL_curpad[0];
6d4ff0d2 2163
93965878 2164 items = AvFILLp(av) + 1;
6d4ff0d2
MB
2165 if (items) {
2166 /* Mark is at the end of the stack. */
924508f0
GS
2167 EXTEND(SP, items);
2168 Copy(AvARRAY(av), SP + 1, items, SV*);
2169 SP += items;
6d4ff0d2
MB
2170 PUTBACK ;
2171 }
2172 }
2173#endif /* USE_THREADS */
3280af22
NIS
2174 SAVESPTR(PL_curpad);
2175 PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
6d4ff0d2
MB
2176#ifndef USE_THREADS
2177 if (cx->blk_sub.hasargs)
2178#endif /* USE_THREADS */
2179 {
3280af22 2180 AV* av = (AV*)PL_curpad[0];
a0d0e21e
LW
2181 SV** ary;
2182
6d4ff0d2 2183#ifndef USE_THREADS
3280af22
NIS
2184 cx->blk_sub.savearray = GvAV(PL_defgv);
2185 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
6d4ff0d2
MB
2186#endif /* USE_THREADS */
2187 cx->blk_sub.argarray = av;
a0d0e21e
LW
2188 ++mark;
2189
2190 if (items >= AvMAX(av) + 1) {
2191 ary = AvALLOC(av);
2192 if (AvARRAY(av) != ary) {
2193 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2194 SvPVX(av) = (char*)ary;
2195 }
2196 if (items >= AvMAX(av) + 1) {
2197 AvMAX(av) = items - 1;
2198 Renew(ary,items+1,SV*);
2199 AvALLOC(av) = ary;
2200 SvPVX(av) = (char*)ary;
2201 }
2202 }
2203 Copy(mark,AvARRAY(av),items,SV*);
93965878 2204 AvFILLp(av) = items - 1;
d8b46c1b 2205 assert(!AvREAL(av));
a0d0e21e
LW
2206 while (items--) {
2207 if (*mark)
2208 SvTEMP_off(*mark);
2209 mark++;
2210 }
2211 }
491527d0 2212 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
44a8e56a
PP
2213 /*
2214 * We do not care about using sv to call CV;
2215 * it's for informational purposes only.
2216 */
3280af22 2217 SV *sv = GvSV(PL_DBsub);
491527d0
GS
2218 CV *gotocv;
2219
2220 if (PERLDB_SUB_NN) {
56431972 2221 SvIVX(sv) = PTR2IV(cv); /* Already upgraded, saved */
491527d0
GS
2222 } else {
2223 save_item(sv);
2224 gv_efullname3(sv, CvGV(cv), Nullch);
2225 }
2226 if ( PERLDB_GOTO
864dbfa3 2227 && (gotocv = get_cv("DB::goto", FALSE)) ) {
3280af22 2228 PUSHMARK( PL_stack_sp );
864dbfa3 2229 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
3280af22 2230 PL_stack_sp--;
491527d0 2231 }
1ce6579f 2232 }
a0d0e21e
LW
2233 RETURNOP(CvSTART(cv));
2234 }
2235 }
1614b0e3 2236 else {
2d8e6c8d 2237 label = SvPV(sv,n_a);
1614b0e3 2238 if (!(do_dump || *label))
cea2e8a9 2239 DIE(aTHX_ must_have_label);
1614b0e3 2240 }
a0d0e21e 2241 }
533c011a 2242 else if (PL_op->op_flags & OPf_SPECIAL) {
a0d0e21e 2243 if (! do_dump)
cea2e8a9 2244 DIE(aTHX_ must_have_label);
a0d0e21e
LW
2245 }
2246 else
2247 label = cPVOP->op_pv;
2248
2249 if (label && *label) {
2250 OP *gotoprobe = 0;
2251
2252 /* find label */
2253
3280af22 2254 PL_lastgotoprobe = 0;
a0d0e21e
LW
2255 *enterops = 0;
2256 for (ix = cxstack_ix; ix >= 0; ix--) {
2257 cx = &cxstack[ix];
6b35e009 2258 switch (CxTYPE(cx)) {
a0d0e21e 2259 case CXt_EVAL:
3280af22 2260 gotoprobe = PL_eval_root; /* XXX not good for nested eval */
a0d0e21e
LW
2261 break;
2262 case CXt_LOOP:
2263 gotoprobe = cx->blk_oldcop->op_sibling;
2264 break;
2265 case CXt_SUBST:
2266 continue;
2267 case CXt_BLOCK:
2268 if (ix)
2269 gotoprobe = cx->blk_oldcop->op_sibling;
2270 else
3280af22 2271 gotoprobe = PL_main_root;
a0d0e21e 2272 break;
b3933176
CS
2273 case CXt_SUB:
2274 if (CvDEPTH(cx->blk_sub.cv)) {
2275 gotoprobe = CvROOT(cx->blk_sub.cv);
2276 break;
2277 }
2278 /* FALL THROUGH */
0a753a76 2279 case CXt_NULL:
cea2e8a9 2280 DIE(aTHX_ "Can't \"goto\" outside a block");
a0d0e21e
LW
2281 default:
2282 if (ix)
cea2e8a9 2283 DIE(aTHX_ "panic: goto");
3280af22 2284 gotoprobe = PL_main_root;
a0d0e21e
LW
2285 break;
2286 }
fc36a67e
PP
2287 retop = dofindlabel(gotoprobe, label,
2288 enterops, enterops + GOTO_DEPTH);
a0d0e21e
LW
2289 if (retop)
2290 break;
3280af22 2291 PL_lastgotoprobe = gotoprobe;
a0d0e21e
LW
2292 }
2293 if (!retop)
cea2e8a9 2294 DIE(aTHX_ "Can't find label %s", label);
a0d0e21e
LW
2295
2296 /* pop unwanted frames */
2297
2298 if (ix < cxstack_ix) {
2299 I32 oldsave;
2300
2301 if (ix < 0)
2302 ix = 0;
2303 dounwind(ix);
2304 TOPBLOCK(cx);
3280af22 2305 oldsave = PL_scopestack[PL_scopestack_ix];
a0d0e21e
LW
2306 LEAVE_SCOPE(oldsave);
2307 }
2308
2309 /* push wanted frames */
2310
748a9306 2311 if (*enterops && enterops[1]) {
533c011a 2312 OP *oldop = PL_op;
748a9306 2313 for (ix = 1; enterops[ix]; ix++) {
533c011a 2314 PL_op = enterops[ix];
84902520
TB
2315 /* Eventually we may want to stack the needed arguments
2316 * for each op. For now, we punt on the hard ones. */
533c011a 2317 if (PL_op->op_type == OP_ENTERITER)
cea2e8a9 2318 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop",
84902520 2319 label);
fc0dc3b3 2320 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
a0d0e21e 2321 }
533c011a 2322 PL_op = oldop;
a0d0e21e
LW
2323 }
2324 }
2325
2326 if (do_dump) {
a5f75d66 2327#ifdef VMS
6b88bc9c 2328 if (!retop) retop = PL_main_start;
a5f75d66 2329#endif
3280af22
NIS
2330 PL_restartop = retop;
2331 PL_do_undump = TRUE;
a0d0e21e
LW
2332
2333 my_unexec();
2334
3280af22
NIS
2335 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2336 PL_do_undump = FALSE;
a0d0e21e
LW
2337 }
2338
2339 RETURNOP(retop);
2340}
2341
2342PP(pp_exit)
2343{
4e35701f 2344 djSP;
a0d0e21e
LW
2345 I32 anum;
2346
2347 if (MAXARG < 1)
2348 anum = 0;
ff0cee69 2349 else {
a0d0e21e 2350 anum = SvIVx(POPs);
ff0cee69
PP
2351#ifdef VMSISH_EXIT
2352 if (anum == 1 && VMSISH_EXIT)
2353 anum = 0;
2354#endif
2355 }
a0d0e21e 2356 my_exit(anum);
3280af22 2357 PUSHs(&PL_sv_undef);
a0d0e21e
LW
2358 RETURN;
2359}
2360
2361#ifdef NOTYET
2362PP(pp_nswitch)
2363{
4e35701f 2364 djSP;
65202027 2365 NV value = SvNVx(GvSV(cCOP->cop_gv));
a0d0e21e
LW
2366 register I32 match = I_32(value);
2367
2368 if (value < 0.0) {
65202027 2369 if (((NV)match) > value)
a0d0e21e
LW
2370 --match; /* was fractional--truncate other way */
2371 }
2372 match -= cCOP->uop.scop.scop_offset;
2373 if (match < 0)
2374 match = 0;
2375 else if (match > cCOP->uop.scop.scop_max)
2376 match = cCOP->uop.scop.scop_max;
6b88bc9c
GS
2377 PL_op = cCOP->uop.scop.scop_next[match];
2378 RETURNOP(PL_op);
a0d0e21e
LW
2379}
2380
2381PP(pp_cswitch)
2382{
4e35701f 2383 djSP;
a0d0e21e
LW
2384 register I32 match;
2385
6b88bc9c
GS
2386 if (PL_multiline)
2387 PL_op = PL_op->op_next; /* can't assume anything */
a0d0e21e 2388 else {
2d8e6c8d
GS
2389 STRLEN n_a;
2390 match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255;
a0d0e21e
LW
2391 match -= cCOP->uop.scop.scop_offset;
2392 if (match < 0)
2393 match = 0;
2394 else if (match > cCOP->uop.scop.scop_max)
2395 match = cCOP->uop.scop.scop_max;
6b88bc9c 2396 PL_op = cCOP->uop.scop.scop_next[match];
a0d0e21e 2397 }
6b88bc9c 2398 RETURNOP(PL_op);
a0d0e21e
LW
2399}
2400#endif
2401
2402/* Eval. */
2403
0824fdcb 2404STATIC void
cea2e8a9 2405S_save_lines(pTHX_ AV *array, SV *sv)
a0d0e21e
LW
2406{
2407 register char *s = SvPVX(sv);
2408 register char *send = SvPVX(sv) + SvCUR(sv);
2409 register char *t;
2410 register I32 line = 1;
2411
2412 while (s && s < send) {
2413 SV *tmpstr = NEWSV(85,0);
2414
2415 sv_upgrade(tmpstr, SVt_PVMG);
2416 t = strchr(s, '\n');
2417 if (t)
2418 t++;
2419 else
2420 t = send;
2421
2422 sv_setpvn(tmpstr, s, t - s);
2423 av_store(array, line++, tmpstr);
2424 s = t;
2425 }
2426}
2427
312caa8e 2428STATIC void *
cea2e8a9 2429S_docatch_body(pTHX_ va_list args)
312caa8e 2430{
cea2e8a9 2431 CALLRUNOPS(aTHX);
312caa8e
CS
2432 return NULL;
2433}
2434
0824fdcb 2435STATIC OP *
cea2e8a9 2436S_docatch(pTHX_ OP *o)
1e422769 2437{
e858de61 2438 dTHR;
6224f72b 2439 int ret;
533c011a 2440 OP *oldop = PL_op;
0cdb2077 2441 volatile PERL_SI *cursi = PL_curstackinfo;
db36c5a1 2442 dJMPENV;
1e422769 2443
1e422769 2444#ifdef DEBUGGING
54310121 2445 assert(CATCH_GET == TRUE);
1e422769 2446#endif
312caa8e
CS
2447 PL_op = o;
2448 redo_body:
db36c5a1 2449 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_docatch_body));
6224f72b 2450 switch (ret) {
312caa8e
CS
2451 case 0:
2452 break;
2453 case 3:
0cdb2077 2454 if (PL_restartop && cursi == PL_curstackinfo) {
312caa8e
CS
2455 PL_op = PL_restartop;
2456 PL_restartop = 0;
2457 goto redo_body;
2458 }
2459 /* FALL THROUGH */
2460 default:
533c011a 2461 PL_op = oldop;
6224f72b 2462 JMPENV_JUMP(ret);
1e422769 2463 /* NOTREACHED */
1e422769 2464 }
533c011a 2465 PL_op = oldop;
1e422769
PP
2466 return Nullop;
2467}
2468
c277df42 2469OP *
864dbfa3 2470Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, AV** avp)
c277df42
IZ
2471/* sv Text to convert to OP tree. */
2472/* startop op_free() this to undo. */
2473/* code Short string id of the caller. */
2474{
2475 dSP; /* Make POPBLOCK work. */
2476 PERL_CONTEXT *cx;
2477 SV **newsp;
f987c7de 2478 I32 gimme = 0; /* SUSPECT - INITIALZE TO WHAT? NI-S */
c277df42
IZ
2479 I32 optype;
2480 OP dummy;
533c011a 2481 OP *oop = PL_op, *rop;
c277df42
IZ
2482 char tmpbuf[TYPE_DIGITS(long) + 12 + 10];
2483 char *safestr;
2484
2485 ENTER;
2486 lex_start(sv);
2487 SAVETMPS;
2488 /* switch to eval mode */
2489
cbce877f
IZ
2490 if (PL_curcop == &PL_compiling) {
2491 SAVESPTR(PL_compiling.cop_stash);
2492 PL_compiling.cop_stash = PL_curstash;
2493 }
cc49e20b 2494 SAVESPTR(CopFILEGV(&PL_compiling));
3280af22
NIS
2495 SAVEI16(PL_compiling.cop_line);
2496 sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
cc49e20b 2497 CopFILEGV_set(&PL_compiling, gv_fetchfile(tmpbuf+2));
3280af22 2498 PL_compiling.cop_line = 1;
c277df42
IZ
2499 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2500 deleting the eval's FILEGV from the stash before gv_check() runs
2501 (i.e. before run-time proper). To work around the coredump that
2502 ensues, we always turn GvMULTI_on for any globals that were
2503 introduced within evals. See force_ident(). GSAR 96-10-12 */
2504 safestr = savepv(tmpbuf);
3280af22 2505 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
b3ac6de7 2506 SAVEHINTS();
d1ca3daa 2507#ifdef OP_IN_REGISTER
6b88bc9c 2508 PL_opsave = op;
d1ca3daa 2509#else
533c011a 2510 SAVEPPTR(PL_op);
d1ca3daa 2511#endif
3280af22 2512 PL_hints = 0;
c277df42 2513
533c011a 2514 PL_op = &dummy;
13b51b79 2515 PL_op->op_type = OP_ENTEREVAL;
533c011a 2516 PL_op->op_flags = 0; /* Avoid uninit warning. */
c277df42 2517 PUSHBLOCK(cx, CXt_EVAL, SP);
cc49e20b 2518 PUSHEVAL(cx, 0, Nullgv);
c277df42 2519 rop = doeval(G_SCALAR, startop);
13b51b79 2520 POPBLOCK(cx,PL_curpm);
e84b9f1f 2521 POPEVAL(cx);
c277df42
IZ
2522
2523 (*startop)->op_type = OP_NULL;
22c35a8c 2524 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
c277df42 2525 lex_end();
3280af22 2526 *avp = (AV*)SvREFCNT_inc(PL_comppad);
c277df42 2527 LEAVE;
13b51b79 2528 if (PL_curcop == &PL_compiling)
a0ed51b3 2529 PL_compiling.op_private = PL_hints;
d1ca3daa 2530#ifdef OP_IN_REGISTER
6b88bc9c 2531 op = PL_opsave;
d1ca3daa 2532#endif
c277df42
IZ
2533 return rop;
2534}
2535
0f15f207 2536/* With USE_THREADS, eval_owner must be held on entry to doeval */
0824fdcb 2537STATIC OP *
cea2e8a9 2538S_doeval(pTHX_ int gimme, OP** startop)
a0d0e21e
LW
2539{
2540 dSP;
533c011a 2541 OP *saveop = PL_op;
a0d0e21e 2542 HV *newstash;
ff3ff8d1 2543 CV *caller;
748a9306 2544 AV* comppadlist;
67a38de0 2545 I32 i;
a0d0e21e 2546
faef0170 2547 PL_in_eval = EVAL_INEVAL;
a0d0e21e 2548
1ce6579f
PP
2549 PUSHMARK(SP);
2550
a0d0e21e
LW
2551 /* set up a scratch pad */
2552
3280af22
NIS
2553 SAVEI32(PL_padix);
2554 SAVESPTR(PL_curpad);
2555 SAVESPTR(PL_comppad);
2556 SAVESPTR(PL_comppad_name);
2557 SAVEI32(PL_comppad_name_fill);
2558 SAVEI32(PL_min_intro_pending);
2559 SAVEI32(PL_max_intro_pending);
748a9306 2560
3280af22 2561 caller = PL_compcv;
6b35e009 2562 for (i = cxstack_ix - 1; i >= 0; i--) {
67a38de0 2563 PERL_CONTEXT *cx = &cxstack[i];
6b35e009 2564 if (CxTYPE(cx) == CXt_EVAL)
67a38de0 2565 break;
6b35e009 2566 else if (CxTYPE(cx) == CXt_SUB) {
67a38de0
NIS
2567 caller = cx->blk_sub.cv;
2568 break;
2569 }
2570 }
2571
3280af22
NIS
2572 SAVESPTR(PL_compcv);
2573 PL_compcv = (CV*)NEWSV(1104,0);
2574 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
1aff0e91 2575 CvEVAL_on(PL_compcv);
11343788 2576#ifdef USE_THREADS
533c011a
NIS
2577 CvOWNER(PL_compcv) = 0;
2578 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
2579 MUTEX_INIT(CvMUTEXP(PL_compcv));
11343788 2580#endif /* USE_THREADS */
748a9306 2581
3280af22
NIS
2582 PL_comppad = newAV();
2583 av_push(PL_comppad, Nullsv);
2584 PL_curpad = AvARRAY(PL_comppad);
2585 PL_comppad_name = newAV();
2586 PL_comppad_name_fill = 0;
2587 PL_min_intro_pending = 0;
2588 PL_padix = 0;
11343788 2589#ifdef USE_THREADS
79cb57f6 2590 av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
533c011a
NIS
2591 PL_curpad[0] = (SV*)newAV();
2592 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
11343788 2593#endif /* USE_THREADS */
a0d0e21e 2594
748a9306
LW
2595 comppadlist = newAV();
2596 AvREAL_off(comppadlist);
3280af22
NIS
2597 av_store(comppadlist, 0, (SV*)PL_comppad_name);
2598 av_store(comppadlist, 1, (SV*)PL_comppad);
2599 CvPADLIST(PL_compcv) = comppadlist;
2c05e328 2600
c277df42 2601 if (!saveop || saveop->op_type != OP_REQUIRE)
3280af22 2602 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(caller);
07055b4c 2603
3280af22 2604 SAVEFREESV(PL_compcv);
748a9306 2605
a0d0e21e
LW
2606 /* make sure we compile in the right package */
2607
3280af22
NIS
2608 newstash = PL_curcop->cop_stash;
2609 if (PL_curstash != newstash) {
2610 SAVESPTR(PL_curstash);
2611 PL_curstash = newstash;
a0d0e21e 2612 }
3280af22
NIS
2613 SAVESPTR(PL_beginav);
2614 PL_beginav = newAV();
2615 SAVEFREESV(PL_beginav);
a0d0e21e
LW
2616
2617 /* try to compile it */
2618
3280af22
NIS
2619 PL_eval_root = Nullop;
2620 PL_error_count = 0;
2621 PL_curcop = &PL_compiling;
2622 PL_curcop->cop_arybase = 0;
2623 SvREFCNT_dec(PL_rs);
79cb57f6 2624 PL_rs = newSVpvn("\n", 1);
c277df42 2625 if (saveop && saveop->op_flags & OPf_SPECIAL)
faef0170 2626 PL_in_eval |= EVAL_KEEPERR;
1ce6579f 2627 else
38a03e6e 2628 sv_setpv(ERRSV,"");
3280af22 2629 if (yyparse() || PL_error_count || !PL_eval_root) {
a0d0e21e
LW
2630 SV **newsp;
2631 I32 gimme;
c09156bb 2632 PERL_CONTEXT *cx;
c277df42 2633 I32 optype = 0; /* Might be reset by POPEVAL. */
2d8e6c8d 2634 STRLEN n_a;
097ee67d 2635
533c011a 2636 PL_op = saveop;
3280af22
NIS
2637 if (PL_eval_root) {
2638 op_free(PL_eval_root);
2639 PL_eval_root = Nullop;
a0d0e21e 2640 }
3280af22 2641 SP = PL_stack_base + POPMARK; /* pop original mark */
c277df42 2642 if (!startop) {
3280af22 2643 POPBLOCK(cx,PL_curpm);
c277df42
IZ
2644 POPEVAL(cx);
2645 pop_return();
2646 }
a0d0e21e
LW
2647 lex_end();
2648 LEAVE;
7a2e2cd6 2649 if (optype == OP_REQUIRE) {
2d8e6c8d 2650 char* msg = SvPVx(ERRSV, n_a);
5a844595
GS
2651 DIE(aTHX_ "%sCompilation failed in require",
2652 *msg ? msg : "Unknown error\n");
2653 }
2654 else if (startop) {
2d8e6c8d 2655 char* msg = SvPVx(ERRSV, n_a);
c277df42 2656
3280af22 2657 POPBLOCK(cx,PL_curpm);
c277df42 2658 POPEVAL(cx);
5a844595
GS
2659 Perl_croak(aTHX_ "%sCompilation failed in regexp",
2660 (*msg ? msg : "Unknown error\n"));
7a2e2cd6 2661 }
3280af22
NIS
2662 SvREFCNT_dec(PL_rs);
2663 PL_rs = SvREFCNT_inc(PL_nrs);
f2134d95 2664#ifdef USE_THREADS
533c011a
NIS
2665 MUTEX_LOCK(&PL_eval_mutex);
2666 PL_eval_owner = 0;
2667 COND_SIGNAL(&PL_eval_cond);
2668 MUTEX_UNLOCK(&PL_eval_mutex);
f2134d95 2669#endif /* USE_THREADS */
a0d0e21e
LW
2670 RETPUSHUNDEF;
2671 }
3280af22
NIS
2672 SvREFCNT_dec(PL_rs);
2673 PL_rs = SvREFCNT_inc(PL_nrs);
2674 PL_compiling.cop_line = 0;
c277df42 2675 if (startop) {
3280af22
NIS
2676 *startop = PL_eval_root;
2677 SvREFCNT_dec(CvOUTSIDE(PL_compcv));
2678 CvOUTSIDE(PL_compcv) = Nullcv;
c277df42 2679 } else
3280af22 2680 SAVEFREEOP(PL_eval_root);
54310121 2681 if (gimme & G_VOID)
3280af22 2682 scalarvoid(PL_eval_root);
54310121 2683 else if (gimme & G_ARRAY)
3280af22 2684 list(PL_eval_root);
a0d0e21e 2685 else
3280af22 2686 scalar(PL_eval_root);
a0d0e21e
LW
2687
2688 DEBUG_x(dump_eval());
2689
55497cff 2690 /* Register with debugger: */
84902520 2691 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
864dbfa3 2692 CV *cv = get_cv("DB::postponed", FALSE);
55497cff
PP
2693 if (cv) {
2694 dSP;
924508f0 2695 PUSHMARK(SP);
cc49e20b 2696 XPUSHs((SV*)CopFILEGV(&PL_compiling));
55497cff 2697 PUTBACK;
864dbfa3 2698 call_sv((SV*)cv, G_DISCARD);
55497cff
PP
2699 }
2700 }
2701
a0d0e21e
LW
2702 /* compiled okay, so do it */
2703
3280af22
NIS
2704 CvDEPTH(PL_compcv) = 1;
2705 SP = PL_stack_base + POPMARK; /* pop original mark */
533c011a 2706 PL_op = saveop; /* The caller may need it. */
b35b2403 2707#ifdef USE_THREADS
533c011a
NIS
2708 MUTEX_LOCK(&PL_eval_mutex);
2709 PL_eval_owner = 0;
2710 COND_SIGNAL(&PL_eval_cond);
2711 MUTEX_UNLOCK(&PL_eval_mutex);
b35b2403 2712#endif /* USE_THREADS */
5dc0d613 2713
3280af22 2714 RETURNOP(PL_eval_start);
a0d0e21e
LW
2715}
2716
a6c40364 2717STATIC PerlIO *
cea2e8a9 2718S_doopen_pmc(pTHX_ const char *name, const char *mode)
b295d113
TH
2719{
2720 STRLEN namelen = strlen(name);
2721 PerlIO *fp;
2722
7894fbab 2723 if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
cea2e8a9 2724 SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
b295d113
TH
2725 char *pmc = SvPV_nolen(pmcsv);
2726 Stat_t pmstat;
a6c40364
GS
2727 Stat_t pmcstat;
2728 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
b295d113 2729 fp = PerlIO_open(name, mode);
a6c40364
GS
2730 }
2731 else {
b295d113 2732 if (PerlLIO_stat(name, &pmstat) < 0 ||
a6c40364
GS
2733 pmstat.st_mtime < pmcstat.st_mtime)
2734 {
2735 fp = PerlIO_open(pmc, mode);
2736 }
2737 else {
2738 fp = PerlIO_open(name, mode);
2739 }
b295d113 2740 }
a6c40364
GS
2741 SvREFCNT_dec(pmcsv);
2742 }
2743 else {
2744 fp = PerlIO_open(name, mode);
b295d113 2745 }
b295d113
TH
2746 return fp;
2747}
2748
a0d0e21e
LW
2749PP(pp_require)
2750{
4e35701f 2751 djSP;
c09156bb 2752 register PERL_CONTEXT *cx;
a0d0e21e
LW
2753 SV *sv;
2754 char *name;
6132ea6c 2755 STRLEN len;
46fc3d4c
PP
2756 char *tryname;
2757 SV *namesv = Nullsv;
a0d0e21e
LW
2758 SV** svp;
2759 I32 gimme = G_SCALAR;
760ac839 2760 PerlIO *tryrsfp = 0;
2d8e6c8d 2761 STRLEN n_a;
bbed91b5
KF
2762 int filter_has_file = 0;
2763 GV *filter_child_proc = 0;
2764 SV *filter_state = 0;
2765 SV *filter_sub = 0;
a0d0e21e
LW
2766
2767 sv = POPs;
4633a7c4 2768 if (SvNIOKp(sv) && !SvPOKp(sv)) {
097ee67d 2769 if (Atof(PL_patchlevel) + 0.00000999 < SvNV(sv))
cea2e8a9 2770 DIE(aTHX_ "Perl %s required--this is only version %s, stopped",
2d8e6c8d 2771 SvPV(sv,n_a),PL_patchlevel);
a0d0e21e
LW
2772 RETPUSHYES;
2773 }
6132ea6c
GS
2774 name = SvPV(sv, len);
2775 if (!(name && len > 0 && *name))
cea2e8a9 2776 DIE(aTHX_ "Null filename used");
4633a7c4 2777 TAINT_PROPER("require");
533c011a 2778 if (PL_op->op_type == OP_REQUIRE &&
3280af22
NIS
2779 (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0)) &&
2780 *svp != &PL_sv_undef)
a0d0e21e
LW
2781 RETPUSHYES;
2782
2783 /* prepare to compile file */
2784
46fc3d4c
PP
2785 if (*name == '/' ||
2786 (*name == '.' &&
2787 (name[1] == '/' ||
2788 (name[1] == '.' && name[2] == '/')))
4633a7c4 2789#ifdef DOSISH
46fc3d4c 2790 || (name[0] && name[1] == ':')
4633a7c4 2791#endif
ba42ef2f
WJ
2792#ifdef WIN32
2793 || (name[0] == '\\' && name[1] == '\\') /* UNC path */
2794#endif
748a9306 2795#ifdef VMS
46fc3d4c
PP
2796 || (strchr(name,':') || ((*name == '[' || *name == '<') &&
2797 (isALNUM(name[1]) || strchr("$-_]>",name[1]))))
748a9306
LW
2798#endif
2799 )
a0d0e21e 2800 {
46fc3d4c 2801 tryname = name;
a6c40364 2802 tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE);
a0d0e21e
LW
2803 }
2804 else {
3280af22 2805 AV *ar = GvAVn(PL_incgv);
a0d0e21e 2806 I32 i;
748a9306 2807#ifdef VMS
46fc3d4c
PP
2808 char *unixname;
2809 if ((unixname = tounixspec(name, Nullch)) != Nullch)
2810#endif
2811 {
2812 namesv = NEWSV(806, 0);
2813 for (i = 0; i <= AvFILL(ar); i++) {
bbed91b5
KF
2814 SV *dirsv = *av_fetch(ar, i, TRUE);
2815
2816 if (SvROK(dirsv)) {
2817 int count;
2818 SV *loader = dirsv;
2819
2820 if (SvTYPE(SvRV(loader)) == SVt_PVAV) {
2821 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
2822 }
2823
b900a521
JH
2824 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
2825 PTR2UV(SvANY(loader)), name);
bbed91b5
KF
2826 tryname = SvPVX(namesv);
2827 tryrsfp = 0;
2828
2829 ENTER;
2830 SAVETMPS;
2831 EXTEND(SP, 2);
2832
2833 PUSHMARK(SP);
2834 PUSHs(dirsv);
2835 PUSHs(sv);
2836 PUTBACK;
2837 count = call_sv(loader, G_ARRAY);
2838 SPAGAIN;
2839
2840 if (count > 0) {
2841 int i = 0;
2842 SV *arg;
2843
2844 SP -= count - 1;
2845 arg = SP[i++];
2846
2847 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
2848 arg = SvRV(arg);
2849 }
2850
2851 if (SvTYPE(arg) == SVt_PVGV) {
2852 IO *io = GvIO((GV *)arg);
2853
2854 ++filter_has_file;
2855
2856 if (io) {
2857 tryrsfp = IoIFP(io);
2858 if (IoTYPE(io) == '|') {
2859 /* reading from a child process doesn't
2860 nest -- when returning from reading
2861 the inner module, the outer one is
2862 unreadable (closed?) I've tried to
2863 save the gv to manage the lifespan of
2864 the pipe, but this didn't help. XXX */
2865 filter_child_proc = (GV *)arg;
520c758a 2866 (void)SvREFCNT_inc(filter_child_proc);
bbed91b5
KF
2867 }
2868 else {
2869 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
2870 PerlIO_close(IoOFP(io));
2871 }
2872 IoIFP(io) = Nullfp;
2873 IoOFP(io) = Nullfp;
2874 }
2875 }
2876
2877 if (i < count) {
2878 arg = SP[i++];
2879 }
2880 }
2881
2882 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
2883 filter_sub = arg;
520c758a 2884 (void)SvREFCNT_inc(filter_sub);
bbed91b5
KF
2885
2886 if (i < count) {
2887 filter_state = SP[i];
520c758a 2888 (void)SvREFCNT_inc(filter_state);
bbed91b5
KF
2889 }
2890
2891 if (tryrsfp == 0) {
2892 tryrsfp = PerlIO_open("/dev/null",
2893 PERL_SCRIPT_MODE);
2894 }
2895 }
2896 }
2897
2898 PUTBACK;
2899 FREETMPS;
2900 LEAVE;
2901
2902 if (tryrsfp) {
2903 break;
2904 }
2905
2906 filter_has_file = 0;
2907 if (filter_child_proc) {
2908 SvREFCNT_dec(filter_child_proc);
2909 filter_child_proc = 0;
2910 }
2911 if (filter_state) {
2912 SvREFCNT_dec(filter_state);
2913 filter_state = 0;
2914 }
2915 if (filter_sub) {
2916 SvREFCNT_dec(filter_sub);
2917 filter_sub = 0;
2918 }
2919 }
2920 else {
2921 char *dir = SvPVx(dirsv, n_a);
46fc3d4c 2922#ifdef VMS
bbed91b5
KF
2923 char *unixdir;
2924 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
2925 continue;
2926 sv_setpv(namesv, unixdir);
2927 sv_catpv(namesv, unixname);
748a9306 2928#else
bbed91b5 2929 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
748a9306 2930#endif
bbed91b5
KF
2931 TAINT_PROPER("require");
2932 tryname = SvPVX(namesv);
2933 tryrsfp = doopen_pmc(tryname, PERL_SCRIPT_MODE);
2934 if (tryrsfp) {
2935 if (tryname[0] == '.' && tryname[1] == '/')
2936 tryname += 2;
2937 break;
2938 }
46fc3d4c 2939 }
a0d0e21e
LW
2940 }
2941 }
2942 }
cc49e20b
GS
2943 SAVESPTR(CopFILEGV(&PL_compiling));
2944 CopFILEGV_set(&PL_compiling, gv_fetchfile(tryrsfp ? tryname : name));
46fc3d4c 2945 SvREFCNT_dec(namesv);
a0d0e21e 2946 if (!tryrsfp) {
533c011a 2947 if (PL_op->op_type == OP_REQUIRE) {
ec889f3a
GS
2948 char *msgstr = name;
2949 if (namesv) { /* did we lookup @INC? */
2950 SV *msg = sv_2mortal(newSVpv(msgstr,0));
2951 SV *dirmsgsv = NEWSV(0, 0);
2952 AV *ar = GvAVn(PL_incgv);
2953 I32 i;
2954 sv_catpvn(msg, " in @INC", 8);
2955 if (instr(SvPVX(msg), ".h "))
2956 sv_catpv(msg, " (change .h to .ph maybe?)");
2957 if (instr(SvPVX(msg), ".ph "))
2958 sv_catpv(msg, " (did you run h2ph?)");
2959 sv_catpv(msg, " (@INC contains:");
2960 for (i = 0; i <= AvFILL(ar); i++) {
2961 char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
cea2e8a9 2962 Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
ec889f3a
GS
2963 sv_catsv(msg, dirmsgsv);
2964 }
2965 sv_catpvn(msg, ")", 1);
2966 SvREFCNT_dec(dirmsgsv);
2967 msgstr = SvPV_nolen(msg);
2683423c 2968 }
cea2e8a9 2969 DIE(aTHX_ "Can't locate %s", msgstr);
a0d0e21e
LW
2970 }
2971
2972 RETPUSHUNDEF;
2973 }
d8bfb8bd 2974 else
aba27d88 2975 SETERRNO(0, SS$_NORMAL);
a0d0e21e
LW
2976
2977 /* Assume success here to prevent recursive requirement. */
3280af22 2978 (void)hv_store(GvHVn(PL_incgv), name, strlen(name),
cc49e20b 2979 newSVsv(CopFILESV(&PL_compiling)), 0 );
a0d0e21e
LW
2980
2981 ENTER;
2982 SAVETMPS;
79cb57f6 2983 lex_start(sv_2mortal(newSVpvn("",0)));
b9d12d37
GS
2984 SAVEGENERICSV(PL_rsfp_filters);
2985 PL_rsfp_filters = Nullav;
e50aee73 2986
3280af22 2987 PL_rsfp = tryrsfp;
a0d0e21e
LW
2988 name = savepv(name);
2989 SAVEFREEPV(name);
b3ac6de7 2990 SAVEHINTS();
3280af22 2991 PL_hints = 0;
599cee73 2992 SAVEPPTR(PL_compiling.cop_warnings);
0453d815
PM
2993 if (PL_dowarn & G_WARN_ALL_ON)
2994 PL_compiling.cop_warnings = WARN_ALL ;
2995 else if (PL_dowarn & G_WARN_ALL_OFF)
2996 PL_compiling.cop_warnings = WARN_NONE ;
2997 else
2998 PL_compiling.cop_warnings = WARN_STD ;
a0d0e21e 2999
bbed91b5
KF
3000 if (filter_sub || filter_child_proc) {
3001 SV *datasv = filter_add(run_user_filter, Nullsv);
3002 IoLINES(datasv) = filter_has_file;
3003 IoFMT_GV(datasv) = (GV *)filter_child_proc;
3004 IoTOP_GV(datasv) = (GV *)filter_state;
3005 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3006 }
3007
3008 /* switch to eval mode */
533c011a 3009 push_return(PL_op->op_next);
a0d0e21e 3010 PUSHBLOCK(cx, CXt_EVAL, SP);
cc49e20b 3011 PUSHEVAL(cx, name, Nullgv);
a0d0e21e 3012
63eb823a 3013 SAVEI16(PL_compiling.cop_line);
3280af22 3014 PL_compiling.cop_line = 0;
a0d0e21e
LW
3015
3016 PUTBACK;
0f15f207 3017#ifdef USE_THREADS
533c011a
NIS
3018 MUTEX_LOCK(&PL_eval_mutex);
3019 if (PL_eval_owner && PL_eval_owner != thr)
3020 while (PL_eval_owner)
3021 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3022 PL_eval_owner = thr;
3023 MUTEX_UNLOCK(&PL_eval_mutex);
0f15f207 3024#endif /* USE_THREADS */
c277df42 3025 return DOCATCH(doeval(G_SCALAR, NULL));
a0d0e21e
LW
3026}
3027
3028PP(pp_dofile)
3029{
cea2e8a9 3030 return pp_require();
a0d0e21e
LW
3031}
3032
3033PP(pp_entereval)
3034{
4e35701f 3035 djSP;
c09156bb 3036 register PERL_CONTEXT *cx;
a0d0e21e 3037 dPOPss;
3280af22 3038 I32 gimme = GIMME_V, was = PL_sub_generation;
fc36a67e
PP
3039 char tmpbuf[TYPE_DIGITS(long) + 12];
3040 char *safestr;
a0d0e21e 3041 STRLEN len;
55497cff 3042 OP *ret;
a0d0e21e
LW
3043
3044 if (!SvPV(sv,len) || !len)
3045 RETPUSHUNDEF;
748a9306 3046 TAINT_PROPER("eval");
a0d0e21e
LW
3047
3048 ENTER;
a0d0e21e 3049 lex_start(sv);
748a9306 3050 SAVETMPS;
a0d0e21e
LW
3051
3052 /* switch to eval mode */
3053
cc49e20b 3054 SAVESPTR(CopFILEGV(&PL_compiling));
3280af22 3055 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
cc49e20b 3056 CopFILEGV_set(&PL_compiling, gv_fetchfile(tmpbuf+2));
3280af22 3057 PL_compiling.cop_line = 1;
55497cff
PP
3058 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3059 deleting the eval's FILEGV from the stash before gv_check() runs
3060 (i.e. before run-time proper). To work around the coredump that
3061 ensues, we always turn GvMULTI_on for any globals that were
3062 introduced within evals. See force_ident(). GSAR 96-10-12 */
3063 safestr = savepv(tmpbuf);
3280af22 3064 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
b3ac6de7 3065 SAVEHINTS();
533c011a 3066 PL_hints = PL_op->op_targ;
e24b16f9 3067 SAVEPPTR(PL_compiling.cop_warnings);
0453d815 3068 if (!specialWARN(PL_compiling.cop_warnings)) {
599cee73
PM
3069 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
3070 SAVEFREESV(PL_compiling.cop_warnings) ;
3071 }
a0d0e21e 3072
533c011a 3073 push_return(PL_op->op_next);
6b35e009 3074 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
cc49e20b 3075 PUSHEVAL(cx, 0, Nullgv);
a0d0e21e
LW
3076
3077 /* prepare to compile string */
3078
3280af22 3079 if (PERLDB_LINE && PL_curstash != PL_debstash)
cc49e20b 3080 save_lines(CopFILEAV(&PL_compiling), PL_linestr);
a0d0e21e 3081 PUTBACK;
0f15f207 3082#ifdef USE_THREADS
533c011a
NIS
3083 MUTEX_LOCK(&PL_eval_mutex);
3084 if (PL_eval_owner && PL_eval_owner != thr)
3085 while (PL_eval_owner)
3086 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3087 PL_eval_owner = thr;
3088 MUTEX_UNLOCK(&PL_eval_mutex);
0f15f207 3089#endif /* USE_THREADS */
c277df42 3090 ret = doeval(gimme, NULL);
3280af22 3091 if (PERLDB_INTER && was != PL_sub_generation /* Some subs defined here. */
533c011a 3092 && ret != PL_op->op_next) { /* Successive compilation. */
55497cff
PP
3093 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
3094 }
1e422769 3095 return DOCATCH(ret);
a0d0e21e
LW
3096}
3097
3098PP(pp_leaveeval)
3099{
4e35701f 3100 djSP;
a0d0e21e
LW
3101 register SV **mark;
3102 SV **newsp;
3103 PMOP *newpm;
3104 I32 gimme;
c09156bb 3105 register PERL_CONTEXT *cx;
a0d0e21e 3106 OP *retop;
533c011a 3107 U8 save_flags = PL_op -> op_flags;
a0d0e21e
LW
3108 I32 optype;
3109
3110 POPBLOCK(cx,newpm);
3111 POPEVAL(cx);
3112 retop = pop_return();
3113
a1f49e72 3114 TAINT_NOT;
54310121
PP
3115 if (gimme == G_VOID)
3116 MARK = newsp;
3117 else if (gimme == G_SCALAR) {
3118 MARK = newsp + 1;
3119 if (MARK <= SP) {
3120 if (SvFLAGS(TOPs) & SVs_TEMP)
3121 *MARK = TOPs;
3122 else
3123 *MARK = sv_mortalcopy(TOPs);
3124 }
a0d0e21e 3125 else {
54310121 3126 MEXTEND(mark,0);
3280af22 3127 *MARK = &PL_sv_undef;
a0d0e21e 3128 }
a7ec2b44 3129 SP = MARK;
a0d0e21e
LW
3130 }
3131 else {
a1f49e72
CS
3132 /* in case LEAVE wipes old return values */
3133 for (mark = newsp + 1; mark <= SP; mark++) {
3134 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
a0d0e21e 3135 *mark = sv_mortalcopy(*mark);
a1f49e72
CS
3136 TAINT_NOT; /* Each item is independent */
3137 }
3138 }
a0d0e21e 3139 }
3280af22 3140 PL_curpm = newpm; /* Don't pop $1 et al till now */
a0d0e21e 3141
067f92a0
GS
3142 if (AvFILLp(PL_comppad_name) >= 0)
3143 free_closures();
84902520 3144
4fdae800 3145#ifdef DEBUGGING
3280af22 3146 assert(CvDEPTH(PL_compcv) == 1);
4fdae800 3147#endif
3280af22 3148 CvDEPTH(PL_compcv) = 0;
f46d017c 3149 lex_end();
4fdae800 3150
1ce6579f 3151 if (optype == OP_REQUIRE &&
924508f0 3152 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
54310121 3153 {
1ce6579f 3154 /* Unassume the success we assumed earlier. */
54310121 3155 char *name = cx->blk_eval.old_name;
3280af22 3156 (void)hv_delete(GvHVn(PL_incgv), name, strlen(name), G_DISCARD);
cea2e8a9 3157 retop = Perl_die(aTHX_ "%s did not return a true value", name);
f46d017c
GS
3158 /* die_where() did LEAVE, or we won't be here */
3159 }
3160 else {
3161 LEAVE;
3162 if (!(save_flags & OPf_SPECIAL))
3163 sv_setpv(ERRSV,"");
a0d0e21e 3164 }
a0d0e21e
LW
3165
3166 RETURNOP(retop);
3167}
3168
a0d0e21e
LW
3169PP(pp_entertry)
3170{
4e35701f 3171 djSP;
c09156bb 3172 register PERL_CONTEXT *cx;
54310121 3173 I32 gimme = GIMME_V;
a0d0e21e
LW
3174
3175 ENTER;
3176 SAVETMPS;
3177
3178 push_return(cLOGOP->op_other->op_next);
3179 PUSHBLOCK(cx, CXt_EVAL, SP);
3180 PUSHEVAL(cx, 0, 0);
533c011a 3181 PL_eval_root = PL_op; /* Only needed so that goto works right. */
a0d0e21e 3182
faef0170 3183 PL_in_eval = EVAL_INEVAL;
38a03e6e 3184 sv_setpv(ERRSV,"");
1e422769 3185 PUTBACK;
533c011a 3186 return DOCATCH(PL_op->op_next);
a0d0e21e
LW
3187}
3188
3189PP(pp_leavetry)
3190{
4e35701f 3191 djSP;
a0d0e21e
LW
3192 register SV **mark;
3193 SV **newsp;
3194 PMOP *newpm;
3195 I32 gimme;
c09156bb 3196 register PERL_CONTEXT *cx;
a0d0e21e
LW
3197 I32 optype;
3198
3199 POPBLOCK(cx,newpm);
3200 POPEVAL(cx);
3201 pop_return();
3202
a1f49e72 3203 TAINT_NOT;
54310121
PP
3204 if (gimme == G_VOID)
3205 SP = newsp;
3206 else if (gimme == G_SCALAR) {
3207 MARK = newsp + 1;
3208 if (MARK <= SP) {
3209 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3210 *MARK = TOPs;
3211 else
3212 *MARK = sv_mortalcopy(TOPs);
3213 }
a0d0e21e 3214 else {
54310121 3215 MEXTEND(mark,0);
3280af22 3216 *MARK = &PL_sv_undef;
a0d0e21e
LW
3217 }
3218 SP = MARK;
3219 }
3220 else {
a1f49e72
CS
3221 /* in case LEAVE wipes old return values */
3222 for (mark = newsp + 1; mark <= SP; mark++) {
3223 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
a0d0e21e 3224 *mark = sv_mortalcopy(*mark);
a1f49e72
CS
3225 TAINT_NOT; /* Each item is independent */
3226 }
3227 }
a0d0e21e 3228 }
3280af22 3229 PL_curpm = newpm; /* Don't pop $1 et al till now */
a0d0e21e
LW
3230
3231 LEAVE;
38a03e6e 3232 sv_setpv(ERRSV,"");
a0d0e21e
LW
3233 RETURN;
3234}
3235
0824fdcb 3236STATIC void
cea2e8a9 3237S_doparseform(pTHX_ SV *sv)
a0d0e21e
LW
3238{
3239 STRLEN len;
3240 register char *s = SvPV_force(sv, len);
3241 register char *send = s + len;
3242 register char *base;
3243 register I32 skipspaces = 0;
3244 bool noblank;
3245 bool repeat;
3246 bool postspace = FALSE;
3247 U16 *fops;
3248 register U16 *fpc;
3249 U16 *linepc;
3250 register I32 arg;
3251 bool ischop;
3252
55497cff 3253 if (len == 0)
cea2e8a9 3254 Perl_croak(aTHX_ "Null picture in formline");
55497cff
PP
3255
3256 New(804, fops, (send - s)*3+10, U16); /* Almost certainly too long... */
a0d0e21e
LW
3257 fpc = fops;
3258
3259 if (s < send) {
3260 linepc = fpc;
3261 *fpc++ = FF_LINEMARK;
3262 noblank = repeat = FALSE;
3263 base = s;
3264 }
3265
3266 while (s <= send) {
3267 switch (*s++) {
3268 default:
3269 skipspaces = 0;
3270 continue;
3271
3272 case '~':
3273 if (*s == '~') {
3274 repeat = TRUE;
3275 *s = ' ';
3276 }
3277 noblank = TRUE;
3278 s[-1] = ' ';
3279 /* FALL THROUGH */
3280 case ' ': case '\t':
3281 skipspaces++;
3282 continue;
3283
3284 case '\n': case 0:
3285 arg = s - base;
3286 skipspaces++;
3287 arg -= skipspaces;
3288 if (arg) {
5f05dabc 3289 if (postspace)
a0d0e21e 3290 *fpc++ = FF_SPACE;
a0d0e21e
LW
3291 *fpc++ = FF_LITERAL;
3292 *fpc++ = arg;
3293 }
5f05dabc 3294 postspace = FALSE;
a0d0e21e
LW
3295 if (s <= send)
3296 skipspaces--;
3297 if (skipspaces) {
3298 *fpc++ = FF_SKIP;
3299 *fpc++ = skipspaces;
3300 }
3301 skipspaces = 0;
3302 if (s <= send)
3303 *fpc++ = FF_NEWLINE;
3304 if (noblank) {
3305 *fpc++ = FF_BLANK;
3306 if (repeat)
3307 arg = fpc - linepc + 1;
3308 else
3309 arg = 0;
3310 *fpc++ = arg;
3311 }
3312 if (s < send) {
3313 linepc = fpc;
3314 *fpc++ = FF_LINEMARK;
3315 noblank = repeat = FALSE;
3316 base = s;
3317 }
3318 else
3319 s++;
3320 continue;
3321
3322 case '@':
3323 case '^':
3324 ischop = s[-1] == '^';
3325
3326 if (postspace) {
3327 *fpc++ = FF_SPACE;
3328 postspace = FALSE;
3329 }
3330 arg = (s - base) - 1;
3331 if (arg) {
3332 *fpc++ = FF_LITERAL;
3333 *fpc++ = arg;
3334 }
3335
3336 base = s - 1;
3337 *fpc++ = FF_FETCH;
3338 if (*s == '*') {
3339 s++;
3340 *fpc++ = 0;
3341 *fpc++ = FF_LINEGLOB;
3342 }
3343 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3344 arg = ischop ? 512 : 0;
3345 base = s - 1;
3346 while (*s == '#')
3347 s++;
3348 if (*s == '.') {
3349 char *f;
3350 s++;
3351 f = s;
3352 while (*s == '#')
3353 s++;
3354 arg |= 256 + (s - f);
3355 }
3356 *fpc++ = s - base; /* fieldsize for FETCH */
3357 *fpc++ = FF_DECIMAL;
3358 *fpc++ = arg;
3359 }
3360 else {
3361 I32 prespace = 0;
3362 bool ismore = FALSE;
3363
3364 if (*s == '>') {
3365 while (*++s == '>') ;
3366 prespace = FF_SPACE;
3367 }
3368 else if (*s == '|') {
3369 while (*++s == '|') ;
3370 prespace = FF_HALFSPACE;
3371 postspace = TRUE;
3372 }
3373 else {
3374 if (*s == '<')
3375 while (*++s == '<') ;
3376 postspace = TRUE;
3377 }
3378 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3379 s += 3;
3380 ismore = TRUE;
3381 }
3382 *fpc++ = s - base; /* fieldsize for FETCH */
3383
3384 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3385
3386 if (prespace)
3387 *fpc++ = prespace;
3388 *fpc++ = FF_ITEM;
3389 if (ismore)
3390 *fpc++ = FF_MORE;
3391 if (ischop)
3392 *fpc++ = FF_CHOP;
3393 }
3394 base = s;
3395 skipspaces = 0;
3396 continue;
3397 }
3398 }
3399 *fpc++ = FF_END;
3400
3401 arg = fpc - fops;
3402 { /* need to jump to the next word */
3403 int z;
3404 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3405 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U16) + 4);
3406 s = SvPVX(sv) + SvCUR(sv) + z;
3407 }
3408 Copy(fops, s, arg, U16);
3409 Safefree(fops);
55497cff 3410 sv_magic(sv, Nullsv, 'f', Nullch, 0);
a0d0e21e
LW
3411 SvCOMPILED_on(sv);
3412}
4e35701f 3413
745d3a65
HM
3414/*
3415 * The rest of this file was derived from source code contributed
3416 * by Tom Horsley.
3417 *
3418 * NOTE: this code was derived from Tom Horsley's qsort replacement
3419 * and should not be confused with the original code.
3420 */
3421
3422/* Copyright (C) Tom Horsley, 1997. All rights reserved.
3423
3424 Permission granted to distribute under the same terms as perl which are
3425 (briefly):
3426
3427 This program is free software; you can redistribute it and/or modify
3428 it under the terms of either:
3429
3430 a) the GNU General Public License as published by the Free
3431 Software Foundation; either version 1, or (at your option) any
3432 later version, or
3433
3434 b) the "Artistic License" which comes with this Kit.
3435
3436 Details on the perl license can be found in the perl source code which
3437 may be located via the www.perl.com web page.
3438
3439 This is the most wonderfulest possible qsort I can come up with (and
3440 still be mostly portable) My (limited) tests indicate it consistently
3441 does about 20% fewer calls to compare than does the qsort in the Visual
3442 C++ library, other vendors may vary.
3443
3444 Some of the ideas in here can be found in "Algorithms" by Sedgewick,
3445 others I invented myself (or more likely re-invented since they seemed
3446 pretty obvious once I watched the algorithm operate for a while).
3447
3448 Most of this code was written while watching the Marlins sweep the Giants
3449 in the 1997 National League Playoffs - no Braves fans allowed to use this
3450 code (just kidding :-).
3451
3452 I realize that if I wanted to be true to the perl tradition, the only
3453 comment in this file would be something like:
3454
3455 ...they shuffled back towards the rear of the line. 'No, not at the
3456 rear!' the slave-driver shouted. 'Three files up. And stay there...
3457
3458 However, I really needed to violate that tradition just so I could keep
3459 track of what happens myself, not to mention some poor fool trying to
3460 understand this years from now :-).
3461*/
3462
3463/* ********************************************************** Configuration */
3464
3465#ifndef QSORT_ORDER_GUESS
3466#define QSORT_ORDER_GUESS 2 /* Select doubling version of the netBSD trick */
3467#endif
3468
3469/* QSORT_MAX_STACK is the largest number of partitions that can be stacked up for
3470 future processing - a good max upper bound is log base 2 of memory size
3471 (32 on 32 bit machines, 64 on 64 bit machines, etc). In reality can
3472 safely be smaller than that since the program is taking up some space and
3473 most operating systems only let you grab some subset of contiguous
3474 memory (not to mention that you are normally sorting data larger than
3475 1 byte element size :-).
3476*/
3477#ifndef QSORT_MAX_STACK
3478#define QSORT_MAX_STACK 32
3479#endif
3480
3481/* QSORT_BREAK_EVEN is the size of the largest partition we should insertion sort.
3482 Anything bigger and we use qsort. If you make this too small, the qsort
3483 will probably break (or become less efficient), because it doesn't expect
3484 the middle element of a partition to be the same as the right or left -
3485 you have been warned).
3486*/
3487#ifndef QSORT_BREAK_EVEN
3488#define QSORT_BREAK_EVEN 6
3489#endif
3490
3491/* ************************************************************* Data Types */
3492
3493/* hold left and right index values of a partition waiting to be sorted (the
3494 partition includes both left and right - right is NOT one past the end or
3495 anything like that).
3496*/
3497struct partition_stack_entry {
3498 int left;
3499 int right;
3500#ifdef QSORT_ORDER_GUESS
3501 int qsort_break_even;
3502#endif
3503};
3504
3505/* ******************************************************* Shorthand Macros */
3506
3507/* Note that these macros will be used from inside the qsort function where
3508 we happen to know that the variable 'elt_size' contains the size of an
3509 array element and the variable 'temp' points to enough space to hold a
3510 temp element and the variable 'array' points to the array being sorted
3511 and 'compare' is the pointer to the compare routine.
3512
3513 Also note that there are very many highly architecture specific ways
3514 these might be sped up, but this is simply the most generally portable
3515 code I could think of.
3516*/
161b471a 3517
745d3a65
HM
3518/* Return < 0 == 0 or > 0 as the value of elt1 is < elt2, == elt2, > elt2
3519*/
565764a8 3520#define qsort_cmp(elt1, elt2) \
51371543 3521 ((*compare)(aTHXo_ array[elt1], array[elt2]))
745d3a65
HM
3522
3523#ifdef QSORT_ORDER_GUESS
3524#define QSORT_NOTICE_SWAP swapped++;
3525#else
3526#define QSORT_NOTICE_SWAP
3527#endif
3528
3529/* swaps contents of array elements elt1, elt2.
3530*/
3531#define qsort_swap(elt1, elt2) \
3532 STMT_START { \
3533 QSORT_NOTICE_SWAP \
3534 temp = array[elt1]; \
3535 array[elt1] = array[elt2]; \
3536 array[elt2] = temp; \
3537 } STMT_END
3538
3539/* rotate contents of elt1, elt2, elt3 such that elt1 gets elt2, elt2 gets
3540 elt3 and elt3 gets elt1.
3541*/
3542#define qsort_rotate(elt1, elt2, elt3) \
3543 STMT_START { \
3544 QSORT_NOTICE_SWAP \
3545 temp = array[elt1]; \
3546 array[elt1] = array[elt2]; \
3547 array[elt2] = array[elt3]; \
3548 array[elt3] = temp; \
3549 } STMT_END
3550
3551/* ************************************************************ Debug stuff */
3552
3553#ifdef QSORT_DEBUG
3554
3555static void
3556break_here()
3557{
3558 return; /* good place to set a breakpoint */
3559}
3560
3561#define qsort_assert(t) (void)( (t) || (break_here(), 0) )
3562
3563static void
3564doqsort_all_asserts(
3565 void * array,
3566 size_t num_elts,
3567 size_t elt_size,
3568 int (*compare)(const void * elt1, const void * elt2),
3569 int pc_left, int pc_right, int u_left, int u_right)
3570{
3571 int i;
3572
3573 qsort_assert(pc_left <= pc_right);
3574 qsort_assert(u_right < pc_left);
3575 qsort_assert(pc_right < u_left);
3576 for (i = u_right + 1; i < pc_left; ++i) {
3577 qsort_assert(qsort_cmp(i, pc_left) < 0);
3578 }
3579 for (i = pc_left; i < pc_right; ++i) {
3580 qsort_assert(qsort_cmp(i, pc_right) == 0);
3581 }
3582 for (i = pc_right + 1; i < u_left; ++i) {
3583 qsort_assert(qsort_cmp(pc_right, i) < 0);
3584 }
3585}
3586
3587#define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) \
3588 doqsort_all_asserts(array, num_elts, elt_size, compare, \
3589 PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT)
3590
3591#else
3592
3593#define qsort_assert(t) ((void)0)
3594
3595#define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) ((void)0)
3596
3597#endif
3598
3599/* ****************************************************************** qsort */
3600
6cc33c6d 3601STATIC void
cea2e8a9 3602S_qsortsv(pTHX_ SV ** array, size_t num_elts, SVCOMPARE_t compare)
745d3a65
HM
3603{
3604 register SV * temp;
3605
3606 struct partition_stack_entry partition_stack[QSORT_MAX_STACK];
3607 int next_stack_entry = 0;
3608
3609 int part_left;
3610 int part_right;
3611#ifdef QSORT_ORDER_GUESS
3612 int qsort_break_even;
3613 int swapped;
3614#endif
161b471a 3615
745d3a65
HM
3616 /* Make sure we actually have work to do.
3617 */
3618 if (num_elts <= 1) {
3619 return;
3620 }
3621
3622 /* Setup the initial partition definition and fall into the sorting loop
3623 */
3624 part_left = 0;
3625 part_right = (int)(num_elts - 1);
3626#ifdef QSORT_ORDER_GUESS
3627 qsort_break_even = QSORT_BREAK_EVEN;
3628#else
3629#define qsort_break_even QSORT_BREAK_EVEN
3630#endif
3631 for ( ; ; ) {
3632 if ((part_right - part_left) >= qsort_break_even) {
3633 /* OK, this is gonna get hairy, so lets try to document all the
3634 concepts and abbreviations and variables and what they keep
3635 track of:
3636
3637 pc: pivot chunk - the set of array elements we accumulate in the
3638 middle of the partition, all equal in value to the original
3639 pivot element selected. The pc is defined by:
3640
3641 pc_left - the leftmost array index of the pc
3642 pc_right - the rightmost array index of the pc
3643
3644 we start with pc_left == pc_right and only one element
3645 in the pivot chunk (but it can grow during the scan).
3646
3647 u: uncompared elements - the set of elements in the partition
3648 we have not yet compared to the pivot value. There are two
3649 uncompared sets during the scan - one to the left of the pc
3650 and one to the right.
3651
3652 u_right - the rightmost index of the left side's uncompared set
3653 u_left - the leftmost index of the right side's uncompared set
3654
3655 The leftmost index of the left sides's uncompared set
3656 doesn't need its own variable because it is always defined
3657 by the leftmost edge of the whole partition (part_left). The
3658 same goes for the rightmost edge of the right partition
3659 (part_right).
3660