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