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 = ((SVOP*)repl)->op_sv;
2830     STRLEN tlen;
2831     STRLEN rlen;
2832     const U8 *t = (U8*)SvPV_const(tstr, tlen);
2833     const U8 *r = (U8*)SvPV_const(rstr, rlen);
2834     register I32 i;
2835     register I32 j;
2836     I32 grows = 0;
2837     register short *tbl;
2838
2839     const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
2840     const I32 squash     = o->op_private & OPpTRANS_SQUASH;
2841     I32 del              = o->op_private & OPpTRANS_DELETE;
2842     PL_hints |= HINT_BLOCK_SCOPE;
2843
2844     if (SvUTF8(tstr))
2845         o->op_private |= OPpTRANS_FROM_UTF;
2846
2847     if (SvUTF8(rstr))
2848         o->op_private |= OPpTRANS_TO_UTF;
2849
2850     if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2851         SV* const listsv = newSVpvs("# comment\n");
2852         SV* transv = NULL;
2853         const U8* tend = t + tlen;
2854         const U8* rend = r + rlen;
2855         STRLEN ulen;
2856         UV tfirst = 1;
2857         UV tlast = 0;
2858         IV tdiff;
2859         UV rfirst = 1;
2860         UV rlast = 0;
2861         IV rdiff;
2862         IV diff;
2863         I32 none = 0;
2864         U32 max = 0;
2865         I32 bits;
2866         I32 havefinal = 0;
2867         U32 final = 0;
2868         const I32 from_utf  = o->op_private & OPpTRANS_FROM_UTF;
2869         const I32 to_utf    = o->op_private & OPpTRANS_TO_UTF;
2870         U8* tsave = NULL;
2871         U8* rsave = NULL;
2872         const U32 flags = UTF8_ALLOW_DEFAULT;
2873
2874         if (!from_utf) {
2875             STRLEN len = tlen;
2876             t = tsave = bytes_to_utf8(t, &len);
2877             tend = t + len;
2878         }
2879         if (!to_utf && rlen) {
2880             STRLEN len = rlen;
2881             r = rsave = bytes_to_utf8(r, &len);
2882             rend = r + len;
2883         }
2884
2885 /* There are several snags with this code on EBCDIC:
2886    1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2887    2. scan_const() in toke.c has encoded chars in native encoding which makes
2888       ranges at least in EBCDIC 0..255 range the bottom odd.
2889 */
2890
2891         if (complement) {
2892             U8 tmpbuf[UTF8_MAXBYTES+1];
2893             UV *cp;
2894             UV nextmin = 0;
2895             Newx(cp, 2*tlen, UV);
2896             i = 0;
2897             transv = newSVpvs("");
2898             while (t < tend) {
2899                 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
2900                 t += ulen;
2901                 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2902                     t++;
2903                     cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
2904                     t += ulen;
2905                 }
2906                 else {
2907                  cp[2*i+1] = cp[2*i];
2908                 }
2909                 i++;
2910             }
2911             qsort(cp, i, 2*sizeof(UV), uvcompare);
2912             for (j = 0; j < i; j++) {
2913                 UV  val = cp[2*j];
2914                 diff = val - nextmin;
2915                 if (diff > 0) {
2916                     t = uvuni_to_utf8(tmpbuf,nextmin);
2917                     sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2918                     if (diff > 1) {
2919                         U8  range_mark = UTF_TO_NATIVE(0xff);
2920                         t = uvuni_to_utf8(tmpbuf, val - 1);
2921                         sv_catpvn(transv, (char *)&range_mark, 1);
2922                         sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2923                     }
2924                 }
2925                 val = cp[2*j+1];
2926                 if (val >= nextmin)
2927                     nextmin = val + 1;
2928             }
2929             t = uvuni_to_utf8(tmpbuf,nextmin);
2930             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2931             {
2932                 U8 range_mark = UTF_TO_NATIVE(0xff);
2933                 sv_catpvn(transv, (char *)&range_mark, 1);
2934             }
2935             t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
2936                                     UNICODE_ALLOW_SUPER);
2937             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2938             t = (const U8*)SvPVX_const(transv);
2939             tlen = SvCUR(transv);
2940             tend = t + tlen;
2941             Safefree(cp);
2942         }
2943         else if (!rlen && !del) {
2944             r = t; rlen = tlen; rend = tend;
2945         }
2946         if (!squash) {
2947                 if ((!rlen && !del) || t == r ||
2948                     (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2949                 {
2950                     o->op_private |= OPpTRANS_IDENTICAL;
2951                 }
2952         }
2953
2954         while (t < tend || tfirst <= tlast) {
2955             /* see if we need more "t" chars */
2956             if (tfirst > tlast) {
2957                 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
2958                 t += ulen;
2959                 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {    /* illegal utf8 val indicates range */
2960                     t++;
2961                     tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
2962                     t += ulen;
2963                 }
2964                 else
2965                     tlast = tfirst;
2966             }
2967
2968             /* now see if we need more "r" chars */
2969             if (rfirst > rlast) {
2970                 if (r < rend) {
2971                     rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
2972                     r += ulen;
2973                     if (r < rend && NATIVE_TO_UTF(*r) == 0xff) {        /* illegal utf8 val indicates range */
2974                         r++;
2975                         rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
2976                         r += ulen;
2977                     }
2978                     else
2979                         rlast = rfirst;
2980                 }
2981                 else {
2982                     if (!havefinal++)
2983                         final = rlast;
2984                     rfirst = rlast = 0xffffffff;
2985                 }
2986             }
2987
2988             /* now see which range will peter our first, if either. */
2989             tdiff = tlast - tfirst;
2990             rdiff = rlast - rfirst;
2991
2992             if (tdiff <= rdiff)
2993                 diff = tdiff;
2994             else
2995                 diff = rdiff;
2996
2997             if (rfirst == 0xffffffff) {
2998                 diff = tdiff;   /* oops, pretend rdiff is infinite */
2999                 if (diff > 0)
3000                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
3001                                    (long)tfirst, (long)tlast);
3002                 else
3003                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
3004             }
3005             else {
3006                 if (diff > 0)
3007                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
3008                                    (long)tfirst, (long)(tfirst + diff),
3009                                    (long)rfirst);
3010                 else
3011                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
3012                                    (long)tfirst, (long)rfirst);
3013
3014                 if (rfirst + diff > max)
3015                     max = rfirst + diff;
3016                 if (!grows)
3017                     grows = (tfirst < rfirst &&
3018                              UNISKIP(tfirst) < UNISKIP(rfirst + diff));
3019                 rfirst += diff + 1;
3020             }
3021             tfirst += diff + 1;
3022         }
3023
3024         none = ++max;
3025         if (del)
3026             del = ++max;
3027
3028         if (max > 0xffff)
3029             bits = 32;
3030         else if (max > 0xff)
3031             bits = 16;
3032         else
3033             bits = 8;
3034
3035         Safefree(cPVOPo->op_pv);
3036         cPVOPo->op_pv = NULL;
3037         cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
3038         SvREFCNT_dec(listsv);
3039         SvREFCNT_dec(transv);
3040
3041         if (!del && havefinal && rlen)
3042             (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
3043                            newSVuv((UV)final), 0);
3044
3045         if (grows)
3046             o->op_private |= OPpTRANS_GROWS;
3047
3048         Safefree(tsave);
3049         Safefree(rsave);
3050
3051 #ifdef PERL_MAD
3052         op_getmad(expr,o,'e');
3053         op_getmad(repl,o,'r');
3054 #else
3055         op_free(expr);
3056         op_free(repl);
3057 #endif
3058         return o;
3059     }
3060
3061     tbl = (short*)cPVOPo->op_pv;
3062     if (complement) {
3063         Zero(tbl, 256, short);
3064         for (i = 0; i < (I32)tlen; i++)
3065             tbl[t[i]] = -1;
3066         for (i = 0, j = 0; i < 256; i++) {
3067             if (!tbl[i]) {
3068                 if (j >= (I32)rlen) {
3069                     if (del)
3070                         tbl[i] = -2;
3071                     else if (rlen)
3072                         tbl[i] = r[j-1];
3073                     else
3074                         tbl[i] = (short)i;
3075                 }
3076                 else {
3077                     if (i < 128 && r[j] >= 128)
3078                         grows = 1;
3079                     tbl[i] = r[j++];
3080                 }
3081             }
3082         }
3083         if (!del) {
3084             if (!rlen) {
3085                 j = rlen;
3086                 if (!squash)
3087                     o->op_private |= OPpTRANS_IDENTICAL;
3088             }
3089             else if (j >= (I32)rlen)
3090                 j = rlen - 1;
3091             else
3092                 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
3093             tbl[0x100] = (short)(rlen - j);
3094             for (i=0; i < (I32)rlen - j; i++)
3095                 tbl[0x101+i] = r[j+i];
3096         }
3097     }
3098     else {
3099         if (!rlen && !del) {
3100             r = t; rlen = tlen;
3101             if (!squash)
3102                 o->op_private |= OPpTRANS_IDENTICAL;
3103         }
3104         else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
3105             o->op_private |= OPpTRANS_IDENTICAL;
3106         }
3107         for (i = 0; i < 256; i++)
3108             tbl[i] = -1;
3109         for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
3110             if (j >= (I32)rlen) {
3111                 if (del) {
3112                     if (tbl[t[i]] == -1)
3113                         tbl[t[i]] = -2;
3114                     continue;
3115                 }
3116                 --j;
3117             }
3118             if (tbl[t[i]] == -1) {
3119                 if (t[i] < 128 && r[j] >= 128)
3120                     grows = 1;
3121                 tbl[t[i]] = r[j];
3122             }
3123         }
3124     }
3125     if (grows)
3126         o->op_private |= OPpTRANS_GROWS;
3127 #ifdef PERL_MAD
3128     op_getmad(expr,o,'e');
3129     op_getmad(repl,o,'r');
3130 #else
3131     op_free(expr);
3132     op_free(repl);
3133 #endif
3134
3135     return o;
3136 }
3137
3138 OP *
3139 Perl_newPMOP(pTHX_ I32 type, I32 flags)
3140 {
3141     dVAR;
3142     PMOP *pmop;
3143
3144     NewOp(1101, pmop, 1, PMOP);
3145     pmop->op_type = (OPCODE)type;
3146     pmop->op_ppaddr = PL_ppaddr[type];
3147     pmop->op_flags = (U8)flags;
3148     pmop->op_private = (U8)(0 | (flags >> 8));
3149
3150     if (PL_hints & HINT_RE_TAINT)
3151         pmop->op_pmpermflags |= PMf_RETAINT;
3152     if (PL_hints & HINT_LOCALE)
3153         pmop->op_pmpermflags |= PMf_LOCALE;
3154     pmop->op_pmflags = pmop->op_pmpermflags;
3155
3156 #ifdef USE_ITHREADS
3157     if (av_len((AV*) PL_regex_pad[0]) > -1) {
3158         SV * const repointer = av_pop((AV*)PL_regex_pad[0]);
3159         pmop->op_pmoffset = SvIV(repointer);
3160         SvREPADTMP_off(repointer);
3161         sv_setiv(repointer,0);
3162     } else {
3163         SV * const repointer = newSViv(0);
3164         av_push(PL_regex_padav, SvREFCNT_inc_simple_NN(repointer));
3165         pmop->op_pmoffset = av_len(PL_regex_padav);
3166         PL_regex_pad = AvARRAY(PL_regex_padav);
3167     }
3168 #endif
3169
3170         /* link into pm list */
3171     if (type != OP_TRANS && PL_curstash) {
3172         MAGIC *mg = mg_find((SV*)PL_curstash, PERL_MAGIC_symtab);
3173
3174         if (!mg) {
3175             mg = sv_magicext((SV*)PL_curstash, 0, PERL_MAGIC_symtab, 0, 0, 0);
3176         }
3177         pmop->op_pmnext = (PMOP*)mg->mg_obj;
3178         mg->mg_obj = (SV*)pmop;
3179         PmopSTASH_set(pmop,PL_curstash);
3180     }
3181
3182     return CHECKOP(type, pmop);
3183 }
3184
3185 /* Given some sort of match op o, and an expression expr containing a
3186  * pattern, either compile expr into a regex and attach it to o (if it's
3187  * constant), or convert expr into a runtime regcomp op sequence (if it's
3188  * not)
3189  *
3190  * isreg indicates that the pattern is part of a regex construct, eg
3191  * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
3192  * split "pattern", which aren't. In the former case, expr will be a list
3193  * if the pattern contains more than one term (eg /a$b/) or if it contains
3194  * a replacement, ie s/// or tr///.
3195  */
3196
3197 OP *
3198 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
3199 {
3200     dVAR;
3201     PMOP *pm;
3202     LOGOP *rcop;
3203     I32 repl_has_vars = 0;
3204     OP* repl = NULL;
3205     bool reglist;
3206
3207     if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
3208         /* last element in list is the replacement; pop it */
3209         OP* kid;
3210         repl = cLISTOPx(expr)->op_last;
3211         kid = cLISTOPx(expr)->op_first;
3212         while (kid->op_sibling != repl)
3213             kid = kid->op_sibling;
3214         kid->op_sibling = NULL;
3215         cLISTOPx(expr)->op_last = kid;
3216     }
3217
3218     if (isreg && expr->op_type == OP_LIST &&
3219         cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
3220     {
3221         /* convert single element list to element */
3222         OP* const oe = expr;
3223         expr = cLISTOPx(oe)->op_first->op_sibling;
3224         cLISTOPx(oe)->op_first->op_sibling = NULL;
3225         cLISTOPx(oe)->op_last = NULL;
3226         op_free(oe);
3227     }
3228
3229     if (o->op_type == OP_TRANS) {
3230         return pmtrans(o, expr, repl);
3231     }
3232
3233     reglist = isreg && expr->op_type == OP_LIST;
3234     if (reglist)
3235         op_null(expr);
3236
3237     PL_hints |= HINT_BLOCK_SCOPE;
3238     pm = (PMOP*)o;
3239
3240     if (expr->op_type == OP_CONST) {
3241         STRLEN plen;
3242         SV * const pat = ((SVOP*)expr)->op_sv;
3243         const char *p = SvPV_const(pat, plen);
3244         if ((o->op_flags & OPf_SPECIAL) && (*p == ' ' && p[1] == '\0')) {
3245             U32 was_readonly = SvREADONLY(pat);
3246
3247             if (was_readonly) {
3248                 if (SvFAKE(pat)) {
3249                     sv_force_normal_flags(pat, 0);
3250                     assert(!SvREADONLY(pat));
3251                     was_readonly = 0;
3252                 } else {
3253                     SvREADONLY_off(pat);
3254                 }
3255             }
3256
3257             sv_setpvn(pat, "\\s+", 3);
3258
3259             SvFLAGS(pat) |= was_readonly;
3260
3261             p = SvPV_const(pat, plen);
3262             pm->op_pmflags |= PMf_SKIPWHITE;
3263         }
3264         if (DO_UTF8(pat))
3265             pm->op_pmdynflags |= PMdf_UTF8;
3266         /* FIXME - can we make this function take const char * args?  */
3267         PM_SETRE(pm, CALLREGCOMP((char*)p, (char*)p + plen, pm));
3268         if (strEQ("\\s+", PM_GETRE(pm)->precomp))
3269             pm->op_pmflags |= PMf_WHITE;
3270 #ifdef PERL_MAD
3271         op_getmad(expr,(OP*)pm,'e');
3272 #else
3273         op_free(expr);
3274 #endif
3275     }
3276     else {
3277         if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3278             expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3279                             ? OP_REGCRESET
3280                             : OP_REGCMAYBE),0,expr);
3281
3282         NewOp(1101, rcop, 1, LOGOP);
3283         rcop->op_type = OP_REGCOMP;
3284         rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3285         rcop->op_first = scalar(expr);
3286         rcop->op_flags |= OPf_KIDS
3287                             | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
3288                             | (reglist ? OPf_STACKED : 0);
3289         rcop->op_private = 1;
3290         rcop->op_other = o;
3291         if (reglist)
3292             rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
3293
3294         /* /$x/ may cause an eval, since $x might be qr/(?{..})/  */
3295         PL_cv_has_eval = 1;
3296
3297         /* establish postfix order */
3298         if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3299             LINKLIST(expr);
3300             rcop->op_next = expr;
3301             ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3302         }
3303         else {
3304             rcop->op_next = LINKLIST(expr);
3305             expr->op_next = (OP*)rcop;
3306         }
3307
3308         prepend_elem(o->op_type, scalar((OP*)rcop), o);
3309     }
3310
3311     if (repl) {
3312         OP *curop;
3313         if (pm->op_pmflags & PMf_EVAL) {
3314             curop = NULL;
3315             if (CopLINE(PL_curcop) < (line_t)PL_multi_end)
3316                 CopLINE_set(PL_curcop, (line_t)PL_multi_end);
3317         }
3318         else if (repl->op_type == OP_CONST)
3319             curop = repl;
3320         else {
3321             OP *lastop = NULL;
3322             for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3323                 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3324                     if (curop->op_type == OP_GV) {
3325                         GV * const gv = cGVOPx_gv(curop);
3326                         repl_has_vars = 1;
3327                         if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
3328                             break;
3329                     }
3330                     else if (curop->op_type == OP_RV2CV)
3331                         break;
3332                     else if (curop->op_type == OP_RV2SV ||
3333                              curop->op_type == OP_RV2AV ||
3334                              curop->op_type == OP_RV2HV ||
3335                              curop->op_type == OP_RV2GV) {
3336                         if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3337                             break;
3338                     }
3339                     else if (curop->op_type == OP_PADSV ||
3340                              curop->op_type == OP_PADAV ||
3341                              curop->op_type == OP_PADHV ||
3342                              curop->op_type == OP_PADANY) {
3343                         repl_has_vars = 1;
3344                     }
3345                     else if (curop->op_type == OP_PUSHRE)
3346                         NOOP; /* Okay here, dangerous in newASSIGNOP */
3347                     else
3348                         break;
3349                 }
3350                 lastop = curop;
3351             }
3352         }
3353         if (curop == repl
3354             && !(repl_has_vars
3355                  && (!PM_GETRE(pm)
3356                      || PM_GETRE(pm)->extflags & RXf_EVAL_SEEN))) {
3357             pm->op_pmflags |= PMf_CONST;        /* const for long enough */
3358             pm->op_pmpermflags |= PMf_CONST;    /* const for long enough */
3359             prepend_elem(o->op_type, scalar(repl), o);
3360         }
3361         else {
3362             if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3363                 pm->op_pmflags |= PMf_MAYBE_CONST;
3364                 pm->op_pmpermflags |= PMf_MAYBE_CONST;
3365             }
3366             NewOp(1101, rcop, 1, LOGOP);
3367             rcop->op_type = OP_SUBSTCONT;
3368             rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3369             rcop->op_first = scalar(repl);
3370             rcop->op_flags |= OPf_KIDS;
3371             rcop->op_private = 1;
3372             rcop->op_other = o;
3373
3374             /* establish postfix order */
3375             rcop->op_next = LINKLIST(repl);
3376             repl->op_next = (OP*)rcop;
3377
3378             pm->op_pmreplroot = scalar((OP*)rcop);
3379             pm->op_pmreplstart = LINKLIST(rcop);
3380             rcop->op_next = 0;
3381         }
3382     }
3383
3384     return (OP*)pm;
3385 }
3386
3387 OP *
3388 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3389 {
3390     dVAR;
3391     SVOP *svop;
3392     NewOp(1101, svop, 1, SVOP);
3393     svop->op_type = (OPCODE)type;
3394     svop->op_ppaddr = PL_ppaddr[type];
3395     svop->op_sv = sv;
3396     svop->op_next = (OP*)svop;
3397     svop->op_flags = (U8)flags;
3398     if (PL_opargs[type] & OA_RETSCALAR)
3399         scalar((OP*)svop);
3400     if (PL_opargs[type] & OA_TARGET)
3401         svop->op_targ = pad_alloc(type, SVs_PADTMP);
3402     return CHECKOP(type, svop);
3403 }
3404
3405 OP *
3406 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3407 {
3408     dVAR;
3409     PADOP *padop;
3410     NewOp(1101, padop, 1, PADOP);
3411     padop->op_type = (OPCODE)type;
3412     padop->op_ppaddr = PL_ppaddr[type];
3413     padop->op_padix = pad_alloc(type, SVs_PADTMP);
3414     SvREFCNT_dec(PAD_SVl(padop->op_padix));
3415     PAD_SETSV(padop->op_padix, sv);
3416     if (sv)
3417         SvPADTMP_on(sv);
3418     padop->op_next = (OP*)padop;
3419     padop->op_flags = (U8)flags;
3420     if (PL_opargs[type] & OA_RETSCALAR)
3421         scalar((OP*)padop);
3422     if (PL_opargs[type] & OA_TARGET)
3423         padop->op_targ = pad_alloc(type, SVs_PADTMP);
3424     return CHECKOP(type, padop);
3425 }
3426
3427 OP *
3428 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3429 {
3430     dVAR;
3431 #ifdef USE_ITHREADS
3432     if (gv)
3433         GvIN_PAD_on(gv);
3434     return newPADOP(type, flags, SvREFCNT_inc_simple(gv));
3435 #else
3436     return newSVOP(type, flags, SvREFCNT_inc_simple(gv));
3437 #endif
3438 }
3439
3440 OP *
3441 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3442 {
3443     dVAR;
3444     PVOP *pvop;
3445     NewOp(1101, pvop, 1, PVOP);
3446     pvop->op_type = (OPCODE)type;
3447     pvop->op_ppaddr = PL_ppaddr[type];
3448     pvop->op_pv = pv;
3449     pvop->op_next = (OP*)pvop;
3450     pvop->op_flags = (U8)flags;
3451     if (PL_opargs[type] & OA_RETSCALAR)
3452         scalar((OP*)pvop);
3453     if (PL_opargs[type] & OA_TARGET)
3454         pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3455     return CHECKOP(type, pvop);
3456 }
3457
3458 #ifdef PERL_MAD
3459 OP*
3460 #else
3461 void
3462 #endif
3463 Perl_package(pTHX_ OP *o)
3464 {
3465     dVAR;
3466     const char *name;
3467     STRLEN len;
3468 #ifdef PERL_MAD
3469     OP *pegop;
3470 #endif
3471
3472     save_hptr(&PL_curstash);
3473     save_item(PL_curstname);
3474
3475     name = SvPV_const(cSVOPo->op_sv, len);
3476     PL_curstash = gv_stashpvn(name, len, TRUE);
3477     sv_setpvn(PL_curstname, name, len);
3478
3479     PL_hints |= HINT_BLOCK_SCOPE;
3480     PL_copline = NOLINE;
3481     PL_expect = XSTATE;
3482
3483 #ifndef PERL_MAD
3484     op_free(o);
3485 #else
3486     if (!PL_madskills) {
3487         op_free(o);
3488         return NULL;
3489     }
3490
3491     pegop = newOP(OP_NULL,0);
3492     op_getmad(o,pegop,'P');
3493     return pegop;
3494 #endif
3495 }
3496
3497 #ifdef PERL_MAD
3498 OP*
3499 #else
3500 void
3501 #endif
3502 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
3503 {
3504     dVAR;
3505     OP *pack;
3506     OP *imop;
3507     OP *veop;
3508 #ifdef PERL_MAD
3509     OP *pegop = newOP(OP_NULL,0);
3510 #endif
3511
3512     if (idop->op_type != OP_CONST)
3513         Perl_croak(aTHX_ "Module name must be constant");
3514
3515     if (PL_madskills)
3516         op_getmad(idop,pegop,'U');
3517
3518     veop = NULL;
3519
3520     if (version) {
3521         SV * const vesv = ((SVOP*)version)->op_sv;
3522
3523         if (PL_madskills)
3524             op_getmad(version,pegop,'V');
3525         if (!arg && !SvNIOKp(vesv)) {
3526             arg = version;
3527         }
3528         else {
3529             OP *pack;
3530             SV *meth;
3531
3532             if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3533                 Perl_croak(aTHX_ "Version number must be constant number");
3534
3535             /* Make copy of idop so we don't free it twice */
3536             pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3537
3538             /* Fake up a method call to VERSION */
3539             meth = newSVpvs_share("VERSION");
3540             veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3541                             append_elem(OP_LIST,
3542                                         prepend_elem(OP_LIST, pack, list(version)),
3543                                         newSVOP(OP_METHOD_NAMED, 0, meth)));
3544         }
3545     }
3546
3547     /* Fake up an import/unimport */
3548     if (arg && arg->op_type == OP_STUB) {
3549         if (PL_madskills)
3550             op_getmad(arg,pegop,'S');
3551         imop = arg;             /* no import on explicit () */
3552     }
3553     else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
3554         imop = NULL;            /* use 5.0; */
3555         if (!aver)
3556             idop->op_private |= OPpCONST_NOVER;
3557     }
3558     else {
3559         SV *meth;
3560
3561         if (PL_madskills)
3562             op_getmad(arg,pegop,'A');
3563
3564         /* Make copy of idop so we don't free it twice */
3565         pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3566
3567         /* Fake up a method call to import/unimport */
3568         meth = aver
3569             ? newSVpvs_share("import") : newSVpvs_share("unimport");
3570         imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3571                        append_elem(OP_LIST,
3572                                    prepend_elem(OP_LIST, pack, list(arg)),
3573                                    newSVOP(OP_METHOD_NAMED, 0, meth)));
3574     }
3575
3576     /* Fake up the BEGIN {}, which does its thing immediately. */
3577     newATTRSUB(floor,
3578         newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
3579         NULL,
3580         NULL,
3581         append_elem(OP_LINESEQ,
3582             append_elem(OP_LINESEQ,
3583                 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
3584                 newSTATEOP(0, NULL, veop)),
3585             newSTATEOP(0, NULL, imop) ));
3586
3587     /* The "did you use incorrect case?" warning used to be here.
3588      * The problem is that on case-insensitive filesystems one
3589      * might get false positives for "use" (and "require"):
3590      * "use Strict" or "require CARP" will work.  This causes
3591      * portability problems for the script: in case-strict
3592      * filesystems the script will stop working.
3593      *
3594      * The "incorrect case" warning checked whether "use Foo"
3595      * imported "Foo" to your namespace, but that is wrong, too:
3596      * there is no requirement nor promise in the language that
3597      * a Foo.pm should or would contain anything in package "Foo".
3598      *
3599      * There is very little Configure-wise that can be done, either:
3600      * the case-sensitivity of the build filesystem of Perl does not
3601      * help in guessing the case-sensitivity of the runtime environment.
3602      */
3603
3604     PL_hints |= HINT_BLOCK_SCOPE;
3605     PL_copline = NOLINE;
3606     PL_expect = XSTATE;
3607     PL_cop_seqmax++; /* Purely for B::*'s benefit */
3608
3609 #ifdef PERL_MAD
3610     if (!PL_madskills) {
3611         /* FIXME - don't allocate pegop if !PL_madskills */
3612         op_free(pegop);
3613         return NULL;
3614     }
3615     return pegop;
3616 #endif
3617 }
3618
3619 /*
3620 =head1 Embedding Functions
3621
3622 =for apidoc load_module
3623
3624 Loads the module whose name is pointed to by the string part of name.
3625 Note that the actual module name, not its filename, should be given.
3626 Eg, "Foo::Bar" instead of "Foo/Bar.pm".  flags can be any of
3627 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3628 (or 0 for no flags). ver, if specified, provides version semantics
3629 similar to C<use Foo::Bar VERSION>.  The optional trailing SV*
3630 arguments can be used to specify arguments to the module's import()
3631 method, similar to C<use Foo::Bar VERSION LIST>.
3632
3633 =cut */
3634
3635 void
3636 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3637 {
3638     va_list args;
3639     va_start(args, ver);
3640     vload_module(flags, name, ver, &args);
3641     va_end(args);
3642 }
3643
3644 #ifdef PERL_IMPLICIT_CONTEXT
3645 void
3646 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3647 {
3648     dTHX;
3649     va_list args;
3650     va_start(args, ver);
3651     vload_module(flags, name, ver, &args);
3652     va_end(args);
3653 }
3654 #endif
3655
3656 void
3657 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3658 {
3659     dVAR;
3660     OP *veop, *imop;
3661
3662     OP * const modname = newSVOP(OP_CONST, 0, name);
3663     modname->op_private |= OPpCONST_BARE;
3664     if (ver) {
3665         veop = newSVOP(OP_CONST, 0, ver);
3666     }
3667     else
3668         veop = NULL;
3669     if (flags & PERL_LOADMOD_NOIMPORT) {
3670         imop = sawparens(newNULLLIST());
3671     }
3672     else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3673         imop = va_arg(*args, OP*);
3674     }
3675     else {
3676         SV *sv;
3677         imop = NULL;
3678         sv = va_arg(*args, SV*);
3679         while (sv) {
3680             imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3681             sv = va_arg(*args, SV*);
3682         }
3683     }
3684     {
3685         const line_t ocopline = PL_copline;
3686         COP * const ocurcop = PL_curcop;
3687         const int oexpect = PL_expect;
3688
3689         utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3690                 veop, modname, imop);
3691         PL_expect = oexpect;
3692         PL_copline = ocopline;
3693         PL_curcop = ocurcop;
3694     }
3695 }
3696
3697 OP *
3698 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
3699 {
3700     dVAR;
3701     OP *doop;
3702     GV *gv = NULL;
3703
3704     if (!force_builtin) {
3705         gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
3706         if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
3707             GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
3708             gv = gvp ? *gvp : NULL;
3709         }
3710     }
3711
3712     if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3713         doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3714                                append_elem(OP_LIST, term,
3715                                            scalar(newUNOP(OP_RV2CV, 0,
3716                                                           newGVOP(OP_GV, 0, gv))))));
3717     }
3718     else {
3719         doop = newUNOP(OP_DOFILE, 0, scalar(term));
3720     }
3721     return doop;
3722 }
3723
3724 OP *
3725 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3726 {
3727     return newBINOP(OP_LSLICE, flags,
3728             list(force_list(subscript)),
3729             list(force_list(listval)) );
3730 }
3731
3732 STATIC I32
3733 S_is_list_assignment(pTHX_ register const OP *o)
3734 {
3735     unsigned type;
3736     U8 flags;
3737
3738     if (!o)
3739         return TRUE;
3740
3741     if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
3742         o = cUNOPo->op_first;
3743
3744     flags = o->op_flags;
3745     type = o->op_type;
3746     if (type == OP_COND_EXPR) {
3747         const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
3748         const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3749
3750         if (t && f)
3751             return TRUE;
3752         if (t || f)
3753             yyerror("Assignment to both a list and a scalar");
3754         return FALSE;
3755     }
3756
3757     if (type == OP_LIST &&
3758         (flags & OPf_WANT) == OPf_WANT_SCALAR &&
3759         o->op_private & OPpLVAL_INTRO)
3760         return FALSE;
3761
3762     if (type == OP_LIST || flags & OPf_PARENS ||
3763         type == OP_RV2AV || type == OP_RV2HV ||
3764         type == OP_ASLICE || type == OP_HSLICE)
3765         return TRUE;
3766
3767     if (type == OP_PADAV || type == OP_PADHV)
3768         return TRUE;
3769
3770     if (type == OP_RV2SV)
3771         return FALSE;
3772
3773     return FALSE;
3774 }
3775
3776 OP *
3777 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3778 {
3779     dVAR;
3780     OP *o;
3781
3782     if (optype) {
3783         if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
3784             return newLOGOP(optype, 0,
3785                 mod(scalar(left), optype),
3786                 newUNOP(OP_SASSIGN, 0, scalar(right)));
3787         }
3788         else {
3789             return newBINOP(optype, OPf_STACKED,
3790                 mod(scalar(left), optype), scalar(right));
3791         }
3792     }
3793
3794     if (is_list_assignment(left)) {
3795         OP *curop;
3796
3797         PL_modcount = 0;
3798         /* Grandfathering $[ assignment here.  Bletch.*/
3799         /* Only simple assignments like C<< ($[) = 1 >> are allowed */
3800         PL_eval_start = (left->op_type == OP_CONST) ? right : 0;
3801         left = mod(left, OP_AASSIGN);
3802         if (PL_eval_start)
3803             PL_eval_start = 0;
3804         else if (left->op_type == OP_CONST) {
3805             /* FIXME for MAD */
3806             /* Result of assignment is always 1 (or we'd be dead already) */
3807             return newSVOP(OP_CONST, 0, newSViv(1));
3808         }
3809         curop = list(force_list(left));
3810         o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3811         o->op_private = (U8)(0 | (flags >> 8));
3812
3813         /* PL_generation sorcery:
3814          * an assignment like ($a,$b) = ($c,$d) is easier than
3815          * ($a,$b) = ($c,$a), since there is no need for temporary vars.
3816          * To detect whether there are common vars, the global var
3817          * PL_generation is incremented for each assign op we compile.
3818          * Then, while compiling the assign op, we run through all the
3819          * variables on both sides of the assignment, setting a spare slot
3820          * in each of them to PL_generation. If any of them already have
3821          * that value, we know we've got commonality.  We could use a
3822          * single bit marker, but then we'd have to make 2 passes, first
3823          * to clear the flag, then to test and set it.  To find somewhere
3824          * to store these values, evil chicanery is done with SvCUR().
3825          */
3826
3827         {
3828             OP *lastop = o;
3829             PL_generation++;
3830             for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3831                 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3832                     if (curop->op_type == OP_GV) {
3833                         GV *gv = cGVOPx_gv(curop);
3834                         if (gv == PL_defgv
3835                             || (int)GvASSIGN_GENERATION(gv) == PL_generation)
3836                             break;
3837                         GvASSIGN_GENERATION_set(gv, PL_generation);
3838                     }
3839                     else if (curop->op_type == OP_PADSV ||
3840                              curop->op_type == OP_PADAV ||
3841                              curop->op_type == OP_PADHV ||
3842                              curop->op_type == OP_PADANY)
3843                     {
3844                         if (PAD_COMPNAME_GEN(curop->op_targ)
3845                                                     == (STRLEN)PL_generation)
3846                             break;
3847                         PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
3848
3849                     }
3850                     else if (curop->op_type == OP_RV2CV)
3851                         break;
3852                     else if (curop->op_type == OP_RV2SV ||
3853                              curop->op_type == OP_RV2AV ||
3854                              curop->op_type == OP_RV2HV ||
3855                              curop->op_type == OP_RV2GV) {
3856                         if (lastop->op_type != OP_GV)   /* funny deref? */
3857                             break;
3858                     }
3859                     else if (curop->op_type == OP_PUSHRE) {
3860                         if (((PMOP*)curop)->op_pmreplroot) {
3861 #ifdef USE_ITHREADS
3862                             GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET,
3863                                         ((PMOP*)curop)->op_pmreplroot));
3864 #else
3865                             GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3866 #endif
3867                             if (gv == PL_defgv
3868                                 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
3869                                 break;
3870                             GvASSIGN_GENERATION_set(gv, PL_generation);
3871                             GvASSIGN_GENERATION_set(gv, PL_generation);
3872                         }
3873                     }
3874                     else
3875                         break;
3876                 }
3877                 lastop = curop;
3878             }
3879             if (curop != o)
3880                 o->op_private |= OPpASSIGN_COMMON;
3881         }
3882
3883         if ( ((left->op_private & OPpLVAL_INTRO) || ckWARN(WARN_MISC))
3884                 && (left->op_type == OP_LIST
3885                     || (left->op_type == OP_NULL && left->op_targ == OP_LIST)))
3886         {
3887             OP* lop = ((LISTOP*)left)->op_first;
3888             while (lop) {
3889                 if (lop->op_type == OP_PADSV ||
3890                     lop->op_type == OP_PADAV ||
3891                     lop->op_type == OP_PADHV ||
3892                     lop->op_type == OP_PADANY)
3893                 {
3894                     if (lop->op_private & OPpPAD_STATE) {
3895                         if (left->op_private & OPpLVAL_INTRO) {
3896                             o->op_private |= OPpASSIGN_STATE;
3897                             /* hijacking PADSTALE for uninitialized state variables */
3898                             SvPADSTALE_on(PAD_SVl(lop->op_targ));
3899                         }
3900                         else { /* we already checked for WARN_MISC before */
3901                             Perl_warner(aTHX_ packWARN(WARN_MISC), "State variable %s will be reinitialized",
3902                                     PAD_COMPNAME_PV(lop->op_targ));
3903                         }
3904                     }
3905                 }
3906                 lop = lop->op_sibling;
3907             }
3908         }
3909
3910         if (right && right->op_type == OP_SPLIT) {
3911             OP* tmpop = ((LISTOP*)right)->op_first;
3912             if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
3913                 PMOP * const pm = (PMOP*)tmpop;
3914                 if (left->op_type == OP_RV2AV &&
3915                     !(left->op_private & OPpLVAL_INTRO) &&
3916                     !(o->op_private & OPpASSIGN_COMMON) )
3917                 {
3918                     tmpop = ((UNOP*)left)->op_first;
3919                     if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3920 #ifdef USE_ITHREADS
3921                         pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
3922                         cPADOPx(tmpop)->op_padix = 0;   /* steal it */
3923 #else
3924                         pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3925                         cSVOPx(tmpop)->op_sv = NULL;    /* steal it */
3926 #endif
3927                         pm->op_pmflags |= PMf_ONCE;
3928                         tmpop = cUNOPo->op_first;       /* to list (nulled) */
3929                         tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3930                         tmpop->op_sibling = NULL;       /* don't free split */
3931                         right->op_next = tmpop->op_next;  /* fix starting loc */
3932 #ifdef PERL_MAD
3933                         op_getmad(o,right,'R');         /* blow off assign */
3934 #else
3935                         op_free(o);                     /* blow off assign */
3936 #endif
3937                         right->op_flags &= ~OPf_WANT;
3938                                 /* "I don't know and I don't care." */
3939                         return right;
3940                     }
3941                 }
3942                 else {
3943                    if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3944                       ((LISTOP*)right)->op_last->op_type == OP_CONST)
3945                     {
3946                         SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3947                         if (SvIVX(sv) == 0)
3948                             sv_setiv(sv, PL_modcount+1);
3949                     }
3950                 }
3951             }
3952         }
3953         return o;
3954     }
3955     if (!right)
3956         right = newOP(OP_UNDEF, 0);
3957     if (right->op_type == OP_READLINE) {
3958         right->op_flags |= OPf_STACKED;
3959         return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3960     }
3961     else {
3962         PL_eval_start = right;  /* Grandfathering $[ assignment here.  Bletch.*/
3963         o = newBINOP(OP_SASSIGN, flags,
3964             scalar(right), mod(scalar(left), OP_SASSIGN) );
3965         if (PL_eval_start)
3966             PL_eval_start = 0;
3967         else {
3968             /* FIXME for MAD */
3969             op_free(o);
3970             o = newSVOP(OP_CONST, 0, newSViv(CopARYBASE_get(&PL_compiling)));
3971             o->op_private |= OPpCONST_ARYBASE;
3972         }
3973     }
3974     return o;
3975 }
3976
3977 OP *
3978 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3979 {
3980     dVAR;
3981     const U32 seq = intro_my();
3982     register COP *cop;
3983
3984     NewOp(1101, cop, 1, COP);
3985     if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3986         cop->op_type = OP_DBSTATE;
3987         cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3988     }
3989     else {
3990         cop->op_type = OP_NEXTSTATE;
3991         cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3992     }
3993     cop->op_flags = (U8)flags;
3994     CopHINTS_set(cop, PL_hints);
3995 #ifdef NATIVE_HINTS
3996     cop->op_private |= NATIVE_HINTS;
3997 #endif
3998     CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
3999     cop->op_next = (OP*)cop;
4000
4001     if (label) {
4002         cop->cop_label = label;
4003         PL_hints |= HINT_BLOCK_SCOPE;
4004     }
4005     cop->cop_seq = seq;
4006     /* CopARYBASE is now "virtual", in that it's stored as a flag bit in
4007        CopHINTS and a possible value in cop_hints_hash, so no need to copy it.
4008     */
4009     cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
4010     cop->cop_hints_hash = PL_curcop->cop_hints_hash;
4011     if (cop->cop_hints_hash) {
4012         HINTS_REFCNT_LOCK;
4013         cop->cop_hints_hash->refcounted_he_refcnt++;
4014         HINTS_REFCNT_UNLOCK;
4015     }
4016
4017     if (PL_copline == NOLINE)
4018         CopLINE_set(cop, CopLINE(PL_curcop));
4019     else {
4020         CopLINE_set(cop, PL_copline);
4021         PL_copline = NOLINE;
4022     }
4023 #ifdef USE_ITHREADS
4024     CopFILE_set(cop, CopFILE(PL_curcop));       /* XXX share in a pvtable? */
4025 #else
4026     CopFILEGV_set(cop, CopFILEGV(PL_curcop));
4027 #endif
4028     CopSTASH_set(cop, PL_curstash);
4029
4030     if (PERLDB_LINE && PL_curstash != PL_debstash) {
4031         AV *av = CopFILEAVx(PL_curcop);
4032         if (av) {
4033             SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE);
4034             if (svp && *svp != &PL_sv_undef ) {
4035                 (void)SvIOK_on(*svp);
4036                 SvIV_set(*svp, PTR2IV(cop));
4037             }
4038         }
4039     }
4040
4041     return prepend_elem(OP_LINESEQ, (OP*)cop, o);
4042 }
4043
4044
4045 OP *
4046 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
4047 {
4048     dVAR;
4049     return new_logop(type, flags, &first, &other);
4050 }
4051
4052 STATIC OP *
4053 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
4054 {
4055     dVAR;
4056     LOGOP *logop;
4057     OP *o;
4058     OP *first = *firstp;
4059     OP * const other = *otherp;
4060
4061     if (type == OP_XOR)         /* Not short circuit, but here by precedence. */
4062         return newBINOP(type, flags, scalar(first), scalar(other));
4063
4064     scalarboolean(first);
4065     /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
4066     if (first->op_type == OP_NOT
4067         && (first->op_flags & OPf_SPECIAL)
4068         && (first->op_flags & OPf_KIDS)) {
4069         if (type == OP_AND || type == OP_OR) {
4070             if (type == OP_AND)
4071                 type = OP_OR;
4072             else
4073                 type = OP_AND;
4074             o = first;
4075             first = *firstp = cUNOPo->op_first;
4076             if (o->op_next)
4077                 first->op_next = o->op_next;
4078             cUNOPo->op_first = NULL;
4079 #ifdef PERL_MAD
4080             op_getmad(o,first,'O');
4081 #else
4082             op_free(o);
4083 #endif
4084         }
4085     }
4086     if (first->op_type == OP_CONST) {
4087         if (first->op_private & OPpCONST_STRICT)
4088             no_bareword_allowed(first);
4089         else if ((first->op_private & OPpCONST_BARE) && ckWARN(WARN_BAREWORD))
4090                 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
4091         if ((type == OP_AND &&  SvTRUE(((SVOP*)first)->op_sv)) ||
4092             (type == OP_OR  && !SvTRUE(((SVOP*)first)->op_sv)) ||
4093             (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) {
4094             *firstp = NULL;
4095             if (other->op_type == OP_CONST)
4096                 other->op_private |= OPpCONST_SHORTCIRCUIT;
4097             if (PL_madskills) {
4098                 OP *newop = newUNOP(OP_NULL, 0, other);
4099                 op_getmad(first, newop, '1');
4100                 newop->op_targ = type;  /* set "was" field */
4101                 return newop;
4102             }
4103             op_free(first);
4104             return other;
4105         }
4106         else {
4107             /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
4108             const OP *o2 = other;
4109             if ( ! (o2->op_type == OP_LIST
4110                     && (( o2 = cUNOPx(o2)->op_first))
4111                     && o2->op_type == OP_PUSHMARK
4112                     && (( o2 = o2->op_sibling)) )
4113             )
4114                 o2 = other;
4115             if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
4116                         || o2->op_type == OP_PADHV)
4117                 && o2->op_private & OPpLVAL_INTRO
4118                 && ckWARN(WARN_DEPRECATED))
4119             {
4120                 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4121                             "Deprecated use of my() in false conditional");
4122             }
4123
4124             *otherp = NULL;
4125             if (first->op_type == OP_CONST)
4126                 first->op_private |= OPpCONST_SHORTCIRCUIT;
4127             if (PL_madskills) {
4128                 first = newUNOP(OP_NULL, 0, first);
4129                 op_getmad(other, first, '2');
4130                 first->op_targ = type;  /* set "was" field */
4131             }
4132             else
4133                 op_free(other);
4134             return first;
4135         }
4136     }
4137     else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
4138         && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
4139     {
4140         const OP * const k1 = ((UNOP*)first)->op_first;
4141         const OP * const k2 = k1->op_sibling;
4142         OPCODE warnop = 0;
4143         switch (first->op_type)
4144         {
4145         case OP_NULL:
4146             if (k2 && k2->op_type == OP_READLINE
4147                   && (k2->op_flags & OPf_STACKED)
4148                   && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4149             {
4150                 warnop = k2->op_type;
4151             }
4152             break;
4153
4154         case OP_SASSIGN:
4155             if (k1->op_type == OP_READDIR
4156                   || k1->op_type == OP_GLOB
4157                   || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4158                   || k1->op_type == OP_EACH)
4159             {
4160                 warnop = ((k1->op_type == OP_NULL)
4161                           ? (OPCODE)k1->op_targ : k1->op_type);
4162             }
4163             break;
4164         }
4165         if (warnop) {
4166             const line_t oldline = CopLINE(PL_curcop);
4167             CopLINE_set(PL_curcop, PL_copline);
4168             Perl_warner(aTHX_ packWARN(WARN_MISC),
4169                  "Value of %s%s can be \"0\"; test with defined()",
4170                  PL_op_desc[warnop],
4171                  ((warnop == OP_READLINE || warnop == OP_GLOB)
4172                   ? " construct" : "() operator"));
4173             CopLINE_set(PL_curcop, oldline);
4174         }
4175     }
4176
4177     if (!other)
4178         return first;
4179
4180     if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
4181         other->op_private |= OPpASSIGN_BACKWARDS;  /* other is an OP_SASSIGN */
4182
4183     NewOp(1101, logop, 1, LOGOP);
4184
4185     logop->op_type = (OPCODE)type;
4186     logop->op_ppaddr = PL_ppaddr[type];
4187     logop->op_first = first;
4188     logop->op_flags = (U8)(flags | OPf_KIDS);
4189     logop->op_other = LINKLIST(other);
4190     logop->op_private = (U8)(1 | (flags >> 8));
4191
4192     /* establish postfix order */
4193     logop->op_next = LINKLIST(first);
4194     first->op_next = (OP*)logop;
4195     first->op_sibling = other;
4196
4197     CHECKOP(type,logop);
4198
4199     o = newUNOP(OP_NULL, 0, (OP*)logop);
4200     other->op_next = o;
4201
4202     return o;
4203 }
4204
4205 OP *
4206 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
4207 {
4208     dVAR;
4209     LOGOP *logop;
4210     OP *start;
4211     OP *o;
4212
4213     if (!falseop)
4214         return newLOGOP(OP_AND, 0, first, trueop);
4215     if (!trueop)
4216         return newLOGOP(OP_OR, 0, first, falseop);
4217
4218     scalarboolean(first);
4219     if (first->op_type == OP_CONST) {
4220         if (first->op_private & OPpCONST_BARE &&
4221             first->op_private & OPpCONST_STRICT) {
4222             no_bareword_allowed(first);
4223         }
4224         if (SvTRUE(((SVOP*)first)->op_sv)) {
4225 #ifdef PERL_MAD
4226             if (PL_madskills) {
4227                 trueop = newUNOP(OP_NULL, 0, trueop);
4228                 op_getmad(first,trueop,'C');
4229                 op_getmad(falseop,trueop,'e');
4230             }
4231             /* FIXME for MAD - should there be an ELSE here?  */
4232 #else
4233             op_free(first);
4234             op_free(falseop);
4235 #endif
4236             return trueop;
4237         }
4238         else {
4239 #ifdef PERL_MAD
4240             if (PL_madskills) {
4241                 falseop = newUNOP(OP_NULL, 0, falseop);
4242                 op_getmad(first,falseop,'C');
4243                 op_getmad(trueop,falseop,'t');
4244             }
4245             /* FIXME for MAD - should there be an ELSE here?  */
4246 #else
4247             op_free(first);
4248             op_free(trueop);
4249 #endif
4250             return falseop;
4251         }
4252     }
4253     NewOp(1101, logop, 1, LOGOP);
4254     logop->op_type = OP_COND_EXPR;
4255     logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
4256     logop->op_first = first;
4257     logop->op_flags = (U8)(flags | OPf_KIDS);
4258     logop->op_private = (U8)(1 | (flags >> 8));
4259     logop->op_other = LINKLIST(trueop);
4260     logop->op_next = LINKLIST(falseop);
4261
4262     CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
4263             logop);
4264
4265     /* establish postfix order */
4266     start = LINKLIST(first);
4267     first->op_next = (OP*)logop;
4268
4269     first->op_sibling = trueop;
4270     trueop->op_sibling = falseop;
4271     o = newUNOP(OP_NULL, 0, (OP*)logop);
4272
4273     trueop->op_next = falseop->op_next = o;
4274
4275     o->op_next = start;
4276     return o;
4277 }
4278
4279 OP *
4280 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
4281 {
4282     dVAR;
4283     LOGOP *range;
4284     OP *flip;
4285     OP *flop;
4286     OP *leftstart;
4287     OP *o;
4288
4289     NewOp(1101, range, 1, LOGOP);
4290
4291     range->op_type = OP_RANGE;
4292     range->op_ppaddr = PL_ppaddr[OP_RANGE];
4293     range->op_first = left;
4294     range->op_flags = OPf_KIDS;
4295     leftstart = LINKLIST(left);
4296     range->op_other = LINKLIST(right);
4297     range->op_private = (U8)(1 | (flags >> 8));
4298
4299     left->op_sibling = right;
4300
4301     range->op_next = (OP*)range;
4302     flip = newUNOP(OP_FLIP, flags, (OP*)range);
4303     flop = newUNOP(OP_FLOP, 0, flip);
4304     o = newUNOP(OP_NULL, 0, flop);
4305     linklist(flop);
4306     range->op_next = leftstart;
4307
4308     left->op_next = flip;
4309     right->op_next = flop;
4310
4311     range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4312     sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
4313     flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4314     sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
4315
4316     flip->op_private =  left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4317     flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4318
4319     flip->op_next = o;
4320     if (!flip->op_private || !flop->op_private)
4321         linklist(o);            /* blow off optimizer unless constant */
4322
4323     return o;
4324 }
4325
4326 OP *
4327 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
4328 {
4329     dVAR;
4330     OP* listop;
4331     OP* o;
4332     const bool once = block && block->op_flags & OPf_SPECIAL &&
4333       (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
4334
4335     PERL_UNUSED_ARG(debuggable);
4336
4337     if (expr) {
4338         if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
4339             return block;       /* do {} while 0 does once */
4340         if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4341             || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4342             expr = newUNOP(OP_DEFINED, 0,
4343                 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4344         } else if (expr->op_flags & OPf_KIDS) {
4345             const OP * const k1 = ((UNOP*)expr)->op_first;
4346             const OP * const k2 = k1 ? k1->op_sibling : NULL;
4347             switch (expr->op_type) {
4348               case OP_NULL:
4349                 if (k2 && k2->op_type == OP_READLINE
4350                       && (k2->op_flags & OPf_STACKED)
4351                       && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4352                     expr = newUNOP(OP_DEFINED, 0, expr);
4353                 break;
4354
4355               case OP_SASSIGN:
4356                 if (k1 && (k1->op_type == OP_READDIR
4357                       || k1->op_type == OP_GLOB
4358                       || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4359                       || k1->op_type == OP_EACH))
4360                     expr = newUNOP(OP_DEFINED, 0, expr);
4361                 break;
4362             }
4363         }
4364     }
4365
4366     /* if block is null, the next append_elem() would put UNSTACK, a scalar
4367      * op, in listop. This is wrong. [perl #27024] */
4368     if (!block)
4369         block = newOP(OP_NULL, 0);
4370     listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
4371     o = new_logop(OP_AND, 0, &expr, &listop);
4372
4373     if (listop)
4374         ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
4375
4376     if (once && o != listop)
4377         o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
4378
4379     if (o == listop)
4380         o = newUNOP(OP_NULL, 0, o);     /* or do {} while 1 loses outer block */
4381
4382     o->op_flags |= flags;
4383     o = scope(o);
4384     o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
4385     return o;
4386 }
4387
4388 OP *
4389 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
4390 whileline, OP *expr, OP *block, OP *cont, I32 has_my)
4391 {
4392     dVAR;
4393     OP *redo;
4394     OP *next = NULL;
4395     OP *listop;
4396     OP *o;
4397     U8 loopflags = 0;
4398
4399     PERL_UNUSED_ARG(debuggable);
4400
4401     if (expr) {
4402         if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4403                      || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4404             expr = newUNOP(OP_DEFINED, 0,
4405                 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4406         } else if (expr->op_flags & OPf_KIDS) {
4407             const OP * const k1 = ((UNOP*)expr)->op_first;
4408             const OP * const k2 = (k1) ? k1->op_sibling : NULL;
4409             switch (expr->op_type) {
4410               case OP_NULL:
4411                 if (k2 && k2->op_type == OP_READLINE
4412                       && (k2->op_flags & OPf_STACKED)
4413                       && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4414                     expr = newUNOP(OP_DEFINED, 0, expr);
4415                 break;
4416
4417               case OP_SASSIGN:
4418                 if (k1 && (k1->op_type == OP_READDIR
4419                       || k1->op_type == OP_GLOB
4420                       || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4421                       || k1->op_type == OP_EACH))
4422                     expr = newUNOP(OP_DEFINED, 0, expr);
4423                 break;
4424             }
4425         }
4426     }
4427
4428     if (!block)
4429         block = newOP(OP_NULL, 0);
4430     else if (cont || has_my) {
4431         block = scope(block);
4432     }
4433
4434     if (cont) {
4435         next = LINKLIST(cont);
4436     }
4437     if (expr) {
4438         OP * const unstack = newOP(OP_UNSTACK, 0);
4439         if (!next)
4440             next = unstack;
4441         cont = append_elem(OP_LINESEQ, cont, unstack);
4442     }
4443
4444     assert(block);
4445     listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4446     assert(listop);
4447     redo = LINKLIST(listop);
4448
4449     if (expr) {
4450         PL_copline = (line_t)whileline;
4451         scalar(listop);
4452         o = new_logop(OP_AND, 0, &expr, &listop);
4453         if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4454             op_free(expr);              /* oops, it's a while (0) */
4455             op_free((OP*)loop);
4456             return NULL;                /* listop already freed by new_logop */
4457         }
4458         if (listop)
4459             ((LISTOP*)listop)->op_last->op_next =
4460                 (o == listop ? redo : LINKLIST(o));
4461     }
4462     else
4463         o = listop;
4464
4465     if (!loop) {
4466         NewOp(1101,loop,1,LOOP);
4467         loop->op_type = OP_ENTERLOOP;
4468         loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4469         loop->op_private = 0;
4470         loop->op_next = (OP*)loop;
4471     }
4472
4473     o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4474
4475     loop->op_redoop = redo;
4476     loop->op_lastop = o;
4477     o->op_private |= loopflags;
4478
4479     if (next)
4480         loop->op_nextop = next;
4481     else
4482         loop->op_nextop = o;
4483
4484     o->op_flags |= flags;
4485     o->op_private |= (flags >> 8);
4486     return o;
4487 }
4488
4489 OP *
4490 Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont)
4491 {
4492     dVAR;
4493     LOOP *loop;
4494     OP *wop;
4495     PADOFFSET padoff = 0;
4496     I32 iterflags = 0;
4497     I32 iterpflags = 0;
4498     OP *madsv = NULL;
4499
4500     if (sv) {
4501         if (sv->op_type == OP_RV2SV) {  /* symbol table variable */
4502             iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
4503             sv->op_type = OP_RV2GV;
4504             sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4505             if (cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
4506                 iterpflags |= OPpITER_DEF;
4507         }
4508         else if (sv->op_type == OP_PADSV) { /* private variable */
4509             iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
4510             padoff = sv->op_targ;
4511             if (PL_madskills)
4512                 madsv = sv;
4513             else {
4514                 sv->op_targ = 0;
4515                 op_free(sv);
4516             }
4517             sv = NULL;
4518         }
4519         else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
4520             padoff = sv->op_targ;
4521             if (PL_madskills)
4522                 madsv = sv;
4523             else {
4524                 sv->op_targ = 0;
4525                 iterflags |= OPf_SPECIAL;
4526                 op_free(sv);
4527             }
4528             sv = NULL;
4529         }
4530         else
4531             Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4532         if (padoff && strEQ(PAD_COMPNAME_PV(padoff), "$_"))
4533             iterpflags |= OPpITER_DEF;
4534     }
4535     else {
4536         const PADOFFSET offset = pad_findmy("$_");
4537         if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
4538             sv = newGVOP(OP_GV, 0, PL_defgv);
4539         }
4540         else {
4541             padoff = offset;
4542         }
4543         iterpflags |= OPpITER_DEF;
4544     }
4545     if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4546         expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4547         iterflags |= OPf_STACKED;
4548     }
4549     else if (expr->op_type == OP_NULL &&
4550              (expr->op_flags & OPf_KIDS) &&
4551              ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4552     {
4553         /* Basically turn for($x..$y) into the same as for($x,$y), but we
4554          * set the STACKED flag to indicate that these values are to be
4555          * treated as min/max values by 'pp_iterinit'.
4556          */
4557         const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4558         LOGOP* const range = (LOGOP*) flip->op_first;
4559         OP* const left  = range->op_first;
4560         OP* const right = left->op_sibling;
4561         LISTOP* listop;
4562
4563         range->op_flags &= ~OPf_KIDS;
4564         range->op_first = NULL;
4565
4566         listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4567         listop->op_first->op_next = range->op_next;
4568         left->op_next = range->op_other;
4569         right->op_next = (OP*)listop;
4570         listop->op_next = listop->op_first;
4571
4572 #ifdef PERL_MAD
4573         op_getmad(expr,(OP*)listop,'O');
4574 #else
4575         op_free(expr);
4576 #endif
4577         expr = (OP*)(listop);
4578         op_null(expr);
4579         iterflags |= OPf_STACKED;
4580     }
4581     else {
4582         expr = mod(force_list(expr), OP_GREPSTART);
4583     }
4584
4585     loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4586                                append_elem(OP_LIST, expr, scalar(sv))));
4587     assert(!loop->op_next);
4588     /* for my  $x () sets OPpLVAL_INTRO;
4589      * for our $x () sets OPpOUR_INTRO */
4590     loop->op_private = (U8)iterpflags;
4591 #ifdef PL_OP_SLAB_ALLOC
4592     {
4593         LOOP *tmp;
4594         NewOp(1234,tmp,1,LOOP);
4595         Copy(loop,tmp,1,LISTOP);
4596         S_op_destroy(aTHX_ loop);
4597         loop = tmp;
4598     }
4599 #else
4600     loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
4601 #endif
4602     loop->op_targ = padoff;
4603     wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
4604     if (madsv)
4605         op_getmad(madsv, (OP*)loop, 'v');
4606     PL_copline = forline;
4607     return newSTATEOP(0, label, wop);
4608 }
4609
4610 OP*
4611 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4612 {
4613     dVAR;
4614     OP *o;
4615
4616     if (type != OP_GOTO || label->op_type == OP_CONST) {
4617         /* "last()" means "last" */
4618         if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4619             o = newOP(type, OPf_SPECIAL);
4620         else {
4621             o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4622                                         ? SvPVx_nolen_const(((SVOP*)label)->op_sv)
4623                                         : ""));
4624         }
4625 #ifdef PERL_MAD
4626         op_getmad(label,o,'L');
4627 #else
4628         op_free(label);
4629 #endif
4630     }
4631     else {
4632         /* Check whether it's going to be a goto &function */
4633         if (label->op_type == OP_ENTERSUB
4634                 && !(label->op_flags & OPf_STACKED))
4635             label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4636         o = newUNOP(type, OPf_STACKED, label);
4637     }
4638     PL_hints |= HINT_BLOCK_SCOPE;
4639     return o;
4640 }
4641
4642 /* if the condition is a literal array or hash
4643    (or @{ ... } etc), make a reference to it.
4644  */
4645 STATIC OP *
4646 S_ref_array_or_hash(pTHX_ OP *cond)
4647 {
4648     if (cond
4649     && (cond->op_type == OP_RV2AV
4650     ||  cond->op_type == OP_PADAV
4651     ||  cond->op_type == OP_RV2HV
4652     ||  cond->op_type == OP_PADHV))
4653
4654         return newUNOP(OP_REFGEN,
4655             0, mod(cond, OP_REFGEN));
4656
4657     else
4658         return cond;
4659 }
4660
4661 /* These construct the optree fragments representing given()
4662    and when() blocks.
4663
4664    entergiven and enterwhen are LOGOPs; the op_other pointer
4665    points up to the associated leave op. We need this so we
4666    can put it in the context and make break/continue work.
4667    (Also, of course, pp_enterwhen will jump straight to
4668    op_other if the match fails.)
4669  */
4670
4671 STATIC
4672 OP *
4673 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
4674                    I32 enter_opcode, I32 leave_opcode,
4675                    PADOFFSET entertarg)
4676 {
4677     dVAR;
4678     LOGOP *enterop;
4679     OP *o;
4680
4681     NewOp(1101, enterop, 1, LOGOP);
4682     enterop->op_type = enter_opcode;
4683     enterop->op_ppaddr = PL_ppaddr[enter_opcode];
4684     enterop->op_flags =  (U8) OPf_KIDS;
4685     enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
4686     enterop->op_private = 0;
4687
4688     o = newUNOP(leave_opcode, 0, (OP *) enterop);
4689
4690     if (cond) {
4691         enterop->op_first = scalar(cond);
4692         cond->op_sibling = block;
4693
4694         o->op_next = LINKLIST(cond);
4695         cond->op_next = (OP *) enterop;
4696     }
4697     else {
4698         /* This is a default {} block */
4699         enterop->op_first = block;
4700         enterop->op_flags |= OPf_SPECIAL;
4701
4702         o->op_next = (OP *) enterop;
4703     }
4704
4705     CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
4706                                        entergiven and enterwhen both
4707                                        use ck_null() */
4708
4709     enterop->op_next = LINKLIST(block);
4710     block->op_next = enterop->op_other = o;
4711
4712     return o;
4713 }
4714
4715 /* Does this look like a boolean operation? For these purposes
4716    a boolean operation is:
4717      - a subroutine call [*]
4718      - a logical connective
4719      - a comparison operator
4720      - a filetest operator, with the exception of -s -M -A -C
4721      - defined(), exists() or eof()
4722      - /$re/ or $foo =~ /$re/
4723
4724    [*] possibly surprising
4725  */
4726 STATIC
4727 bool
4728 S_looks_like_bool(pTHX_ const OP *o)
4729 {
4730     dVAR;
4731     switch(o->op_type) {
4732         case OP_OR:
4733             return looks_like_bool(cLOGOPo->op_first);
4734
4735         case OP_AND:
4736             return (
4737                 looks_like_bool(cLOGOPo->op_first)
4738              && looks_like_bool(cLOGOPo->op_first->op_sibling));
4739
4740         case OP_ENTERSUB:
4741
4742         case OP_NOT:    case OP_XOR:
4743         /* Note that OP_DOR is not here */
4744
4745         case OP_EQ:     case OP_NE:     case OP_LT:
4746         case OP_GT:     case OP_LE:     case OP_GE:
4747
4748         case OP_I_EQ:   case OP_I_NE:   case OP_I_LT:
4749         case OP_I_GT:   case OP_I_LE:   case OP_I_GE:
4750
4751         case OP_SEQ:    case OP_SNE:    case OP_SLT:
4752         case OP_SGT:    case OP_SLE:    case OP_SGE:
4753
4754         case OP_SMARTMATCH:
4755
4756         case OP_FTRREAD:  case OP_FTRWRITE: case OP_FTREXEC:
4757         case OP_FTEREAD:  case OP_FTEWRITE: case OP_FTEEXEC:
4758         case OP_FTIS:     case OP_FTEOWNED: case OP_FTROWNED:
4759         case OP_FTZERO:   case OP_FTSOCK:   case OP_FTCHR:
4760         case OP_FTBLK:    case OP_FTFILE:   case OP_FTDIR:
4761         case OP_FTPIPE:   case OP_FTLINK:   case OP_FTSUID:
4762         case OP_FTSGID:   case OP_FTSVTX:   case OP_FTTTY:
4763         case OP_FTTEXT:   case OP_FTBINARY:
4764
4765         case OP_DEFINED: case OP_EXISTS:
4766         case OP_MATCH:   case OP_EOF:
4767
4768             return TRUE;
4769
4770         case OP_CONST:
4771             /* Detect comparisons that have been optimized away */
4772             if (cSVOPo->op_sv == &PL_sv_yes
4773             ||  cSVOPo->op_sv == &PL_sv_no)
4774
4775                 return TRUE;
4776
4777         /* FALL THROUGH */
4778         default:
4779             return FALSE;
4780     }
4781 }
4782
4783 OP *
4784 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
4785 {
4786     dVAR;
4787     assert( cond );
4788     return newGIVWHENOP(
4789         ref_array_or_hash(cond),
4790         block,
4791         OP_ENTERGIVEN, OP_LEAVEGIVEN,
4792         defsv_off);
4793 }
4794
4795 /* If cond is null, this is a default {} block */
4796 OP *
4797 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
4798 {
4799     const bool cond_llb = (!cond || looks_like_bool(cond));
4800     OP *cond_op;
4801
4802     if (cond_llb)
4803         cond_op = cond;
4804     else {
4805         cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
4806                 newDEFSVOP(),
4807                 scalar(ref_array_or_hash(cond)));
4808     }
4809
4810     return newGIVWHENOP(
4811         cond_op,
4812         append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
4813         OP_ENTERWHEN, OP_LEAVEWHEN, 0);
4814 }
4815
4816 /*
4817 =for apidoc cv_undef
4818
4819 Clear out all the active components of a CV. This can happen either
4820 by an explicit C<undef &foo>, or by the reference count going to zero.
4821 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
4822 children can still follow the full lexical scope chain.
4823
4824 =cut
4825 */
4826
4827 void
4828 Perl_cv_undef(pTHX_ CV *cv)
4829 {
4830     dVAR;
4831 #ifdef USE_ITHREADS
4832     if (CvFILE(cv) && !CvISXSUB(cv)) {
4833         /* for XSUBs CvFILE point directly to static memory; __FILE__ */
4834         Safefree(CvFILE(cv));
4835     }
4836     CvFILE(cv) = NULL;
4837 #endif
4838
4839     if (!CvISXSUB(cv) && CvROOT(cv)) {
4840         if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
4841             Perl_croak(aTHX_ "Can't undef active subroutine");
4842         ENTER;
4843
4844         PAD_SAVE_SETNULLPAD();
4845
4846         op_free(CvROOT(cv));
4847         CvROOT(cv) = NULL;
4848         CvSTART(cv) = NULL;
4849         LEAVE;
4850     }
4851     SvPOK_off((SV*)cv);         /* forget prototype */
4852     CvGV(cv) = NULL;
4853
4854     pad_undef(cv);
4855
4856     /* remove CvOUTSIDE unless this is an undef rather than a free */
4857     if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
4858         if (!CvWEAKOUTSIDE(cv))
4859             SvREFCNT_dec(CvOUTSIDE(cv));
4860         CvOUTSIDE(cv) = NULL;
4861     }
4862     if (CvCONST(cv)) {
4863         SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4864         CvCONST_off(cv);
4865     }
4866     if (CvISXSUB(cv) && CvXSUB(cv)) {
4867         CvXSUB(cv) = NULL;
4868     }
4869     /* delete all flags except WEAKOUTSIDE */
4870     CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
4871 }
4872
4873 void
4874 Perl_cv_ckproto_len(pTHX_ const CV *cv, const GV *gv, const char *p,
4875                     const STRLEN len)
4876 {
4877     /* Can't just use a strcmp on the prototype, as CONSTSUBs "cheat" by
4878        relying on SvCUR, and doubling up the buffer to hold CvFILE().  */
4879     if (((!p != !SvPOK(cv)) /* One has prototype, one has not.  */
4880          || (p && (len != SvCUR(cv) /* Not the same length.  */
4881                    || memNE(p, SvPVX_const(cv), len))))
4882          && ckWARN_d(WARN_PROTOTYPE)) {
4883         SV* const msg = sv_newmortal();
4884         SV* name = NULL;
4885
4886         if (gv)
4887             gv_efullname3(name = sv_newmortal(), gv, NULL);
4888         sv_setpv(msg, "Prototype mismatch:");
4889         if (name)
4890             Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, (void*)name);
4891         if (SvPOK(cv))
4892             Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (void*)cv);
4893         else
4894             sv_catpvs(msg, ": none");
4895         sv_catpvs(msg, " vs ");
4896         if (p)
4897             Perl_sv_catpvf(aTHX_ msg, "(%.*s)", (int) len, p);
4898         else
4899             sv_catpvs(msg, "none");
4900         Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, (void*)msg);
4901     }
4902 }
4903
4904 static void const_sv_xsub(pTHX_ CV* cv);
4905
4906 /*
4907
4908 =head1 Optree Manipulation Functions
4909
4910 =for apidoc cv_const_sv
4911
4912 If C<cv> is a constant sub eligible for inlining. returns the constant
4913 value returned by the sub.  Otherwise, returns NULL.
4914
4915 Constant subs can be created with C<newCONSTSUB> or as described in
4916 L<perlsub/"Constant Functions">.
4917
4918 =cut
4919 */
4920 SV *
4921 Perl_cv_const_sv(pTHX_ CV *cv)
4922 {
4923     PERL_UNUSED_CONTEXT;
4924     if (!cv)
4925         return NULL;
4926     if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
4927         return NULL;
4928     return CvCONST(cv) ? (SV*)CvXSUBANY(cv).any_ptr : NULL;
4929 }
4930
4931 /* op_const_sv:  examine an optree to determine whether it's in-lineable.
4932  * Can be called in 3 ways:
4933  *
4934  * !cv
4935  *      look for a single OP_CONST with attached value: return the value
4936  *
4937  * cv && CvCLONE(cv) && !CvCONST(cv)
4938  *
4939  *      examine the clone prototype, and if contains only a single
4940  *      OP_CONST referencing a pad const, or a single PADSV referencing
4941  *      an outer lexical, return a non-zero value to indicate the CV is
4942  *      a candidate for "constizing" at clone time
4943  *
4944  * cv && CvCONST(cv)
4945  *
4946  *      We have just cloned an anon prototype that was marked as a const
4947  *      candidiate. Try to grab the current value, and in the case of
4948  *      PADSV, ignore it if it has multiple references. Return the value.
4949  */
4950
4951 SV *
4952 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
4953 {
4954     dVAR;
4955     SV *sv = NULL;
4956
4957     if (!o)
4958         return NULL;
4959
4960     if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4961         o = cLISTOPo->op_first->op_sibling;
4962
4963     for (; o; o = o->op_next) {
4964         const OPCODE type = o->op_type;
4965
4966         if (sv && o->op_next == o)
4967             return sv;
4968         if (o->op_next != o) {
4969             if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4970                 continue;
4971             if (type == OP_DBSTATE)
4972                 continue;
4973         }
4974         if (type == OP_LEAVESUB || type == OP_RETURN)
4975             break;
4976         if (sv)
4977             return NULL;
4978         if (type == OP_CONST && cSVOPo->op_sv)
4979             sv = cSVOPo->op_sv;
4980         else if (cv && type == OP_CONST) {
4981             sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4982             if (!sv)
4983                 return NULL;
4984         }
4985         else if (cv && type == OP_PADSV) {
4986             if (CvCONST(cv)) { /* newly cloned anon */
4987                 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4988                 /* the candidate should have 1 ref from this pad and 1 ref
4989                  * from the parent */
4990                 if (!sv || SvREFCNT(sv) != 2)
4991                     return NULL;
4992                 sv = newSVsv(sv);
4993                 SvREADONLY_on(sv);
4994                 return sv;
4995             }
4996             else {
4997                 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
4998                     sv = &PL_sv_undef; /* an arbitrary non-null value */
4999             }
5000         }
5001         else {
5002             return NULL;
5003         }
5004     }
5005     return sv;
5006 }
5007
5008 #ifdef PERL_MAD
5009 OP *
5010 #else
5011 void
5012 #endif
5013 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5014 {
5015 #if 0
5016     /* This would be the return value, but the return cannot be reached.  */
5017     OP* pegop = newOP(OP_NULL, 0);
5018 #endif
5019
5020     PERL_UNUSED_ARG(floor);
5021
5022     if (o)
5023         SAVEFREEOP(o);
5024     if (proto)
5025         SAVEFREEOP(proto);
5026     if (attrs)
5027         SAVEFREEOP(attrs);
5028     if (block)
5029         SAVEFREEOP(block);
5030     Perl_croak(aTHX_ "\"my sub\" not yet implemented");
5031 #ifdef PERL_MAD
5032     NORETURN_FUNCTION_END;
5033 #endif
5034 }
5035
5036 CV *
5037 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
5038 {
5039     return Perl_newATTRSUB(aTHX_ floor, o, proto, NULL, block);
5040 }
5041
5042 CV *
5043 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5044 {
5045     dVAR;
5046     const char *aname;
5047     GV *gv;
5048     const char *ps;
5049     STRLEN ps_len;
5050     register CV *cv = NULL;
5051     SV *const_sv;
5052     /* If the subroutine has no body, no attributes, and no builtin attributes
5053        then it's just a sub declaration, and we may be able to get away with
5054        storing with a placeholder scalar in the symbol table, rather than a
5055        full GV and CV.  If anything is present then it will take a full CV to
5056        store it.  */
5057     const I32 gv_fetch_flags
5058         = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5059            || PL_madskills)
5060         ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
5061     const char * const name = o ? SvPVx_nolen_const(cSVOPo->op_sv) : NULL;
5062
5063     if (proto) {
5064         assert(proto->op_type == OP_CONST);
5065         ps = SvPVx_const(((SVOP*)proto)->op_sv, ps_len);
5066     }
5067     else
5068         ps = NULL;
5069
5070     if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
5071         SV * const sv = sv_newmortal();
5072         Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
5073                        PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
5074                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
5075         aname = SvPVX_const(sv);
5076     }
5077     else
5078         aname = NULL;
5079
5080     gv = name ? gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV)
5081         : gv_fetchpv(aname ? aname
5082                      : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5083                      gv_fetch_flags, SVt_PVCV);
5084
5085     if (!PL_madskills) {
5086         if (o)
5087             SAVEFREEOP(o);
5088         if (proto)
5089             SAVEFREEOP(proto);
5090         if (attrs)
5091             SAVEFREEOP(attrs);
5092     }
5093
5094     if (SvTYPE(gv) != SVt_PVGV) {       /* Maybe prototype now, and had at
5095                                            maximum a prototype before. */
5096         if (SvTYPE(gv) > SVt_NULL) {
5097             if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
5098                 && ckWARN_d(WARN_PROTOTYPE))
5099             {
5100                 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
5101             }
5102             cv_ckproto_len((CV*)gv, NULL, ps, ps_len);
5103         }
5104         if (ps)
5105             sv_setpvn((SV*)gv, ps, ps_len);
5106         else
5107             sv_setiv((SV*)gv, -1);
5108         SvREFCNT_dec(PL_compcv);
5109         cv = PL_compcv = NULL;
5110         PL_sub_generation++;
5111         goto done;
5112     }
5113
5114     cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
5115
5116 #ifdef GV_UNIQUE_CHECK
5117     if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
5118         Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
5119     }
5120 #endif
5121
5122     if (!block || !ps || *ps || attrs
5123         || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5124 #ifdef PERL_MAD
5125         || block->op_type == OP_NULL
5126 #endif
5127         )
5128         const_sv = NULL;
5129     else
5130         const_sv = op_const_sv(block, NULL);
5131
5132     if (cv) {
5133         const bool exists = CvROOT(cv) || CvXSUB(cv);
5134
5135 #ifdef GV_UNIQUE_CHECK
5136         if (exists && GvUNIQUE(gv)) {
5137             Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
5138         }
5139 #endif
5140
5141         /* if the subroutine doesn't exist and wasn't pre-declared
5142          * with a prototype, assume it will be AUTOLOADed,
5143          * skipping the prototype check
5144          */
5145         if (exists || SvPOK(cv))
5146             cv_ckproto_len(cv, gv, ps, ps_len);
5147         /* already defined (or promised)? */
5148         if (exists || GvASSUMECV(gv)) {
5149             if ((!block
5150 #ifdef PERL_MAD
5151                  || block->op_type == OP_NULL
5152 #endif
5153                  )&& !attrs) {
5154                 if (CvFLAGS(PL_compcv)) {
5155                     /* might have had built-in attrs applied */
5156                     CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5157                 }
5158                 /* just a "sub foo;" when &foo is already defined */
5159                 SAVEFREESV(PL_compcv);
5160                 goto done;
5161             }
5162             if (block
5163 #ifdef PERL_MAD
5164                 && block->op_type != OP_NULL
5165 #endif
5166                 ) {
5167                 if (ckWARN(WARN_REDEFINE)
5168                     || (CvCONST(cv)
5169                         && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
5170                 {
5171                     const line_t oldline = CopLINE(PL_curcop);
5172                     if (PL_copline != NOLINE)
5173                         CopLINE_set(PL_curcop, PL_copline);
5174                     Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5175                         CvCONST(cv) ? "Constant subroutine %s redefined"
5176                                     : "Subroutine %s redefined", name);
5177                     CopLINE_set(PL_curcop, oldline);
5178                 }
5179 #ifdef PERL_MAD
5180                 if (!PL_minus_c)        /* keep old one around for madskills */
5181 #endif
5182                     {
5183                         /* (PL_madskills unset in used file.) */
5184                         SvREFCNT_dec(cv);
5185                     }
5186                 cv = NULL;
5187             }
5188         }
5189     }
5190     if (const_sv) {
5191         SvREFCNT_inc_simple_void_NN(const_sv);
5192         if (cv) {
5193             assert(!CvROOT(cv) && !CvCONST(cv));
5194             sv_setpvn((SV*)cv, "", 0);  /* prototype is "" */
5195             CvXSUBANY(cv).any_ptr = const_sv;
5196             CvXSUB(cv) = const_sv_xsub;
5197             CvCONST_on(cv);
5198             CvISXSUB_on(cv);
5199         }
5200         else {
5201             GvCV(gv) = NULL;
5202             cv = newCONSTSUB(NULL, name, const_sv);
5203         }
5204         PL_sub_generation++;
5205         if (PL_madskills)
5206             goto install_block;
5207         op_free(block);
5208         SvREFCNT_dec(PL_compcv);
5209         PL_compcv = NULL;
5210         goto done;
5211     }
5212     if (attrs) {
5213         HV *stash;
5214         SV *rcv;
5215
5216         /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
5217          * before we clobber PL_compcv.
5218          */
5219         if (cv && (!block
5220 #ifdef PERL_MAD
5221                     || block->op_type == OP_NULL
5222 #endif
5223                     )) {
5224             rcv = (SV*)cv;
5225             /* Might have had built-in attributes applied -- propagate them. */
5226             CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5227             if (CvGV(cv) && GvSTASH(CvGV(cv)))
5228                 stash = GvSTASH(CvGV(cv));
5229             else if (CvSTASH(cv))
5230                 stash = CvSTASH(cv);
5231             else
5232                 stash = PL_curstash;
5233         }
5234         else {
5235             /* possibly about to re-define existing subr -- ignore old cv */
5236             rcv = (SV*)PL_compcv;
5237             if (name && GvSTASH(gv))
5238                 stash = GvSTASH(gv);
5239             else
5240                 stash = PL_curstash;
5241         }
5242         apply_attrs(stash, rcv, attrs, FALSE);
5243     }
5244     if (cv) {                           /* must reuse cv if autoloaded */
5245         if (
5246 #ifdef PERL_MAD
5247             (
5248 #endif
5249              !block
5250 #ifdef PERL_MAD
5251              || block->op_type == OP_NULL) && !PL_madskills
5252 #endif
5253              ) {
5254             /* got here with just attrs -- work done, so bug out */
5255             SAVEFREESV(PL_compcv);
5256             goto done;
5257         }
5258         /* transfer PL_compcv to cv */
5259         cv_undef(cv);
5260         CvFLAGS(cv) = CvFLAGS(PL_compcv);
5261         if (!CvWEAKOUTSIDE(cv))
5262             SvREFCNT_dec(CvOUTSIDE(cv));
5263         CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
5264         CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
5265         CvOUTSIDE(PL_compcv) = 0;
5266         CvPADLIST(cv) = CvPADLIST(PL_compcv);
5267         CvPADLIST(PL_compcv) = 0;
5268         /* inner references to PL_compcv must be fixed up ... */
5269         pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
5270         /* ... before we throw it away */
5271         SvREFCNT_dec(PL_compcv);
5272         PL_compcv = cv;
5273         if (PERLDB_INTER)/* Advice debugger on the new sub. */
5274           ++PL_sub_generation;
5275     }
5276     else {
5277         cv = PL_compcv;
5278         if (name) {
5279             GvCV(gv) = cv;
5280             if (PL_madskills) {
5281                 if (strEQ(name, "import")) {
5282                     PL_formfeed = (SV*)cv;
5283                     Perl_warner(aTHX_ packWARN(WARN_VOID), "%lx\n", (long)cv);
5284                 }
5285             }
5286             GvCVGEN(gv) = 0;
5287             PL_sub_generation++;
5288         }
5289     }
5290     CvGV(cv) = gv;
5291     CvFILE_set_from_cop(cv, PL_curcop);
5292     CvSTASH(cv) = PL_curstash;
5293
5294     if (ps)
5295         sv_setpvn((SV*)cv, ps, ps_len);
5296
5297     if (PL_error_count) {
5298         op_free(block);
5299         block = NULL;
5300         if (name) {
5301             const char *s = strrchr(name, ':');
5302             s = s ? s+1 : name;
5303             if (strEQ(s, "BEGIN")) {
5304                 const char not_safe[] =
5305                     "BEGIN not safe after errors--compilation aborted";
5306                 if (PL_in_eval & EVAL_KEEPERR)
5307                     Perl_croak(aTHX_ not_safe);
5308                 else {
5309                     /* force display of errors found but not reported */
5310                     sv_catpv(ERRSV, not_safe);
5311                     Perl_croak(aTHX_ "%"SVf, (void*)ERRSV);
5312                 }
5313             }
5314         }
5315     }
5316  install_block:
5317     if (!block)
5318         goto done;
5319
5320     if (CvLVALUE(cv)) {
5321         CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
5322                              mod(scalarseq(block), OP_LEAVESUBLV));
5323     }
5324     else {
5325         /* This makes sub {}; work as expected.  */
5326         if (block->op_type == OP_STUB) {
5327             OP* const newblock = newSTATEOP(0, NULL, 0);
5328 #ifdef PERL_MAD
5329             op_getmad(block,newblock,'B');
5330 #else
5331             op_free(block);
5332 #endif
5333             block = newblock;
5334         }
5335         CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
5336     }
5337     CvROOT(cv)->op_private |= OPpREFCOUNTED;
5338     OpREFCNT_set(CvROOT(cv), 1);
5339     CvSTART(cv) = LINKLIST(CvROOT(cv));
5340     CvROOT(cv)->op_next = 0;
5341     CALL_PEEP(CvSTART(cv));
5342
5343     /* now that optimizer has done its work, adjust pad values */
5344
5345     pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
5346
5347     if (CvCLONE(cv)) {
5348         assert(!CvCONST(cv));
5349         if (ps && !*ps && op_const_sv(block, cv))
5350             CvCONST_on(cv);
5351     }
5352
5353     if (name || aname) {
5354         const char *s;
5355         const char * const tname = (name ? name : aname);
5356
5357         if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
5358             SV * const sv = newSV(0);
5359             SV * const tmpstr = sv_newmortal();
5360             GV * const db_postponed = gv_fetchpvs("DB::postponed",
5361                                                   GV_ADDMULTI, SVt_PVHV);
5362             HV *hv;
5363
5364             Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
5365                            CopFILE(PL_curcop),
5366                            (long)PL_subline, (long)CopLINE(PL_curcop));
5367             gv_efullname3(tmpstr, gv, NULL);
5368             hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr), SvCUR(tmpstr), sv, 0);
5369             hv = GvHVn(db_postponed);
5370             if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
5371                 CV * const pcv = GvCV(db_postponed);
5372                 if (pcv) {
5373                     dSP;
5374                     PUSHMARK(SP);
5375                     XPUSHs(tmpstr);
5376                     PUTBACK;
5377                     call_sv((SV*)pcv, G_DISCARD);
5378                 }
5379             }
5380         }
5381
5382         if ((s = strrchr(tname,':')))
5383             s++;
5384         else
5385             s = tname;
5386
5387         if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I' && *s != 'U')
5388             goto done;
5389
5390         if (strEQ(s, "BEGIN") && !PL_error_count) {
5391             const I32 oldscope = PL_scopestack_ix;
5392             ENTER;
5393             SAVECOPFILE(&PL_compiling);
5394             SAVECOPLINE(&PL_compiling);
5395
5396             if (!PL_beginav)
5397                 PL_beginav = newAV();
5398             DEBUG_x( dump_sub(gv) );
5399             av_push(PL_beginav, (SV*)cv);
5400             GvCV(gv) = 0;               /* cv has been hijacked */
5401             call_list(oldscope, PL_beginav);
5402
5403             PL_curcop = &PL_compiling;
5404             CopHINTS_set(&PL_compiling, PL_hints);
5405             LEAVE;
5406         }
5407         else if (strEQ(s, "END") && !PL_error_count) {
5408             if (!PL_endav)
5409                 PL_endav = newAV();
5410             DEBUG_x( dump_sub(gv) );
5411             av_unshift(PL_endav, 1);
5412             av_store(PL_endav, 0, (SV*)cv);
5413             GvCV(gv) = 0;               /* cv has been hijacked */
5414         }
5415         else if (strEQ(s, "UNITCHECK") && !PL_error_count) {
5416             /* It's never too late to run a unitcheck block */
5417             if (!PL_unitcheckav)
5418                 PL_unitcheckav = newAV();
5419             DEBUG_x( dump_sub(gv) );
5420             av_unshift(PL_unitcheckav, 1);
5421             av_store(PL_unitcheckav, 0, (SV*)cv);
5422             GvCV(gv) = 0;               /* cv has been hijacked */
5423         }
5424         else if (strEQ(s, "CHECK") && !PL_error_count) {
5425             if (!PL_checkav)
5426                 PL_checkav = newAV();
5427             DEBUG_x( dump_sub(gv) );
5428             if (PL_main_start && ckWARN(WARN_VOID))
5429                 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
5430             av_unshift(PL_checkav, 1);
5431             av_store(PL_checkav, 0, (SV*)cv);
5432             GvCV(gv) = 0;               /* cv has been hijacked */
5433         }
5434         else if (strEQ(s, "INIT") && !PL_error_count) {
5435             if (!PL_initav)
5436                 PL_initav = newAV();
5437             DEBUG_x( dump_sub(gv) );
5438             if (PL_main_start && ckWARN(WARN_VOID))
5439                 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
5440             av_push(PL_initav, (SV*)cv);
5441             GvCV(gv) = 0;               /* cv has been hijacked */
5442         }
5443     }
5444
5445   done:
5446     PL_copline = NOLINE;
5447     LEAVE_SCOPE(floor);
5448     return cv;
5449 }
5450
5451 /* XXX unsafe for threads if eval_owner isn't held */
5452 /*
5453 =for apidoc newCONSTSUB
5454
5455 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
5456 eligible for inlining at compile-time.
5457
5458 =cut
5459 */
5460
5461 CV *
5462 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
5463 {
5464     dVAR;
5465     CV* cv;
5466 #ifdef USE_ITHREADS
5467     const char *const temp_p = CopFILE(PL_curcop);
5468     const STRLEN len = temp_p ? strlen(temp_p) : 0;
5469 #else
5470     SV *const temp_sv = CopFILESV(PL_curcop);
5471     STRLEN len;
5472     const char *const temp_p = temp_sv ? SvPV_const(temp_sv, len) : NULL;
5473 #endif
5474     char *const file = savepvn(temp_p, temp_p ? len : 0);
5475
5476     ENTER;
5477
5478     SAVECOPLINE(PL_curcop);
5479     CopLINE_set(PL_curcop, PL_copline);
5480
5481     SAVEHINTS();
5482     PL_hints &= ~HINT_BLOCK_SCOPE;
5483
5484     if (stash) {
5485         SAVESPTR(PL_curstash);
5486         SAVECOPSTASH(PL_curcop);
5487         PL_curstash = stash;
5488         CopSTASH_set(PL_curcop,stash);
5489     }
5490
5491     /* file becomes the CvFILE. For an XS, it's supposed to be static storage,
5492        and so doesn't get free()d.  (It's expected to be from the C pre-
5493        processor __FILE__ directive). But we need a dynamically allocated one,
5494        and we need it to get freed.  */
5495     cv = newXS_flags(name, const_sv_xsub, file, "", XS_DYNAMIC_FILENAME);
5496     CvXSUBANY(cv).any_ptr = sv;
5497     CvCONST_on(cv);
5498     Safefree(file);
5499
5500 #ifdef USE_ITHREADS
5501     if (stash)
5502         CopSTASH_free(PL_curcop);
5503 #endif
5504     LEAVE;
5505
5506     return cv;
5507 }
5508
5509 CV *
5510 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
5511                  const char *const filename, const char *const proto,
5512                  U32 flags)
5513 {
5514     CV *cv = newXS(name, subaddr, filename);
5515
5516     if (flags & XS_DYNAMIC_FILENAME) {
5517         /* We need to "make arrangements" (ie cheat) to ensure that the
5518            filename lasts as long as the PVCV we just created, but also doesn't
5519            leak  */
5520         STRLEN filename_len = strlen(filename);
5521         STRLEN proto_and_file_len = filename_len;
5522         char *proto_and_file;
5523         STRLEN proto_len;
5524
5525         if (proto) {
5526             proto_len = strlen(proto);
5527             proto_and_file_len += proto_len;
5528
5529             Newx(proto_and_file, proto_and_file_len + 1, char);
5530             Copy(proto, proto_and_file, proto_len, char);
5531             Copy(filename, proto_and_file + proto_len, filename_len + 1, char);
5532         } else {
5533             proto_len = 0;
5534             proto_and_file = savepvn(filename, filename_len);
5535         }
5536
5537         /* This gets free()d.  :-)  */
5538         sv_usepvn_flags((SV*)cv, proto_and_file, proto_and_file_len,
5539                         SV_HAS_TRAILING_NUL);
5540         if (proto) {
5541             /* This gives us the correct prototype, rather than one with the
5542                file name appended.  */
5543             SvCUR_set(cv, proto_len);
5544         } else {
5545             SvPOK_off(cv);
5546         }
5547         CvFILE(cv) = proto_and_file + proto_len;
5548     } else {
5549         sv_setpv((SV *)cv, proto);
5550     }
5551     return cv;
5552 }
5553
5554 /*
5555 =for apidoc U||newXS
5556
5557 Used by C<xsubpp> to hook up XSUBs as Perl subs.  I<filename> needs to be
5558 static storage, as it is used directly as CvFILE(), without a copy being made.
5559
5560 =cut
5561 */
5562
5563 CV *
5564 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
5565 {
5566     dVAR;
5567     GV * const gv = gv_fetchpv(name ? name :
5568                         (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5569                         GV_ADDMULTI, SVt_PVCV);
5570     register CV *cv;
5571
5572     if (!subaddr)
5573         Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
5574
5575     if ((cv = (name ? GvCV(gv) : NULL))) {
5576         if (GvCVGEN(gv)) {
5577             /* just a cached method */
5578             SvREFCNT_dec(cv);
5579             cv = NULL;
5580         }
5581         else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
5582             /* already defined (or promised) */
5583             /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
5584             if (ckWARN(WARN_REDEFINE)) {
5585                 GV * const gvcv = CvGV(cv);
5586                 if (gvcv) {
5587                     HV * const stash = GvSTASH(gvcv);
5588                     if (stash) {
5589                         const char *redefined_name = HvNAME_get(stash);
5590                         if ( strEQ(redefined_name,"autouse") ) {
5591                             const line_t oldline = CopLINE(PL_curcop);
5592                             if (PL_copline != NOLINE)
5593                                 CopLINE_set(PL_curcop, PL_copline);
5594                             Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5595                                         CvCONST(cv) ? "Constant subroutine %s redefined"
5596                                                     : "Subroutine %s redefined"
5597                                         ,name);
5598                             CopLINE_set(PL_curcop, oldline);
5599                         }
5600                     }
5601                 }
5602             }
5603             SvREFCNT_dec(cv);
5604             cv = NULL;
5605         }
5606     }
5607
5608     if (cv)                             /* must reuse cv if autoloaded */
5609         cv_undef(cv);
5610     else {
5611         cv = (CV*)newSV(0);
5612         sv_upgrade((SV *)cv, SVt_PVCV);
5613         if (name) {
5614             GvCV(gv) = cv;
5615             GvCVGEN(gv) = 0;
5616             PL_sub_generation++;
5617         }
5618     }
5619     CvGV(cv) = gv;
5620     (void)gv_fetchfile(filename);
5621     CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
5622                                    an external constant string */
5623     CvISXSUB_on(cv);
5624     CvXSUB(cv) = subaddr;
5625
5626     if (name) {
5627         const char *s = strrchr(name,':');
5628         if (s)
5629             s++;
5630         else
5631             s = name;
5632
5633         if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5634             goto done;
5635
5636         if (strEQ(s, "BEGIN")) {
5637             if (!PL_beginav)
5638                 PL_beginav = newAV();
5639             av_push(PL_beginav, (SV*)cv);
5640             GvCV(gv) = 0;               /* cv has been hijacked */
5641         }
5642         else if (strEQ(s, "END")) {
5643             if (!PL_endav)
5644                 PL_endav = newAV();
5645             av_unshift(PL_endav, 1);
5646             av_store(PL_endav, 0, (SV*)cv);
5647             GvCV(gv) = 0;               /* cv has been hijacked */
5648         }
5649         else if (strEQ(s, "CHECK")) {
5650             if (!PL_checkav)
5651                 PL_checkav = newAV();
5652             if (PL_main_start && ckWARN(WARN_VOID))
5653                 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
5654             av_unshift(PL_checkav, 1);
5655             av_store(PL_checkav, 0, (SV*)cv);
5656             GvCV(gv) = 0;               /* cv has been hijacked */
5657         }
5658         else if (strEQ(s, "INIT")) {
5659             if (!PL_initav)
5660                 PL_initav = newAV();
5661             if (PL_main_start && ckWARN(WARN_VOID))
5662                 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
5663             av_push(PL_initav, (SV*)cv);
5664             GvCV(gv) = 0;               /* cv has been hijacked */
5665         }
5666     }
5667     else
5668         CvANON_on(cv);
5669
5670 done:
5671     return cv;
5672 }
5673
5674 #ifdef PERL_MAD
5675 OP *
5676 #else
5677 void
5678 #endif
5679 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
5680 {
5681     dVAR;
5682     register CV *cv;
5683 #ifdef PERL_MAD
5684     OP* pegop = newOP(OP_NULL, 0);
5685 #endif
5686
5687     GV * const gv = o
5688         ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
5689         : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
5690
5691 #ifdef GV_UNIQUE_CHECK
5692     if (GvUNIQUE(gv)) {
5693         Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
5694     }
5695 #endif
5696     GvMULTI_on(gv);
5697     if ((cv = GvFORM(gv))) {
5698         if (ckWARN(WARN_REDEFINE)) {
5699             const line_t oldline = CopLINE(PL_curcop);
5700             if (PL_copline != NOLINE)
5701                 CopLINE_set(PL_curcop, PL_copline);
5702             Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5703                         o ? "Format %"SVf" redefined"
5704                         : "Format STDOUT redefined", (void*)cSVOPo->op_sv);
5705             CopLINE_set(PL_curcop, oldline);
5706         }
5707         SvREFCNT_dec(cv);
5708     }
5709     cv = PL_compcv;
5710     GvFORM(gv) = cv;
5711     CvGV(cv) = gv;
5712     CvFILE_set_from_cop(cv, PL_curcop);
5713
5714
5715     pad_tidy(padtidy_FORMAT);
5716     CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5717     CvROOT(cv)->op_private |= OPpREFCOUNTED;
5718     OpREFCNT_set(CvROOT(cv), 1);
5719     CvSTART(cv) = LINKLIST(CvROOT(cv));
5720     CvROOT(cv)->op_next = 0;
5721     CALL_PEEP(CvSTART(cv));
5722 #ifdef PERL_MAD
5723     op_getmad(o,pegop,'n');
5724     op_getmad_weak(block, pegop, 'b');
5725 #else
5726     op_free(o);
5727 #endif
5728     PL_copline = NOLINE;
5729     LEAVE_SCOPE(floor);
5730 #ifdef PERL_MAD
5731     return pegop;
5732 #endif
5733 }
5734
5735 OP *
5736 Perl_newANONLIST(pTHX_ OP *o)
5737 {
5738     return convert(OP_ANONLIST, OPf_SPECIAL, o);
5739 }
5740
5741 OP *
5742 Perl_newANONHASH(pTHX_ OP *o)
5743 {
5744     return convert(OP_ANONHASH, OPf_SPECIAL, o);
5745 }
5746
5747 OP *
5748 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5749 {
5750     return newANONATTRSUB(floor, proto, NULL, block);
5751 }
5752
5753 OP *
5754 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5755 {
5756     return newUNOP(OP_REFGEN, 0,
5757         newSVOP(OP_ANONCODE, 0,
5758                 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5759 }
5760
5761 OP *
5762 Perl_oopsAV(pTHX_ OP *o)
5763 {
5764     dVAR;
5765     switch (o->op_type) {
5766     case OP_PADSV:
5767         o->op_type = OP_PADAV;
5768         o->op_ppaddr = PL_ppaddr[OP_PADAV];
5769         return ref(o, OP_RV2AV);
5770
5771     case OP_RV2SV:
5772         o->op_type = OP_RV2AV;
5773         o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5774         ref(o, OP_RV2AV);
5775         break;
5776
5777     default:
5778         if (ckWARN_d(WARN_INTERNAL))
5779             Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
5780         break;
5781     }
5782     return o;
5783 }
5784
5785 OP *
5786 Perl_oopsHV(pTHX_ OP *o)
5787 {
5788     dVAR;
5789     switch (o->op_type) {
5790     case OP_PADSV:
5791     case OP_PADAV:
5792         o->op_type = OP_PADHV;
5793         o->op_ppaddr = PL_ppaddr[OP_PADHV];
5794         return ref(o, OP_RV2HV);
5795
5796     case OP_RV2SV:
5797     case OP_RV2AV:
5798         o->op_type = OP_RV2HV;
5799         o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5800         ref(o, OP_RV2HV);
5801         break;
5802
5803     default:
5804         if (ckWARN_d(WARN_INTERNAL))
5805             Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
5806         break;
5807     }
5808     return o;
5809 }
5810
5811 OP *
5812 Perl_newAVREF(pTHX_ OP *o)
5813 {
5814     dVAR;
5815     if (o->op_type == OP_PADANY) {
5816         o->op_type = OP_PADAV;
5817         o->op_ppaddr = PL_ppaddr[OP_PADAV];
5818         return o;
5819     }
5820     else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
5821                 && ckWARN(WARN_DEPRECATED)) {
5822         Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5823                 "Using an array as a reference is deprecated");
5824     }
5825     return newUNOP(OP_RV2AV, 0, scalar(o));
5826 }
5827
5828 OP *
5829 Perl_newGVREF(pTHX_ I32 type, OP *o)
5830 {
5831     if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5832         return newUNOP(OP_NULL, 0, o);
5833     return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5834 }
5835
5836 OP *
5837 Perl_newHVREF(pTHX_ OP *o)
5838 {
5839     dVAR;
5840     if (o->op_type == OP_PADANY) {
5841         o->op_type = OP_PADHV;
5842         o->op_ppaddr = PL_ppaddr[OP_PADHV];
5843         return o;
5844     }
5845     else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
5846                 && ckWARN(WARN_DEPRECATED)) {
5847         Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5848                 "Using a hash as a reference is deprecated");
5849     }
5850     return newUNOP(OP_RV2HV, 0, scalar(o));
5851 }
5852
5853 OP *
5854 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5855 {
5856     return newUNOP(OP_RV2CV, flags, scalar(o));
5857 }
5858
5859 OP *
5860 Perl_newSVREF(pTHX_ OP *o)
5861 {
5862     dVAR;
5863     if (o->op_type == OP_PADANY) {
5864         o->op_type = OP_PADSV;
5865         o->op_ppaddr = PL_ppaddr[OP_PADSV];
5866         return o;
5867     }
5868     else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5869         o->op_flags |= OPpDONE_SVREF;
5870         return o;
5871     }
5872     return newUNOP(OP_RV2SV, 0, scalar(o));
5873 }
5874
5875 /* Check routines. See the comments at the top of this file for details
5876  * on when these are called */
5877
5878 OP *
5879 Perl_ck_anoncode(pTHX_ OP *o)
5880 {
5881     cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
5882     if (!PL_madskills)
5883         cSVOPo->op_sv = NULL;
5884     return o;
5885 }
5886
5887 OP *
5888 Perl_ck_bitop(pTHX_ OP *o)
5889 {
5890     dVAR;
5891 #define OP_IS_NUMCOMPARE(op) \
5892         ((op) == OP_LT   || (op) == OP_I_LT || \
5893          (op) == OP_GT   || (op) == OP_I_GT || \
5894          (op) == OP_LE   || (op) == OP_I_LE || \
5895          (op) == OP_GE   || (op) == OP_I_GE || \
5896          (op) == OP_EQ   || (op) == OP_I_EQ || \
5897          (op) == OP_NE   || (op) == OP_I_NE || \
5898          (op) == OP_NCMP || (op) == OP_I_NCMP)
5899     o->op_private = (U8)(PL_hints & HINT_INTEGER);
5900     if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
5901             && (o->op_type == OP_BIT_OR
5902              || o->op_type == OP_BIT_AND
5903              || o->op_type == OP_BIT_XOR))
5904     {
5905         const OP * const left = cBINOPo->op_first;
5906         const OP * const right = left->op_sibling;
5907         if ((OP_IS_NUMCOMPARE(left->op_type) &&
5908                 (left->op_flags & OPf_PARENS) == 0) ||
5909             (OP_IS_NUMCOMPARE(right->op_type) &&
5910                 (right->op_flags & OPf_PARENS) == 0))
5911             if (ckWARN(WARN_PRECEDENCE))
5912                 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
5913                         "Possible precedence problem on bitwise %c operator",
5914                         o->op_type == OP_BIT_OR ? '|'
5915                             : o->op_type == OP_BIT_AND ? '&' : '^'
5916                         );
5917     }
5918     return o;
5919 }
5920
5921 OP *
5922 Perl_ck_concat(pTHX_ OP *o)
5923 {
5924     const OP * const kid = cUNOPo->op_first;
5925     PERL_UNUSED_CONTEXT;
5926     if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
5927             !(kUNOP->op_first->op_flags & OPf_MOD))
5928         o->op_flags |= OPf_STACKED;
5929     return o;
5930 }
5931
5932 OP *
5933 Perl_ck_spair(pTHX_ OP *o)
5934 {
5935     dVAR;
5936     if (o->op_flags & OPf_KIDS) {
5937         OP* newop;
5938         OP* kid;
5939         const OPCODE type = o->op_type;
5940         o = modkids(ck_fun(o), type);
5941         kid = cUNOPo->op_first;
5942         newop = kUNOP->op_first->op_sibling;
5943         if (newop) {
5944             const OPCODE type = newop->op_type;
5945             if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
5946                     type == OP_PADAV || type == OP_PADHV ||
5947                     type == OP_RV2AV || type == OP_RV2HV)
5948                 return o;
5949         }
5950 #ifdef PERL_MAD
5951         op_getmad(kUNOP->op_first,newop,'K');
5952 #else
5953         op_free(kUNOP->op_first);
5954 #endif
5955         kUNOP->op_first = newop;
5956     }
5957     o->op_ppaddr = PL_ppaddr[++o->op_type];
5958     return ck_fun(o);
5959 }
5960
5961 OP *
5962 Perl_ck_delete(pTHX_ OP *o)
5963 {
5964     o = ck_fun(o);
5965     o->op_private = 0;
5966     if (o->op_flags & OPf_KIDS) {
5967         OP * const kid = cUNOPo->op_first;
5968         switch (kid->op_type) {
5969         case OP_ASLICE:
5970             o->op_flags |= OPf_SPECIAL;
5971             /* FALL THROUGH */
5972         case OP_HSLICE:
5973             o->op_private |= OPpSLICE;
5974             break;
5975         case OP_AELEM:
5976             o->op_flags |= OPf_SPECIAL;
5977             /* FALL THROUGH */
5978         case OP_HELEM:
5979             break;
5980         default:
5981             Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5982                   OP_DESC(o));
5983         }
5984         op_null(kid);
5985     }
5986     return o;
5987 }
5988
5989 OP *
5990 Perl_ck_die(pTHX_ OP *o)
5991 {
5992 #ifdef VMS
5993     if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5994 #endif
5995     return ck_fun(o);
5996 }
5997
5998 OP *
5999 Perl_ck_eof(pTHX_ OP *o)
6000 {
6001     dVAR;
6002
6003     if (o->op_flags & OPf_KIDS) {
6004         if (cLISTOPo->op_first->op_type == OP_STUB) {
6005             OP * const newop
6006                 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
6007 #ifdef PERL_MAD
6008             op_getmad(o,newop,'O');
6009 #else
6010             op_free(o);
6011 #endif
6012             o = newop;
6013         }
6014         return ck_fun(o);
6015     }
6016     return o;
6017 }
6018
6019 OP *
6020 Perl_ck_eval(pTHX_ OP *o)
6021 {
6022     dVAR;
6023     PL_hints |= HINT_BLOCK_SCOPE;
6024     if (o->op_flags & OPf_KIDS) {
6025         SVOP * const kid = (SVOP*)cUNOPo->op_first;
6026
6027         if (!kid) {
6028             o->op_flags &= ~OPf_KIDS;
6029             op_null(o);
6030         }
6031         else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
6032             LOGOP *enter;
6033 #ifdef PERL_MAD
6034             OP* const oldo = o;
6035 #endif
6036
6037             cUNOPo->op_first = 0;
6038 #ifndef PERL_MAD
6039             op_free(o);
6040 #endif
6041
6042             NewOp(1101, enter, 1, LOGOP);
6043             enter->op_type = OP_ENTERTRY;
6044             enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
6045             enter->op_private = 0;
6046
6047             /* establish postfix order */
6048             enter->op_next = (OP*)enter;
6049
6050             o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
6051             o->op_type = OP_LEAVETRY;
6052             o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
6053             enter->op_other = o;
6054             op_getmad(oldo,o,'O');
6055             return o;
6056         }
6057         else {
6058             scalar((OP*)kid);
6059             PL_cv_has_eval = 1;
6060         }
6061     }
6062     else {
6063 #ifdef PERL_MAD
6064         OP* const oldo = o;
6065 #else
6066         op_free(o);
6067 #endif
6068         o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
6069         op_getmad(oldo,o,'O');
6070     }
6071     o->op_targ = (PADOFFSET)PL_hints;
6072     if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
6073         /* Store a copy of %^H that pp_entereval can pick up */
6074         OP *hhop = newSVOP(OP_CONST, 0,
6075                            (SV*)Perl_hv_copy_hints_hv(aTHX_ GvHV(PL_hintgv)));
6076         cUNOPo->op_first->op_sibling = hhop;
6077         o->op_private |= OPpEVAL_HAS_HH;
6078     }
6079     return o;
6080 }
6081
6082 OP *
6083 Perl_ck_exit(pTHX_ OP *o)
6084 {
6085 #ifdef VMS
6086     HV * const table = GvHV(PL_hintgv);
6087     if (table) {
6088        SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
6089        if (svp && *svp && SvTRUE(*svp))
6090            o->op_private |= OPpEXIT_VMSISH;
6091     }
6092     if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6093 #endif
6094     return ck_fun(o);
6095 }
6096
6097 OP *
6098 Perl_ck_exec(pTHX_ OP *o)
6099 {
6100     if (o->op_flags & OPf_STACKED) {
6101         OP *kid;
6102         o = ck_fun(o);
6103         kid = cUNOPo->op_first->op_sibling;
6104         if (kid->op_type == OP_RV2GV)
6105             op_null(kid);
6106     }
6107     else
6108         o = listkids(o);
6109     return o;
6110 }
6111
6112 OP *
6113 Perl_ck_exists(pTHX_ OP *o)
6114 {
6115     dVAR;
6116     o = ck_fun(o);
6117     if (o->op_flags & OPf_KIDS) {
6118         OP * const kid = cUNOPo->op_first;
6119         if (kid->op_type == OP_ENTERSUB) {
6120             (void) ref(kid, o->op_type);
6121             if (kid->op_type != OP_RV2CV && !PL_error_count)
6122                 Perl_croak(aTHX_ "%s argument is not a subroutine name",
6123                             OP_DESC(o));
6124             o->op_private |= OPpEXISTS_SUB;
6125         }
6126         else if (kid->op_type == OP_AELEM)
6127             o->op_flags |= OPf_SPECIAL;
6128         else if (kid->op_type != OP_HELEM)
6129             Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
6130                         OP_DESC(o));
6131         op_null(kid);
6132     }
6133     return o;
6134 }
6135
6136 OP *
6137 Perl_ck_rvconst(pTHX_ register OP *o)
6138 {
6139     dVAR;
6140     SVOP * const kid = (SVOP*)cUNOPo->op_first;
6141
6142     o->op_private |= (PL_hints & HINT_STRICT_REFS);
6143     if (o->op_type == OP_RV2CV)
6144         o->op_private &= ~1;
6145
6146     if (kid->op_type == OP_CONST) {
6147         int iscv;
6148         GV *gv;
6149         SV * const kidsv = kid->op_sv;
6150
6151         /* Is it a constant from cv_const_sv()? */
6152         if (SvROK(kidsv) && SvREADONLY(kidsv)) {
6153             SV * const rsv = SvRV(kidsv);
6154             const svtype type = SvTYPE(rsv);
6155             const char *badtype = NULL;
6156
6157             switch (o->op_type) {
6158             case OP_RV2SV:
6159                 if (type > SVt_PVMG)
6160                     badtype = "a SCALAR";
6161                 break;
6162             case OP_RV2AV:
6163                 if (type != SVt_PVAV)
6164                     badtype = "an ARRAY";
6165                 break;
6166             case OP_RV2HV:
6167                 if (type != SVt_PVHV)
6168                     badtype = "a HASH";
6169                 break;
6170             case OP_RV2CV:
6171                 if (type != SVt_PVCV)
6172                     badtype = "a CODE";
6173                 break;
6174             }
6175             if (badtype)
6176                 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
6177             return o;
6178         }
6179         else if ((o->op_type == OP_RV2HV || o->op_type == OP_RV2SV) &&
6180                 (PL_hints & HINT_STRICT_REFS) && SvPOK(kidsv)) {
6181             /* If this is an access to a stash, disable "strict refs", because
6182              * stashes aren't auto-vivified at compile-time (unless we store
6183              * symbols in them), and we don't want to produce a run-time
6184              * stricture error when auto-vivifying the stash. */
6185             const char *s = SvPV_nolen(kidsv);
6186             const STRLEN l = SvCUR(kidsv);
6187             if (l > 1 && s[l-1] == ':' && s[l-2] == ':')
6188                 o->op_private &= ~HINT_STRICT_REFS;
6189         }
6190         if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
6191             const char *badthing;
6192             switch (o->op_type) {
6193             case OP_RV2SV:
6194                 badthing = "a SCALAR";
6195                 break;
6196             case OP_RV2AV:
6197                 badthing = "an ARRAY";
6198                 break;
6199             case OP_RV2HV:
6200                 badthing = "a HASH";
6201                 break;
6202             default:
6203                 badthing = NULL;
6204                 break;
6205             }
6206             if (badthing)
6207                 Perl_croak(aTHX_
6208                            "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
6209                            (void*)kidsv, badthing);
6210         }
6211         /*
6212          * This is a little tricky.  We only want to add the symbol if we
6213          * didn't add it in the lexer.  Otherwise we get duplicate strict
6214          * warnings.  But if we didn't add it in the lexer, we must at
6215          * least pretend like we wanted to add it even if it existed before,
6216          * or we get possible typo warnings.  OPpCONST_ENTERED says
6217          * whether the lexer already added THIS instance of this symbol.
6218          */
6219         iscv = (o->op_type == OP_RV2CV) * 2;
6220         do {
6221             gv = gv_fetchsv(kidsv,
6222                 iscv | !(kid->op_private & OPpCONST_ENTERED),
6223                 iscv
6224                     ? SVt_PVCV
6225                     : o->op_type == OP_RV2SV
6226                         ? SVt_PV
6227                         : o->op_type == OP_RV2AV
6228                             ? SVt_PVAV
6229                             : o->op_type == OP_RV2HV
6230                                 ? SVt_PVHV
6231                                 : SVt_PVGV);
6232         } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
6233         if (gv) {
6234             kid->op_type = OP_GV;
6235             SvREFCNT_dec(kid->op_sv);
6236 #ifdef USE_ITHREADS
6237             /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
6238             kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
6239             SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
6240             GvIN_PAD_on(gv);
6241             PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc_simple_NN(gv));
6242 #else
6243             kid->op_sv = SvREFCNT_inc_simple_NN(gv);
6244 #endif
6245             kid->op_private = 0;
6246             kid->op_ppaddr = PL_ppaddr[OP_GV];
6247         }
6248     }
6249     return o;
6250 }
6251
6252 OP *
6253 Perl_ck_ftst(pTHX_ OP *o)
6254 {
6255     dVAR;
6256     const I32 type = o->op_type;
6257
6258     if (o->op_flags & OPf_REF) {
6259         NOOP;
6260     }
6261     else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
6262         SVOP * const kid = (SVOP*)cUNOPo->op_first;
6263         const OPCODE kidtype = kid->op_type;
6264
6265         if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6266             OP * const newop = newGVOP(type, OPf_REF,
6267                 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
6268 #ifdef PERL_MAD
6269             op_getmad(o,newop,'O');
6270 #else
6271             op_free(o);
6272 #endif
6273             return newop;
6274         }
6275         if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o))
6276             o->op_private |= OPpFT_ACCESS;
6277         if (PL_check[kidtype] == MEMBER_TO_FPTR(Perl_ck_ftst)
6278                 && kidtype != OP_STAT && kidtype != OP_LSTAT)
6279             o->op_private |= OPpFT_STACKED;
6280     }
6281     else {
6282 #ifdef PERL_MAD
6283         OP* const oldo = o;
6284 #else
6285         op_free(o);
6286 #endif
6287         if (type == OP_FTTTY)
6288             o = newGVOP(type, OPf_REF, PL_stdingv);
6289         else
6290             o = newUNOP(type, 0, newDEFSVOP());
6291         op_getmad(oldo,o,'O');
6292     }
6293     return o;
6294 }
6295
6296 OP *
6297 Perl_ck_fun(pTHX_ OP *o)
6298 {
6299     dVAR;
6300     const int type = o->op_type;
6301     register I32 oa = PL_opargs[type] >> OASHIFT;
6302
6303     if (o->op_flags & OPf_STACKED) {
6304         if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
6305             oa &= ~OA_OPTIONAL;
6306         else
6307             return no_fh_allowed(o);
6308     }
6309
6310     if (o->op_flags & OPf_KIDS) {
6311         OP **tokid = &cLISTOPo->op_first;
6312         register OP *kid = cLISTOPo->op_first;
6313         OP *sibl;
6314         I32 numargs = 0;
6315
6316         if (kid->op_type == OP_PUSHMARK ||
6317             (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
6318         {
6319             tokid = &kid->op_sibling;
6320             kid = kid->op_sibling;
6321         }
6322         if (!kid && PL_opargs[type] & OA_DEFGV)
6323             *tokid = kid = newDEFSVOP();
6324
6325         while (oa && kid) {
6326             numargs++;
6327             sibl = kid->op_sibling;
6328 #ifdef PERL_MAD
6329             if (!sibl && kid->op_type == OP_STUB) {
6330                 numargs--;
6331                 break;
6332             }
6333 #endif
6334             switch (oa & 7) {
6335             case OA_SCALAR:
6336                 /* list seen where single (scalar) arg expected? */
6337                 if (numargs == 1 && !(oa >> 4)
6338                     && kid->op_type == OP_LIST && type != OP_SCALAR)
6339                 {
6340                     return too_many_arguments(o,PL_op_desc[type]);
6341                 }
6342                 scalar(kid);
6343                 break;
6344             case OA_LIST:
6345                 if (oa < 16) {
6346                     kid = 0;
6347                     continue;
6348                 }
6349                 else
6350                     list(kid);
6351                 break;
6352             case OA_AVREF:
6353                 if ((type == OP_PUSH || type == OP_UNSHIFT)
6354                     && !kid->op_sibling && ckWARN(WARN_SYNTAX))
6355                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6356                         "Useless use of %s with no values",
6357                         PL_op_desc[type]);
6358
6359                 if (kid->op_type == OP_CONST &&
6360                     (kid->op_private & OPpCONST_BARE))
6361                 {
6362                     OP * const newop = newAVREF(newGVOP(OP_GV, 0,
6363                         gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
6364                     if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6365                         Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6366                             "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
6367                             (void*)((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
6368 #ifdef PERL_MAD
6369                     op_getmad(kid,newop,'K');
6370 #else
6371                     op_free(kid);
6372 #endif
6373                     kid = newop;
6374                     kid->op_sibling = sibl;
6375                     *tokid = kid;
6376                 }
6377                 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
6378                     bad_type(numargs, "array", PL_op_desc[type], kid);
6379                 mod(kid, type);
6380                 break;
6381             case OA_HVREF:
6382                 if (kid->op_type == OP_CONST &&
6383                     (kid->op_private & OPpCONST_BARE))
6384                 {
6385                     OP * const newop = newHVREF(newGVOP(OP_GV, 0,
6386                         gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
6387                     if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6388                         Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6389                             "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
6390                             (void*)((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
6391 #ifdef PERL_MAD
6392                     op_getmad(kid,newop,'K');
6393 #else
6394                     op_free(kid);
6395 #endif
6396                     kid = newop;
6397                     kid->op_sibling = sibl;
6398                     *tokid = kid;
6399                 }
6400                 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
6401                     bad_type(numargs, "hash", PL_op_desc[type], kid);
6402                 mod(kid, type);
6403                 break;
6404             case OA_CVREF:
6405                 {
6406                     OP * const newop = newUNOP(OP_NULL, 0, kid);
6407                     kid->op_sibling = 0;
6408                     linklist(kid);
6409                     newop->op_next = newop;
6410                     kid = newop;
6411                     kid->op_sibling = sibl;
6412                     *tokid = kid;
6413                 }
6414                 break;
6415             case OA_FILEREF:
6416                 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
6417                     if (kid->op_type == OP_CONST &&
6418                         (kid->op_private & OPpCONST_BARE))
6419                     {
6420                         OP * const newop = newGVOP(OP_GV, 0,
6421                             gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
6422                         if (!(o->op_private & 1) && /* if not unop */
6423                             kid == cLISTOPo->op_last)
6424                             cLISTOPo->op_last = newop;
6425 #ifdef PERL_MAD
6426                         op_getmad(kid,newop,'K');
6427 #else
6428                         op_free(kid);
6429 #endif
6430                         kid = newop;
6431                     }
6432                     else if (kid->op_type == OP_READLINE) {
6433                         /* neophyte patrol: open(<FH>), close(<FH>) etc. */
6434                         bad_type(numargs, "HANDLE", OP_DESC(o), kid);
6435                     }
6436                     else {
6437                         I32 flags = OPf_SPECIAL;
6438                         I32 priv = 0;
6439                         PADOFFSET targ = 0;
6440
6441                         /* is this op a FH constructor? */
6442                         if (is_handle_constructor(o,numargs)) {
6443                             const char *name = NULL;
6444                             STRLEN len = 0;
6445
6446                             flags = 0;
6447                             /* Set a flag to tell rv2gv to vivify
6448                              * need to "prove" flag does not mean something
6449                              * else already - NI-S 1999/05/07
6450                              */
6451                             priv = OPpDEREF;
6452                             if (kid->op_type == OP_PADSV) {
6453                                 name = PAD_COMPNAME_PV(kid->op_targ);
6454                                 /* SvCUR of a pad namesv can't be trusted
6455                                  * (see PL_generation), so calc its length
6456                                  * manually */
6457                                 if (name)
6458                                     len = strlen(name);
6459
6460                             }
6461                             else if (kid->op_type == OP_RV2SV
6462                                      && kUNOP->op_first->op_type == OP_GV)
6463                             {
6464                                 GV * const gv = cGVOPx_gv(kUNOP->op_first);
6465                                 name = GvNAME(gv);
6466                                 len = GvNAMELEN(gv);
6467                             }
6468                             else if (kid->op_type == OP_AELEM
6469                                      || kid->op_type == OP_HELEM)
6470                             {
6471                                  OP *firstop;
6472                                  OP *op = ((BINOP*)kid)->op_first;
6473                                  name = NULL;
6474                                  if (op) {
6475                                       SV *tmpstr = NULL;
6476                                       const char * const a =
6477                                            kid->op_type == OP_AELEM ?
6478                                            "[]" : "{}";
6479                                       if (((op->op_type == OP_RV2AV) ||
6480                                            (op->op_type == OP_RV2HV)) &&
6481                                           (firstop = ((UNOP*)op)->op_first) &&
6482                                           (firstop->op_type == OP_GV)) {
6483                                            /* packagevar $a[] or $h{} */
6484                                            GV * const gv = cGVOPx_gv(firstop);
6485                                            if (gv)
6486                                                 tmpstr =
6487                                                      Perl_newSVpvf(aTHX_
6488                                                                    "%s%c...%c",
6489                                                                    GvNAME(gv),
6490                                                                    a[0], a[1]);
6491                                       }
6492                                       else if (op->op_type == OP_PADAV
6493                                                || op->op_type == OP_PADHV) {
6494                                            /* lexicalvar $a[] or $h{} */
6495                                            const char * const padname =
6496                                                 PAD_COMPNAME_PV(op->op_targ);
6497                                            if (padname)
6498                                                 tmpstr =
6499                                                      Perl_newSVpvf(aTHX_
6500                                                                    "%s%c...%c",
6501                                                                    padname + 1,
6502                                                                    a[0], a[1]);
6503                                       }
6504                                       if (tmpstr) {
6505                                            name = SvPV_const(tmpstr, len);
6506                                            sv_2mortal(tmpstr);
6507                                       }
6508                                  }
6509                                  if (!name) {
6510                                       name = "__ANONIO__";
6511                                       len = 10;
6512                                  }
6513                                  mod(kid, type);
6514                             }
6515                             if (name) {
6516                                 SV *namesv;
6517                                 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
6518                                 namesv = PAD_SVl(targ);
6519                                 SvUPGRADE(namesv, SVt_PV);
6520                                 if (*name != '$')
6521                                     sv_setpvn(namesv, "$", 1);
6522                                 sv_catpvn(namesv, name, len);
6523                             }
6524                         }
6525                         kid->op_sibling = 0;
6526                         kid = newUNOP(OP_RV2GV, flags, scalar(kid));
6527                         kid->op_targ = targ;
6528                         kid->op_private |= priv;
6529                     }
6530                     kid->op_sibling = sibl;
6531                     *tokid = kid;
6532                 }
6533                 scalar(kid);
6534                 break;
6535             case OA_SCALARREF:
6536                 mod(scalar(kid), type);
6537                 break;
6538             }
6539             oa >>= 4;
6540             tokid = &kid->op_sibling;
6541             kid = kid->op_sibling;
6542         }
6543 #ifdef PERL_MAD
6544         if (kid && kid->op_type != OP_STUB)
6545             return too_many_arguments(o,OP_DESC(o));
6546         o->op_private |= numargs;
6547 #else
6548         /* FIXME - should the numargs move as for the PERL_MAD case?  */
6549         o->op_private |= numargs;
6550         if (kid)
6551             return too_many_arguments(o,OP_DESC(o));
6552 #endif
6553         listkids(o);
6554     }
6555     else if (PL_opargs[type] & OA_DEFGV) {
6556 #ifdef PERL_MAD
6557         OP *newop = newUNOP(type, 0, newDEFSVOP());
6558         op_getmad(o,newop,'O');
6559         return newop;
6560 #else
6561         /* Ordering of these two is important to keep f_map.t passing.  */
6562         op_free(o);
6563         return newUNOP(type, 0, newDEFSVOP());
6564 #endif
6565     }
6566
6567     if (oa) {
6568         while (oa & OA_OPTIONAL)
6569             oa >>= 4;
6570         if (oa && oa != OA_LIST)
6571             return too_few_arguments(o,OP_DESC(o));
6572     }
6573     return o;
6574 }
6575
6576 OP *
6577 Perl_ck_glob(pTHX_ OP *o)
6578 {
6579     dVAR;
6580     GV *gv;
6581
6582     o = ck_fun(o);
6583     if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
6584         append_elem(OP_GLOB, o, newDEFSVOP());
6585
6586     if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
6587           && GvCVu(gv) && GvIMPORTED_CV(gv)))
6588     {
6589         gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
6590     }
6591
6592 #if !defined(PERL_EXTERNAL_GLOB)
6593     /* XXX this can be tightened up and made more failsafe. */
6594     if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
6595         GV *glob_gv;
6596         ENTER;
6597         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
6598                 newSVpvs("File::Glob"), NULL, NULL, NULL);
6599         gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
6600         glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV);
6601         GvCV(gv) = GvCV(glob_gv);
6602         SvREFCNT_inc_void((SV*)GvCV(gv));
6603         GvIMPORTED_CV_on(gv);
6604         LEAVE;
6605     }
6606 #endif /* PERL_EXTERNAL_GLOB */
6607
6608     if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6609         append_elem(OP_GLOB, o,
6610                     newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
6611         o->op_type = OP_LIST;
6612         o->op_ppaddr = PL_ppaddr[OP_LIST];
6613         cLISTOPo->op_first->op_type = OP_PUSHMARK;
6614         cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
6615         cLISTOPo->op_first->op_targ = 0;
6616         o = newUNOP(OP_ENTERSUB, OPf_STACKED,
6617                     append_elem(OP_LIST, o,
6618                                 scalar(newUNOP(OP_RV2CV, 0,
6619                                                newGVOP(OP_GV, 0, gv)))));
6620         o = newUNOP(OP_NULL, 0, ck_subr(o));
6621         o->op_targ = OP_GLOB;           /* hint at what it used to be */
6622         return o;
6623     }
6624     gv = newGVgen("main");
6625     gv_IOadd(gv);
6626     append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
6627     scalarkids(o);
6628     return o;
6629 }
6630
6631 OP *
6632 Perl_ck_grep(pTHX_ OP *o)
6633 {
6634     dVAR;
6635     LOGOP *gwop = NULL;
6636     OP *kid;
6637     const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
6638     PADOFFSET offset;
6639
6640     o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
6641     /* don't allocate gwop here, as we may leak it if PL_error_count > 0 */
6642
6643     if (o->op_flags & OPf_STACKED) {
6644         OP* k;
6645         o = ck_sort(o);
6646         kid = cLISTOPo->op_first->op_sibling;
6647         if (!cUNOPx(kid)->op_next)
6648             Perl_croak(aTHX_ "panic: ck_grep");
6649         for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
6650             kid = k;
6651         }
6652         NewOp(1101, gwop, 1, LOGOP);
6653         kid->op_next = (OP*)gwop;
6654         o->op_flags &= ~OPf_STACKED;
6655     }
6656     kid = cLISTOPo->op_first->op_sibling;
6657     if (type == OP_MAPWHILE)
6658         list(kid);
6659     else
6660         scalar(kid);
6661     o = ck_fun(o);
6662     if (PL_error_count)
6663         return o;
6664     kid = cLISTOPo->op_first->op_sibling;
6665     if (kid->op_type != OP_NULL)
6666         Perl_croak(aTHX_ "panic: ck_grep");
6667     kid = kUNOP->op_first;
6668
6669     if (!gwop)
6670         NewOp(1101, gwop, 1, LOGOP);
6671     gwop->op_type = type;
6672     gwop->op_ppaddr = PL_ppaddr[type];
6673     gwop->op_first = listkids(o);
6674     gwop->op_flags |= OPf_KIDS;
6675     gwop->op_other = LINKLIST(kid);
6676     kid->op_next = (OP*)gwop;
6677     offset = pad_findmy("$_");
6678     if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
6679         o->op_private = gwop->op_private = 0;
6680         gwop->op_targ = pad_alloc(type, SVs_PADTMP);
6681     }
6682     else {
6683         o->op_private = gwop->op_private = OPpGREP_LEX;
6684         gwop->op_targ = o->op_targ = offset;
6685     }
6686
6687     kid = cLISTOPo->op_first->op_sibling;
6688     if (!kid || !kid->op_sibling)
6689         return too_few_arguments(o,OP_DESC(o));
6690     for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
6691         mod(kid, OP_GREPSTART);
6692
6693     return (OP*)gwop;
6694 }
6695
6696 OP *
6697 Perl_ck_index(pTHX_ OP *o)
6698 {
6699     if (o->op_flags & OPf_KIDS) {
6700         OP *kid = cLISTOPo->op_first->op_sibling;       /* get past pushmark */
6701         if (kid)
6702             kid = kid->op_sibling;                      /* get past "big" */
6703         if (kid && kid->op_type == OP_CONST)
6704             fbm_compile(((SVOP*)kid)->op_sv, 0);
6705     }
6706     return ck_fun(o);
6707 }
6708
6709 OP *
6710 Perl_ck_lengthconst(pTHX_ OP *o)
6711 {
6712     /* XXX length optimization goes here */
6713     return ck_fun(o);
6714 }
6715
6716 OP *
6717 Perl_ck_lfun(pTHX_ OP *o)
6718 {
6719     const OPCODE type = o->op_type;
6720     return modkids(ck_fun(o), type);
6721 }
6722
6723 OP *
6724 Perl_ck_defined(pTHX_ OP *o)            /* 19990527 MJD */
6725 {
6726     if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
6727         switch (cUNOPo->op_first->op_type) {
6728         case OP_RV2AV:
6729             /* This is needed for
6730                if (defined %stash::)
6731                to work.   Do not break Tk.
6732                */
6733             break;                      /* Globals via GV can be undef */
6734         case OP_PADAV:
6735         case OP_AASSIGN:                /* Is this a good idea? */
6736             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6737                         "defined(@array) is deprecated");
6738             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6739                         "\t(Maybe you should just omit the defined()?)\n");
6740         break;
6741         case OP_RV2HV:
6742             /* This is needed for
6743                if (defined %stash::)
6744                to work.   Do not break Tk.
6745                */
6746             break;                      /* Globals via GV can be undef */
6747         case OP_PADHV:
6748             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6749                         "defined(%%hash) is deprecated");
6750             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6751                         "\t(Maybe you should just omit the defined()?)\n");
6752             break;
6753         default:
6754             /* no warning */
6755             break;
6756         }
6757     }
6758     return ck_rfun(o);
6759 }
6760
6761 OP *
6762 Perl_ck_rfun(pTHX_ OP *o)
6763 {
6764     const OPCODE type = o->op_type;
6765     return refkids(ck_fun(o), type);
6766 }
6767
6768 OP *
6769 Perl_ck_listiob(pTHX_ OP *o)
6770 {
6771     register OP *kid;
6772
6773     kid = cLISTOPo->op_first;
6774     if (!kid) {
6775         o = force_list(o);
6776         kid = cLISTOPo->op_first;
6777     }
6778     if (kid->op_type == OP_PUSHMARK)
6779         kid = kid->op_sibling;
6780     if (kid && o->op_flags & OPf_STACKED)
6781         kid = kid->op_sibling;
6782     else if (kid && !kid->op_sibling) {         /* print HANDLE; */
6783         if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
6784             o->op_flags |= OPf_STACKED; /* make it a filehandle */
6785             kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
6786             cLISTOPo->op_first->op_sibling = kid;
6787             cLISTOPo->op_last = kid;
6788             kid = kid->op_sibling;
6789         }
6790     }
6791
6792     if (!kid)
6793         append_elem(o->op_type, o, newDEFSVOP());
6794
6795     return listkids(o);
6796 }
6797
6798 OP *
6799 Perl_ck_smartmatch(pTHX_ OP *o)
6800 {
6801     dVAR;
6802     if (0 == (o->op_flags & OPf_SPECIAL)) {
6803         OP *first  = cBINOPo->op_first;
6804         OP *second = first->op_sibling;
6805
6806         /* Implicitly take a reference to an array or hash */
6807         first->op_sibling = NULL;
6808         first = cBINOPo->op_first = ref_array_or_hash(first);
6809         second = first->op_sibling = ref_array_or_hash(second);
6810
6811         /* Implicitly take a reference to a regular expression */
6812         if (first->op_type == OP_MATCH) {
6813             first->op_type = OP_QR;
6814             first->op_ppaddr = PL_ppaddr[OP_QR];
6815         }
6816         if (second->op_type == OP_MATCH) {
6817             second->op_type = OP_QR;
6818             second->op_ppaddr = PL_ppaddr[OP_QR];
6819         }
6820     }
6821
6822     return o;
6823 }
6824
6825
6826 OP *
6827 Perl_ck_sassign(pTHX_ OP *o)
6828 {
6829     OP * const kid = cLISTOPo->op_first;
6830     /* has a disposable target? */
6831     if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6832         && !(kid->op_flags & OPf_STACKED)
6833         /* Cannot steal the second time! */
6834         && !(kid->op_private & OPpTARGET_MY))
6835     {
6836         OP * const kkid = kid->op_sibling;
6837
6838         /* Can just relocate the target. */
6839         if (kkid && kkid->op_type == OP_PADSV
6840             && !(kkid->op_private & OPpLVAL_INTRO))
6841         {
6842             kid->op_targ = kkid->op_targ;
6843             kkid->op_targ = 0;
6844             /* Now we do not need PADSV and SASSIGN. */
6845             kid->op_sibling = o->op_sibling;    /* NULL */
6846             cLISTOPo->op_first = NULL;
6847 #ifdef PERL_MAD
6848             op_getmad(o,kid,'O');
6849             op_getmad(kkid,kid,'M');
6850 #else
6851             op_free(o);
6852             op_free(kkid);
6853 #endif
6854             kid->op_private |= OPpTARGET_MY;    /* Used for context settings */
6855             return kid;
6856         }
6857     }
6858     if (kid->op_sibling) {
6859         OP *kkid = kid->op_sibling;
6860         if (kkid->op_type == OP_PADSV
6861                 && (kkid->op_private & OPpLVAL_INTRO)
6862                 && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
6863             o->op_private |= OPpASSIGN_STATE;
6864             /* hijacking PADSTALE for uninitialized state variables */
6865             SvPADSTALE_on(PAD_SVl(kkid->op_targ));
6866         }
6867     }
6868     return o;
6869 }
6870
6871 OP *
6872 Perl_ck_match(pTHX_ OP *o)
6873 {
6874     dVAR;
6875     if (o->op_type != OP_QR && PL_compcv) {
6876         const PADOFFSET offset = pad_findmy("$_");
6877         if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
6878             o->op_targ = offset;
6879             o->op_private |= OPpTARGET_MY;
6880         }
6881     }
6882     if (o->op_type == OP_MATCH || o->op_type == OP_QR)
6883         o->op_private |= OPpRUNTIME;
6884     return o;
6885 }
6886
6887 OP *
6888 Perl_ck_method(pTHX_ OP *o)
6889 {
6890     OP * const kid = cUNOPo->op_first;
6891     if (kid->op_type == OP_CONST) {
6892         SV* sv = kSVOP->op_sv;
6893         const char * const method = SvPVX_const(sv);
6894         if (!(strchr(method, ':') || strchr(method, '\''))) {
6895             OP *cmop;
6896             if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6897                 sv = newSVpvn_share(method, SvCUR(sv), 0);
6898             }
6899             else {
6900                 kSVOP->op_sv = NULL;
6901             }
6902             cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6903 #ifdef PERL_MAD
6904             op_getmad(o,cmop,'O');
6905 #else
6906             op_free(o);
6907 #endif
6908             return cmop;
6909         }
6910     }
6911     return o;
6912 }
6913
6914 OP *
6915 Perl_ck_null(pTHX_ OP *o)
6916 {
6917     PERL_UNUSED_CONTEXT;
6918     return o;
6919 }
6920
6921 OP *
6922 Perl_ck_open(pTHX_ OP *o)
6923 {
6924     dVAR;
6925     HV * const table = GvHV(PL_hintgv);
6926     if (table) {
6927         SV **svp = hv_fetchs(table, "open_IN", FALSE);
6928         if (svp && *svp) {
6929             const I32 mode = mode_from_discipline(*svp);
6930             if (mode & O_BINARY)
6931                 o->op_private |= OPpOPEN_IN_RAW;
6932             else if (mode & O_TEXT)
6933                 o->op_private |= OPpOPEN_IN_CRLF;
6934         }
6935
6936         svp = hv_fetchs(table, "open_OUT", FALSE);
6937         if (svp && *svp) {
6938             const I32 mode = mode_from_discipline(*svp);
6939             if (mode & O_BINARY)
6940                 o->op_private |= OPpOPEN_OUT_RAW;
6941             else if (mode & O_TEXT)
6942                 o->op_private |= OPpOPEN_OUT_CRLF;
6943         }
6944     }
6945     if (o->op_type == OP_BACKTICK)
6946         return o;
6947     {
6948          /* In case of three-arg dup open remove strictness
6949           * from the last arg if it is a bareword. */
6950          OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
6951          OP * const last  = cLISTOPx(o)->op_last;  /* The bareword. */
6952          OP *oa;
6953          const char *mode;
6954
6955          if ((last->op_type == OP_CONST) &&             /* The bareword. */
6956              (last->op_private & OPpCONST_BARE) &&
6957              (last->op_private & OPpCONST_STRICT) &&
6958              (oa = first->op_sibling) &&                /* The fh. */
6959              (oa = oa->op_sibling) &&                   /* The mode. */
6960              (oa->op_type == OP_CONST) &&
6961              SvPOK(((SVOP*)oa)->op_sv) &&
6962              (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
6963              mode[0] == '>' && mode[1] == '&' &&        /* A dup open. */
6964              (last == oa->op_sibling))                  /* The bareword. */
6965               last->op_private &= ~OPpCONST_STRICT;
6966     }
6967     return ck_fun(o);
6968 }
6969
6970 OP *
6971 Perl_ck_repeat(pTHX_ OP *o)
6972 {
6973     if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6974         o->op_private |= OPpREPEAT_DOLIST;
6975         cBINOPo->op_first = force_list(cBINOPo->op_first);
6976     }
6977     else
6978         scalar(o);
6979     return o;
6980 }
6981
6982 OP *
6983 Perl_ck_require(pTHX_ OP *o)
6984 {
6985     dVAR;
6986     GV* gv = NULL;
6987
6988     if (o->op_flags & OPf_KIDS) {       /* Shall we supply missing .pm? */
6989         SVOP * const kid = (SVOP*)cUNOPo->op_first;
6990
6991         if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6992             SV * const sv = kid->op_sv;
6993             U32 was_readonly = SvREADONLY(sv);
6994             char *s;
6995
6996             if (was_readonly) {
6997                 if (SvFAKE(sv)) {
6998                     sv_force_normal_flags(sv, 0);
6999                     assert(!SvREADONLY(sv));
7000                     was_readonly = 0;
7001                 } else {
7002                     SvREADONLY_off(sv);
7003                 }
7004             }
7005
7006             for (s = SvPVX(sv); *s; s++) {
7007                 if (*s == ':' && s[1] == ':') {
7008                     const STRLEN len = strlen(s+2)+1;
7009                     *s = '/';
7010                     Move(s+2, s+1, len, char);
7011                     SvCUR_set(sv, SvCUR(sv) - 1);
7012                 }
7013             }
7014             sv_catpvs(sv, ".pm");
7015             SvFLAGS(sv) |= was_readonly;
7016         }
7017     }
7018
7019     if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
7020         /* handle override, if any */
7021         gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
7022         if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7023             GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
7024             gv = gvp ? *gvp : NULL;
7025         }
7026     }
7027
7028     if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
7029         OP * const kid = cUNOPo->op_first;
7030         OP * newop;
7031
7032         cUNOPo->op_first = 0;
7033 #ifndef PERL_MAD
7034         op_free(o);
7035 #endif
7036         newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
7037                                 append_elem(OP_LIST, kid,
7038                                             scalar(newUNOP(OP_RV2CV, 0,
7039                                                            newGVOP(OP_GV, 0,
7040                                                                    gv))))));
7041         op_getmad(o,newop,'O');
7042         return newop;
7043     }
7044
7045     return ck_fun(o);
7046 }
7047
7048 OP *
7049 Perl_ck_return(pTHX_ OP *o)
7050 {
7051     dVAR;
7052     if (CvLVALUE(PL_compcv)) {
7053         OP *kid;
7054         for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
7055             mod(kid, OP_LEAVESUBLV);
7056     }
7057     return o;
7058 }
7059
7060 OP *
7061 Perl_ck_select(pTHX_ OP *o)
7062 {
7063     dVAR;
7064     OP* kid;
7065     if (o->op_flags & OPf_KIDS) {
7066         kid = cLISTOPo->op_first->op_sibling;   /* get past pushmark */
7067         if (kid && kid->op_sibling) {
7068             o->op_type = OP_SSELECT;
7069             o->op_ppaddr = PL_ppaddr[OP_SSELECT];
7070             o = ck_fun(o);
7071             return fold_constants(o);
7072         }
7073     }
7074     o = ck_fun(o);
7075     kid = cLISTOPo->op_first->op_sibling;    /* get past pushmark */
7076     if (kid && kid->op_type == OP_RV2GV)
7077         kid->op_private &= ~HINT_STRICT_REFS;
7078     return o;
7079 }
7080
7081 OP *
7082 Perl_ck_shift(pTHX_ OP *o)
7083 {
7084     dVAR;
7085     const I32 type = o->op_type;
7086
7087     if (!(o->op_flags & OPf_KIDS)) {
7088         OP *argop;
7089         /* FIXME - this can be refactored to reduce code in #ifdefs  */
7090 #ifdef PERL_MAD
7091         OP * const oldo = o;
7092 #else
7093         op_free(o);
7094 #endif
7095         argop = newUNOP(OP_RV2AV, 0,
7096             scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
7097 #ifdef PERL_MAD
7098         o = newUNOP(type, 0, scalar(argop));
7099         op_getmad(oldo,o,'O');
7100         return o;
7101 #else
7102         return newUNOP(type, 0, scalar(argop));
7103 #endif
7104     }
7105     return scalar(modkids(ck_fun(o), type));
7106 }
7107
7108 OP *
7109 Perl_ck_sort(pTHX_ OP *o)
7110 {
7111     dVAR;
7112     OP *firstkid;
7113
7114     if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0) {
7115         HV * const hinthv = GvHV(PL_hintgv);
7116         if (hinthv) {
7117             SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
7118             if (svp) {
7119                 const I32 sorthints = (I32)SvIV(*svp);
7120                 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
7121                     o->op_private |= OPpSORT_QSORT;
7122                 if ((sorthints & HINT_SORT_STABLE) != 0)
7123                     o->op_private |= OPpSORT_STABLE;
7124             }
7125         }
7126     }
7127
7128     if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
7129         simplify_sort(o);
7130     firstkid = cLISTOPo->op_first->op_sibling;          /* get past pushmark */
7131     if (o->op_flags & OPf_STACKED) {                    /* may have been cleared */
7132         OP *k = NULL;
7133         OP *kid = cUNOPx(firstkid)->op_first;           /* get past null */
7134
7135         if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
7136             linklist(kid);
7137             if (kid->op_type == OP_SCOPE) {
7138                 k = kid->op_next;
7139                 kid->op_next = 0;
7140             }
7141             else if (kid->op_type == OP_LEAVE) {
7142                 if (o->op_type == OP_SORT) {
7143                     op_null(kid);                       /* wipe out leave */
7144                     kid->op_next = kid;
7145
7146                     for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
7147                         if (k->op_next == kid)
7148                             k->op_next = 0;
7149                         /* don't descend into loops */
7150                         else if (k->op_type == OP_ENTERLOOP
7151                                  || k->op_type == OP_ENTERITER)
7152                         {
7153                             k = cLOOPx(k)->op_lastop;
7154                         }
7155                     }
7156                 }
7157                 else
7158                     kid->op_next = 0;           /* just disconnect the leave */
7159                 k = kLISTOP->op_first;
7160             }
7161             CALL_PEEP(k);
7162
7163             kid = firstkid;
7164             if (o->op_type == OP_SORT) {
7165                 /* provide scalar context for comparison function/block */
7166                 kid = scalar(kid);
7167                 kid->op_next = kid;
7168             }
7169             else
7170                 kid->op_next = k;
7171             o->op_flags |= OPf_SPECIAL;
7172         }
7173         else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
7174             op_null(firstkid);
7175
7176         firstkid = firstkid->op_sibling;
7177     }
7178
7179     /* provide list context for arguments */
7180     if (o->op_type == OP_SORT)
7181         list(firstkid);
7182
7183     return o;
7184 }
7185
7186 STATIC void
7187 S_simplify_sort(pTHX_ OP *o)
7188 {
7189     dVAR;
7190     register OP *kid = cLISTOPo->op_first->op_sibling;  /* get past pushmark */
7191     OP *k;
7192     int descending;
7193     GV *gv;
7194     const char *gvname;
7195     if (!(o->op_flags & OPf_STACKED))
7196         return;
7197     GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
7198     GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
7199     kid = kUNOP->op_first;                              /* get past null */
7200     if (kid->op_type != OP_SCOPE)
7201         return;
7202     kid = kLISTOP->op_last;                             /* get past scope */
7203     switch(kid->op_type) {
7204         case OP_NCMP:
7205         case OP_I_NCMP:
7206         case OP_SCMP:
7207             break;
7208         default:
7209             return;
7210     }
7211     k = kid;                                            /* remember this node*/
7212     if (kBINOP->op_first->op_type != OP_RV2SV)
7213         return;
7214     kid = kBINOP->op_first;                             /* get past cmp */
7215     if (kUNOP->op_first->op_type != OP_GV)
7216         return;
7217     kid = kUNOP->op_first;                              /* get past rv2sv */
7218     gv = kGVOP_gv;
7219     if (GvSTASH(gv) != PL_curstash)
7220         return;
7221     gvname = GvNAME(gv);
7222     if (*gvname == 'a' && gvname[1] == '\0')
7223         descending = 0;
7224     else if (*gvname == 'b' && gvname[1] == '\0')
7225         descending = 1;
7226     else
7227         return;
7228
7229     kid = k;                                            /* back to cmp */
7230     if (kBINOP->op_last->op_type != OP_RV2SV)
7231         return;
7232     kid = kBINOP->op_last;                              /* down to 2nd arg */
7233     if (kUNOP->op_first->op_type != OP_GV)
7234         return;
7235     kid = kUNOP->op_first;                              /* get past rv2sv */
7236     gv = kGVOP_gv;
7237     if (GvSTASH(gv) != PL_curstash)
7238         return;
7239     gvname = GvNAME(gv);
7240     if ( descending
7241          ? !(*gvname == 'a' && gvname[1] == '\0')
7242          : !(*gvname == 'b' && gvname[1] == '\0'))
7243         return;
7244     o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
7245     if (descending)
7246         o->op_private |= OPpSORT_DESCEND;
7247     if (k->op_type == OP_NCMP)
7248         o->op_private |= OPpSORT_NUMERIC;
7249     if (k->op_type == OP_I_NCMP)
7250         o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
7251     kid = cLISTOPo->op_first->op_sibling;
7252     cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
7253 #ifdef PERL_MAD
7254     op_getmad(kid,o,'S');                             /* then delete it */
7255 #else
7256     op_free(kid);                                     /* then delete it */
7257 #endif
7258 }
7259
7260 OP *
7261 Perl_ck_split(pTHX_ OP *o)
7262 {
7263     dVAR;
7264     register OP *kid;
7265
7266     if (o->op_flags & OPf_STACKED)
7267         return no_fh_allowed(o);
7268
7269     kid = cLISTOPo->op_first;
7270     if (kid->op_type != OP_NULL)
7271         Perl_croak(aTHX_ "panic: ck_split");
7272     kid = kid->op_sibling;
7273     op_free(cLISTOPo->op_first);
7274     cLISTOPo->op_first = kid;
7275     if (!kid) {
7276         cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
7277         cLISTOPo->op_last = kid; /* There was only one element previously */
7278     }
7279
7280     if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
7281         OP * const sibl = kid->op_sibling;
7282         kid->op_sibling = 0;
7283         kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
7284         if (cLISTOPo->op_first == cLISTOPo->op_last)
7285             cLISTOPo->op_last = kid;
7286         cLISTOPo->op_first = kid;
7287         kid->op_sibling = sibl;
7288     }
7289
7290     kid->op_type = OP_PUSHRE;
7291     kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
7292     scalar(kid);
7293     if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL && ckWARN(WARN_REGEXP)) {
7294       Perl_warner(aTHX_ packWARN(WARN_REGEXP),
7295                   "Use of /g modifier is meaningless in split");
7296     }
7297
7298     if (!kid->op_sibling)
7299         append_elem(OP_SPLIT, o, newDEFSVOP());
7300
7301     kid = kid->op_sibling;
7302     scalar(kid);
7303
7304     if (!kid->op_sibling)
7305         append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
7306     assert(kid->op_sibling);
7307
7308     kid = kid->op_sibling;
7309     scalar(kid);
7310
7311     if (kid->op_sibling)
7312         return too_many_arguments(o,OP_DESC(o));
7313
7314     return o;
7315 }
7316
7317 OP *
7318 Perl_ck_join(pTHX_ OP *o)
7319 {
7320     const OP * const kid = cLISTOPo->op_first->op_sibling;
7321     if (kid && kid->op_type == OP_MATCH) {
7322         if (ckWARN(WARN_SYNTAX)) {
7323             const REGEXP *re = PM_GETRE(kPMOP);
7324             const char *pmstr = re ? re->precomp : "STRING";
7325             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7326                         "/%s/ should probably be written as \"%s\"",
7327                         pmstr, pmstr);
7328         }
7329     }
7330     return ck_fun(o);
7331 }
7332
7333 OP *
7334 Perl_ck_subr(pTHX_ OP *o)
7335 {
7336     dVAR;
7337     OP *prev = ((cUNOPo->op_first->op_sibling)
7338              ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
7339     OP *o2 = prev->op_sibling;
7340     OP *cvop;
7341     const char *proto = NULL;
7342     const char *proto_end = NULL;
7343     CV *cv = NULL;
7344     GV *namegv = NULL;
7345     int optional = 0;
7346     I32 arg = 0;
7347     I32 contextclass = 0;
7348     const char *e = NULL;
7349     bool delete_op = 0;
7350
7351     o->op_private |= OPpENTERSUB_HASTARG;
7352     for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
7353     if (cvop->op_type == OP_RV2CV) {
7354         SVOP* tmpop;
7355         o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
7356         op_null(cvop);          /* disable rv2cv */
7357         tmpop = (SVOP*)((UNOP*)cvop)->op_first;
7358         if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
7359             GV *gv = cGVOPx_gv(tmpop);
7360             cv = GvCVu(gv);
7361             if (!cv)
7362                 tmpop->op_private |= OPpEARLY_CV;
7363             else {
7364                 if (SvPOK(cv)) {
7365                     STRLEN len;
7366                     namegv = CvANON(cv) ? gv : CvGV(cv);
7367                     proto = SvPV((SV*)cv, len);
7368                     proto_end = proto + len;
7369                 }
7370                 if (CvASSERTION(cv)) {
7371                     U32 asserthints = 0;
7372                     HV *const hinthv = GvHV(PL_hintgv);
7373                     if (hinthv) {
7374                         SV **svp = hv_fetchs(hinthv, "assertions", FALSE);
7375                         if (svp && *svp)
7376                             asserthints = SvUV(*svp);
7377                     }
7378                     if (asserthints & HINT_ASSERTING) {
7379                         if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
7380                             o->op_private |= OPpENTERSUB_DB;
7381                     }
7382                     else {
7383                         delete_op = 1;
7384                         if (!(asserthints & HINT_ASSERTIONSSEEN) && ckWARN(WARN_ASSERTIONS)) {
7385                             Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
7386                                         "Impossible to activate assertion call");
7387                         }
7388                     }
7389                 }
7390             }
7391         }
7392     }
7393     else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
7394         if (o2->op_type == OP_CONST)
7395             o2->op_private &= ~OPpCONST_STRICT;
7396         else if (o2->op_type == OP_LIST) {
7397             OP * const sib = ((UNOP*)o2)->op_first->op_sibling;
7398             if (sib && sib->op_type == OP_CONST)
7399                 sib->op_private &= ~OPpCONST_STRICT;
7400         }
7401     }
7402     o->op_private |= (PL_hints & HINT_STRICT_REFS);
7403     if (PERLDB_SUB && PL_curstash != PL_debstash)
7404         o->op_private |= OPpENTERSUB_DB;
7405     while (o2 != cvop) {
7406         OP* o3;
7407         if (PL_madskills && o2->op_type == OP_NULL)
7408             o3 = ((UNOP*)o2)->op_first;
7409         else
7410             o3 = o2;
7411         if (proto) {
7412             if (proto >= proto_end)
7413                 return too_many_arguments(o, gv_ename(namegv));
7414
7415             switch (*proto) {
7416             case ';':
7417                 optional = 1;
7418                 proto++;
7419                 continue;
7420             case '_':
7421                 /* _ must be at the end */
7422                 if (proto[1] && proto[1] != ';')
7423                     goto oops;
7424             case '$':
7425                 proto++;
7426                 arg++;
7427                 scalar(o2);
7428                 break;
7429             case '%':
7430             case '@':
7431                 list(o2);
7432                 arg++;
7433                 break;
7434             case '&':
7435                 proto++;
7436                 arg++;
7437                 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
7438                     bad_type(arg,
7439                         arg == 1 ? "block or sub {}" : "sub {}",
7440                         gv_ename(namegv), o3);
7441                 break;
7442             case '*':
7443                 /* '*' allows any scalar type, including bareword */
7444                 proto++;
7445                 arg++;
7446                 if (o3->op_type == OP_RV2GV)
7447                     goto wrapref;       /* autoconvert GLOB -> GLOBref */
7448                 else if (o3->op_type == OP_CONST)
7449                     o3->op_private &= ~OPpCONST_STRICT;
7450                 else if (o3->op_type == OP_ENTERSUB) {
7451                     /* accidental subroutine, revert to bareword */
7452                     OP *gvop = ((UNOP*)o3)->op_first;
7453                     if (gvop && gvop->op_type == OP_NULL) {
7454                         gvop = ((UNOP*)gvop)->op_first;
7455                         if (gvop) {
7456                             for (; gvop->op_sibling; gvop = gvop->op_sibling)
7457                                 ;
7458                             if (gvop &&
7459                                 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
7460                                 (gvop = ((UNOP*)gvop)->op_first) &&
7461                                 gvop->op_type == OP_GV)
7462                             {
7463                                 GV * const gv = cGVOPx_gv(gvop);
7464                                 OP * const sibling = o2->op_sibling;
7465                                 SV * const n = newSVpvs("");
7466 #ifdef PERL_MAD
7467                                 OP * const oldo2 = o2;
7468 #else
7469                                 op_free(o2);
7470 #endif
7471                                 gv_fullname4(n, gv, "", FALSE);
7472                                 o2 = newSVOP(OP_CONST, 0, n);
7473                                 op_getmad(oldo2,o2,'O');
7474                                 prev->op_sibling = o2;
7475                                 o2->op_sibling = sibling;
7476                             }
7477                         }
7478                     }
7479                 }
7480                 scalar(o2);
7481                 break;
7482             case '[': case ']':
7483                  goto oops;
7484                  break;
7485             case '\\':
7486                 proto++;
7487                 arg++;
7488             again:
7489                 switch (*proto++) {
7490                 case '[':
7491                      if (contextclass++ == 0) {
7492                           e = strchr(proto, ']');
7493                           if (!e || e == proto)
7494                                goto oops;
7495                      }
7496                      else
7497                           goto oops;
7498                      goto again;
7499                      break;
7500                 case ']':
7501                      if (contextclass) {
7502                          const char *p = proto;
7503                          const char *const end = proto;
7504                          contextclass = 0;
7505                          while (*--p != '[');
7506                          bad_type(arg, Perl_form(aTHX_ "one of %.*s",
7507                                                  (int)(end - p), p),
7508                                   gv_ename(namegv), o3);
7509                      } else
7510                           goto oops;
7511                      break;
7512                 case '*':
7513                      if (o3->op_type == OP_RV2GV)
7514                           goto wrapref;
7515                      if (!contextclass)
7516                           bad_type(arg, "symbol", gv_ename(namegv), o3);
7517                      break;
7518                 case '&':
7519                      if (o3->op_type == OP_ENTERSUB)
7520                           goto wrapref;
7521                      if (!contextclass)
7522                           bad_type(arg, "subroutine entry", gv_ename(namegv),
7523                                    o3);
7524                      break;
7525                 case '$':
7526                     if (o3->op_type == OP_RV2SV ||
7527                         o3->op_type == OP_PADSV ||
7528                         o3->op_type == OP_HELEM ||
7529                         o3->op_type == OP_AELEM ||
7530                         o3->op_type == OP_THREADSV)
7531                          goto wrapref;
7532                     if (!contextclass)
7533                         bad_type(arg, "scalar", gv_ename(namegv), o3);
7534                      break;
7535                 case '@':
7536                     if (o3->op_type == OP_RV2AV ||
7537                         o3->op_type == OP_PADAV)
7538                          goto wrapref;
7539                     if (!contextclass)
7540                         bad_type(arg, "array", gv_ename(namegv), o3);
7541                     break;
7542                 case '%':
7543                     if (o3->op_type == OP_RV2HV ||
7544                         o3->op_type == OP_PADHV)
7545                          goto wrapref;
7546                     if (!contextclass)
7547                          bad_type(arg, "hash", gv_ename(namegv), o3);
7548                     break;
7549                 wrapref:
7550                     {
7551                         OP* const kid = o2;
7552                         OP* const sib = kid->op_sibling;
7553                         kid->op_sibling = 0;
7554                         o2 = newUNOP(OP_REFGEN, 0, kid);
7555                         o2->op_sibling = sib;
7556                         prev->op_sibling = o2;
7557                     }
7558                     if (contextclass && e) {
7559                          proto = e + 1;
7560                          contextclass = 0;
7561                     }
7562                     break;
7563                 default: goto oops;
7564                 }
7565                 if (contextclass)
7566                      goto again;
7567                 break;
7568             case ' ':
7569                 proto++;
7570                 continue;
7571             default:
7572               oops:
7573                 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
7574                            gv_ename(namegv), (void*)cv);
7575             }
7576         }
7577         else
7578             list(o2);
7579         mod(o2, OP_ENTERSUB);
7580         prev = o2;
7581         o2 = o2->op_sibling;
7582     } /* while */
7583     if (o2 == cvop && proto && *proto == '_') {
7584         /* generate an access to $_ */
7585         o2 = newDEFSVOP();
7586         o2->op_sibling = prev->op_sibling;
7587         prev->op_sibling = o2; /* instead of cvop */
7588     }
7589     if (proto && !optional && proto_end > proto &&
7590         (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
7591         return too_few_arguments(o, gv_ename(namegv));
7592     if(delete_op) {
7593 #ifdef PERL_MAD
7594         OP * const oldo = o;
7595 #else
7596         op_free(o);
7597 #endif
7598         o=newSVOP(OP_CONST, 0, newSViv(0));
7599         op_getmad(oldo,o,'O');
7600     }
7601     return o;
7602 }
7603
7604 OP *
7605 Perl_ck_svconst(pTHX_ OP *o)
7606 {
7607     PERL_UNUSED_CONTEXT;
7608     SvREADONLY_on(cSVOPo->op_sv);
7609     return o;
7610 }
7611
7612 OP *
7613 Perl_ck_chdir(pTHX_ OP *o)
7614 {
7615     if (o->op_flags & OPf_KIDS) {
7616         SVOP * const kid = (SVOP*)cUNOPo->op_first;
7617
7618         if (kid && kid->op_type == OP_CONST &&
7619             (kid->op_private & OPpCONST_BARE))
7620         {
7621             o->op_flags |= OPf_SPECIAL;
7622             kid->op_private &= ~OPpCONST_STRICT;
7623         }
7624     }
7625     return ck_fun(o);
7626 }
7627
7628 OP *
7629 Perl_ck_trunc(pTHX_ OP *o)
7630 {
7631     if (o->op_flags & OPf_KIDS) {
7632         SVOP *kid = (SVOP*)cUNOPo->op_first;
7633
7634         if (kid->op_type == OP_NULL)
7635             kid = (SVOP*)kid->op_sibling;
7636         if (kid && kid->op_type == OP_CONST &&
7637             (kid->op_private & OPpCONST_BARE))
7638         {
7639             o->op_flags |= OPf_SPECIAL;
7640             kid->op_private &= ~OPpCONST_STRICT;
7641         }
7642     }
7643     return ck_fun(o);
7644 }
7645
7646 OP *
7647 Perl_ck_unpack(pTHX_ OP *o)
7648 {
7649     OP *kid = cLISTOPo->op_first;
7650     if (kid->op_sibling) {
7651         kid = kid->op_sibling;
7652         if (!kid->op_sibling)
7653             kid->op_sibling = newDEFSVOP();
7654     }
7655     return ck_fun(o);
7656 }
7657
7658 OP *
7659 Perl_ck_substr(pTHX_ OP *o)
7660 {
7661     o = ck_fun(o);
7662     if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
7663         OP *kid = cLISTOPo->op_first;
7664
7665         if (kid->op_type == OP_NULL)
7666             kid = kid->op_sibling;
7667         if (kid)
7668             kid->op_flags |= OPf_MOD;
7669
7670     }
7671     return o;
7672 }
7673
7674 /* A peephole optimizer.  We visit the ops in the order they're to execute.
7675  * See the comments at the top of this file for more details about when
7676  * peep() is called */
7677
7678 void
7679 Perl_peep(pTHX_ register OP *o)
7680 {
7681     dVAR;
7682     register OP* oldop = NULL;
7683
7684     if (!o || o->op_opt)
7685         return;
7686     ENTER;
7687     SAVEOP();
7688     SAVEVPTR(PL_curcop);
7689     for (; o; o = o->op_next) {
7690         if (o->op_opt)
7691             break;
7692         PL_op = o;
7693         switch (o->op_type) {
7694         case OP_SETSTATE:
7695         case OP_NEXTSTATE:
7696         case OP_DBSTATE:
7697             PL_curcop = ((COP*)o);              /* for warnings */
7698             o->op_opt = 1;
7699             break;
7700
7701         case OP_CONST:
7702             if (cSVOPo->op_private & OPpCONST_STRICT)
7703                 no_bareword_allowed(o);
7704 #ifdef USE_ITHREADS
7705         case OP_METHOD_NAMED:
7706             /* Relocate sv to the pad for thread safety.
7707              * Despite being a "constant", the SV is written to,
7708              * for reference counts, sv_upgrade() etc. */
7709             if (cSVOP->op_sv) {
7710                 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
7711                 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
7712                     /* If op_sv is already a PADTMP then it is being used by
7713                      * some pad, so make a copy. */
7714                     sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
7715                     SvREADONLY_on(PAD_SVl(ix));
7716                     SvREFCNT_dec(cSVOPo->op_sv);
7717                 }
7718                 else if (o->op_type == OP_CONST
7719                          && cSVOPo->op_sv == &PL_sv_undef) {
7720                     /* PL_sv_undef is hack - it's unsafe to store it in the
7721                        AV that is the pad, because av_fetch treats values of
7722                        PL_sv_undef as a "free" AV entry and will merrily
7723                        replace them with a new SV, causing pad_alloc to think
7724                        that this pad slot is free. (When, clearly, it is not)
7725                     */
7726                     SvOK_off(PAD_SVl(ix));
7727                     SvPADTMP_on(PAD_SVl(ix));
7728                     SvREADONLY_on(PAD_SVl(ix));
7729                 }
7730                 else {
7731                     SvREFCNT_dec(PAD_SVl(ix));
7732                     SvPADTMP_on(cSVOPo->op_sv);
7733                     PAD_SETSV(ix, cSVOPo->op_sv);
7734                     /* XXX I don't know how this isn't readonly already. */
7735                     SvREADONLY_on(PAD_SVl(ix));
7736                 }
7737                 cSVOPo->op_sv = NULL;
7738                 o->op_targ = ix;
7739             }
7740 #endif
7741             o->op_opt = 1;
7742             break;
7743
7744         case OP_CONCAT:
7745             if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
7746                 if (o->op_next->op_private & OPpTARGET_MY) {
7747                     if (o->op_flags & OPf_STACKED) /* chained concats */
7748                         goto ignore_optimization;
7749                     else {
7750                         /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
7751                         o->op_targ = o->op_next->op_targ;
7752                         o->op_next->op_targ = 0;
7753                         o->op_private |= OPpTARGET_MY;
7754                     }
7755                 }
7756                 op_null(o->op_next);
7757             }
7758           ignore_optimization:
7759             o->op_opt = 1;
7760             break;
7761         case OP_STUB:
7762             if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
7763                 o->op_opt = 1;
7764                 break; /* Scalar stub must produce undef.  List stub is noop */
7765             }
7766             goto nothin;
7767         case OP_NULL:
7768             if (o->op_targ == OP_NEXTSTATE
7769                 || o->op_targ == OP_DBSTATE
7770                 || o->op_targ == OP_SETSTATE)
7771             {
7772                 PL_curcop = ((COP*)o);
7773             }
7774             /* XXX: We avoid setting op_seq here to prevent later calls
7775                to peep() from mistakenly concluding that optimisation
7776                has already occurred. This doesn't fix the real problem,
7777                though (See 20010220.007). AMS 20010719 */
7778             /* op_seq functionality is now replaced by op_opt */
7779             if (oldop && o->op_next) {
7780                 oldop->op_next = o->op_next;
7781                 continue;
7782             }
7783             break;
7784         case OP_SCALAR:
7785         case OP_LINESEQ:
7786         case OP_SCOPE:
7787           nothin:
7788             if (oldop && o->op_next) {
7789                 oldop->op_next = o->op_next;
7790                 continue;
7791             }
7792             o->op_opt = 1;
7793             break;
7794
7795         case OP_PADAV:
7796         case OP_GV:
7797             if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
7798                 OP* const pop = (o->op_type == OP_PADAV) ?
7799                             o->op_next : o->op_next->op_next;
7800                 IV i;
7801                 if (pop && pop->op_type == OP_CONST &&
7802                     ((PL_op = pop->op_next)) &&
7803                     pop->op_next->op_type == OP_AELEM &&
7804                     !(pop->op_next->op_private &
7805                       (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
7806                     (i = SvIV(((SVOP*)pop)->op_sv) - CopARYBASE_get(PL_curcop))
7807                                 <= 255 &&
7808                     i >= 0)
7809                 {
7810                     GV *gv;
7811                     if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
7812                         no_bareword_allowed(pop);
7813                     if (o->op_type == OP_GV)
7814                         op_null(o->op_next);
7815                     op_null(pop->op_next);
7816                     op_null(pop);
7817                     o->op_flags |= pop->op_next->op_flags & OPf_MOD;
7818                     o->op_next = pop->op_next->op_next;
7819                     o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
7820                     o->op_private = (U8)i;
7821                     if (o->op_type == OP_GV) {
7822                         gv = cGVOPo_gv;
7823                         GvAVn(gv);
7824                     }
7825                     else
7826                         o->op_flags |= OPf_SPECIAL;
7827                     o->op_type = OP_AELEMFAST;
7828                 }
7829                 o->op_opt = 1;
7830                 break;
7831             }
7832
7833             if (o->op_next->op_type == OP_RV2SV) {
7834                 if (!(o->op_next->op_private & OPpDEREF)) {
7835                     op_null(o->op_next);
7836                     o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
7837                                                                | OPpOUR_INTRO);
7838                     o->op_next = o->op_next->op_next;
7839                     o->op_type = OP_GVSV;
7840                     o->op_ppaddr = PL_ppaddr[OP_GVSV];
7841                 }
7842             }
7843             else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
7844                 GV * const gv = cGVOPo_gv;
7845                 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
7846                     /* XXX could check prototype here instead of just carping */
7847                     SV * const sv = sv_newmortal();
7848                     gv_efullname3(sv, gv, NULL);
7849                     Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
7850                                 "%"SVf"() called too early to check prototype",
7851                                 (void*)sv);
7852                 }
7853             }
7854             else if (o->op_next->op_type == OP_READLINE
7855                     && o->op_next->op_next->op_type == OP_CONCAT
7856                     && (o->op_next->op_next->op_flags & OPf_STACKED))
7857             {
7858                 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
7859                 o->op_type   = OP_RCATLINE;
7860                 o->op_flags |= OPf_STACKED;
7861                 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
7862                 op_null(o->op_next->op_next);
7863                 op_null(o->op_next);
7864             }
7865
7866             o->op_opt = 1;
7867             break;
7868
7869         case OP_MAPWHILE:
7870         case OP_GREPWHILE:
7871         case OP_AND:
7872         case OP_OR:
7873         case OP_DOR:
7874         case OP_ANDASSIGN:
7875         case OP_ORASSIGN:
7876         case OP_DORASSIGN:
7877         case OP_COND_EXPR:
7878         case OP_RANGE:
7879             o->op_opt = 1;
7880             while (cLOGOP->op_other->op_type == OP_NULL)
7881                 cLOGOP->op_other = cLOGOP->op_other->op_next;
7882             peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
7883             break;
7884
7885         case OP_ENTERLOOP:
7886         case OP_ENTERITER:
7887             o->op_opt = 1;
7888             while (cLOOP->op_redoop->op_type == OP_NULL)
7889                 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
7890             peep(cLOOP->op_redoop);
7891             while (cLOOP->op_nextop->op_type == OP_NULL)
7892                 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
7893             peep(cLOOP->op_nextop);
7894             while (cLOOP->op_lastop->op_type == OP_NULL)
7895                 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
7896             peep(cLOOP->op_lastop);
7897             break;
7898
7899         case OP_QR:
7900         case OP_MATCH:
7901         case OP_SUBST:
7902             o->op_opt = 1;
7903             while (cPMOP->op_pmreplstart &&
7904                    cPMOP->op_pmreplstart->op_type == OP_NULL)
7905                 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
7906             peep(cPMOP->op_pmreplstart);
7907             break;
7908
7909         case OP_EXEC:
7910             o->op_opt = 1;
7911             if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
7912                 && ckWARN(WARN_SYNTAX))
7913             {
7914                 if (o->op_next->op_sibling) {
7915                     const OPCODE type = o->op_next->op_sibling->op_type;
7916                     if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
7917                         const line_t oldline = CopLINE(PL_curcop);
7918                         CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
7919                         Perl_warner(aTHX_ packWARN(WARN_EXEC),
7920                                     "Statement unlikely to be reached");
7921                         Perl_warner(aTHX_ packWARN(WARN_EXEC),
7922                                     "\t(Maybe you meant system() when you said exec()?)\n");
7923                         CopLINE_set(PL_curcop, oldline);
7924                     }
7925                 }
7926             }
7927             break;
7928
7929         case OP_HELEM: {
7930             UNOP *rop;
7931             SV *lexname;
7932             GV **fields;
7933             SV **svp, *sv;
7934             const char *key = NULL;
7935             STRLEN keylen;
7936
7937             o->op_opt = 1;
7938
7939             if (((BINOP*)o)->op_last->op_type != OP_CONST)
7940                 break;
7941
7942             /* Make the CONST have a shared SV */
7943             svp = cSVOPx_svp(((BINOP*)o)->op_last);
7944             if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
7945                 key = SvPV_const(sv, keylen);
7946                 lexname = newSVpvn_share(key,
7947                                          SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
7948                                          0);
7949                 SvREFCNT_dec(sv);
7950                 *svp = lexname;
7951             }
7952
7953             if ((o->op_private & (OPpLVAL_INTRO)))
7954                 break;
7955
7956             rop = (UNOP*)((BINOP*)o)->op_first;
7957             if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
7958                 break;
7959             lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
7960             if (!SvPAD_TYPED(lexname))
7961                 break;
7962             fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
7963             if (!fields || !GvHV(*fields))
7964                 break;
7965             key = SvPV_const(*svp, keylen);
7966             if (!hv_fetch(GvHV(*fields), key,
7967                         SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
7968             {
7969                 Perl_croak(aTHX_ "No such class field \"%s\" "
7970                            "in variable %s of type %s",
7971                       key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
7972             }
7973
7974             break;
7975         }
7976
7977         case OP_HSLICE: {
7978             UNOP *rop;
7979             SV *lexname;
7980             GV **fields;
7981             SV **svp;
7982             const char *key;
7983             STRLEN keylen;
7984             SVOP *first_key_op, *key_op;
7985
7986             if ((o->op_private & (OPpLVAL_INTRO))
7987                 /* I bet there's always a pushmark... */
7988                 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
7989                 /* hmmm, no optimization if list contains only one key. */
7990                 break;
7991             rop = (UNOP*)((LISTOP*)o)->op_last;
7992             if (rop->op_type != OP_RV2HV)
7993                 break;
7994             if (rop->op_first->op_type == OP_PADSV)
7995                 /* @$hash{qw(keys here)} */
7996                 rop = (UNOP*)rop->op_first;
7997             else {
7998                 /* @{$hash}{qw(keys here)} */
7999                 if (rop->op_first->op_type == OP_SCOPE
8000                     && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
8001                 {
8002                     rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
8003                 }
8004                 else
8005                     break;
8006             }
8007
8008             lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
8009             if (!SvPAD_TYPED(lexname))
8010                 break;
8011             fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
8012             if (!fields || !GvHV(*fields))
8013                 break;
8014             /* Again guessing that the pushmark can be jumped over.... */
8015             first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
8016                 ->op_first->op_sibling;
8017             for (key_op = first_key_op; key_op;
8018                  key_op = (SVOP*)key_op->op_sibling) {
8019                 if (key_op->op_type != OP_CONST)
8020                     continue;
8021                 svp = cSVOPx_svp(key_op);
8022                 key = SvPV_const(*svp, keylen);
8023                 if (!hv_fetch(GvHV(*fields), key,
8024                             SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
8025                 {
8026                     Perl_croak(aTHX_ "No such class field \"%s\" "
8027                                "in variable %s of type %s",
8028                           key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
8029                 }
8030             }
8031             break;
8032         }
8033
8034         case OP_SORT: {
8035             /* will point to RV2AV or PADAV op on LHS/RHS of assign */
8036             OP *oleft;
8037             OP *o2;
8038
8039             /* check that RHS of sort is a single plain array */
8040             OP *oright = cUNOPo->op_first;
8041             if (!oright || oright->op_type != OP_PUSHMARK)
8042                 break;
8043
8044             /* reverse sort ... can be optimised.  */
8045             if (!cUNOPo->op_sibling) {
8046                 /* Nothing follows us on the list. */
8047                 OP * const reverse = o->op_next;
8048
8049                 if (reverse->op_type == OP_REVERSE &&
8050                     (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
8051                     OP * const pushmark = cUNOPx(reverse)->op_first;
8052                     if (pushmark && (pushmark->op_type == OP_PUSHMARK)
8053                         && (cUNOPx(pushmark)->op_sibling == o)) {
8054                         /* reverse -> pushmark -> sort */
8055                         o->op_private |= OPpSORT_REVERSE;
8056                         op_null(reverse);
8057                         pushmark->op_next = oright->op_next;
8058                         op_null(oright);
8059                     }
8060                 }
8061             }
8062
8063             /* make @a = sort @a act in-place */
8064
8065             o->op_opt = 1;
8066
8067             oright = cUNOPx(oright)->op_sibling;
8068             if (!oright)
8069                 break;
8070             if (oright->op_type == OP_NULL) { /* skip sort block/sub */
8071                 oright = cUNOPx(oright)->op_sibling;
8072             }
8073
8074             if (!oright ||
8075                 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
8076                 || oright->op_next != o
8077                 || (oright->op_private & OPpLVAL_INTRO)
8078             )
8079                 break;
8080
8081             /* o2 follows the chain of op_nexts through the LHS of the
8082              * assign (if any) to the aassign op itself */
8083             o2 = o->op_next;
8084             if (!o2 || o2->op_type != OP_NULL)
8085                 break;
8086             o2 = o2->op_next;
8087             if (!o2 || o2->op_type != OP_PUSHMARK)
8088                 break;
8089             o2 = o2->op_next;
8090             if (o2 && o2->op_type == OP_GV)
8091                 o2 = o2->op_next;
8092             if (!o2
8093                 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
8094                 || (o2->op_private & OPpLVAL_INTRO)
8095             )
8096                 break;
8097             oleft = o2;
8098             o2 = o2->op_next;
8099             if (!o2 || o2->op_type != OP_NULL)
8100                 break;
8101             o2 = o2->op_next;
8102             if (!o2 || o2->op_type != OP_AASSIGN
8103                     || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
8104                 break;
8105
8106             /* check that the sort is the first arg on RHS of assign */
8107
8108             o2 = cUNOPx(o2)->op_first;
8109             if (!o2 || o2->op_type != OP_NULL)
8110                 break;
8111             o2 = cUNOPx(o2)->op_first;
8112             if (!o2 || o2->op_type != OP_PUSHMARK)
8113                 break;
8114             if (o2->op_sibling != o)
8115                 break;
8116
8117             /* check the array is the same on both sides */
8118             if (oleft->op_type == OP_RV2AV) {
8119                 if (oright->op_type != OP_RV2AV
8120                     || !cUNOPx(oright)->op_first
8121                     || cUNOPx(oright)->op_first->op_type != OP_GV
8122                     ||  cGVOPx_gv(cUNOPx(oleft)->op_first) !=
8123                         cGVOPx_gv(cUNOPx(oright)->op_first)
8124                 )
8125                     break;
8126             }
8127             else if (oright->op_type != OP_PADAV
8128                 || oright->op_targ != oleft->op_targ
8129             )
8130                 break;
8131
8132             /* transfer MODishness etc from LHS arg to RHS arg */
8133             oright->op_flags = oleft->op_flags;
8134             o->op_private |= OPpSORT_INPLACE;
8135
8136             /* excise push->gv->rv2av->null->aassign */
8137             o2 = o->op_next->op_next;
8138             op_null(o2); /* PUSHMARK */
8139             o2 = o2->op_next;
8140             if (o2->op_type == OP_GV) {
8141                 op_null(o2); /* GV */
8142                 o2 = o2->op_next;
8143             }
8144             op_null(o2); /* RV2AV or PADAV */
8145             o2 = o2->op_next->op_next;
8146             op_null(o2); /* AASSIGN */
8147
8148             o->op_next = o2->op_next;
8149
8150             break;
8151         }
8152
8153         case OP_REVERSE: {
8154             OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
8155             OP *gvop = NULL;
8156             LISTOP *enter, *exlist;
8157             o->op_opt = 1;
8158
8159             enter = (LISTOP *) o->op_next;
8160             if (!enter)
8161                 break;
8162             if (enter->op_type == OP_NULL) {
8163                 enter = (LISTOP *) enter->op_next;
8164                 if (!enter)
8165                     break;
8166             }
8167             /* for $a (...) will have OP_GV then OP_RV2GV here.
8168                for (...) just has an OP_GV.  */
8169             if (enter->op_type == OP_GV) {
8170                 gvop = (OP *) enter;
8171                 enter = (LISTOP *) enter->op_next;
8172                 if (!enter)
8173                     break;
8174                 if (enter->op_type == OP_RV2GV) {
8175                   enter = (LISTOP *) enter->op_next;
8176                   if (!enter)
8177                     break;
8178                 }
8179             }
8180
8181             if (enter->op_type != OP_ENTERITER)
8182                 break;
8183
8184             iter = enter->op_next;
8185             if (!iter || iter->op_type != OP_ITER)
8186                 break;
8187
8188             expushmark = enter->op_first;
8189             if (!expushmark || expushmark->op_type != OP_NULL
8190                 || expushmark->op_targ != OP_PUSHMARK)
8191                 break;
8192
8193             exlist = (LISTOP *) expushmark->op_sibling;
8194             if (!exlist || exlist->op_type != OP_NULL
8195                 || exlist->op_targ != OP_LIST)
8196                 break;
8197
8198             if (exlist->op_last != o) {
8199                 /* Mmm. Was expecting to point back to this op.  */
8200                 break;
8201             }
8202             theirmark = exlist->op_first;
8203             if (!theirmark || theirmark->op_type != OP_PUSHMARK)
8204                 break;
8205
8206             if (theirmark->op_sibling != o) {
8207                 /* There's something between the mark and the reverse, eg
8208                    for (1, reverse (...))
8209                    so no go.  */
8210                 break;
8211             }
8212
8213             ourmark = ((LISTOP *)o)->op_first;
8214             if (!ourmark || ourmark->op_type != OP_PUSHMARK)
8215                 break;
8216
8217             ourlast = ((LISTOP *)o)->op_last;
8218             if (!ourlast || ourlast->op_next != o)
8219                 break;
8220
8221             rv2av = ourmark->op_sibling;
8222             if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
8223                 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
8224                 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
8225                 /* We're just reversing a single array.  */
8226                 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
8227                 enter->op_flags |= OPf_STACKED;
8228             }
8229
8230             /* We don't have control over who points to theirmark, so sacrifice
8231                ours.  */
8232             theirmark->op_next = ourmark->op_next;
8233             theirmark->op_flags = ourmark->op_flags;
8234             ourlast->op_next = gvop ? gvop : (OP *) enter;
8235             op_null(ourmark);
8236             op_null(o);
8237             enter->op_private |= OPpITER_REVERSED;
8238             iter->op_private |= OPpITER_REVERSED;
8239
8240             break;
8241         }
8242
8243         case OP_SASSIGN: {
8244             OP *rv2gv;
8245             UNOP *refgen, *rv2cv;
8246             LISTOP *exlist;
8247
8248             /* I do not understand this, but if o->op_opt isn't set to 1,
8249                various tests in ext/B/t/bytecode.t fail with no readily
8250                apparent cause.  */
8251
8252             o->op_opt = 1;
8253
8254
8255             if ((o->op_flags && OPf_WANT) != OPf_WANT_VOID)
8256                 break;
8257
8258             if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
8259                 break;
8260
8261             rv2gv = ((BINOP *)o)->op_last;
8262             if (!rv2gv || rv2gv->op_type != OP_RV2GV)
8263                 break;
8264
8265             refgen = (UNOP *)((BINOP *)o)->op_first;
8266
8267             if (!refgen || refgen->op_type != OP_REFGEN)
8268                 break;
8269
8270             exlist = (LISTOP *)refgen->op_first;
8271             if (!exlist || exlist->op_type != OP_NULL
8272                 || exlist->op_targ != OP_LIST)
8273                 break;
8274
8275             if (exlist->op_first->op_type != OP_PUSHMARK)
8276                 break;
8277
8278             rv2cv = (UNOP*)exlist->op_last;
8279
8280             if (rv2cv->op_type != OP_RV2CV)
8281                 break;
8282
8283             assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
8284             assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
8285             assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
8286
8287             o->op_private |= OPpASSIGN_CV_TO_GV;
8288             rv2gv->op_private |= OPpDONT_INIT_GV;
8289             rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
8290
8291             break;
8292         }
8293
8294
8295         default:
8296             o->op_opt = 1;
8297             break;
8298         }
8299         oldop = o;
8300     }
8301     LEAVE;
8302 }
8303
8304 char*
8305 Perl_custom_op_name(pTHX_ const OP* o)
8306 {
8307     dVAR;
8308     const IV index = PTR2IV(o->op_ppaddr);
8309     SV* keysv;
8310     HE* he;
8311
8312     if (!PL_custom_op_names) /* This probably shouldn't happen */
8313         return (char *)PL_op_name[OP_CUSTOM];
8314
8315     keysv = sv_2mortal(newSViv(index));
8316
8317     he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
8318     if (!he)
8319         return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
8320
8321     return SvPV_nolen(HeVAL(he));
8322 }
8323
8324 char*
8325 Perl_custom_op_desc(pTHX_ const OP* o)
8326 {
8327     dVAR;
8328     const IV index = PTR2IV(o->op_ppaddr);
8329     SV* keysv;
8330     HE* he;
8331
8332     if (!PL_custom_op_descs)
8333         return (char *)PL_op_desc[OP_CUSTOM];
8334
8335     keysv = sv_2mortal(newSViv(index));
8336
8337     he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
8338     if (!he)
8339         return (char *)PL_op_desc[OP_CUSTOM];
8340
8341     return SvPV_nolen(HeVAL(he));
8342 }
8343
8344 #include "XSUB.h"
8345
8346 /* Efficient sub that returns a constant scalar value. */
8347 static void
8348 const_sv_xsub(pTHX_ CV* cv)
8349 {
8350     dVAR;
8351     dXSARGS;
8352     if (items != 0) {
8353         NOOP;
8354 #if 0
8355         Perl_croak(aTHX_ "usage: %s::%s()",
8356                    HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
8357 #endif
8358     }
8359     EXTEND(sp, 1);
8360     ST(0) = (SV*)XSANY.any_ptr;
8361     XSRETURN(1);
8362 }
8363
8364 /*
8365  * Local variables:
8366  * c-indentation-style: bsd
8367  * c-basic-offset: 4
8368  * indent-tabs-mode: t
8369  * End:
8370  *
8371  * ex: set ts=8 sts=4 sw=4 noet:
8372  */