user/perl/pad.c

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