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