op.c

   1 /*    op.c
   2  *
   3  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
   4  *    2000, 2001, 2002, 2003, 2004, 2005, by Larry Wall and others
   5  *
   6  *    You may distribute under the terms of either the GNU General Public
   7  *    License or the Artistic License, as specified in the README file.
   8  *
   9  */
  10
  11 /*
  12  * "You see: Mr. Drogo, he married poor Miss Primula Brandybuck.  She was
  13  * our Mr. Bilbo's first cousin on the mother's side (her mother being the
  14  * youngest of the Old Took's daughters); and Mr. Drogo was his second
  15  * cousin.  So Mr. Frodo is his first *and* second cousin, once removed
  16  * either way, as the saying is, if you follow me."  --the Gaffer
  17  */
  18
  19 /* This file contains the functions that create, manipulate and optimize
  20  * the OP structures that hold a compiled perl program.
  21  *
  22  * A Perl program is compiled into a tree of OPs. Each op contains
  23  * structural pointers (eg to its siblings and the next op in the
  24  * execution sequence), a pointer to the function that would execute the
  25  * op, plus any data specific to that op. For example, an OP_CONST op
  26  * points to the pp_const() function and to an SV containing the constant
  27  * value. When pp_const() is executed, its job is to push that SV onto the
  28  * stack.
  29  *
  30  * OPs are mainly created by the newFOO() functions, which are mainly
  31  * called from the parser (in perly.y) as the code is parsed. For example
  32  * the Perl code $a + $b * $c would cause the equivalent of the following
  33  * to be called (oversimplifying a bit):
  34  *
  35  *  newBINOP(OP_ADD, flags,
  36  *      newSVREF($a),
  37  *      newBINOP(OP_MULTIPLY, flags, newSVREF($b), newSVREF($c))
  38  *  )
  39  *
  40  * Note that during the build of miniperl, a temporary copy of this file
  41  * is made, called opmini.c.
  42  */
  43
  44 /*
  45 Perl's compiler is essentially a 3-pass compiler with interleaved phases:
  46
  47     A bottom-up pass
  48     A top-down pass
  49     An execution-order pass
  50
  51 The bottom-up pass is represented by all the "newOP" routines and
  52 the ck_ routines.  The bottom-upness is actually driven by yacc.
  53 So at the point that a ck_ routine fires, we have no idea what the
  54 context is, either upward in the syntax tree, or either forward or
  55 backward in the execution order.  (The bottom-up parser builds that
  56 part of the execution order it knows about, but if you follow the "next"
  57 links around, you'll find it's actually a closed loop through the
  58 top level node.
  59
  60 Whenever the bottom-up parser gets to a node that supplies context to
  61 its components, it invokes that portion of the top-down pass that applies
  62 to that part of the subtree (and marks the top node as processed, so
  63 if a node further up supplies context, it doesn't have to take the
  64 plunge again).  As a particular subcase of this, as the new node is
  65 built, it takes all the closed execution loops of its subcomponents
  66 and links them into a new closed loop for the higher level node.  But
  67 it's still not the real execution order.
  68
  69 The actual execution order is not known till we get a grammar reduction
  70 to a top-level unit like a subroutine or file that will be called by
  71 "name" rather than via a "next" pointer.  At that point, we can call
  72 into peep() to do that code's portion of the 3rd pass.  It has to be
  73 recursive, but it's recursive on basic blocks, not on tree nodes.
  74 */
  75
  76 #include "EXTERN.h"
  77 #define PERL_IN_OP_C
  78 #include "perl.h"
  79 #include "keywords.h"
  80
  81 #define CALL_PEEP(o) CALL_FPTR(PL_peepp)(aTHX_ o)
  82
  83 #if defined(PL_OP_SLAB_ALLOC)
  84
  85 #ifndef PERL_SLAB_SIZE
  86 #define PERL_SLAB_SIZE 2048
  87 #endif
  88
  89 void *
  90 Perl_Slab_Alloc(pTHX_ int m, size_t sz)
  91 {
  92     /*
  93      * To make incrementing use count easy PL_OpSlab is an I32 *
  94      * To make inserting the link to slab PL_OpPtr is I32 **
  95      * So compute size in units of sizeof(I32 *) as that is how Pl_OpPtr increments
  96      * Add an overhead for pointer to slab and round up as a number of pointers
  97      */
  98     sz = (sz + 2*sizeof(I32 *) -1)/sizeof(I32 *);
  99     if ((PL_OpSpace -= sz) < 0) {
 100         PL_OpPtr = (I32 **) PerlMemShared_malloc(PERL_SLAB_SIZE*sizeof(I32*));
 101         if (!PL_OpPtr) {
 102             return NULL;
 103         }
 104         Zero(PL_OpPtr,PERL_SLAB_SIZE,I32 **);
 105         /* We reserve the 0'th I32 sized chunk as a use count */
 106         PL_OpSlab = (I32 *) PL_OpPtr;
 107         /* Reduce size by the use count word, and by the size we need.
 108          * Latter is to mimic the '-=' in the if() above
 109          */
 110         PL_OpSpace = PERL_SLAB_SIZE - (sizeof(I32)+sizeof(I32 **)-1)/sizeof(I32 **) - sz;
 111         /* Allocation pointer starts at the top.
 112            Theory: because we build leaves before trunk allocating at end
 113            means that at run time access is cache friendly upward
 114          */
 115         PL_OpPtr += PERL_SLAB_SIZE;
 116     }
 117     assert( PL_OpSpace >= 0 );
 118     /* Move the allocation pointer down */
 119     PL_OpPtr   -= sz;
 120     assert( PL_OpPtr > (I32 **) PL_OpSlab );
 121     *PL_OpPtr   = PL_OpSlab;    /* Note which slab it belongs to */
 122     (*PL_OpSlab)++;             /* Increment use count of slab */
 123     assert( PL_OpPtr+sz <= ((I32 **) PL_OpSlab + PERL_SLAB_SIZE) );
 124     assert( *PL_OpSlab > 0 );
 125     return (void *)(PL_OpPtr + 1);
 126 }
 127
 128 void
 129 Perl_Slab_Free(pTHX_ void *op)
 130 {
 131     I32 **ptr = (I32 **) op;
 132     I32 *slab = ptr[-1];
 133     assert( ptr-1 > (I32 **) slab );
 134     assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
 135     assert( *slab > 0 );
 136     if (--(*slab) == 0) {
 137 #  ifdef NETWARE
 138 #    define PerlMemShared PerlMem
 139 #  endif
 140
 141     PerlMemShared_free(slab);
 142         if (slab == PL_OpSlab) {
 143             PL_OpSpace = 0;
 144         }
 145     }
 146 }
 147 #endif
 148 /*
 149  * In the following definition, the ", Nullop" is just to make the compiler
 150  * think the expression is of the right type: croak actually does a Siglongjmp.
 151  */
 152 #define CHECKOP(type,o) \
 153     ((PL_op_mask && PL_op_mask[type])                                   \
 154      ? ( op_free((OP*)o),                                       \
 155          Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]),  \
 156          Nullop )                                               \
 157      : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o))
 158
 159 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
 160
 161 STATIC char*
 162 S_gv_ename(pTHX_ GV *gv)
 163 {
 164     STRLEN n_a;
 165     SV* tmpsv = sv_newmortal();
 166     gv_efullname3(tmpsv, gv, Nullch);
 167     return SvPV(tmpsv,n_a);
 168 }
 169
 170 STATIC OP *
 171 S_no_fh_allowed(pTHX_ OP *o)
 172 {
 173     yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
 174                  OP_DESC(o)));
 175     return o;
 176 }
 177
 178 STATIC OP *
 179 S_too_few_arguments(pTHX_ OP *o, const char *name)
 180 {
 181     yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
 182     return o;
 183 }
 184
 185 STATIC OP *
 186 S_too_many_arguments(pTHX_ OP *o, const char *name)
 187 {
 188     yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
 189     return o;
 190 }
 191
 192 STATIC void
 193 S_bad_type(pTHX_ I32 n, const char *t, const char *name, const OP *kid)
 194 {
 195     yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
 196                  (int)n, name, t, OP_DESC(kid)));
 197 }
 198
 199 STATIC void
 200 S_no_bareword_allowed(pTHX_ const OP *o)
 201 {
 202     qerror(Perl_mess(aTHX_
 203                      "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
 204                      cSVOPo_sv));
 205 }
 206
 207 /* "register" allocation */
 208
 209 PADOFFSET
 210 Perl_allocmy(pTHX_ char *name)
 211 {
 212     PADOFFSET off;
 213
 214     /* complain about "my $<special_var>" etc etc */
 215     if (!(PL_in_my == KEY_our ||
 216           isALPHA(name[1]) ||
 217           (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
 218           (name[1] == '_' && (*name == '$' || (int)strlen(name) > 2))))
 219     {
 220         if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
 221             /* 1999-02-27 mjd@plover.com */
 222             char *p;
 223             p = strchr(name, '\0');
 224             /* The next block assumes the buffer is at least 205 chars
 225                long.  At present, it's always at least 256 chars. */
 226             if (p-name > 200) {
 227                 strcpy(name+200, "...");
 228                 p = name+199;
 229             }
 230             else {
 231                 p[1] = '\0';
 232             }
 233             /* Move everything else down one character */
 234             for (; p-name > 2; p--)
 235                 *p = *(p-1);
 236             name[2] = toCTRL(name[1]);
 237             name[1] = '^';
 238         }
 239         yyerror(Perl_form(aTHX_ "Can't use global %s in \"my\"",name));
 240     }
 241
 242     /* check for duplicate declaration */
 243     pad_check_dup(name,
 244                 (bool)(PL_in_my == KEY_our),
 245                 (PL_curstash ? PL_curstash : PL_defstash)
 246     );
 247
 248     if (PL_in_my_stash && *name != '$') {
 249         yyerror(Perl_form(aTHX_
 250                     "Can't declare class for non-scalar %s in \"%s\"",
 251                      name, PL_in_my == KEY_our ? "our" : "my"));
 252     }
 253
 254     /* allocate a spare slot and store the name in that slot */
 255
 256     off = pad_add_name(name,
 257                     PL_in_my_stash,
 258                     (PL_in_my == KEY_our
 259                         /* $_ is always in main::, even with our */
 260                         ? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash)
 261                         : Nullhv
 262                     ),
 263                     0 /*  not fake */
 264     );
 265     return off;
 266 }
 267
 268 /* Destructor */
 269
 270 void
 271 Perl_op_free(pTHX_ OP *o)
 272 {
 273     OPCODE type;
 274     PADOFFSET refcnt;
 275
 276     if (!o || o->op_static)
 277         return;
 278
 279     if (o->op_private & OPpREFCOUNTED) {
 280         switch (o->op_type) {
 281         case OP_LEAVESUB:
 282         case OP_LEAVESUBLV:
 283         case OP_LEAVEEVAL:
 284         case OP_LEAVE:
 285         case OP_SCOPE:
 286         case OP_LEAVEWRITE:
 287             OP_REFCNT_LOCK;
 288             refcnt = OpREFCNT_dec(o);
 289             OP_REFCNT_UNLOCK;
 290             if (refcnt)
 291                 return;
 292             break;
 293         default:
 294             break;
 295         }
 296     }
 297
 298     if (o->op_flags & OPf_KIDS) {
 299         register OP *kid, *nextkid;
 300         for (kid = cUNOPo->op_first; kid; kid = nextkid) {
 301             nextkid = kid->op_sibling; /* Get before next freeing kid */
 302             op_free(kid);
 303         }
 304     }
 305     type = o->op_type;
 306     if (type == OP_NULL)
 307         type = (OPCODE)o->op_targ;
 308
 309     /* COP* is not cleared by op_clear() so that we may track line
 310      * numbers etc even after null() */
 311     if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE)
 312         cop_free((COP*)o);
 313
 314     op_clear(o);
 315     FreeOp(o);
 316 #ifdef DEBUG_LEAKING_SCALARS
 317     if (PL_op == o)
 318         PL_op = Nullop;
 319 #endif
 320 }
 321
 322 void
 323 Perl_op_clear(pTHX_ OP *o)
 324 {
 325
 326     switch (o->op_type) {
 327     case OP_NULL:       /* Was holding old type, if any. */
 328     case OP_ENTEREVAL:  /* Was holding hints. */
 329         o->op_targ = 0;
 330         break;
 331     default:
 332         if (!(o->op_flags & OPf_REF)
 333             || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
 334             break;
 335         /* FALL THROUGH */
 336     case OP_GVSV:
 337     case OP_GV:
 338     case OP_AELEMFAST:
 339         if (! (o->op_type == OP_AELEMFAST && o->op_flags & OPf_SPECIAL)) {
 340             /* not an OP_PADAV replacement */
 341 #ifdef USE_ITHREADS
 342             if (cPADOPo->op_padix > 0) {
 343                 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
 344                  * may still exist on the pad */
 345                 pad_swipe(cPADOPo->op_padix, TRUE);
 346                 cPADOPo->op_padix = 0;
 347             }
 348 #else
 349             SvREFCNT_dec(cSVOPo->op_sv);
 350             cSVOPo->op_sv = Nullsv;
 351 #endif
 352         }
 353         break;
 354     case OP_METHOD_NAMED:
 355     case OP_CONST:
 356         SvREFCNT_dec(cSVOPo->op_sv);
 357         cSVOPo->op_sv = Nullsv;
 358 #ifdef USE_ITHREADS
 359         /** Bug #15654
 360           Even if op_clear does a pad_free for the target of the op,
 361           pad_free doesn't actually remove the sv that exists in the pad;
 362           instead it lives on. This results in that it could be reused as
 363           a target later on when the pad was reallocated.
 364         **/
 365         if(o->op_targ) {
 366           pad_swipe(o->op_targ,1);
 367           o->op_targ = 0;
 368         }
 369 #endif
 370         break;
 371     case OP_GOTO:
 372     case OP_NEXT:
 373     case OP_LAST:
 374     case OP_REDO:
 375         if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
 376             break;
 377         /* FALL THROUGH */
 378     case OP_TRANS:
 379         if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
 380             SvREFCNT_dec(cSVOPo->op_sv);
 381             cSVOPo->op_sv = Nullsv;
 382         }
 383         else {
 384             Safefree(cPVOPo->op_pv);
 385             cPVOPo->op_pv = Nullch;
 386         }
 387         break;
 388     case OP_SUBST:
 389         op_free(cPMOPo->op_pmreplroot);
 390         goto clear_pmop;
 391     case OP_PUSHRE:
 392 #ifdef USE_ITHREADS
 393         if (INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)) {
 394             /* No GvIN_PAD_off here, because other references may still
 395              * exist on the pad */
 396             pad_swipe(INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot), TRUE);
 397         }
 398 #else
 399         SvREFCNT_dec((SV*)cPMOPo->op_pmreplroot);
 400 #endif
 401         /* FALL THROUGH */
 402     case OP_MATCH:
 403     case OP_QR:
 404 clear_pmop:
 405         {
 406             HV *pmstash = PmopSTASH(cPMOPo);
 407             if (pmstash && SvREFCNT(pmstash)) {
 408                 PMOP *pmop = HvPMROOT(pmstash);
 409                 PMOP *lastpmop = NULL;
 410                 while (pmop) {
 411                     if (cPMOPo == pmop) {
 412                         if (lastpmop)
 413                             lastpmop->op_pmnext = pmop->op_pmnext;
 414                         else
 415                             HvPMROOT(pmstash) = pmop->op_pmnext;
 416                         break;
 417                     }
 418                     lastpmop = pmop;
 419                     pmop = pmop->op_pmnext;
 420                 }
 421             }
 422             PmopSTASH_free(cPMOPo);
 423         }
 424         cPMOPo->op_pmreplroot = Nullop;
 425         /* we use the "SAFE" version of the PM_ macros here
 426          * since sv_clean_all might release some PMOPs
 427          * after PL_regex_padav has been cleared
 428          * and the clearing of PL_regex_padav needs to
 429          * happen before sv_clean_all
 430          */
 431         ReREFCNT_dec(PM_GETRE_SAFE(cPMOPo));
 432         PM_SETRE_SAFE(cPMOPo, (REGEXP*)NULL);
 433 #ifdef USE_ITHREADS
 434         if(PL_regex_pad) {        /* We could be in destruction */
 435             av_push((AV*) PL_regex_pad[0],(SV*) PL_regex_pad[(cPMOPo)->op_pmoffset]);
 436             SvREPADTMP_on(PL_regex_pad[(cPMOPo)->op_pmoffset]);
 437             PM_SETRE(cPMOPo, (cPMOPo)->op_pmoffset);
 438         }
 439 #endif
 440
 441         break;
 442     }
 443
 444     if (o->op_targ > 0) {
 445         pad_free(o->op_targ);
 446         o->op_targ = 0;
 447     }
 448 }
 449
 450 STATIC void
 451 S_cop_free(pTHX_ COP* cop)
 452 {
 453     Safefree(cop->cop_label);   /* FIXME: treaddead ??? */
 454     CopFILE_free(cop);
 455     CopSTASH_free(cop);
 456     if (! specialWARN(cop->cop_warnings))
 457         SvREFCNT_dec(cop->cop_warnings);
 458     if (! specialCopIO(cop->cop_io)) {
 459 #ifdef USE_ITHREADS
 460 #if 0
 461         STRLEN len;
 462         char *s = SvPV(cop->cop_io,len);
 463         Perl_warn(aTHX_ "io='%.*s'",(int) len,s); /* ??? --jhi */
 464 #endif
 465 #else
 466         SvREFCNT_dec(cop->cop_io);
 467 #endif
 468     }
 469 }
 470
 471 void
 472 Perl_op_null(pTHX_ OP *o)
 473 {
 474     if (o->op_type == OP_NULL)
 475         return;
 476     op_clear(o);
 477     o->op_targ = o->op_type;
 478     o->op_type = OP_NULL;
 479     o->op_ppaddr = PL_ppaddr[OP_NULL];
 480 }
 481
 482 void
 483 Perl_op_refcnt_lock(pTHX)
 484 {
 485     OP_REFCNT_LOCK;
 486 }
 487
 488 void
 489 Perl_op_refcnt_unlock(pTHX)
 490 {
 491     OP_REFCNT_UNLOCK;
 492 }
 493
 494 /* Contextualizers */
 495
 496 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
 497
 498 OP *
 499 Perl_linklist(pTHX_ OP *o)
 500 {
 501
 502     if (o->op_next)
 503         return o->op_next;
 504
 505     /* establish postfix order */
 506     if (cUNOPo->op_first) {
 507         register OP *kid;
 508         o->op_next = LINKLIST(cUNOPo->op_first);
 509         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
 510             if (kid->op_sibling)
 511                 kid->op_next = LINKLIST(kid->op_sibling);
 512             else
 513                 kid->op_next = o;
 514         }
 515     }
 516     else
 517         o->op_next = o;
 518
 519     return o->op_next;
 520 }
 521
 522 OP *
 523 Perl_scalarkids(pTHX_ OP *o)
 524 {
 525     if (o && o->op_flags & OPf_KIDS) {
 526         OP *kid;
 527         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
 528             scalar(kid);
 529     }
 530     return o;
 531 }
 532
 533 STATIC OP *
 534 S_scalarboolean(pTHX_ OP *o)
 535 {
 536     if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
 537         if (ckWARN(WARN_SYNTAX)) {
 538             const line_t oldline = CopLINE(PL_curcop);
 539
 540             if (PL_copline != NOLINE)
 541                 CopLINE_set(PL_curcop, PL_copline);
 542             Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
 543             CopLINE_set(PL_curcop, oldline);
 544         }
 545     }
 546     return scalar(o);
 547 }
 548
 549 OP *
 550 Perl_scalar(pTHX_ OP *o)
 551 {
 552     OP *kid;
 553
 554     /* assumes no premature commitment */
 555     if (!o || (o->op_flags & OPf_WANT) || PL_error_count
 556          || o->op_type == OP_RETURN)
 557     {
 558         return o;
 559     }
 560
 561     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
 562
 563     switch (o->op_type) {
 564     case OP_REPEAT:
 565         scalar(cBINOPo->op_first);
 566         break;
 567     case OP_OR:
 568     case OP_AND:
 569     case OP_COND_EXPR:
 570         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
 571             scalar(kid);
 572         break;
 573     case OP_SPLIT:
 574         if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
 575             if (!kPMOP->op_pmreplroot)
 576                 deprecate_old("implicit split to @_");
 577         }
 578         /* FALL THROUGH */
 579     case OP_MATCH:
 580     case OP_QR:
 581     case OP_SUBST:
 582     case OP_NULL:
 583     default:
 584         if (o->op_flags & OPf_KIDS) {
 585             for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
 586                 scalar(kid);
 587         }
 588         break;
 589     case OP_LEAVE:
 590     case OP_LEAVETRY:
 591         kid = cLISTOPo->op_first;
 592         scalar(kid);
 593         while ((kid = kid->op_sibling)) {
 594             if (kid->op_sibling)
 595                 scalarvoid(kid);
 596             else
 597                 scalar(kid);
 598         }
 599         WITH_THR(PL_curcop = &PL_compiling);
 600         break;
 601     case OP_SCOPE:
 602     case OP_LINESEQ:
 603     case OP_LIST:
 604         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
 605             if (kid->op_sibling)
 606                 scalarvoid(kid);
 607             else
 608                 scalar(kid);
 609         }
 610         WITH_THR(PL_curcop = &PL_compiling);
 611         break;
 612     case OP_SORT:
 613         if (ckWARN(WARN_VOID))
 614             Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
 615     }
 616     return o;
 617 }
 618
 619 OP *
 620 Perl_scalarvoid(pTHX_ OP *o)
 621 {
 622     OP *kid;
 623     const char* useless = 0;
 624     SV* sv;
 625     U8 want;
 626
 627     if (o->op_type == OP_NEXTSTATE
 628         || o->op_type == OP_SETSTATE
 629         || o->op_type == OP_DBSTATE
 630         || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
 631                                       || o->op_targ == OP_SETSTATE
 632                                       || o->op_targ == OP_DBSTATE)))
 633         PL_curcop = (COP*)o;            /* for warning below */
 634
 635     /* assumes no premature commitment */
 636     want = o->op_flags & OPf_WANT;
 637     if ((want && want != OPf_WANT_SCALAR) || PL_error_count
 638          || o->op_type == OP_RETURN)
 639     {
 640         return o;
 641     }
 642
 643     if ((o->op_private & OPpTARGET_MY)
 644         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
 645     {
 646         return scalar(o);                       /* As if inside SASSIGN */
 647     }
 648
 649     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
 650
 651     switch (o->op_type) {
 652     default:
 653         if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
 654             break;
 655         /* FALL THROUGH */
 656     case OP_REPEAT:
 657         if (o->op_flags & OPf_STACKED)
 658             break;
 659         goto func_ops;
 660     case OP_SUBSTR:
 661         if (o->op_private == 4)
 662             break;
 663         /* FALL THROUGH */
 664     case OP_GVSV:
 665     case OP_WANTARRAY:
 666     case OP_GV:
 667     case OP_PADSV:
 668     case OP_PADAV:
 669     case OP_PADHV:
 670     case OP_PADANY:
 671     case OP_AV2ARYLEN:
 672     case OP_REF:
 673     case OP_REFGEN:
 674     case OP_SREFGEN:
 675     case OP_DEFINED:
 676     case OP_HEX:
 677     case OP_OCT:
 678     case OP_LENGTH:
 679     case OP_VEC:
 680     case OP_INDEX:
 681     case OP_RINDEX:
 682     case OP_SPRINTF:
 683     case OP_AELEM:
 684     case OP_AELEMFAST:
 685     case OP_ASLICE:
 686     case OP_HELEM:
 687     case OP_HSLICE:
 688     case OP_UNPACK:
 689     case OP_PACK:
 690     case OP_JOIN:
 691     case OP_LSLICE:
 692     case OP_ANONLIST:
 693     case OP_ANONHASH:
 694     case OP_SORT:
 695     case OP_REVERSE:
 696     case OP_RANGE:
 697     case OP_FLIP:
 698     case OP_FLOP:
 699     case OP_CALLER:
 700     case OP_FILENO:
 701     case OP_EOF:
 702     case OP_TELL:
 703     case OP_GETSOCKNAME:
 704     case OP_GETPEERNAME:
 705     case OP_READLINK:
 706     case OP_TELLDIR:
 707     case OP_GETPPID:
 708     case OP_GETPGRP:
 709     case OP_GETPRIORITY:
 710     case OP_TIME:
 711     case OP_TMS:
 712     case OP_LOCALTIME:
 713     case OP_GMTIME:
 714     case OP_GHBYNAME:
 715     case OP_GHBYADDR:
 716     case OP_GHOSTENT:
 717     case OP_GNBYNAME:
 718     case OP_GNBYADDR:
 719     case OP_GNETENT:
 720     case OP_GPBYNAME:
 721     case OP_GPBYNUMBER:
 722     case OP_GPROTOENT:
 723     case OP_GSBYNAME:
 724     case OP_GSBYPORT:
 725     case OP_GSERVENT:
 726     case OP_GPWNAM:
 727     case OP_GPWUID:
 728     case OP_GGRNAM:
 729     case OP_GGRGID:
 730     case OP_GETLOGIN:
 731     case OP_PROTOTYPE:
 732       func_ops:
 733         if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
 734             useless = OP_DESC(o);
 735         break;
 736
 737     case OP_NOT:
 738        kid = cUNOPo->op_first;
 739        if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
 740            kid->op_type != OP_TRANS) {
 741                 goto func_ops;
 742        }
 743        useless = "negative pattern binding (!~)";
 744        break;
 745
 746     case OP_RV2GV:
 747     case OP_RV2SV:
 748     case OP_RV2AV:
 749     case OP_RV2HV:
 750         if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
 751                 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
 752             useless = "a variable";
 753         break;
 754
 755     case OP_CONST:
 756         sv = cSVOPo_sv;
 757         if (cSVOPo->op_private & OPpCONST_STRICT)
 758             no_bareword_allowed(o);
 759         else {
 760             if (ckWARN(WARN_VOID)) {
 761                 useless = "a constant";
 762                 /* don't warn on optimised away booleans, eg
 763                  * use constant Foo, 5; Foo || print; */
 764                 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
 765                     useless = 0;
 766                 /* the constants 0 and 1 are permitted as they are
 767                    conventionally used as dummies in constructs like
 768                         1 while some_condition_with_side_effects;  */
 769                 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
 770                     useless = 0;
 771                 else if (SvPOK(sv)) {
 772                   /* perl4's way of mixing documentation and code
 773                      (before the invention of POD) was based on a
 774                      trick to mix nroff and perl code. The trick was
 775                      built upon these three nroff macros being used in
 776                      void context. The pink camel has the details in
 777                      the script wrapman near page 319. */
 778                     if (strnEQ(SvPVX(sv), "di", 2) ||
 779                         strnEQ(SvPVX(sv), "ds", 2) ||
 780                         strnEQ(SvPVX(sv), "ig", 2))
 781                             useless = 0;
 782                 }
 783             }
 784         }
 785         op_null(o);             /* don't execute or even remember it */
 786         break;
 787
 788     case OP_POSTINC:
 789         o->op_type = OP_PREINC;         /* pre-increment is faster */
 790         o->op_ppaddr = PL_ppaddr[OP_PREINC];
 791         break;
 792
 793     case OP_POSTDEC:
 794         o->op_type = OP_PREDEC;         /* pre-decrement is faster */
 795         o->op_ppaddr = PL_ppaddr[OP_PREDEC];
 796         break;
 797
 798     case OP_OR:
 799     case OP_AND:
 800     case OP_DOR:
 801     case OP_COND_EXPR:
 802         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
 803             scalarvoid(kid);
 804         break;
 805
 806     case OP_NULL:
 807         if (o->op_flags & OPf_STACKED)
 808             break;
 809         /* FALL THROUGH */
 810     case OP_NEXTSTATE:
 811     case OP_DBSTATE:
 812     case OP_ENTERTRY:
 813     case OP_ENTER:
 814         if (!(o->op_flags & OPf_KIDS))
 815             break;
 816         /* FALL THROUGH */
 817     case OP_SCOPE:
 818     case OP_LEAVE:
 819     case OP_LEAVETRY:
 820     case OP_LEAVELOOP:
 821     case OP_LINESEQ:
 822     case OP_LIST:
 823         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
 824             scalarvoid(kid);
 825         break;
 826     case OP_ENTEREVAL:
 827         scalarkids(o);
 828         break;
 829     case OP_REQUIRE:
 830         /* all requires must return a boolean value */
 831         o->op_flags &= ~OPf_WANT;
 832         /* FALL THROUGH */
 833     case OP_SCALAR:
 834         return scalar(o);
 835     case OP_SPLIT:
 836         if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
 837             if (!kPMOP->op_pmreplroot)
 838                 deprecate_old("implicit split to @_");
 839         }
 840         break;
 841     }
 842     if (useless && ckWARN(WARN_VOID))
 843         Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
 844     return o;
 845 }
 846
 847 OP *
 848 Perl_listkids(pTHX_ OP *o)
 849 {
 850     if (o && o->op_flags & OPf_KIDS) {
 851         OP *kid;
 852         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
 853             list(kid);
 854     }
 855     return o;
 856 }
 857
 858 OP *
 859 Perl_list(pTHX_ OP *o)
 860 {
 861     OP *kid;
 862
 863     /* assumes no premature commitment */
 864     if (!o || (o->op_flags & OPf_WANT) || PL_error_count
 865          || o->op_type == OP_RETURN)
 866     {
 867         return o;
 868     }
 869
 870     if ((o->op_private & OPpTARGET_MY)
 871         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
 872     {
 873         return o;                               /* As if inside SASSIGN */
 874     }
 875
 876     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
 877
 878     switch (o->op_type) {
 879     case OP_FLOP:
 880     case OP_REPEAT:
 881         list(cBINOPo->op_first);
 882         break;
 883     case OP_OR:
 884     case OP_AND:
 885     case OP_COND_EXPR:
 886         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
 887             list(kid);
 888         break;
 889     default:
 890     case OP_MATCH:
 891     case OP_QR:
 892     case OP_SUBST:
 893     case OP_NULL:
 894         if (!(o->op_flags & OPf_KIDS))
 895             break;
 896         if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
 897             list(cBINOPo->op_first);
 898             return gen_constant_list(o);
 899         }
 900     case OP_LIST:
 901         listkids(o);
 902         break;
 903     case OP_LEAVE:
 904     case OP_LEAVETRY:
 905         kid = cLISTOPo->op_first;
 906         list(kid);
 907         while ((kid = kid->op_sibling)) {
 908             if (kid->op_sibling)
 909                 scalarvoid(kid);
 910             else
 911                 list(kid);
 912         }
 913         WITH_THR(PL_curcop = &PL_compiling);
 914         break;
 915     case OP_SCOPE:
 916     case OP_LINESEQ:
 917         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
 918             if (kid->op_sibling)
 919                 scalarvoid(kid);
 920             else
 921                 list(kid);
 922         }
 923         WITH_THR(PL_curcop = &PL_compiling);
 924         break;
 925     case OP_REQUIRE:
 926         /* all requires must return a boolean value */
 927         o->op_flags &= ~OPf_WANT;
 928         return scalar(o);
 929     }
 930     return o;
 931 }
 932
 933 OP *
 934 Perl_scalarseq(pTHX_ OP *o)
 935 {
 936     if (o) {
 937         if (o->op_type == OP_LINESEQ ||
 938              o->op_type == OP_SCOPE ||
 939              o->op_type == OP_LEAVE ||
 940              o->op_type == OP_LEAVETRY)
 941         {
 942             OP *kid;
 943             for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
 944                 if (kid->op_sibling) {
 945                     scalarvoid(kid);
 946                 }
 947             }
 948             PL_curcop = &PL_compiling;
 949         }
 950         o->op_flags &= ~OPf_PARENS;
 951         if (PL_hints & HINT_BLOCK_SCOPE)
 952             o->op_flags |= OPf_PARENS;
 953     }
 954     else
 955         o = newOP(OP_STUB, 0);
 956     return o;
 957 }
 958
 959 STATIC OP *
 960 S_modkids(pTHX_ OP *o, I32 type)
 961 {
 962     if (o && o->op_flags & OPf_KIDS) {
 963         OP *kid;
 964         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
 965             mod(kid, type);
 966     }
 967     return o;
 968 }
 969
 970 /* Propagate lvalue ("modifiable") context to an op and it's children.
 971  * 'type' represents the context type, roughly based on the type of op that
 972  * would do the modifying, although local() is represented by OP_NULL.
 973  * It's responsible for detecting things that can't be modified,  flag
 974  * things that need to behave specially in an lvalue context (e.g., "$$x = 5"
 975  * might have to vivify a reference in $x), and so on.
 976  *
 977  * For example, "$a+1 = 2" would cause mod() to be called with o being
 978  * OP_ADD and type being OP_SASSIGN, and would output an error.
 979  */
 980
 981 OP *
 982 Perl_mod(pTHX_ OP *o, I32 type)
 983 {
 984     OP *kid;
 985     /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
 986     int localize = -1;
 987
 988     if (!o || PL_error_count)
 989         return o;
 990
 991     if ((o->op_private & OPpTARGET_MY)
 992         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
 993     {
 994         return o;
 995     }
 996
 997     switch (o->op_type) {
 998     case OP_UNDEF:
 999         localize = 0;
1000         PL_modcount++;
1001         return o;
1002     case OP_CONST:
1003         if (!(o->op_private & (OPpCONST_ARYBASE)))
1004             goto nomod;
1005         if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1006             PL_compiling.cop_arybase = (I32)SvIV(cSVOPx(PL_eval_start)->op_sv);
1007             PL_eval_start = 0;
1008         }
1009         else if (!type) {
1010             SAVEI32(PL_compiling.cop_arybase);
1011             PL_compiling.cop_arybase = 0;
1012         }
1013         else if (type == OP_REFGEN)
1014             goto nomod;
1015         else
1016             Perl_croak(aTHX_ "That use of $[ is unsupported");
1017         break;
1018     case OP_STUB:
1019         if (o->op_flags & OPf_PARENS)
1020             break;
1021         goto nomod;
1022     case OP_ENTERSUB:
1023         if ((type == OP_UNDEF || type == OP_REFGEN) &&
1024             !(o->op_flags & OPf_STACKED)) {
1025             o->op_type = OP_RV2CV;              /* entersub => rv2cv */
1026             o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1027             assert(cUNOPo->op_first->op_type == OP_NULL);
1028             op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1029             break;
1030         }
1031         else if (o->op_private & OPpENTERSUB_NOMOD)
1032             return o;
1033         else {                          /* lvalue subroutine call */
1034             o->op_private |= OPpLVAL_INTRO;
1035             PL_modcount = RETURN_UNLIMITED_NUMBER;
1036             if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1037                 /* Backward compatibility mode: */
1038                 o->op_private |= OPpENTERSUB_INARGS;
1039                 break;
1040             }
1041             else {                      /* Compile-time error message: */
1042                 OP *kid = cUNOPo->op_first;
1043                 CV *cv;
1044                 OP *okid;
1045
1046                 if (kid->op_type == OP_PUSHMARK)
1047                     goto skip_kids;
1048                 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1049                     Perl_croak(aTHX_
1050                                "panic: unexpected lvalue entersub "
1051                                "args: type/targ %ld:%"UVuf,
1052                                (long)kid->op_type, (UV)kid->op_targ);
1053                 kid = kLISTOP->op_first;
1054               skip_kids:
1055                 while (kid->op_sibling)
1056                     kid = kid->op_sibling;
1057                 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1058                     /* Indirect call */
1059                     if (kid->op_type == OP_METHOD_NAMED
1060                         || kid->op_type == OP_METHOD)
1061                     {
1062                         UNOP *newop;
1063
1064                         NewOp(1101, newop, 1, UNOP);
1065                         newop->op_type = OP_RV2CV;
1066                         newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1067                         newop->op_first = Nullop;
1068                         newop->op_next = (OP*)newop;
1069                         kid->op_sibling = (OP*)newop;
1070                         newop->op_private |= OPpLVAL_INTRO;
1071                         break;
1072                     }
1073
1074                     if (kid->op_type != OP_RV2CV)
1075                         Perl_croak(aTHX_
1076                                    "panic: unexpected lvalue entersub "
1077                                    "entry via type/targ %ld:%"UVuf,
1078                                    (long)kid->op_type, (UV)kid->op_targ);
1079                     kid->op_private |= OPpLVAL_INTRO;
1080                     break;      /* Postpone until runtime */
1081                 }
1082
1083                 okid = kid;
1084                 kid = kUNOP->op_first;
1085                 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1086                     kid = kUNOP->op_first;
1087                 if (kid->op_type == OP_NULL)
1088                     Perl_croak(aTHX_
1089                                "Unexpected constant lvalue entersub "
1090                                "entry via type/targ %ld:%"UVuf,
1091                                (long)kid->op_type, (UV)kid->op_targ);
1092                 if (kid->op_type != OP_GV) {
1093                     /* Restore RV2CV to check lvalueness */
1094                   restore_2cv:
1095                     if (kid->op_next && kid->op_next != kid) { /* Happens? */
1096                         okid->op_next = kid->op_next;
1097                         kid->op_next = okid;
1098                     }
1099                     else
1100                         okid->op_next = Nullop;
1101                     okid->op_type = OP_RV2CV;
1102                     okid->op_targ = 0;
1103                     okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1104                     okid->op_private |= OPpLVAL_INTRO;
1105                     break;
1106                 }
1107
1108                 cv = GvCV(kGVOP_gv);
1109                 if (!cv)
1110                     goto restore_2cv;
1111                 if (CvLVALUE(cv))
1112                     break;
1113             }
1114         }
1115         /* FALL THROUGH */
1116     default:
1117       nomod:
1118         /* grep, foreach, subcalls, refgen */
1119         if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1120             break;
1121         yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1122                      (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1123                       ? "do block"
1124                       : (o->op_type == OP_ENTERSUB
1125                         ? "non-lvalue subroutine call"
1126                         : OP_DESC(o))),
1127                      type ? PL_op_desc[type] : "local"));
1128         return o;
1129
1130     case OP_PREINC:
1131     case OP_PREDEC:
1132     case OP_POW:
1133     case OP_MULTIPLY:
1134     case OP_DIVIDE:
1135     case OP_MODULO:
1136     case OP_REPEAT:
1137     case OP_ADD:
1138     case OP_SUBTRACT:
1139     case OP_CONCAT:
1140     case OP_LEFT_SHIFT:
1141     case OP_RIGHT_SHIFT:
1142     case OP_BIT_AND:
1143     case OP_BIT_XOR:
1144     case OP_BIT_OR:
1145     case OP_I_MULTIPLY:
1146     case OP_I_DIVIDE:
1147     case OP_I_MODULO:
1148     case OP_I_ADD:
1149     case OP_I_SUBTRACT:
1150         if (!(o->op_flags & OPf_STACKED))
1151             goto nomod;
1152         PL_modcount++;
1153         break;
1154
1155     case OP_COND_EXPR:
1156         localize = 1;
1157         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1158             mod(kid, type);
1159         break;
1160
1161     case OP_RV2AV:
1162     case OP_RV2HV:
1163         if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1164            PL_modcount = RETURN_UNLIMITED_NUMBER;
1165             return o;           /* Treat \(@foo) like ordinary list. */
1166         }
1167         /* FALL THROUGH */
1168     case OP_RV2GV:
1169         if (scalar_mod_type(o, type))
1170             goto nomod;
1171         ref(cUNOPo->op_first, o->op_type);
1172         /* FALL THROUGH */
1173     case OP_ASLICE:
1174     case OP_HSLICE:
1175         if (type == OP_LEAVESUBLV)
1176             o->op_private |= OPpMAYBE_LVSUB;
1177         localize = 1;
1178         /* FALL THROUGH */
1179     case OP_AASSIGN:
1180     case OP_NEXTSTATE:
1181     case OP_DBSTATE:
1182        PL_modcount = RETURN_UNLIMITED_NUMBER;
1183         break;
1184     case OP_RV2SV:
1185         ref(cUNOPo->op_first, o->op_type);
1186         localize = 1;
1187         /* FALL THROUGH */
1188     case OP_GV:
1189     case OP_AV2ARYLEN:
1190         PL_hints |= HINT_BLOCK_SCOPE;
1191     case OP_SASSIGN:
1192     case OP_ANDASSIGN:
1193     case OP_ORASSIGN:
1194     case OP_DORASSIGN:
1195         PL_modcount++;
1196         break;
1197
1198     case OP_AELEMFAST:
1199         localize = -1;
1200         PL_modcount++;
1201         break;
1202
1203     case OP_PADAV:
1204     case OP_PADHV:
1205        PL_modcount = RETURN_UNLIMITED_NUMBER;
1206         if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1207             return o;           /* Treat \(@foo) like ordinary list. */
1208         if (scalar_mod_type(o, type))
1209             goto nomod;
1210         if (type == OP_LEAVESUBLV)
1211             o->op_private |= OPpMAYBE_LVSUB;
1212         /* FALL THROUGH */
1213     case OP_PADSV:
1214         PL_modcount++;
1215         if (!type) /* local() */
1216             Perl_croak(aTHX_ "Can't localize lexical variable %s",
1217                  PAD_COMPNAME_PV(o->op_targ));
1218         break;
1219
1220     case OP_PUSHMARK:
1221         localize = 0;
1222         break;
1223
1224     case OP_KEYS:
1225         if (type != OP_SASSIGN)
1226             goto nomod;
1227         goto lvalue_func;
1228     case OP_SUBSTR:
1229         if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1230             goto nomod;
1231         /* FALL THROUGH */
1232     case OP_POS:
1233     case OP_VEC:
1234         if (type == OP_LEAVESUBLV)
1235             o->op_private |= OPpMAYBE_LVSUB;
1236       lvalue_func:
1237         pad_free(o->op_targ);
1238         o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1239         assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1240         if (o->op_flags & OPf_KIDS)
1241             mod(cBINOPo->op_first->op_sibling, type);
1242         break;
1243
1244     case OP_AELEM:
1245     case OP_HELEM:
1246         ref(cBINOPo->op_first, o->op_type);
1247         if (type == OP_ENTERSUB &&
1248              !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1249             o->op_private |= OPpLVAL_DEFER;
1250         if (type == OP_LEAVESUBLV)
1251             o->op_private |= OPpMAYBE_LVSUB;
1252         localize = 1;
1253         PL_modcount++;
1254         break;
1255
1256     case OP_SCOPE:
1257     case OP_LEAVE:
1258     case OP_ENTER:
1259     case OP_LINESEQ:
1260         localize = 0;
1261         if (o->op_flags & OPf_KIDS)
1262             mod(cLISTOPo->op_last, type);
1263         break;
1264
1265     case OP_NULL:
1266         localize = 0;
1267         if (o->op_flags & OPf_SPECIAL)          /* do BLOCK */
1268             goto nomod;
1269         else if (!(o->op_flags & OPf_KIDS))
1270             break;
1271         if (o->op_targ != OP_LIST) {
1272             mod(cBINOPo->op_first, type);
1273             break;
1274         }
1275         /* FALL THROUGH */
1276     case OP_LIST:
1277         localize = 0;
1278         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1279             mod(kid, type);
1280         break;
1281
1282     case OP_RETURN:
1283         if (type != OP_LEAVESUBLV)
1284             goto nomod;
1285         break; /* mod()ing was handled by ck_return() */
1286     }
1287
1288     /* [20011101.069] File test operators interpret OPf_REF to mean that
1289        their argument is a filehandle; thus \stat(".") should not set
1290        it. AMS 20011102 */
1291     if (type == OP_REFGEN &&
1292         PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1293         return o;
1294
1295     if (type != OP_LEAVESUBLV)
1296         o->op_flags |= OPf_MOD;
1297
1298     if (type == OP_AASSIGN || type == OP_SASSIGN)
1299         o->op_flags |= OPf_SPECIAL|OPf_REF;
1300     else if (!type) { /* local() */
1301         switch (localize) {
1302         case 1:
1303             o->op_private |= OPpLVAL_INTRO;
1304             o->op_flags &= ~OPf_SPECIAL;
1305             PL_hints |= HINT_BLOCK_SCOPE;
1306             break;
1307         case 0:
1308             break;
1309         case -1:
1310             if (ckWARN(WARN_SYNTAX)) {
1311                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1312                     "Useless localization of %s", OP_DESC(o));
1313             }
1314         }
1315     }
1316     else if (type != OP_GREPSTART && type != OP_ENTERSUB
1317              && type != OP_LEAVESUBLV)
1318         o->op_flags |= OPf_REF;
1319     return o;
1320 }
1321
1322 STATIC bool
1323 S_scalar_mod_type(pTHX_ const OP *o, I32 type)
1324 {
1325     switch (type) {
1326     case OP_SASSIGN:
1327         if (o->op_type == OP_RV2GV)
1328             return FALSE;
1329         /* FALL THROUGH */
1330     case OP_PREINC:
1331     case OP_PREDEC:
1332     case OP_POSTINC:
1333     case OP_POSTDEC:
1334     case OP_I_PREINC:
1335     case OP_I_PREDEC:
1336     case OP_I_POSTINC:
1337     case OP_I_POSTDEC:
1338     case OP_POW:
1339     case OP_MULTIPLY:
1340     case OP_DIVIDE:
1341     case OP_MODULO:
1342     case OP_REPEAT:
1343     case OP_ADD:
1344     case OP_SUBTRACT:
1345     case OP_I_MULTIPLY:
1346     case OP_I_DIVIDE:
1347     case OP_I_MODULO:
1348     case OP_I_ADD:
1349     case OP_I_SUBTRACT:
1350     case OP_LEFT_SHIFT:
1351     case OP_RIGHT_SHIFT:
1352     case OP_BIT_AND:
1353     case OP_BIT_XOR:
1354     case OP_BIT_OR:
1355     case OP_CONCAT:
1356     case OP_SUBST:
1357     case OP_TRANS:
1358     case OP_READ:
1359     case OP_SYSREAD:
1360     case OP_RECV:
1361     case OP_ANDASSIGN:
1362     case OP_ORASSIGN:
1363         return TRUE;
1364     default:
1365         return FALSE;
1366     }
1367 }
1368
1369 STATIC bool
1370 S_is_handle_constructor(pTHX_ const OP *o, I32 argnum)
1371 {
1372     switch (o->op_type) {
1373     case OP_PIPE_OP:
1374     case OP_SOCKPAIR:
1375         if (argnum == 2)
1376             return TRUE;
1377         /* FALL THROUGH */
1378     case OP_SYSOPEN:
1379     case OP_OPEN:
1380     case OP_SELECT:             /* XXX c.f. SelectSaver.pm */
1381     case OP_SOCKET:
1382     case OP_OPEN_DIR:
1383     case OP_ACCEPT:
1384         if (argnum == 1)
1385             return TRUE;
1386         /* FALL THROUGH */
1387     default:
1388         return FALSE;
1389     }
1390 }
1391
1392 OP *
1393 Perl_refkids(pTHX_ OP *o, I32 type)
1394 {
1395     if (o && o->op_flags & OPf_KIDS) {
1396         OP *kid;
1397         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1398             ref(kid, type);
1399     }
1400     return o;
1401 }
1402
1403 OP *
1404 Perl_ref(pTHX_ OP *o, I32 type)
1405 {
1406     OP *kid;
1407
1408     if (!o || PL_error_count)
1409         return o;
1410
1411     switch (o->op_type) {
1412     case OP_ENTERSUB:
1413         if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1414             !(o->op_flags & OPf_STACKED)) {
1415             o->op_type = OP_RV2CV;             /* entersub => rv2cv */
1416             o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1417             assert(cUNOPo->op_first->op_type == OP_NULL);
1418             op_null(((LISTOP*)cUNOPo->op_first)->op_first);     /* disable pushmark */
1419             o->op_flags |= OPf_SPECIAL;
1420         }
1421         break;
1422
1423     case OP_COND_EXPR:
1424         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1425             ref(kid, type);
1426         break;
1427     case OP_RV2SV:
1428         if (type == OP_DEFINED)
1429             o->op_flags |= OPf_SPECIAL;         /* don't create GV */
1430         ref(cUNOPo->op_first, o->op_type);
1431         /* FALL THROUGH */
1432     case OP_PADSV:
1433         if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1434             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1435                               : type == OP_RV2HV ? OPpDEREF_HV
1436                               : OPpDEREF_SV);
1437             o->op_flags |= OPf_MOD;
1438         }
1439         break;
1440
1441     case OP_THREADSV:
1442         o->op_flags |= OPf_MOD;         /* XXX ??? */
1443         break;
1444
1445     case OP_RV2AV:
1446     case OP_RV2HV:
1447         o->op_flags |= OPf_REF;
1448         /* FALL THROUGH */
1449     case OP_RV2GV:
1450         if (type == OP_DEFINED)
1451             o->op_flags |= OPf_SPECIAL;         /* don't create GV */
1452         ref(cUNOPo->op_first, o->op_type);
1453         break;
1454
1455     case OP_PADAV:
1456     case OP_PADHV:
1457         o->op_flags |= OPf_REF;
1458         break;
1459
1460     case OP_SCALAR:
1461     case OP_NULL:
1462         if (!(o->op_flags & OPf_KIDS))
1463             break;
1464         ref(cBINOPo->op_first, type);
1465         break;
1466     case OP_AELEM:
1467     case OP_HELEM:
1468         ref(cBINOPo->op_first, o->op_type);
1469         if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1470             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1471                               : type == OP_RV2HV ? OPpDEREF_HV
1472                               : OPpDEREF_SV);
1473             o->op_flags |= OPf_MOD;
1474         }
1475         break;
1476
1477     case OP_SCOPE:
1478     case OP_LEAVE:
1479     case OP_ENTER:
1480     case OP_LIST:
1481         if (!(o->op_flags & OPf_KIDS))
1482             break;
1483         ref(cLISTOPo->op_last, type);
1484         break;
1485     default:
1486         break;
1487     }
1488     return scalar(o);
1489
1490 }
1491
1492 STATIC OP *
1493 S_dup_attrlist(pTHX_ OP *o)
1494 {
1495     OP *rop = Nullop;
1496
1497     /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1498      * where the first kid is OP_PUSHMARK and the remaining ones
1499      * are OP_CONST.  We need to push the OP_CONST values.
1500      */
1501     if (o->op_type == OP_CONST)
1502         rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc(cSVOPo->op_sv));
1503     else {
1504         assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1505         for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1506             if (o->op_type == OP_CONST)
1507                 rop = append_elem(OP_LIST, rop,
1508                                   newSVOP(OP_CONST, o->op_flags,
1509                                           SvREFCNT_inc(cSVOPo->op_sv)));
1510         }
1511     }
1512     return rop;
1513 }
1514
1515 STATIC void
1516 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1517 {
1518     SV *stashsv;
1519
1520     /* fake up C<use attributes $pkg,$rv,@attrs> */
1521     ENTER;              /* need to protect against side-effects of 'use' */
1522     SAVEINT(PL_expect);
1523     if (stash)
1524         stashsv = newSVpv(HvNAME(stash), 0);
1525     else
1526         stashsv = &PL_sv_no;
1527
1528 #define ATTRSMODULE "attributes"
1529 #define ATTRSMODULE_PM "attributes.pm"
1530
1531     if (for_my) {
1532         SV **svp;
1533         /* Don't force the C<use> if we don't need it. */
1534         svp = hv_fetch(GvHVn(PL_incgv), ATTRSMODULE_PM,
1535                        sizeof(ATTRSMODULE_PM)-1, 0);
1536         if (svp && *svp != &PL_sv_undef)
1537             ;           /* already in %INC */
1538         else
1539             Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1540                              newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1541                              Nullsv);
1542     }
1543     else {
1544         Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1545                          newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1546                          Nullsv,
1547                          prepend_elem(OP_LIST,
1548                                       newSVOP(OP_CONST, 0, stashsv),
1549                                       prepend_elem(OP_LIST,
1550                                                    newSVOP(OP_CONST, 0,
1551                                                            newRV(target)),
1552                                                    dup_attrlist(attrs))));
1553     }
1554     LEAVE;
1555 }
1556
1557 STATIC void
1558 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1559 {
1560     OP *pack, *imop, *arg;
1561     SV *meth, *stashsv;
1562
1563     if (!attrs)
1564         return;
1565
1566     assert(target->op_type == OP_PADSV ||
1567            target->op_type == OP_PADHV ||
1568            target->op_type == OP_PADAV);
1569
1570     /* Ensure that attributes.pm is loaded. */
1571     apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
1572
1573     /* Need package name for method call. */
1574     pack = newSVOP(OP_CONST, 0, newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1));
1575
1576     /* Build up the real arg-list. */
1577     if (stash)
1578         stashsv = newSVpv(HvNAME(stash), 0);
1579     else
1580         stashsv = &PL_sv_no;
1581     arg = newOP(OP_PADSV, 0);
1582     arg->op_targ = target->op_targ;
1583     arg = prepend_elem(OP_LIST,
1584                        newSVOP(OP_CONST, 0, stashsv),
1585                        prepend_elem(OP_LIST,
1586                                     newUNOP(OP_REFGEN, 0,
1587                                             mod(arg, OP_REFGEN)),
1588                                     dup_attrlist(attrs)));
1589
1590     /* Fake up a method call to import */
1591     meth = newSVpvn("import", 6);
1592     (void)SvUPGRADE(meth, SVt_PVIV);
1593     (void)SvIOK_on(meth);
1594     {
1595         U32 hash;
1596         PERL_HASH(hash, SvPVX(meth), SvCUR(meth));
1597         SvUV_set(meth, hash);
1598     }
1599     imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
1600                    append_elem(OP_LIST,
1601                                prepend_elem(OP_LIST, pack, list(arg)),
1602                                newSVOP(OP_METHOD_NAMED, 0, meth)));
1603     imop->op_private |= OPpENTERSUB_NOMOD;
1604
1605     /* Combine the ops. */
1606     *imopsp = append_elem(OP_LIST, *imopsp, imop);
1607 }
1608
1609 /*
1610 =notfor apidoc apply_attrs_string
1611
1612 Attempts to apply a list of attributes specified by the C<attrstr> and
1613 C<len> arguments to the subroutine identified by the C<cv> argument which
1614 is expected to be associated with the package identified by the C<stashpv>
1615 argument (see L<attributes>).  It gets this wrong, though, in that it
1616 does not correctly identify the boundaries of the individual attribute
1617 specifications within C<attrstr>.  This is not really intended for the
1618 public API, but has to be listed here for systems such as AIX which
1619 need an explicit export list for symbols.  (It's called from XS code
1620 in support of the C<ATTRS:> keyword from F<xsubpp>.)  Patches to fix it
1621 to respect attribute syntax properly would be welcome.
1622
1623 =cut
1624 */
1625
1626 void
1627 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
1628                         const char *attrstr, STRLEN len)
1629 {
1630     OP *attrs = Nullop;
1631
1632     if (!len) {
1633         len = strlen(attrstr);
1634     }
1635
1636     while (len) {
1637         for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1638         if (len) {
1639             const char *sstr = attrstr;
1640             for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1641             attrs = append_elem(OP_LIST, attrs,
1642                                 newSVOP(OP_CONST, 0,
1643                                         newSVpvn(sstr, attrstr-sstr)));
1644         }
1645     }
1646
1647     Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1648                      newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1649                      Nullsv, prepend_elem(OP_LIST,
1650                                   newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1651                                   prepend_elem(OP_LIST,
1652                                                newSVOP(OP_CONST, 0,
1653                                                        newRV((SV*)cv)),
1654                                                attrs)));
1655 }
1656
1657 STATIC OP *
1658 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
1659 {
1660     I32 type;
1661
1662     if (!o || PL_error_count)
1663         return o;
1664
1665     type = o->op_type;
1666     if (type == OP_LIST) {
1667         OP *kid;
1668         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1669             my_kid(kid, attrs, imopsp);
1670     } else if (type == OP_UNDEF) {
1671         return o;
1672     } else if (type == OP_RV2SV ||      /* "our" declaration */
1673                type == OP_RV2AV ||
1674                type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1675         if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
1676             yyerror(Perl_form(aTHX_ "Can't declare %s in %s",
1677                         OP_DESC(o), PL_in_my == KEY_our ? "our" : "my"));
1678         } else if (attrs) {
1679             GV *gv = cGVOPx_gv(cUNOPo->op_first);
1680             PL_in_my = FALSE;
1681             PL_in_my_stash = Nullhv;
1682             apply_attrs(GvSTASH(gv),
1683                         (type == OP_RV2SV ? GvSV(gv) :
1684                          type == OP_RV2AV ? (SV*)GvAV(gv) :
1685                          type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1686                         attrs, FALSE);
1687         }
1688         o->op_private |= OPpOUR_INTRO;
1689         return o;
1690     }
1691     else if (type != OP_PADSV &&
1692              type != OP_PADAV &&
1693              type != OP_PADHV &&
1694              type != OP_PUSHMARK)
1695     {
1696         yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1697                           OP_DESC(o),
1698                           PL_in_my == KEY_our ? "our" : "my"));
1699         return o;
1700     }
1701     else if (attrs && type != OP_PUSHMARK) {
1702         HV *stash;
1703
1704         PL_in_my = FALSE;
1705         PL_in_my_stash = Nullhv;
1706
1707         /* check for C<my Dog $spot> when deciding package */
1708         stash = PAD_COMPNAME_TYPE(o->op_targ);
1709         if (!stash)
1710             stash = PL_curstash;
1711         apply_attrs_my(stash, o, attrs, imopsp);
1712     }
1713     o->op_flags |= OPf_MOD;
1714     o->op_private |= OPpLVAL_INTRO;
1715     return o;
1716 }
1717
1718 OP *
1719 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
1720 {
1721     OP *rops = Nullop;
1722     int maybe_scalar = 0;
1723
1724 /* [perl #17376]: this appears to be premature, and results in code such as
1725    C< our(%x); > executing in list mode rather than void mode */
1726 #if 0
1727     if (o->op_flags & OPf_PARENS)
1728         list(o);
1729     else
1730         maybe_scalar = 1;
1731 #else
1732     maybe_scalar = 1;
1733 #endif
1734     if (attrs)
1735         SAVEFREEOP(attrs);
1736     o = my_kid(o, attrs, &rops);
1737     if (rops) {
1738         if (maybe_scalar && o->op_type == OP_PADSV) {
1739             o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
1740             o->op_private |= OPpLVAL_INTRO;
1741         }
1742         else
1743             o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
1744     }
1745     PL_in_my = FALSE;
1746     PL_in_my_stash = Nullhv;
1747     return o;
1748 }
1749
1750 OP *
1751 Perl_my(pTHX_ OP *o)
1752 {
1753     return my_attrs(o, Nullop);
1754 }
1755
1756 OP *
1757 Perl_sawparens(pTHX_ OP *o)
1758 {
1759     if (o)
1760         o->op_flags |= OPf_PARENS;
1761     return o;
1762 }
1763
1764 OP *
1765 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
1766 {
1767     OP *o;
1768     bool ismatchop = 0;
1769
1770     if (ckWARN(WARN_MISC) &&
1771       (left->op_type == OP_RV2AV ||
1772        left->op_type == OP_RV2HV ||
1773        left->op_type == OP_PADAV ||
1774        left->op_type == OP_PADHV)) {
1775       const char *desc = PL_op_desc[(right->op_type == OP_SUBST ||
1776                             right->op_type == OP_TRANS)
1777                            ? right->op_type : OP_MATCH];
1778       const char *sample = ((left->op_type == OP_RV2AV ||
1779                              left->op_type == OP_PADAV)
1780                             ? "@array" : "%hash");
1781       Perl_warner(aTHX_ packWARN(WARN_MISC),
1782              "Applying %s to %s will act on scalar(%s)",
1783              desc, sample, sample);
1784     }
1785
1786     if (right->op_type == OP_CONST &&
1787         cSVOPx(right)->op_private & OPpCONST_BARE &&
1788         cSVOPx(right)->op_private & OPpCONST_STRICT)
1789     {
1790         no_bareword_allowed(right);
1791     }
1792
1793     ismatchop = right->op_type == OP_MATCH ||
1794                 right->op_type == OP_SUBST ||
1795                 right->op_type == OP_TRANS;
1796     if (ismatchop && right->op_private & OPpTARGET_MY) {
1797         right->op_targ = 0;
1798         right->op_private &= ~OPpTARGET_MY;
1799     }
1800     if (!(right->op_flags & OPf_STACKED) && ismatchop) {
1801         right->op_flags |= OPf_STACKED;
1802         if (right->op_type != OP_MATCH &&
1803             ! (right->op_type == OP_TRANS &&
1804                right->op_private & OPpTRANS_IDENTICAL))
1805             left = mod(left, right->op_type);
1806         if (right->op_type == OP_TRANS)
1807             o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
1808         else
1809             o = prepend_elem(right->op_type, scalar(left), right);
1810         if (type == OP_NOT)
1811             return newUNOP(OP_NOT, 0, scalar(o));
1812         return o;
1813     }
1814     else
1815         return bind_match(type, left,
1816                 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
1817 }
1818
1819 OP *
1820 Perl_invert(pTHX_ OP *o)
1821 {
1822     if (!o)
1823         return o;
1824     /* XXX need to optimize away NOT NOT here?  Or do we let optimizer do it? */
1825     return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
1826 }
1827
1828 OP *
1829 Perl_scope(pTHX_ OP *o)
1830 {
1831     if (o) {
1832         if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
1833             o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
1834             o->op_type = OP_LEAVE;
1835             o->op_ppaddr = PL_ppaddr[OP_LEAVE];
1836         }
1837         else if (o->op_type == OP_LINESEQ) {
1838             OP *kid;
1839             o->op_type = OP_SCOPE;
1840             o->op_ppaddr = PL_ppaddr[OP_SCOPE];
1841             kid = ((LISTOP*)o)->op_first;
1842             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
1843                 op_null(kid);
1844         }
1845         else
1846             o = newLISTOP(OP_SCOPE, 0, o, Nullop);
1847     }
1848     return o;
1849 }
1850
1851 /* XXX kept for BINCOMPAT only */
1852 void
1853 Perl_save_hints(pTHX)
1854 {
1855     Perl_croak(aTHX_ "internal error: obsolete function save_hints() called");
1856 }
1857
1858 int
1859 Perl_block_start(pTHX_ int full)
1860 {
1861     const int retval = PL_savestack_ix;
1862     pad_block_start(full);
1863     SAVEHINTS();
1864     PL_hints &= ~HINT_BLOCK_SCOPE;
1865     SAVESPTR(PL_compiling.cop_warnings);
1866     if (! specialWARN(PL_compiling.cop_warnings)) {
1867         PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
1868         SAVEFREESV(PL_compiling.cop_warnings) ;
1869     }
1870     SAVESPTR(PL_compiling.cop_io);
1871     if (! specialCopIO(PL_compiling.cop_io)) {
1872         PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
1873         SAVEFREESV(PL_compiling.cop_io) ;
1874     }
1875     return retval;
1876 }
1877
1878 OP*
1879 Perl_block_end(pTHX_ I32 floor, OP *seq)
1880 {
1881     const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
1882     OP* retval = scalarseq(seq);
1883     LEAVE_SCOPE(floor);
1884     PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
1885     if (needblockscope)
1886         PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
1887     pad_leavemy();
1888     return retval;
1889 }
1890
1891 STATIC OP *
1892 S_newDEFSVOP(pTHX)
1893 {
1894     const I32 offset = pad_findmy("$_");
1895     if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
1896         return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
1897     }
1898     else {
1899         OP *o = newOP(OP_PADSV, 0);
1900         o->op_targ = offset;
1901         return o;
1902     }
1903 }
1904
1905 void
1906 Perl_newPROG(pTHX_ OP *o)
1907 {
1908     if (PL_in_eval) {
1909         if (PL_eval_root)
1910                 return;
1911         PL_eval_root = newUNOP(OP_LEAVEEVAL,
1912                                ((PL_in_eval & EVAL_KEEPERR)
1913                                 ? OPf_SPECIAL : 0), o);
1914         PL_eval_start = linklist(PL_eval_root);
1915         PL_eval_root->op_private |= OPpREFCOUNTED;
1916         OpREFCNT_set(PL_eval_root, 1);
1917         PL_eval_root->op_next = 0;
1918         CALL_PEEP(PL_eval_start);
1919     }
1920     else {
1921         if (o->op_type == OP_STUB) {
1922             PL_comppad_name = 0;
1923             PL_compcv = 0;
1924             FreeOp(o);
1925             return;
1926         }
1927         PL_main_root = scope(sawparens(scalarvoid(o)));
1928         PL_curcop = &PL_compiling;
1929         PL_main_start = LINKLIST(PL_main_root);
1930         PL_main_root->op_private |= OPpREFCOUNTED;
1931         OpREFCNT_set(PL_main_root, 1);
1932         PL_main_root->op_next = 0;
1933         CALL_PEEP(PL_main_start);
1934         PL_compcv = 0;
1935
1936         /* Register with debugger */
1937         if (PERLDB_INTER) {
1938             CV *cv = get_cv("DB::postponed", FALSE);
1939             if (cv) {
1940                 dSP;
1941                 PUSHMARK(SP);
1942                 XPUSHs((SV*)CopFILEGV(&PL_compiling));
1943                 PUTBACK;
1944                 call_sv((SV*)cv, G_DISCARD);
1945             }
1946         }
1947     }
1948 }
1949
1950 OP *
1951 Perl_localize(pTHX_ OP *o, I32 lex)
1952 {
1953     if (o->op_flags & OPf_PARENS)
1954 /* [perl #17376]: this appears to be premature, and results in code such as
1955    C< our(%x); > executing in list mode rather than void mode */
1956 #if 0
1957         list(o);
1958 #else
1959         ;
1960 #endif
1961     else {
1962         if (ckWARN(WARN_PARENTHESIS)
1963             && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',')
1964         {
1965             char *s = PL_bufptr;
1966             bool sigil = FALSE;
1967
1968             /* some heuristics to detect a potential error */
1969             while (*s && (strchr(", \t\n", *s)))
1970                 s++;
1971
1972             while (1) {
1973                 if (*s && strchr("@$%*", *s) && *++s
1974                        && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
1975                     s++;
1976                     sigil = TRUE;
1977                     while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
1978                         s++;
1979                     while (*s && (strchr(", \t\n", *s)))
1980                         s++;
1981                 }
1982                 else
1983                     break;
1984             }
1985             if (sigil && (*s == ';' || *s == '=')) {
1986                 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
1987                                 "Parentheses missing around \"%s\" list",
1988                                 lex ? (PL_in_my == KEY_our ? "our" : "my")
1989                                 : "local");
1990             }
1991         }
1992     }
1993     if (lex)
1994         o = my(o);
1995     else
1996         o = mod(o, OP_NULL);            /* a bit kludgey */
1997     PL_in_my = FALSE;
1998     PL_in_my_stash = Nullhv;
1999     return o;
2000 }
2001
2002 OP *
2003 Perl_jmaybe(pTHX_ OP *o)
2004 {
2005     if (o->op_type == OP_LIST) {
2006         OP *o2;
2007         o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
2008         o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2009     }
2010     return o;
2011 }
2012
2013 OP *
2014 Perl_fold_constants(pTHX_ register OP *o)
2015 {
2016     register OP *curop;
2017     I32 type = o->op_type;
2018     SV *sv;
2019
2020     if (PL_opargs[type] & OA_RETSCALAR)
2021         scalar(o);
2022     if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2023         o->op_targ = pad_alloc(type, SVs_PADTMP);
2024
2025     /* integerize op, unless it happens to be C<-foo>.
2026      * XXX should pp_i_negate() do magic string negation instead? */
2027     if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2028         && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2029              && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2030     {
2031         o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2032     }
2033
2034     if (!(PL_opargs[type] & OA_FOLDCONST))
2035         goto nope;
2036
2037     switch (type) {
2038     case OP_NEGATE:
2039         /* XXX might want a ck_negate() for this */
2040         cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2041         break;
2042     case OP_SPRINTF:
2043     case OP_UCFIRST:
2044     case OP_LCFIRST:
2045     case OP_UC:
2046     case OP_LC:
2047     case OP_SLT:
2048     case OP_SGT:
2049     case OP_SLE:
2050     case OP_SGE:
2051     case OP_SCMP:
2052         /* XXX what about the numeric ops? */
2053         if (PL_hints & HINT_LOCALE)
2054             goto nope;
2055     }
2056
2057     if (PL_error_count)
2058         goto nope;              /* Don't try to run w/ errors */
2059
2060     for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2061         if ((curop->op_type != OP_CONST ||
2062              (curop->op_private & OPpCONST_BARE)) &&
2063             curop->op_type != OP_LIST &&
2064             curop->op_type != OP_SCALAR &&
2065             curop->op_type != OP_NULL &&
2066             curop->op_type != OP_PUSHMARK)
2067         {
2068             goto nope;
2069         }
2070     }
2071
2072     curop = LINKLIST(o);
2073     o->op_next = 0;
2074     PL_op = curop;
2075     CALLRUNOPS(aTHX);
2076     sv = *(PL_stack_sp--);
2077     if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2078         pad_swipe(o->op_targ,  FALSE);
2079     else if (SvTEMP(sv)) {                      /* grab mortal temp? */
2080         (void)SvREFCNT_inc(sv);
2081         SvTEMP_off(sv);
2082     }
2083     op_free(o);
2084     if (type == OP_RV2GV)
2085         return newGVOP(OP_GV, 0, (GV*)sv);
2086     return newSVOP(OP_CONST, 0, sv);
2087
2088   nope:
2089     return o;
2090 }
2091
2092 OP *
2093 Perl_gen_constant_list(pTHX_ register OP *o)
2094 {
2095     register OP *curop;
2096     const I32 oldtmps_floor = PL_tmps_floor;
2097
2098     list(o);
2099     if (PL_error_count)
2100         return o;               /* Don't attempt to run with errors */
2101
2102     PL_op = curop = LINKLIST(o);
2103     o->op_next = 0;
2104     CALL_PEEP(curop);
2105     pp_pushmark();
2106     CALLRUNOPS(aTHX);
2107     PL_op = curop;
2108     pp_anonlist();
2109     PL_tmps_floor = oldtmps_floor;
2110
2111     o->op_type = OP_RV2AV;
2112     o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2113     o->op_flags &= ~OPf_REF;    /* treat \(1..2) like an ordinary list */
2114     o->op_flags |= OPf_PARENS;  /* and flatten \(1..2,3) */
2115     o->op_opt = 0;              /* needs to be revisited in peep() */
2116     curop = ((UNOP*)o)->op_first;
2117     ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
2118     op_free(curop);
2119     linklist(o);
2120     return list(o);
2121 }
2122
2123 OP *
2124 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2125 {
2126     if (!o || o->op_type != OP_LIST)
2127         o = newLISTOP(OP_LIST, 0, o, Nullop);
2128     else
2129         o->op_flags &= ~OPf_WANT;
2130
2131     if (!(PL_opargs[type] & OA_MARK))
2132         op_null(cLISTOPo->op_first);
2133
2134     o->op_type = (OPCODE)type;
2135     o->op_ppaddr = PL_ppaddr[type];
2136     o->op_flags |= flags;
2137
2138     o = CHECKOP(type, o);
2139     if (o->op_type != (unsigned)type)
2140         return o;
2141
2142     return fold_constants(o);
2143 }
2144
2145 /* List constructors */
2146
2147 OP *
2148 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2149 {
2150     if (!first)
2151         return last;
2152
2153     if (!last)
2154         return first;
2155
2156     if (first->op_type != (unsigned)type
2157         || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2158     {
2159         return newLISTOP(type, 0, first, last);
2160     }
2161
2162     if (first->op_flags & OPf_KIDS)
2163         ((LISTOP*)first)->op_last->op_sibling = last;
2164     else {
2165         first->op_flags |= OPf_KIDS;
2166         ((LISTOP*)first)->op_first = last;
2167     }
2168     ((LISTOP*)first)->op_last = last;
2169     return first;
2170 }
2171
2172 OP *
2173 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2174 {
2175     if (!first)
2176         return (OP*)last;
2177
2178     if (!last)
2179         return (OP*)first;
2180
2181     if (first->op_type != (unsigned)type)
2182         return prepend_elem(type, (OP*)first, (OP*)last);
2183
2184     if (last->op_type != (unsigned)type)
2185         return append_elem(type, (OP*)first, (OP*)last);
2186
2187     first->op_last->op_sibling = last->op_first;
2188     first->op_last = last->op_last;
2189     first->op_flags |= (last->op_flags & OPf_KIDS);
2190
2191     FreeOp(last);
2192
2193     return (OP*)first;
2194 }
2195
2196 OP *
2197 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2198 {
2199     if (!first)
2200         return last;
2201
2202     if (!last)
2203         return first;
2204
2205     if (last->op_type == (unsigned)type) {
2206         if (type == OP_LIST) {  /* already a PUSHMARK there */
2207             first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2208             ((LISTOP*)last)->op_first->op_sibling = first;
2209             if (!(first->op_flags & OPf_PARENS))
2210                 last->op_flags &= ~OPf_PARENS;
2211         }
2212         else {
2213             if (!(last->op_flags & OPf_KIDS)) {
2214                 ((LISTOP*)last)->op_last = first;
2215                 last->op_flags |= OPf_KIDS;
2216             }
2217             first->op_sibling = ((LISTOP*)last)->op_first;
2218             ((LISTOP*)last)->op_first = first;
2219         }
2220         last->op_flags |= OPf_KIDS;
2221         return last;
2222     }
2223
2224     return newLISTOP(type, 0, first, last);
2225 }
2226
2227 /* Constructors */
2228
2229 OP *
2230 Perl_newNULLLIST(pTHX)
2231 {
2232     return newOP(OP_STUB, 0);
2233 }
2234
2235 OP *
2236 Perl_force_list(pTHX_ OP *o)
2237 {
2238     if (!o || o->op_type != OP_LIST)
2239         o = newLISTOP(OP_LIST, 0, o, Nullop);
2240     op_null(o);
2241     return o;
2242 }
2243
2244 OP *
2245 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2246 {
2247     LISTOP *listop;
2248
2249     NewOp(1101, listop, 1, LISTOP);
2250
2251     listop->op_type = (OPCODE)type;
2252     listop->op_ppaddr = PL_ppaddr[type];
2253     if (first || last)
2254         flags |= OPf_KIDS;
2255     listop->op_flags = (U8)flags;
2256
2257     if (!last && first)
2258         last = first;
2259     else if (!first && last)
2260         first = last;
2261     else if (first)
2262         first->op_sibling = last;
2263     listop->op_first = first;
2264     listop->op_last = last;
2265     if (type == OP_LIST) {
2266         OP* pushop;
2267         pushop = newOP(OP_PUSHMARK, 0);
2268         pushop->op_sibling = first;
2269         listop->op_first = pushop;
2270         listop->op_flags |= OPf_KIDS;
2271         if (!last)
2272             listop->op_last = pushop;
2273     }
2274
2275     return CHECKOP(type, listop);
2276 }
2277
2278 OP *
2279 Perl_newOP(pTHX_ I32 type, I32 flags)
2280 {
2281     OP *o;
2282     NewOp(1101, o, 1, OP);
2283     o->op_type = (OPCODE)type;
2284     o->op_ppaddr = PL_ppaddr[type];
2285     o->op_flags = (U8)flags;
2286
2287     o->op_next = o;
2288     o->op_private = (U8)(0 | (flags >> 8));
2289     if (PL_opargs[type] & OA_RETSCALAR)
2290         scalar(o);
2291     if (PL_opargs[type] & OA_TARGET)
2292         o->op_targ = pad_alloc(type, SVs_PADTMP);
2293     return CHECKOP(type, o);
2294 }
2295
2296 OP *
2297 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2298 {
2299     UNOP *unop;
2300
2301     if (!first)
2302         first = newOP(OP_STUB, 0);
2303     if (PL_opargs[type] & OA_MARK)
2304         first = force_list(first);
2305
2306     NewOp(1101, unop, 1, UNOP);
2307     unop->op_type = (OPCODE)type;
2308     unop->op_ppaddr = PL_ppaddr[type];
2309     unop->op_first = first;
2310     unop->op_flags = flags | OPf_KIDS;
2311     unop->op_private = (U8)(1 | (flags >> 8));
2312     unop = (UNOP*) CHECKOP(type, unop);
2313     if (unop->op_next)
2314         return (OP*)unop;
2315
2316     return fold_constants((OP *) unop);
2317 }
2318
2319 OP *
2320 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2321 {
2322     BINOP *binop;
2323     NewOp(1101, binop, 1, BINOP);
2324
2325     if (!first)
2326         first = newOP(OP_NULL, 0);
2327
2328     binop->op_type = (OPCODE)type;
2329     binop->op_ppaddr = PL_ppaddr[type];
2330     binop->op_first = first;
2331     binop->op_flags = flags | OPf_KIDS;
2332     if (!last) {
2333         last = first;
2334         binop->op_private = (U8)(1 | (flags >> 8));
2335     }
2336     else {
2337         binop->op_private = (U8)(2 | (flags >> 8));
2338         first->op_sibling = last;
2339     }
2340
2341     binop = (BINOP*)CHECKOP(type, binop);
2342     if (binop->op_next || binop->op_type != (OPCODE)type)
2343         return (OP*)binop;
2344
2345     binop->op_last = binop->op_first->op_sibling;
2346
2347     return fold_constants((OP *)binop);
2348 }
2349
2350 static int
2351 uvcompare(const void *a, const void *b)
2352 {
2353     if (*((const UV *)a) < (*(const UV *)b))
2354         return -1;
2355     if (*((const UV *)a) > (*(const UV *)b))
2356         return 1;
2357     if (*((const UV *)a+1) < (*(const UV *)b+1))
2358         return -1;
2359     if (*((const UV *)a+1) > (*(const UV *)b+1))
2360         return 1;
2361     return 0;
2362 }
2363
2364 OP *
2365 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2366 {
2367     SV *tstr = ((SVOP*)expr)->op_sv;
2368     SV *rstr = ((SVOP*)repl)->op_sv;
2369     STRLEN tlen;
2370     STRLEN rlen;
2371     U8 *t = (U8*)SvPV(tstr, tlen);
2372     U8 *r = (U8*)SvPV(rstr, rlen);
2373     register I32 i;
2374     register I32 j;
2375     I32 del;
2376     I32 complement;
2377     I32 squash;
2378     I32 grows = 0;
2379     register short *tbl;
2380
2381     PL_hints |= HINT_BLOCK_SCOPE;
2382     complement  = o->op_private & OPpTRANS_COMPLEMENT;
2383     del         = o->op_private & OPpTRANS_DELETE;
2384     squash      = o->op_private & OPpTRANS_SQUASH;
2385
2386     if (SvUTF8(tstr))
2387         o->op_private |= OPpTRANS_FROM_UTF;
2388
2389     if (SvUTF8(rstr))
2390         o->op_private |= OPpTRANS_TO_UTF;
2391
2392     if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2393         SV* listsv = newSVpvn("# comment\n",10);
2394         SV* transv = 0;
2395         U8* tend = t + tlen;
2396         U8* rend = r + rlen;
2397         STRLEN ulen;
2398         UV tfirst = 1;
2399         UV tlast = 0;
2400         IV tdiff;
2401         UV rfirst = 1;
2402         UV rlast = 0;
2403         IV rdiff;
2404         IV diff;
2405         I32 none = 0;
2406         U32 max = 0;
2407         I32 bits;
2408         I32 havefinal = 0;
2409         U32 final = 0;
2410         I32 from_utf    = o->op_private & OPpTRANS_FROM_UTF;
2411         I32 to_utf      = o->op_private & OPpTRANS_TO_UTF;
2412         U8* tsave = NULL;
2413         U8* rsave = NULL;
2414
2415         if (!from_utf) {
2416             STRLEN len = tlen;
2417             tsave = t = bytes_to_utf8(t, &len);
2418             tend = t + len;
2419         }
2420         if (!to_utf && rlen) {
2421             STRLEN len = rlen;
2422             rsave = r = bytes_to_utf8(r, &len);
2423             rend = r + len;
2424         }
2425
2426 /* There are several snags with this code on EBCDIC:
2427    1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2428    2. scan_const() in toke.c has encoded chars in native encoding which makes
2429       ranges at least in EBCDIC 0..255 range the bottom odd.
2430 */
2431
2432         if (complement) {
2433             U8 tmpbuf[UTF8_MAXBYTES+1];
2434             UV *cp;
2435             UV nextmin = 0;
2436             New(1109, cp, 2*tlen, UV);
2437             i = 0;
2438             transv = newSVpvn("",0);
2439             while (t < tend) {
2440                 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2441                 t += ulen;
2442                 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2443                     t++;
2444                     cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2445                     t += ulen;
2446                 }
2447                 else {
2448                  cp[2*i+1] = cp[2*i];
2449                 }
2450                 i++;
2451             }
2452             qsort(cp, i, 2*sizeof(UV), uvcompare);
2453             for (j = 0; j < i; j++) {
2454                 UV  val = cp[2*j];
2455                 diff = val - nextmin;
2456                 if (diff > 0) {
2457                     t = uvuni_to_utf8(tmpbuf,nextmin);
2458                     sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2459                     if (diff > 1) {
2460                         U8  range_mark = UTF_TO_NATIVE(0xff);
2461                         t = uvuni_to_utf8(tmpbuf, val - 1);
2462                         sv_catpvn(transv, (char *)&range_mark, 1);
2463                         sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2464                     }
2465                 }
2466                 val = cp[2*j+1];
2467                 if (val >= nextmin)
2468                     nextmin = val + 1;
2469             }
2470             t = uvuni_to_utf8(tmpbuf,nextmin);
2471             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2472             {
2473                 U8 range_mark = UTF_TO_NATIVE(0xff);
2474                 sv_catpvn(transv, (char *)&range_mark, 1);
2475             }
2476             t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
2477                                     UNICODE_ALLOW_SUPER);
2478             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2479             t = (U8*)SvPVX(transv);
2480             tlen = SvCUR(transv);
2481             tend = t + tlen;
2482             Safefree(cp);
2483         }
2484         else if (!rlen && !del) {
2485             r = t; rlen = tlen; rend = tend;
2486         }
2487         if (!squash) {
2488                 if ((!rlen && !del) || t == r ||
2489                     (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2490                 {
2491                     o->op_private |= OPpTRANS_IDENTICAL;
2492                 }
2493         }
2494
2495         while (t < tend || tfirst <= tlast) {
2496             /* see if we need more "t" chars */
2497             if (tfirst > tlast) {
2498                 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2499                 t += ulen;
2500                 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {    /* illegal utf8 val indicates range */
2501                     t++;
2502                     tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2503                     t += ulen;
2504                 }
2505                 else
2506                     tlast = tfirst;
2507             }
2508
2509             /* now see if we need more "r" chars */
2510             if (rfirst > rlast) {
2511                 if (r < rend) {
2512                     rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2513                     r += ulen;
2514                     if (r < rend && NATIVE_TO_UTF(*r) == 0xff) {        /* illegal utf8 val indicates range */
2515                         r++;
2516                         rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2517                         r += ulen;
2518                     }
2519                     else
2520                         rlast = rfirst;
2521                 }
2522                 else {
2523                     if (!havefinal++)
2524                         final = rlast;
2525                     rfirst = rlast = 0xffffffff;
2526                 }
2527             }
2528
2529             /* now see which range will peter our first, if either. */
2530             tdiff = tlast - tfirst;
2531             rdiff = rlast - rfirst;
2532
2533             if (tdiff <= rdiff)
2534                 diff = tdiff;
2535             else
2536                 diff = rdiff;
2537
2538             if (rfirst == 0xffffffff) {
2539                 diff = tdiff;   /* oops, pretend rdiff is infinite */
2540                 if (diff > 0)
2541                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2542                                    (long)tfirst, (long)tlast);
2543                 else
2544                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2545             }
2546             else {
2547                 if (diff > 0)
2548                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2549                                    (long)tfirst, (long)(tfirst + diff),
2550                                    (long)rfirst);
2551                 else
2552                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2553                                    (long)tfirst, (long)rfirst);
2554
2555                 if (rfirst + diff > max)
2556                     max = rfirst + diff;
2557                 if (!grows)
2558                     grows = (tfirst < rfirst &&
2559                              UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2560                 rfirst += diff + 1;
2561             }
2562             tfirst += diff + 1;
2563         }
2564
2565         none = ++max;
2566         if (del)
2567             del = ++max;
2568
2569         if (max > 0xffff)
2570             bits = 32;
2571         else if (max > 0xff)
2572             bits = 16;
2573         else
2574             bits = 8;
2575
2576         Safefree(cPVOPo->op_pv);
2577         cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2578         SvREFCNT_dec(listsv);
2579         if (transv)
2580             SvREFCNT_dec(transv);
2581
2582         if (!del && havefinal && rlen)
2583             (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2584                            newSVuv((UV)final), 0);
2585
2586         if (grows)
2587             o->op_private |= OPpTRANS_GROWS;
2588
2589         if (tsave)
2590             Safefree(tsave);
2591         if (rsave)
2592             Safefree(rsave);
2593
2594         op_free(expr);
2595         op_free(repl);
2596         return o;
2597     }
2598
2599     tbl = (short*)cPVOPo->op_pv;
2600     if (complement) {
2601         Zero(tbl, 256, short);
2602         for (i = 0; i < (I32)tlen; i++)
2603             tbl[t[i]] = -1;
2604         for (i = 0, j = 0; i < 256; i++) {
2605             if (!tbl[i]) {
2606                 if (j >= (I32)rlen) {
2607                     if (del)
2608                         tbl[i] = -2;
2609                     else if (rlen)
2610                         tbl[i] = r[j-1];
2611                     else
2612                         tbl[i] = (short)i;
2613                 }
2614                 else {
2615                     if (i < 128 && r[j] >= 128)
2616                         grows = 1;
2617                     tbl[i] = r[j++];
2618                 }
2619             }
2620         }
2621         if (!del) {
2622             if (!rlen) {
2623                 j = rlen;
2624                 if (!squash)
2625                     o->op_private |= OPpTRANS_IDENTICAL;
2626             }
2627             else if (j >= (I32)rlen)
2628                 j = rlen - 1;
2629             else
2630                 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
2631             tbl[0x100] = rlen - j;
2632             for (i=0; i < (I32)rlen - j; i++)
2633                 tbl[0x101+i] = r[j+i];
2634         }
2635     }
2636     else {
2637         if (!rlen && !del) {
2638             r = t; rlen = tlen;
2639             if (!squash)
2640                 o->op_private |= OPpTRANS_IDENTICAL;
2641         }
2642         else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
2643             o->op_private |= OPpTRANS_IDENTICAL;
2644         }
2645         for (i = 0; i < 256; i++)
2646             tbl[i] = -1;
2647         for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
2648             if (j >= (I32)rlen) {
2649                 if (del) {
2650                     if (tbl[t[i]] == -1)
2651                         tbl[t[i]] = -2;
2652                     continue;
2653                 }
2654                 --j;
2655             }
2656             if (tbl[t[i]] == -1) {
2657                 if (t[i] < 128 && r[j] >= 128)
2658                     grows = 1;
2659                 tbl[t[i]] = r[j];
2660             }
2661         }
2662     }
2663     if (grows)
2664         o->op_private |= OPpTRANS_GROWS;
2665     op_free(expr);
2666     op_free(repl);
2667
2668     return o;
2669 }
2670
2671 OP *
2672 Perl_newPMOP(pTHX_ I32 type, I32 flags)
2673 {
2674     PMOP *pmop;
2675
2676     NewOp(1101, pmop, 1, PMOP);
2677     pmop->op_type = (OPCODE)type;
2678     pmop->op_ppaddr = PL_ppaddr[type];
2679     pmop->op_flags = (U8)flags;
2680     pmop->op_private = (U8)(0 | (flags >> 8));
2681
2682     if (PL_hints & HINT_RE_TAINT)
2683         pmop->op_pmpermflags |= PMf_RETAINT;
2684     if (PL_hints & HINT_LOCALE)
2685         pmop->op_pmpermflags |= PMf_LOCALE;
2686     pmop->op_pmflags = pmop->op_pmpermflags;
2687
2688 #ifdef USE_ITHREADS
2689     {
2690         SV* repointer;
2691         if(av_len((AV*) PL_regex_pad[0]) > -1) {
2692             repointer = av_pop((AV*)PL_regex_pad[0]);
2693             pmop->op_pmoffset = SvIV(repointer);
2694             SvREPADTMP_off(repointer);
2695             sv_setiv(repointer,0);
2696         } else {
2697             repointer = newSViv(0);
2698             av_push(PL_regex_padav,SvREFCNT_inc(repointer));
2699             pmop->op_pmoffset = av_len(PL_regex_padav);
2700             PL_regex_pad = AvARRAY(PL_regex_padav);
2701         }
2702     }
2703 #endif
2704
2705         /* link into pm list */
2706     if (type != OP_TRANS && PL_curstash) {
2707         pmop->op_pmnext = HvPMROOT(PL_curstash);
2708         HvPMROOT(PL_curstash) = pmop;
2709         PmopSTASH_set(pmop,PL_curstash);
2710     }
2711
2712     return CHECKOP(type, pmop);
2713 }
2714
2715 /* Given some sort of match op o, and an expression expr containing a
2716  * pattern, either compile expr into a regex and attach it to o (if it's
2717  * constant), or convert expr into a runtime regcomp op sequence (if it's
2718  * not)
2719  *
2720  * isreg indicates that the pattern is part of a regex construct, eg
2721  * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
2722  * split "pattern", which aren't. In the former case, expr will be a list
2723  * if the pattern contains more than one term (eg /a$b/) or if it contains
2724  * a replacement, ie s/// or tr///.
2725  */
2726
2727 OP *
2728 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
2729 {
2730     PMOP *pm;
2731     LOGOP *rcop;
2732     I32 repl_has_vars = 0;
2733     OP* repl  = Nullop;
2734     bool reglist;
2735
2736     if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
2737         /* last element in list is the replacement; pop it */
2738         OP* kid;
2739         repl = cLISTOPx(expr)->op_last;
2740         kid = cLISTOPx(expr)->op_first;
2741         while (kid->op_sibling != repl)
2742             kid = kid->op_sibling;
2743         kid->op_sibling = Nullop;
2744         cLISTOPx(expr)->op_last = kid;
2745     }
2746
2747     if (isreg && expr->op_type == OP_LIST &&
2748         cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
2749     {
2750         /* convert single element list to element */
2751         OP* oe = expr;
2752         expr = cLISTOPx(oe)->op_first->op_sibling;
2753         cLISTOPx(oe)->op_first->op_sibling = Nullop;
2754         cLISTOPx(oe)->op_last = Nullop;
2755         op_free(oe);
2756     }
2757
2758     if (o->op_type == OP_TRANS) {
2759         return pmtrans(o, expr, repl);
2760     }
2761
2762     reglist = isreg && expr->op_type == OP_LIST;
2763     if (reglist)
2764         op_null(expr);
2765
2766     PL_hints |= HINT_BLOCK_SCOPE;
2767     pm = (PMOP*)o;
2768
2769     if (expr->op_type == OP_CONST) {
2770         STRLEN plen;
2771         SV *pat = ((SVOP*)expr)->op_sv;
2772         char *p = SvPV(pat, plen);
2773         if ((o->op_flags & OPf_SPECIAL) && (*p == ' ' && p[1] == '\0')) {
2774             sv_setpvn(pat, "\\s+", 3);
2775             p = SvPV(pat, plen);
2776             pm->op_pmflags |= PMf_SKIPWHITE;
2777         }
2778         if (DO_UTF8(pat))
2779             pm->op_pmdynflags |= PMdf_UTF8;
2780         PM_SETRE(pm, CALLREGCOMP(aTHX_ p, p + plen, pm));
2781         if (strEQ("\\s+", PM_GETRE(pm)->precomp))
2782             pm->op_pmflags |= PMf_WHITE;
2783         op_free(expr);
2784     }
2785     else {
2786         if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
2787             expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
2788                             ? OP_REGCRESET
2789                             : OP_REGCMAYBE),0,expr);
2790
2791         NewOp(1101, rcop, 1, LOGOP);
2792         rcop->op_type = OP_REGCOMP;
2793         rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
2794         rcop->op_first = scalar(expr);
2795         rcop->op_flags |= OPf_KIDS
2796                             | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
2797                             | (reglist ? OPf_STACKED : 0);
2798         rcop->op_private = 1;
2799         rcop->op_other = o;
2800         if (reglist)
2801             rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
2802
2803         /* /$x/ may cause an eval, since $x might be qr/(?{..})/  */
2804         PL_cv_has_eval = 1;
2805
2806         /* establish postfix order */
2807         if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
2808             LINKLIST(expr);
2809             rcop->op_next = expr;
2810             ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
2811         }
2812         else {
2813             rcop->op_next = LINKLIST(expr);
2814             expr->op_next = (OP*)rcop;
2815         }
2816
2817         prepend_elem(o->op_type, scalar((OP*)rcop), o);
2818     }
2819
2820     if (repl) {
2821         OP *curop;
2822         if (pm->op_pmflags & PMf_EVAL) {
2823             curop = 0;
2824             if (CopLINE(PL_curcop) < (line_t)PL_multi_end)
2825                 CopLINE_set(PL_curcop, (line_t)PL_multi_end);
2826         }
2827         else if (repl->op_type == OP_CONST)
2828             curop = repl;
2829         else {
2830             OP *lastop = 0;
2831             for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
2832                 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
2833                     if (curop->op_type == OP_GV) {
2834                         GV *gv = cGVOPx_gv(curop);
2835                         repl_has_vars = 1;
2836                         if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
2837                             break;
2838                     }
2839                     else if (curop->op_type == OP_RV2CV)
2840                         break;
2841                     else if (curop->op_type == OP_RV2SV ||
2842                              curop->op_type == OP_RV2AV ||
2843                              curop->op_type == OP_RV2HV ||
2844                              curop->op_type == OP_RV2GV) {
2845                         if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
2846                             break;
2847                     }
2848                     else if (curop->op_type == OP_PADSV ||
2849                              curop->op_type == OP_PADAV ||
2850                              curop->op_type == OP_PADHV ||
2851                              curop->op_type == OP_PADANY) {
2852                         repl_has_vars = 1;
2853                     }
2854                     else if (curop->op_type == OP_PUSHRE)
2855                         ; /* Okay here, dangerous in newASSIGNOP */
2856                     else
2857                         break;
2858                 }
2859                 lastop = curop;
2860             }
2861         }
2862         if (curop == repl
2863             && !(repl_has_vars
2864                  && (!PM_GETRE(pm)
2865                      || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
2866             pm->op_pmflags |= PMf_CONST;        /* const for long enough */
2867             pm->op_pmpermflags |= PMf_CONST;    /* const for long enough */
2868             prepend_elem(o->op_type, scalar(repl), o);
2869         }
2870         else {
2871             if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
2872                 pm->op_pmflags |= PMf_MAYBE_CONST;
2873                 pm->op_pmpermflags |= PMf_MAYBE_CONST;
2874             }
2875             NewOp(1101, rcop, 1, LOGOP);
2876             rcop->op_type = OP_SUBSTCONT;
2877             rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
2878             rcop->op_first = scalar(repl);
2879             rcop->op_flags |= OPf_KIDS;
2880             rcop->op_private = 1;
2881             rcop->op_other = o;
2882
2883             /* establish postfix order */
2884             rcop->op_next = LINKLIST(repl);
2885             repl->op_next = (OP*)rcop;
2886
2887             pm->op_pmreplroot = scalar((OP*)rcop);
2888             pm->op_pmreplstart = LINKLIST(rcop);
2889             rcop->op_next = 0;
2890         }
2891     }
2892
2893     return (OP*)pm;
2894 }
2895
2896 OP *
2897 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
2898 {
2899     SVOP *svop;
2900     NewOp(1101, svop, 1, SVOP);
2901     svop->op_type = (OPCODE)type;
2902     svop->op_ppaddr = PL_ppaddr[type];
2903     svop->op_sv = sv;
2904     svop->op_next = (OP*)svop;
2905     svop->op_flags = (U8)flags;
2906     if (PL_opargs[type] & OA_RETSCALAR)
2907         scalar((OP*)svop);
2908     if (PL_opargs[type] & OA_TARGET)
2909         svop->op_targ = pad_alloc(type, SVs_PADTMP);
2910     return CHECKOP(type, svop);
2911 }
2912
2913 OP *
2914 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
2915 {
2916     PADOP *padop;
2917     NewOp(1101, padop, 1, PADOP);
2918     padop->op_type = (OPCODE)type;
2919     padop->op_ppaddr = PL_ppaddr[type];
2920     padop->op_padix = pad_alloc(type, SVs_PADTMP);
2921     SvREFCNT_dec(PAD_SVl(padop->op_padix));
2922     PAD_SETSV(padop->op_padix, sv);
2923     if (sv)
2924         SvPADTMP_on(sv);
2925     padop->op_next = (OP*)padop;
2926     padop->op_flags = (U8)flags;
2927     if (PL_opargs[type] & OA_RETSCALAR)
2928         scalar((OP*)padop);
2929     if (PL_opargs[type] & OA_TARGET)
2930         padop->op_targ = pad_alloc(type, SVs_PADTMP);
2931     return CHECKOP(type, padop);
2932 }
2933
2934 OP *
2935 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
2936 {
2937 #ifdef USE_ITHREADS
2938     if (gv)
2939         GvIN_PAD_on(gv);
2940     return newPADOP(type, flags, SvREFCNT_inc(gv));
2941 #else
2942     return newSVOP(type, flags, SvREFCNT_inc(gv));
2943 #endif
2944 }
2945
2946 OP *
2947 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
2948 {
2949     PVOP *pvop;
2950     NewOp(1101, pvop, 1, PVOP);
2951     pvop->op_type = (OPCODE)type;
2952     pvop->op_ppaddr = PL_ppaddr[type];
2953     pvop->op_pv = pv;
2954     pvop->op_next = (OP*)pvop;
2955     pvop->op_flags = (U8)flags;
2956     if (PL_opargs[type] & OA_RETSCALAR)
2957         scalar((OP*)pvop);
2958     if (PL_opargs[type] & OA_TARGET)
2959         pvop->op_targ = pad_alloc(type, SVs_PADTMP);
2960     return CHECKOP(type, pvop);
2961 }
2962
2963 void
2964 Perl_package(pTHX_ OP *o)
2965 {
2966     const char *name;
2967     STRLEN len;
2968
2969     save_hptr(&PL_curstash);
2970     save_item(PL_curstname);
2971
2972     name = SvPV(cSVOPo->op_sv, len);
2973     PL_curstash = gv_stashpvn(name, len, TRUE);
2974     sv_setpvn(PL_curstname, name, len);
2975     op_free(o);
2976
2977     PL_hints |= HINT_BLOCK_SCOPE;
2978     PL_copline = NOLINE;
2979     PL_expect = XSTATE;
2980 }
2981
2982 void
2983 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
2984 {
2985     OP *pack;
2986     OP *imop;
2987     OP *veop;
2988
2989     if (idop->op_type != OP_CONST)
2990         Perl_croak(aTHX_ "Module name must be constant");
2991
2992     veop = Nullop;
2993
2994     if (version != Nullop) {
2995         SV *vesv = ((SVOP*)version)->op_sv;
2996
2997         if (arg == Nullop && !SvNIOKp(vesv)) {
2998             arg = version;
2999         }
3000         else {
3001             OP *pack;
3002             SV *meth;
3003
3004             if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3005                 Perl_croak(aTHX_ "Version number must be constant number");
3006
3007             /* Make copy of idop so we don't free it twice */
3008             pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3009
3010             /* Fake up a method call to VERSION */
3011             meth = newSVpvn("VERSION",7);
3012             sv_upgrade(meth, SVt_PVIV);
3013             (void)SvIOK_on(meth);
3014             {
3015                 U32 hash;
3016                 PERL_HASH(hash, SvPVX(meth), SvCUR(meth));
3017                 SvUV_set(meth, hash);
3018             }
3019             veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3020                             append_elem(OP_LIST,
3021                                         prepend_elem(OP_LIST, pack, list(version)),
3022                                         newSVOP(OP_METHOD_NAMED, 0, meth)));
3023         }
3024     }
3025
3026     /* Fake up an import/unimport */
3027     if (arg && arg->op_type == OP_STUB)
3028         imop = arg;             /* no import on explicit () */
3029     else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
3030         imop = Nullop;          /* use 5.0; */
3031     }
3032     else {
3033         SV *meth;
3034
3035         /* Make copy of idop so we don't free it twice */
3036         pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3037
3038         /* Fake up a method call to import/unimport */
3039         meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);
3040         (void)SvUPGRADE(meth, SVt_PVIV);
3041         (void)SvIOK_on(meth);
3042         {
3043             U32 hash;
3044             PERL_HASH(hash, SvPVX(meth), SvCUR(meth));
3045             SvUV_set(meth, hash);
3046         }
3047         imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3048                        append_elem(OP_LIST,
3049                                    prepend_elem(OP_LIST, pack, list(arg)),
3050                                    newSVOP(OP_METHOD_NAMED, 0, meth)));
3051     }
3052
3053     /* Fake up the BEGIN {}, which does its thing immediately. */
3054     newATTRSUB(floor,
3055         newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
3056         Nullop,
3057         Nullop,
3058         append_elem(OP_LINESEQ,
3059             append_elem(OP_LINESEQ,
3060                 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, idop)),
3061                 newSTATEOP(0, Nullch, veop)),
3062             newSTATEOP(0, Nullch, imop) ));
3063
3064     /* The "did you use incorrect case?" warning used to be here.
3065      * The problem is that on case-insensitive filesystems one
3066      * might get false positives for "use" (and "require"):
3067      * "use Strict" or "require CARP" will work.  This causes
3068      * portability problems for the script: in case-strict
3069      * filesystems the script will stop working.
3070      *
3071      * The "incorrect case" warning checked whether "use Foo"
3072      * imported "Foo" to your namespace, but that is wrong, too:
3073      * there is no requirement nor promise in the language that
3074      * a Foo.pm should or would contain anything in package "Foo".
3075      *
3076      * There is very little Configure-wise that can be done, either:
3077      * the case-sensitivity of the build filesystem of Perl does not
3078      * help in guessing the case-sensitivity of the runtime environment.
3079      */
3080
3081     PL_hints |= HINT_BLOCK_SCOPE;
3082     PL_copline = NOLINE;
3083     PL_expect = XSTATE;
3084     PL_cop_seqmax++; /* Purely for B::*'s benefit */
3085 }
3086
3087 /*
3088 =head1 Embedding Functions
3089
3090 =for apidoc load_module
3091
3092 Loads the module whose name is pointed to by the string part of name.
3093 Note that the actual module name, not its filename, should be given.
3094 Eg, "Foo::Bar" instead of "Foo/Bar.pm".  flags can be any of
3095 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3096 (or 0 for no flags). ver, if specified, provides version semantics
3097 similar to C<use Foo::Bar VERSION>.  The optional trailing SV*
3098 arguments can be used to specify arguments to the module's import()
3099 method, similar to C<use Foo::Bar VERSION LIST>.
3100
3101 =cut */
3102
3103 void
3104 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3105 {
3106     va_list args;
3107     va_start(args, ver);
3108     vload_module(flags, name, ver, &args);
3109     va_end(args);
3110 }
3111
3112 #ifdef PERL_IMPLICIT_CONTEXT
3113 void
3114 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3115 {
3116     dTHX;
3117     va_list args;
3118     va_start(args, ver);
3119     vload_module(flags, name, ver, &args);
3120     va_end(args);
3121 }
3122 #endif
3123
3124 void
3125 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3126 {
3127     OP *modname, *veop, *imop;
3128
3129     modname = newSVOP(OP_CONST, 0, name);
3130     modname->op_private |= OPpCONST_BARE;
3131     if (ver) {
3132         veop = newSVOP(OP_CONST, 0, ver);
3133     }
3134     else
3135         veop = Nullop;
3136     if (flags & PERL_LOADMOD_NOIMPORT) {
3137         imop = sawparens(newNULLLIST());
3138     }
3139     else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3140         imop = va_arg(*args, OP*);
3141     }
3142     else {
3143         SV *sv;
3144         imop = Nullop;
3145         sv = va_arg(*args, SV*);
3146         while (sv) {
3147             imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3148             sv = va_arg(*args, SV*);
3149         }
3150     }
3151     {
3152         const line_t ocopline = PL_copline;
3153         COP * const ocurcop = PL_curcop;
3154         const int oexpect = PL_expect;
3155
3156         utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3157                 veop, modname, imop);
3158         PL_expect = oexpect;
3159         PL_copline = ocopline;
3160         PL_curcop = ocurcop;
3161     }
3162 }
3163
3164 OP *
3165 Perl_dofile(pTHX_ OP *term)
3166 {
3167     OP *doop;
3168     GV *gv;
3169
3170     gv = gv_fetchpv("do", FALSE, SVt_PVCV);
3171     if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
3172         gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3173
3174     if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3175         doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3176                                append_elem(OP_LIST, term,
3177                                            scalar(newUNOP(OP_RV2CV, 0,
3178                                                           newGVOP(OP_GV, 0,
3179                                                                   gv))))));
3180     }
3181     else {
3182         doop = newUNOP(OP_DOFILE, 0, scalar(term));
3183     }
3184     return doop;
3185 }
3186
3187 OP *
3188 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3189 {
3190     return newBINOP(OP_LSLICE, flags,
3191             list(force_list(subscript)),
3192             list(force_list(listval)) );
3193 }
3194
3195 STATIC I32
3196 S_list_assignment(pTHX_ register const OP *o)
3197 {
3198     if (!o)
3199         return TRUE;
3200
3201     if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3202         o = cUNOPo->op_first;
3203
3204     if (o->op_type == OP_COND_EXPR) {
3205         const I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3206         const I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3207
3208         if (t && f)
3209             return TRUE;
3210         if (t || f)
3211             yyerror("Assignment to both a list and a scalar");
3212         return FALSE;
3213     }
3214
3215     if (o->op_type == OP_LIST &&
3216         (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR &&
3217         o->op_private & OPpLVAL_INTRO)
3218         return FALSE;
3219
3220     if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3221         o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3222         o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3223         return TRUE;
3224
3225     if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3226         return TRUE;
3227
3228     if (o->op_type == OP_RV2SV)
3229         return FALSE;
3230
3231     return FALSE;
3232 }
3233
3234 OP *
3235 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3236 {
3237     OP *o;
3238
3239     if (optype) {
3240         if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
3241             return newLOGOP(optype, 0,
3242                 mod(scalar(left), optype),
3243                 newUNOP(OP_SASSIGN, 0, scalar(right)));
3244         }
3245         else {
3246             return newBINOP(optype, OPf_STACKED,
3247                 mod(scalar(left), optype), scalar(right));
3248         }
3249     }
3250
3251     if (list_assignment(left)) {
3252         OP *curop;
3253
3254         PL_modcount = 0;
3255         PL_eval_start = right;  /* Grandfathering $[ assignment here.  Bletch.*/
3256         left = mod(left, OP_AASSIGN);
3257         if (PL_eval_start)
3258             PL_eval_start = 0;
3259         else {
3260             op_free(left);
3261             op_free(right);
3262             return Nullop;
3263         }
3264         /* optimise C<my @x = ()> to C<my @x>, and likewise for hashes */
3265         if ((left->op_type == OP_PADAV || left->op_type == OP_PADHV)
3266                 && right->op_type == OP_STUB
3267                 && (left->op_private & OPpLVAL_INTRO))
3268         {
3269             op_free(right);
3270             left->op_flags &= ~(OPf_REF|OPf_SPECIAL);
3271             return left;
3272         }
3273         curop = list(force_list(left));
3274         o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3275         o->op_private = (U8)(0 | (flags >> 8));
3276
3277         /* PL_generation sorcery:
3278          * an assignment like ($a,$b) = ($c,$d) is easier than
3279          * ($a,$b) = ($c,$a), since there is no need for temporary vars.
3280          * To detect whether there are common vars, the global var
3281          * PL_generation is incremented for each assign op we compile.
3282          * Then, while compiling the assign op, we run through all the
3283          * variables on both sides of the assignment, setting a spare slot
3284          * in each of them to PL_generation. If any of them already have
3285          * that value, we know we've got commonality.  We could use a
3286          * single bit marker, but then we'd have to make 2 passes, first
3287          * to clear the flag, then to test and set it.  To find somewhere
3288          * to store these values, evil chicanery is done with SvCUR().
3289          */
3290
3291         if (!(left->op_private & OPpLVAL_INTRO)) {
3292             OP *lastop = o;
3293             PL_generation++;
3294             for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3295                 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3296                     if (curop->op_type == OP_GV) {
3297                         GV *gv = cGVOPx_gv(curop);
3298                         if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3299                             break;
3300                         SvCUR_set(gv, PL_generation);
3301                     }
3302                     else if (curop->op_type == OP_PADSV ||
3303                              curop->op_type == OP_PADAV ||
3304                              curop->op_type == OP_PADHV ||
3305                              curop->op_type == OP_PADANY)
3306                     {
3307                         if (PAD_COMPNAME_GEN(curop->op_targ)
3308                                                     == (STRLEN)PL_generation)
3309                             break;
3310                         PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
3311
3312                     }
3313                     else if (curop->op_type == OP_RV2CV)
3314                         break;
3315                     else if (curop->op_type == OP_RV2SV ||
3316                              curop->op_type == OP_RV2AV ||
3317                              curop->op_type == OP_RV2HV ||
3318                              curop->op_type == OP_RV2GV) {
3319                         if (lastop->op_type != OP_GV)   /* funny deref? */
3320                             break;
3321                     }
3322                     else if (curop->op_type == OP_PUSHRE) {
3323                         if (((PMOP*)curop)->op_pmreplroot) {
3324 #ifdef USE_ITHREADS
3325                             GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET,
3326                                         ((PMOP*)curop)->op_pmreplroot));
3327 #else
3328                             GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3329 #endif
3330                             if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3331                                 break;
3332                             SvCUR_set(gv, PL_generation);
3333                         }
3334                     }
3335                     else
3336                         break;
3337                 }
3338                 lastop = curop;
3339             }
3340             if (curop != o)
3341                 o->op_private |= OPpASSIGN_COMMON;
3342         }
3343         if (right && right->op_type == OP_SPLIT) {
3344             OP* tmpop;
3345             if ((tmpop = ((LISTOP*)right)->op_first) &&
3346                 tmpop->op_type == OP_PUSHRE)
3347             {
3348                 PMOP *pm = (PMOP*)tmpop;
3349                 if (left->op_type == OP_RV2AV &&
3350                     !(left->op_private & OPpLVAL_INTRO) &&
3351                     !(o->op_private & OPpASSIGN_COMMON) )
3352                 {
3353                     tmpop = ((UNOP*)left)->op_first;
3354                     if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3355 #ifdef USE_ITHREADS
3356                         pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
3357                         cPADOPx(tmpop)->op_padix = 0;   /* steal it */
3358 #else
3359                         pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3360                         cSVOPx(tmpop)->op_sv = Nullsv;  /* steal it */
3361 #endif
3362                         pm->op_pmflags |= PMf_ONCE;
3363                         tmpop = cUNOPo->op_first;       /* to list (nulled) */
3364                         tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3365                         tmpop->op_sibling = Nullop;     /* don't free split */
3366                         right->op_next = tmpop->op_next;  /* fix starting loc */
3367                         op_free(o);                     /* blow off assign */
3368                         right->op_flags &= ~OPf_WANT;
3369                                 /* "I don't know and I don't care." */
3370                         return right;
3371                     }
3372                 }
3373                 else {
3374                    if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3375                       ((LISTOP*)right)->op_last->op_type == OP_CONST)
3376                     {
3377                         SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3378                         if (SvIVX(sv) == 0)
3379                             sv_setiv(sv, PL_modcount+1);
3380                     }
3381                 }
3382             }
3383         }
3384         return o;
3385     }
3386     if (!right)
3387         right = newOP(OP_UNDEF, 0);
3388     if (right->op_type == OP_READLINE) {
3389         right->op_flags |= OPf_STACKED;
3390         return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3391     }
3392     else {
3393         PL_eval_start = right;  /* Grandfathering $[ assignment here.  Bletch.*/
3394         o = newBINOP(OP_SASSIGN, flags,
3395             scalar(right), mod(scalar(left), OP_SASSIGN) );
3396         if (PL_eval_start)
3397             PL_eval_start = 0;
3398         else {
3399             op_free(o);
3400             return Nullop;
3401         }
3402     }
3403     return o;
3404 }
3405
3406 OP *
3407 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3408 {
3409     const U32 seq = intro_my();
3410     register COP *cop;
3411
3412     NewOp(1101, cop, 1, COP);
3413     if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3414         cop->op_type = OP_DBSTATE;
3415         cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3416     }
3417     else {
3418         cop->op_type = OP_NEXTSTATE;
3419         cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3420     }
3421     cop->op_flags = (U8)flags;
3422     cop->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
3423 #ifdef NATIVE_HINTS
3424     cop->op_private |= NATIVE_HINTS;
3425 #endif
3426     PL_compiling.op_private = cop->op_private;
3427     cop->op_next = (OP*)cop;
3428
3429     if (label) {
3430         cop->cop_label = label;
3431         PL_hints |= HINT_BLOCK_SCOPE;
3432     }
3433     cop->cop_seq = seq;
3434     cop->cop_arybase = PL_curcop->cop_arybase;
3435     if (specialWARN(PL_curcop->cop_warnings))
3436         cop->cop_warnings = PL_curcop->cop_warnings ;
3437     else
3438         cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3439     if (specialCopIO(PL_curcop->cop_io))
3440         cop->cop_io = PL_curcop->cop_io;
3441     else
3442         cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3443
3444
3445     if (PL_copline == NOLINE)
3446         CopLINE_set(cop, CopLINE(PL_curcop));
3447     else {
3448         CopLINE_set(cop, PL_copline);
3449         PL_copline = NOLINE;
3450     }
3451 #ifdef USE_ITHREADS
3452     CopFILE_set(cop, CopFILE(PL_curcop));       /* XXX share in a pvtable? */
3453 #else
3454     CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3455 #endif
3456     CopSTASH_set(cop, PL_curstash);
3457
3458     if (PERLDB_LINE && PL_curstash != PL_debstash) {
3459         SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3460         if (svp && *svp != &PL_sv_undef ) {
3461            (void)SvIOK_on(*svp);
3462             SvIV_set(*svp, PTR2IV(cop));
3463         }
3464     }
3465
3466     return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3467 }
3468
3469
3470 OP *
3471 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3472 {
3473     return new_logop(type, flags, &first, &other);
3474 }
3475
3476 STATIC OP *
3477 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3478 {
3479     LOGOP *logop;
3480     OP *o;
3481     OP *first = *firstp;
3482     OP *other = *otherp;
3483
3484     if (type == OP_XOR)         /* Not short circuit, but here by precedence. */
3485         return newBINOP(type, flags, scalar(first), scalar(other));
3486
3487     scalarboolean(first);
3488     /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3489     if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3490         if (type == OP_AND || type == OP_OR) {
3491             if (type == OP_AND)
3492                 type = OP_OR;
3493             else
3494                 type = OP_AND;
3495             o = first;
3496             first = *firstp = cUNOPo->op_first;
3497             if (o->op_next)
3498                 first->op_next = o->op_next;
3499             cUNOPo->op_first = Nullop;
3500             op_free(o);
3501         }
3502     }
3503     if (first->op_type == OP_CONST) {
3504         if (first->op_private & OPpCONST_STRICT)
3505             no_bareword_allowed(first);
3506         else if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
3507                 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
3508         if ((type == OP_AND &&  SvTRUE(((SVOP*)first)->op_sv)) ||
3509             (type == OP_OR  && !SvTRUE(((SVOP*)first)->op_sv)) ||
3510             (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) {
3511             op_free(first);
3512             *firstp = Nullop;
3513             if (other->op_type == OP_CONST)
3514                 other->op_private |= OPpCONST_SHORTCIRCUIT;
3515             return other;
3516         }
3517         else {
3518             /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
3519             const OP *o2 = other;
3520             if ( ! (o2->op_type == OP_LIST
3521                     && (( o2 = cUNOPx(o2)->op_first))
3522                     && o2->op_type == OP_PUSHMARK
3523                     && (( o2 = o2->op_sibling)) )
3524             )
3525                 o2 = other;
3526             if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
3527                         || o2->op_type == OP_PADHV)
3528                 && o2->op_private & OPpLVAL_INTRO
3529                 && ckWARN(WARN_DEPRECATED))
3530             {
3531                 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
3532                             "Deprecated use of my() in false conditional");
3533             }
3534
3535             op_free(other);
3536             *otherp = Nullop;
3537             if (first->op_type == OP_CONST)
3538                 first->op_private |= OPpCONST_SHORTCIRCUIT;
3539             return first;
3540         }
3541     }
3542     else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS) &&
3543              type != OP_DOR) /* [#24076] Don't warn for <FH> err FOO. */
3544     {
3545         const OP *k1 = ((UNOP*)first)->op_first;
3546         const OP *k2 = k1->op_sibling;
3547         OPCODE warnop = 0;
3548         switch (first->op_type)
3549         {
3550         case OP_NULL:
3551             if (k2 && k2->op_type == OP_READLINE
3552                   && (k2->op_flags & OPf_STACKED)
3553                   && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3554             {
3555                 warnop = k2->op_type;
3556             }
3557             break;
3558
3559         case OP_SASSIGN:
3560             if (k1->op_type == OP_READDIR
3561                   || k1->op_type == OP_GLOB
3562                   || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3563                   || k1->op_type == OP_EACH)
3564             {
3565                 warnop = ((k1->op_type == OP_NULL)
3566                           ? (OPCODE)k1->op_targ : k1->op_type);
3567             }
3568             break;
3569         }
3570         if (warnop) {
3571             const line_t oldline = CopLINE(PL_curcop);
3572             CopLINE_set(PL_curcop, PL_copline);
3573             Perl_warner(aTHX_ packWARN(WARN_MISC),
3574                  "Value of %s%s can be \"0\"; test with defined()",
3575                  PL_op_desc[warnop],
3576                  ((warnop == OP_READLINE || warnop == OP_GLOB)
3577                   ? " construct" : "() operator"));
3578             CopLINE_set(PL_curcop, oldline);
3579         }
3580     }
3581
3582     if (!other)
3583         return first;
3584
3585     if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
3586         other->op_private |= OPpASSIGN_BACKWARDS;  /* other is an OP_SASSIGN */
3587
3588     NewOp(1101, logop, 1, LOGOP);
3589
3590     logop->op_type = (OPCODE)type;
3591     logop->op_ppaddr = PL_ppaddr[type];
3592     logop->op_first = first;
3593     logop->op_flags = flags | OPf_KIDS;
3594     logop->op_other = LINKLIST(other);
3595     logop->op_private = (U8)(1 | (flags >> 8));
3596
3597     /* establish postfix order */
3598     logop->op_next = LINKLIST(first);
3599     first->op_next = (OP*)logop;
3600     first->op_sibling = other;
3601
3602     CHECKOP(type,logop);
3603
3604     o = newUNOP(OP_NULL, 0, (OP*)logop);
3605     other->op_next = o;
3606
3607     return o;
3608 }
3609
3610 OP *
3611 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3612 {
3613     LOGOP *logop;
3614     OP *start;
3615     OP *o;
3616
3617     if (!falseop)
3618         return newLOGOP(OP_AND, 0, first, trueop);
3619     if (!trueop)
3620         return newLOGOP(OP_OR, 0, first, falseop);
3621
3622     scalarboolean(first);
3623     if (first->op_type == OP_CONST) {
3624         if (first->op_private & OPpCONST_BARE &&
3625            first->op_private & OPpCONST_STRICT) {
3626            no_bareword_allowed(first);
3627        }
3628         if (SvTRUE(((SVOP*)first)->op_sv)) {
3629             op_free(first);
3630             op_free(falseop);
3631             return trueop;
3632         }
3633         else {
3634             op_free(first);
3635             op_free(trueop);
3636             return falseop;
3637         }
3638     }
3639     NewOp(1101, logop, 1, LOGOP);
3640     logop->op_type = OP_COND_EXPR;
3641     logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3642     logop->op_first = first;
3643     logop->op_flags = flags | OPf_KIDS;
3644     logop->op_private = (U8)(1 | (flags >> 8));
3645     logop->op_other = LINKLIST(trueop);
3646     logop->op_next = LINKLIST(falseop);
3647
3648     CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
3649             logop);
3650
3651     /* establish postfix order */
3652     start = LINKLIST(first);
3653     first->op_next = (OP*)logop;
3654
3655     first->op_sibling = trueop;
3656     trueop->op_sibling = falseop;
3657     o = newUNOP(OP_NULL, 0, (OP*)logop);
3658
3659     trueop->op_next = falseop->op_next = o;
3660
3661     o->op_next = start;
3662     return o;
3663 }
3664
3665 OP *
3666 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3667 {
3668     LOGOP *range;
3669     OP *flip;
3670     OP *flop;
3671     OP *leftstart;
3672     OP *o;
3673
3674     NewOp(1101, range, 1, LOGOP);
3675
3676     range->op_type = OP_RANGE;
3677     range->op_ppaddr = PL_ppaddr[OP_RANGE];
3678     range->op_first = left;
3679     range->op_flags = OPf_KIDS;
3680     leftstart = LINKLIST(left);
3681     range->op_other = LINKLIST(right);
3682     range->op_private = (U8)(1 | (flags >> 8));
3683
3684     left->op_sibling = right;
3685
3686     range->op_next = (OP*)range;
3687     flip = newUNOP(OP_FLIP, flags, (OP*)range);
3688     flop = newUNOP(OP_FLOP, 0, flip);
3689     o = newUNOP(OP_NULL, 0, flop);
3690     linklist(flop);
3691     range->op_next = leftstart;
3692
3693     left->op_next = flip;
3694     right->op_next = flop;
3695
3696     range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3697     sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3698     flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3699     sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3700
3701     flip->op_private =  left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3702     flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3703
3704     flip->op_next = o;
3705     if (!flip->op_private || !flop->op_private)
3706         linklist(o);            /* blow off optimizer unless constant */
3707
3708     return o;
3709 }
3710
3711 OP *
3712 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3713 {
3714     OP* listop;
3715     OP* o;
3716     const bool once = block && block->op_flags & OPf_SPECIAL &&
3717       (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3718     (void)debuggable;
3719
3720     if (expr) {
3721         if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3722             return block;       /* do {} while 0 does once */
3723         if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3724             || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3725             expr = newUNOP(OP_DEFINED, 0,
3726                 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3727         } else if (expr->op_flags & OPf_KIDS) {
3728             const OP *k1 = ((UNOP*)expr)->op_first;
3729             const OP *k2 = (k1) ? k1->op_sibling : NULL;
3730             switch (expr->op_type) {
3731               case OP_NULL:
3732                 if (k2 && k2->op_type == OP_READLINE
3733                       && (k2->op_flags & OPf_STACKED)
3734                       && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3735                     expr = newUNOP(OP_DEFINED, 0, expr);
3736                 break;
3737
3738               case OP_SASSIGN:
3739                 if (k1->op_type == OP_READDIR
3740                       || k1->op_type == OP_GLOB
3741                       || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3742                       || k1->op_type == OP_EACH)
3743                     expr = newUNOP(OP_DEFINED, 0, expr);
3744                 break;
3745             }
3746         }
3747     }
3748
3749     /* if block is null, the next append_elem() would put UNSTACK, a scalar
3750      * op, in listop. This is wrong. [perl #27024] */
3751     if (!block)
3752         block = newOP(OP_NULL, 0);
3753     listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3754     o = new_logop(OP_AND, 0, &expr, &listop);
3755
3756     if (listop)
3757         ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3758
3759     if (once && o != listop)
3760         o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3761
3762     if (o == listop)
3763         o = newUNOP(OP_NULL, 0, o);     /* or do {} while 1 loses outer block */
3764
3765     o->op_flags |= flags;
3766     o = scope(o);
3767     o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3768     return o;
3769 }
3770
3771 OP *
3772 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
3773 {
3774     OP *redo;
3775     OP *next = 0;
3776     OP *listop;
3777     OP *o;
3778     U8 loopflags = 0;
3779     (void)debuggable;
3780
3781     if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3782                  || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
3783         expr = newUNOP(OP_DEFINED, 0,
3784             newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3785     } else if (expr && (expr->op_flags & OPf_KIDS)) {
3786         const OP *k1 = ((UNOP*)expr)->op_first;
3787         const OP *k2 = (k1) ? k1->op_sibling : NULL;
3788         switch (expr->op_type) {
3789           case OP_NULL:
3790             if (k2 && k2->op_type == OP_READLINE
3791                   && (k2->op_flags & OPf_STACKED)
3792                   && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3793                 expr = newUNOP(OP_DEFINED, 0, expr);
3794             break;
3795
3796           case OP_SASSIGN:
3797             if (k1->op_type == OP_READDIR
3798                   || k1->op_type == OP_GLOB
3799                   || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3800                   || k1->op_type == OP_EACH)
3801                 expr = newUNOP(OP_DEFINED, 0, expr);
3802             break;
3803         }
3804     }
3805
3806     if (!block)
3807         block = newOP(OP_NULL, 0);
3808     else if (cont) {
3809         block = scope(block);
3810     }
3811
3812     if (cont) {
3813         next = LINKLIST(cont);
3814     }
3815     if (expr) {
3816         OP *unstack = newOP(OP_UNSTACK, 0);
3817         if (!next)
3818             next = unstack;
3819         cont = append_elem(OP_LINESEQ, cont, unstack);
3820     }
3821
3822     listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
3823     redo = LINKLIST(listop);
3824
3825     if (expr) {
3826         PL_copline = (line_t)whileline;
3827         scalar(listop);
3828         o = new_logop(OP_AND, 0, &expr, &listop);
3829         if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
3830             op_free(expr);              /* oops, it's a while (0) */
3831             op_free((OP*)loop);
3832             return Nullop;              /* listop already freed by new_logop */
3833         }
3834         if (listop)
3835             ((LISTOP*)listop)->op_last->op_next =
3836                 (o == listop ? redo : LINKLIST(o));
3837     }
3838     else
3839         o = listop;
3840
3841     if (!loop) {
3842         NewOp(1101,loop,1,LOOP);
3843         loop->op_type = OP_ENTERLOOP;
3844         loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
3845         loop->op_private = 0;
3846         loop->op_next = (OP*)loop;
3847     }
3848
3849     o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
3850
3851     loop->op_redoop = redo;
3852     loop->op_lastop = o;
3853     o->op_private |= loopflags;
3854
3855     if (next)
3856         loop->op_nextop = next;
3857     else
3858         loop->op_nextop = o;
3859
3860     o->op_flags |= flags;
3861     o->op_private |= (flags >> 8);
3862     return o;
3863 }
3864
3865 OP *
3866 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
3867 {
3868     LOOP *loop;
3869     OP *wop;
3870     PADOFFSET padoff = 0;
3871     I32 iterflags = 0;
3872     I32 iterpflags = 0;
3873
3874     if (sv) {
3875         if (sv->op_type == OP_RV2SV) {  /* symbol table variable */
3876             iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
3877             sv->op_type = OP_RV2GV;
3878             sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
3879         }
3880         else if (sv->op_type == OP_PADSV) { /* private variable */
3881             iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
3882             padoff = sv->op_targ;
3883             sv->op_targ = 0;
3884             op_free(sv);
3885             sv = Nullop;
3886         }
3887         else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
3888             padoff = sv->op_targ;
3889             sv->op_targ = 0;
3890             iterflags |= OPf_SPECIAL;
3891             op_free(sv);
3892             sv = Nullop;
3893         }
3894         else
3895             Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
3896     }
3897     else {
3898         const I32 offset = pad_findmy("$_");
3899         if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
3900             sv = newGVOP(OP_GV, 0, PL_defgv);
3901         }
3902         else {
3903             padoff = offset;
3904         }
3905     }
3906     if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
3907         expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
3908         iterflags |= OPf_STACKED;
3909     }
3910     else if (expr->op_type == OP_NULL &&
3911              (expr->op_flags & OPf_KIDS) &&
3912              ((BINOP*)expr)->op_first->op_type == OP_FLOP)
3913     {
3914         /* Basically turn for($x..$y) into the same as for($x,$y), but we
3915          * set the STACKED flag to indicate that these values are to be
3916          * treated as min/max values by 'pp_iterinit'.
3917          */
3918         UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
3919         LOGOP* range = (LOGOP*) flip->op_first;
3920         OP* left  = range->op_first;
3921         OP* right = left->op_sibling;
3922         LISTOP* listop;
3923
3924         range->op_flags &= ~OPf_KIDS;
3925         range->op_first = Nullop;
3926
3927         listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
3928         listop->op_first->op_next = range->op_next;
3929         left->op_next = range->op_other;
3930         right->op_next = (OP*)listop;
3931         listop->op_next = listop->op_first;
3932
3933         op_free(expr);
3934         expr = (OP*)(listop);
3935         op_null(expr);
3936         iterflags |= OPf_STACKED;
3937     }
3938     else {
3939         expr = mod(force_list(expr), OP_GREPSTART);
3940     }
3941
3942     loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
3943                                append_elem(OP_LIST, expr, scalar(sv))));
3944     assert(!loop->op_next);
3945     /* for my  $x () sets OPpLVAL_INTRO;
3946      * for our $x () sets OPpOUR_INTRO */
3947     loop->op_private = (U8)iterpflags;
3948 #ifdef PL_OP_SLAB_ALLOC
3949     {
3950         LOOP *tmp;
3951         NewOp(1234,tmp,1,LOOP);
3952         Copy(loop,tmp,1,LISTOP);
3953         FreeOp(loop);
3954         loop = tmp;
3955     }
3956 #else
3957     Renew(loop, 1, LOOP);
3958 #endif
3959     loop->op_targ = padoff;
3960     wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
3961     PL_copline = forline;
3962     return newSTATEOP(0, label, wop);
3963 }
3964
3965 OP*
3966 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
3967 {
3968     OP *o;
3969     STRLEN n_a;
3970
3971     if (type != OP_GOTO || label->op_type == OP_CONST) {
3972         /* "last()" means "last" */
3973         if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
3974             o = newOP(type, OPf_SPECIAL);
3975         else {
3976             o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
3977                                         ? SvPVx(((SVOP*)label)->op_sv, n_a)
3978                                         : ""));
3979         }
3980         op_free(label);
3981     }
3982     else {
3983         /* Check whether it's going to be a goto &function */
3984         if (label->op_type == OP_ENTERSUB
3985                 && !(label->op_flags & OPf_STACKED))
3986             label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
3987         o = newUNOP(type, OPf_STACKED, label);
3988     }
3989     PL_hints |= HINT_BLOCK_SCOPE;
3990     return o;
3991 }
3992
3993 /*
3994 =for apidoc cv_undef
3995
3996 Clear out all the active components of a CV. This can happen either
3997 by an explicit C<undef &foo>, or by the reference count going to zero.
3998 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
3999 children can still follow the full lexical scope chain.
4000
4001 =cut
4002 */
4003
4004 void
4005 Perl_cv_undef(pTHX_ CV *cv)
4006 {
4007 #ifdef USE_ITHREADS
4008     if (CvFILE(cv) && !CvXSUB(cv)) {
4009         /* for XSUBs CvFILE point directly to static memory; __FILE__ */
4010         Safefree(CvFILE(cv));
4011     }
4012     CvFILE(cv) = 0;
4013 #endif
4014
4015     if (!CvXSUB(cv) && CvROOT(cv)) {
4016         if (CvDEPTH(cv))
4017             Perl_croak(aTHX_ "Can't undef active subroutine");
4018         ENTER;
4019
4020         PAD_SAVE_SETNULLPAD();
4021
4022         op_free(CvROOT(cv));
4023         CvROOT(cv) = Nullop;
4024         LEAVE;
4025     }
4026     SvPOK_off((SV*)cv);         /* forget prototype */
4027     CvGV(cv) = Nullgv;
4028
4029     pad_undef(cv);
4030
4031     /* remove CvOUTSIDE unless this is an undef rather than a free */
4032     if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
4033         if (!CvWEAKOUTSIDE(cv))
4034             SvREFCNT_dec(CvOUTSIDE(cv));
4035         CvOUTSIDE(cv) = Nullcv;
4036     }
4037     if (CvCONST(cv)) {
4038         SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4039         CvCONST_off(cv);
4040     }
4041     if (CvXSUB(cv)) {
4042         CvXSUB(cv) = 0;
4043     }
4044     /* delete all flags except WEAKOUTSIDE */
4045     CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
4046 }
4047
4048 void
4049 Perl_cv_ckproto(pTHX_ const CV *cv, const GV *gv, const char *p)
4050 {
4051     if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4052         SV* msg = sv_newmortal();
4053         SV* name = Nullsv;
4054
4055         if (gv)
4056             gv_efullname3(name = sv_newmortal(), gv, Nullch);
4057         sv_setpv(msg, "Prototype mismatch:");
4058         if (name)
4059             Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4060         if (SvPOK(cv))
4061             Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (const SV *)cv);
4062         else
4063             Perl_sv_catpv(aTHX_ msg, ": none");
4064         sv_catpv(msg, " vs ");
4065         if (p)
4066             Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4067         else
4068             sv_catpv(msg, "none");
4069         Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, msg);
4070     }
4071 }
4072
4073 static void const_sv_xsub(pTHX_ CV* cv);
4074
4075 /*
4076
4077 =head1 Optree Manipulation Functions
4078
4079 =for apidoc cv_const_sv
4080
4081 If C<cv> is a constant sub eligible for inlining. returns the constant
4082 value returned by the sub.  Otherwise, returns NULL.
4083
4084 Constant subs can be created with C<newCONSTSUB> or as described in
4085 L<perlsub/"Constant Functions">.
4086
4087 =cut
4088 */
4089 SV *
4090 Perl_cv_const_sv(pTHX_ CV *cv)
4091 {
4092     if (!cv || !CvCONST(cv))
4093         return Nullsv;
4094     return (SV*)CvXSUBANY(cv).any_ptr;
4095 }
4096
4097 /* op_const_sv:  examine an optree to determine whether it's in-lineable.
4098  * Can be called in 3 ways:
4099  *
4100  * !cv
4101  *      look for a single OP_CONST with attached value: return the value
4102  *
4103  * cv && CvCLONE(cv) && !CvCONST(cv)
4104  *
4105  *      examine the clone prototype, and if contains only a single
4106  *      OP_CONST referencing a pad const, or a single PADSV referencing
4107  *      an outer lexical, return a non-zero value to indicate the CV is
4108  *      a candidate for "constizing" at clone time
4109  *
4110  * cv && CvCONST(cv)
4111  *
4112  *      We have just cloned an anon prototype that was marked as a const
4113  *      candidiate. Try to grab the current value, and in the case of
4114  *      PADSV, ignore it if it has multiple references. Return the value.
4115  */
4116
4117 SV *
4118 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
4119 {
4120     SV *sv = Nullsv;
4121
4122     if (!o)
4123         return Nullsv;
4124
4125     if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4126         o = cLISTOPo->op_first->op_sibling;
4127
4128     for (; o; o = o->op_next) {
4129         OPCODE type = o->op_type;
4130
4131         if (sv && o->op_next == o)
4132             return sv;
4133         if (o->op_next != o) {
4134             if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4135                 continue;
4136             if (type == OP_DBSTATE)
4137                 continue;
4138         }
4139         if (type == OP_LEAVESUB || type == OP_RETURN)
4140             break;
4141         if (sv)
4142             return Nullsv;
4143         if (type == OP_CONST && cSVOPo->op_sv)
4144             sv = cSVOPo->op_sv;
4145         else if (cv && type == OP_CONST) {
4146             sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4147             if (!sv)
4148                 return Nullsv;
4149         }
4150         else if (cv && type == OP_PADSV) {
4151             if (CvCONST(cv)) { /* newly cloned anon */
4152                 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4153                 /* the candidate should have 1 ref from this pad and 1 ref
4154                  * from the parent */
4155                 if (!sv || SvREFCNT(sv) != 2)
4156                     return Nullsv;
4157                 sv = newSVsv(sv);
4158                 SvREADONLY_on(sv);
4159                 return sv;
4160             }
4161             else {
4162                 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
4163                     sv = &PL_sv_undef; /* an arbitrary non-null value */
4164             }
4165         }
4166         else {
4167             return Nullsv;
4168         }
4169     }
4170     return sv;
4171 }
4172
4173 void
4174 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4175 {
4176     (void)floor;
4177     if (o)
4178         SAVEFREEOP(o);
4179     if (proto)
4180         SAVEFREEOP(proto);
4181     if (attrs)
4182         SAVEFREEOP(attrs);
4183     if (block)
4184         SAVEFREEOP(block);
4185     Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4186 }
4187
4188 CV *
4189 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4190 {
4191     return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4192 }
4193
4194 CV *
4195 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4196 {
4197     STRLEN n_a;
4198     const char *name;
4199     const char *aname;
4200     GV *gv;
4201     char *ps;
4202     register CV *cv=0;
4203     SV *const_sv;
4204
4205     name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4206
4207     if (proto) {
4208         assert(proto->op_type == OP_CONST);
4209         ps = SvPVx(((SVOP*)proto)->op_sv, n_a);
4210     }
4211     else
4212         ps = Nullch;
4213
4214     if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4215         SV *sv = sv_newmortal();
4216         Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
4217                        PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
4218                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4219         aname = SvPVX(sv);
4220     }
4221     else
4222         aname = Nullch;
4223     gv = name ? gv_fetchsv(cSVOPo->op_sv,
4224                            GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4225                            SVt_PVCV)
4226         : gv_fetchpv(aname ? aname
4227                      : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4228                      GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4229                      SVt_PVCV);
4230
4231     if (o)
4232         SAVEFREEOP(o);
4233     if (proto)
4234         SAVEFREEOP(proto);
4235     if (attrs)
4236         SAVEFREEOP(attrs);
4237
4238     if (SvTYPE(gv) != SVt_PVGV) {       /* Maybe prototype now, and had at
4239                                            maximum a prototype before. */
4240         if (SvTYPE(gv) > SVt_NULL) {
4241             if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4242                 && ckWARN_d(WARN_PROTOTYPE))
4243             {
4244                 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
4245             }
4246             cv_ckproto((CV*)gv, NULL, ps);
4247         }
4248         if (ps)
4249             sv_setpv((SV*)gv, ps);
4250         else
4251             sv_setiv((SV*)gv, -1);
4252         SvREFCNT_dec(PL_compcv);
4253         cv = PL_compcv = NULL;
4254         PL_sub_generation++;
4255         goto done;
4256     }
4257
4258     cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4259
4260 #ifdef GV_UNIQUE_CHECK
4261     if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4262         Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
4263     }
4264 #endif
4265
4266     if (!block || !ps || *ps || attrs)
4267         const_sv = Nullsv;
4268     else
4269         const_sv = op_const_sv(block, Nullcv);
4270
4271     if (cv) {
4272         const bool exists = CvROOT(cv) || CvXSUB(cv);
4273
4274 #ifdef GV_UNIQUE_CHECK
4275         if (exists && GvUNIQUE(gv)) {
4276             Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
4277         }
4278 #endif
4279
4280         /* if the subroutine doesn't exist and wasn't pre-declared
4281          * with a prototype, assume it will be AUTOLOADed,
4282          * skipping the prototype check
4283          */
4284         if (exists || SvPOK(cv))
4285             cv_ckproto(cv, gv, ps);
4286         /* already defined (or promised)? */
4287         if (exists || GvASSUMECV(gv)) {
4288             if (!block && !attrs) {
4289                 if (CvFLAGS(PL_compcv)) {
4290                     /* might have had built-in attrs applied */
4291                     CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4292                 }
4293                 /* just a "sub foo;" when &foo is already defined */
4294                 SAVEFREESV(PL_compcv);
4295                 goto done;
4296             }
4297             /* ahem, death to those who redefine active sort subs */
4298             if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4299                 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4300             if (block) {
4301                 if (ckWARN(WARN_REDEFINE)
4302                     || (CvCONST(cv)
4303                         && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4304                 {
4305                     const line_t oldline = CopLINE(PL_curcop);
4306                     if (PL_copline != NOLINE)
4307                         CopLINE_set(PL_curcop, PL_copline);
4308                     Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4309                         CvCONST(cv) ? "Constant subroutine %s redefined"
4310                                     : "Subroutine %s redefined", name);
4311                     CopLINE_set(PL_curcop, oldline);
4312                 }
4313                 SvREFCNT_dec(cv);
4314                 cv = Nullcv;
4315             }
4316         }
4317     }
4318     if (const_sv) {
4319         (void)SvREFCNT_inc(const_sv);
4320         if (cv) {
4321             assert(!CvROOT(cv) && !CvCONST(cv));
4322             sv_setpv((SV*)cv, "");  /* prototype is "" */
4323             CvXSUBANY(cv).any_ptr = const_sv;
4324             CvXSUB(cv) = const_sv_xsub;
4325             CvCONST_on(cv);
4326         }
4327         else {
4328             GvCV(gv) = Nullcv;
4329             cv = newCONSTSUB(NULL, name, const_sv);
4330         }
4331         op_free(block);
4332         SvREFCNT_dec(PL_compcv);
4333         PL_compcv = NULL;
4334         PL_sub_generation++;
4335         goto done;
4336     }
4337     if (attrs) {
4338         HV *stash;
4339         SV *rcv;
4340
4341         /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4342          * before we clobber PL_compcv.
4343          */
4344         if (cv && !block) {
4345             rcv = (SV*)cv;
4346             /* Might have had built-in attributes applied -- propagate them. */
4347             CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4348             if (CvGV(cv) && GvSTASH(CvGV(cv)))
4349                 stash = GvSTASH(CvGV(cv));
4350             else if (CvSTASH(cv))
4351                 stash = CvSTASH(cv);
4352             else
4353                 stash = PL_curstash;
4354         }
4355         else {
4356             /* possibly about to re-define existing subr -- ignore old cv */
4357             rcv = (SV*)PL_compcv;
4358             if (name && GvSTASH(gv))
4359                 stash = GvSTASH(gv);
4360             else
4361                 stash = PL_curstash;
4362         }
4363         apply_attrs(stash, rcv, attrs, FALSE);
4364     }
4365     if (cv) {                           /* must reuse cv if autoloaded */
4366         if (!block) {
4367             /* got here with just attrs -- work done, so bug out */
4368             SAVEFREESV(PL_compcv);
4369             goto done;
4370         }
4371         /* transfer PL_compcv to cv */
4372         cv_undef(cv);
4373         CvFLAGS(cv) = CvFLAGS(PL_compcv);
4374         if (!CvWEAKOUTSIDE(cv))
4375             SvREFCNT_dec(CvOUTSIDE(cv));
4376         CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4377         CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
4378         CvOUTSIDE(PL_compcv) = 0;
4379         CvPADLIST(cv) = CvPADLIST(PL_compcv);
4380         CvPADLIST(PL_compcv) = 0;
4381         /* inner references to PL_compcv must be fixed up ... */
4382         pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
4383         /* ... before we throw it away */
4384         SvREFCNT_dec(PL_compcv);
4385         PL_compcv = cv;
4386         if (PERLDB_INTER)/* Advice debugger on the new sub. */
4387           ++PL_sub_generation;
4388     }
4389     else {
4390         cv = PL_compcv;
4391         if (name) {
4392             GvCV(gv) = cv;
4393             GvCVGEN(gv) = 0;
4394             PL_sub_generation++;
4395         }
4396     }
4397     CvGV(cv) = gv;
4398     CvFILE_set_from_cop(cv, PL_curcop);
4399     CvSTASH(cv) = PL_curstash;
4400
4401     if (ps)
4402         sv_setpv((SV*)cv, ps);
4403
4404     if (PL_error_count) {
4405         op_free(block);
4406         block = Nullop;
4407         if (name) {
4408             const char *s = strrchr(name, ':');
4409             s = s ? s+1 : name;
4410             if (strEQ(s, "BEGIN")) {
4411                 const char not_safe[] =
4412                     "BEGIN not safe after errors--compilation aborted";
4413                 if (PL_in_eval & EVAL_KEEPERR)
4414                     Perl_croak(aTHX_ not_safe);
4415                 else {
4416                     /* force display of errors found but not reported */
4417                     sv_catpv(ERRSV, not_safe);
4418                     Perl_croak(aTHX_ "%"SVf, ERRSV);
4419                 }
4420             }
4421         }
4422     }
4423     if (!block)
4424         goto done;
4425
4426     if (CvLVALUE(cv)) {
4427         CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4428                              mod(scalarseq(block), OP_LEAVESUBLV));
4429     }
4430     else {
4431         /* This makes sub {}; work as expected.  */
4432         if (block->op_type == OP_STUB) {
4433             op_free(block);
4434             block = newSTATEOP(0, Nullch, 0);
4435         }
4436         CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4437     }
4438     CvROOT(cv)->op_private |= OPpREFCOUNTED;
4439     OpREFCNT_set(CvROOT(cv), 1);
4440     CvSTART(cv) = LINKLIST(CvROOT(cv));
4441     CvROOT(cv)->op_next = 0;
4442     CALL_PEEP(CvSTART(cv));
4443
4444     /* now that optimizer has done its work, adjust pad values */
4445
4446     pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
4447
4448     if (CvCLONE(cv)) {
4449         assert(!CvCONST(cv));
4450         if (ps && !*ps && op_const_sv(block, cv))
4451             CvCONST_on(cv);
4452     }
4453
4454     if (name || aname) {
4455         const char *s;
4456         const char *tname = (name ? name : aname);
4457
4458         if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4459             SV *sv = NEWSV(0,0);
4460             SV *tmpstr = sv_newmortal();
4461             GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4462             CV *pcv;
4463             HV *hv;
4464
4465             Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4466                            CopFILE(PL_curcop),
4467                            (long)PL_subline, (long)CopLINE(PL_curcop));
4468             gv_efullname3(tmpstr, gv, Nullch);
4469             hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
4470             hv = GvHVn(db_postponed);
4471             if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
4472                 && (pcv = GvCV(db_postponed)))
4473             {
4474                 dSP;
4475                 PUSHMARK(SP);
4476                 XPUSHs(tmpstr);
4477                 PUTBACK;
4478                 call_sv((SV*)pcv, G_DISCARD);
4479             }
4480         }
4481
4482         if ((s = strrchr(tname,':')))
4483             s++;
4484         else
4485             s = tname;
4486
4487         if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4488             goto done;
4489
4490         if (strEQ(s, "BEGIN") && !PL_error_count) {
4491             const I32 oldscope = PL_scopestack_ix;
4492             ENTER;
4493             SAVECOPFILE(&PL_compiling);
4494             SAVECOPLINE(&PL_compiling);
4495
4496             if (!PL_beginav)
4497                 PL_beginav = newAV();
4498             DEBUG_x( dump_sub(gv) );
4499             av_push(PL_beginav, (SV*)cv);
4500             GvCV(gv) = 0;               /* cv has been hijacked */
4501             call_list(oldscope, PL_beginav);
4502
4503             PL_curcop = &PL_compiling;
4504             PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4505             LEAVE;
4506         }
4507         else if (strEQ(s, "END") && !PL_error_count) {
4508             if (!PL_endav)
4509                 PL_endav = newAV();
4510             DEBUG_x( dump_sub(gv) );
4511             av_unshift(PL_endav, 1);
4512             av_store(PL_endav, 0, (SV*)cv);
4513             GvCV(gv) = 0;               /* cv has been hijacked */
4514         }
4515         else if (strEQ(s, "CHECK") && !PL_error_count) {
4516             if (!PL_checkav)
4517                 PL_checkav = newAV();
4518             DEBUG_x( dump_sub(gv) );
4519             if (PL_main_start && ckWARN(WARN_VOID))
4520                 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4521             av_unshift(PL_checkav, 1);
4522             av_store(PL_checkav, 0, (SV*)cv);
4523             GvCV(gv) = 0;               /* cv has been hijacked */
4524         }
4525         else if (strEQ(s, "INIT") && !PL_error_count) {
4526             if (!PL_initav)
4527                 PL_initav = newAV();
4528             DEBUG_x( dump_sub(gv) );
4529             if (PL_main_start && ckWARN(WARN_VOID))
4530                 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4531             av_push(PL_initav, (SV*)cv);
4532             GvCV(gv) = 0;               /* cv has been hijacked */
4533         }
4534     }
4535
4536   done:
4537     PL_copline = NOLINE;
4538     LEAVE_SCOPE(floor);
4539     return cv;
4540 }
4541
4542 /* XXX unsafe for threads if eval_owner isn't held */
4543 /*
4544 =for apidoc newCONSTSUB
4545
4546 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4547 eligible for inlining at compile-time.
4548
4549 =cut
4550 */
4551
4552 CV *
4553 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
4554 {
4555     CV* cv;
4556
4557     ENTER;
4558
4559     SAVECOPLINE(PL_curcop);
4560     CopLINE_set(PL_curcop, PL_copline);
4561
4562     SAVEHINTS();
4563     PL_hints &= ~HINT_BLOCK_SCOPE;
4564
4565     if (stash) {
4566         SAVESPTR(PL_curstash);
4567         SAVECOPSTASH(PL_curcop);
4568         PL_curstash = stash;
4569         CopSTASH_set(PL_curcop,stash);
4570     }
4571
4572     cv = newXS(name, const_sv_xsub, savepv(CopFILE(PL_curcop)));
4573     CvXSUBANY(cv).any_ptr = sv;
4574     CvCONST_on(cv);
4575     sv_setpv((SV*)cv, "");  /* prototype is "" */
4576
4577     if (stash)
4578         CopSTASH_free(PL_curcop);
4579
4580     LEAVE;
4581
4582     return cv;
4583 }
4584
4585 /*
4586 =for apidoc U||newXS
4587
4588 Used by C<xsubpp> to hook up XSUBs as Perl subs.
4589
4590 =cut
4591 */
4592
4593 CV *
4594 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
4595 {
4596     GV *gv = gv_fetchpv(name ? name :
4597                         (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4598                         GV_ADDMULTI, SVt_PVCV);
4599     register CV *cv;
4600
4601     if (!subaddr)
4602         Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
4603
4604     if ((cv = (name ? GvCV(gv) : Nullcv))) {
4605         if (GvCVGEN(gv)) {
4606             /* just a cached method */
4607             SvREFCNT_dec(cv);
4608             cv = 0;
4609         }
4610         else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4611             /* already defined (or promised) */
4612             if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
4613                             && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
4614                 const line_t oldline = CopLINE(PL_curcop);
4615                 if (PL_copline != NOLINE)
4616                     CopLINE_set(PL_curcop, PL_copline);
4617                 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4618                             CvCONST(cv) ? "Constant subroutine %s redefined"
4619                                         : "Subroutine %s redefined"
4620                             ,name);
4621                 CopLINE_set(PL_curcop, oldline);
4622             }
4623             SvREFCNT_dec(cv);
4624             cv = 0;
4625         }
4626     }
4627
4628     if (cv)                             /* must reuse cv if autoloaded */
4629         cv_undef(cv);
4630     else {
4631         cv = (CV*)NEWSV(1105,0);
4632         sv_upgrade((SV *)cv, SVt_PVCV);
4633         if (name) {
4634             GvCV(gv) = cv;
4635             GvCVGEN(gv) = 0;
4636             PL_sub_generation++;
4637         }
4638     }
4639     CvGV(cv) = gv;
4640     (void)gv_fetchfile(filename);
4641     CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
4642                                    an external constant string */
4643     CvXSUB(cv) = subaddr;
4644
4645     if (name) {
4646         const char *s = strrchr(name,':');
4647         if (s)
4648             s++;
4649         else
4650             s = name;
4651
4652         if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4653             goto done;
4654
4655         if (strEQ(s, "BEGIN")) {
4656             if (!PL_beginav)
4657                 PL_beginav = newAV();
4658             av_push(PL_beginav, (SV*)cv);
4659             GvCV(gv) = 0;               /* cv has been hijacked */
4660         }
4661         else if (strEQ(s, "END")) {
4662             if (!PL_endav)
4663                 PL_endav = newAV();
4664             av_unshift(PL_endav, 1);
4665             av_store(PL_endav, 0, (SV*)cv);
4666             GvCV(gv) = 0;               /* cv has been hijacked */
4667         }
4668         else if (strEQ(s, "CHECK")) {
4669             if (!PL_checkav)
4670                 PL_checkav = newAV();
4671             if (PL_main_start && ckWARN(WARN_VOID))
4672                 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4673             av_unshift(PL_checkav, 1);
4674             av_store(PL_checkav, 0, (SV*)cv);
4675             GvCV(gv) = 0;               /* cv has been hijacked */
4676         }
4677         else if (strEQ(s, "INIT")) {
4678             if (!PL_initav)
4679                 PL_initav = newAV();
4680             if (PL_main_start && ckWARN(WARN_VOID))
4681                 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4682             av_push(PL_initav, (SV*)cv);
4683             GvCV(gv) = 0;               /* cv has been hijacked */
4684         }
4685     }
4686     else
4687         CvANON_on(cv);
4688
4689 done:
4690     return cv;
4691 }
4692
4693 void
4694 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
4695 {
4696     register CV *cv;
4697     GV *gv;
4698
4699     if (o)
4700         gv = gv_fetchsv(cSVOPo->op_sv, TRUE, SVt_PVFM);
4701     else
4702         gv = gv_fetchpv("STDOUT", TRUE, SVt_PVFM);
4703
4704 #ifdef GV_UNIQUE_CHECK
4705     if (GvUNIQUE(gv)) {
4706         Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
4707     }
4708 #endif
4709     GvMULTI_on(gv);
4710     if ((cv = GvFORM(gv))) {
4711         if (ckWARN(WARN_REDEFINE)) {
4712             const line_t oldline = CopLINE(PL_curcop);
4713             if (PL_copline != NOLINE)
4714                 CopLINE_set(PL_curcop, PL_copline);
4715             Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4716                         o ? "Format %"SVf" redefined"
4717                         : "Format STDOUT redefined" ,cSVOPo->op_sv);
4718             CopLINE_set(PL_curcop, oldline);
4719         }
4720         SvREFCNT_dec(cv);
4721     }
4722     cv = PL_compcv;
4723     GvFORM(gv) = cv;
4724     CvGV(cv) = gv;
4725     CvFILE_set_from_cop(cv, PL_curcop);
4726
4727
4728     pad_tidy(padtidy_FORMAT);
4729     CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
4730     CvROOT(cv)->op_private |= OPpREFCOUNTED;
4731     OpREFCNT_set(CvROOT(cv), 1);
4732     CvSTART(cv) = LINKLIST(CvROOT(cv));
4733     CvROOT(cv)->op_next = 0;
4734     CALL_PEEP(CvSTART(cv));
4735     op_free(o);
4736     PL_copline = NOLINE;
4737     LEAVE_SCOPE(floor);
4738 }
4739
4740 OP *
4741 Perl_newANONLIST(pTHX_ OP *o)
4742 {
4743     return newUNOP(OP_REFGEN, 0,
4744         mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
4745 }
4746
4747 OP *
4748 Perl_newANONHASH(pTHX_ OP *o)
4749 {
4750     return newUNOP(OP_REFGEN, 0,
4751         mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
4752 }
4753
4754 OP *
4755 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
4756 {
4757     return newANONATTRSUB(floor, proto, Nullop, block);
4758 }
4759
4760 OP *
4761 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
4762 {
4763     return newUNOP(OP_REFGEN, 0,
4764         newSVOP(OP_ANONCODE, 0,
4765                 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
4766 }
4767
4768 OP *
4769 Perl_oopsAV(pTHX_ OP *o)
4770 {
4771     switch (o->op_type) {
4772     case OP_PADSV:
4773         o->op_type = OP_PADAV;
4774         o->op_ppaddr = PL_ppaddr[OP_PADAV];
4775         return ref(o, OP_RV2AV);
4776
4777     case OP_RV2SV:
4778         o->op_type = OP_RV2AV;
4779         o->op_ppaddr = PL_ppaddr[OP_RV2AV];
4780         ref(o, OP_RV2AV);
4781         break;
4782
4783     default:
4784         if (ckWARN_d(WARN_INTERNAL))
4785             Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
4786         break;
4787     }
4788     return o;
4789 }
4790
4791 OP *
4792 Perl_oopsHV(pTHX