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         if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5412             const char *badthing = Nullch;
5413             switch (o->op_type) {
5414             case OP_RV2SV:
5415                 badthing = "a SCALAR";
5416                 break;
5417             case OP_RV2AV:
5418                 badthing = "an ARRAY";
5419                 break;
5420             case OP_RV2HV:
5421                 badthing = "a HASH";
5422                 break;
5423             }
5424             if (badthing)
5425                 Perl_croak(aTHX_
5426           "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
5427                       kidsv, badthing);
5428         }
5429         /*
5430          * This is a little tricky.  We only want to add the symbol if we
5431          * didn't add it in the lexer.  Otherwise we get duplicate strict
5432          * warnings.  But if we didn't add it in the lexer, we must at
5433          * least pretend like we wanted to add it even if it existed before,
5434          * or we get possible typo warnings.  OPpCONST_ENTERED says
5435          * whether the lexer already added THIS instance of this symbol.
5436          */
5437         iscv = (o->op_type == OP_RV2CV) * 2;
5438         do {
5439             gv = gv_fetchsv(kidsv,
5440                 iscv | !(kid->op_private & OPpCONST_ENTERED),
5441                 iscv
5442                     ? SVt_PVCV
5443                     : o->op_type == OP_RV2SV
5444                         ? SVt_PV
5445                         : o->op_type == OP_RV2AV
5446                             ? SVt_PVAV
5447                             : o->op_type == OP_RV2HV
5448                                 ? SVt_PVHV
5449                                 : SVt_PVGV);
5450         } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5451         if (gv) {
5452             kid->op_type = OP_GV;
5453             SvREFCNT_dec(kid->op_sv);
5454 #ifdef USE_ITHREADS
5455             /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5456             kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5457             SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
5458             GvIN_PAD_on(gv);
5459             PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc(gv));
5460 #else
5461             kid->op_sv = SvREFCNT_inc(gv);
5462 #endif
5463             kid->op_private = 0;
5464             kid->op_ppaddr = PL_ppaddr[OP_GV];
5465         }
5466     }
5467     return o;
5468 }
5469
5470 OP *
5471 Perl_ck_ftst(pTHX_ OP *o)
5472 {
5473     dVAR;
5474     const I32 type = o->op_type;
5475
5476     if (o->op_flags & OPf_REF) {
5477         /* nothing */
5478     }
5479     else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5480         SVOP * const kid = (SVOP*)cUNOPo->op_first;
5481
5482         if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5483             OP * const newop = newGVOP(type, OPf_REF,
5484                 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
5485             op_free(o);
5486             o = newop;
5487             return o;
5488         }
5489         else {
5490           if ((PL_hints & HINT_FILETEST_ACCESS) &&
5491               OP_IS_FILETEST_ACCESS(o))
5492             o->op_private |= OPpFT_ACCESS;
5493         }
5494         if (PL_check[kid->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst)
5495                 && kid->op_type != OP_STAT && kid->op_type != OP_LSTAT)
5496             o->op_private |= OPpFT_STACKED;
5497     }
5498     else {
5499         op_free(o);
5500         if (type == OP_FTTTY)
5501             o = newGVOP(type, OPf_REF, PL_stdingv);
5502         else
5503             o = newUNOP(type, 0, newDEFSVOP());
5504     }
5505     return o;
5506 }
5507
5508 OP *
5509 Perl_ck_fun(pTHX_ OP *o)
5510 {
5511     const int type = o->op_type;
5512     register I32 oa = PL_opargs[type] >> OASHIFT;
5513
5514     if (o->op_flags & OPf_STACKED) {
5515         if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5516             oa &= ~OA_OPTIONAL;
5517         else
5518             return no_fh_allowed(o);
5519     }
5520
5521     if (o->op_flags & OPf_KIDS) {
5522         OP **tokid = &cLISTOPo->op_first;
5523         register OP *kid = cLISTOPo->op_first;
5524         OP *sibl;
5525         I32 numargs = 0;
5526
5527         if (kid->op_type == OP_PUSHMARK ||
5528             (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5529         {
5530             tokid = &kid->op_sibling;
5531             kid = kid->op_sibling;
5532         }
5533         if (!kid && PL_opargs[type] & OA_DEFGV)
5534             *tokid = kid = newDEFSVOP();
5535
5536         while (oa && kid) {
5537             numargs++;
5538             sibl = kid->op_sibling;
5539             switch (oa & 7) {
5540             case OA_SCALAR:
5541                 /* list seen where single (scalar) arg expected? */
5542                 if (numargs == 1 && !(oa >> 4)
5543                     && kid->op_type == OP_LIST && type != OP_SCALAR)
5544                 {
5545                     return too_many_arguments(o,PL_op_desc[type]);
5546                 }
5547                 scalar(kid);
5548                 break;
5549             case OA_LIST:
5550                 if (oa < 16) {
5551                     kid = 0;
5552                     continue;
5553                 }
5554                 else
5555                     list(kid);
5556                 break;
5557             case OA_AVREF:
5558                 if ((type == OP_PUSH || type == OP_UNSHIFT)
5559                     && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5560                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5561                         "Useless use of %s with no values",
5562                         PL_op_desc[type]);
5563
5564                 if (kid->op_type == OP_CONST &&
5565                     (kid->op_private & OPpCONST_BARE))
5566                 {
5567                     OP * const newop = newAVREF(newGVOP(OP_GV, 0,
5568                         gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
5569                     if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5570                         Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5571                             "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
5572                             ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
5573                     op_free(kid);
5574                     kid = newop;
5575                     kid->op_sibling = sibl;
5576                     *tokid = kid;
5577                 }
5578                 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5579                     bad_type(numargs, "array", PL_op_desc[type], kid);
5580                 mod(kid, type);
5581                 break;
5582             case OA_HVREF:
5583                 if (kid->op_type == OP_CONST &&
5584                     (kid->op_private & OPpCONST_BARE))
5585                 {
5586                     OP * const newop = newHVREF(newGVOP(OP_GV, 0,
5587                         gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
5588                     if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5589                         Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5590                             "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
5591                             ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
5592                     op_free(kid);
5593                     kid = newop;
5594                     kid->op_sibling = sibl;
5595                     *tokid = kid;
5596                 }
5597                 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5598                     bad_type(numargs, "hash", PL_op_desc[type], kid);
5599                 mod(kid, type);
5600                 break;
5601             case OA_CVREF:
5602                 {
5603                     OP * const newop = newUNOP(OP_NULL, 0, kid);
5604                     kid->op_sibling = 0;
5605                     linklist(kid);
5606                     newop->op_next = newop;
5607                     kid = newop;
5608                     kid->op_sibling = sibl;
5609                     *tokid = kid;
5610                 }
5611                 break;
5612             case OA_FILEREF:
5613                 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5614                     if (kid->op_type == OP_CONST &&
5615                         (kid->op_private & OPpCONST_BARE))
5616                     {
5617                         OP * const newop = newGVOP(OP_GV, 0,
5618                             gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
5619                         if (!(o->op_private & 1) && /* if not unop */
5620                             kid == cLISTOPo->op_last)
5621                             cLISTOPo->op_last = newop;
5622                         op_free(kid);
5623                         kid = newop;
5624                     }
5625                     else if (kid->op_type == OP_READLINE) {
5626                         /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5627                         bad_type(numargs, "HANDLE", OP_DESC(o), kid);
5628                     }
5629                     else {
5630                         I32 flags = OPf_SPECIAL;
5631                         I32 priv = 0;
5632                         PADOFFSET targ = 0;
5633
5634                         /* is this op a FH constructor? */
5635                         if (is_handle_constructor(o,numargs)) {
5636                             const char *name = Nullch;
5637                             STRLEN len = 0;
5638
5639                             flags = 0;
5640                             /* Set a flag to tell rv2gv to vivify
5641                              * need to "prove" flag does not mean something
5642                              * else already - NI-S 1999/05/07
5643                              */
5644                             priv = OPpDEREF;
5645                             if (kid->op_type == OP_PADSV) {
5646                                 name = PAD_COMPNAME_PV(kid->op_targ);
5647                                 /* SvCUR of a pad namesv can't be trusted
5648                                  * (see PL_generation), so calc its length
5649                                  * manually */
5650                                 if (name)
5651                                     len = strlen(name);
5652
5653                             }
5654                             else if (kid->op_type == OP_RV2SV
5655                                      && kUNOP->op_first->op_type == OP_GV)
5656                             {
5657                                 GV * const gv = cGVOPx_gv(kUNOP->op_first);
5658                                 name = GvNAME(gv);
5659                                 len = GvNAMELEN(gv);
5660                             }
5661                             else if (kid->op_type == OP_AELEM
5662                                      || kid->op_type == OP_HELEM)
5663                             {
5664                                  OP *op = ((BINOP*)kid)->op_first;
5665                                  name = 0;
5666                                  if (op) {
5667                                       SV *tmpstr = Nullsv;
5668                                       const char * const a =
5669                                            kid->op_type == OP_AELEM ?
5670                                            "[]" : "{}";
5671                                       if (((op->op_type == OP_RV2AV) ||
5672                                            (op->op_type == OP_RV2HV)) &&
5673                                           (op = ((UNOP*)op)->op_first) &&
5674                                           (op->op_type == OP_GV)) {
5675                                            /* packagevar $a[] or $h{} */
5676                                            GV * const gv = cGVOPx_gv(op);
5677                                            if (gv)
5678                                                 tmpstr =
5679                                                      Perl_newSVpvf(aTHX_
5680                                                                    "%s%c...%c",
5681                                                                    GvNAME(gv),
5682                                                                    a[0], a[1]);
5683                                       }
5684                                       else if (op->op_type == OP_PADAV
5685                                                || op->op_type == OP_PADHV) {
5686                                            /* lexicalvar $a[] or $h{} */
5687                                            const char * const padname =
5688                                                 PAD_COMPNAME_PV(op->op_targ);
5689                                            if (padname)
5690                                                 tmpstr =
5691                                                      Perl_newSVpvf(aTHX_
5692                                                                    "%s%c...%c",
5693                                                                    padname + 1,
5694                                                                    a[0], a[1]);
5695                                       }
5696                                       if (tmpstr) {
5697                                            name = SvPV_const(tmpstr, len);
5698                                            sv_2mortal(tmpstr);
5699                                       }
5700                                  }
5701                                  if (!name) {
5702                                       name = "__ANONIO__";
5703                                       len = 10;
5704                                  }
5705                                  mod(kid, type);
5706                             }
5707                             if (name) {
5708                                 SV *namesv;
5709                                 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5710                                 namesv = PAD_SVl(targ);
5711                                 SvUPGRADE(namesv, SVt_PV);
5712                                 if (*name != '$')
5713                                     sv_setpvn(namesv, "$", 1);
5714                                 sv_catpvn(namesv, name, len);
5715                             }
5716                         }
5717                         kid->op_sibling = 0;
5718                         kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5719                         kid->op_targ = targ;
5720                         kid->op_private |= priv;
5721                     }
5722                     kid->op_sibling = sibl;
5723                     *tokid = kid;
5724                 }
5725                 scalar(kid);
5726                 break;
5727             case OA_SCALARREF:
5728                 mod(scalar(kid), type);
5729                 break;
5730             }
5731             oa >>= 4;
5732             tokid = &kid->op_sibling;
5733             kid = kid->op_sibling;
5734         }
5735         o->op_private |= numargs;
5736         if (kid)
5737             return too_many_arguments(o,OP_DESC(o));
5738         listkids(o);
5739     }
5740     else if (PL_opargs[type] & OA_DEFGV) {
5741         op_free(o);
5742         return newUNOP(type, 0, newDEFSVOP());
5743     }
5744
5745     if (oa) {
5746         while (oa & OA_OPTIONAL)
5747             oa >>= 4;
5748         if (oa && oa != OA_LIST)
5749             return too_few_arguments(o,OP_DESC(o));
5750     }
5751     return o;
5752 }
5753
5754 OP *
5755 Perl_ck_glob(pTHX_ OP *o)
5756 {
5757     dVAR;
5758     GV *gv;
5759
5760     o = ck_fun(o);
5761     if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5762         append_elem(OP_GLOB, o, newDEFSVOP());
5763
5764     if (!((gv = gv_fetchpv("glob", 0, SVt_PVCV))
5765           && GvCVu(gv) && GvIMPORTED_CV(gv)))
5766     {
5767         gv = gv_fetchpv("CORE::GLOBAL::glob", 0, SVt_PVCV);
5768     }
5769
5770 #if !defined(PERL_EXTERNAL_GLOB)
5771     /* XXX this can be tightened up and made more failsafe. */
5772     if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
5773         GV *glob_gv;
5774         ENTER;
5775         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
5776                 newSVpvn("File::Glob", 10), Nullsv, Nullsv, Nullsv);
5777         gv = gv_fetchpv("CORE::GLOBAL::glob", 0, SVt_PVCV);
5778         glob_gv = gv_fetchpv("File::Glob::csh_glob", 0, SVt_PVCV);
5779         GvCV(gv) = GvCV(glob_gv);
5780         (void)SvREFCNT_inc((SV*)GvCV(gv));
5781         GvIMPORTED_CV_on(gv);
5782         LEAVE;
5783     }
5784 #endif /* PERL_EXTERNAL_GLOB */
5785
5786     if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5787         append_elem(OP_GLOB, o,
5788                     newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5789         o->op_type = OP_LIST;
5790         o->op_ppaddr = PL_ppaddr[OP_LIST];
5791         cLISTOPo->op_first->op_type = OP_PUSHMARK;
5792         cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5793         cLISTOPo->op_first->op_targ = 0;
5794         o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5795                     append_elem(OP_LIST, o,
5796                                 scalar(newUNOP(OP_RV2CV, 0,
5797                                                newGVOP(OP_GV, 0, gv)))));
5798         o = newUNOP(OP_NULL, 0, ck_subr(o));
5799         o->op_targ = OP_GLOB;           /* hint at what it used to be */
5800         return o;
5801     }
5802     gv = newGVgen("main");
5803     gv_IOadd(gv);
5804     append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5805     scalarkids(o);
5806     return o;
5807 }
5808
5809 OP *
5810 Perl_ck_grep(pTHX_ OP *o)
5811 {
5812     dVAR;
5813     LOGOP *gwop;
5814     OP *kid;
5815     const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5816     I32 offset;
5817
5818     o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5819     NewOp(1101, gwop, 1, LOGOP);
5820
5821     if (o->op_flags & OPf_STACKED) {
5822         OP* k;
5823         o = ck_sort(o);
5824         kid = cLISTOPo->op_first->op_sibling;
5825         if (!cUNOPx(kid)->op_next)
5826             Perl_croak(aTHX_ "panic: ck_grep");
5827         for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
5828             kid = k;
5829         }
5830         kid->op_next = (OP*)gwop;
5831         o->op_flags &= ~OPf_STACKED;
5832     }
5833     kid = cLISTOPo->op_first->op_sibling;
5834     if (type == OP_MAPWHILE)
5835         list(kid);
5836     else
5837         scalar(kid);
5838     o = ck_fun(o);
5839     if (PL_error_count)
5840         return o;
5841     kid = cLISTOPo->op_first->op_sibling;
5842     if (kid->op_type != OP_NULL)
5843         Perl_croak(aTHX_ "panic: ck_grep");
5844     kid = kUNOP->op_first;
5845
5846     gwop->op_type = type;
5847     gwop->op_ppaddr = PL_ppaddr[type];
5848     gwop->op_first = listkids(o);
5849     gwop->op_flags |= OPf_KIDS;
5850     gwop->op_other = LINKLIST(kid);
5851     kid->op_next = (OP*)gwop;
5852     offset = pad_findmy("$_");
5853     if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
5854         o->op_private = gwop->op_private = 0;
5855         gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5856     }
5857     else {
5858         o->op_private = gwop->op_private = OPpGREP_LEX;
5859         gwop->op_targ = o->op_targ = offset;
5860     }
5861
5862     kid = cLISTOPo->op_first->op_sibling;
5863     if (!kid || !kid->op_sibling)
5864         return too_few_arguments(o,OP_DESC(o));
5865     for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5866         mod(kid, OP_GREPSTART);
5867
5868     return (OP*)gwop;
5869 }
5870
5871 OP *
5872 Perl_ck_index(pTHX_ OP *o)
5873 {
5874     if (o->op_flags & OPf_KIDS) {
5875         OP *kid = cLISTOPo->op_first->op_sibling;       /* get past pushmark */
5876         if (kid)
5877             kid = kid->op_sibling;                      /* get past "big" */
5878         if (kid && kid->op_type == OP_CONST)
5879             fbm_compile(((SVOP*)kid)->op_sv, 0);
5880     }
5881     return ck_fun(o);
5882 }
5883
5884 OP *
5885 Perl_ck_lengthconst(pTHX_ OP *o)
5886 {
5887     /* XXX length optimization goes here */
5888     return ck_fun(o);
5889 }
5890
5891 OP *
5892 Perl_ck_lfun(pTHX_ OP *o)
5893 {
5894     const OPCODE type = o->op_type;
5895     return modkids(ck_fun(o), type);
5896 }
5897
5898 OP *
5899 Perl_ck_defined(pTHX_ OP *o)            /* 19990527 MJD */
5900 {
5901     if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
5902         switch (cUNOPo->op_first->op_type) {
5903         case OP_RV2AV:
5904             /* This is needed for
5905                if (defined %stash::)
5906                to work.   Do not break Tk.
5907                */
5908             break;                      /* Globals via GV can be undef */
5909         case OP_PADAV:
5910         case OP_AASSIGN:                /* Is this a good idea? */
5911             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5912                         "defined(@array) is deprecated");
5913             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5914                         "\t(Maybe you should just omit the defined()?)\n");
5915         break;
5916         case OP_RV2HV:
5917             /* This is needed for
5918                if (defined %stash::)
5919                to work.   Do not break Tk.
5920                */
5921             break;                      /* Globals via GV can be undef */
5922         case OP_PADHV:
5923             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5924                         "defined(%%hash) is deprecated");
5925             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5926                         "\t(Maybe you should just omit the defined()?)\n");
5927             break;
5928         default:
5929             /* no warning */
5930             break;
5931         }
5932     }
5933     return ck_rfun(o);
5934 }
5935
5936 OP *
5937 Perl_ck_rfun(pTHX_ OP *o)
5938 {
5939     const OPCODE type = o->op_type;
5940     return refkids(ck_fun(o), type);
5941 }
5942
5943 OP *
5944 Perl_ck_listiob(pTHX_ OP *o)
5945 {
5946     register OP *kid;
5947
5948     kid = cLISTOPo->op_first;
5949     if (!kid) {
5950         o = force_list(o);
5951         kid = cLISTOPo->op_first;
5952     }
5953     if (kid->op_type == OP_PUSHMARK)
5954         kid = kid->op_sibling;
5955     if (kid && o->op_flags & OPf_STACKED)
5956         kid = kid->op_sibling;
5957     else if (kid && !kid->op_sibling) {         /* print HANDLE; */
5958         if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
5959             o->op_flags |= OPf_STACKED; /* make it a filehandle */
5960             kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
5961             cLISTOPo->op_first->op_sibling = kid;
5962             cLISTOPo->op_last = kid;
5963             kid = kid->op_sibling;
5964         }
5965     }
5966
5967     if (!kid)
5968         append_elem(o->op_type, o, newDEFSVOP());
5969
5970     return listkids(o);
5971 }
5972
5973 OP *
5974 Perl_ck_say(pTHX_ OP *o)
5975 {
5976     o = ck_listiob(o);
5977     o->op_type = OP_PRINT;
5978     cLISTOPo->op_last = cLISTOPo->op_last->op_sibling
5979         = newSVOP(OP_CONST, 0, newSVpvn("\n", 1));
5980     return o;
5981 }
5982
5983 OP *
5984 Perl_ck_smartmatch(pTHX_ OP *o)
5985 {
5986     if (0 == (o->op_flags & OPf_SPECIAL)) {
5987         OP *first  = cBINOPo->op_first;
5988         OP *second = first->op_sibling;
5989
5990         /* Implicitly take a reference to an array or hash */
5991         first->op_sibling = Nullop;
5992         first = cBINOPo->op_first = ref_array_or_hash(first);
5993         second = first->op_sibling = ref_array_or_hash(second);
5994
5995         /* Implicitly take a reference to a regular expression */
5996         if (first->op_type == OP_MATCH) {
5997             first->op_type = OP_QR;
5998             first->op_ppaddr = PL_ppaddr[OP_QR];
5999         }
6000         if (second->op_type == OP_MATCH) {
6001             second->op_type = OP_QR;
6002             second->op_ppaddr = PL_ppaddr[OP_QR];
6003         }
6004     }
6005
6006     return o;
6007 }
6008
6009
6010 OP *
6011 Perl_ck_sassign(pTHX_ OP *o)
6012 {
6013     OP *kid = cLISTOPo->op_first;
6014     /* has a disposable target? */
6015     if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6016         && !(kid->op_flags & OPf_STACKED)
6017         /* Cannot steal the second time! */
6018         && !(kid->op_private & OPpTARGET_MY))
6019     {
6020         OP * const kkid = kid->op_sibling;
6021
6022         /* Can just relocate the target. */
6023         if (kkid && kkid->op_type == OP_PADSV
6024             && !(kkid->op_private & OPpLVAL_INTRO))
6025         {
6026             kid->op_targ = kkid->op_targ;
6027             kkid->op_targ = 0;
6028             /* Now we do not need PADSV and SASSIGN. */
6029             kid->op_sibling = o->op_sibling;    /* NULL */
6030             cLISTOPo->op_first = NULL;
6031             op_free(o);
6032             op_free(kkid);
6033             kid->op_private |= OPpTARGET_MY;    /* Used for context settings */
6034             return kid;
6035         }
6036     }
6037     return o;
6038 }
6039
6040 OP *
6041 Perl_ck_match(pTHX_ OP *o)
6042 {
6043     if (o->op_type != OP_QR && PL_compcv) {
6044         const I32 offset = pad_findmy("$_");
6045         if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS(offset) & SVpad_OUR)) {
6046             o->op_targ = offset;
6047             o->op_private |= OPpTARGET_MY;
6048         }
6049     }
6050     if (o->op_type == OP_MATCH || o->op_type == OP_QR)
6051         o->op_private |= OPpRUNTIME;
6052     return o;
6053 }
6054
6055 OP *
6056 Perl_ck_method(pTHX_ OP *o)
6057 {
6058     OP * const kid = cUNOPo->op_first;
6059     if (kid->op_type == OP_CONST) {
6060         SV* sv = kSVOP->op_sv;
6061         if (!(strchr(SvPVX_const(sv), ':') || strchr(SvPVX_const(sv), '\''))) {
6062             OP *cmop;
6063             if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6064                 sv = newSVpvn_share(SvPVX_const(sv), SvCUR(sv), 0);
6065             }
6066             else {
6067                 kSVOP->op_sv = Nullsv;
6068             }
6069             cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6070             op_free(o);
6071             return cmop;
6072         }
6073     }
6074     return o;
6075 }
6076
6077 OP *
6078 Perl_ck_null(pTHX_ OP *o)
6079 {
6080     return o;
6081 }
6082
6083 OP *
6084 Perl_ck_open(pTHX_ OP *o)
6085 {
6086     HV * const table = GvHV(PL_hintgv);
6087     if (table) {
6088         SV **svp = hv_fetch(table, "open_IN", 7, FALSE);
6089         if (svp && *svp) {
6090             const I32 mode = mode_from_discipline(*svp);
6091             if (mode & O_BINARY)
6092                 o->op_private |= OPpOPEN_IN_RAW;
6093             else if (mode & O_TEXT)
6094                 o->op_private |= OPpOPEN_IN_CRLF;
6095         }
6096
6097         svp = hv_fetch(table, "open_OUT", 8, FALSE);
6098         if (svp && *svp) {
6099             const I32 mode = mode_from_discipline(*svp);
6100             if (mode & O_BINARY)
6101                 o->op_private |= OPpOPEN_OUT_RAW;
6102             else if (mode & O_TEXT)
6103                 o->op_private |= OPpOPEN_OUT_CRLF;
6104         }
6105     }
6106     if (o->op_type == OP_BACKTICK)
6107         return o;
6108     {
6109          /* In case of three-arg dup open remove strictness
6110           * from the last arg if it is a bareword. */
6111          OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
6112          OP * const last  = cLISTOPx(o)->op_last;  /* The bareword. */
6113          OP *oa;
6114          const char *mode;
6115
6116          if ((last->op_type == OP_CONST) &&             /* The bareword. */
6117              (last->op_private & OPpCONST_BARE) &&
6118              (last->op_private & OPpCONST_STRICT) &&
6119              (oa = first->op_sibling) &&                /* The fh. */
6120              (oa = oa->op_sibling) &&                   /* The mode. */
6121              (oa->op_type == OP_CONST) &&
6122              SvPOK(((SVOP*)oa)->op_sv) &&
6123              (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
6124              mode[0] == '>' && mode[1] == '&' &&        /* A dup open. */
6125              (last == oa->op_sibling))                  /* The bareword. */
6126               last->op_private &= ~OPpCONST_STRICT;
6127     }
6128     return ck_fun(o);
6129 }
6130
6131 OP *
6132 Perl_ck_repeat(pTHX_ OP *o)
6133 {
6134     if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6135         o->op_private |= OPpREPEAT_DOLIST;
6136         cBINOPo->op_first = force_list(cBINOPo->op_first);
6137     }
6138     else
6139         scalar(o);
6140     return o;
6141 }
6142
6143 OP *
6144 Perl_ck_require(pTHX_ OP *o)
6145 {
6146     GV* gv = Nullgv;
6147
6148     if (o->op_flags & OPf_KIDS) {       /* Shall we supply missing .pm? */
6149         SVOP * const kid = (SVOP*)cUNOPo->op_first;
6150
6151         if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6152             SV * const sv = kid->op_sv;
6153             U32 was_readonly = SvREADONLY(sv);
6154             char *s;
6155
6156             if (was_readonly) {
6157                 if (SvFAKE(sv)) {
6158                     sv_force_normal_flags(sv, 0);
6159                     assert(!SvREADONLY(sv));
6160                     was_readonly = 0;
6161                 } else {
6162                     SvREADONLY_off(sv);
6163                 }
6164             }
6165
6166             for (s = SvPVX(sv); *s; s++) {
6167                 if (*s == ':' && s[1] == ':') {
6168                     const STRLEN len = strlen(s+2)+1;
6169                     *s = '/';
6170                     Move(s+2, s+1, len, char);
6171                     SvCUR_set(sv, SvCUR(sv) - 1);
6172                 }
6173             }
6174             sv_catpvn(sv, ".pm", 3);
6175             SvFLAGS(sv) |= was_readonly;
6176         }
6177     }
6178
6179     if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
6180         /* handle override, if any */
6181         gv = gv_fetchpv("require", 0, SVt_PVCV);
6182         if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
6183             GV * const * const gvp = (GV**)hv_fetch(PL_globalstash, "require", 7, FALSE);
6184             gv = gvp ? *gvp : Nullgv;
6185         }
6186     }
6187
6188     if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6189         OP * const kid = cUNOPo->op_first;
6190         cUNOPo->op_first = 0;
6191         op_free(o);
6192         return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
6193                                append_elem(OP_LIST, kid,
6194                                            scalar(newUNOP(OP_RV2CV, 0,
6195                                                           newGVOP(OP_GV, 0,
6196                                                                   gv))))));
6197     }
6198
6199     return ck_fun(o);
6200 }
6201
6202 OP *
6203 Perl_ck_return(pTHX_ OP *o)
6204 {
6205     if (CvLVALUE(PL_compcv)) {
6206         OP *kid;
6207         for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
6208             mod(kid, OP_LEAVESUBLV);
6209     }
6210     return o;
6211 }
6212
6213 OP *
6214 Perl_ck_select(pTHX_ OP *o)
6215 {
6216     dVAR;
6217     OP* kid;
6218     if (o->op_flags & OPf_KIDS) {
6219         kid = cLISTOPo->op_first->op_sibling;   /* get past pushmark */
6220         if (kid && kid->op_sibling) {
6221             o->op_type = OP_SSELECT;
6222             o->op_ppaddr = PL_ppaddr[OP_SSELECT];
6223             o = ck_fun(o);
6224             return fold_constants(o);
6225         }
6226     }
6227     o = ck_fun(o);
6228     kid = cLISTOPo->op_first->op_sibling;    /* get past pushmark */
6229     if (kid && kid->op_type == OP_RV2GV)
6230         kid->op_private &= ~HINT_STRICT_REFS;
6231     return o;
6232 }
6233
6234 OP *
6235 Perl_ck_shift(pTHX_ OP *o)
6236 {
6237     const I32 type = o->op_type;
6238
6239     if (!(o->op_flags & OPf_KIDS)) {
6240         OP *argop;
6241
6242         op_free(o);
6243         argop = newUNOP(OP_RV2AV, 0,
6244             scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
6245         return newUNOP(type, 0, scalar(argop));
6246     }
6247     return scalar(modkids(ck_fun(o), type));
6248 }
6249
6250 OP *
6251 Perl_ck_sort(pTHX_ OP *o)
6252 {
6253     OP *firstkid;
6254
6255     if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0)
6256     {
6257         HV *hinthv = GvHV(PL_hintgv);
6258         if (hinthv) {
6259             SV **svp = hv_fetch(hinthv, "sort", 4, 0);
6260             if (svp) {
6261                 I32 sorthints = (I32)SvIV(*svp);
6262                 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
6263                     o->op_private |= OPpSORT_QSORT;
6264                 if ((sorthints & HINT_SORT_STABLE) != 0)
6265                     o->op_private |= OPpSORT_STABLE;
6266             }
6267         }
6268     }
6269
6270     if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6271         simplify_sort(o);
6272     firstkid = cLISTOPo->op_first->op_sibling;          /* get past pushmark */
6273     if (o->op_flags & OPf_STACKED) {                    /* may have been cleared */
6274         OP *k = NULL;
6275         OP *kid = cUNOPx(firstkid)->op_first;           /* get past null */
6276
6277         if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
6278             linklist(kid);
6279             if (kid->op_type == OP_SCOPE) {
6280                 k = kid->op_next;
6281                 kid->op_next = 0;
6282             }
6283             else if (kid->op_type == OP_LEAVE) {
6284                 if (o->op_type == OP_SORT) {
6285                     op_null(kid);                       /* wipe out leave */
6286                     kid->op_next = kid;
6287
6288                     for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6289                         if (k->op_next == kid)
6290                             k->op_next = 0;
6291                         /* don't descend into loops */
6292                         else if (k->op_type == OP_ENTERLOOP
6293                                  || k->op_type == OP_ENTERITER)
6294                         {
6295                             k = cLOOPx(k)->op_lastop;
6296                         }
6297                     }
6298                 }
6299                 else
6300                     kid->op_next = 0;           /* just disconnect the leave */
6301                 k = kLISTOP->op_first;
6302             }
6303             CALL_PEEP(k);
6304
6305             kid = firstkid;
6306             if (o->op_type == OP_SORT) {
6307                 /* provide scalar context for comparison function/block */
6308                 kid = scalar(kid);
6309                 kid->op_next = kid;
6310             }
6311             else
6312                 kid->op_next = k;
6313             o->op_flags |= OPf_SPECIAL;
6314         }
6315         else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6316             op_null(firstkid);
6317
6318         firstkid = firstkid->op_sibling;
6319     }
6320
6321     /* provide list context for arguments */
6322     if (o->op_type == OP_SORT)
6323         list(firstkid);
6324
6325     return o;
6326 }
6327
6328 STATIC void
6329 S_simplify_sort(pTHX_ OP *o)
6330 {
6331     register OP *kid = cLISTOPo->op_first->op_sibling;  /* get past pushmark */
6332     OP *k;
6333     int descending;
6334     GV *gv;
6335     const char *gvname;
6336     if (!(o->op_flags & OPf_STACKED))
6337         return;
6338     GvMULTI_on(gv_fetchpv("a", GV_ADD, SVt_PV));
6339     GvMULTI_on(gv_fetchpv("b", GV_ADD, SVt_PV));
6340     kid = kUNOP->op_first;                              /* get past null */
6341     if (kid->op_type != OP_SCOPE)
6342         return;
6343     kid = kLISTOP->op_last;                             /* get past scope */
6344     switch(kid->op_type) {
6345         case OP_NCMP:
6346         case OP_I_NCMP:
6347         case OP_SCMP:
6348             break;
6349         default:
6350             return;
6351     }
6352     k = kid;                                            /* remember this node*/
6353     if (kBINOP->op_first->op_type != OP_RV2SV)
6354         return;
6355     kid = kBINOP->op_first;                             /* get past cmp */
6356     if (kUNOP->op_first->op_type != OP_GV)
6357         return;
6358     kid = kUNOP->op_first;                              /* get past rv2sv */
6359     gv = kGVOP_gv;
6360     if (GvSTASH(gv) != PL_curstash)
6361         return;
6362     gvname = GvNAME(gv);
6363     if (*gvname == 'a' && gvname[1] == '\0')
6364         descending = 0;
6365     else if (*gvname == 'b' && gvname[1] == '\0')
6366         descending = 1;
6367     else
6368         return;
6369
6370     kid = k;                                            /* back to cmp */
6371     if (kBINOP->op_last->op_type != OP_RV2SV)
6372         return;
6373     kid = kBINOP->op_last;                              /* down to 2nd arg */
6374     if (kUNOP->op_first->op_type != OP_GV)
6375         return;
6376     kid = kUNOP->op_first;                              /* get past rv2sv */
6377     gv = kGVOP_gv;
6378     if (GvSTASH(gv) != PL_curstash)
6379         return;
6380     gvname = GvNAME(gv);
6381     if ( descending
6382          ? !(*gvname == 'a' && gvname[1] == '\0')
6383          : !(*gvname == 'b' && gvname[1] == '\0'))
6384         return;
6385     o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6386     if (descending)
6387         o->op_private |= OPpSORT_DESCEND;
6388     if (k->op_type == OP_NCMP)
6389         o->op_private |= OPpSORT_NUMERIC;
6390     if (k->op_type == OP_I_NCMP)
6391         o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6392     kid = cLISTOPo->op_first->op_sibling;
6393     cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6394     op_free(kid);                                     /* then delete it */
6395 }
6396
6397 OP *
6398 Perl_ck_split(pTHX_ OP *o)
6399 {
6400     dVAR;
6401     register OP *kid;
6402
6403     if (o->op_flags & OPf_STACKED)
6404         return no_fh_allowed(o);
6405
6406     kid = cLISTOPo->op_first;
6407     if (kid->op_type != OP_NULL)
6408         Perl_croak(aTHX_ "panic: ck_split");
6409     kid = kid->op_sibling;
6410     op_free(cLISTOPo->op_first);
6411     cLISTOPo->op_first = kid;
6412     if (!kid) {
6413         cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
6414         cLISTOPo->op_last = kid; /* There was only one element previously */
6415     }
6416
6417     if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6418         OP * const sibl = kid->op_sibling;
6419         kid->op_sibling = 0;
6420         kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
6421         if (cLISTOPo->op_first == cLISTOPo->op_last)
6422             cLISTOPo->op_last = kid;
6423         cLISTOPo->op_first = kid;
6424         kid->op_sibling = sibl;
6425     }
6426
6427     kid->op_type = OP_PUSHRE;
6428     kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6429     scalar(kid);
6430     if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL && ckWARN(WARN_REGEXP)) {
6431       Perl_warner(aTHX_ packWARN(WARN_REGEXP),
6432                   "Use of /g modifier is meaningless in split");
6433     }
6434
6435     if (!kid->op_sibling)
6436         append_elem(OP_SPLIT, o, newDEFSVOP());
6437
6438     kid = kid->op_sibling;
6439     scalar(kid);
6440
6441     if (!kid->op_sibling)
6442         append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6443
6444     kid = kid->op_sibling;
6445     scalar(kid);
6446
6447     if (kid->op_sibling)
6448         return too_many_arguments(o,OP_DESC(o));
6449
6450     return o;
6451 }
6452
6453 OP *
6454 Perl_ck_join(pTHX_ OP *o)
6455 {
6456     const OP * const kid = cLISTOPo->op_first->op_sibling;
6457     if (kid && kid->op_type == OP_MATCH) {
6458         if (ckWARN(WARN_SYNTAX)) {
6459             const REGEXP *re = PM_GETRE(kPMOP);
6460             const char *pmstr = re ? re->precomp : "STRING";
6461             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6462                         "/%s/ should probably be written as \"%s\"",
6463                         pmstr, pmstr);
6464         }
6465     }
6466     return ck_fun(o);
6467 }
6468
6469 OP *
6470 Perl_ck_subr(pTHX_ OP *o)
6471 {
6472     OP *prev = ((cUNOPo->op_first->op_sibling)
6473              ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6474     OP *o2 = prev->op_sibling;
6475     OP *cvop;
6476     char *proto = NULL;
6477     CV *cv = NULL;
6478     GV *namegv = NULL;
6479     int optional = 0;
6480     I32 arg = 0;
6481     I32 contextclass = 0;
6482     char *e = NULL;
6483     bool delete_op = 0;
6484
6485     o->op_private |= OPpENTERSUB_HASTARG;
6486     for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6487     if (cvop->op_type == OP_RV2CV) {
6488         SVOP* tmpop;
6489         o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6490         op_null(cvop);          /* disable rv2cv */
6491         tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6492         if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6493             GV *gv = cGVOPx_gv(tmpop);
6494             cv = GvCVu(gv);
6495             if (!cv)
6496                 tmpop->op_private |= OPpEARLY_CV;
6497             else {
6498                 if (SvPOK(cv)) {
6499                     namegv = CvANON(cv) ? gv : CvGV(cv);
6500                     proto = SvPV_nolen((SV*)cv);
6501                 }
6502                 if (CvASSERTION(cv)) {
6503                     if (PL_hints & HINT_ASSERTING) {
6504                         if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
6505                             o->op_private |= OPpENTERSUB_DB;
6506                     }
6507                     else {
6508                         delete_op = 1;
6509                         if (!(PL_hints & HINT_ASSERTIONSSEEN) && ckWARN(WARN_ASSERTIONS)) {
6510                             Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
6511                                         "Impossible to activate assertion call");
6512                         }
6513                     }
6514                 }
6515             }
6516         }
6517     }
6518     else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6519         if (o2->op_type == OP_CONST)
6520             o2->op_private &= ~OPpCONST_STRICT;
6521         else if (o2->op_type == OP_LIST) {
6522             OP * const o = ((UNOP*)o2)->op_first->op_sibling;
6523             if (o && o->op_type == OP_CONST)
6524                 o->op_private &= ~OPpCONST_STRICT;
6525         }
6526     }
6527     o->op_private |= (PL_hints & HINT_STRICT_REFS);
6528     if (PERLDB_SUB && PL_curstash != PL_debstash)
6529         o->op_private |= OPpENTERSUB_DB;
6530     while (o2 != cvop) {
6531         if (proto) {
6532             switch (*proto) {
6533             case '\0':
6534                 return too_many_arguments(o, gv_ename(namegv));
6535             case ';':
6536                 optional = 1;
6537                 proto++;
6538                 continue;
6539             case '$':
6540                 proto++;
6541                 arg++;
6542                 scalar(o2);
6543                 break;
6544             case '%':
6545             case '@':
6546                 list(o2);
6547                 arg++;
6548                 break;
6549             case '&':
6550                 proto++;
6551                 arg++;
6552                 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6553                     bad_type(arg,
6554                         arg == 1 ? "block or sub {}" : "sub {}",
6555                         gv_ename(namegv), o2);
6556                 break;
6557             case '*':
6558                 /* '*' allows any scalar type, including bareword */
6559                 proto++;
6560                 arg++;
6561                 if (o2->op_type == OP_RV2GV)
6562                     goto wrapref;       /* autoconvert GLOB -> GLOBref */
6563                 else if (o2->op_type == OP_CONST)
6564                     o2->op_private &= ~OPpCONST_STRICT;
6565                 else if (o2->op_type == OP_ENTERSUB) {
6566                     /* accidental subroutine, revert to bareword */
6567                     OP *gvop = ((UNOP*)o2)->op_first;
6568                     if (gvop && gvop->op_type == OP_NULL) {
6569                         gvop = ((UNOP*)gvop)->op_first;
6570                         if (gvop) {
6571                             for (; gvop->op_sibling; gvop = gvop->op_sibling)
6572                                 ;
6573                             if (gvop &&
6574                                 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6575                                 (gvop = ((UNOP*)gvop)->op_first) &&
6576                                 gvop->op_type == OP_GV)
6577                             {
6578                                 GV * const gv = cGVOPx_gv(gvop);
6579                                 OP * const sibling = o2->op_sibling;
6580                                 SV * const n = newSVpvn("",0);
6581                                 op_free(o2);
6582                                 gv_fullname4(n, gv, "", FALSE);
6583                                 o2 = newSVOP(OP_CONST, 0, n);
6584                                 prev->op_sibling = o2;
6585                                 o2->op_sibling = sibling;
6586                             }
6587                         }
6588                     }
6589                 }
6590                 scalar(o2);
6591                 break;
6592             case '[': case ']':
6593                  goto oops;
6594                  break;
6595             case '\\':
6596                 proto++;
6597                 arg++;
6598             again:
6599                 switch (*proto++) {
6600                 case '[':
6601                      if (contextclass++ == 0) {
6602                           e = strchr(proto, ']');
6603                           if (!e || e == proto)
6604                                goto oops;
6605                      }
6606                      else
6607                           goto oops;
6608                      goto again;
6609                      break;
6610                 case ']':
6611                      if (contextclass) {
6612                          /* XXX We shouldn't be modifying proto, so we can const proto */
6613                          char *p = proto;
6614                          const char s = *p;
6615                          contextclass = 0;
6616                          *p = '\0';
6617                          while (*--p != '[');
6618                          bad_type(arg, Perl_form(aTHX_ "one of %s", p),
6619                                  gv_ename(namegv), o2);
6620                          *proto = s;
6621                      } else
6622                           goto oops;
6623                      break;
6624                 case '*':
6625                      if (o2->op_type == OP_RV2GV)
6626                           goto wrapref;
6627                      if (!contextclass)
6628                           bad_type(arg, "symbol", gv_ename(namegv), o2);
6629                      break;
6630                 case '&':
6631                      if (o2->op_type == OP_ENTERSUB)
6632                           goto wrapref;
6633                      if (!contextclass)
6634                           bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6635                      break;
6636                 case '$':
6637                     if (o2->op_type == OP_RV2SV ||
6638                         o2->op_type == OP_PADSV ||
6639                         o2->op_type == OP_HELEM ||
6640                         o2->op_type == OP_AELEM ||
6641                         o2->op_type == OP_THREADSV)
6642                          goto wrapref;
6643                     if (!contextclass)
6644                         bad_type(arg, "scalar", gv_ename(namegv), o2);
6645                      break;
6646                 case '@':
6647                     if (o2->op_type == OP_RV2AV ||
6648                         o2->op_type == OP_PADAV)
6649                          goto wrapref;
6650                     if (!contextclass)
6651                         bad_type(arg, "array", gv_ename(namegv), o2);
6652                     break;
6653                 case '%':
6654                     if (o2->op_type == OP_RV2HV ||
6655                         o2->op_type == OP_PADHV)
6656                          goto wrapref;
6657                     if (!contextclass)
6658                          bad_type(arg, "hash", gv_ename(namegv), o2);
6659                     break;
6660                 wrapref:
6661                     {
6662                         OP* const kid = o2;
6663                         OP* const sib = kid->op_sibling;
6664                         kid->op_sibling = 0;
6665                         o2 = newUNOP(OP_REFGEN, 0, kid);
6666                         o2->op_sibling = sib;
6667                         prev->op_sibling = o2;
6668                     }
6669                     if (contextclass && e) {
6670                          proto = e + 1;
6671                          contextclass = 0;
6672                     }
6673                     break;
6674                 default: goto oops;
6675                 }
6676                 if (contextclass)
6677                      goto again;
6678                 break;
6679             case ' ':
6680                 proto++;
6681                 continue;
6682             default:
6683               oops:
6684                 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
6685                            gv_ename(namegv), cv);
6686             }
6687         }
6688         else
6689             list(o2);
6690         mod(o2, OP_ENTERSUB);
6691         prev = o2;
6692         o2 = o2->op_sibling;
6693     } /* while */
6694     if (proto && !optional &&
6695           (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6696         return too_few_arguments(o, gv_ename(namegv));
6697     if(delete_op) {
6698         op_free(o);
6699         o=newSVOP(OP_CONST, 0, newSViv(0));
6700     }
6701     return o;
6702 }
6703
6704 OP *
6705 Perl_ck_svconst(pTHX_ OP *o)
6706 {
6707     SvREADONLY_on(cSVOPo->op_sv);
6708     return o;
6709 }
6710
6711 OP *
6712 Perl_ck_trunc(pTHX_ OP *o)
6713 {
6714     if (o->op_flags & OPf_KIDS) {
6715         SVOP *kid = (SVOP*)cUNOPo->op_first;
6716
6717         if (kid->op_type == OP_NULL)
6718             kid = (SVOP*)kid->op_sibling;
6719         if (kid && kid->op_type == OP_CONST &&
6720             (kid->op_private & OPpCONST_BARE))
6721         {
6722             o->op_flags |= OPf_SPECIAL;
6723             kid->op_private &= ~OPpCONST_STRICT;
6724         }
6725     }
6726     return ck_fun(o);
6727 }
6728
6729 OP *
6730 Perl_ck_unpack(pTHX_ OP *o)
6731 {
6732     OP *kid = cLISTOPo->op_first;
6733     if (kid->op_sibling) {
6734         kid = kid->op_sibling;
6735         if (!kid->op_sibling)
6736             kid->op_sibling = newDEFSVOP();
6737     }
6738     return ck_fun(o);
6739 }
6740
6741 OP *
6742 Perl_ck_substr(pTHX_ OP *o)
6743 {
6744     o = ck_fun(o);
6745     if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6746         OP *kid = cLISTOPo->op_first;
6747
6748         if (kid->op_type == OP_NULL)
6749             kid = kid->op_sibling;
6750         if (kid)
6751             kid->op_flags |= OPf_MOD;
6752
6753     }
6754     return o;
6755 }
6756
6757 /* A peephole optimizer.  We visit the ops in the order they're to execute.
6758  * See the comments at the top of this file for more details about when
6759  * peep() is called */
6760
6761 void
6762 Perl_peep(pTHX_ register OP *o)
6763 {
6764     dVAR;
6765     register OP* oldop = NULL;
6766
6767     if (!o || o->op_opt)
6768         return;
6769     ENTER;
6770     SAVEOP();
6771     SAVEVPTR(PL_curcop);
6772     for (; o; o = o->op_next) {
6773         if (o->op_opt)
6774             break;
6775         PL_op = o;
6776         switch (o->op_type) {
6777         case OP_SETSTATE:
6778         case OP_NEXTSTATE:
6779         case OP_DBSTATE:
6780             PL_curcop = ((COP*)o);              /* for warnings */
6781             o->op_opt = 1;
6782             break;
6783
6784         case OP_CONST:
6785             if (cSVOPo->op_private & OPpCONST_STRICT)
6786                 no_bareword_allowed(o);
6787 #ifdef USE_ITHREADS
6788         case OP_METHOD_NAMED:
6789             /* Relocate sv to the pad for thread safety.
6790              * Despite being a "constant", the SV is written to,
6791              * for reference counts, sv_upgrade() etc. */
6792             if (cSVOP->op_sv) {
6793                 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6794                 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
6795                     /* If op_sv is already a PADTMP then it is being used by
6796                      * some pad, so make a copy. */
6797                     sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
6798                     SvREADONLY_on(PAD_SVl(ix));
6799                     SvREFCNT_dec(cSVOPo->op_sv);
6800                 }
6801                 else if (o->op_type == OP_CONST
6802                          && cSVOPo->op_sv == &PL_sv_undef) {
6803                     /* PL_sv_undef is hack - it's unsafe to store it in the
6804                        AV that is the pad, because av_fetch treats values of
6805                        PL_sv_undef as a "free" AV entry and will merrily
6806                        replace them with a new SV, causing pad_alloc to think
6807                        that this pad slot is free. (When, clearly, it is not)
6808                     */
6809                     SvOK_off(PAD_SVl(ix));
6810                     SvPADTMP_on(PAD_SVl(ix));
6811                     SvREADONLY_on(PAD_SVl(ix));
6812                 }
6813                 else {
6814                     SvREFCNT_dec(PAD_SVl(ix));
6815                     SvPADTMP_on(cSVOPo->op_sv);
6816                     PAD_SETSV(ix, cSVOPo->op_sv);
6817                     /* XXX I don't know how this isn't readonly already. */
6818                     SvREADONLY_on(PAD_SVl(ix));
6819                 }
6820                 cSVOPo->op_sv = Nullsv;
6821                 o->op_targ = ix;
6822             }
6823 #endif
6824             o->op_opt = 1;
6825             break;
6826
6827         case OP_CONCAT:
6828             if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6829                 if (o->op_next->op_private & OPpTARGET_MY) {
6830                     if (o->op_flags & OPf_STACKED) /* chained concats */
6831                         goto ignore_optimization;
6832                     else {
6833                         /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6834                         o->op_targ = o->op_next->op_targ;
6835                         o->op_next->op_targ = 0;
6836                         o->op_private |= OPpTARGET_MY;
6837                     }
6838                 }
6839                 op_null(o->op_next);
6840             }
6841           ignore_optimization:
6842             o->op_opt = 1;
6843             break;
6844         case OP_STUB:
6845             if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6846                 o->op_opt = 1;
6847                 break; /* Scalar stub must produce undef.  List stub is noop */
6848             }
6849             goto nothin;
6850         case OP_NULL:
6851             if (o->op_targ == OP_NEXTSTATE
6852                 || o->op_targ == OP_DBSTATE
6853                 || o->op_targ == OP_SETSTATE)
6854             {
6855                 PL_curcop = ((COP*)o);
6856             }
6857             /* XXX: We avoid setting op_seq here to prevent later calls
6858                to peep() from mistakenly concluding that optimisation
6859                has already occurred. This doesn't fix the real problem,
6860                though (See 20010220.007). AMS 20010719 */
6861             /* op_seq functionality is now replaced by op_opt */
6862             if (oldop && o->op_next) {
6863                 oldop->op_next = o->op_next;
6864                 continue;
6865             }
6866             break;
6867         case OP_SCALAR:
6868         case OP_LINESEQ:
6869         case OP_SCOPE:
6870           nothin:
6871             if (oldop && o->op_next) {
6872                 oldop->op_next = o->op_next;
6873                 continue;
6874             }
6875             o->op_opt = 1;
6876             break;
6877
6878         case OP_PADAV:
6879         case OP_GV:
6880             if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
6881                 OP* const pop = (o->op_type == OP_PADAV) ?
6882                             o->op_next : o->op_next->op_next;
6883                 IV i;
6884                 if (pop && pop->op_type == OP_CONST &&
6885                     ((PL_op = pop->op_next)) &&
6886                     pop->op_next->op_type == OP_AELEM &&
6887                     !(pop->op_next->op_private &
6888                       (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6889                     (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
6890                                 <= 255 &&
6891                     i >= 0)
6892                 {
6893                     GV *gv;
6894                     if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
6895                         no_bareword_allowed(pop);
6896                     if (o->op_type == OP_GV)
6897                         op_null(o->op_next);
6898                     op_null(pop->op_next);
6899                     op_null(pop);
6900                     o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6901                     o->op_next = pop->op_next->op_next;
6902                     o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6903                     o->op_private = (U8)i;
6904                     if (o->op_type == OP_GV) {
6905                         gv = cGVOPo_gv;
6906                         GvAVn(gv);
6907                     }
6908                     else
6909                         o->op_flags |= OPf_SPECIAL;
6910                     o->op_type = OP_AELEMFAST;
6911                 }
6912                 o->op_opt = 1;
6913                 break;
6914             }
6915
6916             if (o->op_next->op_type == OP_RV2SV) {
6917                 if (!(o->op_next->op_private & OPpDEREF)) {
6918                     op_null(o->op_next);
6919                     o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6920                                                                | OPpOUR_INTRO);
6921                     o->op_next = o->op_next->op_next;
6922                     o->op_type = OP_GVSV;
6923                     o->op_ppaddr = PL_ppaddr[OP_GVSV];
6924                 }
6925             }
6926             else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6927                 GV * const gv = cGVOPo_gv;
6928                 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
6929                     /* XXX could check prototype here instead of just carping */
6930                     SV * const sv = sv_newmortal();
6931                     gv_efullname3(sv, gv, Nullch);
6932                     Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
6933                                 "%"SVf"() called too early to check prototype",
6934                                 sv);
6935                 }
6936             }
6937             else if (o->op_next->op_type == OP_READLINE
6938                     && o->op_next->op_next->op_type == OP_CONCAT
6939                     && (o->op_next->op_next->op_flags & OPf_STACKED))
6940             {
6941                 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
6942                 o->op_type   = OP_RCATLINE;
6943                 o->op_flags |= OPf_STACKED;
6944                 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
6945                 op_null(o->op_next->op_next);
6946                 op_null(o->op_next);
6947             }
6948
6949             o->op_opt = 1;
6950             break;
6951
6952         case OP_MAPWHILE:
6953         case OP_GREPWHILE:
6954         case OP_AND:
6955         case OP_OR:
6956         case OP_DOR:
6957         case OP_ANDASSIGN:
6958         case OP_ORASSIGN:
6959         case OP_DORASSIGN:
6960         case OP_COND_EXPR:
6961         case OP_RANGE:
6962             o->op_opt = 1;
6963             while (cLOGOP->op_other->op_type == OP_NULL)
6964                 cLOGOP->op_other = cLOGOP->op_other->op_next;
6965             peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
6966             break;
6967
6968         case OP_ENTERLOOP:
6969         case OP_ENTERITER:
6970             o->op_opt = 1;
6971             while (cLOOP->op_redoop->op_type == OP_NULL)
6972                 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6973             peep(cLOOP->op_redoop);
6974             while (cLOOP->op_nextop->op_type == OP_NULL)
6975                 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6976             peep(cLOOP->op_nextop);
6977             while (cLOOP->op_lastop->op_type == OP_NULL)
6978                 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6979             peep(cLOOP->op_lastop);
6980             break;
6981
6982         case OP_QR:
6983         case OP_MATCH:
6984         case OP_SUBST:
6985             o->op_opt = 1;
6986             while (cPMOP->op_pmreplstart &&
6987                    cPMOP->op_pmreplstart->op_type == OP_NULL)
6988                 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6989             peep(cPMOP->op_pmreplstart);
6990             break;
6991
6992         case OP_EXEC:
6993             o->op_opt = 1;
6994             if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
6995                 && ckWARN(WARN_SYNTAX))
6996             {
6997                 if (o->op_next->op_sibling &&
6998                         o->op_next->op_sibling->op_type != OP_EXIT &&
6999                         o->op_next->op_sibling->op_type != OP_WARN &&
7000                         o->op_next->op_sibling->op_type != OP_DIE) {
7001                     const line_t oldline = CopLINE(PL_curcop);
7002
7003                     CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
7004                     Perl_warner(aTHX_ packWARN(WARN_EXEC),
7005                                 "Statement unlikely to be reached");
7006                     Perl_warner(aTHX_ packWARN(WARN_EXEC),
7007                                 "\t(Maybe you meant system() when you said exec()?)\n");
7008                     CopLINE_set(PL_curcop, oldline);
7009                 }
7010             }
7011             break;
7012
7013         case OP_HELEM: {
7014             UNOP *rop;
7015             SV *lexname;
7016             GV **fields;
7017             SV **svp, *sv;
7018             const char *key = NULL;
7019             STRLEN keylen;
7020
7021             o->op_opt = 1;
7022
7023             if (((BINOP*)o)->op_last->op_type != OP_CONST)
7024                 break;
7025
7026             /* Make the CONST have a shared SV */
7027             svp = cSVOPx_svp(((BINOP*)o)->op_last);
7028             if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
7029                 key = SvPV_const(sv, keylen);
7030                 lexname = newSVpvn_share(key,
7031                                          SvUTF8(sv) ? -(I32)keylen : keylen,
7032                                          0);
7033                 SvREFCNT_dec(sv);
7034                 *svp = lexname;
7035             }
7036
7037             if ((o->op_private & (OPpLVAL_INTRO)))
7038                 break;
7039
7040             rop = (UNOP*)((BINOP*)o)->op_first;
7041             if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
7042                 break;
7043             lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
7044             if (!(SvFLAGS(lexname) & SVpad_TYPED))
7045                 break;
7046             fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
7047             if (!fields || !GvHV(*fields))
7048                 break;
7049             key = SvPV_const(*svp, keylen);
7050             if (!hv_fetch(GvHV(*fields), key,
7051                         SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
7052             {
7053                 Perl_croak(aTHX_ "No such class field \"%s\" "
7054                            "in variable %s of type %s",
7055                       key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
7056             }
7057
7058             break;
7059         }
7060
7061         case OP_HSLICE: {
7062             UNOP *rop;
7063             SV *lexname;
7064             GV **fields;
7065             SV **svp;
7066             const char *key;
7067             STRLEN keylen;
7068             SVOP *first_key_op, *key_op;
7069
7070             if ((o->op_private & (OPpLVAL_INTRO))
7071                 /* I bet there's always a pushmark... */
7072                 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
7073                 /* hmmm, no optimization if list contains only one key. */
7074                 break;
7075             rop = (UNOP*)((LISTOP*)o)->op_last;
7076             if (rop->op_type != OP_RV2HV)
7077                 break;
7078             if (rop->op_first->op_type == OP_PADSV)
7079                 /* @$hash{qw(keys here)} */
7080                 rop = (UNOP*)rop->op_first;
7081             else {
7082                 /* @{$hash}{qw(keys here)} */
7083                 if (rop->op_first->op_type == OP_SCOPE
7084                     && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
7085                 {
7086                     rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
7087                 }
7088                 else
7089                     break;
7090             }
7091
7092             lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
7093             if (!(SvFLAGS(lexname) & SVpad_TYPED))
7094                 break;
7095             fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
7096             if (!fields || !GvHV(*fields))
7097                 break;
7098             /* Again guessing that the pushmark can be jumped over.... */
7099             first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
7100                 ->op_first->op_sibling;
7101             for (key_op = first_key_op; key_op;
7102                  key_op = (SVOP*)key_op->op_sibling) {
7103                 if (key_op->op_type != OP_CONST)
7104                     continue;
7105                 svp = cSVOPx_svp(key_op);
7106                 key = SvPV_const(*svp, keylen);
7107                 if (!hv_fetch(GvHV(*fields), key,
7108                             SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
7109                 {
7110                     Perl_croak(aTHX_ "No such class field \"%s\" "
7111                                "in variable %s of type %s",
7112                           key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
7113                 }
7114             }
7115             break;
7116         }
7117
7118         case OP_SORT: {
7119             /* will point to RV2AV or PADAV op on LHS/RHS of assign */
7120             OP *oleft;
7121             OP *o2;
7122
7123             /* check that RHS of sort is a single plain array */
7124             OP *oright = cUNOPo->op_first;
7125             if (!oright || oright->op_type != OP_PUSHMARK)
7126                 break;
7127
7128             /* reverse sort ... can be optimised.  */
7129             if (!cUNOPo->op_sibling) {
7130                 /* Nothing follows us on the list. */
7131                 OP * const reverse = o->op_next;
7132
7133                 if (reverse->op_type == OP_REVERSE &&
7134                     (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
7135                     OP * const pushmark = cUNOPx(reverse)->op_first;
7136                     if (pushmark && (pushmark->op_type == OP_PUSHMARK)
7137                         && (cUNOPx(pushmark)->op_sibling == o)) {
7138                         /* reverse -> pushmark -> sort */
7139                         o->op_private |= OPpSORT_REVERSE;
7140                         op_null(reverse);
7141                         pushmark->op_next = oright->op_next;
7142                         op_null(oright);
7143                     }
7144                 }
7145             }
7146
7147             /* make @a = sort @a act in-place */
7148
7149             o->op_opt = 1;
7150
7151             oright = cUNOPx(oright)->op_sibling;
7152             if (!oright)
7153                 break;
7154             if (oright->op_type == OP_NULL) { /* skip sort block/sub */
7155                 oright = cUNOPx(oright)->op_sibling;
7156             }
7157
7158             if (!oright ||
7159                 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
7160                 || oright->op_next != o
7161                 || (oright->op_private & OPpLVAL_INTRO)
7162             )
7163                 break;
7164
7165             /* o2 follows the chain of op_nexts through the LHS of the
7166              * assign (if any) to the aassign op itself */
7167             o2 = o->op_next;
7168             if (!o2 || o2->op_type != OP_NULL)
7169                 break;
7170             o2 = o2->op_next;
7171             if (!o2 || o2->op_type != OP_PUSHMARK)
7172                 break;
7173             o2 = o2->op_next;
7174             if (o2 && o2->op_type == OP_GV)
7175                 o2 = o2->op_next;
7176             if (!o2
7177                 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
7178                 || (o2->op_private & OPpLVAL_INTRO)
7179             )
7180                 break;
7181             oleft = o2;
7182             o2 = o2->op_next;
7183             if (!o2 || o2->op_type != OP_NULL)
7184                 break;
7185             o2 = o2->op_next;
7186             if (!o2 || o2->op_type != OP_AASSIGN
7187                     || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
7188                 break;
7189
7190             /* check that the sort is the first arg on RHS of assign */
7191
7192             o2 = cUNOPx(o2)->op_first;
7193             if (!o2 || o2->op_type != OP_NULL)
7194                 break;
7195             o2 = cUNOPx(o2)->op_first;
7196             if (!o2 || o2->op_type != OP_PUSHMARK)
7197                 break;
7198             if (o2->op_sibling != o)
7199                 break;
7200
7201             /* check the array is the same on both sides */
7202             if (oleft->op_type == OP_RV2AV) {
7203                 if (oright->op_type != OP_RV2AV
7204                     || !cUNOPx(oright)->op_first
7205                     || cUNOPx(oright)->op_first->op_type != OP_GV
7206                     ||  cGVOPx_gv(cUNOPx(oleft)->op_first) !=
7207                         cGVOPx_gv(cUNOPx(oright)->op_first)
7208                 )
7209                     break;
7210             }
7211             else if (oright->op_type != OP_PADAV
7212                 || oright->op_targ != oleft->op_targ
7213             )
7214                 break;
7215
7216             /* transfer MODishness etc from LHS arg to RHS arg */
7217             oright->op_flags = oleft->op_flags;
7218             o->op_private |= OPpSORT_INPLACE;
7219
7220             /* excise push->gv->rv2av->null->aassign */
7221             o2 = o->op_next->op_next;
7222             op_null(o2); /* PUSHMARK */
7223             o2 = o2->op_next;
7224             if (o2->op_type == OP_GV) {
7225                 op_null(o2); /* GV */
7226                 o2 = o2->op_next;
7227             }
7228             op_null(o2); /* RV2AV or PADAV */
7229             o2 = o2->op_next->op_next;
7230             op_null(o2); /* AASSIGN */
7231
7232             o->op_next = o2->op_next;
7233
7234             break;
7235         }
7236
7237         case OP_REVERSE: {
7238             OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
7239             OP *gvop = NULL;
7240             LISTOP *enter, *exlist;
7241             o->op_opt = 1;
7242
7243             enter = (LISTOP *) o->op_next;
7244             if (!enter)
7245                 break;
7246             if (enter->op_type == OP_NULL) {
7247                 enter = (LISTOP *) enter->op_next;
7248                 if (!enter)
7249                     break;
7250             }
7251             /* for $a (...) will have OP_GV then OP_RV2GV here.
7252                for (...) just has an OP_GV.  */
7253             if (enter->op_type == OP_GV) {
7254                 gvop = (OP *) enter;
7255                 enter = (LISTOP *) enter->op_next;
7256                 if (!enter)
7257                     break;
7258                 if (enter->op_type == OP_RV2GV) {
7259                   enter = (LISTOP *) enter->op_next;
7260                   if (!enter)
7261                     break;
7262                 }
7263             }
7264
7265             if (enter->op_type != OP_ENTERITER)
7266                 break;
7267
7268             iter = enter->op_next;
7269             if (!iter || iter->op_type != OP_ITER)
7270                 break;
7271
7272             expushmark = enter->op_first;
7273             if (!expushmark || expushmark->op_type != OP_NULL
7274                 || expushmark->op_targ != OP_PUSHMARK)
7275                 break;
7276
7277             exlist = (LISTOP *) expushmark->op_sibling;
7278             if (!exlist || exlist->op_type != OP_NULL
7279                 || exlist->op_targ != OP_LIST)
7280                 break;
7281
7282             if (exlist->op_last != o) {
7283                 /* Mmm. Was expecting to point back to this op.  */
7284                 break;
7285             }
7286             theirmark = exlist->op_first;
7287             if (!theirmark || theirmark->op_type != OP_PUSHMARK)
7288                 break;
7289
7290             if (theirmark->op_sibling != o) {
7291                 /* There's something between the mark and the reverse, eg
7292                    for (1, reverse (...))
7293                    so no go.  */
7294                 break;
7295             }
7296
7297             ourmark = ((LISTOP *)o)->op_first;
7298             if (!ourmark || ourmark->op_type != OP_PUSHMARK)
7299                 break;
7300
7301             ourlast = ((LISTOP *)o)->op_last;
7302             if (!ourlast || ourlast->op_next != o)
7303                 break;
7304
7305             rv2av = ourmark->op_sibling;
7306             if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
7307                 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
7308                 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
7309                 /* We're just reversing a single array.  */
7310                 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
7311                 enter->op_flags |= OPf_STACKED;
7312             }
7313
7314             /* We don't have control over who points to theirmark, so sacrifice
7315                ours.  */
7316             theirmark->op_next = ourmark->op_next;
7317             theirmark->op_flags = ourmark->op_flags;
7318             ourlast->op_next = gvop ? gvop : (OP *) enter;
7319             op_null(ourmark);
7320             op_null(o);
7321             enter->op_private |= OPpITER_REVERSED;
7322             iter->op_private |= OPpITER_REVERSED;
7323
7324             break;
7325         }
7326
7327         case OP_SASSIGN: {
7328             OP *rv2gv;
7329             UNOP *refgen, *rv2cv;
7330             LISTOP *exlist;
7331
7332             /* I do not understand this, but if o->op_opt isn't set to 1,
7333                various tests in ext/B/t/bytecode.t fail with no readily
7334                apparent cause.  */
7335
7336             o->op_opt = 1;
7337
7338
7339             if ((o->op_flags && OPf_WANT) != OPf_WANT_VOID)
7340                 break;
7341
7342             if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
7343                 break;
7344
7345             rv2gv = ((BINOP *)o)->op_last;
7346             if (!rv2gv || rv2gv->op_type != OP_RV2GV)
7347                 break;
7348
7349             refgen = (UNOP *)((BINOP *)o)->op_first;
7350
7351             if (!refgen || refgen->op_type != OP_REFGEN)
7352                 break;
7353
7354             exlist = (LISTOP *)refgen->op_first;
7355             if (!exlist || exlist->op_type != OP_NULL
7356                 || exlist->op_targ != OP_LIST)
7357                 break;
7358
7359             if (exlist->op_first->op_type != OP_PUSHMARK)
7360                 break;
7361
7362             rv2cv = (UNOP*)exlist->op_last;
7363
7364             if (rv2cv->op_type != OP_RV2CV)
7365                 break;
7366
7367             assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
7368             assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
7369             assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
7370
7371             o->op_private |= OPpASSIGN_CV_TO_GV;
7372             rv2gv->op_private |= OPpDONT_INIT_GV;
7373             rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
7374
7375             break;
7376         }
7377
7378
7379         default:
7380             o->op_opt = 1;
7381             break;
7382         }
7383         oldop = o;
7384     }
7385     LEAVE;
7386 }
7387
7388 char*
7389 Perl_custom_op_name(pTHX_ const OP* o)
7390 {
7391     const IV index = PTR2IV(o->op_ppaddr);
7392     SV* keysv;
7393     HE* he;
7394
7395     if (!PL_custom_op_names) /* This probably shouldn't happen */
7396         return (char *)PL_op_name[OP_CUSTOM];
7397
7398     keysv = sv_2mortal(newSViv(index));
7399
7400     he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
7401     if (!he)
7402         return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
7403
7404     return SvPV_nolen(HeVAL(he));
7405 }
7406
7407 char*
7408 Perl_custom_op_desc(pTHX_ const OP* o)
7409 {
7410     const IV index = PTR2IV(o->op_ppaddr);
7411     SV* keysv;
7412     HE* he;
7413
7414     if (!PL_custom_op_descs)
7415         return (char *)PL_op_desc[OP_CUSTOM];
7416
7417     keysv = sv_2mortal(newSViv(index));
7418
7419     he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
7420     if (!he)
7421         return (char *)PL_op_desc[OP_CUSTOM];
7422
7423     return SvPV_nolen(HeVAL(he));
7424 }
7425
7426 #include "XSUB.h"
7427
7428 /* Efficient sub that returns a constant scalar value. */
7429 static void
7430 const_sv_xsub(pTHX_ CV* cv)
7431 {
7432     dXSARGS;
7433     if (items != 0) {
7434 #if 0
7435         Perl_croak(aTHX_ "usage: %s::%s()",
7436                    HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
7437 #endif
7438     }
7439     EXTEND(sp, 1);
7440     ST(0) = (SV*)XSANY.any_ptr;
7441     XSRETURN(1);
7442 }
7443
7444 /*
7445  * Local variables:
7446  * c-indentation-style: bsd
7447  * c-basic-offset: 4
7448  * indent-tabs-mode: t
7449  * End:
7450  *
7451  * ex: set ts=8 sts=4 sw=4 noet:
7452  */