op.c

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