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     I32 gv_fetch_flags;
4444
4445     const char * const name = o ? SvPVx_nolen_const(cSVOPo->op_sv) : Nullch;
4446
4447     if (proto) {
4448         assert(proto->op_type == OP_CONST);
4449         ps = SvPVx_const(((SVOP*)proto)->op_sv, ps_len);
4450     }
4451     else
4452         ps = Nullch;
4453
4454     if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4455         SV * const sv = sv_newmortal();
4456         Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
4457                        PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
4458                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4459         aname = SvPVX_const(sv);
4460     }
4461     else
4462         aname = Nullch;
4463
4464     gv_fetch_flags = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
4465         ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
4466     gv = name ? gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV)
4467         : gv_fetchpv(aname ? aname
4468                      : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4469                      gv_fetch_flags, SVt_PVCV);
4470
4471     if (o)
4472         SAVEFREEOP(o);
4473     if (proto)
4474         SAVEFREEOP(proto);
4475     if (attrs)
4476         SAVEFREEOP(attrs);
4477
4478     if (SvTYPE(gv) != SVt_PVGV) {       /* Maybe prototype now, and had at
4479                                            maximum a prototype before. */
4480         if (SvTYPE(gv) > SVt_NULL) {
4481             if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4482                 && ckWARN_d(WARN_PROTOTYPE))
4483             {
4484                 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
4485             }
4486             cv_ckproto((CV*)gv, NULL, ps);
4487         }
4488         if (ps)
4489             sv_setpvn((SV*)gv, ps, ps_len);
4490         else
4491             sv_setiv((SV*)gv, -1);
4492         SvREFCNT_dec(PL_compcv);
4493         cv = PL_compcv = NULL;
4494         PL_sub_generation++;
4495         goto done;
4496     }
4497
4498     cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4499
4500 #ifdef GV_UNIQUE_CHECK
4501     if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4502         Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
4503     }
4504 #endif
4505
4506     if (!block || !ps || *ps || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
4507         const_sv = Nullsv;
4508     else
4509         const_sv = op_const_sv(block, Nullcv);
4510
4511     if (cv) {
4512         const bool exists = CvROOT(cv) || CvXSUB(cv);
4513
4514 #ifdef GV_UNIQUE_CHECK
4515         if (exists && GvUNIQUE(gv)) {
4516             Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
4517         }
4518 #endif
4519
4520         /* if the subroutine doesn't exist and wasn't pre-declared
4521          * with a prototype, assume it will be AUTOLOADed,
4522          * skipping the prototype check
4523          */
4524         if (exists || SvPOK(cv))
4525             cv_ckproto(cv, gv, ps);
4526         /* already defined (or promised)? */
4527         if (exists || GvASSUMECV(gv)) {
4528             if (!block && !attrs) {
4529                 if (CvFLAGS(PL_compcv)) {
4530                     /* might have had built-in attrs applied */
4531                     CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4532                 }
4533                 /* just a "sub foo;" when &foo is already defined */
4534                 SAVEFREESV(PL_compcv);
4535                 goto done;
4536             }
4537             if (block) {
4538                 if (ckWARN(WARN_REDEFINE)
4539                     || (CvCONST(cv)
4540                         && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4541                 {
4542                     const line_t oldline = CopLINE(PL_curcop);
4543                     if (PL_copline != NOLINE)
4544                         CopLINE_set(PL_curcop, PL_copline);
4545                     Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4546                         CvCONST(cv) ? "Constant subroutine %s redefined"
4547                                     : "Subroutine %s redefined", name);
4548                     CopLINE_set(PL_curcop, oldline);
4549                 }
4550                 SvREFCNT_dec(cv);
4551                 cv = Nullcv;
4552             }
4553         }
4554     }
4555     if (const_sv) {
4556         (void)SvREFCNT_inc(const_sv);
4557         if (cv) {
4558             assert(!CvROOT(cv) && !CvCONST(cv));
4559             sv_setpvn((SV*)cv, "", 0);  /* prototype is "" */
4560             CvXSUBANY(cv).any_ptr = const_sv;
4561             CvXSUB(cv) = const_sv_xsub;
4562             CvCONST_on(cv);
4563         }
4564         else {
4565             GvCV(gv) = Nullcv;
4566             cv = newCONSTSUB(NULL, name, const_sv);
4567         }
4568         op_free(block);
4569         SvREFCNT_dec(PL_compcv);
4570         PL_compcv = NULL;
4571         PL_sub_generation++;
4572         goto done;
4573     }
4574     if (attrs) {
4575         HV *stash;
4576         SV *rcv;
4577
4578         /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4579          * before we clobber PL_compcv.
4580          */
4581         if (cv && !block) {
4582             rcv = (SV*)cv;
4583             /* Might have had built-in attributes applied -- propagate them. */
4584             CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4585             if (CvGV(cv) && GvSTASH(CvGV(cv)))
4586                 stash = GvSTASH(CvGV(cv));
4587             else if (CvSTASH(cv))
4588                 stash = CvSTASH(cv);
4589             else
4590                 stash = PL_curstash;
4591         }
4592         else {
4593             /* possibly about to re-define existing subr -- ignore old cv */
4594             rcv = (SV*)PL_compcv;
4595             if (name && GvSTASH(gv))
4596                 stash = GvSTASH(gv);
4597             else
4598                 stash = PL_curstash;
4599         }
4600         apply_attrs(stash, rcv, attrs, FALSE);
4601     }
4602     if (cv) {                           /* must reuse cv if autoloaded */
4603         if (!block) {
4604             /* got here with just attrs -- work done, so bug out */
4605             SAVEFREESV(PL_compcv);
4606             goto done;
4607         }
4608         /* transfer PL_compcv to cv */
4609         cv_undef(cv);
4610         CvFLAGS(cv) = CvFLAGS(PL_compcv);
4611         if (!CvWEAKOUTSIDE(cv))
4612             SvREFCNT_dec(CvOUTSIDE(cv));
4613         CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4614         CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
4615         CvOUTSIDE(PL_compcv) = 0;
4616         CvPADLIST(cv) = CvPADLIST(PL_compcv);
4617         CvPADLIST(PL_compcv) = 0;
4618         /* inner references to PL_compcv must be fixed up ... */
4619         pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
4620         /* ... before we throw it away */
4621         SvREFCNT_dec(PL_compcv);
4622         PL_compcv = cv;
4623         if (PERLDB_INTER)/* Advice debugger on the new sub. */
4624           ++PL_sub_generation;
4625     }
4626     else {
4627         cv = PL_compcv;
4628         if (name) {
4629             GvCV(gv) = cv;
4630             GvCVGEN(gv) = 0;
4631             PL_sub_generation++;
4632         }
4633     }
4634     CvGV(cv) = gv;
4635     CvFILE_set_from_cop(cv, PL_curcop);
4636     CvSTASH(cv) = PL_curstash;
4637
4638     if (ps)
4639         sv_setpvn((SV*)cv, ps, ps_len);
4640
4641     if (PL_error_count) {
4642         op_free(block);
4643         block = Nullop;
4644         if (name) {
4645             const char *s = strrchr(name, ':');
4646             s = s ? s+1 : name;
4647             if (strEQ(s, "BEGIN")) {
4648                 const char not_safe[] =
4649                     "BEGIN not safe after errors--compilation aborted";
4650                 if (PL_in_eval & EVAL_KEEPERR)
4651                     Perl_croak(aTHX_ not_safe);
4652                 else {
4653                     /* force display of errors found but not reported */
4654                     sv_catpv(ERRSV, not_safe);
4655                     Perl_croak(aTHX_ "%"SVf, ERRSV);
4656                 }
4657             }
4658         }
4659     }
4660     if (!block)
4661         goto done;
4662
4663     if (CvLVALUE(cv)) {
4664         CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4665                              mod(scalarseq(block), OP_LEAVESUBLV));
4666     }
4667     else {
4668         /* This makes sub {}; work as expected.  */
4669         if (block->op_type == OP_STUB) {
4670             op_free(block);
4671             block = newSTATEOP(0, Nullch, 0);
4672         }
4673         CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4674     }
4675     CvROOT(cv)->op_private |= OPpREFCOUNTED;
4676     OpREFCNT_set(CvROOT(cv), 1);
4677     CvSTART(cv) = LINKLIST(CvROOT(cv));
4678     CvROOT(cv)->op_next = 0;
4679     CALL_PEEP(CvSTART(cv));
4680
4681     /* now that optimizer has done its work, adjust pad values */
4682
4683     pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
4684
4685     if (CvCLONE(cv)) {
4686         assert(!CvCONST(cv));
4687         if (ps && !*ps && op_const_sv(block, cv))
4688             CvCONST_on(cv);
4689     }
4690
4691     if (name || aname) {
4692         const char *s;
4693         const char * const tname = (name ? name : aname);
4694
4695         if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4696             SV * const sv = NEWSV(0,0);
4697             SV * const tmpstr = sv_newmortal();
4698             GV * const db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4699             HV *hv;
4700
4701             Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4702                            CopFILE(PL_curcop),
4703                            (long)PL_subline, (long)CopLINE(PL_curcop));
4704             gv_efullname3(tmpstr, gv, Nullch);
4705             hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr), SvCUR(tmpstr), sv, 0);
4706             hv = GvHVn(db_postponed);
4707             if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
4708                 CV * const pcv = GvCV(db_postponed);
4709                 if (pcv) {
4710                     dSP;
4711                     PUSHMARK(SP);
4712                     XPUSHs(tmpstr);
4713                     PUTBACK;
4714                     call_sv((SV*)pcv, G_DISCARD);
4715                 }
4716             }
4717         }
4718
4719         if ((s = strrchr(tname,':')))
4720             s++;
4721         else
4722             s = tname;
4723
4724         if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4725             goto done;
4726
4727         if (strEQ(s, "BEGIN") && !PL_error_count) {
4728             const I32 oldscope = PL_scopestack_ix;
4729             ENTER;
4730             SAVECOPFILE(&PL_compiling);
4731             SAVECOPLINE(&PL_compiling);
4732
4733             if (!PL_beginav)
4734                 PL_beginav = newAV();
4735             DEBUG_x( dump_sub(gv) );
4736             av_push(PL_beginav, (SV*)cv);
4737             GvCV(gv) = 0;               /* cv has been hijacked */
4738             call_list(oldscope, PL_beginav);
4739
4740             PL_curcop = &PL_compiling;
4741             PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4742             LEAVE;
4743         }
4744         else if (strEQ(s, "END") && !PL_error_count) {
4745             if (!PL_endav)
4746                 PL_endav = newAV();
4747             DEBUG_x( dump_sub(gv) );
4748             av_unshift(PL_endav, 1);
4749             av_store(PL_endav, 0, (SV*)cv);
4750             GvCV(gv) = 0;               /* cv has been hijacked */
4751         }
4752         else if (strEQ(s, "CHECK") && !PL_error_count) {
4753             if (!PL_checkav)
4754                 PL_checkav = newAV();
4755             DEBUG_x( dump_sub(gv) );
4756             if (PL_main_start && ckWARN(WARN_VOID))
4757                 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4758             av_unshift(PL_checkav, 1);
4759             av_store(PL_checkav, 0, (SV*)cv);
4760             GvCV(gv) = 0;               /* cv has been hijacked */
4761         }
4762         else if (strEQ(s, "INIT") && !PL_error_count) {
4763             if (!PL_initav)
4764                 PL_initav = newAV();
4765             DEBUG_x( dump_sub(gv) );
4766             if (PL_main_start && ckWARN(WARN_VOID))
4767                 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4768             av_push(PL_initav, (SV*)cv);
4769             GvCV(gv) = 0;               /* cv has been hijacked */
4770         }
4771     }
4772
4773   done:
4774     PL_copline = NOLINE;
4775     LEAVE_SCOPE(floor);
4776     return cv;
4777 }
4778
4779 /* XXX unsafe for threads if eval_owner isn't held */
4780 /*
4781 =for apidoc newCONSTSUB
4782
4783 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4784 eligible for inlining at compile-time.
4785
4786 =cut
4787 */
4788
4789 CV *
4790 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
4791 {
4792     dVAR;
4793     CV* cv;
4794
4795     ENTER;
4796
4797     SAVECOPLINE(PL_curcop);
4798     CopLINE_set(PL_curcop, PL_copline);
4799
4800     SAVEHINTS();
4801     PL_hints &= ~HINT_BLOCK_SCOPE;
4802
4803     if (stash) {
4804         SAVESPTR(PL_curstash);
4805         SAVECOPSTASH(PL_curcop);
4806         PL_curstash = stash;
4807         CopSTASH_set(PL_curcop,stash);
4808     }
4809
4810     cv = newXS(name, const_sv_xsub, savepv(CopFILE(PL_curcop)));
4811     CvXSUBANY(cv).any_ptr = sv;
4812     CvCONST_on(cv);
4813     sv_setpvn((SV*)cv, "", 0);  /* prototype is "" */
4814
4815 #ifdef USE_ITHREADS
4816     if (stash)
4817         CopSTASH_free(PL_curcop);
4818 #endif
4819     LEAVE;
4820
4821     return cv;
4822 }
4823
4824 /*
4825 =for apidoc U||newXS
4826
4827 Used by C<xsubpp> to hook up XSUBs as Perl subs.
4828
4829 =cut
4830 */
4831
4832 CV *
4833 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
4834 {
4835     GV * const gv = gv_fetchpv(name ? name :
4836                         (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4837                         GV_ADDMULTI, SVt_PVCV);
4838     register CV *cv;
4839
4840     if (!subaddr)
4841         Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
4842
4843     if ((cv = (name ? GvCV(gv) : Nullcv))) {
4844         if (GvCVGEN(gv)) {
4845             /* just a cached method */
4846             SvREFCNT_dec(cv);
4847             cv = Nullcv;
4848         }
4849         else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4850             /* already defined (or promised) */
4851             /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
4852             if (ckWARN(WARN_REDEFINE)) {
4853                 GV * const gvcv = CvGV(cv);
4854                 if (gvcv) {
4855                     HV * const stash = GvSTASH(gvcv);
4856                     if (stash) {
4857                         const char *name = HvNAME_get(stash);
4858                         if ( strEQ(name,"autouse") ) {
4859                             const line_t oldline = CopLINE(PL_curcop);
4860                             if (PL_copline != NOLINE)
4861                                 CopLINE_set(PL_curcop, PL_copline);
4862                             Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4863                                         CvCONST(cv) ? "Constant subroutine %s redefined"
4864                                                     : "Subroutine %s redefined"
4865                                         ,name);
4866                             CopLINE_set(PL_curcop, oldline);
4867                         }
4868                     }
4869                 }
4870             }
4871             SvREFCNT_dec(cv);
4872             cv = Nullcv;
4873         }
4874     }
4875
4876     if (cv)                             /* must reuse cv if autoloaded */
4877         cv_undef(cv);
4878     else {
4879         cv = (CV*)NEWSV(1105,0);
4880         sv_upgrade((SV *)cv, SVt_PVCV);
4881         if (name) {
4882             GvCV(gv) = cv;
4883             GvCVGEN(gv) = 0;
4884             PL_sub_generation++;
4885         }
4886     }
4887     CvGV(cv) = gv;
4888     (void)gv_fetchfile(filename);
4889     CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
4890                                    an external constant string */
4891     CvXSUB(cv) = subaddr;
4892
4893     if (name) {
4894         const char *s = strrchr(name,':');
4895         if (s)
4896             s++;
4897         else
4898             s = name;
4899
4900         if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4901             goto done;
4902
4903         if (strEQ(s, "BEGIN")) {
4904             if (!PL_beginav)
4905                 PL_beginav = newAV();
4906             av_push(PL_beginav, (SV*)cv);
4907             GvCV(gv) = 0;               /* cv has been hijacked */
4908         }
4909         else if (strEQ(s, "END")) {
4910             if (!PL_endav)
4911                 PL_endav = newAV();
4912             av_unshift(PL_endav, 1);
4913             av_store(PL_endav, 0, (SV*)cv);
4914             GvCV(gv) = 0;               /* cv has been hijacked */
4915         }
4916         else if (strEQ(s, "CHECK")) {
4917             if (!PL_checkav)
4918                 PL_checkav = newAV();
4919             if (PL_main_start && ckWARN(WARN_VOID))
4920                 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4921             av_unshift(PL_checkav, 1);
4922             av_store(PL_checkav, 0, (SV*)cv);
4923             GvCV(gv) = 0;               /* cv has been hijacked */
4924         }
4925         else if (strEQ(s, "INIT")) {
4926             if (!PL_initav)
4927                 PL_initav = newAV();
4928             if (PL_main_start && ckWARN(WARN_VOID))
4929                 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4930             av_push(PL_initav, (SV*)cv);
4931             GvCV(gv) = 0;               /* cv has been hijacked */
4932         }
4933     }
4934     else
4935         CvANON_on(cv);
4936
4937 done:
4938     return cv;
4939 }
4940
4941 void
4942 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
4943 {
4944     register CV *cv;
4945
4946     GV * const gv = o
4947         ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
4948         : gv_fetchpv("STDOUT", GV_ADD, SVt_PVFM);
4949
4950 #ifdef GV_UNIQUE_CHECK
4951     if (GvUNIQUE(gv)) {
4952         Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
4953     }
4954 #endif
4955     GvMULTI_on(gv);
4956     if ((cv = GvFORM(gv))) {
4957         if (ckWARN(WARN_REDEFINE)) {
4958             const line_t oldline = CopLINE(PL_curcop);
4959             if (PL_copline != NOLINE)
4960                 CopLINE_set(PL_curcop, PL_copline);
4961             Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4962                         o ? "Format %"SVf" redefined"
4963                         : "Format STDOUT redefined" ,cSVOPo->op_sv);
4964             CopLINE_set(PL_curcop, oldline);
4965         }
4966         SvREFCNT_dec(cv);
4967     }
4968     cv = PL_compcv;
4969     GvFORM(gv) = cv;
4970     CvGV(cv) = gv;
4971     CvFILE_set_from_cop(cv, PL_curcop);
4972
4973
4974     pad_tidy(padtidy_FORMAT);
4975     CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
4976     CvROOT(cv)->op_private |= OPpREFCOUNTED;
4977     OpREFCNT_set(CvROOT(cv), 1);
4978     CvSTART(cv) = LINKLIST(CvROOT(cv));
4979     CvROOT(cv)->op_next = 0;
4980     CALL_PEEP(CvSTART(cv));
4981     op_free(o);
4982     PL_copline = NOLINE;
4983     LEAVE_SCOPE(floor);
4984 }
4985
4986 OP *
4987 Perl_newANONLIST(pTHX_ OP *o)
4988 {
4989     return newUNOP(OP_REFGEN, 0,
4990         mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
4991 }
4992
4993 OP *
4994 Perl_newANONHASH(pTHX_ OP *o)
4995 {
4996     return newUNOP(OP_REFGEN, 0,
4997         mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
4998 }
4999
5000 OP *
5001 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5002 {
5003     return newANONATTRSUB(floor, proto, Nullop, block);
5004 }
5005
5006 OP *
5007 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5008 {
5009     return newUNOP(OP_REFGEN, 0,
5010         newSVOP(OP_ANONCODE, 0,
5011                 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5012 }
5013
5014 OP *
5015 Perl_oopsAV(pTHX_ OP *o)
5016 {
5017     dVAR;
5018     switch (o->op_type) {
5019     case OP_PADSV:
5020         o->op_type = OP_PADAV;
5021         o->op_ppaddr = PL_ppaddr[OP_PADAV];
5022         return ref(o, OP_RV2AV);
5023
5024     case OP_RV2SV:
5025         o->op_type = OP_RV2AV;
5026         o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5027         ref(o, OP_RV2AV);
5028         break;
5029
5030     default:
5031         if (ckWARN_d(WARN_INTERNAL))
5032             Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
5033         break;
5034     }
5035     return o;
5036 }
5037
5038 OP *
5039 Perl_oopsHV(pTHX_ OP *o)
5040 {
5041     dVAR;
5042     switch (o->op_type) {
5043     case OP_PADSV:
5044     case OP_PADAV:
5045         o->op_type = OP_PADHV;
5046         o->op_ppaddr = PL_ppaddr[OP_PADHV];
5047         return ref(o, OP_RV2HV);
5048
5049     case OP_RV2SV:
5050     case OP_RV2AV:
5051         o->op_type = OP_RV2HV;
5052         o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5053         ref(o, OP_RV2HV);
5054         break;
5055
5056     default:
5057         if (ckWARN_d(WARN_INTERNAL))
5058             Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
5059         break;
5060     }
5061     return o;
5062 }
5063
5064 OP *
5065 Perl_newAVREF(pTHX_ OP *o)
5066 {
5067     dVAR;
5068     if (o->op_type == OP_PADANY) {
5069         o->op_type = OP_PADAV;
5070         o->op_ppaddr = PL_ppaddr[OP_PADAV];
5071         return o;
5072     }
5073     else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
5074                 && ckWARN(WARN_DEPRECATED)) {
5075         Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5076                 "Using an array as a reference is deprecated");
5077     }
5078     return newUNOP(OP_RV2AV, 0, scalar(o));
5079 }
5080
5081 OP *
5082 Perl_newGVREF(pTHX_ I32 type, OP *o)
5083 {
5084     if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5085         return newUNOP(OP_NULL, 0, o);
5086     return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5087 }
5088
5089 OP *
5090 Perl_newHVREF(pTHX_ OP *o)
5091 {
5092     dVAR;
5093     if (o->op_type == OP_PADANY) {
5094         o->op_type = OP_PADHV;
5095         o->op_ppaddr = PL_ppaddr[OP_PADHV];
5096         return o;
5097     }
5098     else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
5099                 && ckWARN(WARN_DEPRECATED)) {
5100         Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5101                 "Using a hash as a reference is deprecated");
5102     }
5103     return newUNOP(OP_RV2HV, 0, scalar(o));
5104 }
5105
5106 OP *
5107 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5108 {
5109     return newUNOP(OP_RV2CV, flags, scalar(o));
5110 }
5111
5112 OP *
5113 Perl_newSVREF(pTHX_ OP *o)
5114 {
5115     dVAR;
5116     if (o->op_type == OP_PADANY) {
5117         o->op_type = OP_PADSV;
5118         o->op_ppaddr = PL_ppaddr[OP_PADSV];
5119         return o;
5120     }
5121     else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5122         o->op_flags |= OPpDONE_SVREF;
5123         return o;
5124     }
5125     return newUNOP(OP_RV2SV, 0, scalar(o));
5126 }
5127
5128 /* Check routines. See the comments at the top of this file for details
5129  * on when these are called */
5130
5131 OP *
5132 Perl_ck_anoncode(pTHX_ OP *o)
5133 {
5134     cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
5135     cSVOPo->op_sv = Nullsv;
5136     return o;
5137 }
5138
5139 OP *
5140 Perl_ck_bitop(pTHX_ OP *o)
5141 {
5142 #define OP_IS_NUMCOMPARE(op) \
5143         ((op) == OP_LT   || (op) == OP_I_LT || \
5144          (op) == OP_GT   || (op) == OP_I_GT || \
5145          (op) == OP_LE   || (op) == OP_I_LE || \
5146          (op) == OP_GE   || (op) == OP_I_GE || \
5147          (op) == OP_EQ   || (op) == OP_I_EQ || \
5148          (op) == OP_NE   || (op) == OP_I_NE || \
5149          (op) == OP_NCMP || (op) == OP_I_NCMP)
5150     o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
5151     if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
5152             && (o->op_type == OP_BIT_OR
5153              || o->op_type == OP_BIT_AND
5154              || o->op_type == OP_BIT_XOR))
5155     {
5156         const OP * const left = cBINOPo->op_first;
5157         const OP * const right = left->op_sibling;
5158         if ((OP_IS_NUMCOMPARE(left->op_type) &&
5159                 (left->op_flags & OPf_PARENS) == 0) ||
5160             (OP_IS_NUMCOMPARE(right->op_type) &&
5161                 (right->op_flags & OPf_PARENS) == 0))
5162             if (ckWARN(WARN_PRECEDENCE))
5163                 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
5164                         "Possible precedence problem on bitwise %c operator",
5165                         o->op_type == OP_BIT_OR ? '|'
5166                             : o->op_type == OP_BIT_AND ? '&' : '^'
5167                         );
5168     }
5169     return o;
5170 }
5171
5172 OP *
5173 Perl_ck_concat(pTHX_ OP *o)
5174 {
5175     const OP * const kid = cUNOPo->op_first;
5176     if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
5177             !(kUNOP->op_first->op_flags & OPf_MOD))
5178         o->op_flags |= OPf_STACKED;
5179     return o;
5180 }
5181
5182 OP *
5183 Perl_ck_spair(pTHX_ OP *o)
5184 {
5185     dVAR;
5186     if (o->op_flags & OPf_KIDS) {
5187         OP* newop;
5188         OP* kid;
5189         const OPCODE type = o->op_type;
5190         o = modkids(ck_fun(o), type);
5191         kid = cUNOPo->op_first;
5192         newop = kUNOP->op_first->op_sibling;
5193         if (newop &&
5194             (newop->op_sibling ||
5195              !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
5196              newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5197              newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
5198
5199             return o;
5200         }
5201         op_free(kUNOP->op_first);
5202         kUNOP->op_first = newop;
5203     }
5204     o->op_ppaddr = PL_ppaddr[++o->op_type];
5205     return ck_fun(o);
5206 }
5207
5208 OP *
5209 Perl_ck_delete(pTHX_ OP *o)
5210 {
5211     o = ck_fun(o);
5212     o->op_private = 0;
5213     if (o->op_flags & OPf_KIDS) {
5214         OP * const kid = cUNOPo->op_first;
5215         switch (kid->op_type) {
5216         case OP_ASLICE:
5217             o->op_flags |= OPf_SPECIAL;
5218             /* FALL THROUGH */
5219         case OP_HSLICE:
5220             o->op_private |= OPpSLICE;
5221             break;
5222         case OP_AELEM:
5223             o->op_flags |= OPf_SPECIAL;
5224             /* FALL THROUGH */
5225         case OP_HELEM:
5226             break;
5227         default:
5228             Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5229                   OP_DESC(o));
5230         }
5231         op_null(kid);
5232     }
5233     return o;
5234 }
5235
5236 OP *
5237 Perl_ck_die(pTHX_ OP *o)
5238 {
5239 #ifdef VMS
5240     if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5241 #endif
5242     return ck_fun(o);
5243 }
5244
5245 OP *
5246 Perl_ck_eof(pTHX_ OP *o)
5247 {
5248     const I32 type = o->op_type;
5249
5250     if (o->op_flags & OPf_KIDS) {
5251         if (cLISTOPo->op_first->op_type == OP_STUB) {
5252             op_free(o);
5253             o = newUNOP(type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
5254         }
5255         return ck_fun(o);
5256     }
5257     return o;
5258 }
5259
5260 OP *
5261 Perl_ck_eval(pTHX_ OP *o)
5262 {
5263     dVAR;
5264     PL_hints |= HINT_BLOCK_SCOPE;
5265     if (o->op_flags & OPf_KIDS) {
5266         SVOP * const kid = (SVOP*)cUNOPo->op_first;
5267
5268         if (!kid) {
5269             o->op_flags &= ~OPf_KIDS;
5270             op_null(o);
5271         }
5272         else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
5273             LOGOP *enter;
5274
5275             cUNOPo->op_first = 0;
5276             op_free(o);
5277
5278             NewOp(1101, enter, 1, LOGOP);
5279             enter->op_type = OP_ENTERTRY;
5280             enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5281             enter->op_private = 0;
5282
5283             /* establish postfix order */
5284             enter->op_next = (OP*)enter;
5285
5286             o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5287             o->op_type = OP_LEAVETRY;
5288             o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5289             enter->op_other = o;
5290             return o;
5291         }
5292         else {
5293             scalar((OP*)kid);
5294             PL_cv_has_eval = 1;
5295         }
5296     }
5297     else {
5298         op_free(o);
5299         o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5300     }
5301     o->op_targ = (PADOFFSET)PL_hints;
5302     if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
5303         /* Store a copy of %^H that pp_entereval can pick up */
5304         OP *hhop = newSVOP(OP_CONST, 0, (SV*)newHVhv(GvHV(PL_hintgv)));
5305         cUNOPo->op_first->op_sibling = hhop;
5306         o->op_private |= OPpEVAL_HAS_HH;
5307     }
5308     return o;
5309 }
5310
5311 OP *
5312 Perl_ck_exit(pTHX_ OP *o)
5313 {
5314 #ifdef VMS
5315     HV * const table = GvHV(PL_hintgv);
5316     if (table) {
5317        SV * const * const svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
5318        if (svp && *svp && SvTRUE(*svp))
5319            o->op_private |= OPpEXIT_VMSISH;
5320     }
5321     if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5322 #endif
5323     return ck_fun(o);
5324 }
5325
5326 OP *
5327 Perl_ck_exec(pTHX_ OP *o)
5328 {
5329     if (o->op_flags & OPf_STACKED) {
5330         OP *kid;
5331         o = ck_fun(o);
5332         kid = cUNOPo->op_first->op_sibling;
5333         if (kid->op_type == OP_RV2GV)
5334             op_null(kid);
5335     }
5336     else
5337         o = listkids(o);
5338     return o;
5339 }
5340
5341 OP *
5342 Perl_ck_exists(pTHX_ OP *o)
5343 {
5344     o = ck_fun(o);
5345     if (o->op_flags & OPf_KIDS) {
5346         OP * const kid = cUNOPo->op_first;
5347         if (kid->op_type == OP_ENTERSUB) {
5348             (void) ref(kid, o->op_type);
5349             if (kid->op_type != OP_RV2CV && !PL_error_count)
5350                 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5351                             OP_DESC(o));
5352             o->op_private |= OPpEXISTS_SUB;
5353         }
5354         else if (kid->op_type == OP_AELEM)
5355             o->op_flags |= OPf_SPECIAL;
5356         else if (kid->op_type != OP_HELEM)
5357             Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5358                         OP_DESC(o));
5359         op_null(kid);
5360     }
5361     return o;
5362 }
5363
5364 OP *
5365 Perl_ck_rvconst(pTHX_ register OP *o)
5366 {
5367     dVAR;
5368     SVOP * const kid = (SVOP*)cUNOPo->op_first;
5369
5370     o->op_private |= (PL_hints & HINT_STRICT_REFS);
5371     if (o->op_type == OP_RV2CV)
5372         o->op_private &= ~1;
5373
5374     if (kid->op_type == OP_CONST) {
5375         int iscv;
5376         GV *gv;
5377         SV * const kidsv = kid->op_sv;
5378
5379         /* Is it a constant from cv_const_sv()? */
5380         if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5381             SV * const rsv = SvRV(kidsv);
5382             const int svtype = SvTYPE(rsv);
5383             const char *badtype = Nullch;
5384
5385             switch (o->op_type) {
5386             case OP_RV2SV:
5387                 if (svtype > SVt_PVMG)
5388                     badtype = "a SCALAR";
5389                 break;
5390             case OP_RV2AV:
5391                 if (svtype != SVt_PVAV)
5392                     badtype = "an ARRAY";
5393                 break;
5394             case OP_RV2HV:
5395                 if (svtype != SVt_PVHV)
5396                     badtype = "a HASH";
5397                 break;
5398             case OP_RV2CV:
5399                 if (svtype != SVt_PVCV)
5400                     badtype = "a CODE";
5401                 break;
5402             }
5403             if (badtype)
5404                 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5405             return o;
5406         }
5407         if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5408             const char *badthing = Nullch;
5409             switch (o->op_type) {
5410             case OP_RV2SV:
5411                 badthing = "a SCALAR";
5412                 break;
5413             case OP_RV2AV:
5414                 badthing = "an ARRAY";
5415                 break;
5416             case OP_RV2HV:
5417                 badthing = "a HASH";
5418                 break;
5419             }
5420             if (badthing)
5421                 Perl_croak(aTHX_
5422           "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
5423                       kidsv, badthing);
5424         }
5425         /*
5426          * This is a little tricky.  We only want to add the symbol if we
5427          * didn't add it in the lexer.  Otherwise we get duplicate strict
5428          * warnings.  But if we didn't add it in the lexer, we must at
5429          * least pretend like we wanted to add it even if it existed before,
5430          * or we get possible typo warnings.  OPpCONST_ENTERED says
5431          * whether the lexer already added THIS instance of this symbol.
5432          */
5433         iscv = (o->op_type == OP_RV2CV) * 2;
5434         do {
5435             gv = gv_fetchsv(kidsv,
5436                 iscv | !(kid->op_private & OPpCONST_ENTERED),
5437                 iscv
5438                     ? SVt_PVCV
5439                     : o->op_type == OP_RV2SV
5440                         ? SVt_PV
5441                         : o->op_type == OP_RV2AV
5442                             ? SVt_PVAV
5443                             : o->op_type == OP_RV2HV
5444                                 ? SVt_PVHV
5445                                 : SVt_PVGV);
5446         } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5447         if (gv) {
5448             kid->op_type = OP_GV;
5449             SvREFCNT_dec(kid->op_sv);
5450 #ifdef USE_ITHREADS
5451             /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5452             kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5453             SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
5454             GvIN_PAD_on(gv);
5455             PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc(gv));
5456 #else
5457             kid->op_sv = SvREFCNT_inc(gv);
5458 #endif
5459             kid->op_private = 0;
5460             kid->op_ppaddr = PL_ppaddr[OP_GV];
5461         }
5462     }
5463     return o;
5464 }
5465
5466 OP *
5467 Perl_ck_ftst(pTHX_ OP *o)
5468 {
5469     dVAR;
5470     const I32 type = o->op_type;
5471
5472     if (o->op_flags & OPf_REF) {
5473         /* nothing */
5474     }
5475     else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5476         SVOP * const kid = (SVOP*)cUNOPo->op_first;
5477
5478         if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5479             OP * const newop = newGVOP(type, OPf_REF,
5480                 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
5481             op_free(o);
5482             o = newop;
5483             return o;
5484         }
5485         else {
5486           if ((PL_hints & HINT_FILETEST_ACCESS) &&
5487               OP_IS_FILETEST_ACCESS(o))
5488             o->op_private |= OPpFT_ACCESS;
5489         }
5490         if (PL_check[kid->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst)
5491                 && kid->op_type != OP_STAT && kid->op_type != OP_LSTAT)
5492             o->op_private |= OPpFT_STACKED;
5493     }
5494     else {
5495         op_free(o);
5496         if (type == OP_FTTTY)
5497             o = newGVOP(type, OPf_REF, PL_stdingv);
5498         else
5499             o = newUNOP(type, 0, newDEFSVOP());
5500     }
5501     return o;
5502 }
5503
5504 OP *
5505 Perl_ck_fun(pTHX_ OP *o)
5506 {
5507     const int type = o->op_type;
5508     register I32 oa = PL_opargs[type] >> OASHIFT;
5509
5510     if (o->op_flags & OPf_STACKED) {
5511         if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5512             oa &= ~OA_OPTIONAL;
5513         else
5514             return no_fh_allowed(o);
5515     }
5516
5517     if (o->op_flags & OPf_KIDS) {
5518         OP **tokid = &cLISTOPo->op_first;
5519         register OP *kid = cLISTOPo->op_first;
5520         OP *sibl;
5521         I32 numargs = 0;
5522
5523         if (kid->op_type == OP_PUSHMARK ||
5524             (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5525         {
5526             tokid = &kid->op_sibling;
5527             kid = kid->op_sibling;
5528         }
5529         if (!kid && PL_opargs[type] & OA_DEFGV)
5530             *tokid = kid = newDEFSVOP();
5531
5532         while (oa && kid) {
5533             numargs++;
5534             sibl = kid->op_sibling;
5535             switch (oa & 7) {
5536             case OA_SCALAR:
5537                 /* list seen where single (scalar) arg expected? */
5538                 if (numargs == 1 && !(oa >> 4)
5539                     && kid->op_type == OP_LIST && type != OP_SCALAR)
5540                 {
5541                     return too_many_arguments(o,PL_op_desc[type]);
5542                 }
5543                 scalar(kid);
5544                 break;
5545             case OA_LIST:
5546                 if (oa < 16) {
5547                     kid = 0;
5548                     continue;
5549                 }
5550                 else
5551                     list(kid);
5552                 break;
5553             case OA_AVREF:
5554                 if ((type == OP_PUSH || type == OP_UNSHIFT)
5555                     && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5556                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5557                         "Useless use of %s with no values",
5558                         PL_op_desc[type]);
5559
5560                 if (kid->op_type == OP_CONST &&
5561                     (kid->op_private & OPpCONST_BARE))
5562                 {
5563                     OP * const newop = newAVREF(newGVOP(OP_GV, 0,
5564                         gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
5565                     if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5566                         Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5567                             "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
5568                             ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
5569                     op_free(kid);
5570                     kid = newop;
5571                     kid->op_sibling = sibl;
5572                     *tokid = kid;
5573                 }
5574                 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5575                     bad_type(numargs, "array", PL_op_desc[type], kid);
5576                 mod(kid, type);
5577                 break;
5578             case OA_HVREF:
5579                 if (kid->op_type == OP_CONST &&
5580                     (kid->op_private & OPpCONST_BARE))
5581                 {
5582                     OP * const newop = newHVREF(newGVOP(OP_GV, 0,
5583                         gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
5584                     if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5585                         Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5586                             "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
5587                             ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
5588                     op_free(kid);
5589                     kid = newop;
5590                     kid->op_sibling = sibl;
5591                     *tokid = kid;
5592                 }
5593                 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5594                     bad_type(numargs, "hash", PL_op_desc[type], kid);
5595                 mod(kid, type);
5596                 break;
5597             case OA_CVREF:
5598                 {
5599                     OP * const newop = newUNOP(OP_NULL, 0, kid);
5600                     kid->op_sibling = 0;
5601                     linklist(kid);
5602                     newop->op_next = newop;
5603                     kid = newop;
5604                     kid->op_sibling = sibl;
5605                     *tokid = kid;
5606                 }
5607                 break;
5608             case OA_FILEREF:
5609                 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5610                     if (kid->op_type == OP_CONST &&
5611                         (kid->op_private & OPpCONST_BARE))
5612                     {
5613                         OP * const newop = newGVOP(OP_GV, 0,
5614                             gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
5615                         if (!(o->op_private & 1) && /* if not unop */
5616                             kid == cLISTOPo->op_last)
5617                             cLISTOPo->op_last = newop;
5618                         op_free(kid);
5619                         kid = newop;
5620                     }
5621                     else if (kid->op_type == OP_READLINE) {
5622                         /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5623                         bad_type(numargs, "HANDLE", OP_DESC(o), kid);
5624                     }
5625                     else {
5626                         I32 flags = OPf_SPECIAL;
5627                         I32 priv = 0;
5628                         PADOFFSET targ = 0;
5629
5630                         /* is this op a FH constructor? */
5631                         if (is_handle_constructor(o,numargs)) {
5632                             const char *name = Nullch;
5633                             STRLEN len = 0;
5634
5635                             flags = 0;
5636                             /* Set a flag to tell rv2gv to vivify
5637                              * need to "prove" flag does not mean something
5638                              * else already - NI-S 1999/05/07
5639                              */
5640                             priv = OPpDEREF;
5641                             if (kid->op_type == OP_PADSV) {
5642                                 name = PAD_COMPNAME_PV(kid->op_targ);
5643                                 /* SvCUR of a pad namesv can't be trusted
5644                                  * (see PL_generation), so calc its length
5645                                  * manually */
5646                                 if (name)
5647                                     len = strlen(name);
5648
5649                             }
5650                             else if (kid->op_type == OP_RV2SV
5651                                      && kUNOP->op_first->op_type == OP_GV)
5652                             {
5653                                 GV * const gv = cGVOPx_gv(kUNOP->op_first);
5654                                 name = GvNAME(gv);
5655                                 len = GvNAMELEN(gv);
5656                             }
5657                             else if (kid->op_type == OP_AELEM
5658                                      || kid->op_type == OP_HELEM)
5659                             {
5660                                  OP *op = ((BINOP*)kid)->op_first;
5661                                  name = 0;
5662                                  if (op) {
5663                                       SV *tmpstr = Nullsv;
5664                                       const char * const a =
5665                                            kid->op_type == OP_AELEM ?
5666                                            "[]" : "{}";
5667                                       if (((op->op_type == OP_RV2AV) ||
5668                                            (op->op_type == OP_RV2HV)) &&
5669                                           (op = ((UNOP*)op)->op_first) &&
5670                                           (op->op_type == OP_GV)) {
5671                                            /* packagevar $a[] or $h{} */
5672                                            GV * const gv = cGVOPx_gv(op);
5673                                            if (gv)
5674                                                 tmpstr =
5675                                                      Perl_newSVpvf(aTHX_
5676                                                                    "%s%c...%c",
5677                                                                    GvNAME(gv),
5678                                                                    a[0], a[1]);
5679                                       }
5680                                       else if (op->op_type == OP_PADAV
5681                                                || op->op_type == OP_PADHV) {
5682                                            /* lexicalvar $a[] or $h{} */
5683                                            const char * const padname =
5684                                                 PAD_COMPNAME_PV(op->op_targ);
5685                                            if (padname)
5686                                                 tmpstr =
5687                                                      Perl_newSVpvf(aTHX_
5688                                                                    "%s%c...%c",
5689                                                                    padname + 1,
5690                                                                    a[0], a[1]);
5691                                       }
5692                                       if (tmpstr) {
5693                                            name = SvPV_const(tmpstr, len);
5694                                            sv_2mortal(tmpstr);
5695                                       }
5696                                  }
5697                                  if (!name) {
5698                                       name = "__ANONIO__";
5699                                       len = 10;
5700                                  }
5701                                  mod(kid, type);
5702                             }
5703                             if (name) {
5704                                 SV *namesv;
5705                                 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5706                                 namesv = PAD_SVl(targ);
5707                                 SvUPGRADE(namesv, SVt_PV);
5708                                 if (*name != '$')
5709                                     sv_setpvn(namesv, "$", 1);
5710                                 sv_catpvn(namesv, name, len);
5711                             }
5712                         }
5713                         kid->op_sibling = 0;
5714                         kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5715                         kid->op_targ = targ;
5716                         kid->op_private |= priv;
5717                     }
5718                     kid->op_sibling = sibl;
5719                     *tokid = kid;
5720                 }
5721                 scalar(kid);
5722                 break;
5723             case OA_SCALARREF:
5724                 mod(scalar(kid), type);
5725                 break;
5726             }
5727             oa >>= 4;
5728             tokid = &kid->op_sibling;
5729             kid = kid->op_sibling;
5730         }
5731         o->op_private |= numargs;
5732         if (kid)
5733             return too_many_arguments(o,OP_DESC(o));
5734         listkids(o);
5735     }
5736     else if (PL_opargs[type] & OA_DEFGV) {
5737         op_free(o);
5738         return newUNOP(type, 0, newDEFSVOP());
5739     }
5740
5741     if (oa) {
5742         while (oa & OA_OPTIONAL)
5743             oa >>= 4;
5744         if (oa && oa != OA_LIST)
5745             return too_few_arguments(o,OP_DESC(o));
5746     }
5747     return o;
5748 }
5749
5750 OP *
5751 Perl_ck_glob(pTHX_ OP *o)
5752 {
5753     dVAR;
5754     GV *gv;
5755
5756     o = ck_fun(o);
5757     if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5758         append_elem(OP_GLOB, o, newDEFSVOP());
5759
5760     if (!((gv = gv_fetchpv("glob", 0, SVt_PVCV))
5761           && GvCVu(gv) && GvIMPORTED_CV(gv)))
5762     {
5763         gv = gv_fetchpv("CORE::GLOBAL::glob", 0, SVt_PVCV);
5764     }
5765
5766 #if !defined(PERL_EXTERNAL_GLOB)
5767     /* XXX this can be tightened up and made more failsafe. */
5768     if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
5769         GV *glob_gv;
5770         ENTER;
5771         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
5772                 newSVpvn("File::Glob", 10), Nullsv, Nullsv, Nullsv);
5773         gv = gv_fetchpv("CORE::GLOBAL::glob", 0, SVt_PVCV);
5774         glob_gv = gv_fetchpv("File::Glob::csh_glob", 0, SVt_PVCV);
5775         GvCV(gv) = GvCV(glob_gv);
5776         (void)SvREFCNT_inc((SV*)GvCV(gv));
5777         GvIMPORTED_CV_on(gv);
5778         LEAVE;
5779     }
5780 #endif /* PERL_EXTERNAL_GLOB */
5781
5782     if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5783         append_elem(OP_GLOB, o,
5784                     newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5785         o->op_type = OP_LIST;
5786         o->op_ppaddr = PL_ppaddr[OP_LIST];
5787         cLISTOPo->op_first->op_type = OP_PUSHMARK;
5788         cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5789         cLISTOPo->op_first->op_targ = 0;
5790         o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5791                     append_elem(OP_LIST, o,
5792                                 scalar(newUNOP(OP_RV2CV, 0,
5793                                                newGVOP(OP_GV, 0, gv)))));
5794         o = newUNOP(OP_NULL, 0, ck_subr(o));
5795         o->op_targ = OP_GLOB;           /* hint at what it used to be */
5796         return o;
5797     }
5798     gv = newGVgen("main");
5799     gv_IOadd(gv);
5800     append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5801     scalarkids(o);
5802     return o;
5803 }
5804
5805 OP *
5806 Perl_ck_grep(pTHX_ OP *o)
5807 {
5808     dVAR;
5809     LOGOP *gwop;
5810     OP *kid;
5811     const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5812     I32 offset;
5813
5814     o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5815     NewOp(1101, gwop, 1, LOGOP);
5816
5817     if (o->op_flags & OPf_STACKED) {
5818         OP* k;
5819         o = ck_sort(o);
5820         kid = cLISTOPo->op_first->op_sibling;
5821         if (!cUNOPx(kid)->op_next)
5822             Perl_croak(aTHX_ "panic: ck_grep");
5823         for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
5824             kid = k;
5825         }
5826         kid->op_next = (OP*)gwop;
5827         o->op_flags &= ~OPf_STACKED;
5828     }
5829     kid = cLISTOPo->op_first->op_sibling;
5830     if (type == OP_MAPWHILE)
5831         list(kid);
5832     else
5833         scalar(kid);
5834     o = ck_fun(o);
5835     if (PL_error_count)
5836         return o;
5837     kid = cLISTOPo->op_first->op_sibling;
5838     if (kid->op_type != OP_NULL)
5839         Perl_croak(aTHX_ "panic: ck_grep");
5840     kid = kUNOP->op_first;
5841
5842     gwop->op_type = type;
5843     gwop->op_ppaddr = PL_ppaddr[type];
5844     gwop->op_first = listkids(o);
5845     gwop->op_flags |= OPf_KIDS;
5846     gwop->op_other = LINKLIST(kid);
5847     kid->op_next = (OP*)gwop;
5848     offset = pad_findmy("$_");
5849     if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
5850         o->op_private = gwop->op_private = 0;
5851         gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5852     }
5853     else {
5854         o->op_private = gwop->op_private = OPpGREP_LEX;
5855         gwop->op_targ = o->op_targ = offset;
5856     }
5857
5858     kid = cLISTOPo->op_first->op_sibling;
5859     if (!kid || !kid->op_sibling)
5860         return too_few_arguments(o,OP_DESC(o));
5861     for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5862         mod(kid, OP_GREPSTART);
5863
5864     return (OP*)gwop;
5865 }
5866
5867 OP *
5868 Perl_ck_index(pTHX_ OP *o)
5869 {
5870     if (o->op_flags & OPf_KIDS) {
5871         OP *kid = cLISTOPo->op_first->op_sibling;       /* get past pushmark */
5872         if (kid)
5873             kid = kid->op_sibling;                      /* get past "big" */
5874         if (kid && kid->op_type == OP_CONST)
5875             fbm_compile(((SVOP*)kid)->op_sv, 0);
5876     }
5877     return ck_fun(o);
5878 }
5879
5880 OP *
5881 Perl_ck_lengthconst(pTHX_ OP *o)
5882 {
5883     /* XXX length optimization goes here */
5884     return ck_fun(o);
5885 }
5886
5887 OP *
5888 Perl_ck_lfun(pTHX_ OP *o)
5889 {
5890     const OPCODE type = o->op_type;
5891     return modkids(ck_fun(o), type);
5892 }
5893
5894 OP *
5895 Perl_ck_defined(pTHX_ OP *o)            /* 19990527 MJD */
5896 {
5897     if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
5898         switch (cUNOPo->op_first->op_type) {
5899         case OP_RV2AV:
5900             /* This is needed for
5901                if (defined %stash::)
5902                to work.   Do not break Tk.
5903                */
5904             break;                      /* Globals via GV can be undef */
5905         case OP_PADAV:
5906         case OP_AASSIGN:                /* Is this a good idea? */
5907             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5908                         "defined(@array) is deprecated");
5909             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5910                         "\t(Maybe you should just omit the defined()?)\n");
5911         break;
5912         case OP_RV2HV:
5913             /* This is needed for
5914                if (defined %stash::)
5915                to work.   Do not break Tk.
5916                */
5917             break;                      /* Globals via GV can be undef */
5918         case OP_PADHV:
5919             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5920                         "defined(%%hash) is deprecated");
5921             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5922                         "\t(Maybe you should just omit the defined()?)\n");
5923             break;
5924         default:
5925             /* no warning */
5926             break;
5927         }
5928     }
5929     return ck_rfun(o);
5930 }
5931
5932 OP *
5933 Perl_ck_rfun(pTHX_ OP *o)
5934 {
5935     const OPCODE type = o->op_type;
5936     return refkids(ck_fun(o), type);
5937 }
5938
5939 OP *
5940 Perl_ck_listiob(pTHX_ OP *o)
5941 {
5942     register OP *kid;
5943
5944     kid = cLISTOPo->op_first;
5945     if (!kid) {
5946         o = force_list(o);
5947         kid = cLISTOPo->op_first;
5948     }
5949     if (kid->op_type == OP_PUSHMARK)
5950         kid = kid->op_sibling;
5951     if (kid && o->op_flags & OPf_STACKED)
5952         kid = kid->op_sibling;
5953     else if (kid && !kid->op_sibling) {         /* print HANDLE; */
5954         if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
5955             o->op_flags |= OPf_STACKED; /* make it a filehandle */
5956             kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
5957             cLISTOPo->op_first->op_sibling = kid;
5958             cLISTOPo->op_last = kid;
5959             kid = kid->op_sibling;
5960         }
5961     }
5962
5963     if (!kid)
5964         append_elem(o->op_type, o, newDEFSVOP());
5965
5966     return listkids(o);
5967 }
5968
5969 OP *
5970 Perl_ck_say(pTHX_ OP *o)
5971 {
5972     o = ck_listiob(o);
5973     o->op_type = OP_PRINT;
5974     cLISTOPo->op_last = cLISTOPo->op_last->op_sibling
5975         = newSVOP(OP_CONST, 0, newSVpvn("\n", 1));
5976     return o;
5977 }
5978
5979 OP *
5980 Perl_ck_smartmatch(pTHX_ OP *o)
5981 {
5982     if (0 == (o->op_flags & OPf_SPECIAL)) {
5983         OP *first  = cBINOPo->op_first;
5984         OP *second = first->op_sibling;
5985
5986         /* Implicitly take a reference to an array or hash */
5987         first->op_sibling = Nullop;
5988         first = cBINOPo->op_first = ref_array_or_hash(first);
5989         second = first->op_sibling = ref_array_or_hash(second);
5990
5991         /* Implicitly take a reference to a regular expression */
5992         if (first->op_type == OP_MATCH) {
5993             first->op_type = OP_QR;
5994             first->op_ppaddr = PL_ppaddr[OP_QR];
5995         }
5996         if (second->op_type == OP_MATCH) {
5997             second->op_type = OP_QR;
5998             second->op_ppaddr = PL_ppaddr[OP_QR];
5999         }
6000     }
6001
6002     return o;
6003 }
6004
6005
6006 OP *
6007 Perl_ck_sassign(pTHX_ OP *o)
6008 {
6009     OP *kid = cLISTOPo->op_first;
6010     /* has a disposable target? */
6011     if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6012         && !(kid->op_flags & OPf_STACKED)
6013         /* Cannot steal the second time! */
6014         && !(kid->op_private & OPpTARGET_MY))
6015     {
6016         OP * const kkid = kid->op_sibling;
6017
6018         /* Can just relocate the target. */
6019         if (kkid && kkid->op_type == OP_PADSV
6020             && !(kkid->op_private & OPpLVAL_INTRO))
6021         {
6022             kid->op_targ = kkid->op_targ;
6023             kkid->op_targ = 0;
6024             /* Now we do not need PADSV and SASSIGN. */
6025             kid->op_sibling = o->op_sibling;    /* NULL */
6026             cLISTOPo->op_first = NULL;
6027             op_free(o);
6028             op_free(kkid);
6029             kid->op_private |= OPpTARGET_MY;    /* Used for context settings */
6030             return kid;
6031         }
6032     }
6033     return o;
6034 }
6035
6036 OP *
6037 Perl_ck_match(pTHX_ OP *o)
6038 {
6039     if (o->op_type != OP_QR && PL_compcv) {
6040         const I32 offset = pad_findmy("$_");
6041         if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS(offset) & SVpad_OUR)) {
6042             o->op_targ = offset;
6043             o->op_private |= OPpTARGET_MY;
6044         }
6045     }
6046     if (o->op_type == OP_MATCH || o->op_type == OP_QR)
6047         o->op_private |= OPpRUNTIME;
6048     return o;
6049 }
6050
6051 OP *
6052 Perl_ck_method(pTHX_ OP *o)
6053 {
6054     OP * const kid = cUNOPo->op_first;
6055     if (kid->op_type == OP_CONST) {
6056         SV* sv = kSVOP->op_sv;
6057         if (!(strchr(SvPVX_const(sv), ':') || strchr(SvPVX_const(sv), '\''))) {
6058             OP *cmop;
6059             if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6060                 sv = newSVpvn_share(SvPVX_const(sv), SvCUR(sv), 0);
6061             }
6062             else {
6063                 kSVOP->op_sv = Nullsv;
6064             }
6065             cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6066             op_free(o);
6067             return cmop;
6068         }
6069     }
6070     return o;
6071 }
6072
6073 OP *
6074 Perl_ck_null(pTHX_ OP *o)
6075 {
6076     return o;
6077 }
6078
6079 OP *
6080 Perl_ck_open(pTHX_ OP *o)
6081 {
6082     HV * const table = GvHV(PL_hintgv);
6083     if (table) {
6084         SV **svp = hv_fetch(table, "open_IN", 7, FALSE);
6085         if (svp && *svp) {
6086             const I32 mode = mode_from_discipline(*svp);
6087             if (mode & O_BINARY)
6088                 o->op_private |= OPpOPEN_IN_RAW;
6089             else if (mode & O_TEXT)
6090                 o->op_private |= OPpOPEN_IN_CRLF;
6091         }
6092
6093         svp = hv_fetch(table, "open_OUT", 8, FALSE);
6094         if (svp && *svp) {
6095             const I32 mode = mode_from_discipline(*svp);
6096             if (mode & O_BINARY)
6097                 o->op_private |= OPpOPEN_OUT_RAW;
6098             else if (mode & O_TEXT)
6099                 o->op_private |= OPpOPEN_OUT_CRLF;
6100         }
6101     }
6102     if (o->op_type == OP_BACKTICK)
6103         return o;
6104     {
6105          /* In case of three-arg dup open remove strictness
6106           * from the last arg if it is a bareword. */
6107          OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
6108          OP * const last  = cLISTOPx(o)->op_last;  /* The bareword. */
6109          OP *oa;
6110          const char *mode;
6111
6112          if ((last->op_type == OP_CONST) &&             /* The bareword. */
6113              (last->op_private & OPpCONST_BARE) &&
6114              (last->op_private & OPpCONST_STRICT) &&
6115              (oa = first->op_sibling) &&                /* The fh. */
6116              (oa = oa->op_sibling) &&                   /* The mode. */
6117              (oa->op_type == OP_CONST) &&
6118              SvPOK(((SVOP*)oa)->op_sv) &&
6119              (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
6120              mode[0] == '>' && mode[1] == '&' &&        /* A dup open. */
6121              (last == oa->op_sibling))                  /* The bareword. */
6122               last->op_private &= ~OPpCONST_STRICT;
6123     }
6124     return ck_fun(o);
6125 }
6126
6127 OP *
6128 Perl_ck_repeat(pTHX_ OP *o)
6129 {
6130     if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6131         o->op_private |= OPpREPEAT_DOLIST;
6132         cBINOPo->op_first = force_list(cBINOPo->op_first);
6133     }
6134     else
6135         scalar(o);
6136     return o;
6137 }
6138
6139 OP *
6140 Perl_ck_require(pTHX_ OP *o)
6141 {
6142     GV* gv = Nullgv;
6143
6144     if (o->op_flags & OPf_KIDS) {       /* Shall we supply missing .pm? */
6145         SVOP * const kid = (SVOP*)cUNOPo->op_first;
6146
6147         if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6148             SV * const sv = kid->op_sv;
6149             U32 was_readonly = SvREADONLY(sv);
6150             char *s;
6151
6152             if (was_readonly) {
6153                 if (SvFAKE(sv)) {
6154                     sv_force_normal_flags(sv, 0);
6155                     assert(!SvREADONLY(sv));
6156                     was_readonly = 0;
6157                 } else {
6158                     SvREADONLY_off(sv);
6159                 }
6160             }
6161
6162             for (s = SvPVX(sv); *s; s++) {
6163                 if (*s == ':' && s[1] == ':') {
6164                     const STRLEN len = strlen(s+2)+1;
6165                     *s = '/';
6166                     Move(s+2, s+1, len, char);
6167                     SvCUR_set(sv, SvCUR(sv) - 1);
6168                 }
6169             }
6170             sv_catpvn(sv, ".pm", 3);
6171             SvFLAGS(sv) |= was_readonly;
6172         }
6173     }
6174
6175     if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
6176         /* handle override, if any */
6177         gv = gv_fetchpv("require", 0, SVt_PVCV);
6178         if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
6179             GV * const * const gvp = (GV**)hv_fetch(PL_globalstash, "require", 7, FALSE);
6180             gv = gvp ? *gvp : Nullgv;
6181         }
6182     }
6183
6184     if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6185         OP * const kid = cUNOPo->op_first;
6186         cUNOPo->op_first = 0;
6187         op_free(o);
6188         return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
6189                                append_elem(OP_LIST, kid,
6190                                            scalar(newUNOP(OP_RV2CV, 0,
6191                                                           newGVOP(OP_GV, 0,
6192                                                                   gv))))));
6193     }
6194
6195     return ck_fun(o);
6196 }
6197
6198 OP *
6199 Perl_ck_return(pTHX_ OP *o)
6200 {
6201     if (CvLVALUE(PL_compcv)) {
6202         OP *kid;
6203         for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
6204             mod(kid, OP_LEAVESUBLV);
6205     }
6206     return o;
6207 }
6208
6209 OP *
6210 Perl_ck_select(pTHX_ OP *o)
6211 {
6212     dVAR;
6213     OP* kid;
6214     if (o->op_flags & OPf_KIDS) {
6215         kid = cLISTOPo->op_first->op_sibling;   /* get past pushmark */
6216         if (kid && kid->op_sibling) {
6217             o->op_type = OP_SSELECT;
6218             o->op_ppaddr = PL_ppaddr[OP_SSELECT];
6219             o = ck_fun(o);
6220             return fold_constants(o);
6221         }
6222     }
6223     o = ck_fun(o);
6224     kid = cLISTOPo->op_first->op_sibling;    /* get past pushmark */
6225     if (kid && kid->op_type == OP_RV2GV)
6226         kid->op_private &= ~HINT_STRICT_REFS;
6227     return o;
6228 }
6229
6230 OP *
6231 Perl_ck_shift(pTHX_ OP *o)
6232 {
6233     const I32 type = o->op_type;
6234
6235     if (!(o->op_flags & OPf_KIDS)) {
6236         OP *argop;
6237
6238         op_free(o);
6239         argop = newUNOP(OP_RV2AV, 0,
6240             scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
6241         return newUNOP(type, 0, scalar(argop));
6242     }
6243     return scalar(modkids(ck_fun(o), type));
6244 }
6245
6246 OP *
6247 Perl_ck_sort(pTHX_ OP *o)
6248 {
6249     OP *firstkid;
6250
6251     if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0)
6252     {
6253         HV *hinthv = GvHV(PL_hintgv);
6254         if (hinthv) {
6255             SV **svp = hv_fetch(hinthv, "sort", 4, 0);
6256             if (svp) {
6257                 I32 sorthints = (I32)SvIV(*svp);
6258                 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
6259                     o->op_private |= OPpSORT_QSORT;
6260                 if ((sorthints & HINT_SORT_STABLE) != 0)
6261                     o->op_private |= OPpSORT_STABLE;
6262             }
6263         }
6264     }
6265
6266     if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6267         simplify_sort(o);
6268     firstkid = cLISTOPo->op_first->op_sibling;          /* get past pushmark */
6269     if (o->op_flags & OPf_STACKED) {                    /* may have been cleared */
6270         OP *k = NULL;
6271         OP *kid = cUNOPx(firstkid)->op_first;           /* get past null */
6272
6273         if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
6274             linklist(kid);
6275             if (kid->op_type == OP_SCOPE) {
6276                 k = kid->op_next;
6277                 kid->op_next = 0;
6278             }
6279             else if (kid->op_type == OP_LEAVE) {
6280                 if (o->op_type == OP_SORT) {
6281                     op_null(kid);                       /* wipe out leave */
6282                     kid->op_next = kid;
6283
6284                     for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6285                         if (k->op_next == kid)
6286                             k->op_next = 0;
6287                         /* don't descend into loops */
6288                         else if (k->op_type == OP_ENTERLOOP
6289                                  || k->op_type == OP_ENTERITER)
6290                         {
6291                             k = cLOOPx(k)->op_lastop;
6292                         }
6293                     }
6294                 }
6295                 else
6296                     kid->op_next = 0;           /* just disconnect the leave */
6297                 k = kLISTOP->op_first;
6298             }
6299             CALL_PEEP(k);
6300
6301             kid = firstkid;
6302             if (o->op_type == OP_SORT) {
6303                 /* provide scalar context for comparison function/block */
6304                 kid = scalar(kid);
6305                 kid->op_next = kid;
6306             }
6307             else
6308                 kid->op_next = k;
6309             o->op_flags |= OPf_SPECIAL;
6310         }
6311         else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6312             op_null(firstkid);
6313
6314         firstkid = firstkid->op_sibling;
6315     }
6316
6317     /* provide list context for arguments */
6318     if (o->op_type == OP_SORT)
6319         list(firstkid);
6320
6321     return o;
6322 }
6323
6324 STATIC void
6325 S_simplify_sort(pTHX_ OP *o)
6326 {
6327     register OP *kid = cLISTOPo->op_first->op_sibling;  /* get past pushmark */
6328     OP *k;
6329     int descending;
6330     GV *gv;
6331     const char *gvname;
6332     if (!(o->op_flags & OPf_STACKED))
6333         return;
6334     GvMULTI_on(gv_fetchpv("a", GV_ADD, SVt_PV));
6335     GvMULTI_on(gv_fetchpv("b", GV_ADD, SVt_PV));
6336     kid = kUNOP->op_first;                              /* get past null */
6337     if (kid->op_type != OP_SCOPE)
6338         return;
6339     kid = kLISTOP->op_last;                             /* get past scope */
6340     switch(kid->op_type) {
6341         case OP_NCMP:
6342         case OP_I_NCMP:
6343         case OP_SCMP:
6344             break;
6345         default:
6346             return;
6347     }
6348     k = kid;                                            /* remember this node*/
6349     if (kBINOP->op_first->op_type != OP_RV2SV)
6350         return;
6351     kid = kBINOP->op_first;                             /* get past cmp */
6352     if (kUNOP->op_first->op_type != OP_GV)
6353         return;
6354     kid = kUNOP->op_first;                              /* get past rv2sv */
6355     gv = kGVOP_gv;
6356     if (GvSTASH(gv) != PL_curstash)
6357         return;
6358     gvname = GvNAME(gv);
6359     if (*gvname == 'a' && gvname[1] == '\0')
6360         descending = 0;
6361     else if (*gvname == 'b' && gvname[1] == '\0')
6362         descending = 1;
6363     else
6364         return;
6365
6366     kid = k;                                            /* back to cmp */
6367     if (kBINOP->op_last->op_type != OP_RV2SV)
6368         return;
6369     kid = kBINOP->op_last;                              /* down to 2nd arg */
6370     if (kUNOP->op_first->op_type != OP_GV)
6371         return;
6372     kid = kUNOP->op_first;                              /* get past rv2sv */
6373     gv = kGVOP_gv;
6374     if (GvSTASH(gv) != PL_curstash)
6375         return;
6376     gvname = GvNAME(gv);
6377     if ( descending
6378          ? !(*gvname == 'a' && gvname[1] == '\0')
6379          : !(*gvname == 'b' && gvname[1] == '\0'))
6380         return;
6381     o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6382     if (descending)
6383         o->op_private |= OPpSORT_DESCEND;
6384     if (k->op_type == OP_NCMP)
6385         o->op_private |= OPpSORT_NUMERIC;
6386     if (k->op_type == OP_I_NCMP)
6387         o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6388     kid = cLISTOPo->op_first->op_sibling;
6389     cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6390     op_free(kid);                                     /* then delete it */
6391 }
6392
6393 OP *
6394 Perl_ck_split(pTHX_ OP *o)
6395 {
6396     dVAR;
6397     register OP *kid;
6398
6399     if (o->op_flags & OPf_STACKED)
6400         return no_fh_allowed(o);
6401
6402     kid = cLISTOPo->op_first;
6403     if (kid->op_type != OP_NULL)
6404         Perl_croak(aTHX_ "panic: ck_split");
6405     kid = kid->op_sibling;
6406     op_free(cLISTOPo->op_first);
6407     cLISTOPo->op_first = kid;
6408     if (!kid) {
6409         cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
6410         cLISTOPo->op_last = kid; /* There was only one element previously */
6411     }
6412
6413     if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6414         OP * const sibl = kid->op_sibling;
6415         kid->op_sibling = 0;
6416         kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
6417         if (cLISTOPo->op_first == cLISTOPo->op_last)
6418             cLISTOPo->op_last = kid;
6419         cLISTOPo->op_first = kid;
6420         kid->op_sibling = sibl;
6421     }
6422
6423     kid->op_type = OP_PUSHRE;
6424     kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6425     scalar(kid);
6426     if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL && ckWARN(WARN_REGEXP)) {
6427       Perl_warner(aTHX_ packWARN(WARN_REGEXP),
6428                   "Use of /g modifier is meaningless in split");
6429     }
6430
6431     if (!kid->op_sibling)
6432         append_elem(OP_SPLIT, o, newDEFSVOP());
6433
6434     kid = kid->op_sibling;
6435     scalar(kid);
6436
6437     if (!kid->op_sibling)
6438         append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6439
6440     kid = kid->op_sibling;
6441     scalar(kid);
6442
6443     if (kid->op_sibling)
6444         return too_many_arguments(o,OP_DESC(o));
6445
6446     return o;
6447 }
6448
6449 OP *
6450 Perl_ck_join(pTHX_ OP *o)
6451 {
6452     const OP * const kid = cLISTOPo->op_first->op_sibling;
6453     if (kid && kid->op_type == OP_MATCH) {
6454         if (ckWARN(WARN_SYNTAX)) {
6455             const REGEXP *re = PM_GETRE(kPMOP);
6456             const char *pmstr = re ? re->precomp : "STRING";
6457             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6458                         "/%s/ should probably be written as \"%s\"",
6459                         pmstr, pmstr);
6460         }
6461     }
6462     return ck_fun(o);
6463 }
6464
6465 OP *
6466 Perl_ck_subr(pTHX_ OP *o)
6467 {
6468     OP *prev = ((cUNOPo->op_first->op_sibling)
6469              ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6470     OP *o2 = prev->op_sibling;
6471     OP *cvop;
6472     char *proto = NULL;
6473     CV *cv = NULL;
6474     GV *namegv = NULL;
6475     int optional = 0;
6476     I32 arg = 0;
6477     I32 contextclass = 0;
6478     char *e = NULL;
6479     bool delete_op = 0;
6480
6481     o->op_private |= OPpENTERSUB_HASTARG;
6482     for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6483     if (cvop->op_type == OP_RV2CV) {
6484         SVOP* tmpop;
6485         o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6486         op_null(cvop);          /* disable rv2cv */
6487         tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6488         if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6489             GV *gv = cGVOPx_gv(tmpop);
6490             cv = GvCVu(gv);
6491             if (!cv)
6492                 tmpop->op_private |= OPpEARLY_CV;
6493             else {
6494                 if (SvPOK(cv)) {
6495                     namegv = CvANON(cv) ? gv : CvGV(cv);
6496                     proto = SvPV_nolen((SV*)cv);
6497                 }
6498                 if (CvASSERTION(cv)) {
6499                     if (PL_hints & HINT_ASSERTING) {
6500                         if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
6501                             o->op_private |= OPpENTERSUB_DB;
6502                     }
6503                     else {
6504                         delete_op = 1;
6505                         if (!(PL_hints & HINT_ASSERTIONSSEEN) && ckWARN(WARN_ASSERTIONS)) {
6506                             Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
6507                                         "Impossible to activate assertion call");
6508                         }
6509                     }
6510                 }
6511             }
6512         }
6513     }
6514     else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6515         if (o2->op_type == OP_CONST)
6516             o2->op_private &= ~OPpCONST_STRICT;
6517         else if (o2->op_type == OP_LIST) {
6518             OP * const o = ((UNOP*)o2)->op_first->op_sibling;
6519             if (o && o->op_type == OP_CONST)
6520                 o->op_private &= ~OPpCONST_STRICT;
6521         }
6522     }
6523     o->op_private |= (PL_hints & HINT_STRICT_REFS);
6524     if (PERLDB_SUB && PL_curstash != PL_debstash)
6525         o->op_private |= OPpENTERSUB_DB;
6526     while (o2 != cvop) {
6527         if (proto) {
6528             switch (*proto) {
6529             case '\0':
6530                 return too_many_arguments(o, gv_ename(namegv));
6531             case ';':
6532                 optional = 1;
6533                 proto++;
6534                 continue;
6535             case '$':
6536                 proto++;
6537                 arg++;
6538                 scalar(o2);
6539                 break;
6540             case '%':
6541             case '@':
6542                 list(o2);
6543                 arg++;
6544                 break;
6545             case '&':
6546                 proto++;
6547                 arg++;
6548                 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6549                     bad_type(arg,
6550                         arg == 1 ? "block or sub {}" : "sub {}",
6551                         gv_ename(namegv), o2);
6552                 break;
6553             case '*':
6554                 /* '*' allows any scalar type, including bareword */
6555                 proto++;
6556                 arg++;
6557                 if (o2->op_type == OP_RV2GV)
6558                     goto wrapref;       /* autoconvert GLOB -> GLOBref */
6559                 else if (o2->op_type == OP_CONST)
6560                     o2->op_private &= ~OPpCONST_STRICT;
6561                 else if (o2->op_type == OP_ENTERSUB) {
6562                     /* accidental subroutine, revert to bareword */
6563                     OP *gvop = ((UNOP*)o2)->op_first;
6564                     if (gvop && gvop->op_type == OP_NULL) {
6565                         gvop = ((UNOP*)gvop)->op_first;
6566                         if (gvop) {
6567                             for (; gvop->op_sibling; gvop = gvop->op_sibling)
6568                                 ;
6569                             if (gvop &&
6570                                 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6571                                 (gvop = ((UNOP*)gvop)->op_first) &&
6572                                 gvop->op_type == OP_GV)
6573                             {
6574                                 GV * const gv = cGVOPx_gv(gvop);
6575                                 OP * const sibling = o2->op_sibling;
6576                                 SV * const n = newSVpvn("",0);
6577                                 op_free(o2);
6578                                 gv_fullname4(n, gv, "", FALSE);
6579                                 o2 = newSVOP(OP_CONST, 0, n);
6580                                 prev->op_sibling = o2;
6581                                 o2->op_sibling = sibling;
6582                             }
6583                         }
6584                     }
6585                 }
6586                 scalar(o2);
6587                 break;
6588             case '[': case ']':
6589                  goto oops;
6590                  break;
6591             case '\\':
6592                 proto++;
6593                 arg++;
6594             again:
6595                 switch (*proto++) {
6596                 case '[':
6597                      if (contextclass++ == 0) {
6598                           e = strchr(proto, ']');
6599                           if (!e || e == proto)
6600                                goto oops;
6601                      }
6602                      else
6603                           goto oops;
6604                      goto again;
6605                      break;
6606                 case ']':
6607                      if (contextclass) {
6608                          /* XXX We shouldn't be modifying proto, so we can const proto */
6609                          char *p = proto;
6610                          const char s = *p;
6611                          contextclass = 0;
6612                          *p = '\0';
6613                          while (*--p != '[');
6614                          bad_type(arg, Perl_form(aTHX_ "one of %s", p),
6615                                  gv_ename(namegv), o2);
6616                          *proto = s;
6617                      } else
6618                           goto oops;
6619                      break;
6620                 case '*':
6621                      if (o2->op_type == OP_RV2GV)
6622                           goto wrapref;
6623                      if (!contextclass)
6624                           bad_type(arg, "symbol", gv_ename(namegv), o2);
6625                      break;
6626                 case '&':
6627                      if (o2->op_type == OP_ENTERSUB)
6628                           goto wrapref;
6629                      if (!contextclass)
6630                           bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6631                      break;
6632                 case '$':
6633                     if (o2->op_type == OP_RV2SV ||
6634                         o2->op_type == OP_PADSV ||
6635                         o2->op_type == OP_HELEM ||
6636                         o2->op_type == OP_AELEM ||
6637                         o2->op_type == OP_THREADSV)
6638                          goto wrapref;
6639                     if (!contextclass)
6640                         bad_type(arg, "scalar", gv_ename(namegv), o2);
6641                      break;
6642                 case '@':
6643                     if (o2->op_type == OP_RV2AV ||
6644                         o2->op_type == OP_PADAV)
6645                          goto wrapref;
6646                     if (!contextclass)
6647                         bad_type(arg, "array", gv_ename(namegv), o2);
6648                     break;
6649                 case '%':
6650                     if (o2->op_type == OP_RV2HV ||
6651                         o2->op_type == OP_PADHV)
6652                          goto wrapref;
6653                     if (!contextclass)
6654                          bad_type(arg, "hash", gv_ename(namegv), o2);
6655                     break;
6656                 wrapref:
6657                     {
6658                         OP* const kid = o2;
6659                         OP* const sib = kid->op_sibling;
6660                         kid->op_sibling = 0;
6661                         o2 = newUNOP(OP_REFGEN, 0, kid);
6662                         o2->op_sibling = sib;
6663                         prev->op_sibling = o2;
6664                     }
6665                     if (contextclass && e) {
6666                          proto = e + 1;
6667                          contextclass = 0;
6668                     }
6669                     break;
6670                 default: goto oops;
6671                 }
6672                 if (contextclass)
6673                      goto again;
6674                 break;
6675             case ' ':
6676                 proto++;
6677                 continue;
6678             default:
6679               oops:
6680                 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
6681                            gv_ename(namegv), cv);
6682             }
6683         }
6684         else
6685             list(o2);
6686         mod(o2, OP_ENTERSUB);
6687         prev = o2;
6688         o2 = o2->op_sibling;
6689     } /* while */
6690     if (proto && !optional &&
6691           (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6692         return too_few_arguments(o, gv_ename(namegv));
6693     if(delete_op) {
6694         op_free(o);
6695         o=newSVOP(OP_CONST, 0, newSViv(0));
6696     }
6697     return o;
6698 }
6699
6700 OP *
6701 Perl_ck_svconst(pTHX_ OP *o)
6702 {
6703     SvREADONLY_on(cSVOPo->op_sv);
6704     return o;
6705 }
6706
6707 OP *
6708 Perl_ck_trunc(pTHX_ OP *o)
6709 {
6710     if (o->op_flags & OPf_KIDS) {
6711         SVOP *kid = (SVOP*)cUNOPo->op_first;
6712
6713         if (kid->op_type == OP_NULL)
6714             kid = (SVOP*)kid->op_sibling;
6715         if (kid && kid->op_type == OP_CONST &&
6716             (kid->op_private & OPpCONST_BARE))
6717         {
6718             o->op_flags |= OPf_SPECIAL;
6719             kid->op_private &= ~OPpCONST_STRICT;
6720         }
6721     }
6722     return ck_fun(o);
6723 }
6724
6725 OP *
6726 Perl_ck_unpack(pTHX_ OP *o)
6727 {
6728     OP *kid = cLISTOPo->op_first;
6729     if (kid->op_sibling) {
6730         kid = kid->op_sibling;
6731         if (!kid->op_sibling)
6732             kid->op_sibling = newDEFSVOP();
6733     }
6734     return ck_fun(o);
6735 }
6736
6737 OP *
6738 Perl_ck_substr(pTHX_ OP *o)
6739 {
6740     o = ck_fun(o);
6741     if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6742         OP *kid = cLISTOPo->op_first;
6743
6744         if (kid->op_type == OP_NULL)
6745             kid = kid->op_sibling;
6746         if (kid)
6747             kid->op_flags |= OPf_MOD;
6748
6749     }
6750     return o;
6751 }
6752
6753 /* A peephole optimizer.  We visit the ops in the order they're to execute.
6754  * See the comments at the top of this file for more details about when
6755  * peep() is called */
6756
6757 void
6758 Perl_peep(pTHX_ register OP *o)
6759 {
6760     dVAR;
6761     register OP* oldop = NULL;
6762
6763     if (!o || o->op_opt)
6764         return;
6765     ENTER;
6766     SAVEOP();
6767     SAVEVPTR(PL_curcop);
6768     for (; o; o = o->op_next) {
6769         if (o->op_opt)
6770             break;
6771         PL_op = o;
6772         switch (o->op_type) {
6773         case OP_SETSTATE:
6774         case OP_NEXTSTATE:
6775         case OP_DBSTATE:
6776             PL_curcop = ((COP*)o);              /* for warnings */
6777             o->op_opt = 1;
6778             break;
6779
6780         case OP_CONST:
6781             if (cSVOPo->op_private & OPpCONST_STRICT)
6782                 no_bareword_allowed(o);
6783 #ifdef USE_ITHREADS
6784         case OP_METHOD_NAMED:
6785             /* Relocate sv to the pad for thread safety.
6786              * Despite being a "constant", the SV is written to,
6787              * for reference counts, sv_upgrade() etc. */
6788             if (cSVOP->op_sv) {
6789                 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6790                 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
6791                     /* If op_sv is already a PADTMP then it is being used by
6792                      * some pad, so make a copy. */
6793                     sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
6794                     SvREADONLY_on(PAD_SVl(ix));
6795                     SvREFCNT_dec(cSVOPo->op_sv);
6796                 }
6797                 else {
6798                     SvREFCNT_dec(PAD_SVl(ix));
6799                     SvPADTMP_on(cSVOPo->op_sv);
6800                     PAD_SETSV(ix, cSVOPo->op_sv);
6801                     /* XXX I don't know how this isn't readonly already. */
6802                     SvREADONLY_on(PAD_SVl(ix));
6803                 }
6804                 cSVOPo->op_sv = Nullsv;
6805                 o->op_targ = ix;
6806             }
6807 #endif
6808             o->op_opt = 1;
6809             break;
6810
6811         case OP_CONCAT:
6812             if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6813                 if (o->op_next->op_private & OPpTARGET_MY) {
6814                     if (o->op_flags & OPf_STACKED) /* chained concats */
6815                         goto ignore_optimization;
6816                     else {
6817                         /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6818                         o->op_targ = o->op_next->op_targ;
6819                         o->op_next->op_targ = 0;
6820                         o->op_private |= OPpTARGET_MY;
6821                     }
6822                 }
6823                 op_null(o->op_next);
6824             }
6825           ignore_optimization:
6826             o->op_opt = 1;
6827             break;
6828         case OP_STUB:
6829             if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6830                 o->op_opt = 1;
6831                 break; /* Scalar stub must produce undef.  List stub is noop */
6832             }
6833             goto nothin;
6834         case OP_NULL:
6835             if (o->op_targ == OP_NEXTSTATE
6836                 || o->op_targ == OP_DBSTATE
6837                 || o->op_targ == OP_SETSTATE)
6838             {
6839                 PL_curcop = ((COP*)o);
6840             }
6841             /* XXX: We avoid setting op_seq here to prevent later calls
6842                to peep() from mistakenly concluding that optimisation
6843                has already occurred. This doesn't fix the real problem,
6844                though (See 20010220.007). AMS 20010719 */
6845             /* op_seq functionality is now replaced by op_opt */
6846             if (oldop && o->op_next) {
6847                 oldop->op_next = o->op_next;
6848                 continue;
6849             }
6850             break;
6851         case OP_SCALAR:
6852         case OP_LINESEQ:
6853         case OP_SCOPE:
6854           nothin:
6855             if (oldop && o->op_next) {
6856                 oldop->op_next = o->op_next;
6857                 continue;
6858             }
6859             o->op_opt = 1;
6860             break;
6861
6862         case OP_PADAV:
6863         case OP_GV:
6864             if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
6865                 OP* const pop = (o->op_type == OP_PADAV) ?
6866                             o->op_next : o->op_next->op_next;
6867                 IV i;
6868                 if (pop && pop->op_type == OP_CONST &&
6869                     ((PL_op = pop->op_next)) &&
6870                     pop->op_next->op_type == OP_AELEM &&
6871                     !(pop->op_next->op_private &
6872                       (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6873                     (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
6874                                 <= 255 &&
6875                     i >= 0)
6876                 {
6877                     GV *gv;
6878                     if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
6879                         no_bareword_allowed(pop);
6880                     if (o->op_type == OP_GV)
6881                         op_null(o->op_next);
6882                     op_null(pop->op_next);
6883                     op_null(pop);
6884                     o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6885                     o->op_next = pop->op_next->op_next;
6886                     o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6887                     o->op_private = (U8)i;
6888                     if (o->op_type == OP_GV) {
6889                         gv = cGVOPo_gv;
6890                         GvAVn(gv);
6891                     }
6892                     else
6893                         o->op_flags |= OPf_SPECIAL;
6894                     o->op_type = OP_AELEMFAST;
6895                 }
6896                 o->op_opt = 1;
6897                 break;
6898             }
6899
6900             if (o->op_next->op_type == OP_RV2SV) {
6901                 if (!(o->op_next->op_private & OPpDEREF)) {
6902                     op_null(o->op_next);
6903                     o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6904                                                                | OPpOUR_INTRO);
6905                     o->op_next = o->op_next->op_next;
6906                     o->op_type = OP_GVSV;
6907                     o->op_ppaddr = PL_ppaddr[OP_GVSV];
6908                 }
6909             }
6910             else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6911                 GV * const gv = cGVOPo_gv;
6912                 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
6913                     /* XXX could check prototype here instead of just carping */
6914                     SV * const sv = sv_newmortal();
6915                     gv_efullname3(sv, gv, Nullch);
6916                     Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
6917                                 "%"SVf"() called too early to check prototype",
6918                                 sv);
6919                 }
6920             }
6921             else if (o->op_next->op_type == OP_READLINE
6922                     && o->op_next->op_next->op_type == OP_CONCAT
6923                     && (o->op_next->op_next->op_flags & OPf_STACKED))
6924             {
6925                 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
6926                 o->op_type   = OP_RCATLINE;
6927                 o->op_flags |= OPf_STACKED;
6928                 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
6929                 op_null(o->op_next->op_next);
6930                 op_null(o->op_next);
6931             }
6932
6933             o->op_opt = 1;
6934             break;
6935
6936         case OP_MAPWHILE:
6937         case OP_GREPWHILE:
6938         case OP_AND:
6939         case OP_OR:
6940         case OP_DOR:
6941         case OP_ANDASSIGN:
6942         case OP_ORASSIGN:
6943         case OP_DORASSIGN:
6944         case OP_COND_EXPR:
6945         case OP_RANGE:
6946             o->op_opt = 1;
6947             while (cLOGOP->op_other->op_type == OP_NULL)
6948                 cLOGOP->op_other = cLOGOP->op_other->op_next;
6949             peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
6950             break;
6951
6952         case OP_ENTERLOOP:
6953         case OP_ENTERITER:
6954             o->op_opt = 1;
6955             while (cLOOP->op_redoop->op_type == OP_NULL)
6956                 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6957             peep(cLOOP->op_redoop);
6958             while (cLOOP->op_nextop->op_type == OP_NULL)
6959                 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6960             peep(cLOOP->op_nextop);
6961             while (cLOOP->op_lastop->op_type == OP_NULL)
6962                 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6963             peep(cLOOP->op_lastop);
6964             break;
6965
6966         case OP_QR:
6967         case OP_MATCH:
6968         case OP_SUBST:
6969             o->op_opt = 1;
6970             while (cPMOP->op_pmreplstart &&
6971                    cPMOP->op_pmreplstart->op_type == OP_NULL)
6972                 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6973             peep(cPMOP->op_pmreplstart);
6974             break;
6975
6976         case OP_EXEC:
6977             o->op_opt = 1;
6978             if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
6979                 && ckWARN(WARN_SYNTAX))
6980             {
6981                 if (o->op_next->op_sibling &&
6982                         o->op_next->op_sibling->op_type != OP_EXIT &&
6983                         o->op_next->op_sibling->op_type != OP_WARN &&
6984                         o->op_next->op_sibling->op_type != OP_DIE) {
6985                     const line_t oldline = CopLINE(PL_curcop);
6986
6987                     CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6988                     Perl_warner(aTHX_ packWARN(WARN_EXEC),
6989                                 "Statement unlikely to be reached");
6990                     Perl_warner(aTHX_ packWARN(WARN_EXEC),
6991                                 "\t(Maybe you meant system() when you said exec()?)\n");
6992                     CopLINE_set(PL_curcop, oldline);
6993                 }
6994             }
6995             break;
6996
6997         case OP_HELEM: {
6998             UNOP *rop;
6999             SV *lexname;
7000             GV **fields;
7001             SV **svp, *sv;
7002             const char *key = NULL;
7003             STRLEN keylen;
7004
7005             o->op_opt = 1;
7006
7007             if (((BINOP*)o)->op_last->op_type != OP_CONST)
7008                 break;
7009
7010             /* Make the CONST have a shared SV */
7011             svp = cSVOPx_svp(((BINOP*)o)->op_last);
7012             if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
7013                 key = SvPV_const(sv, keylen);
7014                 lexname = newSVpvn_share(key,
7015                                          SvUTF8(sv) ? -(I32)keylen : keylen,
7016                                          0);
7017                 SvREFCNT_dec(sv);
7018                 *svp = lexname;
7019             }
7020
7021             if ((o->op_private & (OPpLVAL_INTRO)))
7022                 break;
7023
7024             rop = (UNOP*)((BINOP*)o)->op_first;
7025             if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
7026                 break;
7027             lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
7028             if (!(SvFLAGS(lexname) & SVpad_TYPED))
7029                 break;
7030             fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
7031             if (!fields || !GvHV(*fields))
7032                 break;
7033             key = SvPV_const(*svp, keylen);
7034             if (!hv_fetch(GvHV(*fields), key,
7035                         SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
7036             {
7037                 Perl_croak(aTHX_ "No such class field \"%s\" "
7038                            "in variable %s of type %s",
7039                       key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
7040             }
7041
7042             break;
7043         }
7044
7045         case OP_HSLICE: {
7046             UNOP *rop;
7047             SV *lexname;
7048             GV **fields;
7049             SV **svp;
7050             const char *key;
7051             STRLEN keylen;
7052             SVOP *first_key_op, *key_op;
7053
7054             if ((o->op_private & (OPpLVAL_INTRO))
7055                 /* I bet there's always a pushmark... */
7056                 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
7057                 /* hmmm, no optimization if list contains only one key. */
7058                 break;
7059             rop = (UNOP*)((LISTOP*)o)->op_last;
7060             if (rop->op_type != OP_RV2HV)
7061                 break;
7062             if (rop->op_first->op_type == OP_PADSV)
7063                 /* @$hash{qw(keys here)} */
7064                 rop = (UNOP*)rop->op_first;
7065             else {
7066                 /* @{$hash}{qw(keys here)} */
7067                 if (rop->op_first->op_type == OP_SCOPE
7068                     && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
7069                 {
7070                     rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
7071                 }
7072                 else
7073                     break;
7074             }
7075
7076             lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
7077             if (!(SvFLAGS(lexname) & SVpad_TYPED))
7078                 break;
7079             fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
7080             if (!fields || !GvHV(*fields))
7081                 break;
7082             /* Again guessing that the pushmark can be jumped over.... */
7083             first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
7084                 ->op_first->op_sibling;
7085             for (key_op = first_key_op; key_op;
7086                  key_op = (SVOP*)key_op->op_sibling) {
7087                 if (key_op->op_type != OP_CONST)
7088                     continue;
7089                 svp = cSVOPx_svp(key_op);
7090                 key = SvPV_const(*svp, keylen);
7091                 if (!hv_fetch(GvHV(*fields), key,
7092                             SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
7093                 {
7094                     Perl_croak(aTHX_ "No such class field \"%s\" "
7095                                "in variable %s of type %s",
7096                           key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
7097                 }
7098             }
7099             break;
7100         }
7101
7102         case OP_SORT: {
7103             /* will point to RV2AV or PADAV op on LHS/RHS of assign */
7104             OP *oleft;
7105             OP *o2;
7106
7107             /* check that RHS of sort is a single plain array */
7108             OP *oright = cUNOPo->op_first;
7109             if (!oright || oright->op_type != OP_PUSHMARK)
7110                 break;
7111
7112             /* reverse sort ... can be optimised.  */
7113             if (!cUNOPo->op_sibling) {
7114                 /* Nothing follows us on the list. */
7115                 OP * const reverse = o->op_next;
7116
7117                 if (reverse->op_type == OP_REVERSE &&
7118                     (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
7119                     OP * const pushmark = cUNOPx(reverse)->op_first;
7120                     if (pushmark && (pushmark->op_type == OP_PUSHMARK)
7121                         && (cUNOPx(pushmark)->op_sibling == o)) {
7122                         /* reverse -> pushmark -> sort */
7123                         o->op_private |= OPpSORT_REVERSE;
7124                         op_null(reverse);
7125                         pushmark->op_next = oright->op_next;
7126                         op_null(oright);
7127                     }
7128                 }
7129             }
7130
7131             /* make @a = sort @a act in-place */
7132
7133             o->op_opt = 1;
7134
7135             oright = cUNOPx(oright)->op_sibling;
7136             if (!oright)
7137                 break;
7138             if (oright->op_type == OP_NULL) { /* skip sort block/sub */
7139                 oright = cUNOPx(oright)->op_sibling;
7140             }
7141
7142             if (!oright ||
7143                 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
7144                 || oright->op_next != o
7145                 || (oright->op_private & OPpLVAL_INTRO)
7146             )
7147                 break;
7148
7149             /* o2 follows the chain of op_nexts through the LHS of the
7150              * assign (if any) to the aassign op itself */
7151             o2 = o->op_next;
7152             if (!o2 || o2->op_type != OP_NULL)
7153                 break;
7154             o2 = o2->op_next;
7155             if (!o2 || o2->op_type != OP_PUSHMARK)
7156                 break;
7157             o2 = o2->op_next;
7158             if (o2 && o2->op_type == OP_GV)
7159                 o2 = o2->op_next;
7160             if (!o2
7161                 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
7162                 || (o2->op_private & OPpLVAL_INTRO)
7163             )
7164                 break;
7165             oleft = o2;
7166             o2 = o2->op_next;
7167             if (!o2 || o2->op_type != OP_NULL)
7168                 break;
7169             o2 = o2->op_next;
7170             if (!o2 || o2->op_type != OP_AASSIGN
7171                     || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
7172                 break;
7173
7174             /* check that the sort is the first arg on RHS of assign */
7175
7176             o2 = cUNOPx(o2)->op_first;
7177             if (!o2 || o2->op_type != OP_NULL)
7178                 break;
7179             o2 = cUNOPx(o2)->op_first;
7180             if (!o2 || o2->op_type != OP_PUSHMARK)
7181                 break;
7182             if (o2->op_sibling != o)
7183                 break;
7184
7185             /* check the array is the same on both sides */
7186             if (oleft->op_type == OP_RV2AV) {
7187                 if (oright->op_type != OP_RV2AV
7188                     || !cUNOPx(oright)->op_first
7189                     || cUNOPx(oright)->op_first->op_type != OP_GV
7190                     ||  cGVOPx_gv(cUNOPx(oleft)->op_first) !=
7191                         cGVOPx_gv(cUNOPx(oright)->op_first)
7192                 )
7193                     break;
7194             }
7195             else if (oright->op_type != OP_PADAV
7196                 || oright->op_targ != oleft->op_targ
7197             )
7198                 break;
7199
7200             /* transfer MODishness etc from LHS arg to RHS arg */
7201             oright->op_flags = oleft->op_flags;
7202             o->op_private |= OPpSORT_INPLACE;
7203
7204             /* excise push->gv->rv2av->null->aassign */
7205             o2 = o->op_next->op_next;
7206             op_null(o2); /* PUSHMARK */
7207             o2 = o2->op_next;
7208             if (o2->op_type == OP_GV) {
7209                 op_null(o2); /* GV */
7210                 o2 = o2->op_next;
7211             }
7212             op_null(o2); /* RV2AV or PADAV */
7213             o2 = o2->op_next->op_next;
7214             op_null(o2); /* AASSIGN */
7215
7216             o->op_next = o2->op_next;
7217
7218             break;
7219         }
7220
7221         case OP_REVERSE: {
7222             OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
7223             OP *gvop = NULL;
7224             LISTOP *enter, *exlist;
7225             o->op_opt = 1;
7226
7227             enter = (LISTOP *) o->op_next;
7228             if (!enter)
7229                 break;
7230             if (enter->op_type == OP_NULL) {
7231                 enter = (LISTOP *) enter->op_next;
7232                 if (!enter)
7233                     break;
7234             }
7235             /* for $a (...) will have OP_GV then OP_RV2GV here.
7236                for (...) just has an OP_GV.  */
7237             if (enter->op_type == OP_GV) {
7238                 gvop = (OP *) enter;
7239                 enter = (LISTOP *) enter->op_next;
7240                 if (!enter)
7241                     break;
7242                 if (enter->op_type == OP_RV2GV) {
7243                   enter = (LISTOP *) enter->op_next;
7244                   if (!enter)
7245                     break;
7246                 }
7247             }
7248
7249             if (enter->op_type != OP_ENTERITER)
7250                 break;
7251
7252             iter = enter->op_next;
7253             if (!iter || iter->op_type != OP_ITER)
7254                 break;
7255
7256             expushmark = enter->op_first;
7257             if (!expushmark || expushmark->op_type != OP_NULL
7258                 || expushmark->op_targ != OP_PUSHMARK)
7259                 break;
7260
7261             exlist = (LISTOP *) expushmark->op_sibling;
7262             if (!exlist || exlist->op_type != OP_NULL
7263                 || exlist->op_targ != OP_LIST)
7264                 break;
7265
7266             if (exlist->op_last != o) {
7267                 /* Mmm. Was expecting to point back to this op.  */
7268                 break;
7269             }
7270             theirmark = exlist->op_first;
7271             if (!theirmark || theirmark->op_type != OP_PUSHMARK)
7272                 break;
7273
7274             if (theirmark->op_sibling != o) {
7275                 /* There's something between the mark and the reverse, eg
7276                    for (1, reverse (...))
7277                    so no go.  */
7278                 break;
7279             }
7280
7281             ourmark = ((LISTOP *)o)->op_first;
7282             if (!ourmark || ourmark->op_type != OP_PUSHMARK)
7283                 break;
7284
7285             ourlast = ((LISTOP *)o)->op_last;
7286             if (!ourlast || ourlast->op_next != o)
7287                 break;
7288
7289             rv2av = ourmark->op_sibling;
7290             if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
7291                 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
7292                 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
7293                 /* We're just reversing a single array.  */
7294                 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
7295                 enter->op_flags |= OPf_STACKED;
7296             }
7297
7298             /* We don't have control over who points to theirmark, so sacrifice
7299                ours.  */
7300             theirmark->op_next = ourmark->op_next;
7301             theirmark->op_flags = ourmark->op_flags;
7302             ourlast->op_next = gvop ? gvop : (OP *) enter;
7303             op_null(ourmark);
7304             op_null(o);
7305             enter->op_private |= OPpITER_REVERSED;
7306             iter->op_private |= OPpITER_REVERSED;
7307
7308             break;
7309         }
7310
7311         case OP_SASSIGN: {
7312             OP *rv2gv;
7313             UNOP *refgen, *rv2cv;
7314             LISTOP *exlist;
7315
7316             /* I do not understand this, but if o->op_opt isn't set to 1,
7317                various tests in ext/B/t/bytecode.t fail with no readily
7318                apparent cause.  */
7319
7320             o->op_opt = 1;
7321
7322
7323             if ((o->op_flags && OPf_WANT) != OPf_WANT_VOID)
7324                 break;
7325
7326             if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
7327                 break;
7328
7329             rv2gv = ((BINOP *)o)->op_last;
7330             if (!rv2gv || rv2gv->op_type != OP_RV2GV)
7331                 break;
7332
7333             refgen = (UNOP *)((BINOP *)o)->op_first;
7334
7335             if (!refgen || refgen->op_type != OP_REFGEN)
7336                 break;
7337
7338             exlist = (LISTOP *)refgen->op_first;
7339             if (!exlist || exlist->op_type != OP_NULL
7340                 || exlist->op_targ != OP_LIST)
7341                 break;
7342
7343             if (exlist->op_first->op_type != OP_PUSHMARK)
7344                 break;
7345
7346             rv2cv = (UNOP*)exlist->op_last;
7347
7348             if (rv2cv->op_type != OP_RV2CV)
7349                 break;
7350
7351             assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
7352             assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
7353             assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
7354
7355             o->op_private |= OPpASSIGN_CV_TO_GV;
7356             rv2gv->op_private |= OPpDONT_INIT_GV;
7357             rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
7358
7359             break;
7360         }
7361
7362
7363         default:
7364             o->op_opt = 1;
7365             break;
7366         }
7367         oldop = o;
7368     }
7369     LEAVE;
7370 }
7371
7372 char*
7373 Perl_custom_op_name(pTHX_ const OP* o)
7374 {
7375     const IV index = PTR2IV(o->op_ppaddr);
7376     SV* keysv;
7377     HE* he;
7378
7379     if (!PL_custom_op_names) /* This probably shouldn't happen */
7380         return (char *)PL_op_name[OP_CUSTOM];
7381
7382     keysv = sv_2mortal(newSViv(index));
7383
7384     he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
7385     if (!he)
7386         return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
7387
7388     return SvPV_nolen(HeVAL(he));
7389 }
7390
7391 char*
7392 Perl_custom_op_desc(pTHX_ const OP* o)
7393 {
7394     const IV index = PTR2IV(o->op_ppaddr);
7395     SV* keysv;
7396     HE* he;
7397
7398     if (!PL_custom_op_descs)
7399         return (char *)PL_op_desc[OP_CUSTOM];
7400
7401     keysv = sv_2mortal(newSViv(index));
7402
7403     he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
7404     if (!he)
7405         return (char *)PL_op_desc[OP_CUSTOM];
7406
7407     return SvPV_nolen(HeVAL(he));
7408 }
7409
7410 #include "XSUB.h"
7411
7412 /* Efficient sub that returns a constant scalar value. */
7413 static void
7414 const_sv_xsub(pTHX_ CV* cv)
7415 {
7416     dXSARGS;
7417     if (items != 0) {
7418 #if 0
7419         Perl_croak(aTHX_ "usage: %s::%s()",
7420                    HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
7421 #endif
7422     }
7423     EXTEND(sp, 1);
7424     ST(0) = (SV*)XSANY.any_ptr;
7425     XSRETURN(1);
7426 }
7427
7428 /*
7429  * Local variables:
7430  * c-indentation-style: bsd
7431  * c-basic-offset: 4
7432  * indent-tabs-mode: t
7433  * End:
7434  *
7435  * ex: set ts=8 sts=4 sw=4 noet:
7436  */