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