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