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