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