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