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