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