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