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