op.c

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