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