op.c

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