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