This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Add OP_FREED op type
[perl5.git] / pad.c
CommitLineData
dd2155a4
DM
1/* pad.c
2 *
1129b882
NC
3 * Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008
4 * by Larry Wall and others
dd2155a4
DM
5 *
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
4ac71550
TC
8 */
9
10/*
11 * 'Anyway: there was this Mr. Frodo left an orphan and stranded, as you
12 * might say, among those queer Bucklanders, being brought up anyhow in
13 * Brandy Hall. A regular warren, by all accounts. Old Master Gorbadoc
14 * never had fewer than a couple of hundred relations in the place.
15 * Mr. Bilbo never did a kinder deed than when he brought the lad back
16 * to live among decent folk.' --the Gaffer
dd2155a4 17 *
4ac71550 18 * [p.23 of _The Lord of the Rings_, I/i: "A Long-Expected Party"]
dd2155a4
DM
19 */
20
21/* XXX DAPM
22 * As of Sept 2002, this file is new and may be in a state of flux for
23 * a while. I've marked things I intent to come back and look at further
24 * with an 'XXX DAPM' comment.
25 */
26
27/*
28=head1 Pad Data Structures
29
cc76b5cc 30=for apidoc Amx|PADLIST *|CvPADLIST|CV *cv
166f8a29 31
cc76b5cc
Z
32CV's can have CvPADLIST(cv) set to point to an AV. This is the CV's
33scratchpad, which stores lexical variables and opcode temporary and
34per-thread values.
dd2155a4
DM
35
36For these purposes "forms" are a kind-of CV, eval""s are too (except they're
37not callable at will and are always thrown away after the eval"" is done
b5c19bd7
DM
38executing). Require'd files are simply evals without any outer lexical
39scope.
dd2155a4
DM
40
41XSUBs don't have CvPADLIST set - dXSTARG fetches values from PL_curpad,
42but that is really the callers pad (a slot of which is allocated by
43every entersub).
44
7d953ba8 45The CvPADLIST AV has the REFCNT of its component items managed "manually"
6e670818 46(mostly in pad.c) rather than by normal av.c rules. So we turn off AvREAL
7d953ba8 47just before freeing it, to let av.c know not to touch the entries.
dd2155a4
DM
48The items in the AV are not SVs as for a normal AV, but other AVs:
49
500'th Entry of the CvPADLIST is an AV which represents the "names" or rather
51the "static type information" for lexicals.
52
53The CvDEPTH'th entry of CvPADLIST AV is an AV which is the stack frame at that
54depth of recursion into the CV.
55The 0'th slot of a frame AV is an AV which is @_.
56other entries are storage for variables and op targets.
57
f3548bdc 58Iterating over the names AV iterates over all possible pad
dd2155a4
DM
59items. Pad slots that are SVs_PADTMP (targets/GVs/constants) end up having
60&PL_sv_undef "names" (see pad_alloc()).
61
62Only my/our variable (SVs_PADMY/SVs_PADOUR) slots get valid names.
63The rest are op targets/GVs/constants which are statically allocated
64or resolved at compile time. These don't have names by which they
65can be looked up from Perl code at run time through eval"" like
66my/our variables can be. Since they can't be looked up by "name"
67but only by their index allocated at compile time (which is usually
68in PL_op->op_targ), wasting a name SV for them doesn't make sense.
69
70The SVs in the names AV have their PV being the name of the variable.
3441fb63 71xlow+1..xhigh inclusive in the NV union is a range of cop_seq numbers for
61f4bfbf
DM
72which the name is valid (accessed through the macros COP_SEQ_RANGE_LOW and
73_HIGH). During compilation, these fields may hold the special value
74PERL_PADSEQ_INTRO to indicate various stages:
0d311cdb
DM
75
76 COP_SEQ_RANGE_LOW _HIGH
77 ----------------- -----
78 PERL_PADSEQ_INTRO 0 variable not yet introduced: { my ($x
79 valid-seq# PERL_PADSEQ_INTRO variable in scope: { my ($x)
80 valid-seq# valid-seq# compilation of scope complete: { my ($x) }
81
82For typed lexicals name SV is SVt_PVMG and SvSTASH
3441fb63 83points at the type. For C<our> lexicals, the type is also SVt_PVMG, with the
73d95100 84SvOURSTASH slot pointing at the stash of the associated global (so that
931b58fb 85duplicate C<our> declarations in the same package can be detected). SvUVX is
3441fb63 86sometimes hijacked to store the generation number during compilation.
dd2155a4 87
b5c19bd7
DM
88If SvFAKE is set on the name SV, then that slot in the frame AV is
89a REFCNT'ed reference to a lexical from "outside". In this case,
3441fb63
NC
90the name SV does not use xlow and xhigh to store a cop_seq range, since it is
91in scope throughout. Instead xhigh stores some flags containing info about
b5c19bd7 92the real lexical (is it declared in an anon, and is it capable of being
3441fb63 93instantiated multiple times?), and for fake ANONs, xlow contains the index
b5c19bd7
DM
94within the parent's pad where the lexical's value is stored, to make
95cloning quicker.
dd2155a4 96
a6d05634 97If the 'name' is '&' the corresponding entry in frame AV
dd2155a4
DM
98is a CV representing a possible closure.
99(SvFAKE and name of '&' is not a meaningful combination currently but could
100become so if C<my sub foo {}> is implemented.)
101
71f882da
DM
102Note that formats are treated as anon subs, and are cloned each time
103write is called (if necessary).
104
ab8e66c1 105The flag SVs_PADSTALE is cleared on lexicals each time the my() is executed,
e6e7068b
DM
106and set on scope exit. This allows the 'Variable $x is not available' warning
107to be generated in evals, such as
108
109 { my $x = 1; sub f { eval '$x'} } f();
110
ab8e66c1 111For state vars, SVs_PADSTALE is overloaded to mean 'not yet initialised'
d1186544 112
cc76b5cc
Z
113=for apidoc AmxU|AV *|PL_comppad_name
114
115During compilation, this points to the array containing the names part
116of the pad for the currently-compiling code.
117
118=for apidoc AmxU|AV *|PL_comppad
119
120During compilation, this points to the array containing the values
121part of the pad for the currently-compiling code. (At runtime a CV may
122have many such value arrays; at compile time just one is constructed.)
123At runtime, this points to the array containing the currently-relevant
124values for the pad for the currently-executing code.
125
126=for apidoc AmxU|SV **|PL_curpad
127
128Points directly to the body of the L</PL_comppad> array.
129(I.e., this is C<AvARRAY(PL_comppad)>.)
130
dd2155a4
DM
131=cut
132*/
133
134
135#include "EXTERN.h"
136#define PERL_IN_PAD_C
137#include "perl.h"
952306ac 138#include "keywords.h"
dd2155a4 139
3441fb63
NC
140#define COP_SEQ_RANGE_LOW_set(sv,val) \
141 STMT_START { ((XPVNV*)SvANY(sv))->xnv_u.xpad_cop_seq.xlow = (val); } STMT_END
142#define COP_SEQ_RANGE_HIGH_set(sv,val) \
143 STMT_START { ((XPVNV*)SvANY(sv))->xnv_u.xpad_cop_seq.xhigh = (val); } STMT_END
809abb02 144
3441fb63
NC
145#define PARENT_PAD_INDEX_set(sv,val) \
146 STMT_START { ((XPVNV*)SvANY(sv))->xnv_u.xpad_cop_seq.xlow = (val); } STMT_END
147#define PARENT_FAKELEX_FLAGS_set(sv,val) \
148 STMT_START { ((XPVNV*)SvANY(sv))->xnv_u.xpad_cop_seq.xhigh = (val); } STMT_END
dd2155a4 149
cc76b5cc
Z
150/*
151=for apidoc mx|void|pad_peg|const char *s
152
153When PERL_MAD is enabled, this is a small no-op function that gets called
154at the start of each pad-related function. It can be breakpointed to
155track all pad operations. The parameter is a string indicating the type
156of pad operation being performed.
157
158=cut
159*/
160
1dba731d
NC
161#ifdef PERL_MAD
162void pad_peg(const char* s) {
790427a5
DM
163 static int pegcnt; /* XXX not threadsafe */
164 PERL_UNUSED_ARG(s);
7918f24d
NC
165
166 PERL_ARGS_ASSERT_PAD_PEG;
167
1dba731d
NC
168 pegcnt++;
169}
170#endif
dd2155a4
DM
171
172/*
5b16296c
BF
173This is basically sv_eq_flags() in sv.c, but we avoid the magic
174and bytes checking.
175*/
176
76d60a53
NC
177static bool
178sv_eq_pvn_flags(pTHX_ const SV *sv, const char* pv, const STRLEN pvlen, const U32 flags) {
5b16296c
BF
179 if ( (SvUTF8(sv) & SVf_UTF8 ) != (flags & SVf_UTF8) ) {
180 const char *pv1 = SvPVX_const(sv);
181 STRLEN cur1 = SvCUR(sv);
182 const char *pv2 = pv;
183 STRLEN cur2 = pvlen;
184 if (PL_encoding) {
185 SV* svrecode = NULL;
186 if (SvUTF8(sv)) {
187 svrecode = newSVpvn(pv2, cur2);
188 sv_recode_to_utf8(svrecode, PL_encoding);
189 pv2 = SvPV_const(svrecode, cur2);
190 }
191 else {
192 svrecode = newSVpvn(pv1, cur1);
193 sv_recode_to_utf8(svrecode, PL_encoding);
194 pv1 = SvPV_const(svrecode, cur1);
195 }
196 SvREFCNT_dec(svrecode);
197 }
198 if (flags & SVf_UTF8)
199 return (bytes_cmp_utf8(
200 (const U8*)pv1, cur1,
201 (const U8*)pv2, cur2) == 0);
202 else
203 return (bytes_cmp_utf8(
204 (const U8*)pv2, cur2,
205 (const U8*)pv1, cur1) == 0);
206 }
207 else
208 return ((SvPVX_const(sv) == pv)
209 || memEQ(SvPVX_const(sv), pv, pvlen));
210}
211
212
213/*
cc76b5cc 214=for apidoc Am|PADLIST *|pad_new|int flags
dd2155a4 215
cc76b5cc
Z
216Create a new padlist, updating the global variables for the
217currently-compiling padlist to point to the new padlist. The following
218flags can be OR'ed together:
dd2155a4
DM
219
220 padnew_CLONE this pad is for a cloned CV
cc76b5cc 221 padnew_SAVE save old globals on the save stack
dd2155a4
DM
222 padnew_SAVESUB also save extra stuff for start of sub
223
224=cut
225*/
226
227PADLIST *
c7c737cb 228Perl_pad_new(pTHX_ int flags)
dd2155a4 229{
97aff369 230 dVAR;
e1ec3a88 231 AV *padlist, *padname, *pad;
7a6072a8 232 SV **ary;
dd2155a4 233
f3548bdc
DM
234 ASSERT_CURPAD_LEGAL("pad_new");
235
dd2155a4
DM
236 /* XXX DAPM really need a new SAVEt_PAD which restores all or most
237 * vars (based on flags) rather than storing vals + addresses for
238 * each individually. Also see pad_block_start.
239 * XXX DAPM Try to see whether all these conditionals are required
240 */
241
242 /* save existing state, ... */
243
244 if (flags & padnew_SAVE) {
3979c56f 245 SAVECOMPPAD();
dd2155a4
DM
246 SAVESPTR(PL_comppad_name);
247 if (! (flags & padnew_CLONE)) {
248 SAVEI32(PL_padix);
249 SAVEI32(PL_comppad_name_fill);
250 SAVEI32(PL_min_intro_pending);
251 SAVEI32(PL_max_intro_pending);
8bbe96d7 252 SAVEBOOL(PL_cv_has_eval);
dd2155a4 253 if (flags & padnew_SAVESUB) {
f0cb02e3 254 SAVEBOOL(PL_pad_reset_pending);
dd2155a4
DM
255 }
256 }
257 }
258 /* XXX DAPM interestingly, PL_comppad_name_floor never seems to be
259 * saved - check at some pt that this is okay */
260
261 /* ... create new pad ... */
262
263 padlist = newAV();
264 padname = newAV();
265 pad = newAV();
266
267 if (flags & padnew_CLONE) {
268 /* XXX DAPM I dont know why cv_clone needs it
269 * doing differently yet - perhaps this separate branch can be
270 * dispensed with eventually ???
271 */
272
e1ec3a88 273 AV * const a0 = newAV(); /* will be @_ */
ad64d0ec 274 av_store(pad, 0, MUTABLE_SV(a0));
11ca45c0 275 AvREIFY_only(a0);
dd2155a4
DM
276 }
277 else {
a0714e2c 278 av_store(pad, 0, NULL);
dd2155a4
DM
279 }
280
7a6072a8
NC
281 /* Most subroutines never recurse, hence only need 2 entries in the padlist
282 array - names, and depth=1. The default for av_store() is to allocate
283 0..3, and even an explicit call to av_extend() with <3 will be rounded
284 up, so we inline the allocation of the array here. */
285 Newx(ary, 2, SV*);
286 AvFILLp(padlist) = 1;
287 AvMAX(padlist) = 1;
288 AvALLOC(padlist) = ary;
289 AvARRAY(padlist) = ary;
290 ary[0] = MUTABLE_SV(padname);
291 ary[1] = MUTABLE_SV(pad);
dd2155a4
DM
292
293 /* ... then update state variables */
294
403799bf
NC
295 PL_comppad_name = padname;
296 PL_comppad = pad;
297 PL_curpad = AvARRAY(pad);
dd2155a4
DM
298
299 if (! (flags & padnew_CLONE)) {
300 PL_comppad_name_fill = 0;
301 PL_min_intro_pending = 0;
302 PL_padix = 0;
b5c19bd7 303 PL_cv_has_eval = 0;
dd2155a4
DM
304 }
305
306 DEBUG_X(PerlIO_printf(Perl_debug_log,
b5c19bd7 307 "Pad 0x%"UVxf"[0x%"UVxf"] new: compcv=0x%"UVxf
dd2155a4 308 " name=0x%"UVxf" flags=0x%"UVxf"\n",
b5c19bd7 309 PTR2UV(PL_comppad), PTR2UV(PL_curpad), PTR2UV(PL_compcv),
dd2155a4
DM
310 PTR2UV(padname), (UV)flags
311 )
312 );
313
314 return (PADLIST*)padlist;
315}
316
dd2155a4 317
c4528262
NC
318/*
319=head1 Embedding Functions
320
321=for apidoc cv_undef
322
323Clear out all the active components of a CV. This can happen either
324by an explicit C<undef &foo>, or by the reference count going to zero.
325In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
326children can still follow the full lexical scope chain.
327
328=cut
329*/
330
331void
332Perl_cv_undef(pTHX_ CV *cv)
333{
334 dVAR;
c2736fce 335 const PADLIST *padlist = CvPADLIST(cv);
c4528262
NC
336
337 PERL_ARGS_ASSERT_CV_UNDEF;
338
339 DEBUG_X(PerlIO_printf(Perl_debug_log,
340 "CV undef: cv=0x%"UVxf" comppad=0x%"UVxf"\n",
341 PTR2UV(cv), PTR2UV(PL_comppad))
342 );
343
bad4ae38 344 if (CvFILE(cv) && CvDYNFILE(cv)) {
c4528262
NC
345 Safefree(CvFILE(cv));
346 }
347 CvFILE(cv) = NULL;
dd2155a4 348
c4528262
NC
349 if (!CvISXSUB(cv) && CvROOT(cv)) {
350 if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
351 Perl_croak(aTHX_ "Can't undef active subroutine");
352 ENTER;
353
354 PAD_SAVE_SETNULLPAD();
355
356 op_free(CvROOT(cv));
357 CvROOT(cv) = NULL;
358 CvSTART(cv) = NULL;
359 LEAVE;
360 }
361 SvPOK_off(MUTABLE_SV(cv)); /* forget prototype */
362 CvGV_set(cv, NULL);
363
c2736fce
NC
364 /* This statement and the subsequence if block was pad_undef(). */
365 pad_peg("pad_undef");
366
367 if (padlist && !SvIS_FREED(padlist) /* may be during global destruction */
368 ) {
369 I32 ix;
370
371 /* Free the padlist associated with a CV.
372 If parts of it happen to be current, we null the relevant PL_*pad*
373 global vars so that we don't have any dangling references left.
374 We also repoint the CvOUTSIDE of any about-to-be-orphaned inner
375 subs to the outer of this cv. */
376
377 DEBUG_X(PerlIO_printf(Perl_debug_log,
378 "Pad undef: cv=0x%"UVxf" padlist=0x%"UVxf" comppad=0x%"UVxf"\n",
379 PTR2UV(cv), PTR2UV(padlist), PTR2UV(PL_comppad))
380 );
381
382 /* detach any '&' anon children in the pad; if afterwards they
383 * are still live, fix up their CvOUTSIDEs to point to our outside,
384 * bypassing us. */
385 /* XXX DAPM for efficiency, we should only do this if we know we have
386 * children, or integrate this loop with general cleanup */
387
388 if (PL_phase != PERL_PHASE_DESTRUCT) { /* don't bother during global destruction */
389 CV * const outercv = CvOUTSIDE(cv);
390 const U32 seq = CvOUTSIDE_SEQ(cv);
391 AV * const comppad_name = MUTABLE_AV(AvARRAY(padlist)[0]);
392 SV ** const namepad = AvARRAY(comppad_name);
393 AV * const comppad = MUTABLE_AV(AvARRAY(padlist)[1]);
394 SV ** const curpad = AvARRAY(comppad);
395 for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
396 SV * const namesv = namepad[ix];
397 if (namesv && namesv != &PL_sv_undef
398 && *SvPVX_const(namesv) == '&')
399 {
400 CV * const innercv = MUTABLE_CV(curpad[ix]);
401 U32 inner_rc = SvREFCNT(innercv);
402 assert(inner_rc);
e09ac076 403 assert(SvTYPE(innercv) != SVt_PVFM);
c2736fce
NC
404 namepad[ix] = NULL;
405 SvREFCNT_dec(namesv);
406
407 if (SvREFCNT(comppad) < 2) { /* allow for /(?{ sub{} })/ */
408 curpad[ix] = NULL;
409 SvREFCNT_dec(innercv);
410 inner_rc--;
411 }
412
413 /* in use, not just a prototype */
414 if (inner_rc && (CvOUTSIDE(innercv) == cv)) {
415 assert(CvWEAKOUTSIDE(innercv));
416 /* don't relink to grandfather if he's being freed */
417 if (outercv && SvREFCNT(outercv)) {
418 CvWEAKOUTSIDE_off(innercv);
419 CvOUTSIDE(innercv) = outercv;
420 CvOUTSIDE_SEQ(innercv) = seq;
421 SvREFCNT_inc_simple_void_NN(outercv);
422 }
423 else {
424 CvOUTSIDE(innercv) = NULL;
425 }
426 }
427 }
428 }
429 }
430
431 ix = AvFILLp(padlist);
aa2f79cf 432 while (ix > 0) {
c2736fce
NC
433 SV* const sv = AvARRAY(padlist)[ix--];
434 if (sv) {
aa2f79cf 435 if (sv == (const SV *)PL_comppad) {
c2736fce
NC
436 PL_comppad = NULL;
437 PL_curpad = NULL;
438 }
aa2f79cf 439 SvREFCNT_dec(sv);
c2736fce 440 }
aa2f79cf
NC
441 }
442 {
443 SV *const sv = AvARRAY(padlist)[0];
444 if (sv == (const SV *)PL_comppad_name)
445 PL_comppad_name = NULL;
c2736fce
NC
446 SvREFCNT_dec(sv);
447 }
7d953ba8 448 AvREAL_off(CvPADLIST(cv));
c2736fce
NC
449 SvREFCNT_dec(MUTABLE_SV(CvPADLIST(cv)));
450 CvPADLIST(cv) = NULL;
451 }
452
c4528262
NC
453
454 /* remove CvOUTSIDE unless this is an undef rather than a free */
455 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
456 if (!CvWEAKOUTSIDE(cv))
457 SvREFCNT_dec(CvOUTSIDE(cv));
458 CvOUTSIDE(cv) = NULL;
459 }
460 if (CvCONST(cv)) {
461 SvREFCNT_dec(MUTABLE_SV(CvXSUBANY(cv).any_ptr));
462 CvCONST_off(cv);
463 }
464 if (CvISXSUB(cv) && CvXSUB(cv)) {
465 CvXSUB(cv) = NULL;
466 }
467 /* delete all flags except WEAKOUTSIDE and CVGV_RC, which indicate the
2c374370
FC
468 * ref status of CvOUTSIDE and CvGV, and ANON, which pp_entersub uses
469 * to choose an error message */
470 CvFLAGS(cv) &= (CVf_WEAKOUTSIDE|CVf_CVGV_RC|CVf_ANON);
c4528262 471}
dd2155a4 472
cc76b5cc
Z
473/*
474=for apidoc m|PADOFFSET|pad_alloc_name|SV *namesv|U32 flags|HV *typestash|HV *ourstash
475
1a115e49
FC
476Allocates a place in the currently-compiling
477pad (via L<perlapi/pad_alloc>) and
cc76b5cc
Z
478then stores a name for that entry. I<namesv> is adopted and becomes the
479name entry; it must already contain the name string and be sufficiently
480upgraded. I<typestash> and I<ourstash> and the C<padadd_STATE> flag get
1a115e49
FC
481added to I<namesv>. None of the other
482processing of L<perlapi/pad_add_name_pvn>
cc76b5cc
Z
483is done. Returns the offset of the allocated pad slot.
484
485=cut
486*/
487
3291825f 488static PADOFFSET
cc76b5cc 489S_pad_alloc_name(pTHX_ SV *namesv, U32 flags, HV *typestash, HV *ourstash)
3291825f
NC
490{
491 dVAR;
492 const PADOFFSET offset = pad_alloc(OP_PADSV, SVs_PADMY);
493
cc76b5cc 494 PERL_ARGS_ASSERT_PAD_ALLOC_NAME;
3291825f 495
cc76b5cc 496 ASSERT_CURPAD_ACTIVE("pad_alloc_name");
3291825f
NC
497
498 if (typestash) {
499 assert(SvTYPE(namesv) == SVt_PVMG);
500 SvPAD_TYPED_on(namesv);
501 SvSTASH_set(namesv, MUTABLE_HV(SvREFCNT_inc_simple_NN(MUTABLE_SV(typestash))));
502 }
503 if (ourstash) {
504 SvPAD_OUR_on(namesv);
505 SvOURSTASH_set(namesv, ourstash);
506 SvREFCNT_inc_simple_void_NN(ourstash);
507 }
59cfed7d 508 else if (flags & padadd_STATE) {
3291825f
NC
509 SvPAD_STATE_on(namesv);
510 }
511
512 av_store(PL_comppad_name, offset, namesv);
513 return offset;
514}
515
dd2155a4 516/*
cc76b5cc 517=for apidoc Am|PADOFFSET|pad_add_name_pvn|const char *namepv|STRLEN namelen|U32 flags|HV *typestash|HV *ourstash
dd2155a4 518
cc76b5cc
Z
519Allocates a place in the currently-compiling pad for a named lexical
520variable. Stores the name and other metadata in the name part of the
521pad, and makes preparations to manage the variable's lexical scoping.
522Returns the offset of the allocated pad slot.
dd2155a4 523
cc76b5cc
Z
524I<namepv>/I<namelen> specify the variable's name, including leading sigil.
525If I<typestash> is non-null, the name is for a typed lexical, and this
526identifies the type. If I<ourstash> is non-null, it's a lexical reference
527to a package variable, and this identifies the package. The following
528flags can be OR'ed together:
529
530 padadd_OUR redundantly specifies if it's a package var
531 padadd_STATE variable will retain value persistently
532 padadd_NO_DUP_CHECK skip check for lexical shadowing
dd2155a4
DM
533
534=cut
535*/
536
dd2155a4 537PADOFFSET
cc76b5cc
Z
538Perl_pad_add_name_pvn(pTHX_ const char *namepv, STRLEN namelen,
539 U32 flags, HV *typestash, HV *ourstash)
dd2155a4 540{
97aff369 541 dVAR;
3291825f 542 PADOFFSET offset;
cca43f78 543 SV *namesv;
e8b34487 544 bool is_utf8;
dd2155a4 545
cc76b5cc 546 PERL_ARGS_ASSERT_PAD_ADD_NAME_PVN;
7918f24d 547
2435e5d3 548 if (flags & ~(padadd_OUR|padadd_STATE|padadd_NO_DUP_CHECK|padadd_UTF8_NAME))
cc76b5cc 549 Perl_croak(aTHX_ "panic: pad_add_name_pvn illegal flag bits 0x%" UVxf,
cca43f78
NC
550 (UV)flags);
551
552 namesv = newSV_type((ourstash || typestash) ? SVt_PVMG : SVt_PVNV);
e8b34487
BF
553
554 if ((is_utf8 = ((flags & padadd_UTF8_NAME) != 0))) {
555 namepv = (const char*)bytes_from_utf8((U8*)namepv, &namelen, &is_utf8);
556 }
557
0727928e
BF
558 sv_setpvn(namesv, namepv, namelen);
559
e8b34487
BF
560 if (is_utf8) {
561 flags |= padadd_UTF8_NAME;
562 SvUTF8_on(namesv);
563 }
564 else
565 flags &= ~padadd_UTF8_NAME;
dd2155a4 566
59cfed7d 567 if ((flags & padadd_NO_DUP_CHECK) == 0) {
2d12d04f 568 /* check for duplicate declaration */
59cfed7d 569 pad_check_dup(namesv, flags & padadd_OUR, ourstash);
2d12d04f
NC
570 }
571
2435e5d3 572 offset = pad_alloc_name(namesv, flags & ~padadd_UTF8_NAME, typestash, ourstash);
3291825f
NC
573
574 /* not yet introduced */
2df5bdd7
DM
575 COP_SEQ_RANGE_LOW_set(namesv, PERL_PADSEQ_INTRO);
576 COP_SEQ_RANGE_HIGH_set(namesv, 0);
3291825f
NC
577
578 if (!PL_min_intro_pending)
579 PL_min_intro_pending = offset;
580 PL_max_intro_pending = offset;
581 /* if it's not a simple scalar, replace with an AV or HV */
c1bf42f3
NC
582 assert(SvTYPE(PL_curpad[offset]) == SVt_NULL);
583 assert(SvREFCNT(PL_curpad[offset]) == 1);
cc76b5cc 584 if (namelen != 0 && *namepv == '@')
c1bf42f3 585 sv_upgrade(PL_curpad[offset], SVt_PVAV);
cc76b5cc 586 else if (namelen != 0 && *namepv == '%')
c1bf42f3
NC
587 sv_upgrade(PL_curpad[offset], SVt_PVHV);
588 assert(SvPADMY(PL_curpad[offset]));
3291825f
NC
589 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
590 "Pad addname: %ld \"%s\" new lex=0x%"UVxf"\n",
cc76b5cc
Z
591 (long)offset, SvPVX(namesv),
592 PTR2UV(PL_curpad[offset])));
dd2155a4
DM
593
594 return offset;
595}
596
cc76b5cc
Z
597/*
598=for apidoc Am|PADOFFSET|pad_add_name_pv|const char *name|U32 flags|HV *typestash|HV *ourstash
dd2155a4 599
cc76b5cc
Z
600Exactly like L</pad_add_name_pvn>, but takes a nul-terminated string
601instead of a string/length pair.
dd2155a4 602
cc76b5cc
Z
603=cut
604*/
605
606PADOFFSET
607Perl_pad_add_name_pv(pTHX_ const char *name,
0e1b3a4b 608 const U32 flags, HV *typestash, HV *ourstash)
cc76b5cc
Z
609{
610 PERL_ARGS_ASSERT_PAD_ADD_NAME_PV;
611 return pad_add_name_pvn(name, strlen(name), flags, typestash, ourstash);
612}
dd2155a4
DM
613
614/*
cc76b5cc 615=for apidoc Am|PADOFFSET|pad_add_name_sv|SV *name|U32 flags|HV *typestash|HV *ourstash
dd2155a4 616
cc76b5cc
Z
617Exactly like L</pad_add_name_pvn>, but takes the name string in the form
618of an SV instead of a string/length pair.
619
620=cut
621*/
622
623PADOFFSET
624Perl_pad_add_name_sv(pTHX_ SV *name, U32 flags, HV *typestash, HV *ourstash)
625{
626 char *namepv;
627 STRLEN namelen;
628 PERL_ARGS_ASSERT_PAD_ADD_NAME_SV;
629 namepv = SvPV(name, namelen);
e8b34487
BF
630 if (SvUTF8(name))
631 flags |= padadd_UTF8_NAME;
cc76b5cc
Z
632 return pad_add_name_pvn(namepv, namelen, flags, typestash, ourstash);
633}
634
635/*
636=for apidoc Amx|PADOFFSET|pad_alloc|I32 optype|U32 tmptype
637
638Allocates a place in the currently-compiling pad,
639returning the offset of the allocated pad slot.
640No name is initially attached to the pad slot.
641I<tmptype> is a set of flags indicating the kind of pad entry required,
642which will be set in the value SV for the allocated pad entry:
643
644 SVs_PADMY named lexical variable ("my", "our", "state")
645 SVs_PADTMP unnamed temporary store
646
647I<optype> should be an opcode indicating the type of operation that the
648pad entry is to support. This doesn't affect operational semantics,
649but is used for debugging.
dd2155a4
DM
650
651=cut
652*/
653
654/* XXX DAPM integrate alloc(), add_name() and add_anon(),
655 * or at least rationalise ??? */
dd2155a4
DM
656
657PADOFFSET
658Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype)
659{
97aff369 660 dVAR;
dd2155a4
DM
661 SV *sv;
662 I32 retval;
663
6136c704 664 PERL_UNUSED_ARG(optype);
f3548bdc
DM
665 ASSERT_CURPAD_ACTIVE("pad_alloc");
666
dd2155a4 667 if (AvARRAY(PL_comppad) != PL_curpad)
5637ef5b
NC
668 Perl_croak(aTHX_ "panic: pad_alloc, %p!=%p",
669 AvARRAY(PL_comppad), PL_curpad);
dd2155a4
DM
670 if (PL_pad_reset_pending)
671 pad_reset();
672 if (tmptype & SVs_PADMY) {
cc76b5cc 673 /* For a my, simply push a null SV onto the end of PL_comppad. */
235cc2e3 674 sv = *av_fetch(PL_comppad, AvFILLp(PL_comppad) + 1, TRUE);
dd2155a4
DM
675 retval = AvFILLp(PL_comppad);
676 }
677 else {
cc76b5cc
Z
678 /* For a tmp, scan the pad from PL_padix upwards
679 * for a slot which has no name and no active value.
680 */
551405c4 681 SV * const * const names = AvARRAY(PL_comppad_name);
e1ec3a88 682 const SSize_t names_fill = AvFILLp(PL_comppad_name);
dd2155a4
DM
683 for (;;) {
684 /*
685 * "foreach" index vars temporarily become aliases to non-"my"
686 * values. Thus we must skip, not just pad values that are
687 * marked as current pad values, but also those with names.
688 */
689 /* HVDS why copy to sv here? we don't seem to use it */
690 if (++PL_padix <= names_fill &&
691 (sv = names[PL_padix]) && sv != &PL_sv_undef)
692 continue;
693 sv = *av_fetch(PL_comppad, PL_padix, TRUE);
694 if (!(SvFLAGS(sv) & (SVs_PADTMP | SVs_PADMY)) &&
695 !IS_PADGV(sv) && !IS_PADCONST(sv))
696 break;
697 }
698 retval = PL_padix;
699 }
700 SvFLAGS(sv) |= tmptype;
701 PL_curpad = AvARRAY(PL_comppad);
702
703 DEBUG_X(PerlIO_printf(Perl_debug_log,
704 "Pad 0x%"UVxf"[0x%"UVxf"] alloc: %ld for %s\n",
705 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long) retval,
706 PL_op_name[optype]));
fd0854ff
DM
707#ifdef DEBUG_LEAKING_SCALARS
708 sv->sv_debug_optype = optype;
709 sv->sv_debug_inpad = 1;
fd0854ff 710#endif
a212c8b5 711 return (PADOFFSET)retval;
dd2155a4
DM
712}
713
714/*
cc76b5cc 715=for apidoc Am|PADOFFSET|pad_add_anon|CV *func|I32 optype
dd2155a4 716
cc76b5cc
Z
717Allocates a place in the currently-compiling pad (via L</pad_alloc>)
718for an anonymous function that is lexically scoped inside the
719currently-compiling function.
720The function I<func> is linked into the pad, and its C<CvOUTSIDE> link
721to the outer scope is weakened to avoid a reference loop.
722
723I<optype> should be an opcode indicating the type of operation that the
724pad entry is to support. This doesn't affect operational semantics,
725but is used for debugging.
dd2155a4
DM
726
727=cut
728*/
729
730PADOFFSET
cc76b5cc 731Perl_pad_add_anon(pTHX_ CV* func, I32 optype)
dd2155a4 732{
97aff369 733 dVAR;
dd2155a4 734 PADOFFSET ix;
b9f83d2f 735 SV* const name = newSV_type(SVt_PVNV);
7918f24d
NC
736
737 PERL_ARGS_ASSERT_PAD_ADD_ANON;
738
1dba731d 739 pad_peg("add_anon");
76f68e9b 740 sv_setpvs(name, "&");
0d311cdb
DM
741 /* These two aren't used; just make sure they're not equal to
742 * PERL_PADSEQ_INTRO */
743 COP_SEQ_RANGE_LOW_set(name, 0);
744 COP_SEQ_RANGE_HIGH_set(name, 0);
cc76b5cc 745 ix = pad_alloc(optype, SVs_PADMY);
dd2155a4 746 av_store(PL_comppad_name, ix, name);
f3548bdc 747 /* XXX DAPM use PL_curpad[] ? */
e09ac076
FC
748 if (SvTYPE(func) == SVt_PVCV || !CvOUTSIDE(func))
749 av_store(PL_comppad, ix, (SV*)func);
750 else {
751 SV *rv = newRV_inc((SV *)func);
752 sv_rvweaken(rv);
753 assert (SvTYPE(func) == SVt_PVFM);
754 av_store(PL_comppad, ix, rv);
755 }
cc76b5cc 756 SvPADMY_on((SV*)func);
7dafbf52
DM
757
758 /* to avoid ref loops, we never have parent + child referencing each
759 * other simultaneously */
e09ac076 760 if (CvOUTSIDE(func) && SvTYPE(func) == SVt_PVCV) {
cc76b5cc
Z
761 assert(!CvWEAKOUTSIDE(func));
762 CvWEAKOUTSIDE_on(func);
763 SvREFCNT_dec(CvOUTSIDE(func));
7dafbf52 764 }
dd2155a4
DM
765 return ix;
766}
767
dd2155a4 768/*
13087dd8 769=for apidoc pad_check_dup
dd2155a4
DM
770
771Check for duplicate declarations: report any of:
13087dd8 772
dd2155a4 773 * a my in the current scope with the same name;
13087dd8
FC
774 * an our (anywhere in the pad) with the same name and the
775 same stash as C<ourstash>
776
777C<is_our> indicates that the name to check is an 'our' declaration.
dd2155a4
DM
778
779=cut
780*/
781
20381b50 782STATIC void
cc76b5cc 783S_pad_check_dup(pTHX_ SV *name, U32 flags, const HV *ourstash)
dd2155a4 784{
97aff369 785 dVAR;
53c1dcc0 786 SV **svp;
dd2155a4 787 PADOFFSET top, off;
59cfed7d 788 const U32 is_our = flags & padadd_OUR;
dd2155a4 789
7918f24d
NC
790 PERL_ARGS_ASSERT_PAD_CHECK_DUP;
791
f3548bdc 792 ASSERT_CURPAD_ACTIVE("pad_check_dup");
35f82371 793
59cfed7d 794 assert((flags & ~padadd_OUR) == 0);
35f82371 795
041457d9 796 if (AvFILLp(PL_comppad_name) < 0 || !ckWARN(WARN_MISC))
dd2155a4
DM
797 return; /* nothing to check */
798
799 svp = AvARRAY(PL_comppad_name);
800 top = AvFILLp(PL_comppad_name);
801 /* check the current scope */
802 /* XXX DAPM - why the (I32) cast - shouldn't we ensure they're the same
803 * type ? */
804 for (off = top; (I32)off > PL_comppad_name_floor; off--) {
53c1dcc0
AL
805 SV * const sv = svp[off];
806 if (sv
dd2155a4 807 && sv != &PL_sv_undef
ee6cee0c 808 && !SvFAKE(sv)
0d311cdb
DM
809 && ( COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO
810 || COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO)
2d12d04f 811 && sv_eq(name, sv))
dd2155a4 812 {
00b1698f 813 if (is_our && (SvPAD_OUR(sv)))
7f73a9f1 814 break; /* "our" masking "our" */
dd2155a4 815 Perl_warner(aTHX_ packWARN(WARN_MISC),
c541b9b4 816 "\"%s\" variable %"SVf" masks earlier declaration in same %s",
12bd6ede 817 (is_our ? "our" : PL_parser->in_my == KEY_my ? "my" : "state"),
c541b9b4 818 sv,
2df5bdd7
DM
819 (COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO
820 ? "scope" : "statement"));
dd2155a4
DM
821 --off;
822 break;
823 }
824 }
825 /* check the rest of the pad */
826 if (is_our) {
61c5492a 827 while (off > 0) {
53c1dcc0
AL
828 SV * const sv = svp[off];
829 if (sv
dd2155a4 830 && sv != &PL_sv_undef
ee6cee0c 831 && !SvFAKE(sv)
0d311cdb
DM
832 && ( COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO
833 || COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO)
73d95100 834 && SvOURSTASH(sv) == ourstash
2d12d04f 835 && sv_eq(name, sv))
dd2155a4
DM
836 {
837 Perl_warner(aTHX_ packWARN(WARN_MISC),
c541b9b4 838 "\"our\" variable %"SVf" redeclared", sv);
624f69f5 839 if ((I32)off <= PL_comppad_name_floor)
7f73a9f1
RGS
840 Perl_warner(aTHX_ packWARN(WARN_MISC),
841 "\t(Did you mean \"local\" instead of \"our\"?)\n");
dd2155a4
DM
842 break;
843 }
61c5492a
NC
844 --off;
845 }
dd2155a4
DM
846 }
847}
848
849
dd2155a4 850/*
cc76b5cc 851=for apidoc Am|PADOFFSET|pad_findmy_pvn|const char *namepv|STRLEN namelen|U32 flags
dd2155a4 852
cc76b5cc
Z
853Given the name of a lexical variable, find its position in the
854currently-compiling pad.
855I<namepv>/I<namelen> specify the variable's name, including leading sigil.
856I<flags> is reserved and must be zero.
857If it is not in the current pad but appears in the pad of any lexically
858enclosing scope, then a pseudo-entry for it is added in the current pad.
859Returns the offset in the current pad,
860or C<NOT_IN_PAD> if no such lexical is in scope.
dd2155a4
DM
861
862=cut
863*/
864
865PADOFFSET
cc76b5cc 866Perl_pad_findmy_pvn(pTHX_ const char *namepv, STRLEN namelen, U32 flags)
dd2155a4 867{
97aff369 868 dVAR;
b5c19bd7
DM
869 SV *out_sv;
870 int out_flags;
929a0744 871 I32 offset;
e1ec3a88 872 const AV *nameav;
929a0744 873 SV **name_svp;
dd2155a4 874
cc76b5cc 875 PERL_ARGS_ASSERT_PAD_FINDMY_PVN;
7918f24d 876
cc76b5cc 877 pad_peg("pad_findmy_pvn");
f8f98e0a 878
2435e5d3 879 if (flags & ~padadd_UTF8_NAME)
cc76b5cc 880 Perl_croak(aTHX_ "panic: pad_findmy_pvn illegal flag bits 0x%" UVxf,
f8f98e0a
NC
881 (UV)flags);
882
e8b34487
BF
883 if (flags & padadd_UTF8_NAME) {
884 bool is_utf8 = TRUE;
885 namepv = (const char*)bytes_from_utf8((U8*)namepv, &namelen, &is_utf8);
886
887 if (is_utf8)
888 flags |= padadd_UTF8_NAME;
889 else
890 flags &= ~padadd_UTF8_NAME;
891 }
892
fbb889c8
BF
893 offset = pad_findlex(namepv, namelen, flags,
894 PL_compcv, PL_cop_seqmax, 1, NULL, &out_sv, &out_flags);
9f7d9405 895 if ((PADOFFSET)offset != NOT_IN_PAD)
929a0744
DM
896 return offset;
897
898 /* look for an our that's being introduced; this allows
899 * our $foo = 0 unless defined $foo;
900 * to not give a warning. (Yes, this is a hack) */
901
502c6561 902 nameav = MUTABLE_AV(AvARRAY(CvPADLIST(PL_compcv))[0]);
929a0744
DM
903 name_svp = AvARRAY(nameav);
904 for (offset = AvFILLp(nameav); offset > 0; offset--) {
551405c4 905 const SV * const namesv = name_svp[offset];
929a0744
DM
906 if (namesv && namesv != &PL_sv_undef
907 && !SvFAKE(namesv)
00b1698f 908 && (SvPAD_OUR(namesv))
cc76b5cc 909 && SvCUR(namesv) == namelen
e8b34487
BF
910 && sv_eq_pvn_flags(aTHX_ namesv, namepv, namelen,
911 flags & padadd_UTF8_NAME ? SVf_UTF8 : 0 )
2df5bdd7 912 && COP_SEQ_RANGE_LOW(namesv) == PERL_PADSEQ_INTRO
929a0744
DM
913 )
914 return offset;
915 }
916 return NOT_IN_PAD;
dd2155a4
DM
917}
918
e1f795dc 919/*
cc76b5cc
Z
920=for apidoc Am|PADOFFSET|pad_findmy_pv|const char *name|U32 flags
921
922Exactly like L</pad_findmy_pvn>, but takes a nul-terminated string
923instead of a string/length pair.
924
925=cut
926*/
927
928PADOFFSET
929Perl_pad_findmy_pv(pTHX_ const char *name, U32 flags)
930{
931 PERL_ARGS_ASSERT_PAD_FINDMY_PV;
932 return pad_findmy_pvn(name, strlen(name), flags);
933}
934
935/*
936=for apidoc Am|PADOFFSET|pad_findmy_sv|SV *name|U32 flags
937
938Exactly like L</pad_findmy_pvn>, but takes the name string in the form
939of an SV instead of a string/length pair.
940
941=cut
942*/
943
944PADOFFSET
945Perl_pad_findmy_sv(pTHX_ SV *name, U32 flags)
946{
947 char *namepv;
948 STRLEN namelen;
949 PERL_ARGS_ASSERT_PAD_FINDMY_SV;
950 namepv = SvPV(name, namelen);
2435e5d3
BF
951 if (SvUTF8(name))
952 flags |= padadd_UTF8_NAME;
cc76b5cc
Z
953 return pad_findmy_pvn(namepv, namelen, flags);
954}
955
956/*
957=for apidoc Amp|PADOFFSET|find_rundefsvoffset
958
959Find the position of the lexical C<$_> in the pad of the
960currently-executing function. Returns the offset in the current pad,
961or C<NOT_IN_PAD> if there is no lexical C<$_> in scope (in which case
962the global one should be used instead).
963L</find_rundefsv> is likely to be more convenient.
964
965=cut
966*/
e1f795dc
RGS
967
968PADOFFSET
29289021 969Perl_find_rundefsvoffset(pTHX)
e1f795dc 970{
97aff369 971 dVAR;
e1f795dc
RGS
972 SV *out_sv;
973 int out_flags;
fbb889c8 974 return pad_findlex("$_", 2, 0, find_runcv(NULL), PL_curcop->cop_seq, 1,
4608196e 975 NULL, &out_sv, &out_flags);
e1f795dc 976}
dd2155a4 977
dd2155a4 978/*
cc76b5cc
Z
979=for apidoc Am|SV *|find_rundefsv
980
981Find and return the variable that is named C<$_> in the lexical scope
982of the currently-executing function. This may be a lexical C<$_>,
983or will otherwise be the global one.
984
985=cut
986*/
789bd863
VP
987
988SV *
989Perl_find_rundefsv(pTHX)
990{
991 SV *namesv;
992 int flags;
993 PADOFFSET po;
994
fbb889c8 995 po = pad_findlex("$_", 2, 0, find_runcv(NULL), PL_curcop->cop_seq, 1,
789bd863
VP
996 NULL, &namesv, &flags);
997
1979170b 998 if (po == NOT_IN_PAD || SvPAD_OUR(namesv))
789bd863
VP
999 return DEFSV;
1000
1001 return PAD_SVl(po);
1002}
1003
c086f97a
FC
1004SV *
1005Perl_find_rundefsv2(pTHX_ CV *cv, U32 seq)
1006{
1007 SV *namesv;
1008 int flags;
1009 PADOFFSET po;
1010
1011 PERL_ARGS_ASSERT_FIND_RUNDEFSV2;
1012
1013 po = pad_findlex("$_", 2, 0, cv, seq, 1,
1014 NULL, &namesv, &flags);
1015
1016 if (po == NOT_IN_PAD || SvPAD_OUR(namesv))
1017 return DEFSV;
1018
1019 return AvARRAY((PAD*) (AvARRAY(CvPADLIST(cv))[CvDEPTH(cv)]))[po];
1020}
1021
789bd863 1022/*
fbb889c8 1023=for apidoc m|PADOFFSET|pad_findlex|const char *namepv|STRLEN namelen|U32 flags|const CV* cv|U32 seq|int warn|SV** out_capture|SV** out_name_sv|int *out_flags
dd2155a4
DM
1024
1025Find a named lexical anywhere in a chain of nested pads. Add fake entries
b5c19bd7
DM
1026in the inner pads if it's found in an outer one.
1027
1028Returns the offset in the bottom pad of the lex or the fake lex.
1029cv is the CV in which to start the search, and seq is the current cop_seq
1030to match against. If warn is true, print appropriate warnings. The out_*
1031vars return values, and so are pointers to where the returned values
1032should be stored. out_capture, if non-null, requests that the innermost
1033instance of the lexical is captured; out_name_sv is set to the innermost
1034matched namesv or fake namesv; out_flags returns the flags normally
1035associated with the IVX field of a fake namesv.
1036
1037Note that pad_findlex() is recursive; it recurses up the chain of CVs,
1038then comes back down, adding fake entries as it goes. It has to be this way
3441fb63 1039because fake namesvs in anon protoypes have to store in xlow the index into
b5c19bd7 1040the parent pad.
dd2155a4
DM
1041
1042=cut
1043*/
1044
b5c19bd7
DM
1045/* the CV has finished being compiled. This is not a sufficient test for
1046 * all CVs (eg XSUBs), but suffices for the CVs found in a lexical chain */
1047#define CvCOMPILED(cv) CvROOT(cv)
1048
71f882da
DM
1049/* the CV does late binding of its lexicals */
1050#define CvLATE(cv) (CvANON(cv) || SvTYPE(cv) == SVt_PVFM)
1051
b5c19bd7 1052
dd2155a4 1053STATIC PADOFFSET
fbb889c8 1054S_pad_findlex(pTHX_ const char *namepv, STRLEN namelen, U32 flags, const CV* cv, U32 seq,
cc76b5cc 1055 int warn, SV** out_capture, SV** out_name_sv, int *out_flags)
dd2155a4 1056{
97aff369 1057 dVAR;
b5c19bd7
DM
1058 I32 offset, new_offset;
1059 SV *new_capture;
1060 SV **new_capturep;
b64e5050 1061 const AV * const padlist = CvPADLIST(cv);
dd2155a4 1062
7918f24d
NC
1063 PERL_ARGS_ASSERT_PAD_FINDLEX;
1064
2435e5d3
BF
1065 if (flags & ~padadd_UTF8_NAME)
1066 Perl_croak(aTHX_ "panic: pad_findlex illegal flag bits 0x%" UVxf,
1067 (UV)flags);
1068
b5c19bd7 1069 *out_flags = 0;
a3985cdc 1070
b5c19bd7 1071 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
cc76b5cc 1072 "Pad findlex cv=0x%"UVxf" searching \"%.*s\" seq=%d%s\n",
4c760560 1073 PTR2UV(cv), (int)namelen, namepv, (int)seq,
cc76b5cc 1074 out_capture ? " capturing" : "" ));
dd2155a4 1075
b5c19bd7 1076 /* first, search this pad */
dd2155a4 1077
b5c19bd7
DM
1078 if (padlist) { /* not an undef CV */
1079 I32 fake_offset = 0;
502c6561 1080 const AV * const nameav = MUTABLE_AV(AvARRAY(padlist)[0]);
551405c4 1081 SV * const * const name_svp = AvARRAY(nameav);
ee6cee0c 1082
b5c19bd7 1083 for (offset = AvFILLp(nameav); offset > 0; offset--) {
551405c4 1084 const SV * const namesv = name_svp[offset];
b5c19bd7 1085 if (namesv && namesv != &PL_sv_undef
cc76b5cc 1086 && SvCUR(namesv) == namelen
e8b34487
BF
1087 && sv_eq_pvn_flags(aTHX_ namesv, namepv, namelen,
1088 flags & padadd_UTF8_NAME ? SVf_UTF8 : 0))
b5c19bd7 1089 {
6012dc80 1090 if (SvFAKE(namesv)) {
b5c19bd7 1091 fake_offset = offset; /* in case we don't find a real one */
6012dc80
DM
1092 continue;
1093 }
1094 /* is seq within the range _LOW to _HIGH ?
1095 * This is complicated by the fact that PL_cop_seqmax
1096 * may have wrapped around at some point */
1097 if (COP_SEQ_RANGE_LOW(namesv) == PERL_PADSEQ_INTRO)
1098 continue; /* not yet introduced */
1099
1100 if (COP_SEQ_RANGE_HIGH(namesv) == PERL_PADSEQ_INTRO) {
1101 /* in compiling scope */
1102 if (
1103 (seq > COP_SEQ_RANGE_LOW(namesv))
1104 ? (seq - COP_SEQ_RANGE_LOW(namesv) < (U32_MAX >> 1))
1105 : (COP_SEQ_RANGE_LOW(namesv) - seq > (U32_MAX >> 1))
1106 )
1107 break;
1108 }
1109 else if (
1110 (COP_SEQ_RANGE_LOW(namesv) > COP_SEQ_RANGE_HIGH(namesv))
1111 ?
1112 ( seq > COP_SEQ_RANGE_LOW(namesv)
1113 || seq <= COP_SEQ_RANGE_HIGH(namesv))
1114
1115 : ( seq > COP_SEQ_RANGE_LOW(namesv)
1116 && seq <= COP_SEQ_RANGE_HIGH(namesv))
1117 )
1118 break;
ee6cee0c
DM
1119 }
1120 }
1121
b5c19bd7
DM
1122 if (offset > 0 || fake_offset > 0 ) { /* a match! */
1123 if (offset > 0) { /* not fake */
1124 fake_offset = 0;
1125 *out_name_sv = name_svp[offset]; /* return the namesv */
1126
1127 /* set PAD_FAKELEX_MULTI if this lex can have multiple
1128 * instances. For now, we just test !CvUNIQUE(cv), but
1129 * ideally, we should detect my's declared within loops
1130 * etc - this would allow a wider range of 'not stayed
486ec47a 1131 * shared' warnings. We also treated already-compiled
b5c19bd7
DM
1132 * lexes as not multi as viewed from evals. */
1133
1134 *out_flags = CvANON(cv) ?
1135 PAD_FAKELEX_ANON :
1136 (!CvUNIQUE(cv) && ! CvCOMPILED(cv))
1137 ? PAD_FAKELEX_MULTI : 0;
1138
1139 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
809abb02
NC
1140 "Pad findlex cv=0x%"UVxf" matched: offset=%ld (%lu,%lu)\n",
1141 PTR2UV(cv), (long)offset,
1142 (unsigned long)COP_SEQ_RANGE_LOW(*out_name_sv),
1143 (unsigned long)COP_SEQ_RANGE_HIGH(*out_name_sv)));
b5c19bd7
DM
1144 }
1145 else { /* fake match */
1146 offset = fake_offset;
1147 *out_name_sv = name_svp[offset]; /* return the namesv */
809abb02 1148 *out_flags = PARENT_FAKELEX_FLAGS(*out_name_sv);
b5c19bd7 1149 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
19a5c512 1150 "Pad findlex cv=0x%"UVxf" matched: offset=%ld flags=0x%lx index=%lu\n",
b5c19bd7 1151 PTR2UV(cv), (long)offset, (unsigned long)*out_flags,
809abb02 1152 (unsigned long) PARENT_PAD_INDEX(*out_name_sv)
b5c19bd7
DM
1153 ));
1154 }
dd2155a4 1155
b5c19bd7 1156 /* return the lex? */
dd2155a4 1157
b5c19bd7 1158 if (out_capture) {
dd2155a4 1159
b5c19bd7 1160 /* our ? */
00b1698f 1161 if (SvPAD_OUR(*out_name_sv)) {
a0714e2c 1162 *out_capture = NULL;
b5c19bd7
DM
1163 return offset;
1164 }
ee6cee0c 1165
b5c19bd7
DM
1166 /* trying to capture from an anon prototype? */
1167 if (CvCOMPILED(cv)
1168 ? CvANON(cv) && CvCLONE(cv) && !CvCLONED(cv)
1169 : *out_flags & PAD_FAKELEX_ANON)
1170 {
a2a5de95
NC
1171 if (warn)
1172 Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE),
0727928e
BF
1173 "Variable \"%"SVf"\" is not available",
1174 newSVpvn_flags(namepv, namelen,
1175 SVs_TEMP |
1176 (flags & padadd_UTF8_NAME ? SVf_UTF8 : 0)));
1177
a0714e2c 1178 *out_capture = NULL;
b5c19bd7 1179 }
ee6cee0c 1180
b5c19bd7
DM
1181 /* real value */
1182 else {
1183 int newwarn = warn;
1184 if (!CvCOMPILED(cv) && (*out_flags & PAD_FAKELEX_MULTI)
d1186544 1185 && !SvPAD_STATE(name_svp[offset])
b5c19bd7
DM
1186 && warn && ckWARN(WARN_CLOSURE)) {
1187 newwarn = 0;
1188 Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
0727928e
BF
1189 "Variable \"%"SVf"\" will not stay shared",
1190 newSVpvn_flags(namepv, namelen,
1191 SVs_TEMP |
1192 (flags & padadd_UTF8_NAME ? SVf_UTF8 : 0)));
b5c19bd7 1193 }
dd2155a4 1194
b5c19bd7
DM
1195 if (fake_offset && CvANON(cv)
1196 && CvCLONE(cv) &&!CvCLONED(cv))
1197 {
1198 SV *n;
1199 /* not yet caught - look further up */
1200 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1201 "Pad findlex cv=0x%"UVxf" chasing lex in outer pad\n",
1202 PTR2UV(cv)));
1203 n = *out_name_sv;
fbb889c8 1204 (void) pad_findlex(namepv, namelen, flags, CvOUTSIDE(cv),
282e1742 1205 CvOUTSIDE_SEQ(cv),
b5c19bd7
DM
1206 newwarn, out_capture, out_name_sv, out_flags);
1207 *out_name_sv = n;
1208 return offset;
dd2155a4 1209 }
b5c19bd7 1210
502c6561
NC
1211 *out_capture = AvARRAY(MUTABLE_AV(AvARRAY(padlist)[
1212 CvDEPTH(cv) ? CvDEPTH(cv) : 1]))[offset];
b5c19bd7
DM
1213 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1214 "Pad findlex cv=0x%"UVxf" found lex=0x%"UVxf"\n",
19a5c512 1215 PTR2UV(cv), PTR2UV(*out_capture)));
b5c19bd7 1216
d1186544
DM
1217 if (SvPADSTALE(*out_capture)
1218 && !SvPAD_STATE(name_svp[offset]))
1219 {
a2a5de95 1220 Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE),
0727928e
BF
1221 "Variable \"%"SVf"\" is not available",
1222 newSVpvn_flags(namepv, namelen,
1223 SVs_TEMP |
1224 (flags & padadd_UTF8_NAME ? SVf_UTF8 : 0)));
a0714e2c 1225 *out_capture = NULL;
dd2155a4
DM
1226 }
1227 }
b5c19bd7 1228 if (!*out_capture) {
cc76b5cc 1229 if (namelen != 0 && *namepv == '@')
ad64d0ec 1230 *out_capture = sv_2mortal(MUTABLE_SV(newAV()));
cc76b5cc 1231 else if (namelen != 0 && *namepv == '%')
ad64d0ec 1232 *out_capture = sv_2mortal(MUTABLE_SV(newHV()));
b5c19bd7
DM
1233 else
1234 *out_capture = sv_newmortal();
1235 }
dd2155a4 1236 }
b5c19bd7
DM
1237
1238 return offset;
ee6cee0c 1239 }
b5c19bd7
DM
1240 }
1241
1242 /* it's not in this pad - try above */
1243
1244 if (!CvOUTSIDE(cv))
1245 return NOT_IN_PAD;
9f7d9405 1246
b5c19bd7 1247 /* out_capture non-null means caller wants us to capture lex; in
71f882da 1248 * addition we capture ourselves unless it's an ANON/format */
b5c19bd7 1249 new_capturep = out_capture ? out_capture :
4608196e 1250 CvLATE(cv) ? NULL : &new_capture;
b5c19bd7 1251
fbb889c8 1252 offset = pad_findlex(namepv, namelen, flags, CvOUTSIDE(cv), CvOUTSIDE_SEQ(cv), 1,
b5c19bd7 1253 new_capturep, out_name_sv, out_flags);
9f7d9405 1254 if ((PADOFFSET)offset == NOT_IN_PAD)
b5c19bd7 1255 return NOT_IN_PAD;
9f7d9405 1256
b5c19bd7
DM
1257 /* found in an outer CV. Add appropriate fake entry to this pad */
1258
1259 /* don't add new fake entries (via eval) to CVs that we have already
1260 * finished compiling, or to undef CVs */
1261 if (CvCOMPILED(cv) || !padlist)
1262 return 0; /* this dummy (and invalid) value isnt used by the caller */
1263
1264 {
3291825f 1265 /* This relies on sv_setsv_flags() upgrading the destination to the same
486ec47a 1266 type as the source, independent of the flags set, and on it being
3291825f
NC
1267 "good" and only copying flag bits and pointers that it understands.
1268 */
1269 SV *new_namesv = newSVsv(*out_name_sv);
53c1dcc0
AL
1270 AV * const ocomppad_name = PL_comppad_name;
1271 PAD * const ocomppad = PL_comppad;
502c6561
NC
1272 PL_comppad_name = MUTABLE_AV(AvARRAY(padlist)[0]);
1273 PL_comppad = MUTABLE_AV(AvARRAY(padlist)[1]);
b5c19bd7
DM
1274 PL_curpad = AvARRAY(PL_comppad);
1275
3291825f 1276 new_offset
cc76b5cc 1277 = pad_alloc_name(new_namesv,
59cfed7d 1278 (SvPAD_STATE(*out_name_sv) ? padadd_STATE : 0),
3291825f
NC
1279 SvPAD_TYPED(*out_name_sv)
1280 ? SvSTASH(*out_name_sv) : NULL,
1281 SvOURSTASH(*out_name_sv)
1282 );
1283
1284 SvFAKE_on(new_namesv);
1285 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1286 "Pad addname: %ld \"%.*s\" FAKE\n",
1287 (long)new_offset,
1288 (int) SvCUR(new_namesv), SvPVX(new_namesv)));
809abb02 1289 PARENT_FAKELEX_FLAGS_set(new_namesv, *out_flags);
b5c19bd7 1290
809abb02 1291 PARENT_PAD_INDEX_set(new_namesv, 0);
00b1698f 1292 if (SvPAD_OUR(new_namesv)) {
6f207bd3 1293 NOOP; /* do nothing */
b5c19bd7 1294 }
71f882da 1295 else if (CvLATE(cv)) {
b5c19bd7 1296 /* delayed creation - just note the offset within parent pad */
809abb02 1297 PARENT_PAD_INDEX_set(new_namesv, offset);
b5c19bd7
DM
1298 CvCLONE_on(cv);
1299 }
1300 else {
1301 /* immediate creation - capture outer value right now */
1302 av_store(PL_comppad, new_offset, SvREFCNT_inc(*new_capturep));
1303 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1304 "Pad findlex cv=0x%"UVxf" saved captured sv 0x%"UVxf" at offset %ld\n",
1305 PTR2UV(cv), PTR2UV(*new_capturep), (long)new_offset));
dd2155a4 1306 }
b5c19bd7 1307 *out_name_sv = new_namesv;
809abb02 1308 *out_flags = PARENT_FAKELEX_FLAGS(new_namesv);
b5c19bd7
DM
1309
1310 PL_comppad_name = ocomppad_name;
1311 PL_comppad = ocomppad;
4608196e 1312 PL_curpad = ocomppad ? AvARRAY(ocomppad) : NULL;
dd2155a4 1313 }
b5c19bd7 1314 return new_offset;
dd2155a4
DM
1315}
1316
fb8a9836 1317#ifdef DEBUGGING
cc76b5cc 1318
dd2155a4 1319/*
cc76b5cc 1320=for apidoc Am|SV *|pad_sv|PADOFFSET po
dd2155a4 1321
cc76b5cc 1322Get the value at offset I<po> in the current (compiling or executing) pad.
dd2155a4
DM
1323Use macro PAD_SV instead of calling this function directly.
1324
1325=cut
1326*/
1327
dd2155a4
DM
1328SV *
1329Perl_pad_sv(pTHX_ PADOFFSET po)
1330{
97aff369 1331 dVAR;
f3548bdc 1332 ASSERT_CURPAD_ACTIVE("pad_sv");
dd2155a4 1333
dd2155a4
DM
1334 if (!po)
1335 Perl_croak(aTHX_ "panic: pad_sv po");
dd2155a4
DM
1336 DEBUG_X(PerlIO_printf(Perl_debug_log,
1337 "Pad 0x%"UVxf"[0x%"UVxf"] sv: %ld sv=0x%"UVxf"\n",
f3548bdc 1338 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po, PTR2UV(PL_curpad[po]))
dd2155a4
DM
1339 );
1340 return PL_curpad[po];
1341}
1342
dd2155a4 1343/*
cc76b5cc 1344=for apidoc Am|void|pad_setsv|PADOFFSET po|SV *sv
dd2155a4 1345
cc76b5cc 1346Set the value at offset I<po> in the current (compiling or executing) pad.
dd2155a4
DM
1347Use the macro PAD_SETSV() rather than calling this function directly.
1348
1349=cut
1350*/
1351
dd2155a4
DM
1352void
1353Perl_pad_setsv(pTHX_ PADOFFSET po, SV* sv)
1354{
97aff369 1355 dVAR;
7918f24d
NC
1356
1357 PERL_ARGS_ASSERT_PAD_SETSV;
1358
f3548bdc 1359 ASSERT_CURPAD_ACTIVE("pad_setsv");
dd2155a4
DM
1360
1361 DEBUG_X(PerlIO_printf(Perl_debug_log,
1362 "Pad 0x%"UVxf"[0x%"UVxf"] setsv: %ld sv=0x%"UVxf"\n",
f3548bdc 1363 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po, PTR2UV(sv))
dd2155a4
DM
1364 );
1365 PL_curpad[po] = sv;
1366}
dd2155a4 1367
cc76b5cc 1368#endif /* DEBUGGING */
dd2155a4
DM
1369
1370/*
cc76b5cc 1371=for apidoc m|void|pad_block_start|int full
dd2155a4
DM
1372
1373Update the pad compilation state variables on entry to a new block
1374
1375=cut
1376*/
1377
1378/* XXX DAPM perhaps:
1379 * - integrate this in general state-saving routine ???
1380 * - combine with the state-saving going on in pad_new ???
1381 * - introduce a new SAVE type that does all this in one go ?
1382 */
1383
1384void
1385Perl_pad_block_start(pTHX_ int full)
1386{
97aff369 1387 dVAR;
f3548bdc 1388 ASSERT_CURPAD_ACTIVE("pad_block_start");
dd2155a4
DM
1389 SAVEI32(PL_comppad_name_floor);
1390 PL_comppad_name_floor = AvFILLp(PL_comppad_name);
1391 if (full)
1392 PL_comppad_name_fill = PL_comppad_name_floor;
1393 if (PL_comppad_name_floor < 0)
1394 PL_comppad_name_floor = 0;
1395 SAVEI32(PL_min_intro_pending);
1396 SAVEI32(PL_max_intro_pending);
1397 PL_min_intro_pending = 0;
1398 SAVEI32(PL_comppad_name_fill);
1399 SAVEI32(PL_padix_floor);
1400 PL_padix_floor = PL_padix;
1401 PL_pad_reset_pending = FALSE;
1402}
1403
dd2155a4 1404/*
cc76b5cc 1405=for apidoc m|U32|intro_my
dd2155a4
DM
1406
1407"Introduce" my variables to visible status.
1408
1409=cut
1410*/
1411
1412U32
1413Perl_intro_my(pTHX)
1414{
97aff369 1415 dVAR;
dd2155a4 1416 SV **svp;
dd2155a4 1417 I32 i;
6012dc80 1418 U32 seq;
dd2155a4 1419
f3548bdc 1420 ASSERT_CURPAD_ACTIVE("intro_my");
dd2155a4
DM
1421 if (! PL_min_intro_pending)
1422 return PL_cop_seqmax;
1423
1424 svp = AvARRAY(PL_comppad_name);
1425 for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
53c1dcc0
AL
1426 SV * const sv = svp[i];
1427
0d311cdb
DM
1428 if (sv && sv != &PL_sv_undef && !SvFAKE(sv)
1429 && COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO)
1430 {
2df5bdd7 1431 COP_SEQ_RANGE_HIGH_set(sv, PERL_PADSEQ_INTRO); /* Don't know scope end yet. */
809abb02 1432 COP_SEQ_RANGE_LOW_set(sv, PL_cop_seqmax);
dd2155a4 1433 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
809abb02 1434 "Pad intromy: %ld \"%s\", (%lu,%lu)\n",
b15aece3 1435 (long)i, SvPVX_const(sv),
809abb02
NC
1436 (unsigned long)COP_SEQ_RANGE_LOW(sv),
1437 (unsigned long)COP_SEQ_RANGE_HIGH(sv))
dd2155a4
DM
1438 );
1439 }
1440 }
6012dc80
DM
1441 seq = PL_cop_seqmax;
1442 PL_cop_seqmax++;
1443 if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */
1444 PL_cop_seqmax++;
dd2155a4
DM
1445 PL_min_intro_pending = 0;
1446 PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
1447 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
6012dc80 1448 "Pad intromy: seq -> %ld\n", (long)(PL_cop_seqmax)));
dd2155a4 1449
6012dc80 1450 return seq;
dd2155a4
DM
1451}
1452
1453/*
cc76b5cc 1454=for apidoc m|void|pad_leavemy
dd2155a4
DM
1455
1456Cleanup at end of scope during compilation: set the max seq number for
1457lexicals in this scope and warn of any lexicals that never got introduced.
1458
1459=cut
1460*/
1461
1462void
1463Perl_pad_leavemy(pTHX)
1464{
97aff369 1465 dVAR;
dd2155a4 1466 I32 off;
551405c4 1467 SV * const * const svp = AvARRAY(PL_comppad_name);
dd2155a4
DM
1468
1469 PL_pad_reset_pending = FALSE;
1470
f3548bdc 1471 ASSERT_CURPAD_ACTIVE("pad_leavemy");
dd2155a4
DM
1472 if (PL_min_intro_pending && PL_comppad_name_fill < PL_min_intro_pending) {
1473 for (off = PL_max_intro_pending; off >= PL_min_intro_pending; off--) {
53c1dcc0 1474 const SV * const sv = svp[off];
9b387841
NC
1475 if (sv && sv != &PL_sv_undef && !SvFAKE(sv))
1476 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
1477 "%"SVf" never introduced",
1478 SVfARG(sv));
dd2155a4
DM
1479 }
1480 }
1481 /* "Deintroduce" my variables that are leaving with this scope. */
1482 for (off = AvFILLp(PL_comppad_name); off > PL_comppad_name_fill; off--) {
53c1dcc0 1483 const SV * const sv = svp[off];
2df5bdd7
DM
1484 if (sv && sv != &PL_sv_undef && !SvFAKE(sv)
1485 && COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO)
1486 {
809abb02 1487 COP_SEQ_RANGE_HIGH_set(sv, PL_cop_seqmax);
dd2155a4 1488 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
809abb02 1489 "Pad leavemy: %ld \"%s\", (%lu,%lu)\n",
b15aece3 1490 (long)off, SvPVX_const(sv),
809abb02
NC
1491 (unsigned long)COP_SEQ_RANGE_LOW(sv),
1492 (unsigned long)COP_SEQ_RANGE_HIGH(sv))
dd2155a4
DM
1493 );
1494 }
1495 }
1496 PL_cop_seqmax++;
6012dc80
DM
1497 if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */
1498 PL_cop_seqmax++;
dd2155a4
DM
1499 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1500 "Pad leavemy: seq = %ld\n", (long)PL_cop_seqmax));
1501}
1502
dd2155a4 1503/*
cc76b5cc 1504=for apidoc m|void|pad_swipe|PADOFFSET po|bool refadjust
dd2155a4
DM
1505
1506Abandon the tmp in the current pad at offset po and replace with a
1507new one.
1508
1509=cut
1510*/
1511
1512void
1513Perl_pad_swipe(pTHX_ PADOFFSET po, bool refadjust)
1514{
97aff369 1515 dVAR;
f3548bdc 1516 ASSERT_CURPAD_LEGAL("pad_swipe");
dd2155a4
DM
1517 if (!PL_curpad)
1518 return;
1519 if (AvARRAY(PL_comppad) != PL_curpad)
5637ef5b
NC
1520 Perl_croak(aTHX_ "panic: pad_swipe curpad, %p!=%p",
1521 AvARRAY(PL_comppad), PL_curpad);
9100eeb1
Z
1522 if (!po || ((SSize_t)po) > AvFILLp(PL_comppad))
1523 Perl_croak(aTHX_ "panic: pad_swipe po=%ld, fill=%ld",
1524 (long)po, (long)AvFILLp(PL_comppad));
dd2155a4
DM
1525
1526 DEBUG_X(PerlIO_printf(Perl_debug_log,
1527 "Pad 0x%"UVxf"[0x%"UVxf"] swipe: %ld\n",
1528 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po));
1529
1530 if (PL_curpad[po])
1531 SvPADTMP_off(PL_curpad[po]);
1532 if (refadjust)
1533 SvREFCNT_dec(PL_curpad[po]);
1534
9ad9869c
DM
1535
1536 /* if pad tmps aren't shared between ops, then there's no need to
1537 * create a new tmp when an existing op is freed */
1538#ifdef USE_BROKEN_PAD_RESET
561b68a9 1539 PL_curpad[po] = newSV(0);
dd2155a4 1540 SvPADTMP_on(PL_curpad[po]);
9ad9869c
DM
1541#else
1542 PL_curpad[po] = &PL_sv_undef;
97bf4a8d 1543#endif
dd2155a4
DM
1544 if ((I32)po < PL_padix)
1545 PL_padix = po - 1;
1546}
1547
dd2155a4 1548/*
cc76b5cc 1549=for apidoc m|void|pad_reset
dd2155a4
DM
1550
1551Mark all the current temporaries for reuse
1552
1553=cut
1554*/
1555
1556/* XXX pad_reset() is currently disabled because it results in serious bugs.
1557 * It causes pad temp TARGs to be shared between OPs. Since TARGs are pushed
1558 * on the stack by OPs that use them, there are several ways to get an alias
1559 * to a shared TARG. Such an alias will change randomly and unpredictably.
1560 * We avoid doing this until we can think of a Better Way.
1561 * GSAR 97-10-29 */
1f676739 1562static void
82af08ae 1563S_pad_reset(pTHX)
dd2155a4 1564{
97aff369 1565 dVAR;
dd2155a4 1566#ifdef USE_BROKEN_PAD_RESET
dd2155a4 1567 if (AvARRAY(PL_comppad) != PL_curpad)
5637ef5b
NC
1568 Perl_croak(aTHX_ "panic: pad_reset curpad, %p!=%p",
1569 AvARRAY(PL_comppad), PL_curpad);
dd2155a4
DM
1570
1571 DEBUG_X(PerlIO_printf(Perl_debug_log,
1572 "Pad 0x%"UVxf"[0x%"UVxf"] reset: padix %ld -> %ld",
1573 PTR2UV(PL_comppad), PTR2UV(PL_curpad),
1574 (long)PL_padix, (long)PL_padix_floor
1575 )
1576 );
1577
1578 if (!PL_tainting) { /* Can't mix tainted and non-tainted temporaries. */
e1ec3a88 1579 register I32 po;
dd2155a4
DM
1580 for (po = AvMAX(PL_comppad); po > PL_padix_floor; po--) {
1581 if (PL_curpad[po] && !SvIMMORTAL(PL_curpad[po]))
1582 SvPADTMP_off(PL_curpad[po]);
1583 }
1584 PL_padix = PL_padix_floor;
1585 }
1586#endif
1587 PL_pad_reset_pending = FALSE;
1588}
1589
dd2155a4 1590/*
cc76b5cc
Z
1591=for apidoc Amx|void|pad_tidy|padtidy_type type
1592
1593Tidy up a pad at the end of compilation of the code to which it belongs.
1594Jobs performed here are: remove most stuff from the pads of anonsub
1595prototypes; give it a @_; mark temporaries as such. I<type> indicates
1596the kind of subroutine:
dd2155a4 1597
cc76b5cc
Z
1598 padtidy_SUB ordinary subroutine
1599 padtidy_SUBCLONE prototype for lexical closure
1600 padtidy_FORMAT format
dd2155a4
DM
1601
1602=cut
1603*/
1604
1605/* XXX DAPM surely most of this stuff should be done properly
1606 * at the right time beforehand, rather than going around afterwards
1607 * cleaning up our mistakes ???
1608 */
1609
1610void
1611Perl_pad_tidy(pTHX_ padtidy_type type)
1612{
27da23d5 1613 dVAR;
dd2155a4 1614
f3548bdc 1615 ASSERT_CURPAD_ACTIVE("pad_tidy");
b5c19bd7
DM
1616
1617 /* If this CV has had any 'eval-capable' ops planted in it
1618 * (ie it contains eval '...', //ee, /$var/ or /(?{..})/), Then any
1619 * anon prototypes in the chain of CVs should be marked as cloneable,
1620 * so that for example the eval's CV in C<< sub { eval '$x' } >> gets
1621 * the right CvOUTSIDE.
1622 * If running with -d, *any* sub may potentially have an eval
486ec47a 1623 * executed within it.
b5c19bd7
DM
1624 */
1625
1626 if (PL_cv_has_eval || PL_perldb) {
e1ec3a88 1627 const CV *cv;
b5c19bd7
DM
1628 for (cv = PL_compcv ;cv; cv = CvOUTSIDE(cv)) {
1629 if (cv != PL_compcv && CvCOMPILED(cv))
1630 break; /* no need to mark already-compiled code */
1631 if (CvANON(cv)) {
1632 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1633 "Pad clone on cv=0x%"UVxf"\n", PTR2UV(cv)));
1634 CvCLONE_on(cv);
a0d2bbd5 1635 CvHASEVAL_on(cv);
b5c19bd7
DM
1636 }
1637 }
1638 }
1639
dd2155a4
DM
1640 /* extend curpad to match namepad */
1641 if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
a0714e2c 1642 av_store(PL_comppad_name, AvFILLp(PL_comppad), NULL);
dd2155a4
DM
1643
1644 if (type == padtidy_SUBCLONE) {
551405c4 1645 SV * const * const namep = AvARRAY(PL_comppad_name);
504618e9 1646 PADOFFSET ix;
b5c19bd7 1647
dd2155a4
DM
1648 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1649 SV *namesv;
1650
1651 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
1652 continue;
1653 /*
1654 * The only things that a clonable function needs in its
b5c19bd7 1655 * pad are anonymous subs.
dd2155a4
DM
1656 * The rest are created anew during cloning.
1657 */
a0714e2c 1658 if (!((namesv = namep[ix]) != NULL &&
dd2155a4 1659 namesv != &PL_sv_undef &&
b15aece3 1660 *SvPVX_const(namesv) == '&'))
dd2155a4
DM
1661 {
1662 SvREFCNT_dec(PL_curpad[ix]);
a0714e2c 1663 PL_curpad[ix] = NULL;
dd2155a4
DM
1664 }
1665 }
1666 }
1667 else if (type == padtidy_SUB) {
1668 /* XXX DAPM this same bit of code keeps appearing !!! Rationalise? */
53c1dcc0 1669 AV * const av = newAV(); /* Will be @_ */
ad64d0ec 1670 av_store(PL_comppad, 0, MUTABLE_SV(av));
11ca45c0 1671 AvREIFY_only(av);
dd2155a4
DM
1672 }
1673
4cee4ca8 1674 if (type == padtidy_SUB || type == padtidy_FORMAT) {
adf8f095 1675 SV * const * const namep = AvARRAY(PL_comppad_name);
504618e9 1676 PADOFFSET ix;
dd2155a4
DM
1677 for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1678 if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
1679 continue;
adf8f095 1680 if (!SvPADMY(PL_curpad[ix])) {
dd2155a4 1681 SvPADTMP_on(PL_curpad[ix]);
adf8f095
NC
1682 } else if (!SvFAKE(namep[ix])) {
1683 /* This is a work around for how the current implementation of
1684 ?{ } blocks in regexps interacts with lexicals.
1685
1686 One of our lexicals.
1687 Can't do this on all lexicals, otherwise sub baz() won't
1688 compile in
1689
1690 my $foo;
1691
1692 sub bar { ++$foo; }
1693
1694 sub baz { ++$foo; }
1695
1696 because completion of compiling &bar calling pad_tidy()
1697 would cause (top level) $foo to be marked as stale, and
1698 "no longer available". */
1699 SvPADSTALE_on(PL_curpad[ix]);
1700 }
dd2155a4
DM
1701 }
1702 }
f3548bdc 1703 PL_curpad = AvARRAY(PL_comppad);
dd2155a4
DM
1704}
1705
dd2155a4 1706/*
cc76b5cc 1707=for apidoc m|void|pad_free|PADOFFSET po
dd2155a4 1708
8627550a 1709Free the SV at offset po in the current pad.
dd2155a4
DM
1710
1711=cut
1712*/
1713
1714/* XXX DAPM integrate with pad_swipe ???? */
1715void
1716Perl_pad_free(pTHX_ PADOFFSET po)
1717{
97aff369 1718 dVAR;
f3548bdc 1719 ASSERT_CURPAD_LEGAL("pad_free");
dd2155a4
DM
1720 if (!PL_curpad)
1721 return;
1722 if (AvARRAY(PL_comppad) != PL_curpad)
5637ef5b
NC
1723 Perl_croak(aTHX_ "panic: pad_free curpad, %p!=%p",
1724 AvARRAY(PL_comppad), PL_curpad);
dd2155a4
DM
1725 if (!po)
1726 Perl_croak(aTHX_ "panic: pad_free po");
1727
1728 DEBUG_X(PerlIO_printf(Perl_debug_log,
1729 "Pad 0x%"UVxf"[0x%"UVxf"] free: %ld\n",
1730 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po)
1731 );
1732
1733 if (PL_curpad[po] && PL_curpad[po] != &PL_sv_undef) {
9a214eec 1734 SvFLAGS(PL_curpad[po]) &= ~SVs_PADTMP; /* also clears SVs_PADSTALE */
dd2155a4
DM
1735 }
1736 if ((I32)po < PL_padix)
1737 PL_padix = po - 1;
1738}
1739
dd2155a4 1740/*
cc76b5cc 1741=for apidoc m|void|do_dump_pad|I32 level|PerlIO *file|PADLIST *padlist|int full
dd2155a4
DM
1742
1743Dump the contents of a padlist
1744
1745=cut
1746*/
1747
1748void
1749Perl_do_dump_pad(pTHX_ I32 level, PerlIO *file, PADLIST *padlist, int full)
1750{
97aff369 1751 dVAR;
e1ec3a88
AL
1752 const AV *pad_name;
1753 const AV *pad;
dd2155a4
DM
1754 SV **pname;
1755 SV **ppad;
dd2155a4
DM
1756 I32 ix;
1757
7918f24d
NC
1758 PERL_ARGS_ASSERT_DO_DUMP_PAD;
1759
dd2155a4
DM
1760 if (!padlist) {
1761 return;
1762 }
502c6561
NC
1763 pad_name = MUTABLE_AV(*av_fetch(MUTABLE_AV(padlist), 0, FALSE));
1764 pad = MUTABLE_AV(*av_fetch(MUTABLE_AV(padlist), 1, FALSE));
dd2155a4
DM
1765 pname = AvARRAY(pad_name);
1766 ppad = AvARRAY(pad);
1767 Perl_dump_indent(aTHX_ level, file,
1768 "PADNAME = 0x%"UVxf"(0x%"UVxf") PAD = 0x%"UVxf"(0x%"UVxf")\n",
1769 PTR2UV(pad_name), PTR2UV(pname), PTR2UV(pad), PTR2UV(ppad)
1770 );
1771
1772 for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
e1ec3a88 1773 const SV *namesv = pname[ix];
dd2155a4 1774 if (namesv && namesv == &PL_sv_undef) {
a0714e2c 1775 namesv = NULL;
dd2155a4
DM
1776 }
1777 if (namesv) {
ee6cee0c
DM
1778 if (SvFAKE(namesv))
1779 Perl_dump_indent(aTHX_ level+1, file,
c0fd1b42 1780 "%2d. 0x%"UVxf"<%lu> FAKE \"%s\" flags=0x%lx index=%lu\n",
ee6cee0c
DM
1781 (int) ix,
1782 PTR2UV(ppad[ix]),
1783 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
b15aece3 1784 SvPVX_const(namesv),
809abb02
NC
1785 (unsigned long)PARENT_FAKELEX_FLAGS(namesv),
1786 (unsigned long)PARENT_PAD_INDEX(namesv)
b5c19bd7 1787
ee6cee0c
DM
1788 );
1789 else
1790 Perl_dump_indent(aTHX_ level+1, file,
809abb02 1791 "%2d. 0x%"UVxf"<%lu> (%lu,%lu) \"%s\"\n",
ee6cee0c
DM
1792 (int) ix,
1793 PTR2UV(ppad[ix]),
1794 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
809abb02
NC
1795 (unsigned long)COP_SEQ_RANGE_LOW(namesv),
1796 (unsigned long)COP_SEQ_RANGE_HIGH(namesv),
b15aece3 1797 SvPVX_const(namesv)
ee6cee0c 1798 );
dd2155a4
DM
1799 }
1800 else if (full) {
1801 Perl_dump_indent(aTHX_ level+1, file,
1802 "%2d. 0x%"UVxf"<%lu>\n",
1803 (int) ix,
1804 PTR2UV(ppad[ix]),
1805 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0)
1806 );
1807 }
1808 }
1809}
1810
cc76b5cc 1811#ifdef DEBUGGING
dd2155a4
DM
1812
1813/*
cc76b5cc 1814=for apidoc m|void|cv_dump|CV *cv|const char *title
dd2155a4
DM
1815
1816dump the contents of a CV
1817
1818=cut
1819*/
1820
dd2155a4 1821STATIC void
e1ec3a88 1822S_cv_dump(pTHX_ const CV *cv, const char *title)
dd2155a4 1823{
97aff369 1824 dVAR;
53c1dcc0
AL
1825 const CV * const outside = CvOUTSIDE(cv);
1826 AV* const padlist = CvPADLIST(cv);
dd2155a4 1827
7918f24d
NC
1828 PERL_ARGS_ASSERT_CV_DUMP;
1829
dd2155a4
DM
1830 PerlIO_printf(Perl_debug_log,
1831 " %s: CV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
1832 title,
1833 PTR2UV(cv),
1834 (CvANON(cv) ? "ANON"
71f882da 1835 : (SvTYPE(cv) == SVt_PVFM) ? "FORMAT"
dd2155a4
DM
1836 : (cv == PL_main_cv) ? "MAIN"
1837 : CvUNIQUE(cv) ? "UNIQUE"
1838 : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
1839 PTR2UV(outside),
1840 (!outside ? "null"
1841 : CvANON(outside) ? "ANON"
1842 : (outside == PL_main_cv) ? "MAIN"
1843 : CvUNIQUE(outside) ? "UNIQUE"
1844 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
1845
1846 PerlIO_printf(Perl_debug_log,
1847 " PADLIST = 0x%"UVxf"\n", PTR2UV(padlist));
1848 do_dump_pad(1, Perl_debug_log, padlist, 1);
1849}
dd2155a4 1850
cc76b5cc 1851#endif /* DEBUGGING */
dd2155a4
DM
1852
1853/*
cc76b5cc 1854=for apidoc Am|CV *|cv_clone|CV *proto
dd2155a4 1855
cc76b5cc
Z
1856Clone a CV, making a lexical closure. I<proto> supplies the prototype
1857of the function: its code, pad structure, and other attributes.
1858The prototype is combined with a capture of outer lexicals to which the
1859code refers, which are taken from the currently-executing instance of
1860the immediately surrounding code.
dd2155a4
DM
1861
1862=cut
1863*/
1864
1865CV *
1866Perl_cv_clone(pTHX_ CV *proto)
1867{
27da23d5 1868 dVAR;
dd2155a4 1869 I32 ix;
53c1dcc0 1870 AV* const protopadlist = CvPADLIST(proto);
502c6561
NC
1871 const AV *const protopad_name = (const AV *)*av_fetch(protopadlist, 0, FALSE);
1872 const AV *const protopad = (const AV *)*av_fetch(protopadlist, 1, FALSE);
53c1dcc0
AL
1873 SV** const pname = AvARRAY(protopad_name);
1874 SV** const ppad = AvARRAY(protopad);
e1ec3a88
AL
1875 const I32 fname = AvFILLp(protopad_name);
1876 const I32 fpad = AvFILLp(protopad);
dd2155a4 1877 CV* cv;
b5c19bd7
DM
1878 SV** outpad;
1879 CV* outside;
71f882da 1880 long depth;
dd2155a4 1881
7918f24d
NC
1882 PERL_ARGS_ASSERT_CV_CLONE;
1883
dd2155a4
DM
1884 assert(!CvUNIQUE(proto));
1885
71f882da
DM
1886 /* Since cloneable anon subs can be nested, CvOUTSIDE may point
1887 * to a prototype; we instead want the cloned parent who called us.
af41786f
FC
1888 * Note that in general for formats, CvOUTSIDE != find_runcv; formats
1889 * inside closures, however, only work if CvOUTSIDE == find_runcv.
1890 */
71f882da
DM
1891
1892 outside = CvOUTSIDE(proto);
0f9db002 1893 if (!outside || (CvCLONE(outside) && ! CvCLONED(outside)))
71f882da 1894 outside = find_runcv(NULL);
af41786f
FC
1895 if (SvTYPE(proto) == SVt_PVFM
1896 && CvROOT(outside) != CvROOT(CvOUTSIDE(proto)))
1897 outside = CvOUTSIDE(proto);
71f882da
DM
1898 depth = CvDEPTH(outside);
1899 assert(depth || SvTYPE(proto) == SVt_PVFM);
1900 if (!depth)
1901 depth = 1;
b5c19bd7
DM
1902 assert(CvPADLIST(outside));
1903
dd2155a4
DM
1904 ENTER;
1905 SAVESPTR(PL_compcv);
1906
ea726b52 1907 cv = PL_compcv = MUTABLE_CV(newSV_type(SvTYPE(proto)));
c794ca97 1908 CvFLAGS(cv) = CvFLAGS(proto) & ~(CVf_CLONE|CVf_WEAKOUTSIDE|CVf_CVGV_RC);
dd2155a4
DM
1909 CvCLONED_on(cv);
1910
bad4ae38
FC
1911 CvFILE(cv) = CvDYNFILE(proto) ? savepv(CvFILE(proto))
1912 : CvFILE(proto);
b3f91e91 1913 CvGV_set(cv,CvGV(proto));
c68d9564 1914 CvSTASH_set(cv, CvSTASH(proto));
b34c0dd4 1915 OP_REFCNT_LOCK;
dd2155a4 1916 CvROOT(cv) = OpREFCNT_inc(CvROOT(proto));
b34c0dd4 1917 OP_REFCNT_UNLOCK;
dd2155a4 1918 CvSTART(cv) = CvSTART(proto);
a0d2bbd5
FC
1919 if (CvHASEVAL(cv))
1920 CvOUTSIDE(cv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
b5c19bd7 1921 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(proto);
dd2155a4
DM
1922
1923 if (SvPOK(proto))
ad64d0ec 1924 sv_setpvn(MUTABLE_SV(cv), SvPVX_const(proto), SvCUR(proto));
09fb282d
FC
1925 if (SvMAGIC(proto))
1926 mg_copy((SV *)proto, (SV *)cv, 0, 0);
dd2155a4 1927
b7787f18 1928 CvPADLIST(cv) = pad_new(padnew_CLONE|padnew_SAVE);
dd2155a4 1929
b5c19bd7 1930 av_fill(PL_comppad, fpad);
7aaef02a 1931 for (ix = fname; ix > 0; ix--)
dd2155a4
DM
1932 av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
1933
dd2155a4
DM
1934 PL_curpad = AvARRAY(PL_comppad);
1935
71f882da 1936 outpad = AvARRAY(AvARRAY(CvPADLIST(outside))[depth]);
b5c19bd7 1937
dd2155a4 1938 for (ix = fpad; ix > 0; ix--) {
a0714e2c
SS
1939 SV* const namesv = (ix <= fname) ? pname[ix] : NULL;
1940 SV *sv = NULL;
71f882da 1941 if (namesv && namesv != &PL_sv_undef) { /* lexical */
b5c19bd7 1942 if (SvFAKE(namesv)) { /* lexical from outside? */
809abb02 1943 sv = outpad[PARENT_PAD_INDEX(namesv)];
33894c1a
DM
1944 /* formats may have an inactive parent,
1945 while my $x if $false can leave an active var marked as
d1186544 1946 stale. And state vars are always available */
af41786f 1947 if (!sv || (SvPADSTALE(sv) && !SvPAD_STATE(namesv))) {
a2a5de95 1948 Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE),
0727928e 1949 "Variable \"%"SVf"\" is not available", namesv);
a0714e2c 1950 sv = NULL;
71f882da 1951 }
33894c1a 1952 else
f84c484e 1953 SvREFCNT_inc_simple_void_NN(sv);
dd2155a4 1954 }
71f882da 1955 if (!sv) {
b15aece3 1956 const char sigil = SvPVX_const(namesv)[0];
e1ec3a88 1957 if (sigil == '&')
dd2155a4 1958 sv = SvREFCNT_inc(ppad[ix]);
e1ec3a88 1959 else if (sigil == '@')
ad64d0ec 1960 sv = MUTABLE_SV(newAV());
e1ec3a88 1961 else if (sigil == '%')
ad64d0ec 1962 sv = MUTABLE_SV(newHV());
dd2155a4 1963 else
561b68a9 1964 sv = newSV(0);
235cc2e3 1965 SvPADMY_on(sv);
0d3b281c
DM
1966 /* reset the 'assign only once' flag on each state var */
1967 if (SvPAD_STATE(namesv))
1968 SvPADSTALE_on(sv);
dd2155a4
DM
1969 }
1970 }
1971 else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
f84c484e 1972 sv = SvREFCNT_inc_NN(ppad[ix]);
dd2155a4
DM
1973 }
1974 else {
561b68a9 1975 sv = newSV(0);
dd2155a4 1976 SvPADTMP_on(sv);
dd2155a4 1977 }
71f882da 1978 PL_curpad[ix] = sv;
dd2155a4
DM
1979 }
1980
dd2155a4
DM
1981 DEBUG_Xv(
1982 PerlIO_printf(Perl_debug_log, "\nPad CV clone\n");
1983 cv_dump(outside, "Outside");
1984 cv_dump(proto, "Proto");
1985 cv_dump(cv, "To");
1986 );
1987
1988 LEAVE;
1989
1990 if (CvCONST(cv)) {
b5c19bd7
DM
1991 /* Constant sub () { $x } closing over $x - see lib/constant.pm:
1992 * The prototype was marked as a candiate for const-ization,
1993 * so try to grab the current const value, and if successful,
1994 * turn into a const sub:
1995 */
551405c4 1996 SV* const const_sv = op_const_sv(CvSTART(cv), cv);
b5c19bd7
DM
1997 if (const_sv) {
1998 SvREFCNT_dec(cv);
bd61b366 1999 cv = newCONSTSUB(CvSTASH(proto), NULL, const_sv);
b5c19bd7
DM
2000 }
2001 else {
2002 CvCONST_off(cv);
2003 }
dd2155a4
DM
2004 }
2005
2006 return cv;
2007}
2008
dd2155a4 2009/*
cc76b5cc 2010=for apidoc m|void|pad_fixup_inner_anons|PADLIST *padlist|CV *old_cv|CV *new_cv
dd2155a4
DM
2011
2012For any anon CVs in the pad, change CvOUTSIDE of that CV from
7dafbf52
DM
2013old_cv to new_cv if necessary. Needed when a newly-compiled CV has to be
2014moved to a pre-existing CV struct.
dd2155a4
DM
2015
2016=cut
2017*/
2018
2019void
2020Perl_pad_fixup_inner_anons(pTHX_ PADLIST *padlist, CV *old_cv, CV *new_cv)
2021{
97aff369 2022 dVAR;
dd2155a4 2023 I32 ix;
502c6561
NC
2024 AV * const comppad_name = MUTABLE_AV(AvARRAY(padlist)[0]);
2025 AV * const comppad = MUTABLE_AV(AvARRAY(padlist)[1]);
53c1dcc0
AL
2026 SV ** const namepad = AvARRAY(comppad_name);
2027 SV ** const curpad = AvARRAY(comppad);
7918f24d
NC
2028
2029 PERL_ARGS_ASSERT_PAD_FIXUP_INNER_ANONS;
294a48e9
AL
2030 PERL_UNUSED_ARG(old_cv);
2031
dd2155a4 2032 for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
551405c4 2033 const SV * const namesv = namepad[ix];
dd2155a4 2034 if (namesv && namesv != &PL_sv_undef
b15aece3 2035 && *SvPVX_const(namesv) == '&')
dd2155a4 2036 {
e09ac076 2037 if (SvTYPE(curpad[ix]) == SVt_PVCV) {
ea726b52 2038 CV * const innercv = MUTABLE_CV(curpad[ix]);
7dafbf52
DM
2039 assert(CvWEAKOUTSIDE(innercv));
2040 assert(CvOUTSIDE(innercv) == old_cv);
2041 CvOUTSIDE(innercv) = new_cv;
e09ac076
FC
2042 }
2043 else { /* format reference */
2044 SV * const rv = curpad[ix];
2045 CV *innercv;
2046 if (!SvOK(rv)) continue;
2047 assert(SvROK(rv));
2048 assert(SvWEAKREF(rv));
2049 innercv = (CV *)SvRV(rv);
2050 assert(!CvWEAKOUTSIDE(innercv));
2051 SvREFCNT_dec(CvOUTSIDE(innercv));
2052 CvOUTSIDE(innercv) = (CV *)SvREFCNT_inc_simple_NN(new_cv);
2053 }
dd2155a4
DM
2054 }
2055 }
2056}
2057
2058/*
cc76b5cc 2059=for apidoc m|void|pad_push|PADLIST *padlist|int depth
dd2155a4
DM
2060
2061Push a new pad frame onto the padlist, unless there's already a pad at
26019298
AL
2062this depth, in which case don't bother creating a new one. Then give
2063the new pad an @_ in slot zero.
dd2155a4
DM
2064
2065=cut
2066*/
2067
2068void
26019298 2069Perl_pad_push(pTHX_ PADLIST *padlist, int depth)
dd2155a4 2070{
97aff369 2071 dVAR;
7918f24d
NC
2072
2073 PERL_ARGS_ASSERT_PAD_PUSH;
2074
b37c2d43 2075 if (depth > AvFILLp(padlist)) {
44f8325f
AL
2076 SV** const svp = AvARRAY(padlist);
2077 AV* const newpad = newAV();
2078 SV** const oldpad = AvARRAY(svp[depth-1]);
502c6561
NC
2079 I32 ix = AvFILLp((const AV *)svp[1]);
2080 const I32 names_fill = AvFILLp((const AV *)svp[0]);
44f8325f 2081 SV** const names = AvARRAY(svp[0]);
26019298
AL
2082 AV *av;
2083
dd2155a4
DM
2084 for ( ;ix > 0; ix--) {
2085 if (names_fill >= ix && names[ix] != &PL_sv_undef) {
b15aece3 2086 const char sigil = SvPVX_const(names[ix])[0];
fda94784
RGS
2087 if ((SvFLAGS(names[ix]) & SVf_FAKE)
2088 || (SvFLAGS(names[ix]) & SVpad_STATE)
2089 || sigil == '&')
2090 {
dd2155a4
DM
2091 /* outer lexical or anon code */
2092 av_store(newpad, ix, SvREFCNT_inc(oldpad[ix]));
2093 }
2094 else { /* our own lexical */
26019298
AL
2095 SV *sv;
2096 if (sigil == '@')
ad64d0ec 2097 sv = MUTABLE_SV(newAV());
26019298 2098 else if (sigil == '%')
ad64d0ec 2099 sv = MUTABLE_SV(newHV());
dd2155a4 2100 else
561b68a9 2101 sv = newSV(0);
26019298 2102 av_store(newpad, ix, sv);
dd2155a4
DM
2103 SvPADMY_on(sv);
2104 }
2105 }
2106 else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
f84c484e 2107 av_store(newpad, ix, SvREFCNT_inc_NN(oldpad[ix]));
dd2155a4
DM
2108 }
2109 else {
2110 /* save temporaries on recursion? */
561b68a9 2111 SV * const sv = newSV(0);
26019298 2112 av_store(newpad, ix, sv);
dd2155a4
DM
2113 SvPADTMP_on(sv);
2114 }
2115 }
26019298 2116 av = newAV();
ad64d0ec 2117 av_store(newpad, 0, MUTABLE_SV(av));
11ca45c0 2118 AvREIFY_only(av);
26019298 2119
ad64d0ec 2120 av_store(padlist, depth, MUTABLE_SV(newpad));
dd2155a4
DM
2121 AvFILLp(padlist) = depth;
2122 }
2123}
b21dc031 2124
cc76b5cc
Z
2125/*
2126=for apidoc Am|HV *|pad_compname_type|PADOFFSET po
2127
2128Looks up the type of the lexical variable at position I<po> in the
2129currently-compiling pad. If the variable is typed, the stash of the
2130class to which it is typed is returned. If not, C<NULL> is returned.
2131
2132=cut
2133*/
b21dc031
AL
2134
2135HV *
2136Perl_pad_compname_type(pTHX_ const PADOFFSET po)
2137{
97aff369 2138 dVAR;
551405c4 2139 SV* const * const av = av_fetch(PL_comppad_name, po, FALSE);
00b1698f 2140 if ( SvPAD_TYPED(*av) ) {
b21dc031
AL
2141 return SvSTASH(*av);
2142 }
5c284bb0 2143 return NULL;
b21dc031 2144}
66610fdd 2145
d5b1589c
NC
2146#if defined(USE_ITHREADS)
2147
2148# define av_dup_inc(s,t) MUTABLE_AV(sv_dup_inc((const SV *)s,t))
2149
cc76b5cc
Z
2150/*
2151=for apidoc m|AV *|padlist_dup|AV *srcpad|CLONE_PARAMS *param
2152
2153Duplicates a pad.
2154
2155=cut
2156*/
2157
d5b1589c 2158AV *
cc76b5cc 2159Perl_padlist_dup(pTHX_ AV *srcpad, CLONE_PARAMS *param)
d5b1589c
NC
2160{
2161 AV *dstpad;
2162 PERL_ARGS_ASSERT_PADLIST_DUP;
2163
2164 if (!srcpad)
2165 return NULL;
2166
6de654a5
NC
2167 if (param->flags & CLONEf_COPY_STACKS
2168 || SvREFCNT(AvARRAY(srcpad)[1]) > 1) {
6de654a5 2169 dstpad = av_dup_inc(srcpad, param);
6de654a5
NC
2170 assert (SvREFCNT(AvARRAY(srcpad)[1]) == 1);
2171 } else {
2172 /* CvDEPTH() on our subroutine will be set to 0, so there's no need
2173 to build anything other than the first level of pads. */
2174
2175 I32 ix = AvFILLp((const AV *)AvARRAY(srcpad)[1]);
2176 AV *pad1;
05d04d9c 2177 const I32 names_fill = AvFILLp((const AV *)(AvARRAY(srcpad)[0]));
6de654a5
NC
2178 const AV *const srcpad1 = (const AV *) AvARRAY(srcpad)[1];
2179 SV **oldpad = AvARRAY(srcpad1);
2180 SV **names;
2181 SV **pad1a;
2182 AV *args;
7d953ba8
FC
2183 /* Look for it in the table first, as the padlist may have ended up
2184 as an element of @DB::args (or theoretically even @_), so it may
104a8185 2185 may have been cloned already. */
6de654a5
NC
2186 dstpad = (AV*)ptr_table_fetch(PL_ptr_table, srcpad);
2187
2188 if (dstpad)
7d953ba8 2189 return (AV *)SvREFCNT_inc_simple_NN(dstpad);
6de654a5
NC
2190
2191 dstpad = newAV();
2192 ptr_table_store(PL_ptr_table, srcpad, dstpad);
6de654a5
NC
2193 av_extend(dstpad, 1);
2194 AvARRAY(dstpad)[0] = MUTABLE_SV(av_dup_inc(AvARRAY(srcpad)[0], param));
2195 names = AvARRAY(AvARRAY(dstpad)[0]);
2196
2197 pad1 = newAV();
2198
2199 av_extend(pad1, ix);
2200 AvARRAY(dstpad)[1] = MUTABLE_SV(pad1);
2201 pad1a = AvARRAY(pad1);
2202 AvFILLp(dstpad) = 1;
2203
2204 if (ix > -1) {
2205 AvFILLp(pad1) = ix;
2206
2207 for ( ;ix > 0; ix--) {
05d04d9c
NC
2208 if (!oldpad[ix]) {
2209 pad1a[ix] = NULL;
2210 } else if (names_fill >= ix && names[ix] != &PL_sv_undef) {
2211 const char sigil = SvPVX_const(names[ix])[0];
2212 if ((SvFLAGS(names[ix]) & SVf_FAKE)
2213 || (SvFLAGS(names[ix]) & SVpad_STATE)
2214 || sigil == '&')
2215 {
2216 /* outer lexical or anon code */
2217 pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2218 }
2219 else { /* our own lexical */
adf8f095
NC
2220 if(SvPADSTALE(oldpad[ix]) && SvREFCNT(oldpad[ix]) > 1) {
2221 /* This is a work around for how the current
2222 implementation of ?{ } blocks in regexps
2223 interacts with lexicals. */
05d04d9c
NC
2224 pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2225 } else {
2226 SV *sv;
2227
2228 if (sigil == '@')
2229 sv = MUTABLE_SV(newAV());
2230 else if (sigil == '%')
2231 sv = MUTABLE_SV(newHV());
2232 else
2233 sv = newSV(0);
2234 pad1a[ix] = sv;
2235 SvPADMY_on(sv);
2236 }
2237 }
2238 }
2239 else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
2240 pad1a[ix] = sv_dup_inc(oldpad[ix], param);
2241 }
2242 else {
2243 /* save temporaries on recursion? */
2244 SV * const sv = newSV(0);
2245 pad1a[ix] = sv;
2246
2247 /* SvREFCNT(oldpad[ix]) != 1 for some code in threads.xs
2248 FIXTHAT before merging this branch.
2249 (And I know how to) */
2250 if (SvPADMY(oldpad[ix]))
2251 SvPADMY_on(sv);
2252 else
2253 SvPADTMP_on(sv);
2254 }
6de654a5
NC
2255 }
2256
2257 if (oldpad[0]) {
2258 args = newAV(); /* Will be @_ */
2259 AvREIFY_only(args);
2260 pad1a[0] = (SV *)args;
2261 }
2262 }
2263 }
d5b1589c
NC
2264
2265 return dstpad;
2266}
2267
cc76b5cc 2268#endif /* USE_ITHREADS */
d5b1589c 2269
66610fdd
RGS
2270/*
2271 * Local variables:
2272 * c-indentation-style: bsd
2273 * c-basic-offset: 4
14d04a33 2274 * indent-tabs-mode: nil
66610fdd
RGS
2275 * End:
2276 *
14d04a33 2277 * ex: set ts=8 sts=4 sw=4 et:
37442d52 2278 */