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