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