op.c

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