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, 2006, 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 * const * const ptr = (I32 **) op;
 132     I32 * const 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 ", (OP*)0" 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          (OP*)0 )                                               \
 157      : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o))
 158
 159 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
 160
 161 STATIC const char*
 162 S_gv_ename(pTHX_ GV *gv)
 163 {
 164     SV* const tmpsv = sv_newmortal();
 165     gv_efullname3(tmpsv, gv, NULL);
 166     return SvPV_nolen_const(tmpsv);
 167 }
 168
 169 STATIC OP *
 170 S_no_fh_allowed(pTHX_ OP *o)
 171 {
 172     yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
 173                  OP_DESC(o)));
 174     return o;
 175 }
 176
 177 STATIC OP *
 178 S_too_few_arguments(pTHX_ OP *o, const char *name)
 179 {
 180     yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
 181     return o;
 182 }
 183
 184 STATIC OP *
 185 S_too_many_arguments(pTHX_ OP *o, const char *name)
 186 {
 187     yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
 188     return o;
 189 }
 190
 191 STATIC void
 192 S_bad_type(pTHX_ I32 n, const char *t, const char *name, const OP *kid)
 193 {
 194     yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
 195                  (int)n, name, t, OP_DESC(kid)));
 196 }
 197
 198 STATIC void
 199 S_no_bareword_allowed(pTHX_ const OP *o)
 200 {
 201     if (PL_madskills)
 202         return;         /* various ok barewords are hidden in extra OP_NULL */
 203     qerror(Perl_mess(aTHX_
 204                      "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
 205                      cSVOPo_sv));
 206 }
 207
 208 /* "register" allocation */
 209
 210 PADOFFSET
 211 Perl_allocmy(pTHX_ char *name)
 212 {
 213     dVAR;
 214     PADOFFSET off;
 215     const bool is_our = (PL_in_my == KEY_our);
 216
 217     /* complain about "my $<special_var>" etc etc */
 218     if (*name &&
 219         !(is_our ||
 220           isALPHA(name[1]) ||
 221           (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
 222           (name[1] == '_' && (*name == '$' || name[2]))))
 223     {
 224         /* name[2] is true if strlen(name) > 2  */
 225         if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
 226             /* 1999-02-27 mjd@plover.com */
 227             char *p;
 228             p = strchr(name, '\0');
 229             /* The next block assumes the buffer is at least 205 chars
 230                long.  At present, it's always at least 256 chars. */
 231             if (p-name > 200) {
 232                 strcpy(name+200, "...");
 233                 p = name+199;
 234             }
 235             else {
 236                 p[1] = '\0';
 237             }
 238             /* Move everything else down one character */
 239             for (; p-name > 2; p--)
 240                 *p = *(p-1);
 241             name[2] = toCTRL(name[1]);
 242             name[1] = '^';
 243         }
 244         yyerror(Perl_form(aTHX_ "Can't use global %s in \"my\"",name));
 245     }
 246
 247     /* check for duplicate declaration */
 248     pad_check_dup(name, is_our, (PL_curstash ? PL_curstash : PL_defstash));
 249
 250     if (PL_in_my_stash && *name != '$') {
 251         yyerror(Perl_form(aTHX_
 252                     "Can't declare class for non-scalar %s in \"%s\"",
 253                      name, is_our ? "our" : "my"));
 254     }
 255
 256     /* allocate a spare slot and store the name in that slot */
 257
 258     off = pad_add_name(name,
 259                     PL_in_my_stash,
 260                     (is_our
 261                         /* $_ is always in main::, even with our */
 262                         ? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash)
 263                         : NULL
 264                     ),
 265                     0 /*  not fake */
 266     );
 267     return off;
 268 }
 269
 270 /* Destructor */
 271
 272 void
 273 Perl_op_free(pTHX_ OP *o)
 274 {
 275     dVAR;
 276     OPCODE type;
 277
 278     if (!o || o->op_static)
 279         return;
 280
 281     type = o->op_type;
 282     if (o->op_private & OPpREFCOUNTED) {
 283         switch (type) {
 284         case OP_LEAVESUB:
 285         case OP_LEAVESUBLV:
 286         case OP_LEAVEEVAL:
 287         case OP_LEAVE:
 288         case OP_SCOPE:
 289         case OP_LEAVEWRITE:
 290             {
 291             PADOFFSET refcnt;
 292             OP_REFCNT_LOCK;
 293             refcnt = OpREFCNT_dec(o);
 294             OP_REFCNT_UNLOCK;
 295             if (refcnt)
 296                 return;
 297             }
 298             break;
 299         default:
 300             break;
 301         }
 302     }
 303
 304     if (o->op_flags & OPf_KIDS) {
 305         register OP *kid, *nextkid;
 306         for (kid = cUNOPo->op_first; kid; kid = nextkid) {
 307             nextkid = kid->op_sibling; /* Get before next freeing kid */
 308             op_free(kid);
 309         }
 310     }
 311     if (type == OP_NULL)
 312         type = (OPCODE)o->op_targ;
 313
 314     /* COP* is not cleared by op_clear() so that we may track line
 315      * numbers etc even after null() */
 316     if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE)
 317         cop_free((COP*)o);
 318
 319     op_clear(o);
 320     FreeOp(o);
 321 #ifdef DEBUG_LEAKING_SCALARS
 322     if (PL_op == o)
 323         PL_op = NULL;
 324 #endif
 325 }
 326
 327 void
 328 Perl_op_clear(pTHX_ OP *o)
 329 {
 330
 331     dVAR;
 332 #ifdef PERL_MAD
 333     /* if (o->op_madprop && o->op_madprop->mad_next)
 334        abort(); */
 335     /* FIXME for MAD - if I uncomment these two lines t/op/pack.t fails with
 336        "modification of a read only value" for a reason I can't fathom why.
 337        It's the "" stringification of $_, where $_ was set to '' in a foreach
 338        loop, but it defies simplification into a small test case.  */
 339     /*
 340       mad_free(o->op_madprop);
 341       o->op_madprop = 0;
 342     */
 343 #endif
 344
 345  retry:
 346     switch (o->op_type) {
 347     case OP_NULL:       /* Was holding old type, if any. */
 348         if (PL_madskills && o->op_targ != OP_NULL) {
 349             o->op_type = o->op_targ;
 350             o->op_targ = 0;
 351             goto retry;
 352         }
 353     case OP_ENTEREVAL:  /* Was holding hints. */
 354         o->op_targ = 0;
 355         break;
 356     default:
 357         if (!(o->op_flags & OPf_REF)
 358             || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
 359             break;
 360         /* FALL THROUGH */
 361     case OP_GVSV:
 362     case OP_GV:
 363     case OP_AELEMFAST:
 364         if (! (o->op_type == OP_AELEMFAST && o->op_flags & OPf_SPECIAL)) {
 365             /* not an OP_PADAV replacement */
 366 #ifdef USE_ITHREADS
 367             if (cPADOPo->op_padix > 0) {
 368                 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
 369                  * may still exist on the pad */
 370                 pad_swipe(cPADOPo->op_padix, TRUE);
 371                 cPADOPo->op_padix = 0;
 372             }
 373 #else
 374             SvREFCNT_dec(cSVOPo->op_sv);
 375             cSVOPo->op_sv = NULL;
 376 #endif
 377         }
 378         break;
 379     case OP_METHOD_NAMED:
 380     case OP_CONST:
 381         SvREFCNT_dec(cSVOPo->op_sv);
 382         cSVOPo->op_sv = NULL;
 383 #ifdef USE_ITHREADS
 384         /** Bug #15654
 385           Even if op_clear does a pad_free for the target of the op,
 386           pad_free doesn't actually remove the sv that exists in the pad;
 387           instead it lives on. This results in that it could be reused as
 388           a target later on when the pad was reallocated.
 389         **/
 390         if(o->op_targ) {
 391           pad_swipe(o->op_targ,1);
 392           o->op_targ = 0;
 393         }
 394 #endif
 395         break;
 396     case OP_GOTO:
 397     case OP_NEXT:
 398     case OP_LAST:
 399     case OP_REDO:
 400         if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
 401             break;
 402         /* FALL THROUGH */
 403     case OP_TRANS:
 404         if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
 405             SvREFCNT_dec(cSVOPo->op_sv);
 406             cSVOPo->op_sv = NULL;
 407         }
 408         else {
 409             Safefree(cPVOPo->op_pv);
 410             cPVOPo->op_pv = NULL;
 411         }
 412         break;
 413     case OP_SUBST:
 414         op_free(cPMOPo->op_pmreplroot);
 415         goto clear_pmop;
 416     case OP_PUSHRE:
 417 #ifdef USE_ITHREADS
 418         if (INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)) {
 419             /* No GvIN_PAD_off here, because other references may still
 420              * exist on the pad */
 421             pad_swipe(INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot), TRUE);
 422         }
 423 #else
 424         SvREFCNT_dec((SV*)cPMOPo->op_pmreplroot);
 425 #endif
 426         /* FALL THROUGH */
 427     case OP_MATCH:
 428     case OP_QR:
 429 clear_pmop:
 430         {
 431             HV * const pmstash = PmopSTASH(cPMOPo);
 432             if (pmstash && !SvIS_FREED(pmstash)) {
 433                 MAGIC * const mg = mg_find((SV*)pmstash, PERL_MAGIC_symtab);
 434                 if (mg) {
 435                     PMOP *pmop = (PMOP*) mg->mg_obj;
 436                     PMOP *lastpmop = NULL;
 437                     while (pmop) {
 438                         if (cPMOPo == pmop) {
 439                             if (lastpmop)
 440                                 lastpmop->op_pmnext = pmop->op_pmnext;
 441                             else
 442                                 mg->mg_obj = (SV*) pmop->op_pmnext;
 443                             break;
 444                         }
 445                         lastpmop = pmop;
 446                         pmop = pmop->op_pmnext;
 447                     }
 448                 }
 449             }
 450             PmopSTASH_free(cPMOPo);
 451         }
 452         cPMOPo->op_pmreplroot = NULL;
 453         /* we use the "SAFE" version of the PM_ macros here
 454          * since sv_clean_all might release some PMOPs
 455          * after PL_regex_padav has been cleared
 456          * and the clearing of PL_regex_padav needs to
 457          * happen before sv_clean_all
 458          */
 459         ReREFCNT_dec(PM_GETRE_SAFE(cPMOPo));
 460         PM_SETRE_SAFE(cPMOPo, NULL);
 461 #ifdef USE_ITHREADS
 462         if(PL_regex_pad) {        /* We could be in destruction */
 463             av_push((AV*) PL_regex_pad[0],(SV*) PL_regex_pad[(cPMOPo)->op_pmoffset]);
 464             SvREPADTMP_on(PL_regex_pad[(cPMOPo)->op_pmoffset]);
 465             PM_SETRE(cPMOPo, (cPMOPo)->op_pmoffset);
 466         }
 467 #endif
 468
 469         break;
 470     }
 471
 472     if (o->op_targ > 0) {
 473         pad_free(o->op_targ);
 474         o->op_targ = 0;
 475     }
 476 }
 477
 478 STATIC void
 479 S_cop_free(pTHX_ COP* cop)
 480 {
 481     Safefree(cop->cop_label);   /* FIXME: treaddead ??? */
 482     CopFILE_free(cop);
 483     CopSTASH_free(cop);
 484     if (! specialWARN(cop->cop_warnings))
 485         SvREFCNT_dec(cop->cop_warnings);
 486     if (! specialCopIO(cop->cop_io)) {
 487 #ifdef USE_ITHREADS
 488         /*EMPTY*/
 489 #else
 490         SvREFCNT_dec(cop->cop_io);
 491 #endif
 492     }
 493 }
 494
 495 void
 496 Perl_op_null(pTHX_ OP *o)
 497 {
 498     dVAR;
 499     if (o->op_type == OP_NULL)
 500         return;
 501     if (!PL_madskills)
 502         op_clear(o);
 503     o->op_targ = o->op_type;
 504     o->op_type = OP_NULL;
 505     o->op_ppaddr = PL_ppaddr[OP_NULL];
 506 }
 507
 508 void
 509 Perl_op_refcnt_lock(pTHX)
 510 {
 511     dVAR;
 512     PERL_UNUSED_CONTEXT;
 513     OP_REFCNT_LOCK;
 514 }
 515
 516 void
 517 Perl_op_refcnt_unlock(pTHX)
 518 {
 519     dVAR;
 520     PERL_UNUSED_CONTEXT;
 521     OP_REFCNT_UNLOCK;
 522 }
 523
 524 /* Contextualizers */
 525
 526 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
 527
 528 OP *
 529 Perl_linklist(pTHX_ OP *o)
 530 {
 531     OP *first;
 532
 533     if (o->op_next)
 534         return o->op_next;
 535
 536     /* establish postfix order */
 537     first = cUNOPo->op_first;
 538     if (first) {
 539         register OP *kid;
 540         o->op_next = LINKLIST(first);
 541         kid = first;
 542         for (;;) {
 543             if (kid->op_sibling) {
 544                 kid->op_next = LINKLIST(kid->op_sibling);
 545                 kid = kid->op_sibling;
 546             } else {
 547                 kid->op_next = o;
 548                 break;
 549             }
 550         }
 551     }
 552     else
 553         o->op_next = o;
 554
 555     return o->op_next;
 556 }
 557
 558 OP *
 559 Perl_scalarkids(pTHX_ OP *o)
 560 {
 561     if (o && o->op_flags & OPf_KIDS) {
 562         OP *kid;
 563         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
 564             scalar(kid);
 565     }
 566     return o;
 567 }
 568
 569 STATIC OP *
 570 S_scalarboolean(pTHX_ OP *o)
 571 {
 572     dVAR;
 573     if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
 574         if (ckWARN(WARN_SYNTAX)) {
 575             const line_t oldline = CopLINE(PL_curcop);
 576
 577             if (PL_copline != NOLINE)
 578                 CopLINE_set(PL_curcop, PL_copline);
 579             Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
 580             CopLINE_set(PL_curcop, oldline);
 581         }
 582     }
 583     return scalar(o);
 584 }
 585
 586 OP *
 587 Perl_scalar(pTHX_ OP *o)
 588 {
 589     dVAR;
 590     OP *kid;
 591
 592     /* assumes no premature commitment */
 593     if (!o || PL_error_count || (o->op_flags & OPf_WANT)
 594          || o->op_type == OP_RETURN)
 595     {
 596         return o;
 597     }
 598
 599     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
 600
 601     switch (o->op_type) {
 602     case OP_REPEAT:
 603         scalar(cBINOPo->op_first);
 604         break;
 605     case OP_OR:
 606     case OP_AND:
 607     case OP_COND_EXPR:
 608         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
 609             scalar(kid);
 610         break;
 611     case OP_SPLIT:
 612         if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
 613             if (!kPMOP->op_pmreplroot)
 614                 deprecate_old("implicit split to @_");
 615         }
 616         /* FALL THROUGH */
 617     case OP_MATCH:
 618     case OP_QR:
 619     case OP_SUBST:
 620     case OP_NULL:
 621     default:
 622         if (o->op_flags & OPf_KIDS) {
 623             for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
 624                 scalar(kid);
 625         }
 626         break;
 627     case OP_LEAVE:
 628     case OP_LEAVETRY:
 629         kid = cLISTOPo->op_first;
 630         scalar(kid);
 631         while ((kid = kid->op_sibling)) {
 632             if (kid->op_sibling)
 633                 scalarvoid(kid);
 634             else
 635                 scalar(kid);
 636         }
 637         WITH_THR(PL_curcop = &PL_compiling);
 638         break;
 639     case OP_SCOPE:
 640     case OP_LINESEQ:
 641     case OP_LIST:
 642         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
 643             if (kid->op_sibling)
 644                 scalarvoid(kid);
 645             else
 646                 scalar(kid);
 647         }
 648         WITH_THR(PL_curcop = &PL_compiling);
 649         break;
 650     case OP_SORT:
 651         if (ckWARN(WARN_VOID))
 652             Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
 653     }
 654     return o;
 655 }
 656
 657 OP *
 658 Perl_scalarvoid(pTHX_ OP *o)
 659 {
 660     dVAR;
 661     OP *kid;
 662     const char* useless = NULL;
 663     SV* sv;
 664     U8 want;
 665
 666     /* trailing mad null ops don't count as "there" for void processing */
 667     if (PL_madskills &&
 668         o->op_type != OP_NULL &&
 669         o->op_sibling &&
 670         o->op_sibling->op_type == OP_NULL)
 671     {
 672         OP *sib;
 673         for (sib = o->op_sibling;
 674                 sib && sib->op_type == OP_NULL;
 675                 sib = sib->op_sibling) ;
 676
 677         if (!sib)
 678             return o;
 679     }
 680
 681     if (o->op_type == OP_NEXTSTATE
 682         || o->op_type == OP_SETSTATE
 683         || o->op_type == OP_DBSTATE
 684         || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
 685                                       || o->op_targ == OP_SETSTATE
 686                                       || o->op_targ == OP_DBSTATE)))
 687         PL_curcop = (COP*)o;            /* for warning below */
 688
 689     /* assumes no premature commitment */
 690     want = o->op_flags & OPf_WANT;
 691     if ((want && want != OPf_WANT_SCALAR) || PL_error_count
 692          || o->op_type == OP_RETURN)
 693     {
 694         return o;
 695     }
 696
 697     if ((o->op_private & OPpTARGET_MY)
 698         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
 699     {
 700         return scalar(o);                       /* As if inside SASSIGN */
 701     }
 702
 703     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
 704
 705     switch (o->op_type) {
 706     default:
 707         if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
 708             break;
 709         /* FALL THROUGH */
 710     case OP_REPEAT:
 711         if (o->op_flags & OPf_STACKED)
 712             break;
 713         goto func_ops;
 714     case OP_SUBSTR:
 715         if (o->op_private == 4)
 716             break;
 717         /* FALL THROUGH */
 718     case OP_GVSV:
 719     case OP_WANTARRAY:
 720     case OP_GV:
 721     case OP_PADSV:
 722     case OP_PADAV:
 723     case OP_PADHV:
 724     case OP_PADANY:
 725     case OP_AV2ARYLEN:
 726     case OP_REF:
 727     case OP_REFGEN:
 728     case OP_SREFGEN:
 729     case OP_DEFINED:
 730     case OP_HEX:
 731     case OP_OCT:
 732     case OP_LENGTH:
 733     case OP_VEC:
 734     case OP_INDEX:
 735     case OP_RINDEX:
 736     case OP_SPRINTF:
 737     case OP_AELEM:
 738     case OP_AELEMFAST:
 739     case OP_ASLICE:
 740     case OP_HELEM:
 741     case OP_HSLICE:
 742     case OP_UNPACK:
 743     case OP_PACK:
 744     case OP_JOIN:
 745     case OP_LSLICE:
 746     case OP_ANONLIST:
 747     case OP_ANONHASH:
 748     case OP_SORT:
 749     case OP_REVERSE:
 750     case OP_RANGE:
 751     case OP_FLIP:
 752     case OP_FLOP:
 753     case OP_CALLER:
 754     case OP_FILENO:
 755     case OP_EOF:
 756     case OP_TELL:
 757     case OP_GETSOCKNAME:
 758     case OP_GETPEERNAME:
 759     case OP_READLINK:
 760     case OP_TELLDIR:
 761     case OP_GETPPID:
 762     case OP_GETPGRP:
 763     case OP_GETPRIORITY:
 764     case OP_TIME:
 765     case OP_TMS:
 766     case OP_LOCALTIME:
 767     case OP_GMTIME:
 768     case OP_GHBYNAME:
 769     case OP_GHBYADDR:
 770     case OP_GHOSTENT:
 771     case OP_GNBYNAME:
 772     case OP_GNBYADDR:
 773     case OP_GNETENT:
 774     case OP_GPBYNAME:
 775     case OP_GPBYNUMBER:
 776     case OP_GPROTOENT:
 777     case OP_GSBYNAME:
 778     case OP_GSBYPORT:
 779     case OP_GSERVENT:
 780     case OP_GPWNAM:
 781     case OP_GPWUID:
 782     case OP_GGRNAM:
 783     case OP_GGRGID:
 784     case OP_GETLOGIN:
 785     case OP_PROTOTYPE:
 786       func_ops:
 787         if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
 788             useless = OP_DESC(o);
 789         break;
 790
 791     case OP_NOT:
 792        kid = cUNOPo->op_first;
 793        if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
 794            kid->op_type != OP_TRANS) {
 795                 goto func_ops;
 796        }
 797        useless = "negative pattern binding (!~)";
 798        break;
 799
 800     case OP_RV2GV:
 801     case OP_RV2SV:
 802     case OP_RV2AV:
 803     case OP_RV2HV:
 804         if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
 805                 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
 806             useless = "a variable";
 807         break;
 808
 809     case OP_CONST:
 810         sv = cSVOPo_sv;
 811         if (cSVOPo->op_private & OPpCONST_STRICT)
 812             no_bareword_allowed(o);
 813         else {
 814             if (ckWARN(WARN_VOID)) {
 815                 useless = "a constant";
 816                 if (o->op_private & OPpCONST_ARYBASE)
 817                     useless = 0;
 818                 /* don't warn on optimised away booleans, eg
 819                  * use constant Foo, 5; Foo || print; */
 820                 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
 821                     useless = 0;
 822                 /* the constants 0 and 1 are permitted as they are
 823                    conventionally used as dummies in constructs like
 824                         1 while some_condition_with_side_effects;  */
 825                 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
 826                     useless = 0;
 827                 else if (SvPOK(sv)) {
 828                   /* perl4's way of mixing documentation and code
 829                      (before the invention of POD) was based on a
 830                      trick to mix nroff and perl code. The trick was
 831                      built upon these three nroff macros being used in
 832                      void context. The pink camel has the details in
 833                      the script wrapman near page 319. */
 834                     const char * const maybe_macro = SvPVX_const(sv);
 835                     if (strnEQ(maybe_macro, "di", 2) ||
 836                         strnEQ(maybe_macro, "ds", 2) ||
 837                         strnEQ(maybe_macro, "ig", 2))
 838                             useless = 0;
 839                 }
 840             }
 841         }
 842         op_null(o);             /* don't execute or even remember it */
 843         break;
 844
 845     case OP_POSTINC:
 846         o->op_type = OP_PREINC;         /* pre-increment is faster */
 847         o->op_ppaddr = PL_ppaddr[OP_PREINC];
 848         break;
 849
 850     case OP_POSTDEC:
 851         o->op_type = OP_PREDEC;         /* pre-decrement is faster */
 852         o->op_ppaddr = PL_ppaddr[OP_PREDEC];
 853         break;
 854
 855     case OP_I_POSTINC:
 856         o->op_type = OP_I_PREINC;       /* pre-increment is faster */
 857         o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
 858         break;
 859
 860     case OP_I_POSTDEC:
 861         o->op_type = OP_I_PREDEC;       /* pre-decrement is faster */
 862         o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
 863         break;
 864
 865     case OP_OR:
 866     case OP_AND:
 867     case OP_DOR:
 868     case OP_COND_EXPR:
 869     case OP_ENTERGIVEN:
 870     case OP_ENTERWHEN:
 871         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
 872             scalarvoid(kid);
 873         break;
 874
 875     case OP_NULL:
 876         if (o->op_flags & OPf_STACKED)
 877             break;
 878         /* FALL THROUGH */
 879     case OP_NEXTSTATE:
 880     case OP_DBSTATE:
 881     case OP_ENTERTRY:
 882     case OP_ENTER:
 883         if (!(o->op_flags & OPf_KIDS))
 884             break;
 885         /* FALL THROUGH */
 886     case OP_SCOPE:
 887     case OP_LEAVE:
 888     case OP_LEAVETRY:
 889     case OP_LEAVELOOP:
 890     case OP_LINESEQ:
 891     case OP_LIST:
 892     case OP_LEAVEGIVEN:
 893     case OP_LEAVEWHEN:
 894         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
 895             scalarvoid(kid);
 896         break;
 897     case OP_ENTEREVAL:
 898         scalarkids(o);
 899         break;
 900     case OP_REQUIRE:
 901         /* all requires must return a boolean value */
 902         o->op_flags &= ~OPf_WANT;
 903         /* FALL THROUGH */
 904     case OP_SCALAR:
 905         return scalar(o);
 906     case OP_SPLIT:
 907         if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
 908             if (!kPMOP->op_pmreplroot)
 909                 deprecate_old("implicit split to @_");
 910         }
 911         break;
 912     }
 913     if (useless && ckWARN(WARN_VOID))
 914         Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
 915     return o;
 916 }
 917
 918 OP *
 919 Perl_listkids(pTHX_ OP *o)
 920 {
 921     if (o && o->op_flags & OPf_KIDS) {
 922         OP *kid;
 923         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
 924             list(kid);
 925     }
 926     return o;
 927 }
 928
 929 OP *
 930 Perl_list(pTHX_ OP *o)
 931 {
 932     dVAR;
 933     OP *kid;
 934
 935     /* assumes no premature commitment */
 936     if (!o || (o->op_flags & OPf_WANT) || PL_error_count
 937          || o->op_type == OP_RETURN)
 938     {
 939         return o;
 940     }
 941
 942     if ((o->op_private & OPpTARGET_MY)
 943         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
 944     {
 945         return o;                               /* As if inside SASSIGN */
 946     }
 947
 948     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
 949
 950     switch (o->op_type) {
 951     case OP_FLOP:
 952     case OP_REPEAT:
 953         list(cBINOPo->op_first);
 954         break;
 955     case OP_OR:
 956     case OP_AND:
 957     case OP_COND_EXPR:
 958         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
 959             list(kid);
 960         break;
 961     default:
 962     case OP_MATCH:
 963     case OP_QR:
 964     case OP_SUBST:
 965     case OP_NULL:
 966         if (!(o->op_flags & OPf_KIDS))
 967             break;
 968         if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
 969             list(cBINOPo->op_first);
 970             return gen_constant_list(o);
 971         }
 972     case OP_LIST:
 973         listkids(o);
 974         break;
 975     case OP_LEAVE:
 976     case OP_LEAVETRY:
 977         kid = cLISTOPo->op_first;
 978         list(kid);
 979         while ((kid = kid->op_sibling)) {
 980             if (kid->op_sibling)
 981                 scalarvoid(kid);
 982             else
 983                 list(kid);
 984         }
 985         WITH_THR(PL_curcop = &PL_compiling);
 986         break;
 987     case OP_SCOPE:
 988     case OP_LINESEQ:
 989         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
 990             if (kid->op_sibling)
 991                 scalarvoid(kid);
 992             else
 993                 list(kid);
 994         }
 995         WITH_THR(PL_curcop = &PL_compiling);
 996         break;
 997     case OP_REQUIRE:
 998         /* all requires must return a boolean value */
 999         o->op_flags &= ~OPf_WANT;
1000         return scalar(o);
1001     }
1002     return o;
1003 }
1004
1005 OP *
1006 Perl_scalarseq(pTHX_ OP *o)
1007 {
1008     dVAR;
1009     if (o) {
1010         if (o->op_type == OP_LINESEQ ||
1011              o->op_type == OP_SCOPE ||
1012              o->op_type == OP_LEAVE ||
1013              o->op_type == OP_LEAVETRY)
1014         {
1015             OP *kid;
1016             for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1017                 if (kid->op_sibling) {
1018                     scalarvoid(kid);
1019                 }
1020             }
1021             PL_curcop = &PL_compiling;
1022         }
1023         o->op_flags &= ~OPf_PARENS;
1024         if (PL_hints & HINT_BLOCK_SCOPE)
1025             o->op_flags |= OPf_PARENS;
1026     }
1027     else
1028         o = newOP(OP_STUB, 0);
1029     return o;
1030 }
1031
1032 STATIC OP *
1033 S_modkids(pTHX_ OP *o, I32 type)
1034 {
1035     if (o && o->op_flags & OPf_KIDS) {
1036         OP *kid;
1037         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1038             mod(kid, type);
1039     }
1040     return o;
1041 }
1042
1043 /* Propagate lvalue ("modifiable") context to an op and its children.
1044  * 'type' represents the context type, roughly based on the type of op that
1045  * would do the modifying, although local() is represented by OP_NULL.
1046  * It's responsible for detecting things that can't be modified,  flag
1047  * things that need to behave specially in an lvalue context (e.g., "$$x = 5"
1048  * might have to vivify a reference in $x), and so on.
1049  *
1050  * For example, "$a+1 = 2" would cause mod() to be called with o being
1051  * OP_ADD and type being OP_SASSIGN, and would output an error.
1052  */
1053
1054 OP *
1055 Perl_mod(pTHX_ OP *o, I32 type)
1056 {
1057     dVAR;
1058     OP *kid;
1059     /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
1060     int localize = -1;
1061
1062     if (!o || PL_error_count)
1063         return o;
1064
1065     if ((o->op_private & OPpTARGET_MY)
1066         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1067     {
1068         return o;
1069     }
1070
1071     switch (o->op_type) {
1072     case OP_UNDEF:
1073         localize = 0;
1074         PL_modcount++;
1075         return o;
1076     case OP_CONST:
1077         if (!(o->op_private & OPpCONST_ARYBASE))
1078             goto nomod;
1079         localize = 0;
1080         if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1081             PL_compiling.cop_arybase = (I32)SvIV(cSVOPx(PL_eval_start)->op_sv);
1082             PL_eval_start = 0;
1083         }
1084         else if (!type) {
1085             SAVEI32(PL_compiling.cop_arybase);
1086             PL_compiling.cop_arybase = 0;
1087         }
1088         else if (type == OP_REFGEN)
1089             goto nomod;
1090         else
1091             Perl_croak(aTHX_ "That use of $[ is unsupported");
1092         break;
1093     case OP_STUB:
1094         if (o->op_flags & OPf_PARENS || PL_madskills)
1095             break;
1096         goto nomod;
1097     case OP_ENTERSUB:
1098         if ((type == OP_UNDEF || type == OP_REFGEN) &&
1099             !(o->op_flags & OPf_STACKED)) {
1100             o->op_type = OP_RV2CV;              /* entersub => rv2cv */
1101             /* The default is to set op_private to the number of children,
1102                which for a UNOP such as RV2CV is always 1. And w're using
1103                the bit for a flag in RV2CV, so we need it clear.  */
1104             o->op_private &= ~1;
1105             o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1106             assert(cUNOPo->op_first->op_type == OP_NULL);
1107             op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1108             break;
1109         }
1110         else if (o->op_private & OPpENTERSUB_NOMOD)
1111             return o;
1112         else {                          /* lvalue subroutine call */
1113             o->op_private |= OPpLVAL_INTRO;
1114             PL_modcount = RETURN_UNLIMITED_NUMBER;
1115             if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1116                 /* Backward compatibility mode: */
1117                 o->op_private |= OPpENTERSUB_INARGS;
1118                 break;
1119             }
1120             else {                      /* Compile-time error message: */
1121                 OP *kid = cUNOPo->op_first;
1122                 CV *cv;
1123                 OP *okid;
1124
1125                 if (kid->op_type == OP_PUSHMARK)
1126                     goto skip_kids;
1127                 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1128                     Perl_croak(aTHX_
1129                                "panic: unexpected lvalue entersub "
1130                                "args: type/targ %ld:%"UVuf,
1131                                (long)kid->op_type, (UV)kid->op_targ);
1132                 kid = kLISTOP->op_first;
1133               skip_kids:
1134                 while (kid->op_sibling)
1135                     kid = kid->op_sibling;
1136                 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1137                     /* Indirect call */
1138                     if (kid->op_type == OP_METHOD_NAMED
1139                         || kid->op_type == OP_METHOD)
1140                     {
1141                         UNOP *newop;
1142
1143                         NewOp(1101, newop, 1, UNOP);
1144                         newop->op_type = OP_RV2CV;
1145                         newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1146                         newop->op_first = NULL;
1147                         newop->op_next = (OP*)newop;
1148                         kid->op_sibling = (OP*)newop;
1149                         newop->op_private |= OPpLVAL_INTRO;
1150                         newop->op_private &= ~1;
1151                         break;
1152                     }
1153
1154                     if (kid->op_type != OP_RV2CV)
1155                         Perl_croak(aTHX_
1156                                    "panic: unexpected lvalue entersub "
1157                                    "entry via type/targ %ld:%"UVuf,
1158                                    (long)kid->op_type, (UV)kid->op_targ);
1159                     kid->op_private |= OPpLVAL_INTRO;
1160                     break;      /* Postpone until runtime */
1161                 }
1162
1163                 okid = kid;
1164                 kid = kUNOP->op_first;
1165                 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1166                     kid = kUNOP->op_first;
1167                 if (kid->op_type == OP_NULL)
1168                     Perl_croak(aTHX_
1169                                "Unexpected constant lvalue entersub "
1170                                "entry via type/targ %ld:%"UVuf,
1171                                (long)kid->op_type, (UV)kid->op_targ);
1172                 if (kid->op_type != OP_GV) {
1173                     /* Restore RV2CV to check lvalueness */
1174                   restore_2cv:
1175                     if (kid->op_next && kid->op_next != kid) { /* Happens? */
1176                         okid->op_next = kid->op_next;
1177                         kid->op_next = okid;
1178                     }
1179                     else
1180                         okid->op_next = NULL;
1181                     okid->op_type = OP_RV2CV;
1182                     okid->op_targ = 0;
1183                     okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1184                     okid->op_private |= OPpLVAL_INTRO;
1185                     okid->op_private &= ~1;
1186                     break;
1187                 }
1188
1189                 cv = GvCV(kGVOP_gv);
1190                 if (!cv)
1191                     goto restore_2cv;
1192                 if (CvLVALUE(cv))
1193                     break;
1194             }
1195         }
1196         /* FALL THROUGH */
1197     default:
1198       nomod:
1199         /* grep, foreach, subcalls, refgen */
1200         if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1201             break;
1202         yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1203                      (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1204                       ? "do block"
1205                       : (o->op_type == OP_ENTERSUB
1206                         ? "non-lvalue subroutine call"
1207                         : OP_DESC(o))),
1208                      type ? PL_op_desc[type] : "local"));
1209         return o;
1210
1211     case OP_PREINC:
1212     case OP_PREDEC:
1213     case OP_POW:
1214     case OP_MULTIPLY:
1215     case OP_DIVIDE:
1216     case OP_MODULO:
1217     case OP_REPEAT:
1218     case OP_ADD:
1219     case OP_SUBTRACT:
1220     case OP_CONCAT:
1221     case OP_LEFT_SHIFT:
1222     case OP_RIGHT_SHIFT:
1223     case OP_BIT_AND:
1224     case OP_BIT_XOR:
1225     case OP_BIT_OR:
1226     case OP_I_MULTIPLY:
1227     case OP_I_DIVIDE:
1228     case OP_I_MODULO:
1229     case OP_I_ADD:
1230     case OP_I_SUBTRACT:
1231         if (!(o->op_flags & OPf_STACKED))
1232             goto nomod;
1233         PL_modcount++;
1234         break;
1235
1236     case OP_COND_EXPR:
1237         localize = 1;
1238         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1239             mod(kid, type);
1240         break;
1241
1242     case OP_RV2AV:
1243     case OP_RV2HV:
1244         if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1245            PL_modcount = RETURN_UNLIMITED_NUMBER;
1246             return o;           /* Treat \(@foo) like ordinary list. */
1247         }
1248         /* FALL THROUGH */
1249     case OP_RV2GV:
1250         if (scalar_mod_type(o, type))
1251             goto nomod;
1252         ref(cUNOPo->op_first, o->op_type);
1253         /* FALL THROUGH */
1254     case OP_ASLICE:
1255     case OP_HSLICE:
1256         if (type == OP_LEAVESUBLV)
1257             o->op_private |= OPpMAYBE_LVSUB;
1258         localize = 1;
1259         /* FALL THROUGH */
1260     case OP_AASSIGN:
1261     case OP_NEXTSTATE:
1262     case OP_DBSTATE:
1263        PL_modcount = RETURN_UNLIMITED_NUMBER;
1264         break;
1265     case OP_RV2SV:
1266         ref(cUNOPo->op_first, o->op_type);
1267         localize = 1;
1268         /* FALL THROUGH */
1269     case OP_GV:
1270     case OP_AV2ARYLEN:
1271         PL_hints |= HINT_BLOCK_SCOPE;
1272     case OP_SASSIGN:
1273     case OP_ANDASSIGN:
1274     case OP_ORASSIGN:
1275     case OP_DORASSIGN:
1276         PL_modcount++;
1277         break;
1278
1279     case OP_AELEMFAST:
1280         localize = -1;
1281         PL_modcount++;
1282         break;
1283
1284     case OP_PADAV:
1285     case OP_PADHV:
1286        PL_modcount = RETURN_UNLIMITED_NUMBER;
1287         if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1288             return o;           /* Treat \(@foo) like ordinary list. */
1289         if (scalar_mod_type(o, type))
1290             goto nomod;
1291         if (type == OP_LEAVESUBLV)
1292             o->op_private |= OPpMAYBE_LVSUB;
1293         /* FALL THROUGH */
1294     case OP_PADSV:
1295         PL_modcount++;
1296         if (!type) /* local() */
1297             Perl_croak(aTHX_ "Can't localize lexical variable %s",
1298                  PAD_COMPNAME_PV(o->op_targ));
1299         break;
1300
1301     case OP_PUSHMARK:
1302         localize = 0;
1303         break;
1304
1305     case OP_KEYS:
1306         if (type != OP_SASSIGN)
1307             goto nomod;
1308         goto lvalue_func;
1309     case OP_SUBSTR:
1310         if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1311             goto nomod;
1312         /* FALL THROUGH */
1313     case OP_POS:
1314     case OP_VEC:
1315         if (type == OP_LEAVESUBLV)
1316             o->op_private |= OPpMAYBE_LVSUB;
1317       lvalue_func:
1318         pad_free(o->op_targ);
1319         o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1320         assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1321         if (o->op_flags & OPf_KIDS)
1322             mod(cBINOPo->op_first->op_sibling, type);
1323         break;
1324
1325     case OP_AELEM:
1326     case OP_HELEM:
1327         ref(cBINOPo->op_first, o->op_type);
1328         if (type == OP_ENTERSUB &&
1329              !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1330             o->op_private |= OPpLVAL_DEFER;
1331         if (type == OP_LEAVESUBLV)
1332             o->op_private |= OPpMAYBE_LVSUB;
1333         localize = 1;
1334         PL_modcount++;
1335         break;
1336
1337     case OP_SCOPE:
1338     case OP_LEAVE:
1339     case OP_ENTER:
1340     case OP_LINESEQ:
1341         localize = 0;
1342         if (o->op_flags & OPf_KIDS)
1343             mod(cLISTOPo->op_last, type);
1344         break;
1345
1346     case OP_NULL:
1347         localize = 0;
1348         if (o->op_flags & OPf_SPECIAL)          /* do BLOCK */
1349             goto nomod;
1350         else if (!(o->op_flags & OPf_KIDS))
1351             break;
1352         if (o->op_targ != OP_LIST) {
1353             mod(cBINOPo->op_first, type);
1354             break;
1355         }
1356         /* FALL THROUGH */
1357     case OP_LIST:
1358         localize = 0;
1359         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1360             mod(kid, type);
1361         break;
1362
1363     case OP_RETURN:
1364         if (type != OP_LEAVESUBLV)
1365             goto nomod;
1366         break; /* mod()ing was handled by ck_return() */
1367     }
1368
1369     /* [20011101.069] File test operators interpret OPf_REF to mean that
1370        their argument is a filehandle; thus \stat(".") should not set
1371        it. AMS 20011102 */
1372     if (type == OP_REFGEN &&
1373         PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1374         return o;
1375
1376     if (type != OP_LEAVESUBLV)
1377         o->op_flags |= OPf_MOD;
1378
1379     if (type == OP_AASSIGN || type == OP_SASSIGN)
1380         o->op_flags |= OPf_SPECIAL|OPf_REF;
1381     else if (!type) { /* local() */
1382         switch (localize) {
1383         case 1:
1384             o->op_private |= OPpLVAL_INTRO;
1385             o->op_flags &= ~OPf_SPECIAL;
1386             PL_hints |= HINT_BLOCK_SCOPE;
1387             break;
1388         case 0:
1389             break;
1390         case -1:
1391             if (ckWARN(WARN_SYNTAX)) {
1392                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1393                     "Useless localization of %s", OP_DESC(o));
1394             }
1395         }
1396     }
1397     else if (type != OP_GREPSTART && type != OP_ENTERSUB
1398              && type != OP_LEAVESUBLV)
1399         o->op_flags |= OPf_REF;
1400     return o;
1401 }
1402
1403 STATIC bool
1404 S_scalar_mod_type(const OP *o, I32 type)
1405 {
1406     switch (type) {
1407     case OP_SASSIGN:
1408         if (o->op_type == OP_RV2GV)
1409             return FALSE;
1410         /* FALL THROUGH */
1411     case OP_PREINC:
1412     case OP_PREDEC:
1413     case OP_POSTINC:
1414     case OP_POSTDEC:
1415     case OP_I_PREINC:
1416     case OP_I_PREDEC:
1417     case OP_I_POSTINC:
1418     case OP_I_POSTDEC:
1419     case OP_POW:
1420     case OP_MULTIPLY:
1421     case OP_DIVIDE:
1422     case OP_MODULO:
1423     case OP_REPEAT:
1424     case OP_ADD:
1425     case OP_SUBTRACT:
1426     case OP_I_MULTIPLY:
1427     case OP_I_DIVIDE:
1428     case OP_I_MODULO:
1429     case OP_I_ADD:
1430     case OP_I_SUBTRACT:
1431     case OP_LEFT_SHIFT:
1432     case OP_RIGHT_SHIFT:
1433     case OP_BIT_AND:
1434     case OP_BIT_XOR:
1435     case OP_BIT_OR:
1436     case OP_CONCAT:
1437     case OP_SUBST:
1438     case OP_TRANS:
1439     case OP_READ:
1440     case OP_SYSREAD:
1441     case OP_RECV:
1442     case OP_ANDASSIGN:
1443     case OP_ORASSIGN:
1444         return TRUE;
1445     default:
1446         return FALSE;
1447     }
1448 }
1449
1450 STATIC bool
1451 S_is_handle_constructor(const OP *o, I32 numargs)
1452 {
1453     switch (o->op_type) {
1454     case OP_PIPE_OP:
1455     case OP_SOCKPAIR:
1456         if (numargs == 2)
1457             return TRUE;
1458         /* FALL THROUGH */
1459     case OP_SYSOPEN:
1460     case OP_OPEN:
1461     case OP_SELECT:             /* XXX c.f. SelectSaver.pm */
1462     case OP_SOCKET:
1463     case OP_OPEN_DIR:
1464     case OP_ACCEPT:
1465         if (numargs == 1)
1466             return TRUE;
1467         /* FALLTHROUGH */
1468     default:
1469         return FALSE;
1470     }
1471 }
1472
1473 OP *
1474 Perl_refkids(pTHX_ OP *o, I32 type)
1475 {
1476     if (o && o->op_flags & OPf_KIDS) {
1477         OP *kid;
1478         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1479             ref(kid, type);
1480     }
1481     return o;
1482 }
1483
1484 OP *
1485 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
1486 {
1487     dVAR;
1488     OP *kid;
1489
1490     if (!o || PL_error_count)
1491         return o;
1492
1493     switch (o->op_type) {
1494     case OP_ENTERSUB:
1495         if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1496             !(o->op_flags & OPf_STACKED)) {
1497             o->op_type = OP_RV2CV;             /* entersub => rv2cv */
1498             o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1499             assert(cUNOPo->op_first->op_type == OP_NULL);
1500             op_null(((LISTOP*)cUNOPo->op_first)->op_first);     /* disable pushmark */
1501             o->op_flags |= OPf_SPECIAL;
1502             o->op_private &= ~1;
1503         }
1504         break;
1505
1506     case OP_COND_EXPR:
1507         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1508             doref(kid, type, set_op_ref);
1509         break;
1510     case OP_RV2SV:
1511         if (type == OP_DEFINED)
1512             o->op_flags |= OPf_SPECIAL;         /* don't create GV */
1513         doref(cUNOPo->op_first, o->op_type, set_op_ref);
1514         /* FALL THROUGH */
1515     case OP_PADSV:
1516         if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1517             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1518                               : type == OP_RV2HV ? OPpDEREF_HV
1519                               : OPpDEREF_SV);
1520             o->op_flags |= OPf_MOD;
1521         }
1522         break;
1523
1524     case OP_THREADSV:
1525         o->op_flags |= OPf_MOD;         /* XXX ??? */
1526         break;
1527
1528     case OP_RV2AV:
1529     case OP_RV2HV:
1530         if (set_op_ref)
1531             o->op_flags |= OPf_REF;
1532         /* FALL THROUGH */
1533     case OP_RV2GV:
1534         if (type == OP_DEFINED)
1535             o->op_flags |= OPf_SPECIAL;         /* don't create GV */
1536         doref(cUNOPo->op_first, o->op_type, set_op_ref);
1537         break;
1538
1539     case OP_PADAV:
1540     case OP_PADHV:
1541         if (set_op_ref)
1542             o->op_flags |= OPf_REF;
1543         break;
1544
1545     case OP_SCALAR:
1546     case OP_NULL:
1547         if (!(o->op_flags & OPf_KIDS))
1548             break;
1549         doref(cBINOPo->op_first, type, set_op_ref);
1550         break;
1551     case OP_AELEM:
1552     case OP_HELEM:
1553         doref(cBINOPo->op_first, o->op_type, set_op_ref);
1554         if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1555             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1556                               : type == OP_RV2HV ? OPpDEREF_HV
1557                               : OPpDEREF_SV);
1558             o->op_flags |= OPf_MOD;
1559         }
1560         break;
1561
1562     case OP_SCOPE:
1563     case OP_LEAVE:
1564         set_op_ref = FALSE;
1565         /* FALL THROUGH */
1566     case OP_ENTER:
1567     case OP_LIST:
1568         if (!(o->op_flags & OPf_KIDS))
1569             break;
1570         doref(cLISTOPo->op_last, type, set_op_ref);
1571         break;
1572     default:
1573         break;
1574     }
1575     return scalar(o);
1576
1577 }
1578
1579 STATIC OP *
1580 S_dup_attrlist(pTHX_ OP *o)
1581 {
1582     dVAR;
1583     OP *rop;
1584
1585     /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1586      * where the first kid is OP_PUSHMARK and the remaining ones
1587      * are OP_CONST.  We need to push the OP_CONST values.
1588      */
1589     if (o->op_type == OP_CONST)
1590         rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
1591 #ifdef PERL_MAD
1592     else if (o->op_type == OP_NULL)
1593         rop = Nullop;
1594 #endif
1595     else {
1596         assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1597         rop = NULL;
1598         for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1599             if (o->op_type == OP_CONST)
1600                 rop = append_elem(OP_LIST, rop,
1601                                   newSVOP(OP_CONST, o->op_flags,
1602                                           SvREFCNT_inc_NN(cSVOPo->op_sv)));
1603         }
1604     }
1605     return rop;
1606 }
1607
1608 STATIC void
1609 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1610 {
1611     dVAR;
1612     SV *stashsv;
1613
1614     /* fake up C<use attributes $pkg,$rv,@attrs> */
1615     ENTER;              /* need to protect against side-effects of 'use' */
1616     SAVEINT(PL_expect);
1617     stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1618
1619 #define ATTRSMODULE "attributes"
1620 #define ATTRSMODULE_PM "attributes.pm"
1621
1622     if (for_my) {
1623         /* Don't force the C<use> if we don't need it. */
1624         SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
1625         if (svp && *svp != &PL_sv_undef)
1626             /*EMPTY*/;          /* already in %INC */
1627         else
1628             Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1629                              newSVpvs(ATTRSMODULE), NULL);
1630     }
1631     else {
1632         Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1633                          newSVpvs(ATTRSMODULE),
1634                          NULL,
1635                          prepend_elem(OP_LIST,
1636                                       newSVOP(OP_CONST, 0, stashsv),
1637                                       prepend_elem(OP_LIST,
1638                                                    newSVOP(OP_CONST, 0,
1639                                                            newRV(target)),
1640                                                    dup_attrlist(attrs))));
1641     }
1642     LEAVE;
1643 }
1644
1645 STATIC void
1646 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1647 {
1648     dVAR;
1649     OP *pack, *imop, *arg;
1650     SV *meth, *stashsv;
1651
1652     if (!attrs)
1653         return;
1654
1655     assert(target->op_type == OP_PADSV ||
1656            target->op_type == OP_PADHV ||
1657            target->op_type == OP_PADAV);
1658
1659     /* Ensure that attributes.pm is loaded. */
1660     apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
1661
1662     /* Need package name for method call. */
1663     pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
1664
1665     /* Build up the real arg-list. */
1666     stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1667
1668     arg = newOP(OP_PADSV, 0);
1669     arg->op_targ = target->op_targ;
1670     arg = prepend_elem(OP_LIST,
1671                        newSVOP(OP_CONST, 0, stashsv),
1672                        prepend_elem(OP_LIST,
1673                                     newUNOP(OP_REFGEN, 0,
1674                                             mod(arg, OP_REFGEN)),
1675                                     dup_attrlist(attrs)));
1676
1677     /* Fake up a method call to import */
1678     meth = newSVpvs_share("import");
1679     imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
1680                    append_elem(OP_LIST,
1681                                prepend_elem(OP_LIST, pack, list(arg)),
1682                                newSVOP(OP_METHOD_NAMED, 0, meth)));
1683     imop->op_private |= OPpENTERSUB_NOMOD;
1684
1685     /* Combine the ops. */
1686     *imopsp = append_elem(OP_LIST, *imopsp, imop);
1687 }
1688
1689 /*
1690 =notfor apidoc apply_attrs_string
1691
1692 Attempts to apply a list of attributes specified by the C<attrstr> and
1693 C<len> arguments to the subroutine identified by the C<cv> argument which
1694 is expected to be associated with the package identified by the C<stashpv>
1695 argument (see L<attributes>).  It gets this wrong, though, in that it
1696 does not correctly identify the boundaries of the individual attribute
1697 specifications within C<attrstr>.  This is not really intended for the
1698 public API, but has to be listed here for systems such as AIX which
1699 need an explicit export list for symbols.  (It's called from XS code
1700 in support of the C<ATTRS:> keyword from F<xsubpp>.)  Patches to fix it
1701 to respect attribute syntax properly would be welcome.
1702
1703 =cut
1704 */
1705
1706 void
1707 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
1708                         const char *attrstr, STRLEN len)
1709 {
1710     OP *attrs = NULL;
1711
1712     if (!len) {
1713         len = strlen(attrstr);
1714     }
1715
1716     while (len) {
1717         for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1718         if (len) {
1719             const char * const sstr = attrstr;
1720             for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1721             attrs = append_elem(OP_LIST, attrs,
1722                                 newSVOP(OP_CONST, 0,
1723                                         newSVpvn(sstr, attrstr-sstr)));
1724         }
1725     }
1726
1727     Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1728                      newSVpvs(ATTRSMODULE),
1729                      NULL, prepend_elem(OP_LIST,
1730                                   newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1731                                   prepend_elem(OP_LIST,
1732                                                newSVOP(OP_CONST, 0,
1733                                                        newRV((SV*)cv)),
1734                                                attrs)));
1735 }
1736
1737 STATIC OP *
1738 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
1739 {
1740     dVAR;
1741     I32 type;
1742
1743     if (!o || PL_error_count)
1744         return o;
1745
1746     if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
1747         (void)my_kid(cUNOPo->op_first, attrs, imopsp);
1748         return o;
1749     }
1750
1751     type = o->op_type;
1752     if (type == OP_LIST) {
1753         OP *kid;
1754         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1755             my_kid(kid, attrs, imopsp);
1756     } else if (type == OP_UNDEF
1757 #ifdef PERL_MAD
1758                || type == OP_STUB
1759 #endif
1760                ) {
1761         return o;
1762     } else if (type == OP_RV2SV ||      /* "our" declaration */
1763                type == OP_RV2AV ||
1764                type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1765         if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
1766             yyerror(Perl_form(aTHX_ "Can't declare %s in %s",
1767                         OP_DESC(o), PL_in_my == KEY_our ? "our" : "my"));
1768         } else if (attrs) {
1769             GV * const gv = cGVOPx_gv(cUNOPo->op_first);
1770             PL_in_my = FALSE;
1771             PL_in_my_stash = NULL;
1772             apply_attrs(GvSTASH(gv),
1773                         (type == OP_RV2SV ? GvSV(gv) :
1774                          type == OP_RV2AV ? (SV*)GvAV(gv) :
1775                          type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1776                         attrs, FALSE);
1777         }
1778         o->op_private |= OPpOUR_INTRO;
1779         return o;
1780     }
1781     else if (type != OP_PADSV &&
1782              type != OP_PADAV &&
1783              type != OP_PADHV &&
1784              type != OP_PUSHMARK)
1785     {
1786         yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1787                           OP_DESC(o),
1788                           PL_in_my == KEY_our ? "our" : "my"));
1789         return o;
1790     }
1791     else if (attrs && type != OP_PUSHMARK) {
1792         HV *stash;
1793
1794         PL_in_my = FALSE;
1795         PL_in_my_stash = NULL;
1796
1797         /* check for C<my Dog $spot> when deciding package */
1798         stash = PAD_COMPNAME_TYPE(o->op_targ);
1799         if (!stash)
1800             stash = PL_curstash;
1801         apply_attrs_my(stash, o, attrs, imopsp);
1802     }
1803     o->op_flags |= OPf_MOD;
1804     o->op_private |= OPpLVAL_INTRO;
1805     return o;
1806 }
1807
1808 OP *
1809 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
1810 {
1811     dVAR;
1812     OP *rops;
1813     int maybe_scalar = 0;
1814
1815 /* [perl #17376]: this appears to be premature, and results in code such as
1816    C< our(%x); > executing in list mode rather than void mode */
1817 #if 0
1818     if (o->op_flags & OPf_PARENS)
1819         list(o);
1820     else
1821         maybe_scalar = 1;
1822 #else
1823     maybe_scalar = 1;
1824 #endif
1825     if (attrs)
1826         SAVEFREEOP(attrs);
1827     rops = NULL;
1828     o = my_kid(o, attrs, &rops);
1829     if (rops) {
1830         if (maybe_scalar && o->op_type == OP_PADSV) {
1831             o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
1832             o->op_private |= OPpLVAL_INTRO;
1833         }
1834         else
1835             o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
1836     }
1837     PL_in_my = FALSE;
1838     PL_in_my_stash = NULL;
1839     return o;
1840 }
1841
1842 OP *
1843 Perl_my(pTHX_ OP *o)
1844 {
1845     return my_attrs(o, NULL);
1846 }
1847
1848 OP *
1849 Perl_sawparens(pTHX_ OP *o)
1850 {
1851     PERL_UNUSED_CONTEXT;
1852     if (o)
1853         o->op_flags |= OPf_PARENS;
1854     return o;
1855 }
1856
1857 OP *
1858 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
1859 {
1860     OP *o;
1861     bool ismatchop = 0;
1862
1863     if ( (left->op_type == OP_RV2AV ||
1864        left->op_type == OP_RV2HV ||
1865        left->op_type == OP_PADAV ||
1866        left->op_type == OP_PADHV)
1867        && ckWARN(WARN_MISC))
1868     {
1869       const char * const desc = PL_op_desc[(right->op_type == OP_SUBST ||
1870                             right->op_type == OP_TRANS)
1871                            ? right->op_type : OP_MATCH];
1872       const char * const sample = ((left->op_type == OP_RV2AV ||
1873                              left->op_type == OP_PADAV)
1874                             ? "@array" : "%hash");
1875       Perl_warner(aTHX_ packWARN(WARN_MISC),
1876              "Applying %s to %s will act on scalar(%s)",
1877              desc, sample, sample);
1878     }
1879
1880     if (right->op_type == OP_CONST &&
1881         cSVOPx(right)->op_private & OPpCONST_BARE &&
1882         cSVOPx(right)->op_private & OPpCONST_STRICT)
1883     {
1884         no_bareword_allowed(right);
1885     }
1886
1887     ismatchop = right->op_type == OP_MATCH ||
1888                 right->op_type == OP_SUBST ||
1889                 right->op_type == OP_TRANS;
1890     if (ismatchop && right->op_private & OPpTARGET_MY) {
1891         right->op_targ = 0;
1892         right->op_private &= ~OPpTARGET_MY;
1893     }
1894     if (!(right->op_flags & OPf_STACKED) && ismatchop) {
1895         right->op_flags |= OPf_STACKED;
1896         if (right->op_type != OP_MATCH &&
1897             ! (right->op_type == OP_TRANS &&
1898                right->op_private & OPpTRANS_IDENTICAL))
1899             left = mod(left, right->op_type);
1900         if (right->op_type == OP_TRANS)
1901             o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
1902         else
1903             o = prepend_elem(right->op_type, scalar(left), right);
1904         if (type == OP_NOT)
1905             return newUNOP(OP_NOT, 0, scalar(o));
1906         return o;
1907     }
1908     else
1909         return bind_match(type, left,
1910                 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
1911 }
1912
1913 OP *
1914 Perl_invert(pTHX_ OP *o)
1915 {
1916     if (!o)
1917         return o;
1918     /* XXX need to optimize away NOT NOT here?  Or do we let optimizer do it? */
1919     return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
1920 }
1921
1922 OP *
1923 Perl_scope(pTHX_ OP *o)
1924 {
1925     dVAR;
1926     if (o) {
1927         if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
1928             o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
1929             o->op_type = OP_LEAVE;
1930             o->op_ppaddr = PL_ppaddr[OP_LEAVE];
1931         }
1932         else if (o->op_type == OP_LINESEQ) {
1933             OP *kid;
1934             o->op_type = OP_SCOPE;
1935             o->op_ppaddr = PL_ppaddr[OP_SCOPE];
1936             kid = ((LISTOP*)o)->op_first;
1937             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
1938                 op_null(kid);
1939
1940                 /* The following deals with things like 'do {1 for 1}' */
1941                 kid = kid->op_sibling;
1942                 if (kid &&
1943                     (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
1944                     op_null(kid);
1945             }
1946         }
1947         else
1948             o = newLISTOP(OP_SCOPE, 0, o, NULL);
1949     }
1950     return o;
1951 }
1952
1953 int
1954 Perl_block_start(pTHX_ int full)
1955 {
1956     dVAR;
1957     const int retval = PL_savestack_ix;
1958     pad_block_start(full);
1959     SAVEHINTS();
1960     PL_hints &= ~HINT_BLOCK_SCOPE;
1961     SAVESPTR(PL_compiling.cop_warnings);
1962     if (! specialWARN(PL_compiling.cop_warnings)) {
1963         PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
1964         SAVEFREESV(PL_compiling.cop_warnings) ;
1965     }
1966     SAVESPTR(PL_compiling.cop_io);
1967     if (! specialCopIO(PL_compiling.cop_io)) {
1968         PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
1969         SAVEFREESV(PL_compiling.cop_io) ;
1970     }
1971     return retval;
1972 }
1973
1974 OP*
1975 Perl_block_end(pTHX_ I32 floor, OP *seq)
1976 {
1977     dVAR;
1978     const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
1979     OP* const retval = scalarseq(seq);
1980     LEAVE_SCOPE(floor);
1981     PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
1982     if (needblockscope)
1983         PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
1984     pad_leavemy();
1985     return retval;
1986 }
1987
1988 STATIC OP *
1989 S_newDEFSVOP(pTHX)
1990 {
1991     dVAR;
1992     const I32 offset = pad_findmy("$_");
1993     if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
1994         return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
1995     }
1996     else {
1997         OP * const o = newOP(OP_PADSV, 0);
1998         o->op_targ = offset;
1999         return o;
2000     }
2001 }
2002
2003 void
2004 Perl_newPROG(pTHX_ OP *o)
2005 {
2006     dVAR;
2007     if (PL_in_eval) {
2008         if (PL_eval_root)
2009                 return;
2010         PL_eval_root = newUNOP(OP_LEAVEEVAL,
2011                                ((PL_in_eval & EVAL_KEEPERR)
2012                                 ? OPf_SPECIAL : 0), o);
2013         PL_eval_start = linklist(PL_eval_root);
2014         PL_eval_root->op_private |= OPpREFCOUNTED;
2015         OpREFCNT_set(PL_eval_root, 1);
2016         PL_eval_root->op_next = 0;
2017         CALL_PEEP(PL_eval_start);
2018     }
2019     else {
2020         if (o->op_type == OP_STUB) {
2021             PL_comppad_name = 0;
2022             PL_compcv = 0;
2023             FreeOp(o);
2024             return;
2025         }
2026         PL_main_root = scope(sawparens(scalarvoid(o)));
2027         PL_curcop = &PL_compiling;
2028         PL_main_start = LINKLIST(PL_main_root);
2029         PL_main_root->op_private |= OPpREFCOUNTED;
2030         OpREFCNT_set(PL_main_root, 1);
2031         PL_main_root->op_next = 0;
2032         CALL_PEEP(PL_main_start);
2033         PL_compcv = 0;
2034
2035         /* Register with debugger */
2036         if (PERLDB_INTER) {
2037             CV * const cv = get_cv("DB::postponed", FALSE);
2038             if (cv) {
2039                 dSP;
2040                 PUSHMARK(SP);
2041                 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2042                 PUTBACK;
2043                 call_sv((SV*)cv, G_DISCARD);
2044             }
2045         }
2046     }
2047 }
2048
2049 OP *
2050 Perl_localize(pTHX_ OP *o, I32 lex)
2051 {
2052     dVAR;
2053     if (o->op_flags & OPf_PARENS)
2054 /* [perl #17376]: this appears to be premature, and results in code such as
2055    C< our(%x); > executing in list mode rather than void mode */
2056 #if 0
2057         list(o);
2058 #else
2059         /*EMPTY*/;
2060 #endif
2061     else {
2062         if ( PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ','
2063             && ckWARN(WARN_PARENTHESIS))
2064         {
2065             char *s = PL_bufptr;
2066             bool sigil = FALSE;
2067
2068             /* some heuristics to detect a potential error */
2069             while (*s && (strchr(", \t\n", *s)))
2070                 s++;
2071
2072             while (1) {
2073                 if (*s && strchr("@$%*", *s) && *++s
2074                        && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2075                     s++;
2076                     sigil = TRUE;
2077                     while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2078                         s++;
2079                     while (*s && (strchr(", \t\n", *s)))
2080                         s++;
2081                 }
2082                 else
2083                     break;
2084             }
2085             if (sigil && (*s == ';' || *s == '=')) {
2086                 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2087                                 "Parentheses missing around \"%s\" list",
2088                                 lex ? (PL_in_my == KEY_our ? "our" : "my")
2089                                 : "local");
2090             }
2091         }
2092     }
2093     if (lex)
2094         o = my(o);
2095     else
2096         o = mod(o, OP_NULL);            /* a bit kludgey */
2097     PL_in_my = FALSE;
2098     PL_in_my_stash = NULL;
2099     return o;
2100 }
2101
2102 OP *
2103 Perl_jmaybe(pTHX_ OP *o)
2104 {
2105     if (o->op_type == OP_LIST) {
2106         OP * const o2
2107             = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL,
2108                                                      SVt_PV)));
2109         o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2110     }
2111     return o;
2112 }
2113
2114 OP *
2115 Perl_fold_constants(pTHX_ register OP *o)
2116 {
2117     dVAR;
2118     register OP *curop;
2119     OP *newop;
2120     I32 type = o->op_type;
2121     SV *sv;
2122
2123     if (PL_opargs[type] & OA_RETSCALAR)
2124         scalar(o);
2125     if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2126         o->op_targ = pad_alloc(type, SVs_PADTMP);
2127
2128     /* integerize op, unless it happens to be C<-foo>.
2129      * XXX should pp_i_negate() do magic string negation instead? */
2130     if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2131         && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2132              && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2133     {
2134         o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2135     }
2136
2137     if (!(PL_opargs[type] & OA_FOLDCONST))
2138         goto nope;
2139
2140     switch (type) {
2141     case OP_NEGATE:
2142         /* XXX might want a ck_negate() for this */
2143         cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2144         break;
2145     case OP_UCFIRST:
2146     case OP_LCFIRST:
2147     case OP_UC:
2148     case OP_LC:
2149     case OP_SLT:
2150     case OP_SGT:
2151     case OP_SLE:
2152     case OP_SGE:
2153     case OP_SCMP:
2154         /* XXX what about the numeric ops? */
2155         if (PL_hints & HINT_LOCALE)
2156             goto nope;
2157     }
2158
2159     if (PL_error_count)
2160         goto nope;              /* Don't try to run w/ errors */
2161
2162     for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2163         if ((curop->op_type != OP_CONST ||
2164              (curop->op_private & OPpCONST_BARE)) &&
2165             curop->op_type != OP_LIST &&
2166             curop->op_type != OP_SCALAR &&
2167             curop->op_type != OP_NULL &&
2168             curop->op_type != OP_PUSHMARK)
2169         {
2170             goto nope;
2171         }
2172     }
2173
2174     curop = LINKLIST(o);
2175     o->op_next = 0;
2176     PL_op = curop;
2177     CALLRUNOPS(aTHX);
2178     sv = *(PL_stack_sp--);
2179     if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2180         pad_swipe(o->op_targ,  FALSE);
2181     else if (SvTEMP(sv)) {                      /* grab mortal temp? */
2182         SvREFCNT_inc_simple_void(sv);
2183         SvTEMP_off(sv);
2184     }
2185
2186 #ifndef PERL_MAD
2187     op_free(o);
2188 #endif
2189     if (type == OP_RV2GV)
2190         newop = newGVOP(OP_GV, 0, (GV*)sv);
2191     else
2192         newop = newSVOP(OP_CONST, 0, sv);
2193     op_getmad(o,newop,'f');
2194     return newop;
2195
2196   nope:
2197     return o;
2198 }
2199
2200 OP *
2201 Perl_gen_constant_list(pTHX_ register OP *o)
2202 {
2203     dVAR;
2204     register OP *curop;
2205     const I32 oldtmps_floor = PL_tmps_floor;
2206
2207     list(o);
2208     if (PL_error_count)
2209         return o;               /* Don't attempt to run with errors */
2210
2211     PL_op = curop = LINKLIST(o);
2212     o->op_next = 0;
2213     CALL_PEEP(curop);
2214     pp_pushmark();
2215     CALLRUNOPS(aTHX);
2216     PL_op = curop;
2217     pp_anonlist();
2218     PL_tmps_floor = oldtmps_floor;
2219
2220     o->op_type = OP_RV2AV;
2221     o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2222     o->op_flags &= ~OPf_REF;    /* treat \(1..2) like an ordinary list */
2223     o->op_flags |= OPf_PARENS;  /* and flatten \(1..2,3) */
2224     o->op_opt = 0;              /* needs to be revisited in peep() */
2225     curop = ((UNOP*)o)->op_first;
2226     ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
2227 #ifdef PERL_MAD
2228     op_getmad(curop,o,'O');
2229 #else
2230     op_free(curop);
2231 #endif
2232     linklist(o);
2233     return list(o);
2234 }
2235
2236 OP *
2237 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2238 {
2239     dVAR;
2240     if (!o || o->op_type != OP_LIST)
2241         o = newLISTOP(OP_LIST, 0, o, NULL);
2242     else
2243         o->op_flags &= ~OPf_WANT;
2244
2245     if (!(PL_opargs[type] & OA_MARK))
2246         op_null(cLISTOPo->op_first);
2247
2248     o->op_type = (OPCODE)type;
2249     o->op_ppaddr = PL_ppaddr[type];
2250     o->op_flags |= flags;
2251
2252     o = CHECKOP(type, o);
2253     if (o->op_type != (unsigned)type)
2254         return o;
2255
2256     return fold_constants(o);
2257 }
2258
2259 /* List constructors */
2260
2261 OP *
2262 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2263 {
2264     if (!first)
2265         return last;
2266
2267     if (!last)
2268         return first;
2269
2270     if (first->op_type != (unsigned)type
2271         || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2272     {
2273         return newLISTOP(type, 0, first, last);
2274     }
2275
2276     if (first->op_flags & OPf_KIDS)
2277         ((LISTOP*)first)->op_last->op_sibling = last;
2278     else {
2279         first->op_flags |= OPf_KIDS;
2280         ((LISTOP*)first)->op_first = last;
2281     }
2282     ((LISTOP*)first)->op_last = last;
2283     return first;
2284 }
2285
2286 OP *
2287 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2288 {
2289     if (!first)
2290         return (OP*)last;
2291
2292     if (!last)
2293         return (OP*)first;
2294
2295     if (first->op_type != (unsigned)type)
2296         return prepend_elem(type, (OP*)first, (OP*)last);
2297
2298     if (last->op_type != (unsigned)type)
2299         return append_elem(type, (OP*)first, (OP*)last);
2300
2301     first->op_last->op_sibling = last->op_first;
2302     first->op_last = last->op_last;
2303     first->op_flags |= (last->op_flags & OPf_KIDS);
2304
2305 #ifdef PERL_MAD
2306     if (last->op_first && first->op_madprop) {
2307         MADPROP *mp = last->op_first->op_madprop;
2308         if (mp) {
2309             while (mp->mad_next)
2310                 mp = mp->mad_next;
2311             mp->mad_next = first->op_madprop;
2312         }
2313         else {
2314             last->op_first->op_madprop = first->op_madprop;
2315         }
2316     }
2317     first->op_madprop = last->op_madprop;
2318     last->op_madprop = 0;
2319 #endif
2320
2321     FreeOp(last);
2322
2323     return (OP*)first;
2324 }
2325
2326 OP *
2327 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2328 {
2329     if (!first)
2330         return last;
2331
2332     if (!last)
2333         return first;
2334
2335     if (last->op_type == (unsigned)type) {
2336         if (type == OP_LIST) {  /* already a PUSHMARK there */
2337             first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2338             ((LISTOP*)last)->op_first->op_sibling = first;
2339             if (!(first->op_flags & OPf_PARENS))
2340                 last->op_flags &= ~OPf_PARENS;
2341         }
2342         else {
2343             if (!(last->op_flags & OPf_KIDS)) {
2344                 ((LISTOP*)last)->op_last = first;
2345                 last->op_flags |= OPf_KIDS;
2346             }
2347             first->op_sibling = ((LISTOP*)last)->op_first;
2348             ((LISTOP*)last)->op_first = first;
2349         }
2350         last->op_flags |= OPf_KIDS;
2351         return last;
2352     }
2353
2354     return newLISTOP(type, 0, first, last);
2355 }
2356
2357 /* Constructors */
2358
2359 #ifdef PERL_MAD
2360
2361 TOKEN *
2362 Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
2363 {
2364     TOKEN *tk;
2365     Newxz(tk, 1, TOKEN);
2366     tk->tk_type = (OPCODE)optype;
2367     tk->tk_type = 12345;
2368     tk->tk_lval = lval;
2369     tk->tk_mad = madprop;
2370     return tk;
2371 }
2372
2373 void
2374 Perl_token_free(pTHX_ TOKEN* tk)
2375 {
2376     if (tk->tk_type != 12345)
2377         return;
2378     mad_free(tk->tk_mad);
2379     Safefree(tk);
2380 }
2381
2382 void
2383 Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
2384 {
2385     MADPROP* mp;
2386     MADPROP* tm;
2387     if (tk->tk_type != 12345) {
2388         Perl_warner(aTHX_ packWARN(WARN_MISC),
2389              "Invalid TOKEN object ignored");
2390         return;
2391     }
2392     tm = tk->tk_mad;
2393     if (!tm)
2394         return;
2395
2396     /* faked up qw list? */
2397     if (slot == '(' &&
2398         tm->mad_type == MAD_SV &&
2399         SvPVX((SV*)tm->mad_val)[0] == 'q')
2400             slot = 'x';
2401
2402     if (o) {
2403         mp = o->op_madprop;
2404         if (mp) {
2405             for (;;) {
2406                 /* pretend constant fold didn't happen? */
2407                 if (mp->mad_key == 'f' &&
2408                     (o->op_type == OP_CONST ||
2409                      o->op_type == OP_GV) )
2410                 {
2411                     token_getmad(tk,(OP*)mp->mad_val,slot);
2412                     return;
2413                 }
2414                 if (!mp->mad_next)
2415                     break;
2416                 mp = mp->mad_next;
2417             }
2418             mp->mad_next = tm;
2419             mp = mp->mad_next;
2420         }
2421         else {
2422             o->op_madprop = tm;
2423             mp = o->op_madprop;
2424         }
2425         if (mp->mad_key == 'X')
2426             mp->mad_key = slot; /* just change the first one */
2427
2428         tk->tk_mad = 0;
2429     }
2430     else
2431         mad_free(tm);
2432     Safefree(tk);
2433 }
2434
2435 void
2436 Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
2437 {
2438     MADPROP* mp;
2439     if (!from)
2440         return;
2441     if (o) {
2442         mp = o->op_madprop;
2443         if (mp) {
2444             for (;;) {
2445                 /* pretend constant fold didn't happen? */
2446                 if (mp->mad_key == 'f' &&
2447                     (o->op_type == OP_CONST ||
2448                      o->op_type == OP_GV) )
2449                 {
2450                     op_getmad(from,(OP*)mp->mad_val,slot);
2451                     return;
2452                 }
2453                 if (!mp->mad_next)
2454                     break;
2455                 mp = mp->mad_next;
2456             }
2457             mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
2458         }
2459         else {
2460             o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
2461         }
2462     }
2463 }
2464
2465 void
2466 Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
2467 {
2468     MADPROP* mp;
2469     if (!from)
2470         return;
2471     if (o) {
2472         mp = o->op_madprop;
2473         if (mp) {
2474             for (;;) {
2475                 /* pretend constant fold didn't happen? */
2476                 if (mp->mad_key == 'f' &&
2477                     (o->op_type == OP_CONST ||
2478                      o->op_type == OP_GV) )
2479                 {
2480                     op_getmad(from,(OP*)mp->mad_val,slot);
2481                     return;
2482                 }
2483                 if (!mp->mad_next)
2484                     break;
2485                 mp = mp->mad_next;
2486             }
2487             mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
2488         }
2489         else {
2490             o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
2491         }
2492     }
2493     else {
2494         PerlIO_printf(PerlIO_stderr(),
2495                       "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
2496         op_free(from);
2497     }
2498 }
2499
2500 void
2501 Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
2502 {
2503     MADPROP* tm;
2504     if (!mp || !o)
2505         return;
2506     if (slot)
2507         mp->mad_key = slot;
2508     tm = o->op_madprop;
2509     o->op_madprop = mp;
2510     for (;;) {
2511         if (!mp->mad_next)
2512             break;
2513         mp = mp->mad_next;
2514     }
2515     mp->mad_next = tm;
2516 }
2517
2518 void
2519 Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
2520 {
2521     if (!o)
2522         return;
2523     addmad(tm, &(o->op_madprop), slot);
2524 }
2525
2526 void
2527 Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
2528 {
2529     MADPROP* mp;
2530     if (!tm || !root)
2531         return;
2532     if (slot)
2533         tm->mad_key = slot;
2534     mp = *root;
2535     if (!mp) {
2536         *root = tm;
2537         return;
2538     }
2539     for (;;) {
2540         if (!mp->mad_next)
2541             break;
2542         mp = mp->mad_next;
2543     }
2544     mp->mad_next = tm;
2545 }
2546
2547 MADPROP *
2548 Perl_newMADsv(pTHX_ char key, SV* sv)
2549 {
2550     return newMADPROP(key, MAD_SV, sv, 0);
2551 }
2552
2553 MADPROP *
2554 Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen)
2555 {
2556     MADPROP *mp;
2557     Newxz(mp, 1, MADPROP);
2558     mp->mad_next = 0;
2559     mp->mad_key = key;
2560     mp->mad_vlen = vlen;
2561     mp->mad_type = type;
2562     mp->mad_val = val;
2563 /*    PerlIO_printf(PerlIO_stderr(), "NEW  mp = %0x\n", mp);  */
2564     return mp;
2565 }
2566
2567 void
2568 Perl_mad_free(pTHX_ MADPROP* mp)
2569 {
2570 /*    PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
2571     if (!mp)
2572         return;
2573     if (mp->mad_next)
2574         mad_free(mp->mad_next);
2575 /*    if (PL_lex_state != LEX_NOTPARSING && mp->mad_vlen)
2576         PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
2577     switch (mp->mad_type) {
2578     case MAD_NULL:
2579         break;
2580     case MAD_PV:
2581         Safefree((char*)mp->mad_val);
2582         break;
2583     case MAD_OP:
2584         if (mp->mad_vlen)       /* vlen holds "strong/weak" boolean */
2585             op_free((OP*)mp->mad_val);
2586         break;
2587     case MAD_SV:
2588         sv_free((SV*)mp->mad_val);
2589         break;
2590     default:
2591         PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
2592         break;
2593     }
2594     Safefree(mp);
2595 }
2596
2597 #endif
2598
2599 OP *
2600 Perl_newNULLLIST(pTHX)
2601 {
2602     return newOP(OP_STUB, 0);
2603 }
2604
2605 OP *
2606 Perl_force_list(pTHX_ OP *o)
2607 {
2608     if (!o || o->op_type != OP_LIST)
2609         o = newLISTOP(OP_LIST, 0, o, NULL);
2610     op_null(o);
2611     return o;
2612 }
2613
2614 OP *
2615 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2616 {
2617     dVAR;
2618     LISTOP *listop;
2619
2620     NewOp(1101, listop, 1, LISTOP);
2621
2622     listop->op_type = (OPCODE)type;
2623     listop->op_ppaddr = PL_ppaddr[type];
2624     if (first || last)
2625         flags |= OPf_KIDS;
2626     listop->op_flags = (U8)flags;
2627
2628     if (!last && first)
2629         last = first;
2630     else if (!first && last)
2631         first = last;
2632     else if (first)
2633         first->op_sibling = last;
2634     listop->op_first = first;
2635     listop->op_last = last;
2636     if (type == OP_LIST) {
2637         OP* const pushop = newOP(OP_PUSHMARK, 0);
2638         pushop->op_sibling = first;
2639         listop->op_first = pushop;
2640         listop->op_flags |= OPf_KIDS;
2641         if (!last)
2642             listop->op_last = pushop;
2643     }
2644
2645     return CHECKOP(type, listop);
2646 }
2647
2648 OP *
2649 Perl_newOP(pTHX_ I32 type, I32 flags)
2650 {
2651     dVAR;
2652     OP *o;
2653     NewOp(1101, o, 1, OP);
2654     o->op_type = (OPCODE)type;
2655     o->op_ppaddr = PL_ppaddr[type];
2656     o->op_flags = (U8)flags;
2657
2658     o->op_next = o;
2659     o->op_private = (U8)(0 | (flags >> 8));
2660     if (PL_opargs[type] & OA_RETSCALAR)
2661         scalar(o);
2662     if (PL_opargs[type] & OA_TARGET)
2663         o->op_targ = pad_alloc(type, SVs_PADTMP);
2664     return CHECKOP(type, o);
2665 }
2666
2667 OP *
2668 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2669 {
2670     dVAR;
2671     UNOP *unop;
2672
2673     if (!first)
2674         first = newOP(OP_STUB, 0);
2675     if (PL_opargs[type] & OA_MARK)
2676         first = force_list(first);
2677
2678     NewOp(1101, unop, 1, UNOP);
2679     unop->op_type = (OPCODE)type;
2680     unop->op_ppaddr = PL_ppaddr[type];
2681     unop->op_first = first;
2682     unop->op_flags = (U8)(flags | OPf_KIDS);
2683     unop->op_private = (U8)(1 | (flags >> 8));
2684     unop = (UNOP*) CHECKOP(type, unop);
2685     if (unop->op_next)
2686         return (OP*)unop;
2687
2688     return fold_constants((OP *) unop);
2689 }
2690
2691 OP *
2692 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2693 {
2694     dVAR;
2695     BINOP *binop;
2696     NewOp(1101, binop, 1, BINOP);
2697
2698     if (!first)
2699         first = newOP(OP_NULL, 0);
2700
2701     binop->op_type = (OPCODE)type;
2702     binop->op_ppaddr = PL_ppaddr[type];
2703     binop->op_first = first;
2704     binop->op_flags = (U8)(flags | OPf_KIDS);
2705     if (!last) {
2706         last = first;
2707         binop->op_private = (U8)(1 | (flags >> 8));
2708     }
2709     else {
2710         binop->op_private = (U8)(2 | (flags >> 8));
2711         first->op_sibling = last;
2712     }
2713
2714     binop = (BINOP*)CHECKOP(type, binop);
2715     if (binop->op_next || binop->op_type != (OPCODE)type)
2716         return (OP*)binop;
2717
2718     binop->op_last = binop->op_first->op_sibling;
2719
2720     return fold_constants((OP *)binop);
2721 }
2722
2723 static int uvcompare(const void *a, const void *b)
2724     __attribute__nonnull__(1)
2725     __attribute__nonnull__(2)
2726     __attribute__pure__;
2727 static int uvcompare(const void *a, const void *b)
2728 {
2729     if (*((const UV *)a) < (*(const UV *)b))
2730         return -1;
2731     if (*((const UV *)a) > (*(const UV *)b))
2732         return 1;
2733     if (*((const UV *)a+1) < (*(const UV *)b+1))
2734         return -1;
2735     if (*((const UV *)a+1) > (*(const UV *)b+1))
2736         return 1;
2737     return 0;
2738 }
2739
2740 OP *
2741 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2742 {
2743     dVAR;
2744     SV * const tstr = ((SVOP*)expr)->op_sv;
2745     SV * const rstr = ((SVOP*)repl)->op_sv;
2746     STRLEN tlen;
2747     STRLEN rlen;
2748     const U8 *t = (U8*)SvPV_const(tstr, tlen);
2749     const U8 *r = (U8*)SvPV_const(rstr, rlen);
2750     register I32 i;
2751     register I32 j;
2752     I32 grows = 0;
2753     register short *tbl;
2754
2755     const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
2756     const I32 squash     = o->op_private & OPpTRANS_SQUASH;
2757     I32 del              = o->op_private & OPpTRANS_DELETE;
2758     PL_hints |= HINT_BLOCK_SCOPE;
2759
2760     if (SvUTF8(tstr))
2761         o->op_private |= OPpTRANS_FROM_UTF;
2762
2763     if (SvUTF8(rstr))
2764         o->op_private |= OPpTRANS_TO_UTF;
2765
2766     if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2767         SV* const listsv = newSVpvs("# comment\n");
2768         SV* transv = NULL;
2769         const U8* tend = t + tlen;
2770         const U8* rend = r + rlen;
2771         STRLEN ulen;
2772         UV tfirst = 1;
2773         UV tlast = 0;
2774         IV tdiff;
2775         UV rfirst = 1;
2776         UV rlast = 0;
2777         IV rdiff;
2778         IV diff;
2779         I32 none = 0;
2780         U32 max = 0;
2781         I32 bits;
2782         I32 havefinal = 0;
2783         U32 final = 0;
2784         const I32 from_utf  = o->op_private & OPpTRANS_FROM_UTF;
2785         const I32 to_utf    = o->op_private & OPpTRANS_TO_UTF;
2786         U8* tsave = NULL;
2787         U8* rsave = NULL;
2788
2789         if (!from_utf) {
2790             STRLEN len = tlen;
2791             t = tsave = bytes_to_utf8(t, &len);
2792             tend = t + len;
2793         }
2794         if (!to_utf && rlen) {
2795             STRLEN len = rlen;
2796             r = rsave = bytes_to_utf8(r, &len);
2797             rend = r + len;
2798         }
2799
2800 /* There are several snags with this code on EBCDIC:
2801    1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2802    2. scan_const() in toke.c has encoded chars in native encoding which makes
2803       ranges at least in EBCDIC 0..255 range the bottom odd.
2804 */
2805
2806         if (complement) {
2807             U8 tmpbuf[UTF8_MAXBYTES+1];
2808             UV *cp;
2809             UV nextmin = 0;
2810             Newx(cp, 2*tlen, UV);
2811             i = 0;
2812             transv = newSVpvs("");
2813             while (t < tend) {
2814                 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2815                 t += ulen;
2816                 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2817                     t++;
2818                     cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2819                     t += ulen;
2820                 }
2821                 else {
2822                  cp[2*i+1] = cp[2*i];
2823                 }
2824                 i++;
2825             }
2826             qsort(cp, i, 2*sizeof(UV), uvcompare);
2827             for (j = 0; j < i; j++) {
2828                 UV  val = cp[2*j];
2829                 diff = val - nextmin;
2830                 if (diff > 0) {
2831                     t = uvuni_to_utf8(tmpbuf,nextmin);
2832                     sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2833                     if (diff > 1) {
2834                         U8  range_mark = UTF_TO_NATIVE(0xff);
2835                         t = uvuni_to_utf8(tmpbuf, val - 1);
2836                         sv_catpvn(transv, (char *)&range_mark, 1);
2837                         sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2838                     }
2839                 }
2840                 val = cp[2*j+1];
2841                 if (val >= nextmin)
2842                     nextmin = val + 1;
2843             }
2844             t = uvuni_to_utf8(tmpbuf,nextmin);
2845             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2846             {
2847                 U8 range_mark = UTF_TO_NATIVE(0xff);
2848                 sv_catpvn(transv, (char *)&range_mark, 1);
2849             }
2850             t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
2851                                     UNICODE_ALLOW_SUPER);
2852             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2853             t = (const U8*)SvPVX_const(transv);
2854             tlen = SvCUR(transv);
2855             tend = t + tlen;
2856             Safefree(cp);
2857         }
2858         else if (!rlen && !del) {
2859             r = t; rlen = tlen; rend = tend;
2860         }
2861         if (!squash) {
2862                 if ((!rlen && !del) || t == r ||
2863                     (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2864                 {
2865                     o->op_private |= OPpTRANS_IDENTICAL;
2866                 }
2867         }
2868
2869         while (t < tend || tfirst <= tlast) {
2870             /* see if we need more "t" chars */
2871             if (tfirst > tlast) {
2872                 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2873                 t += ulen;
2874                 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {    /* illegal utf8 val indicates range */
2875                     t++;
2876                     tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2877                     t += ulen;
2878                 }
2879                 else
2880                     tlast = tfirst;
2881             }
2882
2883             /* now see if we need more "r" chars */
2884             if (rfirst > rlast) {
2885                 if (r < rend) {
2886                     rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2887                     r += ulen;
2888                     if (r < rend && NATIVE_TO_UTF(*r) == 0xff) {        /* illegal utf8 val indicates range */
2889                         r++;
2890                         rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2891                         r += ulen;
2892                     }
2893                     else
2894                         rlast = rfirst;
2895                 }
2896                 else {
2897                     if (!havefinal++)
2898                         final = rlast;
2899                     rfirst = rlast = 0xffffffff;
2900                 }
2901             }
2902
2903             /* now see which range will peter our first, if either. */
2904             tdiff = tlast - tfirst;
2905             rdiff = rlast - rfirst;
2906
2907             if (tdiff <= rdiff)
2908                 diff = tdiff;
2909             else
2910                 diff = rdiff;
2911
2912             if (rfirst == 0xffffffff) {
2913                 diff = tdiff;   /* oops, pretend rdiff is infinite */
2914                 if (diff > 0)
2915                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2916                                    (long)tfirst, (long)tlast);
2917                 else
2918                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2919             }
2920             else {
2921                 if (diff > 0)
2922                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2923                                    (long)tfirst, (long)(tfirst + diff),
2924                                    (long)rfirst);
2925                 else
2926                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2927                                    (long)tfirst, (long)rfirst);
2928
2929                 if (rfirst + diff > max)
2930                     max = rfirst + diff;
2931                 if (!grows)
2932                     grows = (tfirst < rfirst &&
2933                              UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2934                 rfirst += diff + 1;
2935             }
2936             tfirst += diff + 1;
2937         }
2938
2939         none = ++max;
2940         if (del)
2941             del = ++max;
2942
2943         if (max > 0xffff)
2944             bits = 32;
2945         else if (max > 0xff)
2946             bits = 16;
2947         else
2948             bits = 8;
2949
2950         Safefree(cPVOPo->op_pv);
2951         cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2952         SvREFCNT_dec(listsv);
2953         SvREFCNT_dec(transv);
2954
2955         if (!del && havefinal && rlen)
2956             (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2957                            newSVuv((UV)final), 0);
2958
2959         if (grows)
2960             o->op_private |= OPpTRANS_GROWS;
2961
2962         Safefree(tsave);
2963         Safefree(rsave);
2964
2965 #ifdef PERL_MAD
2966         op_getmad(expr,o,'e');
2967         op_getmad(repl,o,'r');
2968 #else
2969         op_free(expr);
2970         op_free(repl);
2971 #endif
2972         return o;
2973     }
2974
2975     tbl = (short*)cPVOPo->op_pv;
2976     if (complement) {
2977         Zero(tbl, 256, short);
2978         for (i = 0; i < (I32)tlen; i++)
2979             tbl[t[i]] = -1;
2980         for (i = 0, j = 0; i < 256; i++) {
2981             if (!tbl[i]) {
2982                 if (j >= (I32)rlen) {
2983                     if (del)
2984                         tbl[i] = -2;
2985                     else if (rlen)
2986                         tbl[i] = r[j-1];
2987                     else
2988                         tbl[i] = (short)i;
2989                 }
2990                 else {
2991                     if (i < 128 && r[j] >= 128)
2992                         grows = 1;
2993                     tbl[i] = r[j++];
2994                 }
2995             }
2996         }
2997         if (!del) {
2998             if (!rlen) {
2999                 j = rlen;
3000                 if (!squash)
3001                     o->op_private |= OPpTRANS_IDENTICAL;
3002             }
3003             else if (j >= (I32)rlen)
3004                 j = rlen - 1;
3005             else
3006                 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
3007             tbl[0x100] = (short)(rlen - j);
3008             for (i=0; i < (I32)rlen - j; i++)
3009                 tbl[0x101+i] = r[j+i];
3010         }
3011     }
3012     else {
3013         if (!rlen && !del) {
3014             r = t; rlen = tlen;
3015             if (!squash)
3016                 o->op_private |= OPpTRANS_IDENTICAL;
3017         }
3018         else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
3019             o->op_private |= OPpTRANS_IDENTICAL;
3020         }
3021         for (i = 0; i < 256; i++)
3022             tbl[i] = -1;
3023         for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
3024             if (j >= (I32)rlen) {
3025                 if (del) {
3026                     if (tbl[t[i]] == -1)
3027                         tbl[t[i]] = -2;
3028                     continue;
3029                 }
3030                 --j;
3031             }
3032             if (tbl[t[i]] == -1) {
3033                 if (t[i] < 128 && r[j] >= 128)
3034                     grows = 1;
3035                 tbl[t[i]] = r[j];
3036             }
3037         }
3038     }
3039     if (grows)
3040         o->op_private |= OPpTRANS_GROWS;
3041 #ifdef PERL_MAD
3042     op_getmad(expr,o,'e');
3043     op_getmad(repl,o,'r');
3044 #else
3045     op_free(expr);
3046     op_free(repl);
3047 #endif
3048
3049     return o;
3050 }
3051
3052 OP *
3053 Perl_newPMOP(pTHX_ I32 type, I32 flags)
3054 {
3055     dVAR;
3056     PMOP *pmop;
3057
3058     NewOp(1101, pmop, 1, PMOP);
3059     pmop->op_type = (OPCODE)type;
3060     pmop->op_ppaddr = PL_ppaddr[type];
3061     pmop->op_flags = (U8)flags;
3062     pmop->op_private = (U8)(0 | (flags >> 8));
3063
3064     if (PL_hints & HINT_RE_TAINT)
3065         pmop->op_pmpermflags |= PMf_RETAINT;
3066     if (PL_hints & HINT_LOCALE)
3067         pmop->op_pmpermflags |= PMf_LOCALE;
3068     pmop->op_pmflags = pmop->op_pmpermflags;
3069
3070 #ifdef USE_ITHREADS
3071     if (av_len((AV*) PL_regex_pad[0]) > -1) {
3072         SV * const repointer = av_pop((AV*)PL_regex_pad[0]);
3073         pmop->op_pmoffset = SvIV(repointer);
3074         SvREPADTMP_off(repointer);
3075         sv_setiv(repointer,0);
3076     } else {
3077         SV * const repointer = newSViv(0);
3078         av_push(PL_regex_padav, SvREFCNT_inc_simple_NN(repointer));
3079         pmop->op_pmoffset = av_len(PL_regex_padav);
3080         PL_regex_pad = AvARRAY(PL_regex_padav);
3081     }
3082 #endif
3083
3084         /* link into pm list */
3085     if (type != OP_TRANS && PL_curstash) {
3086         MAGIC *mg = mg_find((SV*)PL_curstash, PERL_MAGIC_symtab);
3087
3088         if (!mg) {
3089             mg = sv_magicext((SV*)PL_curstash, 0, PERL_MAGIC_symtab, 0, 0, 0);
3090         }
3091         pmop->op_pmnext = (PMOP*)mg->mg_obj;
3092         mg->mg_obj = (SV*)pmop;
3093         PmopSTASH_set(pmop,PL_curstash);
3094     }
3095
3096     return CHECKOP(type, pmop);
3097 }
3098
3099 /* Given some sort of match op o, and an expression expr containing a
3100  * pattern, either compile expr into a regex and attach it to o (if it's
3101  * constant), or convert expr into a runtime regcomp op sequence (if it's
3102  * not)
3103  *
3104  * isreg indicates that the pattern is part of a regex construct, eg
3105  * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
3106  * split "pattern", which aren't. In the former case, expr will be a list
3107  * if the pattern contains more than one term (eg /a$b/) or if it contains
3108  * a replacement, ie s/// or tr///.
3109  */
3110
3111 OP *
3112 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
3113 {
3114     dVAR;
3115     PMOP *pm;
3116     LOGOP *rcop;
3117     I32 repl_has_vars = 0;
3118     OP* repl = NULL;
3119     bool reglist;
3120
3121     if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
3122         /* last element in list is the replacement; pop it */
3123         OP* kid;
3124         repl = cLISTOPx(expr)->op_last;
3125         kid = cLISTOPx(expr)->op_first;
3126         while (kid->op_sibling != repl)
3127             kid = kid->op_sibling;
3128         kid->op_sibling = NULL;
3129         cLISTOPx(expr)->op_last = kid;
3130     }
3131
3132     if (isreg && expr->op_type == OP_LIST &&
3133         cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
3134     {
3135         /* convert single element list to element */
3136         OP* const oe = expr;
3137         expr = cLISTOPx(oe)->op_first->op_sibling;
3138         cLISTOPx(oe)->op_first->op_sibling = NULL;
3139         cLISTOPx(oe)->op_last = NULL;
3140         op_free(oe);
3141     }
3142
3143     if (o->op_type == OP_TRANS) {
3144         return pmtrans(o, expr, repl);
3145     }
3146
3147     reglist = isreg && expr->op_type == OP_LIST;
3148     if (reglist)
3149         op_null(expr);
3150
3151     PL_hints |= HINT_BLOCK_SCOPE;
3152     pm = (PMOP*)o;
3153
3154     if (expr->op_type == OP_CONST) {
3155         STRLEN plen;
3156         SV * const pat = ((SVOP*)expr)->op_sv;
3157         const char *p = SvPV_const(pat, plen);
3158         if ((o->op_flags & OPf_SPECIAL) && (*p == ' ' && p[1] == '\0')) {
3159             U32 was_readonly = SvREADONLY(pat);
3160
3161             if (was_readonly) {
3162                 if (SvFAKE(pat)) {
3163                     sv_force_normal_flags(pat, 0);
3164                     assert(!SvREADONLY(pat));
3165                     was_readonly = 0;
3166                 } else {
3167                     SvREADONLY_off(pat);
3168                 }
3169             }
3170
3171             sv_setpvn(pat, "\\s+", 3);
3172
3173             SvFLAGS(pat) |= was_readonly;
3174
3175             p = SvPV_const(pat, plen);
3176             pm->op_pmflags |= PMf_SKIPWHITE;
3177         }
3178         if (DO_UTF8(pat))
3179             pm->op_pmdynflags |= PMdf_UTF8;
3180         /* FIXME - can we make this function take const char * args?  */
3181         PM_SETRE(pm, CALLREGCOMP(aTHX_ (char*)p, (char*)p + plen, pm));
3182         if (strEQ("\\s+", PM_GETRE(pm)->precomp))
3183             pm->op_pmflags |= PMf_WHITE;
3184 #ifdef PERL_MAD
3185         op_getmad(expr,(OP*)pm,'e');
3186 #else
3187         op_free(expr);
3188 #endif
3189     }
3190     else {
3191         if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3192             expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3193                             ? OP_REGCRESET
3194                             : OP_REGCMAYBE),0,expr);
3195
3196         NewOp(1101, rcop, 1, LOGOP);
3197         rcop->op_type = OP_REGCOMP;
3198         rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3199         rcop->op_first = scalar(expr);
3200         rcop->op_flags |= OPf_KIDS
3201                             | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
3202                             | (reglist ? OPf_STACKED : 0);
3203         rcop->op_private = 1;
3204         rcop->op_other = o;
3205         if (reglist)
3206             rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
3207
3208         /* /$x/ may cause an eval, since $x might be qr/(?{..})/  */
3209         PL_cv_has_eval = 1;
3210
3211         /* establish postfix order */
3212         if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3213             LINKLIST(expr);
3214             rcop->op_next = expr;
3215             ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3216         }
3217         else {
3218             rcop->op_next = LINKLIST(expr);
3219             expr->op_next = (OP*)rcop;
3220         }
3221
3222         prepend_elem(o->op_type, scalar((OP*)rcop), o);
3223     }
3224
3225     if (repl) {
3226         OP *curop;
3227         if (pm->op_pmflags & PMf_EVAL) {
3228             curop = NULL;
3229             if (CopLINE(PL_curcop) < (line_t)PL_multi_end)
3230                 CopLINE_set(PL_curcop, (line_t)PL_multi_end);
3231         }
3232         else if (repl->op_type == OP_CONST)
3233             curop = repl;
3234         else {
3235             OP *lastop = NULL;
3236             for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3237                 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3238                     if (curop->op_type == OP_GV) {
3239                         GV * const gv = cGVOPx_gv(curop);
3240                         repl_has_vars = 1;
3241                         if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
3242                             break;
3243                     }
3244                     else if (curop->op_type == OP_RV2CV)
3245                         break;
3246                     else if (curop->op_type == OP_RV2SV ||
3247                              curop->op_type == OP_RV2AV ||
3248                              curop->op_type == OP_RV2HV ||
3249                              curop->op_type == OP_RV2GV) {
3250                         if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3251                             break;
3252                     }
3253                     else if (curop->op_type == OP_PADSV ||
3254                              curop->op_type == OP_PADAV ||
3255                              curop->op_type == OP_PADHV ||
3256                              curop->op_type == OP_PADANY) {
3257                         repl_has_vars = 1;
3258                     }
3259                     else if (curop->op_type == OP_PUSHRE)
3260                         /*EMPTY*/; /* Okay here, dangerous in newASSIGNOP */
3261                     else
3262                         break;
3263                 }
3264                 lastop = curop;
3265             }
3266         }
3267         if (curop == repl
3268             && !(repl_has_vars
3269                  && (!PM_GETRE(pm)
3270                      || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
3271             pm->op_pmflags |= PMf_CONST;        /* const for long enough */
3272             pm->op_pmpermflags |= PMf_CONST;    /* const for long enough */
3273             prepend_elem(o->op_type, scalar(repl), o);
3274         }
3275         else {
3276             if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3277                 pm->op_pmflags |= PMf_MAYBE_CONST;
3278                 pm->op_pmpermflags |= PMf_MAYBE_CONST;
3279             }
3280             NewOp(1101, rcop, 1, LOGOP);
3281             rcop->op_type = OP_SUBSTCONT;
3282             rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3283             rcop->op_first = scalar(repl);
3284             rcop->op_flags |= OPf_KIDS;
3285             rcop->op_private = 1;
3286             rcop->op_other = o;
3287
3288             /* establish postfix order */
3289             rcop->op_next = LINKLIST(repl);
3290             repl->op_next = (OP*)rcop;
3291
3292             pm->op_pmreplroot = scalar((OP*)rcop);
3293             pm->op_pmreplstart = LINKLIST(rcop);
3294             rcop->op_next = 0;
3295         }
3296     }
3297
3298     return (OP*)pm;
3299 }
3300
3301 OP *
3302 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3303 {
3304     dVAR;
3305     SVOP *svop;
3306     NewOp(1101, svop, 1, SVOP);
3307     svop->op_type = (OPCODE)type;
3308     svop->op_ppaddr = PL_ppaddr[type];
3309     svop->op_sv = sv;
3310     svop->op_next = (OP*)svop;
3311     svop->op_flags = (U8)flags;
3312     if (PL_opargs[type] & OA_RETSCALAR)
3313         scalar((OP*)svop);
3314     if (PL_opargs[type] & OA_TARGET)
3315         svop->op_targ = pad_alloc(type, SVs_PADTMP);
3316     return CHECKOP(type, svop);
3317 }
3318
3319 OP *
3320 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3321 {
3322     dVAR;
3323     PADOP *padop;
3324     NewOp(1101, padop, 1, PADOP);
3325     padop->op_type = (OPCODE)type;
3326     padop->op_ppaddr = PL_ppaddr[type];
3327     padop->op_padix = pad_alloc(type, SVs_PADTMP);
3328     SvREFCNT_dec(PAD_SVl(padop->op_padix));
3329     PAD_SETSV(padop->op_padix, sv);
3330     if (sv)
3331         SvPADTMP_on(sv);
3332     padop->op_next = (OP*)padop;
3333     padop->op_flags = (U8)flags;
3334     if (PL_opargs[type] & OA_RETSCALAR)
3335         scalar((OP*)padop);
3336     if (PL_opargs[type] & OA_TARGET)
3337         padop->op_targ = pad_alloc(type, SVs_PADTMP);
3338     return CHECKOP(type, padop);
3339 }
3340
3341 OP *
3342 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3343 {
3344     dVAR;
3345 #ifdef USE_ITHREADS
3346     if (gv)
3347         GvIN_PAD_on(gv);
3348     return newPADOP(type, flags, SvREFCNT_inc_simple(gv));
3349 #else
3350     return newSVOP(type, flags, SvREFCNT_inc_simple(gv));
3351 #endif
3352 }
3353
3354 OP *
3355 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3356 {
3357     dVAR;
3358     PVOP *pvop;
3359     NewOp(1101, pvop, 1, PVOP);
3360     pvop->op_type = (OPCODE)type;
3361     pvop->op_ppaddr = PL_ppaddr[type];
3362     pvop->op_pv = pv;
3363     pvop->op_next = (OP*)pvop;
3364     pvop->op_flags = (U8)flags;
3365     if (PL_opargs[type] & OA_RETSCALAR)
3366         scalar((OP*)pvop);
3367     if (PL_opargs[type] & OA_TARGET)
3368         pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3369     return CHECKOP(type, pvop);
3370 }
3371
3372 #ifdef PERL_MAD
3373 OP*
3374 #else
3375 void
3376 #endif
3377 Perl_package(pTHX_ OP *o)
3378 {
3379     dVAR;
3380     const char *name;
3381     STRLEN len;
3382 #ifdef PERL_MAD
3383     OP *pegop;
3384 #endif
3385
3386     save_hptr(&PL_curstash);
3387     save_item(PL_curstname);
3388
3389     name = SvPV_const(cSVOPo->op_sv, len);
3390     PL_curstash = gv_stashpvn(name, len, TRUE);
3391     sv_setpvn(PL_curstname, name, len);
3392
3393     PL_hints |= HINT_BLOCK_SCOPE;
3394     PL_copline = NOLINE;
3395     PL_expect = XSTATE;
3396
3397 #ifndef PERL_MAD
3398     op_free(o);
3399 #else
3400     if (!PL_madskills) {
3401         op_free(o);
3402         return Nullop;
3403     }
3404
3405     pegop = newOP(OP_NULL,0);
3406     op_getmad(o,pegop,'P');
3407     return pegop;
3408 #endif
3409 }
3410
3411 #ifdef PERL_MAD
3412 OP*
3413 #else
3414 void
3415 #endif
3416 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
3417 {
3418     dVAR;
3419     OP *pack;
3420     OP *imop;
3421     OP *veop;
3422 #ifdef PERL_MAD
3423     OP *pegop = newOP(OP_NULL,0);
3424 #endif
3425
3426     if (idop->op_type != OP_CONST)
3427         Perl_croak(aTHX_ "Module name must be constant");
3428
3429     if (PL_madskills)
3430         op_getmad(idop,pegop,'U');
3431
3432     veop = NULL;
3433
3434     if (version) {
3435         SV * const vesv = ((SVOP*)version)->op_sv;
3436
3437         if (PL_madskills)
3438             op_getmad(version,pegop,'V');
3439         if (!arg && !SvNIOKp(vesv)) {
3440             arg = version;
3441         }
3442         else {
3443             OP *pack;
3444             SV *meth;
3445
3446             if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3447                 Perl_croak(aTHX_ "Version number must be constant number");
3448
3449             /* Make copy of idop so we don't free it twice */
3450             pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3451
3452             /* Fake up a method call to VERSION */
3453             meth = newSVpvs_share("VERSION");
3454             veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3455                             append_elem(OP_LIST,
3456                                         prepend_elem(OP_LIST, pack, list(version)),
3457                                         newSVOP(OP_METHOD_NAMED, 0, meth)));
3458         }
3459     }
3460
3461     /* Fake up an import/unimport */
3462     if (arg && arg->op_type == OP_STUB) {
3463         if (PL_madskills)
3464             op_getmad(arg,pegop,'S');
3465         imop = arg;             /* no import on explicit () */
3466     }
3467     else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
3468         imop = NULL;            /* use 5.0; */
3469         if (!aver)
3470             idop->op_private |= OPpCONST_NOVER;
3471     }
3472     else {
3473         SV *meth;
3474
3475         if (PL_madskills)
3476             op_getmad(arg,pegop,'A');
3477
3478         /* Make copy of idop so we don't free it twice */
3479         pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3480
3481         /* Fake up a method call to import/unimport */
3482         meth = aver
3483             ? newSVpvs_share("import") : newSVpvs_share("unimport");
3484         imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3485                        append_elem(OP_LIST,
3486                                    prepend_elem(OP_LIST, pack, list(arg)),
3487                                    newSVOP(OP_METHOD_NAMED, 0, meth)));
3488     }
3489
3490     /* Fake up the BEGIN {}, which does its thing immediately. */
3491     newATTRSUB(floor,
3492         newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
3493         NULL,
3494         NULL,
3495         append_elem(OP_LINESEQ,
3496             append_elem(OP_LINESEQ,
3497                 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
3498                 newSTATEOP(0, NULL, veop)),
3499             newSTATEOP(0, NULL, imop) ));
3500
3501     /* The "did you use incorrect case?" warning used to be here.
3502      * The problem is that on case-insensitive filesystems one
3503      * might get false positives for "use" (and "require"):
3504      * "use Strict" or "require CARP" will work.  This causes
3505      * portability problems for the script: in case-strict
3506      * filesystems the script will stop working.
3507      *
3508      * The "incorrect case" warning checked whether "use Foo"
3509      * imported "Foo" to your namespace, but that is wrong, too:
3510      * there is no requirement nor promise in the language that
3511      * a Foo.pm should or would contain anything in package "Foo".
3512      *
3513      * There is very little Configure-wise that can be done, either:
3514      * the case-sensitivity of the build filesystem of Perl does not
3515      * help in guessing the case-sensitivity of the runtime environment.
3516      */
3517
3518     PL_hints |= HINT_BLOCK_SCOPE;
3519     PL_copline = NOLINE;
3520     PL_expect = XSTATE;
3521     PL_cop_seqmax++; /* Purely for B::*'s benefit */
3522
3523 #ifdef PERL_MAD
3524     if (!PL_madskills) {
3525         /* FIXME - don't allocate pegop if !PL_madskills */
3526         op_free(pegop);
3527         return Nullop;
3528     }
3529     return pegop;
3530 #endif
3531 }
3532
3533 /*
3534 =head1 Embedding Functions
3535
3536 =for apidoc load_module
3537
3538 Loads the module whose name is pointed to by the string part of name.
3539 Note that the actual module name, not its filename, should be given.
3540 Eg, "Foo::Bar" instead of "Foo/Bar.pm".  flags can be any of
3541 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3542 (or 0 for no flags). ver, if specified, provides version semantics
3543 similar to C<use Foo::Bar VERSION>.  The optional trailing SV*
3544 arguments can be used to specify arguments to the module's import()
3545 method, similar to C<use Foo::Bar VERSION LIST>.
3546
3547 =cut */
3548
3549 void
3550 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3551 {
3552     va_list args;
3553     va_start(args, ver);
3554     vload_module(flags, name, ver, &args);
3555     va_end(args);
3556 }
3557
3558 #ifdef PERL_IMPLICIT_CONTEXT
3559 void
3560 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3561 {
3562     dTHX;
3563     va_list args;
3564     va_start(args, ver);
3565     vload_module(flags, name, ver, &args);
3566     va_end(args);
3567 }
3568 #endif
3569
3570 void
3571 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3572 {
3573     dVAR;
3574     OP *veop, *imop;
3575
3576     OP * const modname = newSVOP(OP_CONST, 0, name);
3577     modname->op_private |= OPpCONST_BARE;
3578     if (ver) {
3579         veop = newSVOP(OP_CONST, 0, ver);
3580     }
3581     else
3582         veop = NULL;
3583     if (flags & PERL_LOADMOD_NOIMPORT) {
3584         imop = sawparens(newNULLLIST());
3585     }
3586     else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3587         imop = va_arg(*args, OP*);
3588     }
3589     else {
3590         SV *sv;
3591         imop = NULL;
3592         sv = va_arg(*args, SV*);
3593         while (sv) {
3594             imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3595             sv = va_arg(*args, SV*);
3596         }
3597     }
3598     {
3599         const line_t ocopline = PL_copline;
3600         COP * const ocurcop = PL_curcop;
3601         const int oexpect = PL_expect;
3602
3603         utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3604                 veop, modname, imop);
3605         PL_expect = oexpect;
3606         PL_copline = ocopline;
3607         PL_curcop = ocurcop;
3608     }
3609 }
3610
3611 OP *
3612 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
3613 {
3614     dVAR;
3615     OP *doop;
3616     GV *gv = NULL;
3617
3618     if (!force_builtin) {
3619         gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
3620         if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
3621             GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
3622             gv = gvp ? *gvp : NULL;
3623         }
3624     }
3625
3626     if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3627         doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3628                                append_elem(OP_LIST, term,
3629                                            scalar(newUNOP(OP_RV2CV, 0,
3630                                                           newGVOP(OP_GV, 0,
3631                                                                   gv))))));
3632     }
3633     else {
3634         doop = newUNOP(OP_DOFILE, 0, scalar(term));
3635     }
3636     return doop;
3637 }
3638
3639 OP *
3640 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3641 {
3642     return newBINOP(OP_LSLICE, flags,
3643             list(force_list(subscript)),
3644             list(force_list(listval)) );
3645 }
3646
3647 STATIC I32
3648 S_is_list_assignment(pTHX_ register const OP *o)
3649 {
3650     if (!o)
3651         return TRUE;
3652
3653     if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3654         o = cUNOPo->op_first;
3655
3656     if (o->op_type == OP_COND_EXPR) {
3657         const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
3658         const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3659
3660         if (t && f)
3661             return TRUE;
3662         if (t || f)
3663             yyerror("Assignment to both a list and a scalar");
3664         return FALSE;
3665     }
3666
3667     if (o->op_type == OP_LIST &&
3668         (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR &&
3669         o->op_private & OPpLVAL_INTRO)
3670         return FALSE;
3671
3672     if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3673         o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3674         o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3675         return TRUE;
3676
3677     if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3678         return TRUE;
3679
3680     if (o->op_type == OP_RV2SV)
3681         return FALSE;
3682
3683     return FALSE;
3684 }
3685
3686 OP *
3687 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3688 {
3689     dVAR;
3690     OP *o;
3691
3692     if (optype) {
3693         if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
3694             return newLOGOP(optype, 0,
3695                 mod(scalar(left), optype),
3696                 newUNOP(OP_SASSIGN, 0, scalar(right)));
3697         }
3698         else {
3699             return newBINOP(optype, OPf_STACKED,
3700                 mod(scalar(left), optype), scalar(right));
3701         }
3702     }
3703
3704     if (is_list_assignment(left)) {
3705         OP *curop;
3706
3707         PL_modcount = 0;
3708         /* Grandfathering $[ assignment here.  Bletch.*/
3709         /* Only simple assignments like C<< ($[) = 1 >> are allowed */
3710         PL_eval_start = (left->op_type == OP_CONST) ? right : 0;
3711         left = mod(left, OP_AASSIGN);
3712         if (PL_eval_start)
3713             PL_eval_start = 0;
3714         else if (left->op_type == OP_CONST) {
3715             /* FIXME for MAD */
3716             /* Result of assignment is always 1 (or we'd be dead already) */
3717             return newSVOP(OP_CONST, 0, newSViv(1));
3718         }
3719         curop = list(force_list(left));
3720         o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3721         o->op_private = (U8)(0 | (flags >> 8));
3722
3723         /* PL_generation sorcery:
3724          * an assignment like ($a,$b) = ($c,$d) is easier than
3725          * ($a,$b) = ($c,$a), since there is no need for temporary vars.
3726          * To detect whether there are common vars, the global var
3727          * PL_generation is incremented for each assign op we compile.
3728          * Then, while compiling the assign op, we run through all the
3729          * variables on both sides of the assignment, setting a spare slot
3730          * in each of them to PL_generation. If any of them already have
3731          * that value, we know we've got commonality.  We could use a
3732          * single bit marker, but then we'd have to make 2 passes, first
3733          * to clear the flag, then to test and set it.  To find somewhere
3734          * to store these values, evil chicanery is done with SvCUR().
3735          */
3736
3737         if (!(left->op_private & OPpLVAL_INTRO)) {
3738             OP *lastop = o;
3739             PL_generation++;
3740             for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3741                 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3742                     if (curop->op_type == OP_GV) {
3743                         GV *gv = cGVOPx_gv(curop);
3744                         if (gv == PL_defgv
3745                             || (int)GvASSIGN_GENERATION(gv) == PL_generation)
3746                             break;
3747                         GvASSIGN_GENERATION_set(gv, PL_generation);
3748                     }
3749                     else if (curop->op_type == OP_PADSV ||
3750                              curop->op_type == OP_PADAV ||
3751                              curop->op_type == OP_PADHV ||
3752                              curop->op_type == OP_PADANY)
3753                     {
3754                         if (PAD_COMPNAME_GEN(curop->op_targ)
3755                                                     == (STRLEN)PL_generation)
3756                             break;
3757                         PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
3758
3759                     }
3760                     else if (curop->op_type == OP_RV2CV)
3761                         break;
3762                     else if (curop->op_type == OP_RV2SV ||
3763                              curop->op_type == OP_RV2AV ||
3764                              curop->op_type == OP_RV2HV ||
3765                              curop->op_type == OP_RV2GV) {
3766                         if (lastop->op_type != OP_GV)   /* funny deref? */
3767                             break;
3768                     }
3769                     else if (curop->op_type == OP_PUSHRE) {
3770                         if (((PMOP*)curop)->op_pmreplroot) {
3771 #ifdef USE_ITHREADS
3772                             GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET,
3773                                         ((PMOP*)curop)->op_pmreplroot));
3774 #else
3775                             GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3776 #endif
3777                             if (gv == PL_defgv
3778                                 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
3779                                 break;
3780                             GvASSIGN_GENERATION_set(gv, PL_generation);
3781                             GvASSIGN_GENERATION_set(gv, PL_generation);
3782                         }
3783                     }
3784                     else
3785                         break;
3786                 }
3787                 lastop = curop;
3788             }
3789             if (curop != o)
3790                 o->op_private |= OPpASSIGN_COMMON;
3791         }
3792         if (right && right->op_type == OP_SPLIT) {
3793             OP* tmpop;
3794             if ((tmpop = ((LISTOP*)right)->op_first) &&
3795                 tmpop->op_type == OP_PUSHRE)
3796             {
3797                 PMOP * const pm = (PMOP*)tmpop;
3798                 if (left->op_type == OP_RV2AV &&
3799                     !(left->op_private & OPpLVAL_INTRO) &&
3800                     !(o->op_private & OPpASSIGN_COMMON) )
3801                 {
3802                     tmpop = ((UNOP*)left)->op_first;
3803                     if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3804 #ifdef USE_ITHREADS
3805                         pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
3806                         cPADOPx(tmpop)->op_padix = 0;   /* steal it */
3807 #else
3808                         pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3809                         cSVOPx(tmpop)->op_sv = NULL;    /* steal it */
3810 #endif
3811                         pm->op_pmflags |= PMf_ONCE;
3812                         tmpop = cUNOPo->op_first;       /* to list (nulled) */
3813                         tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3814                         tmpop->op_sibling = NULL;       /* don't free split */
3815                         right->op_next = tmpop->op_next;  /* fix starting loc */
3816 #ifdef PERL_MAD
3817                         op_getmad(o,right,'R');         /* blow off assign */
3818 #else
3819                         op_free(o);                     /* blow off assign */
3820 #endif
3821                         right->op_flags &= ~OPf_WANT;
3822                                 /* "I don't know and I don't care." */
3823                         return right;
3824                     }
3825                 }
3826                 else {
3827                    if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3828                       ((LISTOP*)right)->op_last->op_type == OP_CONST)
3829                     {
3830                         SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3831                         if (SvIVX(sv) == 0)
3832                             sv_setiv(sv, PL_modcount+1);
3833                     }
3834                 }
3835             }
3836         }
3837         return o;
3838     }
3839     if (!right)
3840         right = newOP(OP_UNDEF, 0);
3841     if (right->op_type == OP_READLINE) {
3842         right->op_flags |= OPf_STACKED;
3843         return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3844     }
3845     else {
3846         PL_eval_start = right;  /* Grandfathering $[ assignment here.  Bletch.*/
3847         o = newBINOP(OP_SASSIGN, flags,
3848             scalar(right), mod(scalar(left), OP_SASSIGN) );
3849         if (PL_eval_start)
3850             PL_eval_start = 0;
3851         else {
3852             /* FIXME for MAD */
3853             op_free(o);
3854             o = newSVOP(OP_CONST, 0, newSViv(PL_compiling.cop_arybase));
3855             o->op_private |= OPpCONST_ARYBASE;
3856         }
3857     }
3858     return o;
3859 }
3860
3861 OP *
3862 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3863 {
3864     dVAR;
3865     const U32 seq = intro_my();
3866     register COP *cop;
3867
3868     NewOp(1101, cop, 1, COP);
3869     if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3870         cop->op_type = OP_DBSTATE;
3871         cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3872     }
3873     else {
3874         cop->op_type = OP_NEXTSTATE;
3875         cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3876     }
3877     cop->op_flags = (U8)flags;
3878     cop->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
3879 #ifdef NATIVE_HINTS
3880     cop->op_private |= NATIVE_HINTS;
3881 #endif
3882     PL_compiling.op_private = cop->op_private;
3883     cop->op_next = (OP*)cop;
3884
3885     if (label) {
3886         cop->cop_label = label;
3887         PL_hints |= HINT_BLOCK_SCOPE;
3888     }
3889     cop->cop_seq = seq;
3890     cop->cop_arybase = PL_curcop->cop_arybase;
3891     if (specialWARN(PL_curcop->cop_warnings))
3892         cop->cop_warnings = PL_curcop->cop_warnings ;
3893     else
3894         cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3895     if (specialCopIO(PL_curcop->cop_io))
3896         cop->cop_io = PL_curcop->cop_io;
3897     else
3898         cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3899
3900
3901     if (PL_copline == NOLINE)
3902         CopLINE_set(cop, CopLINE(PL_curcop));
3903     else {
3904         CopLINE_set(cop, PL_copline);
3905         PL_copline = NOLINE;
3906     }
3907 #ifdef USE_ITHREADS
3908     CopFILE_set(cop, CopFILE(PL_curcop));       /* XXX share in a pvtable? */
3909 #else
3910     CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3911 #endif
3912     CopSTASH_set(cop, PL_curstash);
3913
3914     if (PERLDB_LINE && PL_curstash != PL_debstash) {
3915         SV * const * const svp = av_fetch(CopFILEAVx(PL_curcop), (I32)CopLINE(cop), FALSE);
3916         if (svp && *svp != &PL_sv_undef ) {
3917             (void)SvIOK_on(*svp);
3918             SvIV_set(*svp, PTR2IV(cop));
3919         }
3920     }
3921
3922     return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3923 }
3924
3925
3926 OP *
3927 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3928 {
3929     dVAR;
3930     return new_logop(type, flags, &first, &other);
3931 }
3932
3933 STATIC OP *
3934 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3935 {
3936     dVAR;
3937     LOGOP *logop;
3938     OP *o;
3939     OP *first = *firstp;
3940     OP * const other = *otherp;
3941
3942     if (type == OP_XOR)         /* Not short circuit, but here by precedence. */
3943         return newBINOP(type, flags, scalar(first), scalar(other));
3944
3945     scalarboolean(first);
3946     /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3947     if (first->op_type == OP_NOT
3948         && (first->op_flags & OPf_SPECIAL)
3949         && (first->op_flags & OPf_KIDS)) {
3950         if (type == OP_AND || type == OP_OR) {
3951             if (type == OP_AND)
3952                 type = OP_OR;
3953             else
3954                 type = OP_AND;
3955             o = first;
3956             first = *firstp = cUNOPo->op_first;
3957             if (o->op_next)
3958                 first->op_next = o->op_next;
3959             cUNOPo->op_first = NULL;
3960 #ifdef PERL_MAD
3961             op_getmad(o,first,'O');
3962 #else
3963             op_free(o);
3964 #endif
3965         }
3966     }
3967     if (first->op_type == OP_CONST) {
3968         if (first->op_private & OPpCONST_STRICT)
3969             no_bareword_allowed(first);
3970         else if ((first->op_private & OPpCONST_BARE) && ckWARN(WARN_BAREWORD))
3971                 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
3972         if ((type == OP_AND &&  SvTRUE(((SVOP*)first)->op_sv)) ||
3973             (type == OP_OR  && !SvTRUE(((SVOP*)first)->op_sv)) ||
3974             (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) {
3975             *firstp = NULL;
3976             if (other->op_type == OP_CONST)
3977                 other->op_private |= OPpCONST_SHORTCIRCUIT;
3978             if (PL_madskills) {
3979                 OP *newop = newUNOP(OP_NULL, 0, other);
3980                 op_getmad(first, newop, '1');
3981                 newop->op_targ = type;  /* set "was" field */
3982                 return newop;
3983             }
3984             op_free(first);
3985             return other;
3986         }
3987         else {
3988             /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
3989             const OP *o2 = other;
3990             if ( ! (o2->op_type == OP_LIST
3991                     && (( o2 = cUNOPx(o2)->op_first))
3992                     && o2->op_type == OP_PUSHMARK
3993                     && (( o2 = o2->op_sibling)) )
3994             )
3995                 o2 = other;
3996             if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
3997                         || o2->op_type == OP_PADHV)
3998                 && o2->op_private & OPpLVAL_INTRO
3999                 && ckWARN(WARN_DEPRECATED))
4000             {
4001                 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4002                             "Deprecated use of my() in false conditional");
4003             }
4004
4005             *otherp = NULL;
4006             if (first->op_type == OP_CONST)
4007                 first->op_private |= OPpCONST_SHORTCIRCUIT;
4008             if (PL_madskills) {
4009                 first = newUNOP(OP_NULL, 0, first);
4010                 op_getmad(other, first, '2');
4011                 first->op_targ = type;  /* set "was" field */
4012             }
4013             else
4014                 op_free(other);
4015             return first;
4016         }
4017     }
4018     else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
4019         && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
4020     {
4021         const OP * const k1 = ((UNOP*)first)->op_first;
4022         const OP * const k2 = k1->op_sibling;
4023         OPCODE warnop = 0;
4024         switch (first->op_type)
4025         {
4026         case OP_NULL:
4027             if (k2 && k2->op_type == OP_READLINE
4028                   && (k2->op_flags & OPf_STACKED)
4029                   && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4030             {
4031                 warnop = k2->op_type;
4032             }
4033             break;
4034
4035         case OP_SASSIGN:
4036             if (k1->op_type == OP_READDIR
4037                   || k1->op_type == OP_GLOB
4038                   || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4039                   || k1->op_type == OP_EACH)
4040             {
4041                 warnop = ((k1->op_type == OP_NULL)
4042                           ? (OPCODE)k1->op_targ : k1->op_type);
4043             }
4044             break;
4045         }
4046         if (warnop) {
4047             const line_t oldline = CopLINE(PL_curcop);
4048             CopLINE_set(PL_curcop, PL_copline);
4049             Perl_warner(aTHX_ packWARN(WARN_MISC),
4050                  "Value of %s%s can be \"0\"; test with defined()",
4051                  PL_op_desc[warnop],
4052                  ((warnop == OP_READLINE || warnop == OP_GLOB)
4053                   ? " construct" : "() operator"));
4054             CopLINE_set(PL_curcop, oldline);
4055         }
4056     }
4057
4058     if (!other)
4059         return first;
4060
4061     if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
4062         other->op_private |= OPpASSIGN_BACKWARDS;  /* other is an OP_SASSIGN */
4063
4064     NewOp(1101, logop, 1, LOGOP);
4065
4066     logop->op_type = (OPCODE)type;
4067     logop->op_ppaddr = PL_ppaddr[type];
4068     logop->op_first = first;
4069     logop->op_flags = (U8)(flags | OPf_KIDS);
4070     logop->op_other = LINKLIST(other);
4071     logop->op_private = (U8)(1 | (flags >> 8));
4072
4073     /* establish postfix order */
4074     logop->op_next = LINKLIST(first);
4075     first->op_next = (OP*)logop;
4076     first->op_sibling = other;
4077
4078     CHECKOP(type,logop);
4079
4080     o = newUNOP(OP_NULL, 0, (OP*)logop);
4081     other->op_next = o;
4082
4083     return o;
4084 }
4085
4086 OP *
4087 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
4088 {
4089     dVAR;
4090     LOGOP *logop;
4091     OP *start;
4092     OP *o;
4093
4094     if (!falseop)
4095         return newLOGOP(OP_AND, 0, first, trueop);
4096     if (!trueop)
4097         return newLOGOP(OP_OR, 0, first, falseop);
4098
4099     scalarboolean(first);
4100     if (first->op_type == OP_CONST) {
4101         if (first->op_private & OPpCONST_BARE &&
4102             first->op_private & OPpCONST_STRICT) {
4103             no_bareword_allowed(first);
4104         }
4105         if (SvTRUE(((SVOP*)first)->op_sv)) {
4106 #ifdef PERL_MAD
4107             if (PL_madskills) {
4108                 trueop = newUNOP(OP_NULL, 0, trueop);
4109                 op_getmad(first,trueop,'C');
4110                 op_getmad(falseop,trueop,'e');
4111             }
4112             /* FIXME for MAD - should there be an ELSE here?  */
4113 #else
4114             op_free(first);
4115             op_free(falseop);
4116 #endif
4117             return trueop;
4118         }
4119         else {
4120 #ifdef PERL_MAD
4121             if (PL_madskills) {
4122                 falseop = newUNOP(OP_NULL, 0, falseop);
4123                 op_getmad(first,falseop,'C');
4124                 op_getmad(trueop,falseop,'t');
4125             }
4126             /* FIXME for MAD - should there be an ELSE here?  */
4127 #else
4128             op_free(first);
4129             op_free(trueop);
4130 #endif
4131             return falseop;
4132         }
4133     }
4134     NewOp(1101, logop, 1, LOGOP);
4135     logop->op_type = OP_COND_EXPR;
4136     logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
4137     logop->op_first = first;
4138     logop->op_flags = (U8)(flags | OPf_KIDS);
4139     logop->op_private = (U8)(1 | (flags >> 8));
4140     logop->op_other = LINKLIST(trueop);
4141     logop->op_next = LINKLIST(falseop);
4142
4143     CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
4144             logop);
4145
4146     /* establish postfix order */
4147     start = LINKLIST(first);
4148     first->op_next = (OP*)logop;
4149
4150     first->op_sibling = trueop;
4151     trueop->op_sibling = falseop;
4152     o = newUNOP(OP_NULL, 0, (OP*)logop);
4153
4154     trueop->op_next = falseop->op_next = o;
4155
4156     o->op_next = start;
4157     return o;
4158 }
4159
4160 OP *
4161 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
4162 {
4163     dVAR;
4164     LOGOP *range;
4165     OP *flip;
4166     OP *flop;
4167     OP *leftstart;
4168     OP *o;
4169
4170     NewOp(1101, range, 1, LOGOP);
4171
4172     range->op_type = OP_RANGE;
4173     range->op_ppaddr = PL_ppaddr[OP_RANGE];
4174     range->op_first = left;
4175     range->op_flags = OPf_KIDS;
4176     leftstart = LINKLIST(left);
4177     range->op_other = LINKLIST(right);
4178     range->op_private = (U8)(1 | (flags >> 8));
4179
4180     left->op_sibling = right;
4181
4182     range->op_next = (OP*)range;
4183     flip = newUNOP(OP_FLIP, flags, (OP*)range);
4184     flop = newUNOP(OP_FLOP, 0, flip);
4185     o = newUNOP(OP_NULL, 0, flop);
4186     linklist(flop);
4187     range->op_next = leftstart;
4188
4189     left->op_next = flip;
4190     right->op_next = flop;
4191
4192     range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4193     sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
4194     flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4195     sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
4196
4197     flip->op_private =  left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4198     flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4199
4200     flip->op_next = o;
4201     if (!flip->op_private || !flop->op_private)
4202         linklist(o);            /* blow off optimizer unless constant */
4203
4204     return o;
4205 }
4206
4207 OP *
4208 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
4209 {
4210     dVAR;
4211     OP* listop;
4212     OP* o;
4213     const bool once = block && block->op_flags & OPf_SPECIAL &&
4214       (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
4215
4216     PERL_UNUSED_ARG(debuggable);
4217
4218     if (expr) {
4219         if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
4220             return block;       /* do {} while 0 does once */
4221         if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4222             || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4223             expr = newUNOP(OP_DEFINED, 0,
4224                 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4225         } else if (expr->op_flags & OPf_KIDS) {
4226             const OP * const k1 = ((UNOP*)expr)->op_first;
4227             const OP * const k2 = k1 ? k1->op_sibling : NULL;
4228             switch (expr->op_type) {
4229               case OP_NULL:
4230                 if (k2 && k2->op_type == OP_READLINE
4231                       && (k2->op_flags & OPf_STACKED)
4232                       && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4233                     expr = newUNOP(OP_DEFINED, 0, expr);
4234                 break;
4235
4236               case OP_SASSIGN:
4237                 if (k1->op_type == OP_READDIR
4238                       || k1->op_type == OP_GLOB
4239                       || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4240                       || k1->op_type == OP_EACH)
4241                     expr = newUNOP(OP_DEFINED, 0, expr);
4242                 break;
4243             }
4244         }
4245     }
4246
4247     /* if block is null, the next append_elem() would put UNSTACK, a scalar
4248      * op, in listop. This is wrong. [perl #27024] */
4249     if (!block)
4250         block = newOP(OP_NULL, 0);
4251     listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
4252     o = new_logop(OP_AND, 0, &expr, &listop);
4253
4254     if (listop)
4255         ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
4256
4257     if (once && o != listop)
4258         o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
4259
4260     if (o == listop)
4261         o = newUNOP(OP_NULL, 0, o);     /* or do {} while 1 loses outer block */
4262
4263     o->op_flags |= flags;
4264     o = scope(o);
4265     o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
4266     return o;
4267 }
4268
4269 OP *
4270 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
4271 whileline, OP *expr, OP *block, OP *cont, I32 has_my)
4272 {
4273     dVAR;
4274     OP *redo;
4275     OP *next = NULL;
4276     OP *listop;
4277     OP *o;
4278     U8 loopflags = 0;
4279
4280     PERL_UNUSED_ARG(debuggable);
4281
4282     if (expr) {
4283         if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4284                      || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4285             expr = newUNOP(OP_DEFINED, 0,
4286                 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4287         } else if (expr->op_flags & OPf_KIDS) {
4288             const OP * const k1 = ((UNOP*)expr)->op_first;
4289             const OP * const k2 = (k1) ? k1->op_sibling : NULL;
4290             switch (expr->op_type) {
4291               case OP_NULL:
4292                 if (k2 && k2->op_type == OP_READLINE
4293                       && (k2->op_flags & OPf_STACKED)
4294                       && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4295                     expr = newUNOP(OP_DEFINED, 0, expr);
4296                 break;
4297
4298               case OP_SASSIGN:
4299                 if (k1->op_type == OP_READDIR
4300                       || k1->op_type == OP_GLOB
4301                       || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4302                       || k1->op_type == OP_EACH)
4303                     expr = newUNOP(OP_DEFINED, 0, expr);
4304                 break;
4305             }
4306         }
4307     }
4308
4309     if (!block)
4310         block = newOP(OP_NULL, 0);
4311     else if (cont || has_my) {
4312         block = scope(block);
4313     }
4314
4315     if (cont) {
4316         next = LINKLIST(cont);
4317     }
4318     if (expr) {
4319         OP * const unstack = newOP(OP_UNSTACK, 0);
4320         if (!next)
4321             next = unstack;
4322         cont = append_elem(OP_LINESEQ, cont, unstack);
4323     }
4324
4325     listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4326     redo = LINKLIST(listop);
4327
4328     if (expr) {
4329         PL_copline = (line_t)whileline;
4330         scalar(listop);
4331         o = new_logop(OP_AND, 0, &expr, &listop);
4332         if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4333             op_free(expr);              /* oops, it's a while (0) */
4334             op_free((OP*)loop);
4335             return NULL;                /* listop already freed by new_logop */
4336         }
4337         if (listop)
4338             ((LISTOP*)listop)->op_last->op_next =
4339                 (o == listop ? redo : LINKLIST(o));
4340     }
4341     else
4342         o = listop;
4343
4344     if (!loop) {
4345         NewOp(1101,loop,1,LOOP);
4346         loop->op_type = OP_ENTERLOOP;
4347         loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4348         loop->op_private = 0;
4349         loop->op_next = (OP*)loop;
4350     }
4351
4352     o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4353
4354     loop->op_redoop = redo;
4355     loop->op_lastop = o;
4356     o->op_private |= loopflags;
4357
4358     if (next)
4359         loop->op_nextop = next;
4360     else
4361         loop->op_nextop = o;
4362
4363     o->op_flags |= flags;
4364     o->op_private |= (flags >> 8);
4365     return o;
4366 }
4367
4368 OP *
4369 Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont)
4370 {
4371     dVAR;
4372     LOOP *loop;
4373     OP *wop;
4374     PADOFFSET padoff = 0;
4375     I32 iterflags = 0;
4376     I32 iterpflags = 0;
4377     OP *madsv = 0;
4378
4379     if (sv) {
4380         if (sv->op_type == OP_RV2SV) {  /* symbol table variable */
4381             iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
4382             sv->op_type = OP_RV2GV;
4383             sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4384             if (cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
4385                 iterpflags |= OPpITER_DEF;
4386         }
4387         else if (sv->op_type == OP_PADSV) { /* private variable */
4388             iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
4389             padoff = sv->op_targ;
4390             if (PL_madskills)
4391                 madsv = sv;
4392             else {
4393                 sv->op_targ = 0;
4394                 op_free(sv);
4395             }
4396             sv = NULL;
4397         }
4398         else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
4399             padoff = sv->op_targ;
4400             if (PL_madskills)
4401                 madsv = sv;
4402             else {
4403                 sv->op_targ = 0;
4404                 iterflags |= OPf_SPECIAL;
4405                 op_free(sv);
4406             }
4407             sv = NULL;
4408         }
4409         else
4410             Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4411         if (padoff && strEQ(PAD_COMPNAME_PV(padoff), "$_"))
4412             iterpflags |= OPpITER_DEF;
4413     }
4414     else {
4415         const I32 offset = pad_findmy("$_");
4416         if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
4417             sv = newGVOP(OP_GV, 0, PL_defgv);
4418         }
4419         else {
4420             padoff = offset;
4421         }
4422         iterpflags |= OPpITER_DEF;
4423     }
4424     if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4425         expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4426         iterflags |= OPf_STACKED;
4427     }
4428     else if (expr->op_type == OP_NULL &&
4429              (expr->op_flags & OPf_KIDS) &&
4430              ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4431     {
4432         /* Basically turn for($x..$y) into the same as for($x,$y), but we
4433          * set the STACKED flag to indicate that these values are to be
4434          * treated as min/max values by 'pp_iterinit'.
4435          */
4436         UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4437         LOGOP* const range = (LOGOP*) flip->op_first;
4438         OP* const left  = range->op_first;
4439         OP* const right = left->op_sibling;
4440         LISTOP* listop;
4441
4442         range->op_flags &= ~OPf_KIDS;
4443         range->op_first = NULL;
4444
4445         listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4446         listop->op_first->op_next = range->op_next;
4447         left->op_next = range->op_other;
4448         right->op_next = (OP*)listop;
4449         listop->op_next = listop->op_first;
4450
4451 #ifdef PERL_MAD
4452         op_getmad(expr,(OP*)listop,'O');
4453 #else
4454         op_free(expr);
4455 #endif
4456         expr = (OP*)(listop);
4457         op_null(expr);
4458         iterflags |= OPf_STACKED;
4459     }
4460     else {
4461         expr = mod(force_list(expr), OP_GREPSTART);
4462     }
4463
4464     loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4465                                append_elem(OP_LIST, expr, scalar(sv))));
4466     assert(!loop->op_next);
4467     /* for my  $x () sets OPpLVAL_INTRO;
4468      * for our $x () sets OPpOUR_INTRO */
4469     loop->op_private = (U8)iterpflags;
4470 #ifdef PL_OP_SLAB_ALLOC
4471     {
4472         LOOP *tmp;
4473         NewOp(1234,tmp,1,LOOP);
4474         Copy(loop,tmp,1,LISTOP);
4475         FreeOp(loop);
4476         loop = tmp;
4477     }
4478 #else
4479     Renew(loop, 1, LOOP);
4480 #endif
4481     loop->op_targ = padoff;
4482     wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
4483     if (madsv)
4484         op_getmad(madsv, (OP*)loop, 'v');
4485     PL_copline = forline;
4486     return newSTATEOP(0, label, wop);
4487 }
4488
4489 OP*
4490 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4491 {
4492     dVAR;
4493     OP *o;
4494
4495     if (type != OP_GOTO || label->op_type == OP_CONST) {
4496         /* "last()" means "last" */
4497         if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4498             o = newOP(type, OPf_SPECIAL);
4499         else {
4500             o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4501                                         ? SvPVx_nolen_const(((SVOP*)label)->op_sv)
4502                                         : ""));
4503         }
4504 #ifdef PERL_MAD
4505         op_getmad(label,o,'L');
4506 #else
4507         op_free(label);
4508 #endif
4509     }
4510     else {
4511         /* Check whether it's going to be a goto &function */
4512         if (label->op_type == OP_ENTERSUB
4513                 && !(label->op_flags & OPf_STACKED))
4514             label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4515         o = newUNOP(type, OPf_STACKED, label);
4516     }
4517     PL_hints |= HINT_BLOCK_SCOPE;
4518     return o;
4519 }
4520
4521 /* if the condition is a literal array or hash
4522    (or @{ ... } etc), make a reference to it.
4523  */
4524 STATIC OP *
4525 S_ref_array_or_hash(pTHX_ OP *cond)
4526 {
4527     if (cond
4528     && (cond->op_type == OP_RV2AV
4529     ||  cond->op_type == OP_PADAV
4530     ||  cond->op_type == OP_RV2HV
4531     ||  cond->op_type == OP_PADHV))
4532
4533         return newUNOP(OP_REFGEN,
4534             0, mod(cond, OP_REFGEN));
4535
4536     else
4537         return cond;
4538 }
4539
4540 /* These construct the optree fragments representing given()
4541    and when() blocks.
4542
4543    entergiven and enterwhen are LOGOPs; the op_other pointer
4544    points up to the associated leave op. We need this so we
4545    can put it in the context and make break/continue work.
4546    (Also, of course, pp_enterwhen will jump straight to
4547    op_other if the match fails.)
4548  */
4549
4550 STATIC
4551 OP *
4552 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
4553                    I32 enter_opcode, I32 leave_opcode,
4554                    PADOFFSET entertarg)
4555 {
4556     dVAR;
4557     LOGOP *enterop;
4558     OP *o;
4559
4560     NewOp(1101, enterop, 1, LOGOP);
4561     enterop->op_type = enter_opcode;
4562     enterop->op_ppaddr = PL_ppaddr[enter_opcode];
4563     enterop->op_flags =  (U8) OPf_KIDS;
4564     enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
4565     enterop->op_private = 0;
4566
4567     o = newUNOP(leave_opcode, 0, (OP *) enterop);
4568
4569     if (cond) {
4570         enterop->op_first = scalar(cond);
4571         cond->op_sibling = block;
4572
4573         o->op_next = LINKLIST(cond);
4574         cond->op_next = (OP *) enterop;
4575     }
4576     else {
4577         /* This is a default {} block */
4578         enterop->op_first = block;
4579         enterop->op_flags |= OPf_SPECIAL;
4580
4581         o->op_next = (OP *) enterop;
4582     }
4583
4584     CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
4585                                        entergiven and enterwhen both
4586                                        use ck_null() */
4587
4588     enterop->op_next = LINKLIST(block);
4589     block->op_next = enterop->op_other = o;
4590
4591     return o;
4592 }
4593
4594 /* Does this look like a boolean operation? For these purposes
4595    a boolean operation is:
4596      - a subroutine call [*]
4597      - a logical connective
4598      - a comparison operator
4599      - a filetest operator, with the exception of -s -M -A -C
4600      - defined(), exists() or eof()
4601      - /$re/ or $foo =~ /$re/
4602
4603    [*] possibly surprising
4604  */
4605 STATIC
4606 bool
4607 S_looks_like_bool(pTHX_ OP *o)
4608 {
4609     dVAR;
4610     switch(o->op_type) {
4611         case OP_OR:
4612             return looks_like_bool(cLOGOPo->op_first);
4613
4614         case OP_AND:
4615             return (
4616                 looks_like_bool(cLOGOPo->op_first)
4617              && looks_like_bool(cLOGOPo->op_first->op_sibling));
4618
4619         case OP_ENTERSUB:
4620
4621         case OP_NOT:    case OP_XOR:
4622         /* Note that OP_DOR is not here */
4623
4624         case OP_EQ:     case OP_NE:     case OP_LT:
4625         case OP_GT:     case OP_LE:     case OP_GE:
4626
4627         case OP_I_EQ:   case OP_I_NE:   case OP_I_LT:
4628         case OP_I_GT:   case OP_I_LE:   case OP_I_GE:
4629
4630         case OP_SEQ:    case OP_SNE:    case OP_SLT:
4631         case OP_SGT:    case OP_SLE:    case OP_SGE:
4632
4633         case OP_SMARTMATCH:
4634
4635         case OP_FTRREAD:  case OP_FTRWRITE: case OP_FTREXEC:
4636         case OP_FTEREAD:  case OP_FTEWRITE: case OP_FTEEXEC:
4637         case OP_FTIS:     case OP_FTEOWNED: case OP_FTROWNED:
4638         case OP_FTZERO:   case OP_FTSOCK:   case OP_FTCHR:
4639         case OP_FTBLK:    case OP_FTFILE:   case OP_FTDIR:
4640         case OP_FTPIPE:   case OP_FTLINK:   case OP_FTSUID:
4641         case OP_FTSGID:   case OP_FTSVTX:   case OP_FTTTY:
4642         case OP_FTTEXT:   case OP_FTBINARY:
4643
4644         case OP_DEFINED: case OP_EXISTS:
4645         case OP_MATCH:   case OP_EOF:
4646
4647             return TRUE;
4648
4649         case OP_CONST:
4650             /* Detect comparisons that have been optimized away */
4651             if (cSVOPo->op_sv == &PL_sv_yes
4652             ||  cSVOPo->op_sv == &PL_sv_no)
4653
4654                 return TRUE;
4655
4656         /* FALL THROUGH */
4657         default:
4658             return FALSE;
4659     }
4660 }
4661
4662 OP *
4663 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
4664 {
4665     dVAR;
4666     assert( cond );
4667     return newGIVWHENOP(
4668         ref_array_or_hash(cond),
4669         block,
4670         OP_ENTERGIVEN, OP_LEAVEGIVEN,
4671         defsv_off);
4672 }
4673
4674 /* If cond is null, this is a default {} block */
4675 OP *
4676 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
4677 {
4678     bool cond_llb = (!cond || looks_like_bool(cond));
4679     OP *cond_op;
4680
4681     if (cond_llb)
4682         cond_op = cond;
4683     else {
4684         cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
4685                 newDEFSVOP(),
4686                 scalar(ref_array_or_hash(cond)));
4687     }
4688
4689     return newGIVWHENOP(
4690         cond_op,
4691         append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
4692         OP_ENTERWHEN, OP_LEAVEWHEN, 0);
4693 }
4694
4695 /*
4696 =for apidoc cv_undef
4697
4698 Clear out all the active components of a CV. This can happen either
4699 by an explicit C<undef &foo>, or by the reference count going to zero.
4700 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
4701 children can still follow the full lexical scope chain.
4702
4703 =cut
4704 */
4705
4706 void
4707 Perl_cv_undef(pTHX_ CV *cv)
4708 {
4709     dVAR;
4710 #ifdef USE_ITHREADS
4711     if (CvFILE(cv) && !CvISXSUB(cv)) {
4712         /* for XSUBs CvFILE point directly to static memory; __FILE__ */
4713         Safefree(CvFILE(cv));
4714     }
4715     CvFILE(cv) = 0;
4716 #endif
4717
4718     if (!CvISXSUB(cv) && CvROOT(cv)) {
4719         if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
4720             Perl_croak(aTHX_ "Can't undef active subroutine");
4721         ENTER;
4722
4723         PAD_SAVE_SETNULLPAD();
4724
4725         op_free(CvROOT(cv));
4726         CvROOT(cv) = NULL;
4727         CvSTART(cv) = NULL;
4728         LEAVE;
4729     }
4730     SvPOK_off((SV*)cv);         /* forget prototype */
4731     CvGV(cv) = NULL;
4732
4733     pad_undef(cv);
4734
4735     /* remove CvOUTSIDE unless this is an undef rather than a free */
4736     if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
4737         if (!CvWEAKOUTSIDE(cv))
4738             SvREFCNT_dec(CvOUTSIDE(cv));
4739         CvOUTSIDE(cv) = NULL;
4740     }
4741     if (CvCONST(cv)) {
4742         SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4743         CvCONST_off(cv);
4744     }
4745     if (CvISXSUB(cv) && CvXSUB(cv)) {
4746         CvXSUB(cv) = NULL;
4747     }
4748     /* delete all flags except WEAKOUTSIDE */
4749     CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
4750 }
4751
4752 void
4753 Perl_cv_ckproto(pTHX_ const CV *cv, const GV *gv, const char *p)
4754 {
4755     if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX_const(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4756         SV* const msg = sv_newmortal();
4757         SV* name = NULL;
4758
4759         if (gv)
4760             gv_efullname3(name = sv_newmortal(), gv, NULL);
4761         sv_setpv(msg, "Prototype mismatch:");
4762         if (name)
4763             Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4764         if (SvPOK(cv))
4765             Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (const SV *)cv);
4766         else
4767             sv_catpvs(msg, ": none");
4768         sv_catpvs(msg, " vs ");
4769         if (p)
4770             Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4771         else
4772             sv_catpvs(msg, "none");
4773         Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, msg);
4774     }
4775 }
4776
4777 static void const_sv_xsub(pTHX_ CV* cv);
4778
4779 /*
4780
4781 =head1 Optree Manipulation Functions
4782
4783 =for apidoc cv_const_sv
4784
4785 If C<cv> is a constant sub eligible for inlining. returns the constant
4786 value returned by the sub.  Otherwise, returns NULL.
4787
4788 Constant subs can be created with C<newCONSTSUB> or as described in
4789 L<perlsub/"Constant Functions">.
4790
4791 =cut
4792 */
4793 SV *
4794 Perl_cv_const_sv(pTHX_ CV *cv)
4795 {
4796     PERL_UNUSED_CONTEXT;
4797     if (!cv)
4798         return NULL;
4799     if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
4800         return NULL;
4801     return CvCONST(cv) ? (SV*)CvXSUBANY(cv).any_ptr : NULL;
4802 }
4803
4804 /* op_const_sv:  examine an optree to determine whether it's in-lineable.
4805  * Can be called in 3 ways:
4806  *
4807  * !cv
4808  *      look for a single OP_CONST with attached value: return the value
4809  *
4810  * cv && CvCLONE(cv) && !CvCONST(cv)
4811  *
4812  *      examine the clone prototype, and if contains only a single
4813  *      OP_CONST referencing a pad const, or a single PADSV referencing
4814  *      an outer lexical, return a non-zero value to indicate the CV is
4815  *      a candidate for "constizing" at clone time
4816  *
4817  * cv && CvCONST(cv)
4818  *
4819  *      We have just cloned an anon prototype that was marked as a const
4820  *      candidiate. Try to grab the current value, and in the case of
4821  *      PADSV, ignore it if it has multiple references. Return the value.
4822  */
4823
4824 SV *
4825 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
4826 {
4827     dVAR;
4828     SV *sv = NULL;
4829
4830     if (!o)
4831         return NULL;
4832
4833     if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4834         o = cLISTOPo->op_first->op_sibling;
4835
4836     for (; o; o = o->op_next) {
4837         const OPCODE type = o->op_type;
4838
4839         if (sv && o->op_next == o)
4840             return sv;
4841         if (o->op_next != o) {
4842             if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4843                 continue;
4844             if (type == OP_DBSTATE)
4845                 continue;
4846         }
4847         if (type == OP_LEAVESUB || type == OP_RETURN)
4848             break;
4849         if (sv)
4850             return NULL;
4851         if (type == OP_CONST && cSVOPo->op_sv)
4852             sv = cSVOPo->op_sv;
4853         else if (cv && type == OP_CONST) {
4854             sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4855             if (!sv)
4856                 return NULL;
4857         }
4858         else if (cv && type == OP_PADSV) {
4859             if (CvCONST(cv)) { /* newly cloned anon */
4860                 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4861                 /* the candidate should have 1 ref from this pad and 1 ref
4862                  * from the parent */
4863                 if (!sv || SvREFCNT(sv) != 2)
4864                     return NULL;
4865                 sv = newSVsv(sv);
4866                 SvREADONLY_on(sv);
4867                 return sv;
4868             }
4869             else {
4870                 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
4871                     sv = &PL_sv_undef; /* an arbitrary non-null value */
4872             }
4873         }
4874         else {
4875             return NULL;
4876         }
4877     }
4878     return sv;
4879 }
4880
4881 #ifdef PERL_MAD
4882 OP *
4883 #else
4884 void
4885 #endif
4886 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4887 {
4888 #if 0
4889     /* This would be the return value, but the return cannot be reached.  */
4890     OP* pegop = newOP(OP_NULL, 0);
4891 #endif
4892
4893     PERL_UNUSED_ARG(floor);
4894
4895     if (o)
4896         SAVEFREEOP(o);
4897     if (proto)
4898         SAVEFREEOP(proto);
4899     if (attrs)
4900         SAVEFREEOP(attrs);
4901     if (block)
4902         SAVEFREEOP(block);
4903     Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4904 #ifdef PERL_MAD
4905     NORETURN_FUNCTION_END;
4906 #endif
4907 }
4908
4909 CV *
4910 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4911 {
4912     return Perl_newATTRSUB(aTHX_ floor, o, proto, NULL, block);
4913 }
4914
4915 CV *
4916 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4917 {
4918     dVAR;
4919     const char *aname;
4920     GV *gv;
4921     const char *ps;
4922     STRLEN ps_len;
4923     register CV *cv = NULL;
4924     SV *const_sv;
4925     /* If the subroutine has no body, no attributes, and no builtin attributes
4926        then it's just a sub declaration, and we may be able to get away with
4927        storing with a placeholder scalar in the symbol table, rather than a
4928        full GV and CV.  If anything is present then it will take a full CV to
4929        store it.  */
4930     const I32 gv_fetch_flags
4931         = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
4932            || PL_madskills)
4933         ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
4934     const char * const name = o ? SvPVx_nolen_const(cSVOPo->op_sv) : NULL;
4935
4936     if (proto) {
4937         assert(proto->op_type == OP_CONST);
4938         ps = SvPVx_const(((SVOP*)proto)->op_sv, ps_len);
4939     }
4940     else
4941         ps = NULL;
4942
4943     if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4944         SV * const sv = sv_newmortal();
4945         Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
4946                        PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
4947                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4948         aname = SvPVX_const(sv);
4949     }
4950     else
4951         aname = NULL;
4952
4953     gv = name ? gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV)
4954         : gv_fetchpv(aname ? aname
4955                      : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4956                      gv_fetch_flags, SVt_PVCV);
4957
4958     if (!PL_madskills) {
4959         if (o)
4960             SAVEFREEOP(o);
4961         if (proto)
4962             SAVEFREEOP(proto);
4963         if (attrs)
4964             SAVEFREEOP(attrs);
4965     }
4966
4967     if (SvTYPE(gv) != SVt_PVGV) {       /* Maybe prototype now, and had at
4968                                            maximum a prototype before. */
4969         if (SvTYPE(gv) > SVt_NULL) {
4970             if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4971                 && ckWARN_d(WARN_PROTOTYPE))
4972             {
4973                 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
4974             }
4975             cv_ckproto((CV*)gv, NULL, ps);
4976         }
4977         if (ps)
4978             sv_setpvn((SV*)gv, ps, ps_len);
4979         else
4980             sv_setiv((SV*)gv, -1);
4981         SvREFCNT_dec(PL_compcv);
4982         cv = PL_compcv = NULL;
4983         PL_sub_generation++;
4984         goto done;
4985     }
4986
4987     cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
4988
4989 #ifdef GV_UNIQUE_CHECK
4990     if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4991         Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
4992     }
4993 #endif
4994
4995     if (!block || !ps || *ps || attrs
4996         || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
4997 #ifdef PERL_MAD
4998         || block->op_type == OP_NULL
4999 #endif
5000         )
5001         const_sv = NULL;
5002     else
5003         const_sv = op_const_sv(block, NULL);
5004
5005     if (cv) {
5006         const bool exists = CvROOT(cv) || CvXSUB(cv);
5007
5008 #ifdef GV_UNIQUE_CHECK
5009         if (exists && GvUNIQUE(gv)) {
5010             Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
5011         }
5012 #endif
5013
5014         /* if the subroutine doesn't exist and wasn't pre-declared
5015          * with a prototype, assume it will be AUTOLOADed,
5016          * skipping the prototype check
5017          */
5018         if (exists || SvPOK(cv))
5019             cv_ckproto(cv, gv, ps);
5020         /* already defined (or promised)? */
5021         if (exists || GvASSUMECV(gv)) {
5022             if ((!block
5023 #ifdef PERL_MAD
5024                  || block->op_type == OP_NULL
5025 #endif
5026                  )&& !attrs) {
5027                 if (CvFLAGS(PL_compcv)) {
5028                     /* might have had built-in attrs applied */
5029                     CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5030                 }
5031                 /* just a "sub foo;" when &foo is already defined */
5032                 SAVEFREESV(PL_compcv);
5033                 goto done;
5034             }
5035             if (block
5036 #ifdef PERL_MAD
5037                 && block->op_type != OP_NULL
5038 #endif
5039                 ) {
5040                 if (ckWARN(WARN_REDEFINE)
5041                     || (CvCONST(cv)
5042                         && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
5043                 {
5044                     const line_t oldline = CopLINE(PL_curcop);
5045                     if (PL_copline != NOLINE)
5046                         CopLINE_set(PL_curcop, PL_copline);
5047                     Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5048                         CvCONST(cv) ? "Constant subroutine %s redefined"
5049                                     : "Subroutine %s redefined", name);
5050                     CopLINE_set(PL_curcop, oldline);
5051                 }
5052 #ifdef PERL_MAD
5053                 if (!PL_minus_c)        /* keep old one around for madskills */
5054 #endif
5055                     {
5056                         /* (PL_madskills unset in used file.) */
5057                         SvREFCNT_dec(cv);
5058                     }
5059                 cv = NULL;
5060             }
5061         }
5062     }
5063     if (const_sv) {
5064         SvREFCNT_inc_void_NN(const_sv);
5065         if (cv) {
5066             assert(!CvROOT(cv) && !CvCONST(cv));
5067             sv_setpvn((SV*)cv, "", 0);  /* prototype is "" */
5068             CvXSUBANY(cv).any_ptr = const_sv;
5069             CvXSUB(cv) = const_sv_xsub;
5070             CvCONST_on(cv);
5071             CvISXSUB_on(cv);
5072         }
5073         else {
5074             GvCV(gv) = NULL;
5075             cv = newCONSTSUB(NULL, name, const_sv);
5076         }
5077         PL_sub_generation++;
5078         if (PL_madskills)
5079             goto install_block;
5080         op_free(block);
5081         SvREFCNT_dec(PL_compcv);
5082         PL_compcv = NULL;
5083         goto done;
5084     }
5085     if (attrs) {
5086         HV *stash;
5087         SV *rcv;
5088
5089         /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
5090          * before we clobber PL_compcv.
5091          */
5092         if (cv && (!block
5093 #ifdef PERL_MAD
5094                     || block->op_type == OP_NULL
5095 #endif
5096                     )) {
5097             rcv = (SV*)cv;
5098             /* Might have had built-in attributes applied -- propagate them. */
5099             CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5100             if (CvGV(cv) && GvSTASH(CvGV(cv)))
5101                 stash = GvSTASH(CvGV(cv));
5102             else if (CvSTASH(cv))
5103                 stash = CvSTASH(cv);
5104             else
5105                 stash = PL_curstash;
5106         }
5107         else {
5108             /* possibly about to re-define existing subr -- ignore old cv */
5109             rcv = (SV*)PL_compcv;
5110             if (name && GvSTASH(gv))
5111                 stash = GvSTASH(gv);
5112             else
5113                 stash = PL_curstash;
5114         }
5115         apply_attrs(stash, rcv, attrs, FALSE);
5116     }
5117     if (cv) {                           /* must reuse cv if autoloaded */
5118         if (
5119 #ifdef PERL_MAD
5120             (
5121 #endif
5122              !block
5123 #ifdef PERL_MAD
5124              || block->op_type == OP_NULL) && !PL_madskills
5125 #endif
5126              ) {
5127             /* got here with just attrs -- work done, so bug out */
5128             SAVEFREESV(PL_compcv);
5129             goto done;
5130         }
5131         /* transfer PL_compcv to cv */
5132         cv_undef(cv);
5133         CvFLAGS(cv) = CvFLAGS(PL_compcv);
5134         if (!CvWEAKOUTSIDE(cv))
5135             SvREFCNT_dec(CvOUTSIDE(cv));
5136         CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
5137         CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
5138         CvOUTSIDE(PL_compcv) = 0;
5139         CvPADLIST(cv) = CvPADLIST(PL_compcv);
5140         CvPADLIST(PL_compcv) = 0;
5141         /* inner references to PL_compcv must be fixed up ... */
5142         pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
5143         /* ... before we throw it away */
5144         SvREFCNT_dec(PL_compcv);
5145         PL_compcv = cv;
5146         if (PERLDB_INTER)/* Advice debugger on the new sub. */
5147           ++PL_sub_generation;
5148     }
5149     else {
5150         cv = PL_compcv;
5151         if (name) {
5152             GvCV(gv) = cv;
5153             if (PL_madskills) {
5154                 if (strEQ(name, "import")) {
5155                     PL_formfeed = (SV*)cv;
5156                     Perl_warner(aTHX_ packWARN(WARN_VOID), "%lx\n", (long)cv);
5157                 }
5158             }
5159             GvCVGEN(gv) = 0;
5160             PL_sub_generation++;
5161         }
5162     }
5163     CvGV(cv) = gv;
5164     CvFILE_set_from_cop(cv, PL_curcop);
5165     CvSTASH(cv) = PL_curstash;
5166
5167     if (ps)
5168         sv_setpvn((SV*)cv, ps, ps_len);
5169
5170     if (PL_error_count) {
5171         op_free(block);
5172         block = NULL;
5173         if (name) {
5174             const char *s = strrchr(name, ':');
5175             s = s ? s+1 : name;
5176             if (strEQ(s, "BEGIN")) {
5177                 const char not_safe[] =
5178                     "BEGIN not safe after errors--compilation aborted";
5179                 if (PL_in_eval & EVAL_KEEPERR)
5180                     Perl_croak(aTHX_ not_safe);
5181                 else {
5182                     /* force display of errors found but not reported */
5183                     sv_catpv(ERRSV, not_safe);
5184                     Perl_croak(aTHX_ "%"SVf, ERRSV);
5185                 }
5186             }
5187         }
5188     }
5189  install_block:
5190     if (!block)
5191         goto done;
5192
5193     if (CvLVALUE(cv)) {
5194         CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
5195                              mod(scalarseq(block), OP_LEAVESUBLV));
5196     }
5197     else {
5198         /* This makes sub {}; work as expected.  */
5199         if (block->op_type == OP_STUB) {
5200             OP* newblock = newSTATEOP(0, NULL, 0);
5201 #ifdef PERL_MAD
5202             op_getmad(block,newblock,'B');
5203 #else
5204             op_free(block);
5205 #endif
5206             block = newblock;
5207         }
5208         CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
5209     }
5210     CvROOT(cv)->op_private |= OPpREFCOUNTED;
5211     OpREFCNT_set(CvROOT(cv), 1);
5212     CvSTART(cv) = LINKLIST(CvROOT(cv));
5213     CvROOT(cv)->op_next = 0;
5214     CALL_PEEP(CvSTART(cv));
5215
5216     /* now that optimizer has done its work, adjust pad values */
5217
5218     pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
5219
5220     if (CvCLONE(cv)) {
5221         assert(!CvCONST(cv));
5222         if (ps && !*ps && op_const_sv(block, cv))
5223             CvCONST_on(cv);
5224     }
5225
5226     if (name || aname) {
5227         const char *s;
5228         const char * const tname = (name ? name : aname);
5229
5230         if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
5231             SV * const sv = newSV(0);
5232             SV * const tmpstr = sv_newmortal();
5233             GV * const db_postponed = gv_fetchpvs("DB::postponed",
5234                                                   GV_ADDMULTI, SVt_PVHV);
5235             HV *hv;
5236
5237             Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
5238                            CopFILE(PL_curcop),
5239                            (long)PL_subline, (long)CopLINE(PL_curcop));
5240             gv_efullname3(tmpstr, gv, NULL);
5241             hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr), SvCUR(tmpstr), sv, 0);
5242             hv = GvHVn(db_postponed);
5243             if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
5244                 CV * const pcv = GvCV(db_postponed);
5245                 if (pcv) {
5246                     dSP;
5247                     PUSHMARK(SP);
5248                     XPUSHs(tmpstr);
5249                     PUTBACK;
5250                     call_sv((SV*)pcv, G_DISCARD);
5251                 }
5252             }
5253         }
5254
5255         if ((s = strrchr(tname,':')))
5256             s++;
5257         else
5258             s = tname;
5259
5260         if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5261             goto done;
5262
5263         if (strEQ(s, "BEGIN") && !PL_error_count) {
5264             const I32 oldscope = PL_scopestack_ix;
5265             ENTER;
5266             SAVECOPFILE(&PL_compiling);
5267             SAVECOPLINE(&PL_compiling);
5268
5269             if (!PL_beginav)
5270                 PL_beginav = newAV();
5271             DEBUG_x( dump_sub(gv) );
5272             av_push(PL_beginav, (SV*)cv);
5273             GvCV(gv) = 0;               /* cv has been hijacked */
5274             call_list(oldscope, PL_beginav);
5275
5276             PL_curcop = &PL_compiling;
5277             PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
5278             LEAVE;
5279         }
5280         else if (strEQ(s, "END") && !PL_error_count) {
5281             if (!PL_endav)
5282                 PL_endav = newAV();
5283             DEBUG_x( dump_sub(gv) );
5284             av_unshift(PL_endav, 1);
5285             av_store(PL_endav, 0, (SV*)cv);
5286             GvCV(gv) = 0;               /* cv has been hijacked */
5287         }
5288         else if (strEQ(s, "CHECK") && !PL_error_count) {
5289             if (!PL_checkav)
5290                 PL_checkav = newAV();
5291             DEBUG_x( dump_sub(gv) );
5292             if (PL_main_start && ckWARN(WARN_VOID))
5293                 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
5294             av_unshift(PL_checkav, 1);
5295             av_store(PL_checkav, 0, (SV*)cv);
5296             GvCV(gv) = 0;               /* cv has been hijacked */
5297         }
5298         else if (strEQ(s, "INIT") && !PL_error_count) {
5299             if (!PL_initav)
5300                 PL_initav = newAV();
5301             DEBUG_x( dump_sub(gv) );
5302             if (PL_main_start && ckWARN(WARN_VOID))
5303                 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
5304             av_push(PL_initav, (SV*)cv);
5305             GvCV(gv) = 0;               /* cv has been hijacked */
5306         }
5307     }
5308
5309   done:
5310     PL_copline = NOLINE;
5311     LEAVE_SCOPE(floor);
5312     return cv;
5313 }
5314
5315 /* XXX unsafe for threads if eval_owner isn't held */
5316 /*
5317 =for apidoc newCONSTSUB
5318
5319 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
5320 eligible for inlining at compile-time.
5321
5322 =cut
5323 */
5324
5325 CV *
5326 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
5327 {
5328     dVAR;
5329     CV* cv;
5330
5331     ENTER;
5332
5333     SAVECOPLINE(PL_curcop);
5334     CopLINE_set(PL_curcop, PL_copline);
5335
5336     SAVEHINTS();
5337     PL_hints &= ~HINT_BLOCK_SCOPE;
5338
5339     if (stash) {
5340         SAVESPTR(PL_curstash);
5341         SAVECOPSTASH(PL_curcop);
5342         PL_curstash = stash;
5343         CopSTASH_set(PL_curcop,stash);
5344     }
5345
5346     cv = newXS(name, const_sv_xsub, savepv(CopFILE(PL_curcop)));
5347     CvXSUBANY(cv).any_ptr = sv;
5348     CvCONST_on(cv);
5349     sv_setpvn((SV*)cv, "", 0);  /* prototype is "" */
5350
5351 #ifdef USE_ITHREADS
5352     if (stash)
5353         CopSTASH_free(PL_curcop);
5354 #endif
5355     LEAVE;
5356
5357     return cv;
5358 }
5359
5360 /*
5361 =for apidoc U||newXS
5362
5363 Used by C<xsubpp> to hook up XSUBs as Perl subs.
5364
5365 =cut
5366 */
5367
5368 CV *
5369 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
5370 {
5371     dVAR;
5372     GV * const gv = gv_fetchpv(name ? name :
5373                         (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5374                         GV_ADDMULTI, SVt_PVCV);
5375     register CV *cv;
5376
5377     if (!subaddr)
5378         Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
5379
5380     if ((cv = (name ? GvCV(gv) : NULL))) {
5381         if (GvCVGEN(gv)) {
5382             /* just a cached method */
5383             SvREFCNT_dec(cv);
5384             cv = NULL;
5385         }
5386         else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
5387             /* already defined (or promised) */
5388             /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
5389             if (ckWARN(WARN_REDEFINE)) {
5390                 GV * const gvcv = CvGV(cv);
5391                 if (gvcv) {
5392                     HV * const stash = GvSTASH(gvcv);
5393                     if (stash) {
5394                         const char *redefined_name = HvNAME_get(stash);
5395                         if ( strEQ(redefined_name,"autouse") ) {
5396                             const line_t oldline = CopLINE(PL_curcop);
5397                             if (PL_copline != NOLINE)
5398                                 CopLINE_set(PL_curcop, PL_copline);
5399                             Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5400                                         CvCONST(cv) ? "Constant subroutine %s redefined"
5401                                                     : "Subroutine %s redefined"
5402                                         ,name);
5403                             CopLINE_set(PL_curcop, oldline);
5404                         }
5405                     }
5406                 }
5407             }
5408             SvREFCNT_dec(cv);
5409             cv = NULL;
5410         }
5411     }
5412
5413     if (cv)                             /* must reuse cv if autoloaded */
5414         cv_undef(cv);
5415     else {
5416         cv = (CV*)newSV(0);
5417         sv_upgrade((SV *)cv, SVt_PVCV);
5418         if (name) {
5419             GvCV(gv) = cv;
5420             GvCVGEN(gv) = 0;
5421             PL_sub_generation++;
5422         }
5423     }
5424     CvGV(cv) = gv;
5425     (void)gv_fetchfile(filename);
5426     CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
5427                                    an external constant string */
5428     CvISXSUB_on(cv);
5429     CvXSUB(cv) = subaddr;
5430
5431     if (name) {
5432         const char *s = strrchr(name,':');
5433         if (s)
5434             s++;
5435         else
5436             s = name;
5437
5438         if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5439             goto done;
5440
5441         if (strEQ(s, "BEGIN")) {
5442             if (!PL_beginav)
5443                 PL_beginav = newAV();
5444             av_push(PL_beginav, (SV*)cv);
5445             GvCV(gv) = 0;               /* cv has been hijacked */
5446         }
5447         else if (strEQ(s, "END")) {
5448             if (!PL_endav)
5449                 PL_endav = newAV();
5450             av_unshift(PL_endav, 1);
5451             av_store(PL_endav, 0, (SV*)cv);
5452             GvCV(gv) = 0;               /* cv has been hijacked */
5453         }
5454         else if (strEQ(s, "CHECK")) {
5455             if (!PL_checkav)
5456                 PL_checkav = newAV();
5457             if (PL_main_start && ckWARN(WARN_VOID))
5458                 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
5459             av_unshift(PL_checkav, 1);
5460             av_store(PL_checkav, 0, (SV*)cv);
5461             GvCV(gv) = 0;               /* cv has been hijacked */
5462         }
5463         else if (strEQ(s, "INIT")) {
5464             if (!PL_initav)
5465                 PL_initav = newAV();
5466             if (PL_main_start && ckWARN(WARN_VOID))
5467                 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
5468             av_push(PL_initav, (SV*)cv);
5469             GvCV(gv) = 0;               /* cv has been hijacked */
5470         }
5471     }
5472     else
5473         CvANON_on(cv);
5474
5475 done:
5476     return cv;
5477 }
5478
5479 #ifdef PERL_MAD
5480 OP *
5481 #else
5482 void
5483 #endif
5484 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
5485 {
5486     dVAR;
5487     register CV *cv;
5488 #ifdef PERL_MAD
5489     OP* pegop = newOP(OP_NULL, 0);
5490 #endif
5491
5492     GV * const gv = o
5493         ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
5494         : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
5495
5496 #ifdef GV_UNIQUE_CHECK
5497     if (GvUNIQUE(gv)) {
5498         Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
5499     }
5500 #endif
5501     GvMULTI_on(gv);
5502     if ((cv = GvFORM(gv))) {
5503         if (ckWARN(WARN_REDEFINE)) {
5504             const line_t oldline = CopLINE(PL_curcop);
5505             if (PL_copline != NOLINE)
5506                 CopLINE_set(PL_curcop, PL_copline);
5507             Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5508                         o ? "Format %"SVf" redefined"
5509                         : "Format STDOUT redefined" ,cSVOPo->op_sv);
5510             CopLINE_set(PL_curcop, oldline);
5511         }
5512         SvREFCNT_dec(cv);
5513     }
5514     cv = PL_compcv;
5515     GvFORM(gv) = cv;
5516     CvGV(cv) = gv;
5517     CvFILE_set_from_cop(cv, PL_curcop);
5518
5519
5520     pad_tidy(padtidy_FORMAT);
5521     CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5522     CvROOT(cv)->op_private |= OPpREFCOUNTED;
5523     OpREFCNT_set(CvROOT(cv), 1);
5524     CvSTART(cv) = LINKLIST(CvROOT(cv));
5525     CvROOT(cv)->op_next = 0;
5526     CALL_PEEP(CvSTART(cv));
5527 #ifdef PERL_MAD
5528     op_getmad(o,pegop,'n');
5529     op_getmad_weak(block, pegop, 'b');
5530 #else
5531     op_free(o);
5532 #endif
5533     PL_copline = NOLINE;
5534     LEAVE_SCOPE(floor);
5535 #ifdef PERL_MAD
5536     return pegop;
5537 #endif
5538 }
5539
5540 OP *
5541 Perl_newANONLIST(pTHX_ OP *o)
5542 {
5543     return newUNOP(OP_REFGEN, 0,
5544         mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
5545 }
5546
5547 OP *
5548 Perl_newANONHASH(pTHX_ OP *o)
5549 {
5550     return newUNOP(OP_REFGEN, 0,
5551         mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
5552 }
5553
5554 OP *
5555 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5556 {
5557     return newANONATTRSUB(floor, proto, NULL, block);
5558 }
5559
5560 OP *
5561 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5562 {
5563     return newUNOP(OP_REFGEN, 0,
5564         newSVOP(OP_ANONCODE, 0,
5565                 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5566 }
5567
5568 OP *
5569 Perl_oopsAV(pTHX_ OP *o)
5570 {
5571     dVAR;
5572     switch (o->op_type) {
5573     case OP_PADSV:
5574         o->op_type = OP_PADAV;
5575         o->op_ppaddr = PL_ppaddr[OP_PADAV];
5576         return ref(o, OP_RV2AV);
5577
5578     case OP_RV2SV:
5579         o->op_type = OP_RV2AV;
5580         o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5581         ref(o, OP_RV2AV);
5582         break;
5583
5584     default:
5585         if (ckWARN_d(WARN_INTERNAL))
5586             Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
5587         break;
5588     }
5589     return o;
5590 }
5591
5592 OP *
5593 Perl_oopsHV(pTHX_ OP *o)
5594 {
5595     dVAR;
5596     switch (o->op_type) {
5597     case OP_PADSV:
5598     case OP_PADAV:
5599         o->op_type = OP_PADHV;
5600         o->op_ppaddr = PL_ppaddr[OP_PADHV];
5601         return ref(o, OP_RV2HV);
5602
5603     case OP_RV2SV:
5604     case OP_RV2AV:
5605         o->op_type = OP_RV2HV;
5606         o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5607         ref(o, OP_RV2HV);
5608         break;
5609
5610     default:
5611         if (ckWARN_d(WARN_INTERNAL))
5612             Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
5613         break;
5614     }
5615     return o;
5616 }
5617
5618 OP *
5619 Perl_newAVREF(pTHX_ OP *o)
5620 {
5621     dVAR;
5622     if (o->op_type == OP_PADANY) {
5623         o->op_type = OP_PADAV;
5624         o->op_ppaddr = PL_ppaddr[OP_PADAV];
5625         return o;
5626     }
5627     else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
5628                 && ckWARN(WARN_DEPRECATED)) {
5629         Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5630                 "Using an array as a reference is deprecated");
5631     }
5632     return newUNOP(OP_RV2AV, 0, scalar(o));
5633 }
5634
5635 OP *
5636 Perl_newGVREF(pTHX_ I32 type, OP *o)
5637 {
5638     if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5639         return newUNOP(OP_NULL, 0, o);
5640     return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5641 }
5642
5643 OP *
5644 Perl_newHVREF(pTHX_ OP *o)
5645 {
5646     dVAR;
5647     if (o->op_type == OP_PADANY) {
5648         o->op_type = OP_PADHV;
5649         o->op_ppaddr = PL_ppaddr[OP_PADHV];
5650         return o;
5651     }
5652     else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
5653                 && ckWARN(WARN_DEPRECATED)) {
5654         Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5655                 "Using a hash as a reference is deprecated");
5656     }
5657     return newUNOP(OP_RV2HV, 0, scalar(o));
5658 }
5659
5660 OP *
5661 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5662 {
5663     return newUNOP(OP_RV2CV, flags, scalar(o));
5664 }
5665
5666 OP *
5667 Perl_newSVREF(pTHX_ OP *o)
5668 {
5669     dVAR;
5670     if (o->op_type == OP_PADANY) {
5671         o->op_type = OP_PADSV;
5672         o->op_ppaddr = PL_ppaddr[OP_PADSV];
5673         return o;
5674     }
5675     else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5676         o->op_flags |= OPpDONE_SVREF;
5677         return o;
5678     }
5679     return newUNOP(OP_RV2SV, 0, scalar(o));
5680 }
5681
5682 /* Check routines. See the comments at the top of this file for details
5683  * on when these are called */
5684
5685 OP *
5686 Perl_ck_anoncode(pTHX_ OP *o)
5687 {
5688     cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
5689     if (!PL_madskills)
5690         cSVOPo->op_sv = Nullsv;
5691     return o;
5692 }
5693
5694 OP *
5695 Perl_ck_bitop(pTHX_ OP *o)
5696 {
5697     dVAR;
5698 #define OP_IS_NUMCOMPARE(op) \
5699         ((op) == OP_LT   || (op) == OP_I_LT || \
5700          (op) == OP_GT   || (op) == OP_I_GT || \
5701          (op) == OP_LE   || (op) == OP_I_LE || \
5702          (op) == OP_GE   || (op) == OP_I_GE || \
5703          (op) == OP_EQ   || (op) == OP_I_EQ || \
5704          (op) == OP_NE   || (op) == OP_I_NE || \
5705          (op) == OP_NCMP || (op) == OP_I_NCMP)
5706     o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
5707     if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
5708             && (o->op_type == OP_BIT_OR
5709              || o->op_type == OP_BIT_AND
5710              || o->op_type == OP_BIT_XOR))
5711     {
5712         const OP * const left = cBINOPo->op_first;
5713         const OP * const right = left->op_sibling;
5714         if ((OP_IS_NUMCOMPARE(left->op_type) &&
5715                 (left->op_flags & OPf_PARENS) == 0) ||
5716             (OP_IS_NUMCOMPARE(right->op_type) &&
5717                 (right->op_flags & OPf_PARENS) == 0))
5718             if (ckWARN(WARN_PRECEDENCE))
5719                 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
5720                         "Possible precedence problem on bitwise %c operator",
5721                         o->op_type == OP_BIT_OR ? '|'
5722                             : o->op_type == OP_BIT_AND ? '&' : '^'
5723                         );
5724     }
5725     return o;
5726 }
5727
5728 OP *
5729 Perl_ck_concat(pTHX_ OP *o)
5730 {
5731     const OP * const kid = cUNOPo->op_first;
5732     PERL_UNUSED_CONTEXT;
5733     if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
5734             !(kUNOP->op_first->op_flags & OPf_MOD))
5735         o->op_flags |= OPf_STACKED;
5736     return o;
5737 }
5738
5739 OP *
5740 Perl_ck_spair(pTHX_ OP *o)
5741 {
5742     dVAR;
5743     if (o->op_flags & OPf_KIDS) {
5744         OP* newop;
5745         OP* kid;
5746         const OPCODE type = o->op_type;
5747         o = modkids(ck_fun(o), type);
5748         kid = cUNOPo->op_first;
5749         newop = kUNOP->op_first->op_sibling;
5750         if (newop &&
5751             (newop->op_sibling ||
5752              !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
5753              newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5754              newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
5755
5756             return o;
5757         }
5758 #ifdef PERL_MAD
5759         op_getmad(kUNOP->op_first,newop,'K');
5760 #else
5761         op_free(kUNOP->op_first);
5762 #endif
5763         kUNOP->op_first = newop;
5764     }
5765     o->op_ppaddr = PL_ppaddr[++o->op_type];
5766     return ck_fun(o);
5767 }
5768
5769 OP *
5770 Perl_ck_delete(pTHX_ OP *o)
5771 {
5772     o = ck_fun(o);
5773     o->op_private = 0;
5774     if (o->op_flags & OPf_KIDS) {
5775         OP * const kid = cUNOPo->op_first;
5776         switch (kid->op_type) {
5777         case OP_ASLICE:
5778             o->op_flags |= OPf_SPECIAL;
5779             /* FALL THROUGH */
5780         case OP_HSLICE:
5781             o->op_private |= OPpSLICE;
5782             break;
5783         case OP_AELEM:
5784             o->op_flags |= OPf_SPECIAL;
5785             /* FALL THROUGH */
5786         case OP_HELEM:
5787             break;
5788         default:
5789             Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5790                   OP_DESC(o));
5791         }
5792         op_null(kid);
5793     }
5794     return o;
5795 }
5796
5797 OP *
5798 Perl_ck_die(pTHX_ OP *o)
5799 {
5800 #ifdef VMS
5801     if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5802 #endif
5803     return ck_fun(o);
5804 }
5805
5806 OP *
5807 Perl_ck_eof(pTHX_ OP *o)
5808 {
5809     dVAR;
5810     const I32 type = o->op_type;
5811
5812     if (o->op_flags & OPf_KIDS) {
5813         if (cLISTOPo->op_first->op_type == OP_STUB) {
5814             OP* newop
5815                 = newUNOP(type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
5816 #ifdef PERL_MAD
5817             op_getmad(o,newop,'O');
5818 #else
5819             op_free(o);
5820 #endif
5821             o = newop;
5822         }
5823         return ck_fun(o);
5824     }
5825     return o;
5826 }
5827
5828 OP *
5829 Perl_ck_eval(pTHX_ OP *o)
5830 {
5831     dVAR;
5832     PL_hints |= HINT_BLOCK_SCOPE;
5833     if (o->op_flags & OPf_KIDS) {
5834         SVOP * const kid = (SVOP*)cUNOPo->op_first;
5835
5836         if (!kid) {
5837             o->op_flags &= ~OPf_KIDS;
5838             op_null(o);
5839         }
5840         else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
5841             LOGOP *enter;
5842 #ifdef PERL_MAD
5843             OP* oldo = o;
5844 #endif
5845
5846             cUNOPo->op_first = 0;
5847 #ifndef PERL_MAD
5848             op_free(o);
5849 #endif
5850
5851             NewOp(1101, enter, 1, LOGOP);
5852             enter->op_type = OP_ENTERTRY;
5853             enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5854             enter->op_private = 0;
5855
5856             /* establish postfix order */
5857             enter->op_next = (OP*)enter;
5858
5859             o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5860             o->op_type = OP_LEAVETRY;
5861             o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5862             enter->op_other = o;
5863             op_getmad(oldo,o,'O');
5864             return o;
5865         }
5866         else {
5867             scalar((OP*)kid);
5868             PL_cv_has_eval = 1;
5869         }
5870     }
5871     else {
5872 #ifdef PERL_MAD
5873         OP* oldo = o;
5874 #else
5875         op_free(o);
5876 #endif
5877         o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5878         op_getmad(oldo,o,'O');
5879     }
5880     o->op_targ = (PADOFFSET)PL_hints;
5881     if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
5882         /* Store a copy of %^H that pp_entereval can pick up */
5883         OP *hhop = newSVOP(OP_CONST, 0, (SV*)newHVhv(GvHV(PL_hintgv)));
5884         cUNOPo->op_first->op_sibling = hhop;
5885         o->op_private |= OPpEVAL_HAS_HH;
5886     }
5887     return o;
5888 }
5889
5890 OP *
5891 Perl_ck_exit(pTHX_ OP *o)
5892 {
5893 #ifdef VMS
5894     HV * const table = GvHV(PL_hintgv);
5895     if (table) {
5896        SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
5897        if (svp && *svp && SvTRUE(*svp))
5898            o->op_private |= OPpEXIT_VMSISH;
5899     }
5900     if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5901 #endif
5902     return ck_fun(o);
5903 }
5904
5905 OP *
5906 Perl_ck_exec(pTHX_ OP *o)
5907 {
5908     if (o->op_flags & OPf_STACKED) {
5909         OP *kid;
5910         o = ck_fun(o);
5911         kid = cUNOPo->op_first->op_sibling;
5912         if (kid->op_type == OP_RV2GV)
5913             op_null(kid);
5914     }
5915     else
5916         o = listkids(o);
5917     return o;
5918 }
5919
5920 OP *
5921 Perl_ck_exists(pTHX_ OP *o)
5922 {
5923     dVAR;
5924     o = ck_fun(o);
5925     if (o->op_flags & OPf_KIDS) {
5926         OP * const kid = cUNOPo->op_first;
5927         if (kid->op_type == OP_ENTERSUB) {
5928             (void) ref(kid, o->op_type);
5929             if (kid->op_type != OP_RV2CV && !PL_error_count)
5930                 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5931                             OP_DESC(o));
5932             o->op_private |= OPpEXISTS_SUB;
5933         }
5934         else if (kid->op_type == OP_AELEM)
5935             o->op_flags |= OPf_SPECIAL;
5936         else if (kid->op_type != OP_HELEM)
5937             Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5938                         OP_DESC(o));
5939         op_null(kid);
5940     }
5941     return o;
5942 }
5943
5944 OP *
5945 Perl_ck_rvconst(pTHX_ register OP *o)
5946 {
5947     dVAR;
5948     SVOP * const kid = (SVOP*)cUNOPo->op_first;
5949
5950     o->op_private |= (PL_hints & HINT_STRICT_REFS);
5951     if (o->op_type == OP_RV2CV)
5952         o->op_private &= ~1;
5953
5954     if (kid->op_type == OP_CONST) {
5955         int iscv;
5956         GV *gv;
5957         SV * const kidsv = kid->op_sv;
5958
5959         /* Is it a constant from cv_const_sv()? */
5960         if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5961             SV * const rsv = SvRV(kidsv);
5962             const int svtype = SvTYPE(rsv);
5963             const char *badtype = NULL;
5964
5965             switch (o->op_type) {
5966             case OP_RV2SV:
5967                 if (svtype > SVt_PVMG)
5968                     badtype = "a SCALAR";
5969                 break;
5970             case OP_RV2AV:
5971                 if (svtype != SVt_PVAV)
5972                     badtype = "an ARRAY";
5973                 break;
5974             case OP_RV2HV:
5975                 if (svtype != SVt_PVHV)
5976                     badtype = "a HASH";
5977                 break;
5978             case OP_RV2CV:
5979                 if (svtype != SVt_PVCV)
5980                     badtype = "a CODE";
5981                 break;
5982             }
5983             if (badtype)
5984                 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5985             return o;
5986         }
5987         else if ((o->op_type == OP_RV2HV || o->op_type == OP_RV2SV) &&
5988                 (PL_hints & HINT_STRICT_REFS) && SvPOK(kidsv)) {
5989             /* If this is an access to a stash, disable "strict refs", because
5990              * stashes aren't auto-vivified at compile-time (unless we store
5991              * symbols in them), and we don't want to produce a run-time
5992              * stricture error when auto-vivifying the stash. */
5993             const char *s = SvPV_nolen(kidsv);
5994             const STRLEN l = SvCUR(kidsv);
5995             if (l > 1 && s[l-1] == ':' && s[l-2] == ':')
5996                 o->op_private &= ~HINT_STRICT_REFS;
5997         }
5998         if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5999             const char *badthing;
6000             switch (o->op_type) {
6001             case OP_RV2SV:
6002                 badthing = "a SCALAR";
6003                 break;
6004             case OP_RV2AV:
6005                 badthing = "an ARRAY";
6006                 break;
6007             case OP_RV2HV:
6008                 badthing = "a HASH";
6009                 break;
6010             default:
6011                 badthing = NULL;
6012                 break;
6013             }
6014             if (badthing)
6015                 Perl_croak(aTHX_
6016           "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
6017                       kidsv, badthing);
6018         }
6019         /*
6020          * This is a little tricky.  We only want to add the symbol if we
6021          * didn't add it in the lexer.  Otherwise we get duplicate strict
6022          * warnings.  But if we didn't add it in the lexer, we must at
6023          * least pretend like we wanted to add it even if it existed before,
6024          * or we get possible typo warnings.  OPpCONST_ENTERED says
6025          * whether the lexer already added THIS instance of this symbol.
6026          */
6027         iscv = (o->op_type == OP_RV2CV) * 2;
6028         do {
6029             gv = gv_fetchsv(kidsv,
6030                 iscv | !(kid->op_private & OPpCONST_ENTERED),
6031                 iscv
6032                     ? SVt_PVCV
6033                     : o->op_type == OP_RV2SV
6034                         ? SVt_PV
6035                         : o->op_type == OP_RV2AV
6036                             ? SVt_PVAV
6037                             : o->op_type == OP_RV2HV
6038                                 ? SVt_PVHV
6039                                 : SVt_PVGV);
6040         } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
6041         if (gv) {
6042             kid->op_type = OP_GV;
6043             SvREFCNT_dec(kid->op_sv);
6044 #ifdef USE_ITHREADS
6045             /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
6046             kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
6047             SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
6048             GvIN_PAD_on(gv);
6049             PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc_simple_NN(gv));
6050 #else
6051             kid->op_sv = SvREFCNT_inc_simple_NN(gv);
6052 #endif
6053             kid->op_private = 0;
6054             kid->op_ppaddr = PL_ppaddr[OP_GV];
6055         }
6056     }
6057     return o;
6058 }
6059
6060 OP *
6061 Perl_ck_ftst(pTHX_ OP *o)
6062 {
6063     dVAR;
6064     const I32 type = o->op_type;
6065
6066     if (o->op_flags & OPf_REF) {
6067         /*EMPTY*/;
6068     }
6069     else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
6070         SVOP * const kid = (SVOP*)cUNOPo->op_first;
6071
6072         if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6073             OP * const newop = newGVOP(type, OPf_REF,
6074                 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
6075 #ifdef PERL_MAD
6076             op_getmad(o,newop,'O');
6077 #else
6078             op_free(o);
6079 #endif
6080             o = newop;
6081             return o;
6082         }
6083         else {
6084           if ((PL_hints & HINT_FILETEST_ACCESS) &&
6085               OP_IS_FILETEST_ACCESS(o))
6086             o->op_private |= OPpFT_ACCESS;
6087         }
6088         if (PL_check[kid->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst)
6089                 && kid->op_type != OP_STAT && kid->op_type != OP_LSTAT)
6090             o->op_private |= OPpFT_STACKED;
6091     }
6092     else {
6093 #ifdef PERL_MAD
6094         OP* oldo = o;
6095 #else
6096         op_free(o);
6097 #endif
6098         if (type == OP_FTTTY)
6099             o = newGVOP(type, OPf_REF, PL_stdingv);
6100         else
6101             o = newUNOP(type, 0, newDEFSVOP());
6102         op_getmad(oldo,o,'O');
6103     }
6104     return o;
6105 }
6106
6107 OP *
6108 Perl_ck_fun(pTHX_ OP *o)
6109 {
6110     dVAR;
6111     const int type = o->op_type;
6112     register I32 oa = PL_opargs[type] >> OASHIFT;
6113
6114     if (o->op_flags & OPf_STACKED) {
6115         if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
6116             oa &= ~OA_OPTIONAL;
6117         else
6118             return no_fh_allowed(o);
6119     }
6120
6121     if (o->op_flags & OPf_KIDS) {
6122         OP **tokid = &cLISTOPo->op_first;
6123         register OP *kid = cLISTOPo->op_first;
6124         OP *sibl;
6125         I32 numargs = 0;
6126
6127         if (kid->op_type == OP_PUSHMARK ||
6128             (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
6129         {
6130             tokid = &kid->op_sibling;
6131             kid = kid->op_sibling;
6132         }
6133         if (!kid && PL_opargs[type] & OA_DEFGV)
6134             *tokid = kid = newDEFSVOP();
6135
6136         while (oa && kid) {
6137             numargs++;
6138             sibl = kid->op_sibling;
6139 #ifdef PERL_MAD
6140             if (!sibl && kid->op_type == OP_STUB) {
6141                 numargs--;
6142                 break;
6143             }
6144 #endif
6145             switch (oa & 7) {
6146             case OA_SCALAR:
6147                 /* list seen where single (scalar) arg expected? */
6148                 if (numargs == 1 && !(oa >> 4)
6149                     && kid->op_type == OP_LIST && type != OP_SCALAR)
6150                 {
6151                     return too_many_arguments(o,PL_op_desc[type]);
6152                 }
6153                 scalar(kid);
6154                 break;
6155             case OA_LIST:
6156                 if (oa < 16) {
6157                     kid = 0;
6158                     continue;
6159                 }
6160                 else
6161                     list(kid);
6162                 break;
6163             case OA_AVREF:
6164                 if ((type == OP_PUSH || type == OP_UNSHIFT)
6165                     && !kid->op_sibling && ckWARN(WARN_SYNTAX))
6166                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6167                         "Useless use of %s with no values",
6168                         PL_op_desc[type]);
6169
6170                 if (kid->op_type == OP_CONST &&
6171                     (kid->op_private & OPpCONST_BARE))
6172                 {
6173                     OP * const newop = newAVREF(newGVOP(OP_GV, 0,
6174                         gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
6175                     if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6176                         Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6177                             "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
6178                             ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
6179 #ifdef PERL_MAD
6180                     op_getmad(kid,newop,'K');
6181 #else
6182                     op_free(kid);
6183 #endif
6184                     kid = newop;
6185                     kid->op_sibling = sibl;
6186                     *tokid = kid;
6187                 }
6188                 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
6189                     bad_type(numargs, "array", PL_op_desc[type], kid);
6190                 mod(kid, type);
6191                 break;
6192             case OA_HVREF:
6193                 if (kid->op_type == OP_CONST &&
6194                     (kid->op_private & OPpCONST_BARE))
6195                 {
6196                     OP * const newop = newHVREF(newGVOP(OP_GV, 0,
6197                         gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
6198                     if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6199                         Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6200                             "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
6201                             ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
6202 #ifdef PERL_MAD
6203                     op_getmad(kid,newop,'K');
6204 #else
6205                     op_free(kid);
6206 #endif
6207                     kid = newop;
6208                     kid->op_sibling = sibl;
6209                     *tokid = kid;
6210                 }
6211                 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
6212                     bad_type(numargs, "hash", PL_op_desc[type], kid);
6213                 mod(kid, type);
6214                 break;
6215             case OA_CVREF:
6216                 {
6217                     OP * const newop = newUNOP(OP_NULL, 0, kid);
6218                     kid->op_sibling = 0;
6219                     linklist(kid);
6220                     newop->op_next = newop;
6221                     kid = newop;
6222                     kid->op_sibling = sibl;
6223                     *tokid = kid;
6224                 }
6225                 break;
6226             case OA_FILEREF:
6227                 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
6228                     if (kid->op_type == OP_CONST &&
6229                         (kid->op_private & OPpCONST_BARE))
6230                     {
6231                         OP * const newop = newGVOP(OP_GV, 0,
6232                             gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
6233                         if (!(o->op_private & 1) && /* if not unop */
6234                             kid == cLISTOPo->op_last)
6235                             cLISTOPo->op_last = newop;
6236 #ifdef PERL_MAD
6237                         op_getmad(kid,newop,'K');
6238 #else
6239                         op_free(kid);
6240 #endif
6241                         kid = newop;
6242                     }
6243                     else if (kid->op_type == OP_READLINE) {
6244                         /* neophyte patrol: open(<FH>), close(<FH>) etc. */
6245                         bad_type(numargs, "HANDLE", OP_DESC(o), kid);
6246                     }
6247                     else {
6248                         I32 flags = OPf_SPECIAL;
6249                         I32 priv = 0;
6250                         PADOFFSET targ = 0;
6251
6252                         /* is this op a FH constructor? */
6253                         if (is_handle_constructor(o,numargs)) {
6254                             const char *name = NULL;
6255                             STRLEN len = 0;
6256
6257                             flags = 0;
6258                             /* Set a flag to tell rv2gv to vivify
6259                              * need to "prove" flag does not mean something
6260                              * else already - NI-S 1999/05/07
6261                              */
6262                             priv = OPpDEREF;
6263                             if (kid->op_type == OP_PADSV) {
6264                                 name = PAD_COMPNAME_PV(kid->op_targ);
6265                                 /* SvCUR of a pad namesv can't be trusted
6266                                  * (see PL_generation), so calc its length
6267                                  * manually */
6268                                 if (name)
6269                                     len = strlen(name);
6270
6271                             }
6272                             else if (kid->op_type == OP_RV2SV
6273                                      && kUNOP->op_first->op_type == OP_GV)
6274                             {
6275                                 GV * const gv = cGVOPx_gv(kUNOP->op_first);
6276                                 name = GvNAME(gv);
6277                                 len = GvNAMELEN(gv);
6278                             }
6279                             else if (kid->op_type == OP_AELEM
6280                                      || kid->op_type == OP_HELEM)
6281                             {
6282                                  OP *op = ((BINOP*)kid)->op_first;
6283                                  name = NULL;
6284                                  if (op) {
6285                                       SV *tmpstr = NULL;
6286                                       const char * const a =
6287                                            kid->op_type == OP_AELEM ?
6288                                            "[]" : "{}";
6289                                       if (((op->op_type == OP_RV2AV) ||
6290                                            (op->op_type == OP_RV2HV)) &&
6291                                           (op = ((UNOP*)op)->op_first) &&
6292                                           (op->op_type == OP_GV)) {
6293                                            /* packagevar $a[] or $h{} */
6294                                            GV * const gv = cGVOPx_gv(op);
6295                                            if (gv)
6296                                                 tmpstr =
6297                                                      Perl_newSVpvf(aTHX_
6298                                                                    "%s%c...%c",
6299                                                                    GvNAME(gv),
6300                                                                    a[0], a[1]);
6301                                       }
6302                                       else if (op->op_type == OP_PADAV
6303                                                || op->op_type == OP_PADHV) {
6304                                            /* lexicalvar $a[] or $h{} */
6305                                            const char * const padname =
6306                                                 PAD_COMPNAME_PV(op->op_targ);
6307                                            if (padname)
6308                                                 tmpstr =
6309                                                      Perl_newSVpvf(aTHX_
6310                                                                    "%s%c...%c",
6311                                                                    padname + 1,
6312                                                                    a[0], a[1]);
6313                                       }
6314                                       if (tmpstr) {
6315                                            name = SvPV_const(tmpstr, len);
6316                                            sv_2mortal(tmpstr);
6317                                       }
6318                                  }
6319                                  if (!name) {
6320                                       name = "__ANONIO__";
6321                                       len = 10;
6322                                  }
6323                                  mod(kid, type);
6324                             }
6325                             if (name) {
6326                                 SV *namesv;
6327                                 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
6328                                 namesv = PAD_SVl(targ);
6329                                 SvUPGRADE(namesv, SVt_PV);
6330                                 if (*name != '$')
6331                                     sv_setpvn(namesv, "$", 1);
6332                                 sv_catpvn(namesv, name, len);
6333                             }
6334                         }
6335                         kid->op_sibling = 0;
6336                         kid = newUNOP(OP_RV2GV, flags, scalar(kid));
6337                         kid->op_targ = targ;
6338                         kid->op_private |= priv;
6339                     }
6340                     kid->op_sibling = sibl;
6341                     *tokid = kid;
6342                 }
6343                 scalar(kid);
6344                 break;
6345             case OA_SCALARREF:
6346                 mod(scalar(kid), type);
6347                 break;
6348             }
6349             oa >>= 4;
6350             tokid = &kid->op_sibling;
6351             kid = kid->op_sibling;
6352         }
6353 #ifdef PERL_MAD
6354         if (kid && kid->op_type != OP_STUB)
6355             return too_many_arguments(o,OP_DESC(o));
6356         o->op_private |= numargs;
6357 #else
6358         /* FIXME - should the numargs move as for the PERL_MAD case?  */
6359         o->op_private |= numargs;
6360         if (kid)
6361             return too_many_arguments(o,OP_DESC(o));
6362 #endif
6363         listkids(o);
6364     }
6365     else if (PL_opargs[type] & OA_DEFGV) {
6366         OP *newop = newUNOP(type, 0, newDEFSVOP());
6367 #ifdef PERL_MAD
6368         op_getmad(o,newop,'O');
6369 #else
6370         op_free(o);
6371 #endif
6372         return newop;
6373     }
6374
6375     if (oa) {
6376         while (oa & OA_OPTIONAL)
6377             oa >>= 4;
6378         if (oa && oa != OA_LIST)
6379             return too_few_arguments(o,OP_DESC(o));
6380     }
6381     return o;
6382 }
6383
6384 OP *
6385 Perl_ck_glob(pTHX_ OP *o)
6386 {
6387     dVAR;
6388     GV *gv;
6389
6390     o = ck_fun(o);
6391     if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
6392         append_elem(OP_GLOB, o, newDEFSVOP());
6393
6394     if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
6395           && GvCVu(gv) && GvIMPORTED_CV(gv)))
6396     {
6397         gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
6398     }
6399
6400 #if !defined(PERL_EXTERNAL_GLOB)
6401     /* XXX this can be tightened up and made more failsafe. */
6402     if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
6403         GV *glob_gv;
6404         ENTER;
6405         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
6406                 newSVpvs("File::Glob"), NULL, NULL, NULL);
6407         gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
6408         glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV);
6409         GvCV(gv) = GvCV(glob_gv);
6410         SvREFCNT_inc_void((SV*)GvCV(gv));
6411         GvIMPORTED_CV_on(gv);
6412         LEAVE;
6413     }
6414 #endif /* PERL_EXTERNAL_GLOB */
6415
6416     if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6417         append_elem(OP_GLOB, o,
6418                     newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
6419         o->op_type = OP_LIST;
6420         o->op_ppaddr = PL_ppaddr[OP_LIST];
6421         cLISTOPo->op_first->op_type = OP_PUSHMARK;
6422         cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
6423         cLISTOPo->op_first->op_targ = 0;
6424         o = newUNOP(OP_ENTERSUB, OPf_STACKED,
6425                     append_elem(OP_LIST, o,
6426                                 scalar(newUNOP(OP_RV2CV, 0,
6427                                                newGVOP(OP_GV, 0, gv)))));
6428         o = newUNOP(OP_NULL, 0, ck_subr(o));
6429         o->op_targ = OP_GLOB;           /* hint at what it used to be */
6430         return o;
6431     }
6432     gv = newGVgen("main");
6433     gv_IOadd(gv);
6434     append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
6435     scalarkids(o);
6436     return o;
6437 }
6438
6439 OP *
6440 Perl_ck_grep(pTHX_ OP *o)
6441 {
6442     dVAR;
6443     LOGOP *gwop;
6444     OP *kid;
6445     const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
6446     I32 offset;
6447
6448     o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
6449     NewOp(1101, gwop, 1, LOGOP);
6450
6451     if (o->op_flags & OPf_STACKED) {
6452         OP* k;
6453         o = ck_sort(o);
6454         kid = cLISTOPo->op_first->op_sibling;
6455         if (!cUNOPx(kid)->op_next)
6456             Perl_croak(aTHX_ "panic: ck_grep");
6457         for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
6458             kid = k;
6459         }
6460         kid->op_next = (OP*)gwop;
6461         o->op_flags &= ~OPf_STACKED;
6462     }
6463     kid = cLISTOPo->op_first->op_sibling;
6464     if (type == OP_MAPWHILE)
6465         list(kid);
6466     else
6467         scalar(kid);
6468     o = ck_fun(o);
6469     if (PL_error_count)
6470         return o;
6471     kid = cLISTOPo->op_first->op_sibling;
6472     if (kid->op_type != OP_NULL)
6473         Perl_croak(aTHX_ "panic: ck_grep");
6474     kid = kUNOP->op_first;
6475
6476     gwop->op_type = type;
6477     gwop->op_ppaddr = PL_ppaddr[type];
6478     gwop->op_first = listkids(o);
6479     gwop->op_flags |= OPf_KIDS;
6480     gwop->op_other = LINKLIST(kid);
6481     kid->op_next = (OP*)gwop;
6482     offset = pad_findmy("$_");
6483     if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
6484         o->op_private = gwop->op_private = 0;
6485         gwop->op_targ = pad_alloc(type, SVs_PADTMP);
6486     }
6487     else {
6488         o->op_private = gwop->op_private = OPpGREP_LEX;
6489         gwop->op_targ = o->op_targ = offset;
6490     }
6491
6492     kid = cLISTOPo->op_first->op_sibling;
6493     if (!kid || !kid->op_sibling)
6494         return too_few_arguments(o,OP_DESC(o));
6495     for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
6496         mod(kid, OP_GREPSTART);
6497
6498     return (OP*)gwop;
6499 }
6500
6501 OP *
6502 Perl_ck_index(pTHX_ OP *o)
6503 {
6504     if (o->op_flags & OPf_KIDS) {
6505         OP *kid = cLISTOPo->op_first->op_sibling;       /* get past pushmark */
6506         if (kid)
6507             kid = kid->op_sibling;                      /* get past "big" */
6508         if (kid && kid->op_type == OP_CONST)
6509             fbm_compile(((SVOP*)kid)->op_sv, 0);
6510     }
6511     return ck_fun(o);
6512 }
6513
6514 OP *
6515 Perl_ck_lengthconst(pTHX_ OP *o)
6516 {
6517     /* XXX length optimization goes here */
6518     return ck_fun(o);
6519 }
6520
6521 OP *
6522 Perl_ck_lfun(pTHX_ OP *o)
6523 {
6524     const OPCODE type = o->op_type;
6525     return modkids(ck_fun(o), type);
6526 }
6527
6528 OP *
6529 Perl_ck_defined(pTHX_ OP *o)            /* 19990527 MJD */
6530 {
6531     if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
6532         switch (cUNOPo->op_first->op_type) {
6533         case OP_RV2AV:
6534             /* This is needed for
6535                if (defined %stash::)
6536                to work.   Do not break Tk.
6537                */
6538             break;                      /* Globals via GV can be undef */
6539         case OP_PADAV:
6540         case OP_AASSIGN:                /* Is this a good idea? */
6541             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6542                         "defined(@array) is deprecated");
6543             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6544                         "\t(Maybe you should just omit the defined()?)\n");
6545         break;
6546         case OP_RV2HV:
6547             /* This is needed for
6548                if (defined %stash::)
6549                to work.   Do not break Tk.
6550                */
6551             break;                      /* Globals via GV can be undef */
6552         case OP_PADHV:
6553             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6554                         "defined(%%hash) is deprecated");
6555             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6556                         "\t(Maybe you should just omit the defined()?)\n");
6557             break;
6558         default:
6559             /* no warning */
6560             break;
6561         }
6562     }
6563     return ck_rfun(o);
6564 }
6565
6566 OP *
6567 Perl_ck_rfun(pTHX_ OP *o)
6568 {
6569     const OPCODE type = o->op_type;
6570     return refkids(ck_fun(o), type);
6571 }
6572
6573 OP *
6574 Perl_ck_listiob(pTHX_ OP *o)
6575 {
6576     register OP *kid;
6577
6578     kid = cLISTOPo->op_first;
6579     if (!kid) {
6580         o = force_list(o);
6581         kid = cLISTOPo->op_first;
6582     }
6583     if (kid->op_type == OP_PUSHMARK)
6584         kid = kid->op_sibling;
6585     if (kid && o->op_flags & OPf_STACKED)
6586         kid = kid->op_sibling;
6587     else if (kid && !kid->op_sibling) {         /* print HANDLE; */
6588         if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
6589             o->op_flags |= OPf_STACKED; /* make it a filehandle */
6590             kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
6591             cLISTOPo->op_first->op_sibling = kid;
6592             cLISTOPo->op_last = kid;
6593             kid = kid->op_sibling;
6594         }
6595     }
6596
6597     if (!kid)
6598         append_elem(o->op_type, o, newDEFSVOP());
6599
6600     return listkids(o);
6601 }
6602
6603 OP *
6604 Perl_ck_say(pTHX_ OP *o)
6605 {
6606     o = ck_listiob(o);
6607     o->op_type = OP_PRINT;
6608     cLISTOPo->op_last = cLISTOPo->op_last->op_sibling
6609         = newSVOP(OP_CONST, 0, newSVpvs("\n"));
6610     return o;
6611 }
6612
6613 OP *
6614 Perl_ck_smartmatch(pTHX_ OP *o)
6615 {
6616     dVAR;
6617     if (0 == (o->op_flags & OPf_SPECIAL)) {
6618         OP *first  = cBINOPo->op_first;
6619         OP *second = first->op_sibling;
6620
6621         /* Implicitly take a reference to an array or hash */
6622         first->op_sibling = NULL;
6623         first = cBINOPo->op_first = ref_array_or_hash(first);
6624         second = first->op_sibling = ref_array_or_hash(second);
6625
6626         /* Implicitly take a reference to a regular expression */
6627         if (first->op_type == OP_MATCH) {
6628             first->op_type = OP_QR;
6629             first->op_ppaddr = PL_ppaddr[OP_QR];
6630         }
6631         if (second->op_type == OP_MATCH) {
6632             second->op_type = OP_QR;
6633             second->op_ppaddr = PL_ppaddr[OP_QR];
6634         }
6635     }
6636
6637     return o;
6638 }
6639
6640
6641 OP *
6642 Perl_ck_sassign(pTHX_ OP *o)
6643 {
6644     OP *kid = cLISTOPo->op_first;
6645     /* has a disposable target? */
6646     if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6647         && !(kid->op_flags & OPf_STACKED)
6648         /* Cannot steal the second time! */
6649         && !(kid->op_private & OPpTARGET_MY))
6650     {
6651         OP * const kkid = kid->op_sibling;
6652
6653         /* Can just relocate the target. */
6654         if (kkid && kkid->op_type == OP_PADSV
6655             && !(kkid->op_private & OPpLVAL_INTRO))
6656         {
6657             kid->op_targ = kkid->op_targ;
6658             kkid->op_targ = 0;
6659             /* Now we do not need PADSV and SASSIGN. */
6660             kid->op_sibling = o->op_sibling;    /* NULL */
6661             cLISTOPo->op_first = NULL;
6662 #ifdef PERL_MAD
6663             op_getmad(o,kid,'O');
6664             op_getmad(kkid,kid,'M');
6665 #else
6666             op_free(o);
6667             op_free(kkid);
6668 #endif
6669             kid->op_private |= OPpTARGET_MY;    /* Used for context settings */
6670             return kid;
6671         }
6672     }
6673     return o;
6674 }
6675
6676 OP *
6677 Perl_ck_match(pTHX_ OP *o)
6678 {
6679     dVAR;
6680     if (o->op_type != OP_QR && PL_compcv) {
6681         const I32 offset = pad_findmy("$_");
6682         if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
6683             o->op_targ = offset;
6684             o->op_private |= OPpTARGET_MY;
6685         }
6686     }
6687     if (o->op_type == OP_MATCH || o->op_type == OP_QR)
6688         o->op_private |= OPpRUNTIME;
6689     return o;
6690 }
6691
6692 OP *
6693 Perl_ck_method(pTHX_ OP *o)
6694 {
6695     OP * const kid = cUNOPo->op_first;
6696     if (kid->op_type == OP_CONST) {
6697         SV* sv = kSVOP->op_sv;
6698         const char * const method = SvPVX_const(sv);
6699         if (!(strchr(method, ':') || strchr(method, '\''))) {
6700             OP *cmop;
6701             if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6702                 sv = newSVpvn_share(method, SvCUR(sv), 0);
6703             }
6704             else {
6705                 kSVOP->op_sv = NULL;
6706             }
6707             cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6708 #ifdef PERL_MAD
6709             op_getmad(o,cmop,'O');
6710 #else
6711             op_free(o);
6712 #endif
6713             return cmop;
6714         }
6715     }
6716     return o;
6717 }
6718
6719 OP *
6720 Perl_ck_null(pTHX_ OP *o)
6721 {
6722     PERL_UNUSED_CONTEXT;
6723     return o;
6724 }
6725
6726 OP *
6727 Perl_ck_open(pTHX_ OP *o)
6728 {
6729     dVAR;
6730     HV * const table = GvHV(PL_hintgv);
6731     if (table) {
6732         SV **svp = hv_fetchs(table, "open_IN", FALSE);
6733         if (svp && *svp) {
6734             const I32 mode = mode_from_discipline(*svp);
6735             if (mode & O_BINARY)
6736                 o->op_private |= OPpOPEN_IN_RAW;
6737             else if (mode & O_TEXT)
6738                 o->op_private |= OPpOPEN_IN_CRLF;
6739         }
6740
6741         svp = hv_fetchs(table, "open_OUT", FALSE);
6742         if (svp && *svp) {
6743             const I32 mode = mode_from_discipline(*svp);
6744             if (mode & O_BINARY)
6745                 o->op_private |= OPpOPEN_OUT_RAW;
6746             else if (mode & O_TEXT)
6747                 o->op_private |= OPpOPEN_OUT_CRLF;
6748         }
6749     }
6750     if (o->op_type == OP_BACKTICK)
6751         return o;
6752     {
6753          /* In case of three-arg dup open remove strictness
6754           * from the last arg if it is a bareword. */
6755          OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
6756          OP * const last  = cLISTOPx(o)->op_last;  /* The bareword. */
6757          OP *oa;
6758          const char *mode;
6759
6760          if ((last->op_type == OP_CONST) &&             /* The bareword. */
6761              (last->op_private & OPpCONST_BARE) &&
6762              (last->op_private & OPpCONST_STRICT) &&
6763              (oa = first->op_sibling) &&                /* The fh. */
6764              (oa = oa->op_sibling) &&                   /* The mode. */
6765              (oa->op_type == OP_CONST) &&
6766              SvPOK(((SVOP*)oa)->op_sv) &&
6767              (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
6768              mode[0] == '>' && mode[1] == '&' &&        /* A dup open. */
6769              (last == oa->op_sibling))                  /* The bareword. */
6770               last->op_private &= ~OPpCONST_STRICT;
6771     }
6772     return ck_fun(o);
6773 }
6774
6775 OP *
6776 Perl_ck_repeat(pTHX_ OP *o)
6777 {
6778     if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6779         o->op_private |= OPpREPEAT_DOLIST;
6780         cBINOPo->op_first = force_list(cBINOPo->op_first);
6781     }
6782     else
6783         scalar(o);
6784     return o;
6785 }
6786
6787 OP *
6788 Perl_ck_require(pTHX_ OP *o)
6789 {
6790     dVAR;
6791     GV* gv = NULL;
6792
6793     if (o->op_flags & OPf_KIDS) {       /* Shall we supply missing .pm? */
6794         SVOP * const kid = (SVOP*)cUNOPo->op_first;
6795
6796         if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6797             SV * const sv = kid->op_sv;
6798             U32 was_readonly = SvREADONLY(sv);
6799             char *s;
6800
6801             if (was_readonly) {
6802                 if (SvFAKE(sv)) {
6803                     sv_force_normal_flags(sv, 0);
6804                     assert(!SvREADONLY(sv));
6805                     was_readonly = 0;
6806                 } else {
6807                     SvREADONLY_off(sv);
6808                 }
6809             }
6810
6811             for (s = SvPVX(sv); *s; s++) {
6812                 if (*s == ':' && s[1] == ':') {
6813                     const STRLEN len = strlen(s+2)+1;
6814                     *s = '/';
6815                     Move(s+2, s+1, len, char);
6816                     SvCUR_set(sv, SvCUR(sv) - 1);
6817                 }
6818             }
6819             sv_catpvs(sv, ".pm");
6820             SvFLAGS(sv) |= was_readonly;
6821         }
6822     }
6823
6824     if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
6825         /* handle override, if any */
6826         gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
6827         if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
6828             GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
6829             gv = gvp ? *gvp : NULL;
6830         }
6831     }
6832
6833     if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6834         OP * const kid = cUNOPo->op_first;
6835         OP * newop
6836             = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
6837                               append_elem(OP_LIST, kid,
6838                                           scalar(newUNOP(OP_RV2CV, 0,
6839                                                          newGVOP(OP_GV, 0,
6840                                                                  gv))))));
6841         cUNOPo->op_first = 0;
6842 #ifdef PERL_MAD
6843         op_getmad(o,newop,'O');
6844 #else
6845         op_free(o);
6846 #endif
6847         return newop;
6848     }
6849
6850     return ck_fun(o);
6851 }
6852
6853 OP *
6854 Perl_ck_return(pTHX_ OP *o)
6855 {
6856     dVAR;
6857     if (CvLVALUE(PL_compcv)) {
6858         OP *kid;
6859         for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
6860             mod(kid, OP_LEAVESUBLV);
6861     }
6862     return o;
6863 }
6864
6865 OP *
6866 Perl_ck_select(pTHX_ OP *o)
6867 {
6868     dVAR;
6869     OP* kid;
6870     if (o->op_flags & OPf_KIDS) {
6871         kid = cLISTOPo->op_first->op_sibling;   /* get past pushmark */
6872         if (kid && kid->op_sibling) {
6873             o->op_type = OP_SSELECT;
6874             o->op_ppaddr = PL_ppaddr[OP_SSELECT];
6875             o = ck_fun(o);
6876             return fold_constants(o);
6877         }
6878     }
6879     o = ck_fun(o);
6880     kid = cLISTOPo->op_first->op_sibling;    /* get past pushmark */
6881     if (kid && kid->op_type == OP_RV2GV)
6882         kid->op_private &= ~HINT_STRICT_REFS;
6883     return o;
6884 }
6885
6886 OP *
6887 Perl_ck_shift(pTHX_ OP *o)
6888 {
6889     dVAR;
6890     const I32 type = o->op_type;
6891
6892     if (!(o->op_flags & OPf_KIDS)) {
6893         OP *argop;
6894         /* FIXME - this can be refactored to reduce code in #ifdefs  */
6895 #ifdef PERL_MAD
6896         OP *oldo = o;
6897 #else
6898         op_free(o);
6899 #endif
6900         argop = newUNOP(OP_RV2AV, 0,
6901             scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
6902 #ifdef PERL_MAD
6903         o = newUNOP(type, 0, scalar(argop));
6904         op_getmad(oldo,o,'O');
6905         return o;
6906 #else
6907         return newUNOP(type, 0, scalar(argop));
6908 #endif
6909     }
6910     return scalar(modkids(ck_fun(o), type));
6911 }
6912
6913 OP *
6914 Perl_ck_sort(pTHX_ OP *o)
6915 {
6916     dVAR;
6917     OP *firstkid;
6918
6919     if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0)
6920     {
6921         HV * const hinthv = GvHV(PL_hintgv);
6922         if (hinthv) {
6923             SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
6924             if (svp) {
6925                 const I32 sorthints = (I32)SvIV(*svp);
6926                 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
6927                     o->op_private |= OPpSORT_QSORT;
6928                 if ((sorthints & HINT_SORT_STABLE) != 0)
6929                     o->op_private |= OPpSORT_STABLE;
6930             }
6931         }
6932     }
6933
6934     if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6935         simplify_sort(o);
6936     firstkid = cLISTOPo->op_first->op_sibling;          /* get past pushmark */
6937     if (o->op_flags & OPf_STACKED) {                    /* may have been cleared */
6938         OP *k = NULL;
6939         OP *kid = cUNOPx(firstkid)->op_first;           /* get past null */
6940
6941         if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
6942             linklist(kid);
6943             if (kid->op_type == OP_SCOPE) {
6944                 k = kid->op_next;
6945                 kid->op_next = 0;
6946             }
6947             else if (kid->op_type == OP_LEAVE) {
6948                 if (o->op_type == OP_SORT) {
6949                     op_null(kid);                       /* wipe out leave */
6950                     kid->op_next = kid;
6951
6952                     for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6953                         if (k->op_next == kid)
6954                             k->op_next = 0;
6955                         /* don't descend into loops */
6956                         else if (k->op_type == OP_ENTERLOOP
6957                                  || k->op_type == OP_ENTERITER)
6958                         {
6959                             k = cLOOPx(k)->op_lastop;
6960                         }
6961                     }
6962                 }
6963                 else
6964                     kid->op_next = 0;           /* just disconnect the leave */
6965                 k = kLISTOP->op_first;
6966             }
6967             CALL_PEEP(k);
6968
6969             kid = firstkid;
6970             if (o->op_type == OP_SORT) {
6971                 /* provide scalar context for comparison function/block */
6972                 kid = scalar(kid);
6973                 kid->op_next = kid;
6974             }
6975             else
6976                 kid->op_next = k;
6977             o->op_flags |= OPf_SPECIAL;
6978         }
6979         else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6980             op_null(firstkid);
6981
6982         firstkid = firstkid->op_sibling;
6983     }
6984
6985     /* provide list context for arguments */
6986     if (o->op_type == OP_SORT)
6987         list(firstkid);
6988
6989     return o;
6990 }
6991
6992 STATIC void
6993 S_simplify_sort(pTHX_ OP *o)
6994 {
6995     dVAR;
6996     register OP *kid = cLISTOPo->op_first->op_sibling;  /* get past pushmark */
6997     OP *k;
6998     int descending;
6999     GV *gv;
7000     const char *gvname;
7001     if (!(o->op_flags & OPf_STACKED))
7002         return;
7003     GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
7004     GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
7005     kid = kUNOP->op_first;                              /* get past null */
7006     if (kid->op_type != OP_SCOPE)
7007         return;
7008     kid = kLISTOP->op_last;                             /* get past scope */
7009     switch(kid->op_type) {
7010         case OP_NCMP:
7011         case OP_I_NCMP:
7012         case OP_SCMP:
7013             break;
7014         default:
7015             return;
7016     }
7017     k = kid;                                            /* remember this node*/
7018     if (kBINOP->op_first->op_type != OP_RV2SV)
7019         return;
7020     kid = kBINOP->op_first;                             /* get past cmp */
7021     if (kUNOP->op_first->op_type != OP_GV)
7022         return;
7023     kid = kUNOP->op_first;                              /* get past rv2sv */
7024     gv = kGVOP_gv;
7025     if (GvSTASH(gv) != PL_curstash)
7026         return;
7027     gvname = GvNAME(gv);
7028     if (*gvname == 'a' && gvname[1] == '\0')
7029         descending = 0;
7030     else if (*gvname == 'b' && gvname[1] == '\0')
7031         descending = 1;
7032     else
7033         return;
7034
7035     kid = k;                                            /* back to cmp */
7036     if (kBINOP->op_last->op_type != OP_RV2SV)
7037         return;
7038     kid = kBINOP->op_last;                              /* down to 2nd arg */
7039     if (kUNOP->op_first->op_type != OP_GV)
7040         return;
7041     kid = kUNOP->op_first;                              /* get past rv2sv */
7042     gv = kGVOP_gv;
7043     if (GvSTASH(gv) != PL_curstash)
7044         return;
7045     gvname = GvNAME(gv);
7046     if ( descending
7047          ? !(*gvname == 'a' && gvname[1] == '\0')
7048          : !(*gvname == 'b' && gvname[1] == '\0'))
7049         return;
7050     o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
7051     if (descending)
7052         o->op_private |= OPpSORT_DESCEND;
7053     if (k->op_type == OP_NCMP)
7054         o->op_private |= OPpSORT_NUMERIC;
7055     if (k->op_type == OP_I_NCMP)
7056         o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
7057     kid = cLISTOPo->op_first->op_sibling;
7058     cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
7059 #ifdef PERL_MAD
7060     op_getmad(kid,o,'S');                             /* then delete it */
7061 #else
7062     op_free(kid);                                     /* then delete it */
7063 #endif
7064 }
7065
7066 OP *
7067 Perl_ck_split(pTHX_ OP *o)
7068 {
7069     dVAR;
7070     register OP *kid;
7071
7072     if (o->op_flags & OPf_STACKED)
7073         return no_fh_allowed(o);
7074
7075     kid = cLISTOPo->op_first;
7076     if (kid->op_type != OP_NULL)
7077         Perl_croak(aTHX_ "panic: ck_split");
7078     kid = kid->op_sibling;
7079     op_free(cLISTOPo->op_first);
7080     cLISTOPo->op_first = kid;
7081     if (!kid) {
7082         cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
7083         cLISTOPo->op_last = kid; /* There was only one element previously */
7084     }
7085
7086     if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
7087         OP * const sibl = kid->op_sibling;
7088         kid->op_sibling = 0;
7089         kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
7090         if (cLISTOPo->op_first == cLISTOPo->op_last)
7091             cLISTOPo->op_last = kid;
7092         cLISTOPo->op_first = kid;
7093         kid->op_sibling = sibl;
7094     }
7095
7096     kid->op_type = OP_PUSHRE;
7097     kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
7098     scalar(kid);
7099     if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL && ckWARN(WARN_REGEXP)) {
7100       Perl_warner(aTHX_ packWARN(WARN_REGEXP),
7101                   "Use of /g modifier is meaningless in split");
7102     }
7103
7104     if (!kid->op_sibling)
7105         append_elem(OP_SPLIT, o, newDEFSVOP());
7106
7107     kid = kid->op_sibling;
7108     scalar(kid);
7109
7110     if (!kid->op_sibling)
7111         append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
7112
7113     kid = kid->op_sibling;
7114     scalar(kid);
7115
7116     if (kid->op_sibling)
7117         return too_many_arguments(o,OP_DESC(o));
7118
7119     return o;
7120 }
7121
7122 OP *
7123 Perl_ck_join(pTHX_ OP *o)
7124 {
7125     const OP * const kid = cLISTOPo->op_first->op_sibling;
7126     if (kid && kid->op_type == OP_MATCH) {
7127         if (ckWARN(WARN_SYNTAX)) {
7128             const REGEXP *re = PM_GETRE(kPMOP);
7129             const char *pmstr = re ? re->precomp : "STRING";
7130             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7131                         "/%s/ should probably be written as \"%s\"",
7132                         pmstr, pmstr);
7133         }
7134     }
7135     return ck_fun(o);
7136 }
7137
7138 OP *
7139 Perl_ck_subr(pTHX_ OP *o)
7140 {
7141     dVAR;
7142     OP *prev = ((cUNOPo->op_first->op_sibling)
7143              ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
7144     OP *o2 = prev->op_sibling;
7145     OP *cvop;
7146     char *proto = NULL;
7147     CV *cv = NULL;
7148     GV *namegv = NULL;
7149     int optional = 0;
7150     I32 arg = 0;
7151     I32 contextclass = 0;
7152     char *e = NULL;
7153     bool delete_op = 0;
7154
7155     o->op_private |= OPpENTERSUB_HASTARG;
7156     for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
7157     if (cvop->op_type == OP_RV2CV) {
7158         SVOP* tmpop;
7159         o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
7160         op_null(cvop);          /* disable rv2cv */
7161         tmpop = (SVOP*)((UNOP*)cvop)->op_first;
7162         if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
7163             GV *gv = cGVOPx_gv(tmpop);
7164             cv = GvCVu(gv);
7165             if (!cv)
7166                 tmpop->op_private |= OPpEARLY_CV;
7167             else {
7168                 if (SvPOK(cv)) {
7169                     namegv = CvANON(cv) ? gv : CvGV(cv);
7170                     proto = SvPV_nolen((SV*)cv);
7171                 }
7172                 if (CvASSERTION(cv)) {
7173                     if (PL_hints & HINT_ASSERTING) {
7174                         if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
7175                             o->op_private |= OPpENTERSUB_DB;
7176                     }
7177                     else {
7178                         delete_op = 1;
7179                         if (!(PL_hints & HINT_ASSERTIONSSEEN) && ckWARN(WARN_ASSERTIONS)) {
7180                             Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
7181                                         "Impossible to activate assertion call");
7182                         }
7183                     }
7184                 }
7185             }
7186         }
7187     }
7188     else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
7189         if (o2->op_type == OP_CONST)
7190             o2->op_private &= ~OPpCONST_STRICT;
7191         else if (o2->op_type == OP_LIST) {
7192             OP * const sib = ((UNOP*)o2)->op_first->op_sibling;
7193             if (sib && sib->op_type == OP_CONST)
7194                 sib->op_private &= ~OPpCONST_STRICT;
7195         }
7196     }
7197     o->op_private |= (PL_hints & HINT_STRICT_REFS);
7198     if (PERLDB_SUB && PL_curstash != PL_debstash)
7199         o->op_private |= OPpENTERSUB_DB;
7200     while (o2 != cvop) {
7201         OP* o3;
7202         if (PL_madskills && o2->op_type == OP_NULL)
7203             o3 = ((UNOP*)o2)->op_first;
7204         else
7205             o3 = o2;
7206         if (proto) {
7207             switch (*proto) {
7208             case '\0':
7209                 return too_many_arguments(o, gv_ename(namegv));
7210             case ';':
7211                 optional = 1;
7212                 proto++;
7213                 continue;
7214             case '$':
7215                 proto++;
7216                 arg++;
7217                 scalar(o2);
7218                 break;
7219             case '%':
7220             case '@':
7221                 list(o2);
7222                 arg++;
7223                 break;
7224             case '&':
7225                 proto++;
7226                 arg++;
7227                 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
7228                     bad_type(arg,
7229                         arg == 1 ? "block or sub {}" : "sub {}",
7230                         gv_ename(namegv), o3);
7231                 break;
7232             case '*':
7233                 /* '*' allows any scalar type, including bareword */
7234                 proto++;
7235                 arg++;
7236                 if (o3->op_type == OP_RV2GV)
7237                     goto wrapref;       /* autoconvert GLOB -> GLOBref */
7238                 else if (o3->op_type == OP_CONST)
7239                     o3->op_private &= ~OPpCONST_STRICT;
7240                 else if (o3->op_type == OP_ENTERSUB) {
7241                     /* accidental subroutine, revert to bareword */
7242                     OP *gvop = ((UNOP*)o3)->op_first;
7243                     if (gvop && gvop->op_type == OP_NULL) {
7244                         gvop = ((UNOP*)gvop)->op_first;
7245                         if (gvop) {
7246                             for (; gvop->op_sibling; gvop = gvop->op_sibling)
7247                                 ;
7248                             if (gvop &&
7249                                 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
7250                                 (gvop = ((UNOP*)gvop)->op_first) &&
7251                                 gvop->op_type == OP_GV)
7252                             {
7253                                 GV * const gv = cGVOPx_gv(gvop);
7254                                 OP * const sibling = o2->op_sibling;
7255                                 SV * const n = newSVpvs("");
7256 #ifdef PERL_MAD
7257                                 OP *oldo2 = o2;
7258 #else
7259                                 op_free(o2);
7260 #endif
7261                                 gv_fullname4(n, gv, "", FALSE);
7262                                 o2 = newSVOP(OP_CONST, 0, n);
7263                                 op_getmad(oldo2,o2,'O');
7264                                 prev->op_sibling = o2;
7265                                 o2->op_sibling = sibling;
7266                             }
7267                         }
7268                     }
7269                 }
7270                 scalar(o2);
7271                 break;
7272             case '[': case ']':
7273                  goto oops;
7274                  break;
7275             case '\\':
7276                 proto++;
7277                 arg++;
7278             again:
7279                 switch (*proto++) {
7280                 case '[':
7281                      if (contextclass++ == 0) {
7282                           e = strchr(proto, ']');
7283                           if (!e || e == proto)
7284                                goto oops;
7285                      }
7286                      else
7287                           goto oops;
7288                      goto again;
7289                      break;
7290                 case ']':
7291                      if (contextclass) {
7292                          /* XXX We shouldn't be modifying proto, so we can const proto */
7293                          char *p = proto;
7294                          const char s = *p;
7295                          contextclass = 0;
7296                          *p = '\0';
7297                          while (*--p != '[');
7298                          bad_type(arg, Perl_form(aTHX_ "one of %s", p),
7299                                  gv_ename(namegv), o3);
7300                          *proto = s;
7301                      } else
7302                           goto oops;
7303                      break;
7304                 case '*':
7305                      if (o3->op_type == OP_RV2GV)
7306                           goto wrapref;
7307                      if (!contextclass)
7308                           bad_type(arg, "symbol", gv_ename(namegv), o3);
7309                      break;
7310                 case '&':
7311                      if (o3->op_type == OP_ENTERSUB)
7312                           goto wrapref;
7313                      if (!contextclass)
7314                           bad_type(arg, "subroutine entry", gv_ename(namegv),
7315                                    o3);
7316                      break;
7317                 case '$':
7318                     if (o3->op_type == OP_RV2SV ||
7319                         o3->op_type == OP_PADSV ||
7320                         o3->op_type == OP_HELEM ||
7321                         o3->op_type == OP_AELEM ||
7322                         o3->op_type == OP_THREADSV)
7323                          goto wrapref;
7324                     if (!contextclass)
7325                         bad_type(arg, "scalar", gv_ename(namegv), o3);
7326                      break;
7327                 case '@':
7328                     if (o3->op_type == OP_RV2AV ||
7329                         o3->op_type == OP_PADAV)
7330                          goto wrapref;
7331                     if (!contextclass)
7332                         bad_type(arg, "array", gv_ename(namegv), o3);
7333                     break;
7334                 case '%':
7335                     if (o3->op_type == OP_RV2HV ||
7336                         o3->op_type == OP_PADHV)
7337                          goto wrapref;
7338                     if (!contextclass)
7339                          bad_type(arg, "hash", gv_ename(namegv), o3);
7340                     break;
7341                 wrapref:
7342                     {
7343                         OP* const kid = o2;
7344                         OP* const sib = kid->op_sibling;
7345                         kid->op_sibling = 0;
7346                         o2 = newUNOP(OP_REFGEN, 0, kid);
7347                         o2->op_sibling = sib;
7348                         prev->op_sibling = o2;
7349                     }
7350                     if (contextclass && e) {
7351                          proto = e + 1;
7352                          contextclass = 0;
7353                     }
7354                     break;
7355                 default: goto oops;
7356                 }
7357                 if (contextclass)
7358                      goto again;
7359                 break;
7360             case ' ':
7361                 proto++;
7362                 continue;
7363             default:
7364               oops:
7365                 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
7366                            gv_ename(namegv), cv);
7367             }
7368         }
7369         else
7370             list(o2);
7371         mod(o2, OP_ENTERSUB);
7372         prev = o2;
7373         o2 = o2->op_sibling;
7374     } /* while */
7375     if (proto && !optional &&
7376           (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
7377         return too_few_arguments(o, gv_ename(namegv));
7378     if(delete_op) {
7379 #ifdef PERL_MAD
7380         OP *oldo = o;
7381 #else
7382         op_free(o);
7383 #endif
7384         o=newSVOP(OP_CONST, 0, newSViv(0));
7385         op_getmad(oldo,o,'O');
7386     }
7387     return o;
7388 }
7389
7390 OP *
7391 Perl_ck_svconst(pTHX_ OP *o)
7392 {
7393     PERL_UNUSED_CONTEXT;
7394     SvREADONLY_on(cSVOPo->op_sv);
7395     return o;
7396 }
7397
7398 OP *
7399 Perl_ck_chdir(pTHX_ OP *o)
7400 {
7401     if (o->op_flags & OPf_KIDS) {
7402         SVOP *kid = (SVOP*)cUNOPo->op_first;
7403
7404         if (kid && kid->op_type == OP_CONST &&
7405             (kid->op_private & OPpCONST_BARE))
7406         {
7407             o->op_flags |= OPf_SPECIAL;
7408             kid->op_private &= ~OPpCONST_STRICT;
7409         }
7410     }
7411     return ck_fun(o);
7412 }
7413
7414 OP *
7415 Perl_ck_trunc(pTHX_ OP *o)
7416 {
7417     if (o->op_flags & OPf_KIDS) {
7418         SVOP *kid = (SVOP*)cUNOPo->op_first;
7419
7420         if (kid->op_type == OP_NULL)
7421             kid = (SVOP*)kid->op_sibling;
7422         if (kid && kid->op_type == OP_CONST &&
7423             (kid->op_private & OPpCONST_BARE))
7424         {
7425             o->op_flags |= OPf_SPECIAL;
7426             kid->op_private &= ~OPpCONST_STRICT;
7427         }
7428     }
7429     return ck_fun(o);
7430 }
7431
7432 OP *
7433 Perl_ck_unpack(pTHX_ OP *o)
7434 {
7435     OP *kid = cLISTOPo->op_first;
7436     if (kid->op_sibling) {
7437         kid = kid->op_sibling;
7438         if (!kid->op_sibling)
7439             kid->op_sibling = newDEFSVOP();
7440     }
7441     return ck_fun(o);
7442 }
7443
7444 OP *
7445 Perl_ck_substr(pTHX_ OP *o)
7446 {
7447     o = ck_fun(o);
7448     if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
7449         OP *kid = cLISTOPo->op_first;
7450
7451         if (kid->op_type == OP_NULL)
7452             kid = kid->op_sibling;
7453         if (kid)
7454             kid->op_flags |= OPf_MOD;
7455
7456     }
7457     return o;
7458 }
7459
7460 /* A peephole optimizer.  We visit the ops in the order they're to execute.
7461  * See the comments at the top of this file for more details about when
7462  * peep() is called */
7463
7464 void
7465 Perl_peep(pTHX_ register OP *o)
7466 {
7467     dVAR;
7468     register OP* oldop = NULL;
7469
7470     if (!o || o->op_opt)
7471         return;
7472     ENTER;
7473     SAVEOP();
7474     SAVEVPTR(PL_curcop);
7475     for (; o; o = o->op_next) {
7476         if (o->op_opt)
7477             break;
7478         PL_op = o;
7479         switch (o->op_type) {
7480         case OP_SETSTATE:
7481         case OP_NEXTSTATE:
7482         case OP_DBSTATE:
7483             PL_curcop = ((COP*)o);              /* for warnings */
7484             o->op_opt = 1;
7485             break;
7486
7487         case OP_CONST:
7488             if (cSVOPo->op_private & OPpCONST_STRICT)
7489                 no_bareword_allowed(o);
7490 #ifdef USE_ITHREADS
7491         case OP_METHOD_NAMED:
7492             /* Relocate sv to the pad for thread safety.
7493              * Despite being a "constant", the SV is written to,
7494              * for reference counts, sv_upgrade() etc. */
7495             if (cSVOP->op_sv) {
7496                 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
7497                 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
7498                     /* If op_sv is already a PADTMP then it is being used by
7499                      * some pad, so make a copy. */
7500                     sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
7501                     SvREADONLY_on(PAD_SVl(ix));
7502                     SvREFCNT_dec(cSVOPo->op_sv);
7503                 }
7504                 else if (o->op_type == OP_CONST
7505                          && cSVOPo->op_sv == &PL_sv_undef) {
7506                     /* PL_sv_undef is hack - it's unsafe to store it in the
7507                        AV that is the pad, because av_fetch treats values of
7508                        PL_sv_undef as a "free" AV entry and will merrily
7509                        replace them with a new SV, causing pad_alloc to think
7510                        that this pad slot is free. (When, clearly, it is not)
7511                     */
7512                     SvOK_off(PAD_SVl(ix));
7513                     SvPADTMP_on(PAD_SVl(ix));
7514                     SvREADONLY_on(PAD_SVl(ix));
7515                 }
7516                 else {
7517                     SvREFCNT_dec(PAD_SVl(ix));
7518                     SvPADTMP_on(cSVOPo->op_sv);
7519                     PAD_SETSV(ix, cSVOPo->op_sv);
7520                     /* XXX I don't know how this isn't readonly already. */
7521                     SvREADONLY_on(PAD_SVl(ix));
7522                 }
7523                 cSVOPo->op_sv = NULL;
7524                 o->op_targ = ix;
7525             }
7526 #endif
7527             o->op_opt = 1;
7528             break;
7529
7530         case OP_CONCAT:
7531             if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
7532                 if (o->op_next->op_private & OPpTARGET_MY) {
7533                     if (o->op_flags & OPf_STACKED) /* chained concats */
7534                         goto ignore_optimization;
7535                     else {
7536                         /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
7537                         o->op_targ = o->op_next->op_targ;
7538                         o->op_next->op_targ = 0;
7539                         o->op_private |= OPpTARGET_MY;
7540                     }
7541                 }
7542                 op_null(o->op_next);
7543             }
7544           ignore_optimization:
7545             o->op_opt = 1;
7546             break;
7547         case OP_STUB:
7548             if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
7549                 o->op_opt = 1;
7550                 break; /* Scalar stub must produce undef.  List stub is noop */
7551             }
7552             goto nothin;
7553         case OP_NULL:
7554             if (o->op_targ == OP_NEXTSTATE
7555                 || o->op_targ == OP_DBSTATE
7556                 || o->op_targ == OP_SETSTATE)
7557             {
7558                 PL_curcop = ((COP*)o);
7559             }
7560             /* XXX: We avoid setting op_seq here to prevent later calls
7561                to peep() from mistakenly concluding that optimisation
7562                has already occurred. This doesn't fix the real problem,
7563                though (See 20010220.007). AMS 20010719 */
7564             /* op_seq functionality is now replaced by op_opt */
7565             if (oldop && o->op_next) {
7566                 oldop->op_next = o->op_next;
7567                 continue;
7568             }
7569             break;
7570         case OP_SCALAR:
7571         case OP_LINESEQ:
7572         case OP_SCOPE:
7573           nothin:
7574             if (oldop && o->op_next) {
7575                 oldop->op_next = o->op_next;
7576                 continue;
7577             }
7578             o->op_opt = 1;
7579             break;
7580
7581         case OP_PADAV:
7582         case OP_GV:
7583             if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
7584                 OP* const pop = (o->op_type == OP_PADAV) ?
7585                             o->op_next : o->op_next->op_next;
7586                 IV i;
7587                 if (pop && pop->op_type == OP_CONST &&
7588                     ((PL_op = pop->op_next)) &&
7589                     pop->op_next->op_type == OP_AELEM &&
7590                     !(pop->op_next->op_private &
7591                       (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
7592                     (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
7593                                 <= 255 &&
7594                     i >= 0)
7595                 {
7596                     GV *gv;
7597                     if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
7598                         no_bareword_allowed(pop);
7599                     if (o->op_type == OP_GV)
7600                         op_null(o->op_next);
7601                     op_null(pop->op_next);
7602                     op_null(pop);
7603                     o->op_flags |= pop->op_next->op_flags & OPf_MOD;
7604                     o->op_next = pop->op_next->op_next;
7605                     o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
7606                     o->op_private = (U8)i;
7607                     if (o->op_type == OP_GV) {
7608                         gv = cGVOPo_gv;
7609                         GvAVn(gv);
7610                     }
7611                     else
7612                         o->op_flags |= OPf_SPECIAL;
7613                     o->op_type = OP_AELEMFAST;
7614                 }
7615                 o->op_opt = 1;
7616                 break;
7617             }
7618
7619             if (o->op_next->op_type == OP_RV2SV) {
7620                 if (!(o->op_next->op_private & OPpDEREF)) {
7621                     op_null(o->op_next);
7622                     o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
7623                                                                | OPpOUR_INTRO);
7624                     o->op_next = o->op_next->op_next;
7625                     o->op_type = OP_GVSV;
7626                     o->op_ppaddr = PL_ppaddr[OP_GVSV];
7627                 }
7628             }
7629             else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
7630                 GV * const gv = cGVOPo_gv;
7631                 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
7632                     /* XXX could check prototype here instead of just carping */
7633                     SV * const sv = sv_newmortal();
7634                     gv_efullname3(sv, gv, NULL);
7635                     Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
7636                                 "%"SVf"() called too early to check prototype",
7637                                 sv);
7638                 }
7639             }
7640             else if (o->op_next->op_type == OP_READLINE
7641                     && o->op_next->op_next->op_type == OP_CONCAT
7642                     && (o->op_next->op_next->op_flags & OPf_STACKED))
7643             {
7644                 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
7645                 o->op_type   = OP_RCATLINE;
7646                 o->op_flags |= OPf_STACKED;
7647                 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
7648                 op_null(o->op_next->op_next);
7649                 op_null(o->op_next);
7650             }
7651
7652             o->op_opt = 1;
7653             break;
7654
7655         case OP_MAPWHILE:
7656         case OP_GREPWHILE:
7657         case OP_AND:
7658         case OP_OR:
7659         case OP_DOR:
7660         case OP_ANDASSIGN:
7661         case OP_ORASSIGN:
7662         case OP_DORASSIGN:
7663         case OP_COND_EXPR:
7664         case OP_RANGE:
7665             o->op_opt = 1;
7666             while (cLOGOP->op_other->op_type == OP_NULL)
7667                 cLOGOP->op_other = cLOGOP->op_other->op_next;
7668             peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
7669             break;
7670
7671         case OP_ENTERLOOP:
7672         case OP_ENTERITER:
7673             o->op_opt = 1;
7674             while (cLOOP->op_redoop->op_type == OP_NULL)
7675                 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
7676             peep(cLOOP->op_redoop);
7677             while (cLOOP->op_nextop->op_type == OP_NULL)
7678                 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
7679             peep(cLOOP->op_nextop);
7680             while (cLOOP->op_lastop->op_type == OP_NULL)
7681                 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
7682             peep(cLOOP->op_lastop);
7683             break;
7684
7685         case OP_QR:
7686         case OP_MATCH:
7687         case OP_SUBST:
7688             o->op_opt = 1;
7689             while (cPMOP->op_pmreplstart &&
7690                    cPMOP->op_pmreplstart->op_type == OP_NULL)
7691                 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
7692             peep(cPMOP->op_pmreplstart);
7693             break;
7694
7695         case OP_EXEC:
7696             o->op_opt = 1;
7697             if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
7698                 && ckWARN(WARN_SYNTAX))
7699             {
7700                 if (o->op_next->op_sibling &&
7701                         o->op_next->op_sibling->op_type != OP_EXIT &&
7702                         o->op_next->op_sibling->op_type != OP_WARN &&
7703                         o->op_next->op_sibling->op_type != OP_DIE) {
7704                     const line_t oldline = CopLINE(PL_curcop);
7705
7706                     CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
7707                     Perl_warner(aTHX_ packWARN(WARN_EXEC),
7708                                 "Statement unlikely to be reached");
7709                     Perl_warner(aTHX_ packWARN(WARN_EXEC),
7710                                 "\t(Maybe you meant system() when you said exec()?)\n");
7711                     CopLINE_set(PL_curcop, oldline);
7712                 }
7713             }
7714             break;
7715
7716         case OP_HELEM: {
7717             UNOP *rop;
7718             SV *lexname;
7719             GV **fields;
7720             SV **svp, *sv;
7721             const char *key = NULL;
7722             STRLEN keylen;
7723
7724             o->op_opt = 1;
7725
7726             if (((BINOP*)o)->op_last->op_type != OP_CONST)
7727                 break;
7728
7729             /* Make the CONST have a shared SV */
7730             svp = cSVOPx_svp(((BINOP*)o)->op_last);
7731             if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
7732                 key = SvPV_const(sv, keylen);
7733                 lexname = newSVpvn_share(key,
7734                                          SvUTF8(sv) ? -(I32)keylen : keylen,
7735                                          0);
7736                 SvREFCNT_dec(sv);
7737                 *svp = lexname;
7738             }
7739
7740             if ((o->op_private & (OPpLVAL_INTRO)))
7741                 break;
7742
7743             rop = (UNOP*)((BINOP*)o)->op_first;
7744             if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
7745                 break;
7746             lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
7747             if (!SvPAD_TYPED(lexname))
7748                 break;
7749             fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
7750             if (!fields || !GvHV(*fields))
7751                 break;
7752             key = SvPV_const(*svp, keylen);
7753             if (!hv_fetch(GvHV(*fields), key,
7754                         SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
7755             {
7756                 Perl_croak(aTHX_ "No such class field \"%s\" "
7757                            "in variable %s of type %s",
7758                       key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
7759             }
7760
7761             break;
7762         }
7763
7764         case OP_HSLICE: {
7765             UNOP *rop;
7766             SV *lexname;
7767             GV **fields;
7768             SV **svp;
7769             const char *key;
7770             STRLEN keylen;
7771             SVOP *first_key_op, *key_op;
7772
7773             if ((o->op_private & (OPpLVAL_INTRO))
7774                 /* I bet there's always a pushmark... */
7775                 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
7776                 /* hmmm, no optimization if list contains only one key. */
7777                 break;
7778             rop = (UNOP*)((LISTOP*)o)->op_last;
7779             if (rop->op_type != OP_RV2HV)
7780                 break;
7781             if (rop->op_first->op_type == OP_PADSV)
7782                 /* @$hash{qw(keys here)} */
7783                 rop = (UNOP*)rop->op_first;
7784             else {
7785                 /* @{$hash}{qw(keys here)} */
7786                 if (rop->op_first->op_type == OP_SCOPE
7787                     && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
7788                 {
7789                     rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
7790                 }
7791                 else
7792                     break;
7793             }
7794
7795             lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
7796             if (!SvPAD_TYPED(lexname))
7797                 break;
7798             fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
7799             if (!fields || !GvHV(*fields))
7800                 break;
7801             /* Again guessing that the pushmark can be jumped over.... */
7802             first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
7803                 ->op_first->op_sibling;
7804             for (key_op = first_key_op; key_op;
7805                  key_op = (SVOP*)key_op->op_sibling) {
7806                 if (key_op->op_type != OP_CONST)
7807                     continue;
7808                 svp = cSVOPx_svp(key_op);
7809                 key = SvPV_const(*svp, keylen);
7810                 if (!hv_fetch(GvHV(*fields), key,
7811                             SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
7812                 {
7813                     Perl_croak(aTHX_ "No such class field \"%s\" "
7814                                "in variable %s of type %s",
7815                           key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
7816                 }
7817             }
7818             break;
7819         }
7820
7821         case OP_SORT: {
7822             /* will point to RV2AV or PADAV op on LHS/RHS of assign */
7823             OP *oleft;
7824             OP *o2;
7825
7826             /* check that RHS of sort is a single plain array */
7827             OP *oright = cUNOPo->op_first;
7828             if (!oright || oright->op_type != OP_PUSHMARK)
7829                 break;
7830
7831             /* reverse sort ... can be optimised.  */
7832             if (!cUNOPo->op_sibling) {
7833                 /* Nothing follows us on the list. */
7834                 OP * const reverse = o->op_next;
7835
7836                 if (reverse->op_type == OP_REVERSE &&
7837                     (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
7838                     OP * const pushmark = cUNOPx(reverse)->op_first;
7839                     if (pushmark && (pushmark->op_type == OP_PUSHMARK)
7840                         && (cUNOPx(pushmark)->op_sibling == o)) {
7841                         /* reverse -> pushmark -> sort */
7842                         o->op_private |= OPpSORT_REVERSE;
7843                         op_null(reverse);
7844                         pushmark->op_next = oright->op_next;
7845                         op_null(oright);
7846                     }
7847                 }
7848             }
7849
7850             /* make @a = sort @a act in-place */
7851
7852             o->op_opt = 1;
7853
7854             oright = cUNOPx(oright)->op_sibling;
7855             if (!oright)
7856                 break;
7857             if (oright->op_type == OP_NULL) { /* skip sort block/sub */
7858                 oright = cUNOPx(oright)->op_sibling;
7859             }
7860
7861             if (!oright ||
7862                 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
7863                 || oright->op_next != o
7864                 || (oright->op_private & OPpLVAL_INTRO)
7865             )
7866                 break;
7867
7868             /* o2 follows the chain of op_nexts through the LHS of the
7869              * assign (if any) to the aassign op itself */
7870             o2 = o->op_next;
7871             if (!o2 || o2->op_type != OP_NULL)
7872                 break;
7873             o2 = o2->op_next;
7874             if (!o2 || o2->op_type != OP_PUSHMARK)
7875                 break;
7876             o2 = o2->op_next;
7877             if (o2 && o2->op_type == OP_GV)
7878                 o2 = o2->op_next;
7879             if (!o2
7880                 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
7881                 || (o2->op_private & OPpLVAL_INTRO)
7882             )
7883                 break;
7884             oleft = o2;
7885             o2 = o2->op_next;
7886             if (!o2 || o2->op_type != OP_NULL)
7887                 break;
7888             o2 = o2->op_next;
7889             if (!o2 || o2->op_type != OP_AASSIGN
7890                     || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
7891                 break;
7892
7893             /* check that the sort is the first arg on RHS of assign */
7894
7895             o2 = cUNOPx(o2)->op_first;
7896             if (!o2 || o2->op_type != OP_NULL)
7897                 break;
7898             o2 = cUNOPx(o2)->op_first;
7899             if (!o2 || o2->op_type != OP_PUSHMARK)
7900                 break;
7901             if (o2->op_sibling != o)
7902                 break;
7903
7904             /* check the array is the same on both sides */
7905             if (oleft->op_type == OP_RV2AV) {
7906                 if (oright->op_type != OP_RV2AV
7907                     || !cUNOPx(oright)->op_first
7908                     || cUNOPx(oright)->op_first->op_type != OP_GV
7909                     ||  cGVOPx_gv(cUNOPx(oleft)->op_first) !=
7910                         cGVOPx_gv(cUNOPx(oright)->op_first)
7911                 )
7912                     break;
7913             }
7914             else if (oright->op_type != OP_PADAV
7915                 || oright->op_targ != oleft->op_targ
7916             )
7917                 break;
7918
7919             /* transfer MODishness etc from LHS arg to RHS arg */
7920             oright->op_flags = oleft->op_flags;
7921             o->op_private |= OPpSORT_INPLACE;
7922
7923             /* excise push->gv->rv2av->null->aassign */
7924             o2 = o->op_next->op_next;
7925             op_null(o2); /* PUSHMARK */
7926             o2 = o2->op_next;
7927             if (o2->op_type == OP_GV) {
7928                 op_null(o2); /* GV */
7929                 o2 = o2->op_next;
7930             }
7931             op_null(o2); /* RV2AV or PADAV */
7932             o2 = o2->op_next->op_next;
7933             op_null(o2); /* AASSIGN */
7934
7935             o->op_next = o2->op_next;
7936
7937             break;
7938         }
7939
7940         case OP_REVERSE: {
7941             OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
7942             OP *gvop = NULL;
7943             LISTOP *enter, *exlist;
7944             o->op_opt = 1;
7945
7946             enter = (LISTOP *) o->op_next;
7947             if (!enter)
7948                 break;
7949             if (enter->op_type == OP_NULL) {
7950                 enter = (LISTOP *) enter->op_next;
7951                 if (!enter)
7952                     break;
7953             }
7954             /* for $a (...) will have OP_GV then OP_RV2GV here.
7955                for (...) just has an OP_GV.  */
7956             if (enter->op_type == OP_GV) {
7957                 gvop = (OP *) enter;
7958                 enter = (LISTOP *) enter->op_next;
7959                 if (!enter)
7960                     break;
7961                 if (enter->op_type == OP_RV2GV) {
7962                   enter = (LISTOP *) enter->op_next;
7963                   if (!enter)
7964                     break;
7965                 }
7966             }
7967
7968             if (enter->op_type != OP_ENTERITER)
7969                 break;
7970
7971             iter = enter->op_next;
7972             if (!iter || iter->op_type != OP_ITER)
7973                 break;
7974
7975             expushmark = enter->op_first;
7976             if (!expushmark || expushmark->op_type != OP_NULL
7977                 || expushmark->op_targ != OP_PUSHMARK)
7978                 break;
7979
7980             exlist = (LISTOP *) expushmark->op_sibling;
7981             if (!exlist || exlist->op_type != OP_NULL
7982                 || exlist->op_targ != OP_LIST)
7983                 break;
7984
7985             if (exlist->op_last != o) {
7986                 /* Mmm. Was expecting to point back to this op.  */
7987                 break;
7988             }
7989             theirmark = exlist->op_first;
7990             if (!theirmark || theirmark->op_type != OP_PUSHMARK)
7991                 break;
7992
7993             if (theirmark->op_sibling != o) {
7994                 /* There's something between the mark and the reverse, eg
7995                    for (1, reverse (...))
7996                    so no go.  */
7997                 break;
7998             }
7999
8000             ourmark = ((LISTOP *)o)->op_first;
8001             if (!ourmark || ourmark->op_type != OP_PUSHMARK)
8002                 break;
8003
8004             ourlast = ((LISTOP *)o)->op_last;
8005             if (!ourlast || ourlast->op_next != o)
8006                 break;
8007
8008             rv2av = ourmark->op_sibling;
8009             if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
8010                 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
8011                 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
8012                 /* We're just reversing a single array.  */
8013                 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
8014                 enter->op_flags |= OPf_STACKED;
8015             }
8016
8017             /* We don't have control over who points to theirmark, so sacrifice
8018                ours.  */
8019             theirmark->op_next = ourmark->op_next;
8020             theirmark->op_flags = ourmark->op_flags;
8021             ourlast->op_next = gvop ? gvop : (OP *) enter;
8022             op_null(ourmark);
8023             op_null(o);
8024             enter->op_private |= OPpITER_REVERSED;
8025             iter->op_private |= OPpITER_REVERSED;
8026
8027             break;
8028         }
8029
8030         case OP_SASSIGN: {
8031             OP *rv2gv;
8032             UNOP *refgen, *rv2cv;
8033             LISTOP *exlist;
8034
8035             /* I do not understand this, but if o->op_opt isn't set to 1,
8036                various tests in ext/B/t/bytecode.t fail with no readily
8037                apparent cause.  */
8038
8039             o->op_opt = 1;
8040
8041
8042             if ((o->op_flags && OPf_WANT) != OPf_WANT_VOID)
8043                 break;
8044
8045             if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
8046                 break;
8047
8048             rv2gv = ((BINOP *)o)->op_last;
8049             if (!rv2gv || rv2gv->op_type != OP_RV2GV)
8050                 break;
8051
8052             refgen = (UNOP *)((BINOP *)o)->op_first;
8053
8054             if (!refgen || refgen->op_type != OP_REFGEN)
8055                 break;
8056
8057             exlist = (LISTOP *)refgen->op_first;
8058             if (!exlist || exlist->op_type != OP_NULL
8059                 || exlist->op_targ != OP_LIST)
8060                 break;
8061
8062             if (exlist->op_first->op_type != OP_PUSHMARK)
8063                 break;
8064
8065             rv2cv = (UNOP*)exlist->op_last;
8066
8067             if (rv2cv->op_type != OP_RV2CV)
8068                 break;
8069
8070             assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
8071             assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
8072             assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
8073
8074             o->op_private |= OPpASSIGN_CV_TO_GV;
8075             rv2gv->op_private |= OPpDONT_INIT_GV;
8076             rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
8077
8078             break;
8079         }
8080
8081
8082         default:
8083             o->op_opt = 1;
8084             break;
8085         }
8086         oldop = o;
8087     }
8088     LEAVE;
8089 }
8090
8091 char*
8092 Perl_custom_op_name(pTHX_ const OP* o)
8093 {
8094     dVAR;
8095     const IV index = PTR2IV(o->op_ppaddr);
8096     SV* keysv;
8097     HE* he;
8098
8099     if (!PL_custom_op_names) /* This probably shouldn't happen */
8100         return (char *)PL_op_name[OP_CUSTOM];
8101
8102     keysv = sv_2mortal(newSViv(index));
8103
8104     he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
8105     if (!he)
8106         return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
8107
8108     return SvPV_nolen(HeVAL(he));
8109 }
8110
8111 char*
8112 Perl_custom_op_desc(pTHX_ const OP* o)
8113 {
8114     dVAR;
8115     const IV index = PTR2IV(o->op_ppaddr);
8116     SV* keysv;
8117     HE* he;
8118
8119     if (!PL_custom_op_descs)
8120         return (char *)PL_op_desc[OP_CUSTOM];
8121
8122     keysv = sv_2mortal(newSViv(index));
8123
8124     he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
8125     if (!he)
8126         return (char *)PL_op_desc[OP_CUSTOM];
8127
8128     return SvPV_nolen(HeVAL(he));
8129 }
8130
8131 #include "XSUB.h"
8132
8133 /* Efficient sub that returns a constant scalar value. */
8134 static void
8135 const_sv_xsub(pTHX_ CV* cv)
8136 {
8137     dVAR;
8138     dXSARGS;
8139     if (items != 0) {
8140         /*EMPTY*/;
8141 #if 0
8142         Perl_croak(aTHX_ "usage: %s::%s()",
8143                    HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
8144 #endif
8145     }
8146     EXTEND(sp, 1);
8147     ST(0) = (SV*)XSANY.any_ptr;
8148     XSRETURN(1);
8149 }
8150
8151 /*
8152  * Local variables:
8153  * c-indentation-style: bsd
8154  * c-basic-offset: 4
8155  * indent-tabs-mode: t
8156  * End:
8157  *
8158  * ex: set ts=8 sts=4 sw=4 noet:
8159  */