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     I32 offset;
 541     AV *nameav;
 542     SV **name_svp;
 543
 544     offset =  pad_findlex(name, PL_compcv, PL_cop_seqmax, 1,
 545                 Null(SV**), &out_sv, &out_flags);
 546     if (offset != NOT_IN_PAD)
 547         return offset;
 548
 549     /* look for an our that's being introduced; this allows
 550      *    our $foo = 0 unless defined $foo;
 551      * to not give a warning. (Yes, this is a hack) */
 552
 553     nameav = (AV*)AvARRAY(CvPADLIST(PL_compcv))[0];
 554     name_svp = AvARRAY(nameav);
 555     for (offset = AvFILLp(nameav); offset > 0; offset--) {
 556         SV *namesv = name_svp[offset];
 557         if (namesv && namesv != &PL_sv_undef
 558             && !SvFAKE(namesv)
 559             && (SvFLAGS(namesv) & SVpad_OUR)
 560             && strEQ(SvPVX(namesv), name)
 561             && (U32)I_32(SvNVX(namesv)) == PAD_MAX /* min */
 562         )
 563             return offset;
 564     }
 565     return NOT_IN_PAD;
 566 }
 567
 568
 569 /*
 570 =for apidoc pad_findlex
 571
 572 Find a named lexical anywhere in a chain of nested pads. Add fake entries
 573 in the inner pads if it's found in an outer one.
 574
 575 Returns the offset in the bottom pad of the lex or the fake lex.
 576 cv is the CV in which to start the search, and seq is the current cop_seq
 577 to match against. If warn is true, print appropriate warnings.  The out_*
 578 vars return values, and so are pointers to where the returned values
 579 should be stored. out_capture, if non-null, requests that the innermost
 580 instance of the lexical is captured; out_name_sv is set to the innermost
 581 matched namesv or fake namesv; out_flags returns the flags normally
 582 associated with the IVX field of a fake namesv.
 583
 584 Note that pad_findlex() is recursive; it recurses up the chain of CVs,
 585 then comes back down, adding fake entries as it goes. It has to be this way
 586 because fake namesvs in anon protoypes have to store in NVX the index into
 587 the parent pad.
 588
 589 =cut
 590 */
 591
 592 /* Flags set in the SvIVX field of FAKE namesvs */
 593
 594 #define PAD_FAKELEX_ANON   1 /* the lex is declared in an ANON, or ... */
 595 #define PAD_FAKELEX_MULTI  2 /* the lex can be instantiated multiple times */
 596
 597 /* the CV has finished being compiled. This is not a sufficient test for
 598  * all CVs (eg XSUBs), but suffices for the CVs found in a lexical chain */
 599 #define CvCOMPILED(cv)  CvROOT(cv)
 600
 601 /* the CV does late binding of its lexicals */
 602 #define CvLATE(cv) (CvANON(cv) || SvTYPE(cv) == SVt_PVFM)
 603
 604
 605 STATIC PADOFFSET
 606 S_pad_findlex(pTHX_ char *name, CV* cv, U32 seq, int warn,
 607         SV** out_capture, SV** out_name_sv, int *out_flags)
 608 {
 609     I32 offset, new_offset;
 610     SV *new_capture;
 611     SV **new_capturep;
 612     AV *padlist = CvPADLIST(cv);
 613
 614     *out_flags = 0;
 615
 616     DEBUG_Xv(PerlIO_printf(Perl_debug_log,
 617         "Pad findlex cv=0x%"UVxf" searching \"%s\" seq=%d%s\n",
 618         PTR2UV(cv), name, (int)seq, out_capture ? " capturing" : "" ));
 619
 620     /* first, search this pad */
 621
 622     if (padlist) { /* not an undef CV */
 623         I32 fake_offset = 0;
 624         AV *nameav = (AV*)AvARRAY(padlist)[0];
 625         SV **name_svp = AvARRAY(nameav);
 626
 627         for (offset = AvFILLp(nameav); offset > 0; offset--) {
 628             SV *namesv = name_svp[offset];
 629             if (namesv && namesv != &PL_sv_undef
 630                     && strEQ(SvPVX(namesv), name))
 631             {
 632                 if (SvFAKE(namesv))
 633                     fake_offset = offset; /* in case we don't find a real one */
 634                 else if (  seq >  (U32)I_32(SvNVX(namesv))      /* min */
 635                         && seq <= (U32)SvIVX(namesv))           /* max */
 636                     break;
 637             }
 638         }
 639
 640         if (offset > 0 || fake_offset > 0 ) { /* a match! */
 641             if (offset > 0) { /* not fake */
 642                 fake_offset = 0;
 643                 *out_name_sv = name_svp[offset]; /* return the namesv */
 644
 645                 /* set PAD_FAKELEX_MULTI if this lex can have multiple
 646                  * instances. For now, we just test !CvUNIQUE(cv), but
 647                  * ideally, we should detect my's declared within loops
 648                  * etc - this would allow a wider range of 'not stayed
 649                  * shared' warnings. We also treated alreadly-compiled
 650                  * lexes as not multi as viewed from evals. */
 651
 652                 *out_flags = CvANON(cv) ?
 653                         PAD_FAKELEX_ANON :
 654                             (!CvUNIQUE(cv) && ! CvCOMPILED(cv))
 655                                 ? PAD_FAKELEX_MULTI : 0;
 656
 657                 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
 658                     "Pad findlex cv=0x%"UVxf" matched: offset=%ld (%ld,%ld)\n",
 659                     PTR2UV(cv), (long)offset, (long)I_32(SvNVX(*out_name_sv)),
 660                     (long)SvIVX(*out_name_sv)));
 661             }
 662             else { /* fake match */
 663                 offset = fake_offset;
 664                 *out_name_sv = name_svp[offset]; /* return the namesv */
 665                 *out_flags = SvIVX(*out_name_sv);
 666                 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
 667                     "Pad findlex cv=0x%"UVxf" matched: offset=%ld flags=0x%lx index=%lu\n",
 668                     PTR2UV(cv), (long)offset, (unsigned long)*out_flags,
 669                         (unsigned long)SvNVX(*out_name_sv)
 670                 ));
 671             }
 672
 673             /* return the lex? */
 674
 675             if (out_capture) {
 676
 677                 /* our ? */
 678                 if ((SvFLAGS(*out_name_sv) & SVpad_OUR)) {
 679                     *out_capture = Nullsv;
 680                     return offset;
 681                 }
 682
 683                 /* trying to capture from an anon prototype? */
 684                 if (CvCOMPILED(cv)
 685                         ? CvANON(cv) && CvCLONE(cv) && !CvCLONED(cv)
 686                         : *out_flags & PAD_FAKELEX_ANON)
 687                 {
 688                     if (warn && ckWARN(WARN_CLOSURE))
 689                         Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
 690                             "Variable \"%s\" is not available", name);
 691                     *out_capture = Nullsv;
 692                 }
 693
 694                 /* real value */
 695                 else {
 696                     int newwarn = warn;
 697                     if (!CvCOMPILED(cv) && (*out_flags & PAD_FAKELEX_MULTI)
 698                          && warn && ckWARN(WARN_CLOSURE)) {
 699                         newwarn = 0;
 700                         Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
 701                             "Variable \"%s\" will not stay shared", name);
 702                     }
 703
 704                     if (fake_offset && CvANON(cv)
 705                             && CvCLONE(cv) &&!CvCLONED(cv))
 706                     {
 707                         SV *n;
 708                         /* not yet caught - look further up */
 709                         DEBUG_Xv(PerlIO_printf(Perl_debug_log,
 710                             "Pad findlex cv=0x%"UVxf" chasing lex in outer pad\n",
 711                             PTR2UV(cv)));
 712                         n = *out_name_sv;
 713                         pad_findlex(name, CvOUTSIDE(cv), CvOUTSIDE_SEQ(cv),
 714                             newwarn, out_capture, out_name_sv, out_flags);
 715                         *out_name_sv = n;
 716                         return offset;
 717                     }
 718
 719                     *out_capture = AvARRAY((AV*)AvARRAY(padlist)[
 720                                     CvDEPTH(cv) ? CvDEPTH(cv) : 1])[offset];
 721                     DEBUG_Xv(PerlIO_printf(Perl_debug_log,
 722                         "Pad findlex cv=0x%"UVxf" found lex=0x%"UVxf"\n",
 723                         PTR2UV(cv), PTR2UV(*out_capture)));
 724
 725                     if (SvPADSTALE(*out_capture)) {
 726                         if (ckWARN(WARN_CLOSURE))
 727                             Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
 728                                 "Variable \"%s\" is not available", name);
 729                         *out_capture = Nullsv;
 730                     }
 731                 }
 732                 if (!*out_capture) {
 733                     if (*name == '@')
 734                         *out_capture = sv_2mortal((SV*)newAV());
 735                     else if (*name == '%')
 736                         *out_capture = sv_2mortal((SV*)newHV());
 737                     else
 738                         *out_capture = sv_newmortal();
 739                 }
 740             }
 741
 742             return offset;
 743         }
 744     }
 745
 746     /* it's not in this pad - try above */
 747
 748     if (!CvOUTSIDE(cv))
 749         return NOT_IN_PAD;
 750
 751     /* out_capture non-null means caller wants us to capture lex; in
 752      * addition we capture ourselves unless it's an ANON/format */
 753     new_capturep = out_capture ? out_capture :
 754                 CvLATE(cv) ? Null(SV**) : &new_capture;
 755
 756     offset = pad_findlex(name, CvOUTSIDE(cv), CvOUTSIDE_SEQ(cv), 1,
 757                 new_capturep, out_name_sv, out_flags);
 758     if (offset == NOT_IN_PAD)
 759         return NOT_IN_PAD;
 760
 761     /* found in an outer CV. Add appropriate fake entry to this pad */
 762
 763     /* don't add new fake entries (via eval) to CVs that we have already
 764      * finished compiling, or to undef CVs */
 765     if (CvCOMPILED(cv) || !padlist)
 766         return 0; /* this dummy (and invalid) value isnt used by the caller */
 767
 768     {
 769         SV *new_namesv;
 770         AV *ocomppad_name = PL_comppad_name;
 771         PAD *ocomppad = PL_comppad;
 772         PL_comppad_name = (AV*)AvARRAY(padlist)[0];
 773         PL_comppad = (AV*)AvARRAY(padlist)[1];
 774         PL_curpad = AvARRAY(PL_comppad);
 775
 776         new_offset = pad_add_name(
 777             SvPVX(*out_name_sv),
 778             (SvFLAGS(*out_name_sv) & SVpad_TYPED)
 779                     ? SvSTASH(*out_name_sv) : Nullhv,
 780             (SvFLAGS(*out_name_sv) & SVpad_OUR)
 781                     ? GvSTASH(*out_name_sv) : Nullhv,
 782             1  /* fake */
 783         );
 784
 785         new_namesv = AvARRAY(PL_comppad_name)[new_offset];
 786         SvIVX(new_namesv) = *out_flags;
 787
 788         SvNVX(new_namesv) = (NV)0;
 789         if (SvFLAGS(new_namesv) & SVpad_OUR) {
 790            /* do nothing */
 791         }
 792         else if (CvLATE(cv)) {
 793             /* delayed creation - just note the offset within parent pad */
 794             SvNVX(new_namesv) = (NV)offset;
 795             CvCLONE_on(cv);
 796         }
 797         else {
 798             /* immediate creation - capture outer value right now */
 799             av_store(PL_comppad, new_offset, SvREFCNT_inc(*new_capturep));
 800             DEBUG_Xv(PerlIO_printf(Perl_debug_log,
 801                 "Pad findlex cv=0x%"UVxf" saved captured sv 0x%"UVxf" at offset %ld\n",
 802                 PTR2UV(cv), PTR2UV(*new_capturep), (long)new_offset));
 803         }
 804         *out_name_sv = new_namesv;
 805         *out_flags = SvIVX(new_namesv);
 806
 807         PL_comppad_name = ocomppad_name;
 808         PL_comppad = ocomppad;
 809         PL_curpad = ocomppad ? AvARRAY(ocomppad) : Null(SV **);
 810     }
 811     return new_offset;
 812 }
 813
 814
 815 /*
 816 =for apidoc pad_sv
 817
 818 Get the value at offset po in the current pad.
 819 Use macro PAD_SV instead of calling this function directly.
 820
 821 =cut
 822 */
 823
 824
 825 SV *
 826 Perl_pad_sv(pTHX_ PADOFFSET po)
 827 {
 828     ASSERT_CURPAD_ACTIVE("pad_sv");
 829
 830     if (!po)
 831         Perl_croak(aTHX_ "panic: pad_sv po");
 832     DEBUG_X(PerlIO_printf(Perl_debug_log,
 833         "Pad 0x%"UVxf"[0x%"UVxf"] sv:      %ld sv=0x%"UVxf"\n",
 834         PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po, PTR2UV(PL_curpad[po]))
 835     );
 836     return PL_curpad[po];
 837 }
 838
 839
 840 /*
 841 =for apidoc pad_setsv
 842
 843 Set the entry at offset po in the current pad to sv.
 844 Use the macro PAD_SETSV() rather than calling this function directly.
 845
 846 =cut
 847 */
 848
 849 #ifdef DEBUGGING
 850 void
 851 Perl_pad_setsv(pTHX_ PADOFFSET po, SV* sv)
 852 {
 853     ASSERT_CURPAD_ACTIVE("pad_setsv");
 854
 855     DEBUG_X(PerlIO_printf(Perl_debug_log,
 856         "Pad 0x%"UVxf"[0x%"UVxf"] setsv:   %ld sv=0x%"UVxf"\n",
 857         PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po, PTR2UV(sv))
 858     );
 859     PL_curpad[po] = sv;
 860 }
 861 #endif
 862
 863
 864
 865 /*
 866 =for apidoc pad_block_start
 867
 868 Update the pad compilation state variables on entry to a new block
 869
 870 =cut
 871 */
 872
 873 /* XXX DAPM perhaps:
 874  *      - integrate this in general state-saving routine ???
 875  *      - combine with the state-saving going on in pad_new ???
 876  *      - introduce a new SAVE type that does all this in one go ?
 877  */
 878
 879 void
 880 Perl_pad_block_start(pTHX_ int full)
 881 {
 882     ASSERT_CURPAD_ACTIVE("pad_block_start");
 883     SAVEI32(PL_comppad_name_floor);
 884     PL_comppad_name_floor = AvFILLp(PL_comppad_name);
 885     if (full)
 886         PL_comppad_name_fill = PL_comppad_name_floor;
 887     if (PL_comppad_name_floor < 0)
 888         PL_comppad_name_floor = 0;
 889     SAVEI32(PL_min_intro_pending);
 890     SAVEI32(PL_max_intro_pending);
 891     PL_min_intro_pending = 0;
 892     SAVEI32(PL_comppad_name_fill);
 893     SAVEI32(PL_padix_floor);
 894     PL_padix_floor = PL_padix;
 895     PL_pad_reset_pending = FALSE;
 896 }
 897
 898
 899 /*
 900 =for apidoc intro_my
 901
 902 "Introduce" my variables to visible status.
 903
 904 =cut
 905 */
 906
 907 U32
 908 Perl_intro_my(pTHX)
 909 {
 910     SV **svp;
 911     SV *sv;
 912     I32 i;
 913
 914     ASSERT_CURPAD_ACTIVE("intro_my");
 915     if (! PL_min_intro_pending)
 916         return PL_cop_seqmax;
 917
 918     svp = AvARRAY(PL_comppad_name);
 919     for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
 920         if ((sv = svp[i]) && sv != &PL_sv_undef
 921                 && !SvFAKE(sv) && !SvIVX(sv))
 922         {
 923             SvIVX(sv) = PAD_MAX;        /* Don't know scope end yet. */
 924             SvNVX(sv) = (NV)PL_cop_seqmax;
 925             DEBUG_Xv(PerlIO_printf(Perl_debug_log,
 926                 "Pad intromy: %ld \"%s\", (%ld,%ld)\n",
 927                 (long)i, SvPVX(sv),
 928                 (long)I_32(SvNVX(sv)), (long)SvIVX(sv))
 929             );
 930         }
 931     }
 932     PL_min_intro_pending = 0;
 933     PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
 934     DEBUG_Xv(PerlIO_printf(Perl_debug_log,
 935                 "Pad intromy: seq -> %ld\n", (long)(PL_cop_seqmax+1)));
 936
 937     return PL_cop_seqmax++;
 938 }
 939
 940 /*
 941 =for apidoc pad_leavemy
 942
 943 Cleanup at end of scope during compilation: set the max seq number for
 944 lexicals in this scope and warn of any lexicals that never got introduced.
 945
 946 =cut
 947 */
 948
 949 void
 950 Perl_pad_leavemy(pTHX)
 951 {
 952     I32 off;
 953     SV **svp = AvARRAY(PL_comppad_name);
 954     SV *sv;
 955
 956     PL_pad_reset_pending = FALSE;
 957
 958     ASSERT_CURPAD_ACTIVE("pad_leavemy");
 959     if (PL_min_intro_pending && PL_comppad_name_fill < PL_min_intro_pending) {
 960         for (off = PL_max_intro_pending; off >= PL_min_intro_pending; off--) {
 961             if ((sv = svp[off]) && sv != &PL_sv_undef
 962                     && !SvFAKE(sv) && ckWARN_d(WARN_INTERNAL))
 963                 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
 964                                         "%"SVf" never introduced", sv);
 965         }
 966     }
 967     /* "Deintroduce" my variables that are leaving with this scope. */
 968     for (off = AvFILLp(PL_comppad_name); off > PL_comppad_name_fill; off--) {
 969         if ((sv = svp[off]) && sv != &PL_sv_undef
 970                 && !SvFAKE(sv) && SvIVX(sv) == PAD_MAX)
 971         {
 972             SvIVX(sv) = PL_cop_seqmax;
 973             DEBUG_Xv(PerlIO_printf(Perl_debug_log,
 974                 "Pad leavemy: %ld \"%s\", (%ld,%ld)\n",
 975                 (long)off, SvPVX(sv),
 976                 (long)I_32(SvNVX(sv)), (long)SvIVX(sv))
 977             );
 978         }
 979     }
 980     PL_cop_seqmax++;
 981     DEBUG_Xv(PerlIO_printf(Perl_debug_log,
 982             "Pad leavemy: seq = %ld\n", (long)PL_cop_seqmax));
 983 }
 984
 985
 986 /*
 987 =for apidoc pad_swipe
 988
 989 Abandon the tmp in the current pad at offset po and replace with a
 990 new one.
 991
 992 =cut
 993 */
 994
 995 void
 996 Perl_pad_swipe(pTHX_ PADOFFSET po, bool refadjust)
 997 {
 998     ASSERT_CURPAD_LEGAL("pad_swipe");
 999     if (!PL_curpad)
1000         return;
1001     if (AvARRAY(PL_comppad) != PL_curpad)
1002         Perl_croak(aTHX_ "panic: pad_swipe curpad");
1003     if (!po)
1004         Perl_croak(aTHX_ "panic: pad_swipe po");
1005
1006     DEBUG_X(PerlIO_printf(Perl_debug_log,
1007                 "Pad 0x%"UVxf"[0x%"UVxf"] swipe:   %ld\n",
1008                 PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po));
1009
1010     if (PL_curpad[po])
1011         SvPADTMP_off(PL_curpad[po]);
1012     if (refadjust)
1013         SvREFCNT_dec(PL_curpad[po]);
1014
1015     PL_curpad[po] = NEWSV(1107,0);
1016     SvPADTMP_on(PL_curpad[po]);
1017     if ((I32)po < PL_padix)
1018         PL_padix = po - 1;
1019 }
1020
1021
1022 /*
1023 =for apidoc pad_reset
1024
1025 Mark all the current temporaries for reuse
1026
1027 =cut
1028 */
1029
1030 /* XXX pad_reset() is currently disabled because it results in serious bugs.
1031  * It causes pad temp TARGs to be shared between OPs. Since TARGs are pushed
1032  * on the stack by OPs that use them, there are several ways to get an alias
1033  * to  a shared TARG.  Such an alias will change randomly and unpredictably.
1034  * We avoid doing this until we can think of a Better Way.
1035  * GSAR 97-10-29 */
1036 void
1037 Perl_pad_reset(pTHX)
1038 {
1039 #ifdef USE_BROKEN_PAD_RESET
1040     register I32 po;
1041
1042     if (AvARRAY(PL_comppad) != PL_curpad)
1043         Perl_croak(aTHX_ "panic: pad_reset curpad");
1044
1045     DEBUG_X(PerlIO_printf(Perl_debug_log,
1046             "Pad 0x%"UVxf"[0x%"UVxf"] reset:     padix %ld -> %ld",
1047             PTR2UV(PL_comppad), PTR2UV(PL_curpad),
1048                 (long)PL_padix, (long)PL_padix_floor
1049             )
1050     );
1051
1052     if (!PL_tainting) { /* Can't mix tainted and non-tainted temporaries. */
1053         for (po = AvMAX(PL_comppad); po > PL_padix_floor; po--) {
1054             if (PL_curpad[po] && !SvIMMORTAL(PL_curpad[po]))
1055                 SvPADTMP_off(PL_curpad[po]);
1056         }
1057         PL_padix = PL_padix_floor;
1058     }
1059 #endif
1060     PL_pad_reset_pending = FALSE;
1061 }
1062
1063
1064 /*
1065 =for apidoc pad_tidy
1066
1067 Tidy up a pad after we've finished compiling it:
1068     * remove most stuff from the pads of anonsub prototypes;
1069     * give it a @_;
1070     * mark tmps as such.
1071
1072 =cut
1073 */
1074
1075 /* XXX DAPM surely most of this stuff should be done properly
1076  * at the right time beforehand, rather than going around afterwards
1077  * cleaning up our mistakes ???
1078  */
1079
1080 void
1081 Perl_pad_tidy(pTHX_ padtidy_type type)
1082 {
1083     PADOFFSET ix;
1084     CV *cv;
1085
1086     ASSERT_CURPAD_ACTIVE("pad_tidy");
1087
1088     /* If this CV has had any 'eval-capable' ops planted in it
1089      * (ie it contains eval '...', //ee, /$var/ or /(?{..})/), Then any
1090      * anon prototypes in the chain of CVs should be marked as cloneable,
1091      * so that for example the eval's CV in C<< sub { eval '$x' } >> gets
1092      * the right CvOUTSIDE.
1093      * If running with -d, *any* sub may potentially have an eval
1094      * excuted within it.
1095      */
1096
1097     if (PL_cv_has_eval || PL_perldb) {
1098         for (cv = PL_compcv ;cv; cv = CvOUTSIDE(cv)) {
1099             if (cv != PL_compcv && CvCOMPILED(cv))
1100                 break; /* no need to mark already-compiled code */
1101             if (CvANON(cv)) {
1102                 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1103                     "Pad clone on cv=0x%"UVxf"\n", PTR2UV(cv)));
1104                 CvCLONE_on(cv);
1105             }
1106         }
1107     }
1108
1109     /* extend curpad to match namepad */
1110     if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
1111         av_store(PL_comppad_name, AvFILLp(PL_comppad), Nullsv);
1112
1113     if (type == padtidy_SUBCLONE) {
1114         SV **namep = AvARRAY(PL_comppad_name);
1115
1116         for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1117             SV *namesv;
1118
1119             if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
1120                 continue;
1121             /*
1122              * The only things that a clonable function needs in its
1123              * pad are anonymous subs.
1124              * The rest are created anew during cloning.
1125              */
1126             if (!((namesv = namep[ix]) != Nullsv &&
1127                   namesv != &PL_sv_undef &&
1128                    *SvPVX(namesv) == '&'))
1129             {
1130                 SvREFCNT_dec(PL_curpad[ix]);
1131                 PL_curpad[ix] = Nullsv;
1132             }
1133         }
1134     }
1135     else if (type == padtidy_SUB) {
1136         /* XXX DAPM this same bit of code keeps appearing !!! Rationalise? */
1137         AV *av = newAV();                       /* Will be @_ */
1138         av_extend(av, 0);
1139         av_store(PL_comppad, 0, (SV*)av);
1140         AvFLAGS(av) = AVf_REIFY;
1141     }
1142
1143     /* XXX DAPM rationalise these two similar branches */
1144
1145     if (type == padtidy_SUB) {
1146         for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1147             if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
1148                 continue;
1149             if (!SvPADMY(PL_curpad[ix]))
1150                 SvPADTMP_on(PL_curpad[ix]);
1151         }
1152     }
1153     else if (type == padtidy_FORMAT) {
1154         for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
1155             if (!SvPADMY(PL_curpad[ix]) && !SvIMMORTAL(PL_curpad[ix]))
1156                 SvPADTMP_on(PL_curpad[ix]);
1157         }
1158     }
1159     PL_curpad = AvARRAY(PL_comppad);
1160 }
1161
1162
1163 /*
1164 =for apidoc pad_free
1165
1166 Free the SV at offet po in the current pad.
1167
1168 =cut
1169 */
1170
1171 /* XXX DAPM integrate with pad_swipe ???? */
1172 void
1173 Perl_pad_free(pTHX_ PADOFFSET po)
1174 {
1175     ASSERT_CURPAD_LEGAL("pad_free");
1176     if (!PL_curpad)
1177         return;
1178     if (AvARRAY(PL_comppad) != PL_curpad)
1179         Perl_croak(aTHX_ "panic: pad_free curpad");
1180     if (!po)
1181         Perl_croak(aTHX_ "panic: pad_free po");
1182
1183     DEBUG_X(PerlIO_printf(Perl_debug_log,
1184             "Pad 0x%"UVxf"[0x%"UVxf"] free:    %ld\n",
1185             PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po)
1186     );
1187
1188     if (PL_curpad[po] && PL_curpad[po] != &PL_sv_undef) {
1189         SvPADTMP_off(PL_curpad[po]);
1190 #ifdef USE_ITHREADS
1191         /* SV could be a shared hash key (eg bugid #19022) */
1192         if (
1193 #ifdef PERL_COPY_ON_WRITE
1194             !SvIsCOW(PL_curpad[po])
1195 #else
1196             !SvFAKE(PL_curpad[po])
1197 #endif
1198             )
1199             SvREADONLY_off(PL_curpad[po]);      /* could be a freed constant */
1200 #endif
1201     }
1202     if ((I32)po < PL_padix)
1203         PL_padix = po - 1;
1204 }
1205
1206
1207
1208 /*
1209 =for apidoc do_dump_pad
1210
1211 Dump the contents of a padlist
1212
1213 =cut
1214 */
1215
1216 void
1217 Perl_do_dump_pad(pTHX_ I32 level, PerlIO *file, PADLIST *padlist, int full)
1218 {
1219     AV *pad_name;
1220     AV *pad;
1221     SV **pname;
1222     SV **ppad;
1223     SV *namesv;
1224     I32 ix;
1225
1226     if (!padlist) {
1227         return;
1228     }
1229     pad_name = (AV*)*av_fetch((AV*)padlist, 0, FALSE);
1230     pad = (AV*)*av_fetch((AV*)padlist, 1, FALSE);
1231     pname = AvARRAY(pad_name);
1232     ppad = AvARRAY(pad);
1233     Perl_dump_indent(aTHX_ level, file,
1234             "PADNAME = 0x%"UVxf"(0x%"UVxf") PAD = 0x%"UVxf"(0x%"UVxf")\n",
1235             PTR2UV(pad_name), PTR2UV(pname), PTR2UV(pad), PTR2UV(ppad)
1236     );
1237
1238     for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
1239         namesv = pname[ix];
1240         if (namesv && namesv == &PL_sv_undef) {
1241             namesv = Nullsv;
1242         }
1243         if (namesv) {
1244             if (SvFAKE(namesv))
1245                 Perl_dump_indent(aTHX_ level+1, file,
1246                     "%2d. 0x%"UVxf"<%lu> FAKE \"%s\" flags=0x%x index=%lu\n",
1247                     (int) ix,
1248                     PTR2UV(ppad[ix]),
1249                     (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
1250                     SvPVX(namesv),
1251                     (unsigned long)SvIVX(namesv),
1252                     (unsigned long)SvNVX(namesv)
1253
1254                 );
1255             else
1256                 Perl_dump_indent(aTHX_ level+1, file,
1257                     "%2d. 0x%"UVxf"<%lu> (%ld,%ld) \"%s\"\n",
1258                     (int) ix,
1259                     PTR2UV(ppad[ix]),
1260                     (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
1261                     (long)I_32(SvNVX(namesv)),
1262                     (long)SvIVX(namesv),
1263                     SvPVX(namesv)
1264                 );
1265         }
1266         else if (full) {
1267             Perl_dump_indent(aTHX_ level+1, file,
1268                 "%2d. 0x%"UVxf"<%lu>\n",
1269                 (int) ix,
1270                 PTR2UV(ppad[ix]),
1271                 (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0)
1272             );
1273         }
1274     }
1275 }
1276
1277
1278
1279 /*
1280 =for apidoc cv_dump
1281
1282 dump the contents of a CV
1283
1284 =cut
1285 */
1286
1287 #ifdef DEBUGGING
1288 STATIC void
1289 S_cv_dump(pTHX_ CV *cv, char *title)
1290 {
1291     CV *outside = CvOUTSIDE(cv);
1292     AV* padlist = CvPADLIST(cv);
1293
1294     PerlIO_printf(Perl_debug_log,
1295                   "  %s: CV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
1296                   title,
1297                   PTR2UV(cv),
1298                   (CvANON(cv) ? "ANON"
1299                    : (SvTYPE(cv) == SVt_PVFM) ? "FORMAT"
1300                    : (cv == PL_main_cv) ? "MAIN"
1301                    : CvUNIQUE(cv) ? "UNIQUE"
1302                    : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
1303                   PTR2UV(outside),
1304                   (!outside ? "null"
1305                    : CvANON(outside) ? "ANON"
1306                    : (outside == PL_main_cv) ? "MAIN"
1307                    : CvUNIQUE(outside) ? "UNIQUE"
1308                    : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
1309
1310     PerlIO_printf(Perl_debug_log,
1311                     "    PADLIST = 0x%"UVxf"\n", PTR2UV(padlist));
1312     do_dump_pad(1, Perl_debug_log, padlist, 1);
1313 }
1314 #endif /* DEBUGGING */
1315
1316
1317
1318
1319
1320 /*
1321 =for apidoc cv_clone
1322
1323 Clone a CV: make a new CV which points to the same code etc, but which
1324 has a newly-created pad built by copying the prototype pad and capturing
1325 any outer lexicals.
1326
1327 =cut
1328 */
1329
1330 CV *
1331 Perl_cv_clone(pTHX_ CV *proto)
1332 {
1333     I32 ix;
1334     AV* protopadlist = CvPADLIST(proto);
1335     AV* protopad_name = (AV*)*av_fetch(protopadlist, 0, FALSE);
1336     AV* protopad = (AV*)*av_fetch(protopadlist, 1, FALSE);
1337     SV** pname = AvARRAY(protopad_name);
1338     SV** ppad = AvARRAY(protopad);
1339     I32 fname = AvFILLp(protopad_name);
1340     I32 fpad = AvFILLp(protopad);
1341     AV* comppadlist;
1342     CV* cv;
1343     SV** outpad;
1344     CV* outside;
1345     long depth;
1346
1347     assert(!CvUNIQUE(proto));
1348
1349     /* Since cloneable anon subs can be nested, CvOUTSIDE may point
1350      * to a prototype; we instead want the cloned parent who called us.
1351      * Note that in general for formats, CvOUTSIDE != find_runcv */
1352
1353     outside = CvOUTSIDE(proto);
1354     if (outside && CvCLONE(outside) && ! CvCLONED(outside))
1355         outside = find_runcv(NULL);
1356     depth = CvDEPTH(outside);
1357     assert(depth || SvTYPE(proto) == SVt_PVFM);
1358     if (!depth)
1359         depth = 1;
1360     assert(CvPADLIST(outside));
1361
1362     ENTER;
1363     SAVESPTR(PL_compcv);
1364
1365     cv = PL_compcv = (CV*)NEWSV(1104, 0);
1366     sv_upgrade((SV *)cv, SvTYPE(proto));
1367     CvFLAGS(cv) = CvFLAGS(proto) & ~(CVf_CLONE|CVf_WEAKOUTSIDE);
1368     CvCLONED_on(cv);
1369
1370 #ifdef USE_ITHREADS
1371     CvFILE(cv)          = CvXSUB(proto) ? CvFILE(proto)
1372                                         : savepv(CvFILE(proto));
1373 #else
1374     CvFILE(cv)          = CvFILE(proto);
1375 #endif
1376     CvGV(cv)            = CvGV(proto);
1377     CvSTASH(cv)         = CvSTASH(proto);
1378     CvROOT(cv)          = OpREFCNT_inc(CvROOT(proto));
1379     CvSTART(cv)         = CvSTART(proto);
1380     CvOUTSIDE(cv)       = (CV*)SvREFCNT_inc(outside);
1381     CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(proto);
1382
1383     if (SvPOK(proto))
1384         sv_setpvn((SV*)cv, SvPVX(proto), SvCUR(proto));
1385
1386     CvPADLIST(cv) = comppadlist = pad_new(padnew_CLONE|padnew_SAVE);
1387
1388     av_fill(PL_comppad, fpad);
1389     for (ix = fname; ix >= 0; ix--)
1390         av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
1391
1392     PL_curpad = AvARRAY(PL_comppad);
1393
1394     outpad = AvARRAY(AvARRAY(CvPADLIST(outside))[depth]);
1395
1396     for (ix = fpad; ix > 0; ix--) {
1397         SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
1398         SV *sv = Nullsv;
1399         if (namesv && namesv != &PL_sv_undef) { /* lexical */
1400             if (SvFAKE(namesv)) {   /* lexical from outside? */
1401                 sv = outpad[(I32)SvNVX(namesv)];
1402                 assert(sv);
1403                 /* formats may have an inactive parent */
1404                 if (SvTYPE(proto) == SVt_PVFM && SvPADSTALE(sv)) {
1405                     if (ckWARN(WARN_CLOSURE))
1406                         Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
1407                             "Variable \"%s\" is not available", SvPVX(namesv));
1408                     sv = Nullsv;
1409                 }
1410                 else {
1411                     assert(!SvPADSTALE(sv));
1412                     sv = SvREFCNT_inc(sv);
1413                 }
1414             }
1415             if (!sv) {
1416                 char *name = SvPVX(namesv);
1417                 if (*name == '&')
1418                     sv = SvREFCNT_inc(ppad[ix]);
1419                 else if (*name == '@')
1420                     sv = (SV*)newAV();
1421                 else if (*name == '%')
1422                     sv = (SV*)newHV();
1423                 else
1424                     sv = NEWSV(0, 0);
1425                 SvPADMY_on(sv);
1426             }
1427         }
1428         else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
1429             sv = SvREFCNT_inc(ppad[ix]);
1430         }
1431         else {
1432             sv = NEWSV(0, 0);
1433             SvPADTMP_on(sv);
1434         }
1435         PL_curpad[ix] = sv;
1436     }
1437
1438     DEBUG_Xv(
1439         PerlIO_printf(Perl_debug_log, "\nPad CV clone\n");
1440         cv_dump(outside, "Outside");
1441         cv_dump(proto,   "Proto");
1442         cv_dump(cv,      "To");
1443     );
1444
1445     LEAVE;
1446
1447     if (CvCONST(cv)) {
1448         /* Constant sub () { $x } closing over $x - see lib/constant.pm:
1449          * The prototype was marked as a candiate for const-ization,
1450          * so try to grab the current const value, and if successful,
1451          * turn into a const sub:
1452          */
1453         SV* const_sv = op_const_sv(CvSTART(cv), cv);
1454         if (const_sv) {
1455             SvREFCNT_dec(cv);
1456             cv = newCONSTSUB(CvSTASH(proto), 0, const_sv);
1457         }
1458         else {
1459             CvCONST_off(cv);
1460         }
1461     }
1462
1463     return cv;
1464 }
1465
1466
1467 /*
1468 =for apidoc pad_fixup_inner_anons
1469
1470 For any anon CVs in the pad, change CvOUTSIDE of that CV from
1471 old_cv to new_cv if necessary. Needed when a newly-compiled CV has to be
1472 moved to a pre-existing CV struct.
1473
1474 =cut
1475 */
1476
1477 void
1478 Perl_pad_fixup_inner_anons(pTHX_ PADLIST *padlist, CV *old_cv, CV *new_cv)
1479 {
1480     I32 ix;
1481     AV *comppad_name = (AV*)AvARRAY(padlist)[0];
1482     AV *comppad = (AV*)AvARRAY(padlist)[1];
1483     SV **namepad = AvARRAY(comppad_name);
1484     SV **curpad = AvARRAY(comppad);
1485     for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
1486         SV *namesv = namepad[ix];
1487         if (namesv && namesv != &PL_sv_undef
1488             && *SvPVX(namesv) == '&')
1489         {
1490             CV *innercv = (CV*)curpad[ix];
1491             assert(CvWEAKOUTSIDE(innercv));
1492             assert(CvOUTSIDE(innercv) == old_cv);
1493             CvOUTSIDE(innercv) = new_cv;
1494         }
1495     }
1496 }
1497
1498
1499 /*
1500 =for apidoc pad_push
1501
1502 Push a new pad frame onto the padlist, unless there's already a pad at
1503 this depth, in which case don't bother creating a new one.
1504 If has_args is true, give the new pad an @_ in slot zero.
1505
1506 =cut
1507 */
1508
1509 void
1510 Perl_pad_push(pTHX_ PADLIST *padlist, int depth, int has_args)
1511 {
1512     if (depth <= AvFILLp(padlist))
1513         return;
1514
1515     {
1516         SV** svp = AvARRAY(padlist);
1517         AV *newpad = newAV();
1518         SV **oldpad = AvARRAY(svp[depth-1]);
1519         I32 ix = AvFILLp((AV*)svp[1]);
1520         I32 names_fill = AvFILLp((AV*)svp[0]);
1521         SV** names = AvARRAY(svp[0]);
1522         SV* sv;
1523         for ( ;ix > 0; ix--) {
1524             if (names_fill >= ix && names[ix] != &PL_sv_undef) {
1525                 char *name = SvPVX(names[ix]);
1526                 if ((SvFLAGS(names[ix]) & SVf_FAKE) || *name == '&') {
1527                     /* outer lexical or anon code */
1528                     av_store(newpad, ix, SvREFCNT_inc(oldpad[ix]));
1529                 }
1530                 else {          /* our own lexical */
1531                     if (*name == '@')
1532                         av_store(newpad, ix, sv = (SV*)newAV());
1533                     else if (*name == '%')
1534                         av_store(newpad, ix, sv = (SV*)newHV());
1535                     else
1536                         av_store(newpad, ix, sv = NEWSV(0, 0));
1537                     SvPADMY_on(sv);
1538                 }
1539             }
1540             else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
1541                 av_store(newpad, ix, sv = SvREFCNT_inc(oldpad[ix]));
1542             }
1543             else {
1544                 /* save temporaries on recursion? */
1545                 av_store(newpad, ix, sv = NEWSV(0, 0));
1546                 SvPADTMP_on(sv);
1547             }
1548         }
1549         if (has_args) {
1550             AV* av = newAV();
1551             av_extend(av, 0);
1552             av_store(newpad, 0, (SV*)av);
1553             AvFLAGS(av) = AVf_REIFY;
1554         }
1555         av_store(padlist, depth, (SV*)newpad);
1556         AvFILLp(padlist) = depth;
1557     }
1558 }