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