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 * const tstr = ((SVOP*)expr)->op_sv;
2377     SV * const 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         if (!aver)
3061             idop->op_private |= OPpCONST_NOVER;
3062     }
3063     else {
3064         SV *meth;
3065
3066         /* Make copy of idop so we don't free it twice */
3067         pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3068
3069         /* Fake up a method call to import/unimport */
3070         meth = aver
3071             ? newSVpvn_share("import",6, 0) : newSVpvn_share("unimport", 8, 0);
3072         imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3073                        append_elem(OP_LIST,
3074                                    prepend_elem(OP_LIST, pack, list(arg)),
3075                                    newSVOP(OP_METHOD_NAMED, 0, meth)));
3076     }
3077
3078     /* Fake up the BEGIN {}, which does its thing immediately. */
3079     newATTRSUB(floor,
3080         newSVOP(OP_CONST, 0, newSVpvn_share("BEGIN", 5, 0)),
3081         Nullop,
3082         Nullop,
3083         append_elem(OP_LINESEQ,
3084             append_elem(OP_LINESEQ,
3085                 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, idop)),
3086                 newSTATEOP(0, Nullch, veop)),
3087             newSTATEOP(0, Nullch, imop) ));
3088
3089     /* The "did you use incorrect case?" warning used to be here.
3090      * The problem is that on case-insensitive filesystems one
3091      * might get false positives for "use" (and "require"):
3092      * "use Strict" or "require CARP" will work.  This causes
3093      * portability problems for the script: in case-strict
3094      * filesystems the script will stop working.
3095      *
3096      * The "incorrect case" warning checked whether "use Foo"
3097      * imported "Foo" to your namespace, but that is wrong, too:
3098      * there is no requirement nor promise in the language that
3099      * a Foo.pm should or would contain anything in package "Foo".
3100      *
3101      * There is very little Configure-wise that can be done, either:
3102      * the case-sensitivity of the build filesystem of Perl does not
3103      * help in guessing the case-sensitivity of the runtime environment.
3104      */
3105
3106     PL_hints |= HINT_BLOCK_SCOPE;
3107     PL_copline = NOLINE;
3108     PL_expect = XSTATE;
3109     PL_cop_seqmax++; /* Purely for B::*'s benefit */
3110 }
3111
3112 /*
3113 =head1 Embedding Functions
3114
3115 =for apidoc load_module
3116
3117 Loads the module whose name is pointed to by the string part of name.
3118 Note that the actual module name, not its filename, should be given.
3119 Eg, "Foo::Bar" instead of "Foo/Bar.pm".  flags can be any of
3120 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3121 (or 0 for no flags). ver, if specified, provides version semantics
3122 similar to C<use Foo::Bar VERSION>.  The optional trailing SV*
3123 arguments can be used to specify arguments to the module's import()
3124 method, similar to C<use Foo::Bar VERSION LIST>.
3125
3126 =cut */
3127
3128 void
3129 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3130 {
3131     va_list args;
3132     va_start(args, ver);
3133     vload_module(flags, name, ver, &args);
3134     va_end(args);
3135 }
3136
3137 #ifdef PERL_IMPLICIT_CONTEXT
3138 void
3139 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3140 {
3141     dTHX;
3142     va_list args;
3143     va_start(args, ver);
3144     vload_module(flags, name, ver, &args);
3145     va_end(args);
3146 }
3147 #endif
3148
3149 void
3150 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3151 {
3152     OP *modname, *veop, *imop;
3153
3154     modname = newSVOP(OP_CONST, 0, name);
3155     modname->op_private |= OPpCONST_BARE;
3156     if (ver) {
3157         veop = newSVOP(OP_CONST, 0, ver);
3158     }
3159     else
3160         veop = Nullop;
3161     if (flags & PERL_LOADMOD_NOIMPORT) {
3162         imop = sawparens(newNULLLIST());
3163     }
3164     else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3165         imop = va_arg(*args, OP*);
3166     }
3167     else {
3168         SV *sv;
3169         imop = Nullop;
3170         sv = va_arg(*args, SV*);
3171         while (sv) {
3172             imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3173             sv = va_arg(*args, SV*);
3174         }
3175     }
3176     {
3177         const line_t ocopline = PL_copline;
3178         COP * const ocurcop = PL_curcop;
3179         const int oexpect = PL_expect;
3180
3181         utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3182                 veop, modname, imop);
3183         PL_expect = oexpect;
3184         PL_copline = ocopline;
3185         PL_curcop = ocurcop;
3186     }
3187 }
3188
3189 OP *
3190 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
3191 {
3192     OP *doop;
3193     GV *gv = Nullgv;
3194
3195     if (!force_builtin) {
3196         gv = gv_fetchpv("do", FALSE, SVt_PVCV);
3197         if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
3198             GV **gvp = (GV**)hv_fetch(PL_globalstash, "do", 2, FALSE);
3199             if (gvp) gv = *gvp; else gv = Nullgv;
3200         }
3201     }
3202
3203     if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3204         doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3205                                append_elem(OP_LIST, term,
3206                                            scalar(newUNOP(OP_RV2CV, 0,
3207                                                           newGVOP(OP_GV, 0,
3208                                                                   gv))))));
3209     }
3210     else {
3211         doop = newUNOP(OP_DOFILE, 0, scalar(term));
3212     }
3213     return doop;
3214 }
3215
3216 OP *
3217 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3218 {
3219     return newBINOP(OP_LSLICE, flags,
3220             list(force_list(subscript)),
3221             list(force_list(listval)) );
3222 }
3223
3224 STATIC I32
3225 S_is_list_assignment(pTHX_ register const OP *o)
3226 {
3227     if (!o)
3228         return TRUE;
3229
3230     if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3231         o = cUNOPo->op_first;
3232
3233     if (o->op_type == OP_COND_EXPR) {
3234         const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
3235         const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3236
3237         if (t && f)
3238             return TRUE;
3239         if (t || f)
3240             yyerror("Assignment to both a list and a scalar");
3241         return FALSE;
3242     }
3243
3244     if (o->op_type == OP_LIST &&
3245         (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR &&
3246         o->op_private & OPpLVAL_INTRO)
3247         return FALSE;
3248
3249     if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3250         o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3251         o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3252         return TRUE;
3253
3254     if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3255         return TRUE;
3256
3257     if (o->op_type == OP_RV2SV)
3258         return FALSE;
3259
3260     return FALSE;
3261 }
3262
3263 OP *
3264 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3265 {
3266     OP *o;
3267
3268     if (optype) {
3269         if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
3270             return newLOGOP(optype, 0,
3271                 mod(scalar(left), optype),
3272                 newUNOP(OP_SASSIGN, 0, scalar(right)));
3273         }
3274         else {
3275             return newBINOP(optype, OPf_STACKED,
3276                 mod(scalar(left), optype), scalar(right));
3277         }
3278     }
3279
3280     if (is_list_assignment(left)) {
3281         OP *curop;
3282
3283         PL_modcount = 0;
3284         /* Grandfathering $[ assignment here.  Bletch.*/
3285         /* Only simple assignments like C<< ($[) = 1 >> are allowed */
3286         PL_eval_start = (left->op_type == OP_CONST) ? right : 0;
3287         left = mod(left, OP_AASSIGN);
3288         if (PL_eval_start)
3289             PL_eval_start = 0;
3290         else if (left->op_type == OP_CONST) {
3291             /* Result of assignment is always 1 (or we'd be dead already) */
3292             return newSVOP(OP_CONST, 0, newSViv(1));
3293         }
3294         /* optimise C<my @x = ()> to C<my @x>, and likewise for hashes */
3295         if ((left->op_type == OP_PADAV || left->op_type == OP_PADHV)
3296                 && right->op_type == OP_STUB
3297                 && (left->op_private & OPpLVAL_INTRO))
3298         {
3299             op_free(right);
3300             left->op_flags &= ~(OPf_REF|OPf_SPECIAL);
3301             return left;
3302         }
3303         curop = list(force_list(left));
3304         o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3305         o->op_private = (U8)(0 | (flags >> 8));
3306
3307         /* PL_generation sorcery:
3308          * an assignment like ($a,$b) = ($c,$d) is easier than
3309          * ($a,$b) = ($c,$a), since there is no need for temporary vars.
3310          * To detect whether there are common vars, the global var
3311          * PL_generation is incremented for each assign op we compile.
3312          * Then, while compiling the assign op, we run through all the
3313          * variables on both sides of the assignment, setting a spare slot
3314          * in each of them to PL_generation. If any of them already have
3315          * that value, we know we've got commonality.  We could use a
3316          * single bit marker, but then we'd have to make 2 passes, first
3317          * to clear the flag, then to test and set it.  To find somewhere
3318          * to store these values, evil chicanery is done with SvCUR().
3319          */
3320
3321         if (!(left->op_private & OPpLVAL_INTRO)) {
3322             OP *lastop = o;
3323             PL_generation++;
3324             for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3325                 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3326                     if (curop->op_type == OP_GV) {
3327                         GV *gv = cGVOPx_gv(curop);
3328                         if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3329                             break;
3330                         SvCUR_set(gv, PL_generation);
3331                     }
3332                     else if (curop->op_type == OP_PADSV ||
3333                              curop->op_type == OP_PADAV ||
3334                              curop->op_type == OP_PADHV ||
3335                              curop->op_type == OP_PADANY)
3336                     {
3337                         if (PAD_COMPNAME_GEN(curop->op_targ)
3338                                                     == (STRLEN)PL_generation)
3339                             break;
3340                         PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
3341
3342                     }
3343                     else if (curop->op_type == OP_RV2CV)
3344                         break;
3345                     else if (curop->op_type == OP_RV2SV ||
3346                              curop->op_type == OP_RV2AV ||
3347                              curop->op_type == OP_RV2HV ||
3348                              curop->op_type == OP_RV2GV) {
3349                         if (lastop->op_type != OP_GV)   /* funny deref? */
3350                             break;
3351                     }
3352                     else if (curop->op_type == OP_PUSHRE) {
3353                         if (((PMOP*)curop)->op_pmreplroot) {
3354 #ifdef USE_ITHREADS
3355                             GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET,
3356                                         ((PMOP*)curop)->op_pmreplroot));
3357 #else
3358                             GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3359 #endif
3360                             if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3361                                 break;
3362                             SvCUR_set(gv, PL_generation);
3363                         }
3364                     }
3365                     else
3366                         break;
3367                 }
3368                 lastop = curop;
3369             }
3370             if (curop != o)
3371                 o->op_private |= OPpASSIGN_COMMON;
3372         }
3373         if (right && right->op_type == OP_SPLIT) {
3374             OP* tmpop;
3375             if ((tmpop = ((LISTOP*)right)->op_first) &&
3376                 tmpop->op_type == OP_PUSHRE)
3377             {
3378                 PMOP *pm = (PMOP*)tmpop;
3379                 if (left->op_type == OP_RV2AV &&
3380                     !(left->op_private & OPpLVAL_INTRO) &&
3381                     !(o->op_private & OPpASSIGN_COMMON) )
3382                 {
3383                     tmpop = ((UNOP*)left)->op_first;
3384                     if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3385 #ifdef USE_ITHREADS
3386                         pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
3387                         cPADOPx(tmpop)->op_padix = 0;   /* steal it */
3388 #else
3389                         pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3390                         cSVOPx(tmpop)->op_sv = Nullsv;  /* steal it */
3391 #endif
3392                         pm->op_pmflags |= PMf_ONCE;
3393                         tmpop = cUNOPo->op_first;       /* to list (nulled) */
3394                         tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3395                         tmpop->op_sibling = Nullop;     /* don't free split */
3396                         right->op_next = tmpop->op_next;  /* fix starting loc */
3397                         op_free(o);                     /* blow off assign */
3398                         right->op_flags &= ~OPf_WANT;
3399                                 /* "I don't know and I don't care." */
3400                         return right;
3401                     }
3402                 }
3403                 else {
3404                    if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3405                       ((LISTOP*)right)->op_last->op_type == OP_CONST)
3406                     {
3407                         SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3408                         if (SvIVX(sv) == 0)
3409                             sv_setiv(sv, PL_modcount+1);
3410                     }
3411                 }
3412             }
3413         }
3414         return o;
3415     }
3416     if (!right)
3417         right = newOP(OP_UNDEF, 0);
3418     if (right->op_type == OP_READLINE) {
3419         right->op_flags |= OPf_STACKED;
3420         return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3421     }
3422     else {
3423         PL_eval_start = right;  /* Grandfathering $[ assignment here.  Bletch.*/
3424         o = newBINOP(OP_SASSIGN, flags,
3425             scalar(right), mod(scalar(left), OP_SASSIGN) );
3426         if (PL_eval_start)
3427             PL_eval_start = 0;
3428         else {
3429             o = newSVOP(OP_CONST, 0, newSViv(PL_compiling.cop_arybase));
3430         }
3431     }
3432     return o;
3433 }
3434
3435 OP *
3436 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3437 {
3438     dVAR;
3439     const U32 seq = intro_my();
3440     register COP *cop;
3441
3442     NewOp(1101, cop, 1, COP);
3443     if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3444         cop->op_type = OP_DBSTATE;
3445         cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3446     }
3447     else {
3448         cop->op_type = OP_NEXTSTATE;
3449         cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3450     }
3451     cop->op_flags = (U8)flags;
3452     cop->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
3453 #ifdef NATIVE_HINTS
3454     cop->op_private |= NATIVE_HINTS;
3455 #endif
3456     PL_compiling.op_private = cop->op_private;
3457     cop->op_next = (OP*)cop;
3458
3459     if (label) {
3460         cop->cop_label = label;
3461         PL_hints |= HINT_BLOCK_SCOPE;
3462     }
3463     cop->cop_seq = seq;
3464     cop->cop_arybase = PL_curcop->cop_arybase;
3465     if (specialWARN(PL_curcop->cop_warnings))
3466         cop->cop_warnings = PL_curcop->cop_warnings ;
3467     else
3468         cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3469     if (specialCopIO(PL_curcop->cop_io))
3470         cop->cop_io = PL_curcop->cop_io;
3471     else
3472         cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3473
3474
3475     if (PL_copline == NOLINE)
3476         CopLINE_set(cop, CopLINE(PL_curcop));
3477     else {
3478         CopLINE_set(cop, PL_copline);
3479         PL_copline = NOLINE;
3480     }
3481 #ifdef USE_ITHREADS
3482     CopFILE_set(cop, CopFILE(PL_curcop));       /* XXX share in a pvtable? */
3483 #else
3484     CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3485 #endif
3486     CopSTASH_set(cop, PL_curstash);
3487
3488     if (PERLDB_LINE && PL_curstash != PL_debstash) {
3489         SV ** const svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3490         if (svp && *svp != &PL_sv_undef ) {
3491             (void)SvIOK_on(*svp);
3492             SvIV_set(*svp, PTR2IV(cop));
3493         }
3494     }
3495
3496     return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3497 }
3498
3499
3500 OP *
3501 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3502 {
3503     dVAR;
3504     return new_logop(type, flags, &first, &other);
3505 }
3506
3507 STATIC OP *
3508 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3509 {
3510     dVAR;
3511     LOGOP *logop;
3512     OP *o;
3513     OP *first = *firstp;
3514     OP * const other = *otherp;
3515
3516     if (type == OP_XOR)         /* Not short circuit, but here by precedence. */
3517         return newBINOP(type, flags, scalar(first), scalar(other));
3518
3519     scalarboolean(first);
3520     /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3521     if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3522         if (type == OP_AND || type == OP_OR) {
3523             if (type == OP_AND)
3524                 type = OP_OR;
3525             else
3526                 type = OP_AND;
3527             o = first;
3528             first = *firstp = cUNOPo->op_first;
3529             if (o->op_next)
3530                 first->op_next = o->op_next;
3531             cUNOPo->op_first = Nullop;
3532             op_free(o);
3533         }
3534     }
3535     if (first->op_type == OP_CONST) {
3536         if (first->op_private & OPpCONST_STRICT)
3537             no_bareword_allowed(first);
3538         else if ((first->op_private & OPpCONST_BARE) && ckWARN(WARN_BAREWORD))
3539                 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
3540         if ((type == OP_AND &&  SvTRUE(((SVOP*)first)->op_sv)) ||
3541             (type == OP_OR  && !SvTRUE(((SVOP*)first)->op_sv)) ||
3542             (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) {
3543             op_free(first);
3544             *firstp = Nullop;
3545             if (other->op_type == OP_CONST)
3546                 other->op_private |= OPpCONST_SHORTCIRCUIT;
3547             return other;
3548         }
3549         else {
3550             /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
3551             const OP *o2 = other;
3552             if ( ! (o2->op_type == OP_LIST
3553                     && (( o2 = cUNOPx(o2)->op_first))
3554                     && o2->op_type == OP_PUSHMARK
3555                     && (( o2 = o2->op_sibling)) )
3556             )
3557                 o2 = other;
3558             if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
3559                         || o2->op_type == OP_PADHV)
3560                 && o2->op_private & OPpLVAL_INTRO
3561                 && ckWARN(WARN_DEPRECATED))
3562             {
3563                 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
3564                             "Deprecated use of my() in false conditional");
3565             }
3566
3567             op_free(other);
3568             *otherp = Nullop;
3569             if (first->op_type == OP_CONST)
3570                 first->op_private |= OPpCONST_SHORTCIRCUIT;
3571             return first;
3572         }
3573     }
3574     else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
3575         && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
3576     {
3577         const OP * const k1 = ((UNOP*)first)->op_first;
3578         const OP * const k2 = k1->op_sibling;
3579         OPCODE warnop = 0;
3580         switch (first->op_type)
3581         {
3582         case OP_NULL:
3583             if (k2 && k2->op_type == OP_READLINE
3584                   && (k2->op_flags & OPf_STACKED)
3585                   && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3586             {
3587                 warnop = k2->op_type;
3588             }
3589             break;
3590
3591         case OP_SASSIGN:
3592             if (k1->op_type == OP_READDIR
3593                   || k1->op_type == OP_GLOB
3594                   || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3595                   || k1->op_type == OP_EACH)
3596             {
3597                 warnop = ((k1->op_type == OP_NULL)
3598                           ? (OPCODE)k1->op_targ : k1->op_type);
3599             }
3600             break;
3601         }
3602         if (warnop) {
3603             const line_t oldline = CopLINE(PL_curcop);
3604             CopLINE_set(PL_curcop, PL_copline);
3605             Perl_warner(aTHX_ packWARN(WARN_MISC),
3606                  "Value of %s%s can be \"0\"; test with defined()",
3607                  PL_op_desc[warnop],
3608                  ((warnop == OP_READLINE || warnop == OP_GLOB)
3609                   ? " construct" : "() operator"));
3610             CopLINE_set(PL_curcop, oldline);
3611         }
3612     }
3613
3614     if (!other)
3615         return first;
3616
3617     if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
3618         other->op_private |= OPpASSIGN_BACKWARDS;  /* other is an OP_SASSIGN */
3619
3620     NewOp(1101, logop, 1, LOGOP);
3621
3622     logop->op_type = (OPCODE)type;
3623     logop->op_ppaddr = PL_ppaddr[type];
3624     logop->op_first = first;
3625     logop->op_flags = flags | OPf_KIDS;
3626     logop->op_other = LINKLIST(other);
3627     logop->op_private = (U8)(1 | (flags >> 8));
3628
3629     /* establish postfix order */
3630     logop->op_next = LINKLIST(first);
3631     first->op_next = (OP*)logop;
3632     first->op_sibling = other;
3633
3634     CHECKOP(type,logop);
3635
3636     o = newUNOP(OP_NULL, 0, (OP*)logop);
3637     other->op_next = o;
3638
3639     return o;
3640 }
3641
3642 OP *
3643 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3644 {
3645     dVAR;
3646     LOGOP *logop;
3647     OP *start;
3648     OP *o;
3649
3650     if (!falseop)
3651         return newLOGOP(OP_AND, 0, first, trueop);
3652     if (!trueop)
3653         return newLOGOP(OP_OR, 0, first, falseop);
3654
3655     scalarboolean(first);
3656     if (first->op_type == OP_CONST) {
3657         if (first->op_private & OPpCONST_BARE &&
3658             first->op_private & OPpCONST_STRICT) {
3659             no_bareword_allowed(first);
3660         }
3661         if (SvTRUE(((SVOP*)first)->op_sv)) {
3662             op_free(first);
3663             op_free(falseop);
3664             return trueop;
3665         }
3666         else {
3667             op_free(first);
3668             op_free(trueop);
3669             return falseop;
3670         }
3671     }
3672     NewOp(1101, logop, 1, LOGOP);
3673     logop->op_type = OP_COND_EXPR;
3674     logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3675     logop->op_first = first;
3676     logop->op_flags = flags | OPf_KIDS;
3677     logop->op_private = (U8)(1 | (flags >> 8));
3678     logop->op_other = LINKLIST(trueop);
3679     logop->op_next = LINKLIST(falseop);
3680
3681     CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
3682             logop);
3683
3684     /* establish postfix order */
3685     start = LINKLIST(first);
3686     first->op_next = (OP*)logop;
3687
3688     first->op_sibling = trueop;
3689     trueop->op_sibling = falseop;
3690     o = newUNOP(OP_NULL, 0, (OP*)logop);
3691
3692     trueop->op_next = falseop->op_next = o;
3693
3694     o->op_next = start;
3695     return o;
3696 }
3697
3698 OP *
3699 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3700 {
3701     dVAR;
3702     LOGOP *range;
3703     OP *flip;
3704     OP *flop;
3705     OP *leftstart;
3706     OP *o;
3707
3708     NewOp(1101, range, 1, LOGOP);
3709
3710     range->op_type = OP_RANGE;
3711     range->op_ppaddr = PL_ppaddr[OP_RANGE];
3712     range->op_first = left;
3713     range->op_flags = OPf_KIDS;
3714     leftstart = LINKLIST(left);
3715     range->op_other = LINKLIST(right);
3716     range->op_private = (U8)(1 | (flags >> 8));
3717
3718     left->op_sibling = right;
3719
3720     range->op_next = (OP*)range;
3721     flip = newUNOP(OP_FLIP, flags, (OP*)range);
3722     flop = newUNOP(OP_FLOP, 0, flip);
3723     o = newUNOP(OP_NULL, 0, flop);
3724     linklist(flop);
3725     range->op_next = leftstart;
3726
3727     left->op_next = flip;
3728     right->op_next = flop;
3729
3730     range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3731     sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3732     flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3733     sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3734
3735     flip->op_private =  left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3736     flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3737
3738     flip->op_next = o;
3739     if (!flip->op_private || !flop->op_private)
3740         linklist(o);            /* blow off optimizer unless constant */
3741
3742     return o;
3743 }
3744
3745 OP *
3746 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3747 {
3748     OP* listop;
3749     OP* o;
3750     const bool once = block && block->op_flags & OPf_SPECIAL &&
3751       (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3752
3753     PERL_UNUSED_ARG(debuggable);
3754
3755     if (expr) {
3756         if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3757             return block;       /* do {} while 0 does once */
3758         if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3759             || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3760             expr = newUNOP(OP_DEFINED, 0,
3761                 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3762         } else if (expr->op_flags & OPf_KIDS) {
3763             const OP * const k1 = ((UNOP*)expr)->op_first;
3764             const OP * const k2 = k1 ? k1->op_sibling : NULL;
3765             switch (expr->op_type) {
3766               case OP_NULL:
3767                 if (k2 && k2->op_type == OP_READLINE
3768                       && (k2->op_flags & OPf_STACKED)
3769                       && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3770                     expr = newUNOP(OP_DEFINED, 0, expr);
3771                 break;
3772
3773               case OP_SASSIGN:
3774                 if (k1->op_type == OP_READDIR
3775                       || k1->op_type == OP_GLOB
3776                       || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3777                       || k1->op_type == OP_EACH)
3778                     expr = newUNOP(OP_DEFINED, 0, expr);
3779                 break;
3780             }
3781         }
3782     }
3783
3784     /* if block is null, the next append_elem() would put UNSTACK, a scalar
3785      * op, in listop. This is wrong. [perl #27024] */
3786     if (!block)
3787         block = newOP(OP_NULL, 0);
3788     listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3789     o = new_logop(OP_AND, 0, &expr, &listop);
3790
3791     if (listop)
3792         ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3793
3794     if (once && o != listop)
3795         o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3796
3797     if (o == listop)
3798         o = newUNOP(OP_NULL, 0, o);     /* or do {} while 1 loses outer block */
3799
3800     o->op_flags |= flags;
3801     o = scope(o);
3802     o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3803     return o;
3804 }
3805
3806 OP *
3807 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
3808 whileline, OP *expr, OP *block, OP *cont, I32 has_my)
3809 {
3810     dVAR;
3811     OP *redo;
3812     OP *next = 0;
3813     OP *listop;
3814     OP *o;
3815     U8 loopflags = 0;
3816
3817     PERL_UNUSED_ARG(debuggable);
3818
3819     if (expr) {
3820         if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3821                      || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3822             expr = newUNOP(OP_DEFINED, 0,
3823                 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3824         } else if (expr->op_flags & OPf_KIDS) {
3825             const OP * const k1 = ((UNOP*)expr)->op_first;
3826             const OP * const k2 = (k1) ? k1->op_sibling : NULL;
3827             switch (expr->op_type) {
3828               case OP_NULL:
3829                 if (k2 && k2->op_type == OP_READLINE
3830                       && (k2->op_flags & OPf_STACKED)
3831                       && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3832                     expr = newUNOP(OP_DEFINED, 0, expr);
3833                 break;
3834
3835               case OP_SASSIGN:
3836                 if (k1->op_type == OP_READDIR
3837                       || k1->op_type == OP_GLOB
3838                       || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3839                       || k1->op_type == OP_EACH)
3840                     expr = newUNOP(OP_DEFINED, 0, expr);
3841                 break;
3842             }
3843         }
3844     }
3845
3846     if (!block)
3847         block = newOP(OP_NULL, 0);
3848     else if (cont || has_my) {
3849         block = scope(block);
3850     }
3851
3852     if (cont) {
3853         next = LINKLIST(cont);
3854     }
3855     if (expr) {
3856         OP *unstack = newOP(OP_UNSTACK, 0);
3857         if (!next)
3858             next = unstack;
3859         cont = append_elem(OP_LINESEQ, cont, unstack);
3860     }
3861
3862     listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
3863     redo = LINKLIST(listop);
3864
3865     if (expr) {
3866         PL_copline = (line_t)whileline;
3867         scalar(listop);
3868         o = new_logop(OP_AND, 0, &expr, &listop);
3869         if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
3870             op_free(expr);              /* oops, it's a while (0) */
3871             op_free((OP*)loop);
3872             return Nullop;              /* listop already freed by new_logop */
3873         }
3874         if (listop)
3875             ((LISTOP*)listop)->op_last->op_next =
3876                 (o == listop ? redo : LINKLIST(o));
3877     }
3878     else
3879         o = listop;
3880
3881     if (!loop) {
3882         NewOp(1101,loop,1,LOOP);
3883         loop->op_type = OP_ENTERLOOP;
3884         loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
3885         loop->op_private = 0;
3886         loop->op_next = (OP*)loop;
3887     }
3888
3889     o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
3890
3891     loop->op_redoop = redo;
3892     loop->op_lastop = o;
3893     o->op_private |= loopflags;
3894
3895     if (next)
3896         loop->op_nextop = next;
3897     else
3898         loop->op_nextop = o;
3899
3900     o->op_flags |= flags;
3901     o->op_private |= (flags >> 8);
3902     return o;
3903 }
3904
3905 OP *
3906 Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont)
3907 {
3908     dVAR;
3909     LOOP *loop;
3910     OP *wop;
3911     PADOFFSET padoff = 0;
3912     I32 iterflags = 0;
3913     I32 iterpflags = 0;
3914
3915     if (sv) {
3916         if (sv->op_type == OP_RV2SV) {  /* symbol table variable */
3917             iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
3918             sv->op_type = OP_RV2GV;
3919             sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
3920         }
3921         else if (sv->op_type == OP_PADSV) { /* private variable */
3922             iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
3923             padoff = sv->op_targ;
3924             sv->op_targ = 0;
3925             op_free(sv);
3926             sv = Nullop;
3927         }
3928         else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
3929             padoff = sv->op_targ;
3930             sv->op_targ = 0;
3931             iterflags |= OPf_SPECIAL;
3932             op_free(sv);
3933             sv = Nullop;
3934         }
3935         else
3936             Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
3937     }
3938     else {
3939         const I32 offset = pad_findmy("$_");
3940         if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
3941             sv = newGVOP(OP_GV, 0, PL_defgv);
3942         }
3943         else {
3944             padoff = offset;
3945         }
3946     }
3947     if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
3948         expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
3949         iterflags |= OPf_STACKED;
3950     }
3951     else if (expr->op_type == OP_NULL &&
3952              (expr->op_flags & OPf_KIDS) &&
3953              ((BINOP*)expr)->op_first->op_type == OP_FLOP)
3954     {
3955         /* Basically turn for($x..$y) into the same as for($x,$y), but we
3956          * set the STACKED flag to indicate that these values are to be
3957          * treated as min/max values by 'pp_iterinit'.
3958          */
3959         UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
3960         LOGOP* range = (LOGOP*) flip->op_first;
3961         OP* const left  = range->op_first;
3962         OP* const right = left->op_sibling;
3963         LISTOP* listop;
3964
3965         range->op_flags &= ~OPf_KIDS;
3966         range->op_first = Nullop;
3967
3968         listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
3969         listop->op_first->op_next = range->op_next;
3970         left->op_next = range->op_other;
3971         right->op_next = (OP*)listop;
3972         listop->op_next = listop->op_first;
3973
3974         op_free(expr);
3975         expr = (OP*)(listop);
3976         op_null(expr);
3977         iterflags |= OPf_STACKED;
3978     }
3979     else {
3980         expr = mod(force_list(expr), OP_GREPSTART);
3981     }
3982
3983     loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
3984                                append_elem(OP_LIST, expr, scalar(sv))));
3985     assert(!loop->op_next);
3986     /* for my  $x () sets OPpLVAL_INTRO;
3987      * for our $x () sets OPpOUR_INTRO */
3988     loop->op_private = (U8)iterpflags;
3989 #ifdef PL_OP_SLAB_ALLOC
3990     {
3991         LOOP *tmp;
3992         NewOp(1234,tmp,1,LOOP);
3993         Copy(loop,tmp,1,LISTOP);
3994         FreeOp(loop);
3995         loop = tmp;
3996     }
3997 #else
3998     Renew(loop, 1, LOOP);
3999 #endif
4000     loop->op_targ = padoff;
4001     wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
4002     PL_copline = forline;
4003     return newSTATEOP(0, label, wop);
4004 }
4005
4006 OP*
4007 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4008 {
4009     OP *o;
4010
4011     if (type != OP_GOTO || label->op_type == OP_CONST) {
4012         /* "last()" means "last" */
4013         if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4014             o = newOP(type, OPf_SPECIAL);
4015         else {
4016             o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4017                                         ? SvPVx_nolen_const(((SVOP*)label)->op_sv)
4018                                         : ""));
4019         }
4020         op_free(label);
4021     }
4022     else {
4023         /* Check whether it's going to be a goto &function */
4024         if (label->op_type == OP_ENTERSUB
4025                 && !(label->op_flags & OPf_STACKED))
4026             label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4027         o = newUNOP(type, OPf_STACKED, label);
4028     }
4029     PL_hints |= HINT_BLOCK_SCOPE;
4030     return o;
4031 }
4032
4033 /*
4034 =for apidoc cv_undef
4035
4036 Clear out all the active components of a CV. This can happen either
4037 by an explicit C<undef &foo>, or by the reference count going to zero.
4038 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
4039 children can still follow the full lexical scope chain.
4040
4041 =cut
4042 */
4043
4044 void
4045 Perl_cv_undef(pTHX_ CV *cv)
4046 {
4047     dVAR;
4048 #ifdef USE_ITHREADS
4049     if (CvFILE(cv) && !CvXSUB(cv)) {
4050         /* for XSUBs CvFILE point directly to static memory; __FILE__ */
4051         Safefree(CvFILE(cv));
4052     }
4053     CvFILE(cv) = 0;
4054 #endif
4055
4056     if (!CvXSUB(cv) && CvROOT(cv)) {
4057         if (CvDEPTH(cv))
4058             Perl_croak(aTHX_ "Can't undef active subroutine");
4059         ENTER;
4060
4061         PAD_SAVE_SETNULLPAD();
4062
4063         op_free(CvROOT(cv));
4064         CvROOT(cv) = Nullop;
4065         CvSTART(cv) = Nullop;
4066         LEAVE;
4067     }
4068     SvPOK_off((SV*)cv);         /* forget prototype */
4069     CvGV(cv) = Nullgv;
4070
4071     pad_undef(cv);
4072
4073     /* remove CvOUTSIDE unless this is an undef rather than a free */
4074     if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
4075         if (!CvWEAKOUTSIDE(cv))
4076             SvREFCNT_dec(CvOUTSIDE(cv));
4077         CvOUTSIDE(cv) = Nullcv;
4078     }
4079     if (CvCONST(cv)) {
4080         SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4081         CvCONST_off(cv);
4082     }
4083     if (CvXSUB(cv)) {
4084         CvXSUB(cv) = 0;
4085     }
4086     /* delete all flags except WEAKOUTSIDE */
4087     CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
4088 }
4089
4090 void
4091 Perl_cv_ckproto(pTHX_ const CV *cv, const GV *gv, const char *p)
4092 {
4093     if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX_const(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4094         SV* const msg = sv_newmortal();
4095         SV* name = Nullsv;
4096
4097         if (gv)
4098             gv_efullname3(name = sv_newmortal(), gv, Nullch);
4099         sv_setpv(msg, "Prototype mismatch:");
4100         if (name)
4101             Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4102         if (SvPOK(cv))
4103             Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (const SV *)cv);
4104         else
4105             Perl_sv_catpv(aTHX_ msg, ": none");
4106         sv_catpv(msg, " vs ");
4107         if (p)
4108             Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4109         else
4110             sv_catpv(msg, "none");
4111         Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, msg);
4112     }
4113 }
4114
4115 static void const_sv_xsub(pTHX_ CV* cv);
4116
4117 /*
4118
4119 =head1 Optree Manipulation Functions
4120
4121 =for apidoc cv_const_sv
4122
4123 If C<cv> is a constant sub eligible for inlining. returns the constant
4124 value returned by the sub.  Otherwise, returns NULL.
4125
4126 Constant subs can be created with C<newCONSTSUB> or as described in
4127 L<perlsub/"Constant Functions">.
4128
4129 =cut
4130 */
4131 SV *
4132 Perl_cv_const_sv(pTHX_ CV *cv)
4133 {
4134     if (!cv || !CvCONST(cv))
4135         return Nullsv;
4136     return (SV*)CvXSUBANY(cv).any_ptr;
4137 }
4138
4139 /* op_const_sv:  examine an optree to determine whether it's in-lineable.
4140  * Can be called in 3 ways:
4141  *
4142  * !cv
4143  *      look for a single OP_CONST with attached value: return the value
4144  *
4145  * cv && CvCLONE(cv) && !CvCONST(cv)
4146  *
4147  *      examine the clone prototype, and if contains only a single
4148  *      OP_CONST referencing a pad const, or a single PADSV referencing
4149  *      an outer lexical, return a non-zero value to indicate the CV is
4150  *      a candidate for "constizing" at clone time
4151  *
4152  * cv && CvCONST(cv)
4153  *
4154  *      We have just cloned an anon prototype that was marked as a const
4155  *      candidiate. Try to grab the current value, and in the case of
4156  *      PADSV, ignore it if it has multiple references. Return the value.
4157  */
4158
4159 SV *
4160 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
4161 {
4162     SV *sv = Nullsv;
4163
4164     if (!o)
4165         return Nullsv;
4166
4167     if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4168         o = cLISTOPo->op_first->op_sibling;
4169
4170     for (; o; o = o->op_next) {
4171         const OPCODE type = o->op_type;
4172
4173         if (sv && o->op_next == o)
4174             return sv;
4175         if (o->op_next != o) {
4176             if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4177                 continue;
4178             if (type == OP_DBSTATE)
4179                 continue;
4180         }
4181         if (type == OP_LEAVESUB || type == OP_RETURN)
4182             break;
4183         if (sv)
4184             return Nullsv;
4185         if (type == OP_CONST && cSVOPo->op_sv)
4186             sv = cSVOPo->op_sv;
4187         else if (cv && type == OP_CONST) {
4188             sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4189             if (!sv)
4190                 return Nullsv;
4191         }
4192         else if (cv && type == OP_PADSV) {
4193             if (CvCONST(cv)) { /* newly cloned anon */
4194                 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4195                 /* the candidate should have 1 ref from this pad and 1 ref
4196                  * from the parent */
4197                 if (!sv || SvREFCNT(sv) != 2)
4198                     return Nullsv;
4199                 sv = newSVsv(sv);
4200                 SvREADONLY_on(sv);
4201                 return sv;
4202             }
4203             else {
4204                 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
4205                     sv = &PL_sv_undef; /* an arbitrary non-null value */
4206             }
4207         }
4208         else {
4209             return Nullsv;
4210         }
4211     }
4212     return sv;
4213 }
4214
4215 void
4216 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4217 {
4218     PERL_UNUSED_ARG(floor);
4219
4220     if (o)
4221         SAVEFREEOP(o);
4222     if (proto)
4223         SAVEFREEOP(proto);
4224     if (attrs)
4225         SAVEFREEOP(attrs);
4226     if (block)
4227         SAVEFREEOP(block);
4228     Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4229 }
4230
4231 CV *
4232 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4233 {
4234     return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4235 }
4236
4237 CV *
4238 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4239 {
4240     dVAR;
4241     const char *aname;
4242     GV *gv;
4243     const char *ps;
4244     STRLEN ps_len;
4245     register CV *cv=0;
4246     SV *const_sv;
4247     I32 gv_fetch_flags;
4248
4249     const char * const name = o ? SvPVx_nolen_const(cSVOPo->op_sv) : Nullch;
4250
4251     if (proto) {
4252         assert(proto->op_type == OP_CONST);
4253         ps = SvPVx_const(((SVOP*)proto)->op_sv, ps_len);
4254     }
4255     else
4256         ps = Nullch;
4257
4258     if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4259         SV * const sv = sv_newmortal();
4260         Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
4261                        PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
4262                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4263         aname = SvPVX_const(sv);
4264     }
4265     else
4266         aname = Nullch;
4267
4268     gv_fetch_flags = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
4269         ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
4270     gv = name ? gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV)
4271         : gv_fetchpv(aname ? aname
4272                      : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4273                      gv_fetch_flags, SVt_PVCV);
4274
4275     if (o)
4276         SAVEFREEOP(o);
4277     if (proto)
4278         SAVEFREEOP(proto);
4279     if (attrs)
4280         SAVEFREEOP(attrs);
4281
4282     if (SvTYPE(gv) != SVt_PVGV) {       /* Maybe prototype now, and had at
4283                                            maximum a prototype before. */
4284         if (SvTYPE(gv) > SVt_NULL) {
4285             if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4286                 && ckWARN_d(WARN_PROTOTYPE))
4287             {
4288                 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
4289             }
4290             cv_ckproto((CV*)gv, NULL, ps);
4291         }
4292         if (ps)
4293             sv_setpvn((SV*)gv, ps, ps_len);
4294         else
4295             sv_setiv((SV*)gv, -1);
4296         SvREFCNT_dec(PL_compcv);
4297         cv = PL_compcv = NULL;
4298         PL_sub_generation++;
4299         goto done;
4300     }
4301
4302     cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4303
4304 #ifdef GV_UNIQUE_CHECK
4305     if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4306         Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
4307     }
4308 #endif
4309
4310     if (!block || !ps || *ps || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
4311         const_sv = Nullsv;
4312     else
4313         const_sv = op_const_sv(block, Nullcv);
4314
4315     if (cv) {
4316         const bool exists = CvROOT(cv) || CvXSUB(cv);
4317
4318 #ifdef GV_UNIQUE_CHECK
4319         if (exists && GvUNIQUE(gv)) {
4320             Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
4321         }
4322 #endif
4323
4324         /* if the subroutine doesn't exist and wasn't pre-declared
4325          * with a prototype, assume it will be AUTOLOADed,
4326          * skipping the prototype check
4327          */
4328         if (exists || SvPOK(cv))
4329             cv_ckproto(cv, gv, ps);
4330         /* already defined (or promised)? */
4331         if (exists || GvASSUMECV(gv)) {
4332             if (!block && !attrs) {
4333                 if (CvFLAGS(PL_compcv)) {
4334                     /* might have had built-in attrs applied */
4335                     CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4336                 }
4337                 /* just a "sub foo;" when &foo is already defined */
4338                 SAVEFREESV(PL_compcv);
4339                 goto done;
4340             }
4341             /* ahem, death to those who redefine active sort subs */
4342             if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4343                 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4344             if (block) {
4345                 if (ckWARN(WARN_REDEFINE)
4346                     || (CvCONST(cv)
4347                         && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4348                 {
4349                     const line_t oldline = CopLINE(PL_curcop);
4350                     if (PL_copline != NOLINE)
4351                         CopLINE_set(PL_curcop, PL_copline);
4352                     Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4353                         CvCONST(cv) ? "Constant subroutine %s redefined"
4354                                     : "Subroutine %s redefined", name);
4355                     CopLINE_set(PL_curcop, oldline);
4356                 }
4357                 SvREFCNT_dec(cv);
4358                 cv = Nullcv;
4359             }
4360         }
4361     }
4362     if (const_sv) {
4363         (void)SvREFCNT_inc(const_sv);
4364         if (cv) {
4365             assert(!CvROOT(cv) && !CvCONST(cv));
4366             sv_setpvn((SV*)cv, "", 0);  /* prototype is "" */
4367             CvXSUBANY(cv).any_ptr = const_sv;
4368             CvXSUB(cv) = const_sv_xsub;
4369             CvCONST_on(cv);
4370         }
4371         else {
4372             GvCV(gv) = Nullcv;
4373             cv = newCONSTSUB(NULL, name, const_sv);
4374         }
4375         op_free(block);
4376         SvREFCNT_dec(PL_compcv);
4377         PL_compcv = NULL;
4378         PL_sub_generation++;
4379         goto done;
4380     }
4381     if (attrs) {
4382         HV *stash;
4383         SV *rcv;
4384
4385         /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4386          * before we clobber PL_compcv.
4387          */
4388         if (cv && !block) {
4389             rcv = (SV*)cv;
4390             /* Might have had built-in attributes applied -- propagate them. */
4391             CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4392             if (CvGV(cv) && GvSTASH(CvGV(cv)))
4393                 stash = GvSTASH(CvGV(cv));
4394             else if (CvSTASH(cv))
4395                 stash = CvSTASH(cv);
4396             else
4397                 stash = PL_curstash;
4398         }
4399         else {
4400             /* possibly about to re-define existing subr -- ignore old cv */
4401             rcv = (SV*)PL_compcv;
4402             if (name && GvSTASH(gv))
4403                 stash = GvSTASH(gv);
4404             else
4405                 stash = PL_curstash;
4406         }
4407         apply_attrs(stash, rcv, attrs, FALSE);
4408     }
4409     if (cv) {                           /* must reuse cv if autoloaded */
4410         if (!block) {
4411             /* got here with just attrs -- work done, so bug out */
4412             SAVEFREESV(PL_compcv);
4413             goto done;
4414         }
4415         /* transfer PL_compcv to cv */
4416         cv_undef(cv);
4417         CvFLAGS(cv) = CvFLAGS(PL_compcv);
4418         if (!CvWEAKOUTSIDE(cv))
4419             SvREFCNT_dec(CvOUTSIDE(cv));
4420         CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4421         CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
4422         CvOUTSIDE(PL_compcv) = 0;
4423         CvPADLIST(cv) = CvPADLIST(PL_compcv);
4424         CvPADLIST(PL_compcv) = 0;
4425         /* inner references to PL_compcv must be fixed up ... */
4426         pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
4427         /* ... before we throw it away */
4428         SvREFCNT_dec(PL_compcv);
4429         PL_compcv = cv;
4430         if (PERLDB_INTER)/* Advice debugger on the new sub. */
4431           ++PL_sub_generation;
4432     }
4433     else {
4434         cv = PL_compcv;
4435         if (name) {
4436             GvCV(gv) = cv;
4437             GvCVGEN(gv) = 0;
4438             PL_sub_generation++;
4439         }
4440     }
4441     CvGV(cv) = gv;
4442     CvFILE_set_from_cop(cv, PL_curcop);
4443     CvSTASH(cv) = PL_curstash;
4444
4445     if (ps)
4446         sv_setpvn((SV*)cv, ps, ps_len);
4447
4448     if (PL_error_count) {
4449         op_free(block);
4450         block = Nullop;
4451         if (name) {
4452             const char *s = strrchr(name, ':');
4453             s = s ? s+1 : name;
4454             if (strEQ(s, "BEGIN")) {
4455                 const char not_safe[] =
4456                     "BEGIN not safe after errors--compilation aborted";
4457                 if (PL_in_eval & EVAL_KEEPERR)
4458                     Perl_croak(aTHX_ not_safe);
4459                 else {
4460                     /* force display of errors found but not reported */
4461                     sv_catpv(ERRSV, not_safe);
4462                     Perl_croak(aTHX_ "%"SVf, ERRSV);
4463                 }
4464             }
4465         }
4466     }
4467     if (!block)
4468         goto done;
4469
4470     if (CvLVALUE(cv)) {
4471         CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4472                              mod(scalarseq(block), OP_LEAVESUBLV));
4473     }
4474     else {
4475         /* This makes sub {}; work as expected.  */
4476         if (block->op_type == OP_STUB) {
4477             op_free(block);
4478             block = newSTATEOP(0, Nullch, 0);
4479         }
4480         CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4481     }
4482     CvROOT(cv)->op_private |= OPpREFCOUNTED;
4483     OpREFCNT_set(CvROOT(cv), 1);
4484     CvSTART(cv) = LINKLIST(CvROOT(cv));
4485     CvROOT(cv)->op_next = 0;
4486     CALL_PEEP(CvSTART(cv));
4487
4488     /* now that optimizer has done its work, adjust pad values */
4489
4490     pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
4491
4492     if (CvCLONE(cv)) {
4493         assert(!CvCONST(cv));
4494         if (ps && !*ps && op_const_sv(block, cv))
4495             CvCONST_on(cv);
4496     }
4497
4498     if (name || aname) {
4499         const char *s;
4500         const char *tname = (name ? name : aname);
4501
4502         if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4503             SV *sv = NEWSV(0,0);
4504             SV *tmpstr = sv_newmortal();
4505             GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4506             CV *pcv;
4507             HV *hv;
4508
4509             Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4510                            CopFILE(PL_curcop),
4511                            (long)PL_subline, (long)CopLINE(PL_curcop));
4512             gv_efullname3(tmpstr, gv, Nullch);
4513             hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr), SvCUR(tmpstr), sv, 0);
4514             hv = GvHVn(db_postponed);
4515             if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))
4516                 && (pcv = GvCV(db_postponed)))
4517             {
4518                 dSP;
4519                 PUSHMARK(SP);
4520                 XPUSHs(tmpstr);
4521                 PUTBACK;
4522                 call_sv((SV*)pcv, G_DISCARD);
4523             }
4524         }
4525
4526         if ((s = strrchr(tname,':')))
4527             s++;
4528         else
4529             s = tname;
4530
4531         if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4532             goto done;
4533
4534         if (strEQ(s, "BEGIN") && !PL_error_count) {
4535             const I32 oldscope = PL_scopestack_ix;
4536             ENTER;
4537             SAVECOPFILE(&PL_compiling);
4538             SAVECOPLINE(&PL_compiling);
4539
4540             if (!PL_beginav)
4541                 PL_beginav = newAV();
4542             DEBUG_x( dump_sub(gv) );
4543             av_push(PL_beginav, (SV*)cv);
4544             GvCV(gv) = 0;               /* cv has been hijacked */
4545             call_list(oldscope, PL_beginav);
4546
4547             PL_curcop = &PL_compiling;
4548             PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4549             LEAVE;
4550         }
4551         else if (strEQ(s, "END") && !PL_error_count) {
4552             if (!PL_endav)
4553                 PL_endav = newAV();
4554             DEBUG_x( dump_sub(gv) );
4555             av_unshift(PL_endav, 1);
4556             av_store(PL_endav, 0, (SV*)cv);
4557             GvCV(gv) = 0;               /* cv has been hijacked */
4558         }
4559         else if (strEQ(s, "CHECK") && !PL_error_count) {
4560             if (!PL_checkav)
4561                 PL_checkav = newAV();
4562             DEBUG_x( dump_sub(gv) );
4563             if (PL_main_start && ckWARN(WARN_VOID))
4564                 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4565             av_unshift(PL_checkav, 1);
4566             av_store(PL_checkav, 0, (SV*)cv);
4567             GvCV(gv) = 0;               /* cv has been hijacked */
4568         }
4569         else if (strEQ(s, "INIT") && !PL_error_count) {
4570             if (!PL_initav)
4571                 PL_initav = newAV();
4572             DEBUG_x( dump_sub(gv) );
4573             if (PL_main_start && ckWARN(WARN_VOID))
4574                 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4575             av_push(PL_initav, (SV*)cv);
4576             GvCV(gv) = 0;               /* cv has been hijacked */
4577         }
4578     }
4579
4580   done:
4581     PL_copline = NOLINE;
4582     LEAVE_SCOPE(floor);
4583     return cv;
4584 }
4585
4586 /* XXX unsafe for threads if eval_owner isn't held */
4587 /*
4588 =for apidoc newCONSTSUB
4589
4590 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4591 eligible for inlining at compile-time.
4592
4593 =cut
4594 */
4595
4596 CV *
4597 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
4598 {
4599     dVAR;
4600     CV* cv;
4601
4602     ENTER;
4603
4604     SAVECOPLINE(PL_curcop);
4605     CopLINE_set(PL_curcop, PL_copline);
4606
4607     SAVEHINTS();
4608     PL_hints &= ~HINT_BLOCK_SCOPE;
4609
4610     if (stash) {
4611         SAVESPTR(PL_curstash);
4612         SAVECOPSTASH(PL_curcop);
4613         PL_curstash = stash;
4614         CopSTASH_set(PL_curcop,stash);
4615     }
4616
4617     cv = newXS(name, const_sv_xsub, savepv(CopFILE(PL_curcop)));
4618     CvXSUBANY(cv).any_ptr = sv;
4619     CvCONST_on(cv);
4620     sv_setpvn((SV*)cv, "", 0);  /* prototype is "" */
4621
4622     if (stash)
4623         CopSTASH_free(PL_curcop);
4624
4625     LEAVE;
4626
4627     return cv;
4628 }
4629
4630 /*
4631 =for apidoc U||newXS
4632
4633 Used by C<xsubpp> to hook up XSUBs as Perl subs.
4634
4635 =cut
4636 */
4637
4638 CV *
4639 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
4640 {
4641     GV * const gv = gv_fetchpv(name ? name :
4642                         (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4643                         GV_ADDMULTI, SVt_PVCV);
4644     register CV *cv;
4645
4646     if (!subaddr)
4647         Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
4648
4649     if ((cv = (name ? GvCV(gv) : Nullcv))) {
4650         if (GvCVGEN(gv)) {
4651             /* just a cached method */
4652             SvREFCNT_dec(cv);
4653             cv = Nullcv;
4654         }
4655         else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4656             /* already defined (or promised) */
4657             /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
4658             if (ckWARN(WARN_REDEFINE)) {
4659                 GV * const gvcv = CvGV(cv);
4660                 if (gvcv) {
4661                     HV * const stash = GvSTASH(gvcv);
4662                     if (stash) {
4663                         const char *name = HvNAME_get(stash);
4664                         if ( strEQ(name,"autouse") ) {
4665                             const line_t oldline = CopLINE(PL_curcop);
4666                             if (PL_copline != NOLINE)
4667                                 CopLINE_set(PL_curcop, PL_copline);
4668                             Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4669                                         CvCONST(cv) ? "Constant subroutine %s redefined"
4670                                                     : "Subroutine %s redefined"
4671                                         ,name);
4672                             CopLINE_set(PL_curcop, oldline);
4673                         }
4674                     }
4675                 }
4676             }
4677             SvREFCNT_dec(cv);
4678             cv = Nullcv;
4679         }
4680     }
4681
4682     if (cv)                             /* must reuse cv if autoloaded */
4683         cv_undef(cv);
4684     else {
4685         cv = (CV*)NEWSV(1105,0);
4686         sv_upgrade((SV *)cv, SVt_PVCV);
4687         if (name) {
4688             GvCV(gv) = cv;
4689             GvCVGEN(gv) = 0;
4690             PL_sub_generation++;
4691         }
4692     }
4693     CvGV(cv) = gv;
4694     (void)gv_fetchfile(filename);
4695     CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
4696                                    an external constant string */
4697     CvXSUB(cv) = subaddr;
4698
4699     if (name) {
4700         const char *s = strrchr(name,':');
4701         if (s)
4702             s++;
4703         else
4704             s = name;
4705
4706         if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4707             goto done;
4708
4709         if (strEQ(s, "BEGIN")) {
4710             if (!PL_beginav)
4711                 PL_beginav = newAV();
4712             av_push(PL_beginav, (SV*)cv);
4713             GvCV(gv) = 0;               /* cv has been hijacked */
4714         }
4715         else if (strEQ(s, "END")) {
4716             if (!PL_endav)
4717                 PL_endav = newAV();
4718             av_unshift(PL_endav, 1);
4719             av_store(PL_endav, 0, (SV*)cv);
4720             GvCV(gv) = 0;               /* cv has been hijacked */
4721         }
4722         else if (strEQ(s, "CHECK")) {
4723             if (!PL_checkav)
4724                 PL_checkav = newAV();
4725             if (PL_main_start && ckWARN(WARN_VOID))
4726                 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4727             av_unshift(PL_checkav, 1);
4728             av_store(PL_checkav, 0, (SV*)cv);
4729             GvCV(gv) = 0;               /* cv has been hijacked */
4730         }
4731         else if (strEQ(s, "INIT")) {
4732             if (!PL_initav)
4733                 PL_initav = newAV();
4734             if (PL_main_start && ckWARN(WARN_VOID))
4735                 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4736             av_push(PL_initav, (SV*)cv);
4737             GvCV(gv) = 0;               /* cv has been hijacked */
4738         }
4739     }
4740     else
4741         CvANON_on(cv);
4742
4743 done:
4744     return cv;
4745 }
4746
4747 void
4748 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
4749 {
4750     register CV *cv;
4751     GV *gv;
4752
4753     if (o)
4754         gv = gv_fetchsv(cSVOPo->op_sv, TRUE, SVt_PVFM);
4755     else
4756         gv = gv_fetchpv("STDOUT", TRUE, SVt_PVFM);
4757
4758 #ifdef GV_UNIQUE_CHECK
4759     if (GvUNIQUE(gv)) {
4760         Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
4761     }
4762 #endif
4763     GvMULTI_on(gv);
4764     if ((cv = GvFORM(gv))) {
4765         if (ckWARN(WARN_REDEFINE)) {
4766             const line_t oldline = CopLINE(PL_curcop);
4767             if (PL_copline != NOLINE)
4768                 CopLINE_set(PL_curcop, PL_copline);
4769             Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4770                         o ? "Format %"SVf" redefined"
4771                         : "Format STDOUT redefined" ,cSVOPo->op_sv);
4772             CopLINE_set(PL_curcop, oldline);
4773         }
4774         SvREFCNT_dec(cv);
4775     }
4776     cv = PL_compcv;
4777     GvFORM(gv) = cv;
4778     CvGV(cv) = gv;
4779     CvFILE_set_from_cop(cv, PL_curcop);
4780
4781
4782     pad_tidy(padtidy_FORMAT);
4783     CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
4784     CvROOT(cv)->op_private |= OPpREFCOUNTED;
4785     OpREFCNT_set(CvROOT(cv), 1);
4786     CvSTART(cv) = LINKLIST(CvROOT(cv));
4787     CvROOT(cv)->op_next = 0;
4788     CALL_PEEP(CvSTART(cv));
4789     op_free(o);
4790     PL_copline = NOLINE;
4791     LEAVE_SCOPE(floor);
4792 }
4793
4794 OP *
4795 Perl_newANONLIST(pTHX_ OP *o)
4796 {
4797     return newUNOP(OP_REFGEN, 0,
4798         mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
4799 }
4800
4801 OP *
4802 Perl_newANONHASH(pTHX_ OP *o)
4803 {
4804     return newUNOP(OP_REFGEN, 0,
4805         mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
4806 }
4807
4808 OP *
4809 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
4810 {
4811     return newANONATTRSUB(floor, proto, Nullop, block);
4812 }
4813
4814 OP *
4815 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
4816 {
4817     return newUNOP(OP_REFGEN, 0,
4818         newSVOP(OP_ANONCODE, 0,
4819                 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
4820 }
4821
4822 OP *
4823 Perl_oopsAV(pTHX_ OP *o)
4824 {
4825     dVAR;
4826     switch (o->op_type) {
4827     case OP_PADSV:
4828         o->op_type = OP_PADAV;
4829         o->op_ppaddr = PL_ppaddr[OP_PADAV];
4830         return ref(o, OP_RV2AV);
4831
4832     case OP_RV2SV:
4833         o->op_type = OP_RV2AV;
4834         o->op_ppaddr = PL_ppaddr[OP_RV2AV];
4835         ref(o, OP_RV2AV);
4836         break;
4837
4838     default:
4839         if (ckWARN_d(WARN_INTERNAL))
4840             Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
4841         break;
4842     }
4843     return o;
4844 }
4845
4846 OP *
4847 Perl_oopsHV(pTHX_ OP *o)
4848 {
4849     dVAR;
4850     switch (o->op_type) {
4851     case OP_PADSV:
4852     case OP_PADAV:
4853         o->op_type = OP_PADHV;
4854         o->op_ppaddr = PL_ppaddr[OP_PADHV];
4855         return ref(o, OP_RV2HV);
4856
4857     case OP_RV2SV:
4858     case OP_RV2AV:
4859         o->op_type = OP_RV2HV;
4860         o->op_ppaddr = PL_ppaddr[OP_RV2HV];
4861         ref(o, OP_RV2HV);
4862         break;
4863
4864     default:
4865         if (ckWARN_d(WARN_INTERNAL))
4866             Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
4867         break;
4868     }
4869     return o;
4870 }
4871
4872 OP *
4873 Perl_newAVREF(pTHX_ OP *o)
4874 {
4875     dVAR;
4876     if (o->op_type == OP_PADANY) {
4877         o->op_type = OP_PADAV;
4878         o->op_ppaddr = PL_ppaddr[OP_PADAV];
4879         return o;
4880     }
4881     else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
4882                 && ckWARN(WARN_DEPRECATED)) {
4883         Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4884                 "Using an array as a reference is deprecated");
4885     }
4886     return newUNOP(OP_RV2AV, 0, scalar(o));
4887 }
4888
4889 OP *
4890 Perl_newGVREF(pTHX_ I32 type, OP *o)
4891 {
4892     if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
4893         return newUNOP(OP_NULL, 0, o);
4894     return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
4895 }
4896
4897 OP *
4898 Perl_newHVREF(pTHX_ OP *o)
4899 {
4900     dVAR;
4901     if (o->op_type == OP_PADANY) {
4902         o->op_type = OP_PADHV;
4903         o->op_ppaddr = PL_ppaddr[OP_PADHV];
4904         return o;
4905     }
4906     else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
4907                 && ckWARN(WARN_DEPRECATED)) {
4908         Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4909                 "Using a hash as a reference is deprecated");
4910     }
4911     return newUNOP(OP_RV2HV, 0, scalar(o));
4912 }
4913
4914 OP *
4915 Perl_oopsCV(pTHX_ OP *o)
4916 {
4917     Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
4918     /* STUB */
4919     PERL_UNUSED_ARG(o);
4920     NORETURN_FUNCTION_END;
4921 }
4922
4923 OP *
4924 Perl_newCVREF(pTHX_ I32 flags, OP *o)
4925 {
4926     return newUNOP(OP_RV2CV, flags, scalar(o));
4927 }
4928
4929 OP *
4930 Perl_newSVREF(pTHX_ OP *o)
4931 {
4932     dVAR;
4933     if (o->op_type == OP_PADANY) {
4934         o->op_type = OP_PADSV;
4935         o->op_ppaddr = PL_ppaddr[OP_PADSV];
4936         return o;
4937     }
4938     else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
4939         o->op_flags |= OPpDONE_SVREF;
4940         return o;
4941     }
4942     return newUNOP(OP_RV2SV, 0, scalar(o));
4943 }
4944
4945 /* Check routines. See the comments at the top of this file for details
4946  * on when these are called */
4947
4948 OP *
4949 Perl_ck_anoncode(pTHX_ OP *o)
4950 {
4951     cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
4952     cSVOPo->op_sv = Nullsv;
4953     return o;
4954 }
4955
4956 OP *
4957 Perl_ck_bitop(pTHX_ OP *o)
4958 {
4959 #define OP_IS_NUMCOMPARE(op) \
4960         ((op) == OP_LT   || (op) == OP_I_LT || \
4961          (op) == OP_GT   || (op) == OP_I_GT || \
4962          (op) == OP_LE   || (op) == OP_I_LE || \
4963          (op) == OP_GE   || (op) == OP_I_GE || \
4964          (op) == OP_EQ   || (op) == OP_I_EQ || \
4965          (op) == OP_NE   || (op) == OP_I_NE || \
4966          (op) == OP_NCMP || (op) == OP_I_NCMP)
4967     o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4968     if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
4969             && (o->op_type == OP_BIT_OR
4970              || o->op_type == OP_BIT_AND
4971              || o->op_type == OP_BIT_XOR))
4972     {
4973         const OP * const left = cBINOPo->op_first;
4974         const OP * const right = left->op_sibling;
4975         if ((OP_IS_NUMCOMPARE(left->op_type) &&
4976                 (left->op_flags & OPf_PARENS) == 0) ||
4977             (OP_IS_NUMCOMPARE(right->op_type) &&
4978                 (right->op_flags & OPf_PARENS) == 0))
4979             if (ckWARN(WARN_PRECEDENCE))
4980                 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
4981                         "Possible precedence problem on bitwise %c operator",
4982                         o->op_type == OP_BIT_OR ? '|'
4983                             : o->op_type == OP_BIT_AND ? '&' : '^'
4984                         );
4985     }
4986     return o;
4987 }
4988
4989 OP *
4990 Perl_ck_concat(pTHX_ OP *o)
4991 {
4992     const OP *kid = cUNOPo->op_first;
4993     if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
4994             !(kUNOP->op_first->op_flags & OPf_MOD))
4995         o->op_flags |= OPf_STACKED;
4996     return o;
4997 }
4998
4999 OP *
5000 Perl_ck_spair(pTHX_ OP *o)
5001 {
5002     dVAR;
5003     if (o->op_flags & OPf_KIDS) {
5004         OP* newop;
5005         OP* kid;
5006         const OPCODE type = o->op_type;
5007         o = modkids(ck_fun(o), type);
5008         kid = cUNOPo->op_first;
5009         newop = kUNOP->op_first->op_sibling;
5010         if (newop &&
5011             (newop->op_sibling ||
5012              !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
5013              newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5014              newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
5015
5016             return o;
5017         }
5018         op_free(kUNOP->op_first);
5019         kUNOP->op_first = newop;
5020     }
5021     o->op_ppaddr = PL_ppaddr[++o->op_type];
5022     return ck_fun(o);
5023 }
5024
5025 OP *
5026 Perl_ck_delete(pTHX_ OP *o)
5027 {
5028     o = ck_fun(o);
5029     o->op_private = 0;
5030     if (o->op_flags & OPf_KIDS) {
5031         OP *kid = cUNOPo->op_first;
5032         switch (kid->op_type) {
5033         case OP_ASLICE:
5034             o->op_flags |= OPf_SPECIAL;
5035             /* FALL THROUGH */
5036         case OP_HSLICE:
5037             o->op_private |= OPpSLICE;
5038             break;
5039         case OP_AELEM:
5040             o->op_flags |= OPf_SPECIAL;
5041             /* FALL THROUGH */
5042         case OP_HELEM:
5043             break;
5044         default:
5045             Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5046                   OP_DESC(o));
5047         }
5048         op_null(kid);
5049     }
5050     return o;
5051 }
5052
5053 OP *
5054 Perl_ck_die(pTHX_ OP *o)
5055 {
5056 #ifdef VMS
5057     if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5058 #endif
5059     return ck_fun(o);
5060 }
5061
5062 OP *
5063 Perl_ck_eof(pTHX_ OP *o)
5064 {
5065     const I32 type = o->op_type;
5066
5067     if (o->op_flags & OPf_KIDS) {
5068         if (cLISTOPo->op_first->op_type == OP_STUB) {
5069             op_free(o);
5070             o = newUNOP(type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
5071         }
5072         return ck_fun(o);
5073     }
5074     return o;
5075 }
5076
5077 OP *
5078 Perl_ck_eval(pTHX_ OP *o)
5079 {
5080     dVAR;
5081     PL_hints |= HINT_BLOCK_SCOPE;
5082     if (o->op_flags & OPf_KIDS) {
5083         SVOP * const kid = (SVOP*)cUNOPo->op_first;
5084
5085         if (!kid) {
5086             o->op_flags &= ~OPf_KIDS;
5087             op_null(o);
5088         }
5089         else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
5090             LOGOP *enter;
5091
5092             cUNOPo->op_first = 0;
5093             op_free(o);
5094
5095             NewOp(1101, enter, 1, LOGOP);
5096             enter->op_type = OP_ENTERTRY;
5097             enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5098             enter->op_private = 0;
5099
5100             /* establish postfix order */
5101             enter->op_next = (OP*)enter;
5102
5103             o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5104             o->op_type = OP_LEAVETRY;
5105             o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5106             enter->op_other = o;
5107             return o;
5108         }
5109         else {
5110             scalar((OP*)kid);
5111             PL_cv_has_eval = 1;
5112         }
5113     }
5114     else {
5115         op_free(o);
5116         o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5117     }
5118     o->op_targ = (PADOFFSET)PL_hints;
5119     return o;
5120 }
5121
5122 OP *
5123 Perl_ck_exit(pTHX_ OP *o)
5124 {
5125 #ifdef VMS
5126     HV *table = GvHV(PL_hintgv);
5127     if (table) {
5128        SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
5129        if (svp && *svp && SvTRUE(*svp))
5130            o->op_private |= OPpEXIT_VMSISH;
5131     }
5132     if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5133 #endif
5134     return ck_fun(o);
5135 }
5136
5137 OP *
5138 Perl_ck_exec(pTHX_ OP *o)
5139 {
5140     if (o->op_flags & OPf_STACKED) {
5141         OP *kid;
5142         o = ck_fun(o);
5143         kid = cUNOPo->op_first->op_sibling;
5144         if (kid->op_type == OP_RV2GV)
5145             op_null(kid);
5146     }
5147     else
5148         o = listkids(o);
5149     return o;
5150 }
5151
5152 OP *
5153 Perl_ck_exists(pTHX_ OP *o)
5154 {
5155     o = ck_fun(o);
5156     if (o->op_flags & OPf_KIDS) {
5157         OP * const kid = cUNOPo->op_first;
5158         if (kid->op_type == OP_ENTERSUB) {
5159             (void) ref(kid, o->op_type);
5160             if (kid->op_type != OP_RV2CV && !PL_error_count)
5161                 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5162                             OP_DESC(o));
5163             o->op_private |= OPpEXISTS_SUB;
5164         }
5165         else if (kid->op_type == OP_AELEM)
5166             o->op_flags |= OPf_SPECIAL;
5167         else if (kid->op_type != OP_HELEM)
5168             Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5169                         OP_DESC(o));
5170         op_null(kid);
5171     }
5172     return o;
5173 }
5174
5175 OP *
5176 Perl_ck_rvconst(pTHX_ register OP *o)
5177 {
5178     dVAR;
5179     SVOP *kid = (SVOP*)cUNOPo->op_first;
5180
5181     o->op_private |= (PL_hints & HINT_STRICT_REFS);
5182     if (kid->op_type == OP_CONST) {
5183         int iscv;
5184         GV *gv;
5185         SV * const kidsv = kid->op_sv;
5186
5187         /* Is it a constant from cv_const_sv()? */
5188         if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5189             SV *rsv = SvRV(kidsv);
5190             const int svtype = SvTYPE(rsv);
5191             const char *badtype = Nullch;
5192
5193             switch (o->op_type) {
5194             case OP_RV2SV:
5195                 if (svtype > SVt_PVMG)
5196                     badtype = "a SCALAR";
5197                 break;
5198             case OP_RV2AV:
5199                 if (svtype != SVt_PVAV)
5200                     badtype = "an ARRAY";
5201                 break;
5202             case OP_RV2HV:
5203                 if (svtype != SVt_PVHV)
5204                     badtype = "a HASH";
5205                 break;
5206             case OP_RV2CV:
5207                 if (svtype != SVt_PVCV)
5208                     badtype = "a CODE";
5209                 break;
5210             }
5211             if (badtype)
5212                 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5213             return o;
5214         }
5215         if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5216             const char *badthing = Nullch;
5217             switch (o->op_type) {
5218             case OP_RV2SV:
5219                 badthing = "a SCALAR";
5220                 break;
5221             case OP_RV2AV:
5222                 badthing = "an ARRAY";
5223                 break;
5224             case OP_RV2HV:
5225                 badthing = "a HASH";
5226                 break;
5227             }
5228             if (badthing)
5229                 Perl_croak(aTHX_
5230           "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
5231                       kidsv, badthing);
5232         }
5233         /*
5234          * This is a little tricky.  We only want to add the symbol if we
5235          * didn't add it in the lexer.  Otherwise we get duplicate strict
5236          * warnings.  But if we didn't add it in the lexer, we must at
5237          * least pretend like we wanted to add it even if it existed before,
5238          * or we get possible typo warnings.  OPpCONST_ENTERED says
5239          * whether the lexer already added THIS instance of this symbol.
5240          */
5241         iscv = (o->op_type == OP_RV2CV) * 2;
5242         do {
5243             gv = gv_fetchsv(kidsv,
5244                 iscv | !(kid->op_private & OPpCONST_ENTERED),
5245                 iscv
5246                     ? SVt_PVCV
5247                     : o->op_type == OP_RV2SV
5248                         ? SVt_PV
5249                         : o->op_type == OP_RV2AV
5250                             ? SVt_PVAV
5251                             : o->op_type == OP_RV2HV
5252                                 ? SVt_PVHV
5253                                 : SVt_PVGV);
5254         } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5255         if (gv) {
5256             kid->op_type = OP_GV;
5257             SvREFCNT_dec(kid->op_sv);
5258 #ifdef USE_ITHREADS
5259             /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5260             kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5261             SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
5262             GvIN_PAD_on(gv);
5263             PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc(gv));
5264 #else
5265             kid->op_sv = SvREFCNT_inc(gv);
5266 #endif
5267             kid->op_private = 0;
5268             kid->op_ppaddr = PL_ppaddr[OP_GV];
5269         }
5270     }
5271     return o;
5272 }
5273
5274 OP *
5275 Perl_ck_ftst(pTHX_ OP *o)
5276 {
5277     dVAR;
5278     const I32 type = o->op_type;
5279
5280     if (o->op_flags & OPf_REF) {
5281         /* nothing */
5282     }
5283     else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5284         SVOP *kid = (SVOP*)cUNOPo->op_first;
5285
5286         if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5287             OP *newop = newGVOP(type, OPf_REF,
5288                 gv_fetchsv(kid->op_sv, TRUE, SVt_PVIO));
5289             op_free(o);
5290             o = newop;
5291             return o;
5292         }
5293         else {
5294           if ((PL_hints & HINT_FILETEST_ACCESS) &&
5295               OP_IS_FILETEST_ACCESS(o))
5296             o->op_private |= OPpFT_ACCESS;
5297         }
5298         if (PL_check[kid->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst)
5299                 && kid->op_type != OP_STAT && kid->op_type != OP_LSTAT)
5300             o->op_private |= OPpFT_STACKED;
5301     }
5302     else {
5303         op_free(o);
5304         if (type == OP_FTTTY)
5305             o = newGVOP(type, OPf_REF, PL_stdingv);
5306         else
5307             o = newUNOP(type, 0, newDEFSVOP());
5308     }
5309     return o;
5310 }
5311
5312 OP *
5313 Perl_ck_fun(pTHX_ OP *o)
5314 {
5315     const int type = o->op_type;
5316     register I32 oa = PL_opargs[type] >> OASHIFT;
5317
5318     if (o->op_flags & OPf_STACKED) {
5319         if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5320             oa &= ~OA_OPTIONAL;
5321         else
5322             return no_fh_allowed(o);
5323     }
5324
5325     if (o->op_flags & OPf_KIDS) {
5326         OP **tokid = &cLISTOPo->op_first;
5327         register OP *kid = cLISTOPo->op_first;
5328         OP *sibl;
5329         I32 numargs = 0;
5330
5331         if (kid->op_type == OP_PUSHMARK ||
5332             (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5333         {
5334             tokid = &kid->op_sibling;
5335             kid = kid->op_sibling;
5336         }
5337         if (!kid && PL_opargs[type] & OA_DEFGV)
5338             *tokid = kid = newDEFSVOP();
5339
5340         while (oa && kid) {
5341             numargs++;
5342             sibl = kid->op_sibling;
5343             switch (oa & 7) {
5344             case OA_SCALAR:
5345                 /* list seen where single (scalar) arg expected? */
5346                 if (numargs == 1 && !(oa >> 4)
5347                     && kid->op_type == OP_LIST && type != OP_SCALAR)
5348                 {
5349                     return too_many_arguments(o,PL_op_desc[type]);
5350                 }
5351                 scalar(kid);
5352                 break;
5353             case OA_LIST:
5354                 if (oa < 16) {
5355                     kid = 0;
5356                     continue;
5357                 }
5358                 else
5359                     list(kid);
5360                 break;
5361             case OA_AVREF:
5362                 if ((type == OP_PUSH || type == OP_UNSHIFT)
5363                     && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5364                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5365                         "Useless use of %s with no values",
5366                         PL_op_desc[type]);
5367
5368                 if (kid->op_type == OP_CONST &&
5369                     (kid->op_private & OPpCONST_BARE))
5370                 {
5371                     OP *newop = newAVREF(newGVOP(OP_GV, 0,
5372                         gv_fetchsv(((SVOP*)kid)->op_sv, TRUE, SVt_PVAV) ));
5373                     if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5374                         Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5375                             "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
5376                             ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
5377                     op_free(kid);
5378                     kid = newop;
5379                     kid->op_sibling = sibl;
5380                     *tokid = kid;
5381                 }
5382                 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5383                     bad_type(numargs, "array", PL_op_desc[type], kid);
5384                 mod(kid, type);
5385                 break;
5386             case OA_HVREF:
5387                 if (kid->op_type == OP_CONST &&
5388                     (kid->op_private & OPpCONST_BARE))
5389                 {
5390                     OP *newop = newHVREF(newGVOP(OP_GV, 0,
5391                         gv_fetchsv(((SVOP*)kid)->op_sv, TRUE, SVt_PVHV) ));
5392                     if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5393                         Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5394                             "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
5395                             ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
5396                     op_free(kid);
5397                     kid = newop;
5398                     kid->op_sibling = sibl;
5399                     *tokid = kid;
5400                 }
5401                 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5402                     bad_type(numargs, "hash", PL_op_desc[type], kid);
5403                 mod(kid, type);
5404                 break;
5405             case OA_CVREF:
5406                 {
5407                     OP *newop = newUNOP(OP_NULL, 0, kid);
5408                     kid->op_sibling = 0;
5409                     linklist(kid);
5410                     newop->op_next = newop;
5411                     kid = newop;
5412                     kid->op_sibling = sibl;
5413                     *tokid = kid;
5414                 }
5415                 break;
5416             case OA_FILEREF:
5417                 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5418                     if (kid->op_type == OP_CONST &&
5419                         (kid->op_private & OPpCONST_BARE))
5420                     {
5421                         OP *newop = newGVOP(OP_GV, 0,
5422                             gv_fetchsv(((SVOP*)kid)->op_sv, TRUE, SVt_PVIO) );
5423                         if (!(o->op_private & 1) && /* if not unop */
5424                             kid == cLISTOPo->op_last)
5425                             cLISTOPo->op_last = newop;
5426                         op_free(kid);
5427                         kid = newop;
5428                     }
5429                     else if (kid->op_type == OP_READLINE) {
5430                         /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5431                         bad_type(numargs, "HANDLE", OP_DESC(o), kid);
5432                     }
5433                     else {
5434                         I32 flags = OPf_SPECIAL;
5435                         I32 priv = 0;
5436                         PADOFFSET targ = 0;
5437
5438                         /* is this op a FH constructor? */
5439                         if (is_handle_constructor(o,numargs)) {
5440                             const char *name = Nullch;
5441                             STRLEN len = 0;
5442
5443                             flags = 0;
5444                             /* Set a flag to tell rv2gv to vivify
5445                              * need to "prove" flag does not mean something
5446                              * else already - NI-S 1999/05/07
5447                              */
5448                             priv = OPpDEREF;
5449                             if (kid->op_type == OP_PADSV) {
5450                                 name = PAD_COMPNAME_PV(kid->op_targ);
5451                                 /* SvCUR of a pad namesv can't be trusted
5452                                  * (see PL_generation), so calc its length
5453                                  * manually */
5454                                 if (name)
5455                                     len = strlen(name);
5456
5457                             }
5458                             else if (kid->op_type == OP_RV2SV
5459                                      && kUNOP->op_first->op_type == OP_GV)
5460                             {
5461                                 GV *gv = cGVOPx_gv(kUNOP->op_first);
5462                                 name = GvNAME(gv);
5463                                 len = GvNAMELEN(gv);
5464                             }
5465                             else if (kid->op_type == OP_AELEM
5466                                      || kid->op_type == OP_HELEM)
5467                             {
5468                                  OP *op;
5469
5470                                  name = 0;
5471                                  if ((op = ((BINOP*)kid)->op_first)) {
5472                                       SV *tmpstr = Nullsv;
5473                                       const char *a =
5474                                            kid->op_type == OP_AELEM ?
5475                                            "[]" : "{}";
5476                                       if (((op->op_type == OP_RV2AV) ||
5477                                            (op->op_type == OP_RV2HV)) &&
5478                                           (op = ((UNOP*)op)->op_first) &&
5479                                           (op->op_type == OP_GV)) {
5480                                            /* packagevar $a[] or $h{} */
5481                                            GV *gv = cGVOPx_gv(op);
5482                                            if (gv)
5483                                                 tmpstr =
5484                                                      Perl_newSVpvf(aTHX_
5485                                                                    "%s%c...%c",
5486                                                                    GvNAME(gv),
5487                                                                    a[0], a[1]);
5488                                       }
5489                                       else if (op->op_type == OP_PADAV
5490                                                || op->op_type == OP_PADHV) {
5491                                            /* lexicalvar $a[] or $h{} */
5492                                            const char *padname =
5493                                                 PAD_COMPNAME_PV(op->op_targ);
5494                                            if (padname)
5495                                                 tmpstr =
5496                                                      Perl_newSVpvf(aTHX_
5497                                                                    "%s%c...%c",
5498                                                                    padname + 1,
5499                                                                    a[0], a[1]);
5500
5501                                       }
5502                                       if (tmpstr) {
5503                                            name = SvPV_const(tmpstr, len);
5504                                            sv_2mortal(tmpstr);
5505                                       }
5506                                  }
5507                                  if (!name) {
5508                                       name = "__ANONIO__";
5509                                       len = 10;
5510                                  }
5511                                  mod(kid, type);
5512                             }
5513                             if (name) {
5514                                 SV *namesv;
5515                                 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5516                                 namesv = PAD_SVl(targ);
5517                                 SvUPGRADE(namesv, SVt_PV);
5518                                 if (*name != '$')
5519                                     sv_setpvn(namesv, "$", 1);
5520                                 sv_catpvn(namesv, name, len);
5521                             }
5522                         }
5523                         kid->op_sibling = 0;
5524                         kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5525                         kid->op_targ = targ;
5526                         kid->op_private |= priv;
5527                     }
5528                     kid->op_sibling = sibl;
5529                     *tokid = kid;
5530                 }
5531                 scalar(kid);
5532                 break;
5533             case OA_SCALARREF:
5534                 mod(scalar(kid), type);
5535                 break;
5536             }
5537             oa >>= 4;
5538             tokid = &kid->op_sibling;
5539             kid = kid->op_sibling;
5540         }
5541         o->op_private |= numargs;
5542         if (kid)
5543             return too_many_arguments(o,OP_DESC(o));
5544         listkids(o);
5545     }
5546     else if (PL_opargs[type] & OA_DEFGV) {
5547         op_free(o);
5548         return newUNOP(type, 0, newDEFSVOP());
5549     }
5550
5551     if (oa) {
5552         while (oa & OA_OPTIONAL)
5553             oa >>= 4;
5554         if (oa && oa != OA_LIST)
5555             return too_few_arguments(o,OP_DESC(o));
5556     }
5557     return o;
5558 }
5559
5560 OP *
5561 Perl_ck_glob(pTHX_ OP *o)
5562 {
5563     dVAR;
5564     GV *gv;
5565
5566     o = ck_fun(o);
5567     if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5568         append_elem(OP_GLOB, o, newDEFSVOP());
5569
5570     if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV))
5571           && GvCVu(gv) && GvIMPORTED_CV(gv)))
5572     {
5573         gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5574     }
5575
5576 #if !defined(PERL_EXTERNAL_GLOB)
5577     /* XXX this can be tightened up and made more failsafe. */
5578     if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
5579         GV *glob_gv;
5580         ENTER;
5581         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
5582                 newSVpvn("File::Glob", 10), Nullsv, Nullsv, Nullsv);
5583         gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5584         glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
5585         GvCV(gv) = GvCV(glob_gv);
5586         (void)SvREFCNT_inc((SV*)GvCV(gv));
5587         GvIMPORTED_CV_on(gv);
5588         LEAVE;
5589     }
5590 #endif /* PERL_EXTERNAL_GLOB */
5591
5592     if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5593         append_elem(OP_GLOB, o,
5594                     newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5595         o->op_type = OP_LIST;
5596         o->op_ppaddr = PL_ppaddr[OP_LIST];
5597         cLISTOPo->op_first->op_type = OP_PUSHMARK;
5598         cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5599         cLISTOPo->op_first->op_targ = 0;
5600         o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5601                     append_elem(OP_LIST, o,
5602                                 scalar(newUNOP(OP_RV2CV, 0,
5603                                                newGVOP(OP_GV, 0, gv)))));
5604         o = newUNOP(OP_NULL, 0, ck_subr(o));
5605         o->op_targ = OP_GLOB;           /* hint at what it used to be */
5606         return o;
5607     }
5608     gv = newGVgen("main");
5609     gv_IOadd(gv);
5610     append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5611     scalarkids(o);
5612     return o;
5613 }
5614
5615 OP *
5616 Perl_ck_grep(pTHX_ OP *o)
5617 {
5618     dVAR;
5619     LOGOP *gwop;
5620     OP *kid;
5621     const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5622     I32 offset;
5623
5624     o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5625     NewOp(1101, gwop, 1, LOGOP);
5626
5627     if (o->op_flags & OPf_STACKED) {
5628         OP* k;
5629         o = ck_sort(o);
5630         kid = cLISTOPo->op_first->op_sibling;
5631         if (!cUNOPx(kid)->op_next)
5632             Perl_croak(aTHX_ "panic: ck_grep");
5633         for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
5634             kid = k;
5635         }
5636         kid->op_next = (OP*)gwop;
5637         o->op_flags &= ~OPf_STACKED;
5638     }
5639     kid = cLISTOPo->op_first->op_sibling;
5640     if (type == OP_MAPWHILE)
5641         list(kid);
5642     else
5643         scalar(kid);
5644     o = ck_fun(o);
5645     if (PL_error_count)
5646         return o;
5647     kid = cLISTOPo->op_first->op_sibling;
5648     if (kid->op_type != OP_NULL)
5649         Perl_croak(aTHX_ "panic: ck_grep");
5650     kid = kUNOP->op_first;
5651
5652     gwop->op_type = type;
5653     gwop->op_ppaddr = PL_ppaddr[type];
5654     gwop->op_first = listkids(o);
5655     gwop->op_flags |= OPf_KIDS;
5656     gwop->op_other = LINKLIST(kid);
5657     kid->op_next = (OP*)gwop;
5658     offset = pad_findmy("$_");
5659     if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
5660         o->op_private = gwop->op_private = 0;
5661         gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5662     }
5663     else {
5664         o->op_private = gwop->op_private = OPpGREP_LEX;
5665         gwop->op_targ = o->op_targ = offset;
5666     }
5667
5668     kid = cLISTOPo->op_first->op_sibling;
5669     if (!kid || !kid->op_sibling)
5670         return too_few_arguments(o,OP_DESC(o));
5671     for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5672         mod(kid, OP_GREPSTART);
5673
5674     return (OP*)gwop;
5675 }
5676
5677 OP *
5678 Perl_ck_index(pTHX_ OP *o)
5679 {
5680     if (o->op_flags & OPf_KIDS) {
5681         OP *kid = cLISTOPo->op_first->op_sibling;       /* get past pushmark */
5682         if (kid)
5683             kid = kid->op_sibling;                      /* get past "big" */
5684         if (kid && kid->op_type == OP_CONST)
5685             fbm_compile(((SVOP*)kid)->op_sv, 0);
5686     }
5687     return ck_fun(o);
5688 }
5689
5690 OP *
5691 Perl_ck_lengthconst(pTHX_ OP *o)
5692 {
5693     /* XXX length optimization goes here */
5694     return ck_fun(o);
5695 }
5696
5697 OP *
5698 Perl_ck_lfun(pTHX_ OP *o)
5699 {
5700     const OPCODE type = o->op_type;
5701     return modkids(ck_fun(o), type);
5702 }
5703
5704 OP *
5705 Perl_ck_defined(pTHX_ OP *o)            /* 19990527 MJD */
5706 {
5707     if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
5708         switch (cUNOPo->op_first->op_type) {
5709         case OP_RV2AV:
5710             /* This is needed for
5711                if (defined %stash::)
5712                to work.   Do not break Tk.
5713                */
5714             break;                      /* Globals via GV can be undef */
5715         case OP_PADAV:
5716         case OP_AASSIGN:                /* Is this a good idea? */
5717             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5718                         "defined(@array) is deprecated");
5719             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5720                         "\t(Maybe you should just omit the defined()?)\n");
5721         break;
5722         case OP_RV2HV:
5723             /* This is needed for
5724                if (defined %stash::)
5725                to work.   Do not break Tk.
5726                */
5727             break;                      /* Globals via GV can be undef */
5728         case OP_PADHV:
5729             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5730                         "defined(%%hash) is deprecated");
5731             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5732                         "\t(Maybe you should just omit the defined()?)\n");
5733             break;
5734         default:
5735             /* no warning */
5736             break;
5737         }
5738     }
5739     return ck_rfun(o);
5740 }
5741
5742 OP *
5743 Perl_ck_rfun(pTHX_ OP *o)
5744 {
5745     const OPCODE type = o->op_type;
5746     return refkids(ck_fun(o), type);
5747 }
5748
5749 OP *
5750 Perl_ck_listiob(pTHX_ OP *o)
5751 {
5752     register OP *kid;
5753
5754     kid = cLISTOPo->op_first;
5755     if (!kid) {
5756         o = force_list(o);
5757         kid = cLISTOPo->op_first;
5758     }
5759     if (kid->op_type == OP_PUSHMARK)
5760         kid = kid->op_sibling;
5761     if (kid && o->op_flags & OPf_STACKED)
5762         kid = kid->op_sibling;
5763     else if (kid && !kid->op_sibling) {         /* print HANDLE; */
5764         if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
5765             o->op_flags |= OPf_STACKED; /* make it a filehandle */
5766             kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
5767             cLISTOPo->op_first->op_sibling = kid;
5768             cLISTOPo->op_last = kid;
5769             kid = kid->op_sibling;
5770         }
5771     }
5772
5773     if (!kid)
5774         append_elem(o->op_type, o, newDEFSVOP());
5775
5776     return listkids(o);
5777 }
5778
5779 OP *
5780 Perl_ck_sassign(pTHX_ OP *o)
5781 {
5782     OP *kid = cLISTOPo->op_first;
5783     /* has a disposable target? */
5784     if ((PL_opargs[kid->op_type] & OA_TARGLEX)
5785         && !(kid->op_flags & OPf_STACKED)
5786         /* Cannot steal the second time! */
5787         && !(kid->op_private & OPpTARGET_MY))
5788     {
5789         OP *kkid = kid->op_sibling;
5790
5791         /* Can just relocate the target. */
5792         if (kkid && kkid->op_type == OP_PADSV
5793             && !(kkid->op_private & OPpLVAL_INTRO))
5794         {
5795             kid->op_targ = kkid->op_targ;
5796             kkid->op_targ = 0;
5797             /* Now we do not need PADSV and SASSIGN. */
5798             kid->op_sibling = o->op_sibling;    /* NULL */
5799             cLISTOPo->op_first = NULL;
5800             op_free(o);
5801             op_free(kkid);
5802             kid->op_private |= OPpTARGET_MY;    /* Used for context settings */
5803             return kid;
5804         }
5805     }
5806     /* optimise C<my $x = undef> to C<my $x> */
5807     if (kid->op_type == OP_UNDEF) {
5808         OP *kkid = kid->op_sibling;
5809         if (kkid && kkid->op_type == OP_PADSV
5810                 && (kkid->op_private & OPpLVAL_INTRO))
5811         {
5812             cLISTOPo->op_first = NULL;
5813             kid->op_sibling = NULL;
5814             op_free(o);
5815             op_free(kid);
5816             return kkid;
5817         }
5818     }
5819     return o;
5820 }
5821
5822 OP *
5823 Perl_ck_match(pTHX_ OP *o)
5824 {
5825     if (o->op_type != OP_QR) {
5826         const I32 offset = pad_findmy("$_");
5827         if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS(offset) & SVpad_OUR)) {
5828             o->op_targ = offset;
5829             o->op_private |= OPpTARGET_MY;
5830         }
5831     }
5832     if (o->op_type == OP_MATCH || o->op_type == OP_QR)
5833         o->op_private |= OPpRUNTIME;
5834     return o;
5835 }
5836
5837 OP *
5838 Perl_ck_method(pTHX_ OP *o)
5839 {
5840     OP *kid = cUNOPo->op_first;
5841     if (kid->op_type == OP_CONST) {
5842         SV* sv = kSVOP->op_sv;
5843         if (!(strchr(SvPVX_const(sv), ':') || strchr(SvPVX_const(sv), '\''))) {
5844             OP *cmop;
5845             if (!SvREADONLY(sv) || !SvFAKE(sv)) {
5846                 sv = newSVpvn_share(SvPVX_const(sv), SvCUR(sv), 0);
5847             }
5848             else {
5849                 kSVOP->op_sv = Nullsv;
5850             }
5851             cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
5852             op_free(o);
5853             return cmop;
5854         }
5855     }
5856     return o;
5857 }
5858
5859 OP *
5860 Perl_ck_null(pTHX_ OP *o)
5861 {
5862     return o;
5863 }
5864
5865 OP *
5866 Perl_ck_open(pTHX_ OP *o)
5867 {
5868     HV *table = GvHV(PL_hintgv);
5869     if (table) {
5870         SV **svp;
5871         I32 mode;
5872         svp = hv_fetch(table, "open_IN", 7, FALSE);
5873         if (svp && *svp) {
5874             mode = mode_from_discipline(*svp);
5875             if (mode & O_BINARY)
5876                 o->op_private |= OPpOPEN_IN_RAW;
5877             else if (mode & O_TEXT)
5878                 o->op_private |= OPpOPEN_IN_CRLF;
5879         }
5880
5881         svp = hv_fetch(table, "open_OUT", 8, FALSE);
5882         if (svp && *svp) {
5883             mode = mode_from_discipline(*svp);
5884             if (mode & O_BINARY)
5885                 o->op_private |= OPpOPEN_OUT_RAW;
5886             else if (mode & O_TEXT)
5887                 o->op_private |= OPpOPEN_OUT_CRLF;
5888         }
5889     }
5890     if (o->op_type == OP_BACKTICK)
5891         return o;
5892     {
5893          /* In case of three-arg dup open remove strictness
5894           * from the last arg if it is a bareword. */
5895          OP *first = cLISTOPx(o)->op_first; /* The pushmark. */
5896          OP *last  = cLISTOPx(o)->op_last;  /* The bareword. */
5897          OP *oa;
5898          const char *mode;
5899
5900          if ((last->op_type == OP_CONST) &&             /* The bareword. */
5901              (last->op_private & OPpCONST_BARE) &&
5902              (last->op_private & OPpCONST_STRICT) &&
5903              (oa = first->op_sibling) &&                /* The fh. */
5904              (oa = oa->op_sibling) &&                   /* The mode. */
5905              (oa->op_type == OP_CONST) &&
5906              SvPOK(((SVOP*)oa)->op_sv) &&
5907              (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
5908              mode[0] == '>' && mode[1] == '&' &&        /* A dup open. */
5909              (last == oa->op_sibling))                  /* The bareword. */
5910               last->op_private &= ~OPpCONST_STRICT;
5911     }
5912     return ck_fun(o);
5913 }
5914
5915 OP *
5916 Perl_ck_repeat(pTHX_ OP *o)
5917 {
5918     if (cBINOPo->op_first->op_flags & OPf_PARENS) {
5919         o->op_private |= OPpREPEAT_DOLIST;
5920         cBINOPo->op_first = force_list(cBINOPo->op_first);
5921     }
5922     else
5923         scalar(o);
5924     return o;
5925 }
5926
5927 OP *
5928 Perl_ck_require(pTHX_ OP *o)
5929 {
5930     GV* gv = Nullgv;
5931
5932     if (o->op_flags & OPf_KIDS) {       /* Shall we supply missing .pm? */
5933         SVOP *kid = (SVOP*)cUNOPo->op_first;
5934
5935         if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5936             SV *sv = kid->op_sv;
5937             U32 was_readonly = SvREADONLY(sv);
5938             char *s;
5939
5940             if (was_readonly) {
5941                 if (SvFAKE(sv)) {
5942                     sv_force_normal_flags(sv, 0);
5943                     assert(!SvREADONLY(sv));
5944                     was_readonly = 0;
5945                 } else {
5946                     SvREADONLY_off(sv);
5947                 }
5948             }
5949
5950             for (s = SvPVX(sv); *s; s++) {
5951                 if (*s == ':' && s[1] == ':') {
5952                     *s = '/';
5953                     Move(s+2, s+1, strlen(s+2)+1, char);
5954                     SvCUR_set(sv, SvCUR(sv) - 1);
5955                 }
5956             }
5957             sv_catpvn(sv, ".pm", 3);
5958             SvFLAGS(sv) |= was_readonly;
5959         }
5960     }
5961
5962     if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
5963         /* handle override, if any */
5964         gv = gv_fetchpv("require", FALSE, SVt_PVCV);
5965         if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
5966             GV **gvp = (GV**)hv_fetch(PL_globalstash, "require", 7, FALSE);
5967             if (gvp) gv = *gvp; else gv = Nullgv;
5968         }
5969     }
5970
5971     if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5972         OP *kid = cUNOPo->op_first;
5973         cUNOPo->op_first = 0;
5974         op_free(o);
5975         return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
5976                                append_elem(OP_LIST, kid,
5977                                            scalar(newUNOP(OP_RV2CV, 0,
5978                                                           newGVOP(OP_GV, 0,
5979                                                                   gv))))));
5980     }
5981
5982     return ck_fun(o);
5983 }
5984
5985 OP *
5986 Perl_ck_return(pTHX_ OP *o)
5987 {
5988     if (CvLVALUE(PL_compcv)) {
5989         OP *kid;
5990         for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
5991             mod(kid, OP_LEAVESUBLV);
5992     }
5993     return o;
5994 }
5995
5996 #if 0
5997 OP *
5998 Perl_ck_retarget(pTHX_ OP *o)
5999 {
6000     Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
6001     /* STUB */
6002     return o;
6003 }
6004 #endif
6005
6006 OP *
6007 Perl_ck_select(pTHX_ OP *o)
6008 {
6009     dVAR;
6010     OP* kid;
6011     if (o->op_flags & OPf_KIDS) {
6012         kid = cLISTOPo->op_first->op_sibling;   /* get past pushmark */
6013         if (kid && kid->op_sibling) {
6014             o->op_type = OP_SSELECT;
6015             o->op_ppaddr = PL_ppaddr[OP_SSELECT];
6016             o = ck_fun(o);
6017             return fold_constants(o);
6018         }
6019     }
6020     o = ck_fun(o);
6021     kid = cLISTOPo->op_first->op_sibling;    /* get past pushmark */
6022     if (kid && kid->op_type == OP_RV2GV)
6023         kid->op_private &= ~HINT_STRICT_REFS;
6024     return o;
6025 }
6026
6027 OP *
6028 Perl_ck_shift(pTHX_ OP *o)
6029 {
6030     const I32 type = o->op_type;
6031
6032     if (!(o->op_flags & OPf_KIDS)) {
6033         OP *argop;
6034
6035         op_free(o);
6036         argop = newUNOP(OP_RV2AV, 0,
6037             scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
6038         return newUNOP(type, 0, scalar(argop));
6039     }
6040     return scalar(modkids(ck_fun(o), type));
6041 }
6042
6043 OP *
6044 Perl_ck_sort(pTHX_ OP *o)
6045 {
6046     OP *firstkid;
6047
6048     if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6049         simplify_sort(o);
6050     firstkid = cLISTOPo->op_first->op_sibling;          /* get past pushmark */
6051     if (o->op_flags & OPf_STACKED) {                    /* may have been cleared */
6052         OP *k = NULL;
6053         OP *kid = cUNOPx(firstkid)->op_first;           /* get past null */
6054
6055         if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
6056             linklist(kid);
6057             if (kid->op_type == OP_SCOPE) {
6058                 k = kid->op_next;
6059                 kid->op_next = 0;
6060             }
6061             else if (kid->op_type == OP_LEAVE) {
6062                 if (o->op_type == OP_SORT) {
6063                     op_null(kid);                       /* wipe out leave */
6064                     kid->op_next = kid;
6065
6066                     for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6067                         if (k->op_next == kid)
6068                             k->op_next = 0;
6069                         /* don't descend into loops */
6070                         else if (k->op_type == OP_ENTERLOOP
6071                                  || k->op_type == OP_ENTERITER)
6072                         {
6073                             k = cLOOPx(k)->op_lastop;
6074                         }
6075                     }
6076                 }
6077                 else
6078                     kid->op_next = 0;           /* just disconnect the leave */
6079                 k = kLISTOP->op_first;
6080             }
6081             CALL_PEEP(k);
6082
6083             kid = firstkid;
6084             if (o->op_type == OP_SORT) {
6085                 /* provide scalar context for comparison function/block */
6086                 kid = scalar(kid);
6087                 kid->op_next = kid;
6088             }
6089             else
6090                 kid->op_next = k;
6091             o->op_flags |= OPf_SPECIAL;
6092         }
6093         else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6094             op_null(firstkid);
6095
6096         firstkid = firstkid->op_sibling;
6097     }
6098
6099     /* provide list context for arguments */
6100     if (o->op_type == OP_SORT)
6101         list(firstkid);
6102
6103     return o;
6104 }
6105
6106 STATIC void
6107 S_simplify_sort(pTHX_ OP *o)
6108 {
6109     register OP *kid = cLISTOPo->op_first->op_sibling;  /* get past pushmark */
6110     OP *k;
6111     int descending;
6112     GV *gv;
6113     const char *gvname;
6114     if (!(o->op_flags & OPf_STACKED))
6115         return;
6116     GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
6117     GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
6118     kid = kUNOP->op_first;                              /* get past null */
6119     if (kid->op_type != OP_SCOPE)
6120         return;
6121     kid = kLISTOP->op_last;                             /* get past scope */
6122     switch(kid->op_type) {
6123         case OP_NCMP:
6124         case OP_I_NCMP:
6125         case OP_SCMP:
6126             break;
6127         default:
6128             return;
6129     }
6130     k = kid;                                            /* remember this node*/
6131     if (kBINOP->op_first->op_type != OP_RV2SV)
6132         return;
6133     kid = kBINOP->op_first;                             /* get past cmp */
6134     if (kUNOP->op_first->op_type != OP_GV)
6135         return;
6136     kid = kUNOP->op_first;                              /* get past rv2sv */
6137     gv = kGVOP_gv;
6138     if (GvSTASH(gv) != PL_curstash)
6139         return;
6140     gvname = GvNAME(gv);
6141     if (*gvname == 'a' && gvname[1] == '\0')
6142         descending = 0;
6143     else if (*gvname == 'b' && gvname[1] == '\0')
6144         descending = 1;
6145     else
6146         return;
6147
6148     kid = k;                                            /* back to cmp */
6149     if (kBINOP->op_last->op_type != OP_RV2SV)
6150         return;
6151     kid = kBINOP->op_last;                              /* down to 2nd arg */
6152     if (kUNOP->op_first->op_type != OP_GV)
6153         return;
6154     kid = kUNOP->op_first;                              /* get past rv2sv */
6155     gv = kGVOP_gv;
6156     if (GvSTASH(gv) != PL_curstash)
6157         return;
6158     gvname = GvNAME(gv);
6159     if ( descending
6160          ? !(*gvname == 'a' && gvname[1] == '\0')
6161          : !(*gvname == 'b' && gvname[1] == '\0'))
6162         return;
6163     o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6164     if (descending)
6165         o->op_private |= OPpSORT_DESCEND;
6166     if (k->op_type == OP_NCMP)
6167         o->op_private |= OPpSORT_NUMERIC;
6168     if (k->op_type == OP_I_NCMP)
6169         o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6170     kid = cLISTOPo->op_first->op_sibling;
6171     cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6172     op_free(kid);                                     /* then delete it */
6173 }
6174
6175 OP *
6176 Perl_ck_split(pTHX_ OP *o)
6177 {
6178     dVAR;
6179     register OP *kid;
6180
6181     if (o->op_flags & OPf_STACKED)
6182         return no_fh_allowed(o);
6183
6184     kid = cLISTOPo->op_first;
6185     if (kid->op_type != OP_NULL)
6186         Perl_croak(aTHX_ "panic: ck_split");
6187     kid = kid->op_sibling;
6188     op_free(cLISTOPo->op_first);
6189     cLISTOPo->op_first = kid;
6190     if (!kid) {
6191         cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
6192         cLISTOPo->op_last = kid; /* There was only one element previously */
6193     }
6194
6195     if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6196         OP *sibl = kid->op_sibling;
6197         kid->op_sibling = 0;
6198         kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
6199         if (cLISTOPo->op_first == cLISTOPo->op_last)
6200             cLISTOPo->op_last = kid;
6201         cLISTOPo->op_first = kid;
6202         kid->op_sibling = sibl;
6203     }
6204
6205     kid->op_type = OP_PUSHRE;
6206     kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6207     scalar(kid);
6208     if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL && ckWARN(WARN_REGEXP)) {
6209       Perl_warner(aTHX_ packWARN(WARN_REGEXP),
6210                   "Use of /g modifier is meaningless in split");
6211     }
6212
6213     if (!kid->op_sibling)
6214         append_elem(OP_SPLIT, o, newDEFSVOP());
6215
6216     kid = kid->op_sibling;
6217     scalar(kid);
6218
6219     if (!kid->op_sibling)
6220         append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6221
6222     kid = kid->op_sibling;
6223     scalar(kid);
6224
6225     if (kid->op_sibling)
6226         return too_many_arguments(o,OP_DESC(o));
6227
6228     return o;
6229 }
6230
6231 OP *
6232 Perl_ck_join(pTHX_ OP *o)
6233 {
6234     const OP *kid = cLISTOPo->op_first->op_sibling;
6235     if (kid && kid->op_type == OP_MATCH) {
6236         if (ckWARN(WARN_SYNTAX)) {
6237             const REGEXP *re = PM_GETRE(kPMOP);
6238             const char *pmstr = re ? re->precomp : "STRING";
6239             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6240                         "/%s/ should probably be written as \"%s\"",
6241                         pmstr, pmstr);
6242         }
6243     }
6244     return ck_fun(o);
6245 }
6246
6247 OP *
6248 Perl_ck_subr(pTHX_ OP *o)
6249 {
6250     OP *prev = ((cUNOPo->op_first->op_sibling)
6251              ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6252     OP *o2 = prev->op_sibling;
6253     OP *cvop;
6254     char *proto = 0;
6255     CV *cv = 0;
6256     GV *namegv = 0;
6257     int optional = 0;
6258     I32 arg = 0;
6259     I32 contextclass = 0;
6260     char *e = 0;
6261     bool delete_op = 0;
6262
6263     o->op_private |= OPpENTERSUB_HASTARG;
6264     for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6265     if (cvop->op_type == OP_RV2CV) {
6266         SVOP* tmpop;
6267         o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6268         op_null(cvop);          /* disable rv2cv */
6269         tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6270         if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6271             GV *gv = cGVOPx_gv(tmpop);
6272             cv = GvCVu(gv);
6273             if (!cv)
6274                 tmpop->op_private |= OPpEARLY_CV;
6275             else {
6276                 if (SvPOK(cv)) {
6277                     namegv = CvANON(cv) ? gv : CvGV(cv);
6278                     proto = SvPV_nolen((SV*)cv);
6279                 }
6280                 if (CvASSERTION(cv)) {
6281                     if (PL_hints & HINT_ASSERTING) {
6282                         if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
6283                             o->op_private |= OPpENTERSUB_DB;
6284                     }
6285                     else {
6286                         delete_op = 1;
6287                         if (!(PL_hints & HINT_ASSERTIONSSEEN) && ckWARN(WARN_ASSERTIONS)) {
6288                             Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
6289                                         "Impossible to activate assertion call");
6290                         }
6291                     }
6292                 }
6293             }
6294         }
6295     }
6296     else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6297         if (o2->op_type == OP_CONST)
6298             o2->op_private &= ~OPpCONST_STRICT;
6299         else if (o2->op_type == OP_LIST) {
6300             OP *o = ((UNOP*)o2)->op_first->op_sibling;
6301             if (o && o->op_type == OP_CONST)
6302                 o->op_private &= ~OPpCONST_STRICT;
6303         }
6304     }
6305     o->op_private |= (PL_hints & HINT_STRICT_REFS);
6306     if (PERLDB_SUB && PL_curstash != PL_debstash)
6307         o->op_private |= OPpENTERSUB_DB;
6308     while (o2 != cvop) {
6309         if (proto) {
6310             switch (*proto) {
6311             case '\0':
6312                 return too_many_arguments(o, gv_ename(namegv));
6313             case ';':
6314                 optional = 1;
6315                 proto++;
6316                 continue;
6317             case '$':
6318                 proto++;
6319                 arg++;
6320                 scalar(o2);
6321                 break;
6322             case '%':
6323             case '@':
6324                 list(o2);
6325                 arg++;
6326                 break;
6327             case '&':
6328                 proto++;
6329                 arg++;
6330                 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6331                     bad_type(arg,
6332                         arg == 1 ? "block or sub {}" : "sub {}",
6333                         gv_ename(namegv), o2);
6334                 break;
6335             case '*':
6336                 /* '*' allows any scalar type, including bareword */
6337                 proto++;
6338                 arg++;
6339                 if (o2->op_type == OP_RV2GV)
6340                     goto wrapref;       /* autoconvert GLOB -> GLOBref */
6341                 else if (o2->op_type == OP_CONST)
6342                     o2->op_private &= ~OPpCONST_STRICT;
6343                 else if (o2->op_type == OP_ENTERSUB) {
6344                     /* accidental subroutine, revert to bareword */
6345                     OP *gvop = ((UNOP*)o2)->op_first;
6346                     if (gvop && gvop->op_type == OP_NULL) {
6347                         gvop = ((UNOP*)gvop)->op_first;
6348                         if (gvop) {
6349                             for (; gvop->op_sibling; gvop = gvop->op_sibling)
6350                                 ;
6351                             if (gvop &&
6352                                 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6353                                 (gvop = ((UNOP*)gvop)->op_first) &&
6354                                 gvop->op_type == OP_GV)
6355                             {
6356                                 GV *gv = cGVOPx_gv(gvop);
6357                                 OP *sibling = o2->op_sibling;
6358                                 SV *n = newSVpvn("",0);
6359                                 op_free(o2);
6360                                 gv_fullname4(n, gv, "", FALSE);
6361                                 o2 = newSVOP(OP_CONST, 0, n);
6362                                 prev->op_sibling = o2;
6363                                 o2->op_sibling = sibling;
6364                             }
6365                         }
6366                     }
6367                 }
6368                 scalar(o2);
6369                 break;
6370             case '[': case ']':
6371                  goto oops;
6372                  break;
6373             case '\\':
6374                 proto++;
6375                 arg++;
6376             again:
6377                 switch (*proto++) {
6378                 case '[':
6379                      if (contextclass++ == 0) {
6380                           e = strchr(proto, ']');
6381                           if (!e || e == proto)
6382                                goto oops;
6383                      }
6384                      else
6385                           goto oops;
6386                      goto again;
6387                      break;
6388                 case ']':
6389                      if (contextclass) {
6390                          char *p = proto;
6391                          const char s = *p;
6392                          contextclass = 0;
6393                          *p = '\0';
6394                          while (*--p != '[');
6395                          bad_type(arg, Perl_form(aTHX_ "one of %s", p),
6396                                  gv_ename(namegv), o2);
6397                          *proto = s;
6398                      } else
6399                           goto oops;
6400                      break;
6401                 case '*':
6402                      if (o2->op_type == OP_RV2GV)
6403                           goto wrapref;
6404                      if (!contextclass)
6405                           bad_type(arg, "symbol", gv_ename(namegv), o2);
6406                      break;
6407                 case '&':
6408                      if (o2->op_type == OP_ENTERSUB)
6409                           goto wrapref;
6410                      if (!contextclass)
6411                           bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6412                      break;
6413                 case '$':
6414                     if (o2->op_type == OP_RV2SV ||
6415                         o2->op_type == OP_PADSV ||
6416                         o2->op_type == OP_HELEM ||
6417                         o2->op_type == OP_AELEM ||
6418                         o2->op_type == OP_THREADSV)
6419                          goto wrapref;
6420                     if (!contextclass)
6421                         bad_type(arg, "scalar", gv_ename(namegv), o2);
6422                      break;
6423                 case '@':
6424                     if (o2->op_type == OP_RV2AV ||
6425                         o2->op_type == OP_PADAV)
6426                          goto wrapref;
6427                     if (!contextclass)
6428                         bad_type(arg, "array", gv_ename(namegv), o2);
6429                     break;
6430                 case '%':
6431                     if (o2->op_type == OP_RV2HV ||
6432                         o2->op_type == OP_PADHV)
6433                          goto wrapref;
6434                     if (!contextclass)
6435                          bad_type(arg, "hash", gv_ename(namegv), o2);
6436                     break;
6437                 wrapref:
6438                     {
6439                         OP* kid = o2;
6440                         OP* sib = kid->op_sibling;
6441                         kid->op_sibling = 0;
6442                         o2 = newUNOP(OP_REFGEN, 0, kid);
6443                         o2->op_sibling = sib;
6444                         prev->op_sibling = o2;
6445                     }
6446                     if (contextclass && e) {
6447                          proto = e + 1;
6448                          contextclass = 0;
6449                     }
6450                     break;
6451                 default: goto oops;
6452                 }
6453                 if (contextclass)
6454                      goto again;
6455                 break;
6456             case ' ':
6457                 proto++;
6458                 continue;
6459             default:
6460               oops:
6461                 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
6462                            gv_ename(namegv), cv);
6463             }
6464         }
6465         else
6466             list(o2);
6467         mod(o2, OP_ENTERSUB);
6468         prev = o2;
6469         o2 = o2->op_sibling;
6470     }
6471     if (proto && !optional &&
6472           (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6473         return too_few_arguments(o, gv_ename(namegv));
6474     if(delete_op) {
6475         op_free(o);
6476         o=newSVOP(OP_CONST, 0, newSViv(0));
6477     }
6478     return o;
6479 }
6480
6481 OP *
6482 Perl_ck_svconst(pTHX_ OP *o)
6483 {
6484     SvREADONLY_on(cSVOPo->op_sv);
6485     return o;
6486 }
6487
6488 OP *
6489 Perl_ck_trunc(pTHX_ OP *o)
6490 {
6491     if (o->op_flags & OPf_KIDS) {
6492         SVOP *kid = (SVOP*)cUNOPo->op_first;
6493
6494         if (kid->op_type == OP_NULL)
6495             kid = (SVOP*)kid->op_sibling;
6496         if (kid && kid->op_type == OP_CONST &&
6497             (kid->op_private & OPpCONST_BARE))
6498         {
6499             o->op_flags |= OPf_SPECIAL;
6500             kid->op_private &= ~OPpCONST_STRICT;
6501         }
6502     }
6503     return ck_fun(o);
6504 }
6505
6506 OP *
6507 Perl_ck_unpack(pTHX_ OP *o)
6508 {
6509     OP *kid = cLISTOPo->op_first;
6510     if (kid->op_sibling) {
6511         kid = kid->op_sibling;
6512         if (!kid->op_sibling)
6513             kid->op_sibling = newDEFSVOP();
6514     }
6515     return ck_fun(o);
6516 }
6517
6518 OP *
6519 Perl_ck_substr(pTHX_ OP *o)
6520 {
6521     o = ck_fun(o);
6522     if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6523         OP *kid = cLISTOPo->op_first;
6524
6525         if (kid->op_type == OP_NULL)
6526             kid = kid->op_sibling;
6527         if (kid)
6528             kid->op_flags |= OPf_MOD;
6529
6530     }
6531     return o;
6532 }
6533
6534 /* A peephole optimizer.  We visit the ops in the order they're to execute.
6535  * See the comments at the top of this file for more details about when
6536  * peep() is called */
6537
6538 void
6539 Perl_peep(pTHX_ register OP *o)
6540 {
6541     dVAR;
6542     register OP* oldop = 0;
6543
6544     if (!o || o->op_opt)
6545         return;
6546     ENTER;
6547     SAVEOP();
6548     SAVEVPTR(PL_curcop);
6549     for (; o; o = o->op_next) {
6550         if (o->op_opt)
6551             break;
6552         PL_op = o;
6553         switch (o->op_type) {
6554         case OP_SETSTATE:
6555         case OP_NEXTSTATE:
6556         case OP_DBSTATE:
6557             PL_curcop = ((COP*)o);              /* for warnings */
6558             o->op_opt = 1;
6559             break;
6560
6561         case OP_CONST:
6562             if (cSVOPo->op_private & OPpCONST_STRICT)
6563                 no_bareword_allowed(o);
6564 #ifdef USE_ITHREADS
6565         case OP_METHOD_NAMED:
6566             /* Relocate sv to the pad for thread safety.
6567              * Despite being a "constant", the SV is written to,
6568              * for reference counts, sv_upgrade() etc. */
6569             if (cSVOP->op_sv) {
6570                 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6571                 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
6572                     /* If op_sv is already a PADTMP then it is being used by
6573                      * some pad, so make a copy. */
6574                     sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
6575                     SvREADONLY_on(PAD_SVl(ix));
6576                     SvREFCNT_dec(cSVOPo->op_sv);
6577                 }
6578                 else {
6579                     SvREFCNT_dec(PAD_SVl(ix));
6580                     SvPADTMP_on(cSVOPo->op_sv);
6581                     PAD_SETSV(ix, cSVOPo->op_sv);
6582                     /* XXX I don't know how this isn't readonly already. */
6583                     SvREADONLY_on(PAD_SVl(ix));
6584                 }
6585                 cSVOPo->op_sv = Nullsv;
6586                 o->op_targ = ix;
6587             }
6588 #endif
6589             o->op_opt = 1;
6590             break;
6591
6592         case OP_CONCAT:
6593             if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6594                 if (o->op_next->op_private & OPpTARGET_MY) {
6595                     if (o->op_flags & OPf_STACKED) /* chained concats */
6596                         goto ignore_optimization;
6597                     else {
6598                         /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6599                         o->op_targ = o->op_next->op_targ;
6600                         o->op_next->op_targ = 0;
6601                         o->op_private |= OPpTARGET_MY;
6602                     }
6603                 }
6604                 op_null(o->op_next);
6605             }
6606           ignore_optimization:
6607             o->op_opt = 1;
6608             break;
6609         case OP_STUB:
6610             if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6611                 o->op_opt = 1;
6612                 break; /* Scalar stub must produce undef.  List stub is noop */
6613             }
6614             goto nothin;
6615         case OP_NULL:
6616             if (o->op_targ == OP_NEXTSTATE
6617                 || o->op_targ == OP_DBSTATE
6618                 || o->op_targ == OP_SETSTATE)
6619             {
6620                 PL_curcop = ((COP*)o);
6621             }
6622             /* XXX: We avoid setting op_seq here to prevent later calls
6623                to peep() from mistakenly concluding that optimisation
6624                has already occurred. This doesn't fix the real problem,
6625                though (See 20010220.007). AMS 20010719 */
6626             /* op_seq functionality is now replaced by op_opt */
6627             if (oldop && o->op_next) {
6628                 oldop->op_next = o->op_next;
6629                 continue;
6630             }
6631             break;
6632         case OP_SCALAR:
6633         case OP_LINESEQ:
6634         case OP_SCOPE:
6635           nothin:
6636             if (oldop && o->op_next) {
6637                 oldop->op_next = o->op_next;
6638                 continue;
6639             }
6640             o->op_opt = 1;
6641             break;
6642
6643         case OP_PADAV:
6644         case OP_GV:
6645             if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
6646                 OP* pop = (o->op_type == OP_PADAV) ?
6647                             o->op_next : o->op_next->op_next;
6648                 IV i;
6649                 if (pop && pop->op_type == OP_CONST &&
6650                     ((PL_op = pop->op_next)) &&
6651                     pop->op_next->op_type == OP_AELEM &&
6652                     !(pop->op_next->op_private &
6653                       (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6654                     (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
6655                                 <= 255 &&
6656                     i >= 0)
6657                 {
6658                     GV *gv;
6659                     if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
6660                         no_bareword_allowed(pop);
6661                     if (o->op_type == OP_GV)
6662                         op_null(o->op_next);
6663                     op_null(pop->op_next);
6664                     op_null(pop);
6665                     o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6666                     o->op_next = pop->op_next->op_next;
6667                     o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6668                     o->op_private = (U8)i;
6669                     if (o->op_type == OP_GV) {
6670                         gv = cGVOPo_gv;
6671                         GvAVn(gv);
6672                     }
6673                     else
6674                         o->op_flags |= OPf_SPECIAL;
6675                     o->op_type = OP_AELEMFAST;
6676                 }
6677                 o->op_opt = 1;
6678                 break;
6679             }
6680
6681             if (o->op_next->op_type == OP_RV2SV) {
6682                 if (!(o->op_next->op_private & OPpDEREF)) {
6683                     op_null(o->op_next);
6684                     o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6685                                                                | OPpOUR_INTRO);
6686                     o->op_next = o->op_next->op_next;
6687                     o->op_type = OP_GVSV;
6688                     o->op_ppaddr = PL_ppaddr[OP_GVSV];
6689                 }
6690             }
6691             else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6692                 GV *gv = cGVOPo_gv;
6693                 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
6694                     /* XXX could check prototype here instead of just carping */
6695                     SV *sv = sv_newmortal();
6696                     gv_efullname3(sv, gv, Nullch);
6697                     Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
6698                                 "%"SVf"() called too early to check prototype",
6699                                 sv);
6700                 }
6701             }
6702             else if (o->op_next->op_type == OP_READLINE
6703                     && o->op_next->op_next->op_type == OP_CONCAT
6704                     && (o->op_next->op_next->op_flags & OPf_STACKED))
6705             {
6706                 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
6707                 o->op_type   = OP_RCATLINE;
6708                 o->op_flags |= OPf_STACKED;
6709                 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
6710                 op_null(o->op_next->op_next);
6711                 op_null(o->op_next);
6712             }
6713
6714             o->op_opt = 1;
6715             break;
6716
6717         case OP_MAPWHILE:
6718         case OP_GREPWHILE:
6719         case OP_AND:
6720         case OP_OR:
6721         case OP_DOR:
6722         case OP_ANDASSIGN:
6723         case OP_ORASSIGN:
6724         case OP_DORASSIGN:
6725         case OP_COND_EXPR:
6726         case OP_RANGE:
6727             o->op_opt = 1;
6728             while (cLOGOP->op_other->op_type == OP_NULL)
6729                 cLOGOP->op_other = cLOGOP->op_other->op_next;
6730             peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
6731             break;
6732
6733         case OP_ENTERLOOP:
6734         case OP_ENTERITER:
6735             o->op_opt = 1;
6736             while (cLOOP->op_redoop->op_type == OP_NULL)
6737                 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6738             peep(cLOOP->op_redoop);
6739             while (cLOOP->op_nextop->op_type == OP_NULL)
6740                 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6741             peep(cLOOP->op_nextop);
6742             while (cLOOP->op_lastop->op_type == OP_NULL)
6743                 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6744             peep(cLOOP->op_lastop);
6745             break;
6746
6747         case OP_QR:
6748         case OP_MATCH:
6749         case OP_SUBST:
6750             o->op_opt = 1;
6751             while (cPMOP->op_pmreplstart &&
6752                    cPMOP->op_pmreplstart->op_type == OP_NULL)
6753                 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6754             peep(cPMOP->op_pmreplstart);
6755             break;
6756
6757         case OP_EXEC:
6758             o->op_opt = 1;
6759             if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
6760                 && ckWARN(WARN_SYNTAX))
6761             {
6762                 if (o->op_next->op_sibling &&
6763                         o->op_next->op_sibling->op_type != OP_EXIT &&
6764                         o->op_next->op_sibling->op_type != OP_WARN &&
6765                         o->op_next->op_sibling->op_type != OP_DIE) {
6766                     const line_t oldline = CopLINE(PL_curcop);
6767
6768                     CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6769                     Perl_warner(aTHX_ packWARN(WARN_EXEC),
6770                                 "Statement unlikely to be reached");
6771                     Perl_warner(aTHX_ packWARN(WARN_EXEC),
6772                                 "\t(Maybe you meant system() when you said exec()?)\n");
6773                     CopLINE_set(PL_curcop, oldline);
6774                 }
6775             }
6776             break;
6777
6778         case OP_HELEM: {
6779             UNOP *rop;
6780             SV *lexname;
6781             GV **fields;
6782             SV **svp, *sv;
6783             const char *key = NULL;
6784             STRLEN keylen;
6785
6786             o->op_opt = 1;
6787
6788             if (((BINOP*)o)->op_last->op_type != OP_CONST)
6789                 break;
6790
6791             /* Make the CONST have a shared SV */
6792             svp = cSVOPx_svp(((BINOP*)o)->op_last);
6793             if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
6794                 key = SvPV_const(sv, keylen);
6795                 lexname = newSVpvn_share(key,
6796                                          SvUTF8(sv) ? -(I32)keylen : keylen,
6797                                          0);
6798                 SvREFCNT_dec(sv);
6799                 *svp = lexname;
6800             }
6801
6802             if ((o->op_private & (OPpLVAL_INTRO)))
6803                 break;
6804
6805             rop = (UNOP*)((BINOP*)o)->op_first;
6806             if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6807                 break;
6808             lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
6809             if (!(SvFLAGS(lexname) & SVpad_TYPED))
6810                 break;
6811             fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6812             if (!fields || !GvHV(*fields))
6813                 break;
6814             key = SvPV_const(*svp, keylen);
6815             if (!hv_fetch(GvHV(*fields), key,
6816                         SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
6817             {
6818                 Perl_croak(aTHX_ "No such class field \"%s\" "
6819                            "in variable %s of type %s",
6820                       key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
6821             }
6822
6823             break;
6824         }
6825
6826         case OP_HSLICE: {
6827             UNOP *rop;
6828             SV *lexname;
6829             GV **fields;
6830             SV **svp;
6831             const char *key;
6832             STRLEN keylen;
6833             SVOP *first_key_op, *key_op;
6834
6835             if ((o->op_private & (OPpLVAL_INTRO))
6836                 /* I bet there's always a pushmark... */
6837                 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
6838                 /* hmmm, no optimization if list contains only one key. */
6839                 break;
6840             rop = (UNOP*)((LISTOP*)o)->op_last;
6841             if (rop->op_type != OP_RV2HV)
6842                 break;
6843             if (rop->op_first->op_type == OP_PADSV)
6844                 /* @$hash{qw(keys here)} */
6845                 rop = (UNOP*)rop->op_first;
6846             else {
6847                 /* @{$hash}{qw(keys here)} */
6848                 if (rop->op_first->op_type == OP_SCOPE
6849                     && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
6850                 {
6851                     rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
6852                 }
6853                 else
6854                     break;
6855             }
6856
6857             lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
6858             if (!(SvFLAGS(lexname) & SVpad_TYPED))
6859                 break;
6860             fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6861             if (!fields || !GvHV(*fields))
6862                 break;
6863             /* Again guessing that the pushmark can be jumped over.... */
6864             first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
6865                 ->op_first->op_sibling;
6866             for (key_op = first_key_op; key_op;
6867                  key_op = (SVOP*)key_op->op_sibling) {
6868                 if (key_op->op_type != OP_CONST)
6869                     continue;
6870                 svp = cSVOPx_svp(key_op);
6871                 key = SvPV_const(*svp, keylen);
6872                 if (!hv_fetch(GvHV(*fields), key,
6873                             SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
6874                 {
6875                     Perl_croak(aTHX_ "No such class field \"%s\" "
6876                                "in variable %s of type %s",
6877                           key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
6878                 }
6879             }
6880             break;
6881         }
6882
6883         case OP_SORT: {
6884             /* will point to RV2AV or PADAV op on LHS/RHS of assign */
6885             OP *oleft, *oright;
6886             OP *o2;
6887
6888             /* check that RHS of sort is a single plain array */
6889             oright = cUNOPo->op_first;
6890             if (!oright || oright->op_type != OP_PUSHMARK)
6891                 break;
6892
6893             /* reverse sort ... can be optimised.  */
6894             if (!cUNOPo->op_sibling) {
6895                 /* Nothing follows us on the list. */
6896                 OP *reverse = o->op_next;
6897
6898                 if (reverse->op_type == OP_REVERSE &&
6899                     (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
6900                     OP *pushmark = cUNOPx(reverse)->op_first;
6901                     if (pushmark && (pushmark->op_type == OP_PUSHMARK)
6902                         && (cUNOPx(pushmark)->op_sibling == o)) {
6903                         /* reverse -> pushmark -> sort */
6904                         o->op_private |= OPpSORT_REVERSE;
6905                         op_null(reverse);
6906                         pushmark->op_next = oright->op_next;
6907                         op_null(oright);
6908                     }
6909                 }
6910             }
6911
6912             /* make @a = sort @a act in-place */
6913
6914             o->op_opt = 1;
6915
6916             oright = cUNOPx(oright)->op_sibling;
6917             if (!oright)
6918                 break;
6919             if (oright->op_type == OP_NULL) { /* skip sort block/sub */
6920                 oright = cUNOPx(oright)->op_sibling;
6921             }
6922
6923             if (!oright ||
6924                 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
6925                 || oright->op_next != o
6926                 || (oright->op_private & OPpLVAL_INTRO)
6927             )
6928                 break;
6929
6930             /* o2 follows the chain of op_nexts through the LHS of the
6931              * assign (if any) to the aassign op itself */
6932             o2 = o->op_next;
6933             if (!o2 || o2->op_type != OP_NULL)
6934                 break;
6935             o2 = o2->op_next;
6936             if (!o2 || o2->op_type != OP_PUSHMARK)
6937                 break;
6938             o2 = o2->op_next;
6939             if (o2 && o2->op_type == OP_GV)
6940                 o2 = o2->op_next;
6941             if (!o2
6942                 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
6943                 || (o2->op_private & OPpLVAL_INTRO)
6944             )
6945                 break;
6946             oleft = o2;
6947             o2 = o2->op_next;
6948             if (!o2 || o2->op_type != OP_NULL)
6949                 break;
6950             o2 = o2->op_next;
6951             if (!o2 || o2->op_type != OP_AASSIGN
6952                     || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
6953                 break;
6954
6955             /* check that the sort is the first arg on RHS of assign */
6956
6957             o2 = cUNOPx(o2)->op_first;
6958             if (!o2 || o2->op_type != OP_NULL)
6959                 break;
6960             o2 = cUNOPx(o2)->op_first;
6961             if (!o2 || o2->op_type != OP_PUSHMARK)
6962                 break;
6963             if (o2->op_sibling != o)
6964                 break;
6965
6966             /* check the array is the same on both sides */
6967             if (oleft->op_type == OP_RV2AV) {
6968                 if (oright->op_type != OP_RV2AV
6969                     || !cUNOPx(oright)->op_first
6970                     || cUNOPx(oright)->op_first->op_type != OP_GV
6971                     ||  cGVOPx_gv(cUNOPx(oleft)->op_first) !=
6972                         cGVOPx_gv(cUNOPx(oright)->op_first)
6973                 )
6974                     break;
6975             }
6976             else if (oright->op_type != OP_PADAV
6977                 || oright->op_targ != oleft->op_targ
6978             )
6979                 break;
6980
6981             /* transfer MODishness etc from LHS arg to RHS arg */
6982             oright->op_flags = oleft->op_flags;
6983             o->op_private |= OPpSORT_INPLACE;
6984
6985             /* excise push->gv->rv2av->null->aassign */
6986             o2 = o->op_next->op_next;
6987             op_null(o2); /* PUSHMARK */
6988             o2 = o2->op_next;
6989             if (o2->op_type == OP_GV) {
6990                 op_null(o2); /* GV */
6991                 o2 = o2->op_next;
6992             }
6993             op_null(o2); /* RV2AV or PADAV */
6994             o2 = o2->op_next->op_next;
6995             op_null(o2); /* AASSIGN */
6996
6997             o->op_next = o2->op_next;
6998
6999             break;
7000         }
7001
7002         case OP_REVERSE: {
7003             OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
7004             OP *gvop = NULL;
7005             LISTOP *enter, *exlist;
7006             o->op_opt = 1;
7007
7008             enter = (LISTOP *) o->op_next;
7009             if (!enter)
7010                 break;
7011             if (enter->op_type == OP_NULL) {
7012                 enter = (LISTOP *) enter->op_next;
7013                 if (!enter)
7014                     break;
7015             }
7016             /* for $a (...) will have OP_GV then OP_RV2GV here.
7017                for (...) just has an OP_GV.  */
7018             if (enter->op_type == OP_GV) {
7019                 gvop = (OP *) enter;
7020                 enter = (LISTOP *) enter->op_next;
7021                 if (!enter)
7022                     break;
7023                 if (enter->op_type == OP_RV2GV) {
7024                   enter = (LISTOP *) enter->op_next;
7025                   if (!enter)
7026                     break;
7027                 }
7028             }
7029
7030             if (enter->op_type != OP_ENTERITER)
7031                 break;
7032
7033             iter = enter->op_next;
7034             if (!iter || iter->op_type != OP_ITER)
7035                 break;
7036
7037             expushmark = enter->op_first;
7038             if (!expushmark || expushmark->op_type != OP_NULL
7039                 || expushmark->op_targ != OP_PUSHMARK)
7040                 break;
7041
7042             exlist = (LISTOP *) expushmark->op_sibling;
7043             if (!exlist || exlist->op_type != OP_NULL
7044                 || exlist->op_targ != OP_LIST)
7045                 break;
7046
7047             if (exlist->op_last != o) {
7048                 /* Mmm. Was expecting to point back to this op.  */
7049                 break;
7050             }
7051             theirmark = exlist->op_first;
7052             if (!theirmark || theirmark->op_type != OP_PUSHMARK)
7053                 break;
7054
7055             if (theirmark->op_sibling != o) {
7056                 /* There's something between the mark and the reverse, eg
7057                    for (1, reverse (...))
7058                    so no go.  */
7059                 break;
7060             }
7061
7062             ourmark = ((LISTOP *)o)->op_first;
7063             if (!ourmark || ourmark->op_type != OP_PUSHMARK)
7064                 break;
7065
7066             ourlast = ((LISTOP *)o)->op_last;
7067             if (!ourlast || ourlast->op_next != o)
7068                 break;
7069
7070             rv2av = ourmark->op_sibling;
7071             if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
7072                 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
7073                 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
7074                 /* We're just reversing a single array.  */
7075                 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
7076                 enter->op_flags |= OPf_STACKED;
7077             }
7078
7079             /* We don't have control over who points to theirmark, so sacrifice
7080                ours.  */
7081             theirmark->op_next = ourmark->op_next;
7082             theirmark->op_flags = ourmark->op_flags;
7083             ourlast->op_next = gvop ? gvop : (OP *) enter;
7084             op_null(ourmark);
7085             op_null(o);
7086             enter->op_private |= OPpITER_REVERSED;
7087             iter->op_private |= OPpITER_REVERSED;
7088
7089             break;
7090         }
7091
7092         default:
7093             o->op_opt = 1;
7094             break;
7095         }
7096         oldop = o;
7097     }
7098     LEAVE;
7099 }
7100
7101 char*
7102 Perl_custom_op_name(pTHX_ const OP* o)
7103 {
7104     const IV index = PTR2IV(o->op_ppaddr);
7105     SV* keysv;
7106     HE* he;
7107
7108     if (!PL_custom_op_names) /* This probably shouldn't happen */
7109         return (char *)PL_op_name[OP_CUSTOM];
7110
7111     keysv = sv_2mortal(newSViv(index));
7112
7113     he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
7114     if (!he)
7115         return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
7116
7117     return SvPV_nolen(HeVAL(he));
7118 }
7119
7120 char*
7121 Perl_custom_op_desc(pTHX_ const OP* o)
7122 {
7123     const IV index = PTR2IV(o->op_ppaddr);
7124     SV* keysv;
7125     HE* he;
7126
7127     if (!PL_custom_op_descs)
7128         return (char *)PL_op_desc[OP_CUSTOM];
7129
7130     keysv = sv_2mortal(newSViv(index));
7131
7132     he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
7133     if (!he)
7134         return (char *)PL_op_desc[OP_CUSTOM];
7135
7136     return SvPV_nolen(HeVAL(he));
7137 }
7138
7139 #include "XSUB.h"
7140
7141 /* Efficient sub that returns a constant scalar value. */
7142 static void
7143 const_sv_xsub(pTHX_ CV* cv)
7144 {
7145     dXSARGS;
7146     if (items != 0) {
7147 #if 0
7148         Perl_croak(aTHX_ "usage: %s::%s()",
7149                    HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
7150 #endif
7151     }
7152     EXTEND(sp, 1);
7153     ST(0) = (SV*)XSANY.any_ptr;
7154     XSRETURN(1);
7155 }
7156
7157 /*
7158  * Local variables:
7159  * c-indentation-style: bsd
7160  * c-basic-offset: 4
7161  * indent-tabs-mode: t
7162  * End:
7163  *
7164  * ex: set ts=8 sts=4 sw=4 noet:
7165  */