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