pad.c

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