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