pad.c

   1 /*    pad.c
   2  *
   3  *    Copyright (C) 2002,2003 by Larry Wall and others
   4  *
   5  *    You may distribute under the terms of either the GNU General Public
   6  *    License or the Artistic License, as specified in the README file.
   7  *
   8  *  "Anyway: there was this Mr Frodo left an orphan and stranded, as you
   9  *  might say, among those queer Bucklanders, being brought up anyhow in
  10  *  Brandy Hall. A regular warren, by all accounts. Old Master Gorbadoc
  11  *  never had fewer than a couple of hundred relations in the place. Mr
  12  *  Bilbo never did a kinder deed than when he brought the lad back to
  13  *  live among decent folk." --the Gaffer
  14  */
  15
  16 /* XXX DAPM
  17  * As of Sept 2002, this file is new and may be in a state of flux for
  18  * a while. I've marked things I intent to come back and look at further
  19  * with an 'XXX DAPM' comment.
  20  */
  21
  22 /*
  23 =head1 Pad Data Structures
  24
  25 =for apidoc m|AV *|CvPADLIST|CV *cv
  26 CV's can have CvPADLIST(cv) set to point to an AV.
  27
  28 For these purposes "forms" are a kind-of CV, eval""s are too (except they're
  29 not callable at will and are always thrown away after the eval"" is done
  30 executing). Require'd files are simply evals without any outer lexical
  31 scope.
  32
  33 XSUBs don't have CvPADLIST set - dXSTARG fetches values from PL_curpad,
  34 but that is really the callers pad (a slot of which is allocated by
  35 every entersub).
  36
  37 The CvPADLIST AV has does not have AvREAL set, so REFCNT of component items
  38 is managed "manual" (mostly in pad.c) rather than normal av.c rules.
  39 The items in the AV are not SVs as for a normal AV, but other AVs:
  40
  41 0'th Entry of the CvPADLIST is an AV which represents the "names" or rather
  42 the "static type information" for lexicals.
  43
  44 The CvDEPTH'th entry of CvPADLIST AV is an AV which is the stack frame at that
  45 depth of recursion into the CV.
  46 The 0'th slot of a frame AV is an AV which is @_.
  47 other entries are storage for variables and op targets.
  48
  49 During compilation:
  50 C<PL_comppad_name> is set to the names AV.
  51 C<PL_comppad> is set to the frame AV for the frame CvDEPTH == 1.
  52 C<PL_curpad> is set to the body of the frame AV (i.e. AvARRAY(PL_comppad)).
  53
  54 During execution, C<PL_comppad> and C<PL_curpad> refer to the live
  55 frame of the currently executing sub.
  56
  57 Iterating over the names AV iterates over all possible pad
  58 items. Pad slots that are SVs_PADTMP (targets/GVs/constants) end up having
  59 &PL_sv_undef "names" (see pad_alloc()).
  60
  61 Only my/our variable (SVs_PADMY/SVs_PADOUR) slots get valid names.
  62 The rest are op targets/GVs/constants which are statically allocated
  63 or resolved at compile time.  These don't have names by which they
  64 can be looked up from Perl code at run time through eval"" like
  65 my/our variables can be.  Since they can't be looked up by "name"
  66 but only by their index allocated at compile time (which is usually
  67 in PL_op->op_targ), wasting a name SV for them doesn't make sense.
  68
  69 The SVs in the names AV have their PV being the name of the variable.
  70 NV+1..IV inclusive is a range of cop_seq numbers for which the name is
  71 valid.  For typed lexicals name SV is SVt_PVMG and SvSTASH points at the
  72 type.  For C<our> lexicals, the type is SVt_PVGV, and GvSTASH points at the
  73 stash of the associated global (so that duplicate C<our> delarations in the
  74 same package can be detected).  SvCUR is sometimes hijacked to
  75 store the generation number during compilation.
  76
  77 If SvFAKE is set on the name SV, then that slot in the frame AV is
  78 a REFCNT'ed reference to a lexical from "outside". In this case,
  79 the name SV does not use NVX and IVX to store a cop_seq range, since it is
  80 in scope throughout. Instead IVX stores some flags containing info about
  81 the real lexical (is it declared in an anon, and is it capable of being
  82 instantiated multiple times?), and for fake ANONs, NVX contains the index
  83 within the parent's pad where the lexical's value is stored, to make
  84 cloning quicker.
  85
  86 If the 'name' is '&' the corresponding entry in frame AV
  87 is a CV representing a possible closure.
  88 (SvFAKE and name of '&' is not a meaningful combination currently but could
  89 become so if C<my sub foo {}> is implemented.)
  90
  91 Note that formats are treated as anon subs, and are cloned each time
  92 write is called (if necessary).
  93
  94 =cut
  95 */
  96
  97
  98 #include "EXTERN.h"
  99 #define PERL_IN_PAD_C
 100 #include "perl.h"
 101
 102
 103 #define PAD_MAX 999999999
 104
 105
 106
 107 /*
 108 =for apidoc pad_new
 109
 110 Create a new compiling padlist, saving and updating the various global
 111 vars at the same time as creating the pad itself. The following flags
 112 can be OR'ed together:
 113
 114     padnew_CLONE        this pad is for a cloned CV
 115     padnew_SAVE         save old globals
 116     padnew_SAVESUB      also save extra stuff for start of sub
 117
 118 =cut
 119 */
 120
 121 PADLIST *
 122 Perl_pad_new(pTHX_ int flags)
 123 {
 124     AV *padlist, *padname, *pad, *a0;
 125
 126     ASSERT_CURPAD_LEGAL("pad_new");
 127
 128     /* XXX DAPM really need a new SAVEt_PAD which restores all or most
 129      * vars (based on flags) rather than storing vals + addresses for
 130      * each individually. Also see pad_block_start.
 131      * XXX DAPM Try to see whether all these conditionals are required
 132      */
 133
 134     /* save existing state, ... */
 135
 136     if (flags & padnew_SAVE) {
 137         SAVECOMPPAD();
 138         SAVESPTR(PL_comppad_name);
 139         if (! (flags & padnew_CLONE)) {
 140             SAVEI32(PL_padix);
 141             SAVEI32(PL_comppad_name_fill);
 142             SAVEI32(PL_min_intro_pending);
 143             SAVEI32(PL_max_intro_pending);
 144             SAVEI32(PL_cv_has_eval);
 145             if (flags & padnew_SAVESUB) {
 146                 SAVEI32(PL_pad_reset_pending);
 147             }
 148         }
 149     }
 150     /* XXX DAPM interestingly, PL_comppad_name_floor never seems to be
 151      * saved - check at some pt that this is okay */
 152
 153     /* ... create new pad ... */
 154
 155     padlist     = newAV();
 156     padname     = newAV();
 157     pad         = newAV();
 158
 159     if (flags & padnew_CLONE) {
 160         /* XXX DAPM  I dont know why cv_clone needs it
 161          * doing differently yet - perhaps this separate branch can be
 162          * dispensed with eventually ???
 163          */
 164
 165         a0 = newAV();                   /* will be @_ */
 166         av_extend(a0, 0);
 167         av_store(pad, 0, (SV*)a0);
 168         AvFLAGS(a0) = AVf_REIFY;
 169     }
 170     else {
 171         av_store(pad, 0, Nullsv);
 172     }
 173
 174     AvREAL_off(padlist);
 175     av_store(padlist, 0, (SV*)padname);
 176     av_store(padlist, 1, (SV*)pad);
 177
 178     /* ... then update state variables */
 179
 180     PL_comppad_name     = (AV*)(*av_fetch(padlist, 0, FALSE));
 181     PL_comppad          = (AV*)(*av_fetch(padlist, 1, FALSE));
 182     PL_curpad           = AvARRAY(PL_comppad);
 183
 184     if (! (flags & padnew_CLONE)) {
 185         PL_comppad_name_fill = 0;
 186         PL_min_intro_pending = 0;
 187         PL_padix             = 0;
 188         PL_cv_has_eval       = 0;
 189     }
 190
 191     DEBUG_X(PerlIO_printf(Perl_debug_log,
 192           "Pad 0x%"UVxf"[0x%"UVxf"] new:       compcv=0x%"UVxf
 193               " name=0x%"UVxf" flags=0x%"UVxf"\n",
 194           PTR2UV(PL_comppad), PTR2UV(PL_curpad), PTR2UV(PL_compcv),
 195               PTR2UV(padname), (UV)flags
 196         )
 197     );
 198
 199     return (PADLIST*)padlist;
 200 }
 201
 202 /*
 203 =for apidoc pad_undef
 204
 205 Free the padlist associated with a CV.
 206 If parts of it happen to be current, we null the relevant
 207 PL_*pad* global vars so that we don't have any dangling references left.
 208 We also repoint the CvOUTSIDE of any about-to-be-orphaned
 209 inner subs to the outer of this cv.
 210
 211 (This function should really be called pad_free, but the name was already
 212 taken)
 213
 214 =cut
 215 */
 216
 217 void
 218 Perl_pad_undef(pTHX_ CV* cv)
 219 {
 220     I32 ix;
 221     PADLIST *padlist = CvPADLIST(cv);
 222
 223     if (!padlist)
 224         return;
 225     if (!SvREFCNT(CvPADLIST(cv))) /* may be during global destruction */
 226         return;
 227
 228     DEBUG_X(PerlIO_printf(Perl_debug_log,
 229           "Pad undef: cv=0x%"UVxf" padlist=0x%"UVxf"\n",
 230             PTR2UV(cv), PTR2UV(padlist))
 231     );
 232
 233     /* detach any '&' anon children in the pad; if afterwards they
 234      * are still live, fix up their CvOUTSIDEs to point to our outside,
 235      * bypassing us. */
 236     /* XXX DAPM for efficiency, we should only do this if we know we have
 237      * children, or integrate this loop with general cleanup */
 238
 239     if (!PL_dirty) { /* don't bother during global destruction */
 240         CV *outercv = CvOUTSIDE(cv);
 241         U32 seq = CvOUTSIDE_SEQ(cv);
 242         AV *comppad_name = (AV*)AvARRAY(padlist)[0];
 243         SV **namepad = AvARRAY(comppad_name);
 244         AV *comppad = (AV*)AvARRAY(padlist)[1];
 245         SV **curpad = AvARRAY(comppad);
 246         for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
 247             SV *namesv = namepad[ix];
 248             if (namesv && namesv != &PL_sv_undef
 249                 && *SvPVX(namesv) == '&')
 250             {
 251                 CV *innercv = (CV*)curpad[ix];
 252                 namepad[ix] = Nullsv;
 253                 SvREFCNT_dec(namesv);
 254                 curpad[ix] = Nullsv;
 255                 SvREFCNT_dec(innercv);
 256                 if (SvREFCNT(innercv) /* in use, not just a prototype */
 257                     && CvOUTSIDE(innercv) == cv)
 258                 {
 259                     assert(CvWEAKOUTSIDE(innercv));
 260                     CvWEAKOUTSIDE_off(innercv);
 261                     CvOUTSIDE(innercv) = outercv;
 262                     CvOUTSIDE_SEQ(innercv) = seq;
 263                     SvREFCNT_inc(outercv);
 264                 }
 265             }
 266         }
 267     }
 268
 269     ix = AvFILLp(padlist);
 270     while (ix >= 0) {
 271         SV* sv = AvARRAY(padlist)[ix--];
 272         if (!sv)
 273             continue;
 274         if (sv == (SV*)PL_comppad_name)
 275             PL_comppad_name = Nullav;
 276         else if (sv == (SV*)PL_comppad) {
 277             PL_comppad = Null(PAD*);
 278             PL_curpad = Null(SV**);
 279         }
 280         SvREFCNT_dec(sv);
 281     }
 282     SvREFCNT_dec((SV*)CvPADLIST(cv));
 283     CvPADLIST(cv) = Null(PADLIST*);
 284 }
 285
 286
 287
 288
 289 /*
 290 =for apidoc pad_add_name
 291
 292 Create a new name and associated PADMY SV in the current pad; return the
 293 offset.
 294 If C<typestash> is valid, the name is for a typed lexical; set the
 295 name's stash to that value.
 296 If C<ourstash> is valid, it's an our lexical, set the name's
 297 GvSTASH to that value
 298
 299 If fake, it means we're cloning an existing entry
 300
 301 =cut
 302 */
 303
 304 PADOFFSET
 305 Perl_pad_add_name(pTHX_ char *name, HV* typestash, HV* ourstash, bool fake)
 306 {
 307     PADOFFSET offset = pad_alloc(OP_PADSV, SVs_PADMY);
 308     SV* namesv = NEWSV(1102, 0);
 309
 310     ASSERT_CURPAD_ACTIVE("pad_add_name");
 311
 312
 313     sv_upgrade(namesv, ourstash ? SVt_PVGV : typestash ? SVt_PVMG : SVt_PVNV);
 314     sv_setpv(namesv, name);
 315
 316     if (typestash) {
 317         SvFLAGS(namesv) |= SVpad_TYPED;
 318         SvSTASH(namesv) = (HV*)SvREFCNT_inc((SV*) typestash);
 319     }
 320     if (ourstash) {
 321         SvFLAGS(namesv) |= SVpad_OUR;
 322         GvSTASH(namesv) = (HV*)SvREFCNT_inc((SV*) ourstash);
 323     }
 324
 325     av_store(PL_comppad_name, offset, namesv);
 326     if (fake) {
 327         SvFAKE_on(namesv);
 328         DEBUG_Xv(PerlIO_printf(Perl_debug_log,
 329             "Pad addname: %ld \"%s\" FAKE\n", (long)offset, name));
 330     }
 331     else {
 332         /* not yet introduced */
 333         SvNVX(namesv) = (NV)PAD_MAX;    /* min */
 334         SvIVX(namesv) = 0;              /* max */
 335
 336         if (!PL_min_intro_pending)
 337             PL_min_intro_pending = offset;
 338         PL_max_intro_pending = offset;
 339         /* if it's not a simple scalar, replace with an AV or HV */
 340         /* XXX DAPM since slot has been allocated, replace
 341          * av_store with PL_curpad[offset] ? */
 342         if (*name == '@')
 343             av_store(PL_comppad, offset, (SV*)newAV());
 344         else if (*name == '%')
 345             av_store(PL_comppad, offset, (SV*)newHV());
 346         SvPADMY_on(PL_curpad[offset]);
 347         DEBUG_Xv(PerlIO_printf(Perl_debug_log,
 348             "Pad addname: %ld \"%s\" new lex=0x%"UVxf"\n",
 349             (long)offset, name, PTR2UV(PL_curpad[offset])));
 350     }
 351
 352     return offset;
 353 }
 354
 355
 356
 357
 358 /*
 359 =for apidoc pad_alloc
 360
 361 Allocate a new my or tmp pad entry. For a my, simply push a null SV onto
 362 the end of PL_comppad, but for a tmp, scan the pad from PL_padix upwards
 363 for a slot which has no name and and no active value.
 364
 365 =cut
 366 */
 367
 368 /* XXX DAPM integrate alloc(), add_name() and add_anon(),
 369  * or at least rationalise ??? */
 370
 371
 372 PADOFFSET
 373 Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype)
 374 {
 375     SV *sv;
 376     I32 retval;
 377
 378     ASSERT_CURPAD_ACTIVE("pad_alloc");
 379
 380     if (AvARRAY(PL_comppad) != PL_curpad)
 381         Perl_croak(aTHX_ "panic: pad_alloc");
 382     if (PL_pad_reset_pending)
 383         pad_reset();
 384     if (tmptype & SVs_PADMY) {
 385         sv = *av_fetch(PL_comppad, AvFILLp(PL_comppad) + 1, TRUE);
 386         retval = AvFILLp(PL_comppad);
 387     }
 388     else {
 389         SV **names = AvARRAY(PL_comppad_name);
 390         SSize_t names_fill = AvFILLp(PL_comppad_name);
 391         for (;;) {
 392             /*
 393              * "foreach" index vars temporarily become aliases to non-"my"
 394              * values.  Thus we must skip, not just pad values that are
 395              * marked as current pad values, but also those with names.
 396              */
 397             /* HVDS why copy to sv here? we don't seem to use it */
 398             if (++PL_padix <= names_fill &&
 399                    (sv = names[PL_padix]) && sv != &PL_sv_undef)
 400                 continue;
 401             sv = *av_fetch(PL_comppad, PL_padix, TRUE);
 402             if (!(SvFLAGS(sv) & (SVs_PADTMP | SVs_PADMY)) &&
 403                 !IS_PADGV(sv) && !IS_PADCONST(sv))
 404                 break;
 405         }
 406         retval = PL_padix;
 407     }
 408     SvFLAGS(sv) |= tmptype;
 409     PL_curpad = AvARRAY(PL_comppad);
 410
 411     DEBUG_X(PerlIO_printf(Perl_debug_log,
 412           "Pad 0x%"UVxf"[0x%"UVxf"] alloc:   %ld for %s\n",
 413           PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long) retval,
 414           PL_op_name[optype]));
 415     return (PADOFFSET)retval;
 416 }
 417
 418 /*
 419 =for apidoc pad_add_anon
 420
 421 Add an anon code entry to the current compiling pad
 422
 423 =cut
 424 */
 425
 426 PADOFFSET
 427 Perl_pad_add_anon(pTHX_ SV* sv, OPCODE op_type)
 428 {
 429     PADOFFSET ix;
 430     SV* name;
 431
 432     name = NEWSV(1106, 0);
 433     sv_upgrade(name, SVt_PVNV);
 434     sv_setpvn(name, "&", 1);
 435     SvIVX(name) = -1;
 436     SvNVX(name) = 1;
 437     ix = pad_alloc(op_type, SVs_PADMY);
 438     av_store(PL_comppad_name, ix, name);
 439     /* XXX DAPM use PL_curpad[] ? */
 440     av_store(PL_comppad, ix, sv);
 441     SvPADMY_on(sv);
 442
 443     /* to avoid ref loops, we never have parent + child referencing each
 444      * other simultaneously */
 445     if (CvOUTSIDE((CV*)sv)) {
 446         assert(!CvWEAKOUTSIDE((CV*)sv));
 447         CvWEAKOUTSIDE_on((CV*)sv);
 448         SvREFCNT_dec(CvOUTSIDE((CV*)sv));
 449     }
 450     return ix;
 451 }
 452
 453
 454
 455 /*
 456 =for apidoc pad_check_dup
 457
 458 Check for duplicate declarations: report any of:
 459      * a my in the current scope with the same name;
 460      * an our (anywhere in the pad) with the same name and the same stash
 461        as C<ourstash>
 462 C<is_our> indicates that the name to check is an 'our' declaration
 463
 464 =cut
 465 */
 466
 467 /* XXX DAPM integrate this into pad_add_name ??? */
 468
 469 void
 470 Perl_pad_check_dup(pTHX_ char *name, bool is_our, HV *ourstash)
 471 {
 472     SV          **svp, *sv;
 473     PADOFFSET   top, off;
 474
 475     ASSERT_CURPAD_ACTIVE("pad_check_dup");
 476     if (!ckWARN(WARN_MISC) || AvFILLp(PL_comppad_name) < 0)
 477         return; /* nothing to check */
 478
 479     svp = AvARRAY(PL_comppad_name);
 480     top = AvFILLp(PL_comppad_name);
 481     /* check the current scope */
 482     /* XXX DAPM - why the (I32) cast - shouldn't we ensure they're the same
 483      * type ? */
 484     for (off = top; (I32)off > PL_comppad_name_floor; off--) {
 485         if ((sv = svp[off])
 486             && sv != &PL_sv_undef
 487             && !SvFAKE(sv)
 488             && (SvIVX(sv) == PAD_MAX || SvIVX(sv) == 0)
 489             && (!is_our
 490                 || ((SvFLAGS(sv) & SVpad_OUR) && GvSTASH(sv) == ourstash))
 491             && strEQ(name, SvPVX(sv)))
 492         {
 493             Perl_warner(aTHX_ packWARN(WARN_MISC),
 494                 "\"%s\" variable %s masks earlier declaration in same %s",
 495                 (is_our ? "our" : "my"),
 496                 name,
 497                 (SvIVX(sv) == PAD_MAX ? "scope" : "statement"));
 498             --off;
 499             break;
 500         }
 501     }
 502     /* check the rest of the pad */
 503     if (is_our) {
 504         do {
 505             if ((sv = svp[off])
 506                 && sv != &PL_sv_undef
 507                 && !SvFAKE(sv)
 508                 && (SvIVX(sv) == PAD_MAX || SvIVX(sv) == 0)
 509                 && ((SvFLAGS(sv) & SVpad_OUR) && GvSTASH(sv) == ourstash)
 510                 && strEQ(name, SvPVX(sv)))
 511             {
 512                 Perl_warner(aTHX_ packWARN(WARN_MISC),
 513                     "\"our\" variable %s redeclared", name);
 514                 Perl_warner(aTHX_ packWARN(WARN_MISC),
 515                     "\t(Did you mean \"local\" instead of \"our\"?)\n");
 516                 break;
 517             }
 518         } while ( off-- > 0 );
 519     }
 520 }
 521
 522
 523 /*
 524 =for apidoc pad_findmy
 525
 526 Given a lexical name, try to find its offset, first in the current pad,
 527 or failing that, in the pads of any lexically enclosing subs (including
 528 the complications introduced by eval). If the name is found in an outer pad,
 529 then a fake entry is added to the current pad.
 530 Returns the offset in the current pad, or NOT_IN_PAD on failure.
 531
 532 =cut
 533 */
 534
 535 PADOFFSET
 536 Perl_pad_findmy(pTHX_ char *name)
 537 {
 538     SV *out_sv;
 539     int out_flags;
 540
 541     return pad_findlex(name, PL_compcv, PL_cop_seqmax, 1,
 542                 Null(SV**), &out_sv, &out_flags);
 543 }
 544
 545
 546 /*
 547 =for apidoc pad_findlex
 548
 549 Find a named lexical anywhere in a chain of nested pads. Add fake entries
 550 in the inner pads if it's found in an outer one.
 551
 552 Returns the offset in the bottom pad of the lex or the fake lex.
 553 cv is the CV in which to start the search, and seq is the current cop_seq
 554 to match against. If warn is true, print appropriate warnings.  The out_*
 555 vars return values, and so are pointers to where the returned values
 556 should be stored. out_capture, if non-null, requests that the innermost
 557 instance of the lexical is captured; out_name_sv is set to the innermost
 558 matched namesv or fake namesv; out_flags returns the flags normally
 559 associated with the IVX field of a fake namesv.
 560
 561 Note that pad_findlex() is recursive; it recurses up the chain of CVs,
 562 then comes back down, adding fake entries as it goes. It has to be this way
 563 because fake namesvs in anon protoypes have to store in NVX the index into
 564 the parent pad.
 565
 566 =cut
 567 */
 568
 569 /* Flags set in the SvIVX field of FAKE namesvs */
 570
 571 #define PAD_FAKELEX_ANON   1 /* the lex is declared in an ANON, or ... */
 572 #define PAD_FAKELEX_MULTI  2 /* the lex can be instantiated multiple times */
 573
 574 /* the CV has finished being compiled. This is not a sufficient test for
 575  * all CVs (eg XSUBs), but suffices for the CVs found in a lexical chain */
 576 #define CvCOMPILED(cv)  CvROOT(cv)
 577
 578 /* the CV does late binding of its lexicals */
 579 #define CvLATE(cv) (CvANON(cv) || SvTYPE(cv) == SVt_PVFM)
 580
 581
 582 STATIC PADOFFSET
 583 S_pad_findlex(pTHX_ char *name, CV* cv, U32 seq, int warn,
 584         SV** out_capture, SV** out_name_sv, int *out_flags)
 585 {
 586     I32 offset, new_offset;
 587     SV *new_capture;
 588     SV **new_capturep;
 589     AV *padlist = CvPADLIST(cv);
 590
 591     *out_flags = 0;
 592
 593     DEBUG_Xv(PerlIO_printf(Perl_debug_log,
 594         "Pad findlex cv=0x%"UVxf" searching \"%s\" seq=%d%s\n",
 595         PTR2UV(cv), name, (int)seq, out_capture ? " capturing" : "" ));
 596
 597     /* first, search this pad */
 598
 599     if (padlist) { /* not an undef CV */
 600         I32 fake_offset = 0;
 601         AV *nameav = (AV*)AvARRAY(padlist)[0];
 602         SV **name_svp = AvARRAY(nameav);
 603
 604         for (offset = AvFILLp(nameav); offset > 0; offset--) {
 605             SV *namesv = name_svp[offset];
 606             if (namesv && namesv != &PL_sv_undef
 607                     && strEQ(SvPVX(namesv), name))
 608             {
 609                 if (SvFAKE(namesv))
 610                     fake_offset = offset; /* in case we don't find a real one */
 611                 else if (  seq >  (U32)I_32(SvNVX(namesv))      /* min */
 612                         && seq <= (U32)SvIVX(namesv))           /* max */
 613                     break;
 614             }
 615         }
 616
 617         if (offset > 0 || fake_offset > 0 ) { /* a match! */
 618             if (offset > 0) { /* not fake */
 619                 fake_offset = 0;
 620                 *out_name_sv = name_svp[offset]; /* return the namesv */
 621
 622                 /* set PAD_FAKELEX_MULTI if this lex can have multiple
 623                  * instances. For now, we just test !CvUNIQUE(cv), but
 624                  * ideally, we should detect my's declared within loops
 625                  * etc - this would allow a wider range of 'not stayed
 626                  * shared' warnings. We also treated alreadly-compiled
 627                  * lexes as not multi as viewed from evals. */
 628
 629                 *out_flags = CvANON(cv) ?
 630                         PAD_FAKELEX_ANON :
 631                             (!CvUNIQUE(cv) && ! CvCOMPILED(cv))
 632                                 ? PAD_FAKELEX_MULTI : 0;
 633
 634                 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
 635                     "Pad findlex cv=0x%"UVxf" matched: offset=%ld (%ld,%ld)\n",
 636                     PTR2UV(cv), (long)offset, (long)I_32(SvNVX(*out_name_sv)),
 637                     (long)SvIVX(*out_name_sv)));
 638             }
 639             else { /* fake match */
 640                 offset = fake_offset;
 641                 *out_name_sv = name_svp[offset]; /* return the namesv */
 642                 *out_flags = SvIVX(*out_name_sv);
 643                 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
 644                     "Pad findlex cv=0x%"UVxf" matched: offset=%ld flags=0x%x index=%lu\n",
 645                     PTR2UV(cv), (long)offset, (unsigned long)*out_flags,
 646                         (unsigned long)SvNVX(*out_name_sv)
 647                 ));
 648             }
 649
 650             /* return the lex? */
 651
 652             if (out_capture) {
 653
 654                 /* our ? */
 655                 if ((SvFLAGS(*out_name_sv) & SVpad_OUR)) {
 656                     *out_capture = Nullsv;
 657                     return offset;
 658                 }
 659
 660                 /* trying to capture from an anon prototype? */
 661                 if (CvCOMPILED(cv)
 662                         ? CvANON(cv) && CvCLONE(cv) && !CvCLONED(cv)
 663                         : *out_flags & PAD_FAKELEX_ANON)
 664                 {
 665                     if (warn && ckWARN(WARN_CLOSURE))
 666                         Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
 667                             "Variable \"%s\" is not available", name);
 668                     *out_capture = Nullsv;
 669                 }
 670
 671                 /* real value */
 672                 else {
 673                     int newwarn = warn;
 674                     if (!CvCOMPILED(cv) && (*out_flags & PAD_FAKELEX_MULTI)
 675                          && warn && ckWARN(WARN_CLOSURE)) {
 676                         newwarn = 0;
 677                         Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
 678                             "Variable \"%s\" will not stay shared", name);
 679                     }
 680
 681                     if (fake_offset && CvANON(cv)
 682                             && CvCLONE(cv) &&!CvCLONED(cv))
 683                     {
 684                         SV *n;
 685                         /* not yet caught - look further up */
 686                         DEBUG_Xv(PerlIO_printf(Perl_debug_log,
 687                             "Pad findlex cv=0x%"UVxf" chasing lex in outer pad\n",
 688                             PTR2UV(cv)));
 689                         n = *out_name_sv;
 690                         pad_findlex(name, CvOUTSIDE(cv), CvOUTSIDE_SEQ(cv),
 691                             newwarn, out_capture, out_name_sv, out_flags);
 692                         *out_name_sv = n;
 693                         return offset;
 694                     }
 695
 696                     *out_capture = AvARRAY((AV*)AvARRAY(padlist)[
 697                                     CvDEPTH(cv) ? CvDEPTH(cv) : 1])[offset];
 698                     DEBUG_Xv(PerlIO_printf(Perl_debug_log,
 699                         "Pad findlex cv=0x%"UVxf" found lex=0x%"UVxf"\n",
 700                         PTR2UV(cv), *out_capture));
 701
 702                     if (SvPADSTALE(*out_capture)) {
 703                         if (ckWARN(WARN_CLOSURE))
 704                             Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
 705                                 "Variable \"%s\" is not available", name);
 706                         *out_capture = Nullsv;
 707                     }
 708                 }
 709                 if (!*out_capture) {
 710                     if (*name == '@')
 711                         *out_capture = sv_2mortal((SV*)newAV());
 712                     else if (*name == '%')
 713                         *out_capture = sv_2mortal((SV*)newHV());
 714                     else
 715                         *out_capture = sv_newmortal();
 716                 }
 717             }
 718
 719             return offset;
 720         }
 721     }
 722
 723     /* it's not in this pad - try above */
 724
 725     if (!CvOUTSIDE(cv))
 726         return NOT_IN_PAD;
 727
 728     /* out_capture non-null means caller wants us to capture lex; in
 729      * addition we capture ourselves unless it's an ANON/format */
 730     new_capturep = out_capture ? out_capture :
 731                 CvLATE(cv) ? Null(SV**) : &new_capture;
 732
 733     offset = pad_findlex(name, CvOUTSIDE(cv), CvOUTSIDE_SEQ(cv), 1,
 734                 new_capturep, out_name_sv, out_flags);
 735     if (offset == NOT_IN_PAD)
 736         return NOT_IN_PAD;
 737
 738     /* found in an outer CV. Add appropriate fake entry to this pad */
 739
 740     /* don't add new fake entries (via eval) to CVs that we have already
 741      * finished compiling, or to undef CVs */
 742     if (CvCOMPILED(cv) || !padlist)
 743         return 0; /* this dummy (and invalid) value isnt used by the caller */
 744
 745     {
 746         SV *new_namesv;
 747         AV *ocomppad_name = PL_comppad_name;
 748         PAD *ocomppad = PL_comppad;
 749         PL_comppad_name = (AV*)AvARRAY(padlist)[0];
 750         PL_comppad = (AV*)AvARRAY(padlist)[1];
 751         PL_curpad = AvARRAY(PL_comppad);
 752
 753         new_offset = pad_add_name(
 754             SvPVX(*out_name_sv),
 755             (SvFLAGS(*out_name_sv) & SVpad_TYPED)
 756                     ? SvSTASH(*out_name_sv) : Nullhv,
 757             (SvFLAGS(*out_name_sv) & SVpad_OUR)
 758                     ? GvSTASH(*out_name_sv) : Nullhv,
 759             1  /* fake */
 760         );
 761
 762         new_namesv = AvARRAY(PL_comppad_name)[new_offset];
 763         SvIVX(new_namesv) = *out_flags;
 764
 765         SvNVX(new_namesv) = (NV)0;
 766         if (SvFLAGS(new_namesv) & SVpad_OUR) {
 767            /* do nothing */
 768         }
 769         else if (CvLATE(cv)) {
 770             /* delayed creation - just note the offset within parent pad */
 771             SvNVX(new_namesv) = (NV)offset;
 772             CvCLONE_on(cv);
 773         }
 774         else {
 775             /* immediate creation - capture outer value right now */
 776             av_store(PL_comppad, new_offset, SvREFCNT_inc(*new_capturep));
 777             DEBUG_Xv(PerlIO_printf(Perl_debug_log,
 778                 "Pad findlex cv=0x%"UVxf" saved captured sv 0x%"UVxf" at offset %ld\n",
 779                 PTR2UV(cv), PTR2UV(*new_capturep), (long)new_offset));
 780         }
 781         *out_name_sv = new_namesv;
 782         *out_flags = SvIVX(new_namesv);
 783
 784         PL_comppad_name = ocomppad_name;
 785         PL_comppad = ocomppad;
 786         PL_curpad = ocomppad ? AvARRAY(ocomppad) : Null(SV **);
 787     }
 788     return new_offset;
 789 }
 790
 791
 792 /*
 793 =for apidoc pad_sv
 794
 795 Get the value at offset po in the current pad.
 796 Use macro PAD_SV instead of calling this function directly.
 797
 798 =cut
 799 */
 800
 801
 802 SV *
 803 Perl_pad_sv(pTHX_ PADOFFSET po)
 804 {
 805     ASSERT_CURPAD_ACTIVE("pad_sv");
 806
 807     if (!po)
 808         Perl_croak(aTHX_ "panic: pad_sv po");
 809     DEBUG_X(PerlIO_printf(Perl_debug_log,
 810         "Pad 0x%"UVxf"[0x%"UVxf"] sv:      %ld sv=0x%"UVxf"\n",
 811         PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po, PTR2UV(PL_curpad[po]))
 812     );
 813     return PL_curpad[po];
 814 }
 815
 816
 817 /*
 818 =for apidoc pad_setsv
 819
 820 Set the entry at offset po in the current pad to sv.
 821 Use the macro PAD_SETSV() rather than calling this function directly.
 822
 823 =cut
 824 */
 825
 826 #ifdef DEBUGGING
 827 void
 828 Perl_pad_setsv(pTHX_ PADOFFSET po, SV* sv)
 829 {
 830     ASSERT_CURPAD_ACTIVE("pad_setsv");
 831
 832     DEBUG_X(PerlIO_printf(Perl_debug_log,
 833         "Pad 0x%"UVxf"[0x%"UVxf"] setsv:   %ld sv=0x%"UVxf"\n",
 834         PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po, PTR2UV(sv))
 835     );
 836     PL_curpad[po] = sv;
 837 }
 838 #endif
 839
 840
 841
 842 /*
 843 =for apidoc pad_block_start
 844
 845 Update the pad compilation state variables on entry to a new block
 846
 847 =cut
 848 */
 849
 850 /* XXX DAPM perhaps:
 851  *      - integrate this in general state-saving routine ???
 852  *      - combine with the state-saving going on in pad_new ???
 853  *      - introduce a new SAVE type that does all this in one go ?
 854  */
 855
 856 void
 857 Perl_pad_block_start(pTHX_ int full)
 858 {
 859     ASSERT_CURPAD_ACTIVE("pad_block_start");
 860     SAVEI32(PL_comppad_name_floor);
 861     PL_comppad_name_floor = AvFILLp(PL_comppad_name);
 862     if (full)
 863         PL_comppad_name_fill = PL_comppad_name_floor;
 864     if (PL_comppad_name_floor < 0)
 865         PL_comppad_name_floor = 0;
 866     SAVEI32(PL_min_intro_pending);
 867     SAVEI32(PL_max_intro_pending);
 868     PL_min_intro_pending = 0;
 869     SAVEI32(PL_comppad_name_fill);
 870     SAVEI32(PL_padix_floor);
 871     PL_padix_floor = PL_padix;
 872     PL_pad_reset_pending = FALSE;
 873 }
 874
 875
 876 /*
 877 =for apidoc intro_my
 878
 879 "Introduce" my variables to visible status.
 880
 881 =cut
 882 */
 883
 884 U32
 885 Perl_intro_my(pTHX)
 886 {
 887     SV **svp;
 888     SV *sv;
 889     I32 i;
 890
 891     ASSERT_CURPAD_ACTIVE("intro_my");
 892     if (! PL_min_intro_pending)
 893         return PL_cop_seqmax;
 894
 895     svp = AvARRAY(PL_comppad_name);
 896     for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
 897         if ((sv = svp[i]) && sv != &PL_sv_undef
 898                 && !SvFAKE(sv) && !SvIVX(sv))
 899         {
 900             SvIVX(sv) = PAD_MAX;        /* Don't know scope end yet. */
 901             SvNVX(sv) = (NV)PL_cop_seqmax;
 902             DEBUG_Xv(PerlIO_printf(Perl_debug_log,
 903                 "Pad intromy: %ld \"%s\", (%ld,%ld)\n",
 904                 (long)i, SvPVX(sv),
 905                 (long)I_32(SvNVX(sv)), (long)SvIVX(sv))
 906             );
 907         }
 908     }
 909     PL_min_intro_pending = 0;
 910     PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
 911     DEBUG_Xv(PerlIO_printf(Perl_debug_log,
 912                 "Pad intromy: seq -> %ld\n", (long)(PL_cop_seqmax+1)));
 913
 914     return PL_cop_seqmax++;
 915 }
 916
 917 /*
 918 =for apidoc pad_leavemy
 919
 920 Cleanup at end of scope during compilation: set the max seq number for
 921 lexicals in this scope and warn of any lexicals that never got introduced.
 922
 923 =cut
 924 */
 925
 926 void
 927 Perl_pad_leavemy(pTHX)
 928 {
 929     I32 off;
 930     SV **svp = AvARRAY(PL_comppad_name);
 931     SV *sv;
 932
 933     PL_pad_reset_pending = FALSE;
 934
 935     ASSERT_CURPAD_ACTIVE("pad_leavemy");
 936     if (PL_min_intro_pending && PL_comppad_name_fill < PL_min_intro_pending) {
 937         for (off = PL_max_intro_pending; off >= PL_min_intro_pending; off--) {
 938             if ((sv = svp[off]) && sv != &PL_sv_undef
 939                     && !SvFAKE(sv) && ckWARN_d(WARN_INTERNAL))
 940                 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
 941                                         "%"SVf" never introduced", sv);
 942         }
 943     }
 944     /* "Deintroduce" my variables that are leaving with this scope. */
 945     for (off = AvFILLp(PL_comppad_name); off > PL_comppad_name_fill; off--) {
 946         if ((sv = svp[off]) && sv != &PL_sv_undef
 947                 && !SvFAKE(sv) && SvIVX(sv) == PAD_MAX)
 948         {
 949             SvIVX(sv) = PL_cop_seqmax;
 950             DEBUG_Xv(PerlIO_printf(Perl_debug_log,
 951                 "Pad leavemy: %ld \"%s\", (%ld,%ld)\n",
 952                 (long)off, SvPVX(sv),
 953                 (long)I_32(SvNVX(sv)), (long)SvIVX(sv))
 954             );
 955         }
 956     }
 957     PL_cop_seqmax++;
 958     DEBUG_Xv(PerlIO_printf(Perl_debug_log,
 959             "Pad leavemy: seq = %ld\n", (long)PL_cop_seqmax));
 960 }
 961
 962
 963 /*
 964 =for apidoc pad_swipe
 965
 966 Abandon the tmp in the current pad at offset po and replace with a
 967 new one.
 968
 969 =cut
 970 */
 971
 972 void
 973 Perl_pad_swipe(pTHX_ PADOFFSET po, bool refadjust)
 974 {
 975     ASSERT_CURPAD_LEGAL("pad_swipe");
 976     if (!PL_curpad)
 977         return;
 978     if (AvARRAY(PL_comppad) != PL_curpad)
 979         Perl_croak(aTHX_ "panic: pad_swipe curpad");
 980     if (!po)
 981         Perl_croak(aTHX_ "panic: pad_swipe po");
 982
 983     DEBUG_X(PerlIO_printf(Perl_debug_log,
 984                 "Pad 0x%"UVxf"[0x%"UVxf"] swipe:   %ld\n",
 985                 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po));
 986
 987     if (PL_curpad[po])
 988         SvPADTMP_off(PL_curpad[po]);
 989     if (refadjust)
 990         SvREFCNT_dec(PL_curpad[po]);
 991
 992     PL_curpad[po] = NEWSV(1107,0);
 993     SvPADTMP_on(PL_curpad[po]);
 994     if ((I32)po < PL_padix)
 995         PL_padix = po - 1;
 996 }
 997
 998
 999 /*
1000 =for apidoc pad_reset
1001
1002 Mark all the current temporaries for reuse
1003
1004 =cut
1005 */
1006
1007 /* XXX pad_reset() is currently disabled because it results in serious bugs.
1008  * It causes pad temp TARGs to be shared between OPs. Since TARGs are pushed
1009  * on the stack by OPs that use them, there are several ways to get an alias
1010  * to  a shared TARG.  Such an alias will change randomly and unpredictably.
1011  * We avoid doing this until we can think of a Better Way.
1012  * GSAR 97-10-29 */
1013 void
1014 Perl_pad_reset(pTHX)
1015 {
1016 #ifdef USE_BROKEN_PAD_RESET
1017     register I32 po;
1018
1019     if (AvARRAY(PL_comppad) != PL_curpad)
1020         Perl_croak(aTHX_ "panic: pad_reset curpad");
1021
1022     DEBUG_X(PerlIO_printf(Perl_debug_log,
1023             "Pad 0x%"UVxf"[0x%"UVxf"] reset:     padix %ld -> %ld",
1024             PTR2UV(PL_comppad), PTR2UV(PL_curpad),
1025                 (long)PL_padix, (long)PL_padix_floor
1026             )
1027     );
1028
1029     if (!PL_tainting) { /* Can't mix tainted and non-tainted temporaries. */
1030         for (po = AvMAX(PL_comppad); po > PL_padix_floor; po--) {
1031             if (PL_curpad[po] && !SvIMMORTAL(PL_curpad[po]))
1032                 SvPADTMP_off(PL_curpad[po]);
1033         }
1034         PL_padix = PL_padix_floor;
1035     }
1036 #endif
1037     PL_pad_reset_pending = FALSE;
1038 }
1039
1040
1041 /*
1042 =for apidoc pad_tidy
1043
1044 Tidy up a pad after we've finished compiling it:
1045     * remove most stuff from the pads of anonsub prototypes;
1046     * give it a @_;
1047     * mark tmps as such.
1048
1049 =cut
1050 */
1051
1052 /* XXX DAPM surely most of this stuff should be done properly
1053  * at the right time beforehand, rather than going around afterwards
1054  * cleaning up our mistakes ???
1055  */
1056
1057 void
1058 Perl_pad_tidy(pTHX_ padtidy_type type)
1059 {
1060     PADOFFSET ix;
1061     CV *cv;
1062
1063     ASSERT_CURPAD_ACTIVE("pad_tidy");
1064
1065     /* If this CV has had any 'eval-capable' ops planted in it
1066      * (ie it contains eval '...', //ee, /$var/ or /(?{..})/), Then any
1067      * anon prototypes in the chain of CVs should be marked as cloneable,
1068      * so that for example the eval's CV in C<< sub { eval '$x' } >> gets
1069      * the right CvOUTSIDE.
1070      * If running with -d, *any* sub may potentially have an eval
1071      * excuted within it.
1072      */
1073
1074     if (PL_cv_has_eval || PL_perldb) {
1075         for (cv = PL_compcv ;cv; cv = CvOUTSIDE(cv)) {
1076             if (cv != PL_compcv && CvCOMPILED(cv))
1077                 break; /* no need to mark already-compiled code */
1078             if (CvANON(cv)) {
1079                 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1080                     "Pad clone on cv=0x%"UVxf"\n", PTR2UV(cv)));
1081                 CvCLONE_on(cv);
1082             }
1083         }
1084     }
1085
1086     /* extend curpad to match namepad */
1087     if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
1088         av_store(PL_comppad_name, AvFILLp(PL_comppad), Nullsv);
1089
1090     if (type == padtidy_SUBCLONE) {
1091         SV **namep = AvARRAY(PL_comppad_name);
1092
1093         for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1094             SV *namesv;
1095
1096             if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
1097                 continue;
1098             /*
1099              * The only things that a clonable function needs in its
1100              * pad are anonymous subs.
1101              * The rest are created anew during cloning.
1102              */
1103             if (!((namesv = namep[ix]) != Nullsv &&
1104                   namesv != &PL_sv_undef &&
1105                    *SvPVX(namesv) == '&'))
1106             {
1107                 SvREFCNT_dec(PL_curpad[ix]);
1108                 PL_curpad[ix] = Nullsv;
1109             }
1110         }
1111     }
1112     else if (type == padtidy_SUB) {
1113         /* XXX DAPM this same bit of code keeps appearing !!! Rationalise? */
1114         AV *av = newAV();                       /* Will be @_ */
1115         av_extend(av, 0);
1116         av_store(PL_comppad, 0, (SV*)av);
1117         AvFLAGS(av) = AVf_REIFY;
1118     }
1119
1120     /* XXX DAPM rationalise these two similar branches */
1121
1122     if (type == padtidy_SUB) {
1123         for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1124             if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
1125                 continue;
1126             if (!SvPADMY(PL_curpad[ix]))
1127                 SvPADTMP_on(PL_curpad[ix]);
1128         }
1129     }
1130     else if (type == padtidy_FORMAT) {
1131         for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1132             if (!SvPADMY(PL_curpad[ix]) && !SvIMMORTAL(PL_curpad[ix]))
1133                 SvPADTMP_on(PL_curpad[ix]);
1134         }
1135     }
1136     PL_curpad = AvARRAY(PL_comppad);
1137 }
1138
1139
1140 /*
1141 =for apidoc pad_free
1142
1143 Free the SV at offet po in the current pad.
1144
1145 =cut
1146 */
1147
1148 /* XXX DAPM integrate with pad_swipe ???? */
1149 void
1150 Perl_pad_free(pTHX_ PADOFFSET po)
1151 {
1152     ASSERT_CURPAD_LEGAL("pad_free");
1153     if (!PL_curpad)
1154         return;
1155     if (AvARRAY(PL_comppad) != PL_curpad)
1156         Perl_croak(aTHX_ "panic: pad_free curpad");
1157     if (!po)
1158         Perl_croak(aTHX_ "panic: pad_free po");
1159
1160     DEBUG_X(PerlIO_printf(Perl_debug_log,
1161             "Pad 0x%"UVxf"[0x%"UVxf"] free:    %ld\n",
1162             PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po)
1163     );
1164
1165     if (PL_curpad[po] && PL_curpad[po] != &PL_sv_undef) {
1166         SvPADTMP_off(PL_curpad[po]);
1167 #ifdef USE_ITHREADS
1168         /* SV could be a shared hash key (eg bugid #19022) */
1169         if (
1170 #ifdef PERL_COPY_ON_WRITE
1171             !SvIsCOW(PL_curpad[po])
1172 #else
1173             !SvFAKE(PL_curpad[po])
1174 #endif
1175             )
1176             SvREADONLY_off(PL_curpad[po]);      /* could be a freed constant */
1177 #endif
1178     }
1179     if ((I32)po < PL_padix)
1180         PL_padix = po - 1;
1181 }
1182
1183
1184
1185 /*
1186 =for apidoc do_dump_pad
1187
1188 Dump the contents of a padlist
1189
1190 =cut
1191 */
1192
1193 void
1194 Perl_do_dump_pad(pTHX_ I32 level, PerlIO *file, PADLIST *padlist, int full)
1195 {
1196     AV *pad_name;
1197     AV *pad;
1198     SV **pname;
1199     SV **ppad;
1200     SV *namesv;
1201     I32 ix;
1202
1203     if (!padlist) {
1204         return;
1205     }
1206     pad_name = (AV*)*av_fetch((AV*)padlist, 0, FALSE);
1207     pad = (AV*)*av_fetch((AV*)padlist, 1, FALSE);
1208     pname = AvARRAY(pad_name);
1209     ppad = AvARRAY(pad);
1210     Perl_dump_indent(aTHX_ level, file,
1211             "PADNAME = 0x%"UVxf"(0x%"UVxf") PAD = 0x%"UVxf"(0x%"UVxf")\n",
1212             PTR2UV(pad_name), PTR2UV(pname), PTR2UV(pad), PTR2UV(ppad)
1213     );
1214
1215     for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
1216         namesv = pname[ix];
1217         if (namesv && namesv == &PL_sv_undef) {
1218             namesv = Nullsv;
1219         }
1220         if (namesv) {
1221             if (SvFAKE(namesv))
1222                 Perl_dump_indent(aTHX_ level+1, file,
1223                     "%2d. 0x%"UVxf"<%lu> FAKE \"%s\" flags=0x%x index=%lu\n",
1224                     (int) ix,
1225                     PTR2UV(ppad[ix]),
1226                     (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
1227                     SvPVX(namesv),
1228                     (unsigned long)SvIVX(namesv),
1229                     (unsigned long)SvNVX(namesv)
1230
1231                 );
1232             else
1233                 Perl_dump_indent(aTHX_ level+1, file,
1234                     "%2d. 0x%"UVxf"<%lu> (%ld,%ld) \"%s\"\n",
1235                     (int) ix,
1236                     PTR2UV(ppad[ix]),
1237                     (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
1238                     (long)I_32(SvNVX(namesv)),
1239                     (long)SvIVX(namesv),
1240                     SvPVX(namesv)
1241                 );
1242         }
1243         else if (full) {
1244             Perl_dump_indent(aTHX_ level+1, file,
1245                 "%2d. 0x%"UVxf"<%lu>\n",
1246                 (int) ix,
1247                 PTR2UV(ppad[ix]),
1248                 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0)
1249             );
1250         }
1251     }
1252 }
1253
1254
1255
1256 /*
1257 =for apidoc cv_dump
1258
1259 dump the contents of a CV
1260
1261 =cut
1262 */
1263
1264 #ifdef DEBUGGING
1265 STATIC void
1266 S_cv_dump(pTHX_ CV *cv, char *title)
1267 {
1268     CV *outside = CvOUTSIDE(cv);
1269     AV* padlist = CvPADLIST(cv);
1270
1271     PerlIO_printf(Perl_debug_log,
1272                   "  %s: CV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
1273                   title,
1274                   PTR2UV(cv),
1275                   (CvANON(cv) ? "ANON"
1276                    : (SvTYPE(cv) == SVt_PVFM) ? "FORMAT"
1277                    : (cv == PL_main_cv) ? "MAIN"
1278                    : CvUNIQUE(cv) ? "UNIQUE"
1279                    : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
1280                   PTR2UV(outside),
1281                   (!outside ? "null"
1282                    : CvANON(outside) ? "ANON"
1283                    : (outside == PL_main_cv) ? "MAIN"
1284                    : CvUNIQUE(outside) ? "UNIQUE"
1285                    : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
1286
1287     PerlIO_printf(Perl_debug_log,
1288                     "    PADLIST = 0x%"UVxf"\n", PTR2UV(padlist));
1289     do_dump_pad(1, Perl_debug_log, padlist, 1);
1290 }
1291 #endif /* DEBUGGING */
1292
1293
1294
1295
1296
1297 /*
1298 =for apidoc cv_clone
1299
1300 Clone a CV: make a new CV which points to the same code etc, but which
1301 has a newly-created pad built by copying the prototype pad and capturing
1302 any outer lexicals.
1303
1304 =cut
1305 */
1306
1307 CV *
1308 Perl_cv_clone(pTHX_ CV *proto)
1309 {
1310     I32 ix;
1311     AV* protopadlist = CvPADLIST(proto);
1312     AV* protopad_name = (AV*)*av_fetch(protopadlist, 0, FALSE);
1313     AV* protopad = (AV*)*av_fetch(protopadlist, 1, FALSE);
1314     SV** pname = AvARRAY(protopad_name);
1315     SV** ppad = AvARRAY(protopad);
1316     I32 fname = AvFILLp(protopad_name);
1317     I32 fpad = AvFILLp(protopad);
1318     AV* comppadlist;
1319     CV* cv;
1320     SV** outpad;
1321     CV* outside;
1322     long depth;
1323
1324     assert(!CvUNIQUE(proto));
1325
1326     /* Since cloneable anon subs can be nested, CvOUTSIDE may point
1327      * to a prototype; we instead want the cloned parent who called us.
1328      * Note that in general for formats, CvOUTSIDE != find_runcv */
1329
1330     outside = CvOUTSIDE(proto);
1331     if (outside && CvCLONE(outside) && ! CvCLONED(outside))
1332         outside = find_runcv(NULL);
1333     depth = CvDEPTH(outside);
1334     assert(depth || SvTYPE(proto) == SVt_PVFM);
1335     if (!depth)
1336         depth = 1;
1337     assert(CvPADLIST(outside));
1338
1339     ENTER;
1340     SAVESPTR(PL_compcv);
1341
1342     cv = PL_compcv = (CV*)NEWSV(1104, 0);
1343     sv_upgrade((SV *)cv, SvTYPE(proto));
1344     CvFLAGS(cv) = CvFLAGS(proto) & ~(CVf_CLONE|CVf_WEAKOUTSIDE);
1345     CvCLONED_on(cv);
1346
1347 #ifdef USE_ITHREADS
1348     CvFILE(cv)          = CvXSUB(proto) ? CvFILE(proto)
1349                                         : savepv(CvFILE(proto));
1350 #else
1351     CvFILE(cv)          = CvFILE(proto);
1352 #endif
1353     CvGV(cv)            = CvGV(proto);
1354     CvSTASH(cv)         = CvSTASH(proto);
1355     CvROOT(cv)          = OpREFCNT_inc(CvROOT(proto));
1356     CvSTART(cv)         = CvSTART(proto);
1357     CvOUTSIDE(cv)       = (CV*)SvREFCNT_inc(outside);
1358     CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(proto);
1359
1360     if (SvPOK(proto))
1361         sv_setpvn((SV*)cv, SvPVX(proto), SvCUR(proto));
1362
1363     CvPADLIST(cv) = comppadlist = pad_new(padnew_CLONE|padnew_SAVE);
1364
1365     av_fill(PL_comppad, fpad);
1366     for (ix = fname; ix >= 0; ix--)
1367         av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
1368
1369     PL_curpad = AvARRAY(PL_comppad);
1370
1371     outpad = AvARRAY(AvARRAY(CvPADLIST(outside))[depth]);
1372
1373     for (ix = fpad; ix > 0; ix--) {
1374         SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
1375         SV *sv = Nullsv;
1376         if (namesv && namesv != &PL_sv_undef) { /* lexical */
1377             if (SvFAKE(namesv)) {   /* lexical from outside? */
1378                 sv = outpad[(I32)SvNVX(namesv)];
1379                 assert(sv);
1380                 /* formats may have an inactive parent */
1381                 if (SvTYPE(proto) == SVt_PVFM && SvPADSTALE(sv)) {
1382                     if (ckWARN(WARN_CLOSURE))
1383                         Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
1384                             "Variable \"%s\" is not available", SvPVX(namesv));
1385                     sv = Nullsv;
1386                 }
1387                 else {
1388                     assert(!SvPADSTALE(sv));
1389                     sv = SvREFCNT_inc(sv);
1390                 }
1391             }
1392             if (!sv) {
1393                 char *name = SvPVX(namesv);
1394                 if (*name == '&')
1395                     sv = SvREFCNT_inc(ppad[ix]);
1396                 else if (*name == '@')
1397                     sv = (SV*)newAV();
1398                 else if (*name == '%')
1399                     sv = (SV*)newHV();
1400                 else
1401                     sv = NEWSV(0, 0);
1402                 SvPADMY_on(sv);
1403             }
1404         }
1405         else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
1406             sv = SvREFCNT_inc(ppad[ix]);
1407         }
1408         else {
1409             sv = NEWSV(0, 0);
1410             SvPADTMP_on(sv);
1411         }
1412         PL_curpad[ix] = sv;
1413     }
1414
1415     DEBUG_Xv(
1416         PerlIO_printf(Perl_debug_log, "\nPad CV clone\n");
1417         cv_dump(outside, "Outside");
1418         cv_dump(proto,   "Proto");
1419         cv_dump(cv,      "To");
1420     );
1421
1422     LEAVE;
1423
1424     if (CvCONST(cv)) {
1425         /* Constant sub () { $x } closing over $x - see lib/constant.pm:
1426          * The prototype was marked as a candiate for const-ization,
1427          * so try to grab the current const value, and if successful,
1428          * turn into a const sub:
1429          */
1430         SV* const_sv = op_const_sv(CvSTART(cv), cv);
1431         if (const_sv) {
1432             SvREFCNT_dec(cv);
1433             cv = newCONSTSUB(CvSTASH(proto), 0, const_sv);
1434         }
1435         else {
1436             CvCONST_off(cv);
1437         }
1438     }
1439
1440     return cv;
1441 }
1442
1443
1444 /*
1445 =for apidoc pad_fixup_inner_anons
1446
1447 For any anon CVs in the pad, change CvOUTSIDE of that CV from
1448 old_cv to new_cv if necessary. Needed when a newly-compiled CV has to be
1449 moved to a pre-existing CV struct.
1450
1451 =cut
1452 */
1453
1454 void
1455 Perl_pad_fixup_inner_anons(pTHX_ PADLIST *padlist, CV *old_cv, CV *new_cv)
1456 {
1457     I32 ix;
1458     AV *comppad_name = (AV*)AvARRAY(padlist)[0];
1459     AV *comppad = (AV*)AvARRAY(padlist)[1];
1460     SV **namepad = AvARRAY(comppad_name);
1461     SV **curpad = AvARRAY(comppad);
1462     for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
1463         SV *namesv = namepad[ix];
1464         if (namesv && namesv != &PL_sv_undef
1465             && *SvPVX(namesv) == '&')
1466         {
1467             CV *innercv = (CV*)curpad[ix];
1468             assert(CvWEAKOUTSIDE(innercv));
1469             assert(CvOUTSIDE(innercv) == old_cv);
1470             CvOUTSIDE(innercv) = new_cv;
1471         }
1472     }
1473 }
1474
1475
1476 /*
1477 =for apidoc pad_push
1478
1479 Push a new pad frame onto the padlist, unless there's already a pad at
1480 this depth, in which case don't bother creating a new one.
1481 If has_args is true, give the new pad an @_ in slot zero.
1482
1483 =cut
1484 */
1485
1486 void
1487 Perl_pad_push(pTHX_ PADLIST *padlist, int depth, int has_args)
1488 {
1489     if (depth <= AvFILLp(padlist))
1490         return;
1491
1492     {
1493         SV** svp = AvARRAY(padlist);
1494         AV *newpad = newAV();
1495         SV **oldpad = AvARRAY(svp[depth-1]);
1496         I32 ix = AvFILLp((AV*)svp[1]);
1497         I32 names_fill = AvFILLp((AV*)svp[0]);
1498         SV** names = AvARRAY(svp[0]);
1499         SV* sv;
1500         for ( ;ix > 0; ix--) {
1501             if (names_fill >= ix && names[ix] != &PL_sv_undef) {
1502                 char *name = SvPVX(names[ix]);
1503                 if ((SvFLAGS(names[ix]) & SVf_FAKE) || *name == '&') {
1504                     /* outer lexical or anon code */
1505                     av_store(newpad, ix, SvREFCNT_inc(oldpad[ix]));
1506                 }
1507                 else {          /* our own lexical */
1508                     if (*name == '@')
1509                         av_store(newpad, ix, sv = (SV*)newAV());
1510                     else if (*name == '%')
1511                         av_store(newpad, ix, sv = (SV*)newHV());
1512                     else
1513                         av_store(newpad, ix, sv = NEWSV(0, 0));
1514                     SvPADMY_on(sv);
1515                 }
1516             }
1517             else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
1518                 av_store(newpad, ix, sv = SvREFCNT_inc(oldpad[ix]));
1519             }
1520             else {
1521                 /* save temporaries on recursion? */
1522                 av_store(newpad, ix, sv = NEWSV(0, 0));
1523                 SvPADTMP_on(sv);
1524             }
1525         }
1526         if (has_args) {
1527             AV* av = newAV();
1528             av_extend(av, 0);
1529             av_store(newpad, 0, (SV*)av);
1530             AvFLAGS(av) = AVf_REIFY;
1531         }
1532         av_store(padlist, depth, (SV*)newpad);
1533         AvFILLp(padlist) = depth;
1534     }
1535 }