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