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