op.c

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