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