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