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