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