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