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