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         CvSTART(cv) = Nullop;
4066         LEAVE;
4067     }
4068     SvPOK_off((SV*)cv);         /* forget prototype */
4069     CvGV(cv) = Nullgv;
4070
4071     pad_undef(cv);
4072
4073     /* remove CvOUTSIDE unless this is an undef rather than a free */
4074     if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
4075         if (!CvWEAKOUTSIDE(cv))
4076             SvREFCNT_dec(CvOUTSIDE(cv));
4077         CvOUTSIDE(cv) = Nullcv;
4078     }
4079     if (CvCONST(cv)) {
4080         SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4081         CvCONST_off(cv);
4082     }
4083     if (CvXSUB(cv)) {
4084         CvXSUB(cv) = 0;
4085     }
4086     /* delete all flags except WEAKOUTSIDE */
4087     CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
4088 }
4089
4090 void
4091 Perl_cv_ckproto(pTHX_ const CV *cv, const GV *gv, const char *p)
4092 {
4093     if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX_const(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4094         SV* msg = sv_newmortal();
4095         SV* name = Nullsv;
4096
4097         if (gv)
4098             gv_efullname3(name = sv_newmortal(), gv, Nullch);
4099         sv_setpv(msg, "Prototype mismatch:");
4100         if (name)
4101             Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4102         if (SvPOK(cv))
4103             Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (const SV *)cv);
4104         else
4105             Perl_sv_catpv(aTHX_ msg, ": none");
4106         sv_catpv(msg, " vs ");
4107         if (p)
4108             Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4109         else
4110             sv_catpv(msg, "none");
4111         Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, msg);
4112     }
4113 }
4114
4115 static void const_sv_xsub(pTHX_ CV* cv);
4116
4117 /*
4118
4119 =head1 Optree Manipulation Functions
4120
4121 =for apidoc cv_const_sv
4122
4123 If C<cv> is a constant sub eligible for inlining. returns the constant
4124 value returned by the sub.  Otherwise, returns NULL.
4125
4126 Constant subs can be created with C<newCONSTSUB> or as described in
4127 L<perlsub/"Constant Functions">.
4128
4129 =cut
4130 */
4131 SV *
4132 Perl_cv_const_sv(pTHX_ CV *cv)
4133 {
4134     if (!cv || !CvCONST(cv))
4135         return Nullsv;
4136     return (SV*)CvXSUBANY(cv).any_ptr;
4137 }
4138
4139 /* op_const_sv:  examine an optree to determine whether it's in-lineable.
4140  * Can be called in 3 ways:
4141  *
4142  * !cv
4143  *      look for a single OP_CONST with attached value: return the value
4144  *
4145  * cv && CvCLONE(cv) && !CvCONST(cv)
4146  *
4147  *      examine the clone prototype, and if contains only a single
4148  *      OP_CONST referencing a pad const, or a single PADSV referencing
4149  *      an outer lexical, return a non-zero value to indicate the CV is
4150  *      a candidate for "constizing" at clone time
4151  *
4152  * cv && CvCONST(cv)
4153  *
4154  *      We have just cloned an anon prototype that was marked as a const
4155  *      candidiate. Try to grab the current value, and in the case of
4156  *      PADSV, ignore it if it has multiple references. Return the value.
4157  */
4158
4159 SV *
4160 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
4161 {
4162     SV *sv = Nullsv;
4163
4164     if (!o)
4165         return Nullsv;
4166
4167     if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4168         o = cLISTOPo->op_first->op_sibling;
4169
4170     for (; o; o = o->op_next) {
4171         OPCODE type = o->op_type;
4172
4173         if (sv && o->op_next == o)
4174             return sv;
4175         if (o->op_next != o) {
4176             if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4177                 continue;
4178             if (type == OP_DBSTATE)
4179                 continue;
4180         }
4181         if (type == OP_LEAVESUB || type == OP_RETURN)
4182             break;
4183         if (sv)
4184             return Nullsv;
4185         if (type == OP_CONST && cSVOPo->op_sv)
4186             sv = cSVOPo->op_sv;
4187         else if (cv && type == OP_CONST) {
4188             sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4189             if (!sv)
4190                 return Nullsv;
4191         }
4192         else if (cv && type == OP_PADSV) {
4193             if (CvCONST(cv)) { /* newly cloned anon */
4194                 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4195                 /* the candidate should have 1 ref from this pad and 1 ref
4196                  * from the parent */
4197                 if (!sv || SvREFCNT(sv) != 2)
4198                     return Nullsv;
4199                 sv = newSVsv(sv);
4200                 SvREADONLY_on(sv);
4201                 return sv;
4202             }
4203             else {
4204                 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
4205                     sv = &PL_sv_undef; /* an arbitrary non-null value */
4206             }
4207         }
4208         else {
4209             return Nullsv;
4210         }
4211     }
4212     return sv;
4213 }
4214
4215 void
4216 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4217 {
4218     (void)floor;
4219     if (o)
4220         SAVEFREEOP(o);
4221     if (proto)
4222         SAVEFREEOP(proto);
4223     if (attrs)
4224         SAVEFREEOP(attrs);
4225     if (block)
4226         SAVEFREEOP(block);
4227     Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4228 }
4229
4230 CV *
4231 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4232 {
4233     return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4234 }
4235
4236 CV *
4237 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4238 {
4239     dVAR;
4240     STRLEN n_a;
4241     const char *aname;
4242     GV *gv;
4243     char *ps;
4244     STRLEN ps_len;
4245     register CV *cv=0;
4246     SV *const_sv;
4247
4248     const char * const name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4249
4250     if (proto) {
4251         assert(proto->op_type == OP_CONST);
4252         ps = SvPVx(((SVOP*)proto)->op_sv, ps_len);
4253     }
4254     else
4255         ps = Nullch;
4256
4257     if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4258         SV *sv = sv_newmortal();
4259         Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
4260                        PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
4261                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4262         aname = SvPVX_const(sv);
4263     }
4264     else
4265         aname = Nullch;
4266     gv = name ? gv_fetchsv(cSVOPo->op_sv,
4267                            GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4268                            SVt_PVCV)
4269         : gv_fetchpv(aname ? aname
4270                      : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4271                      GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4272                      SVt_PVCV);
4273
4274     if (o)
4275         SAVEFREEOP(o);
4276     if (proto)
4277         SAVEFREEOP(proto);
4278     if (attrs)
4279         SAVEFREEOP(attrs);
4280
4281     if (SvTYPE(gv) != SVt_PVGV) {       /* Maybe prototype now, and had at
4282                                            maximum a prototype before. */
4283         if (SvTYPE(gv) > SVt_NULL) {
4284             if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4285                 && ckWARN_d(WARN_PROTOTYPE))
4286             {
4287                 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
4288             }
4289             cv_ckproto((CV*)gv, NULL, ps);
4290         }
4291         if (ps)
4292             sv_setpvn((SV*)gv, ps, ps_len);
4293         else
4294             sv_setiv((SV*)gv, -1);
4295         SvREFCNT_dec(PL_compcv);
4296         cv = PL_compcv = NULL;
4297         PL_sub_generation++;
4298         goto done;
4299     }
4300
4301     cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4302
4303 #ifdef GV_UNIQUE_CHECK
4304     if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4305         Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
4306     }
4307 #endif
4308
4309     if (!block || !ps || *ps || attrs)
4310         const_sv = Nullsv;
4311     else
4312         const_sv = op_const_sv(block, Nullcv);
4313
4314     if (cv) {
4315         const bool exists = CvROOT(cv) || CvXSUB(cv);
4316
4317 #ifdef GV_UNIQUE_CHECK
4318         if (exists && GvUNIQUE(gv)) {
4319             Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
4320         }
4321 #endif
4322
4323         /* if the subroutine doesn't exist and wasn't pre-declared
4324          * with a prototype, assume it will be AUTOLOADed,
4325          * skipping the prototype check
4326          */
4327         if (exists || SvPOK(cv))
4328             cv_ckproto(cv, gv, ps);
4329         /* already defined (or promised)? */
4330         if (exists || GvASSUMECV(gv)) {
4331             if (!block && !attrs) {
4332                 if (CvFLAGS(PL_compcv)) {
4333                     /* might have had built-in attrs applied */
4334                     CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4335                 }
4336                 /* just a "sub foo;" when &foo is already defined */
4337                 SAVEFREESV(PL_compcv);
4338                 goto done;
4339             }
4340             /* ahem, death to those who redefine active sort subs */
4341             if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4342                 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4343             if (block) {
4344                 if (ckWARN(WARN_REDEFINE)
4345                     || (CvCONST(cv)
4346                         && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4347                 {
4348                     const line_t oldline = CopLINE(PL_curcop);
4349                     if (PL_copline != NOLINE)
4350                         CopLINE_set(PL_curcop, PL_copline);
4351                     Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4352                         CvCONST(cv) ? "Constant subroutine %s redefined"
4353                                     : "Subroutine %s redefined", name);
4354                     CopLINE_set(PL_curcop, oldline);
4355                 }
4356                 SvREFCNT_dec(cv);
4357                 cv = Nullcv;
4358             }
4359         }
4360     }
4361     if (const_sv) {
4362         (void)SvREFCNT_inc(const_sv);
4363         if (cv) {
4364             assert(!CvROOT(cv) && !CvCONST(cv));
4365             sv_setpvn((SV*)cv, "", 0);  /* prototype is "" */
4366             CvXSUBANY(cv).any_ptr = const_sv;
4367             CvXSUB(cv) = const_sv_xsub;
4368             CvCONST_on(cv);
4369         }
4370         else {
4371             GvCV(gv) = Nullcv;
4372             cv = newCONSTSUB(NULL, name, const_sv);
4373         }
4374         op_free(block);
4375         SvREFCNT_dec(PL_compcv);
4376         PL_compcv = NULL;
4377         PL_sub_generation++;
4378         goto done;
4379     }
4380     if (attrs) {
4381         HV *stash;
4382         SV *rcv;
4383
4384         /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4385          * before we clobber PL_compcv.
4386          */
4387         if (cv && !block) {
4388             rcv = (SV*)cv;
4389             /* Might have had built-in attributes applied -- propagate them. */
4390             CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4391             if (CvGV(cv) && GvSTASH(CvGV(cv)))
4392                 stash = GvSTASH(CvGV(cv));
4393             else if (CvSTASH(cv))
4394                 stash = CvSTASH(cv);
4395             else
4396                 stash = PL_curstash;
4397         }
4398         else {
4399             /* possibly about to re-define existing subr -- ignore old cv */
4400             rcv = (SV*)PL_compcv;
4401             if (name && GvSTASH(gv))
4402                 stash = GvSTASH(gv);
4403             else
4404                 stash = PL_curstash;
4405         }
4406         apply_attrs(stash, rcv, attrs, FALSE);
4407     }
4408     if (cv) {                           /* must reuse cv if autoloaded */
4409         if (!block) {
4410             /* got here with just attrs -- work done, so bug out */
4411             SAVEFREESV(PL_compcv);
4412             goto done;
4413         }
4414         /* transfer PL_compcv to cv */
4415         cv_undef(cv);
4416         CvFLAGS(cv) = CvFLAGS(PL_compcv);
4417         if (!CvWEAKOUTSIDE(cv))
4418             SvREFCNT_dec(CvOUTSIDE(cv));
4419         CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4420         CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
4421         CvOUTSIDE(PL_compcv) = 0;
4422         CvPADLIST(cv) = CvPADLIST(PL_compcv);
4423         CvPADLIST(PL_compcv) = 0;
4424         /* inner references to PL_compcv must be fixed up ... */
4425         pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
4426         /* ... before we throw it away */
4427         SvREFCNT_dec(PL_compcv);
4428         PL_compcv = cv;
4429         if (PERLDB_INTER)/* Advice debugger on the new sub. */
4430           ++PL_sub_generation;
4431     }
4432     else {
4433         cv = PL_compcv;
4434         if (name) {
4435             GvCV(gv) = cv;
4436             GvCVGEN(gv) = 0;
4437             PL_sub_generation++;
4438         }
4439     }
4440     CvGV(cv) = gv;
4441     CvFILE_set_from_cop(cv, PL_curcop);
4442     CvSTASH(cv) = PL_curstash;
4443
4444     if (ps)
4445         sv_setpvn((SV*)cv, ps, ps_len);
4446
4447     if (PL_error_count) {
4448         op_free(block);
4449         block = Nullop;
4450         if (name) {
4451             const char *s = strrchr(name, ':');
4452             s = s ? s+1 : name;
4453             if (strEQ(s, "BEGIN")) {
4454                 const char not_safe[] =
4455                     "BEGIN not safe after errors--compilation aborted";
4456                 if (PL_in_eval & EVAL_KEEPERR)
4457                     Perl_croak(aTHX_ not_safe);
4458                 else {
4459                     /* force display of errors found but not reported */
4460                     sv_catpv(ERRSV, not_safe);
4461                     Perl_croak(aTHX_ "%"SVf, ERRSV);
4462                 }
4463             }
4464         }
4465     }
4466     if (!block)
4467         goto done;
4468
4469     if (CvLVALUE(cv)) {
4470         CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4471                              mod(scalarseq(block), OP_LEAVESUBLV));
4472     }
4473     else {
4474         /* This makes sub {}; work as expected.  */
4475         if (block->op_type == OP_STUB) {
4476             op_free(block);
4477             block = newSTATEOP(0, Nullch, 0);
4478         }
4479         CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4480     }
4481     CvROOT(cv)->op_private |= OPpREFCOUNTED;
4482     OpREFCNT_set(CvROOT(cv), 1);
4483     CvSTART(cv) = LINKLIST(CvROOT(cv));
4484     CvROOT(cv)->op_next = 0;
4485     CALL_PEEP(CvSTART(cv));
4486
4487     /* now that optimizer has done its work, adjust pad values */
4488
4489     pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
4490
4491     if (CvCLONE(cv)) {
4492         assert(!CvCONST(cv));
4493         if (ps && !*ps && op_const_sv(block, cv))
4494             CvCONST_on(cv);
4495     }
4496
4497     if (name || aname) {
4498         const char *s;
4499         const char *tname = (name ? name : aname);
4500
4501         if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4502             SV *sv = NEWSV(0,0);
4503             SV *tmpstr = sv_newmortal();
4504             GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4505             CV *pcv;
4506             HV *hv;
4507
4508             Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4509                            CopFILE(PL_curcop),
4510                            (long)PL_subline, (long)CopLINE(PL_curcop));
4511             gv_efullname3(tmpstr, gv, Nullch);
4512             hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr), SvCUR(tmpstr), sv, 0);
4513             hv = GvHVn(db_postponed);
4514             if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))
4515                 && (pcv = GvCV(db_postponed)))
4516             {
4517                 dSP;
4518                 PUSHMARK(SP);
4519                 XPUSHs(tmpstr);
4520                 PUTBACK;
4521                 call_sv((SV*)pcv, G_DISCARD);
4522             }
4523         }
4524
4525         if ((s = strrchr(tname,':')))
4526             s++;
4527         else
4528             s = tname;
4529
4530         if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4531             goto done;
4532
4533         if (strEQ(s, "BEGIN") && !PL_error_count) {
4534             const I32 oldscope = PL_scopestack_ix;
4535             ENTER;
4536             SAVECOPFILE(&PL_compiling);
4537             SAVECOPLINE(&PL_compiling);
4538
4539             if (!PL_beginav)
4540                 PL_beginav = newAV();
4541             DEBUG_x( dump_sub(gv) );
4542             av_push(PL_beginav, (SV*)cv);
4543             GvCV(gv) = 0;               /* cv has been hijacked */
4544             call_list(oldscope, PL_beginav);
4545
4546             PL_curcop = &PL_compiling;
4547             PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4548             LEAVE;
4549         }
4550         else if (strEQ(s, "END") && !PL_error_count) {
4551             if (!PL_endav)
4552                 PL_endav = newAV();
4553             DEBUG_x( dump_sub(gv) );
4554             av_unshift(PL_endav, 1);
4555             av_store(PL_endav, 0, (SV*)cv);
4556             GvCV(gv) = 0;               /* cv has been hijacked */
4557         }
4558         else if (strEQ(s, "CHECK") && !PL_error_count) {
4559             if (!PL_checkav)
4560                 PL_checkav = newAV();
4561             DEBUG_x( dump_sub(gv) );
4562             if (PL_main_start && ckWARN(WARN_VOID))
4563                 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4564             av_unshift(PL_checkav, 1);
4565             av_store(PL_checkav, 0, (SV*)cv);
4566             GvCV(gv) = 0;               /* cv has been hijacked */
4567         }
4568         else if (strEQ(s, "INIT") && !PL_error_count) {
4569             if (!PL_initav)
4570                 PL_initav = newAV();
4571             DEBUG_x( dump_sub(gv) );
4572             if (PL_main_start && ckWARN(WARN_VOID))
4573                 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4574             av_push(PL_initav, (SV*)cv);
4575             GvCV(gv) = 0;               /* cv has been hijacked */
4576         }
4577     }
4578
4579   done:
4580     PL_copline = NOLINE;
4581     LEAVE_SCOPE(floor);
4582     return cv;
4583 }
4584
4585 /* XXX unsafe for threads if eval_owner isn't held */
4586 /*
4587 =for apidoc newCONSTSUB
4588
4589 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4590 eligible for inlining at compile-time.
4591
4592 =cut
4593 */
4594
4595 CV *
4596 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
4597 {
4598     dVAR;
4599     CV* cv;
4600
4601     ENTER;
4602
4603     SAVECOPLINE(PL_curcop);
4604     CopLINE_set(PL_curcop, PL_copline);
4605
4606     SAVEHINTS();
4607     PL_hints &= ~HINT_BLOCK_SCOPE;
4608
4609     if (stash) {
4610         SAVESPTR(PL_curstash);
4611         SAVECOPSTASH(PL_curcop);
4612         PL_curstash = stash;
4613         CopSTASH_set(PL_curcop,stash);
4614     }
4615
4616     cv = newXS(name, const_sv_xsub, savepv(CopFILE(PL_curcop)));
4617     CvXSUBANY(cv).any_ptr = sv;
4618     CvCONST_on(cv);
4619     sv_setpvn((SV*)cv, "", 0);  /* prototype is "" */
4620
4621     if (stash)
4622         CopSTASH_free(PL_curcop);
4623
4624     LEAVE;
4625
4626     return cv;
4627 }
4628
4629 /*
4630 =for apidoc U||newXS
4631
4632 Used by C<xsubpp> to hook up XSUBs as Perl subs.
4633
4634 =cut
4635 */
4636
4637 CV *
4638 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
4639 {
4640     GV *gv = gv_fetchpv(name ? name :
4641                         (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4642                         GV_ADDMULTI, SVt_PVCV);
4643     register CV *cv;
4644
4645     if (!subaddr)
4646         Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
4647
4648     if ((cv = (name ? GvCV(gv) : Nullcv))) {
4649         if (GvCVGEN(gv)) {
4650             /* just a cached method */
4651             SvREFCNT_dec(cv);
4652             cv = 0;
4653         }
4654         else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4655             /* already defined (or promised) */
4656             /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
4657             if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
4658                             && strEQ(HvNAME_get(GvSTASH(CvGV(cv))), "autouse"))) {
4659                 const line_t oldline = CopLINE(PL_curcop);
4660                 if (PL_copline != NOLINE)
4661                     CopLINE_set(PL_curcop, PL_copline);
4662                 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4663                             CvCONST(cv) ? "Constant subroutine %s redefined"
4664                                         : "Subroutine %s redefined"
4665                             ,name);
4666                 CopLINE_set(PL_curcop, oldline);
4667             }
4668             SvREFCNT_dec(cv);
4669             cv = 0;
4670         }
4671     }
4672
4673     if (cv)                             /* must reuse cv if autoloaded */
4674         cv_undef(cv);
4675     else {
4676         cv = (CV*)NEWSV(1105,0);
4677         sv_upgrade((SV *)cv, SVt_PVCV);
4678         if (name) {
4679             GvCV(gv) = cv;
4680             GvCVGEN(gv) = 0;
4681             PL_sub_generation++;
4682         }
4683     }
4684     CvGV(cv) = gv;
4685     (void)gv_fetchfile(filename);
4686     CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
4687                                    an external constant string */
4688     CvXSUB(cv) = subaddr;
4689
4690     if (name) {
4691         const char *s = strrchr(name,':');
4692         if (s)
4693             s++;
4694         else
4695             s = name;
4696
4697         if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4698             goto done;
4699
4700         if (strEQ(s, "BEGIN")) {
4701             if (!PL_beginav)
4702                 PL_beginav = newAV();
4703             av_push(PL_beginav, (SV*)cv);
4704             GvCV(gv) = 0;               /* cv has been hijacked */
4705         }
4706         else if (strEQ(s, "END")) {
4707             if (!PL_endav)
4708                 PL_endav = newAV();
4709             av_unshift(PL_endav, 1);
4710             av_store(PL_endav, 0, (SV*)cv);
4711             GvCV(gv) = 0;               /* cv has been hijacked */
4712         }
4713         else if (strEQ(s, "CHECK")) {
4714             if (!PL_checkav)
4715                 PL_checkav = newAV();
4716             if (PL_main_start && ckWARN(WARN_VOID))
4717                 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4718             av_unshift(PL_checkav, 1);
4719             av_store(PL_checkav, 0, (SV*)cv);
4720             GvCV(gv) = 0;               /* cv has been hijacked */
4721         }
4722         else if (strEQ(s, "INIT")) {
4723             if (!PL_initav)
4724                 PL_initav = newAV();
4725             if (PL_main_start && ckWARN(WARN_VOID))
4726                 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4727             av_push(PL_initav, (SV*)cv);
4728             GvCV(gv) = 0;               /* cv has been hijacked */
4729         }
4730     }
4731     else
4732         CvANON_on(cv);
4733
4734 done:
4735     return cv;
4736 }
4737
4738 void
4739 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
4740 {
4741     register CV *cv;
4742     GV *gv;
4743
4744     if (o)
4745         gv = gv_fetchsv(cSVOPo->op_sv, TRUE, SVt_PVFM);
4746     else
4747         gv = gv_fetchpv("STDOUT", TRUE, SVt_PVFM);
4748
4749 #ifdef GV_UNIQUE_CHECK
4750     if (GvUNIQUE(gv)) {
4751         Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
4752     }
4753 #endif
4754     GvMULTI_on(gv);
4755     if ((cv = GvFORM(gv))) {
4756         if (ckWARN(WARN_REDEFINE)) {
4757             const line_t oldline = CopLINE(PL_curcop);
4758             if (PL_copline != NOLINE)
4759                 CopLINE_set(PL_curcop, PL_copline);
4760             Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4761                         o ? "Format %"SVf" redefined"
4762                         : "Format STDOUT redefined" ,cSVOPo->op_sv);
4763             CopLINE_set(PL_curcop, oldline);
4764         }
4765         SvREFCNT_dec(cv);
4766     }
4767     cv = PL_compcv;
4768     GvFORM(gv) = cv;
4769     CvGV(cv) = gv;
4770     CvFILE_set_from_cop(cv, PL_curcop);
4771
4772
4773     pad_tidy(padtidy_FORMAT);
4774     CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
4775     CvROOT(cv)->op_private |= OPpREFCOUNTED;
4776     OpREFCNT_set(CvROOT(cv), 1);
4777     CvSTART(cv) = LINKLIST(CvROOT(cv));
4778     CvROOT(cv)->op_next = 0;
4779     CALL_PEEP(CvSTART(cv));
4780     op_free(o);
4781     PL_copline = NOLINE;
4782     LEAVE_SCOPE(floor);
4783 }
4784
4785 OP *
4786 Perl_newANONLIST(pTHX_ OP *o)
4787 {
4788     return newUNOP(OP_REFGEN, 0,
4789         mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
4790 }
4791
4792 OP *
4793 Perl_newANONHASH(pTHX_ OP *o)
4794 {
4795     return newUNOP(OP_REFGEN, 0,
4796         mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
4797 }
4798
4799 OP *
4800 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
4801 {
4802     return newANONATTRSUB(floor, proto, Nullop, block);
4803 }
4804
4805 OP *
4806 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
4807 {
4808     return newUNOP(OP_REFGEN, 0,
4809         newSVOP(OP_ANONCODE, 0,
4810                 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
4811 }
4812
4813 OP *
4814 Perl_oopsAV(pTHX_ OP *o)
4815 {
4816     dVAR;
4817     switch (o->op_type) {
4818     case OP_PADSV:
4819         o->op_type = OP_PADAV;
4820         o->op_ppaddr = PL_ppaddr[OP_PADAV];
4821         return ref(o, OP_RV2AV);
4822
4823     case OP_RV2SV:
4824         o->op_type = OP_RV2AV;
4825         o->op_ppaddr = PL_ppaddr[OP_RV2AV];
4826         ref(o, OP_RV2AV);
4827         break;
4828
4829     default:
4830         if (ckWARN_d(WARN_INTERNAL))
4831             Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
4832         break;
4833     }
4834     return o;
4835 }
4836
4837 OP *
4838 Perl_oopsHV(pTHX_ OP *o)
4839 {
4840     dVAR;
4841     switch (o->op_type) {
4842     case OP_PADSV:
4843     case OP_PADAV:
4844         o->op_type = OP_PADHV;
4845         o->op_ppaddr = PL_ppaddr[OP_PADHV];
4846         return ref(o, OP_RV2HV);
4847
4848     case OP_RV2SV:
4849     case OP_RV2AV:
4850         o->op_type = OP_RV2HV;
4851         o->op_ppaddr = PL_ppaddr[OP_RV2HV];
4852         ref(o, OP_RV2HV);
4853         break;
4854
4855     default:
4856         if (ckWARN_d(WARN_INTERNAL))
4857             Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
4858         break;
4859     }
4860     return o;
4861 }
4862
4863 OP *
4864 Perl_newAVREF(pTHX_ OP *o)
4865 {
4866     dVAR;
4867     if (o->op_type == OP_PADANY) {
4868         o->op_type = OP_PADAV;
4869         o->op_ppaddr = PL_ppaddr[OP_PADAV];
4870         return o;
4871     }
4872     else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
4873                 && ckWARN(WARN_DEPRECATED)) {
4874         Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4875                 "Using an array as a reference is deprecated");
4876     }
4877     return newUNOP(OP_RV2AV, 0, scalar(o));
4878 }
4879
4880 OP *
4881 Perl_newGVREF(pTHX_ I32 type, OP *o)
4882 {
4883     if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
4884         return newUNOP(OP_NULL, 0, o);
4885     return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
4886 }
4887
4888 OP *
4889 Perl_newHVREF(pTHX_ OP *o)
4890 {
4891     dVAR;
4892     if (o->op_type == OP_PADANY) {
4893         o->op_type = OP_PADHV;
4894         o->op_ppaddr = PL_ppaddr[OP_PADHV];
4895         return o;
4896     }
4897     else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
4898                 && ckWARN(WARN_DEPRECATED)) {
4899         Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4900                 "Using a hash as a reference is deprecated");
4901     }
4902     return newUNOP(OP_RV2HV, 0, scalar(o));
4903 }
4904
4905 OP *
4906 Perl_oopsCV(pTHX_ OP *o)
4907 {
4908     Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
4909     /* STUB */
4910     (void)o;
4911     NORETURN_FUNCTION_END;
4912 }
4913
4914 OP *
4915 Perl_newCVREF(pTHX_ I32 flags, OP *o)
4916 {
4917     return newUNOP(OP_RV2CV, flags, scalar(o));
4918 }
4919
4920 OP *
4921 Perl_newSVREF(pTHX_ OP *o)
4922 {
4923     dVAR;
4924     if (o->op_type == OP_PADANY) {
4925         o->op_type = OP_PADSV;
4926         o->op_ppaddr = PL_ppaddr[OP_PADSV];
4927         return o;
4928     }
4929     else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
4930         o->op_flags |= OPpDONE_SVREF;
4931         return o;
4932     }
4933     return newUNOP(OP_RV2SV, 0, scalar(o));
4934 }
4935
4936 /* Check routines. See the comments at the top of this file for details
4937  * on when these are called */
4938
4939 OP *
4940 Perl_ck_anoncode(pTHX_ OP *o)
4941 {
4942     cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
4943     cSVOPo->op_sv = Nullsv;
4944     return o;
4945 }
4946
4947 OP *
4948 Perl_ck_bitop(pTHX_ OP *o)
4949 {
4950 #define OP_IS_NUMCOMPARE(op) \
4951         ((op) == OP_LT   || (op) == OP_I_LT || \
4952          (op) == OP_GT   || (op) == OP_I_GT || \
4953          (op) == OP_LE   || (op) == OP_I_LE || \
4954          (op) == OP_GE   || (op) == OP_I_GE || \
4955          (op) == OP_EQ   || (op) == OP_I_EQ || \
4956          (op) == OP_NE   || (op) == OP_I_NE || \
4957          (op) == OP_NCMP || (op) == OP_I_NCMP)
4958     o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4959     if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
4960             && (o->op_type == OP_BIT_OR
4961              || o->op_type == OP_BIT_AND
4962              || o->op_type == OP_BIT_XOR))
4963     {
4964         const OP * const left = cBINOPo->op_first;
4965         const OP * const right = left->op_sibling;
4966         if ((OP_IS_NUMCOMPARE(left->op_type) &&
4967                 (left->op_flags & OPf_PARENS) == 0) ||
4968             (OP_IS_NUMCOMPARE(right->op_type) &&
4969                 (right->op_flags & OPf_PARENS) == 0))
4970             if (ckWARN(WARN_PRECEDENCE))
4971                 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
4972                         "Possible precedence problem on bitwise %c operator",
4973                         o->op_type == OP_BIT_OR ? '|'
4974                             : o->op_type == OP_BIT_AND ? '&' : '^'
4975                         );
4976     }
4977     return o;
4978 }
4979
4980 OP *
4981 Perl_ck_concat(pTHX_ OP *o)
4982 {
4983     const OP *kid = cUNOPo->op_first;
4984     if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
4985             !(kUNOP->op_first->op_flags & OPf_MOD))
4986         o->op_flags |= OPf_STACKED;
4987     return o;
4988 }
4989
4990 OP *
4991 Perl_ck_spair(pTHX_ OP *o)
4992 {
4993     dVAR;
4994     if (o->op_flags & OPf_KIDS) {
4995         OP* newop;
4996         OP* kid;
4997         const OPCODE type = o->op_type;
4998         o = modkids(ck_fun(o), type);
4999         kid = cUNOPo->op_first;
5000         newop = kUNOP->op_first->op_sibling;
5001         if (newop &&
5002             (newop->op_sibling ||
5003              !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
5004              newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5005              newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
5006
5007             return o;
5008         }
5009         op_free(kUNOP->op_first);
5010         kUNOP->op_first = newop;
5011     }
5012     o->op_ppaddr = PL_ppaddr[++o->op_type];
5013     return ck_fun(o);
5014 }
5015
5016 OP *
5017 Perl_ck_delete(pTHX_ OP *o)
5018 {
5019     o = ck_fun(o);
5020     o->op_private = 0;
5021     if (o->op_flags & OPf_KIDS) {
5022         OP *kid = cUNOPo->op_first;
5023         switch (kid->op_type) {
5024         case OP_ASLICE:
5025             o->op_flags |= OPf_SPECIAL;
5026             /* FALL THROUGH */
5027         case OP_HSLICE:
5028             o->op_private |= OPpSLICE;
5029             break;
5030         case OP_AELEM:
5031             o->op_flags |= OPf_SPECIAL;
5032             /* FALL THROUGH */
5033         case OP_HELEM:
5034             break;
5035         default:
5036             Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5037                   OP_DESC(o));
5038         }
5039         op_null(kid);
5040     }
5041     return o;
5042 }
5043
5044 OP *
5045 Perl_ck_die(pTHX_ OP *o)
5046 {
5047 #ifdef VMS
5048     if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5049 #endif
5050     return ck_fun(o);
5051 }
5052
5053 OP *
5054 Perl_ck_eof(pTHX_ OP *o)
5055 {
5056     const I32 type = o->op_type;
5057
5058     if (o->op_flags & OPf_KIDS) {
5059         if (cLISTOPo->op_first->op_type == OP_STUB) {
5060             op_free(o);
5061             o = newUNOP(type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
5062         }
5063         return ck_fun(o);
5064     }
5065     return o;
5066 }
5067
5068 OP *
5069 Perl_ck_eval(pTHX_ OP *o)
5070 {
5071     dVAR;
5072     PL_hints |= HINT_BLOCK_SCOPE;
5073     if (o->op_flags & OPf_KIDS) {
5074         SVOP *kid = (SVOP*)cUNOPo->op_first;
5075
5076         if (!kid) {
5077             o->op_flags &= ~OPf_KIDS;
5078             op_null(o);
5079         }
5080         else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
5081             LOGOP *enter;
5082
5083             cUNOPo->op_first = 0;
5084             op_free(o);
5085
5086             NewOp(1101, enter, 1, LOGOP);
5087             enter->op_type = OP_ENTERTRY;
5088             enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5089             enter->op_private = 0;
5090
5091             /* establish postfix order */
5092             enter->op_next = (OP*)enter;
5093
5094             o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5095             o->op_type = OP_LEAVETRY;
5096             o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5097             enter->op_other = o;
5098             return o;
5099         }
5100         else {
5101             scalar((OP*)kid);
5102             PL_cv_has_eval = 1;
5103         }
5104     }
5105     else {
5106         op_free(o);
5107         o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5108     }
5109     o->op_targ = (PADOFFSET)PL_hints;
5110     return o;
5111 }
5112
5113 OP *
5114 Perl_ck_exit(pTHX_ OP *o)
5115 {
5116 #ifdef VMS
5117     HV *table = GvHV(PL_hintgv);
5118     if (table) {
5119        SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
5120        if (svp && *svp && SvTRUE(*svp))
5121            o->op_private |= OPpEXIT_VMSISH;
5122     }
5123     if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5124 #endif
5125     return ck_fun(o);
5126 }
5127
5128 OP *
5129 Perl_ck_exec(pTHX_ OP *o)
5130 {
5131     if (o->op_flags & OPf_STACKED) {
5132         OP *kid;
5133         o = ck_fun(o);
5134         kid = cUNOPo->op_first->op_sibling;
5135         if (kid->op_type == OP_RV2GV)
5136             op_null(kid);
5137     }
5138     else
5139         o = listkids(o);
5140     return o;
5141 }
5142
5143 OP *
5144 Perl_ck_exists(pTHX_ OP *o)
5145 {
5146     o = ck_fun(o);
5147     if (o->op_flags & OPf_KIDS) {
5148         OP *kid = cUNOPo->op_first;
5149         if (kid->op_type == OP_ENTERSUB) {
5150             (void) ref(kid, o->op_type);
5151             if (kid->op_type != OP_RV2CV && !PL_error_count)
5152                 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5153                             OP_DESC(o));
5154             o->op_private |= OPpEXISTS_SUB;
5155         }
5156         else if (kid->op_type == OP_AELEM)
5157             o->op_flags |= OPf_SPECIAL;
5158         else if (kid->op_type != OP_HELEM)
5159             Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5160                         OP_DESC(o));
5161         op_null(kid);
5162     }
5163     return o;
5164 }
5165
5166 OP *
5167 Perl_ck_rvconst(pTHX_ register OP *o)
5168 {
5169     dVAR;
5170     SVOP *kid = (SVOP*)cUNOPo->op_first;
5171
5172     o->op_private |= (PL_hints & HINT_STRICT_REFS);
5173     if (kid->op_type == OP_CONST) {
5174         int iscv;
5175         GV *gv;
5176         SV * const kidsv = kid->op_sv;
5177
5178         /* Is it a constant from cv_const_sv()? */
5179         if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5180             SV *rsv = SvRV(kidsv);
5181             const int svtype = SvTYPE(rsv);
5182             const char *badtype = Nullch;
5183
5184             switch (o->op_type) {
5185             case OP_RV2SV:
5186                 if (svtype > SVt_PVMG)
5187                     badtype = "a SCALAR";
5188                 break;
5189             case OP_RV2AV:
5190                 if (svtype != SVt_PVAV)
5191                     badtype = "an ARRAY";
5192                 break;
5193             case OP_RV2HV:
5194                 if (svtype != SVt_PVHV)
5195                     badtype = "a HASH";
5196                 break;
5197             case OP_RV2CV:
5198                 if (svtype != SVt_PVCV)
5199                     badtype = "a CODE";
5200                 break;
5201             }
5202             if (badtype)
5203                 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5204             return o;
5205         }
5206         if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5207             const char *badthing = Nullch;
5208             switch (o->op_type) {
5209             case OP_RV2SV:
5210                 badthing = "a SCALAR";
5211                 break;
5212             case OP_RV2AV:
5213                 badthing = "an ARRAY";
5214                 break;
5215             case OP_RV2HV:
5216                 badthing = "a HASH";
5217                 break;
5218             }
5219             if (badthing)
5220                 Perl_croak(aTHX_
5221           "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
5222                       kidsv, badthing);
5223         }
5224         /*
5225          * This is a little tricky.  We only want to add the symbol if we
5226          * didn't add it in the lexer.  Otherwise we get duplicate strict
5227          * warnings.  But if we didn't add it in the lexer, we must at
5228          * least pretend like we wanted to add it even if it existed before,
5229          * or we get possible typo warnings.  OPpCONST_ENTERED says
5230          * whether the lexer already added THIS instance of this symbol.
5231          */
5232         iscv = (o->op_type == OP_RV2CV) * 2;
5233         do {
5234             gv = gv_fetchsv(kidsv,
5235                 iscv | !(kid->op_private & OPpCONST_ENTERED),
5236                 iscv
5237                     ? SVt_PVCV
5238                     : o->op_type == OP_RV2SV
5239                         ? SVt_PV
5240                         : o->op_type == OP_RV2AV
5241                             ? SVt_PVAV
5242                             : o->op_type == OP_RV2HV
5243                                 ? SVt_PVHV
5244                                 : SVt_PVGV);
5245         } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5246         if (gv) {
5247             kid->op_type = OP_GV;
5248             SvREFCNT_dec(kid->op_sv);
5249 #ifdef USE_ITHREADS
5250             /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5251             kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5252             SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
5253             GvIN_PAD_on(gv);
5254             PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc(gv));
5255 #else
5256             kid->op_sv = SvREFCNT_inc(gv);
5257 #endif
5258             kid->op_private = 0;
5259             kid->op_ppaddr = PL_ppaddr[OP_GV];
5260         }
5261     }
5262     return o;
5263 }
5264
5265 OP *
5266 Perl_ck_ftst(pTHX_ OP *o)
5267 {
5268     dVAR;
5269     const I32 type = o->op_type;
5270
5271     if (o->op_flags & OPf_REF) {
5272         /* nothing */
5273     }
5274     else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5275         SVOP *kid = (SVOP*)cUNOPo->op_first;
5276
5277         if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5278             OP *newop = newGVOP(type, OPf_REF,
5279                 gv_fetchsv(kid->op_sv, TRUE, SVt_PVIO));
5280             op_free(o);
5281             o = newop;
5282             return o;
5283         }
5284         else {
5285           if ((PL_hints & HINT_FILETEST_ACCESS) &&
5286               OP_IS_FILETEST_ACCESS(o))
5287             o->op_private |= OPpFT_ACCESS;
5288         }
5289         if (PL_check[kid->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst)
5290                 && kid->op_type != OP_STAT && kid->op_type != OP_LSTAT)
5291             o->op_private |= OPpFT_STACKED;
5292     }
5293     else {
5294         op_free(o);
5295         if (type == OP_FTTTY)
5296             o = newGVOP(type, OPf_REF, PL_stdingv);
5297         else
5298             o = newUNOP(type, 0, newDEFSVOP());
5299     }
5300     return o;
5301 }
5302
5303 OP *
5304 Perl_ck_fun(pTHX_ OP *o)
5305 {
5306     const int type = o->op_type;
5307     register I32 oa = PL_opargs[type] >> OASHIFT;
5308
5309     if (o->op_flags & OPf_STACKED) {
5310         if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5311             oa &= ~OA_OPTIONAL;
5312         else
5313             return no_fh_allowed(o);
5314     }
5315
5316     if (o->op_flags & OPf_KIDS) {
5317         OP **tokid = &cLISTOPo->op_first;
5318         register OP *kid = cLISTOPo->op_first;
5319         OP *sibl;
5320         I32 numargs = 0;
5321
5322         if (kid->op_type == OP_PUSHMARK ||
5323             (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5324         {
5325             tokid = &kid->op_sibling;
5326             kid = kid->op_sibling;
5327         }
5328         if (!kid && PL_opargs[type] & OA_DEFGV)
5329             *tokid = kid = newDEFSVOP();
5330
5331         while (oa && kid) {
5332             numargs++;
5333             sibl = kid->op_sibling;
5334             switch (oa & 7) {
5335             case OA_SCALAR:
5336                 /* list seen where single (scalar) arg expected? */
5337                 if (numargs == 1 && !(oa >> 4)
5338                     && kid->op_type == OP_LIST && type != OP_SCALAR)
5339                 {
5340                     return too_many_arguments(o,PL_op_desc[type]);
5341                 }
5342                 scalar(kid);
5343                 break;
5344             case OA_LIST:
5345                 if (oa < 16) {
5346                     kid = 0;
5347                     continue;
5348                 }
5349                 else
5350                     list(kid);
5351                 break;
5352             case OA_AVREF:
5353                 if ((type == OP_PUSH || type == OP_UNSHIFT)
5354                     && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5355                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5356                         "Useless use of %s with no values",
5357                         PL_op_desc[type]);
5358
5359                 if (kid->op_type == OP_CONST &&
5360                     (kid->op_private & OPpCONST_BARE))
5361                 {
5362                     OP *newop = newAVREF(newGVOP(OP_GV, 0,
5363                         gv_fetchsv(((SVOP*)kid)->op_sv, TRUE, SVt_PVAV) ));
5364                     if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5365                         Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5366                             "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
5367                             ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
5368                     op_free(kid);
5369                     kid = newop;
5370                     kid->op_sibling = sibl;
5371                     *tokid = kid;
5372                 }
5373                 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5374                     bad_type(numargs, "array", PL_op_desc[type], kid);
5375                 mod(kid, type);
5376                 break;
5377             case OA_HVREF:
5378                 if (kid->op_type == OP_CONST &&
5379                     (kid->op_private & OPpCONST_BARE))
5380                 {
5381                     OP *newop = newHVREF(newGVOP(OP_GV, 0,
5382                         gv_fetchsv(((SVOP*)kid)->op_sv, TRUE, SVt_PVHV) ));
5383                     if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5384                         Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5385                             "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
5386                             ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
5387                     op_free(kid);
5388                     kid = newop;
5389                     kid->op_sibling = sibl;
5390                     *tokid = kid;
5391                 }
5392                 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5393                     bad_type(numargs, "hash", PL_op_desc[type], kid);
5394                 mod(kid, type);
5395                 break;
5396             case OA_CVREF:
5397                 {
5398                     OP *newop = newUNOP(OP_NULL, 0, kid);
5399                     kid->op_sibling = 0;
5400                     linklist(kid);
5401                     newop->op_next = newop;
5402                     kid = newop;
5403                     kid->op_sibling = sibl;
5404                     *tokid = kid;
5405                 }
5406                 break;
5407             case OA_FILEREF:
5408                 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5409                     if (kid->op_type == OP_CONST &&
5410                         (kid->op_private & OPpCONST_BARE))
5411                     {
5412                         OP *newop = newGVOP(OP_GV, 0,
5413                             gv_fetchsv(((SVOP*)kid)->op_sv, TRUE, SVt_PVIO) );
5414                         if (!(o->op_private & 1) && /* if not unop */
5415                             kid == cLISTOPo->op_last)
5416                             cLISTOPo->op_last = newop;
5417                         op_free(kid);
5418                         kid = newop;
5419                     }
5420                     else if (kid->op_type == OP_READLINE) {
5421                         /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5422                         bad_type(numargs, "HANDLE", OP_DESC(o), kid);
5423                     }
5424                     else {
5425                         I32 flags = OPf_SPECIAL;
5426                         I32 priv = 0;
5427                         PADOFFSET targ = 0;
5428
5429                         /* is this op a FH constructor? */
5430                         if (is_handle_constructor(o,numargs)) {
5431                             const char *name = Nullch;
5432                             STRLEN len = 0;
5433
5434                             flags = 0;
5435                             /* Set a flag to tell rv2gv to vivify
5436                              * need to "prove" flag does not mean something
5437                              * else already - NI-S 1999/05/07
5438                              */
5439                             priv = OPpDEREF;
5440                             if (kid->op_type == OP_PADSV) {
5441                                 name = PAD_COMPNAME_PV(kid->op_targ);
5442                                 /* SvCUR of a pad namesv can't be trusted
5443                                  * (see PL_generation), so calc its length
5444                                  * manually */
5445                                 if (name)
5446                                     len = strlen(name);
5447
5448                             }
5449                             else if (kid->op_type == OP_RV2SV
5450                                      && kUNOP->op_first->op_type == OP_GV)
5451                             {
5452                                 GV *gv = cGVOPx_gv(kUNOP->op_first);
5453                                 name = GvNAME(gv);
5454                                 len = GvNAMELEN(gv);
5455                             }
5456                             else if (kid->op_type == OP_AELEM
5457                                      || kid->op_type == OP_HELEM)
5458                             {
5459                                  OP *op;
5460
5461                                  name = 0;
5462                                  if ((op = ((BINOP*)kid)->op_first)) {
5463                                       SV *tmpstr = Nullsv;
5464                                       const char *a =
5465                                            kid->op_type == OP_AELEM ?
5466                                            "[]" : "{}";
5467                                       if (((op->op_type == OP_RV2AV) ||
5468                                            (op->op_type == OP_RV2HV)) &&
5469                                           (op = ((UNOP*)op)->op_first) &&
5470                                           (op->op_type == OP_GV)) {
5471                                            /* packagevar $a[] or $h{} */
5472                                            GV *gv = cGVOPx_gv(op);
5473                                            if (gv)
5474                                                 tmpstr =
5475                                                      Perl_newSVpvf(aTHX_
5476                                                                    "%s%c...%c",
5477                                                                    GvNAME(gv),
5478                                                                    a[0], a[1]);
5479                                       }
5480                                       else if (op->op_type == OP_PADAV
5481                                                || op->op_type == OP_PADHV) {
5482                                            /* lexicalvar $a[] or $h{} */
5483                                            const char *padname =
5484                                                 PAD_COMPNAME_PV(op->op_targ);
5485                                            if (padname)
5486                                                 tmpstr =
5487                                                      Perl_newSVpvf(aTHX_
5488                                                                    "%s%c...%c",
5489                                                                    padname + 1,
5490                                                                    a[0], a[1]);
5491
5492                                       }
5493                                       if (tmpstr) {
5494                                            name = SvPV(tmpstr, len);
5495                                            sv_2mortal(tmpstr);
5496                                       }
5497                                  }
5498                                  if (!name) {
5499                                       name = "__ANONIO__";
5500                                       len = 10;
5501                                  }
5502                                  mod(kid, type);
5503                             }
5504                             if (name) {
5505                                 SV *namesv;
5506                                 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5507                                 namesv = PAD_SVl(targ);
5508                                 (void)SvUPGRADE(namesv, SVt_PV);
5509                                 if (*name != '$')
5510                                     sv_setpvn(namesv, "$", 1);
5511                                 sv_catpvn(namesv, name, len);
5512                             }
5513                         }
5514                         kid->op_sibling = 0;
5515                         kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5516                         kid->op_targ = targ;
5517                         kid->op_private |= priv;
5518                     }
5519                     kid->op_sibling = sibl;
5520                     *tokid = kid;
5521                 }
5522                 scalar(kid);
5523                 break;
5524             case OA_SCALARREF:
5525                 mod(scalar(kid), type);
5526                 break;
5527             }
5528             oa >>= 4;
5529             tokid = &kid->op_sibling;
5530             kid = kid->op_sibling;
5531         }
5532         o->op_private |= numargs;
5533         if (kid)
5534             return too_many_arguments(o,OP_DESC(o));
5535         listkids(o);
5536     }
5537     else if (PL_opargs[type] & OA_DEFGV) {
5538         op_free(o);
5539         return newUNOP(type, 0, newDEFSVOP());
5540     }
5541
5542     if (oa) {
5543         while (oa & OA_OPTIONAL)
5544             oa >>= 4;
5545         if (oa && oa != OA_LIST)
5546             return too_few_arguments(o,OP_DESC(o));
5547     }
5548     return o;
5549 }
5550
5551 OP *
5552 Perl_ck_glob(pTHX_ OP *o)
5553 {
5554     dVAR;
5555     GV *gv;
5556
5557     o = ck_fun(o);
5558     if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5559         append_elem(OP_GLOB, o, newDEFSVOP());
5560
5561     if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV))
5562           && GvCVu(gv) && GvIMPORTED_CV(gv)))
5563     {
5564         gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5565     }
5566
5567 #if !defined(PERL_EXTERNAL_GLOB)
5568     /* XXX this can be tightened up and made more failsafe. */
5569     if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
5570         GV *glob_gv;
5571         ENTER;
5572         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
5573                 newSVpvn("File::Glob", 10), Nullsv, Nullsv, Nullsv);
5574         gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5575         glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
5576         GvCV(gv) = GvCV(glob_gv);
5577         (void)SvREFCNT_inc((SV*)GvCV(gv));
5578         GvIMPORTED_CV_on(gv);
5579         LEAVE;
5580     }
5581 #endif /* PERL_EXTERNAL_GLOB */
5582
5583     if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5584         append_elem(OP_GLOB, o,
5585                     newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5586         o->op_type = OP_LIST;
5587         o->op_ppaddr = PL_ppaddr[OP_LIST];
5588         cLISTOPo->op_first->op_type = OP_PUSHMARK;
5589         cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5590         cLISTOPo->op_first->op_targ = 0;
5591         o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5592                     append_elem(OP_LIST, o,
5593                                 scalar(newUNOP(OP_RV2CV, 0,
5594                                                newGVOP(OP_GV, 0, gv)))));
5595         o = newUNOP(OP_NULL, 0, ck_subr(o));
5596         o->op_targ = OP_GLOB;           /* hint at what it used to be */
5597         return o;
5598     }
5599     gv = newGVgen("main");
5600     gv_IOadd(gv);
5601     append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5602     scalarkids(o);
5603     return o;
5604 }
5605
5606 OP *
5607 Perl_ck_grep(pTHX_ OP *o)
5608 {
5609     dVAR;
5610     LOGOP *gwop;
5611     OP *kid;
5612     const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5613     I32 offset;
5614
5615     o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5616     NewOp(1101, gwop, 1, LOGOP);
5617
5618     if (o->op_flags & OPf_STACKED) {
5619         OP* k;
5620         o = ck_sort(o);
5621         kid = cLISTOPo->op_first->op_sibling;
5622         if (!cUNOPx(kid)->op_next)
5623             Perl_croak(aTHX_ "panic: ck_grep");
5624         for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
5625             kid = k;
5626         }
5627         kid->op_next = (OP*)gwop;
5628         o->op_flags &= ~OPf_STACKED;
5629     }
5630     kid = cLISTOPo->op_first->op_sibling;
5631     if (type == OP_MAPWHILE)
5632         list(kid);
5633     else
5634         scalar(kid);
5635     o = ck_fun(o);
5636     if (PL_error_count)
5637         return o;
5638     kid = cLISTOPo->op_first->op_sibling;
5639     if (kid->op_type != OP_NULL)
5640         Perl_croak(aTHX_ "panic: ck_grep");
5641     kid = kUNOP->op_first;
5642
5643     gwop->op_type = type;
5644     gwop->op_ppaddr = PL_ppaddr[type];
5645     gwop->op_first = listkids(o);
5646     gwop->op_flags |= OPf_KIDS;
5647     gwop->op_other = LINKLIST(kid);
5648     kid->op_next = (OP*)gwop;
5649     offset = pad_findmy("$_");
5650     if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
5651         o->op_private = gwop->op_private = 0;
5652         gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5653     }
5654     else {
5655         o->op_private = gwop->op_private = OPpGREP_LEX;
5656         gwop->op_targ = o->op_targ = offset;
5657     }
5658
5659     kid = cLISTOPo->op_first->op_sibling;
5660     if (!kid || !kid->op_sibling)
5661         return too_few_arguments(o,OP_DESC(o));
5662     for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5663         mod(kid, OP_GREPSTART);
5664
5665     return (OP*)gwop;
5666 }
5667
5668 OP *
5669 Perl_ck_index(pTHX_ OP *o)
5670 {
5671     if (o->op_flags & OPf_KIDS) {
5672         OP *kid = cLISTOPo->op_first->op_sibling;       /* get past pushmark */
5673         if (kid)
5674             kid = kid->op_sibling;                      /* get past "big" */
5675         if (kid && kid->op_type == OP_CONST)
5676             fbm_compile(((SVOP*)kid)->op_sv, 0);
5677     }
5678     return ck_fun(o);
5679 }
5680
5681 OP *
5682 Perl_ck_lengthconst(pTHX_ OP *o)
5683 {
5684     /* XXX length optimization goes here */
5685     return ck_fun(o);
5686 }
5687
5688 OP *
5689 Perl_ck_lfun(pTHX_ OP *o)
5690 {
5691     const OPCODE type = o->op_type;
5692     return modkids(ck_fun(o), type);
5693 }
5694
5695 OP *
5696 Perl_ck_defined(pTHX_ OP *o)            /* 19990527 MJD */
5697 {
5698     if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
5699         switch (cUNOPo->op_first->op_type) {
5700         case OP_RV2AV:
5701             /* This is needed for
5702                if (defined %stash::)
5703                to work.   Do not break Tk.
5704                */
5705             break;                      /* Globals via GV can be undef */
5706         case OP_PADAV:
5707         case OP_AASSIGN:                /* Is this a good idea? */
5708             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5709                         "defined(@array) is deprecated");
5710             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5711                         "\t(Maybe you should just omit the defined()?)\n");
5712         break;
5713         case OP_RV2HV:
5714             /* This is needed for
5715                if (defined %stash::)
5716                to work.   Do not break Tk.
5717                */
5718             break;                      /* Globals via GV can be undef */
5719         case OP_PADHV:
5720             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5721                         "defined(%%hash) is deprecated");
5722             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5723                         "\t(Maybe you should just omit the defined()?)\n");
5724             break;
5725         default:
5726             /* no warning */
5727             break;
5728         }
5729     }
5730     return ck_rfun(o);
5731 }
5732
5733 OP *
5734 Perl_ck_rfun(pTHX_ OP *o)
5735 {
5736     const OPCODE type = o->op_type;
5737     return refkids(ck_fun(o), type);
5738 }
5739
5740 OP *
5741 Perl_ck_listiob(pTHX_ OP *o)
5742 {
5743     register OP *kid;
5744
5745     kid = cLISTOPo->op_first;
5746     if (!kid) {
5747         o = force_list(o);
5748         kid = cLISTOPo->op_first;
5749     }
5750     if (kid->op_type == OP_PUSHMARK)
5751         kid = kid->op_sibling;
5752     if (kid && o->op_flags & OPf_STACKED)
5753         kid = kid->op_sibling;
5754     else if (kid && !kid->op_sibling) {         /* print HANDLE; */
5755         if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
5756             o->op_flags |= OPf_STACKED; /* make it a filehandle */
5757             kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
5758             cLISTOPo->op_first->op_sibling = kid;
5759             cLISTOPo->op_last = kid;
5760             kid = kid->op_sibling;
5761         }
5762     }
5763
5764     if (!kid)
5765         append_elem(o->op_type, o, newDEFSVOP());
5766
5767     return listkids(o);
5768 }
5769
5770 OP *
5771 Perl_ck_sassign(pTHX_ OP *o)
5772 {
5773     OP *kid = cLISTOPo->op_first;
5774     /* has a disposable target? */
5775     if ((PL_opargs[kid->op_type] & OA_TARGLEX)
5776         && !(kid->op_flags & OPf_STACKED)
5777         /* Cannot steal the second time! */
5778         && !(kid->op_private & OPpTARGET_MY))
5779     {
5780         OP *kkid = kid->op_sibling;
5781
5782         /* Can just relocate the target. */
5783         if (kkid && kkid->op_type == OP_PADSV
5784             && !(kkid->op_private & OPpLVAL_INTRO))
5785         {
5786             kid->op_targ = kkid->op_targ;
5787             kkid->op_targ = 0;
5788             /* Now we do not need PADSV and SASSIGN. */
5789             kid->op_sibling = o->op_sibling;    /* NULL */
5790             cLISTOPo->op_first = NULL;
5791             op_free(o);
5792             op_free(kkid);
5793             kid->op_private |= OPpTARGET_MY;    /* Used for context settings */
5794             return kid;
5795         }
5796     }
5797     /* optimise C<my $x = undef> to C<my $x> */
5798     if (kid->op_type == OP_UNDEF) {
5799         OP *kkid = kid->op_sibling;
5800         if (kkid && kkid->op_type == OP_PADSV
5801                 && (kkid->op_private & OPpLVAL_INTRO))
5802         {
5803             cLISTOPo->op_first = NULL;
5804             kid->op_sibling = NULL;
5805             op_free(o);
5806             op_free(kid);
5807             return kkid;
5808         }
5809     }
5810     return o;
5811 }
5812
5813 OP *
5814 Perl_ck_match(pTHX_ OP *o)
5815 {
5816     if (o->op_type != OP_QR) {
5817         const I32 offset = pad_findmy("$_");
5818         if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS(offset) & SVpad_OUR)) {
5819             o->op_targ = offset;
5820             o->op_private |= OPpTARGET_MY;
5821         }
5822     }
5823     if (o->op_type == OP_MATCH || o->op_type == OP_QR)
5824         o->op_private |= OPpRUNTIME;
5825     return o;
5826 }
5827
5828 OP *
5829 Perl_ck_method(pTHX_ OP *o)
5830 {
5831     OP *kid = cUNOPo->op_first;
5832     if (kid->op_type == OP_CONST) {
5833         SV* sv = kSVOP->op_sv;
5834         if (!(strchr(SvPVX_const(sv), ':') || strchr(SvPVX_const(sv), '\''))) {
5835             OP *cmop;
5836             if (!SvREADONLY(sv) || !SvFAKE(sv)) {
5837                 sv = newSVpvn_share(SvPVX_const(sv), SvCUR(sv), 0);
5838             }
5839             else {
5840                 kSVOP->op_sv = Nullsv;
5841             }
5842             cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
5843             op_free(o);
5844             return cmop;
5845         }
5846     }
5847     return o;
5848 }
5849
5850 OP *
5851 Perl_ck_null(pTHX_ OP *o)
5852 {
5853     return o;
5854 }
5855
5856 OP *
5857 Perl_ck_open(pTHX_ OP *o)
5858 {
5859     HV *table = GvHV(PL_hintgv);
5860     if (table) {
5861         SV **svp;
5862         I32 mode;
5863         svp = hv_fetch(table, "open_IN", 7, FALSE);
5864         if (svp && *svp) {
5865             mode = mode_from_discipline(*svp);
5866             if (mode & O_BINARY)
5867                 o->op_private |= OPpOPEN_IN_RAW;
5868             else if (mode & O_TEXT)
5869                 o->op_private |= OPpOPEN_IN_CRLF;
5870         }
5871
5872         svp = hv_fetch(table, "open_OUT", 8, FALSE);
5873         if (svp && *svp) {
5874             mode = mode_from_discipline(*svp);
5875             if (mode & O_BINARY)
5876                 o->op_private |= OPpOPEN_OUT_RAW;
5877             else if (mode & O_TEXT)
5878                 o->op_private |= OPpOPEN_OUT_CRLF;
5879         }
5880     }
5881     if (o->op_type == OP_BACKTICK)
5882         return o;
5883     {
5884          /* In case of three-arg dup open remove strictness
5885           * from the last arg if it is a bareword. */
5886          OP *first = cLISTOPx(o)->op_first; /* The pushmark. */
5887          OP *last  = cLISTOPx(o)->op_last;  /* The bareword. */
5888          OP *oa;
5889          const char *mode;
5890
5891          if ((last->op_type == OP_CONST) &&             /* The bareword. */
5892              (last->op_private & OPpCONST_BARE) &&
5893              (last->op_private & OPpCONST_STRICT) &&
5894              (oa = first->op_sibling) &&                /* The fh. */
5895              (oa = oa->op_sibling) &&                   /* The mode. */
5896              SvPOK(((SVOP*)oa)->op_sv) &&
5897              (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
5898              mode[0] == '>' && mode[1] == '&' &&        /* A dup open. */
5899              (last == oa->op_sibling))                  /* The bareword. */
5900               last->op_private &= ~OPpCONST_STRICT;
5901     }
5902     return ck_fun(o);
5903 }
5904
5905 OP *
5906 Perl_ck_repeat(pTHX_ OP *o)
5907 {
5908     if (cBINOPo->op_first->op_flags & OPf_PARENS) {
5909         o->op_private |= OPpREPEAT_DOLIST;
5910         cBINOPo->op_first = force_list(cBINOPo->op_first);
5911     }
5912     else
5913         scalar(o);
5914     return o;
5915 }
5916
5917 OP *
5918 Perl_ck_require(pTHX_ OP *o)
5919 {
5920     GV* gv;
5921
5922     if (o->op_flags & OPf_KIDS) {       /* Shall we supply missing .pm? */
5923         SVOP *kid = (SVOP*)cUNOPo->op_first;
5924
5925         if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5926             char *s;
5927             for (s = SvPVX(kid->op_sv); *s; s++) {
5928                 if (*s == ':' && s[1] == ':') {
5929                     *s = '/';
5930                     Move(s+2, s+1, strlen(s+2)+1, char);
5931                     SvCUR_set(kid->op_sv, SvCUR(kid->op_sv) - 1);
5932                 }
5933             }
5934             if (SvREADONLY(kid->op_sv)) {
5935                 SvREADONLY_off(kid->op_sv);
5936                 sv_catpvn(kid->op_sv, ".pm", 3);
5937                 SvREADONLY_on(kid->op_sv);
5938             }
5939             else
5940                 sv_catpvn(kid->op_sv, ".pm", 3);
5941         }
5942     }
5943
5944     /* handle override, if any */
5945     gv = gv_fetchpv("require", FALSE, SVt_PVCV);
5946     if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
5947         gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
5948
5949     if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5950         OP *kid = cUNOPo->op_first;
5951         cUNOPo->op_first = 0;
5952         op_free(o);
5953         return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
5954                                append_elem(OP_LIST, kid,
5955                                            scalar(newUNOP(OP_RV2CV, 0,
5956                                                           newGVOP(OP_GV, 0,
5957                                                                   gv))))));
5958     }
5959
5960     return ck_fun(o);
5961 }
5962
5963 OP *
5964 Perl_ck_return(pTHX_ OP *o)
5965 {
5966     if (CvLVALUE(PL_compcv)) {
5967         OP *kid;
5968         for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
5969             mod(kid, OP_LEAVESUBLV);
5970     }
5971     return o;
5972 }
5973
5974 #if 0
5975 OP *
5976 Perl_ck_retarget(pTHX_ OP *o)
5977 {
5978     Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5979     /* STUB */
5980     return o;
5981 }
5982 #endif
5983
5984 OP *
5985 Perl_ck_select(pTHX_ OP *o)
5986 {
5987     dVAR;
5988     OP* kid;
5989     if (o->op_flags & OPf_KIDS) {
5990         kid = cLISTOPo->op_first->op_sibling;   /* get past pushmark */
5991         if (kid && kid->op_sibling) {
5992             o->op_type = OP_SSELECT;
5993             o->op_ppaddr = PL_ppaddr[OP_SSELECT];
5994             o = ck_fun(o);
5995             return fold_constants(o);
5996         }
5997     }
5998     o = ck_fun(o);
5999     kid = cLISTOPo->op_first->op_sibling;    /* get past pushmark */
6000     if (kid && kid->op_type == OP_RV2GV)
6001         kid->op_private &= ~HINT_STRICT_REFS;
6002     return o;
6003 }
6004
6005 OP *
6006 Perl_ck_shift(pTHX_ OP *o)
6007 {
6008     const I32 type = o->op_type;
6009
6010     if (!(o->op_flags & OPf_KIDS)) {
6011         OP *argop;
6012
6013         op_free(o);
6014         argop = newUNOP(OP_RV2AV, 0,
6015             scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
6016         return newUNOP(type, 0, scalar(argop));
6017     }
6018     return scalar(modkids(ck_fun(o), type));
6019 }
6020
6021 OP *
6022 Perl_ck_sort(pTHX_ OP *o)
6023 {
6024     OP *firstkid;
6025
6026     if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6027         simplify_sort(o);
6028     firstkid = cLISTOPo->op_first->op_sibling;          /* get past pushmark */
6029     if (o->op_flags & OPf_STACKED) {                    /* may have been cleared */
6030         OP *k = NULL;
6031         OP *kid = cUNOPx(firstkid)->op_first;           /* get past null */
6032
6033         if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
6034             linklist(kid);
6035             if (kid->op_type == OP_SCOPE) {
6036                 k = kid->op_next;
6037                 kid->op_next = 0;
6038             }
6039             else if (kid->op_type == OP_LEAVE) {
6040                 if (o->op_type == OP_SORT) {
6041                     op_null(kid);                       /* wipe out leave */
6042                     kid->op_next = kid;
6043
6044                     for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6045                         if (k->op_next == kid)
6046                             k->op_next = 0;
6047                         /* don't descend into loops */
6048                         else if (k->op_type == OP_ENTERLOOP
6049                                  || k->op_type == OP_ENTERITER)
6050                         {
6051                             k = cLOOPx(k)->op_lastop;
6052                         }
6053                     }
6054                 }
6055                 else
6056                     kid->op_next = 0;           /* just disconnect the leave */
6057                 k = kLISTOP->op_first;
6058             }
6059             CALL_PEEP(k);
6060
6061             kid = firstkid;
6062             if (o->op_type == OP_SORT) {
6063                 /* provide scalar context for comparison function/block */
6064                 kid = scalar(kid);
6065                 kid->op_next = kid;
6066             }
6067             else
6068                 kid->op_next = k;
6069             o->op_flags |= OPf_SPECIAL;
6070         }
6071         else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6072             op_null(firstkid);
6073
6074         firstkid = firstkid->op_sibling;
6075     }
6076
6077     /* provide list context for arguments */
6078     if (o->op_type == OP_SORT)
6079         list(firstkid);
6080
6081     return o;
6082 }
6083
6084 STATIC void
6085 S_simplify_sort(pTHX_ OP *o)
6086 {
6087     register OP *kid = cLISTOPo->op_first->op_sibling;  /* get past pushmark */
6088     OP *k;
6089     int descending;
6090     GV *gv;
6091     const char *gvname;
6092     if (!(o->op_flags & OPf_STACKED))
6093         return;
6094     GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
6095     GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
6096     kid = kUNOP->op_first;                              /* get past null */
6097     if (kid->op_type != OP_SCOPE)
6098         return;
6099     kid = kLISTOP->op_last;                             /* get past scope */
6100     switch(kid->op_type) {
6101         case OP_NCMP:
6102         case OP_I_NCMP:
6103         case OP_SCMP:
6104             break;
6105         default:
6106             return;
6107     }
6108     k = kid;                                            /* remember this node*/
6109     if (kBINOP->op_first->op_type != OP_RV2SV)
6110         return;
6111     kid = kBINOP->op_first;                             /* get past cmp */
6112     if (kUNOP->op_first->op_type != OP_GV)
6113         return;
6114     kid = kUNOP->op_first;                              /* get past rv2sv */
6115     gv = kGVOP_gv;
6116     if (GvSTASH(gv) != PL_curstash)
6117         return;
6118     gvname = GvNAME(gv);
6119     if (*gvname == 'a' && gvname[1] == '\0')
6120         descending = 0;
6121     else if (*gvname == 'b' && gvname[1] == '\0')
6122         descending = 1;
6123     else
6124         return;
6125
6126     kid = k;                                            /* back to cmp */
6127     if (kBINOP->op_last->op_type != OP_RV2SV)
6128         return;
6129     kid = kBINOP->op_last;                              /* down to 2nd arg */
6130     if (kUNOP->op_first->op_type != OP_GV)
6131         return;
6132     kid = kUNOP->op_first;                              /* get past rv2sv */
6133     gv = kGVOP_gv;
6134     if (GvSTASH(gv) != PL_curstash)
6135         return;
6136     gvname = GvNAME(gv);
6137     if ( descending
6138          ? !(*gvname == 'a' && gvname[1] == '\0')
6139          : !(*gvname == 'b' && gvname[1] == '\0'))
6140         return;
6141     o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6142     if (descending)
6143         o->op_private |= OPpSORT_DESCEND;
6144     if (k->op_type == OP_NCMP)
6145         o->op_private |= OPpSORT_NUMERIC;
6146     if (k->op_type == OP_I_NCMP)
6147         o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6148     kid = cLISTOPo->op_first->op_sibling;
6149     cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6150     op_free(kid);                                     /* then delete it */
6151 }
6152
6153 OP *
6154 Perl_ck_split(pTHX_ OP *o)
6155 {
6156     dVAR;
6157     register OP *kid;
6158
6159     if (o->op_flags & OPf_STACKED)
6160         return no_fh_allowed(o);
6161
6162     kid = cLISTOPo->op_first;
6163     if (kid->op_type != OP_NULL)
6164         Perl_croak(aTHX_ "panic: ck_split");
6165     kid = kid->op_sibling;
6166     op_free(cLISTOPo->op_first);
6167     cLISTOPo->op_first = kid;
6168     if (!kid) {
6169         cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
6170         cLISTOPo->op_last = kid; /* There was only one element previously */
6171     }
6172
6173     if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6174         OP *sibl = kid->op_sibling;
6175         kid->op_sibling = 0;
6176         kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
6177         if (cLISTOPo->op_first == cLISTOPo->op_last)
6178             cLISTOPo->op_last = kid;
6179         cLISTOPo->op_first = kid;
6180         kid->op_sibling = sibl;
6181     }
6182
6183     kid->op_type = OP_PUSHRE;
6184     kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6185     scalar(kid);
6186     if (ckWARN(WARN_REGEXP) && ((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
6187       Perl_warner(aTHX_ packWARN(WARN_REGEXP),
6188                   "Use of /g modifier is meaningless in split");
6189     }
6190
6191     if (!kid->op_sibling)
6192         append_elem(OP_SPLIT, o, newDEFSVOP());
6193
6194     kid = kid->op_sibling;
6195     scalar(kid);
6196
6197     if (!kid->op_sibling)
6198         append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6199
6200     kid = kid->op_sibling;
6201     scalar(kid);
6202
6203     if (kid->op_sibling)
6204         return too_many_arguments(o,OP_DESC(o));
6205
6206     return o;
6207 }
6208
6209 OP *
6210 Perl_ck_join(pTHX_ OP *o)
6211 {
6212     if (ckWARN(WARN_SYNTAX)) {
6213         const OP *kid = cLISTOPo->op_first->op_sibling;
6214         if (kid && kid->op_type == OP_MATCH) {
6215             const REGEXP *re = PM_GETRE(kPMOP);
6216             const char *pmstr = re ? re->precomp : "STRING";
6217             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6218                         "/%s/ should probably be written as \"%s\"",
6219                         pmstr, pmstr);
6220         }
6221     }
6222     return ck_fun(o);
6223 }
6224
6225 OP *
6226 Perl_ck_subr(pTHX_ OP *o)
6227 {
6228     OP *prev = ((cUNOPo->op_first->op_sibling)
6229              ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6230     OP *o2 = prev->op_sibling;
6231     OP *cvop;
6232     char *proto = 0;
6233     CV *cv = 0;
6234     GV *namegv = 0;
6235     int optional = 0;
6236     I32 arg = 0;
6237     I32 contextclass = 0;
6238     char *e = 0;
6239     STRLEN n_a;
6240     bool delete_op = 0;
6241
6242     o->op_private |= OPpENTERSUB_HASTARG;
6243     for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6244     if (cvop->op_type == OP_RV2CV) {
6245         SVOP* tmpop;
6246         o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6247         op_null(cvop);          /* disable rv2cv */
6248         tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6249         if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6250             GV *gv = cGVOPx_gv(tmpop);
6251             cv = GvCVu(gv);
6252             if (!cv)
6253                 tmpop->op_private |= OPpEARLY_CV;
6254             else {
6255                 if (SvPOK(cv)) {
6256                     namegv = CvANON(cv) ? gv : CvGV(cv);
6257                     proto = SvPV((SV*)cv, n_a);
6258                 }
6259                 if (CvASSERTION(cv)) {
6260                     if (PL_hints & HINT_ASSERTING) {
6261                         if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
6262                             o->op_private |= OPpENTERSUB_DB;
6263                     }
6264                     else {
6265                         delete_op = 1;
6266                         if (ckWARN(WARN_ASSERTIONS) && !(PL_hints & HINT_ASSERTIONSSEEN)) {
6267                             Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
6268                                         "Impossible to activate assertion call");
6269                         }
6270                     }
6271                 }
6272             }
6273         }
6274     }
6275     else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6276         if (o2->op_type == OP_CONST)
6277             o2->op_private &= ~OPpCONST_STRICT;
6278         else if (o2->op_type == OP_LIST) {
6279             OP *o = ((UNOP*)o2)->op_first->op_sibling;
6280             if (o && o->op_type == OP_CONST)
6281                 o->op_private &= ~OPpCONST_STRICT;
6282         }
6283     }
6284     o->op_private |= (PL_hints & HINT_STRICT_REFS);
6285     if (PERLDB_SUB && PL_curstash != PL_debstash)
6286         o->op_private |= OPpENTERSUB_DB;
6287     while (o2 != cvop) {
6288         if (proto) {
6289             switch (*proto) {
6290             case '\0':
6291                 return too_many_arguments(o, gv_ename(namegv));
6292             case ';':
6293                 optional = 1;
6294                 proto++;
6295                 continue;
6296             case '$':
6297                 proto++;
6298                 arg++;
6299                 scalar(o2);
6300                 break;
6301             case '%':
6302             case '@':
6303                 list(o2);
6304                 arg++;
6305                 break;
6306             case '&':
6307                 proto++;
6308                 arg++;
6309                 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6310                     bad_type(arg,
6311                         arg == 1 ? "block or sub {}" : "sub {}",
6312                         gv_ename(namegv), o2);
6313                 break;
6314             case '*':
6315                 /* '*' allows any scalar type, including bareword */
6316                 proto++;
6317                 arg++;
6318                 if (o2->op_type == OP_RV2GV)
6319                     goto wrapref;       /* autoconvert GLOB -> GLOBref */
6320                 else if (o2->op_type == OP_CONST)
6321                     o2->op_private &= ~OPpCONST_STRICT;
6322                 else if (o2->op_type == OP_ENTERSUB) {
6323                     /* accidental subroutine, revert to bareword */
6324                     OP *gvop = ((UNOP*)o2)->op_first;
6325                     if (gvop && gvop->op_type == OP_NULL) {
6326                         gvop = ((UNOP*)gvop)->op_first;
6327                         if (gvop) {
6328                             for (; gvop->op_sibling; gvop = gvop->op_sibling)
6329                                 ;
6330                             if (gvop &&
6331                                 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6332                                 (gvop = ((UNOP*)gvop)->op_first) &&
6333                                 gvop->op_type == OP_GV)
6334                             {
6335                                 GV *gv = cGVOPx_gv(gvop);
6336                                 OP *sibling = o2->op_sibling;
6337                                 SV *n = newSVpvn("",0);
6338                                 op_free(o2);
6339                                 gv_fullname4(n, gv, "", FALSE);
6340                                 o2 = newSVOP(OP_CONST, 0, n);
6341                                 prev->op_sibling = o2;
6342                                 o2->op_sibling = sibling;
6343                             }
6344                         }
6345                     }
6346                 }
6347                 scalar(o2);
6348                 break;
6349             case '[': case ']':
6350                  goto oops;
6351                  break;
6352             case '\\':
6353                 proto++;
6354                 arg++;
6355             again:
6356                 switch (*proto++) {
6357                 case '[':
6358                      if (contextclass++ == 0) {
6359                           e = strchr(proto, ']');
6360                           if (!e || e == proto)
6361                                goto oops;
6362                      }
6363                      else
6364                           goto oops;
6365                      goto again;
6366                      break;
6367                 case ']':
6368                      if (contextclass) {
6369                          char *p = proto;
6370                          const char s = *p;
6371                          contextclass = 0;
6372                          *p = '\0';
6373                          while (*--p != '[');
6374                          bad_type(arg, Perl_form(aTHX_ "one of %s", p),
6375                                  gv_ename(namegv), o2);
6376                          *proto = s;
6377                      } else
6378                           goto oops;
6379                      break;
6380                 case '*':
6381                      if (o2->op_type == OP_RV2GV)
6382                           goto wrapref;
6383                      if (!contextclass)
6384                           bad_type(arg, "symbol", gv_ename(namegv), o2);
6385                      break;
6386                 case '&':
6387                      if (o2->op_type == OP_ENTERSUB)
6388                           goto wrapref;
6389                      if (!contextclass)
6390                           bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6391                      break;
6392                 case '$':
6393                     if (o2->op_type == OP_RV2SV ||
6394                         o2->op_type == OP_PADSV ||
6395                         o2->op_type == OP_HELEM ||
6396                         o2->op_type == OP_AELEM ||
6397                         o2->op_type == OP_THREADSV)
6398                          goto wrapref;
6399                     if (!contextclass)
6400                         bad_type(arg, "scalar", gv_ename(namegv), o2);
6401                      break;
6402                 case '@':
6403                     if (o2->op_type == OP_RV2AV ||
6404                         o2->op_type == OP_PADAV)
6405                          goto wrapref;
6406                     if (!contextclass)
6407                         bad_type(arg, "array", gv_ename(namegv), o2);
6408                     break;
6409                 case '%':
6410                     if (o2->op_type == OP_RV2HV ||
6411                         o2->op_type == OP_PADHV)
6412                          goto wrapref;
6413                     if (!contextclass)
6414                          bad_type(arg, "hash", gv_ename(namegv), o2);
6415                     break;
6416                 wrapref:
6417                     {
6418                         OP* kid = o2;
6419                         OP* sib = kid->op_sibling;
6420                         kid->op_sibling = 0;
6421                         o2 = newUNOP(OP_REFGEN, 0, kid);
6422                         o2->op_sibling = sib;
6423                         prev->op_sibling = o2;
6424                     }
6425                     if (contextclass && e) {
6426                          proto = e + 1;
6427                          contextclass = 0;
6428                     }
6429                     break;
6430                 default: goto oops;
6431                 }
6432                 if (contextclass)
6433                      goto again;
6434                 break;
6435             case ' ':
6436                 proto++;
6437                 continue;
6438             default:
6439               oops:
6440                 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
6441                            gv_ename(namegv), cv);
6442             }
6443         }
6444         else
6445             list(o2);
6446         mod(o2, OP_ENTERSUB);
6447         prev = o2;
6448         o2 = o2->op_sibling;
6449     }
6450     if (proto && !optional &&
6451           (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6452         return too_few_arguments(o, gv_ename(namegv));
6453     if(delete_op) {
6454         op_free(o);
6455         o=newSVOP(OP_CONST, 0, newSViv(0));
6456     }
6457     return o;
6458 }
6459
6460 OP *
6461 Perl_ck_svconst(pTHX_ OP *o)
6462 {
6463     SvREADONLY_on(cSVOPo->op_sv);
6464     return o;
6465 }
6466
6467 OP *
6468 Perl_ck_trunc(pTHX_ OP *o)
6469 {
6470     if (o->op_flags & OPf_KIDS) {
6471         SVOP *kid = (SVOP*)cUNOPo->op_first;
6472
6473         if (kid->op_type == OP_NULL)
6474             kid = (SVOP*)kid->op_sibling;
6475         if (kid && kid->op_type == OP_CONST &&
6476             (kid->op_private & OPpCONST_BARE))
6477         {
6478             o->op_flags |= OPf_SPECIAL;
6479             kid->op_private &= ~OPpCONST_STRICT;
6480         }
6481     }
6482     return ck_fun(o);
6483 }
6484
6485 OP *
6486 Perl_ck_unpack(pTHX_ OP *o)
6487 {
6488     OP *kid = cLISTOPo->op_first;
6489     if (kid->op_sibling) {
6490         kid = kid->op_sibling;
6491         if (!kid->op_sibling)
6492             kid->op_sibling = newDEFSVOP();
6493     }
6494     return ck_fun(o);
6495 }
6496
6497 OP *
6498 Perl_ck_substr(pTHX_ OP *o)
6499 {
6500     o = ck_fun(o);
6501     if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6502         OP *kid = cLISTOPo->op_first;
6503
6504         if (kid->op_type == OP_NULL)
6505             kid = kid->op_sibling;
6506         if (kid)
6507             kid->op_flags |= OPf_MOD;
6508
6509     }
6510     return o;
6511 }
6512
6513 /* A peephole optimizer.  We visit the ops in the order they're to execute.
6514  * See the comments at the top of this file for more details about when
6515  * peep() is called */
6516
6517 void
6518 Perl_peep(pTHX_ register OP *o)
6519 {
6520     dVAR;
6521     register OP* oldop = 0;
6522
6523     if (!o || o->op_opt)
6524         return;
6525     ENTER;
6526     SAVEOP();
6527     SAVEVPTR(PL_curcop);
6528     for (; o; o = o->op_next) {
6529         if (o->op_opt)
6530             break;
6531         PL_op = o;
6532         switch (o->op_type) {
6533         case OP_SETSTATE:
6534         case OP_NEXTSTATE:
6535         case OP_DBSTATE:
6536             PL_curcop = ((COP*)o);              /* for warnings */
6537             o->op_opt = 1;
6538             break;
6539
6540         case OP_CONST:
6541             if (cSVOPo->op_private & OPpCONST_STRICT)
6542                 no_bareword_allowed(o);
6543 #ifdef USE_ITHREADS
6544         case OP_METHOD_NAMED:
6545             /* Relocate sv to the pad for thread safety.
6546              * Despite being a "constant", the SV is written to,
6547              * for reference counts, sv_upgrade() etc. */
6548             if (cSVOP->op_sv) {
6549                 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6550                 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
6551                     /* If op_sv is already a PADTMP then it is being used by
6552                      * some pad, so make a copy. */
6553                     sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
6554                     SvREADONLY_on(PAD_SVl(ix));
6555                     SvREFCNT_dec(cSVOPo->op_sv);
6556                 }
6557                 else {
6558                     SvREFCNT_dec(PAD_SVl(ix));
6559                     SvPADTMP_on(cSVOPo->op_sv);
6560                     PAD_SETSV(ix, cSVOPo->op_sv);
6561                     /* XXX I don't know how this isn't readonly already. */
6562                     SvREADONLY_on(PAD_SVl(ix));
6563                 }
6564                 cSVOPo->op_sv = Nullsv;
6565                 o->op_targ = ix;
6566             }
6567 #endif
6568             o->op_opt = 1;
6569             break;
6570
6571         case OP_CONCAT:
6572             if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6573                 if (o->op_next->op_private & OPpTARGET_MY) {
6574                     if (o->op_flags & OPf_STACKED) /* chained concats */
6575                         goto ignore_optimization;
6576                     else {
6577                         /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6578                         o->op_targ = o->op_next->op_targ;
6579                         o->op_next->op_targ = 0;
6580                         o->op_private |= OPpTARGET_MY;
6581                     }
6582                 }
6583                 op_null(o->op_next);
6584             }
6585           ignore_optimization:
6586             o->op_opt = 1;
6587             break;
6588         case OP_STUB:
6589             if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6590                 o->op_opt = 1;
6591                 break; /* Scalar stub must produce undef.  List stub is noop */
6592             }
6593             goto nothin;
6594         case OP_NULL:
6595             if (o->op_targ == OP_NEXTSTATE
6596                 || o->op_targ == OP_DBSTATE
6597                 || o->op_targ == OP_SETSTATE)
6598             {
6599                 PL_curcop = ((COP*)o);
6600             }
6601             /* XXX: We avoid setting op_seq here to prevent later calls
6602                to peep() from mistakenly concluding that optimisation
6603                has already occurred. This doesn't fix the real problem,
6604                though (See 20010220.007). AMS 20010719 */
6605             /* op_seq functionality is now replaced by op_opt */
6606             if (oldop && o->op_next) {
6607                 oldop->op_next = o->op_next;
6608                 continue;
6609             }
6610             break;
6611         case OP_SCALAR:
6612         case OP_LINESEQ:
6613         case OP_SCOPE:
6614           nothin:
6615             if (oldop && o->op_next) {
6616                 oldop->op_next = o->op_next;
6617                 continue;
6618             }
6619             o->op_opt = 1;
6620             break;
6621
6622         case OP_PADAV:
6623         case OP_GV:
6624             if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
6625                 OP* pop = (o->op_type == OP_PADAV) ?
6626                             o->op_next : o->op_next->op_next;
6627                 IV i;
6628                 if (pop && pop->op_type == OP_CONST &&
6629                     ((PL_op = pop->op_next)) &&
6630                     pop->op_next->op_type == OP_AELEM &&
6631                     !(pop->op_next->op_private &
6632                       (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6633                     (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
6634                                 <= 255 &&
6635                     i >= 0)
6636                 {
6637                     GV *gv;
6638                     if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
6639                         no_bareword_allowed(pop);
6640                     if (o->op_type == OP_GV)
6641                         op_null(o->op_next);
6642                     op_null(pop->op_next);
6643                     op_null(pop);
6644                     o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6645                     o->op_next = pop->op_next->op_next;
6646                     o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6647                     o->op_private = (U8)i;
6648                     if (o->op_type == OP_GV) {
6649                         gv = cGVOPo_gv;
6650                         GvAVn(gv);
6651                     }
6652                     else
6653                         o->op_flags |= OPf_SPECIAL;
6654                     o->op_type = OP_AELEMFAST;
6655                 }
6656                 o->op_opt = 1;
6657                 break;
6658             }
6659
6660             if (o->op_next->op_type == OP_RV2SV) {
6661                 if (!(o->op_next->op_private & OPpDEREF)) {
6662                     op_null(o->op_next);
6663                     o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6664                                                                | OPpOUR_INTRO);
6665                     o->op_next = o->op_next->op_next;
6666                     o->op_type = OP_GVSV;
6667                     o->op_ppaddr = PL_ppaddr[OP_GVSV];
6668                 }
6669             }
6670             else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6671                 GV *gv = cGVOPo_gv;
6672                 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
6673                     /* XXX could check prototype here instead of just carping */
6674                     SV *sv = sv_newmortal();
6675                     gv_efullname3(sv, gv, Nullch);
6676                     Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
6677                                 "%"SVf"() called too early to check prototype",
6678                                 sv);
6679                 }
6680             }
6681             else if (o->op_next->op_type == OP_READLINE
6682                     && o->op_next->op_next->op_type == OP_CONCAT
6683                     && (o->op_next->op_next->op_flags & OPf_STACKED))
6684             {
6685                 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
6686                 o->op_type   = OP_RCATLINE;
6687                 o->op_flags |= OPf_STACKED;
6688                 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
6689                 op_null(o->op_next->op_next);
6690                 op_null(o->op_next);
6691             }
6692
6693             o->op_opt = 1;
6694             break;
6695
6696         case OP_MAPWHILE:
6697         case OP_GREPWHILE:
6698         case OP_AND:
6699         case OP_OR:
6700         case OP_DOR:
6701         case OP_ANDASSIGN:
6702         case OP_ORASSIGN:
6703         case OP_DORASSIGN:
6704         case OP_COND_EXPR:
6705         case OP_RANGE:
6706             o->op_opt = 1;
6707             while (cLOGOP->op_other->op_type == OP_NULL)
6708                 cLOGOP->op_other = cLOGOP->op_other->op_next;
6709             peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
6710             break;
6711
6712         case OP_ENTERLOOP:
6713         case OP_ENTERITER:
6714             o->op_opt = 1;
6715             while (cLOOP->op_redoop->op_type == OP_NULL)
6716                 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6717             peep(cLOOP->op_redoop);
6718             while (cLOOP->op_nextop->op_type == OP_NULL)
6719                 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6720             peep(cLOOP->op_nextop);
6721             while (cLOOP->op_lastop->op_type == OP_NULL)
6722                 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6723             peep(cLOOP->op_lastop);
6724             break;
6725
6726         case OP_QR:
6727         case OP_MATCH:
6728         case OP_SUBST:
6729             o->op_opt = 1;
6730             while (cPMOP->op_pmreplstart &&
6731                    cPMOP->op_pmreplstart->op_type == OP_NULL)
6732                 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6733             peep(cPMOP->op_pmreplstart);
6734             break;
6735
6736         case OP_EXEC:
6737             o->op_opt = 1;
6738             if (ckWARN(WARN_SYNTAX) && o->op_next
6739                 && o->op_next->op_type == OP_NEXTSTATE) {
6740                 if (o->op_next->op_sibling &&
6741                         o->op_next->op_sibling->op_type != OP_EXIT &&
6742                         o->op_next->op_sibling->op_type != OP_WARN &&
6743                         o->op_next->op_sibling->op_type != OP_DIE) {
6744                     const line_t oldline = CopLINE(PL_curcop);
6745
6746                     CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6747                     Perl_warner(aTHX_ packWARN(WARN_EXEC),
6748                                 "Statement unlikely to be reached");
6749                     Perl_warner(aTHX_ packWARN(WARN_EXEC),
6750                                 "\t(Maybe you meant system() when you said exec()?)\n");
6751                     CopLINE_set(PL_curcop, oldline);
6752                 }
6753             }
6754             break;
6755
6756         case OP_HELEM: {
6757             UNOP *rop;
6758             SV *lexname;
6759             GV **fields;
6760             SV **svp, *sv;
6761             char *key = NULL;
6762             STRLEN keylen;
6763
6764             o->op_opt = 1;
6765
6766             if (((BINOP*)o)->op_last->op_type != OP_CONST)
6767                 break;
6768
6769             /* Make the CONST have a shared SV */
6770             svp = cSVOPx_svp(((BINOP*)o)->op_last);
6771             if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
6772                 key = SvPV(sv, keylen);
6773                 lexname = newSVpvn_share(key,
6774                                          SvUTF8(sv) ? -(I32)keylen : keylen,
6775                                          0);
6776                 SvREFCNT_dec(sv);
6777                 *svp = lexname;
6778             }
6779
6780             if ((o->op_private & (OPpLVAL_INTRO)))
6781                 break;
6782
6783             rop = (UNOP*)((BINOP*)o)->op_first;
6784             if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6785                 break;
6786             lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
6787             if (!(SvFLAGS(lexname) & SVpad_TYPED))
6788                 break;
6789             fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6790             if (!fields || !GvHV(*fields))
6791                 break;
6792             key = SvPV(*svp, keylen);
6793             if (!hv_fetch(GvHV(*fields), key,
6794                         SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
6795             {
6796                 Perl_croak(aTHX_ "No such class field \"%s\" "
6797                            "in variable %s of type %s",
6798                       key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
6799             }
6800
6801             break;
6802         }
6803
6804         case OP_HSLICE: {
6805             UNOP *rop;
6806             SV *lexname;
6807             GV **fields;
6808             SV **svp;
6809             char *key;
6810             STRLEN keylen;
6811             SVOP *first_key_op, *key_op;
6812
6813             if ((o->op_private & (OPpLVAL_INTRO))
6814                 /* I bet there's always a pushmark... */
6815                 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
6816                 /* hmmm, no optimization if list contains only one key. */
6817                 break;
6818             rop = (UNOP*)((LISTOP*)o)->op_last;
6819             if (rop->op_type != OP_RV2HV)
6820                 break;
6821             if (rop->op_first->op_type == OP_PADSV)
6822                 /* @$hash{qw(keys here)} */
6823                 rop = (UNOP*)rop->op_first;
6824             else {
6825                 /* @{$hash}{qw(keys here)} */
6826                 if (rop->op_first->op_type == OP_SCOPE
6827                     && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
6828                 {
6829                     rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
6830                 }
6831                 else
6832                     break;
6833             }
6834
6835             lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
6836             if (!(SvFLAGS(lexname) & SVpad_TYPED))
6837                 break;
6838             fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6839             if (!fields || !GvHV(*fields))
6840                 break;
6841             /* Again guessing that the pushmark can be jumped over.... */
6842             first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
6843                 ->op_first->op_sibling;
6844             for (key_op = first_key_op; key_op;
6845                  key_op = (SVOP*)key_op->op_sibling) {
6846                 if (key_op->op_type != OP_CONST)
6847                     continue;
6848                 svp = cSVOPx_svp(key_op);
6849                 key = SvPV(*svp, keylen);
6850                 if (!hv_fetch(GvHV(*fields), key,
6851                             SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
6852                 {
6853                     Perl_croak(aTHX_ "No such class field \"%s\" "
6854                                "in variable %s of type %s",
6855                           key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
6856                 }
6857             }
6858             break;
6859         }
6860
6861         case OP_SORT: {
6862             /* will point to RV2AV or PADAV op on LHS/RHS of assign */
6863             OP *oleft, *oright;
6864             OP *o2;
6865
6866             /* check that RHS of sort is a single plain array */
6867             oright = cUNOPo->op_first;
6868             if (!oright || oright->op_type != OP_PUSHMARK)
6869                 break;
6870
6871             /* reverse sort ... can be optimised.  */
6872             if (!cUNOPo->op_sibling) {
6873                 /* Nothing follows us on the list. */
6874                 OP *reverse = o->op_next;
6875
6876                 if (reverse->op_type == OP_REVERSE &&
6877                     (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
6878                     OP *pushmark = cUNOPx(reverse)->op_first;
6879                     if (pushmark && (pushmark->op_type == OP_PUSHMARK)
6880                         && (cUNOPx(pushmark)->op_sibling == o)) {
6881                         /* reverse -> pushmark -> sort */
6882                         o->op_private |= OPpSORT_REVERSE;
6883                         op_null(reverse);
6884                         pushmark->op_next = oright->op_next;
6885                         op_null(oright);
6886                     }
6887                 }
6888             }
6889
6890             /* make @a = sort @a act in-place */
6891
6892             o->op_opt = 1;
6893
6894             oright = cUNOPx(oright)->op_sibling;
6895             if (!oright)
6896                 break;
6897             if (oright->op_type == OP_NULL) { /* skip sort block/sub */
6898                 oright = cUNOPx(oright)->op_sibling;
6899             }
6900
6901             if (!oright ||
6902                 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
6903                 || oright->op_next != o
6904                 || (oright->op_private & OPpLVAL_INTRO)
6905             )
6906                 break;
6907
6908             /* o2 follows the chain of op_nexts through the LHS of the
6909              * assign (if any) to the aassign op itself */
6910             o2 = o->op_next;
6911             if (!o2 || o2->op_type != OP_NULL)
6912                 break;
6913             o2 = o2->op_next;
6914             if (!o2 || o2->op_type != OP_PUSHMARK)
6915                 break;
6916             o2 = o2->op_next;
6917             if (o2 && o2->op_type == OP_GV)
6918                 o2 = o2->op_next;
6919             if (!o2
6920                 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
6921                 || (o2->op_private & OPpLVAL_INTRO)
6922             )
6923                 break;
6924             oleft = o2;
6925             o2 = o2->op_next;
6926             if (!o2 || o2->op_type != OP_NULL)
6927                 break;
6928             o2 = o2->op_next;
6929             if (!o2 || o2->op_type != OP_AASSIGN
6930                     || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
6931                 break;
6932
6933             /* check that the sort is the first arg on RHS of assign */
6934
6935             o2 = cUNOPx(o2)->op_first;
6936             if (!o2 || o2->op_type != OP_NULL)
6937                 break;
6938             o2 = cUNOPx(o2)->op_first;
6939             if (!o2 || o2->op_type != OP_PUSHMARK)
6940                 break;
6941             if (o2->op_sibling != o)
6942                 break;
6943
6944             /* check the array is the same on both sides */
6945             if (oleft->op_type == OP_RV2AV) {
6946                 if (oright->op_type != OP_RV2AV
6947                     || !cUNOPx(oright)->op_first
6948                     || cUNOPx(oright)->op_first->op_type != OP_GV
6949                     ||  cGVOPx_gv(cUNOPx(oleft)->op_first) !=
6950                         cGVOPx_gv(cUNOPx(oright)->op_first)
6951                 )
6952                     break;
6953             }
6954             else if (oright->op_type != OP_PADAV
6955                 || oright->op_targ != oleft->op_targ
6956             )
6957                 break;
6958
6959             /* transfer MODishness etc from LHS arg to RHS arg */
6960             oright->op_flags = oleft->op_flags;
6961             o->op_private |= OPpSORT_INPLACE;
6962
6963             /* excise push->gv->rv2av->null->aassign */
6964             o2 = o->op_next->op_next;
6965             op_null(o2); /* PUSHMARK */
6966             o2 = o2->op_next;
6967             if (o2->op_type == OP_GV) {
6968                 op_null(o2); /* GV */
6969                 o2 = o2->op_next;
6970             }
6971             op_null(o2); /* RV2AV or PADAV */
6972             o2 = o2->op_next->op_next;
6973             op_null(o2); /* AASSIGN */
6974
6975             o->op_next = o2->op_next;
6976
6977             break;
6978         }
6979
6980         case OP_REVERSE: {
6981             OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
6982             OP *gvop = NULL;
6983             LISTOP *enter, *exlist;
6984             o->op_opt = 1;
6985
6986             enter = (LISTOP *) o->op_next;
6987             if (!enter)
6988                 break;
6989             if (enter->op_type == OP_NULL) {
6990                 enter = (LISTOP *) enter->op_next;
6991                 if (!enter)
6992                     break;
6993             }
6994             /* for $a (...) will have OP_GV then OP_RV2GV here.
6995                for (...) just has an OP_GV.  */
6996             if (enter->op_type == OP_GV) {
6997                 gvop = (OP *) enter;
6998                 enter = (LISTOP *) enter->op_next;
6999                 if (!enter)
7000                     break;
7001                 if (enter->op_type == OP_RV2GV) {
7002                   enter = (LISTOP *) enter->op_next;
7003                   if (!enter)
7004                     break;
7005                 }
7006             }
7007
7008             if (enter->op_type != OP_ENTERITER)
7009                 break;
7010
7011             iter = enter->op_next;
7012             if (!iter || iter->op_type != OP_ITER)
7013                 break;
7014
7015             expushmark = enter->op_first;
7016             if (!expushmark || expushmark->op_type != OP_NULL
7017                 || expushmark->op_targ != OP_PUSHMARK)
7018                 break;
7019
7020             exlist = (LISTOP *) expushmark->op_sibling;
7021             if (!exlist || exlist->op_type != OP_NULL
7022                 || exlist->op_targ != OP_LIST)
7023                 break;
7024
7025             if (exlist->op_last != o) {
7026                 /* Mmm. Was expecting to point back to this op.  */
7027                 break;
7028             }
7029             theirmark = exlist->op_first;
7030             if (!theirmark || theirmark->op_type != OP_PUSHMARK)
7031                 break;
7032
7033             if (theirmark->op_sibling != o) {
7034                 /* There's something between the mark and the reverse, eg
7035                    for (1, reverse (...))
7036                    so no go.  */
7037                 break;
7038             }
7039
7040             ourmark = ((LISTOP *)o)->op_first;
7041             if (!ourmark || ourmark->op_type != OP_PUSHMARK)
7042                 break;
7043
7044             ourlast = ((LISTOP *)o)->op_last;
7045             if (!ourlast || ourlast->op_next != o)
7046                 break;
7047
7048             rv2av = ourmark->op_sibling;
7049             if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
7050                 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
7051                 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
7052                 /* We're just reversing a single array.  */
7053                 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
7054                 enter->op_flags |= OPf_STACKED;
7055             }
7056
7057             /* We don't have control over who points to theirmark, so sacrifice
7058                ours.  */
7059             theirmark->op_next = ourmark->op_next;
7060             theirmark->op_flags = ourmark->op_flags;
7061             ourlast->op_next = gvop ? gvop : (OP *) enter;
7062             op_null(ourmark);
7063             op_null(o);
7064             enter->op_private |= OPpITER_REVERSED;
7065             iter->op_private |= OPpITER_REVERSED;
7066
7067             break;
7068         }
7069
7070         default:
7071             o->op_opt = 1;
7072             break;
7073         }
7074         oldop = o;
7075     }
7076     LEAVE;
7077 }
7078
7079 char*
7080 Perl_custom_op_name(pTHX_ const OP* o)
7081 {
7082     const IV index = PTR2IV(o->op_ppaddr);
7083     SV* keysv;
7084     HE* he;
7085
7086     if (!PL_custom_op_names) /* This probably shouldn't happen */
7087         return (char *)PL_op_name[OP_CUSTOM];
7088
7089     keysv = sv_2mortal(newSViv(index));
7090
7091     he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
7092     if (!he)
7093         return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
7094
7095     return SvPV_nolen(HeVAL(he));
7096 }
7097
7098 char*
7099 Perl_custom_op_desc(pTHX_ const OP* o)
7100 {
7101     const IV index = PTR2IV(o->op_ppaddr);
7102     SV* keysv;
7103     HE* he;
7104
7105     if (!PL_custom_op_descs)
7106         return (char *)PL_op_desc[OP_CUSTOM];
7107
7108     keysv = sv_2mortal(newSViv(index));
7109
7110     he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
7111     if (!he)
7112         return (char *)PL_op_desc[OP_CUSTOM];
7113
7114     return SvPV_nolen(HeVAL(he));
7115 }
7116
7117 #include "XSUB.h"
7118
7119 /* Efficient sub that returns a constant scalar value. */
7120 static void
7121 const_sv_xsub(pTHX_ CV* cv)
7122 {
7123     dXSARGS;
7124     if (items != 0) {
7125 #if 0
7126         Perl_croak(aTHX_ "usage: %s::%s()",
7127                    HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
7128 #endif
7129     }
7130     EXTEND(sp, 1);
7131     ST(0) = (SV*)XSANY.any_ptr;
7132     XSRETURN(1);
7133 }
7134
7135 /*
7136  * Local variables:
7137  * c-indentation-style: bsd
7138  * c-basic-offset: 4
7139  * indent-tabs-mode: t
7140  * End:
7141  *
7142  * ex: set ts=8 sts=4 sw=4 noet:
7143  */