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