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