pad.c

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