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