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