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_incremental
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (non-incremental) | history | HEAD
Banishing eval from getopt.pl and Getopt/Std.pm
[perl5.git] / scope.c
... / ...
CommitLineData
1/* scope.c
2 *
3 * Copyright (c) 1991-1997, Larry Wall
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 * "For the fashion of Minas Tirith was such that it was built on seven
12 * levels..."
13 */
14
15#include "EXTERN.h"
16#include "perl.h"
17
18SV**
19stack_grow(sp, p, n)
20SV** sp;
21SV** p;
22int n;
23{
24 stack_sp = sp;
25 av_extend(curstack, (p - stack_base) + (n) + 128);
26 return stack_sp;
27}
28
29I32
30cxinc()
31{
32 cxstack_max = cxstack_max * 3 / 2;
33 Renew(cxstack, cxstack_max + 1, CONTEXT); /* XXX should fix CXINC macro */
34 return cxstack_ix + 1;
35}
36
37void
38push_return(retop)
39OP *retop;
40{
41 if (retstack_ix == retstack_max) {
42 retstack_max = retstack_max * 3 / 2;
43 Renew(retstack, retstack_max, OP*);
44 }
45 retstack[retstack_ix++] = retop;
46}
47
48OP *
49pop_return()
50{
51 if (retstack_ix > 0)
52 return retstack[--retstack_ix];
53 else
54 return Nullop;
55}
56
57void
58push_scope()
59{
60 if (scopestack_ix == scopestack_max) {
61 scopestack_max = scopestack_max * 3 / 2;
62 Renew(scopestack, scopestack_max, I32);
63 }
64 scopestack[scopestack_ix++] = savestack_ix;
65
66}
67
68void
69pop_scope()
70{
71 I32 oldsave = scopestack[--scopestack_ix];
72 LEAVE_SCOPE(oldsave);
73}
74
75void
76markstack_grow()
77{
78 I32 oldmax = markstack_max - markstack;
79 I32 newmax = oldmax * 3 / 2;
80
81 Renew(markstack, newmax, I32);
82 markstack_ptr = markstack + oldmax;
83 markstack_max = markstack + newmax;
84}
85
86void
87savestack_grow()
88{
89 savestack_max = savestack_max * 3 / 2;
90 Renew(savestack, savestack_max, ANY);
91}
92
93void
94free_tmps()
95{
96 /* XXX should tmps_floor live in cxstack? */
97 I32 myfloor = tmps_floor;
98 while (tmps_ix > myfloor) { /* clean up after last statement */
99 SV* sv = tmps_stack[tmps_ix];
100 tmps_stack[tmps_ix--] = Nullsv;
101 if (sv) {
102#ifdef DEBUGGING
103 SvTEMP_off(sv);
104#endif
105 SvREFCNT_dec(sv); /* note, can modify tmps_ix!!! */
106 }
107 }
108}
109
110static SV *
111save_scalar_at(sptr)
112SV **sptr;
113{
114 register SV *sv;
115 SV *osv = *sptr;
116
117 sv = *sptr = NEWSV(0,0);
118 if (SvTYPE(osv) >= SVt_PVMG && SvMAGIC(osv) && SvTYPE(osv) != SVt_PVGV) {
119 sv_upgrade(sv, SvTYPE(osv));
120 if (SvGMAGICAL(osv)) {
121 MAGIC* mg;
122 bool oldtainted = tainted;
123 mg_get(osv);
124 if (tainting && tainted && (mg = mg_find(osv, 't'))) {
125 SAVESPTR(mg->mg_obj);
126 mg->mg_obj = osv;
127 }
128 SvFLAGS(osv) |= (SvFLAGS(osv) &
129 (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
130 tainted = oldtainted;
131 }
132 SvMAGIC(sv) = SvMAGIC(osv);
133 SvFLAGS(sv) |= SvMAGICAL(osv);
134 localizing = 1;
135 SvSETMAGIC(sv);
136 localizing = 0;
137 }
138 return sv;
139}
140
141SV *
142save_scalar(gv)
143GV *gv;
144{
145 SSCHECK(3);
146 SSPUSHPTR(gv);
147 SSPUSHPTR(GvSV(gv));
148 SSPUSHINT(SAVEt_SV);
149 return save_scalar_at(&GvSV(gv));
150}
151
152SV*
153save_svref(sptr)
154SV **sptr;
155{
156 SSCHECK(3);
157 SSPUSHPTR(sptr);
158 SSPUSHPTR(*sptr);
159 SSPUSHINT(SAVEt_SVREF);
160 return save_scalar_at(sptr);
161}
162
163void
164save_gp(gv, empty)
165GV *gv;
166I32 empty;
167{
168 SSCHECK(3);
169 SSPUSHPTR(SvREFCNT_inc(gv));
170 SSPUSHPTR(GvGP(gv));
171 SSPUSHINT(SAVEt_GP);
172
173 if (empty) {
174 register GP *gp;
175 Newz(602, gp, 1, GP);
176 GvGP(gv) = gp_ref(gp);
177 GvSV(gv) = NEWSV(72,0);
178 GvLINE(gv) = curcop->cop_line;
179 GvEGV(gv) = gv;
180 }
181 else {
182 gp_ref(GvGP(gv));
183 GvINTRO_on(gv);
184 }
185}
186
187AV *
188save_ary(gv)
189GV *gv;
190{
191 SSCHECK(3);
192 SSPUSHPTR(gv);
193 SSPUSHPTR(GvAVn(gv));
194 SSPUSHINT(SAVEt_AV);
195
196 GvAV(gv) = Null(AV*);
197 return GvAVn(gv);
198}
199
200HV *
201save_hash(gv)
202GV *gv;
203{
204 SSCHECK(3);
205 SSPUSHPTR(gv);
206 SSPUSHPTR(GvHVn(gv));
207 SSPUSHINT(SAVEt_HV);
208
209 GvHV(gv) = Null(HV*);
210 return GvHVn(gv);
211}
212
213void
214save_item(item)
215register SV *item;
216{
217 register SV *sv;
218
219 SSCHECK(3);
220 SSPUSHPTR(item); /* remember the pointer */
221 sv = NEWSV(0,0);
222 sv_setsv(sv,item);
223 SSPUSHPTR(sv); /* remember the value */
224 SSPUSHINT(SAVEt_ITEM);
225}
226
227void
228save_int(intp)
229int *intp;
230{
231 SSCHECK(3);
232 SSPUSHINT(*intp);
233 SSPUSHPTR(intp);
234 SSPUSHINT(SAVEt_INT);
235}
236
237void
238save_long(longp)
239long *longp;
240{
241 SSCHECK(3);
242 SSPUSHLONG(*longp);
243 SSPUSHPTR(longp);
244 SSPUSHINT(SAVEt_LONG);
245}
246
247void
248save_I32(intp)
249I32 *intp;
250{
251 SSCHECK(3);
252 SSPUSHINT(*intp);
253 SSPUSHPTR(intp);
254 SSPUSHINT(SAVEt_I32);
255}
256
257void
258save_I16(intp)
259I16 *intp;
260{
261 SSCHECK(3);
262 SSPUSHINT(*intp);
263 SSPUSHPTR(intp);
264 SSPUSHINT(SAVEt_I16);
265}
266
267void
268save_iv(ivp)
269IV *ivp;
270{
271 SSCHECK(3);
272 SSPUSHIV(*ivp);
273 SSPUSHPTR(ivp);
274 SSPUSHINT(SAVEt_IV);
275}
276
277/* Cannot use save_sptr() to store a char* since the SV** cast will
278 * force word-alignment and we'll miss the pointer.
279 */
280void
281save_pptr(pptr)
282char **pptr;
283{
284 SSCHECK(3);
285 SSPUSHPTR(*pptr);
286 SSPUSHPTR(pptr);
287 SSPUSHINT(SAVEt_PPTR);
288}
289
290void
291save_sptr(sptr)
292SV **sptr;
293{
294 SSCHECK(3);
295 SSPUSHPTR(*sptr);
296 SSPUSHPTR(sptr);
297 SSPUSHINT(SAVEt_SPTR);
298}
299
300void
301save_nogv(gv)
302GV *gv;
303{
304 SSCHECK(2);
305 SSPUSHPTR(gv);
306 SSPUSHINT(SAVEt_NSTAB);
307}
308
309void
310save_hptr(hptr)
311HV **hptr;
312{
313 SSCHECK(3);
314 SSPUSHPTR(*hptr);
315 SSPUSHPTR(hptr);
316 SSPUSHINT(SAVEt_HPTR);
317}
318
319void
320save_aptr(aptr)
321AV **aptr;
322{
323 SSCHECK(3);
324 SSPUSHPTR(*aptr);
325 SSPUSHPTR(aptr);
326 SSPUSHINT(SAVEt_APTR);
327}
328
329void
330save_freesv(sv)
331SV *sv;
332{
333 SSCHECK(2);
334 SSPUSHPTR(sv);
335 SSPUSHINT(SAVEt_FREESV);
336}
337
338void
339save_freeop(op)
340OP *op;
341{
342 SSCHECK(2);
343 SSPUSHPTR(op);
344 SSPUSHINT(SAVEt_FREEOP);
345}
346
347void
348save_freepv(pv)
349char *pv;
350{
351 SSCHECK(2);
352 SSPUSHPTR(pv);
353 SSPUSHINT(SAVEt_FREEPV);
354}
355
356void
357save_clearsv(svp)
358SV** svp;
359{
360 SSCHECK(2);
361 SSPUSHLONG((long)(svp-curpad));
362 SSPUSHINT(SAVEt_CLEARSV);
363}
364
365void
366save_delete(hv,key,klen)
367HV *hv;
368char *key;
369I32 klen;
370{
371 SSCHECK(4);
372 SSPUSHINT(klen);
373 SSPUSHPTR(key);
374 SSPUSHPTR(hv);
375 SSPUSHINT(SAVEt_DELETE);
376}
377
378void
379save_list(sarg,maxsarg)
380register SV **sarg;
381I32 maxsarg;
382{
383 register SV *sv;
384 register I32 i;
385
386 SSCHECK(3 * maxsarg);
387 for (i = 1; i <= maxsarg; i++) {
388 SSPUSHPTR(sarg[i]); /* remember the pointer */
389 sv = NEWSV(0,0);
390 sv_setsv(sv,sarg[i]);
391 SSPUSHPTR(sv); /* remember the value */
392 SSPUSHINT(SAVEt_ITEM);
393 }
394}
395
396void
397save_destructor(f,p)
398void (*f) _((void*));
399void* p;
400{
401 SSCHECK(3);
402 SSPUSHDPTR(f);
403 SSPUSHPTR(p);
404 SSPUSHINT(SAVEt_DESTRUCTOR);
405}
406
407void
408leave_scope(base)
409I32 base;
410{
411 register SV *sv;
412 register SV *value;
413 register GV *gv;
414 register AV *av;
415 register HV *hv;
416 register void* ptr;
417
418 if (base < -1)
419 croak("panic: corrupt saved stack index");
420 while (savestack_ix > base) {
421 switch (SSPOPINT) {
422 case SAVEt_ITEM: /* normal string */
423 value = (SV*)SSPOPPTR;
424 sv = (SV*)SSPOPPTR;
425 sv_replace(sv,value);
426 localizing = 2;
427 SvSETMAGIC(sv);
428 localizing = 0;
429 break;
430 case SAVEt_SV: /* scalar reference */
431 value = (SV*)SSPOPPTR;
432 gv = (GV*)SSPOPPTR;
433 ptr = &GvSV(gv);
434 goto restore_sv;
435 case SAVEt_SVREF: /* scalar reference */
436 value = (SV*)SSPOPPTR;
437 ptr = SSPOPPTR;
438 restore_sv:
439 sv = *(SV**)ptr;
440 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv) &&
441 SvTYPE(sv) != SVt_PVGV)
442 {
443 (void)SvUPGRADE(value, SvTYPE(sv));
444 SvMAGIC(value) = SvMAGIC(sv);
445 SvFLAGS(value) |= SvMAGICAL(sv);
446 SvMAGICAL_off(sv);
447 SvMAGIC(sv) = 0;
448 }
449 else if (SvTYPE(value) >= SVt_PVMG && SvMAGIC(value) &&
450 SvTYPE(value) != SVt_PVGV)
451 {
452 SvFLAGS(value) |= (SvFLAGS(value) &
453 (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
454 SvMAGICAL_off(value);
455 SvMAGIC(value) = 0;
456 }
457 SvREFCNT_dec(sv);
458 *(SV**)ptr = value;
459 localizing = 2;
460 SvSETMAGIC(value);
461 localizing = 0;
462 break;
463 case SAVEt_AV: /* array reference */
464 av = (AV*)SSPOPPTR;
465 gv = (GV*)SSPOPPTR;
466 SvREFCNT_dec(GvAV(gv));
467 GvAV(gv) = av;
468 break;
469 case SAVEt_HV: /* hash reference */
470 hv = (HV*)SSPOPPTR;
471 gv = (GV*)SSPOPPTR;
472 SvREFCNT_dec(GvHV(gv));
473 GvHV(gv) = hv;
474 break;
475 case SAVEt_INT: /* int reference */
476 ptr = SSPOPPTR;
477 *(int*)ptr = (int)SSPOPINT;
478 break;
479 case SAVEt_LONG: /* long reference */
480 ptr = SSPOPPTR;
481 *(long*)ptr = (long)SSPOPLONG;
482 break;
483 case SAVEt_I32: /* I32 reference */
484 ptr = SSPOPPTR;
485 *(I32*)ptr = (I32)SSPOPINT;
486 break;
487 case SAVEt_I16: /* I16 reference */
488 ptr = SSPOPPTR;
489 *(I16*)ptr = (I16)SSPOPINT;
490 break;
491 case SAVEt_IV: /* IV reference */
492 ptr = SSPOPPTR;
493 *(IV*)ptr = (IV)SSPOPIV;
494 break;
495 case SAVEt_SPTR: /* SV* reference */
496 ptr = SSPOPPTR;
497 *(SV**)ptr = (SV*)SSPOPPTR;
498 break;
499 case SAVEt_PPTR: /* char* reference */
500 ptr = SSPOPPTR;
501 *(char**)ptr = (char*)SSPOPPTR;
502 break;
503 case SAVEt_HPTR: /* HV* reference */
504 ptr = SSPOPPTR;
505 *(HV**)ptr = (HV*)SSPOPPTR;
506 break;
507 case SAVEt_APTR: /* AV* reference */
508 ptr = SSPOPPTR;
509 *(AV**)ptr = (AV*)SSPOPPTR;
510 break;
511 case SAVEt_NSTAB:
512 gv = (GV*)SSPOPPTR;
513 (void)sv_clear((SV*)gv);
514 break;
515 case SAVEt_GP: /* scalar reference */
516 ptr = SSPOPPTR;
517 gv = (GV*)SSPOPPTR;
518 gp_free(gv);
519 GvGP(gv) = (GP*)ptr;
520 SvREFCNT_dec(gv);
521 break;
522 case SAVEt_FREESV:
523 ptr = SSPOPPTR;
524 SvREFCNT_dec((SV*)ptr);
525 break;
526 case SAVEt_FREEOP:
527 ptr = SSPOPPTR;
528 if (comppad)
529 curpad = AvARRAY(comppad);
530 op_free((OP*)ptr);
531 break;
532 case SAVEt_FREEPV:
533 ptr = SSPOPPTR;
534 Safefree((char*)ptr);
535 break;
536 case SAVEt_CLEARSV:
537 ptr = (void*)&curpad[SSPOPLONG];
538 sv = *(SV**)ptr;
539 /* Can clear pad variable in place? */
540 if (SvREFCNT(sv) <= 1 && !SvOBJECT(sv)) {
541 if (SvTHINKFIRST(sv)) {
542 if (SvREADONLY(sv))
543 croak("panic: leave_scope clearsv");
544 if (SvROK(sv))
545 sv_unref(sv);
546 }
547 if (SvMAGICAL(sv))
548 mg_free(sv);
549
550 switch (SvTYPE(sv)) {
551 case SVt_NULL:
552 break;
553 case SVt_PVAV:
554 av_clear((AV*)sv);
555 break;
556 case SVt_PVHV:
557 hv_clear((HV*)sv);
558 break;
559 case SVt_PVCV:
560 croak("panic: leave_scope pad code");
561 case SVt_RV:
562 case SVt_IV:
563 case SVt_NV:
564 (void)SvOK_off(sv);
565 break;
566 default:
567 (void)SvOK_off(sv);
568 (void)SvOOK_off(sv);
569 break;
570 }
571 }
572 else { /* Someone has a claim on this, so abandon it. */
573 U32 padflags = SvFLAGS(sv) & (SVs_PADBUSY|SVs_PADMY|SVs_PADTMP);
574 SvREFCNT_dec(sv); /* Cast current value to the winds. */
575 switch (SvTYPE(sv)) { /* Console ourselves with a new value */
576 case SVt_PVAV: *(SV**)ptr = (SV*)newAV(); break;
577 case SVt_PVHV: *(SV**)ptr = (SV*)newHV(); break;
578 default: *(SV**)ptr = NEWSV(0,0); break;
579 }
580 SvFLAGS(*(SV**)ptr) |= padflags; /* preserve pad nature */
581 }
582 break;
583 case SAVEt_DELETE:
584 ptr = SSPOPPTR;
585 hv = (HV*)ptr;
586 ptr = SSPOPPTR;
587 (void)hv_delete(hv, (char*)ptr, (U32)SSPOPINT, G_DISCARD);
588 Safefree(ptr);
589 break;
590 case SAVEt_DESTRUCTOR:
591 ptr = SSPOPPTR;
592 (*SSPOPDPTR)(ptr);
593 break;
594 case SAVEt_REGCONTEXT:
595 {
596 I32 delta = SSPOPINT;
597 savestack_ix -= delta; /* regexp must have croaked */
598 }
599 break;
600 case SAVEt_STACK_POS: /* Position on Perl stack */
601 {
602 I32 delta = SSPOPINT;
603 stack_sp = stack_base + delta;
604 }
605 break;
606 default:
607 croak("panic: leave_scope inconsistency");
608 }
609 }
610}
611
612#ifdef DEBUGGING
613
614void
615cx_dump(cx)
616CONTEXT* cx;
617{
618 PerlIO_printf(Perl_debug_log, "CX %d = %s\n", cx - cxstack, block_type[cx->cx_type]);
619 if (cx->cx_type != CXt_SUBST) {
620 PerlIO_printf(Perl_debug_log, "BLK_OLDSP = %ld\n", (long)cx->blk_oldsp);
621 PerlIO_printf(Perl_debug_log, "BLK_OLDCOP = 0x%lx\n", (long)cx->blk_oldcop);
622 PerlIO_printf(Perl_debug_log, "BLK_OLDMARKSP = %ld\n", (long)cx->blk_oldmarksp);
623 PerlIO_printf(Perl_debug_log, "BLK_OLDSCOPESP = %ld\n", (long)cx->blk_oldscopesp);
624 PerlIO_printf(Perl_debug_log, "BLK_OLDRETSP = %ld\n", (long)cx->blk_oldretsp);
625 PerlIO_printf(Perl_debug_log, "BLK_OLDPM = 0x%lx\n", (long)cx->blk_oldpm);
626 PerlIO_printf(Perl_debug_log, "BLK_GIMME = %s\n", cx->blk_gimme ? "LIST" : "SCALAR");
627 }
628 switch (cx->cx_type) {
629 case CXt_NULL:
630 case CXt_BLOCK:
631 break;
632 case CXt_SUB:
633 PerlIO_printf(Perl_debug_log, "BLK_SUB.CV = 0x%lx\n",
634 (long)cx->blk_sub.cv);
635 PerlIO_printf(Perl_debug_log, "BLK_SUB.GV = 0x%lx\n",
636 (long)cx->blk_sub.gv);
637 PerlIO_printf(Perl_debug_log, "BLK_SUB.DFOUTGV = 0x%lx\n",
638 (long)cx->blk_sub.dfoutgv);
639 PerlIO_printf(Perl_debug_log, "BLK_SUB.OLDDEPTH = %ld\n",
640 (long)cx->blk_sub.olddepth);
641 PerlIO_printf(Perl_debug_log, "BLK_SUB.HASARGS = %d\n",
642 (int)cx->blk_sub.hasargs);
643 break;
644 case CXt_EVAL:
645 PerlIO_printf(Perl_debug_log, "BLK_EVAL.OLD_IN_EVAL = %ld\n",
646 (long)cx->blk_eval.old_in_eval);
647 PerlIO_printf(Perl_debug_log, "BLK_EVAL.OLD_OP_TYPE = %s (%s)\n",
648 op_name[cx->blk_eval.old_op_type],
649 op_desc[cx->blk_eval.old_op_type]);
650 PerlIO_printf(Perl_debug_log, "BLK_EVAL.OLD_NAME = %s\n",
651 cx->blk_eval.old_name);
652 PerlIO_printf(Perl_debug_log, "BLK_EVAL.OLD_EVAL_ROOT = 0x%lx\n",
653 (long)cx->blk_eval.old_eval_root);
654 break;
655
656 case CXt_LOOP:
657 PerlIO_printf(Perl_debug_log, "BLK_LOOP.LABEL = %s\n",
658 cx->blk_loop.label);
659 PerlIO_printf(Perl_debug_log, "BLK_LOOP.RESETSP = %ld\n",
660 (long)cx->blk_loop.resetsp);
661 PerlIO_printf(Perl_debug_log, "BLK_LOOP.REDO_OP = 0x%lx\n",
662 (long)cx->blk_loop.redo_op);
663 PerlIO_printf(Perl_debug_log, "BLK_LOOP.NEXT_OP = 0x%lx\n",
664 (long)cx->blk_loop.next_op);
665 PerlIO_printf(Perl_debug_log, "BLK_LOOP.LAST_OP = 0x%lx\n",
666 (long)cx->blk_loop.last_op);
667 PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERIX = %ld\n",
668 (long)cx->blk_loop.iterix);
669 PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERARY = 0x%lx\n",
670 (long)cx->blk_loop.iterary);
671 PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERVAR = 0x%lx\n",
672 (long)cx->blk_loop.itervar);
673 if (cx->blk_loop.itervar)
674 PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERSAVE = 0x%lx\n",
675 (long)cx->blk_loop.itersave);
676 PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERLVAL = 0x%lx\n",
677 (long)cx->blk_loop.iterlval);
678 break;
679
680 case CXt_SUBST:
681 PerlIO_printf(Perl_debug_log, "SB_ITERS = %ld\n",
682 (long)cx->sb_iters);
683 PerlIO_printf(Perl_debug_log, "SB_MAXITERS = %ld\n",
684 (long)cx->sb_maxiters);
685 PerlIO_printf(Perl_debug_log, "SB_SAFEBASE = %ld\n",
686 (long)cx->sb_safebase);
687 PerlIO_printf(Perl_debug_log, "SB_ONCE = %ld\n",
688 (long)cx->sb_once);
689 PerlIO_printf(Perl_debug_log, "SB_ORIG = %s\n",
690 cx->sb_orig);
691 PerlIO_printf(Perl_debug_log, "SB_DSTR = 0x%lx\n",
692 (long)cx->sb_dstr);
693 PerlIO_printf(Perl_debug_log, "SB_TARG = 0x%lx\n",
694 (long)cx->sb_targ);
695 PerlIO_printf(Perl_debug_log, "SB_S = 0x%lx\n",
696 (long)cx->sb_s);
697 PerlIO_printf(Perl_debug_log, "SB_M = 0x%lx\n",
698 (long)cx->sb_m);
699 PerlIO_printf(Perl_debug_log, "SB_STREND = 0x%lx\n",
700 (long)cx->sb_strend);
701 PerlIO_printf(Perl_debug_log, "SB_RXRES = 0x%lx\n",
702 (long)cx->sb_rxres);
703 break;
704 }
705}
706#endif
Unnamed repository; edit this file 'description' to name the repository.