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