op.c

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