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