padop_on_crack.c.inc

   1 /*
   2  * This code was copied from perl/pad.c and perl/op.c and subsequently
   3  * butchered by Lukas Mai (2012).
   4  */
   5 /* vi: set ft=c inde=: */
   6
   7 #define COP_SEQ_RANGE_LOW_set(SV, VAL) \
   8         STMT_START { ((XPVNV*)SvANY(SV))->xnv_u.xpad_cop_seq.xlow = (VAL); } STMT_END
   9 #define COP_SEQ_RANGE_HIGH_set(SV, VAL) \
  10         STMT_START { ((XPVNV*)SvANY(SV))->xnv_u.xpad_cop_seq.xhigh = (VAL); } STMT_END
  11
  12 static void S_pad_block_start(pTHX_ int full) {
  13         dVAR;
  14         ASSERT_CURPAD_ACTIVE("pad_block_start");
  15         SAVEI32(PL_comppad_name_floor);
  16         PL_comppad_name_floor = AvFILLp(PL_comppad_name);
  17         if (full)
  18                 PL_comppad_name_fill = PL_comppad_name_floor;
  19         if (PL_comppad_name_floor < 0)
  20                 PL_comppad_name_floor = 0;
  21         SAVEI32(PL_min_intro_pending);
  22         SAVEI32(PL_max_intro_pending);
  23         PL_min_intro_pending = 0;
  24         SAVEI32(PL_comppad_name_fill);
  25         SAVEI32(PL_padix_floor);
  26         PL_padix_floor = PL_padix;
  27         PL_pad_reset_pending = FALSE;
  28 }
  29
  30 static int S_block_start(pTHX_ int full) {
  31         dVAR;
  32         const int retval = PL_savestack_ix;
  33
  34         S_pad_block_start(aTHX_ full);
  35         SAVEHINTS();
  36         PL_hints &= ~HINT_BLOCK_SCOPE;
  37         SAVECOMPILEWARNINGS();
  38         PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
  39
  40         CALL_BLOCK_HOOKS(bhk_start, full);
  41
  42         return retval;
  43 }
  44
  45 /* Check for in place reverse and sort assignments like "@a = reverse @a"
  46    and modify the optree to make them work inplace */
  47
  48 static void S_inplace_aassign(pTHX_ OP *o) {
  49         OP *modop, *modop_pushmark;
  50         OP *oright;
  51         OP *oleft, *oleft_pushmark;
  52
  53         assert((o->op_flags & OPf_WANT) == OPf_WANT_VOID);
  54
  55         assert(cUNOPo->op_first->op_type == OP_NULL);
  56         modop_pushmark = cUNOPx(cUNOPo->op_first)->op_first;
  57         assert(modop_pushmark->op_type == OP_PUSHMARK);
  58         modop = modop_pushmark->op_sibling;
  59
  60         if (modop->op_type != OP_SORT && modop->op_type != OP_REVERSE)
  61                 return;
  62
  63         /* no other operation except sort/reverse */
  64         if (modop->op_sibling)
  65                 return;
  66
  67         assert(cUNOPx(modop)->op_first->op_type == OP_PUSHMARK);
  68         if (!(oright = cUNOPx(modop)->op_first->op_sibling)) return;
  69
  70         if (modop->op_flags & OPf_STACKED) {
  71                 /* skip sort subroutine/block */
  72                 assert(oright->op_type == OP_NULL);
  73                 oright = oright->op_sibling;
  74         }
  75
  76         assert(cUNOPo->op_first->op_sibling->op_type == OP_NULL);
  77         oleft_pushmark = cUNOPx(cUNOPo->op_first->op_sibling)->op_first;
  78         assert(oleft_pushmark->op_type == OP_PUSHMARK);
  79         oleft = oleft_pushmark->op_sibling;
  80
  81         /* Check the lhs is an array */
  82         if (!oleft ||
  83                 (oleft->op_type != OP_RV2AV && oleft->op_type != OP_PADAV)
  84                 || oleft->op_sibling
  85                 || (oleft->op_private & OPpLVAL_INTRO)
  86         )
  87                 return;
  88
  89         /* Only one thing on the rhs */
  90         if (oright->op_sibling)
  91                 return;
  92
  93         /* check the array is the same on both sides */
  94         if (oleft->op_type == OP_RV2AV) {
  95                 if (oright->op_type != OP_RV2AV
  96                         || !cUNOPx(oright)->op_first
  97                         || cUNOPx(oright)->op_first->op_type != OP_GV
  98                         || cUNOPx(oleft )->op_first->op_type != OP_GV
  99                         || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
 100                         cGVOPx_gv(cUNOPx(oright)->op_first)
 101                 )
 102                         return;
 103         }
 104         else if (oright->op_type != OP_PADAV
 105                          || oright->op_targ != oleft->op_targ
 106         )
 107                 return;
 108
 109         /* This actually is an inplace assignment */
 110
 111         modop->op_private |= OPpSORT_INPLACE;
 112
 113         /* transfer MODishness etc from LHS arg to RHS arg */
 114         oright->op_flags = oleft->op_flags;
 115
 116         /* remove the aassign op and the lhs */
 117         op_null(o);
 118         op_null(oleft_pushmark);
 119         if (oleft->op_type == OP_RV2AV && cUNOPx(oleft)->op_first)
 120                 op_null(cUNOPx(oleft)->op_first);
 121         op_null(oleft);
 122 }
 123
 124 static OP *S_scalarvoid(pTHX_ OP *);
 125
 126 static OP *S_scalar(pTHX_ OP *o) {
 127         dVAR;
 128         OP *kid;
 129
 130         /* assumes no premature commitment */
 131         if (!o || (PL_parser && PL_parser->error_count)
 132                 || (o->op_flags & OPf_WANT)
 133                 || o->op_type == OP_RETURN)
 134         {
 135                 return o;
 136         }
 137
 138         o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
 139
 140         switch (o->op_type) {
 141                 case OP_REPEAT:
 142                         S_scalar(aTHX_ cBINOPo->op_first);
 143                         break;
 144                 case OP_OR:
 145                 case OP_AND:
 146                 case OP_COND_EXPR:
 147                         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
 148                                 S_scalar(aTHX_ kid);
 149                         break;
 150                         /* FALL THROUGH */
 151                 case OP_SPLIT:
 152                 case OP_MATCH:
 153                 case OP_QR:
 154                 case OP_SUBST:
 155                 case OP_NULL:
 156                 default:
 157                         if (o->op_flags & OPf_KIDS) {
 158                                 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
 159                                         S_scalar(aTHX_ kid);
 160                         }
 161                         break;
 162                 case OP_LEAVE:
 163                 case OP_LEAVETRY:
 164                         kid = cLISTOPo->op_first;
 165                         S_scalar(aTHX_ kid);
 166                         kid = kid->op_sibling;
 167 do_kids:
 168                         while (kid) {
 169                                 OP *sib = kid->op_sibling;
 170                                 if (sib && kid->op_type != OP_LEAVEWHEN)
 171                                         S_scalarvoid(aTHX_ kid);
 172                                 else
 173                                         S_scalar(aTHX_ kid);
 174                                 kid = sib;
 175                         }
 176                         PL_curcop = &PL_compiling;
 177                         break;
 178                 case OP_SCOPE:
 179                 case OP_LINESEQ:
 180                 case OP_LIST:
 181                         kid = cLISTOPo->op_first;
 182                         goto do_kids;
 183                 case OP_SORT:
 184                         Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
 185                         break;
 186         }
 187         return o;
 188 }
 189
 190 static OP *S_scalarkids(pTHX_ OP *o) {
 191     if (o && o->op_flags & OPf_KIDS) {
 192         OP *kid;
 193         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
 194             S_scalar(aTHX_ kid);
 195     }
 196     return o;
 197 }
 198
 199 static OP *S_scalarvoid(pTHX_ OP *o) {
 200         dVAR;
 201         OP *kid;
 202         const char *useless = NULL;
 203         U32 useless_is_utf8 = 0;
 204         SV *sv;
 205         U8 want;
 206
 207         PERL_ARGS_ASSERT_SCALARVOID;
 208
 209         if (
 210                 o->op_type == OP_NEXTSTATE ||
 211                 o->op_type == OP_DBSTATE || (
 212                         o->op_type == OP_NULL && (
 213                                 o->op_targ == OP_NEXTSTATE ||
 214                                 o->op_targ == OP_DBSTATE
 215                         )
 216                 )
 217         ) {
 218                 PL_curcop = (COP*)o;            /* for warning below */
 219         }
 220
 221         /* assumes no premature commitment */
 222         want = o->op_flags & OPf_WANT;
 223         if (
 224                 (want && want != OPf_WANT_SCALAR) ||
 225                 (PL_parser && PL_parser->error_count) ||
 226                 o->op_type == OP_RETURN ||
 227                 o->op_type == OP_REQUIRE ||
 228                 o->op_type == OP_LEAVEWHEN
 229         ) {
 230                 return o;
 231         }
 232
 233         if (
 234                 (o->op_private & OPpTARGET_MY) &&
 235                 (PL_opargs[o->op_type] & OA_TARGLEX)
 236                 /* OPp share the meaning */
 237         ) {
 238                 return S_scalar(aTHX_ o);                       /* As if inside SASSIGN */
 239         }
 240
 241         o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
 242
 243         switch (o->op_type) {
 244                 default:
 245                         if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
 246                                 break;
 247                         /* FALL THROUGH */
 248                 case OP_REPEAT:
 249                         if (o->op_flags & OPf_STACKED)
 250                                 break;
 251                         goto func_ops;
 252                 case OP_SUBSTR:
 253                         if (o->op_private == 4)
 254                                 break;
 255                         /* FALL THROUGH */
 256                 case OP_GVSV:
 257                 case OP_WANTARRAY:
 258                 case OP_GV:
 259                 case OP_SMARTMATCH:
 260                 case OP_PADSV:
 261                 case OP_PADAV:
 262                 case OP_PADHV:
 263                 case OP_PADANY:
 264                 case OP_AV2ARYLEN:
 265                 case OP_REF:
 266                 case OP_REFGEN:
 267                 case OP_SREFGEN:
 268                 case OP_DEFINED:
 269                 case OP_HEX:
 270                 case OP_OCT:
 271                 case OP_LENGTH:
 272                 case OP_VEC:
 273                 case OP_INDEX:
 274                 case OP_RINDEX:
 275                 case OP_SPRINTF:
 276                 case OP_AELEM:
 277                 case OP_AELEMFAST:
 278                 IF_HAVE_PERL_5_16(case OP_AELEMFAST_LEX:, )
 279                 case OP_ASLICE:
 280                 case OP_HELEM:
 281                 case OP_HSLICE:
 282                 case OP_UNPACK:
 283                 case OP_PACK:
 284                 case OP_JOIN:
 285                 case OP_LSLICE:
 286                 case OP_ANONLIST:
 287                 case OP_ANONHASH:
 288                 case OP_SORT:
 289                 case OP_REVERSE:
 290                 case OP_RANGE:
 291                 case OP_FLIP:
 292                 case OP_FLOP:
 293                 case OP_CALLER:
 294                 case OP_FILENO:
 295                 case OP_EOF:
 296                 case OP_TELL:
 297                 case OP_GETSOCKNAME:
 298                 case OP_GETPEERNAME:
 299                 case OP_READLINK:
 300                 case OP_TELLDIR:
 301                 case OP_GETPPID:
 302                 case OP_GETPGRP:
 303                 case OP_GETPRIORITY:
 304                 case OP_TIME:
 305                 case OP_TMS:
 306                 case OP_LOCALTIME:
 307                 case OP_GMTIME:
 308                 case OP_GHBYNAME:
 309                 case OP_GHBYADDR:
 310                 case OP_GHOSTENT:
 311                 case OP_GNBYNAME:
 312                 case OP_GNBYADDR:
 313                 case OP_GNETENT:
 314                 case OP_GPBYNAME:
 315                 case OP_GPBYNUMBER:
 316                 case OP_GPROTOENT:
 317                 case OP_GSBYNAME:
 318                 case OP_GSBYPORT:
 319                 case OP_GSERVENT:
 320                 case OP_GPWNAM:
 321                 case OP_GPWUID:
 322                 case OP_GGRNAM:
 323                 case OP_GGRGID:
 324                 case OP_GETLOGIN:
 325                 case OP_PROTOTYPE:
 326                 IF_HAVE_PERL_5_16(case OP_RUNCV:, )
 327 func_ops:
 328                         if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
 329                                 /* Otherwise it's "Useless use of grep iterator" */
 330                                 useless = OP_DESC(o);
 331                         break;
 332
 333                 case OP_SPLIT:
 334                         kid = cLISTOPo->op_first;
 335                         if (kid && kid->op_type == OP_PUSHRE
 336 #ifdef USE_ITHREADS
 337                                 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff)
 338 #else
 339                                 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv)
 340 #endif
 341                                         useless = OP_DESC(o);
 342                         break;
 343
 344                 case OP_NOT:
 345                         kid = cUNOPo->op_first;
 346                         if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
 347                                 kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
 348                                 goto func_ops;
 349                         }
 350                         useless = "negative pattern binding (!~)";
 351                         break;
 352
 353                 case OP_SUBST:
 354                         if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
 355                                 useless = "non-destructive substitution (s///r)";
 356                         break;
 357
 358                 case OP_TRANSR:
 359                         useless = "non-destructive transliteration (tr///r)";
 360                         break;
 361
 362                 case OP_RV2GV:
 363                 case OP_RV2SV:
 364                 case OP_RV2AV:
 365                 case OP_RV2HV:
 366                         if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
 367                                 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
 368                                 useless = "a variable";
 369                         break;
 370
 371                 case OP_CONST:
 372                         sv = cSVOPo_sv;
 373                         if (cSVOPo->op_private & OPpCONST_STRICT) {
 374                                 //no_bareword_allowed(o);
 375                                 *((int *)NULL) += 1;
 376                         } else {
 377                                 if (ckWARN(WARN_VOID)) {
 378                                         /* don't warn on optimised away booleans, eg
 379                                          * use constant Foo, 5; Foo || print; */
 380                                         if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
 381                                                 useless = NULL;
 382                                         /* the constants 0 and 1 are permitted as they are
 383                                            conventionally used as dummies in constructs like
 384                                            1 while some_condition_with_side_effects;  */
 385                                         else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
 386                                                 useless = NULL;
 387                                         else if (SvPOK(sv)) {
 388                                                 /* perl4's way of mixing documentation and code
 389                                                    (before the invention of POD) was based on a
 390                                                    trick to mix nroff and perl code. The trick was
 391                                                    built upon these three nroff macros being used in
 392                                                    void context. The pink camel has the details in
 393                                                    the script wrapman near page 319. */
 394                                                 const char * const maybe_macro = SvPVX_const(sv);
 395                                                 if (strnEQ(maybe_macro, "di", 2) ||
 396                                                         strnEQ(maybe_macro, "ds", 2) ||
 397                                                         strnEQ(maybe_macro, "ig", 2))
 398                                                         useless = NULL;
 399                                                 else {
 400                                                         SV * const dsv = newSVpvs("");
 401                                                         SV* msv = sv_2mortal(Perl_newSVpvf(aTHX_
 402                                                                                                                            "a constant (%s)",
 403                                                                                                                            pv_pretty(dsv, maybe_macro, SvCUR(sv), 32, NULL, NULL,
 404                                                                                                                                                  PERL_PV_PRETTY_DUMP | PERL_PV_ESCAPE_NOCLEAR | PERL_PV_ESCAPE_UNI_DETECT )));
 405                                                         SvREFCNT_dec(dsv);
 406                                                         useless = SvPV_nolen(msv);
 407                                                         useless_is_utf8 = SvUTF8(msv);
 408                                                 }
 409                                         }
 410                                         else if (SvOK(sv)) {
 411                                                 SV* msv = sv_2mortal(Perl_newSVpvf(aTHX_
 412                                                                                                                    "a constant (%"SVf")", sv));
 413                                                 useless = SvPV_nolen(msv);
 414                                         }
 415                                         else
 416                                                 useless = "a constant (undef)";
 417                                 }
 418                         }
 419                         op_null(o);             /* don't execute or even remember it */
 420                         break;
 421
 422                 case OP_POSTINC:
 423                         o->op_type = OP_PREINC;         /* pre-increment is faster */
 424                         o->op_ppaddr = PL_ppaddr[OP_PREINC];
 425                         break;
 426
 427                 case OP_POSTDEC:
 428                         o->op_type = OP_PREDEC;         /* pre-decrement is faster */
 429                         o->op_ppaddr = PL_ppaddr[OP_PREDEC];
 430                         break;
 431
 432                 case OP_I_POSTINC:
 433                         o->op_type = OP_I_PREINC;       /* pre-increment is faster */
 434                         o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
 435                         break;
 436
 437                 case OP_I_POSTDEC:
 438                         o->op_type = OP_I_PREDEC;       /* pre-decrement is faster */
 439                         o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
 440                         break;
 441
 442                 case OP_SASSIGN: {
 443                         OP *rv2gv;
 444                         UNOP *refgen, *rv2cv;
 445                         LISTOP *exlist;
 446
 447                         if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
 448                                 break;
 449
 450                         rv2gv = ((BINOP *)o)->op_last;
 451                         if (!rv2gv || rv2gv->op_type != OP_RV2GV)
 452                                 break;
 453
 454                         refgen = (UNOP *)((BINOP *)o)->op_first;
 455
 456                         if (!refgen || refgen->op_type != OP_REFGEN)
 457                                 break;
 458
 459                         exlist = (LISTOP *)refgen->op_first;
 460                         if (!exlist || exlist->op_type != OP_NULL
 461                                 || exlist->op_targ != OP_LIST)
 462                                 break;
 463
 464                         if (exlist->op_first->op_type != OP_PUSHMARK)
 465                                 break;
 466
 467                         rv2cv = (UNOP*)exlist->op_last;
 468
 469                         if (rv2cv->op_type != OP_RV2CV)
 470                                 break;
 471
 472                         assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
 473                         assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
 474                         assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
 475
 476                         o->op_private |= OPpASSIGN_CV_TO_GV;
 477                         rv2gv->op_private |= OPpDONT_INIT_GV;
 478                         rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
 479
 480                         break;
 481                 }
 482
 483                 case OP_AASSIGN: {
 484                         S_inplace_aassign(aTHX_ o);
 485                         break;
 486                 }
 487
 488                 case OP_OR:
 489                 case OP_AND:
 490                         kid = cLOGOPo->op_first;
 491                         if (kid->op_type == OP_NOT
 492                                 && (kid->op_flags & OPf_KIDS)
 493                                 && !PL_madskills) {
 494                                 if (o->op_type == OP_AND) {
 495                                         o->op_type = OP_OR;
 496                                         o->op_ppaddr = PL_ppaddr[OP_OR];
 497                                 } else {
 498                                         o->op_type = OP_AND;
 499                                         o->op_ppaddr = PL_ppaddr[OP_AND];
 500                                 }
 501                                 op_null(kid);
 502                         }
 503
 504                 case OP_DOR:
 505                 case OP_COND_EXPR:
 506                 case OP_ENTERGIVEN:
 507                 case OP_ENTERWHEN:
 508                         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
 509                                 S_scalarvoid(aTHX_ kid);
 510                         break;
 511
 512                 case OP_NULL:
 513                         if (o->op_flags & OPf_STACKED)
 514                                 break;
 515                         /* FALL THROUGH */
 516                 case OP_NEXTSTATE:
 517                 case OP_DBSTATE:
 518                 case OP_ENTERTRY:
 519                 case OP_ENTER:
 520                         if (!(o->op_flags & OPf_KIDS))
 521                                 break;
 522                         /* FALL THROUGH */
 523                 case OP_SCOPE:
 524                 case OP_LEAVE:
 525                 case OP_LEAVETRY:
 526                 case OP_LEAVELOOP:
 527                 case OP_LINESEQ:
 528                 case OP_LIST:
 529                 case OP_LEAVEGIVEN:
 530                 case OP_LEAVEWHEN:
 531                         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
 532                                 S_scalarvoid(aTHX_ kid);
 533                         break;
 534                 case OP_ENTEREVAL:
 535                         S_scalarkids(aTHX_ o);
 536                         break;
 537                 case OP_SCALAR:
 538                         return S_scalar(aTHX_ o);
 539         }
 540         if (useless)
 541                 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %"SVf" in void context",
 542                                            newSVpvn_flags(useless, strlen(useless),
 543                                                                           SVs_TEMP | ( useless_is_utf8 ? SVf_UTF8 : 0 )));
 544         return o;
 545 }
 546
 547 static OP *S_scalarseq(pTHX_ OP *o) {
 548         dVAR;
 549         if (o) {
 550                 const OPCODE type = o->op_type;
 551
 552                 if (type == OP_LINESEQ || type == OP_SCOPE ||
 553                     type == OP_LEAVE || type == OP_LEAVETRY)
 554                 {
 555                         OP *kid;
 556                         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
 557                                 if (kid->op_sibling) {
 558                                         S_scalarvoid(aTHX_ kid);
 559                                 }
 560                         }
 561                         PL_curcop = &PL_compiling;
 562                 }
 563                 o->op_flags &= ~OPf_PARENS;
 564                 if (PL_hints & HINT_BLOCK_SCOPE)
 565                         o->op_flags |= OPf_PARENS;
 566         }
 567         else
 568                 o = newOP(OP_STUB, 0);
 569         return o;
 570 }
 571
 572 static void S_pad_leavemy(pTHX) {
 573         dVAR;
 574         I32 off;
 575         SV * const * const svp = AvARRAY(PL_comppad_name);
 576
 577         PL_pad_reset_pending = FALSE;
 578
 579         ASSERT_CURPAD_ACTIVE("pad_leavemy");
 580         if (PL_min_intro_pending && PL_comppad_name_fill < PL_min_intro_pending) {
 581                 for (off = PL_max_intro_pending; off >= PL_min_intro_pending; off--) {
 582                         const SV * const sv = svp[off];
 583                         if (sv && sv != &PL_sv_undef && !SvFAKE(sv))
 584                                 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
 585                                                                  "%"SVf" never introduced",
 586                                                                  SVfARG(sv));
 587                 }
 588         }
 589         /* "Deintroduce" my variables that are leaving with this scope. */
 590         for (off = AvFILLp(PL_comppad_name); off > PL_comppad_name_fill; off--) {
 591                 const SV * const sv = svp[off];
 592                 if (sv && sv != &PL_sv_undef && !SvFAKE(sv)
 593                         && COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO)
 594                 {
 595                         COP_SEQ_RANGE_HIGH_set(sv, PL_cop_seqmax);
 596                         DEBUG_Xv(PerlIO_printf(Perl_debug_log,
 597                                                                    "Pad leavemy: %ld \"%s\", (%lu,%lu)\n",
 598                                                                    (long)off, SvPVX_const(sv),
 599                                                                    (unsigned long)COP_SEQ_RANGE_LOW(sv),
 600                                                                    (unsigned long)COP_SEQ_RANGE_HIGH(sv))
 601                         );
 602                 }
 603         }
 604         PL_cop_seqmax++;
 605         if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */
 606                 PL_cop_seqmax++;
 607         DEBUG_Xv(PerlIO_printf(Perl_debug_log,
 608                                                    "Pad leavemy: seq = %ld\n", (long)PL_cop_seqmax));
 609 }
 610
 611 static OP *S_block_end(pTHX_ I32 floor, OP *seq) {
 612         dVAR;
 613         const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
 614         OP *retval = S_scalarseq(aTHX_ seq);
 615
 616         CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
 617
 618         LEAVE_SCOPE(floor);
 619         CopHINTS_set(&PL_compiling, PL_hints);
 620         if (needblockscope)
 621                 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
 622         S_pad_leavemy(aTHX);
 623
 624         CALL_BLOCK_HOOKS(bhk_post_end, &retval);
 625
 626         return retval;
 627 }
 628
 629
 630 #ifndef pad_alloc
 631
 632 #define pad_alloc(OPTYPE, TMPTYPE) \
 633         S_pad_alloc(aTHX_ OPTYPE, TMPTYPE)
 634
 635 static PADOFFSET S_pad_alloc(pTHX_ I32 optype, U32 tmptype) {
 636         dVAR;
 637         SV *sv;
 638         I32 retval;
 639
 640         PERL_UNUSED_ARG(optype);
 641         ASSERT_CURPAD_ACTIVE("pad_alloc");
 642
 643         if (AvARRAY(PL_comppad) != PL_curpad)
 644                 Perl_croak(aTHX_ "panic: pad_alloc");
 645         PL_pad_reset_pending = FALSE;
 646         if (tmptype & SVs_PADMY) {
 647                 sv = *av_fetch(PL_comppad, AvFILLp(PL_comppad) + 1, TRUE);
 648                 retval = AvFILLp(PL_comppad);
 649         }
 650         else {
 651                 SV * const * const names = AvARRAY(PL_comppad_name);
 652                 const SSize_t names_fill = AvFILLp(PL_comppad_name);
 653                 for (;;) {
 654                         /*
 655                          * "foreach" index vars temporarily become aliases to non-"my"
 656                          * values.  Thus we must skip, not just pad values that are
 657                          * marked as current pad values, but also those with names.
 658                          */
 659                         /* HVDS why copy to sv here? we don't seem to use it */
 660                         if (++PL_padix <= names_fill &&
 661                                 (sv = names[PL_padix]) && sv != &PL_sv_undef)
 662                                 continue;
 663                         sv = *av_fetch(PL_comppad, PL_padix, TRUE);
 664                         if (!(SvFLAGS(sv) & (SVs_PADTMP | SVs_PADMY)) &&
 665                                 !IS_PADGV(sv) && !IS_PADCONST(sv))
 666                                 break;
 667                 }
 668                 retval = PL_padix;
 669         }
 670         SvFLAGS(sv) |= tmptype;
 671         PL_curpad = AvARRAY(PL_comppad);
 672
 673         DEBUG_X(PerlIO_printf(Perl_debug_log,
 674                                                   "Pad 0x%"UVxf"[0x%"UVxf"] alloc:   %ld for %s\n",
 675                                                   PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long) retval,
 676                                                   PL_op_name[optype]));
 677 #ifdef DEBUG_LEAKING_SCALARS
 678         sv->sv_debug_optype = optype;
 679         sv->sv_debug_inpad = 1;
 680 #endif
 681         return (PADOFFSET)retval;
 682 }
 683
 684 #endif
 685
 686
 687 #ifndef pad_add_name_sv
 688
 689 #define pad_add_name_sv(NAMESV, FLAGS, TYPESTASH, OURSTASH) \
 690         S_pad_add_name_sv(aTHX_ NAMESV, FLAGS, TYPESTASH, OURSTASH)
 691
 692 static PADOFFSET S_pad_alloc_name(pTHX_ SV *namesv, U32 flags, HV *typestash, HV *ourstash) {
 693         dVAR;
 694         const PADOFFSET offset = pad_alloc(OP_PADSV, SVs_PADMY);
 695
 696         assert(flags == 0);
 697
 698         ASSERT_CURPAD_ACTIVE("pad_alloc_name");
 699
 700         if (typestash) {
 701                 assert(SvTYPE(namesv) == SVt_PVMG);
 702                 SvPAD_TYPED_on(namesv);
 703                 SvSTASH_set(namesv, MUTABLE_HV(SvREFCNT_inc_simple_NN(MUTABLE_SV(typestash))));
 704         }
 705         if (ourstash) {
 706                 SvPAD_OUR_on(namesv);
 707                 SvOURSTASH_set(namesv, ourstash);
 708                 SvREFCNT_inc_simple_void_NN(ourstash);
 709         }
 710
 711         av_store(PL_comppad_name, offset, namesv);
 712         return offset;
 713 }
 714
 715 PADOFFSET static S_pad_add_name_pvn(pTHX_ const char *namepv, STRLEN namelen, U32 flags, HV *typestash, HV *ourstash) {
 716         dVAR;
 717         PADOFFSET offset;
 718         SV *namesv;
 719
 720         assert(flags == 0);
 721
 722         namesv = newSV_type((ourstash || typestash) ? SVt_PVMG : SVt_PVNV);
 723
 724         sv_setpvn(namesv, namepv, namelen);
 725
 726         offset = S_pad_alloc_name(aTHX_ namesv, flags, typestash, ourstash);
 727
 728         /* not yet introduced */
 729         COP_SEQ_RANGE_LOW_set(namesv, PERL_PADSEQ_INTRO);
 730         COP_SEQ_RANGE_HIGH_set(namesv, 0);
 731
 732         if (!PL_min_intro_pending)
 733                 PL_min_intro_pending = offset;
 734         PL_max_intro_pending = offset;
 735         /* if it's not a simple scalar, replace with an AV or HV */
 736         assert(SvTYPE(PL_curpad[offset]) == SVt_NULL);
 737         assert(SvREFCNT(PL_curpad[offset]) == 1);
 738         if (namelen != 0 && *namepv == '@')
 739                 sv_upgrade(PL_curpad[offset], SVt_PVAV);
 740         else if (namelen != 0 && *namepv == '%')
 741                 sv_upgrade(PL_curpad[offset], SVt_PVHV);
 742         assert(SvPADMY(PL_curpad[offset]));
 743         DEBUG_Xv(PerlIO_printf(Perl_debug_log,
 744                                                    "Pad addname: %ld \"%s\" new lex=0x%"UVxf"\n",
 745                                                    (long)offset, SvPVX(namesv),
 746                                                    PTR2UV(PL_curpad[offset])));
 747
 748         return offset;
 749 }
 750
 751 static PADOFFSET S_pad_add_name_sv(pTHX_ SV *name, U32 flags, HV *typestash, HV *ourstash) {
 752         char *namepv;
 753         STRLEN namelen;
 754         assert(flags == 0);
 755         namepv = SvPV(name, namelen);
 756         return S_pad_add_name_pvn(aTHX_ namepv, namelen, flags, typestash, ourstash);
 757 }
 758
 759 #endif
 760
 761 #ifndef pad_findmy_sv
 762
 763 #define pad_findmy_sv(SV, FLAGS) \
 764         S_pad_findmy(aTHX_ SvPV_nolen(SV), FLAGS)
 765
 766 #define PARENT_PAD_INDEX_set(SV, VAL) \
 767         STMT_START { ((XPVNV*)SvANY(SV))->xnv_u.xpad_cop_seq.xlow = (VAL); } STMT_END
 768 #define PARENT_FAKELEX_FLAGS_set(SV, VAL) \
 769         STMT_START { ((XPVNV*)SvANY(SV))->xnv_u.xpad_cop_seq.xhigh = (VAL); } STMT_END
 770
 771 static PADOFFSET S_pad_findlex(pTHX_ const char *name, const CV *cv, U32 seq, int warn, SV **out_capture, SV **out_name_sv, int *out_flags) {
 772 #define CvCOMPILED(CV) CvROOT(CV)
 773 #define CvLATE(CV) (CvANON(CV) || SvTYPE(CV) == SVt_PVFM)
 774         dVAR;
 775         I32 offset, new_offset;
 776         SV *new_capture;
 777         SV **new_capturep;
 778         const AV *const padlist = CvPADLIST(cv);
 779
 780         *out_flags = 0;
 781
 782         DEBUG_Xv(PerlIO_printf(Perl_debug_log,
 783                                                    "Pad findlex cv=0x%"UVxf" searching \"%s\" seq=%d%s\n",
 784                                                    PTR2UV(cv), name, (int)seq, out_capture ? " capturing" : "" ));
 785
 786         /* first, search this pad */
 787
 788         if (padlist) { /* not an undef CV */
 789                 I32 fake_offset = 0;
 790                 const AV * const nameav = MUTABLE_AV(AvARRAY(padlist)[0]);
 791                 SV * const * const name_svp = AvARRAY(nameav);
 792
 793                 for (offset = AvFILLp(nameav); offset > 0; offset--) {
 794                         const SV * const namesv = name_svp[offset];
 795                         if (namesv && namesv != &PL_sv_undef
 796                                 && strEQ(SvPVX_const(namesv), name))
 797                         {
 798                                 if (SvFAKE(namesv)) {
 799                                         fake_offset = offset; /* in case we don't find a real one */
 800                                         continue;
 801                                 }
 802                                 /* is seq within the range _LOW to _HIGH ?
 803                                  * This is complicated by the fact that PL_cop_seqmax
 804                                  * may have wrapped around at some point */
 805                                 if (COP_SEQ_RANGE_LOW(namesv) == PERL_PADSEQ_INTRO)
 806                                         continue; /* not yet introduced */
 807
 808                                 if (COP_SEQ_RANGE_HIGH(namesv) == PERL_PADSEQ_INTRO) {
 809                                         /* in compiling scope */
 810                                         if (
 811                                                 (seq >  COP_SEQ_RANGE_LOW(namesv))
 812                                                 ? (seq - COP_SEQ_RANGE_LOW(namesv) < (U32_MAX >> 1))
 813                                                 : (COP_SEQ_RANGE_LOW(namesv) - seq > (U32_MAX >> 1))
 814                                         )
 815                                                 break;
 816                                 }
 817                                 else if (
 818                                         (COP_SEQ_RANGE_LOW(namesv) > COP_SEQ_RANGE_HIGH(namesv))
 819                                         ?
 820                                         (  seq >  COP_SEQ_RANGE_LOW(namesv)
 821                                            || seq <= COP_SEQ_RANGE_HIGH(namesv))
 822
 823                                         :    (  seq >  COP_SEQ_RANGE_LOW(namesv)
 824                                                         && seq <= COP_SEQ_RANGE_HIGH(namesv))
 825                                 )
 826                                         break;
 827                         }
 828                 }
 829
 830                 if (offset > 0 || fake_offset > 0 ) { /* a match! */
 831                         if (offset > 0) { /* not fake */
 832                                 fake_offset = 0;
 833                                 *out_name_sv = name_svp[offset]; /* return the namesv */
 834
 835                                 /* set PAD_FAKELEX_MULTI if this lex can have multiple
 836                                  * instances. For now, we just test !CvUNIQUE(cv), but
 837                                  * ideally, we should detect my's declared within loops
 838                                  * etc - this would allow a wider range of 'not stayed
 839                                  * shared' warnings. We also treated already-compiled
 840                                  * lexes as not multi as viewed from evals. */
 841
 842                                 *out_flags = CvANON(cv) ?
 843                                         PAD_FAKELEX_ANON :
 844                                         (!CvUNIQUE(cv) && ! CvCOMPILED(cv))
 845                                         ? PAD_FAKELEX_MULTI : 0;
 846
 847                                 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
 848                                                                            "Pad findlex cv=0x%"UVxf" matched: offset=%ld (%lu,%lu)\n",
 849                                                                            PTR2UV(cv), (long)offset,
 850                                                                            (unsigned long)COP_SEQ_RANGE_LOW(*out_name_sv),
 851                                                                            (unsigned long)COP_SEQ_RANGE_HIGH(*out_name_sv)));
 852                         }
 853                         else { /* fake match */
 854                                 offset = fake_offset;
 855                                 *out_name_sv = name_svp[offset]; /* return the namesv */
 856                                 *out_flags = PARENT_FAKELEX_FLAGS(*out_name_sv);
 857                                 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
 858                                                                            "Pad findlex cv=0x%"UVxf" matched: offset=%ld flags=0x%lx index=%lu\n",
 859                                                                            PTR2UV(cv), (long)offset, (unsigned long)*out_flags,
 860                                                                            (unsigned long) PARENT_PAD_INDEX(*out_name_sv)
 861                                 ));
 862                         }
 863
 864                         /* return the lex? */
 865
 866                         if (out_capture) {
 867
 868                                 /* our ? */
 869                                 if (SvPAD_OUR(*out_name_sv)) {
 870                                         *out_capture = NULL;
 871                                         return offset;
 872                                 }
 873
 874                                 /* trying to capture from an anon prototype? */
 875                                 if (CvCOMPILED(cv)
 876                                         ? CvANON(cv) && CvCLONE(cv) && !CvCLONED(cv)
 877                                         : *out_flags & PAD_FAKELEX_ANON)
 878                                 {
 879                                         if (warn)
 880                                                 Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE),
 881                                                                            "Variable \"%s\" is not available", name);
 882                                         *out_capture = NULL;
 883                                 }
 884
 885                                 /* real value */
 886                                 else {
 887                                         int newwarn = warn;
 888                                         if (!CvCOMPILED(cv) && (*out_flags & PAD_FAKELEX_MULTI)
 889                                                 && !SvPAD_STATE(name_svp[offset])
 890                                                 && warn && ckWARN(WARN_CLOSURE)) {
 891                                                 newwarn = 0;
 892                                                 Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
 893                                                                         "Variable \"%s\" will not stay shared", name);
 894                                         }
 895
 896                                         if (fake_offset && CvANON(cv)
 897                                                 && CvCLONE(cv) &&!CvCLONED(cv))
 898                                         {
 899                                                 SV *n;
 900                                                 /* not yet caught - look further up */
 901                                                 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
 902                                                                                            "Pad findlex cv=0x%"UVxf" chasing lex in outer pad\n",
 903                                                                                            PTR2UV(cv)));
 904                                                 n = *out_name_sv;
 905                                                 (void)S_pad_findlex(aTHX_ name, CvOUTSIDE(cv),
 906                                                                                         CvOUTSIDE_SEQ(cv),
 907                                                                                         newwarn, out_capture, out_name_sv, out_flags);
 908                                                 *out_name_sv = n;
 909                                                 return offset;
 910                                         }
 911
 912                                         *out_capture = AvARRAY(MUTABLE_AV(AvARRAY(padlist)[
 913                                                                                                           CvDEPTH(cv) ? CvDEPTH(cv) : 1]))[offset];
 914                                         DEBUG_Xv(PerlIO_printf(Perl_debug_log,
 915                                                                                    "Pad findlex cv=0x%"UVxf" found lex=0x%"UVxf"\n",
 916                                                                                    PTR2UV(cv), PTR2UV(*out_capture)));
 917
 918                                         if (SvPADSTALE(*out_capture)
 919                                                 && !SvPAD_STATE(name_svp[offset]))
 920                                         {
 921                                                 Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE),
 922                                                                            "Variable \"%s\" is not available", name);
 923                                                 *out_capture = NULL;
 924                                         }
 925                                 }
 926                                 if (!*out_capture) {
 927                                         if (*name == '@')
 928                                                 *out_capture = sv_2mortal(MUTABLE_SV(newAV()));
 929                                         else if (*name == '%')
 930                                                 *out_capture = sv_2mortal(MUTABLE_SV(newHV()));
 931                                         else
 932                                                 *out_capture = sv_newmortal();
 933                                 }
 934                         }
 935
 936                         return offset;
 937                 }
 938         }
 939
 940         /* it's not in this pad - try above */
 941
 942         if (!CvOUTSIDE(cv))
 943                 return NOT_IN_PAD;
 944
 945         /* out_capture non-null means caller wants us to capture lex; in
 946          * addition we capture ourselves unless it's an ANON/format */
 947         new_capturep = out_capture ? out_capture :
 948                 CvLATE(cv) ? NULL : &new_capture;
 949
 950         offset = S_pad_findlex(aTHX_ name, CvOUTSIDE(cv), CvOUTSIDE_SEQ(cv), 1,
 951                                                    new_capturep, out_name_sv, out_flags);
 952         if ((PADOFFSET)offset == NOT_IN_PAD)
 953                 return NOT_IN_PAD;
 954
 955         /* found in an outer CV. Add appropriate fake entry to this pad */
 956
 957         /* don't add new fake entries (via eval) to CVs that we have already
 958          * finished compiling, or to undef CVs */
 959         if (CvCOMPILED(cv) || !padlist)
 960                 return 0; /* this dummy (and invalid) value isnt used by the caller */
 961
 962         {
 963                 /* This relies on sv_setsv_flags() upgrading the destination to the same
 964                    type as the source, independent of the flags set, and on it being
 965                    "good" and only copying flag bits and pointers that it understands.
 966                    */
 967                 SV *new_namesv = newSVsv(*out_name_sv);
 968                 AV *  const ocomppad_name = PL_comppad_name;
 969                 PAD * const ocomppad = PL_comppad;
 970                 PL_comppad_name = MUTABLE_AV(AvARRAY(padlist)[0]);
 971                 PL_comppad = MUTABLE_AV(AvARRAY(padlist)[1]);
 972                 PL_curpad = AvARRAY(PL_comppad);
 973
 974                 new_offset
 975                         = pad_add_name_sv(new_namesv,
 976                                                           0,
 977                                                           SvPAD_TYPED(*out_name_sv)
 978                                                           ? SvSTASH(*out_name_sv) : NULL,
 979                                                           SvOURSTASH(*out_name_sv)
 980                         );
 981
 982                 SvFAKE_on(new_namesv);
 983                 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
 984                                                            "Pad addname: %ld \"%.*s\" FAKE\n",
 985                                                            (long)new_offset,
 986                                                            (int) SvCUR(new_namesv), SvPVX(new_namesv)));
 987                 PARENT_FAKELEX_FLAGS_set(new_namesv, *out_flags);
 988
 989                 PARENT_PAD_INDEX_set(new_namesv, 0);
 990                 if (SvPAD_OUR(new_namesv)) {
 991                         NOOP;   /* do nothing */
 992                 }
 993                 else if (CvLATE(cv)) {
 994                         /* delayed creation - just note the offset within parent pad */
 995                         PARENT_PAD_INDEX_set(new_namesv, offset);
 996                         CvCLONE_on(cv);
 997                 }
 998                 else {
 999                         /* immediate creation - capture outer value right now */
1000                         av_store(PL_comppad, new_offset, SvREFCNT_inc(*new_capturep));
1001                         DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1002                                                                    "Pad findlex cv=0x%"UVxf" saved captured sv 0x%"UVxf" at offset %ld\n",
1003                                                                    PTR2UV(cv), PTR2UV(*new_capturep), (long)new_offset));
1004                 }
1005                 *out_name_sv = new_namesv;
1006                 *out_flags = PARENT_FAKELEX_FLAGS(new_namesv);
1007
1008                 PL_comppad_name = ocomppad_name;
1009                 PL_comppad = ocomppad;
1010                 PL_curpad = ocomppad ? AvARRAY(ocomppad) : NULL;
1011         }
1012         return new_offset;
1013 #undef CvLATE
1014 #undef CvCOMPILED
1015 }
1016
1017 static PADOFFSET S_pad_findmy(pTHX_ const char *name, U32 flags) {
1018         dVAR;
1019         SV *out_sv;
1020         int out_flags;
1021         I32 offset;
1022         const AV *nameav;
1023         SV **name_svp;
1024
1025         offset = S_pad_findlex(aTHX_ name, PL_compcv, PL_cop_seqmax, 1,
1026                                                    NULL, &out_sv, &out_flags);
1027         if ((PADOFFSET)offset != NOT_IN_PAD)
1028                 return offset;
1029
1030         /* look for an our that's being introduced; this allows
1031          *    our $foo = 0 unless defined $foo;
1032          * to not give a warning. (Yes, this is a hack) */
1033
1034         nameav = MUTABLE_AV(AvARRAY(CvPADLIST(PL_compcv))[0]);
1035         name_svp = AvARRAY(nameav);
1036         for (offset = AvFILLp(nameav); offset > 0; offset--) {
1037                 const SV * const namesv = name_svp[offset];
1038                 if (namesv && namesv != &PL_sv_undef
1039                         && !SvFAKE(namesv)
1040                         && (SvPAD_OUR(namesv))
1041                         && strEQ(SvPVX_const(namesv), name)
1042                         && COP_SEQ_RANGE_LOW(namesv) == PERL_PADSEQ_INTRO
1043                 )
1044                         return offset;
1045         }
1046         return NOT_IN_PAD;
1047 }
1048
1049 #endif