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