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