This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
introduce save_I8() for saving byte values
[perl5.git] / scope.c
CommitLineData
a0d0e21e 1/* scope.c
79072805 2 *
4eb8286e 3 * Copyright (c) 1991-1999, Larry Wall
79072805
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 *
a0d0e21e
LW
8 */
9
10/*
11 * "For the fashion of Minas Tirith was such that it was built on seven
12 * levels..."
79072805
LW
13 */
14
15#include "EXTERN.h"
864dbfa3 16#define PERL_IN_SCOPE_C
79072805
LW
17#include "perl.h"
18
312caa8e 19void *
db36c5a1
GS
20Perl_default_protect(pTHX_ volatile JMPENV *pcur_env, int *excpt,
21 protect_body_t body, ...)
312caa8e 22{
c5be433b
GS
23 void *ret;
24 va_list args;
25 va_start(args, body);
db36c5a1 26 ret = vdefault_protect(pcur_env, excpt, body, &args);
c5be433b
GS
27 va_end(args);
28 return ret;
29}
30
31void *
db36c5a1
GS
32Perl_vdefault_protect(pTHX_ volatile JMPENV *pcur_env, int *excpt,
33 protect_body_t body, va_list *args)
c5be433b 34{
312caa8e 35 dTHR;
312caa8e
CS
36 int ex;
37 void *ret;
38
cea2e8a9 39 DEBUG_l(Perl_deb(aTHX_ "Setting up local jumplevel %p, was %p\n",
db36c5a1 40 pcur_env, PL_top_env));
312caa8e
CS
41 JMPENV_PUSH(ex);
42 if (ex)
43 ret = NULL;
c5be433b
GS
44 else
45 ret = CALL_FPTR(body)(aTHX_ *args);
a6c40364 46 *excpt = ex;
312caa8e
CS
47 JMPENV_POP;
48 return ret;
49}
50
a0d0e21e 51SV**
864dbfa3 52Perl_stack_grow(pTHX_ SV **sp, SV **p, int n)
a0d0e21e 53{
11343788 54 dTHR;
a60c0954
NIS
55#if defined(DEBUGGING) && !defined(USE_THREADS)
56 static int growing = 0;
57 if (growing++)
58 abort();
59#endif
3280af22 60 PL_stack_sp = sp;
2ce36478 61#ifndef STRESS_REALLOC
3280af22 62 av_extend(PL_curstack, (p - PL_stack_base) + (n) + 128);
2ce36478 63#else
6b88bc9c 64 av_extend(PL_curstack, (p - PL_stack_base) + (n) + 1);
2ce36478 65#endif
a60c0954
NIS
66#if defined(DEBUGGING) && !defined(USE_THREADS)
67 growing--;
68#endif
3280af22 69 return PL_stack_sp;
a0d0e21e
LW
70}
71
2ce36478
SM
72#ifndef STRESS_REALLOC
73#define GROW(old) ((old) * 3 / 2)
74#else
75#define GROW(old) ((old) + 1)
76#endif
77
e336de0d 78PERL_SI *
864dbfa3 79Perl_new_stackinfo(pTHX_ I32 stitems, I32 cxitems)
e336de0d
GS
80{
81 PERL_SI *si;
82 PERL_CONTEXT *cxt;
83 New(56, si, 1, PERL_SI);
84 si->si_stack = newAV();
85 AvREAL_off(si->si_stack);
86 av_extend(si->si_stack, stitems > 0 ? stitems-1 : 0);
3280af22 87 AvALLOC(si->si_stack)[0] = &PL_sv_undef;
e336de0d
GS
88 AvFILLp(si->si_stack) = 0;
89 si->si_prev = 0;
90 si->si_next = 0;
91 si->si_cxmax = cxitems - 1;
92 si->si_cxix = -1;
e788e7d3 93 si->si_type = PERLSI_UNDEF;
e336de0d
GS
94 New(56, si->si_cxstack, cxitems, PERL_CONTEXT);
95 return si;
96}
97
79072805 98I32
864dbfa3 99Perl_cxinc(pTHX)
79072805 100{
11343788 101 dTHR;
2ce36478 102 cxstack_max = GROW(cxstack_max);
c09156bb 103 Renew(cxstack, cxstack_max + 1, PERL_CONTEXT); /* XXX should fix CXINC macro */
79072805
LW
104 return cxstack_ix + 1;
105}
106
107void
864dbfa3 108Perl_push_return(pTHX_ OP *retop)
79072805 109{
11343788 110 dTHR;
3280af22
NIS
111 if (PL_retstack_ix == PL_retstack_max) {
112 PL_retstack_max = GROW(PL_retstack_max);
113 Renew(PL_retstack, PL_retstack_max, OP*);
79072805 114 }
3280af22 115 PL_retstack[PL_retstack_ix++] = retop;
79072805
LW
116}
117
118OP *
864dbfa3 119Perl_pop_return(pTHX)
79072805 120{
11343788 121 dTHR;
3280af22
NIS
122 if (PL_retstack_ix > 0)
123 return PL_retstack[--PL_retstack_ix];
79072805
LW
124 else
125 return Nullop;
126}
127
128void
864dbfa3 129Perl_push_scope(pTHX)
79072805 130{
11343788 131 dTHR;
3280af22
NIS
132 if (PL_scopestack_ix == PL_scopestack_max) {
133 PL_scopestack_max = GROW(PL_scopestack_max);
134 Renew(PL_scopestack, PL_scopestack_max, I32);
79072805 135 }
3280af22 136 PL_scopestack[PL_scopestack_ix++] = PL_savestack_ix;
79072805
LW
137
138}
139
140void
864dbfa3 141Perl_pop_scope(pTHX)
79072805 142{
11343788 143 dTHR;
3280af22 144 I32 oldsave = PL_scopestack[--PL_scopestack_ix];
8990e307 145 LEAVE_SCOPE(oldsave);
79072805
LW
146}
147
148void
864dbfa3 149Perl_markstack_grow(pTHX)
a0d0e21e 150{
11343788 151 dTHR;
3280af22 152 I32 oldmax = PL_markstack_max - PL_markstack;
2ce36478 153 I32 newmax = GROW(oldmax);
a0d0e21e 154
3280af22
NIS
155 Renew(PL_markstack, newmax, I32);
156 PL_markstack_ptr = PL_markstack + oldmax;
157 PL_markstack_max = PL_markstack + newmax;
a0d0e21e
LW
158}
159
160void
864dbfa3 161Perl_savestack_grow(pTHX)
79072805 162{
11343788 163 dTHR;
3280af22
NIS
164 PL_savestack_max = GROW(PL_savestack_max) + 4;
165 Renew(PL_savestack, PL_savestack_max, ANY);
79072805
LW
166}
167
2ce36478
SM
168#undef GROW
169
79072805 170void
864dbfa3 171Perl_tmps_grow(pTHX_ I32 n)
677b06e3
GS
172{
173 dTHR;
174#ifndef STRESS_REALLOC
175 if (n < 128)
176 n = (PL_tmps_max < 512) ? 128 : 512;
177#endif
178 PL_tmps_max = PL_tmps_ix + n + 1;
179 Renew(PL_tmps_stack, PL_tmps_max, SV*);
180}
181
182
183void
864dbfa3 184Perl_free_tmps(pTHX)
79072805 185{
11343788 186 dTHR;
79072805 187 /* XXX should tmps_floor live in cxstack? */
3280af22
NIS
188 I32 myfloor = PL_tmps_floor;
189 while (PL_tmps_ix > myfloor) { /* clean up after last statement */
190 SV* sv = PL_tmps_stack[PL_tmps_ix];
191 PL_tmps_stack[PL_tmps_ix--] = Nullsv;
463ee0b2 192 if (sv) {
463ee0b2 193 SvTEMP_off(sv);
8990e307 194 SvREFCNT_dec(sv); /* note, can modify tmps_ix!!! */
463ee0b2 195 }
79072805
LW
196 }
197}
198
76e3520e 199STATIC SV *
cea2e8a9 200S_save_scalar_at(pTHX_ SV **sptr)
79072805 201{
11343788 202 dTHR;
79072805 203 register SV *sv;
7a4c00b4 204 SV *osv = *sptr;
79072805 205
7a4c00b4 206 sv = *sptr = NEWSV(0,0);
a0d0e21e 207 if (SvTYPE(osv) >= SVt_PVMG && SvMAGIC(osv) && SvTYPE(osv) != SVt_PVGV) {
79072805 208 sv_upgrade(sv, SvTYPE(osv));
a0d0e21e 209 if (SvGMAGICAL(osv)) {
748a9306 210 MAGIC* mg;
3280af22 211 bool oldtainted = PL_tainted;
a0d0e21e 212 mg_get(osv);
3280af22 213 if (PL_tainting && PL_tainted && (mg = mg_find(osv, 't'))) {
748a9306
LW
214 SAVESPTR(mg->mg_obj);
215 mg->mg_obj = osv;
216 }
a0d0e21e
LW
217 SvFLAGS(osv) |= (SvFLAGS(osv) &
218 (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
3280af22 219 PL_tainted = oldtainted;
a0d0e21e 220 }
79072805 221 SvMAGIC(sv) = SvMAGIC(osv);
a0d0e21e 222 SvFLAGS(sv) |= SvMAGICAL(osv);
3280af22 223 PL_localizing = 1;
79072805 224 SvSETMAGIC(sv);
3280af22 225 PL_localizing = 0;
79072805
LW
226 }
227 return sv;
228}
229
7a4c00b4 230SV *
864dbfa3 231Perl_save_scalar(pTHX_ GV *gv)
7a4c00b4 232{
11343788 233 dTHR;
4e4c362e 234 SV **sptr = &GvSV(gv);
7a4c00b4 235 SSCHECK(3);
4e4c362e
GS
236 SSPUSHPTR(SvREFCNT_inc(gv));
237 SSPUSHPTR(SvREFCNT_inc(*sptr));
7a4c00b4 238 SSPUSHINT(SAVEt_SV);
4e4c362e 239 return save_scalar_at(sptr);
7a4c00b4
PP
240}
241
242SV*
864dbfa3 243Perl_save_svref(pTHX_ SV **sptr)
7a4c00b4 244{
11343788 245 dTHR;
7a4c00b4
PP
246 SSCHECK(3);
247 SSPUSHPTR(sptr);
4e4c362e 248 SSPUSHPTR(SvREFCNT_inc(*sptr));
7a4c00b4
PP
249 SSPUSHINT(SAVEt_SVREF);
250 return save_scalar_at(sptr);
251}
252
b9d12d37
GS
253/* Like save_svref(), but doesn't deal with magic. Can be used to
254 * restore a global SV to its prior contents, freeing new value. */
255void
864dbfa3 256Perl_save_generic_svref(pTHX_ SV **sptr)
b9d12d37
GS
257{
258 dTHR;
259 SSCHECK(3);
260 SSPUSHPTR(sptr);
261 SSPUSHPTR(SvREFCNT_inc(*sptr));
262 SSPUSHINT(SAVEt_GENERIC_SVREF);
263}
264
79072805 265void
864dbfa3 266Perl_save_gp(pTHX_ GV *gv, I32 empty)
79072805 267{
e858de61 268 dTHR;
fb73857a
PP
269 SSCHECK(6);
270 SSPUSHIV((IV)SvLEN(gv));
271 SvLEN(gv) = 0; /* forget that anything was allocated here */
272 SSPUSHIV((IV)SvCUR(gv));
273 SSPUSHPTR(SvPVX(gv));
274 SvPOK_off(gv);
4633a7c4 275 SSPUSHPTR(SvREFCNT_inc(gv));
5f05dabc 276 SSPUSHPTR(GvGP(gv));
79072805
LW
277 SSPUSHINT(SAVEt_GP);
278
5f05dabc
PP
279 if (empty) {
280 register GP *gp;
fae75791 281
18708f5a
GS
282 Newz(602, gp, 1, GP);
283
fae75791 284 if (GvCVu(gv))
3280af22 285 PL_sub_generation++; /* taking a method out of circulation */
cc49e20b 286 if (GvIOp(gv) && (IoFLAGS(GvIOp(gv)) & IOf_ARGV)) {
18708f5a
GS
287 gp->gp_io = newIO();
288 IoFLAGS(gp->gp_io) |= IOf_ARGV|IOf_START;
289 }
44a8e56a 290 GvGP(gv) = gp_ref(gp);
5f05dabc 291 GvSV(gv) = NEWSV(72,0);
57843af0 292 GvLINE(gv) = CopLINE(PL_curcop);
5f05dabc
PP
293 GvEGV(gv) = gv;
294 }
295 else {
44a8e56a 296 gp_ref(GvGP(gv));
5f05dabc
PP
297 GvINTRO_on(gv);
298 }
79072805 299}
79072805 300
79072805 301AV *
864dbfa3 302Perl_save_ary(pTHX_ GV *gv)
79072805 303{
11343788 304 dTHR;
67a38de0
NIS
305 AV *oav = GvAVn(gv);
306 AV *av;
fb73857a 307
67a38de0
NIS
308 if (!AvREAL(oav) && AvREIFY(oav))
309 av_reify(oav);
79072805
LW
310 SSCHECK(3);
311 SSPUSHPTR(gv);
67a38de0 312 SSPUSHPTR(oav);
79072805
LW
313 SSPUSHINT(SAVEt_AV);
314
315 GvAV(gv) = Null(AV*);
fb73857a
PP
316 av = GvAVn(gv);
317 if (SvMAGIC(oav)) {
318 SvMAGIC(av) = SvMAGIC(oav);
319 SvFLAGS(av) |= SvMAGICAL(oav);
320 SvMAGICAL_off(oav);
321 SvMAGIC(oav) = 0;
3280af22 322 PL_localizing = 1;
fb73857a 323 SvSETMAGIC((SV*)av);
3280af22 324 PL_localizing = 0;
fb73857a
PP
325 }
326 return av;
79072805
LW
327}
328
329HV *
864dbfa3 330Perl_save_hash(pTHX_ GV *gv)
79072805 331{
11343788 332 dTHR;
fb73857a
PP
333 HV *ohv, *hv;
334
79072805
LW
335 SSCHECK(3);
336 SSPUSHPTR(gv);
fb73857a 337 SSPUSHPTR(ohv = GvHVn(gv));
79072805
LW
338 SSPUSHINT(SAVEt_HV);
339
340 GvHV(gv) = Null(HV*);
fb73857a
PP
341 hv = GvHVn(gv);
342 if (SvMAGIC(ohv)) {
343 SvMAGIC(hv) = SvMAGIC(ohv);
344 SvFLAGS(hv) |= SvMAGICAL(ohv);
345 SvMAGICAL_off(ohv);
346 SvMAGIC(ohv) = 0;
3280af22 347 PL_localizing = 1;
fb73857a 348 SvSETMAGIC((SV*)hv);
3280af22 349 PL_localizing = 0;
fb73857a
PP
350 }
351 return hv;
79072805
LW
352}
353
354void
864dbfa3 355Perl_save_item(pTHX_ register SV *item)
79072805 356{
11343788 357 dTHR;
f46d017c 358 register SV *sv = NEWSV(0,0);
79072805 359
f46d017c 360 sv_setsv(sv,item);
79072805
LW
361 SSCHECK(3);
362 SSPUSHPTR(item); /* remember the pointer */
79072805
LW
363 SSPUSHPTR(sv); /* remember the value */
364 SSPUSHINT(SAVEt_ITEM);
365}
366
367void
864dbfa3 368Perl_save_int(pTHX_ int *intp)
79072805 369{
11343788 370 dTHR;
79072805
LW
371 SSCHECK(3);
372 SSPUSHINT(*intp);
373 SSPUSHPTR(intp);
374 SSPUSHINT(SAVEt_INT);
375}
376
377void
864dbfa3 378Perl_save_long(pTHX_ long int *longp)
85e6fe83 379{
11343788 380 dTHR;
85e6fe83
LW
381 SSCHECK(3);
382 SSPUSHLONG(*longp);
383 SSPUSHPTR(longp);
384 SSPUSHINT(SAVEt_LONG);
385}
386
387void
864dbfa3 388Perl_save_I32(pTHX_ I32 *intp)
79072805 389{
11343788 390 dTHR;
79072805
LW
391 SSCHECK(3);
392 SSPUSHINT(*intp);
393 SSPUSHPTR(intp);
394 SSPUSHINT(SAVEt_I32);
395}
396
a0d0e21e 397void
864dbfa3 398Perl_save_I16(pTHX_ I16 *intp)
55497cff 399{
e858de61 400 dTHR;
55497cff
PP
401 SSCHECK(3);
402 SSPUSHINT(*intp);
403 SSPUSHPTR(intp);
404 SSPUSHINT(SAVEt_I16);
405}
406
407void
e8347627
GS
408Perl_save_I8(pTHX_ I8 *bytep)
409{
410 dTHR;
411 SSCHECK(3);
412 SSPUSHINT(*bytep);
413 SSPUSHPTR(bytep);
414 SSPUSHINT(SAVEt_I8);
415}
416
417void
864dbfa3 418Perl_save_iv(pTHX_ IV *ivp)
a0d0e21e 419{
11343788 420 dTHR;
a0d0e21e 421 SSCHECK(3);
4aa0a1f7 422 SSPUSHIV(*ivp);
a0d0e21e
LW
423 SSPUSHPTR(ivp);
424 SSPUSHINT(SAVEt_IV);
425}
426
85e6fe83
LW
427/* Cannot use save_sptr() to store a char* since the SV** cast will
428 * force word-alignment and we'll miss the pointer.
429 */
430void
864dbfa3 431Perl_save_pptr(pTHX_ char **pptr)
85e6fe83 432{
11343788 433 dTHR;
85e6fe83
LW
434 SSCHECK(3);
435 SSPUSHPTR(*pptr);
436 SSPUSHPTR(pptr);
437 SSPUSHINT(SAVEt_PPTR);
438}
439
79072805 440void
7766f137
GS
441Perl_save_vptr(pTHX_ void *ptr)
442{
443 dTHR;
444 SSCHECK(3);
445 SSPUSHPTR(*(char**)ptr);
446 SSPUSHPTR(ptr);
447 SSPUSHINT(SAVEt_VPTR);
448}
449
450void
864dbfa3 451Perl_save_sptr(pTHX_ SV **sptr)
79072805 452{
11343788 453 dTHR;
79072805
LW
454 SSCHECK(3);
455 SSPUSHPTR(*sptr);
456 SSPUSHPTR(sptr);
457 SSPUSHINT(SAVEt_SPTR);
458}
459
54b9620d 460SV **
864dbfa3 461Perl_save_threadsv(pTHX_ PADOFFSET i)
54b9620d
MB
462{
463#ifdef USE_THREADS
464 dTHR;
940cb80d 465 SV **svp = &THREADSV(i); /* XXX Change to save by offset */
f1dbda3d
JH
466 DEBUG_S(PerlIO_printf(Perl_debug_log, "save_threadsv %"UVuf": %p %p:%s\n",
467 (UV)i, svp, *svp, SvPEEK(*svp)));
54b9620d
MB
468 save_svref(svp);
469 return svp;
470#else
cea2e8a9 471 Perl_croak(aTHX_ "panic: save_threadsv called in non-threaded perl");
54b9620d
MB
472 return 0;
473#endif /* USE_THREADS */
474}
475
79072805 476void
864dbfa3 477Perl_save_nogv(pTHX_ GV *gv)
79072805 478{
11343788 479 dTHR;
79072805
LW
480 SSCHECK(2);
481 SSPUSHPTR(gv);
482 SSPUSHINT(SAVEt_NSTAB);
483}
484
485void
864dbfa3 486Perl_save_hptr(pTHX_ HV **hptr)
79072805 487{
11343788 488 dTHR;
79072805 489 SSCHECK(3);
85e6fe83 490 SSPUSHPTR(*hptr);
79072805
LW
491 SSPUSHPTR(hptr);
492 SSPUSHINT(SAVEt_HPTR);
493}
494
495void
864dbfa3 496Perl_save_aptr(pTHX_ AV **aptr)
79072805 497{
11343788 498 dTHR;
79072805 499 SSCHECK(3);
85e6fe83 500 SSPUSHPTR(*aptr);
79072805
LW
501 SSPUSHPTR(aptr);
502 SSPUSHINT(SAVEt_APTR);
503}
504
505void
864dbfa3 506Perl_save_freesv(pTHX_ SV *sv)
8990e307 507{
11343788 508 dTHR;
8990e307
LW
509 SSCHECK(2);
510 SSPUSHPTR(sv);
511 SSPUSHINT(SAVEt_FREESV);
512}
513
514void
864dbfa3 515Perl_save_freeop(pTHX_ OP *o)
8990e307 516{
11343788 517 dTHR;
8990e307 518 SSCHECK(2);
11343788 519 SSPUSHPTR(o);
8990e307
LW
520 SSPUSHINT(SAVEt_FREEOP);
521}
522
523void
864dbfa3 524Perl_save_freepv(pTHX_ char *pv)
8990e307 525{
11343788 526 dTHR;
8990e307
LW
527 SSCHECK(2);
528 SSPUSHPTR(pv);
529 SSPUSHINT(SAVEt_FREEPV);
530}
531
532void
864dbfa3 533Perl_save_clearsv(pTHX_ SV **svp)
8990e307 534{
11343788 535 dTHR;
8990e307 536 SSCHECK(2);
3280af22 537 SSPUSHLONG((long)(svp-PL_curpad));
8990e307
LW
538 SSPUSHINT(SAVEt_CLEARSV);
539}
540
541void
864dbfa3 542Perl_save_delete(pTHX_ HV *hv, char *key, I32 klen)
8990e307 543{
11343788 544 dTHR;
8990e307
LW
545 SSCHECK(4);
546 SSPUSHINT(klen);
547 SSPUSHPTR(key);
4e4c362e 548 SSPUSHPTR(SvREFCNT_inc(hv));
8990e307
LW
549 SSPUSHINT(SAVEt_DELETE);
550}
551
552void
864dbfa3 553Perl_save_list(pTHX_ register SV **sarg, I32 maxsarg)
79072805 554{
11343788 555 dTHR;
79072805
LW
556 register SV *sv;
557 register I32 i;
558
79072805 559 for (i = 1; i <= maxsarg; i++) {
79072805
LW
560 sv = NEWSV(0,0);
561 sv_setsv(sv,sarg[i]);
f46d017c
GS
562 SSCHECK(3);
563 SSPUSHPTR(sarg[i]); /* remember the pointer */
79072805
LW
564 SSPUSHPTR(sv); /* remember the value */
565 SSPUSHINT(SAVEt_ITEM);
566 }
567}
568
569void
c76ac1ee 570Perl_save_destructor(pTHX_ DESTRUCTORFUNC_NOCONTEXT_t f, void* p)
a0d0e21e 571{
11343788 572 dTHR;
a0d0e21e
LW
573 SSCHECK(3);
574 SSPUSHDPTR(f);
575 SSPUSHPTR(p);
576 SSPUSHINT(SAVEt_DESTRUCTOR);
577}
578
579void
c76ac1ee
GS
580Perl_save_destructor_x(pTHX_ DESTRUCTORFUNC_t f, void* p)
581{
582 dTHR;
583 SSCHECK(3);
584 SSPUSHDXPTR(f);
585 SSPUSHPTR(p);
586 SSPUSHINT(SAVEt_DESTRUCTOR_X);
587}
588
589void
864dbfa3 590Perl_save_aelem(pTHX_ AV *av, I32 idx, SV **sptr)
4e4c362e
GS
591{
592 dTHR;
593 SSCHECK(4);
594 SSPUSHPTR(SvREFCNT_inc(av));
595 SSPUSHINT(idx);
596 SSPUSHPTR(SvREFCNT_inc(*sptr));
597 SSPUSHINT(SAVEt_AELEM);
598 save_scalar_at(sptr);
599}
600
601void
864dbfa3 602Perl_save_helem(pTHX_ HV *hv, SV *key, SV **sptr)
4e4c362e
GS
603{
604 dTHR;
605 SSCHECK(4);
606 SSPUSHPTR(SvREFCNT_inc(hv));
607 SSPUSHPTR(SvREFCNT_inc(key));
608 SSPUSHPTR(SvREFCNT_inc(*sptr));
609 SSPUSHINT(SAVEt_HELEM);
610 save_scalar_at(sptr);
611}
612
613void
864dbfa3 614Perl_save_op(pTHX)
462e5cf6
MB
615{
616 dTHR;
617 SSCHECK(2);
533c011a 618 SSPUSHPTR(PL_op);
462e5cf6
MB
619 SSPUSHINT(SAVEt_OP);
620}
621
455ece5e 622I32
864dbfa3 623Perl_save_alloc(pTHX_ I32 size, I32 pad)
455ece5e
AD
624{
625 dTHR;
626 register I32 start = pad + ((char*)&PL_savestack[PL_savestack_ix]
627 - (char*)PL_savestack);
628 register I32 elems = 1 + ((size + pad - 1) / sizeof(*PL_savestack));
629
630 /* SSCHECK may not be good enough */
631 while (PL_savestack_ix + elems + 2 > PL_savestack_max)
632 savestack_grow();
633
634 PL_savestack_ix += elems;
635 SSPUSHINT(elems);
636 SSPUSHINT(SAVEt_ALLOC);
637 return start;
638}
639
462e5cf6 640void
864dbfa3 641Perl_leave_scope(pTHX_ I32 base)
79072805 642{
11343788 643 dTHR;
79072805
LW
644 register SV *sv;
645 register SV *value;
646 register GV *gv;
647 register AV *av;
648 register HV *hv;
649 register void* ptr;
161b7d16 650 I32 i;
79072805
LW
651
652 if (base < -1)
cea2e8a9 653 Perl_croak(aTHX_ "panic: corrupt saved stack index");
3280af22 654 while (PL_savestack_ix > base) {
79072805
LW
655 switch (SSPOPINT) {
656 case SAVEt_ITEM: /* normal string */
657 value = (SV*)SSPOPPTR;
658 sv = (SV*)SSPOPPTR;
659 sv_replace(sv,value);
3280af22 660 PL_localizing = 2;
79072805 661 SvSETMAGIC(sv);
3280af22 662 PL_localizing = 0;
79072805
LW
663 break;
664 case SAVEt_SV: /* scalar reference */
665 value = (SV*)SSPOPPTR;
666 gv = (GV*)SSPOPPTR;
7a4c00b4 667 ptr = &GvSV(gv);
4e4c362e 668 SvREFCNT_dec(gv);
7a4c00b4 669 goto restore_sv;
b9d12d37
GS
670 case SAVEt_GENERIC_SVREF: /* generic sv */
671 value = (SV*)SSPOPPTR;
672 ptr = SSPOPPTR;
673 if (ptr) {
674 sv = *(SV**)ptr;
675 *(SV**)ptr = value;
676 SvREFCNT_dec(sv);
677 }
678 SvREFCNT_dec(value);
679 break;
79072805 680 case SAVEt_SVREF: /* scalar reference */
7a4c00b4 681 value = (SV*)SSPOPPTR;
79072805 682 ptr = SSPOPPTR;
7a4c00b4 683 restore_sv:
79072805 684 sv = *(SV**)ptr;
bf49b057 685 DEBUG_S(PerlIO_printf(Perl_debug_log,
54b9620d
MB
686 "restore svref: %p %p:%s -> %p:%s\n",
687 ptr, sv, SvPEEK(sv), value, SvPEEK(value)));
748a9306
LW
688 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv) &&
689 SvTYPE(sv) != SVt_PVGV)
690 {
a0d0e21e
LW
691 (void)SvUPGRADE(value, SvTYPE(sv));
692 SvMAGIC(value) = SvMAGIC(sv);
693 SvFLAGS(value) |= SvMAGICAL(sv);
694 SvMAGICAL_off(sv);
79072805 695 SvMAGIC(sv) = 0;
a0d0e21e 696 }
7a4c00b4
PP
697 else if (SvTYPE(value) >= SVt_PVMG && SvMAGIC(value) &&
698 SvTYPE(value) != SVt_PVGV)
699 {
700 SvFLAGS(value) |= (SvFLAGS(value) &
701 (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
702 SvMAGICAL_off(value);
703 SvMAGIC(value) = 0;
704 }
8990e307 705 SvREFCNT_dec(sv);
a0d0e21e 706 *(SV**)ptr = value;
3280af22 707 PL_localizing = 2;
a0d0e21e 708 SvSETMAGIC(value);
3280af22 709 PL_localizing = 0;
4e4c362e 710 SvREFCNT_dec(value);
79072805
LW
711 break;
712 case SAVEt_AV: /* array reference */
713 av = (AV*)SSPOPPTR;
714 gv = (GV*)SSPOPPTR;
fb73857a
PP
715 if (GvAV(gv)) {
716 AV *goner = GvAV(gv);
717 SvMAGIC(av) = SvMAGIC(goner);
718 SvFLAGS(av) |= SvMAGICAL(goner);
719 SvMAGICAL_off(goner);
720 SvMAGIC(goner) = 0;
721 SvREFCNT_dec(goner);
722 }
79072805 723 GvAV(gv) = av;
fb73857a 724 if (SvMAGICAL(av)) {
3280af22 725 PL_localizing = 2;
fb73857a 726 SvSETMAGIC((SV*)av);
3280af22 727 PL_localizing = 0;
fb73857a 728 }
79072805
LW
729 break;
730 case SAVEt_HV: /* hash reference */
731 hv = (HV*)SSPOPPTR;
732 gv = (GV*)SSPOPPTR;
fb73857a
PP
733 if (GvHV(gv)) {
734 HV *goner = GvHV(gv);
735 SvMAGIC(hv) = SvMAGIC(goner);
736 SvFLAGS(hv) |= SvMAGICAL(goner);
737 SvMAGICAL_off(goner);
738 SvMAGIC(goner) = 0;
739 SvREFCNT_dec(goner);
740 }
79072805 741 GvHV(gv) = hv;
fb73857a 742 if (SvMAGICAL(hv)) {
3280af22 743 PL_localizing = 2;
fb73857a 744 SvSETMAGIC((SV*)hv);
3280af22 745 PL_localizing = 0;
fb73857a 746 }
79072805
LW
747 break;
748 case SAVEt_INT: /* int reference */
749 ptr = SSPOPPTR;
750 *(int*)ptr = (int)SSPOPINT;
751 break;
85e6fe83
LW
752 case SAVEt_LONG: /* long reference */
753 ptr = SSPOPPTR;
754 *(long*)ptr = (long)SSPOPLONG;
755 break;
79072805
LW
756 case SAVEt_I32: /* I32 reference */
757 ptr = SSPOPPTR;
758 *(I32*)ptr = (I32)SSPOPINT;
759 break;
55497cff
PP
760 case SAVEt_I16: /* I16 reference */
761 ptr = SSPOPPTR;
762 *(I16*)ptr = (I16)SSPOPINT;
763 break;
e8347627
GS
764 case SAVEt_I8: /* I8 reference */
765 ptr = SSPOPPTR;
766 *(I8*)ptr = (I8)SSPOPINT;
767 break;
a0d0e21e
LW
768 case SAVEt_IV: /* IV reference */
769 ptr = SSPOPPTR;
770 *(IV*)ptr = (IV)SSPOPIV;
771 break;
79072805
LW
772 case SAVEt_SPTR: /* SV* reference */
773 ptr = SSPOPPTR;
774 *(SV**)ptr = (SV*)SSPOPPTR;
775 break;
7766f137 776 case SAVEt_VPTR: /* random* reference */
85e6fe83
LW
777 case SAVEt_PPTR: /* char* reference */
778 ptr = SSPOPPTR;
779 *(char**)ptr = (char*)SSPOPPTR;
780 break;
79072805
LW
781 case SAVEt_HPTR: /* HV* reference */
782 ptr = SSPOPPTR;
783 *(HV**)ptr = (HV*)SSPOPPTR;
784 break;
785 case SAVEt_APTR: /* AV* reference */
786 ptr = SSPOPPTR;
787 *(AV**)ptr = (AV*)SSPOPPTR;
788 break;
789 case SAVEt_NSTAB:
790 gv = (GV*)SSPOPPTR;
1f96a9ed 791 (void)sv_clear((SV*)gv);
79072805 792 break;
fb73857a 793 case SAVEt_GP: /* scalar reference */
79072805
LW
794 ptr = SSPOPPTR;
795 gv = (GV*)SSPOPPTR;
ed6c1d6b 796 if (SvPVX(gv) && SvLEN(gv) > 0) {
fb73857a
PP
797 Safefree(SvPVX(gv));
798 }
799 SvPVX(gv) = (char *)SSPOPPTR;
800 SvCUR(gv) = (STRLEN)SSPOPIV;
801 SvLEN(gv) = (STRLEN)SSPOPIV;
f46d017c
GS
802 gp_free(gv);
803 GvGP(gv) = (GP*)ptr;
fae75791 804 if (GvCVu(gv))
3280af22 805 PL_sub_generation++; /* putting a method back into circulation */
4633a7c4 806 SvREFCNT_dec(gv);
79072805 807 break;
8990e307
LW
808 case SAVEt_FREESV:
809 ptr = SSPOPPTR;
810 SvREFCNT_dec((SV*)ptr);
811 break;
812 case SAVEt_FREEOP:
813 ptr = SSPOPPTR;
3280af22
NIS
814 if (PL_comppad)
815 PL_curpad = AvARRAY(PL_comppad);
8990e307
LW
816 op_free((OP*)ptr);
817 break;
818 case SAVEt_FREEPV:
819 ptr = SSPOPPTR;
820 Safefree((char*)ptr);
821 break;
822 case SAVEt_CLEARSV:
3280af22 823 ptr = (void*)&PL_curpad[SSPOPLONG];
8990e307 824 sv = *(SV**)ptr;
bc44cdaf
GS
825 /* Can clear pad variable in place? */
826 if (SvREFCNT(sv) <= 1 && !SvOBJECT(sv)) {
6fc92669
GS
827 if (SvTHINKFIRST(sv))
828 sv_force_normal(sv);
a0d0e21e
LW
829 if (SvMAGICAL(sv))
830 mg_free(sv);
8990e307
LW
831
832 switch (SvTYPE(sv)) {
833 case SVt_NULL:
834 break;
835 case SVt_PVAV:
44a8e56a 836 av_clear((AV*)sv);
8990e307
LW
837 break;
838 case SVt_PVHV:
44a8e56a 839 hv_clear((HV*)sv);
8990e307
LW
840 break;
841 case SVt_PVCV:
cea2e8a9 842 Perl_croak(aTHX_ "panic: leave_scope pad code");
5377b701
CS
843 case SVt_RV:
844 case SVt_IV:
845 case SVt_NV:
846 (void)SvOK_off(sv);
8990e307
LW
847 break;
848 default:
a0d0e21e 849 (void)SvOK_off(sv);
5377b701 850 (void)SvOOK_off(sv);
8990e307
LW
851 break;
852 }
853 }
854 else { /* Someone has a claim on this, so abandon it. */
4aa0a1f7 855 U32 padflags = SvFLAGS(sv) & (SVs_PADBUSY|SVs_PADMY|SVs_PADTMP);
8990e307
LW
856 switch (SvTYPE(sv)) { /* Console ourselves with a new value */
857 case SVt_PVAV: *(SV**)ptr = (SV*)newAV(); break;
858 case SVt_PVHV: *(SV**)ptr = (SV*)newHV(); break;
859 default: *(SV**)ptr = NEWSV(0,0); break;
860 }
53868620 861 SvREFCNT_dec(sv); /* Cast current value to the winds. */
4aa0a1f7 862 SvFLAGS(*(SV**)ptr) |= padflags; /* preserve pad nature */
8990e307
LW
863 }
864 break;
865 case SAVEt_DELETE:
866 ptr = SSPOPPTR;
867 hv = (HV*)ptr;
868 ptr = SSPOPPTR;
748a9306 869 (void)hv_delete(hv, (char*)ptr, (U32)SSPOPINT, G_DISCARD);
4e4c362e 870 SvREFCNT_dec(hv);
adbc6bb1 871 Safefree(ptr);
8990e307 872 break;
a0d0e21e
LW
873 case SAVEt_DESTRUCTOR:
874 ptr = SSPOPPTR;
c76ac1ee
GS
875 (*SSPOPDPTR)(ptr);
876 break;
877 case SAVEt_DESTRUCTOR_X:
878 ptr = SSPOPPTR;
879 (*SSPOPDXPTR)(aTHXo_ ptr);
a0d0e21e
LW
880 break;
881 case SAVEt_REGCONTEXT:
455ece5e 882 case SAVEt_ALLOC:
161b7d16 883 i = SSPOPINT;
3280af22 884 PL_savestack_ix -= i; /* regexp must have croaked */
a0d0e21e 885 break;
55497cff 886 case SAVEt_STACK_POS: /* Position on Perl stack */
161b7d16 887 i = SSPOPINT;
3280af22 888 PL_stack_sp = PL_stack_base + i;
55497cff 889 break;
161b7d16
SM
890 case SAVEt_AELEM: /* array element */
891 value = (SV*)SSPOPPTR;
892 i = SSPOPINT;
893 av = (AV*)SSPOPPTR;
894 ptr = av_fetch(av,i,1);
4e4c362e
GS
895 if (ptr) {
896 sv = *(SV**)ptr;
3280af22 897 if (sv && sv != &PL_sv_undef) {
33c27489 898 if (SvTIED_mg((SV*)av, 'P'))
4e4c362e
GS
899 (void)SvREFCNT_inc(sv);
900 SvREFCNT_dec(av);
901 goto restore_sv;
902 }
903 }
904 SvREFCNT_dec(av);
905 SvREFCNT_dec(value);
906 break;
161b7d16
SM
907 case SAVEt_HELEM: /* hash element */
908 value = (SV*)SSPOPPTR;
9002cb76 909 sv = (SV*)SSPOPPTR;
161b7d16
SM
910 hv = (HV*)SSPOPPTR;
911 ptr = hv_fetch_ent(hv, sv, 1, 0);
4e4c362e
GS
912 if (ptr) {
913 SV *oval = HeVAL((HE*)ptr);
3280af22 914 if (oval && oval != &PL_sv_undef) {
4e4c362e 915 ptr = &HeVAL((HE*)ptr);
33c27489 916 if (SvTIED_mg((SV*)hv, 'P'))
4e4c362e
GS
917 (void)SvREFCNT_inc(*(SV**)ptr);
918 SvREFCNT_dec(hv);
919 SvREFCNT_dec(sv);
920 goto restore_sv;
921 }
922 }
923 SvREFCNT_dec(hv);
924 SvREFCNT_dec(sv);
925 SvREFCNT_dec(value);
926 break;
462e5cf6 927 case SAVEt_OP:
533c011a 928 PL_op = (OP*)SSPOPPTR;
462e5cf6 929 break;
25eaa213 930 case SAVEt_HINTS:
3280af22
NIS
931 if (GvHV(PL_hintgv)) {
932 SvREFCNT_dec((SV*)GvHV(PL_hintgv));
933 GvHV(PL_hintgv) = NULL;
b3ac6de7 934 }
3280af22 935 *(I32*)&PL_hints = (I32)SSPOPINT;
b3ac6de7 936 break;
79072805 937 default:
cea2e8a9 938 Perl_croak(aTHX_ "panic: leave_scope inconsistency");
79072805
LW
939 }
940 }
941}
8990e307 942
8990e307 943void
864dbfa3 944Perl_cx_dump(pTHX_ PERL_CONTEXT *cx)
8990e307 945{
35ff7856 946#ifdef DEBUGGING
11343788 947 dTHR;
22c35a8c 948 PerlIO_printf(Perl_debug_log, "CX %ld = %s\n", (long)(cx - cxstack), PL_block_type[CxTYPE(cx)]);
6b35e009 949 if (CxTYPE(cx) != CXt_SUBST) {
760ac839 950 PerlIO_printf(Perl_debug_log, "BLK_OLDSP = %ld\n", (long)cx->blk_oldsp);
b900a521
JH
951 PerlIO_printf(Perl_debug_log, "BLK_OLDCOP = 0x%"UVxf"\n",
952 PTR2UV(cx->blk_oldcop));
760ac839
LW
953 PerlIO_printf(Perl_debug_log, "BLK_OLDMARKSP = %ld\n", (long)cx->blk_oldmarksp);
954 PerlIO_printf(Perl_debug_log, "BLK_OLDSCOPESP = %ld\n", (long)cx->blk_oldscopesp);
955 PerlIO_printf(Perl_debug_log, "BLK_OLDRETSP = %ld\n", (long)cx->blk_oldretsp);
b900a521
JH
956 PerlIO_printf(Perl_debug_log, "BLK_OLDPM = 0x%"UVxf"\n",
957 PTR2UV(cx->blk_oldpm));
760ac839 958 PerlIO_printf(Perl_debug_log, "BLK_GIMME = %s\n", cx->blk_gimme ? "LIST" : "SCALAR");
8990e307 959 }
6b35e009 960 switch (CxTYPE(cx)) {
8990e307
LW
961 case CXt_NULL:
962 case CXt_BLOCK:
963 break;
7766f137 964 case CXt_FORMAT:
b900a521
JH
965 PerlIO_printf(Perl_debug_log, "BLK_SUB.CV = 0x%"UVxf"\n",
966 PTR2UV(cx->blk_sub.cv));
967 PerlIO_printf(Perl_debug_log, "BLK_SUB.GV = 0x%"UVxf"\n",
968 PTR2UV(cx->blk_sub.gv));
969 PerlIO_printf(Perl_debug_log, "BLK_SUB.DFOUTGV = 0x%"UVxf"\n",
970 PTR2UV(cx->blk_sub.dfoutgv));
7766f137
GS
971 PerlIO_printf(Perl_debug_log, "BLK_SUB.HASARGS = %d\n",
972 (int)cx->blk_sub.hasargs);
973 break;
974 case CXt_SUB:
975 PerlIO_printf(Perl_debug_log, "BLK_SUB.CV = 0x%"UVxf"\n",
976 PTR2UV(cx->blk_sub.cv));
760ac839 977 PerlIO_printf(Perl_debug_log, "BLK_SUB.OLDDEPTH = %ld\n",
8990e307 978 (long)cx->blk_sub.olddepth);
760ac839 979 PerlIO_printf(Perl_debug_log, "BLK_SUB.HASARGS = %d\n",
8990e307 980 (int)cx->blk_sub.hasargs);
7766f137
GS
981 PerlIO_printf(Perl_debug_log, "BLK_SUB.LVAL = %d\n",
982 (int)cx->blk_sub.lval);
8990e307
LW
983 break;
984 case CXt_EVAL:
760ac839 985 PerlIO_printf(Perl_debug_log, "BLK_EVAL.OLD_IN_EVAL = %ld\n",
8990e307 986 (long)cx->blk_eval.old_in_eval);
760ac839 987 PerlIO_printf(Perl_debug_log, "BLK_EVAL.OLD_OP_TYPE = %s (%s)\n",
22c35a8c
GS
988 PL_op_name[cx->blk_eval.old_op_type],
989 PL_op_desc[cx->blk_eval.old_op_type]);
760ac839 990 PerlIO_printf(Perl_debug_log, "BLK_EVAL.OLD_NAME = %s\n",
8990e307 991 cx->blk_eval.old_name);
b900a521
JH
992 PerlIO_printf(Perl_debug_log, "BLK_EVAL.OLD_EVAL_ROOT = 0x%"UVxf"\n",
993 PTR2UV(cx->blk_eval.old_eval_root));
8990e307
LW
994 break;
995
996 case CXt_LOOP:
760ac839 997 PerlIO_printf(Perl_debug_log, "BLK_LOOP.LABEL = %s\n",
8990e307 998 cx->blk_loop.label);
760ac839 999 PerlIO_printf(Perl_debug_log, "BLK_LOOP.RESETSP = %ld\n",
8990e307 1000 (long)cx->blk_loop.resetsp);
b900a521
JH
1001 PerlIO_printf(Perl_debug_log, "BLK_LOOP.REDO_OP = 0x%"UVxf"\n",
1002 PTR2UV(cx->blk_loop.redo_op));
1003 PerlIO_printf(Perl_debug_log, "BLK_LOOP.NEXT_OP = 0x%"UVxf"\n",
1004 PTR2UV(cx->blk_loop.next_op));
1005 PerlIO_printf(Perl_debug_log, "BLK_LOOP.LAST_OP = 0x%"UVxf"\n",
1006 PTR2UV(cx->blk_loop.last_op));
760ac839 1007 PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERIX = %ld\n",
8990e307 1008 (long)cx->blk_loop.iterix);
b900a521
JH
1009 PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERARY = 0x%"UVxf"\n",
1010 PTR2UV(cx->blk_loop.iterary));
1011 PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERVAR = 0x%"UVxf"\n",
7766f137
GS
1012 PTR2UV(CxITERVAR(cx)));
1013 if (CxITERVAR(cx))
b900a521
JH
1014 PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERSAVE = 0x%"UVxf"\n",
1015 PTR2UV(cx->blk_loop.itersave));
1016 PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERLVAL = 0x%"UVxf"\n",
1017 PTR2UV(cx->blk_loop.iterlval));
8990e307
LW
1018 break;
1019
1020 case CXt_SUBST:
760ac839 1021 PerlIO_printf(Perl_debug_log, "SB_ITERS = %ld\n",
8990e307 1022 (long)cx->sb_iters);
760ac839 1023 PerlIO_printf(Perl_debug_log, "SB_MAXITERS = %ld\n",
8990e307 1024 (long)cx->sb_maxiters);
35ef4773
GS
1025 PerlIO_printf(Perl_debug_log, "SB_RFLAGS = %ld\n",
1026 (long)cx->sb_rflags);
760ac839 1027 PerlIO_printf(Perl_debug_log, "SB_ONCE = %ld\n",
8990e307 1028 (long)cx->sb_once);
760ac839 1029 PerlIO_printf(Perl_debug_log, "SB_ORIG = %s\n",
8990e307 1030 cx->sb_orig);
b900a521
JH
1031 PerlIO_printf(Perl_debug_log, "SB_DSTR = 0x%"UVxf"\n",
1032 PTR2UV(cx->sb_dstr));
1033 PerlIO_printf(Perl_debug_log, "SB_TARG = 0x%"UVxf"\n",
1034 PTR2UV(cx->sb_targ));
1035 PerlIO_printf(Perl_debug_log, "SB_S = 0x%"UVxf"\n",
1036 PTR2UV(cx->sb_s));
1037 PerlIO_printf(Perl_debug_log, "SB_M = 0x%"UVxf"\n",
1038 PTR2UV(cx->sb_m));
1039 PerlIO_printf(Perl_debug_log, "SB_STREND = 0x%"UVxf"\n",
1040 PTR2UV(cx->sb_strend));
1041 PerlIO_printf(Perl_debug_log, "SB_RXRES = 0x%"UVxf"\n",
1042 PTR2UV(cx->sb_rxres));
8990e307
LW
1043 break;
1044 }
17c3b450 1045#endif /* DEBUGGING */
35ff7856 1046}