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