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