op.c

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