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