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
make sprintf("%g",...) threadsafe; only taint its result iff the
[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
42718184 226 *p++ = (UV)PTR_CAST (RX_MATCH_COPIED(rx) ? rx->subbeg : Nullch);
cf93c79d 227 RX_MATCH_COPIED_off(rx);
c90c0ff4 228
d9f97599 229 *p++ = rx->nparens;
c90c0ff4 230
42718184 231 *p++ = (UV)PTR_CAST 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
42718184 252 rx->subbeg = (char*)PTR_CAST (*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) {
42718184 266 Safefree((char*)PTR_CAST (*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
a0d0e21e 1250OP *
864dbfa3 1251Perl_die_where(pTHX_ char *message, STRLEN msglen)
a0d0e21e 1252{
e336de0d 1253 dSP;
2d8e6c8d 1254 STRLEN n_a;
3280af22 1255 if (PL_in_eval) {
a0d0e21e 1256 I32 cxix;
c09156bb 1257 register PERL_CONTEXT *cx;
a0d0e21e
LW		 1258 I32 gimme;
1259 SV **newsp;
1260
4e6ea2c3 1261 if (message) {
faef0170 1262 if (PL_in_eval & EVAL_KEEPERR) {
4e6ea2c3 1263 SV **svp;
4e6ea2c3 1264
06bf62c7 1265 svp = hv_fetch(ERRHV, message, msglen, TRUE);
4e6ea2c3
GS		 1266 if (svp) {
1267 if (!SvIOK(*svp)) {
1268 static char prefix[] = "\t(in cleanup) ";
1269 SV *err = ERRSV;
1270 sv_upgrade(*svp, SVt_IV);
1271 (void)SvIOK_only(*svp);
1272 if (!SvPOK(err))
1273 sv_setpv(err,"");
06bf62c7 1274 SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
4e6ea2c3 1275 sv_catpvn(err, prefix, sizeof(prefix)-1);
06bf62c7 1276 sv_catpvn(err, message, msglen);
b5d92ff4 1277 if (ckWARN(WARN_UNSAFE)) {
06bf62c7 1278 STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
cea2e8a9 1279 Perl_warner(aTHX_ WARN_UNSAFE, SvPVX(err)+start);
b5d92ff4 1280 }
4e6ea2c3
GS		 1281 }
1282 sv_inc(*svp);
4633a7c4 1283 }
4633a7c4 1284 }
4e6ea2c3 1285 else
06bf62c7 1286 sv_setpvn(ERRSV, message, msglen);
4633a7c4
LW		 1287 }
1288 else
06bf62c7 1289 message = SvPVx(ERRSV, msglen);
4e6ea2c3 1290
3280af22 1291 while ((cxix = dopoptoeval(cxstack_ix)) < 0 && PL_curstackinfo->si_prev) {
bac4b2ad 1292 dounwind(-1);
d3acc0f7 1293 POPSTACK;
bac4b2ad 1294 }
e336de0d 1295
a0d0e21e
LW		 1296 if (cxix >= 0) {
1297 I32 optype;
1298
1299 if (cxix < cxstack_ix)
1300 dounwind(cxix);
1301
3280af22 1302 POPBLOCK(cx,PL_curpm);
6b35e009 1303 if (CxTYPE(cx) != CXt_EVAL) {
06bf62c7
GS		 1304 PerlIO_write(PerlIO_stderr(), "panic: die ", 11);
1305 PerlIO_write(PerlIO_stderr(), message, msglen);
a0d0e21e
LW		 1306 my_exit(1);
1307 }
1308 POPEVAL(cx);
1309
1310 if (gimme == G_SCALAR)
3280af22
NIS		 1311 *++newsp = &PL_sv_undef;
1312 PL_stack_sp = newsp;
a0d0e21e
LW		 1313
1314 LEAVE;
748a9306 1315
7a2e2cd6 1316 if (optype == OP_REQUIRE) {
2d8e6c8d 1317 char* msg = SvPVx(ERRSV, n_a);
cea2e8a9 1318 DIE(aTHX_ "%s", *msg ? msg : "Compilation failed in require");
7a2e2cd6 1319 }
a0d0e21e
LW		 1320 return pop_return();
1321 }
1322 }
9cc2fdd3 1323 if (!message)
06bf62c7 1324 message = SvPVx(ERRSV, msglen);
d175a3f0
GS		 1325 {
1326#ifdef USE_SFIO
1327 /* SFIO can really mess with your errno */
1328 int e = errno;
1329#endif
06bf62c7 1330 PerlIO_write(PerlIO_stderr(), message, msglen);
d175a3f0
GS		 1331 (void)PerlIO_flush(PerlIO_stderr());
1332#ifdef USE_SFIO
1333 errno = e;
1334#endif
1335 }
f86702cc 1336 my_failure_exit();
1337 /* NOTREACHED */
a0d0e21e
LW		 1338 return 0;
1339}
1340
1341PP(pp_xor)
1342{
4e35701f 1343 djSP; dPOPTOPssrl;
a0d0e21e
LW		 1344 if (SvTRUE(left) != SvTRUE(right))
1345 RETSETYES;
1346 else
1347 RETSETNO;
1348}
1349
1350PP(pp_andassign)
1351{
4e35701f 1352 djSP;
a0d0e21e
LW		 1353 if (!SvTRUE(TOPs))
1354 RETURN;
1355 else
1356 RETURNOP(cLOGOP->op_other);
1357}
1358
1359PP(pp_orassign)
1360{
4e35701f 1361 djSP;
a0d0e21e
LW		 1362 if (SvTRUE(TOPs))
1363 RETURN;
1364 else
1365 RETURNOP(cLOGOP->op_other);
1366}
1367
a0d0e21e
LW		 1368PP(pp_caller)
1369{
4e35701f 1370 djSP;
a0d0e21e 1371 register I32 cxix = dopoptosub(cxstack_ix);
c09156bb 1372 register PERL_CONTEXT *cx;
2c375eb9 1373 register PERL_CONTEXT *ccstack = cxstack;
3280af22 1374 PERL_SI *top_si = PL_curstackinfo;
a0d0e21e 1375 I32 dbcxix;
54310121 1376 I32 gimme;
49d8d3a1 1377 HV *hv;
a0d0e21e
LW		 1378 SV *sv;
1379 I32 count = 0;
1380
1381 if (MAXARG)
1382 count = POPi;
f3aa04c2 1383 EXTEND(SP, 7);
a0d0e21e 1384 for (;;) {
2c375eb9
GS		 1385 /* we may be in a higher stacklevel, so dig down deeper */
1386 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1387 top_si = top_si->si_prev;
1388 ccstack = top_si->si_cxstack;
1389 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1390 }
a0d0e21e
LW		 1391 if (cxix < 0) {
1392 if (GIMME != G_ARRAY)
1393 RETPUSHUNDEF;
1394 RETURN;
1395 }
3280af22
NIS		 1396 if (PL_DBsub && cxix >= 0 &&
1397 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
a0d0e21e
LW		 1398 count++;
1399 if (!count--)
1400 break;
2c375eb9 1401 cxix = dopoptosub_at(ccstack, cxix - 1);
a0d0e21e 1402 }
2c375eb9
GS		 1403
1404 cx = &ccstack[cxix];
6b35e009 1405 if (CxTYPE(cx) == CXt_SUB) {
2c375eb9
GS		 1406 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1407 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
06a5b730 1408 field below is defined for any cx. */
3280af22 1409 if (PL_DBsub && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
2c375eb9 1410 cx = &ccstack[dbcxix];
06a5b730 1411 }
1412
a0d0e21e 1413 if (GIMME != G_ARRAY) {
49d8d3a1
MB		 1414 hv = cx->blk_oldcop->cop_stash;
1415 if (!hv)
3280af22 1416 PUSHs(&PL_sv_undef);
49d8d3a1
MB		 1417 else {
1418 dTARGET;
1419 sv_setpv(TARG, HvNAME(hv));
1420 PUSHs(TARG);
1421 }
a0d0e21e
LW		 1422 RETURN;
1423 }
a0d0e21e 1424
49d8d3a1
MB		 1425 hv = cx->blk_oldcop->cop_stash;
1426 if (!hv)
3280af22 1427 PUSHs(&PL_sv_undef);
49d8d3a1
MB		 1428 else
1429 PUSHs(sv_2mortal(newSVpv(HvNAME(hv), 0)));
79cb57f6
GS		 1430 PUSHs(sv_2mortal(newSVpvn(SvPVX(GvSV(cx->blk_oldcop->cop_filegv)),
1431 SvCUR(GvSV(cx->blk_oldcop->cop_filegv)))));
a0d0e21e
LW		 1432 PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->cop_line)));
1433 if (!MAXARG)
1434 RETURN;
6b35e009 1435 if (CxTYPE(cx) == CXt_SUB) { /* So is ccstack[dbcxix]. */
a0d0e21e 1436 sv = NEWSV(49, 0);
2c375eb9 1437 gv_efullname3(sv, CvGV(ccstack[cxix].blk_sub.cv), Nullch);
a0d0e21e
LW		 1438 PUSHs(sv_2mortal(sv));
1439 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1440 }
1441 else {
79cb57f6 1442 PUSHs(sv_2mortal(newSVpvn("(eval)",6)));
a0d0e21e
LW		 1443 PUSHs(sv_2mortal(newSViv(0)));
1444 }
54310121 1445 gimme = (I32)cx->blk_gimme;
1446 if (gimme == G_VOID)
3280af22 1447 PUSHs(&PL_sv_undef);
54310121 1448 else
1449 PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
6b35e009 1450 if (CxTYPE(cx) == CXt_EVAL) {
06a5b730 1451 if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
4633a7c4 1452 PUSHs(cx->blk_eval.cur_text);
3280af22 1453 PUSHs(&PL_sv_no);
06a5b730 1454 }
1455 else if (cx->blk_eval.old_name) { /* Try blocks have old_name == 0. */
1456 /* Require, put the name. */
1457 PUSHs(sv_2mortal(newSVpv(cx->blk_eval.old_name, 0)));
3280af22 1458 PUSHs(&PL_sv_yes);
06a5b730 1459 }
4633a7c4 1460 }
a682de96
GS		 1461 else {
1462 PUSHs(&PL_sv_undef);
1463 PUSHs(&PL_sv_undef);
1464 }
1465 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs
1466 && PL_curcop->cop_stash == PL_debstash)
4633a7c4 1467 {
a0d0e21e
LW		 1468 AV *ary = cx->blk_sub.argarray;
1469 int off = AvARRAY(ary) - AvALLOC(ary);
1470
3280af22 1471 if (!PL_dbargs) {
a0d0e21e 1472 GV* tmpgv;
3280af22 1473 PL_dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE,
a0d0e21e 1474 SVt_PVAV)));
a5f75d66 1475 GvMULTI_on(tmpgv);
3280af22 1476 AvREAL_off(PL_dbargs); /* XXX Should be REIFY */
a0d0e21e
LW		 1477 }
1478
3280af22
NIS		 1479 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1480 av_extend(PL_dbargs, AvFILLp(ary) + off);
1481 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1482 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
a0d0e21e 1483 }
f3aa04c2
GS		 1484 /* XXX only hints propagated via op_private are currently
1485 * visible (others are not easily accessible, since they
1486 * use the global PL_hints) */
1487 PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->op_private &
1488 HINT_PRIVATE_MASK)));
a0d0e21e
LW		 1489 RETURN;
1490}
1491
a0d0e21e
LW		 1492PP(pp_reset)
1493{
4e35701f 1494 djSP;
a0d0e21e 1495 char *tmps;
2d8e6c8d 1496 STRLEN n_a;
a0d0e21e
LW		 1497
1498 if (MAXARG < 1)
1499 tmps = "";
1500 else
2d8e6c8d 1501 tmps = POPpx;
3280af22
NIS		 1502 sv_reset(tmps, PL_curcop->cop_stash);
1503 PUSHs(&PL_sv_yes);
a0d0e21e
LW		 1504 RETURN;
1505}
1506
1507PP(pp_lineseq)
1508{
1509 return NORMAL;
1510}
1511
1512PP(pp_dbstate)
1513{
533c011a 1514 PL_curcop = (COP*)PL_op;
a0d0e21e 1515 TAINT_NOT; /* Each statement is presumed innocent */
3280af22 1516 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
a0d0e21e
LW		 1517 FREETMPS;
1518
533c011a 1519 if (PL_op->op_private || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
a0d0e21e 1520 {
924508f0 1521 djSP;
a0d0e21e 1522 register CV *cv;
c09156bb 1523 register PERL_CONTEXT *cx;
748a9306 1524 I32 gimme = G_ARRAY;
a0d0e21e
LW		 1525 I32 hasargs;
1526 GV *gv;
1527
3280af22 1528 gv = PL_DBgv;
a0d0e21e 1529 cv = GvCV(gv);
a0d0e21e 1530 if (!cv)
cea2e8a9 1531 DIE(aTHX_ "No DB::DB routine defined");
a0d0e21e 1532
3280af22 1533 if (CvDEPTH(cv) >= 1 && !(PL_debug & (1<<30))) /* don't do recursive DB::DB call */
a0d0e21e 1534 return NORMAL;
748a9306 1535
4633a7c4
LW		 1536 ENTER;
1537 SAVETMPS;
1538
3280af22 1539 SAVEI32(PL_debug);
55497cff 1540 SAVESTACK_POS();
3280af22 1541 PL_debug = 0;
748a9306 1542 hasargs = 0;
924508f0 1543 SPAGAIN;
748a9306 1544
533c011a 1545 push_return(PL_op->op_next);
924508f0 1546 PUSHBLOCK(cx, CXt_SUB, SP);
a0d0e21e
LW		 1547 PUSHSUB(cx);
1548 CvDEPTH(cv)++;
1549 (void)SvREFCNT_inc(cv);
3280af22
NIS		 1550 SAVESPTR(PL_curpad);
1551 PL_curpad = AvARRAY((AV*)*av_fetch(CvPADLIST(cv),1,FALSE));
a0d0e21e
LW		 1552 RETURNOP(CvSTART(cv));
1553 }
1554 else
1555 return NORMAL;
1556}
1557
1558PP(pp_scope)
1559{
1560 return NORMAL;
1561}
1562
1563PP(pp_enteriter)
1564{
4e35701f 1565 djSP; dMARK;
c09156bb 1566 register PERL_CONTEXT *cx;
54310121 1567 I32 gimme = GIMME_V;
a0d0e21e
LW		 1568 SV **svp;
1569
4633a7c4
LW		 1570 ENTER;
1571 SAVETMPS;
1572
54b9620d 1573#ifdef USE_THREADS
0214ae40
GS		 1574 if (PL_op->op_flags & OPf_SPECIAL) {
1575 dTHR;
1576 svp = &THREADSV(PL_op->op_targ); /* per-thread variable */
1577 SAVEGENERICSV(*svp);
1578 *svp = NEWSV(0,0);
1579 }
a0d0e21e 1580 else
54b9620d 1581#endif /* USE_THREADS */
533c011a
NIS		 1582 if (PL_op->op_targ) {
1583 svp = &PL_curpad[PL_op->op_targ]; /* "my" variable */
54b9620d
MB		 1584 SAVESPTR(*svp);
1585 }
1586 else {
0214ae40
GS		 1587 svp = &GvSV((GV*)POPs); /* symbol table variable */
1588 SAVEGENERICSV(*svp);
1589 *svp = NEWSV(0,0);
54b9620d 1590 }
4633a7c4 1591
a0d0e21e
LW		 1592 ENTER;
1593
1594 PUSHBLOCK(cx, CXt_LOOP, SP);
1595 PUSHLOOP(cx, svp, MARK);
533c011a 1596 if (PL_op->op_flags & OPf_STACKED) {
44a8e56a 1597 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
89ea2908
GA		 1598 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1599 dPOPss;
1600 if (SvNIOKp(sv) || !SvPOKp(sv) ||
1601 (looks_like_number(sv) && *SvPVX(sv) != '0')) {
1602 if (SvNV(sv) < IV_MIN ||
1603 SvNV((SV*)cx->blk_loop.iterary) >= IV_MAX)
cea2e8a9 1604 Perl_croak(aTHX_ "Range iterator outside integer range");
89ea2908
GA		 1605 cx->blk_loop.iterix = SvIV(sv);
1606 cx->blk_loop.itermax = SvIV((SV*)cx->blk_loop.iterary);
1607 }
1608 else
1609 cx->blk_loop.iterlval = newSVsv(sv);
1610 }
1611 }
4633a7c4 1612 else {
3280af22
NIS		 1613 cx->blk_loop.iterary = PL_curstack;
1614 AvFILLp(PL_curstack) = SP - PL_stack_base;
1615 cx->blk_loop.iterix = MARK - PL_stack_base;
4633a7c4 1616 }
a0d0e21e
LW		 1617
1618 RETURN;
1619}
1620
1621PP(pp_enterloop)
1622{
4e35701f 1623 djSP;
c09156bb 1624 register PERL_CONTEXT *cx;
54310121 1625 I32 gimme = GIMME_V;
a0d0e21e
LW		 1626
1627 ENTER;
1628 SAVETMPS;
1629 ENTER;
1630
1631 PUSHBLOCK(cx, CXt_LOOP, SP);
1632 PUSHLOOP(cx, 0, SP);
1633
1634 RETURN;
1635}
1636
1637PP(pp_leaveloop)
1638{
4e35701f 1639 djSP;
c09156bb 1640 register PERL_CONTEXT *cx;
f86702cc 1641 struct block_loop cxloop;
a0d0e21e
LW		 1642 I32 gimme;
1643 SV **newsp;
1644 PMOP *newpm;
1645 SV **mark;
1646
1647 POPBLOCK(cx,newpm);
4fdae800 1648 mark = newsp;
f86702cc 1649 POPLOOP1(cx); /* Delay POPLOOP2 until stack values are safe */
1650
a1f49e72 1651 TAINT_NOT;
54310121 1652 if (gimme == G_VOID)
1653 ; /* do nothing */
1654 else if (gimme == G_SCALAR) {
1655 if (mark < SP)
1656 *++newsp = sv_mortalcopy(*SP);
1657 else
3280af22 1658 *++newsp = &PL_sv_undef;
a0d0e21e
LW		 1659 }
1660 else {
a1f49e72 1661 while (mark < SP) {
a0d0e21e 1662 *++newsp = sv_mortalcopy(*++mark);
a1f49e72
CS		 1663 TAINT_NOT; /* Each item is independent */
1664 }
a0d0e21e 1665 }
f86702cc 1666 SP = newsp;
1667 PUTBACK;
1668
1669 POPLOOP2(); /* Stack values are safe: release loop vars ... */
3280af22 1670 PL_curpm = newpm; /* ... and pop $1 et al */
f86702cc 1671
a0d0e21e
LW		 1672 LEAVE;
1673 LEAVE;
1674
f86702cc 1675 return NORMAL;
a0d0e21e
LW		 1676}
1677
1678PP(pp_return)
1679{
4e35701f 1680 djSP; dMARK;
a0d0e21e 1681 I32 cxix;
c09156bb 1682 register PERL_CONTEXT *cx;
f86702cc 1683 struct block_sub cxsub;
1684 bool popsub2 = FALSE;
a0d0e21e
LW		 1685 I32 gimme;
1686 SV **newsp;
1687 PMOP *newpm;
1688 I32 optype = 0;
1689
3280af22
NIS		 1690 if (PL_curstackinfo->si_type == PERLSI_SORT) {
1691 if (cxstack_ix == PL_sortcxix || dopoptosub(cxstack_ix) <= PL_sortcxix) {
1692 if (cxstack_ix > PL_sortcxix)
1693 dounwind(PL_sortcxix);
1694 AvARRAY(PL_curstack)[1] = *SP;
1695 PL_stack_sp = PL_stack_base + 1;
a0d0e21e
LW		 1696 return 0;
1697 }
1698 }
1699
1700 cxix = dopoptosub(cxstack_ix);
1701 if (cxix < 0)
cea2e8a9 1702 DIE(aTHX_ "Can't return outside a subroutine");
a0d0e21e
LW		 1703 if (cxix < cxstack_ix)
1704 dounwind(cxix);
1705
1706 POPBLOCK(cx,newpm);
6b35e009 1707 switch (CxTYPE(cx)) {
a0d0e21e 1708 case CXt_SUB:
f86702cc 1709 POPSUB1(cx); /* Delay POPSUB2 until stack values are safe */
1710 popsub2 = TRUE;
a0d0e21e
LW		 1711 break;
1712 case CXt_EVAL:
1713 POPEVAL(cx);
067f92a0
GS		 1714 if (AvFILLp(PL_comppad_name) >= 0)
1715 free_closures();
1716 lex_end();
748a9306
LW		 1717 if (optype == OP_REQUIRE &&
1718 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1719 {
54310121 1720 /* Unassume the success we assumed earlier. */
748a9306 1721 char *name = cx->blk_eval.old_name;
3280af22 1722 (void)hv_delete(GvHVn(PL_incgv), name, strlen(name), G_DISCARD);
cea2e8a9 1723 DIE(aTHX_ "%s did not return a true value", name);
748a9306 1724 }
a0d0e21e
LW		 1725 break;
1726 default:
cea2e8a9 1727 DIE(aTHX_ "panic: return");
a0d0e21e
LW		 1728 }
1729
a1f49e72 1730 TAINT_NOT;
a0d0e21e 1731 if (gimme == G_SCALAR) {
a29cdaf0
IZ		 1732 if (MARK < SP) {
1733 if (popsub2) {
1734 if (cxsub.cv && CvDEPTH(cxsub.cv) > 1) {
1735 if (SvTEMP(TOPs)) {
1736 *++newsp = SvREFCNT_inc(*SP);
1737 FREETMPS;
1738 sv_2mortal(*newsp);
1739 } else {
1740 FREETMPS;
1741 *++newsp = sv_mortalcopy(*SP);
1742 }
1743 } else
1744 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
1745 } else
1746 *++newsp = sv_mortalcopy(*SP);
1747 } else
3280af22 1748 *++newsp = &PL_sv_undef;
a0d0e21e 1749 }
54310121 1750 else if (gimme == G_ARRAY) {
a1f49e72 1751 while (++MARK <= SP) {
f86702cc 1752 *++newsp = (popsub2 && SvTEMP(*MARK))
1753 ? *MARK : sv_mortalcopy(*MARK);
a1f49e72
CS		 1754 TAINT_NOT; /* Each item is independent */
1755 }
a0d0e21e 1756 }
3280af22 1757 PL_stack_sp = newsp;
a0d0e21e 1758
f86702cc 1759 /* Stack values are safe: */
1760 if (popsub2) {
1761 POPSUB2(); /* release CV and @_ ... */
1762 }
3280af22 1763 PL_curpm = newpm; /* ... and pop $1 et al */
f86702cc 1764
a0d0e21e
LW		 1765 LEAVE;
1766 return pop_return();
1767}
1768
1769PP(pp_last)
1770{
4e35701f 1771 djSP;
a0d0e21e 1772 I32 cxix;
c09156bb 1773 register PERL_CONTEXT *cx;
f86702cc 1774 struct block_loop cxloop;
1775 struct block_sub cxsub;
1776 I32 pop2 = 0;
a0d0e21e
LW		 1777 I32 gimme;
1778 I32 optype;
1779 OP *nextop;
1780 SV **newsp;
1781 PMOP *newpm;
3280af22 1782 SV **mark = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
a0d0e21e 1783
533c011a 1784 if (PL_op->op_flags & OPf_SPECIAL) {
a0d0e21e
LW		 1785 cxix = dopoptoloop(cxstack_ix);
1786 if (cxix < 0)
cea2e8a9 1787 DIE(aTHX_ "Can't \"last\" outside a block");
a0d0e21e
LW		 1788 }
1789 else {
1790 cxix = dopoptolabel(cPVOP->op_pv);
1791 if (cxix < 0)
cea2e8a9 1792 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
a0d0e21e
LW		 1793 }
1794 if (cxix < cxstack_ix)
1795 dounwind(cxix);
1796
1797 POPBLOCK(cx,newpm);
6b35e009 1798 switch (CxTYPE(cx)) {
a0d0e21e 1799 case CXt_LOOP:
f86702cc 1800 POPLOOP1(cx); /* Delay POPLOOP2 until stack values are safe */
1801 pop2 = CXt_LOOP;
4fdae800 1802 nextop = cxloop.last_op->op_next;
a0d0e21e 1803 break;
f86702cc 1804 case CXt_SUB:
1805 POPSUB1(cx); /* Delay POPSUB2 until stack values are safe */
1806 pop2 = CXt_SUB;
a0d0e21e
LW		 1807 nextop = pop_return();
1808 break;
f86702cc 1809 case CXt_EVAL:
1810 POPEVAL(cx);
a0d0e21e
LW		 1811 nextop = pop_return();
1812 break;
1813 default:
cea2e8a9 1814 DIE(aTHX_ "panic: last");
a0d0e21e
LW		 1815 }
1816
a1f49e72 1817 TAINT_NOT;
a0d0e21e 1818 if (gimme == G_SCALAR) {
f86702cc 1819 if (MARK < SP)
1820 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
1821 ? *SP : sv_mortalcopy(*SP);
a0d0e21e 1822 else
3280af22 1823 *++newsp = &PL_sv_undef;
a0d0e21e 1824 }
54310121 1825 else if (gimme == G_ARRAY) {
a1f49e72 1826 while (++MARK <= SP) {
f86702cc 1827 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
1828 ? *MARK : sv_mortalcopy(*MARK);
a1f49e72
CS		 1829 TAINT_NOT; /* Each item is independent */
1830 }
f86702cc 1831 }
1832 SP = newsp;
1833 PUTBACK;
1834
1835 /* Stack values are safe: */
1836 switch (pop2) {
1837 case CXt_LOOP:
1838 POPLOOP2(); /* release loop vars ... */
4fdae800 1839 LEAVE;
f86702cc 1840 break;
1841 case CXt_SUB:
1842 POPSUB2(); /* release CV and @_ ... */
1843 break;
a0d0e21e 1844 }
3280af22 1845 PL_curpm = newpm; /* ... and pop $1 et al */
a0d0e21e
LW		 1846
1847 LEAVE;
f86702cc 1848 return nextop;
a0d0e21e
LW		 1849}
1850
1851PP(pp_next)
1852{
1853 I32 cxix;
c09156bb 1854 register PERL_CONTEXT *cx;
a0d0e21e
LW		 1855 I32 oldsave;
1856
533c011a 1857 if (PL_op->op_flags & OPf_SPECIAL) {
a0d0e21e
LW		 1858 cxix = dopoptoloop(cxstack_ix);
1859 if (cxix < 0)
cea2e8a9 1860 DIE(aTHX_ "Can't \"next\" outside a block");
a0d0e21e
LW		 1861 }
1862 else {
1863 cxix = dopoptolabel(cPVOP->op_pv);
1864 if (cxix < 0)
cea2e8a9 1865 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
a0d0e21e
LW		 1866 }
1867 if (cxix < cxstack_ix)
1868 dounwind(cxix);
1869
1870 TOPBLOCK(cx);
3280af22 1871 oldsave = PL_scopestack[PL_scopestack_ix - 1];
a0d0e21e
LW		 1872 LEAVE_SCOPE(oldsave);
1873 return cx->blk_loop.next_op;
1874}
1875
1876PP(pp_redo)
1877{
1878 I32 cxix;
c09156bb 1879 register PERL_CONTEXT *cx;
a0d0e21e
LW		 1880 I32 oldsave;
1881
533c011a 1882 if (PL_op->op_flags & OPf_SPECIAL) {
a0d0e21e
LW		 1883 cxix = dopoptoloop(cxstack_ix);
1884 if (cxix < 0)
cea2e8a9 1885 DIE(aTHX_ "Can't \"redo\" outside a block");
a0d0e21e
LW		 1886 }
1887 else {
1888 cxix = dopoptolabel(cPVOP->op_pv);
1889 if (cxix < 0)
cea2e8a9 1890 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
a0d0e21e
LW		 1891 }
1892 if (cxix < cxstack_ix)
1893 dounwind(cxix);
1894
1895 TOPBLOCK(cx);
3280af22 1896 oldsave = PL_scopestack[PL_scopestack_ix - 1];
a0d0e21e
LW		 1897 LEAVE_SCOPE(oldsave);
1898 return cx->blk_loop.redo_op;
1899}
1900
0824fdcb 1901STATIC OP *
cea2e8a9 1902S_dofindlabel(pTHX_ OP *o, char *label, OP **opstack, OP **oplimit)
a0d0e21e
LW		 1903{
1904 OP *kid;
1905 OP **ops = opstack;
fc36a67e 1906 static char too_deep[] = "Target of goto is too deeply nested";
a0d0e21e 1907
fc36a67e 1908 if (ops >= oplimit)
cea2e8a9 1909 Perl_croak(aTHX_ too_deep);
11343788
MB		 1910 if (o->op_type == OP_LEAVE ||
1911 o->op_type == OP_SCOPE ||
1912 o->op_type == OP_LEAVELOOP ||
1913 o->op_type == OP_LEAVETRY)
fc36a67e 1914 {
5dc0d613 1915 *ops++ = cUNOPo->op_first;
fc36a67e 1916 if (ops >= oplimit)
cea2e8a9 1917 Perl_croak(aTHX_ too_deep);
fc36a67e 1918 }
c4aa4e48 1919 *ops = 0;
11343788 1920 if (o->op_flags & OPf_KIDS) {
5c0ca799 1921 dTHR;
a0d0e21e 1922 /* First try all the kids at this level, since that's likeliest. */
11343788 1923 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
c4aa4e48
GS		 1924 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
1925 kCOP->cop_label && strEQ(kCOP->cop_label, label))
a0d0e21e
LW		 1926 return kid;
1927 }
11343788 1928 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
3280af22 1929 if (kid == PL_lastgotoprobe)
a0d0e21e 1930 continue;
c4aa4e48
GS		 1931 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
1932 (ops == opstack ||
1933 (ops[-1]->op_type != OP_NEXTSTATE &&
1934 ops[-1]->op_type != OP_DBSTATE)))
fc36a67e 1935 *ops++ = kid;
5dc0d613 1936 if (o = dofindlabel(kid, label, ops, oplimit))
11343788 1937 return o;
a0d0e21e
LW		 1938 }
1939 }
c4aa4e48 1940 *ops = 0;
a0d0e21e
LW		 1941 return 0;
1942}
1943
1944PP(pp_dump)
1945{
cea2e8a9 1946 return pp_goto();
a0d0e21e
LW		 1947 /*NOTREACHED*/
1948}
1949
1950PP(pp_goto)
1951{
4e35701f 1952 djSP;
a0d0e21e
LW		 1953 OP *retop = 0;
1954 I32 ix;
c09156bb 1955 register PERL_CONTEXT *cx;
fc36a67e 1956#define GOTO_DEPTH 64
1957 OP *enterops[GOTO_DEPTH];
a0d0e21e 1958 char *label;
533c011a 1959 int do_dump = (PL_op->op_type == OP_DUMP);
1614b0e3 1960 static char must_have_label[] = "goto must have label";
a0d0e21e
LW		 1961
1962 label = 0;
533c011a 1963 if (PL_op->op_flags & OPf_STACKED) {
a0d0e21e 1964 SV *sv = POPs;
2d8e6c8d 1965 STRLEN n_a;
a0d0e21e
LW		 1966
1967 /* This egregious kludge implements goto &subroutine */
1968 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
1969 I32 cxix;
c09156bb 1970 register PERL_CONTEXT *cx;
a0d0e21e
LW		 1971 CV* cv = (CV*)SvRV(sv);
1972 SV** mark;
1973 I32 items = 0;
1974 I32 oldsave;
62b1ebc2 1975 int arg_was_real = 0;
a0d0e21e 1976
e8f7dd13 1977 retry:
4aa0a1f7 1978 if (!CvROOT(cv) && !CvXSUB(cv)) {
e8f7dd13
GS		 1979 GV *gv = CvGV(cv);
1980 GV *autogv;
1981 if (gv) {
1982 SV *tmpstr;
1983 /* autoloaded stub? */
1984 if (cv != GvCV(gv) && (cv = GvCV(gv)))
1985 goto retry;
1986 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
1987 GvNAMELEN(gv), FALSE);
1988 if (autogv && (cv = GvCV(autogv)))
1989 goto retry;
1990 tmpstr = sv_newmortal();
1991 gv_efullname3(tmpstr, gv, Nullch);
cea2e8a9 1992 DIE(aTHX_ "Goto undefined subroutine &%s",SvPVX(tmpstr));
4aa0a1f7 1993 }
cea2e8a9 1994 DIE(aTHX_ "Goto undefined subroutine");
4aa0a1f7
AD		 1995 }
1996
a0d0e21e
LW		 1997 /* First do some returnish stuff. */
1998 cxix = dopoptosub(cxstack_ix);
1999 if (cxix < 0)
cea2e8a9 2000 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
a0d0e21e
LW		 2001 if (cxix < cxstack_ix)
2002 dounwind(cxix);
2003 TOPBLOCK(cx);
6b35e009 2004 if (CxTYPE(cx) == CXt_EVAL && cx->blk_eval.old_op_type == OP_ENTEREVAL)
cea2e8a9 2005 DIE(aTHX_ "Can't goto subroutine from an eval-string");
3280af22 2006 mark = PL_stack_sp;
6b35e009 2007 if (CxTYPE(cx) == CXt_SUB &&
b150fb22 2008 cx->blk_sub.hasargs) { /* put @_ back onto stack */
a0d0e21e
LW		 2009 AV* av = cx->blk_sub.argarray;
2010
93965878 2011 items = AvFILLp(av) + 1;
3280af22
NIS		 2012 PL_stack_sp++;
2013 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2014 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2015 PL_stack_sp += items;
6d4ff0d2 2016#ifndef USE_THREADS
3280af22
NIS		 2017 SvREFCNT_dec(GvAV(PL_defgv));
2018 GvAV(PL_defgv) = cx->blk_sub.savearray;
6d4ff0d2 2019#endif /* USE_THREADS */
62b1ebc2
GS		 2020 if (AvREAL(av)) {
2021 arg_was_real = 1;
2022 AvREAL_off(av); /* so av_clear() won't clobber elts */
2023 }
4633a7c4 2024 av_clear(av);
a0d0e21e 2025 }
1fa4e549
AD		 2026 else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2027 AV* av;
2028 int i;
2029#ifdef USE_THREADS
533c011a 2030 av = (AV*)PL_curpad[0];
1fa4e549 2031#else
3280af22 2032 av = GvAV(PL_defgv);
1fa4e549
AD		 2033#endif
2034 items = AvFILLp(av) + 1;
3280af22
NIS		 2035 PL_stack_sp++;
2036 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2037 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2038 PL_stack_sp += items;
1fa4e549 2039 }
6b35e009 2040 if (CxTYPE(cx) == CXt_SUB &&
b150fb22 2041 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
a0d0e21e 2042 SvREFCNT_dec(cx->blk_sub.cv);
3280af22 2043 oldsave = PL_scopestack[PL_scopestack_ix - 1];
a0d0e21e
LW		 2044 LEAVE_SCOPE(oldsave);
2045
2046 /* Now do some callish stuff. */
2047 SAVETMPS;
2048 if (CvXSUB(cv)) {
67caa1fe 2049#ifdef PERL_XSUB_OLDSTYLE
a0d0e21e 2050 if (CvOLDSTYLE(cv)) {
20ce7b12 2051 I32 (*fp3)(int,int,int);
924508f0
GS		 2052 while (SP > mark) {
2053 SP[1] = SP[0];
2054 SP--;
a0d0e21e 2055 }
20ce7b12 2056 fp3 = (I32(*)(int,int,int)))CvXSUB(cv;
ecfc5424 2057 items = (*fp3)(CvXSUBANY(cv).any_i32,
3280af22 2058 mark - PL_stack_base + 1,
ecfc5424 2059 items);
3280af22 2060 SP = PL_stack_base + items;
a0d0e21e 2061 }
67caa1fe
GS		 2062 else
2063#endif /* PERL_XSUB_OLDSTYLE */
2064 {
1fa4e549
AD		 2065 SV **newsp;
2066 I32 gimme;
2067
3280af22 2068 PL_stack_sp--; /* There is no cv arg. */
1fa4e549
AD		 2069 /* Push a mark for the start of arglist */
2070 PUSHMARK(mark);
0cb96387 2071 (void)(*CvXSUB(cv))(aTHXo_ cv);
1fa4e549 2072 /* Pop the current context like a decent sub should */
3280af22 2073 POPBLOCK(cx, PL_curpm);
1fa4e549 2074 /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
a0d0e21e
LW		 2075 }
2076 LEAVE;
2077 return pop_return();
2078 }
2079 else {
2080 AV* padlist = CvPADLIST(cv);
2081 SV** svp = AvARRAY(padlist);
6b35e009 2082 if (CxTYPE(cx) == CXt_EVAL) {
3280af22
NIS		 2083 PL_in_eval = cx->blk_eval.old_in_eval;
2084 PL_eval_root = cx->blk_eval.old_eval_root;
b150fb22
RH		 2085 cx->cx_type = CXt_SUB;
2086 cx->blk_sub.hasargs = 0;
2087 }
a0d0e21e
LW		 2088 cx->blk_sub.cv = cv;
2089 cx->blk_sub.olddepth = CvDEPTH(cv);
2090 CvDEPTH(cv)++;
2091 if (CvDEPTH(cv) < 2)
2092 (void)SvREFCNT_inc(cv);
2093 else { /* save temporaries on recursion? */
599cee73 2094 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
44a8e56a 2095 sub_crush_depth(cv);
93965878 2096 if (CvDEPTH(cv) > AvFILLp(padlist)) {
a0d0e21e 2097 AV *newpad = newAV();
4aa0a1f7 2098 SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
93965878 2099 I32 ix = AvFILLp((AV*)svp[1]);
a0d0e21e 2100 svp = AvARRAY(svp[0]);
748a9306 2101 for ( ;ix > 0; ix--) {
3280af22 2102 if (svp[ix] != &PL_sv_undef) {
748a9306 2103 char *name = SvPVX(svp[ix]);
5f05dabc 2104 if ((SvFLAGS(svp[ix]) & SVf_FAKE)
2105 || *name == '&')
2106 {
2107 /* outer lexical or anon code */
748a9306 2108 av_store(newpad, ix,
4aa0a1f7 2109 SvREFCNT_inc(oldpad[ix]) );
748a9306
LW		 2110 }
2111 else { /* our own lexical */
2112 if (*name == '@')
2113 av_store(newpad, ix, sv = (SV*)newAV());
2114 else if (*name == '%')
2115 av_store(newpad, ix, sv = (SV*)newHV());
2116 else
2117 av_store(newpad, ix, sv = NEWSV(0,0));
2118 SvPADMY_on(sv);
2119 }
a0d0e21e
LW		 2120 }
2121 else {
748a9306 2122 av_store(newpad, ix, sv = NEWSV(0,0));
a0d0e21e
LW		 2123 SvPADTMP_on(sv);
2124 }
2125 }
2126 if (cx->blk_sub.hasargs) {
2127 AV* av = newAV();
2128 av_extend(av, 0);
2129 av_store(newpad, 0, (SV*)av);
2130 AvFLAGS(av) = AVf_REIFY;
2131 }
2132 av_store(padlist, CvDEPTH(cv), (SV*)newpad);
93965878 2133 AvFILLp(padlist) = CvDEPTH(cv);
a0d0e21e
LW		 2134 svp = AvARRAY(padlist);
2135 }
2136 }
6d4ff0d2
MB		 2137#ifdef USE_THREADS
2138 if (!cx->blk_sub.hasargs) {
533c011a 2139 AV* av = (AV*)PL_curpad[0];
6d4ff0d2 2140
93965878 2141 items = AvFILLp(av) + 1;
6d4ff0d2
MB		 2142 if (items) {
2143 /* Mark is at the end of the stack. */
924508f0
GS		 2144 EXTEND(SP, items);
2145 Copy(AvARRAY(av), SP + 1, items, SV*);
2146 SP += items;
6d4ff0d2
MB		 2147 PUTBACK ;
2148 }
2149 }
2150#endif /* USE_THREADS */
3280af22
NIS		 2151 SAVESPTR(PL_curpad);
2152 PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
6d4ff0d2
MB		 2153#ifndef USE_THREADS
2154 if (cx->blk_sub.hasargs)
2155#endif /* USE_THREADS */
2156 {
3280af22 2157 AV* av = (AV*)PL_curpad[0];
a0d0e21e
LW		 2158 SV** ary;
2159
6d4ff0d2 2160#ifndef USE_THREADS
3280af22
NIS		 2161 cx->blk_sub.savearray = GvAV(PL_defgv);
2162 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
6d4ff0d2
MB		 2163#endif /* USE_THREADS */
2164 cx->blk_sub.argarray = av;
a0d0e21e
LW		 2165 ++mark;
2166
2167 if (items >= AvMAX(av) + 1) {
2168 ary = AvALLOC(av);
2169 if (AvARRAY(av) != ary) {
2170 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2171 SvPVX(av) = (char*)ary;
2172 }
2173 if (items >= AvMAX(av) + 1) {
2174 AvMAX(av) = items - 1;
2175 Renew(ary,items+1,SV*);
2176 AvALLOC(av) = ary;
2177 SvPVX(av) = (char*)ary;
2178 }
2179 }
2180 Copy(mark,AvARRAY(av),items,SV*);
93965878 2181 AvFILLp(av) = items - 1;
62b1ebc2
GS		 2182 /* preserve @_ nature */
2183 if (arg_was_real) {
2184 AvREIFY_off(av);
2185 AvREAL_on(av);
2186 }
a0d0e21e
LW		 2187 while (items--) {
2188 if (*mark)
2189 SvTEMP_off(*mark);
2190 mark++;
2191 }
2192 }
491527d0 2193 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
44a8e56a 2194 /*
2195 * We do not care about using sv to call CV;
2196 * it's for informational purposes only.
2197 */
3280af22 2198 SV *sv = GvSV(PL_DBsub);
491527d0
GS		 2199 CV *gotocv;
2200
2201 if (PERLDB_SUB_NN) {
42718184 2202 SvIVX(sv) = (IV)PTR_CAST cv; /* Already upgraded, saved */
491527d0
GS		 2203 } else {
2204 save_item(sv);
2205 gv_efullname3(sv, CvGV(cv), Nullch);
2206 }
2207 if ( PERLDB_GOTO
864dbfa3 2208 && (gotocv = get_cv("DB::goto", FALSE)) ) {
3280af22 2209 PUSHMARK( PL_stack_sp );
864dbfa3 2210 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
3280af22 2211 PL_stack_sp--;
491527d0 2212 }
1ce6579f 2213 }
a0d0e21e
LW		 2214 RETURNOP(CvSTART(cv));
2215 }
2216 }
1614b0e3 2217 else {
2d8e6c8d 2218 label = SvPV(sv,n_a);
1614b0e3 2219 if (!(do_dump || *label))
cea2e8a9 2220 DIE(aTHX_ must_have_label);
1614b0e3 2221 }
a0d0e21e 2222 }
533c011a 2223 else if (PL_op->op_flags & OPf_SPECIAL) {
a0d0e21e 2224 if (! do_dump)
cea2e8a9 2225 DIE(aTHX_ must_have_label);
a0d0e21e
LW		 2226 }
2227 else
2228 label = cPVOP->op_pv;
2229
2230 if (label && *label) {
2231 OP *gotoprobe = 0;
2232
2233 /* find label */
2234
3280af22 2235 PL_lastgotoprobe = 0;
a0d0e21e
LW		 2236 *enterops = 0;
2237 for (ix = cxstack_ix; ix >= 0; ix--) {
2238 cx = &cxstack[ix];
6b35e009 2239 switch (CxTYPE(cx)) {
a0d0e21e 2240 case CXt_EVAL:
3280af22 2241 gotoprobe = PL_eval_root; /* XXX not good for nested eval */
a0d0e21e
LW		 2242 break;
2243 case CXt_LOOP:
2244 gotoprobe = cx->blk_oldcop->op_sibling;
2245 break;
2246 case CXt_SUBST:
2247 continue;
2248 case CXt_BLOCK:
2249 if (ix)
2250 gotoprobe = cx->blk_oldcop->op_sibling;
2251 else
3280af22 2252 gotoprobe = PL_main_root;
a0d0e21e 2253 break;
b3933176
CS		 2254 case CXt_SUB:
2255 if (CvDEPTH(cx->blk_sub.cv)) {
2256 gotoprobe = CvROOT(cx->blk_sub.cv);
2257 break;
2258 }
2259 /* FALL THROUGH */
0a753a76 2260 case CXt_NULL:
cea2e8a9 2261 DIE(aTHX_ "Can't \"goto\" outside a block");
a0d0e21e
LW		 2262 default:
2263 if (ix)
cea2e8a9 2264 DIE(aTHX_ "panic: goto");
3280af22 2265 gotoprobe = PL_main_root;
a0d0e21e
LW		 2266 break;
2267 }
fc36a67e 2268 retop = dofindlabel(gotoprobe, label,
2269 enterops, enterops + GOTO_DEPTH);
a0d0e21e
LW		 2270 if (retop)
2271 break;
3280af22 2272 PL_lastgotoprobe = gotoprobe;
a0d0e21e
LW		 2273 }
2274 if (!retop)
cea2e8a9 2275 DIE(aTHX_ "Can't find label %s", label);
a0d0e21e
LW		 2276
2277 /* pop unwanted frames */
2278
2279 if (ix < cxstack_ix) {
2280 I32 oldsave;
2281
2282 if (ix < 0)
2283 ix = 0;
2284 dounwind(ix);
2285 TOPBLOCK(cx);
3280af22 2286 oldsave = PL_scopestack[PL_scopestack_ix];
a0d0e21e
LW		 2287 LEAVE_SCOPE(oldsave);
2288 }
2289
2290 /* push wanted frames */
2291
748a9306 2292 if (*enterops && enterops[1]) {
533c011a 2293 OP *oldop = PL_op;
748a9306 2294 for (ix = 1; enterops[ix]; ix++) {
533c011a 2295 PL_op = enterops[ix];
84902520
TB		 2296 /* Eventually we may want to stack the needed arguments
2297 * for each op. For now, we punt on the hard ones. */
533c011a 2298 if (PL_op->op_type == OP_ENTERITER)
cea2e8a9 2299 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop",
84902520 2300 label);
fc0dc3b3 2301 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
a0d0e21e 2302 }
533c011a 2303 PL_op = oldop;
a0d0e21e
LW		 2304 }
2305 }
2306
2307 if (do_dump) {
a5f75d66 2308#ifdef VMS
6b88bc9c 2309 if (!retop) retop = PL_main_start;
a5f75d66 2310#endif
3280af22
NIS		 2311 PL_restartop = retop;
2312 PL_do_undump = TRUE;
a0d0e21e
LW		 2313
2314 my_unexec();
2315
3280af22
NIS		 2316 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2317 PL_do_undump = FALSE;
a0d0e21e
LW		 2318 }
2319
2320 RETURNOP(retop);
2321}
2322
2323PP(pp_exit)
2324{
4e35701f 2325 djSP;
a0d0e21e
LW		 2326 I32 anum;
2327
2328 if (MAXARG < 1)
2329 anum = 0;
ff0cee69 2330 else {
a0d0e21e 2331 anum = SvIVx(POPs);
ff0cee69 2332#ifdef VMSISH_EXIT
2333 if (anum == 1 && VMSISH_EXIT)
2334 anum = 0;
2335#endif
2336 }
a0d0e21e 2337 my_exit(anum);
3280af22 2338 PUSHs(&PL_sv_undef);
a0d0e21e
LW		 2339 RETURN;
2340}
2341
2342#ifdef NOTYET
2343PP(pp_nswitch)
2344{
4e35701f 2345 djSP;
65202027 2346 NV value = SvNVx(GvSV(cCOP->cop_gv));
a0d0e21e
LW		 2347 register I32 match = I_32(value);
2348
2349 if (value < 0.0) {
65202027 2350 if (((NV)match) > value)
a0d0e21e
LW		 2351 --match; /* was fractional--truncate other way */
2352 }
2353 match -= cCOP->uop.scop.scop_offset;
2354 if (match < 0)
2355 match = 0;
2356 else if (match > cCOP->uop.scop.scop_max)
2357 match = cCOP->uop.scop.scop_max;
6b88bc9c
GS		 2358 PL_op = cCOP->uop.scop.scop_next[match];
2359 RETURNOP(PL_op);
a0d0e21e
LW		 2360}
2361
2362PP(pp_cswitch)
2363{
4e35701f 2364 djSP;
a0d0e21e
LW		 2365 register I32 match;
2366
6b88bc9c
GS		 2367 if (PL_multiline)
2368 PL_op = PL_op->op_next; /* can't assume anything */
a0d0e21e 2369 else {
2d8e6c8d
GS		 2370 STRLEN n_a;
2371 match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255;
a0d0e21e
LW		 2372 match -= cCOP->uop.scop.scop_offset;
2373 if (match < 0)
2374 match = 0;
2375 else if (match > cCOP->uop.scop.scop_max)
2376 match = cCOP->uop.scop.scop_max;
6b88bc9c 2377 PL_op = cCOP->uop.scop.scop_next[match];
a0d0e21e 2378 }
6b88bc9c 2379 RETURNOP(PL_op);
a0d0e21e
LW		 2380}
2381#endif
2382
2383/* Eval. */
2384
0824fdcb 2385STATIC void
cea2e8a9 2386S_save_lines(pTHX_ AV *array, SV *sv)
a0d0e21e
LW		 2387{
2388 register char *s = SvPVX(sv);
2389 register char *send = SvPVX(sv) + SvCUR(sv);
2390 register char *t;
2391 register I32 line = 1;
2392
2393 while (s && s < send) {
2394 SV *tmpstr = NEWSV(85,0);
2395
2396 sv_upgrade(tmpstr, SVt_PVMG);
2397 t = strchr(s, '\n');
2398 if (t)
2399 t++;
2400 else
2401 t = send;
2402
2403 sv_setpvn(tmpstr, s, t - s);
2404 av_store(array, line++, tmpstr);
2405 s = t;
2406 }
2407}
2408
312caa8e 2409STATIC void *
cea2e8a9 2410S_docatch_body(pTHX_ va_list args)
312caa8e 2411{
cea2e8a9 2412 CALLRUNOPS(aTHX);
312caa8e
CS		 2413 return NULL;
2414}
2415
0824fdcb 2416STATIC OP *
cea2e8a9 2417S_docatch(pTHX_ OP *o)
1e422769 2418{
e858de61 2419 dTHR;
6224f72b 2420 int ret;
533c011a 2421 OP *oldop = PL_op;
1e422769 2422
1e422769 2423#ifdef DEBUGGING
54310121 2424 assert(CATCH_GET == TRUE);
1e422769 2425#endif
312caa8e
CS		 2426 PL_op = o;
2427 redo_body:
0b94c7bb 2428 CALLPROTECT(aTHX_ &ret, MEMBER_TO_FPTR(S_docatch_body));
6224f72b 2429 switch (ret) {
312caa8e
CS		 2430 case 0:
2431 break;
2432 case 3:
2433 if (PL_restartop) {
2434 PL_op = PL_restartop;
2435 PL_restartop = 0;
2436 goto redo_body;
2437 }
2438 /* FALL THROUGH */
2439 default:
533c011a 2440 PL_op = oldop;
6224f72b 2441 JMPENV_JUMP(ret);
1e422769 2442 /* NOTREACHED */
1e422769 2443 }
533c011a 2444 PL_op = oldop;
1e422769 2445 return Nullop;
2446}
2447
c277df42 2448OP *
864dbfa3 2449Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, AV** avp)
c277df42
IZ		 2450/* sv Text to convert to OP tree. */
2451/* startop op_free() this to undo. */
2452/* code Short string id of the caller. */
2453{
2454 dSP; /* Make POPBLOCK work. */
2455 PERL_CONTEXT *cx;
2456 SV **newsp;
f987c7de 2457 I32 gimme = 0; /* SUSPECT - INITIALZE TO WHAT? NI-S */
c277df42
IZ		 2458 I32 optype;
2459 OP dummy;
533c011a 2460 OP *oop = PL_op, *rop;
c277df42
IZ		 2461 char tmpbuf[TYPE_DIGITS(long) + 12 + 10];
2462 char *safestr;
2463
2464 ENTER;
2465 lex_start(sv);
2466 SAVETMPS;
2467 /* switch to eval mode */
2468
cbce877f
IZ		 2469 if (PL_curcop == &PL_compiling) {
2470 SAVESPTR(PL_compiling.cop_stash);
2471 PL_compiling.cop_stash = PL_curstash;
2472 }
3280af22
NIS		 2473 SAVESPTR(PL_compiling.cop_filegv);
2474 SAVEI16(PL_compiling.cop_line);
2475 sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2476 PL_compiling.cop_filegv = gv_fetchfile(tmpbuf+2);
2477 PL_compiling.cop_line = 1;
c277df42
IZ		 2478 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2479 deleting the eval's FILEGV from the stash before gv_check() runs
2480 (i.e. before run-time proper). To work around the coredump that
2481 ensues, we always turn GvMULTI_on for any globals that were
2482 introduced within evals. See force_ident(). GSAR 96-10-12 */
2483 safestr = savepv(tmpbuf);
3280af22 2484 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
b3ac6de7 2485 SAVEHINTS();
d1ca3daa 2486#ifdef OP_IN_REGISTER
6b88bc9c 2487 PL_opsave = op;
d1ca3daa 2488#else
533c011a 2489 SAVEPPTR(PL_op);
d1ca3daa 2490#endif
3280af22 2491 PL_hints = 0;
c277df42 2492
533c011a 2493 PL_op = &dummy;
13b51b79 2494 PL_op->op_type = OP_ENTEREVAL;
533c011a 2495 PL_op->op_flags = 0; /* Avoid uninit warning. */
c277df42 2496 PUSHBLOCK(cx, CXt_EVAL, SP);
6b88bc9c 2497 PUSHEVAL(cx, 0, PL_compiling.cop_filegv);
c277df42 2498 rop = doeval(G_SCALAR, startop);
13b51b79 2499 POPBLOCK(cx,PL_curpm);
e84b9f1f 2500 POPEVAL(cx);
c277df42
IZ		 2501
2502 (*startop)->op_type = OP_NULL;
22c35a8c 2503 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
c277df42 2504 lex_end();
3280af22 2505 *avp = (AV*)SvREFCNT_inc(PL_comppad);
c277df42 2506 LEAVE;
13b51b79 2507 if (PL_curcop == &PL_compiling)
a0ed51b3 2508 PL_compiling.op_private = PL_hints;
d1ca3daa 2509#ifdef OP_IN_REGISTER
6b88bc9c 2510 op = PL_opsave;
d1ca3daa 2511#endif
c277df42
IZ		 2512 return rop;
2513}
2514
0f15f207 2515/* With USE_THREADS, eval_owner must be held on entry to doeval */
0824fdcb 2516STATIC OP *
cea2e8a9 2517S_doeval(pTHX_ int gimme, OP** startop)
a0d0e21e
LW		 2518{
2519 dSP;
533c011a 2520 OP *saveop = PL_op;
a0d0e21e 2521 HV *newstash;
ff3ff8d1 2522 CV *caller;
748a9306 2523 AV* comppadlist;
67a38de0 2524 I32 i;
a0d0e21e 2525
faef0170 2526 PL_in_eval = EVAL_INEVAL;
a0d0e21e 2527
1ce6579f 2528 PUSHMARK(SP);
2529
a0d0e21e
LW		 2530 /* set up a scratch pad */
2531
3280af22
NIS		 2532 SAVEI32(PL_padix);
2533 SAVESPTR(PL_curpad);
2534 SAVESPTR(PL_comppad);
2535 SAVESPTR(PL_comppad_name);
2536 SAVEI32(PL_comppad_name_fill);
2537 SAVEI32(PL_min_intro_pending);
2538 SAVEI32(PL_max_intro_pending);
748a9306 2539
3280af22 2540 caller = PL_compcv;
6b35e009 2541 for (i = cxstack_ix - 1; i >= 0; i--) {
67a38de0 2542 PERL_CONTEXT *cx = &cxstack[i];
6b35e009 2543 if (CxTYPE(cx) == CXt_EVAL)
67a38de0 2544 break;
6b35e009 2545 else if (CxTYPE(cx) == CXt_SUB) {
67a38de0
NIS		 2546 caller = cx->blk_sub.cv;
2547 break;
2548 }
2549 }
2550
3280af22
NIS		 2551 SAVESPTR(PL_compcv);
2552 PL_compcv = (CV*)NEWSV(1104,0);
2553 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
1aff0e91 2554 CvEVAL_on(PL_compcv);
11343788 2555#ifdef USE_THREADS
533c011a
NIS		 2556 CvOWNER(PL_compcv) = 0;
2557 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
2558 MUTEX_INIT(CvMUTEXP(PL_compcv));
11343788 2559#endif /* USE_THREADS */
748a9306 2560
3280af22
NIS		 2561 PL_comppad = newAV();
2562 av_push(PL_comppad, Nullsv);
2563 PL_curpad = AvARRAY(PL_comppad);
2564 PL_comppad_name = newAV();
2565 PL_comppad_name_fill = 0;
2566 PL_min_intro_pending = 0;
2567 PL_padix = 0;
11343788 2568#ifdef USE_THREADS
79cb57f6 2569 av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
533c011a
NIS		 2570 PL_curpad[0] = (SV*)newAV();
2571 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
11343788 2572#endif /* USE_THREADS */
a0d0e21e 2573
748a9306
LW		 2574 comppadlist = newAV();
2575 AvREAL_off(comppadlist);
3280af22
NIS		 2576 av_store(comppadlist, 0, (SV*)PL_comppad_name);
2577 av_store(comppadlist, 1, (SV*)PL_comppad);
2578 CvPADLIST(PL_compcv) = comppadlist;
2c05e328 2579
c277df42 2580 if (!saveop || saveop->op_type != OP_REQUIRE)
3280af22 2581 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(caller);
07055b4c 2582
3280af22 2583 SAVEFREESV(PL_compcv);
748a9306 2584
a0d0e21e
LW		 2585 /* make sure we compile in the right package */
2586
3280af22
NIS		 2587 newstash = PL_curcop->cop_stash;
2588 if (PL_curstash != newstash) {
2589 SAVESPTR(PL_curstash);
2590 PL_curstash = newstash;
a0d0e21e 2591 }
3280af22
NIS		 2592 SAVESPTR(PL_beginav);
2593 PL_beginav = newAV();
2594 SAVEFREESV(PL_beginav);
a0d0e21e
LW		 2595
2596 /* try to compile it */
2597
3280af22
NIS		 2598 PL_eval_root = Nullop;
2599 PL_error_count = 0;
2600 PL_curcop = &PL_compiling;
2601 PL_curcop->cop_arybase = 0;
2602 SvREFCNT_dec(PL_rs);
79cb57f6 2603 PL_rs = newSVpvn("\n", 1);
c277df42 2604 if (saveop && saveop->op_flags & OPf_SPECIAL)
faef0170 2605 PL_in_eval |= EVAL_KEEPERR;
1ce6579f 2606 else
38a03e6e 2607 sv_setpv(ERRSV,"");
3280af22 2608 if (yyparse() || PL_error_count || !PL_eval_root) {
a0d0e21e
LW		 2609 SV **newsp;
2610 I32 gimme;
c09156bb 2611 PERL_CONTEXT *cx;
c277df42 2612 I32 optype = 0; /* Might be reset by POPEVAL. */
2d8e6c8d 2613 STRLEN n_a;
097ee67d 2614
533c011a 2615 PL_op = saveop;
3280af22
NIS		 2616 if (PL_eval_root) {
2617 op_free(PL_eval_root);
2618 PL_eval_root = Nullop;
a0d0e21e 2619 }
3280af22 2620 SP = PL_stack_base + POPMARK; /* pop original mark */
c277df42 2621 if (!startop) {
3280af22 2622 POPBLOCK(cx,PL_curpm);
c277df42
IZ		 2623 POPEVAL(cx);
2624 pop_return();
2625 }
a0d0e21e
LW		 2626 lex_end();
2627 LEAVE;
7a2e2cd6 2628 if (optype == OP_REQUIRE) {
2d8e6c8d 2629 char* msg = SvPVx(ERRSV, n_a);
cea2e8a9 2630 DIE(aTHX_ "%s", *msg ? msg : "Compilation failed in require");
c277df42 2631 } else if (startop) {
2d8e6c8d 2632 char* msg = SvPVx(ERRSV, n_a);
c277df42 2633
3280af22 2634 POPBLOCK(cx,PL_curpm);
c277df42 2635 POPEVAL(cx);
cea2e8a9 2636 Perl_croak(aTHX_ "%sCompilation failed in regexp", (*msg ? msg : "Unknown error\n"));
7a2e2cd6 2637 }
3280af22
NIS		 2638 SvREFCNT_dec(PL_rs);
2639 PL_rs = SvREFCNT_inc(PL_nrs);
f2134d95 2640#ifdef USE_THREADS
533c011a
NIS		 2641 MUTEX_LOCK(&PL_eval_mutex);
2642 PL_eval_owner = 0;
2643 COND_SIGNAL(&PL_eval_cond);
2644 MUTEX_UNLOCK(&PL_eval_mutex);
f2134d95 2645#endif /* USE_THREADS */
a0d0e21e
LW		 2646 RETPUSHUNDEF;
2647 }
3280af22
NIS		 2648 SvREFCNT_dec(PL_rs);
2649 PL_rs = SvREFCNT_inc(PL_nrs);
2650 PL_compiling.cop_line = 0;
c277df42 2651 if (startop) {
3280af22
NIS		 2652 *startop = PL_eval_root;
2653 SvREFCNT_dec(CvOUTSIDE(PL_compcv));
2654 CvOUTSIDE(PL_compcv) = Nullcv;
c277df42 2655 } else
3280af22 2656 SAVEFREEOP(PL_eval_root);
54310121 2657 if (gimme & G_VOID)
3280af22 2658 scalarvoid(PL_eval_root);
54310121 2659 else if (gimme & G_ARRAY)
3280af22 2660 list(PL_eval_root);
a0d0e21e 2661 else
3280af22 2662 scalar(PL_eval_root);
a0d0e21e
LW		 2663
2664 DEBUG_x(dump_eval());
2665
55497cff 2666 /* Register with debugger: */
84902520 2667 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
864dbfa3 2668 CV *cv = get_cv("DB::postponed", FALSE);
55497cff 2669 if (cv) {
2670 dSP;
924508f0 2671 PUSHMARK(SP);
3280af22 2672 XPUSHs((SV*)PL_compiling.cop_filegv);
55497cff 2673 PUTBACK;
864dbfa3 2674 call_sv((SV*)cv, G_DISCARD);
55497cff 2675 }
2676 }
2677
a0d0e21e
LW		 2678 /* compiled okay, so do it */
2679
3280af22
NIS		 2680 CvDEPTH(PL_compcv) = 1;
2681 SP = PL_stack_base + POPMARK; /* pop original mark */
533c011a 2682 PL_op = saveop; /* The caller may need it. */
b35b2403 2683#ifdef USE_THREADS
533c011a
NIS		 2684 MUTEX_LOCK(&PL_eval_mutex);
2685 PL_eval_owner = 0;
2686 COND_SIGNAL(&PL_eval_cond);
2687 MUTEX_UNLOCK(&PL_eval_mutex);
b35b2403 2688#endif /* USE_THREADS */
5dc0d613 2689
3280af22 2690 RETURNOP(PL_eval_start);
a0d0e21e
LW		 2691}
2692
a6c40364 2693STATIC PerlIO *
cea2e8a9 2694S_doopen_pmc(pTHX_ const char *name, const char *mode)
b295d113
TH		 2695{
2696 STRLEN namelen = strlen(name);
2697 PerlIO *fp;
2698
7894fbab 2699 if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
cea2e8a9 2700 SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
b295d113
TH		 2701 char *pmc = SvPV_nolen(pmcsv);
2702 Stat_t pmstat;
a6c40364
GS		 2703 Stat_t pmcstat;
2704 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
b295d113 2705 fp = PerlIO_open(name, mode);
a6c40364
GS		 2706 }
2707 else {
b295d113 2708 if (PerlLIO_stat(name, &pmstat) < 0 ||
a6c40364
GS		 2709 pmstat.st_mtime < pmcstat.st_mtime)
2710 {
2711 fp = PerlIO_open(pmc, mode);
2712 }
2713 else {
2714 fp = PerlIO_open(name, mode);
2715 }
b295d113 2716 }
a6c40364
GS		 2717 SvREFCNT_dec(pmcsv);
2718 }
2719 else {
2720 fp = PerlIO_open(name, mode);
b295d113 2721 }
b295d113
TH		 2722 return fp;
2723}
2724
a0d0e21e
LW		 2725PP(pp_require)
2726{
4e35701f 2727 djSP;
c09156bb 2728 register PERL_CONTEXT *cx;
a0d0e21e
LW		 2729 SV *sv;
2730 char *name;
6132ea6c 2731 STRLEN len;
46fc3d4c 2732 char *tryname;
2733 SV *namesv = Nullsv;
a0d0e21e
LW		 2734 SV** svp;
2735 I32 gimme = G_SCALAR;
760ac839 2736 PerlIO *tryrsfp = 0;
2d8e6c8d 2737 STRLEN n_a;
bbed91b5
KF		 2738 int filter_has_file = 0;
2739 GV *filter_child_proc = 0;
2740 SV *filter_state = 0;
2741 SV *filter_sub = 0;
a0d0e21e
LW		 2742
2743 sv = POPs;
4633a7c4 2744 if (SvNIOKp(sv) && !SvPOKp(sv)) {
097ee67d 2745 if (Atof(PL_patchlevel) + 0.00000999 < SvNV(sv))
cea2e8a9 2746 DIE(aTHX_ "Perl %s required--this is only version %s, stopped",
2d8e6c8d 2747 SvPV(sv,n_a),PL_patchlevel);
a0d0e21e
LW		 2748 RETPUSHYES;
2749 }
6132ea6c
GS		 2750 name = SvPV(sv, len);
2751 if (!(name && len > 0 && *name))
cea2e8a9 2752 DIE(aTHX_ "Null filename used");
4633a7c4 2753 TAINT_PROPER("require");
533c011a 2754 if (PL_op->op_type == OP_REQUIRE &&
3280af22
NIS		 2755 (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0)) &&
2756 *svp != &PL_sv_undef)
a0d0e21e
LW		 2757 RETPUSHYES;
2758
2759 /* prepare to compile file */
2760
46fc3d4c 2761 if (*name == '/' ||
2762 (*name == '.' &&
2763 (name[1] == '/' ||
2764 (name[1] == '.' && name[2] == '/')))
4633a7c4 2765#ifdef DOSISH
46fc3d4c 2766 || (name[0] && name[1] == ':')
4633a7c4 2767#endif
ba42ef2f
WJ		 2768#ifdef WIN32
2769 || (name[0] == '\\' && name[1] == '\\') /* UNC path */
2770#endif
748a9306 2771#ifdef VMS
46fc3d4c 2772 || (strchr(name,':') || ((*name == '[' || *name == '<') &&
2773 (isALNUM(name[1]) || strchr("$-_]>",name[1]))))
748a9306
LW		 2774#endif
2775 )
a0d0e21e 2776 {
46fc3d4c 2777 tryname = name;
a6c40364 2778 tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE);
a0d0e21e
LW		 2779 }
2780 else {
3280af22 2781 AV *ar = GvAVn(PL_incgv);
a0d0e21e 2782 I32 i;
748a9306 2783#ifdef VMS
46fc3d4c 2784 char *unixname;
2785 if ((unixname = tounixspec(name, Nullch)) != Nullch)
2786#endif
2787 {
2788 namesv = NEWSV(806, 0);
2789 for (i = 0; i <= AvFILL(ar); i++) {
bbed91b5
KF		 2790 SV *dirsv = *av_fetch(ar, i, TRUE);
2791
2792 if (SvROK(dirsv)) {
2793 int count;
2794 SV *loader = dirsv;
2795
2796 if (SvTYPE(SvRV(loader)) == SVt_PVAV) {
2797 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
2798 }
2799
2800 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%lx/%s",
2801 SvANY(loader), name);
2802 tryname = SvPVX(namesv);
2803 tryrsfp = 0;
2804
2805 ENTER;
2806 SAVETMPS;
2807 EXTEND(SP, 2);
2808
2809 PUSHMARK(SP);
2810 PUSHs(dirsv);
2811 PUSHs(sv);
2812 PUTBACK;
2813 count = call_sv(loader, G_ARRAY);
2814 SPAGAIN;
2815
2816 if (count > 0) {
2817 int i = 0;
2818 SV *arg;
2819
2820 SP -= count - 1;
2821 arg = SP[i++];
2822
2823 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
2824 arg = SvRV(arg);
2825 }
2826
2827 if (SvTYPE(arg) == SVt_PVGV) {
2828 IO *io = GvIO((GV *)arg);
2829
2830 ++filter_has_file;
2831
2832 if (io) {
2833 tryrsfp = IoIFP(io);
2834 if (IoTYPE(io) == '|') {
2835 /* reading from a child process doesn't
2836 nest -- when returning from reading
2837 the inner module, the outer one is
2838 unreadable (closed?) I've tried to
2839 save the gv to manage the lifespan of
2840 the pipe, but this didn't help. XXX */
2841 filter_child_proc = (GV *)arg;
520c758a 2842 (void)SvREFCNT_inc(filter_child_proc);
bbed91b5
KF		 2843 }
2844 else {
2845 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
2846 PerlIO_close(IoOFP(io));
2847 }
2848 IoIFP(io) = Nullfp;
2849 IoOFP(io) = Nullfp;
2850 }
2851 }
2852
2853 if (i < count) {
2854 arg = SP[i++];
2855 }
2856 }
2857
2858 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
2859 filter_sub = arg;
520c758a 2860 (void)SvREFCNT_inc(filter_sub);
bbed91b5
KF		 2861
2862 if (i < count) {
2863 filter_state = SP[i];
520c758a 2864 (void)SvREFCNT_inc(filter_state);
bbed91b5
KF		 2865 }
2866
2867 if (tryrsfp == 0) {
2868 tryrsfp = PerlIO_open("/dev/null",
2869 PERL_SCRIPT_MODE);
2870 }
2871 }
2872 }
2873
2874 PUTBACK;
2875 FREETMPS;
2876 LEAVE;
2877
2878 if (tryrsfp) {
2879 break;
2880 }
2881
2882 filter_has_file = 0;
2883 if (filter_child_proc) {
2884 SvREFCNT_dec(filter_child_proc);
2885 filter_child_proc = 0;
2886 }
2887 if (filter_state) {
2888 SvREFCNT_dec(filter_state);
2889 filter_state = 0;
2890 }
2891 if (filter_sub) {
2892 SvREFCNT_dec(filter_sub);
2893 filter_sub = 0;
2894 }
2895 }
2896 else {
2897 char *dir = SvPVx(dirsv, n_a);
46fc3d4c 2898#ifdef VMS
bbed91b5
KF		 2899 char *unixdir;
2900 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
2901 continue;
2902 sv_setpv(namesv, unixdir);
2903 sv_catpv(namesv, unixname);
748a9306 2904#else
bbed91b5 2905 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
748a9306 2906#endif
bbed91b5
KF		 2907 TAINT_PROPER("require");
2908 tryname = SvPVX(namesv);
2909 tryrsfp = doopen_pmc(tryname, PERL_SCRIPT_MODE);
2910 if (tryrsfp) {
2911 if (tryname[0] == '.' && tryname[1] == '/')
2912 tryname += 2;
2913 break;
2914 }
46fc3d4c 2915 }
a0d0e21e
LW		 2916 }
2917 }
2918 }
3280af22
NIS		 2919 SAVESPTR(PL_compiling.cop_filegv);
2920 PL_compiling.cop_filegv = gv_fetchfile(tryrsfp ? tryname : name);
46fc3d4c 2921 SvREFCNT_dec(namesv);
a0d0e21e 2922 if (!tryrsfp) {
533c011a 2923 if (PL_op->op_type == OP_REQUIRE) {
ec889f3a
GS		 2924 char *msgstr = name;
2925 if (namesv) { /* did we lookup @INC? */
2926 SV *msg = sv_2mortal(newSVpv(msgstr,0));
2927 SV *dirmsgsv = NEWSV(0, 0);
2928 AV *ar = GvAVn(PL_incgv);
2929 I32 i;
2930 sv_catpvn(msg, " in @INC", 8);
2931 if (instr(SvPVX(msg), ".h "))
2932 sv_catpv(msg, " (change .h to .ph maybe?)");
2933 if (instr(SvPVX(msg), ".ph "))
2934 sv_catpv(msg, " (did you run h2ph?)");
2935 sv_catpv(msg, " (@INC contains:");
2936 for (i = 0; i <= AvFILL(ar); i++) {
2937 char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
cea2e8a9 2938 Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
ec889f3a
GS		 2939 sv_catsv(msg, dirmsgsv);
2940 }
2941 sv_catpvn(msg, ")", 1);
2942 SvREFCNT_dec(dirmsgsv);
2943 msgstr = SvPV_nolen(msg);
2683423c 2944 }
cea2e8a9 2945 DIE(aTHX_ "Can't locate %s", msgstr);
a0d0e21e
LW		 2946 }
2947
2948 RETPUSHUNDEF;
2949 }
d8bfb8bd 2950 else
aba27d88 2951 SETERRNO(0, SS$_NORMAL);
a0d0e21e
LW		 2952
2953 /* Assume success here to prevent recursive requirement. */
3280af22
NIS		 2954 (void)hv_store(GvHVn(PL_incgv), name, strlen(name),
2955 newSVsv(GvSV(PL_compiling.cop_filegv)), 0 );
a0d0e21e
LW		 2956
2957 ENTER;
2958 SAVETMPS;
79cb57f6 2959 lex_start(sv_2mortal(newSVpvn("",0)));
b9d12d37
GS		 2960 SAVEGENERICSV(PL_rsfp_filters);
2961 PL_rsfp_filters = Nullav;
e50aee73 2962
3280af22 2963 PL_rsfp = tryrsfp;
a0d0e21e
LW		 2964 name = savepv(name);
2965 SAVEFREEPV(name);
b3ac6de7 2966 SAVEHINTS();
3280af22 2967 PL_hints = 0;
599cee73 2968 SAVEPPTR(PL_compiling.cop_warnings);
0453d815
PM		 2969 if (PL_dowarn & G_WARN_ALL_ON)
2970 PL_compiling.cop_warnings = WARN_ALL ;
2971 else if (PL_dowarn & G_WARN_ALL_OFF)
2972 PL_compiling.cop_warnings = WARN_NONE ;
2973 else
2974 PL_compiling.cop_warnings = WARN_STD ;
a0d0e21e 2975
bbed91b5
KF		 2976 if (filter_sub || filter_child_proc) {
2977 SV *datasv = filter_add(run_user_filter, Nullsv);
2978 IoLINES(datasv) = filter_has_file;
2979 IoFMT_GV(datasv) = (GV *)filter_child_proc;
2980 IoTOP_GV(datasv) = (GV *)filter_state;
2981 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
2982 }
2983
2984 /* switch to eval mode */
533c011a 2985 push_return(PL_op->op_next);
a0d0e21e 2986 PUSHBLOCK(cx, CXt_EVAL, SP);
6b88bc9c 2987 PUSHEVAL(cx, name, PL_compiling.cop_filegv);
a0d0e21e 2988
63eb823a 2989 SAVEI16(PL_compiling.cop_line);
3280af22 2990 PL_compiling.cop_line = 0;
a0d0e21e
LW		 2991
2992 PUTBACK;
0f15f207 2993#ifdef USE_THREADS
533c011a
NIS		 2994 MUTEX_LOCK(&PL_eval_mutex);
2995 if (PL_eval_owner && PL_eval_owner != thr)
2996 while (PL_eval_owner)
2997 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
2998 PL_eval_owner = thr;
2999 MUTEX_UNLOCK(&PL_eval_mutex);
0f15f207 3000#endif /* USE_THREADS */
c277df42 3001 return DOCATCH(doeval(G_SCALAR, NULL));
a0d0e21e
LW		 3002}
3003
3004PP(pp_dofile)
3005{
cea2e8a9 3006 return pp_require();
a0d0e21e
LW		 3007}
3008
3009PP(pp_entereval)
3010{
4e35701f 3011 djSP;
c09156bb 3012 register PERL_CONTEXT *cx;
a0d0e21e 3013 dPOPss;
3280af22 3014 I32 gimme = GIMME_V, was = PL_sub_generation;
fc36a67e 3015 char tmpbuf[TYPE_DIGITS(long) + 12];
3016 char *safestr;
a0d0e21e 3017 STRLEN len;
55497cff 3018 OP *ret;
a0d0e21e
LW		 3019
3020 if (!SvPV(sv,len) || !len)
3021 RETPUSHUNDEF;
748a9306 3022 TAINT_PROPER("eval");
a0d0e21e
LW		 3023
3024 ENTER;
a0d0e21e 3025 lex_start(sv);
748a9306 3026 SAVETMPS;
a0d0e21e
LW		 3027
3028 /* switch to eval mode */
3029
3280af22
NIS		 3030 SAVESPTR(PL_compiling.cop_filegv);
3031 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3032 PL_compiling.cop_filegv = gv_fetchfile(tmpbuf+2);
3033 PL_compiling.cop_line = 1;
55497cff 3034 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3035 deleting the eval's FILEGV from the stash before gv_check() runs
3036 (i.e. before run-time proper). To work around the coredump that
3037 ensues, we always turn GvMULTI_on for any globals that were
3038 introduced within evals. See force_ident(). GSAR 96-10-12 */
3039 safestr = savepv(tmpbuf);
3280af22 3040 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
b3ac6de7 3041 SAVEHINTS();
533c011a 3042 PL_hints = PL_op->op_targ;
e24b16f9 3043 SAVEPPTR(PL_compiling.cop_warnings);
0453d815 3044 if (!specialWARN(PL_compiling.cop_warnings)) {
599cee73
PM		 3045 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
3046 SAVEFREESV(PL_compiling.cop_warnings) ;
3047 }
a0d0e21e 3048
533c011a 3049 push_return(PL_op->op_next);
6b35e009 3050 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
6b88bc9c 3051 PUSHEVAL(cx, 0, PL_compiling.cop_filegv);
a0d0e21e
LW		 3052
3053 /* prepare to compile string */
3054
3280af22
NIS		 3055 if (PERLDB_LINE && PL_curstash != PL_debstash)
3056 save_lines(GvAV(PL_compiling.cop_filegv), PL_linestr);
a0d0e21e 3057 PUTBACK;
0f15f207 3058#ifdef USE_THREADS
533c011a
NIS		 3059 MUTEX_LOCK(&PL_eval_mutex);
3060 if (PL_eval_owner && PL_eval_owner != thr)
3061 while (PL_eval_owner)
3062 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3063 PL_eval_owner = thr;
3064 MUTEX_UNLOCK(&PL_eval_mutex);
0f15f207 3065#endif /* USE_THREADS */
c277df42 3066 ret = doeval(gimme, NULL);
3280af22 3067 if (PERLDB_INTER && was != PL_sub_generation /* Some subs defined here. */
533c011a 3068 && ret != PL_op->op_next) { /* Successive compilation. */
55497cff 3069 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
3070 }
1e422769 3071 return DOCATCH(ret);
a0d0e21e
LW		 3072}
3073
3074PP(pp_leaveeval)
3075{
4e35701f 3076 djSP;
a0d0e21e
LW		 3077 register SV **mark;
3078 SV **newsp;
3079 PMOP *newpm;
3080 I32 gimme;
c09156bb 3081 register PERL_CONTEXT *cx;
a0d0e21e 3082 OP *retop;
533c011a 3083 U8 save_flags = PL_op -> op_flags;
a0d0e21e
LW		 3084 I32 optype;
3085
3086 POPBLOCK(cx,newpm);
3087 POPEVAL(cx);
3088 retop = pop_return();
3089
a1f49e72 3090 TAINT_NOT;
54310121 3091 if (gimme == G_VOID)
3092 MARK = newsp;
3093 else if (gimme == G_SCALAR) {
3094 MARK = newsp + 1;
3095 if (MARK <= SP) {
3096 if (SvFLAGS(TOPs) & SVs_TEMP)
3097 *MARK = TOPs;
3098 else
3099 *MARK = sv_mortalcopy(TOPs);
3100 }
a0d0e21e 3101 else {
54310121 3102 MEXTEND(mark,0);
3280af22 3103 *MARK = &PL_sv_undef;
a0d0e21e 3104 }
a0d0e21e
LW		 3105 }
3106 else {
a1f49e72
CS		 3107 /* in case LEAVE wipes old return values */
3108 for (mark = newsp + 1; mark <= SP; mark++) {
3109 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
a0d0e21e 3110 *mark = sv_mortalcopy(*mark);
a1f49e72
CS		 3111 TAINT_NOT; /* Each item is independent */
3112 }
3113 }
a0d0e21e 3114 }
3280af22 3115 PL_curpm = newpm; /* Don't pop $1 et al till now */
a0d0e21e 3116
067f92a0
GS		 3117 if (AvFILLp(PL_comppad_name) >= 0)
3118 free_closures();
84902520 3119
4fdae800 3120#ifdef DEBUGGING
3280af22 3121 assert(CvDEPTH(PL_compcv) == 1);
4fdae800 3122#endif
3280af22 3123 CvDEPTH(PL_compcv) = 0;
f46d017c 3124 lex_end();
4fdae800 3125
1ce6579f 3126 if (optype == OP_REQUIRE &&
924508f0 3127 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
54310121 3128 {
1ce6579f 3129 /* Unassume the success we assumed earlier. */
54310121 3130 char *name = cx->blk_eval.old_name;
3280af22 3131 (void)hv_delete(GvHVn(PL_incgv), name, strlen(name), G_DISCARD);
cea2e8a9 3132 retop = Perl_die(aTHX_ "%s did not return a true value", name);
f46d017c
GS		 3133 /* die_where() did LEAVE, or we won't be here */
3134 }
3135 else {
3136 LEAVE;
3137 if (!(save_flags & OPf_SPECIAL))
3138 sv_setpv(ERRSV,"");
a0d0e21e 3139 }
a0d0e21e
LW		 3140
3141 RETURNOP(retop);
3142}
3143
a0d0e21e
LW		 3144PP(pp_entertry)
3145{
4e35701f 3146 djSP;
c09156bb 3147 register PERL_CONTEXT *cx;
54310121 3148 I32 gimme = GIMME_V;
a0d0e21e
LW		 3149
3150 ENTER;
3151 SAVETMPS;
3152
3153 push_return(cLOGOP->op_other->op_next);
3154 PUSHBLOCK(cx, CXt_EVAL, SP);
3155 PUSHEVAL(cx, 0, 0);
533c011a 3156 PL_eval_root = PL_op; /* Only needed so that goto works right. */
a0d0e21e 3157
faef0170 3158 PL_in_eval = EVAL_INEVAL;
38a03e6e 3159 sv_setpv(ERRSV,"");
1e422769 3160 PUTBACK;
533c011a 3161 return DOCATCH(PL_op->op_next);
a0d0e21e
LW		 3162}
3163
3164PP(pp_leavetry)
3165{
4e35701f 3166 djSP;
a0d0e21e
LW		 3167 register SV **mark;
3168 SV **newsp;
3169 PMOP *newpm;
3170 I32 gimme;
c09156bb 3171 register PERL_CONTEXT *cx;
a0d0e21e
LW		 3172 I32 optype;
3173
3174 POPBLOCK(cx,newpm);
3175 POPEVAL(cx);
3176 pop_return();
3177
a1f49e72 3178 TAINT_NOT;
54310121 3179 if (gimme == G_VOID)
3180 SP = newsp;
3181 else if (gimme == G_SCALAR) {
3182 MARK = newsp + 1;
3183 if (MARK <= SP) {
3184 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3185 *MARK = TOPs;
3186 else
3187 *MARK = sv_mortalcopy(TOPs);
3188 }
a0d0e21e 3189 else {
54310121 3190 MEXTEND(mark,0);
3280af22 3191 *MARK = &PL_sv_undef;
a0d0e21e
LW		 3192 }
3193 SP = MARK;
3194 }
3195 else {
a1f49e72
CS		 3196 /* in case LEAVE wipes old return values */
3197 for (mark = newsp + 1; mark <= SP; mark++) {
3198 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
a0d0e21e 3199 *mark = sv_mortalcopy(*mark);
a1f49e72
CS		 3200 TAINT_NOT; /* Each item is independent */
3201 }
3202 }
a0d0e21e 3203 }
3280af22 3204 PL_curpm = newpm; /* Don't pop $1 et al till now */
a0d0e21e
LW		 3205
3206 LEAVE;
38a03e6e 3207 sv_setpv(ERRSV,"");
a0d0e21e
LW		 3208 RETURN;
3209}
3210
0824fdcb 3211STATIC void
cea2e8a9 3212S_doparseform(pTHX_ SV *sv)
a0d0e21e
LW		 3213{
3214 STRLEN len;
3215 register char *s = SvPV_force(sv, len);
3216 register char *send = s + len;
3217 register char *base;
3218 register I32 skipspaces = 0;
3219 bool noblank;
3220 bool repeat;
3221 bool postspace = FALSE;
3222 U16 *fops;
3223 register U16 *fpc;
3224 U16 *linepc;
3225 register I32 arg;
3226 bool ischop;
3227
55497cff 3228 if (len == 0)
cea2e8a9 3229 Perl_croak(aTHX_ "Null picture in formline");
55497cff 3230
3231 New(804, fops, (send - s)*3+10, U16); /* Almost certainly too long... */
a0d0e21e
LW		 3232 fpc = fops;
3233
3234 if (s < send) {
3235 linepc = fpc;
3236 *fpc++ = FF_LINEMARK;
3237 noblank = repeat = FALSE;
3238 base = s;
3239 }
3240
3241 while (s <= send) {
3242 switch (*s++) {
3243 default:
3244 skipspaces = 0;
3245 continue;
3246
3247 case '~':
3248 if (*s == '~') {
3249 repeat = TRUE;
3250 *s = ' ';
3251 }
3252 noblank = TRUE;
3253 s[-1] = ' ';
3254 /* FALL THROUGH */
3255 case ' ': case '\t':
3256 skipspaces++;
3257 continue;
3258
3259 case '\n': case 0:
3260 arg = s - base;
3261 skipspaces++;
3262 arg -= skipspaces;
3263 if (arg) {
5f05dabc 3264 if (postspace)
a0d0e21e 3265 *fpc++ = FF_SPACE;
a0d0e21e
LW		 3266 *fpc++ = FF_LITERAL;
3267 *fpc++ = arg;
3268 }
5f05dabc 3269 postspace = FALSE;
a0d0e21e
LW		 3270 if (s <= send)
3271 skipspaces--;
3272 if (skipspaces) {
3273 *fpc++ = FF_SKIP;
3274 *fpc++ = skipspaces;
3275 }
3276 skipspaces = 0;
3277 if (s <= send)
3278 *fpc++ = FF_NEWLINE;
3279 if (noblank) {
3280 *fpc++ = FF_BLANK;
3281 if (repeat)
3282 arg = fpc - linepc + 1;
3283 else
3284 arg = 0;
3285 *fpc++ = arg;
3286 }
3287 if (s < send) {
3288 linepc = fpc;
3289 *fpc++ = FF_LINEMARK;
3290 noblank = repeat = FALSE;
3291 base = s;
3292 }
3293 else
3294 s++;
3295 continue;
3296
3297 case '@':
3298 case '^':
3299 ischop = s[-1] == '^';
3300
3301 if (postspace) {
3302 *fpc++ = FF_SPACE;
3303 postspace = FALSE;
3304 }
3305 arg = (s - base) - 1;
3306 if (arg) {
3307 *fpc++ = FF_LITERAL;
3308 *fpc++ = arg;
3309 }
3310
3311 base = s - 1;
3312 *fpc++ = FF_FETCH;
3313 if (*s == '*') {
3314 s++;
3315 *fpc++ = 0;
3316 *fpc++ = FF_LINEGLOB;
3317 }
3318 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3319 arg = ischop ? 512 : 0;
3320 base = s - 1;
3321 while (*s == '#')
3322 s++;
3323 if (*s == '.') {
3324 char *f;
3325 s++;
3326 f = s;
3327 while (*s == '#')
3328 s++;
3329 arg |= 256 + (s - f);
3330 }
3331 *fpc++ = s - base; /* fieldsize for FETCH */
3332 *fpc++ = FF_DECIMAL;
3333 *fpc++ = arg;
3334 }
3335 else {
3336 I32 prespace = 0;
3337 bool ismore = FALSE;
3338
3339 if (*s == '>') {
3340 while (*++s == '>') ;
3341 prespace = FF_SPACE;
3342 }
3343 else if (*s == '|') {
3344 while (*++s == '|') ;
3345 prespace = FF_HALFSPACE;
3346 postspace = TRUE;
3347 }
3348 else {
3349 if (*s == '<')
3350 while (*++s == '<') ;
3351 postspace = TRUE;
3352 }
3353 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3354 s += 3;
3355 ismore = TRUE;
3356 }
3357 *fpc++ = s - base; /* fieldsize for FETCH */
3358
3359 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3360
3361 if (prespace)
3362 *fpc++ = prespace;
3363 *fpc++ = FF_ITEM;
3364 if (ismore)
3365 *fpc++ = FF_MORE;
3366 if (ischop)
3367 *fpc++ = FF_CHOP;
3368 }
3369 base = s;
3370 skipspaces = 0;
3371 continue;
3372 }
3373 }
3374 *fpc++ = FF_END;
3375
3376 arg = fpc - fops;
3377 { /* need to jump to the next word */
3378 int z;
3379 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3380 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U16) + 4);
3381 s = SvPVX(sv) + SvCUR(sv) + z;
3382 }
3383 Copy(fops, s, arg, U16);
3384 Safefree(fops);
55497cff 3385 sv_magic(sv, Nullsv, 'f', Nullch, 0);
a0d0e21e
LW		 3386 SvCOMPILED_on(sv);
3387}
4e35701f 3388
745d3a65
HM		 3389/*
3390 * The rest of this file was derived from source code contributed
3391 * by Tom Horsley.
3392 *
3393 * NOTE: this code was derived from Tom Horsley's qsort replacement
3394 * and should not be confused with the original code.
3395 */
3396
3397/* Copyright (C) Tom Horsley, 1997. All rights reserved.
3398
3399 Permission granted to distribute under the same terms as perl which are
3400 (briefly):
3401
3402 This program is free software; you can redistribute it and/or modify
3403 it under the terms of either:
3404
3405 a) the GNU General Public License as published by the Free
3406 Software Foundation; either version 1, or (at your option) any
3407 later version, or
3408
3409 b) the "Artistic License" which comes with this Kit.
3410
3411 Details on the perl license can be found in the perl source code which
3412 may be located via the www.perl.com web page.
3413
3414 This is the most wonderfulest possible qsort I can come up with (and
3415 still be mostly portable) My (limited) tests indicate it consistently
3416 does about 20% fewer calls to compare than does the qsort in the Visual
3417 C++ library, other vendors may vary.
3418
3419 Some of the ideas in here can be found in "Algorithms" by Sedgewick,
3420 others I invented myself (or more likely re-invented since they seemed
3421 pretty obvious once I watched the algorithm operate for a while).
3422
3423 Most of this code was written while watching the Marlins sweep the Giants
3424 in the 1997 National League Playoffs - no Braves fans allowed to use this
3425 code (just kidding :-).
3426
3427 I realize that if I wanted to be true to the perl tradition, the only
3428 comment in this file would be something like:
3429
3430 ...they shuffled back towards the rear of the line. 'No, not at the
3431 rear!' the slave-driver shouted. 'Three files up. And stay there...
3432
3433 However, I really needed to violate that tradition just so I could keep
3434 track of what happens myself, not to mention some poor fool trying to
3435 understand this years from now :-).
3436*/
3437
3438/* ********************************************************** Configuration */
3439
3440#ifndef QSORT_ORDER_GUESS
3441#define QSORT_ORDER_GUESS 2 /* Select doubling version of the netBSD trick */
3442#endif
3443
3444/* QSORT_MAX_STACK is the largest number of partitions that can be stacked up for
3445 future processing - a good max upper bound is log base 2 of memory size
3446 (32 on 32 bit machines, 64 on 64 bit machines, etc). In reality can
3447 safely be smaller than that since the program is taking up some space and
3448 most operating systems only let you grab some subset of contiguous
3449 memory (not to mention that you are normally sorting data larger than
3450 1 byte element size :-).
3451*/
3452#ifndef QSORT_MAX_STACK
3453#define QSORT_MAX_STACK 32
3454#endif
3455
3456/* QSORT_BREAK_EVEN is the size of the largest partition we should insertion sort.
3457 Anything bigger and we use qsort. If you make this too small, the qsort
3458 will probably break (or become less efficient), because it doesn't expect
3459 the middle element of a partition to be the same as the right or left -
3460 you have been warned).
3461*/
3462#ifndef QSORT_BREAK_EVEN
3463#define QSORT_BREAK_EVEN 6
3464#endif
3465
3466/* ************************************************************* Data Types */
3467
3468/* hold left and right index values of a partition waiting to be sorted (the
3469 partition includes both left and right - right is NOT one past the end or
3470 anything like that).
3471*/
3472struct partition_stack_entry {
3473 int left;
3474 int right;
3475#ifdef QSORT_ORDER_GUESS
3476 int qsort_break_even;
3477#endif
3478};
3479
3480/* ******************************************************* Shorthand Macros */
3481
3482/* Note that these macros will be used from inside the qsort function where
3483 we happen to know that the variable 'elt_size' contains the size of an
3484 array element and the variable 'temp' points to enough space to hold a
3485 temp element and the variable 'array' points to the array being sorted
3486 and 'compare' is the pointer to the compare routine.
3487
3488 Also note that there are very many highly architecture specific ways
3489 these might be sped up, but this is simply the most generally portable
3490 code I could think of.
3491*/
161b471a 3492
745d3a65
HM		 3493/* Return < 0 == 0 or > 0 as the value of elt1 is < elt2, == elt2, > elt2
3494*/
565764a8 3495#define qsort_cmp(elt1, elt2) \
51371543 3496 ((*compare)(aTHXo_ array[elt1], array[elt2]))
745d3a65
HM		 3497
3498#ifdef QSORT_ORDER_GUESS
3499#define QSORT_NOTICE_SWAP swapped++;
3500#else
3501#define QSORT_NOTICE_SWAP
3502#endif
3503
3504/* swaps contents of array elements elt1, elt2.
3505*/
3506#define qsort_swap(elt1, elt2) \
3507 STMT_START { \
3508 QSORT_NOTICE_SWAP \
3509 temp = array[elt1]; \
3510 array[elt1] = array[elt2]; \
3511 array[elt2] = temp; \
3512 } STMT_END
3513
3514/* rotate contents of elt1, elt2, elt3 such that elt1 gets elt2, elt2 gets
3515 elt3 and elt3 gets elt1.
3516*/
3517#define qsort_rotate(elt1, elt2, elt3) \
3518 STMT_START { \
3519 QSORT_NOTICE_SWAP \
3520 temp = array[elt1]; \
3521 array[elt1] = array[elt2]; \
3522 array[elt2] = array[elt3]; \
3523 array[elt3] = temp; \
3524 } STMT_END
3525
3526/* ************************************************************ Debug stuff */
3527
3528#ifdef QSORT_DEBUG
3529
3530static void
3531break_here()
3532{
3533 return; /* good place to set a breakpoint */
3534}
3535
3536#define qsort_assert(t) (void)( (t) || (break_here(), 0) )
3537
3538static void
3539doqsort_all_asserts(
3540 void * array,
3541 size_t num_elts,
3542 size_t elt_size,
3543 int (*compare)(const void * elt1, const void * elt2),
3544 int pc_left, int pc_right, int u_left, int u_right)
3545{
3546 int i;
3547
3548 qsort_assert(pc_left <= pc_right);
3549 qsort_assert(u_right < pc_left);
3550 qsort_assert(pc_right < u_left);
3551 for (i = u_right + 1; i < pc_left; ++i) {
3552 qsort_assert(qsort_cmp(i, pc_left) < 0);
3553 }
3554 for (i = pc_left; i < pc_right; ++i) {
3555 qsort_assert(qsort_cmp(i, pc_right) == 0);
3556 }
3557 for (i = pc_right + 1; i < u_left; ++i) {
3558 qsort_assert(qsort_cmp(pc_right, i) < 0);
3559 }
3560}
3561
3562#define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) \
3563 doqsort_all_asserts(array, num_elts, elt_size, compare, \
3564 PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT)
3565
3566#else
3567
3568#define qsort_assert(t) ((void)0)
3569
3570#define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) ((void)0)
3571
3572#endif
3573
3574/* ****************************************************************** qsort */
3575
6cc33c6d 3576STATIC void
cea2e8a9 3577S_qsortsv(pTHX_ SV ** array, size_t num_elts, SVCOMPARE_t compare)
745d3a65
HM		 3578{
3579 register SV * temp;
3580
3581 struct partition_stack_entry partition_stack[QSORT_MAX_STACK];
3582 int next_stack_entry = 0;
3583
3584 int part_left;
3585 int part_right;
3586#ifdef QSORT_ORDER_GUESS
3587 int qsort_break_even;
3588 int swapped;
3589#endif
161b471a 3590
745d3a65
HM		 3591 /* Make sure we actually have work to do.
3592 */
3593 if (num_elts <= 1) {
3594 return;
3595 }
3596
3597 /* Setup the initial partition definition and fall into the sorting loop
3598 */
3599 part_left = 0;
3600 part_right = (int)(num_elts - 1);
3601#ifdef QSORT_ORDER_GUESS
3602 qsort_break_even = QSORT_BREAK_EVEN;
3603#else
3604#define qsort_break_even QSORT_BREAK_EVEN
3605#endif
3606 for ( ; ; ) {
3607 if ((part_right - part_left) >= qsort_break_even) {
3608 /* OK, this is gonna get hairy, so lets try to document all the
3609 concepts and abbreviations and variables and what they keep
3610 track of:
3611
3612 pc: pivot chunk - the set of array elements we accumulate in the
3613 middle of the partition, all equal in value to the original
3614 pivot element selected. The pc is defined by:
3615
3616 pc_left - the leftmost array index of the pc
3617 pc_right - the rightmost array index of the pc
3618
3619 we start with pc_left == pc_right and only one element
3620 in the pivot chunk (but it can grow during the scan).
3621
3622 u: uncompared elements - the set of elements in the partition
3623 we have not yet compared to the pivot value. There are two
3624 uncompared sets during the scan - one to the left of the pc
3625 and one to the right.
3626
3627 u_right - the rightmost index of the left side's uncompared set
3628 u_left - the leftmost index of the right side's uncompared set
3629
3630 The leftmost index of the left sides's uncompared set
3631 doesn't need its own variable because it is always defined
3632 by the leftmost edge of the whole partition (part_left). The
3633 same goes for the rightmost edge of the right partition
3634 (part_right).
3635
3636 We know there are no uncompared elements on the left once we
3637 get u_right < part_left and no uncompared elements on the
3638 right once u_left > part_right. When both these conditions
3639 are met, we have completed the scan of the partition.
3640
3641 Any elements which are between the pivot chunk and the
3642 uncompared elements should be less than the pivot value on
3643 the left side and greater than the pivot value on the right
3644 side (in fact, the goal of the whole algorithm is to arrange
3645 for that to be true and make the groups of less-than and
3646 greater-then elements into new partitions to sort again).
3647
3648 As you marvel at the complexity of the code and wonder why it
3649 has to be so confusing. Consider some of the things this level
3650 of confusion brings:
3651
3652 Once I do a compare, I squeeze every ounce of juice out of it. I
3653 never do compare calls I don't have to do, and I certainly never
3654 do redundant calls.
3655
3656 I also never swap any elements unless I can prove there is a
3657 good reason. Many sort algorithms will swap a known value with
3658 an uncompared value just to get things in the right place (or
3659 avoid complexity :-), but that uncompared value, once it gets
3660 compared, may then have to be swapped again. A lot of the
3661 complexity of this code is due to the fact that it never swaps
3662 anything except compared values, and it only swaps them when the
3663 compare shows they are out of position.
3664 */
3665 int pc_left, pc_right;
3666 int u_right, u_left;
3667
3668 int s;
3669
3670 pc_left = ((part_left + part_right) / 2);
3671 pc_right = pc_left;
3672 u_right = pc_left - 1;
3673 u_left = pc_right + 1;
3674
3675 /* Qsort works best when the pivot value is also the median value
3676 in the partition (unfortunately you can't find the median value
3677 without first sorting :-), so to give the algorithm a helping
3678 hand, we pick 3 elements and sort them and use the median value
3679 of that tiny set as the pivot value.
3680
3681 Some versions of qsort like to use the left middle and right as
3682 the 3 elements to sort so they can insure the ends of the
3683 partition will contain values which will stop the scan in the
3684 compare loop, but when you have to call an arbitrarily complex
3685 routine to do a compare, its really better to just keep track of
3686 array index values to know when you hit the edge of the
3687 partition and avoid the extra compare. An even better reason to
3688 avoid using a compare call is the fact that you can drop off the
3689 edge of the array if someone foolishly provides you with an
3690 unstable compare function that doesn't always provide consistent
3691 results.
3692
3693 So, since it is simpler for us to compare the three adjacent
3694 elements in the middle of the partition, those are the ones we
3695 pick here (conveniently pointed at by u_right, pc_left, and
3696 u_left). The values of the left, center, and right elements
3697 are refered to as l c and r in the following comments.
3698 */
3699
3700#ifdef QSORT_ORDER_GUESS
3701 swapped = 0;
3702#endif
3703 s = qsort_cmp(u_right, pc_left);
3704 if (s < 0) {
3705 /* l < c */
3706 s = qsort_cmp(pc_left, u_left);
3707 /* if l < c, c < r - already in order - nothing to do */
3708 if (s == 0) {
3709 /* l < c, c == r - already in order, pc grows */
3710 ++pc_right;
3711 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3712 } else if (s > 0) {
3713 /* l < c, c > r - need to know more */
3714 s = qsort_cmp(u_right, u_left);
3715 if (s < 0) {
3716 /* l < c, c > r, l < r - swap c & r to get ordered */
3717 qsort_swap(pc_left, u_left);
3718 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3719 } else if (s == 0) {
3720 /* l < c, c > r, l == r - swap c&r, grow pc */
3721 qsort_swap(pc_left, u_left);
3722 --pc_left;
3723 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3724 } else {
3725 /* l < c, c > r, l > r - make lcr into rlc to get ordered */
3726 qsort_rotate(pc_left, u_right, u_left);
3727 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3728 }
3729 }
3730 } else if (s == 0) {
3731 /* l == c */
3732 s = qsort_cmp(pc_left, u_left);
3733 if (s < 0) {
3734 /* l == c, c < r - already in order, grow pc */
3735 --pc_left;
3736 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3737 } else if (s == 0) {
3738 /* l == c, c == r - already in order, grow pc both ways */
3739 --pc_left;
3740 ++pc_right;
3741 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3742 } else {
3743 /* l == c, c > r - swap l & r, grow pc */
3744 qsort_swap(u_right, u_left);
3745 ++pc_right;
3746 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3747 }
3748 } else {
3749 /* l > c */
3750 s = qsort_cmp(pc_left, u_left);
3751 if (s < 0) {
3752 /* l > c, c < r - need to know more */
3753 s = qsort_cmp(u_right, u_left);
3754 if (s < 0) {
3755 /* l > c, c < r, l < r - swap l & c to get ordered */
3756 qsort_swap(u_right, pc_left);
3757 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3758 } else if (s == 0) {
3759 /* l > c, c < r, l == r - swap l & c, grow pc */
3760 qsort_swap(u_right, pc_left);
3761 ++pc_right;
3762 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3763 } else {
3764 /* l > c, c < r, l > r - rotate lcr into crl to order */
3765 qsort_rotate(u_right, pc_left, u_left);
3766 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3767 }
3768 } else if (s == 0) {
3769 /* l > c, c == r - swap ends, grow pc */
3770 qsort_swap(u_right, u_left);
3771 --pc_left;
3772 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3773 } else {
3774 /* l > c, c > r - swap ends to get in order */
3775 qsort_swap(u_right, u_left);
3776 qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
3777 }
3778 }
3779 /* We now know the 3 middle elements have been compared and
3780 arranged in the desired order, so we can shrink the uncompared
3781 sets on both sides
3782 */
3783 --u_right;
3784 ++u_left;
3785 qsort_all_asserts(pc_left, pc_right, u_left, u_right);
3786
3787 /* The above massive nested if was the simple part :-). We now have
3788 the middle 3 elements ordered and we need to scan through the
3789 uncompared sets on either side, swapping elements that are on
3790 the wrong side or simply shuffling equal elements around to get
3791 all equal elements into the pivot chunk.
3792 */
3793
3794 for ( ; ; ) {
3795 int still_work_on_left;
3796 int still_work_on_right;
3797
3798 /* Scan the uncompared values on the left. If I find a value
3799 equal to the pivot value, move it over so it is adjacent to
3800 the pivot chunk and expand the pivot chunk. If I find a value
3801 less than the pivot value, then just leave it - its already
3802 on the correct side of the partition. If I find a greater
3803 value, then stop the scan.
3804 */
3805 while (still_work_on_left = (u_right >= part_left)) {
3806 s = qsort_cmp(u_right, pc_left);
3807 if (s < 0) {
3808 --u_right;
3809 } else if (s == 0) {
3810 --pc_left;
3811 if (pc_left != u_right) {
3812 qsort_swap(u_right, pc_left);
3813 }
3814 --u_right;
3815 } else {
3816 break;
3817 }
3818 qsort_assert(u_right < pc_left);
3819 qsort_assert(pc_left <= pc_right);
3820 qsort_assert(qsort_cmp(u_right + 1, pc_left) <= 0);
3821 qsort_assert(qsort_cmp(pc_left, pc_right) == 0);
3822 }
3823
3824 /* Do a mirror image scan of uncompared values on the right
3825 */
3826 while (still_work_on_right = (u_left <= part_right)) {
3827 s = qsort_cmp(pc_right, u_left);
3828 if (s < 0) {
3829 ++u_left;
3830 } else if (s == 0) {
3831 ++pc_right;
3832 if (pc_right != u_left) {
3833 qsort_swap(pc_right, u_left);
3834 }
3835 ++u_left;
3836 } else {
3837 break;
3838 }
3839 qsort_assert(u_left > pc_right);
3840 qsort_assert(pc_left <= pc_right);
3841 qsort_assert(qsort_cmp(pc_right, u_left - 1) <= 0);
3842 qsort_assert(qsort_cmp(pc_left, pc_right) == 0);
3843 }
3844
3845 if (still_work_on_left) {
3846 /* I know I have a value on the left side which needs to be
3847 on the right side, but I need to know more to decide
3848 exactly the best thing to do with it.
3849 */
3850 if (still_work_on_right) {
3851 /* I know I have values on both side which are out of
3852 position. This is a big win because I kill two birds
3853 with one swap (so to speak). I can advance the
3854 uncompared pointers on both sides after swapping both
3855 of them into the right place.
3856 */
3857 qsort_swap(u_right, u_left);
3858 --u_right;
3859 ++u_left;
3860 qsort_all_asserts(pc_left, pc_right, u_left, u_right);
3861 } else {
3862 /* I have an out of position value on the left, but the
3863 right is fully scanned, so I "slide" the pivot chunk
3864 and any less-than values left one to make room for the
3865 greater value over on the right. If the out of position
3866 value is immediately adjacent to the pivot chunk (there
3867 are no less-than values), I can do that with a swap,
3868 otherwise, I have to rotate one of the less than values
3869 into the former position of the out of position value
3870 and the right end of the pivot chunk into the left end
3871 (got all that?).
3872 */
3873 --pc_left;
3874 if (pc_left == u_right) {
3875 qsort_swap(u_right, pc_right);
3876 qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1);
3877 } else {
3878 qsort_rotate(u_right, pc_left, pc_right);
3879 qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1);
3880 }
3881 --pc_right;
3882 --u_right;
3883 }
3884 } else if (still_work_on_right) {
3885 /* Mirror image of complex case above: I have an out of
3886 position value on the right, but the left is fully
3887 scanned, so I need to shuffle things around to make room
3888 for the right value on the left.
3889 */
3890 ++pc_right;
3891 if (pc_right == u_left) {
3892 qsort_swap(u_left, pc_left);
3893 qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right);
3894 } else {
3895 qsort_rotate(pc_right, pc_left, u_left);
3896 qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right);
3897 }
3898 ++pc_left;
3899 ++u_left;
3900 } else {
3901 /* No more scanning required on either side of partition,
3902 break out of loop and figure out next set of partitions
3903 */
3904 break;
3905 }
3906 }
3907
3908 /* The elements in the pivot chunk are now in the right place. They
3909 will never move or be compared again. All I have to do is decide
3910 what to do with the stuff to the left and right of the pivot
3911 chunk.
3912
3913 Notes on the QSORT_ORDER_GUESS ifdef code:
3914
3915 1. If I just built these partitions without swapping any (or
3916 very many) elements, there is a chance that the elements are
3917 already ordered properly (being properly ordered will
3918 certainly result in no swapping, but the converse can't be
3919 proved :-).
3920
3921 2. A (properly written) insertion sort will run faster on
3922 already ordered data than qsort will.
3923
3924 3. Perhaps there is some way to make a good guess about
3925 switching to an insertion sort earlier than partition size 6
3926 (for instance - we could save the partition size on the stack
3927 and increase the size each time we find we didn't swap, thus
3928 switching to insertion sort earlier for partitions with a
3929 history of not swapping).
3930
3931 4. Naturally, if I just switch right away, it will make
3932 artificial benchmarks with pure ascending (or descending)
3933 data look really good, but is that a good reason in general?
3934 Hard to say...
3935 */
3936
3937#ifdef QSORT_ORDER_GUESS
3938 if (swapped < 3) {
3939#if QSORT_ORDER_GUESS == 1
3940 qsort_break_even = (part_right - part_left) + 1;
3941#endif
3942#if QSORT_ORDER_GUESS == 2
3943 qsort_break_even *= 2;
3944#endif
3945#if QSORT_ORDER_GUESS == 3
3946 int prev_break = qsort_break_even;
3947 qsort_break_even *= qsort_break_even;
3948 if (qsort_break_even < prev_break) {
3949 qsort_break_even = (part_right - part_left) + 1;
3950 }
3951#endif
3952 } else {
3953 qsort_break_even = QSORT_BREAK_EVEN;
3954 }
3955#endif
3956
3957 if (part_left < pc_left) {
3958 /* There are elements on the left which need more processing.
3959 Check the right as well before deciding what to do.
3960 */
3961 if (pc_right < part_right) {
3962 /* We have two partitions to be sorted. Stack the biggest one
3963 and process the smallest one on the next iteration. This
3964 minimizes the stack height by insuring that any additional
3965 stack entries must come from the smallest partition which
3966 (because it is smallest) will have the fewest
3967 opportunities to generate additional stack entries.
3968 */
3969 if ((part_right - pc_right) > (pc_left - part_left)) {
3970 /* stack the right partition, process the left */
3971 partition_stack[next_stack_entry].left = pc_right + 1;
3972 partition_stack[next_stack_entry].right = part_right;
3973#ifdef QSORT_ORDER_GUESS
3974 partition_stack[next_stack_entry].qsort_break_even = qsort_break_even;
3975#endif
3976 part_right = pc_left - 1;
3977 } else {
3978 /* stack the left partition, process the right */
3979 partition_stack[next_stack_entry].left = part_left;
3980 partition_stack[next_stack_entry].right = pc_left - 1;
3981#ifdef QSORT_ORDER_GUESS
3982 partition_stack[next_stack_entry].qsort_break_even = qsort_break_even;
3983#endif
3984 part_left = pc_right + 1;
3985 }
3986 qsort_assert(next_stack_entry < QSORT_MAX_STACK);
3987 ++next_stack_entry;
3988 } else {
3989 /* The elements on the left are the only remaining elements
3990 that need sorting, arrange for them to be processed as the
3991 next partition.
3992 */
3993 part_right = pc_left - 1;
3994 }
3995 } else if (pc_right < part_right) {
3996 /* There is only one chunk on the right to be sorted, make it
3997 the new partition and loop back around.
3998 */
3999 part_left = pc_right + 1;
4000 } else {
4001 /* This whole partition wound up in the pivot chunk, so
4002 we need to get a new partition off the stack.
4003 */
4004 if (next_stack_entry == 0) {
4005 /* the stack is empty - we are done */
4006 break;
4007 }
4008 --next_stack_entry;
4009 part_left = partition_stack[next_stack_entry].left;
4010 part_right = partition_stack[next_stack_entry].right;
4011#ifdef QSORT_ORDER_GUESS
4012 qsort_break_even = partition_stack[next_stack_entry].qsort_break_even;
4013#endif
4014 }
4015 } else {
4016 /* This partition is too small to fool with qsort complexity, just
4017 do an ordinary insertion sort to minimize overhead.
4018 */
4019 int i;
4020 /* Assume 1st element is in right place already, and start checking
4021 at 2nd element to see where it should be inserted.
4022 */
4023 for (i = part_left + 1; i <= part_right; ++i) {
4024 int j;
4025 /* Scan (backwards - just in case 'i' is already in right place)
4026 through the elements already sorted to see if the ith element
4027 belongs ahead of one of them.
4028 */
4029 for (j = i - 1; j >= part_left; --j) {
4030 if (qsort_cmp(i, j) >= 0) {
4031 /* i belongs right after j
4032 */
4033 break;
4034 }
4035 }
4036 ++j;
4037 if (j != i) {
4038 /* Looks like we really need to move some things
4039 */
b6917549 4040 int k;
745d3a65 4041 temp = array[i];
b6917549
HM		 4042 for (k = i - 1; k >= j; --k)
4043 array[k + 1] = array[k];
745d3a65
HM		 4044 array[j] = temp;
4045 }
4046 }
4047
4048 /* That partition is now sorted, grab the next one, or get out
4049 of the loop if there aren't any more.
4050 */
4051
4052 if (next_stack_entry == 0) {
4053 /* the stack is empty - we are done */
4054 break;
4055 }
4056 --next_stack_entry;
4057 part_left = partition_stack[next_stack_entry].left;
4058 part_right = partition_stack[next_stack_entry].right;
4059#ifdef QSORT_ORDER_GUESS
4060 qsort_break_even = partition_stack[next_stack_entry].qsort_break_even;
4061#endif
4062 }
4063 }
4064
4065 /* Believe it or not, the array is sorted at this point! */
4066}
51371543
GS		 4067
4068
4069#ifdef PERL_OBJECT
4070#define NO_XSLOCKS
4071#undef this
4072#define this pPerl
4073#include "XSUB.h"
4074#endif
4075
4076
4077static I32
4078sortcv(pTHXo_ SV *a, SV *b)
4079{
4080 dTHR;
4081 I32 oldsaveix = PL_savestack_ix;
4082 I32 oldscopeix = PL_scopestack_ix;
4083 I32 result;
4084 GvSV(PL_firstgv) = a;
4085 GvSV(PL_secondgv) = b;
4086 PL_stack_sp = PL_stack_base;
4087 PL_op = PL_sortcop;
4088 CALLRUNOPS(aTHX);
4089 if (PL_stack_sp != PL_stack_base + 1)
4090 Perl_croak(aTHX_ "Sort subroutine didn't return single value");
4091 if (!SvNIOKp(*PL_stack_sp))
4092 Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
4093 result = SvIV(*PL_stack_sp);
4094 while (PL_scopestack_ix > oldscopeix) {
4095 LEAVE;
4096 }
4097 leave_scope(oldsaveix);
4098 return result;
4099}
4100
4101
4102static I32
4103sv_ncmp(pTHXo_ SV *a, SV *b)
4104{
4105 NV nv1 = SvNV(a);
4106 NV nv2 = SvNV(b);
4107 return nv1 < nv2 ? -1 : nv1 > nv2 ? 1 : 0;
4108}
4109
4110static I32
4111sv_i_ncmp(pTHXo_ SV *a, SV *b)
4112{
4113 IV iv1 = SvIV(a);
4114 IV iv2 = SvIV(b);
4115 return iv1 < iv2 ? -1 : iv1 > iv2 ? 1 : 0;
4116}
4117#define tryCALL_AMAGICbin(left,right,meth,svp) STMT_START { \
4118 *svp = Nullsv; \
4119 if (PL_amagic_generation) { \
4120 if (SvAMAGIC(left)||SvAMAGIC(right))\
4121 *svp = amagic_call(left, \
4122 right, \
4123 CAT2(meth,_amg), \
4124 0); \
4125 } \
4126 } STMT_END
4127
4128static I32
4129amagic_ncmp(pTHXo_ register SV *a, register SV *b)
4130{
4131 SV *tmpsv;
4132 tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
4133 if (tmpsv) {
4134 NV d;
4135
4136 if (SvIOK(tmpsv)) {
4137 I32 i = SvIVX(tmpsv);
4138 if (i > 0)
4139 return 1;
4140 return i? -1 : 0;
4141 }
4142 d = SvNV(tmpsv);
4143 if (d > 0)
4144 return 1;
4145 return d? -1 : 0;
4146 }
4147 return sv_ncmp(aTHXo_ a, b);
4148}
4149
4150static I32
4151amagic_i_ncmp(pTHXo_ register SV *a, register SV *b)
4152{
4153 SV *tmpsv;
4154 tryCALL_AMAGICbin(a,b,ncmp,&tmpsv);
4155 if (tmpsv) {
4156 NV d;
4157
4158 if (SvIOK(tmpsv)) {
4159 I32 i = SvIVX(tmpsv);
4160 if (i > 0)
4161 return 1;
4162 return i? -1 : 0;
4163 }
4164 d = SvNV(tmpsv);
4165 if (d > 0)
4166 return 1;
4167 return d? -1 : 0;
4168 }
4169 return sv_i_ncmp(aTHXo_ a, b);
4170}
4171
4172static I32
4173amagic_cmp(pTHXo_ register SV *str1, register SV *str2)
4174{
4175 SV *tmpsv;
4176 tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
4177 if (tmpsv) {
4178 NV d;
4179
4180 if (SvIOK(tmpsv)) {
4181 I32 i = SvIVX(tmpsv);
4182 if (i > 0)
4183 return 1;
4184 return i? -1 : 0;
4185 }
4186 d = SvNV(tmpsv);
4187 if (d > 0)
4188 return 1;
4189 return d? -1 : 0;
4190 }
4191 return sv_cmp(str1, str2);
4192}
4193
4194static I32
4195amagic_cmp_locale(pTHXo_ register SV *str1, register SV *str2)
4196{
4197 SV *tmpsv;
4198 tryCALL_AMAGICbin(str1,str2,scmp,&tmpsv);
4199 if (tmpsv) {
4200 NV d;
4201
4202 if (SvIOK(tmpsv)) {
4203 I32 i = SvIVX(tmpsv);
4204 if (i > 0)
4205 return 1;
4206 return i? -1 : 0;
4207 }
4208 d = SvNV(tmpsv);
4209 if (d > 0)
4210 return 1;
4211 return d? -1 : 0;
4212 }
4213 return sv_cmp_locale(str1, str2);
4214}
4215
bbed91b5
KF		 4216static I32
4217run_user_filter(pTHXo_ int idx, SV *buf_sv, int maxlen)
4218{
4219 SV *datasv = FILTER_DATA(idx);
4220 int filter_has_file = IoLINES(datasv);
4221 GV *filter_child_proc = (GV *)IoFMT_GV(datasv);
4222 SV *filter_state = (SV *)IoTOP_GV(datasv);
4223 SV *filter_sub = (SV *)IoBOTTOM_GV(datasv);
4224 int len = 0;
4225
4226 /* I was having segfault trouble under Linux 2.2.5 after a
4227 parse error occured. (Had to hack around it with a test
4228 for PL_error_count == 0.) Solaris doesn't segfault --
4229 not sure where the trouble is yet. XXX */
4230
4231 if (filter_has_file) {
4232 len = FILTER_READ(idx+1, buf_sv, maxlen);
4233 }
4234
4235 if (filter_sub && len >= 0) {
4236 djSP;
4237 int count;
4238
4239 ENTER;
4240 SAVE_DEFSV;
4241 SAVETMPS;
4242 EXTEND(SP, 2);
4243
4244 DEFSV = buf_sv;
4245 PUSHMARK(SP);
4246 PUSHs(sv_2mortal(newSViv(maxlen)));
4247 if (filter_state) {
4248 PUSHs(filter_state);
4249 }
4250 PUTBACK;
4251 count = call_sv(filter_sub, G_SCALAR);
4252 SPAGAIN;
4253
4254 if (count > 0) {
4255 SV *out = POPs;
4256 if (SvOK(out)) {
4257 len = SvIV(out);
4258 }
4259 }
4260
4261 PUTBACK;
4262 FREETMPS;
4263 LEAVE;
4264 }
4265
4266 if (len <= 0) {
4267 IoLINES(datasv) = 0;
4268 if (filter_child_proc) {
4269 SvREFCNT_dec(filter_child_proc);
4270 IoFMT_GV(datasv) = Nullgv;
4271 }
4272 if (filter_state) {
4273 SvREFCNT_dec(filter_state);
4274 IoTOP_GV(datasv) = Nullgv;
4275 }
4276 if (filter_sub) {
4277 SvREFCNT_dec(filter_sub);
4278 IoBOTTOM_GV(datasv) = Nullgv;
4279 }
4280 filter_del(run_user_filter);
4281 }
4282
4283 return len;
4284}
4285
e7513ba0
GS		 4286#ifdef PERL_OBJECT
4287
51371543
GS		 4288static I32
4289sv_cmp_locale_static(pTHXo_ register SV *str1, register SV *str2)
4290{
4291 return sv_cmp_locale(str1, str2);
4292}
4293
4294static I32
4295sv_cmp_static(pTHXo_ register SV *str1, register SV *str2)
4296{
4297 return sv_cmp(str1, str2);
4298}
e7513ba0
GS		 4299
4300#endif /* PERL_OBJECT */
Unnamed repository; edit this file 'description' to name the repository.