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