pad.c

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