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
integrate cfgperl changes into mainline
[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 ;
1565 if (old_warnings == WARN_NONE || old_warnings == WARN_STD)
1566 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1567 else if (old_warnings == WARN_ALL)
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);
1851 } else {
1852 FREETMPS;
1853 *++newsp = sv_mortalcopy(*SP);
1854 }
1855 } else
1856 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
1857 } else
1858 *++newsp = sv_mortalcopy(*SP);
1859 } else
3280af22 1860 *++newsp = &PL_sv_undef;
a0d0e21e 1861 }
54310121 1862 else if (gimme == G_ARRAY) {
a1f49e72 1863 while (++MARK <= SP) {
f86702cc 1864 *++newsp = (popsub2 && SvTEMP(*MARK))
1865 ? *MARK : sv_mortalcopy(*MARK);
a1f49e72
CS		 1866 TAINT_NOT; /* Each item is independent */
1867 }
a0d0e21e 1868 }
3280af22 1869 PL_stack_sp = newsp;
a0d0e21e 1870
f86702cc 1871 /* Stack values are safe: */
1872 if (popsub2) {
b0d9ce38 1873 POPSUB(cx,sv); /* release CV and @_ ... */
f86702cc 1874 }
b0d9ce38
GS		 1875 else
1876 sv = Nullsv;
3280af22 1877 PL_curpm = newpm; /* ... and pop $1 et al */
f86702cc 1878
a0d0e21e 1879 LEAVE;
b0d9ce38 1880 LEAVESUB(sv);
b45de488
GS		 1881 if (clear_errsv)
1882 sv_setpv(ERRSV,"");
a0d0e21e
LW		 1883 return pop_return();
1884}
1885
1886PP(pp_last)
1887{
4e35701f 1888 djSP;
a0d0e21e 1889 I32 cxix;
c09156bb 1890 register PERL_CONTEXT *cx;
f86702cc 1891 I32 pop2 = 0;
a0d0e21e
LW		 1892 I32 gimme;
1893 I32 optype;
1894 OP *nextop;
1895 SV **newsp;
1896 PMOP *newpm;
a8bba7fa 1897 SV **mark;
b0d9ce38 1898 SV *sv = Nullsv;
a0d0e21e 1899
533c011a 1900 if (PL_op->op_flags & OPf_SPECIAL) {
a0d0e21e
LW		 1901 cxix = dopoptoloop(cxstack_ix);
1902 if (cxix < 0)
a651a37d 1903 DIE(aTHX_ "Can't \"last\" outside a loop block");
a0d0e21e
LW		 1904 }
1905 else {
1906 cxix = dopoptolabel(cPVOP->op_pv);
1907 if (cxix < 0)
cea2e8a9 1908 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
a0d0e21e
LW		 1909 }
1910 if (cxix < cxstack_ix)
1911 dounwind(cxix);
1912
1913 POPBLOCK(cx,newpm);
a8bba7fa 1914 mark = newsp;
6b35e009 1915 switch (CxTYPE(cx)) {
a0d0e21e 1916 case CXt_LOOP:
f86702cc 1917 pop2 = CXt_LOOP;
a8bba7fa
GS		 1918 newsp = PL_stack_base + cx->blk_loop.resetsp;
1919 nextop = cx->blk_loop.last_op->op_next;
a0d0e21e 1920 break;
f86702cc 1921 case CXt_SUB:
f86702cc 1922 pop2 = CXt_SUB;
a0d0e21e
LW		 1923 nextop = pop_return();
1924 break;
f86702cc 1925 case CXt_EVAL:
1926 POPEVAL(cx);
a0d0e21e
LW		 1927 nextop = pop_return();
1928 break;
7766f137
GS		 1929 case CXt_FORMAT:
1930 POPFORMAT(cx);
1931 nextop = pop_return();
1932 break;
a0d0e21e 1933 default:
cea2e8a9 1934 DIE(aTHX_ "panic: last");
a0d0e21e
LW		 1935 }
1936
a1f49e72 1937 TAINT_NOT;
a0d0e21e 1938 if (gimme == G_SCALAR) {
f86702cc 1939 if (MARK < SP)
1940 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
1941 ? *SP : sv_mortalcopy(*SP);
a0d0e21e 1942 else
3280af22 1943 *++newsp = &PL_sv_undef;
a0d0e21e 1944 }
54310121 1945 else if (gimme == G_ARRAY) {
a1f49e72 1946 while (++MARK <= SP) {
f86702cc 1947 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
1948 ? *MARK : sv_mortalcopy(*MARK);
a1f49e72
CS		 1949 TAINT_NOT; /* Each item is independent */
1950 }
f86702cc 1951 }
1952 SP = newsp;
1953 PUTBACK;
1954
1955 /* Stack values are safe: */
1956 switch (pop2) {
1957 case CXt_LOOP:
a8bba7fa 1958 POPLOOP(cx); /* release loop vars ... */
4fdae800 1959 LEAVE;
f86702cc 1960 break;
1961 case CXt_SUB:
b0d9ce38 1962 POPSUB(cx,sv); /* release CV and @_ ... */
f86702cc 1963 break;
a0d0e21e 1964 }
3280af22 1965 PL_curpm = newpm; /* ... and pop $1 et al */
a0d0e21e
LW		 1966
1967 LEAVE;
b0d9ce38 1968 LEAVESUB(sv);
f86702cc 1969 return nextop;
a0d0e21e
LW		 1970}
1971
1972PP(pp_next)
1973{
1974 I32 cxix;
c09156bb 1975 register PERL_CONTEXT *cx;
a0d0e21e
LW		 1976 I32 oldsave;
1977
533c011a 1978 if (PL_op->op_flags & OPf_SPECIAL) {
a0d0e21e
LW		 1979 cxix = dopoptoloop(cxstack_ix);
1980 if (cxix < 0)
a651a37d 1981 DIE(aTHX_ "Can't \"next\" outside a loop block");
a0d0e21e
LW		 1982 }
1983 else {
1984 cxix = dopoptolabel(cPVOP->op_pv);
1985 if (cxix < 0)
cea2e8a9 1986 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
a0d0e21e
LW		 1987 }
1988 if (cxix < cxstack_ix)
1989 dounwind(cxix);
1990
1ba6ee2b
GS		 1991 TOPBLOCK(cx);
1992
1993 /* clean scope, but only if there's no continue block */
1994 if (!(cx->blk_loop.last_op->op_private & OPpLOOP_CONTINUE)) {
1995 oldsave = PL_scopestack[PL_scopestack_ix - 1];
1996 LEAVE_SCOPE(oldsave);
1ee98724 1997 }
1ba6ee2b 1998 return cx->blk_loop.next_op;
a0d0e21e
LW		 1999}
2000
2001PP(pp_redo)
2002{
2003 I32 cxix;
c09156bb 2004 register PERL_CONTEXT *cx;
a0d0e21e
LW		 2005 I32 oldsave;
2006
533c011a 2007 if (PL_op->op_flags & OPf_SPECIAL) {
a0d0e21e
LW		 2008 cxix = dopoptoloop(cxstack_ix);
2009 if (cxix < 0)
a651a37d 2010 DIE(aTHX_ "Can't \"redo\" outside a loop block");
a0d0e21e
LW		 2011 }
2012 else {
2013 cxix = dopoptolabel(cPVOP->op_pv);
2014 if (cxix < 0)
cea2e8a9 2015 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
a0d0e21e
LW		 2016 }
2017 if (cxix < cxstack_ix)
2018 dounwind(cxix);
2019
2020 TOPBLOCK(cx);
3280af22 2021 oldsave = PL_scopestack[PL_scopestack_ix - 1];
a0d0e21e
LW		 2022 LEAVE_SCOPE(oldsave);
2023 return cx->blk_loop.redo_op;
2024}
2025
0824fdcb 2026STATIC OP *
cea2e8a9 2027S_dofindlabel(pTHX_ OP *o, char *label, OP **opstack, OP **oplimit)
a0d0e21e
LW		 2028{
2029 OP *kid;
2030 OP **ops = opstack;
fc36a67e 2031 static char too_deep[] = "Target of goto is too deeply nested";
a0d0e21e 2032
fc36a67e 2033 if (ops >= oplimit)
cea2e8a9 2034 Perl_croak(aTHX_ too_deep);
11343788
MB		 2035 if (o->op_type == OP_LEAVE ||
2036 o->op_type == OP_SCOPE ||
2037 o->op_type == OP_LEAVELOOP ||
2038 o->op_type == OP_LEAVETRY)
fc36a67e 2039 {
5dc0d613 2040 *ops++ = cUNOPo->op_first;
fc36a67e 2041 if (ops >= oplimit)
cea2e8a9 2042 Perl_croak(aTHX_ too_deep);
fc36a67e 2043 }
c4aa4e48 2044 *ops = 0;
11343788 2045 if (o->op_flags & OPf_KIDS) {
5c0ca799 2046 dTHR;
a0d0e21e 2047 /* First try all the kids at this level, since that's likeliest. */
11343788 2048 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
c4aa4e48
GS		 2049 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2050 kCOP->cop_label && strEQ(kCOP->cop_label, label))
a0d0e21e
LW		 2051 return kid;
2052 }
11343788 2053 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
3280af22 2054 if (kid == PL_lastgotoprobe)
a0d0e21e 2055 continue;
c4aa4e48
GS		 2056 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2057 (ops == opstack ||
2058 (ops[-1]->op_type != OP_NEXTSTATE &&
2059 ops[-1]->op_type != OP_DBSTATE)))
fc36a67e 2060 *ops++ = kid;
155aba94 2061 if ((o = dofindlabel(kid, label, ops, oplimit)))
11343788 2062 return o;
a0d0e21e
LW		 2063 }
2064 }
c4aa4e48 2065 *ops = 0;
a0d0e21e
LW		 2066 return 0;
2067}
2068
2069PP(pp_dump)
2070{
cea2e8a9 2071 return pp_goto();
a0d0e21e
LW		 2072 /*NOTREACHED*/
2073}
2074
2075PP(pp_goto)
2076{
4e35701f 2077 djSP;
a0d0e21e
LW		 2078 OP *retop = 0;
2079 I32 ix;
c09156bb 2080 register PERL_CONTEXT *cx;
fc36a67e 2081#define GOTO_DEPTH 64
2082 OP *enterops[GOTO_DEPTH];
a0d0e21e 2083 char *label;
533c011a 2084 int do_dump = (PL_op->op_type == OP_DUMP);
1614b0e3 2085 static char must_have_label[] = "goto must have label";
a0d0e21e
LW		 2086
2087 label = 0;
533c011a 2088 if (PL_op->op_flags & OPf_STACKED) {
a0d0e21e 2089 SV *sv = POPs;
2d8e6c8d 2090 STRLEN n_a;
a0d0e21e
LW		 2091
2092 /* This egregious kludge implements goto &subroutine */
2093 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2094 I32 cxix;
c09156bb 2095 register PERL_CONTEXT *cx;
a0d0e21e
LW		 2096 CV* cv = (CV*)SvRV(sv);
2097 SV** mark;
2098 I32 items = 0;
2099 I32 oldsave;
2100
e8f7dd13 2101 retry:
4aa0a1f7 2102 if (!CvROOT(cv) && !CvXSUB(cv)) {
e8f7dd13
GS		 2103 GV *gv = CvGV(cv);
2104 GV *autogv;
2105 if (gv) {
2106 SV *tmpstr;
2107 /* autoloaded stub? */
2108 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2109 goto retry;
2110 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2111 GvNAMELEN(gv), FALSE);
2112 if (autogv && (cv = GvCV(autogv)))
2113 goto retry;
2114 tmpstr = sv_newmortal();
2115 gv_efullname3(tmpstr, gv, Nullch);
cea2e8a9 2116 DIE(aTHX_ "Goto undefined subroutine &%s",SvPVX(tmpstr));
4aa0a1f7 2117 }
cea2e8a9 2118 DIE(aTHX_ "Goto undefined subroutine");
4aa0a1f7
AD		 2119 }
2120
a0d0e21e
LW		 2121 /* First do some returnish stuff. */
2122 cxix = dopoptosub(cxstack_ix);
2123 if (cxix < 0)
cea2e8a9 2124 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
a0d0e21e
LW		 2125 if (cxix < cxstack_ix)
2126 dounwind(cxix);
2127 TOPBLOCK(cx);
6b35e009 2128 if (CxTYPE(cx) == CXt_EVAL && cx->blk_eval.old_op_type == OP_ENTEREVAL)
cea2e8a9 2129 DIE(aTHX_ "Can't goto subroutine from an eval-string");
3280af22 2130 mark = PL_stack_sp;
d8b46c1b
GS		 2131 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2132 /* put @_ back onto stack */
a0d0e21e
LW		 2133 AV* av = cx->blk_sub.argarray;
2134
93965878 2135 items = AvFILLp(av) + 1;
3280af22
NIS		 2136 PL_stack_sp++;
2137 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2138 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2139 PL_stack_sp += items;
6d4ff0d2 2140#ifndef USE_THREADS
3280af22
NIS		 2141 SvREFCNT_dec(GvAV(PL_defgv));
2142 GvAV(PL_defgv) = cx->blk_sub.savearray;
6d4ff0d2 2143#endif /* USE_THREADS */
d8b46c1b 2144 /* abandon @_ if it got reified */
62b1ebc2 2145 if (AvREAL(av)) {
d8b46c1b
GS		 2146 (void)sv_2mortal((SV*)av); /* delay until return */
2147 av = newAV();
2148 av_extend(av, items-1);
2149 AvFLAGS(av) = AVf_REIFY;
2150 PL_curpad[0] = (SV*)(cx->blk_sub.argarray = av);
62b1ebc2 2151 }
a0d0e21e 2152 }
1fa4e549
AD		 2153 else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2154 AV* av;
1fa4e549 2155#ifdef USE_THREADS
533c011a 2156 av = (AV*)PL_curpad[0];
1fa4e549 2157#else
3280af22 2158 av = GvAV(PL_defgv);
1fa4e549
AD		 2159#endif
2160 items = AvFILLp(av) + 1;
3280af22
NIS		 2161 PL_stack_sp++;
2162 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2163 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2164 PL_stack_sp += items;
1fa4e549 2165 }
6b35e009 2166 if (CxTYPE(cx) == CXt_SUB &&
b150fb22 2167 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
a0d0e21e 2168 SvREFCNT_dec(cx->blk_sub.cv);
3280af22 2169 oldsave = PL_scopestack[PL_scopestack_ix - 1];
a0d0e21e
LW		 2170 LEAVE_SCOPE(oldsave);
2171
2172 /* Now do some callish stuff. */
2173 SAVETMPS;
2174 if (CvXSUB(cv)) {
67caa1fe 2175#ifdef PERL_XSUB_OLDSTYLE
a0d0e21e 2176 if (CvOLDSTYLE(cv)) {
20ce7b12 2177 I32 (*fp3)(int,int,int);
924508f0
GS		 2178 while (SP > mark) {
2179 SP[1] = SP[0];
2180 SP--;
a0d0e21e 2181 }
7766f137 2182 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
ecfc5424 2183 items = (*fp3)(CvXSUBANY(cv).any_i32,
3280af22 2184 mark - PL_stack_base + 1,
ecfc5424 2185 items);
3280af22 2186 SP = PL_stack_base + items;
a0d0e21e 2187 }
67caa1fe
GS		 2188 else
2189#endif /* PERL_XSUB_OLDSTYLE */
2190 {
1fa4e549
AD		 2191 SV **newsp;
2192 I32 gimme;
2193
3280af22 2194 PL_stack_sp--; /* There is no cv arg. */
1fa4e549
AD		 2195 /* Push a mark for the start of arglist */
2196 PUSHMARK(mark);
0cb96387 2197 (void)(*CvXSUB(cv))(aTHXo_ cv);
1fa4e549 2198 /* Pop the current context like a decent sub should */
3280af22 2199 POPBLOCK(cx, PL_curpm);
1fa4e549 2200 /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
a0d0e21e
LW		 2201 }
2202 LEAVE;
2203 return pop_return();
2204 }
2205 else {
2206 AV* padlist = CvPADLIST(cv);
2207 SV** svp = AvARRAY(padlist);
6b35e009 2208 if (CxTYPE(cx) == CXt_EVAL) {
3280af22
NIS		 2209 PL_in_eval = cx->blk_eval.old_in_eval;
2210 PL_eval_root = cx->blk_eval.old_eval_root;
b150fb22
RH		 2211 cx->cx_type = CXt_SUB;
2212 cx->blk_sub.hasargs = 0;
2213 }
a0d0e21e
LW		 2214 cx->blk_sub.cv = cv;
2215 cx->blk_sub.olddepth = CvDEPTH(cv);
2216 CvDEPTH(cv)++;
2217 if (CvDEPTH(cv) < 2)
2218 (void)SvREFCNT_inc(cv);
2219 else { /* save temporaries on recursion? */
599cee73 2220 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
44a8e56a 2221 sub_crush_depth(cv);
93965878 2222 if (CvDEPTH(cv) > AvFILLp(padlist)) {
a0d0e21e 2223 AV *newpad = newAV();
4aa0a1f7 2224 SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
93965878 2225 I32 ix = AvFILLp((AV*)svp[1]);
7766f137 2226 I32 names_fill = AvFILLp((AV*)svp[0]);
a0d0e21e 2227 svp = AvARRAY(svp[0]);
748a9306 2228 for ( ;ix > 0; ix--) {
7766f137 2229 if (names_fill >= ix && svp[ix] != &PL_sv_undef) {
748a9306 2230 char *name = SvPVX(svp[ix]);
5f05dabc 2231 if ((SvFLAGS(svp[ix]) & SVf_FAKE)
2232 || *name == '&')
2233 {
2234 /* outer lexical or anon code */
748a9306 2235 av_store(newpad, ix,
4aa0a1f7 2236 SvREFCNT_inc(oldpad[ix]) );
748a9306
LW		 2237 }
2238 else { /* our own lexical */
2239 if (*name == '@')
2240 av_store(newpad, ix, sv = (SV*)newAV());
2241 else if (*name == '%')
2242 av_store(newpad, ix, sv = (SV*)newHV());
2243 else
2244 av_store(newpad, ix, sv = NEWSV(0,0));
2245 SvPADMY_on(sv);
2246 }
a0d0e21e 2247 }
7766f137 2248 else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
743e66e6
GS		 2249 av_store(newpad, ix, sv = SvREFCNT_inc(oldpad[ix]));
2250 }
a0d0e21e 2251 else {
748a9306 2252 av_store(newpad, ix, sv = NEWSV(0,0));
a0d0e21e
LW		 2253 SvPADTMP_on(sv);
2254 }
2255 }
2256 if (cx->blk_sub.hasargs) {
2257 AV* av = newAV();
2258 av_extend(av, 0);
2259 av_store(newpad, 0, (SV*)av);
2260 AvFLAGS(av) = AVf_REIFY;
2261 }
2262 av_store(padlist, CvDEPTH(cv), (SV*)newpad);
93965878 2263 AvFILLp(padlist) = CvDEPTH(cv);
a0d0e21e
LW		 2264 svp = AvARRAY(padlist);
2265 }
2266 }
6d4ff0d2
MB		 2267#ifdef USE_THREADS
2268 if (!cx->blk_sub.hasargs) {
533c011a 2269 AV* av = (AV*)PL_curpad[0];
6d4ff0d2 2270
93965878 2271 items = AvFILLp(av) + 1;
6d4ff0d2
MB		 2272 if (items) {
2273 /* Mark is at the end of the stack. */
924508f0
GS		 2274 EXTEND(SP, items);
2275 Copy(AvARRAY(av), SP + 1, items, SV*);
2276 SP += items;
6d4ff0d2
MB		 2277 PUTBACK ;
2278 }
2279 }
2280#endif /* USE_THREADS */
7766f137 2281 SAVEVPTR(PL_curpad);
3280af22 2282 PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
6d4ff0d2
MB		 2283#ifndef USE_THREADS
2284 if (cx->blk_sub.hasargs)
2285#endif /* USE_THREADS */
2286 {
3280af22 2287 AV* av = (AV*)PL_curpad[0];
a0d0e21e
LW		 2288 SV** ary;
2289
6d4ff0d2 2290#ifndef USE_THREADS
3280af22
NIS		 2291 cx->blk_sub.savearray = GvAV(PL_defgv);
2292 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
6d4ff0d2
MB		 2293#endif /* USE_THREADS */
2294 cx->blk_sub.argarray = av;
a0d0e21e
LW		 2295 ++mark;
2296
2297 if (items >= AvMAX(av) + 1) {
2298 ary = AvALLOC(av);
2299 if (AvARRAY(av) != ary) {
2300 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2301 SvPVX(av) = (char*)ary;
2302 }
2303 if (items >= AvMAX(av) + 1) {
2304 AvMAX(av) = items - 1;
2305 Renew(ary,items+1,SV*);
2306 AvALLOC(av) = ary;
2307 SvPVX(av) = (char*)ary;
2308 }
2309 }
2310 Copy(mark,AvARRAY(av),items,SV*);
93965878 2311 AvFILLp(av) = items - 1;
d8b46c1b 2312 assert(!AvREAL(av));
a0d0e21e
LW		 2313 while (items--) {
2314 if (*mark)
2315 SvTEMP_off(*mark);
2316 mark++;
2317 }
2318 }
491527d0 2319 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
44a8e56a 2320 /*
2321 * We do not care about using sv to call CV;
2322 * it's for informational purposes only.
2323 */
3280af22 2324 SV *sv = GvSV(PL_DBsub);
491527d0
GS		 2325 CV *gotocv;
2326
2327 if (PERLDB_SUB_NN) {
56431972 2328 SvIVX(sv) = PTR2IV(cv); /* Already upgraded, saved */
491527d0
GS		 2329 } else {
2330 save_item(sv);
2331 gv_efullname3(sv, CvGV(cv), Nullch);
2332 }
2333 if ( PERLDB_GOTO
864dbfa3 2334 && (gotocv = get_cv("DB::goto", FALSE)) ) {
3280af22 2335 PUSHMARK( PL_stack_sp );
864dbfa3 2336 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
3280af22 2337 PL_stack_sp--;
491527d0 2338 }
1ce6579f 2339 }
a0d0e21e
LW		 2340 RETURNOP(CvSTART(cv));
2341 }
2342 }
1614b0e3 2343 else {
2d8e6c8d 2344 label = SvPV(sv,n_a);
1614b0e3 2345 if (!(do_dump || *label))
cea2e8a9 2346 DIE(aTHX_ must_have_label);
1614b0e3 2347 }
a0d0e21e 2348 }
533c011a 2349 else if (PL_op->op_flags & OPf_SPECIAL) {
a0d0e21e 2350 if (! do_dump)
cea2e8a9 2351 DIE(aTHX_ must_have_label);
a0d0e21e
LW		 2352 }
2353 else
2354 label = cPVOP->op_pv;
2355
2356 if (label && *label) {
2357 OP *gotoprobe = 0;
2358
2359 /* find label */
2360
3280af22 2361 PL_lastgotoprobe = 0;
a0d0e21e
LW		 2362 *enterops = 0;
2363 for (ix = cxstack_ix; ix >= 0; ix--) {
2364 cx = &cxstack[ix];
6b35e009 2365 switch (CxTYPE(cx)) {
a0d0e21e 2366 case CXt_EVAL:
3280af22 2367 gotoprobe = PL_eval_root; /* XXX not good for nested eval */
a0d0e21e
LW		 2368 break;
2369 case CXt_LOOP:
2370 gotoprobe = cx->blk_oldcop->op_sibling;
2371 break;
2372 case CXt_SUBST:
2373 continue;
2374 case CXt_BLOCK:
2375 if (ix)
2376 gotoprobe = cx->blk_oldcop->op_sibling;
2377 else
3280af22 2378 gotoprobe = PL_main_root;
a0d0e21e 2379 break;
b3933176
CS		 2380 case CXt_SUB:
2381 if (CvDEPTH(cx->blk_sub.cv)) {
2382 gotoprobe = CvROOT(cx->blk_sub.cv);
2383 break;
2384 }
2385 /* FALL THROUGH */
7766f137 2386 case CXt_FORMAT:
0a753a76 2387 case CXt_NULL:
a651a37d 2388 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
a0d0e21e
LW		 2389 default:
2390 if (ix)
cea2e8a9 2391 DIE(aTHX_ "panic: goto");
3280af22 2392 gotoprobe = PL_main_root;
a0d0e21e
LW		 2393 break;
2394 }
2b597662
GS		 2395 if (gotoprobe) {
2396 retop = dofindlabel(gotoprobe, label,
2397 enterops, enterops + GOTO_DEPTH);
2398 if (retop)
2399 break;
2400 }
3280af22 2401 PL_lastgotoprobe = gotoprobe;
a0d0e21e
LW		 2402 }
2403 if (!retop)
cea2e8a9 2404 DIE(aTHX_ "Can't find label %s", label);
a0d0e21e
LW		 2405
2406 /* pop unwanted frames */
2407
2408 if (ix < cxstack_ix) {
2409 I32 oldsave;
2410
2411 if (ix < 0)
2412 ix = 0;
2413 dounwind(ix);
2414 TOPBLOCK(cx);
3280af22 2415 oldsave = PL_scopestack[PL_scopestack_ix];
a0d0e21e
LW		 2416 LEAVE_SCOPE(oldsave);
2417 }
2418
2419 /* push wanted frames */
2420
748a9306 2421 if (*enterops && enterops[1]) {
533c011a 2422 OP *oldop = PL_op;
748a9306 2423 for (ix = 1; enterops[ix]; ix++) {
533c011a 2424 PL_op = enterops[ix];
84902520
TB		 2425 /* Eventually we may want to stack the needed arguments
2426 * for each op. For now, we punt on the hard ones. */
533c011a 2427 if (PL_op->op_type == OP_ENTERITER)
894356b3 2428 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
fc0dc3b3 2429 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
a0d0e21e 2430 }
533c011a 2431 PL_op = oldop;
a0d0e21e
LW		 2432 }
2433 }
2434
2435 if (do_dump) {
a5f75d66 2436#ifdef VMS
6b88bc9c 2437 if (!retop) retop = PL_main_start;
a5f75d66 2438#endif
3280af22
NIS		 2439 PL_restartop = retop;
2440 PL_do_undump = TRUE;
a0d0e21e
LW		 2441
2442 my_unexec();
2443
3280af22
NIS		 2444 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2445 PL_do_undump = FALSE;
a0d0e21e
LW		 2446 }
2447
2448 RETURNOP(retop);
2449}
2450
2451PP(pp_exit)
2452{
4e35701f 2453 djSP;
a0d0e21e
LW		 2454 I32 anum;
2455
2456 if (MAXARG < 1)
2457 anum = 0;
ff0cee69 2458 else {
a0d0e21e 2459 anum = SvIVx(POPs);
ff0cee69 2460#ifdef VMSISH_EXIT
2461 if (anum == 1 && VMSISH_EXIT)
2462 anum = 0;
2463#endif
2464 }
cc3604b1 2465 PL_exit_flags |= PERL_EXIT_EXPECTED;
a0d0e21e 2466 my_exit(anum);
3280af22 2467 PUSHs(&PL_sv_undef);
a0d0e21e
LW		 2468 RETURN;
2469}
2470
2471#ifdef NOTYET
2472PP(pp_nswitch)
2473{
4e35701f 2474 djSP;
65202027 2475 NV value = SvNVx(GvSV(cCOP->cop_gv));
a0d0e21e
LW		 2476 register I32 match = I_32(value);
2477
2478 if (value < 0.0) {
65202027 2479 if (((NV)match) > value)
a0d0e21e
LW		 2480 --match; /* was fractional--truncate other way */
2481 }
2482 match -= cCOP->uop.scop.scop_offset;
2483 if (match < 0)
2484 match = 0;
2485 else if (match > cCOP->uop.scop.scop_max)
2486 match = cCOP->uop.scop.scop_max;
6b88bc9c
GS		 2487 PL_op = cCOP->uop.scop.scop_next[match];
2488 RETURNOP(PL_op);
a0d0e21e
LW		 2489}
2490
2491PP(pp_cswitch)
2492{
4e35701f 2493 djSP;
a0d0e21e
LW		 2494 register I32 match;
2495
6b88bc9c
GS		 2496 if (PL_multiline)
2497 PL_op = PL_op->op_next; /* can't assume anything */
a0d0e21e 2498 else {
2d8e6c8d
GS		 2499 STRLEN n_a;
2500 match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255;
a0d0e21e
LW		 2501 match -= cCOP->uop.scop.scop_offset;
2502 if (match < 0)
2503 match = 0;
2504 else if (match > cCOP->uop.scop.scop_max)
2505 match = cCOP->uop.scop.scop_max;
6b88bc9c 2506 PL_op = cCOP->uop.scop.scop_next[match];
a0d0e21e 2507 }
6b88bc9c 2508 RETURNOP(PL_op);
a0d0e21e
LW		 2509}
2510#endif
2511
2512/* Eval. */
2513
0824fdcb 2514STATIC void
cea2e8a9 2515S_save_lines(pTHX_ AV *array, SV *sv)
a0d0e21e
LW		 2516{
2517 register char *s = SvPVX(sv);
2518 register char *send = SvPVX(sv) + SvCUR(sv);
2519 register char *t;
2520 register I32 line = 1;
2521
2522 while (s && s < send) {
2523 SV *tmpstr = NEWSV(85,0);
2524
2525 sv_upgrade(tmpstr, SVt_PVMG);
2526 t = strchr(s, '\n');
2527 if (t)
2528 t++;
2529 else
2530 t = send;
2531
2532 sv_setpvn(tmpstr, s, t - s);
2533 av_store(array, line++, tmpstr);
2534 s = t;
2535 }
2536}
2537
14dd3ad8 2538#ifdef PERL_FLEXIBLE_EXCEPTIONS
312caa8e 2539STATIC void *
cea2e8a9 2540S_docatch_body(pTHX_ va_list args)
312caa8e 2541{
14dd3ad8
GS		 2542 return docatch_body();
2543}
2544#endif
2545
2546STATIC void *
2547S_docatch_body(pTHX)
2548{
cea2e8a9 2549 CALLRUNOPS(aTHX);
312caa8e
CS		 2550 return NULL;
2551}
2552
0824fdcb 2553STATIC OP *
cea2e8a9 2554S_docatch(pTHX_ OP *o)
1e422769 2555{
e858de61 2556 dTHR;
6224f72b 2557 int ret;
533c011a 2558 OP *oldop = PL_op;
0cdb2077 2559 volatile PERL_SI *cursi = PL_curstackinfo;
db36c5a1 2560 dJMPENV;
1e422769 2561
1e422769 2562#ifdef DEBUGGING
54310121 2563 assert(CATCH_GET == TRUE);
1e422769 2564#endif
312caa8e 2565 PL_op = o;
14dd3ad8 2566#ifdef PERL_FLEXIBLE_EXCEPTIONS
312caa8e 2567 redo_body:
db36c5a1 2568 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_docatch_body));
14dd3ad8
GS		 2569#else
2570 JMPENV_PUSH(ret);
2571#endif
6224f72b 2572 switch (ret) {
312caa8e 2573 case 0:
14dd3ad8
GS		 2574#ifndef PERL_FLEXIBLE_EXCEPTIONS
2575 redo_body:
2576 docatch_body();
2577#endif
312caa8e
CS		 2578 break;
2579 case 3:
0cdb2077 2580 if (PL_restartop && cursi == PL_curstackinfo) {
312caa8e
CS		 2581 PL_op = PL_restartop;
2582 PL_restartop = 0;
2583 goto redo_body;
2584 }
2585 /* FALL THROUGH */
2586 default:
14dd3ad8 2587 JMPENV_POP;
533c011a 2588 PL_op = oldop;
6224f72b 2589 JMPENV_JUMP(ret);
1e422769 2590 /* NOTREACHED */
1e422769 2591 }
14dd3ad8 2592 JMPENV_POP;
533c011a 2593 PL_op = oldop;
1e422769 2594 return Nullop;
2595}
2596
c277df42 2597OP *
864dbfa3 2598Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, AV** avp)
c277df42
IZ		 2599/* sv Text to convert to OP tree. */
2600/* startop op_free() this to undo. */
2601/* code Short string id of the caller. */
2602{
2603 dSP; /* Make POPBLOCK work. */
2604 PERL_CONTEXT *cx;
2605 SV **newsp;
f987c7de 2606 I32 gimme = 0; /* SUSPECT - INITIALZE TO WHAT? NI-S */
c277df42
IZ		 2607 I32 optype;
2608 OP dummy;
155aba94 2609 OP *rop;
83ee9e09
GS		 2610 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2611 char *tmpbuf = tbuf;
c277df42
IZ		 2612 char *safestr;
2613
2614 ENTER;
2615 lex_start(sv);
2616 SAVETMPS;
2617 /* switch to eval mode */
2618
cbce877f 2619 if (PL_curcop == &PL_compiling) {
11faa288
GS		 2620 SAVECOPSTASH(&PL_compiling);
2621 CopSTASH_set(&PL_compiling, PL_curstash);
cbce877f 2622 }
57843af0
GS		 2623 SAVECOPFILE(&PL_compiling);
2624 SAVECOPLINE(&PL_compiling);
83ee9e09
GS		 2625 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2626 SV *sv = sv_newmortal();
2627 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2628 code, (unsigned long)++PL_evalseq,
2629 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2630 tmpbuf = SvPVX(sv);
2631 }
2632 else
2633 sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
57843af0
GS		 2634 CopFILE_set(&PL_compiling, tmpbuf+2);
2635 CopLINE_set(&PL_compiling, 1);
c277df42
IZ		 2636 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2637 deleting the eval's FILEGV from the stash before gv_check() runs
2638 (i.e. before run-time proper). To work around the coredump that
2639 ensues, we always turn GvMULTI_on for any globals that were
2640 introduced within evals. See force_ident(). GSAR 96-10-12 */
2641 safestr = savepv(tmpbuf);
3280af22 2642 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
b3ac6de7 2643 SAVEHINTS();
d1ca3daa 2644#ifdef OP_IN_REGISTER
6b88bc9c 2645 PL_opsave = op;
d1ca3daa 2646#else
7766f137 2647 SAVEVPTR(PL_op);
d1ca3daa 2648#endif
3280af22 2649 PL_hints = 0;
c277df42 2650
533c011a 2651 PL_op = &dummy;
13b51b79 2652 PL_op->op_type = OP_ENTEREVAL;
533c011a 2653 PL_op->op_flags = 0; /* Avoid uninit warning. */
c277df42 2654 PUSHBLOCK(cx, CXt_EVAL, SP);
cc49e20b 2655 PUSHEVAL(cx, 0, Nullgv);
c277df42 2656 rop = doeval(G_SCALAR, startop);
13b51b79 2657 POPBLOCK(cx,PL_curpm);
e84b9f1f 2658 POPEVAL(cx);
c277df42
IZ		 2659
2660 (*startop)->op_type = OP_NULL;
22c35a8c 2661 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
c277df42 2662 lex_end();
3280af22 2663 *avp = (AV*)SvREFCNT_inc(PL_comppad);
c277df42 2664 LEAVE;
13b51b79 2665 if (PL_curcop == &PL_compiling)
a0ed51b3 2666 PL_compiling.op_private = PL_hints;
d1ca3daa 2667#ifdef OP_IN_REGISTER
6b88bc9c 2668 op = PL_opsave;
d1ca3daa 2669#endif
c277df42
IZ		 2670 return rop;
2671}
2672
0f15f207 2673/* With USE_THREADS, eval_owner must be held on entry to doeval */
0824fdcb 2674STATIC OP *
cea2e8a9 2675S_doeval(pTHX_ int gimme, OP** startop)
a0d0e21e
LW		 2676{
2677 dSP;
533c011a 2678 OP *saveop = PL_op;
ff3ff8d1 2679 CV *caller;
748a9306 2680 AV* comppadlist;
67a38de0 2681 I32 i;
a0d0e21e 2682
faef0170 2683 PL_in_eval = EVAL_INEVAL;
a0d0e21e 2684
1ce6579f 2685 PUSHMARK(SP);
2686
a0d0e21e
LW		 2687 /* set up a scratch pad */
2688
3280af22 2689 SAVEI32(PL_padix);
7766f137 2690 SAVEVPTR(PL_curpad);
3280af22
NIS		 2691 SAVESPTR(PL_comppad);
2692 SAVESPTR(PL_comppad_name);
2693 SAVEI32(PL_comppad_name_fill);
2694 SAVEI32(PL_min_intro_pending);
2695 SAVEI32(PL_max_intro_pending);
748a9306 2696
3280af22 2697 caller = PL_compcv;
6b35e009 2698 for (i = cxstack_ix - 1; i >= 0; i--) {
67a38de0 2699 PERL_CONTEXT *cx = &cxstack[i];
6b35e009 2700 if (CxTYPE(cx) == CXt_EVAL)
67a38de0 2701 break;
7766f137 2702 else if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
67a38de0
NIS		 2703 caller = cx->blk_sub.cv;
2704 break;
2705 }
2706 }
2707
3280af22
NIS		 2708 SAVESPTR(PL_compcv);
2709 PL_compcv = (CV*)NEWSV(1104,0);
2710 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
1aff0e91 2711 CvEVAL_on(PL_compcv);
11343788 2712#ifdef USE_THREADS
533c011a
NIS		 2713 CvOWNER(PL_compcv) = 0;
2714 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
2715 MUTEX_INIT(CvMUTEXP(PL_compcv));
11343788 2716#endif /* USE_THREADS */
748a9306 2717
3280af22
NIS		 2718 PL_comppad = newAV();
2719 av_push(PL_comppad, Nullsv);
2720 PL_curpad = AvARRAY(PL_comppad);
2721 PL_comppad_name = newAV();
2722 PL_comppad_name_fill = 0;
2723 PL_min_intro_pending = 0;
2724 PL_padix = 0;
11343788 2725#ifdef USE_THREADS
79cb57f6 2726 av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
533c011a
NIS		 2727 PL_curpad[0] = (SV*)newAV();
2728 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
11343788 2729#endif /* USE_THREADS */
a0d0e21e 2730
748a9306
LW		 2731 comppadlist = newAV();
2732 AvREAL_off(comppadlist);
3280af22
NIS		 2733 av_store(comppadlist, 0, (SV*)PL_comppad_name);
2734 av_store(comppadlist, 1, (SV*)PL_comppad);
2735 CvPADLIST(PL_compcv) = comppadlist;
2c05e328 2736
faa7e5bb
GS		 2737 if (!saveop ||
2738 (saveop->op_type != OP_REQUIRE && saveop->op_type != OP_DOFILE))
2739 {
3280af22 2740 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(caller);
faa7e5bb 2741 }
07055b4c 2742
3280af22 2743 SAVEFREESV(PL_compcv);
748a9306 2744
a0d0e21e
LW		 2745 /* make sure we compile in the right package */
2746
ed094faf 2747 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
3280af22 2748 SAVESPTR(PL_curstash);
ed094faf 2749 PL_curstash = CopSTASH(PL_curcop);
a0d0e21e 2750 }
3280af22
NIS		 2751 SAVESPTR(PL_beginav);
2752 PL_beginav = newAV();
2753 SAVEFREESV(PL_beginav);
a0d0e21e
LW		 2754
2755 /* try to compile it */
2756
3280af22
NIS		 2757 PL_eval_root = Nullop;
2758 PL_error_count = 0;
2759 PL_curcop = &PL_compiling;
2760 PL_curcop->cop_arybase = 0;
2761 SvREFCNT_dec(PL_rs);
79cb57f6 2762 PL_rs = newSVpvn("\n", 1);
c277df42 2763 if (saveop && saveop->op_flags & OPf_SPECIAL)
faef0170 2764 PL_in_eval |= EVAL_KEEPERR;
1ce6579f 2765 else
38a03e6e 2766 sv_setpv(ERRSV,"");
3280af22 2767 if (yyparse() || PL_error_count || !PL_eval_root) {
a0d0e21e
LW		 2768 SV **newsp;
2769 I32 gimme;
c09156bb 2770 PERL_CONTEXT *cx;
c277df42 2771 I32 optype = 0; /* Might be reset by POPEVAL. */
2d8e6c8d 2772 STRLEN n_a;
097ee67d 2773
533c011a 2774 PL_op = saveop;
3280af22
NIS		 2775 if (PL_eval_root) {
2776 op_free(PL_eval_root);
2777 PL_eval_root = Nullop;
a0d0e21e 2778 }
3280af22 2779 SP = PL_stack_base + POPMARK; /* pop original mark */
c277df42 2780 if (!startop) {
3280af22 2781 POPBLOCK(cx,PL_curpm);
c277df42
IZ		 2782 POPEVAL(cx);
2783 pop_return();
2784 }
a0d0e21e
LW		 2785 lex_end();
2786 LEAVE;
7a2e2cd6 2787 if (optype == OP_REQUIRE) {
2d8e6c8d 2788 char* msg = SvPVx(ERRSV, n_a);
5a844595
GS		 2789 DIE(aTHX_ "%sCompilation failed in require",
2790 *msg ? msg : "Unknown error\n");
2791 }
2792 else if (startop) {
2d8e6c8d 2793 char* msg = SvPVx(ERRSV, n_a);
c277df42 2794
3280af22 2795 POPBLOCK(cx,PL_curpm);
c277df42 2796 POPEVAL(cx);
5a844595
GS		 2797 Perl_croak(aTHX_ "%sCompilation failed in regexp",
2798 (*msg ? msg : "Unknown error\n"));
7a2e2cd6 2799 }
3280af22
NIS		 2800 SvREFCNT_dec(PL_rs);
2801 PL_rs = SvREFCNT_inc(PL_nrs);
f2134d95 2802#ifdef USE_THREADS
533c011a
NIS		 2803 MUTEX_LOCK(&PL_eval_mutex);
2804 PL_eval_owner = 0;
2805 COND_SIGNAL(&PL_eval_cond);
2806 MUTEX_UNLOCK(&PL_eval_mutex);
f2134d95 2807#endif /* USE_THREADS */
a0d0e21e
LW		 2808 RETPUSHUNDEF;
2809 }
3280af22
NIS		 2810 SvREFCNT_dec(PL_rs);
2811 PL_rs = SvREFCNT_inc(PL_nrs);
57843af0 2812 CopLINE_set(&PL_compiling, 0);
c277df42 2813 if (startop) {
3280af22
NIS		 2814 *startop = PL_eval_root;
2815 SvREFCNT_dec(CvOUTSIDE(PL_compcv));
2816 CvOUTSIDE(PL_compcv) = Nullcv;
c277df42 2817 } else
3280af22 2818 SAVEFREEOP(PL_eval_root);
54310121 2819 if (gimme & G_VOID)
3280af22 2820 scalarvoid(PL_eval_root);
54310121 2821 else if (gimme & G_ARRAY)
3280af22 2822 list(PL_eval_root);
a0d0e21e 2823 else
3280af22 2824 scalar(PL_eval_root);
a0d0e21e
LW		 2825
2826 DEBUG_x(dump_eval());
2827
55497cff 2828 /* Register with debugger: */
84902520 2829 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
864dbfa3 2830 CV *cv = get_cv("DB::postponed", FALSE);
55497cff 2831 if (cv) {
2832 dSP;
924508f0 2833 PUSHMARK(SP);
cc49e20b 2834 XPUSHs((SV*)CopFILEGV(&PL_compiling));
55497cff 2835 PUTBACK;
864dbfa3 2836 call_sv((SV*)cv, G_DISCARD);
55497cff 2837 }
2838 }
2839
a0d0e21e
LW		 2840 /* compiled okay, so do it */
2841
3280af22
NIS		 2842 CvDEPTH(PL_compcv) = 1;
2843 SP = PL_stack_base + POPMARK; /* pop original mark */
533c011a 2844 PL_op = saveop; /* The caller may need it. */
b35b2403 2845#ifdef USE_THREADS
533c011a
NIS		 2846 MUTEX_LOCK(&PL_eval_mutex);
2847 PL_eval_owner = 0;
2848 COND_SIGNAL(&PL_eval_cond);
2849 MUTEX_UNLOCK(&PL_eval_mutex);
b35b2403 2850#endif /* USE_THREADS */
5dc0d613 2851
3280af22 2852 RETURNOP(PL_eval_start);
a0d0e21e
LW		 2853}
2854
a6c40364 2855STATIC PerlIO *
cea2e8a9 2856S_doopen_pmc(pTHX_ const char *name, const char *mode)
b295d113
TH		 2857{
2858 STRLEN namelen = strlen(name);
2859 PerlIO *fp;
2860
7894fbab 2861 if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
cea2e8a9 2862 SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
b295d113
TH		 2863 char *pmc = SvPV_nolen(pmcsv);
2864 Stat_t pmstat;
a6c40364
GS		 2865 Stat_t pmcstat;
2866 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
b295d113 2867 fp = PerlIO_open(name, mode);
a6c40364
GS		 2868 }
2869 else {
b295d113 2870 if (PerlLIO_stat(name, &pmstat) < 0 ||
a6c40364
GS		 2871 pmstat.st_mtime < pmcstat.st_mtime)
2872 {
2873 fp = PerlIO_open(pmc, mode);
2874 }
2875 else {
2876 fp = PerlIO_open(name, mode);
2877 }
b295d113 2878 }
a6c40364
GS		 2879 SvREFCNT_dec(pmcsv);
2880 }
2881 else {
2882 fp = PerlIO_open(name, mode);
b295d113 2883 }
b295d113
TH		 2884 return fp;
2885}
2886
a0d0e21e
LW		 2887PP(pp_require)
2888{
4e35701f 2889 djSP;
c09156bb 2890 register PERL_CONTEXT *cx;
a0d0e21e
LW		 2891 SV *sv;
2892 char *name;
6132ea6c 2893 STRLEN len;
46fc3d4c 2894 char *tryname;
2895 SV *namesv = Nullsv;
a0d0e21e
LW		 2896 SV** svp;
2897 I32 gimme = G_SCALAR;
760ac839 2898 PerlIO *tryrsfp = 0;
2d8e6c8d 2899 STRLEN n_a;
bbed91b5
KF		 2900 int filter_has_file = 0;
2901 GV *filter_child_proc = 0;
2902 SV *filter_state = 0;
2903 SV *filter_sub = 0;
a0d0e21e
LW		 2904
2905 sv = POPs;
a7cb1f99
GS		 2906 if (SvNIOKp(sv)) {
2907 UV rev, ver, sver;
3818b22b 2908 if (SvPOKp(sv)) { /* require v5.6.1 */
a7cb1f99
GS		 2909 I32 len;
2910 U8 *s = (U8*)SvPVX(sv);
2911 U8 *end = (U8*)SvPVX(sv) + SvCUR(sv);
2912 if (s < end) {
2913 rev = utf8_to_uv(s, &len);
2914 s += len;
2915 if (s < end) {
2916 ver = utf8_to_uv(s, &len);
2917 s += len;
2918 if (s < end)
2919 sver = utf8_to_uv(s, &len);
2920 else
2921 sver = 0;
2922 }
2923 else
2924 ver = 0;
2925 }
2926 else
2927 rev = 0;
2928 if (PERL_REVISION < rev
2929 || (PERL_REVISION == rev
2930 && (PERL_VERSION < ver
2931 || (PERL_VERSION == ver
2932 && PERL_SUBVERSION < sver))))
2933 {
2934 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--this is only version "
894356b3 2935 "v%d.%d.%d, stopped", rev, ver, sver, PERL_REVISION,
a7cb1f99
GS		 2936 PERL_VERSION, PERL_SUBVERSION);
2937 }
2938 }
2939 else if (!SvPOKp(sv)) { /* require 5.005_03 */
a7cb1f99
GS		 2940 if ((NV)PERL_REVISION + ((NV)PERL_VERSION/(NV)1000)
2941 + ((NV)PERL_SUBVERSION/(NV)1000000)
2942 + 0.00000099 < SvNV(sv))
2943 {
dbe7b177
GS		 2944 NV nrev = SvNV(sv);
2945 UV rev = (UV)nrev;
2946 NV nver = (nrev - rev) * 1000;
2947 UV ver = (UV)(nver + 0.0009);
2948 NV nsver = (nver - ver) * 1000;
2949 UV sver = (UV)(nsver + 0.0009);
2950
a7cb1f99 2951 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--this is only version "
894356b3 2952 "v%d.%d.%d, stopped", rev, ver, sver, PERL_REVISION,
a7cb1f99
GS		 2953 PERL_VERSION, PERL_SUBVERSION);
2954 }
2955 }
a0d0e21e
LW		 2956 RETPUSHYES;
2957 }
6132ea6c
GS		 2958 name = SvPV(sv, len);
2959 if (!(name && len > 0 && *name))
cea2e8a9 2960 DIE(aTHX_ "Null filename used");
4633a7c4 2961 TAINT_PROPER("require");
533c011a 2962 if (PL_op->op_type == OP_REQUIRE &&
3280af22
NIS		 2963 (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0)) &&
2964 *svp != &PL_sv_undef)
a0d0e21e
LW		 2965 RETPUSHYES;
2966
2967 /* prepare to compile file */
2968
57843af0
GS		 2969 if (PERL_FILE_IS_ABSOLUTE(name)
2970 || (*name == '.' && (name[1] == '/' ||
2971 (name[1] == '.' && name[2] == '/'))))
a0d0e21e 2972 {
46fc3d4c 2973 tryname = name;
a6c40364 2974 tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE);
a0d0e21e
LW		 2975 }
2976 else {
3280af22 2977 AV *ar = GvAVn(PL_incgv);
a0d0e21e 2978 I32 i;
748a9306 2979#ifdef VMS
46fc3d4c 2980 char *unixname;
2981 if ((unixname = tounixspec(name, Nullch)) != Nullch)
2982#endif
2983 {
2984 namesv = NEWSV(806, 0);
2985 for (i = 0; i <= AvFILL(ar); i++) {
bbed91b5
KF		 2986 SV *dirsv = *av_fetch(ar, i, TRUE);
2987
2988 if (SvROK(dirsv)) {
2989 int count;
2990 SV *loader = dirsv;
2991
2992 if (SvTYPE(SvRV(loader)) == SVt_PVAV) {
2993 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
2994 }
2995
b900a521
JH		 2996 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
2997 PTR2UV(SvANY(loader)), name);
bbed91b5
KF		 2998 tryname = SvPVX(namesv);
2999 tryrsfp = 0;
3000
3001 ENTER;
3002 SAVETMPS;
3003 EXTEND(SP, 2);
3004
3005 PUSHMARK(SP);
3006 PUSHs(dirsv);
3007 PUSHs(sv);
3008 PUTBACK;
3009 count = call_sv(loader, G_ARRAY);
3010 SPAGAIN;
3011
3012 if (count > 0) {
3013 int i = 0;
3014 SV *arg;
3015
3016 SP -= count - 1;
3017 arg = SP[i++];
3018
3019 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3020 arg = SvRV(arg);
3021 }
3022
3023 if (SvTYPE(arg) == SVt_PVGV) {
3024 IO *io = GvIO((GV *)arg);
3025
3026 ++filter_has_file;
3027
3028 if (io) {
3029 tryrsfp = IoIFP(io);
3030 if (IoTYPE(io) == '|') {
3031 /* reading from a child process doesn't
3032 nest -- when returning from reading
3033 the inner module, the outer one is
3034 unreadable (closed?) I've tried to
3035 save the gv to manage the lifespan of
3036 the pipe, but this didn't help. XXX */
3037 filter_child_proc = (GV *)arg;
520c758a 3038 (void)SvREFCNT_inc(filter_child_proc);
bbed91b5
KF		 3039 }
3040 else {
3041 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3042 PerlIO_close(IoOFP(io));
3043 }
3044 IoIFP(io) = Nullfp;
3045 IoOFP(io) = Nullfp;
3046 }
3047 }
3048
3049 if (i < count) {
3050 arg = SP[i++];
3051 }
3052 }
3053
3054 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3055 filter_sub = arg;
520c758a 3056 (void)SvREFCNT_inc(filter_sub);
bbed91b5
KF		 3057
3058 if (i < count) {
3059 filter_state = SP[i];
520c758a 3060 (void)SvREFCNT_inc(filter_state);
bbed91b5
KF		 3061 }
3062
3063 if (tryrsfp == 0) {
3064 tryrsfp = PerlIO_open("/dev/null",
3065 PERL_SCRIPT_MODE);
3066 }
3067 }
3068 }
3069
3070 PUTBACK;
3071 FREETMPS;
3072 LEAVE;
3073
3074 if (tryrsfp) {
3075 break;
3076 }
3077
3078 filter_has_file = 0;
3079 if (filter_child_proc) {
3080 SvREFCNT_dec(filter_child_proc);
3081 filter_child_proc = 0;
3082 }
3083 if (filter_state) {
3084 SvREFCNT_dec(filter_state);
3085 filter_state = 0;
3086 }
3087 if (filter_sub) {
3088 SvREFCNT_dec(filter_sub);
3089 filter_sub = 0;
3090 }
3091 }
3092 else {
3093 char *dir = SvPVx(dirsv, n_a);
46fc3d4c 3094#ifdef VMS
bbed91b5
KF		 3095 char *unixdir;
3096 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3097 continue;
3098 sv_setpv(namesv, unixdir);
3099 sv_catpv(namesv, unixname);
748a9306 3100#else
bbed91b5 3101 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
748a9306 3102#endif
bbed91b5
KF		 3103 TAINT_PROPER("require");
3104 tryname = SvPVX(namesv);
3105 tryrsfp = doopen_pmc(tryname, PERL_SCRIPT_MODE);
3106 if (tryrsfp) {
3107 if (tryname[0] == '.' && tryname[1] == '/')
3108 tryname += 2;
3109 break;
3110 }
46fc3d4c 3111 }
a0d0e21e
LW		 3112 }
3113 }
3114 }
57843af0
GS		 3115 SAVECOPFILE(&PL_compiling);
3116 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
46fc3d4c 3117 SvREFCNT_dec(namesv);
a0d0e21e 3118 if (!tryrsfp) {
533c011a 3119 if (PL_op->op_type == OP_REQUIRE) {
ec889f3a
GS		 3120 char *msgstr = name;
3121 if (namesv) { /* did we lookup @INC? */
3122 SV *msg = sv_2mortal(newSVpv(msgstr,0));
3123 SV *dirmsgsv = NEWSV(0, 0);
3124 AV *ar = GvAVn(PL_incgv);
3125 I32 i;
3126 sv_catpvn(msg, " in @INC", 8);
3127 if (instr(SvPVX(msg), ".h "))
3128 sv_catpv(msg, " (change .h to .ph maybe?)");
3129 if (instr(SvPVX(msg), ".ph "))
3130 sv_catpv(msg, " (did you run h2ph?)");
3131 sv_catpv(msg, " (@INC contains:");
3132 for (i = 0; i <= AvFILL(ar); i++) {
3133 char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
cea2e8a9 3134 Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
ec889f3a
GS		 3135 sv_catsv(msg, dirmsgsv);
3136 }
3137 sv_catpvn(msg, ")", 1);
3138 SvREFCNT_dec(dirmsgsv);
3139 msgstr = SvPV_nolen(msg);
2683423c 3140 }
cea2e8a9 3141 DIE(aTHX_ "Can't locate %s", msgstr);
a0d0e21e
LW		 3142 }
3143
3144 RETPUSHUNDEF;
3145 }
d8bfb8bd 3146 else
aba27d88 3147 SETERRNO(0, SS$_NORMAL);
a0d0e21e
LW		 3148
3149 /* Assume success here to prevent recursive requirement. */
3280af22 3150 (void)hv_store(GvHVn(PL_incgv), name, strlen(name),
ed094faf 3151 newSVpv(CopFILE(&PL_compiling), 0), 0 );
a0d0e21e
LW		 3152
3153 ENTER;
3154 SAVETMPS;
79cb57f6 3155 lex_start(sv_2mortal(newSVpvn("",0)));
b9d12d37
GS		 3156 SAVEGENERICSV(PL_rsfp_filters);
3157 PL_rsfp_filters = Nullav;
e50aee73 3158
3280af22 3159 PL_rsfp = tryrsfp;
b3ac6de7 3160 SAVEHINTS();
3280af22 3161 PL_hints = 0;
7766f137 3162 SAVESPTR(PL_compiling.cop_warnings);
0453d815
PM		 3163 if (PL_dowarn & G_WARN_ALL_ON)
3164 PL_compiling.cop_warnings = WARN_ALL ;
3165 else if (PL_dowarn & G_WARN_ALL_OFF)
3166 PL_compiling.cop_warnings = WARN_NONE ;
3167 else
3168 PL_compiling.cop_warnings = WARN_STD ;
a0d0e21e 3169
bbed91b5
KF		 3170 if (filter_sub || filter_child_proc) {
3171 SV *datasv = filter_add(run_user_filter, Nullsv);
3172 IoLINES(datasv) = filter_has_file;
3173 IoFMT_GV(datasv) = (GV *)filter_child_proc;
3174 IoTOP_GV(datasv) = (GV *)filter_state;
3175 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3176 }
3177
3178 /* switch to eval mode */
533c011a 3179 push_return(PL_op->op_next);
a0d0e21e 3180 PUSHBLOCK(cx, CXt_EVAL, SP);
cc49e20b 3181 PUSHEVAL(cx, name, Nullgv);
a0d0e21e 3182
57843af0
GS		 3183 SAVECOPLINE(&PL_compiling);
3184 CopLINE_set(&PL_compiling, 0);
a0d0e21e
LW		 3185
3186 PUTBACK;
0f15f207 3187#ifdef USE_THREADS
533c011a
NIS		 3188 MUTEX_LOCK(&PL_eval_mutex);
3189 if (PL_eval_owner && PL_eval_owner != thr)
3190 while (PL_eval_owner)
3191 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3192 PL_eval_owner = thr;
3193 MUTEX_UNLOCK(&PL_eval_mutex);
0f15f207 3194#endif /* USE_THREADS */
c277df42 3195 return DOCATCH(doeval(G_SCALAR, NULL));
a0d0e21e
LW		 3196}
3197
3198PP(pp_dofile)
3199{
cea2e8a9 3200 return pp_require();
a0d0e21e
LW		 3201}
3202
3203PP(pp_entereval)
3204{
4e35701f 3205 djSP;
c09156bb 3206 register PERL_CONTEXT *cx;
a0d0e21e 3207 dPOPss;
3280af22 3208 I32 gimme = GIMME_V, was = PL_sub_generation;
83ee9e09
GS		 3209 char tbuf[TYPE_DIGITS(long) + 12];
3210 char *tmpbuf = tbuf;
fc36a67e 3211 char *safestr;
a0d0e21e 3212 STRLEN len;
55497cff 3213 OP *ret;
a0d0e21e
LW		 3214
3215 if (!SvPV(sv,len) || !len)
3216 RETPUSHUNDEF;
748a9306 3217 TAINT_PROPER("eval");
a0d0e21e
LW		 3218
3219 ENTER;
a0d0e21e 3220 lex_start(sv);
748a9306 3221 SAVETMPS;
a0d0e21e
LW		 3222
3223 /* switch to eval mode */
3224
57843af0 3225 SAVECOPFILE(&PL_compiling);
83ee9e09
GS		 3226 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3227 SV *sv = sv_newmortal();
3228 Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3229 (unsigned long)++PL_evalseq,
3230 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3231 tmpbuf = SvPVX(sv);
3232 }
3233 else
3234 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
57843af0
GS		 3235 CopFILE_set(&PL_compiling, tmpbuf+2);
3236 CopLINE_set(&PL_compiling, 1);
55497cff 3237 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3238 deleting the eval's FILEGV from the stash before gv_check() runs
3239 (i.e. before run-time proper). To work around the coredump that
3240 ensues, we always turn GvMULTI_on for any globals that were
3241 introduced within evals. See force_ident(). GSAR 96-10-12 */
3242 safestr = savepv(tmpbuf);
3280af22 3243 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
b3ac6de7 3244 SAVEHINTS();
533c011a 3245 PL_hints = PL_op->op_targ;
7766f137 3246 SAVESPTR(PL_compiling.cop_warnings);
0453d815 3247 if (!specialWARN(PL_compiling.cop_warnings)) {
599cee73
PM		 3248 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
3249 SAVEFREESV(PL_compiling.cop_warnings) ;
3250 }
a0d0e21e 3251
533c011a 3252 push_return(PL_op->op_next);
6b35e009 3253 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
cc49e20b 3254 PUSHEVAL(cx, 0, Nullgv);
a0d0e21e
LW		 3255
3256 /* prepare to compile string */
3257
3280af22 3258 if (PERLDB_LINE && PL_curstash != PL_debstash)
cc49e20b 3259 save_lines(CopFILEAV(&PL_compiling), PL_linestr);
a0d0e21e 3260 PUTBACK;
0f15f207 3261#ifdef USE_THREADS
533c011a
NIS		 3262 MUTEX_LOCK(&PL_eval_mutex);
3263 if (PL_eval_owner && PL_eval_owner != thr)
3264 while (PL_eval_owner)
3265 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3266 PL_eval_owner = thr;
3267 MUTEX_UNLOCK(&PL_eval_mutex);
0f15f207 3268#endif /* USE_THREADS */
c277df42 3269 ret = doeval(gimme, NULL);
3280af22 3270 if (PERLDB_INTER && was != PL_sub_generation /* Some subs defined here. */
533c011a 3271 && ret != PL_op->op_next) { /* Successive compilation. */
55497cff 3272 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
3273 }
1e422769 3274 return DOCATCH(ret);
a0d0e21e
LW		 3275}
3276
3277PP(pp_leaveeval)
3278{
4e35701f 3279 djSP;
a0d0e21e
LW		 3280 register SV **mark;
3281 SV **newsp;
3282 PMOP *newpm;
3283 I32 gimme;
c09156bb 3284 register PERL_CONTEXT *cx;
a0d0e21e 3285 OP *retop;
533c011a 3286 U8 save_flags = PL_op -> op_flags;
a0d0e21e
LW		 3287 I32 optype;
3288
3289 POPBLOCK(cx,newpm);
3290 POPEVAL(cx);
3291 retop = pop_return();
3292
a1f49e72 3293 TAINT_NOT;
54310121 3294 if (gimme == G_VOID)
3295 MARK = newsp;
3296 else if (gimme == G_SCALAR) {
3297 MARK = newsp + 1;
3298 if (MARK <= SP) {
3299 if (SvFLAGS(TOPs) & SVs_TEMP)
3300 *MARK = TOPs;
3301 else
3302 *MARK = sv_mortalcopy(TOPs);
3303 }
a0d0e21e 3304 else {
54310121 3305 MEXTEND(mark,0);
3280af22 3306 *MARK = &PL_sv_undef;
a0d0e21e 3307 }
a7ec2b44 3308 SP = MARK;
a0d0e21e
LW		 3309 }
3310 else {
a1f49e72
CS		 3311 /* in case LEAVE wipes old return values */
3312 for (mark = newsp + 1; mark <= SP; mark++) {
3313 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
a0d0e21e 3314 *mark = sv_mortalcopy(*mark);
a1f49e72
CS		 3315 TAINT_NOT; /* Each item is independent */
3316 }
3317 }
a0d0e21e 3318 }
3280af22 3319 PL_curpm = newpm; /* Don't pop $1 et al till now */
a0d0e21e 3320
067f92a0
GS		 3321 if (AvFILLp(PL_comppad_name) >= 0)
3322 free_closures();
84902520 3323
4fdae800 3324#ifdef DEBUGGING
3280af22 3325 assert(CvDEPTH(PL_compcv) == 1);
4fdae800 3326#endif
3280af22 3327 CvDEPTH(PL_compcv) = 0;
f46d017c 3328 lex_end();
4fdae800 3329
1ce6579f 3330 if (optype == OP_REQUIRE &&
924508f0 3331 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
54310121 3332 {
1ce6579f 3333 /* Unassume the success we assumed earlier. */
0f79a09d
GS		 3334 SV *nsv = cx->blk_eval.old_namesv;
3335 (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
3336 retop = Perl_die(aTHX_ "%s did not return a true value", SvPVX(nsv));
f46d017c
GS		 3337 /* die_where() did LEAVE, or we won't be here */
3338 }
3339 else {
3340 LEAVE;
3341 if (!(save_flags & OPf_SPECIAL))
3342 sv_setpv(ERRSV,"");
a0d0e21e 3343 }
a0d0e21e
LW		 3344
3345 RETURNOP(retop);
3346}
3347
a0d0e21e
LW		 3348PP(pp_entertry)
3349{
4e35701f 3350 djSP;
c09156bb 3351 register PERL_CONTEXT *cx;
54310121 3352 I32 gimme = GIMME_V;
a0d0e21e
LW		 3353
3354 ENTER;
3355 SAVETMPS;
3356
3357 push_return(cLOGOP->op_other->op_next);
1d76a5c3 3358 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
a0d0e21e 3359 PUSHEVAL(cx, 0, 0);
533c011a 3360 PL_eval_root = PL_op; /* Only needed so that goto works right. */
a0d0e21e 3361
faef0170 3362 PL_in_eval = EVAL_INEVAL;
38a03e6e 3363 sv_setpv(ERRSV,"");
1e422769 3364 PUTBACK;
533c011a 3365 return DOCATCH(PL_op->op_next);
a0d0e21e
LW		 3366}
3367
3368PP(pp_leavetry)
3369{
4e35701f 3370 djSP;
a0d0e21e
LW		 3371 register SV **mark;
3372 SV **newsp;
3373 PMOP *newpm;
3374 I32 gimme;
c09156bb 3375 register PERL_CONTEXT *cx;
a0d0e21e
LW		 3376 I32 optype;
3377
3378 POPBLOCK(cx,newpm);
3379 POPEVAL(cx);
3380 pop_return();
3381
a1f49e72 3382 TAINT_NOT;
54310121 3383 if (gimme == G_VOID)
3384 SP = newsp;
3385 else if (gimme == G_SCALAR) {
3386 MARK = newsp + 1;
3387 if (MARK <= SP) {
3388 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3389 *MARK = TOPs;
3390 else
3391 *MARK = sv_mortalcopy(TOPs);
3392 }
a0d0e21e 3393 else {
54310121 3394 MEXTEND(mark,0);
3280af22 3395 *MARK = &PL_sv_undef;
a0d0e21e
LW		 3396 }
3397 SP = MARK;
3398 }
3399 else {
a1f49e72
CS		 3400 /* in case LEAVE wipes old return values */
3401 for (mark = newsp + 1; mark <= SP; mark++) {
3402 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
a0d0e21e 3403 *mark = sv_mortalcopy(*mark);
a1f49e72
CS		 3404 TAINT_NOT; /* Each item is independent */
3405 }
3406 }
a0d0e21e 3407 }
3280af22 3408 PL_curpm = newpm; /* Don't pop $1 et al till now */
a0d0e21e
LW		 3409
3410 LEAVE;
38a03e6e 3411 sv_setpv(ERRSV,"");
a0d0e21e
LW		 3412 RETURN;
3413}
3414
0824fdcb 3415STATIC void
cea2e8a9 3416S_doparseform(pTHX_ SV *sv)
a0d0e21e
LW		 3417{
3418 STRLEN len;
3419 register char *s = SvPV_force(sv, len);
3420 register char *send = s + len;
3421 register char *base;
3422 register I32 skipspaces = 0;
3423 bool noblank;
3424 bool repeat;
3425 bool postspace = FALSE;
3426 U16 *fops;
3427 register U16 *fpc;
3428 U16 *linepc;
3429 register I32 arg;
3430 bool ischop;
3431
55497cff 3432 if (len == 0)
cea2e8a9 3433 Perl_croak(aTHX_ "Null picture in formline");
55497cff 3434
3435 New(804, fops, (send - s)*3+10, U16); /* Almost certainly too long... */
a0d0e21e
LW		 3436 fpc = fops;
3437
3438 if (s < send) {
3439 linepc = fpc;
3440 *fpc++ = FF_LINEMARK;
3441 noblank = repeat = FALSE;
3442 base = s;
3443 }
3444
3445 while (s <= send) {
3446 switch (*s++) {
3447 default:
3448 skipspaces = 0;
3449 continue;
3450
3451 case '~':
3452 if (*s == '~') {
3453 repeat = TRUE;
3454 *s = ' ';
3455 }
3456 noblank = TRUE;
3457 s[-1] = ' ';
3458 /* FALL THROUGH */
3459 case ' ': case '\t':
3460 skipspaces++;
3461 continue;
3462
3463 case '\n': case 0:
3464 arg = s - base;
3465 skipspaces++;
3466 arg -= skipspaces;
3467 if (arg) {
5f05dabc 3468 if (postspace)
a0d0e21e 3469 *fpc++ = FF_SPACE;
a0d0e21e
LW		 3470 *fpc++ = FF_LITERAL;
3471 *fpc++ = arg;
3472 }
5f05dabc 3473 postspace = FALSE;
a0d0e21e
LW		 3474 if (s <= send)
3475 skipspaces--;
3476 if (skipspaces) {
3477 *fpc++ = FF_SKIP;
3478 *fpc++ = skipspaces;
3479 }
3480 skipspaces = 0;
3481 if (s <= send)
3482 *fpc++ = FF_NEWLINE;
3483 if (noblank) {
3484 *fpc++ = FF_BLANK;
3485 if (repeat)
3486 arg = fpc - linepc + 1;
3487 else
3488 arg = 0;
3489 *fpc++ = arg;
3490 }
3491 if (s < send) {
3492 linepc = fpc;
3493 *fpc++ = FF_LINEMARK;
3494 noblank = repeat = FALSE;
3495 base = s;
3496 }
3497 else
3498 s++;
3499 continue;
3500
3501 case '@':
3502 case '^':
3503 ischop = s[-1] == '^';
3504
3505 if (postspace) {
3506 *fpc++ = FF_SPACE;
3507 postspace = FALSE;
3508 }
3509 arg = (s - base) - 1;
3510 if (arg) {
3511 *fpc++ = FF_LITERAL;
3512 *fpc++ = arg;
3513 }
3514
3515 base = s - 1;
3516 *fpc++ = FF_FETCH;
3517 if (*s == '*') {
3518 s++;
3519 *fpc++ = 0;
3520 *fpc++ = FF_LINEGLOB;
3521 }
3522 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3523 arg = ischop ? 512 : 0;
3524 base = s - 1;
3525 while (*s == '#')
3526 s++;
3527 if (*s == '.') {
3528 char *f;
3529 s++;
3530 f = s;
3531 while (*s == '#')
3532 s++;
3533 arg |= 256 + (s - f);
3534 }
3535 *fpc++ = s - base; /* fieldsize for FETCH */
3536 *fpc++ = FF_DECIMAL;
3537 *fpc++ = arg;
3538 }
3539 else {
3540 I32 prespace = 0;
3541 bool ismore = FALSE;
3542
3543 if (*s == '>') {
3544 while (*++s == '>') ;
3545 prespace = FF_SPACE;
3546 }
3547 else if (*s == '|') {
3548 while (*++s == '|') ;
3549 prespace = FF_HALFSPACE;
3550 postspace = TRUE;
3551 }
3552 else {
3553 if (*s == '<')
3554 while (*++s == '<') ;
3555 postspace = TRUE;
3556 }
3557 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3558 s += 3;
3559 ismore = TRUE;
3560 }
3561 *fpc++ = s - base; /* fieldsize for FETCH */
3562
3563 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3564
3565 if (prespace)
3566 *fpc++ = prespace;
3567 *fpc++ = FF_ITEM;
3568 if (ismore)
3569 *fpc++ = FF_MORE;
3570 if (ischop)
3571 *fpc++ = FF_CHOP;
3572 }
3573 base = s;
3574 skipspaces = 0;
3575 continue;
3576 }
3577 }
3578 *fpc++ = FF_END;
3579
3580 arg = fpc - fops;
3581 { /* need to jump to the next word */
3582 int z;
3583 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3584 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U16) + 4);
3585 s = SvPVX(sv) + SvCUR(sv) + z;
3586 }
3587 Copy(fops, s, arg, U16);
3588 Safefree(fops);
55497cff 3589 sv_magic(sv, Nullsv, 'f', Nullch, 0);
a0d0e21e
LW		 3590 SvCOMPILED_on(sv);
3591}
4e35701f 3592
745d3a65
HM		 3593/*
3594 * The rest of this file was derived from source code contributed
3595 * by Tom Horsley.
3596 *
3597 * NOTE: this code was derived from Tom Horsley's qsort replacement
3598 * and should not be confused with the original code.
3599 */
3600
3601/* Copyright (C) Tom Horsley, 1997. All rights reserved.
3602
3603 Permission granted to distribute under the same terms as perl which are
3604 (briefly):
3605
3606 This program is free software; you can redistribute it and/or modify
3607 it under the terms of either:
3608
3609 a) the GNU General Public License as published by the Free
3610 Software Foundation; either version 1, or (at your option) any
3611 later version, or
3612
3613 b) the "Artistic License" which comes with this Kit.
3614
3615 Details on the perl license can be found in the perl source code which
3616 may be located via the www.perl.com web page.
3617
3618 This is the most wonderfulest possible qsort I can come up with (and
3619 still be mostly portable) My (limited) tests indicate it consistently
3620 does about 20% fewer calls to compare than does the qsort in the Visual
3621 C++ library, other vendors may vary.
3622
3623 Some of the ideas in here can be found in "Algorithms" by Sedgewick,
3624 others I invented myself (or more likely re-invented since they seemed
3625 pretty obvious once I watched the algorithm operate for a while).
3626
3627 Most of this code was written while watching the Marlins sweep the Giants
3628 in the 1997 National League Playoffs - no Braves fans allowed to use this
3629 code (just kidding :-).
3630
3631 I realize that if I wanted to be true to the perl tradition, the only
3632 comment in this file would be something like:
3633
3634 ...they shuffled back towards the rear of the line. 'No, not at the
3635 rear!' the slave-driver shouted. 'Three files up. And stay there...
3636
3637 However, I really needed to violate that tradition just so I could keep
3638 track of what happens myself, not to mention some poor fool trying to
3639 understand this years from now :-).
3640*/
3641
3642/* ********************************************************** Configuration */
3643
3644#ifndef QSORT_ORDER_GUESS
3645#define QSORT_ORDER_GUESS 2 /* Select doubling version of the netBSD trick */
3646#endif
3647
3648/* QSORT_MAX_STACK is the largest number of partitions that can be stacked up for
3649 future processing - a good max upper bound is log base 2 of memory size
3650 (32 on 32 bit machines, 64 on 64 bit machines, etc). In reality can
3651 safely be smaller than that since the program is taking up some space and
3652 most operating systems only let you grab some subset of contiguous
3653 memory (not to mention that you are normally sorting data larger than
3654 1 byte element size :-).
3655*/
3656#ifndef QSORT_MAX_STACK
3657#define QSORT_MAX_STACK 32
3658#endif
3659
3660/* QSORT_BREAK_EVEN is the size of the largest partition we should insertion sort.
3661 Anything bigger and we use qsort. If you make this too small, the qsort
3662 will probably break (or become less efficient), because it doesn't expect
3663 the middle element of a partition to be the same as the right or left -
3664 you have been warned).
3665*/
3666#ifndef QSORT_BREAK_EVEN
3667#define QSORT_BREAK_EVEN 6
3668#endif
3669
3670/* ************************************************************* Data Types */
3671
3672/* hold left and right index values of a partition waiting to be sorted (the
3673 partition includes both left and right - right is NOT one past the end or
3674 anything like that).
3675*/
3676struct partition_stack_entry {
3677 int left;
3678 int right;
3679#ifdef QSORT_ORDER_GUESS
3680 int qsort_break_even;
3681#endif
3682};
3683
3684/* ******************************************************* Shorthand Macros */
3685
3686/* Note that these macros will be used from inside the qsort function where
3687 we happen to know that the variable 'elt_size' contains the size of an
3688 array element and the variable 'temp' points to enough space to hold a
3689 temp element and the variable 'array' points to the array being sorted
3690 and 'compare' is the pointer to the compare routine.
3691
3692 Also note that there are very many highly architecture specific ways
3693 these might be sped up, but this is simply the most generally portable
3694 code I could think of.
3695*/
161b471a 3696
745d3a65
HM		 3697/* Return < 0 == 0 or > 0 as the value of elt1 is < elt2, == elt2, > elt2
3698*/
565764a8 3699#define qsort_cmp(elt1, elt2) \
51371543 3700 ((*compare)(aTHXo_ array[elt1], array[elt2]))
745d3a65
HM		 3701
3702#ifdef QSORT_ORDER_GUESS
3703#define QSORT_NOTICE_SWAP swapped++;
3704#else
3705#define QSORT_NOTICE_SWAP
3706#endif
3707
3708/* swaps contents of array elements elt1, elt2.
3709*/
3710#define qsort_swap(elt1, elt2) \
3711 STMT_START { \
3712 QSORT_NOTICE_SWAP \
3713 temp = array[elt1]; \
3714 array[elt1] = array[elt2]; \
3715 array[elt2] = temp; \
3716 } STMT_END
3717
3718/* rotate contents of elt1, elt2, elt3 such that elt1 gets elt2, elt2 gets
3719 elt3 and elt3 gets elt1.
3720*/
3721#define qsort_rotate(elt1, elt2, elt3) \
3722 STMT_START { \
3723 QSORT_NOTICE_SWAP \
3724 temp = array[elt1]; \
3725 array[elt1] = array[elt2]; \
3726 array[elt2] = array[elt3]; \
3727 array[elt3] = temp; \
3728 } STMT_END
3729
3730/* ************************************************************ Debug stuff */
3731
3732#ifdef QSORT_DEBUG
3733
3734static void
3735break_here()
3736{
3737 return; /* good place to set a breakpoint */
3738}
3739
3740#define qsort_assert(t) (void)( (t) || (break_here(), 0) )
3741
3742static void
3743doqsort_all_asserts(
3744 void * array,
3745 size_t num_elts,
3746 size_t elt_size,
3747 int (*compare)(const void * elt1, const void * elt2),
3748 int pc_left, int pc_right, int u_left, int u_right)
3749{
3750 int i;
3751
3752 qsort_assert(pc_left <= pc_right);
3753 qsort_assert(u_right < pc_left);
3754 qsort_assert(pc_right < u_left);
3755 for (i = u_right + 1; i < pc_left; ++i) {
3756 qsort_assert(qsort_cmp(i, pc_left) < 0);
3757 }
3758 for (i = pc_left; i < pc_right; ++i) {
3759 qsort_assert(qsort_cmp(i, pc_right) == 0);
3760 }
3761 for (i = pc_right + 1; i < u_left; ++i) {
3762 qsort_assert(qsort_cmp(pc_right, i) < 0);
3763 }
3764}
3765
3766#define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) \
3767 doqsort_all_asserts(array, num_elts, elt_size, compare, \
3768 PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT)
3769
3770#else
3771
3772#define qsort_assert(t) ((void)0)
3773
3774#define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) ((void)0)
3775
3776#endif
3777
3778/* ****************************************************************** qsort */
3779
6cc33c6d 3780STATIC void
cea2e8a9 3781S_qsortsv(pTHX_ SV ** array, size_t num_elts, SVCOMPARE_t compare)
745d3a65
HM		 3782{
3783 register SV * temp;
3784
3785 struct partition_stack_entry partition_stack[QSORT_MAX_STACK];
3786 int next_stack_entry = 0;
3787
3788 int part_left;
3789 int part_right;
3790#ifdef QSORT_ORDER_GUESS
3791 int qsort_break_even;
3792 int swapped;
3793#endif
161b471a 3794
745d3a65
HM		 3795 /* Make sure we actually have work to do.
3796 */
3797 if (num_elts <= 1) {
3798 return;
3799 }
3800
3801 /* Setup the initial partition definition and fall into the sorting loop
3802 */
3803 part_left = 0;
3804 part_right = (int)(num_elts - 1);
3805#ifdef QSORT_ORDER_GUESS
3806 qsort_break_even = QSORT_BREAK_EVEN;
3807#else
3808#define qsort_break_even QSORT_BREAK_EVEN
3809#endif
3810 for ( ; ; ) {
3811 if ((part_right - part_left) >= qsort_break_even) {
3812 /* OK, this is gonna get hairy, so lets try to document all the
3813 concepts and abbreviations and variables and what they keep
3814 track of:
3815
3816 pc: pivot chunk - the set of array elements we accumulate in the
3817 middle of the partition, all equal in value to the original
3818 pivot element selected. The pc is defined by:
3819
3820 pc_left - the leftmost array index of the pc
3821 pc_right - the rightmost array index of the pc
3822
3823 we start with pc_left == pc_right and only one element
3824 in the pivot chunk (but it can grow during the scan).
3825
3826 u: uncompared elements - the set of elements in the partition
3827 we have not yet compared to the pivot value. There are two
3828 uncompared sets during the scan - one to the left of the pc
3829 and one to the right.
3830
3831 u_right - the rightmost index of the left side's uncompared set
3832 u_left - the leftmost index of the right side's uncompared set
3833
3834 The leftmost index of the left sides's uncompared set
3835 doesn't need its own variable because it is always defined
3836 by the leftmost edge of the whole partition (part_left). The
3837 same goes for the rightmost edge of the right partition
3838 (part_right).
3839
3840 We know there are no uncompared elements on the left once we
3841 get u_right < part_left and no uncompared elements on the
3842 right once u_left > part_right. When both these conditions
3843 are met, we have completed the scan of the partition.
3844
3845 Any elements which are between the pivot chunk and the
3846 uncompared elements should be less than the pivot value on
3847 the left side and greater than the pivot value on the right
3848 side (in fact, the goal of the whole algorithm is to arrange
3849 for that to be true and make the groups of less-than and
3850 greater-then elements into new partitions to sort again).
3851
3852 As you marvel at the complexity of the code and wonder why it
3853 has to be so confusing. Consider some of the things this level
3854 of confusion brings:
3855
3856 Once I do a compare, I squeeze every ounce of juice out of it. I
3857 never do compare calls I don't have to do, and I certainly never
3858 do redundant calls.
3859
3860 I also never swap any elements unless I can prove there is a
3861 good reason. Many sort algorithms will swap a known value with
3862 an uncompared value just to get things in the right place (or
3863 avoid complexity :-), but that uncompared value, once it gets
3864 compared, may then have to be swapped again. A lot of the
3865 complexity of this code is due to the fact that it never swaps
3866 anything except compared values, and it only swaps them when the
3867 compare shows they are out of position.
3868 */
3869 int pc_left, pc_right;
3870 int u_right, u_left;
3871
3872 int s;
3873
3874 pc_left = ((part_left + part_right) / 2);
3875 pc_right = pc_left;
3876 u_right = pc_left - 1;
3877 u_left = pc_right + 1;
3878
3879 /* Qsort works best when the pivot value is also the median value
3880 in the partition (unfortunately you can't find the median value
3881 without first sorting :-), so to give the algorithm a helping
3882 hand, we pick 3 elements and sort them and use the median value
3883 of that tiny set as the pivot value.
3884
3885 Some versions of qsort like to use the left middle and right as
3886 the 3 elements to sort so they can insure the ends of the
3887 partition will contain values which will stop the scan in the
3888 compare loop, but when you have to call an arbitrarily complex
3889 routine to do a compare, its really better to just keep track of
3890 array index values to know when you hit the edge of the
3891 partition and avoid the extra compare. An even better reason to
3892 avoid using a compare call is the fact that you can drop off the
3893 edge of the array if someone foolishly provides you with an
3894 unstable compare function that doesn't always provide consistent
3895 results.
3896
3897 So, since it is simpler for us to compare the three adjacent
3898 elements in the middle of the partition, those are the ones we
3899 pick here (conveniently pointed at by u_right, pc_left, and
3900 u_left). The values of the left, center, and right elements
3901 are refered to as l c and r in the following comments.
3902 */
3903
3904#ifdef QSORT_ORDER_GUESS
3905 swapped = 0;
3906#endif
3907 s = qsort_cmp(u_right, pc_left);
3908 if (s < 0) {
3909 /* l < c */
3910 s = qsort_cmp(pc_left, u_left);
3911 /* if l < c, c < r - already in order - nothing to do */
3912 if (s == 0) {
3913 /* l < c, c == r - already in order, pc grows */
3914 ++pc_right;
3915 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3916 } else if (s > 0) {
3917 /* l < c, c > r - need to know more */
3918 s = qsort_cmp(u_right, u_left);
3919 if (s < 0) {
3920 /* l < c, c > r, l < r - swap c & r to get ordered */
3921 qsort_swap(pc_left, u_left);
3922 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3923 } else if (s == 0) {
3924 /* l < c, c > r, l == r - swap c&r, grow pc */
3925 qsort_swap(pc_left, u_left);
3926 --pc_left;
3927 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3928 } else {
3929 /* l < c, c > r, l > r - make lcr into rlc to get ordered */
3930 qsort_rotate(pc_left, u_right, u_left);
3931 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3932 }
3933 }
3934 } else if (s == 0) {
3935 /* l == c */
3936 s = qsort_cmp(pc_left, u_left);
3937 if (s < 0) {
3938 /* l == c, c < r - already in order, grow pc */
3939 --pc_left;
3940 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3941 } else if (s == 0) {
3942 /* l == c, c == r - already in order, grow pc both ways */
3943 --pc_left;
3944 ++pc_right;
3945 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3946 } else {
3947 /* l == c, c > r - swap l & r, grow pc */
3948 qsort_swap(u_right, u_left);
3949 ++pc_right;
3950 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3951 }
3952 } else {
3953 /* l > c */
3954 s = qsort_cmp(pc_left, u_left);
3955 if (s < 0) {
3956 /* l > c, c < r - need to know more */
3957 s = qsort_cmp(u_right, u_left);
3958 if (s < 0) {
3959 /* l > c, c < r, l < r - swap l & c to get ordered */
3960 qsort_swap(u_right, pc_left);
3961 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3962 } else if (s == 0) {
3963 /* l > c, c < r, l == r - swap l & c, grow pc */
3964 qsort_swap(u_right, pc_left);
3965 ++pc_right;
3966 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3967 } else {
3968 /* l > c, c < r, l > r - rotate lcr into crl to order */
3969 qsort_rotate(u_right, pc_left, u_left);
3970 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3971 }
3972 } else if (s == 0) {
3973 /* l > c, c == r - swap ends, grow pc */
3974 qsort_swap(u_right, u_left);
3975 --pc_left;
3976 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3977 } else {
3978 /* l > c, c > r - swap ends to get in order */
3979 qsort_swap(u_right, u_left);
3980 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3981 }
3982 }
3983 /* We now know the 3 middle elements have been compared and
3984 arranged in the desired order, so we can shrink the uncompared
3985 sets on both sides
3986 */
3987 --u_right;
3988 ++u_left;
3989 qsort_all_asserts(pc_left, pc_right, u_left, u_right);
3990
3991 /* The above massive nested if was the simple part :-). We now have
3992 the middle 3 elements ordered and we need to scan through the
3993 uncompared sets on either side, swapping elements that are on
3994 the wrong side or simply shuffling equal elements around to get
3995 all equal elements into the pivot chunk.
3996 */
3997
3998 for ( ; ; ) {
3999 int still_work_on_left;
4000 int still_work_on_right;
4001
4002 /* Scan the uncompared values on the left. If I find a value
4003 equal to the pivot value, move it over so it is adjacent to
4004 the pivot chunk and expand the pivot chunk. If I find a value
4005 less than the pivot value, then just leave it - its already
4006 on the correct side of the partition. If I find a greater
4007 value, then stop the scan.
4008 */
155aba94 4009 while ((still_work_on_left = (u_right >= part_left))) {
745d3a65
HM		 4010 s = qsort_cmp(u_right, pc_left);
4011 if (s < 0) {
4012 --u_right;
4013 } else if (s == 0) {
4014 --pc_left;
4015 if (pc_left != u_right) {
4016 qsort_swap(u_right, pc_left);
4017 }
4018 --u_right;
4019 } else {
4020 break;
4021 }
4022 qsort_assert(u_right < pc_left);
4023 qsort_assert(pc_left <= pc_right);
4024 qsort_assert(qsort_cmp(u_right + 1, pc_left) <= 0);
4025 qsort_assert(qsort_cmp(pc_left, pc_right) == 0);
4026 }
4027
4028 /* Do a mirror image scan of uncompared values on the right
4029 */
155aba94 4030 while ((still_work_on_right = (u_left <= part_right))) {
745d3a65
HM		 4031 s = qsort_cmp(pc_right, u_left);
4032 if (s < 0) {
4033 ++u_left;
4034 } else if (s == 0) {
4035 ++pc_right;
4036 if (pc_right != u_left) {
4037 qsort_swap(pc_right, u_left);
4038 }
4039 ++u_left;
4040 } else {
4041 break;
4042 }
4043 qsort_assert(u_left > pc_right);
4044 qsort_assert(pc_left <= pc_right);
4045 qsort_assert(qsort_cmp(pc_right, u_left - 1) <= 0);
4046 qsort_assert(qsort_cmp(pc_left, pc_right) == 0);
4047 }
4048
4049 if (still_work_on_left) {
4050 /* I know I have a value on the left side which needs to be
4051 on the right side, but I need to know more to decide
4052 exactly the best thing to do with it.
4053 */
4054 if (still_work_on_right) {
4055 /* I know I have values on both side which are out of
4056 position. This is a big win because I kill two birds
4057 with one swap (so to speak). I can advance the
4058 uncompared pointers on both sides after swapping both
4059 of them into the right place.
4060 */
4061 qsort_swap(u_right, u_left);
4062 --u_right;
4063 ++u_left;
4064 qsort_all_asserts(pc_left, pc_right, u_left, u_right);
4065 } else {
4066 /* I have an out of position value on the left, but the
4067 right is fully scanned, so I "slide" the pivot chunk
4068 and any less-than values left one to make room for the
4069 greater value over on the right. If the out of position
4070 value is immediately adjacent to the pivot chunk (there
4071 are no less-than values), I can do that with a swap,
4072 otherwise, I have to rotate one of the less than values
4073 into the former position of the out of position value
4074 and the right end of the pivot chunk into the left end
4075 (got all that?).
4076 */
4077 --pc_left;
4078 if (pc_left == u_right) {
4079 qsort_swap(u_right, pc_right);
4080 qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1);
4081 } else {
4082 qsort_rotate(u_right, pc_left, pc_right);
4083 qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1);
4084 }
4085 --pc_right;
4086 --u_right;
4087 }
4088 } else if (still_work_on_right) {
4089 /* Mirror image of complex case above: I have an out of
4090 position value on the right, but the left is fully
4091 scanned, so I need to shuffle things around to make room
4092 for the right value on the left.
4093 */
4094 ++pc_right;
4095 if (pc_right == u_left) {
4096 qsort_swap(u_left, pc_left);
4097 qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right);
4098 } else {
4099 qsort_rotate(pc_right, pc_left, u_left);
4100 qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right);
4101 }
4102 ++pc_left;
4103 ++u_left;
4104 } else {
4105 /* No more scanning required on either side of partition,
4106 break out of loop and figure out next set of partitions
4107 */
4108 break;
4109 }
4110 }
4111
4112 /* The elements in the pivot chunk are now in the right place. They
4113 will never move or be compared again. All I have to do is decide
4114 what to do with the stuff to the left and right of the pivot
4115 chunk.
4116
4117 Notes on the QSORT_ORDER_GUESS ifdef code:
4118
4119 1. If I just built these partitions without swapping any (or
4120 very many) elements, there is a chance that the elements are
4121 already ordered properly (being properly ordered will
4122 certainly result in no swapping, but the converse can't be
4123 proved :-).
4124
4125 2. A (properly written) insertion sort will run faster on
4126 already ordered data than qsort will.
4127
4128 3. Perhaps there is some way to make a good guess about
4129 switching to an insertion sort earlier than partition size 6
4130 (for instance - we could save the partition size on the stack
4131 and increase the size each time we find we didn't swap, thus
4132 switching to insertion sort earlier for partitions with a
4133 history of not swapping).
4134
4135 4. Naturally, if I just switch right away, it will make
4136 artificial benchmarks with pure ascending (or descending)
4137 data look really good, but is that a good reason in general?
4138 Hard to say...
4139 */
4140
4141#ifdef QSORT_ORDER_GUESS
4142 if (swapped < 3) {
4143#if QSORT_ORDER_GUESS == 1
4144 qsort_break_even = (part_right - part_left) + 1;
4145#endif
4146#if QSORT_ORDER_GUESS == 2
4147 qsort_break_even *= 2;
4148#endif
4149#if QSORT_ORDER_GUESS == 3
4150 int prev_break = qsort_break_even;
4151 qsort_break_even *= qsort_break_even;
4152 if (qsort_break_even < prev_break) {
4153 qsort_break_even = (part_right - part_left) + 1;
4154 }
4155#endif
4156 } else {
4157 qsort_break_even = QSORT_BREAK_EVEN;
4158 }
4159#endif
4160
4161 if (part_left < pc_left) {
4162 /* There are elements on the left which need more processing.
4163 Check the right as well before deciding what to do.
4164 */
4165 if (pc_right < part_right) {
4166 /* We have two partitions to be sorted. Stack the biggest one
4167 and process the smallest one on the next iteration. This
4168 minimizes the stack height by insuring that any additional
4169 stack entries must come from the smallest partition which
4170 (because it is smallest) will have the fewest
4171 opportunities to generate additional stack entries.
4172 */
4173 if ((part_right - pc_right) > (pc_left - part_left)) {
4174 /* stack the right partition, process the left */
4175 partition_stack[next_stack_entry].left = pc_right + 1;
4176 partition_stack[next_stack_entry].right = part_right;
4177#ifdef QSORT_ORDER_GUESS
4178 partition_stack[next_stack_entry].qsort_break_even = qsort_break_even;
4179#endif
4180 part_right = pc_left - 1;
4181 } else {
4182 /* stack the left partition, process the right */
4183 partition_stack[next_stack_entry].left = part_left;
4184 partition_stack[next_stack_entry].right = pc_left - 1;
4185#ifdef QSORT_ORDER_GUESS
4186 partition_stack[next_stack_entry].qsort_break_even = qsort_break_even;
4187#endif
4188 part_left = pc_right + 1;
4189 }
4190 qsort_assert(next_stack_entry < QSORT_MAX_STACK);
4191 ++next_stack_entry;
4192 } else {
4193 /* The elements on the left are the only remaining elements
4194 that need sorting, arrange for them to be processed as the
4195 next partition.
4196 */
4197 part_right = pc_left - 1;
4198 }
4199 } else if (pc_right < part_right) {
4200 /* There is only one chunk on the right to be sorted, make it
4201 the new partition and loop back around.
4202 */
4203 part_left = pc_right + 1;
4204 } else {
4205 /* This whole partition wound up in the pivot chunk, so
4206 we need to get a new partition off the stack.
4207 */
4208 if (next_stack_entry == 0) {
4209 /* the stack is empty - we are done */
4210 break;
4211 }
4212 --next_stack_entry;
4213 part_left = partition_stack[next_stack_entry].left;
4214 part_right = partition_stack[next_stack_entry].right;
4215#ifdef QSORT_ORDER_GUESS
4216 qsort_break_even = partition_stack[next_stack_entry].qsort_break_even;
4217#endif
4218 }
4219 } else {
4220 /* This partition is too small to fool with qsort complexity, just
4221 do an ordinary insertion sort to minimize overhead.
4222 */
4223 int i;
4224 /* Assume 1st element is in right place already, and start checking
4225 at 2nd element to see where it should be inserted.
4226 */
4227 for (i = part_left + 1; i <= part_right; ++i) {
4228 int j;
4229 /* Scan (backwards - just in case 'i' is already in right place)
4230 through the elements already sorted to see if the ith element
4231 belongs ahead of one of them.
4232 */
4233 for (j = i - 1; j >= part_left; --j) {
4234 if (qsort_cmp(i, j) >= 0) {
4235 /* i belongs right after j
4236 */
4237 break;
4238 }
4239 }
4240 ++j;
4241 if (j != i) {
4242 /* Looks like we really need to move some things
4243 */
b6917549 4244 int k;
745d3a65 4245 temp = array[i];
b6917549
HM		 4246 for (k = i - 1; k >= j; --k)
4247 array[k + 1] = array[k];
745d3a65
HM		 4248 array[j] = temp;
4249 }
4250 }
4251
4252 /* That partition is now sorted, grab the next one, or get out
4253 of the loop if there aren't any more.
4254 */
4255
4256 if (next_stack_entry == 0) {
4257 /* the stack is empty - we are done */
4258 break;
4259 }
4260 --next_stack_entry;
4261 part_left = partition_stack[next_stack_entry].left;
4262 part_right = partition_stack[next_stack_entry].right;
4263#ifdef QSORT_ORDER_GUESS
4264 qsort_break_even = partition_stack[next_stack_entry].qsort_break_even;
4265#endif
4266 }
4267 }
4268
4269 /* Believe it or not, the array is sorted at this point! */
4270}
51371543
GS		 4271
4272
4273#ifdef PERL_OBJECT
51371543
GS		 4274#undef this
4275#define this pPerl
4276#include "XSUB.h"
4277#endif
4278
4279
4280static I32
4281sortcv(pTHXo_ SV *a, SV *b)
4282{
4283 dTHR;
4284 I32 oldsaveix = PL_savestack_ix;
4285 I32 oldscopeix = PL_scopestack_ix;
4286 I32 result;
4287 GvSV(PL_firstgv) = a;
4288 GvSV(PL_secondgv) = b;
4289 PL_stack_sp = PL_stack_base;
4290 PL_op = PL_sortcop;
4291 CALLRUNOPS(aTHX);
4292 if (PL_stack_sp != PL_stack_base + 1)
4293 Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4294 if (!SvNIOKp(*PL_stack_sp))
4295 Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4296 result = SvIV(*PL_stack_sp);
4297 while (PL_scopestack_ix > oldscopeix) {
43481408
GS		 4298 LEAVE;
4299 }
4300 leave_scope(oldsaveix);
4301 return result;
4302}
4303
4304static I32
4305sortcv_stacked(pTHXo_ SV *a, SV *b)
4306{
4307 dTHR;
4308 I32 oldsaveix = PL_savestack_ix;
4309 I32 oldscopeix = PL_scopestack_ix;
4310 I32 result;
47916595
GS		 4311 AV *av;
4312
4313#ifdef USE_THREADS
4314 av = (AV*)PL_curpad[0];
4315#else
4316 av = GvAV(PL_defgv);
4317#endif
43481408
GS		 4318
4319 if (AvMAX(av) < 1) {
4320 SV** ary = AvALLOC(av);
4321 if (AvARRAY(av) != ary) {
4322 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
4323 SvPVX(av) = (char*)ary;
4324 }
4325 if (AvMAX(av) < 1) {
4326 AvMAX(av) = 1;
4327 Renew(ary,2,SV*);
4328 SvPVX(av) = (char*)ary;
4329 }
4330 }
4331 AvFILLp(av) = 1;
4332
4333 AvARRAY(av)[0] = a;
4334 AvARRAY(av)[1] = b;
4335 PL_stack_sp = PL_stack_base;
4336 PL_op = PL_sortcop;
4337 CALLRUNOPS(aTHX);
4338 if (PL_stack_sp != PL_stack_base + 1)
4339 Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4340 if (!SvNIOKp(*PL_stack_sp))
4341 Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4342 result = SvIV(*PL_stack_sp);
4343 while (PL_scopestack_ix > oldscopeix) {
4344 LEAVE;
4345 }
4346 leave_scope(oldsaveix);
4347 return result;
4348}
4349
4350static I32
4351sortcv_xsub(pTHXo_ SV *a, SV *b)
4352{
4353 dSP;
4354 I32 oldsaveix = PL_savestack_ix;
4355 I32 oldscopeix = PL_scopestack_ix;
4356 I32 result;
4357 CV *cv=(CV*)PL_sortcop;
4358
4359 SP = PL_stack_base;
4360 PUSHMARK(SP);
4361 EXTEND(SP, 2);
4362 *++SP = a;
4363 *++SP = b;
4364 PUTBACK;
4365 (void)(*CvXSUB(cv))(aTHXo_ cv);
4366 if (PL_stack_sp != PL_stack_base + 1)
4367 Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4368 if (!SvNIOKp(*PL_stack_sp))
4369 Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4370 result = SvIV(*PL_stack_sp);
4371 while (PL_scopestack_ix > oldscopeix) {
51371543
GS		 4372 LEAVE;
4373 }
4374 leave_scope(oldsaveix);
4375 return result;
4376}
4377
4378
4379static I32
4380sv_ncmp(pTHXo_ SV *a, SV *b)
4381{
4382 NV nv1 = SvNV(a);
4383 NV nv2 = SvNV(b);
4384 return nv1 < nv2 ? -1 : nv1 > nv2 ? 1 : 0;
4385}
4386
4387static I32
4388sv_i_ncmp(pTHXo_ SV *a, SV *b)
4389{
4390 IV iv1 = SvIV(a);
4391 IV iv2 = SvIV(b);
4392 return iv1 < iv2 ? -1 : iv1 > iv2 ? 1 : 0;
4393}
4394#define tryCALL_AMAGICbin(left,right,meth,svp) STMT_START { \
4395 *svp = Nullsv; \
4396 if (PL_amagic_generation) { \
4397 if (SvAMAGIC(left)||SvAMAGIC(right))\
4398 *svp = amagic_call(left, \
4399 right, \
4400 CAT2(meth,_amg), \
4401 0); \
4402 } \
4403 } STMT_END
4404
4405static I32
4406amagic_ncmp(pTHXo_ register SV *a, register SV *b)
4407{
4408 SV *tmpsv;
4409 tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
4410 if (tmpsv) {
4411 NV d;
4412
4413 if (SvIOK(tmpsv)) {
4414 I32 i = SvIVX(tmpsv);
4415 if (i > 0)
4416 return 1;
4417 return i? -1 : 0;
4418 }
4419 d = SvNV(tmpsv);
4420 if (d > 0)
4421 return 1;
4422 return d? -1 : 0;
4423 }
4424 return sv_ncmp(aTHXo_ a, b);
4425}
4426
4427static I32
4428amagic_i_ncmp(pTHXo_ register SV *a, register SV *b)
4429{
4430 SV *tmpsv;
4431 tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
4432 if (tmpsv) {
4433 NV d;
4434
4435 if (SvIOK(tmpsv)) {
4436 I32 i = SvIVX(tmpsv);
4437 if (i > 0)
4438 return 1;
4439 return i? -1 : 0;
4440 }
4441 d = SvNV(tmpsv);
4442 if (d > 0)
4443 return 1;
4444 return d? -1 : 0;
4445 }
4446 return sv_i_ncmp(aTHXo_ a, b);
4447}
4448
4449static I32
4450amagic_cmp(pTHXo_ register SV *str1, register SV *str2)
4451{
4452 SV *tmpsv;
4453 tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
4454 if (tmpsv) {
4455 NV d;
4456
4457 if (SvIOK(tmpsv)) {
4458 I32 i = SvIVX(tmpsv);
4459 if (i > 0)
4460 return 1;
4461 return i? -1 : 0;
4462 }
4463 d = SvNV(tmpsv);
4464 if (d > 0)
4465 return 1;
4466 return d? -1 : 0;
4467 }
4468 return sv_cmp(str1, str2);
4469}
4470
4471static I32
4472amagic_cmp_locale(pTHXo_ register SV *str1, register SV *str2)
4473{
4474 SV *tmpsv;
4475 tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
4476 if (tmpsv) {
4477 NV d;
4478
4479 if (SvIOK(tmpsv)) {
4480 I32 i = SvIVX(tmpsv);
4481 if (i > 0)
4482 return 1;
4483 return i? -1 : 0;
4484 }
4485 d = SvNV(tmpsv);
4486 if (d > 0)
4487 return 1;
4488 return d? -1 : 0;
4489 }
4490 return sv_cmp_locale(str1, str2);
4491}
4492
bbed91b5
KF		 4493static I32
4494run_user_filter(pTHXo_ int idx, SV *buf_sv, int maxlen)
4495{
4496 SV *datasv = FILTER_DATA(idx);
4497 int filter_has_file = IoLINES(datasv);
4498 GV *filter_child_proc = (GV *)IoFMT_GV(datasv);
4499 SV *filter_state = (SV *)IoTOP_GV(datasv);
4500 SV *filter_sub = (SV *)IoBOTTOM_GV(datasv);
4501 int len = 0;
4502
4503 /* I was having segfault trouble under Linux 2.2.5 after a
4504 parse error occured. (Had to hack around it with a test
4505 for PL_error_count == 0.) Solaris doesn't segfault --
4506 not sure where the trouble is yet. XXX */
4507
4508 if (filter_has_file) {
4509 len = FILTER_READ(idx+1, buf_sv, maxlen);
4510 }
4511
4512 if (filter_sub && len >= 0) {
4513 djSP;
4514 int count;
4515
4516 ENTER;
4517 SAVE_DEFSV;
4518 SAVETMPS;
4519 EXTEND(SP, 2);
4520
4521 DEFSV = buf_sv;
4522 PUSHMARK(SP);
4523 PUSHs(sv_2mortal(newSViv(maxlen)));
4524 if (filter_state) {
4525 PUSHs(filter_state);
4526 }
4527 PUTBACK;
4528 count = call_sv(filter_sub, G_SCALAR);
4529 SPAGAIN;
4530
4531 if (count > 0) {
4532 SV *out = POPs;
4533 if (SvOK(out)) {
4534 len = SvIV(out);
4535 }
4536 }
4537
4538 PUTBACK;
4539 FREETMPS;
4540 LEAVE;
4541 }
4542
4543 if (len <= 0) {
4544 IoLINES(datasv) = 0;
4545 if (filter_child_proc) {
4546 SvREFCNT_dec(filter_child_proc);
4547 IoFMT_GV(datasv) = Nullgv;
4548 }
4549 if (filter_state) {
4550 SvREFCNT_dec(filter_state);
4551 IoTOP_GV(datasv) = Nullgv;
4552 }
4553 if (filter_sub) {
4554 SvREFCNT_dec(filter_sub);
4555 IoBOTTOM_GV(datasv) = Nullgv;
4556 }
4557 filter_del(run_user_filter);
4558 }
4559
4560 return len;
4561}
4562
e7513ba0
GS		 4563#ifdef PERL_OBJECT
4564
51371543
GS		 4565static I32
4566sv_cmp_locale_static(pTHXo_ register SV *str1, register SV *str2)
4567{
4568 return sv_cmp_locale(str1, str2);
4569}
4570
4571static I32
4572sv_cmp_static(pTHXo_ register SV *str1, register SV *str2)
4573{
4574 return sv_cmp(str1, str2);
4575}
e7513ba0
GS		 4576
4577#endif /* PERL_OBJECT */
Unnamed repository; edit this file 'description' to name the repository.