op.c

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