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