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