op.c

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