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