op.c

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