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