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