op.c

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