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