op.c

   1 /*    op.c
   2  *
   3  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
   4  *    2000, 2001, 2002, 2003, 2004, 2005, by Larry Wall and others
   5  *
   6  *    You may distribute under the terms of either the GNU General Public
   7  *    License or the Artistic License, as specified in the README file.
   8  *
   9  */
  10
  11 /*
  12  * "You see: Mr. Drogo, he married poor Miss Primula Brandybuck.  She was
  13  * our Mr. Bilbo's first cousin on the mother's side (her mother being the
  14  * youngest of the Old Took's daughters); and Mr. Drogo was his second
  15  * cousin.  So Mr. Frodo is his first *and* second cousin, once removed
  16  * either way, as the saying is, if you follow me."  --the Gaffer
  17  */
  18
  19 /* This file contains the functions that create, manipulate and optimize
  20  * the OP structures that hold a compiled perl program.
  21  *
  22  * A Perl program is compiled into a tree of OPs. Each op contains
  23  * structural pointers (eg to its siblings and the next op in the
  24  * execution sequence), a pointer to the function that would execute the
  25  * op, plus any data specific to that op. For example, an OP_CONST op
  26  * points to the pp_const() function and to an SV containing the constant
  27  * value. When pp_const() is executed, its job is to push that SV onto the
  28  * stack.
  29  *
  30  * OPs are mainly created by the newFOO() functions, which are mainly
  31  * called from the parser (in perly.y) as the code is parsed. For example
  32  * the Perl code $a + $b * $c would cause the equivalent of the following
  33  * to be called (oversimplifying a bit):
  34  *
  35  *  newBINOP(OP_ADD, flags,
  36  *      newSVREF($a),
  37  *      newBINOP(OP_MULTIPLY, flags, newSVREF($b), newSVREF($c))
  38  *  )
  39  *
  40  * Note that during the build of miniperl, a temporary copy of this file
  41  * is made, called opmini.c.
  42  */
  43
  44 /*
  45 Perl's compiler is essentially a 3-pass compiler with interleaved phases:
  46
  47     A bottom-up pass
  48     A top-down pass
  49     An execution-order pass
  50
  51 The bottom-up pass is represented by all the "newOP" routines and
  52 the ck_ routines.  The bottom-upness is actually driven by yacc.
  53 So at the point that a ck_ routine fires, we have no idea what the
  54 context is, either upward in the syntax tree, or either forward or
  55 backward in the execution order.  (The bottom-up parser builds that
  56 part of the execution order it knows about, but if you follow the "next"
  57 links around, you'll find it's actually a closed loop through the
  58 top level node.
  59
  60 Whenever the bottom-up parser gets to a node that supplies context to
  61 its components, it invokes that portion of the top-down pass that applies
  62 to that part of the subtree (and marks the top node as processed, so
  63 if a node further up supplies context, it doesn't have to take the
  64 plunge again).  As a particular subcase of this, as the new node is
  65 built, it takes all the closed execution loops of its subcomponents
  66 and links them into a new closed loop for the higher level node.  But
  67 it's still not the real execution order.
  68
  69 The actual execution order is not known till we get a grammar reduction
  70 to a top-level unit like a subroutine or file that will be called by
  71 "name" rather than via a "next" pointer.  At that point, we can call
  72 into peep() to do that code's portion of the 3rd pass.  It has to be
  73 recursive, but it's recursive on basic blocks, not on tree nodes.
  74 */
  75
  76 #include "EXTERN.h"
  77 #define PERL_IN_OP_C
  78 #include "perl.h"
  79 #include "keywords.h"
  80
  81 #define CALL_PEEP(o) CALL_FPTR(PL_peepp)(aTHX_ o)
  82
  83 #if defined(PL_OP_SLAB_ALLOC)
  84
  85 #ifndef PERL_SLAB_SIZE
  86 #define PERL_SLAB_SIZE 2048
  87 #endif
  88
  89 void *
  90 Perl_Slab_Alloc(pTHX_ int m, size_t sz)
  91 {
  92     /*
  93      * To make incrementing use count easy PL_OpSlab is an I32 *
  94      * To make inserting the link to slab PL_OpPtr is I32 **
  95      * So compute size in units of sizeof(I32 *) as that is how Pl_OpPtr increments
  96      * Add an overhead for pointer to slab and round up as a number of pointers
  97      */
  98     sz = (sz + 2*sizeof(I32 *) -1)/sizeof(I32 *);
  99     if ((PL_OpSpace -= sz) < 0) {
 100         PL_OpPtr = (I32 **) PerlMemShared_malloc(PERL_SLAB_SIZE*sizeof(I32*));
 101         if (!PL_OpPtr) {
 102             return NULL;
 103         }
 104         Zero(PL_OpPtr,PERL_SLAB_SIZE,I32 **);
 105         /* We reserve the 0'th I32 sized chunk as a use count */
 106         PL_OpSlab = (I32 *) PL_OpPtr;
 107         /* Reduce size by the use count word, and by the size we need.
 108          * Latter is to mimic the '-=' in the if() above
 109          */
 110         PL_OpSpace = PERL_SLAB_SIZE - (sizeof(I32)+sizeof(I32 **)-1)/sizeof(I32 **) - sz;
 111         /* Allocation pointer starts at the top.
 112            Theory: because we build leaves before trunk allocating at end
 113            means that at run time access is cache friendly upward
 114          */
 115         PL_OpPtr += PERL_SLAB_SIZE;
 116     }
 117     assert( PL_OpSpace >= 0 );
 118     /* Move the allocation pointer down */
 119     PL_OpPtr   -= sz;
 120     assert( PL_OpPtr > (I32 **) PL_OpSlab );
 121     *PL_OpPtr   = PL_OpSlab;    /* Note which slab it belongs to */
 122     (*PL_OpSlab)++;             /* Increment use count of slab */
 123     assert( PL_OpPtr+sz <= ((I32 **) PL_OpSlab + PERL_SLAB_SIZE) );
 124     assert( *PL_OpSlab > 0 );
 125     return (void *)(PL_OpPtr + 1);
 126 }
 127
 128 void
 129 Perl_Slab_Free(pTHX_ void *op)
 130 {
 131     I32 **ptr = (I32 **) op;
 132     I32 *slab = ptr[-1];
 133     assert( ptr-1 > (I32 **) slab );
 134     assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
 135     assert( *slab > 0 );
 136     if (--(*slab) == 0) {
 137 #  ifdef NETWARE
 138 #    define PerlMemShared PerlMem
 139 #  endif
 140
 141     PerlMemShared_free(slab);
 142         if (slab == PL_OpSlab) {
 143             PL_OpSpace = 0;
 144         }
 145     }
 146 }
 147 #endif
 148 /*
 149  * In the following definition, the ", Nullop" is just to make the compiler
 150  * think the expression is of the right type: croak actually does a Siglongjmp.
 151  */
 152 #define CHECKOP(type,o) \
 153     ((PL_op_mask && PL_op_mask[type])                                   \
 154      ? ( op_free((OP*)o),                                       \
 155          Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]),  \
 156          Nullop )                                               \
 157      : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o))
 158
 159 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
 160
 161 STATIC char*
 162 S_gv_ename(pTHX_ GV *gv)
 163 {
 164     STRLEN n_a;
 165     SV* tmpsv = sv_newmortal();
 166     gv_efullname3(tmpsv, gv, Nullch);
 167     return SvPV(tmpsv,n_a);
 168 }
 169
 170 STATIC OP *
 171 S_no_fh_allowed(pTHX_ OP *o)
 172 {
 173     yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
 174                  OP_DESC(o)));
 175     return o;
 176 }
 177
 178 STATIC OP *
 179 S_too_few_arguments(pTHX_ OP *o, const char *name)
 180 {
 181     yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
 182     return o;
 183 }
 184
 185 STATIC OP *
 186 S_too_many_arguments(pTHX_ OP *o, const char *name)
 187 {
 188     yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
 189     return o;
 190 }
 191
 192 STATIC void
 193 S_bad_type(pTHX_ I32 n, const char *t, const char *name, const OP *kid)
 194 {
 195     yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
 196                  (int)n, name, t, OP_DESC(kid)));
 197 }
 198
 199 STATIC void
 200 S_no_bareword_allowed(pTHX_ const OP *o)
 201 {
 202     qerror(Perl_mess(aTHX_
 203                      "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
 204                      cSVOPo_sv));
 205 }
 206
 207 /* "register" allocation */
 208
 209 PADOFFSET
 210 Perl_allocmy(pTHX_ char *name)
 211 {
 212     PADOFFSET off;
 213
 214     /* complain about "my $<special_var>" etc etc */
 215     if (!(PL_in_my == KEY_our ||
 216           isALPHA(name[1]) ||
 217           (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
 218           (name[1] == '_' && (*name == '$' || (int)strlen(name) > 2))))
 219     {
 220         if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
 221             /* 1999-02-27 mjd@plover.com */
 222             char *p;
 223             p = strchr(name, '\0');
 224             /* The next block assumes the buffer is at least 205 chars
 225                long.  At present, it's always at least 256 chars. */
 226             if (p-name > 200) {
 227                 strcpy(name+200, "...");
 228                 p = name+199;
 229             }
 230             else {
 231                 p[1] = '\0';
 232             }
 233             /* Move everything else down one character */
 234             for (; p-name > 2; p--)
 235                 *p = *(p-1);
 236             name[2] = toCTRL(name[1]);
 237             name[1] = '^';
 238         }
 239         yyerror(Perl_form(aTHX_ "Can't use global %s in \"my\"",name));
 240     }
 241
 242     /* check for duplicate declaration */
 243     pad_check_dup(name,
 244                 (bool)(PL_in_my == KEY_our),
 245                 (PL_curstash ? PL_curstash : PL_defstash)
 246     );
 247
 248     if (PL_in_my_stash && *name != '$') {
 249         yyerror(Perl_form(aTHX_
 250                     "Can't declare class for non-scalar %s in \"%s\"",
 251                      name, PL_in_my == KEY_our ? "our" : "my"));
 252     }
 253
 254     /* allocate a spare slot and store the name in that slot */
 255
 256     off = pad_add_name(name,
 257                     PL_in_my_stash,
 258                     (PL_in_my == KEY_our
 259                         /* $_ is always in main::, even with our */
 260                         ? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash)
 261                         : Nullhv
 262                     ),
 263                     0 /*  not fake */
 264     );
 265     return off;
 266 }
 267
 268 /* Destructor */
 269
 270 void
 271 Perl_op_free(pTHX_ OP *o)
 272 {
 273     OPCODE type;
 274     PADOFFSET refcnt;
 275
 276     if (!o || o->op_static)
 277         return;
 278
 279     if (o->op_private & OPpREFCOUNTED) {
 280         switch (o->op_type) {
 281         case OP_LEAVESUB:
 282         case OP_LEAVESUBLV:
 283         case OP_LEAVEEVAL:
 284         case OP_LEAVE:
 285         case OP_SCOPE:
 286         case OP_LEAVEWRITE:
 287             OP_REFCNT_LOCK;
 288             refcnt = OpREFCNT_dec(o);
 289             OP_REFCNT_UNLOCK;
 290             if (refcnt)
 291                 return;
 292             break;
 293         default:
 294             break;
 295         }
 296     }
 297
 298     if (o->op_flags & OPf_KIDS) {
 299         register OP *kid, *nextkid;
 300         for (kid = cUNOPo->op_first; kid; kid = nextkid) {
 301             nextkid = kid->op_sibling; /* Get before next freeing kid */
 302             op_free(kid);
 303         }
 304     }
 305     type = o->op_type;
 306     if (type == OP_NULL)
 307         type = (OPCODE)o->op_targ;
 308
 309     /* COP* is not cleared by op_clear() so that we may track line
 310      * numbers etc even after null() */
 311     if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE)
 312         cop_free((COP*)o);
 313
 314     op_clear(o);
 315     FreeOp(o);
 316 }
 317
 318 void
 319 Perl_op_clear(pTHX_ OP *o)
 320 {
 321
 322     switch (o->op_type) {
 323     case OP_NULL:       /* Was holding old type, if any. */
 324     case OP_ENTEREVAL:  /* Was holding hints. */
 325         o->op_targ = 0;
 326         break;
 327     default:
 328         if (!(o->op_flags & OPf_REF)
 329             || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
 330             break;
 331         /* FALL THROUGH */
 332     case OP_GVSV:
 333     case OP_GV:
 334     case OP_AELEMFAST:
 335         if (! (o->op_type == OP_AELEMFAST && o->op_flags & OPf_SPECIAL)) {
 336             /* not an OP_PADAV replacement */
 337 #ifdef USE_ITHREADS
 338             if (cPADOPo->op_padix > 0) {
 339                 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
 340                  * may still exist on the pad */
 341                 pad_swipe(cPADOPo->op_padix, TRUE);
 342                 cPADOPo->op_padix = 0;
 343             }
 344 #else
 345             SvREFCNT_dec(cSVOPo->op_sv);
 346             cSVOPo->op_sv = Nullsv;
 347 #endif
 348         }
 349         break;
 350     case OP_METHOD_NAMED:
 351     case OP_CONST:
 352         SvREFCNT_dec(cSVOPo->op_sv);
 353         cSVOPo->op_sv = Nullsv;
 354 #ifdef USE_ITHREADS
 355         /** Bug #15654
 356           Even if op_clear does a pad_free for the target of the op,
 357           pad_free doesn't actually remove the sv that exists in the pad;
 358           instead it lives on. This results in that it could be reused as
 359           a target later on when the pad was reallocated.
 360         **/
 361         if(o->op_targ) {
 362           pad_swipe(o->op_targ,1);
 363           o->op_targ = 0;
 364         }
 365 #endif
 366         break;
 367     case OP_GOTO:
 368     case OP_NEXT:
 369     case OP_LAST:
 370     case OP_REDO:
 371         if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
 372             break;
 373         /* FALL THROUGH */
 374     case OP_TRANS:
 375         if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
 376             SvREFCNT_dec(cSVOPo->op_sv);
 377             cSVOPo->op_sv = Nullsv;
 378         }
 379         else {
 380             Safefree(cPVOPo->op_pv);
 381             cPVOPo->op_pv = Nullch;
 382         }
 383         break;
 384     case OP_SUBST:
 385         op_free(cPMOPo->op_pmreplroot);
 386         goto clear_pmop;
 387     case OP_PUSHRE:
 388 #ifdef USE_ITHREADS
 389         if (INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)) {
 390             /* No GvIN_PAD_off here, because other references may still
 391              * exist on the pad */
 392             pad_swipe(INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot), TRUE);
 393         }
 394 #else
 395         SvREFCNT_dec((SV*)cPMOPo->op_pmreplroot);
 396 #endif
 397         /* FALL THROUGH */
 398     case OP_MATCH:
 399     case OP_QR:
 400 clear_pmop:
 401         {
 402             HV *pmstash = PmopSTASH(cPMOPo);
 403             if (pmstash && SvREFCNT(pmstash)) {
 404                 PMOP *pmop = HvPMROOT(pmstash);
 405                 PMOP *lastpmop = NULL;
 406                 while (pmop) {
 407                     if (cPMOPo == pmop) {
 408                         if (lastpmop)
 409                             lastpmop->op_pmnext = pmop->op_pmnext;
 410                         else
 411                             HvPMROOT(pmstash) = pmop->op_pmnext;
 412                         break;
 413                     }
 414                     lastpmop = pmop;
 415                     pmop = pmop->op_pmnext;
 416                 }
 417             }
 418             PmopSTASH_free(cPMOPo);
 419         }
 420         cPMOPo->op_pmreplroot = Nullop;
 421         /* we use the "SAFE" version of the PM_ macros here
 422          * since sv_clean_all might release some PMOPs
 423          * after PL_regex_padav has been cleared
 424          * and the clearing of PL_regex_padav needs to
 425          * happen before sv_clean_all
 426          */
 427         ReREFCNT_dec(PM_GETRE_SAFE(cPMOPo));
 428         PM_SETRE_SAFE(cPMOPo, (REGEXP*)NULL);
 429 #ifdef USE_ITHREADS
 430         if(PL_regex_pad) {        /* We could be in destruction */
 431             av_push((AV*) PL_regex_pad[0],(SV*) PL_regex_pad[(cPMOPo)->op_pmoffset]);
 432             SvREPADTMP_on(PL_regex_pad[(cPMOPo)->op_pmoffset]);
 433             PM_SETRE(cPMOPo, (cPMOPo)->op_pmoffset);
 434         }
 435 #endif
 436
 437         break;
 438     }
 439
 440     if (o->op_targ > 0) {
 441         pad_free(o->op_targ);
 442         o->op_targ = 0;
 443     }
 444 }
 445
 446 STATIC void
 447 S_cop_free(pTHX_ COP* cop)
 448 {
 449     Safefree(cop->cop_label);   /* FIXME: treaddead ??? */
 450     CopFILE_free(cop);
 451     CopSTASH_free(cop);
 452     if (! specialWARN(cop->cop_warnings))
 453         SvREFCNT_dec(cop->cop_warnings);
 454     if (! specialCopIO(cop->cop_io)) {
 455 #ifdef USE_ITHREADS
 456 #if 0
 457         STRLEN len;
 458         char *s = SvPV(cop->cop_io,len);
 459         Perl_warn(aTHX_ "io='%.*s'",(int) len,s); /* ??? --jhi */
 460 #endif
 461 #else
 462         SvREFCNT_dec(cop->cop_io);
 463 #endif
 464     }
 465 }
 466
 467 void
 468 Perl_op_null(pTHX_ OP *o)
 469 {
 470     if (o->op_type == OP_NULL)
 471         return;
 472     op_clear(o);
 473     o->op_targ = o->op_type;
 474     o->op_type = OP_NULL;
 475     o->op_ppaddr = PL_ppaddr[OP_NULL];
 476 }
 477
 478 void
 479 Perl_op_refcnt_lock(pTHX)
 480 {
 481     OP_REFCNT_LOCK;
 482 }
 483
 484 void
 485 Perl_op_refcnt_unlock(pTHX)
 486 {
 487     OP_REFCNT_UNLOCK;
 488 }
 489
 490 /* Contextualizers */
 491
 492 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
 493
 494 OP *
 495 Perl_linklist(pTHX_ OP *o)
 496 {
 497
 498     if (o->op_next)
 499         return o->op_next;
 500
 501     /* establish postfix order */
 502     if (cUNOPo->op_first) {
 503         register OP *kid;
 504         o->op_next = LINKLIST(cUNOPo->op_first);
 505         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
 506             if (kid->op_sibling)
 507                 kid->op_next = LINKLIST(kid->op_sibling);
 508             else
 509                 kid->op_next = o;
 510         }
 511     }
 512     else
 513         o->op_next = o;
 514
 515     return o->op_next;
 516 }
 517
 518 OP *
 519 Perl_scalarkids(pTHX_ OP *o)
 520 {
 521     if (o && o->op_flags & OPf_KIDS) {
 522         OP *kid;
 523         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
 524             scalar(kid);
 525     }
 526     return o;
 527 }
 528
 529 STATIC OP *
 530 S_scalarboolean(pTHX_ OP *o)
 531 {
 532     if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
 533         if (ckWARN(WARN_SYNTAX)) {
 534             const line_t oldline = CopLINE(PL_curcop);
 535
 536             if (PL_copline != NOLINE)
 537                 CopLINE_set(PL_curcop, PL_copline);
 538             Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
 539             CopLINE_set(PL_curcop, oldline);
 540         }
 541     }
 542     return scalar(o);
 543 }
 544
 545 OP *
 546 Perl_scalar(pTHX_ OP *o)
 547 {
 548     OP *kid;
 549
 550     /* assumes no premature commitment */
 551     if (!o || (o->op_flags & OPf_WANT) || PL_error_count
 552          || o->op_type == OP_RETURN)
 553     {
 554         return o;
 555     }
 556
 557     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
 558
 559     switch (o->op_type) {
 560     case OP_REPEAT:
 561         scalar(cBINOPo->op_first);
 562         break;
 563     case OP_OR:
 564     case OP_AND:
 565     case OP_COND_EXPR:
 566         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
 567             scalar(kid);
 568         break;
 569     case OP_SPLIT:
 570         if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
 571             if (!kPMOP->op_pmreplroot)
 572                 deprecate_old("implicit split to @_");
 573         }
 574         /* FALL THROUGH */
 575     case OP_MATCH:
 576     case OP_QR:
 577     case OP_SUBST:
 578     case OP_NULL:
 579     default:
 580         if (o->op_flags & OPf_KIDS) {
 581             for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
 582                 scalar(kid);
 583         }
 584         break;
 585     case OP_LEAVE:
 586     case OP_LEAVETRY:
 587         kid = cLISTOPo->op_first;
 588         scalar(kid);
 589         while ((kid = kid->op_sibling)) {
 590             if (kid->op_sibling)
 591                 scalarvoid(kid);
 592             else
 593                 scalar(kid);
 594         }
 595         WITH_THR(PL_curcop = &PL_compiling);
 596         break;
 597     case OP_SCOPE:
 598     case OP_LINESEQ:
 599     case OP_LIST:
 600         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
 601             if (kid->op_sibling)
 602                 scalarvoid(kid);
 603             else
 604                 scalar(kid);
 605         }
 606         WITH_THR(PL_curcop = &PL_compiling);
 607         break;
 608     case OP_SORT:
 609         if (ckWARN(WARN_VOID))
 610             Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
 611     }
 612     return o;
 613 }
 614
 615 OP *
 616 Perl_scalarvoid(pTHX_ OP *o)
 617 {
 618     OP *kid;
 619     const char* useless = 0;
 620     SV* sv;
 621     U8 want;
 622
 623     if (o->op_type == OP_NEXTSTATE
 624         || o->op_type == OP_SETSTATE
 625         || o->op_type == OP_DBSTATE
 626         || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
 627                                       || o->op_targ == OP_SETSTATE
 628                                       || o->op_targ == OP_DBSTATE)))
 629         PL_curcop = (COP*)o;            /* for warning below */
 630
 631     /* assumes no premature commitment */
 632     want = o->op_flags & OPf_WANT;
 633     if ((want && want != OPf_WANT_SCALAR) || PL_error_count
 634          || o->op_type == OP_RETURN)
 635     {
 636         return o;
 637     }
 638
 639     if ((o->op_private & OPpTARGET_MY)
 640         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
 641     {
 642         return scalar(o);                       /* As if inside SASSIGN */
 643     }
 644
 645     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
 646
 647     switch (o->op_type) {
 648     default:
 649         if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
 650             break;
 651         /* FALL THROUGH */
 652     case OP_REPEAT:
 653         if (o->op_flags & OPf_STACKED)
 654             break;
 655         goto func_ops;
 656     case OP_SUBSTR:
 657         if (o->op_private == 4)
 658             break;
 659         /* FALL THROUGH */
 660     case OP_GVSV:
 661     case OP_WANTARRAY:
 662     case OP_GV:
 663     case OP_PADSV:
 664     case OP_PADAV:
 665     case OP_PADHV:
 666     case OP_PADANY:
 667     case OP_AV2ARYLEN:
 668     case OP_REF:
 669     case OP_REFGEN:
 670     case OP_SREFGEN:
 671     case OP_DEFINED:
 672     case OP_HEX:
 673     case OP_OCT:
 674     case OP_LENGTH:
 675     case OP_VEC:
 676     case OP_INDEX:
 677     case OP_RINDEX:
 678     case OP_SPRINTF:
 679     case OP_AELEM:
 680     case OP_AELEMFAST:
 681     case OP_ASLICE:
 682     case OP_HELEM:
 683     case OP_HSLICE:
 684     case OP_UNPACK:
 685     case OP_PACK:
 686     case OP_JOIN:
 687     case OP_LSLICE:
 688     case OP_ANONLIST:
 689     case OP_ANONHASH:
 690     case OP_SORT:
 691     case OP_REVERSE:
 692     case OP_RANGE:
 693     case OP_FLIP:
 694     case OP_FLOP:
 695     case OP_CALLER:
 696     case OP_FILENO:
 697     case OP_EOF:
 698     case OP_TELL:
 699     case OP_GETSOCKNAME:
 700     case OP_GETPEERNAME:
 701     case OP_READLINK:
 702     case OP_TELLDIR:
 703     case OP_GETPPID:
 704     case OP_GETPGRP:
 705     case OP_GETPRIORITY:
 706     case OP_TIME:
 707     case OP_TMS:
 708     case OP_LOCALTIME:
 709     case OP_GMTIME:
 710     case OP_GHBYNAME:
 711     case OP_GHBYADDR:
 712     case OP_GHOSTENT:
 713     case OP_GNBYNAME:
 714     case OP_GNBYADDR:
 715     case OP_GNETENT:
 716     case OP_GPBYNAME:
 717     case OP_GPBYNUMBER:
 718     case OP_GPROTOENT:
 719     case OP_GSBYNAME:
 720     case OP_GSBYPORT:
 721     case OP_GSERVENT:
 722     case OP_GPWNAM:
 723     case OP_GPWUID:
 724     case OP_GGRNAM:
 725     case OP_GGRGID:
 726     case OP_GETLOGIN:
 727     case OP_PROTOTYPE:
 728       func_ops:
 729         if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
 730             useless = OP_DESC(o);
 731         break;
 732
 733     case OP_NOT:
 734        kid = cUNOPo->op_first;
 735        if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
 736            kid->op_type != OP_TRANS) {
 737                 goto func_ops;
 738        }
 739        useless = "negative pattern binding (!~)";
 740        break;
 741
 742     case OP_RV2GV:
 743     case OP_RV2SV:
 744     case OP_RV2AV:
 745     case OP_RV2HV:
 746         if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
 747                 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
 748             useless = "a variable";
 749         break;
 750
 751     case OP_CONST:
 752         sv = cSVOPo_sv;
 753         if (cSVOPo->op_private & OPpCONST_STRICT)
 754             no_bareword_allowed(o);
 755         else {
 756             if (ckWARN(WARN_VOID)) {
 757                 useless = "a constant";
 758                 /* don't warn on optimised away booleans, eg
 759                  * use constant Foo, 5; Foo || print; */
 760                 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
 761                     useless = 0;
 762                 /* the constants 0 and 1 are permitted as they are
 763                    conventionally used as dummies in constructs like
 764                         1 while some_condition_with_side_effects;  */
 765                 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
 766                     useless = 0;
 767                 else if (SvPOK(sv)) {
 768                   /* perl4's way of mixing documentation and code
 769                      (before the invention of POD) was based on a
 770                      trick to mix nroff and perl code. The trick was
 771                      built upon these three nroff macros being used in
 772                      void context. The pink camel has the details in
 773                      the script wrapman near page 319. */
 774                     if (strnEQ(SvPVX(sv), "di", 2) ||
 775                         strnEQ(SvPVX(sv), "ds", 2) ||
 776                         strnEQ(SvPVX(sv), "ig", 2))
 777                             useless = 0;
 778                 }
 779             }
 780         }
 781         op_null(o);             /* don't execute or even remember it */
 782         break;
 783
 784     case OP_POSTINC:
 785         o->op_type = OP_PREINC;         /* pre-increment is faster */
 786         o->op_ppaddr = PL_ppaddr[OP_PREINC];
 787         break;
 788
 789     case OP_POSTDEC:
 790         o->op_type = OP_PREDEC;         /* pre-decrement is faster */
 791         o->op_ppaddr = PL_ppaddr[OP_PREDEC];
 792         break;
 793
 794     case OP_OR:
 795     case OP_AND:
 796     case OP_DOR:
 797     case OP_COND_EXPR:
 798         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
 799             scalarvoid(kid);
 800         break;
 801
 802     case OP_NULL:
 803         if (o->op_flags & OPf_STACKED)
 804             break;
 805         /* FALL THROUGH */
 806     case OP_NEXTSTATE:
 807     case OP_DBSTATE:
 808     case OP_ENTERTRY:
 809     case OP_ENTER:
 810         if (!(o->op_flags & OPf_KIDS))
 811             break;
 812         /* FALL THROUGH */
 813     case OP_SCOPE:
 814     case OP_LEAVE:
 815     case OP_LEAVETRY:
 816     case OP_LEAVELOOP:
 817     case OP_LINESEQ:
 818     case OP_LIST:
 819         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
 820             scalarvoid(kid);
 821         break;
 822     case OP_ENTEREVAL:
 823         scalarkids(o);
 824         break;
 825     case OP_REQUIRE:
 826         /* all requires must return a boolean value */
 827         o->op_flags &= ~OPf_WANT;
 828         /* FALL THROUGH */
 829     case OP_SCALAR:
 830         return scalar(o);
 831     case OP_SPLIT:
 832         if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
 833             if (!kPMOP->op_pmreplroot)
 834                 deprecate_old("implicit split to @_");
 835         }
 836         break;
 837     }
 838     if (useless && ckWARN(WARN_VOID))
 839         Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
 840     return o;
 841 }
 842
 843 OP *
 844 Perl_listkids(pTHX_ OP *o)
 845 {
 846     if (o && o->op_flags & OPf_KIDS) {
 847         OP *kid;
 848         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
 849             list(kid);
 850     }
 851     return o;
 852 }
 853
 854 OP *
 855 Perl_list(pTHX_ OP *o)
 856 {
 857     OP *kid;
 858
 859     /* assumes no premature commitment */
 860     if (!o || (o->op_flags & OPf_WANT) || PL_error_count
 861          || o->op_type == OP_RETURN)
 862     {
 863         return o;
 864     }
 865
 866     if ((o->op_private & OPpTARGET_MY)
 867         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
 868     {
 869         return o;                               /* As if inside SASSIGN */
 870     }
 871
 872     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
 873
 874     switch (o->op_type) {
 875     case OP_FLOP:
 876     case OP_REPEAT:
 877         list(cBINOPo->op_first);
 878         break;
 879     case OP_OR:
 880     case OP_AND:
 881     case OP_COND_EXPR:
 882         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
 883             list(kid);
 884         break;
 885     default:
 886     case OP_MATCH:
 887     case OP_QR:
 888     case OP_SUBST:
 889     case OP_NULL:
 890         if (!(o->op_flags & OPf_KIDS))
 891             break;
 892         if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
 893             list(cBINOPo->op_first);
 894             return gen_constant_list(o);
 895         }
 896     case OP_LIST:
 897         listkids(o);
 898         break;
 899     case OP_LEAVE:
 900     case OP_LEAVETRY:
 901         kid = cLISTOPo->op_first;
 902         list(kid);
 903         while ((kid = kid->op_sibling)) {
 904             if (kid->op_sibling)
 905                 scalarvoid(kid);
 906             else
 907                 list(kid);
 908         }
 909         WITH_THR(PL_curcop = &PL_compiling);
 910         break;
 911     case OP_SCOPE:
 912     case OP_LINESEQ:
 913         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
 914             if (kid->op_sibling)
 915                 scalarvoid(kid);
 916             else
 917                 list(kid);
 918         }
 919         WITH_THR(PL_curcop = &PL_compiling);
 920         break;
 921     case OP_REQUIRE:
 922         /* all requires must return a boolean value */
 923         o->op_flags &= ~OPf_WANT;
 924         return scalar(o);
 925     }
 926     return o;
 927 }
 928
 929 OP *
 930 Perl_scalarseq(pTHX_ OP *o)
 931 {
 932     if (o) {
 933         if (o->op_type == OP_LINESEQ ||
 934              o->op_type == OP_SCOPE ||
 935              o->op_type == OP_LEAVE ||
 936              o->op_type == OP_LEAVETRY)
 937         {
 938             OP *kid;
 939             for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
 940                 if (kid->op_sibling) {
 941                     scalarvoid(kid);
 942                 }
 943             }
 944             PL_curcop = &PL_compiling;
 945         }
 946         o->op_flags &= ~OPf_PARENS;
 947         if (PL_hints & HINT_BLOCK_SCOPE)
 948             o->op_flags |= OPf_PARENS;
 949     }
 950     else
 951         o = newOP(OP_STUB, 0);
 952     return o;
 953 }
 954
 955 STATIC OP *
 956 S_modkids(pTHX_ OP *o, I32 type)
 957 {
 958     if (o && o->op_flags & OPf_KIDS) {
 959         OP *kid;
 960         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
 961             mod(kid, type);
 962     }
 963     return o;
 964 }
 965
 966 /* Propagate lvalue ("modifiable") context to an op and it's children.
 967  * 'type' represents the context type, roughly based on the type of op that
 968  * would do the modifying, although local() is represented by OP_NULL.
 969  * It's responsible for detecting things that can't be modified,  flag
 970  * things that need to behave specially in an lvalue context (e.g., "$$x = 5"
 971  * might have to vivify a reference in $x), and so on.
 972  *
 973  * For example, "$a+1 = 2" would cause mod() to be called with o being
 974  * OP_ADD and type being OP_SASSIGN, and would output an error.
 975  */
 976
 977 OP *
 978 Perl_mod(pTHX_ OP *o, I32 type)
 979 {
 980     OP *kid;
 981     /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
 982     int localize = -1;
 983
 984     if (!o || PL_error_count)
 985         return o;
 986
 987     if ((o->op_private & OPpTARGET_MY)
 988         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
 989     {
 990         return o;
 991     }
 992
 993     switch (o->op_type) {
 994     case OP_UNDEF:
 995         localize = 0;
 996         PL_modcount++;
 997         return o;
 998     case OP_CONST:
 999         if (!(o->op_private & (OPpCONST_ARYBASE)))
1000             goto nomod;
1001         if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1002             PL_compiling.cop_arybase = (I32)SvIV(cSVOPx(PL_eval_start)->op_sv);
1003             PL_eval_start = 0;
1004         }
1005         else if (!type) {
1006             SAVEI32(PL_compiling.cop_arybase);
1007             PL_compiling.cop_arybase = 0;
1008         }
1009         else if (type == OP_REFGEN)
1010             goto nomod;
1011         else
1012             Perl_croak(aTHX_ "That use of $[ is unsupported");
1013         break;
1014     case OP_STUB:
1015         if (o->op_flags & OPf_PARENS)
1016             break;
1017         goto nomod;
1018     case OP_ENTERSUB:
1019         if ((type == OP_UNDEF || type == OP_REFGEN) &&
1020             !(o->op_flags & OPf_STACKED)) {
1021             o->op_type = OP_RV2CV;              /* entersub => rv2cv */
1022             o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1023             assert(cUNOPo->op_first->op_type == OP_NULL);
1024             op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1025             break;
1026         }
1027         else if (o->op_private & OPpENTERSUB_NOMOD)
1028             return o;
1029         else {                          /* lvalue subroutine call */
1030             o->op_private |= OPpLVAL_INTRO;
1031             PL_modcount = RETURN_UNLIMITED_NUMBER;
1032             if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1033                 /* Backward compatibility mode: */
1034                 o->op_private |= OPpENTERSUB_INARGS;
1035                 break;
1036             }
1037             else {                      /* Compile-time error message: */
1038                 OP *kid = cUNOPo->op_first;
1039                 CV *cv;
1040                 OP *okid;
1041
1042                 if (kid->op_type == OP_PUSHMARK)
1043                     goto skip_kids;
1044                 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1045                     Perl_croak(aTHX_
1046                                "panic: unexpected lvalue entersub "
1047                                "args: type/targ %ld:%"UVuf,
1048                                (long)kid->op_type, (UV)kid->op_targ);
1049                 kid = kLISTOP->op_first;
1050               skip_kids:
1051                 while (kid->op_sibling)
1052                     kid = kid->op_sibling;
1053                 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1054                     /* Indirect call */
1055                     if (kid->op_type == OP_METHOD_NAMED
1056                         || kid->op_type == OP_METHOD)
1057                     {
1058                         UNOP *newop;
1059
1060                         NewOp(1101, newop, 1, UNOP);
1061                         newop->op_type = OP_RV2CV;
1062                         newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1063                         newop->op_first = Nullop;
1064                         newop->op_next = (OP*)newop;
1065                         kid->op_sibling = (OP*)newop;
1066                         newop->op_private |= OPpLVAL_INTRO;
1067                         break;
1068                     }
1069
1070                     if (kid->op_type != OP_RV2CV)
1071                         Perl_croak(aTHX_
1072                                    "panic: unexpected lvalue entersub "
1073                                    "entry via type/targ %ld:%"UVuf,
1074                                    (long)kid->op_type, (UV)kid->op_targ);
1075                     kid->op_private |= OPpLVAL_INTRO;
1076                     break;      /* Postpone until runtime */
1077                 }
1078
1079                 okid = kid;
1080                 kid = kUNOP->op_first;
1081                 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1082                     kid = kUNOP->op_first;
1083                 if (kid->op_type == OP_NULL)
1084                     Perl_croak(aTHX_
1085                                "Unexpected constant lvalue entersub "
1086                                "entry via type/targ %ld:%"UVuf,
1087                                (long)kid->op_type, (UV)kid->op_targ);
1088                 if (kid->op_type != OP_GV) {
1089                     /* Restore RV2CV to check lvalueness */
1090                   restore_2cv:
1091                     if (kid->op_next && kid->op_next != kid) { /* Happens? */
1092                         okid->op_next = kid->op_next;
1093                         kid->op_next = okid;
1094                     }
1095                     else
1096                         okid->op_next = Nullop;
1097                     okid->op_type = OP_RV2CV;
1098                     okid->op_targ = 0;
1099                     okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1100                     okid->op_private |= OPpLVAL_INTRO;
1101                     break;
1102                 }
1103
1104                 cv = GvCV(kGVOP_gv);
1105                 if (!cv)
1106                     goto restore_2cv;
1107                 if (CvLVALUE(cv))
1108                     break;
1109             }
1110         }
1111         /* FALL THROUGH */
1112     default:
1113       nomod:
1114         /* grep, foreach, subcalls, refgen */
1115         if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1116             break;
1117         yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1118                      (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1119                       ? "do block"
1120                       : (o->op_type == OP_ENTERSUB
1121                         ? "non-lvalue subroutine call"
1122                         : OP_DESC(o))),
1123                      type ? PL_op_desc[type] : "local"));
1124         return o;
1125
1126     case OP_PREINC:
1127     case OP_PREDEC:
1128     case OP_POW:
1129     case OP_MULTIPLY:
1130     case OP_DIVIDE:
1131     case OP_MODULO:
1132     case OP_REPEAT:
1133     case OP_ADD:
1134     case OP_SUBTRACT:
1135     case OP_CONCAT:
1136     case OP_LEFT_SHIFT:
1137     case OP_RIGHT_SHIFT:
1138     case OP_BIT_AND:
1139     case OP_BIT_XOR:
1140     case OP_BIT_OR:
1141     case OP_I_MULTIPLY:
1142     case OP_I_DIVIDE:
1143     case OP_I_MODULO:
1144     case OP_I_ADD:
1145     case OP_I_SUBTRACT:
1146         if (!(o->op_flags & OPf_STACKED))
1147             goto nomod;
1148         PL_modcount++;
1149         break;
1150
1151     case OP_COND_EXPR:
1152         localize = 1;
1153         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1154             mod(kid, type);
1155         break;
1156
1157     case OP_RV2AV:
1158     case OP_RV2HV:
1159         if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1160            PL_modcount = RETURN_UNLIMITED_NUMBER;
1161             return o;           /* Treat \(@foo) like ordinary list. */
1162         }
1163         /* FALL THROUGH */
1164     case OP_RV2GV:
1165         if (scalar_mod_type(o, type))
1166             goto nomod;
1167         ref(cUNOPo->op_first, o->op_type);
1168         /* FALL THROUGH */
1169     case OP_ASLICE:
1170     case OP_HSLICE:
1171         if (type == OP_LEAVESUBLV)
1172             o->op_private |= OPpMAYBE_LVSUB;
1173         localize = 1;
1174         /* FALL THROUGH */
1175     case OP_AASSIGN:
1176     case OP_NEXTSTATE:
1177     case OP_DBSTATE:
1178        PL_modcount = RETURN_UNLIMITED_NUMBER;
1179         break;
1180     case OP_RV2SV:
1181         ref(cUNOPo->op_first, o->op_type);
1182         localize = 1;
1183         /* FALL THROUGH */
1184     case OP_GV:
1185     case OP_AV2ARYLEN:
1186         PL_hints |= HINT_BLOCK_SCOPE;
1187     case OP_SASSIGN:
1188     case OP_ANDASSIGN:
1189     case OP_ORASSIGN:
1190     case OP_DORASSIGN:
1191         PL_modcount++;
1192         break;
1193
1194     case OP_AELEMFAST:
1195         localize = -1;
1196         PL_modcount++;
1197         break;
1198
1199     case OP_PADAV:
1200     case OP_PADHV:
1201        PL_modcount = RETURN_UNLIMITED_NUMBER;
1202         if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1203             return o;           /* Treat \(@foo) like ordinary list. */
1204         if (scalar_mod_type(o, type))
1205             goto nomod;
1206         if (type == OP_LEAVESUBLV)
1207             o->op_private |= OPpMAYBE_LVSUB;
1208         /* FALL THROUGH */
1209     case OP_PADSV:
1210         PL_modcount++;
1211         if (!type) /* local() */
1212             Perl_croak(aTHX_ "Can't localize lexical variable %s",
1213                  PAD_COMPNAME_PV(o->op_targ));
1214         break;
1215
1216     case OP_PUSHMARK:
1217         localize = 0;
1218         break;
1219
1220     case OP_KEYS:
1221         if (type != OP_SASSIGN)
1222             goto nomod;
1223         goto lvalue_func;
1224     case OP_SUBSTR:
1225         if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1226             goto nomod;
1227         /* FALL THROUGH */
1228     case OP_POS:
1229     case OP_VEC:
1230         if (type == OP_LEAVESUBLV)
1231             o->op_private |= OPpMAYBE_LVSUB;
1232       lvalue_func:
1233         pad_free(o->op_targ);
1234         o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1235         assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1236         if (o->op_flags & OPf_KIDS)
1237             mod(cBINOPo->op_first->op_sibling, type);
1238         break;
1239
1240     case OP_AELEM:
1241     case OP_HELEM:
1242         ref(cBINOPo->op_first, o->op_type);
1243         if (type == OP_ENTERSUB &&
1244              !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1245             o->op_private |= OPpLVAL_DEFER;
1246         if (type == OP_LEAVESUBLV)
1247             o->op_private |= OPpMAYBE_LVSUB;
1248         localize = 1;
1249         PL_modcount++;
1250         break;
1251
1252     case OP_SCOPE:
1253     case OP_LEAVE:
1254     case OP_ENTER:
1255     case OP_LINESEQ:
1256         localize = 0;
1257         if (o->op_flags & OPf_KIDS)
1258             mod(cLISTOPo->op_last, type);
1259         break;
1260
1261     case OP_NULL:
1262         localize = 0;
1263         if (o->op_flags & OPf_SPECIAL)          /* do BLOCK */
1264             goto nomod;
1265         else if (!(o->op_flags & OPf_KIDS))
1266             break;
1267         if (o->op_targ != OP_LIST) {
1268             mod(cBINOPo->op_first, type);
1269             break;
1270         }
1271         /* FALL THROUGH */
1272     case OP_LIST:
1273         localize = 0;
1274         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1275             mod(kid, type);
1276         break;
1277
1278     case OP_RETURN:
1279         if (type != OP_LEAVESUBLV)
1280             goto nomod;
1281         break; /* mod()ing was handled by ck_return() */
1282     }
1283
1284     /* [20011101.069] File test operators interpret OPf_REF to mean that
1285        their argument is a filehandle; thus \stat(".") should not set
1286        it. AMS 20011102 */
1287     if (type == OP_REFGEN &&
1288         PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1289         return o;
1290
1291     if (type != OP_LEAVESUBLV)
1292         o->op_flags |= OPf_MOD;
1293
1294     if (type == OP_AASSIGN || type == OP_SASSIGN)
1295         o->op_flags |= OPf_SPECIAL|OPf_REF;
1296     else if (!type) { /* local() */
1297         switch (localize) {
1298         case 1:
1299             o->op_private |= OPpLVAL_INTRO;
1300             o->op_flags &= ~OPf_SPECIAL;
1301             PL_hints |= HINT_BLOCK_SCOPE;
1302             break;
1303         case 0:
1304             break;
1305         case -1:
1306             if (ckWARN(WARN_SYNTAX)) {
1307                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1308                     "Useless localization of %s", OP_DESC(o));
1309             }
1310         }
1311     }
1312     else if (type != OP_GREPSTART && type != OP_ENTERSUB
1313              && type != OP_LEAVESUBLV)
1314         o->op_flags |= OPf_REF;
1315     return o;
1316 }
1317
1318 STATIC bool
1319 S_scalar_mod_type(pTHX_ const OP *o, I32 type)
1320 {
1321     switch (type) {
1322     case OP_SASSIGN:
1323         if (o->op_type == OP_RV2GV)
1324             return FALSE;
1325         /* FALL THROUGH */
1326     case OP_PREINC:
1327     case OP_PREDEC:
1328     case OP_POSTINC:
1329     case OP_POSTDEC:
1330     case OP_I_PREINC:
1331     case OP_I_PREDEC:
1332     case OP_I_POSTINC:
1333     case OP_I_POSTDEC:
1334     case OP_POW:
1335     case OP_MULTIPLY:
1336     case OP_DIVIDE:
1337     case OP_MODULO:
1338     case OP_REPEAT:
1339     case OP_ADD:
1340     case OP_SUBTRACT:
1341     case OP_I_MULTIPLY:
1342     case OP_I_DIVIDE:
1343     case OP_I_MODULO:
1344     case OP_I_ADD:
1345     case OP_I_SUBTRACT:
1346     case OP_LEFT_SHIFT:
1347     case OP_RIGHT_SHIFT:
1348     case OP_BIT_AND:
1349     case OP_BIT_XOR:
1350     case OP_BIT_OR:
1351     case OP_CONCAT:
1352     case OP_SUBST:
1353     case OP_TRANS:
1354     case OP_READ:
1355     case OP_SYSREAD:
1356     case OP_RECV:
1357     case OP_ANDASSIGN:
1358     case OP_ORASSIGN:
1359         return TRUE;
1360     default:
1361         return FALSE;
1362     }
1363 }
1364
1365 STATIC bool
1366 S_is_handle_constructor(pTHX_ const OP *o, I32 argnum)
1367 {
1368     switch (o->op_type) {
1369     case OP_PIPE_OP:
1370     case OP_SOCKPAIR:
1371         if (argnum == 2)
1372             return TRUE;
1373         /* FALL THROUGH */
1374     case OP_SYSOPEN:
1375     case OP_OPEN:
1376     case OP_SELECT:             /* XXX c.f. SelectSaver.pm */
1377     case OP_SOCKET:
1378     case OP_OPEN_DIR:
1379     case OP_ACCEPT:
1380         if (argnum == 1)
1381             return TRUE;
1382         /* FALL THROUGH */
1383     default:
1384         return FALSE;
1385     }
1386 }
1387
1388 OP *
1389 Perl_refkids(pTHX_ OP *o, I32 type)
1390 {
1391     if (o && o->op_flags & OPf_KIDS) {
1392         OP *kid;
1393         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1394             ref(kid, type);
1395     }
1396     return o;
1397 }
1398
1399 OP *
1400 Perl_ref(pTHX_ OP *o, I32 type)
1401 {
1402     OP *kid;
1403
1404     if (!o || PL_error_count)
1405         return o;
1406
1407     switch (o->op_type) {
1408     case OP_ENTERSUB:
1409         if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1410             !(o->op_flags & OPf_STACKED)) {
1411             o->op_type = OP_RV2CV;             /* entersub => rv2cv */
1412             o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1413             assert(cUNOPo->op_first->op_type == OP_NULL);
1414             op_null(((LISTOP*)cUNOPo->op_first)->op_first);     /* disable pushmark */
1415             o->op_flags |= OPf_SPECIAL;
1416         }
1417         break;
1418
1419     case OP_COND_EXPR:
1420         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1421             ref(kid, type);
1422         break;
1423     case OP_RV2SV:
1424         if (type == OP_DEFINED)
1425             o->op_flags |= OPf_SPECIAL;         /* don't create GV */
1426         ref(cUNOPo->op_first, o->op_type);
1427         /* FALL THROUGH */
1428     case OP_PADSV:
1429         if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1430             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1431                               : type == OP_RV2HV ? OPpDEREF_HV
1432                               : OPpDEREF_SV);
1433             o->op_flags |= OPf_MOD;
1434         }
1435         break;
1436
1437     case OP_THREADSV:
1438         o->op_flags |= OPf_MOD;         /* XXX ??? */
1439         break;
1440
1441     case OP_RV2AV:
1442     case OP_RV2HV:
1443         o->op_flags |= OPf_REF;
1444         /* FALL THROUGH */
1445     case OP_RV2GV:
1446         if (type == OP_DEFINED)
1447             o->op_flags |= OPf_SPECIAL;         /* don't create GV */
1448         ref(cUNOPo->op_first, o->op_type);
1449         break;
1450
1451     case OP_PADAV:
1452     case OP_PADHV:
1453         o->op_flags |= OPf_REF;
1454         break;
1455
1456     case OP_SCALAR:
1457     case OP_NULL:
1458         if (!(o->op_flags & OPf_KIDS))
1459             break;
1460         ref(cBINOPo->op_first, type);
1461         break;
1462     case OP_AELEM:
1463     case OP_HELEM:
1464         ref(cBINOPo->op_first, o->op_type);
1465         if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1466             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1467                               : type == OP_RV2HV ? OPpDEREF_HV
1468                               : OPpDEREF_SV);
1469             o->op_flags |= OPf_MOD;
1470         }
1471         break;
1472
1473     case OP_SCOPE:
1474     case OP_LEAVE:
1475     case OP_ENTER:
1476     case OP_LIST:
1477         if (!(o->op_flags & OPf_KIDS))
1478             break;
1479         ref(cLISTOPo->op_last, type);
1480         break;
1481     default:
1482         break;
1483     }
1484     return scalar(o);
1485
1486 }
1487
1488 STATIC OP *
1489 S_dup_attrlist(pTHX_ OP *o)
1490 {
1491     OP *rop = Nullop;
1492
1493     /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1494      * where the first kid is OP_PUSHMARK and the remaining ones
1495      * are OP_CONST.  We need to push the OP_CONST values.
1496      */
1497     if (o->op_type == OP_CONST)
1498         rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc(cSVOPo->op_sv));
1499     else {
1500         assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1501         for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1502             if (o->op_type == OP_CONST)
1503                 rop = append_elem(OP_LIST, rop,
1504                                   newSVOP(OP_CONST, o->op_flags,
1505                                           SvREFCNT_inc(cSVOPo->op_sv)));
1506         }
1507     }
1508     return rop;
1509 }
1510
1511 STATIC void
1512 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1513 {
1514     SV *stashsv;
1515
1516     /* fake up C<use attributes $pkg,$rv,@attrs> */
1517     ENTER;              /* need to protect against side-effects of 'use' */
1518     SAVEINT(PL_expect);
1519     if (stash)
1520         stashsv = newSVpv(HvNAME(stash), 0);
1521     else
1522         stashsv = &PL_sv_no;
1523
1524 #define ATTRSMODULE "attributes"
1525 #define ATTRSMODULE_PM "attributes.pm"
1526
1527     if (for_my) {
1528         SV **svp;
1529         /* Don't force the C<use> if we don't need it. */
1530         svp = hv_fetch(GvHVn(PL_incgv), ATTRSMODULE_PM,
1531                        sizeof(ATTRSMODULE_PM)-1, 0);
1532         if (svp && *svp != &PL_sv_undef)
1533             ;           /* already in %INC */
1534         else
1535             Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1536                              newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1537                              Nullsv);
1538     }
1539     else {
1540         Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1541                          newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1542                          Nullsv,
1543                          prepend_elem(OP_LIST,
1544                                       newSVOP(OP_CONST, 0, stashsv),
1545                                       prepend_elem(OP_LIST,
1546                                                    newSVOP(OP_CONST, 0,
1547                                                            newRV(target)),
1548                                                    dup_attrlist(attrs))));
1549     }
1550     LEAVE;
1551 }
1552
1553 STATIC void
1554 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1555 {
1556     OP *pack, *imop, *arg;
1557     SV *meth, *stashsv;
1558
1559     if (!attrs)
1560         return;
1561
1562     assert(target->op_type == OP_PADSV ||
1563            target->op_type == OP_PADHV ||
1564            target->op_type == OP_PADAV);
1565
1566     /* Ensure that attributes.pm is loaded. */
1567     apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
1568
1569     /* Need package name for method call. */
1570     pack = newSVOP(OP_CONST, 0, newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1));
1571
1572     /* Build up the real arg-list. */
1573     if (stash)
1574         stashsv = newSVpv(HvNAME(stash), 0);
1575     else
1576         stashsv = &PL_sv_no;
1577     arg = newOP(OP_PADSV, 0);
1578     arg->op_targ = target->op_targ;
1579     arg = prepend_elem(OP_LIST,
1580                        newSVOP(OP_CONST, 0, stashsv),
1581                        prepend_elem(OP_LIST,
1582                                     newUNOP(OP_REFGEN, 0,
1583                                             mod(arg, OP_REFGEN)),
1584                                     dup_attrlist(attrs)));
1585
1586     /* Fake up a method call to import */
1587     meth = newSVpvn("import", 6);
1588     (void)SvUPGRADE(meth, SVt_PVIV);
1589     (void)SvIOK_on(meth);
1590     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_ const char *stashpv, CV *cv,
1620                         const 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             const 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     I32 type;
1653
1654     if (!o || PL_error_count)
1655         return o;
1656
1657     type = o->op_type;
1658     if (type == OP_LIST) {
1659         OP *kid;
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       const 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     const 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     const 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     const 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     const 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 != (unsigned)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 != (unsigned)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 != (unsigned)type)
2174         return prepend_elem(type, (OP*)first, (OP*)last);
2175
2176     if (last->op_type != (unsigned)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 == (unsigned)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 (*((const UV *)a) < (*(const UV *)b))
2346         return -1;
2347     if (*((const UV *)a) > (*(const UV *)b))
2348         return 1;
2349     if (*((const UV *)a+1) < (*(const UV *)b+1))
2350         return -1;
2351     if (*((const UV *)a+1) > (*(const 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_MAXBYTES+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) && (*p == ' ' && p[1] == '\0')) {
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     const 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         const line_t ocopline = PL_copline;
3137         COP * const ocurcop = PL_curcop;
3138         const 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 const 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         const I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3190         const 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     const 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             const 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         const OP *k1 = ((UNOP*)first)->op_first;
3531         const 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             const 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     const bool once = block && block->op_flags & OPf_SPECIAL &&
3702       (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3703     (void)debuggable;
3704
3705     if (expr) {
3706         if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3707             return block;       /* do {} while 0 does once */
3708         if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3709             || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3710             expr = newUNOP(OP_DEFINED, 0,
3711                 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3712         } else if (expr->op_flags & OPf_KIDS) {
3713             const OP *k1 = ((UNOP*)expr)->op_first;
3714             const OP *k2 = (k1) ? k1->op_sibling : NULL;
3715             switch (expr->op_type) {
3716               case OP_NULL:
3717                 if (k2 && k2->op_type == OP_READLINE
3718                       && (k2->op_flags & OPf_STACKED)
3719                       && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3720                     expr = newUNOP(OP_DEFINED, 0, expr);
3721                 break;
3722
3723               case OP_SASSIGN:
3724                 if (k1->op_type == OP_READDIR
3725                       || k1->op_type == OP_GLOB
3726                       || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3727                       || k1->op_type == OP_EACH)
3728                     expr = newUNOP(OP_DEFINED, 0, expr);
3729                 break;
3730             }
3731         }
3732     }
3733
3734     /* if block is null, the next append_elem() would put UNSTACK, a scalar
3735      * op, in listop. This is wrong. [perl #27024] */
3736     if (!block)
3737         block = newOP(OP_NULL, 0);
3738     listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3739     o = new_logop(OP_AND, 0, &expr, &listop);
3740
3741     if (listop)
3742         ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3743
3744     if (once && o != listop)
3745         o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3746
3747     if (o == listop)
3748         o = newUNOP(OP_NULL, 0, o);     /* or do {} while 1 loses outer block */
3749
3750     o->op_flags |= flags;
3751     o = scope(o);
3752     o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3753     return o;
3754 }
3755
3756 OP *
3757 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
3758 {
3759     OP *redo;
3760     OP *next = 0;
3761     OP *listop;
3762     OP *o;
3763     U8 loopflags = 0;
3764     (void)debuggable;
3765
3766     if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3767                  || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
3768         expr = newUNOP(OP_DEFINED, 0,
3769             newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3770     } else if (expr && (expr->op_flags & OPf_KIDS)) {
3771         const OP *k1 = ((UNOP*)expr)->op_first;
3772         const OP *k2 = (k1) ? k1->op_sibling : NULL;
3773         switch (expr->op_type) {
3774           case OP_NULL:
3775             if (k2 && k2->op_type == OP_READLINE
3776                   && (k2->op_flags & OPf_STACKED)
3777                   && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3778                 expr = newUNOP(OP_DEFINED, 0, expr);
3779             break;
3780
3781           case OP_SASSIGN:
3782             if (k1->op_type == OP_READDIR
3783                   || k1->op_type == OP_GLOB
3784                   || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3785                   || k1->op_type == OP_EACH)
3786                 expr = newUNOP(OP_DEFINED, 0, expr);
3787             break;
3788         }
3789     }
3790
3791     if (!block)
3792         block = newOP(OP_NULL, 0);
3793     else if (cont) {
3794         block = scope(block);
3795     }
3796
3797     if (cont) {
3798         next = LINKLIST(cont);
3799     }
3800     if (expr) {
3801         OP *unstack = newOP(OP_UNSTACK, 0);
3802         if (!next)
3803             next = unstack;
3804         cont = append_elem(OP_LINESEQ, cont, unstack);
3805     }
3806
3807     listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
3808     redo = LINKLIST(listop);
3809
3810     if (expr) {
3811         PL_copline = (line_t)whileline;
3812         scalar(listop);
3813         o = new_logop(OP_AND, 0, &expr, &listop);
3814         if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
3815             op_free(expr);              /* oops, it's a while (0) */
3816             op_free((OP*)loop);
3817             return Nullop;              /* listop already freed by new_logop */
3818         }
3819         if (listop)
3820             ((LISTOP*)listop)->op_last->op_next =
3821                 (o == listop ? redo : LINKLIST(o));
3822     }
3823     else
3824         o = listop;
3825
3826     if (!loop) {
3827         NewOp(1101,loop,1,LOOP);
3828         loop->op_type = OP_ENTERLOOP;
3829         loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
3830         loop->op_private = 0;
3831         loop->op_next = (OP*)loop;
3832     }
3833
3834     o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
3835
3836     loop->op_redoop = redo;
3837     loop->op_lastop = o;
3838     o->op_private |= loopflags;
3839
3840     if (next)
3841         loop->op_nextop = next;
3842     else
3843         loop->op_nextop = o;
3844
3845     o->op_flags |= flags;
3846     o->op_private |= (flags >> 8);
3847     return o;
3848 }
3849
3850 OP *
3851 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
3852 {
3853     LOOP *loop;
3854     OP *wop;
3855     PADOFFSET padoff = 0;
3856     I32 iterflags = 0;
3857     I32 iterpflags = 0;
3858
3859     if (sv) {
3860         if (sv->op_type == OP_RV2SV) {  /* symbol table variable */
3861             iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
3862             sv->op_type = OP_RV2GV;
3863             sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
3864         }
3865         else if (sv->op_type == OP_PADSV) { /* private variable */
3866             iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
3867             padoff = sv->op_targ;
3868             sv->op_targ = 0;
3869             op_free(sv);
3870             sv = Nullop;
3871         }
3872         else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
3873             padoff = sv->op_targ;
3874             sv->op_targ = 0;
3875             iterflags |= OPf_SPECIAL;
3876             op_free(sv);
3877             sv = Nullop;
3878         }
3879         else
3880             Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
3881     }
3882     else {
3883         const I32 offset = pad_findmy("$_");
3884         if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
3885             sv = newGVOP(OP_GV, 0, PL_defgv);
3886         }
3887         else {
3888             padoff = offset;
3889         }
3890     }
3891     if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
3892         expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
3893         iterflags |= OPf_STACKED;
3894     }
3895     else if (expr->op_type == OP_NULL &&
3896              (expr->op_flags & OPf_KIDS) &&
3897              ((BINOP*)expr)->op_first->op_type == OP_FLOP)
3898     {
3899         /* Basically turn for($x..$y) into the same as for($x,$y), but we
3900          * set the STACKED flag to indicate that these values are to be
3901          * treated as min/max values by 'pp_iterinit'.
3902          */
3903         UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
3904         LOGOP* range = (LOGOP*) flip->op_first;
3905         OP* left  = range->op_first;
3906         OP* right = left->op_sibling;
3907         LISTOP* listop;
3908
3909         range->op_flags &= ~OPf_KIDS;
3910         range->op_first = Nullop;
3911
3912         listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
3913         listop->op_first->op_next = range->op_next;
3914         left->op_next = range->op_other;
3915         right->op_next = (OP*)listop;
3916         listop->op_next = listop->op_first;
3917
3918         op_free(expr);
3919         expr = (OP*)(listop);
3920         op_null(expr);
3921         iterflags |= OPf_STACKED;
3922     }
3923     else {
3924         expr = mod(force_list(expr), OP_GREPSTART);
3925     }
3926
3927     loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
3928                                append_elem(OP_LIST, expr, scalar(sv))));
3929     assert(!loop->op_next);
3930     /* for my  $x () sets OPpLVAL_INTRO;
3931      * for our $x () sets OPpOUR_INTRO */
3932     loop->op_private = (U8)iterpflags;
3933 #ifdef PL_OP_SLAB_ALLOC
3934     {
3935         LOOP *tmp;
3936         NewOp(1234,tmp,1,LOOP);
3937         Copy(loop,tmp,1,LISTOP);
3938         FreeOp(loop);
3939         loop = tmp;
3940     }
3941 #else
3942     Renew(loop, 1, LOOP);
3943 #endif
3944     loop->op_targ = padoff;
3945     wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
3946     PL_copline = forline;
3947     return newSTATEOP(0, label, wop);
3948 }
3949
3950 OP*
3951 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
3952 {
3953     OP *o;
3954     STRLEN n_a;
3955
3956     if (type != OP_GOTO || label->op_type == OP_CONST) {
3957         /* "last()" means "last" */
3958         if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
3959             o = newOP(type, OPf_SPECIAL);
3960         else {
3961             o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
3962                                         ? SvPVx(((SVOP*)label)->op_sv, n_a)
3963                                         : ""));
3964         }
3965         op_free(label);
3966     }
3967     else {
3968         /* Check whether it's going to be a goto &function */
3969         if (label->op_type == OP_ENTERSUB
3970                 && !(label->op_flags & OPf_STACKED))
3971             label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
3972         o = newUNOP(type, OPf_STACKED, label);
3973     }
3974     PL_hints |= HINT_BLOCK_SCOPE;
3975     return o;
3976 }
3977
3978 /*
3979 =for apidoc cv_undef
3980
3981 Clear out all the active components of a CV. This can happen either
3982 by an explicit C<undef &foo>, or by the reference count going to zero.
3983 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
3984 children can still follow the full lexical scope chain.
3985
3986 =cut
3987 */
3988
3989 void
3990 Perl_cv_undef(pTHX_ CV *cv)
3991 {
3992 #ifdef USE_ITHREADS
3993     if (CvFILE(cv) && !CvXSUB(cv)) {
3994         /* for XSUBs CvFILE point directly to static memory; __FILE__ */
3995         Safefree(CvFILE(cv));
3996     }
3997     CvFILE(cv) = 0;
3998 #endif
3999
4000     if (!CvXSUB(cv) && CvROOT(cv)) {
4001         if (CvDEPTH(cv))
4002             Perl_croak(aTHX_ "Can't undef active subroutine");
4003         ENTER;
4004
4005         PAD_SAVE_SETNULLPAD();
4006
4007         op_free(CvROOT(cv));
4008         CvROOT(cv) = Nullop;
4009         LEAVE;
4010     }
4011     SvPOK_off((SV*)cv);         /* forget prototype */
4012     CvGV(cv) = Nullgv;
4013
4014     pad_undef(cv);
4015
4016     /* remove CvOUTSIDE unless this is an undef rather than a free */
4017     if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
4018         if (!CvWEAKOUTSIDE(cv))
4019             SvREFCNT_dec(CvOUTSIDE(cv));
4020         CvOUTSIDE(cv) = Nullcv;
4021     }
4022     if (CvCONST(cv)) {
4023         SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4024         CvCONST_off(cv);
4025     }
4026     if (CvXSUB(cv)) {
4027         CvXSUB(cv) = 0;
4028     }
4029     /* delete all flags except WEAKOUTSIDE */
4030     CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
4031 }
4032
4033 void
4034 Perl_cv_ckproto(pTHX_ const CV *cv, const GV *gv, const char *p)
4035 {
4036     if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4037         SV* msg = sv_newmortal();
4038         SV* name = Nullsv;
4039
4040         if (gv)
4041             gv_efullname3(name = sv_newmortal(), gv, Nullch);
4042         sv_setpv(msg, "Prototype mismatch:");
4043         if (name)
4044             Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4045         if (SvPOK(cv))
4046             Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (const SV *)cv);
4047         else
4048             Perl_sv_catpv(aTHX_ msg, ": none");
4049         sv_catpv(msg, " vs ");
4050         if (p)
4051             Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4052         else
4053             sv_catpv(msg, "none");
4054         Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, msg);
4055     }
4056 }
4057
4058 static void const_sv_xsub(pTHX_ CV* cv);
4059
4060 /*
4061
4062 =head1 Optree Manipulation Functions
4063
4064 =for apidoc cv_const_sv
4065
4066 If C<cv> is a constant sub eligible for inlining. returns the constant
4067 value returned by the sub.  Otherwise, returns NULL.
4068
4069 Constant subs can be created with C<newCONSTSUB> or as described in
4070 L<perlsub/"Constant Functions">.
4071
4072 =cut
4073 */
4074 SV *
4075 Perl_cv_const_sv(pTHX_ CV *cv)
4076 {
4077     if (!cv || !CvCONST(cv))
4078         return Nullsv;
4079     return (SV*)CvXSUBANY(cv).any_ptr;
4080 }
4081
4082 /* op_const_sv:  examine an optree to determine whether it's in-lineable.
4083  * Can be called in 3 ways:
4084  *
4085  * !cv
4086  *      look for a single OP_CONST with attached value: return the value
4087  *
4088  * cv && CvCLONE(cv) && !CvCONST(cv)
4089  *
4090  *      examine the clone prototype, and if contains only a single
4091  *      OP_CONST referencing a pad const, or a single PADSV referencing
4092  *      an outer lexical, return a non-zero value to indicate the CV is
4093  *      a candidate for "constizing" at clone time
4094  *
4095  * cv && CvCONST(cv)
4096  *
4097  *      We have just cloned an anon prototype that was marked as a const
4098  *      candidiate. Try to grab the current value, and in the case of
4099  *      PADSV, ignore it if it has multiple references. Return the value.
4100  */
4101
4102 SV *
4103 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
4104 {
4105     SV *sv = Nullsv;
4106
4107     if (!o)
4108         return Nullsv;
4109
4110     if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4111         o = cLISTOPo->op_first->op_sibling;
4112
4113     for (; o; o = o->op_next) {
4114         OPCODE type = o->op_type;
4115
4116         if (sv && o->op_next == o)
4117             return sv;
4118         if (o->op_next != o) {
4119             if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4120                 continue;
4121             if (type == OP_DBSTATE)
4122                 continue;
4123         }
4124         if (type == OP_LEAVESUB || type == OP_RETURN)
4125             break;
4126         if (sv)
4127             return Nullsv;
4128         if (type == OP_CONST && cSVOPo->op_sv)
4129             sv = cSVOPo->op_sv;
4130         else if (cv && type == OP_CONST) {
4131             sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4132             if (!sv)
4133                 return Nullsv;
4134         }
4135         else if (cv && type == OP_PADSV) {
4136             if (CvCONST(cv)) { /* newly cloned anon */
4137                 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4138                 /* the candidate should have 1 ref from this pad and 1 ref
4139                  * from the parent */
4140                 if (!sv || SvREFCNT(sv) != 2)
4141                     return Nullsv;
4142                 sv = newSVsv(sv);
4143                 SvREADONLY_on(sv);
4144                 return sv;
4145             }
4146             else {
4147                 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
4148                     sv = &PL_sv_undef; /* an arbitrary non-null value */
4149             }
4150         }
4151         else {
4152             return Nullsv;
4153         }
4154     }
4155     return sv;
4156 }
4157
4158 void
4159 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4160 {
4161     (void)floor;
4162     if (o)
4163         SAVEFREEOP(o);
4164     if (proto)
4165         SAVEFREEOP(proto);
4166     if (attrs)
4167         SAVEFREEOP(attrs);
4168     if (block)
4169         SAVEFREEOP(block);
4170     Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4171 }
4172
4173 CV *
4174 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4175 {
4176     return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4177 }
4178
4179 CV *
4180 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4181 {
4182     STRLEN n_a;
4183     const char *name;
4184     const char *aname;
4185     GV *gv;
4186     char *ps;
4187     register CV *cv=0;
4188     SV *const_sv;
4189
4190     name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4191
4192     if (proto) {
4193         assert(proto->op_type == OP_CONST);
4194         ps = SvPVx(((SVOP*)proto)->op_sv, n_a);
4195     }
4196     else
4197         ps = Nullch;
4198
4199     if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4200         SV *sv = sv_newmortal();
4201         Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
4202                        PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
4203                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4204         aname = SvPVX(sv);
4205     }
4206     else
4207         aname = Nullch;
4208     gv = name ? gv_fetchsv(cSVOPo->op_sv,
4209                            GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4210                            SVt_PVCV)
4211         : gv_fetchpv(aname ? aname
4212                      : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4213                      GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4214                      SVt_PVCV);
4215
4216     if (o)
4217         SAVEFREEOP(o);
4218     if (proto)
4219         SAVEFREEOP(proto);
4220     if (attrs)
4221         SAVEFREEOP(attrs);
4222
4223     if (SvTYPE(gv) != SVt_PVGV) {       /* Maybe prototype now, and had at
4224                                            maximum a prototype before. */
4225         if (SvTYPE(gv) > SVt_NULL) {
4226             if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4227                 && ckWARN_d(WARN_PROTOTYPE))
4228             {
4229                 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
4230             }
4231             cv_ckproto((CV*)gv, NULL, ps);
4232         }
4233         if (ps)
4234             sv_setpv((SV*)gv, ps);
4235         else
4236             sv_setiv((SV*)gv, -1);
4237         SvREFCNT_dec(PL_compcv);
4238         cv = PL_compcv = NULL;
4239         PL_sub_generation++;
4240         goto done;
4241     }
4242
4243     cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4244
4245 #ifdef GV_UNIQUE_CHECK
4246     if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4247         Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
4248     }
4249 #endif
4250
4251     if (!block || !ps || *ps || attrs)
4252         const_sv = Nullsv;
4253     else
4254         const_sv = op_const_sv(block, Nullcv);
4255
4256     if (cv) {
4257         const bool exists = CvROOT(cv) || CvXSUB(cv);
4258
4259 #ifdef GV_UNIQUE_CHECK
4260         if (exists && GvUNIQUE(gv)) {
4261             Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
4262         }
4263 #endif
4264
4265         /* if the subroutine doesn't exist and wasn't pre-declared
4266          * with a prototype, assume it will be AUTOLOADed,
4267          * skipping the prototype check
4268          */
4269         if (exists || SvPOK(cv))
4270             cv_ckproto(cv, gv, ps);
4271         /* already defined (or promised)? */
4272         if (exists || GvASSUMECV(gv)) {
4273             if (!block && !attrs) {
4274                 if (CvFLAGS(PL_compcv)) {
4275                     /* might have had built-in attrs applied */
4276                     CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4277                 }
4278                 /* just a "sub foo;" when &foo is already defined */
4279                 SAVEFREESV(PL_compcv);
4280                 goto done;
4281             }
4282             /* ahem, death to those who redefine active sort subs */
4283             if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4284                 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4285             if (block) {
4286                 if (ckWARN(WARN_REDEFINE)
4287                     || (CvCONST(cv)
4288                         && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4289                 {
4290                     const line_t oldline = CopLINE(PL_curcop);
4291                     if (PL_copline != NOLINE)
4292                         CopLINE_set(PL_curcop, PL_copline);
4293                     Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4294                         CvCONST(cv) ? "Constant subroutine %s redefined"
4295                                     : "Subroutine %s redefined", name);
4296                     CopLINE_set(PL_curcop, oldline);
4297                 }
4298                 SvREFCNT_dec(cv);
4299                 cv = Nullcv;
4300             }
4301         }
4302     }
4303     if (const_sv) {
4304         (void)SvREFCNT_inc(const_sv);
4305         if (cv) {
4306             assert(!CvROOT(cv) && !CvCONST(cv));
4307             sv_setpv((SV*)cv, "");  /* prototype is "" */
4308             CvXSUBANY(cv).any_ptr = const_sv;
4309             CvXSUB(cv) = const_sv_xsub;
4310             CvCONST_on(cv);
4311         }
4312         else {
4313             GvCV(gv) = Nullcv;
4314             cv = newCONSTSUB(NULL, name, const_sv);
4315         }
4316         op_free(block);
4317         SvREFCNT_dec(PL_compcv);
4318         PL_compcv = NULL;
4319         PL_sub_generation++;
4320         goto done;
4321     }
4322     if (attrs) {
4323         HV *stash;
4324         SV *rcv;
4325
4326         /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4327          * before we clobber PL_compcv.
4328          */
4329         if (cv && !block) {
4330             rcv = (SV*)cv;
4331             /* Might have had built-in attributes applied -- propagate them. */
4332             CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4333             if (CvGV(cv) && GvSTASH(CvGV(cv)))
4334                 stash = GvSTASH(CvGV(cv));
4335             else if (CvSTASH(cv))
4336                 stash = CvSTASH(cv);
4337             else
4338                 stash = PL_curstash;
4339         }
4340         else {
4341             /* possibly about to re-define existing subr -- ignore old cv */
4342             rcv = (SV*)PL_compcv;
4343             if (name && GvSTASH(gv))
4344                 stash = GvSTASH(gv);
4345             else
4346                 stash = PL_curstash;
4347         }
4348         apply_attrs(stash, rcv, attrs, FALSE);
4349     }
4350     if (cv) {                           /* must reuse cv if autoloaded */
4351         if (!block) {
4352             /* got here with just attrs -- work done, so bug out */
4353             SAVEFREESV(PL_compcv);
4354             goto done;
4355         }
4356         /* transfer PL_compcv to cv */
4357         cv_undef(cv);
4358         CvFLAGS(cv) = CvFLAGS(PL_compcv);
4359         if (!CvWEAKOUTSIDE(cv))
4360             SvREFCNT_dec(CvOUTSIDE(cv));
4361         CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4362         CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
4363         CvOUTSIDE(PL_compcv) = 0;
4364         CvPADLIST(cv) = CvPADLIST(PL_compcv);
4365         CvPADLIST(PL_compcv) = 0;
4366         /* inner references to PL_compcv must be fixed up ... */
4367         pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
4368         /* ... before we throw it away */
4369         SvREFCNT_dec(PL_compcv);
4370         PL_compcv = cv;
4371         if (PERLDB_INTER)/* Advice debugger on the new sub. */
4372           ++PL_sub_generation;
4373     }
4374     else {
4375         cv = PL_compcv;
4376         if (name) {
4377             GvCV(gv) = cv;
4378             GvCVGEN(gv) = 0;
4379             PL_sub_generation++;
4380         }
4381     }
4382     CvGV(cv) = gv;
4383     CvFILE_set_from_cop(cv, PL_curcop);
4384     CvSTASH(cv) = PL_curstash;
4385
4386     if (ps)
4387         sv_setpv((SV*)cv, ps);
4388
4389     if (PL_error_count) {
4390         op_free(block);
4391         block = Nullop;
4392         if (name) {
4393             const char *s = strrchr(name, ':');
4394             s = s ? s+1 : name;
4395             if (strEQ(s, "BEGIN")) {
4396                 const char not_safe[] =
4397                     "BEGIN not safe after errors--compilation aborted";
4398                 if (PL_in_eval & EVAL_KEEPERR)
4399                     Perl_croak(aTHX_ not_safe);
4400                 else {
4401                     /* force display of errors found but not reported */
4402                     sv_catpv(ERRSV, not_safe);
4403                     Perl_croak(aTHX_ "%"SVf, ERRSV);
4404                 }
4405             }
4406         }
4407     }
4408     if (!block)
4409         goto done;
4410
4411     if (CvLVALUE(cv)) {
4412         CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4413                              mod(scalarseq(block), OP_LEAVESUBLV));
4414     }
4415     else {
4416         /* This makes sub {}; work as expected.  */
4417         if (block->op_type == OP_STUB) {
4418             op_free(block);
4419             block = newSTATEOP(0, Nullch, 0);
4420         }
4421         CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4422     }
4423     CvROOT(cv)->op_private |= OPpREFCOUNTED;
4424     OpREFCNT_set(CvROOT(cv), 1);
4425     CvSTART(cv) = LINKLIST(CvROOT(cv));
4426     CvROOT(cv)->op_next = 0;
4427     CALL_PEEP(CvSTART(cv));
4428
4429     /* now that optimizer has done its work, adjust pad values */
4430
4431     pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
4432
4433     if (CvCLONE(cv)) {
4434         assert(!CvCONST(cv));
4435         if (ps && !*ps && op_const_sv(block, cv))
4436             CvCONST_on(cv);
4437     }
4438
4439     if (name || aname) {
4440         const char *s;
4441         const char *tname = (name ? name : aname);
4442
4443         if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4444             SV *sv = NEWSV(0,0);
4445             SV *tmpstr = sv_newmortal();
4446             GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4447             CV *pcv;
4448             HV *hv;
4449
4450             Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4451                            CopFILE(PL_curcop),
4452                            (long)PL_subline, (long)CopLINE(PL_curcop));
4453             gv_efullname3(tmpstr, gv, Nullch);
4454             hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
4455             hv = GvHVn(db_postponed);
4456             if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
4457                 && (pcv = GvCV(db_postponed)))
4458             {
4459                 dSP;
4460                 PUSHMARK(SP);
4461                 XPUSHs(tmpstr);
4462                 PUTBACK;
4463                 call_sv((SV*)pcv, G_DISCARD);
4464             }
4465         }
4466
4467         if ((s = strrchr(tname,':')))
4468             s++;
4469         else
4470             s = tname;
4471
4472         if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4473             goto done;
4474
4475         if (strEQ(s, "BEGIN") && !PL_error_count) {
4476             const I32 oldscope = PL_scopestack_ix;
4477             ENTER;
4478             SAVECOPFILE(&PL_compiling);
4479             SAVECOPLINE(&PL_compiling);
4480
4481             if (!PL_beginav)
4482                 PL_beginav = newAV();
4483             DEBUG_x( dump_sub(gv) );
4484             av_push(PL_beginav, (SV*)cv);
4485             GvCV(gv) = 0;               /* cv has been hijacked */
4486             call_list(oldscope, PL_beginav);
4487
4488             PL_curcop = &PL_compiling;
4489             PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4490             LEAVE;
4491         }
4492         else if (strEQ(s, "END") && !PL_error_count) {
4493             if (!PL_endav)
4494                 PL_endav = newAV();
4495             DEBUG_x( dump_sub(gv) );
4496             av_unshift(PL_endav, 1);
4497             av_store(PL_endav, 0, (SV*)cv);
4498             GvCV(gv) = 0;               /* cv has been hijacked */
4499         }
4500         else if (strEQ(s, "CHECK") && !PL_error_count) {
4501             if (!PL_checkav)
4502                 PL_checkav = newAV();
4503             DEBUG_x( dump_sub(gv) );
4504             if (PL_main_start && ckWARN(WARN_VOID))
4505                 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4506             av_unshift(PL_checkav, 1);
4507             av_store(PL_checkav, 0, (SV*)cv);
4508             GvCV(gv) = 0;               /* cv has been hijacked */
4509         }
4510         else if (strEQ(s, "INIT") && !PL_error_count) {
4511             if (!PL_initav)
4512                 PL_initav = newAV();
4513             DEBUG_x( dump_sub(gv) );
4514             if (PL_main_start && ckWARN(WARN_VOID))
4515                 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4516             av_push(PL_initav, (SV*)cv);
4517             GvCV(gv) = 0;               /* cv has been hijacked */
4518         }
4519     }
4520
4521   done:
4522     PL_copline = NOLINE;
4523     LEAVE_SCOPE(floor);
4524     return cv;
4525 }
4526
4527 /* XXX unsafe for threads if eval_owner isn't held */
4528 /*
4529 =for apidoc newCONSTSUB
4530
4531 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4532 eligible for inlining at compile-time.
4533
4534 =cut
4535 */
4536
4537 CV *
4538 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
4539 {
4540     CV* cv;
4541
4542     ENTER;
4543
4544     SAVECOPLINE(PL_curcop);
4545     CopLINE_set(PL_curcop, PL_copline);
4546
4547     SAVEHINTS();
4548     PL_hints &= ~HINT_BLOCK_SCOPE;
4549
4550     if (stash) {
4551         SAVESPTR(PL_curstash);
4552         SAVECOPSTASH(PL_curcop);
4553         PL_curstash = stash;
4554         CopSTASH_set(PL_curcop,stash);
4555     }
4556
4557     cv = newXS(name, const_sv_xsub, savepv(CopFILE(PL_curcop)));
4558     CvXSUBANY(cv).any_ptr = sv;
4559     CvCONST_on(cv);
4560     sv_setpv((SV*)cv, "");  /* prototype is "" */
4561
4562     if (stash)
4563         CopSTASH_free(PL_curcop);
4564
4565     LEAVE;
4566
4567     return cv;
4568 }
4569
4570 /*
4571 =for apidoc U||newXS
4572
4573 Used by C<xsubpp> to hook up XSUBs as Perl subs.
4574
4575 =cut
4576 */
4577
4578 CV *
4579 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
4580 {
4581     GV *gv = gv_fetchpv(name ? name :
4582                         (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4583                         GV_ADDMULTI, SVt_PVCV);
4584     register CV *cv;
4585
4586     if (!subaddr)
4587         Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
4588
4589     if ((cv = (name ? GvCV(gv) : Nullcv))) {
4590         if (GvCVGEN(gv)) {
4591             /* just a cached method */
4592             SvREFCNT_dec(cv);
4593             cv = 0;
4594         }
4595         else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4596             /* already defined (or promised) */
4597             if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
4598                             && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
4599                 const line_t oldline = CopLINE(PL_curcop);
4600                 if (PL_copline != NOLINE)
4601                     CopLINE_set(PL_curcop, PL_copline);
4602                 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4603                             CvCONST(cv) ? "Constant subroutine %s redefined"
4604                                         : "Subroutine %s redefined"
4605                             ,name);
4606                 CopLINE_set(PL_curcop, oldline);
4607             }
4608             SvREFCNT_dec(cv);
4609             cv = 0;
4610         }
4611     }
4612
4613     if (cv)                             /* must reuse cv if autoloaded */
4614         cv_undef(cv);
4615     else {
4616         cv = (CV*)NEWSV(1105,0);
4617         sv_upgrade((SV *)cv, SVt_PVCV);
4618         if (name) {
4619             GvCV(gv) = cv;
4620             GvCVGEN(gv) = 0;
4621             PL_sub_generation++;
4622         }
4623     }
4624     CvGV(cv) = gv;
4625     (void)gv_fetchfile(filename);
4626     CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
4627                                    an external constant string */
4628     CvXSUB(cv) = subaddr;
4629
4630     if (name) {
4631         const char *s = strrchr(name,':');
4632         if (s)
4633             s++;
4634         else
4635             s = name;
4636
4637         if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4638             goto done;
4639
4640         if (strEQ(s, "BEGIN")) {
4641             if (!PL_beginav)
4642                 PL_beginav = newAV();
4643             av_push(PL_beginav, (SV*)cv);
4644             GvCV(gv) = 0;               /* cv has been hijacked */
4645         }
4646         else if (strEQ(s, "END")) {
4647             if (!PL_endav)
4648                 PL_endav = newAV();
4649             av_unshift(PL_endav, 1);
4650             av_store(PL_endav, 0, (SV*)cv);
4651             GvCV(gv) = 0;               /* cv has been hijacked */
4652         }
4653         else if (strEQ(s, "CHECK")) {
4654             if (!PL_checkav)
4655                 PL_checkav = newAV();
4656             if (PL_main_start && ckWARN(WARN_VOID))
4657                 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4658             av_unshift(PL_checkav, 1);
4659             av_store(PL_checkav, 0, (SV*)cv);
4660             GvCV(gv) = 0;               /* cv has been hijacked */
4661         }
4662         else if (strEQ(s, "INIT")) {
4663             if (!PL_initav)
4664                 PL_initav = newAV();
4665             if (PL_main_start && ckWARN(WARN_VOID))
4666                 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4667             av_push(PL_initav, (SV*)cv);
4668             GvCV(gv) = 0;               /* cv has been hijacked */
4669         }
4670     }
4671     else
4672         CvANON_on(cv);
4673
4674 done:
4675     return cv;
4676 }
4677
4678 void
4679 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
4680 {
4681     register CV *cv;
4682     GV *gv;
4683
4684     if (o)
4685         gv = gv_fetchsv(cSVOPo->op_sv, TRUE, SVt_PVFM);
4686     else
4687         gv = gv_fetchpv("STDOUT", TRUE, SVt_PVFM);
4688
4689 #ifdef GV_UNIQUE_CHECK
4690     if (GvUNIQUE(gv)) {
4691         Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
4692     }
4693 #endif
4694     GvMULTI_on(gv);
4695     if ((cv = GvFORM(gv))) {
4696         if (ckWARN(WARN_REDEFINE)) {
4697             const line_t oldline = CopLINE(PL_curcop);
4698             if (PL_copline != NOLINE)
4699                 CopLINE_set(PL_curcop, PL_copline);
4700             Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4701                         o ? "Format %"SVf" redefined"
4702                         : "Format STDOUT redefined" ,cSVOPo->op_sv);
4703             CopLINE_set(PL_curcop, oldline);
4704         }
4705         SvREFCNT_dec(cv);
4706     }
4707     cv = PL_compcv;
4708     GvFORM(gv) = cv;
4709     CvGV(cv) = gv;
4710     CvFILE_set_from_cop(cv, PL_curcop);
4711
4712
4713     pad_tidy(padtidy_FORMAT);
4714     CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
4715     CvROOT(cv)->op_private |= OPpREFCOUNTED;
4716     OpREFCNT_set(CvROOT(cv), 1);
4717     CvSTART(cv) = LINKLIST(CvROOT(cv));
4718     CvROOT(cv)->op_next = 0;
4719     CALL_PEEP(CvSTART(cv));
4720     op_free(o);
4721     PL_copline = NOLINE;
4722     LEAVE_SCOPE(floor);
4723 }
4724
4725 OP *
4726 Perl_newANONLIST(pTHX_ OP *o)
4727 {
4728     return newUNOP(OP_REFGEN, 0,
4729         mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
4730 }
4731
4732 OP *
4733 Perl_newANONHASH(pTHX_ OP *o)
4734 {
4735     return newUNOP(OP_REFGEN, 0,
4736         mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
4737 }
4738
4739 OP *
4740 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
4741 {
4742     return newANONATTRSUB(floor, proto, Nullop, block);
4743 }
4744
4745 OP *
4746 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
4747 {
4748     return newUNOP(OP_REFGEN, 0,
4749         newSVOP(OP_ANONCODE, 0,
4750                 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
4751 }
4752
4753 OP *
4754 Perl_oopsAV(pTHX_ OP *o)
4755 {
4756     switch (o->op_type) {
4757     case OP_PADSV:
4758         o->op_type = OP_PADAV;
4759         o->op_ppaddr = PL_ppaddr[OP_PADAV];
4760         return ref(o, OP_RV2AV);
4761
4762     case OP_RV2SV:
4763         o->op_type = OP_RV2AV;
4764         o->op_ppaddr = PL_ppaddr[OP_RV2AV];
4765         ref(o, OP_RV2AV);
4766         break;
4767
4768     default:
4769         if (ckWARN_d(WARN_INTERNAL))
4770             Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
4771         break;
4772     }
4773     return o;
4774 }
4775
4776 OP *
4777 Perl_oopsHV(pTHX_ OP *o)
4778 {
4779     switch (o->op_type) {
4780     case OP_PADSV:
4781     case OP_PADAV:
4782         o->op_type = OP_PADHV;
4783         o->op_ppaddr = PL_ppaddr[OP_PADHV];
4784         return ref(o, OP_RV2HV);
4785
4786     case OP_RV2SV:
4787     case OP_RV2AV:
4788         o->op_type = OP_RV2HV;
4789         o->op_ppaddr = PL_ppaddr[OP_RV2HV];
4790         ref(o, OP_RV2HV);
4791         break;
4792
4793     default:
4794         if (ckWARN_d(WARN_INTERNAL))
4795             Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
4796         break;
4797     }
4798     return o;
4799 }
4800
4801 OP *
4802 Perl_newAVREF(pTHX_ OP *o)
4803 {
4804     if (o->op_type == OP_PADANY) {
4805         o->op_type = OP_PADAV;
4806         o->op_ppaddr = PL_ppaddr[OP_PADAV];
4807         return o;
4808     }
4809     else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
4810                 && ckWARN(WARN_DEPRECATED)) {
4811         Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4812                 "Using an array as a reference is deprecated");
4813     }
4814     return newUNOP(OP_RV2AV, 0, scalar(o));
4815 }
4816
4817 OP *
4818 Perl_newGVREF(pTHX_ I32 type, OP *o)
4819 {
4820     if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
4821         return newUNOP(OP_NULL, 0, o);
4822     return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
4823 }
4824
4825 OP *
4826 Perl_newHVREF(pTHX_ OP *o)
4827 {
4828     if (o->op_type == OP_PADANY) {
4829         o->op_type = OP_PADHV;
4830         o->op_ppaddr = PL_ppaddr[OP_PADHV];
4831         return o;
4832     }
4833     else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
4834                 && ckWARN(WARN_DEPRECATED)) {
4835         Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4836                 "Using a hash as a reference is deprecated");
4837     }
4838     return newUNOP(OP_RV2HV, 0, scalar(o));
4839 }
4840
4841 OP *
4842 Perl_oopsCV(pTHX_ OP *o)
4843 {
4844     Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
4845     /* STUB */
4846     (void)o;
4847 #ifndef HASATTRIBUTE
4848     /* No __attribute__, so the compiler doesn't know that croak never returns
4849      */
4850     return 0;
4851 #endif
4852 }
4853
4854 OP *
4855 Perl_newCVREF(pTHX_ I32 flags, OP *o)
4856 {
4857     return newUNOP(OP_RV2CV, flags, scalar(o));
4858 }
4859
4860 OP *
4861 Perl_newSVREF(pTHX_ OP *o)
4862 {
4863     if (o->op_type == OP_PADANY) {
4864         o->op_type = OP_PADSV;
4865         o->op_ppaddr = PL_ppaddr[OP_PADSV];
4866         return o;
4867     }
4868     else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
4869         o->op_flags |= OPpDONE_SVREF;
4870         return o;
4871     }
4872     return newUNOP(OP_RV2SV, 0, scalar(o));
4873 }
4874
4875 /* Check routines. See the comments at the top of this file for details
4876  * on when these are called */
4877
4878 OP *
4879 Perl_ck_anoncode(pTHX_ OP *o)
4880 {
4881     cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
4882     cSVOPo->op_sv = Nullsv;
4883     return o;
4884 }
4885
4886 OP *
4887 Perl_ck_bitop(pTHX_ OP *o)
4888 {
4889 #define OP_IS_NUMCOMPARE(op) \
4890         ((op) == OP_LT   || (op) == OP_I_LT || \
4891          (op) == OP_GT   || (op) == OP_I_GT || \
4892          (op) == OP_LE   || (op) == OP_I_LE || \
4893          (op) == OP_GE   || (op) == OP_I_GE || \
4894          (op) == OP_EQ   || (op) == OP_I_EQ || \
4895          (op) == OP_NE   || (op) == OP_I_NE || \
4896          (op) == OP_NCMP || (op) == OP_I_NCMP)
4897     o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4898     if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
4899             && (o->op_type == OP_BIT_OR
4900              || o->op_type == OP_BIT_AND
4901              || o->op_type == OP_BIT_XOR))
4902     {
4903         const OP * left = cBINOPo->op_first;
4904         const OP * right = left->op_sibling;
4905         if ((OP_IS_NUMCOMPARE(left->op_type) &&
4906                 (left->op_flags & OPf_PARENS) == 0) ||
4907             (OP_IS_NUMCOMPARE(right->op_type) &&
4908                 (right->op_flags & OPf_PARENS) == 0))
4909             if (ckWARN(WARN_PRECEDENCE))
4910                 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
4911                         "Possible precedence problem on bitwise %c operator",
4912                         o->op_type == OP_BIT_OR ? '|'
4913                             : o->op_type == OP_BIT_AND ? '&' : '^'
4914                         );
4915     }
4916     return o;
4917 }
4918
4919 OP *
4920 Perl_ck_concat(pTHX_ OP *o)
4921 {
4922     const OP *kid = cUNOPo->op_first;
4923     if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
4924             !(kUNOP->op_first->op_flags & OPf_MOD))
4925         o->op_flags |= OPf_STACKED;
4926     return o;
4927 }
4928
4929 OP *
4930 Perl_ck_spair(pTHX_ OP *o)
4931 {
4932     if (o->op_flags & OPf_KIDS) {
4933         OP* newop;
4934         OP* kid;
4935         const OPCODE type = o->op_type;
4936         o = modkids(ck_fun(o), type);
4937         kid = cUNOPo->op_first;
4938         newop = kUNOP->op_first->op_sibling;
4939         if (newop &&
4940             (newop->op_sibling ||
4941              !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
4942              newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
4943              newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
4944
4945             return o;
4946         }
4947         op_free(kUNOP->op_first);
4948         kUNOP->op_first = newop;
4949     }
4950     o->op_ppaddr = PL_ppaddr[++o->op_type];
4951     return ck_fun(o);
4952 }
4953
4954 OP *
4955 Perl_ck_delete(pTHX_ OP *o)
4956 {
4957     o = ck_fun(o);
4958     o->op_private = 0;
4959     if (o->op_flags & OPf_KIDS) {
4960         OP *kid = cUNOPo->op_first;
4961         switch (kid->op_type) {
4962         case OP_ASLICE:
4963             o->op_flags |= OPf_SPECIAL;
4964             /* FALL THROUGH */
4965         case OP_HSLICE:
4966             o->op_private |= OPpSLICE;
4967             break;
4968         case OP_AELEM:
4969             o->op_flags |= OPf_SPECIAL;
4970             /* FALL THROUGH */
4971         case OP_HELEM:
4972             break;
4973         default:
4974             Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
4975                   OP_DESC(o));
4976         }
4977         op_null(kid);
4978     }
4979     return o;
4980 }
4981
4982 OP *
4983 Perl_ck_die(pTHX_ OP *o)
4984 {
4985 #ifdef VMS
4986     if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
4987 #endif
4988     return ck_fun(o);
4989 }
4990
4991 OP *
4992 Perl_ck_eof(pTHX_ OP *o)
4993 {
4994     const I32 type = o->op_type;
4995
4996     if (o->op_flags & OPf_KIDS) {
4997         if (cLISTOPo->op_first->op_type == OP_STUB) {
4998             op_free(o);
4999             o = newUNOP(type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
5000         }
5001         return ck_fun(o);
5002     }
5003     return o;
5004 }
5005
5006 OP *
5007 Perl_ck_eval(pTHX_ OP *o)
5008 {
5009     PL_hints |= HINT_BLOCK_SCOPE;
5010     if (o->op_flags & OPf_KIDS) {
5011         SVOP *kid = (SVOP*)cUNOPo->op_first;
5012
5013         if (!kid) {
5014             o->op_flags &= ~OPf_KIDS;
5015             op_null(o);
5016         }
5017         else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
5018             LOGOP *enter;
5019
5020             cUNOPo->op_first = 0;
5021             op_free(o);
5022
5023             NewOp(1101, enter, 1, LOGOP);
5024             enter->op_type = OP_ENTERTRY;
5025             enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5026             enter->op_private = 0;
5027
5028             /* establish postfix order */
5029             enter->op_next = (OP*)enter;
5030
5031             o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5032             o->op_type = OP_LEAVETRY;
5033             o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5034             enter->op_other = o;
5035             return o;
5036         }
5037         else {
5038             scalar((OP*)kid);
5039             PL_cv_has_eval = 1;
5040         }
5041     }
5042     else {
5043         op_free(o);
5044         o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5045     }
5046     o->op_targ = (PADOFFSET)PL_hints;
5047     return o;
5048 }
5049
5050 OP *
5051 Perl_ck_exit(pTHX_ OP *o)
5052 {
5053 #ifdef VMS
5054     HV *table = GvHV(PL_hintgv);
5055     if (table) {
5056        SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
5057        if (svp && *svp && SvTRUE(*svp))
5058            o->op_private |= OPpEXIT_VMSISH;
5059     }
5060     if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5061 #endif
5062     return ck_fun(o);
5063 }
5064
5065 OP *
5066 Perl_ck_exec(pTHX_ OP *o)
5067 {
5068     if (o->op_flags & OPf_STACKED) {
5069         OP *kid;
5070         o = ck_fun(o);
5071         kid = cUNOPo->op_first->op_sibling;
5072         if (kid->op_type == OP_RV2GV)
5073             op_null(kid);
5074     }
5075     else
5076         o = listkids(o);
5077     return o;
5078 }
5079
5080 OP *
5081 Perl_ck_exists(pTHX_ OP *o)
5082 {
5083     o = ck_fun(o);
5084     if (o->op_flags & OPf_KIDS) {
5085         OP *kid = cUNOPo->op_first;
5086         if (kid->op_type == OP_ENTERSUB) {
5087             (void) ref(kid, o->op_type);
5088             if (kid->op_type != OP_RV2CV && !PL_error_count)
5089                 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5090                             OP_DESC(o));
5091             o->op_private |= OPpEXISTS_SUB;
5092         }
5093         else if (kid->op_type == OP_AELEM)
5094             o->op_flags |= OPf_SPECIAL;
5095         else if (kid->op_type != OP_HELEM)
5096             Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5097                         OP_DESC(o));
5098         op_null(kid);
5099     }
5100     return o;
5101 }
5102
5103 #if 0
5104 OP *
5105 Perl_ck_gvconst(pTHX_ register OP *o)
5106 {
5107     o = fold_constants(o);
5108     if (o->op_type == OP_CONST)
5109         o->op_type = OP_GV;
5110     return o;
5111 }
5112 #endif
5113
5114 OP *
5115 Perl_ck_rvconst(pTHX_ register OP *o)
5116 {
5117     SVOP *kid = (SVOP*)cUNOPo->op_first;
5118
5119     o->op_private |= (PL_hints & HINT_STRICT_REFS);
5120     if (kid->op_type == OP_CONST) {
5121         int iscv;
5122         GV *gv;
5123         SV *kidsv = kid->op_sv;
5124
5125         /* Is it a constant from cv_const_sv()? */
5126         if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5127             SV *rsv = SvRV(kidsv);
5128             int svtype = SvTYPE(rsv);
5129             const char *badtype = Nullch;
5130
5131             switch (o->op_type) {
5132             case OP_RV2SV:
5133                 if (svtype > SVt_PVMG)
5134                     badtype = "a SCALAR";
5135                 break;
5136             case OP_RV2AV:
5137                 if (svtype != SVt_PVAV)
5138                     badtype = "an ARRAY";
5139                 break;
5140             case OP_RV2HV:
5141                 if (svtype != SVt_PVHV)
5142                     badtype = "a HASH";
5143                 break;
5144             case OP_RV2CV:
5145                 if (svtype != SVt_PVCV)
5146                     badtype = "a CODE";
5147                 break;
5148             }
5149             if (badtype)
5150                 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5151             return o;
5152         }
5153         if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5154             const char *badthing = Nullch;
5155             switch (o->op_type) {
5156             case OP_RV2SV:
5157                 badthing = "a SCALAR";
5158                 break;
5159             case OP_RV2AV:
5160                 badthing = "an ARRAY";
5161                 break;
5162             case OP_RV2HV:
5163                 badthing = "a HASH";
5164                 break;
5165             }
5166             if (badthing)
5167                 Perl_croak(aTHX_
5168           "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
5169                       kidsv, badthing);
5170         }
5171         /*
5172          * This is a little tricky.  We only want to add the symbol if we
5173          * didn't add it in the lexer.  Otherwise we get duplicate strict
5174          * warnings.  But if we didn't add it in the lexer, we must at
5175          * least pretend like we wanted to add it even if it existed before,
5176          * or we get possible typo warnings.  OPpCONST_ENTERED says
5177          * whether the lexer already added THIS instance of this symbol.
5178          */
5179         iscv = (o->op_type == OP_RV2CV) * 2;
5180         do {
5181             gv = gv_fetchsv(kidsv,
5182                 iscv | !(kid->op_private & OPpCONST_ENTERED),
5183                 iscv
5184                     ? SVt_PVCV
5185                     : o->op_type == OP_RV2SV
5186                         ? SVt_PV
5187                         : o->op_type == OP_RV2AV
5188                             ? SVt_PVAV
5189                             : o->op_type == OP_RV2HV
5190                                 ? SVt_PVHV
5191                                 : SVt_PVGV);
5192         } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5193         if (gv) {
5194             kid->op_type = OP_GV;
5195             SvREFCNT_dec(kid->op_sv);
5196 #ifdef USE_ITHREADS
5197             /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5198             kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5199             SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
5200             GvIN_PAD_on(gv);
5201             PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc(gv));
5202 #else
5203             kid->op_sv = SvREFCNT_inc(gv);
5204 #endif
5205             kid->op_private = 0;
5206             kid->op_ppaddr = PL_ppaddr[OP_GV];
5207         }
5208     }
5209     return o;
5210 }
5211
5212 OP *
5213 Perl_ck_ftst(pTHX_ OP *o)
5214 {
5215     const I32 type = o->op_type;
5216
5217     if (o->op_flags & OPf_REF) {
5218         /* nothing */
5219     }
5220     else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5221         SVOP *kid = (SVOP*)cUNOPo->op_first;
5222
5223         if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5224             OP *newop = newGVOP(type, OPf_REF,
5225                 gv_fetchsv(kid->op_sv, TRUE, SVt_PVIO));
5226             op_free(o);
5227             o = newop;
5228             return o;
5229         }
5230         else {
5231           if ((PL_hints & HINT_FILETEST_ACCESS) &&
5232               OP_IS_FILETEST_ACCESS(o))
5233             o->op_private |= OPpFT_ACCESS;
5234         }
5235         if (PL_check[kid->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst)
5236                 && kid->op_type != OP_STAT && kid->op_type != OP_LSTAT)
5237             o->op_private |= OPpFT_STACKED;
5238     }
5239     else {
5240         op_free(o);
5241         if (type == OP_FTTTY)
5242             o = newGVOP(type, OPf_REF, PL_stdingv);
5243         else
5244             o = newUNOP(type, 0, newDEFSVOP());
5245     }
5246     return o;
5247 }
5248
5249 OP *
5250 Perl_ck_fun(pTHX_ OP *o)
5251 {
5252     const int type = o->op_type;
5253     register I32 oa = PL_opargs[type] >> OASHIFT;
5254
5255     if (o->op_flags & OPf_STACKED) {
5256         if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5257             oa &= ~OA_OPTIONAL;
5258         else
5259             return no_fh_allowed(o);
5260     }
5261
5262     if (o->op_flags & OPf_KIDS) {
5263         OP **tokid = &cLISTOPo->op_first;
5264         register OP *kid = cLISTOPo->op_first;
5265         OP *sibl;
5266         I32 numargs = 0;
5267
5268         if (kid->op_type == OP_PUSHMARK ||
5269             (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5270         {
5271             tokid = &kid->op_sibling;
5272             kid = kid->op_sibling;
5273         }
5274         if (!kid && PL_opargs[type] & OA_DEFGV)
5275             *tokid = kid = newDEFSVOP();
5276
5277         while (oa && kid) {
5278             numargs++;
5279             sibl = kid->op_sibling;
5280             switch (oa & 7) {
5281             case OA_SCALAR:
5282                 /* list seen where single (scalar) arg expected? */
5283                 if (numargs == 1 && !(oa >> 4)
5284                     && kid->op_type == OP_LIST && type != OP_SCALAR)
5285                 {
5286                     return too_many_arguments(o,PL_op_desc[type]);
5287                 }
5288                 scalar(kid);
5289                 break;
5290             case OA_LIST:
5291                 if (oa < 16) {
5292                     kid = 0;
5293                     continue;
5294                 }
5295                 else
5296                     list(kid);
5297                 break;
5298             case OA_AVREF:
5299                 if ((type == OP_PUSH || type == OP_UNSHIFT)
5300                     && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5301                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5302                         "Useless use of %s with no values",
5303                         PL_op_desc[type]);
5304
5305                 if (kid->op_type == OP_CONST &&
5306                     (kid->op_private & OPpCONST_BARE))
5307                 {
5308                     OP *newop = newAVREF(newGVOP(OP_GV, 0,
5309                         gv_fetchsv(((SVOP*)kid)->op_sv, TRUE, SVt_PVAV) ));
5310                     if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5311                         Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5312                             "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
5313                             ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
5314                     op_free(kid);
5315                     kid = newop;
5316                     kid->op_sibling = sibl;
5317                     *tokid = kid;
5318                 }
5319                 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5320                     bad_type(numargs, "array", PL_op_desc[type], kid);
5321                 mod(kid, type);
5322                 break;
5323             case OA_HVREF:
5324                 if (kid->op_type == OP_CONST &&
5325                     (kid->op_private & OPpCONST_BARE))
5326                 {
5327                     OP *newop = newHVREF(newGVOP(OP_GV, 0,
5328                         gv_fetchsv(((SVOP*)kid)->op_sv, TRUE, SVt_PVHV) ));
5329                     if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5330                         Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5331                             "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
5332                             ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
5333                     op_free(kid);
5334                     kid = newop;
5335                     kid->op_sibling = sibl;
5336                     *tokid = kid;
5337                 }
5338                 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5339                     bad_type(numargs, "hash", PL_op_desc[type], kid);
5340                 mod(kid, type);
5341                 break;
5342             case OA_CVREF:
5343                 {
5344                     OP *newop = newUNOP(OP_NULL, 0, kid);
5345                     kid->op_sibling = 0;
5346                     linklist(kid);
5347                     newop->op_next = newop;
5348                     kid = newop;
5349                     kid->op_sibling = sibl;
5350                     *tokid = kid;
5351                 }
5352                 break;
5353             case OA_FILEREF:
5354                 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5355                     if (kid->op_type == OP_CONST &&
5356                         (kid->op_private & OPpCONST_BARE))
5357                     {
5358                         OP *newop = newGVOP(OP_GV, 0,
5359                             gv_fetchsv(((SVOP*)kid)->op_sv, TRUE, SVt_PVIO) );
5360                         if (!(o->op_private & 1) && /* if not unop */
5361                             kid == cLISTOPo->op_last)
5362                             cLISTOPo->op_last = newop;
5363                         op_free(kid);
5364                         kid = newop;
5365                     }
5366                     else if (kid->op_type == OP_READLINE) {
5367                         /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5368                         bad_type(numargs, "HANDLE", OP_DESC(o), kid);
5369                     }
5370                     else {
5371                         I32 flags = OPf_SPECIAL;
5372                         I32 priv = 0;
5373                         PADOFFSET targ = 0;
5374
5375                         /* is this op a FH constructor? */
5376                         if (is_handle_constructor(o,numargs)) {
5377                             const char *name = Nullch;
5378                             STRLEN len = 0;
5379
5380                             flags = 0;
5381                             /* Set a flag to tell rv2gv to vivify
5382                              * need to "prove" flag does not mean something
5383                              * else already - NI-S 1999/05/07
5384                              */
5385                             priv = OPpDEREF;
5386                             if (kid->op_type == OP_PADSV) {
5387                                 name = PAD_COMPNAME_PV(kid->op_targ);
5388                                 /* SvCUR of a pad namesv can't be trusted
5389                                  * (see PL_generation), so calc its length
5390                                  * manually */
5391                                 if (name)
5392                                     len = strlen(name);
5393
5394                             }
5395                             else if (kid->op_type == OP_RV2SV
5396                                      && kUNOP->op_first->op_type == OP_GV)
5397                             {
5398                                 GV *gv = cGVOPx_gv(kUNOP->op_first);
5399                                 name = GvNAME(gv);
5400                                 len = GvNAMELEN(gv);
5401                             }
5402                             else if (kid->op_type == OP_AELEM
5403                                      || kid->op_type == OP_HELEM)
5404                             {
5405                                  OP *op;
5406
5407                                  name = 0;
5408                                  if ((op = ((BINOP*)kid)->op_first)) {
5409                                       SV *tmpstr = Nullsv;
5410                                       const char *a =
5411                                            kid->op_type == OP_AELEM ?
5412                                            "[]" : "{}";
5413                                       if (((op->op_type == OP_RV2AV) ||
5414                                            (op->op_type == OP_RV2HV)) &&
5415                                           (op = ((UNOP*)op)->op_first) &&
5416                                           (op->op_type == OP_GV)) {
5417                                            /* packagevar $a[] or $h{} */
5418                                            GV *gv = cGVOPx_gv(op);
5419                                            if (gv)
5420                                                 tmpstr =
5421                                                      Perl_newSVpvf(aTHX_
5422                                                                    "%s%c...%c",
5423                                                                    GvNAME(gv),
5424                                                                    a[0], a[1]);
5425                                       }
5426                                       else if (op->op_type == OP_PADAV
5427                                                || op->op_type == OP_PADHV) {
5428                                            /* lexicalvar $a[] or $h{} */
5429                                            const char *padname =
5430                                                 PAD_COMPNAME_PV(op->op_targ);
5431                                            if (padname)
5432                                                 tmpstr =
5433                                                      Perl_newSVpvf(aTHX_
5434                                                                    "%s%c...%c",
5435                                                                    padname + 1,
5436                                                                    a[0], a[1]);
5437
5438                                       }
5439                                       if (tmpstr) {
5440                                            name = SvPV(tmpstr, len);
5441                                            sv_2mortal(tmpstr);
5442                                       }
5443                                  }
5444                                  if (!name) {
5445                                       name = "__ANONIO__";
5446                                       len = 10;
5447                                  }
5448                                  mod(kid, type);
5449                             }
5450                             if (name) {
5451                                 SV *namesv;
5452                                 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5453                                 namesv = PAD_SVl(targ);
5454                                 (void)SvUPGRADE(namesv, SVt_PV);
5455                                 if (*name != '$')
5456                                     sv_setpvn(namesv, "$", 1);
5457                                 sv_catpvn(namesv, name, len);
5458                             }
5459                         }
5460                         kid->op_sibling = 0;
5461                         kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5462                         kid->op_targ = targ;
5463                         kid->op_private |= priv;
5464                     }
5465                     kid->op_sibling = sibl;
5466                     *tokid = kid;
5467                 }
5468                 scalar(kid);
5469                 break;
5470             case OA_SCALARREF:
5471                 mod(scalar(kid), type);
5472                 break;
5473             }
5474             oa >>= 4;
5475             tokid = &kid->op_sibling;
5476             kid = kid->op_sibling;
5477         }
5478         o->op_private |= numargs;
5479         if (kid)
5480             return too_many_arguments(o,OP_DESC(o));
5481         listkids(o);
5482     }
5483     else if (PL_opargs[type] & OA_DEFGV) {
5484         op_free(o);
5485         return newUNOP(type, 0, newDEFSVOP());
5486     }
5487
5488     if (oa) {
5489         while (oa & OA_OPTIONAL)
5490             oa >>= 4;
5491         if (oa && oa != OA_LIST)
5492             return too_few_arguments(o,OP_DESC(o));
5493     }
5494     return o;
5495 }
5496
5497 OP *
5498 Perl_ck_glob(pTHX_ OP *o)
5499 {
5500     GV *gv;
5501
5502     o = ck_fun(o);
5503     if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5504         append_elem(OP_GLOB, o, newDEFSVOP());
5505
5506     if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV))
5507           && GvCVu(gv) && GvIMPORTED_CV(gv)))
5508     {
5509         gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5510     }
5511
5512 #if !defined(PERL_EXTERNAL_GLOB)
5513     /* XXX this can be tightened up and made more failsafe. */
5514     if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
5515         GV *glob_gv;
5516         ENTER;
5517         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
5518                 newSVpvn("File::Glob", 10), Nullsv, Nullsv, Nullsv);
5519         gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5520         glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
5521         GvCV(gv) = GvCV(glob_gv);
5522         (void)SvREFCNT_inc((SV*)GvCV(gv));
5523         GvIMPORTED_CV_on(gv);
5524         LEAVE;
5525     }
5526 #endif /* PERL_EXTERNAL_GLOB */
5527
5528     if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5529         append_elem(OP_GLOB, o,
5530                     newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5531         o->op_type = OP_LIST;
5532         o->op_ppaddr = PL_ppaddr[OP_LIST];
5533         cLISTOPo->op_first->op_type = OP_PUSHMARK;
5534         cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5535         cLISTOPo->op_first->op_targ = 0;
5536         o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5537                     append_elem(OP_LIST, o,
5538                                 scalar(newUNOP(OP_RV2CV, 0,
5539                                                newGVOP(OP_GV, 0, gv)))));
5540         o = newUNOP(OP_NULL, 0, ck_subr(o));
5541         o->op_targ = OP_GLOB;           /* hint at what it used to be */
5542         return o;
5543     }
5544     gv = newGVgen("main");
5545     gv_IOadd(gv);
5546     append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5547     scalarkids(o);
5548     return o;
5549 }
5550
5551 OP *
5552 Perl_ck_grep(pTHX_ OP *o)
5553 {
5554     LOGOP *gwop;
5555     OP *kid;
5556     const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5557     I32 offset;
5558
5559     o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5560     NewOp(1101, gwop, 1, LOGOP);
5561
5562     if (o->op_flags & OPf_STACKED) {
5563         OP* k;
5564         o = ck_sort(o);
5565         kid = cLISTOPo->op_first->op_sibling;
5566         for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
5567             kid = k;
5568         }
5569         kid->op_next = (OP*)gwop;
5570         o->op_flags &= ~OPf_STACKED;
5571     }
5572     kid = cLISTOPo->op_first->op_sibling;
5573     if (type == OP_MAPWHILE)
5574         list(kid);
5575     else
5576         scalar(kid);
5577     o = ck_fun(o);
5578     if (PL_error_count)
5579         return o;
5580     kid = cLISTOPo->op_first->op_sibling;
5581     if (kid->op_type != OP_NULL)
5582         Perl_croak(aTHX_ "panic: ck_grep");
5583     kid = kUNOP->op_first;
5584
5585     gwop->op_type = type;
5586     gwop->op_ppaddr = PL_ppaddr[type];
5587     gwop->op_first = listkids(o);
5588     gwop->op_flags |= OPf_KIDS;
5589     gwop->op_other = LINKLIST(kid);
5590     kid->op_next = (OP*)gwop;
5591     offset = pad_findmy("$_");
5592     if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
5593         o->op_private = gwop->op_private = 0;
5594         gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5595     }
5596     else {
5597         o->op_private = gwop->op_private = OPpGREP_LEX;
5598         gwop->op_targ = o->op_targ = offset;
5599     }
5600
5601     kid = cLISTOPo->op_first->op_sibling;
5602     if (!kid || !kid->op_sibling)
5603         return too_few_arguments(o,OP_DESC(o));
5604     for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5605         mod(kid, OP_GREPSTART);
5606
5607     return (OP*)gwop;
5608 }
5609
5610 OP *
5611 Perl_ck_index(pTHX_ OP *o)
5612 {
5613     if (o->op_flags & OPf_KIDS) {
5614         OP *kid = cLISTOPo->op_first->op_sibling;       /* get past pushmark */
5615         if (kid)
5616             kid = kid->op_sibling;                      /* get past "big" */
5617         if (kid && kid->op_type == OP_CONST)
5618             fbm_compile(((SVOP*)kid)->op_sv, 0);
5619     }
5620     return ck_fun(o);
5621 }
5622
5623 OP *
5624 Perl_ck_lengthconst(pTHX_ OP *o)
5625 {
5626     /* XXX length optimization goes here */
5627     return ck_fun(o);
5628 }
5629
5630 OP *
5631 Perl_ck_lfun(pTHX_ OP *o)
5632 {
5633     const OPCODE type = o->op_type;
5634     return modkids(ck_fun(o), type);
5635 }
5636
5637 OP *
5638 Perl_ck_defined(pTHX_ OP *o)            /* 19990527 MJD */
5639 {
5640     if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
5641         switch (cUNOPo->op_first->op_type) {
5642         case OP_RV2AV:
5643             /* This is needed for
5644                if (defined %stash::)
5645                to work.   Do not break Tk.
5646                */
5647             break;                      /* Globals via GV can be undef */
5648         case OP_PADAV:
5649         case OP_AASSIGN:                /* Is this a good idea? */
5650             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5651                         "defined(@array) is deprecated");
5652             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5653                         "\t(Maybe you should just omit the defined()?)\n");
5654         break;
5655         case OP_RV2HV:
5656             /* This is needed for
5657                if (defined %stash::)
5658                to work.   Do not break Tk.
5659                */
5660             break;                      /* Globals via GV can be undef */
5661         case OP_PADHV:
5662             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5663                         "defined(%%hash) is deprecated");
5664             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5665                         "\t(Maybe you should just omit the defined()?)\n");
5666             break;
5667         default:
5668             /* no warning */
5669             break;
5670         }
5671     }
5672     return ck_rfun(o);
5673 }
5674
5675 OP *
5676 Perl_ck_rfun(pTHX_ OP *o)
5677 {
5678     const OPCODE type = o->op_type;
5679     return refkids(ck_fun(o), type);
5680 }
5681
5682 OP *
5683 Perl_ck_listiob(pTHX_ OP *o)
5684 {
5685     register OP *kid;
5686
5687     kid = cLISTOPo->op_first;
5688     if (!kid) {
5689         o = force_list(o);
5690         kid = cLISTOPo->op_first;
5691     }
5692     if (kid->op_type == OP_PUSHMARK)
5693         kid = kid->op_sibling;
5694     if (kid && o->op_flags & OPf_STACKED)
5695         kid = kid->op_sibling;
5696     else if (kid && !kid->op_sibling) {         /* print HANDLE; */
5697         if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
5698             o->op_flags |= OPf_STACKED; /* make it a filehandle */
5699             kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
5700             cLISTOPo->op_first->op_sibling = kid;
5701             cLISTOPo->op_last = kid;
5702             kid = kid->op_sibling;
5703         }
5704     }
5705
5706     if (!kid)
5707         append_elem(o->op_type, o, newDEFSVOP());
5708
5709     return listkids(o);
5710 }
5711
5712 OP *
5713 Perl_ck_sassign(pTHX_ OP *o)
5714 {
5715     OP *kid = cLISTOPo->op_first;
5716     /* has a disposable target? */
5717     if ((PL_opargs[kid->op_type] & OA_TARGLEX)
5718         && !(kid->op_flags & OPf_STACKED)
5719         /* Cannot steal the second time! */
5720         && !(kid->op_private & OPpTARGET_MY))
5721     {
5722         OP *kkid = kid->op_sibling;
5723
5724         /* Can just relocate the target. */
5725         if (kkid && kkid->op_type == OP_PADSV
5726             && !(kkid->op_private & OPpLVAL_INTRO))
5727         {
5728             kid->op_targ = kkid->op_targ;
5729             kkid->op_targ = 0;
5730             /* Now we do not need PADSV and SASSIGN. */
5731             kid->op_sibling = o->op_sibling;    /* NULL */
5732             cLISTOPo->op_first = NULL;
5733             op_free(o);
5734             op_free(kkid);
5735             kid->op_private |= OPpTARGET_MY;    /* Used for context settings */
5736             return kid;
5737         }
5738     }
5739     /* optimise C<my $x = undef> to C<my $x> */
5740     if (kid->op_type == OP_UNDEF) {
5741         OP *kkid = kid->op_sibling;
5742         if (kkid && kkid->op_type == OP_PADSV
5743                 && (kkid->op_private & OPpLVAL_INTRO))
5744         {
5745             cLISTOPo->op_first = NULL;
5746             kid->op_sibling = NULL;
5747             op_free(o);
5748             op_free(kid);
5749             return kkid;
5750         }
5751     }
5752     return o;
5753 }
5754
5755 OP *
5756 Perl_ck_match(pTHX_ OP *o)
5757 {
5758     if (o->op_type != OP_QR) {
5759         const I32 offset = pad_findmy("$_");
5760         if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS(offset) & SVpad_OUR)) {
5761             o->op_targ = offset;
5762             o->op_private |= OPpTARGET_MY;
5763         }
5764     }
5765     if (o->op_type == OP_MATCH || o->op_type == OP_QR)
5766         o->op_private |= OPpRUNTIME;
5767     return o;
5768 }
5769
5770 OP *
5771 Perl_ck_method(pTHX_ OP *o)
5772 {
5773     OP *kid = cUNOPo->op_first;
5774     if (kid->op_type == OP_CONST) {
5775         SV* sv = kSVOP->op_sv;
5776         if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
5777             OP *cmop;
5778             if (!SvREADONLY(sv) || !SvFAKE(sv)) {
5779                 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
5780             }
5781             else {
5782                 kSVOP->op_sv = Nullsv;
5783             }
5784             cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
5785             op_free(o);
5786             return cmop;
5787         }
5788     }
5789     return o;
5790 }
5791
5792 OP *
5793 Perl_ck_null(pTHX_ OP *o)
5794 {
5795     return o;
5796 }
5797
5798 OP *
5799 Perl_ck_open(pTHX_ OP *o)
5800 {
5801     HV *table = GvHV(PL_hintgv);
5802     if (table) {
5803         SV **svp;
5804         I32 mode;
5805         svp = hv_fetch(table, "open_IN", 7, FALSE);
5806         if (svp && *svp) {
5807             mode = mode_from_discipline(*svp);
5808             if (mode & O_BINARY)
5809                 o->op_private |= OPpOPEN_IN_RAW;
5810             else if (mode & O_TEXT)
5811                 o->op_private |= OPpOPEN_IN_CRLF;
5812         }
5813
5814         svp = hv_fetch(table, "open_OUT", 8, FALSE);
5815         if (svp && *svp) {
5816             mode = mode_from_discipline(*svp);
5817             if (mode & O_BINARY)
5818                 o->op_private |= OPpOPEN_OUT_RAW;
5819             else if (mode & O_TEXT)
5820                 o->op_private |= OPpOPEN_OUT_CRLF;
5821         }
5822     }
5823     if (o->op_type == OP_BACKTICK)
5824         return o;
5825     {
5826          /* In case of three-arg dup open remove strictness
5827           * from the last arg if it is a bareword. */
5828          OP *first = cLISTOPx(o)->op_first; /* The pushmark. */
5829          OP *last  = cLISTOPx(o)->op_last;  /* The bareword. */
5830          OP *oa;
5831          char *mode;
5832
5833          if ((last->op_type == OP_CONST) &&             /* The bareword. */
5834              (last->op_private & OPpCONST_BARE) &&
5835              (last->op_private & OPpCONST_STRICT) &&
5836              (oa = first->op_sibling) &&                /* The fh. */
5837              (oa = oa->op_sibling) &&                   /* The mode. */
5838              SvPOK(((SVOP*)oa)->op_sv) &&
5839              (mode = SvPVX(((SVOP*)oa)->op_sv)) &&
5840              mode[0] == '>' && mode[1] == '&' &&        /* A dup open. */
5841              (last == oa->op_sibling))                  /* The bareword. */
5842               last->op_private &= ~OPpCONST_STRICT;
5843     }
5844     return ck_fun(o);
5845 }
5846
5847 OP *
5848 Perl_ck_repeat(pTHX_ OP *o)
5849 {
5850     if (cBINOPo->op_first->op_flags & OPf_PARENS) {
5851         o->op_private |= OPpREPEAT_DOLIST;
5852         cBINOPo->op_first = force_list(cBINOPo->op_first);
5853     }
5854     else
5855         scalar(o);
5856     return o;
5857 }
5858
5859 OP *
5860 Perl_ck_require(pTHX_ OP *o)
5861 {
5862     GV* gv;
5863
5864     if (o->op_flags & OPf_KIDS) {       /* Shall we supply missing .pm? */
5865         SVOP *kid = (SVOP*)cUNOPo->op_first;
5866
5867         if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5868             char *s;
5869             for (s = SvPVX(kid->op_sv); *s; s++) {
5870                 if (*s == ':' && s[1] == ':') {
5871                     *s = '/';
5872                     Move(s+2, s+1, strlen(s+2)+1, char);
5873                     --SvCUR(kid->op_sv);
5874                 }
5875             }
5876             if (SvREADONLY(kid->op_sv)) {
5877                 SvREADONLY_off(kid->op_sv);
5878                 sv_catpvn(kid->op_sv, ".pm", 3);
5879                 SvREADONLY_on(kid->op_sv);
5880             }
5881             else
5882                 sv_catpvn(kid->op_sv, ".pm", 3);
5883         }
5884     }
5885
5886     /* handle override, if any */
5887     gv = gv_fetchpv("require", FALSE, SVt_PVCV);
5888     if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
5889         gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
5890
5891     if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5892         OP *kid = cUNOPo->op_first;
5893         cUNOPo->op_first = 0;
5894         op_free(o);
5895         return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
5896                                append_elem(OP_LIST, kid,
5897                                            scalar(newUNOP(OP_RV2CV, 0,
5898                                                           newGVOP(OP_GV, 0,
5899                                                                   gv))))));
5900     }
5901
5902     return ck_fun(o);
5903 }
5904
5905 OP *
5906 Perl_ck_return(pTHX_ OP *o)
5907 {
5908     if (CvLVALUE(PL_compcv)) {
5909         OP *kid;
5910         for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
5911             mod(kid, OP_LEAVESUBLV);
5912     }
5913     return o;
5914 }
5915
5916 #if 0
5917 OP *
5918 Perl_ck_retarget(pTHX_ OP *o)
5919 {
5920     Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5921     /* STUB */
5922     return o;
5923 }
5924 #endif
5925
5926 OP *
5927 Perl_ck_select(pTHX_ OP *o)
5928 {
5929     OP* kid;
5930     if (o->op_flags & OPf_KIDS) {
5931         kid = cLISTOPo->op_first->op_sibling;   /* get past pushmark */
5932         if (kid && kid->op_sibling) {
5933             o->op_type = OP_SSELECT;
5934             o->op_ppaddr = PL_ppaddr[OP_SSELECT];
5935             o = ck_fun(o);
5936             return fold_constants(o);
5937         }
5938     }
5939     o = ck_fun(o);
5940     kid = cLISTOPo->op_first->op_sibling;    /* get past pushmark */
5941     if (kid && kid->op_type == OP_RV2GV)
5942         kid->op_private &= ~HINT_STRICT_REFS;
5943     return o;
5944 }
5945
5946 OP *
5947 Perl_ck_shift(pTHX_ OP *o)
5948 {
5949     const I32 type = o->op_type;
5950
5951     if (!(o->op_flags & OPf_KIDS)) {
5952         OP *argop;
5953
5954         op_free(o);
5955         argop = newUNOP(OP_RV2AV, 0,
5956             scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
5957         return newUNOP(type, 0, scalar(argop));
5958     }
5959     return scalar(modkids(ck_fun(o), type));
5960 }
5961
5962 OP *
5963 Perl_ck_sort(pTHX_ OP *o)
5964 {
5965     OP *firstkid;
5966
5967     if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
5968         simplify_sort(o);
5969     firstkid = cLISTOPo->op_first->op_sibling;          /* get past pushmark */
5970     if (o->op_flags & OPf_STACKED) {                    /* may have been cleared */
5971         OP *k = NULL;
5972         OP *kid = cUNOPx(firstkid)->op_first;           /* get past null */
5973
5974         if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
5975             linklist(kid);
5976             if (kid->op_type == OP_SCOPE) {
5977                 k = kid->op_next;
5978                 kid->op_next = 0;
5979             }
5980             else if (kid->op_type == OP_LEAVE) {
5981                 if (o->op_type == OP_SORT) {
5982                     op_null(kid);                       /* wipe out leave */
5983                     kid->op_next = kid;
5984
5985                     for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
5986                         if (k->op_next == kid)
5987                             k->op_next = 0;
5988                         /* don't descend into loops */
5989                         else if (k->op_type == OP_ENTERLOOP
5990                                  || k->op_type == OP_ENTERITER)
5991                         {
5992                             k = cLOOPx(k)->op_lastop;
5993                         }
5994                     }
5995                 }
5996                 else
5997                     kid->op_next = 0;           /* just disconnect the leave */
5998                 k = kLISTOP->op_first;
5999             }
6000             CALL_PEEP(k);
6001
6002             kid = firstkid;
6003             if (o->op_type == OP_SORT) {
6004                 /* provide scalar context for comparison function/block */
6005                 kid = scalar(kid);
6006                 kid->op_next = kid;
6007             }
6008             else
6009                 kid->op_next = k;
6010             o->op_flags |= OPf_SPECIAL;
6011         }
6012         else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6013             op_null(firstkid);
6014
6015         firstkid = firstkid->op_sibling;
6016     }
6017
6018     /* provide list context for arguments */
6019     if (o->op_type == OP_SORT)
6020         list(firstkid);
6021
6022     return o;
6023 }
6024
6025 STATIC void
6026 S_simplify_sort(pTHX_ OP *o)
6027 {
6028     register OP *kid = cLISTOPo->op_first->op_sibling;  /* get past pushmark */
6029     OP *k;
6030     int descending;
6031     GV *gv;
6032     const char *gvname;
6033     if (!(o->op_flags & OPf_STACKED))
6034         return;
6035     GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
6036     GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
6037     kid = kUNOP->op_first;                              /* get past null */
6038     if (kid->op_type != OP_SCOPE)
6039         return;
6040     kid = kLISTOP->op_last;                             /* get past scope */
6041     switch(kid->op_type) {
6042         case OP_NCMP:
6043         case OP_I_NCMP:
6044         case OP_SCMP:
6045             break;
6046         default:
6047             return;
6048     }
6049     k = kid;                                            /* remember this node*/
6050     if (kBINOP->op_first->op_type != OP_RV2SV)
6051         return;
6052     kid = kBINOP->op_first;                             /* get past cmp */
6053     if (kUNOP->op_first->op_type != OP_GV)
6054         return;
6055     kid = kUNOP->op_first;                              /* get past rv2sv */
6056     gv = kGVOP_gv;
6057     if (GvSTASH(gv) != PL_curstash)
6058         return;
6059     gvname = GvNAME(gv);
6060     if (*gvname == 'a' && gvname[1] == '\0')
6061         descending = 0;
6062     else if (*gvname == 'b' && gvname[1] == '\0')
6063         descending = 1;
6064     else
6065         return;
6066
6067     kid = k;                                            /* back to cmp */
6068     if (kBINOP->op_last->op_type != OP_RV2SV)
6069         return;
6070     kid = kBINOP->op_last;                              /* down to 2nd arg */
6071     if (kUNOP->op_first->op_type != OP_GV)
6072         return;
6073     kid = kUNOP->op_first;                              /* get past rv2sv */
6074     gv = kGVOP_gv;
6075     if (GvSTASH(gv) != PL_curstash)
6076         return;
6077     gvname = GvNAME(gv);
6078     if ( descending
6079          ? !(*gvname == 'a' && gvname[1] == '\0')
6080          : !(*gvname == 'b' && gvname[1] == '\0'))
6081         return;
6082     o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6083     if (descending)
6084         o->op_private |= OPpSORT_DESCEND;
6085     if (k->op_type == OP_NCMP)
6086         o->op_private |= OPpSORT_NUMERIC;
6087     if (k->op_type == OP_I_NCMP)
6088         o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6089     kid = cLISTOPo->op_first->op_sibling;
6090     cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6091     op_free(kid);                                     /* then delete it */
6092 }
6093
6094 OP *
6095 Perl_ck_split(pTHX_ OP *o)
6096 {
6097     register OP *kid;
6098
6099     if (o->op_flags & OPf_STACKED)
6100         return no_fh_allowed(o);
6101
6102     kid = cLISTOPo->op_first;
6103     if (kid->op_type != OP_NULL)
6104         Perl_croak(aTHX_ "panic: ck_split");
6105     kid = kid->op_sibling;
6106     op_free(cLISTOPo->op_first);
6107     cLISTOPo->op_first = kid;
6108     if (!kid) {
6109         cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
6110         cLISTOPo->op_last = kid; /* There was only one element previously */
6111     }
6112
6113     if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6114         OP *sibl = kid->op_sibling;
6115         kid->op_sibling = 0;
6116         kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
6117         if (cLISTOPo->op_first == cLISTOPo->op_last)
6118             cLISTOPo->op_last = kid;
6119         cLISTOPo->op_first = kid;
6120         kid->op_sibling = sibl;
6121     }
6122
6123     kid->op_type = OP_PUSHRE;
6124     kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6125     scalar(kid);
6126     if (ckWARN(WARN_REGEXP) && ((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
6127       Perl_warner(aTHX_ packWARN(WARN_REGEXP),
6128                   "Use of /g modifier is meaningless in split");
6129     }
6130
6131     if (!kid->op_sibling)
6132         append_elem(OP_SPLIT, o, newDEFSVOP());
6133
6134     kid = kid->op_sibling;
6135     scalar(kid);
6136
6137     if (!kid->op_sibling)
6138         append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6139
6140     kid = kid->op_sibling;
6141     scalar(kid);
6142
6143     if (kid->op_sibling)
6144         return too_many_arguments(o,OP_DESC(o));
6145
6146     return o;
6147 }
6148
6149 OP *
6150 Perl_ck_join(pTHX_ OP *o)
6151 {
6152     if (ckWARN(WARN_SYNTAX)) {
6153         const OP *kid = cLISTOPo->op_first->op_sibling;
6154         if (kid && kid->op_type == OP_MATCH) {
6155             const REGEXP *re = PM_GETRE(kPMOP);
6156             const char *pmstr = re ? re->precomp : "STRING";
6157             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6158                         "/%s/ should probably be written as \"%s\"",
6159                         pmstr, pmstr);
6160         }
6161     }
6162     return ck_fun(o);
6163 }
6164
6165 OP *
6166 Perl_ck_subr(pTHX_ OP *o)
6167 {
6168     OP *prev = ((cUNOPo->op_first->op_sibling)
6169              ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6170     OP *o2 = prev->op_sibling;
6171     OP *cvop;
6172     char *proto = 0;
6173     CV *cv = 0;
6174     GV *namegv = 0;
6175     int optional = 0;
6176     I32 arg = 0;
6177     I32 contextclass = 0;
6178     char *e = 0;
6179     STRLEN n_a;
6180     bool delete_op = 0;
6181
6182     o->op_private |= OPpENTERSUB_HASTARG;
6183     for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6184     if (cvop->op_type == OP_RV2CV) {
6185         SVOP* tmpop;
6186         o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6187         op_null(cvop);          /* disable rv2cv */
6188         tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6189         if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6190             GV *gv = cGVOPx_gv(tmpop);
6191             cv = GvCVu(gv);
6192             if (!cv)
6193                 tmpop->op_private |= OPpEARLY_CV;
6194             else {
6195                 if (SvPOK(cv)) {
6196                     namegv = CvANON(cv) ? gv : CvGV(cv);
6197                     proto = SvPV((SV*)cv, n_a);
6198                 }
6199                 if (CvASSERTION(cv)) {
6200                     if (PL_hints & HINT_ASSERTING) {
6201                         if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
6202                             o->op_private |= OPpENTERSUB_DB;
6203                     }
6204                     else {
6205                         delete_op = 1;
6206                         if (ckWARN(WARN_ASSERTIONS) && !(PL_hints & HINT_ASSERTIONSSEEN)) {
6207                             Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
6208                                         "Impossible to activate assertion call");
6209                         }
6210                     }
6211                 }
6212             }
6213         }
6214     }
6215     else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6216         if (o2->op_type == OP_CONST)
6217             o2->op_private &= ~OPpCONST_STRICT;
6218         else if (o2->op_type == OP_LIST) {
6219             OP *o = ((UNOP*)o2)->op_first->op_sibling;
6220             if (o && o->op_type == OP_CONST)
6221                 o->op_private &= ~OPpCONST_STRICT;
6222         }
6223     }
6224     o->op_private |= (PL_hints & HINT_STRICT_REFS);
6225     if (PERLDB_SUB && PL_curstash != PL_debstash)
6226         o->op_private |= OPpENTERSUB_DB;
6227     while (o2 != cvop) {
6228         if (proto) {
6229             switch (*proto) {
6230             case '\0':
6231                 return too_many_arguments(o, gv_ename(namegv));
6232             case ';':
6233                 optional = 1;
6234                 proto++;
6235                 continue;
6236             case '$':
6237                 proto++;
6238                 arg++;
6239                 scalar(o2);
6240                 break;
6241             case '%':
6242             case '@':
6243                 list(o2);
6244                 arg++;
6245                 break;
6246             case '&':
6247                 proto++;
6248                 arg++;
6249                 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6250                     bad_type(arg,
6251                         arg == 1 ? "block or sub {}" : "sub {}",
6252                         gv_ename(namegv), o2);
6253                 break;
6254             case '*':
6255                 /* '*' allows any scalar type, including bareword */
6256                 proto++;
6257                 arg++;
6258                 if (o2->op_type == OP_RV2GV)
6259                     goto wrapref;       /* autoconvert GLOB -> GLOBref */
6260                 else if (o2->op_type == OP_CONST)
6261                     o2->op_private &= ~OPpCONST_STRICT;
6262                 else if (o2->op_type == OP_ENTERSUB) {
6263                     /* accidental subroutine, revert to bareword */
6264                     OP *gvop = ((UNOP*)o2)->op_first;
6265                     if (gvop && gvop->op_type == OP_NULL) {
6266                         gvop = ((UNOP*)gvop)->op_first;
6267                         if (gvop) {
6268                             for (; gvop->op_sibling; gvop = gvop->op_sibling)
6269                                 ;
6270                             if (gvop &&
6271                                 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6272                                 (gvop = ((UNOP*)gvop)->op_first) &&
6273                                 gvop->op_type == OP_GV)
6274                             {
6275                                 GV *gv = cGVOPx_gv(gvop);
6276                                 OP *sibling = o2->op_sibling;
6277                                 SV *n = newSVpvn("",0);
6278                                 op_free(o2);
6279                                 gv_fullname4(n, gv, "", FALSE);
6280                                 o2 = newSVOP(OP_CONST, 0, n);
6281                                 prev->op_sibling = o2;
6282                                 o2->op_sibling = sibling;
6283                             }
6284                         }
6285                     }
6286                 }
6287                 scalar(o2);
6288                 break;
6289             case '[': case ']':
6290                  goto oops;
6291                  break;
6292             case '\\':
6293                 proto++;
6294                 arg++;
6295             again:
6296                 switch (*proto++) {
6297                 case '[':
6298                      if (contextclass++ == 0) {
6299                           e = strchr(proto, ']');
6300                           if (!e || e == proto)
6301                                goto oops;
6302                      }
6303                      else
6304                           goto oops;
6305                      goto again;
6306                      break;
6307                 case ']':
6308                      if (contextclass) {
6309                          char *p = proto;
6310                          const char s = *p;
6311                          contextclass = 0;
6312                          *p = '\0';
6313                          while (*--p != '[');
6314                          bad_type(arg, Perl_form(aTHX_ "one of %s", p),
6315                                  gv_ename(namegv), o2);
6316                          *proto = s;
6317                      } else
6318                           goto oops;
6319                      break;
6320                 case '*':
6321                      if (o2->op_type == OP_RV2GV)
6322                           goto wrapref;
6323                      if (!contextclass)
6324                           bad_type(arg, "symbol", gv_ename(namegv), o2);
6325                      break;
6326                 case '&':
6327                      if (o2->op_type == OP_ENTERSUB)
6328                           goto wrapref;
6329                      if (!contextclass)
6330                           bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6331                      break;
6332                 case '$':
6333                     if (o2->op_type == OP_RV2SV ||
6334                         o2->op_type == OP_PADSV ||
6335                         o2->op_type == OP_HELEM ||
6336                         o2->op_type == OP_AELEM ||
6337                         o2->op_type == OP_THREADSV)
6338                          goto wrapref;
6339                     if (!contextclass)
6340                         bad_type(arg, "scalar", gv_ename(namegv), o2);
6341                      break;
6342                 case '@':
6343                     if (o2->op_type == OP_RV2AV ||
6344                         o2->op_type == OP_PADAV)
6345                          goto wrapref;
6346                     if (!contextclass)
6347                         bad_type(arg, "array", gv_ename(namegv), o2);
6348                     break;
6349                 case '%':
6350                     if (o2->op_type == OP_RV2HV ||
6351                         o2->op_type == OP_PADHV)
6352                          goto wrapref;
6353                     if (!contextclass)
6354                          bad_type(arg, "hash", gv_ename(namegv), o2);
6355                     break;
6356                 wrapref:
6357                     {
6358                         OP* kid = o2;
6359                         OP* sib = kid->op_sibling;
6360                         kid->op_sibling = 0;
6361                         o2 = newUNOP(OP_REFGEN, 0, kid);
6362                         o2->op_sibling = sib;
6363                         prev->op_sibling = o2;
6364                     }
6365                     if (contextclass && e) {
6366                          proto = e + 1;
6367                          contextclass = 0;
6368                     }
6369                     break;
6370                 default: goto oops;
6371                 }
6372                 if (contextclass)
6373                      goto again;
6374                 break;
6375             case ' ':
6376                 proto++;
6377                 continue;
6378             default:
6379               oops:
6380                 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
6381                            gv_ename(namegv), cv);
6382             }
6383         }
6384         else
6385             list(o2);
6386         mod(o2, OP_ENTERSUB);
6387         prev = o2;
6388         o2 = o2->op_sibling;
6389     }
6390     if (proto && !optional &&
6391           (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6392         return too_few_arguments(o, gv_ename(namegv));
6393     if(delete_op) {
6394         op_free(o);
6395         o=newSVOP(OP_CONST, 0, newSViv(0));
6396     }
6397     return o;
6398 }
6399
6400 OP *
6401 Perl_ck_svconst(pTHX_ OP *o)
6402 {
6403     SvREADONLY_on(cSVOPo->op_sv);
6404     return o;
6405 }
6406
6407 OP *
6408 Perl_ck_trunc(pTHX_ OP *o)
6409 {
6410     if (o->op_flags & OPf_KIDS) {
6411         SVOP *kid = (SVOP*)cUNOPo->op_first;
6412
6413         if (kid->op_type == OP_NULL)
6414             kid = (SVOP*)kid->op_sibling;
6415         if (kid && kid->op_type == OP_CONST &&
6416             (kid->op_private & OPpCONST_BARE))
6417         {
6418             o->op_flags |= OPf_SPECIAL;
6419             kid->op_private &= ~OPpCONST_STRICT;
6420         }
6421     }
6422     return ck_fun(o);
6423 }
6424
6425 OP *
6426 Perl_ck_unpack(pTHX_ OP *o)
6427 {
6428     OP *kid = cLISTOPo->op_first;
6429     if (kid->op_sibling) {
6430         kid = kid->op_sibling;
6431         if (!kid->op_sibling)
6432             kid->op_sibling = newDEFSVOP();
6433     }
6434     return ck_fun(o);
6435 }
6436
6437 OP *
6438 Perl_ck_substr(pTHX_ OP *o)
6439 {
6440     o = ck_fun(o);
6441     if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6442         OP *kid = cLISTOPo->op_first;
6443
6444         if (kid->op_type == OP_NULL)
6445             kid = kid->op_sibling;
6446         if (kid)
6447             kid->op_flags |= OPf_MOD;
6448
6449     }
6450     return o;
6451 }
6452
6453 /* A peephole optimizer.  We visit the ops in the order they're to execute.
6454  * See the comments at the top of this file for more details about when
6455  * peep() is called */
6456
6457 void
6458 Perl_peep(pTHX_ register OP *o)
6459 {
6460     register OP* oldop = 0;
6461
6462     if (!o || o->op_opt)
6463         return;
6464     ENTER;
6465     SAVEOP();
6466     SAVEVPTR(PL_curcop);
6467     for (; o; o = o->op_next) {
6468         if (o->op_opt)
6469             break;
6470         PL_op = o;
6471         switch (o->op_type) {
6472         case OP_SETSTATE:
6473         case OP_NEXTSTATE:
6474         case OP_DBSTATE:
6475             PL_curcop = ((COP*)o);              /* for warnings */
6476             o->op_opt = 1;
6477             break;
6478
6479         case OP_CONST:
6480             if (cSVOPo->op_private & OPpCONST_STRICT)
6481                 no_bareword_allowed(o);
6482 #ifdef USE_ITHREADS
6483         case OP_METHOD_NAMED:
6484             /* Relocate sv to the pad for thread safety.
6485              * Despite being a "constant", the SV is written to,
6486              * for reference counts, sv_upgrade() etc. */
6487             if (cSVOP->op_sv) {
6488                 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6489                 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
6490                     /* If op_sv is already a PADTMP then it is being used by
6491                      * some pad, so make a copy. */
6492                     sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
6493                     SvREADONLY_on(PAD_SVl(ix));
6494                     SvREFCNT_dec(cSVOPo->op_sv);
6495                 }
6496                 else {
6497                     SvREFCNT_dec(PAD_SVl(ix));
6498                     SvPADTMP_on(cSVOPo->op_sv);
6499                     PAD_SETSV(ix, cSVOPo->op_sv);
6500                     /* XXX I don't know how this isn't readonly already. */
6501                     SvREADONLY_on(PAD_SVl(ix));
6502                 }
6503                 cSVOPo->op_sv = Nullsv;
6504                 o->op_targ = ix;
6505             }
6506 #endif
6507             o->op_opt = 1;
6508             break;
6509
6510         case OP_CONCAT:
6511             if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6512                 if (o->op_next->op_private & OPpTARGET_MY) {
6513                     if (o->op_flags & OPf_STACKED) /* chained concats */
6514                         goto ignore_optimization;
6515                     else {
6516                         /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6517                         o->op_targ = o->op_next->op_targ;
6518                         o->op_next->op_targ = 0;
6519                         o->op_private |= OPpTARGET_MY;
6520                     }
6521                 }
6522                 op_null(o->op_next);
6523             }
6524           ignore_optimization:
6525             o->op_opt = 1;
6526             break;
6527         case OP_STUB:
6528             if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6529                 o->op_opt = 1;
6530                 break; /* Scalar stub must produce undef.  List stub is noop */
6531             }
6532             goto nothin;
6533         case OP_NULL:
6534             if (o->op_targ == OP_NEXTSTATE
6535                 || o->op_targ == OP_DBSTATE
6536                 || o->op_targ == OP_SETSTATE)
6537             {
6538                 PL_curcop = ((COP*)o);
6539             }
6540             /* XXX: We avoid setting op_seq here to prevent later calls
6541                to peep() from mistakenly concluding that optimisation
6542                has already occurred. This doesn't fix the real problem,
6543                though (See 20010220.007). AMS 20010719 */
6544             /* op_seq functionality is now replaced by op_opt */
6545             if (oldop && o->op_next) {
6546                 oldop->op_next = o->op_next;
6547                 continue;
6548             }
6549             break;
6550         case OP_SCALAR:
6551         case OP_LINESEQ:
6552         case OP_SCOPE:
6553           nothin:
6554             if (oldop && o->op_next) {
6555                 oldop->op_next = o->op_next;
6556                 continue;
6557             }
6558             o->op_opt = 1;
6559             break;
6560
6561         case OP_PADAV:
6562         case OP_GV:
6563             if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
6564                 OP* pop = (o->op_type == OP_PADAV) ?
6565                             o->op_next : o->op_next->op_next;
6566                 IV i;
6567                 if (pop && pop->op_type == OP_CONST &&
6568                     ((PL_op = pop->op_next)) &&
6569                     pop->op_next->op_type == OP_AELEM &&
6570                     !(pop->op_next->op_private &
6571                       (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6572                     (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
6573                                 <= 255 &&
6574                     i >= 0)
6575                 {
6576                     GV *gv;
6577                     if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
6578                         no_bareword_allowed(pop);
6579                     if (o->op_type == OP_GV)
6580                         op_null(o->op_next);
6581                     op_null(pop->op_next);
6582                     op_null(pop);
6583                     o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6584                     o->op_next = pop->op_next->op_next;
6585                     o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6586                     o->op_private = (U8)i;
6587                     if (o->op_type == OP_GV) {
6588                         gv = cGVOPo_gv;
6589                         GvAVn(gv);
6590                     }
6591                     else
6592                         o->op_flags |= OPf_SPECIAL;
6593                     o->op_type = OP_AELEMFAST;
6594                 }
6595                 o->op_opt = 1;
6596                 break;
6597             }
6598
6599             if (o->op_next->op_type == OP_RV2SV) {
6600                 if (!(o->op_next->op_private & OPpDEREF)) {
6601                     op_null(o->op_next);
6602                     o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6603                                                                | OPpOUR_INTRO);
6604                     o->op_next = o->op_next->op_next;
6605                     o->op_type = OP_GVSV;
6606                     o->op_ppaddr = PL_ppaddr[OP_GVSV];
6607                 }
6608             }
6609             else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6610                 GV *gv = cGVOPo_gv;
6611                 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
6612                     /* XXX could check prototype here instead of just carping */
6613                     SV *sv = sv_newmortal();
6614                     gv_efullname3(sv, gv, Nullch);
6615                     Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
6616                                 "%"SVf"() called too early to check prototype",
6617                                 sv);
6618                 }
6619             }
6620             else if (o->op_next->op_type == OP_READLINE
6621                     && o->op_next->op_next->op_type == OP_CONCAT
6622                     && (o->op_next->op_next->op_flags & OPf_STACKED))
6623             {
6624                 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
6625                 o->op_type   = OP_RCATLINE;
6626                 o->op_flags |= OPf_STACKED;
6627                 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
6628                 op_null(o->op_next->op_next);
6629                 op_null(o->op_next);
6630             }
6631
6632             o->op_opt = 1;
6633             break;
6634
6635         case OP_MAPWHILE:
6636         case OP_GREPWHILE:
6637         case OP_AND:
6638         case OP_OR:
6639         case OP_DOR:
6640         case OP_ANDASSIGN:
6641         case OP_ORASSIGN:
6642         case OP_DORASSIGN:
6643         case OP_COND_EXPR:
6644         case OP_RANGE:
6645             o->op_opt = 1;
6646             while (cLOGOP->op_other->op_type == OP_NULL)
6647                 cLOGOP->op_other = cLOGOP->op_other->op_next;
6648             peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
6649             break;
6650
6651         case OP_ENTERLOOP:
6652         case OP_ENTERITER:
6653             o->op_opt = 1;
6654             while (cLOOP->op_redoop->op_type == OP_NULL)
6655                 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6656             peep(cLOOP->op_redoop);
6657             while (cLOOP->op_nextop->op_type == OP_NULL)
6658                 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6659             peep(cLOOP->op_nextop);
6660             while (cLOOP->op_lastop->op_type == OP_NULL)
6661                 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6662             peep(cLOOP->op_lastop);
6663             break;
6664
6665         case OP_QR:
6666         case OP_MATCH:
6667         case OP_SUBST:
6668             o->op_opt = 1;
6669             while (cPMOP->op_pmreplstart &&
6670                    cPMOP->op_pmreplstart->op_type == OP_NULL)
6671                 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6672             peep(cPMOP->op_pmreplstart);
6673             break;
6674
6675         case OP_EXEC:
6676             o->op_opt = 1;
6677             if (ckWARN(WARN_SYNTAX) && o->op_next
6678                 && o->op_next->op_type == OP_NEXTSTATE) {
6679                 if (o->op_next->op_sibling &&
6680                         o->op_next->op_sibling->op_type != OP_EXIT &&
6681                         o->op_next->op_sibling->op_type != OP_WARN &&
6682                         o->op_next->op_sibling->op_type != OP_DIE) {
6683                     const line_t oldline = CopLINE(PL_curcop);
6684
6685                     CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6686                     Perl_warner(aTHX_ packWARN(WARN_EXEC),
6687                                 "Statement unlikely to be reached");
6688                     Perl_warner(aTHX_ packWARN(WARN_EXEC),
6689                                 "\t(Maybe you meant system() when you said exec()?)\n");
6690                     CopLINE_set(PL_curcop, oldline);
6691                 }
6692             }
6693             break;
6694
6695         case OP_HELEM: {
6696             UNOP *rop;
6697             SV *lexname;
6698             GV **fields;
6699             SV **svp, *sv;
6700             char *key = NULL;
6701             STRLEN keylen;
6702
6703             o->op_opt = 1;
6704
6705             if (((BINOP*)o)->op_last->op_type != OP_CONST)
6706                 break;
6707
6708             /* Make the CONST have a shared SV */
6709             svp = cSVOPx_svp(((BINOP*)o)->op_last);
6710             if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
6711                 key = SvPV(sv, keylen);
6712                 lexname = newSVpvn_share(key,
6713                                          SvUTF8(sv) ? -(I32)keylen : keylen,
6714                                          0);
6715                 SvREFCNT_dec(sv);
6716                 *svp = lexname;
6717             }
6718
6719             if ((o->op_private & (OPpLVAL_INTRO)))
6720                 break;
6721
6722             rop = (UNOP*)((BINOP*)o)->op_first;
6723             if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6724                 break;
6725             lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
6726             if (!(SvFLAGS(lexname) & SVpad_TYPED))
6727                 break;
6728             fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6729             if (!fields || !GvHV(*fields))
6730                 break;
6731             key = SvPV(*svp, keylen);
6732             if (!hv_fetch(GvHV(*fields), key,
6733                         SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
6734             {
6735                 Perl_croak(aTHX_ "No such class field \"%s\" "
6736                            "in variable %s of type %s",
6737                       key, SvPV_nolen(lexname), HvNAME(SvSTASH(lexname)));
6738             }
6739
6740             break;
6741         }
6742
6743         case OP_HSLICE: {
6744             UNOP *rop;
6745             SV *lexname;
6746             GV **fields;
6747             SV **svp;
6748             char *key;
6749             STRLEN keylen;
6750             SVOP *first_key_op, *key_op;
6751
6752             if ((o->op_private & (OPpLVAL_INTRO))
6753                 /* I bet there's always a pushmark... */
6754                 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
6755                 /* hmmm, no optimization if list contains only one key. */
6756                 break;
6757             rop = (UNOP*)((LISTOP*)o)->op_last;
6758             if (rop->op_type != OP_RV2HV)
6759                 break;
6760             if (rop->op_first->op_type == OP_PADSV)
6761                 /* @$hash{qw(keys here)} */
6762                 rop = (UNOP*)rop->op_first;
6763             else {
6764                 /* @{$hash}{qw(keys here)} */
6765                 if (rop->op_first->op_type == OP_SCOPE
6766                     && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
6767                 {
6768                     rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
6769                 }
6770                 else
6771                     break;
6772             }
6773
6774             lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
6775             if (!(SvFLAGS(lexname) & SVpad_TYPED))
6776                 break;
6777             fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6778             if (!fields || !GvHV(*fields))
6779                 break;
6780             /* Again guessing that the pushmark can be jumped over.... */
6781             first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
6782                 ->op_first->op_sibling;
6783             for (key_op = first_key_op; key_op;
6784                  key_op = (SVOP*)key_op->op_sibling) {
6785                 if (key_op->op_type != OP_CONST)
6786                     continue;
6787                 svp = cSVOPx_svp(key_op);
6788                 key = SvPV(*svp, keylen);
6789                 if (!hv_fetch(GvHV(*fields), key,
6790                             SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
6791                 {
6792                     Perl_croak(aTHX_ "No such class field \"%s\" "
6793                                "in variable %s of type %s",
6794                           key, SvPV_nolen(lexname), HvNAME(SvSTASH(lexname)));
6795                 }
6796             }
6797             break;
6798         }
6799
6800         case OP_SORT: {
6801             /* will point to RV2AV or PADAV op on LHS/RHS of assign */
6802             OP *oleft, *oright;
6803             OP *o2;
6804
6805             /* check that RHS of sort is a single plain array */
6806             oright = cUNOPo->op_first;
6807             if (!oright || oright->op_type != OP_PUSHMARK)
6808                 break;
6809
6810             /* reverse sort ... can be optimised.  */
6811             if (!cUNOPo->op_sibling) {
6812                 /* Nothing follows us on the list. */
6813                 OP *reverse = o->op_next;
6814
6815                 if (reverse->op_type == OP_REVERSE &&
6816                     (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
6817                     OP *pushmark = cUNOPx(reverse)->op_first;
6818                     if (pushmark && (pushmark->op_type == OP_PUSHMARK)
6819                         && (cUNOPx(pushmark)->op_sibling == o)) {
6820                         /* reverse -> pushmark -> sort */
6821                         o->op_private |= OPpSORT_REVERSE;
6822                         op_null(reverse);
6823                         pushmark->op_next = oright->op_next;
6824                         op_null(oright);
6825                     }
6826                 }
6827             }
6828
6829             /* make @a = sort @a act in-place */
6830
6831             o->op_opt = 1;
6832
6833             oright = cUNOPx(oright)->op_sibling;
6834             if (!oright)
6835                 break;
6836             if (oright->op_type == OP_NULL) { /* skip sort block/sub */
6837                 oright = cUNOPx(oright)->op_sibling;
6838             }
6839
6840             if (!oright ||
6841                 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
6842                 || oright->op_next != o
6843                 || (oright->op_private & OPpLVAL_INTRO)
6844             )
6845                 break;
6846
6847             /* o2 follows the chain of op_nexts through the LHS of the
6848              * assign (if any) to the aassign op itself */
6849             o2 = o->op_next;
6850             if (!o2 || o2->op_type != OP_NULL)
6851                 break;
6852             o2 = o2->op_next;
6853             if (!o2 || o2->op_type != OP_PUSHMARK)
6854                 break;
6855             o2 = o2->op_next;
6856             if (o2 && o2->op_type == OP_GV)
6857                 o2 = o2->op_next;
6858             if (!o2
6859                 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
6860                 || (o2->op_private & OPpLVAL_INTRO)
6861             )
6862                 break;
6863             oleft = o2;
6864             o2 = o2->op_next;
6865             if (!o2 || o2->op_type != OP_NULL)
6866                 break;
6867             o2 = o2->op_next;
6868             if (!o2 || o2->op_type != OP_AASSIGN
6869                     || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
6870                 break;
6871
6872             /* check that the sort is the first arg on RHS of assign */
6873
6874             o2 = cUNOPx(o2)->op_first;
6875             if (!o2 || o2->op_type != OP_NULL)
6876                 break;
6877             o2 = cUNOPx(o2)->op_first;
6878             if (!o2 || o2->op_type != OP_PUSHMARK)
6879                 break;
6880             if (o2->op_sibling != o)
6881                 break;
6882
6883             /* check the array is the same on both sides */
6884             if (oleft->op_type == OP_RV2AV) {
6885                 if (oright->op_type != OP_RV2AV
6886                     || !cUNOPx(oright)->op_first
6887                     || cUNOPx(oright)->op_first->op_type != OP_GV
6888                     ||  cGVOPx_gv(cUNOPx(oleft)->op_first) !=
6889                         cGVOPx_gv(cUNOPx(oright)->op_first)
6890                 )
6891                     break;
6892             }
6893             else if (oright->op_type != OP_PADAV
6894                 || oright->op_targ != oleft->op_targ
6895             )
6896                 break;
6897
6898             /* transfer MODishness etc from LHS arg to RHS arg */
6899             oright->op_flags = oleft->op_flags;
6900             o->op_private |= OPpSORT_INPLACE;
6901
6902             /* excise push->gv->rv2av->null->aassign */
6903             o2 = o->op_next->op_next;
6904             op_null(o2); /* PUSHMARK */
6905             o2 = o2->op_next;
6906             if (o2->op_type == OP_GV) {
6907                 op_null(o2); /* GV */
6908                 o2 = o2->op_next;
6909             }
6910             op_null(o2); /* RV2AV or PADAV */
6911             o2 = o2->op_next->op_next;
6912             op_null(o2); /* AASSIGN */
6913
6914             o->op_next = o2->op_next;
6915
6916             break;
6917         }
6918
6919         case OP_REVERSE: {
6920             OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
6921             OP *gvop = NULL;
6922             LISTOP *enter, *exlist;
6923             o->op_opt = 1;
6924
6925             enter = (LISTOP *) o->op_next;
6926             if (!enter)
6927                 break;
6928             if (enter->op_type == OP_NULL) {
6929                 enter = (LISTOP *) enter->op_next;
6930                 if (!enter)
6931                     break;
6932             }
6933             /* for $a (...) will have OP_GV then OP_RV2GV here.
6934                for (...) just has an OP_GV.  */
6935             if (enter->op_type == OP_GV) {
6936                 gvop = (OP *) enter;
6937                 enter = (LISTOP *) enter->op_next;
6938                 if (!enter)
6939                     break;
6940                 if (enter->op_type == OP_RV2GV) {
6941                   enter = (LISTOP *) enter->op_next;
6942                   if (!enter)
6943                     break;
6944                 }
6945             }
6946
6947             if (enter->op_type != OP_ENTERITER)
6948                 break;
6949
6950             iter = enter->op_next;
6951             if (!iter || iter->op_type != OP_ITER)
6952                 break;
6953
6954             expushmark = enter->op_first;
6955             if (!expushmark || expushmark->op_type != OP_NULL
6956                 || expushmark->op_targ != OP_PUSHMARK)
6957                 break;
6958
6959             exlist = (LISTOP *) expushmark->op_sibling;
6960             if (!exlist || exlist->op_type != OP_NULL
6961                 || exlist->op_targ != OP_LIST)
6962                 break;
6963
6964             if (exlist->op_last != o) {
6965                 /* Mmm. Was expecting to point back to this op.  */
6966                 break;
6967             }
6968             theirmark = exlist->op_first;
6969             if (!theirmark || theirmark->op_type != OP_PUSHMARK)
6970                 break;
6971
6972             if (theirmark->op_sibling != o) {
6973                 /* There's something between the mark and the reverse, eg
6974                    for (1, reverse (...))
6975                    so no go.  */
6976                 break;
6977             }
6978
6979             ourmark = ((LISTOP *)o)->op_first;
6980             if (!ourmark || ourmark->op_type != OP_PUSHMARK)
6981                 break;
6982
6983             ourlast = ((LISTOP *)o)->op_last;
6984             if (!ourlast || ourlast->op_next != o)
6985                 break;
6986
6987             rv2av = ourmark->op_sibling;
6988             if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
6989                 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
6990                 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
6991                 /* We're just reversing a single array.  */
6992                 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
6993                 enter->op_flags |= OPf_STACKED;
6994             }
6995
6996             /* We don't have control over who points to theirmark, so sacrifice
6997                ours.  */
6998             theirmark->op_next = ourmark->op_next;
6999             theirmark->op_flags = ourmark->op_flags;
7000             ourlast->op_next = gvop ? gvop : (OP *) enter;
7001             op_null(ourmark);
7002             op_null(o);
7003             enter->op_private |= OPpITER_REVERSED;
7004             iter->op_private |= OPpITER_REVERSED;
7005
7006             break;
7007         }
7008
7009         default:
7010             o->op_opt = 1;
7011             break;
7012         }
7013         oldop = o;
7014     }
7015     LEAVE;
7016 }
7017
7018 char*
7019 Perl_custom_op_name(pTHX_ const OP* o)
7020 {
7021     const IV index = PTR2IV(o->op_ppaddr);
7022     SV* keysv;
7023     HE* he;
7024
7025     if (!PL_custom_op_names) /* This probably shouldn't happen */
7026         return PL_op_name[OP_CUSTOM];
7027
7028     keysv = sv_2mortal(newSViv(index));
7029
7030     he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
7031     if (!he)
7032         return PL_op_name[OP_CUSTOM]; /* Don't know who you are */
7033
7034     return SvPV_nolen(HeVAL(he));
7035 }
7036
7037 char*
7038 Perl_custom_op_desc(pTHX_ const OP* o)
7039 {
7040     const IV index = PTR2IV(o->op_ppaddr);
7041     SV* keysv;
7042     HE* he;
7043
7044     if (!PL_custom_op_descs)
7045         return PL_op_desc[OP_CUSTOM];
7046
7047     keysv = sv_2mortal(newSViv(index));
7048
7049     he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
7050     if (!he)
7051         return PL_op_desc[OP_CUSTOM];
7052
7053     return SvPV_nolen(HeVAL(he));
7054 }
7055
7056 #include "XSUB.h"
7057
7058 /* Efficient sub that returns a constant scalar value. */
7059 static void
7060 const_sv_xsub(pTHX_ CV* cv)
7061 {
7062     dXSARGS;
7063     if (items != 0) {
7064 #if 0
7065         Perl_croak(aTHX_ "usage: %s::%s()",
7066                    HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
7067 #endif
7068     }
7069     EXTEND(sp, 1);
7070     ST(0) = (SV*)XSANY.any_ptr;
7071     XSRETURN(1);
7072 }