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