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