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