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