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
2370 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 whileline, OP *expr, OP *block, OP *cont)
3803 {
3804     dVAR;
3805     OP *redo;
3806     OP *next = 0;
3807     OP *listop;
3808     OP *o;
3809     U8 loopflags = 0;
3810     (void)debuggable;
3811
3812     if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3813                  || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
3814         expr = newUNOP(OP_DEFINED, 0,
3815             newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3816     } else if (expr && (expr->op_flags & OPf_KIDS)) {
3817         const OP *k1 = ((UNOP*)expr)->op_first;
3818         const OP *k2 = (k1) ? k1->op_sibling : NULL;
3819         switch (expr->op_type) {
3820           case OP_NULL:
3821             if (k2 && k2->op_type == OP_READLINE
3822                   && (k2->op_flags & OPf_STACKED)
3823                   && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3824                 expr = newUNOP(OP_DEFINED, 0, expr);
3825             break;
3826
3827           case OP_SASSIGN:
3828             if (k1->op_type == OP_READDIR
3829                   || k1->op_type == OP_GLOB
3830                   || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3831                   || k1->op_type == OP_EACH)
3832                 expr = newUNOP(OP_DEFINED, 0, expr);
3833             break;
3834         }
3835     }
3836
3837     if (!block)
3838         block = newOP(OP_NULL, 0);
3839     else if (cont) {
3840         block = scope(block);
3841     }
3842
3843     if (cont) {
3844         next = LINKLIST(cont);
3845     }
3846     if (expr) {
3847         OP *unstack = newOP(OP_UNSTACK, 0);
3848         if (!next)
3849             next = unstack;
3850         cont = append_elem(OP_LINESEQ, cont, unstack);
3851     }
3852
3853     listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
3854     redo = LINKLIST(listop);
3855
3856     if (expr) {
3857         PL_copline = (line_t)whileline;
3858         scalar(listop);
3859         o = new_logop(OP_AND, 0, &expr, &listop);
3860         if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
3861             op_free(expr);              /* oops, it's a while (0) */
3862             op_free((OP*)loop);
3863             return Nullop;              /* listop already freed by new_logop */
3864         }
3865         if (listop)
3866             ((LISTOP*)listop)->op_last->op_next =
3867                 (o == listop ? redo : LINKLIST(o));
3868     }
3869     else
3870         o = listop;
3871
3872     if (!loop) {
3873         NewOp(1101,loop,1,LOOP);
3874         loop->op_type = OP_ENTERLOOP;
3875         loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
3876         loop->op_private = 0;
3877         loop->op_next = (OP*)loop;
3878     }
3879
3880     o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
3881
3882     loop->op_redoop = redo;
3883     loop->op_lastop = o;
3884     o->op_private |= loopflags;
3885
3886     if (next)
3887         loop->op_nextop = next;
3888     else
3889         loop->op_nextop = o;
3890
3891     o->op_flags |= flags;
3892     o->op_private |= (flags >> 8);
3893     return o;
3894 }
3895
3896 OP *
3897 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
3898 {
3899     dVAR;
3900     LOOP *loop;
3901     OP *wop;
3902     PADOFFSET padoff = 0;
3903     I32 iterflags = 0;
3904     I32 iterpflags = 0;
3905
3906     if (sv) {
3907         if (sv->op_type == OP_RV2SV) {  /* symbol table variable */
3908             iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
3909             sv->op_type = OP_RV2GV;
3910             sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
3911         }
3912         else if (sv->op_type == OP_PADSV) { /* private variable */
3913             iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
3914             padoff = sv->op_targ;
3915             sv->op_targ = 0;
3916             op_free(sv);
3917             sv = Nullop;
3918         }
3919         else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
3920             padoff = sv->op_targ;
3921             sv->op_targ = 0;
3922             iterflags |= OPf_SPECIAL;
3923             op_free(sv);
3924             sv = Nullop;
3925         }
3926         else
3927             Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
3928     }
3929     else {
3930         const I32 offset = pad_findmy("$_");
3931         if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
3932             sv = newGVOP(OP_GV, 0, PL_defgv);
3933         }
3934         else {
3935             padoff = offset;
3936         }
3937     }
3938     if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
3939         expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
3940         iterflags |= OPf_STACKED;
3941     }
3942     else if (expr->op_type == OP_NULL &&
3943              (expr->op_flags & OPf_KIDS) &&
3944              ((BINOP*)expr)->op_first->op_type == OP_FLOP)
3945     {
3946         /* Basically turn for($x..$y) into the same as for($x,$y), but we
3947          * set the STACKED flag to indicate that these values are to be
3948          * treated as min/max values by 'pp_iterinit'.
3949          */
3950         UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
3951         LOGOP* range = (LOGOP*) flip->op_first;
3952         OP* left  = range->op_first;
3953         OP* right = left->op_sibling;
3954         LISTOP* listop;
3955
3956         range->op_flags &= ~OPf_KIDS;
3957         range->op_first = Nullop;
3958
3959         listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
3960         listop->op_first->op_next = range->op_next;
3961         left->op_next = range->op_other;
3962         right->op_next = (OP*)listop;
3963         listop->op_next = listop->op_first;
3964
3965         op_free(expr);
3966         expr = (OP*)(listop);
3967         op_null(expr);
3968         iterflags |= OPf_STACKED;
3969     }
3970     else {
3971         expr = mod(force_list(expr), OP_GREPSTART);
3972     }
3973
3974     loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
3975                                append_elem(OP_LIST, expr, scalar(sv))));
3976     assert(!loop->op_next);
3977     /* for my  $x () sets OPpLVAL_INTRO;
3978      * for our $x () sets OPpOUR_INTRO */
3979     loop->op_private = (U8)iterpflags;
3980 #ifdef PL_OP_SLAB_ALLOC
3981     {
3982         LOOP *tmp;
3983         NewOp(1234,tmp,1,LOOP);
3984         Copy(loop,tmp,1,LISTOP);
3985         FreeOp(loop);
3986         loop = tmp;
3987     }
3988 #else
3989     Renew(loop, 1, LOOP);
3990 #endif
3991     loop->op_targ = padoff;
3992     wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
3993     PL_copline = forline;
3994     return newSTATEOP(0, label, wop);
3995 }
3996
3997 OP*
3998 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
3999 {
4000     OP *o;
4001     STRLEN n_a;
4002
4003     if (type != OP_GOTO || label->op_type == OP_CONST) {
4004         /* "last()" means "last" */
4005         if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4006             o = newOP(type, OPf_SPECIAL);
4007         else {
4008             o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4009                                         ? SvPVx(((SVOP*)label)->op_sv, n_a)
4010                                         : ""));
4011         }
4012         op_free(label);
4013     }
4014     else {
4015         /* Check whether it's going to be a goto &function */
4016         if (label->op_type == OP_ENTERSUB
4017                 && !(label->op_flags & OPf_STACKED))
4018             label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4019         o = newUNOP(type, OPf_STACKED, label);
4020     }
4021     PL_hints |= HINT_BLOCK_SCOPE;
4022     return o;
4023 }
4024
4025 /*
4026 =for apidoc cv_undef
4027
4028 Clear out all the active components of a CV. This can happen either
4029 by an explicit C<undef &foo>, or by the reference count going to zero.
4030 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
4031 children can still follow the full lexical scope chain.
4032
4033 =cut
4034 */
4035
4036 void
4037 Perl_cv_undef(pTHX_ CV *cv)
4038 {
4039     dVAR;
4040 #ifdef USE_ITHREADS
4041     if (CvFILE(cv) && !CvXSUB(cv)) {
4042         /* for XSUBs CvFILE point directly to static memory; __FILE__ */
4043         Safefree(CvFILE(cv));
4044     }
4045     CvFILE(cv) = 0;
4046 #endif
4047
4048     if (!CvXSUB(cv) && CvROOT(cv)) {
4049         if (CvDEPTH(cv))
4050             Perl_croak(aTHX_ "Can't undef active subroutine");
4051         ENTER;
4052
4053         PAD_SAVE_SETNULLPAD();
4054
4055         op_free(CvROOT(cv));
4056         CvROOT(cv) = Nullop;
4057         LEAVE;
4058     }
4059     SvPOK_off((SV*)cv);         /* forget prototype */
4060     CvGV(cv) = Nullgv;
4061
4062     pad_undef(cv);
4063
4064     /* remove CvOUTSIDE unless this is an undef rather than a free */
4065     if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
4066         if (!CvWEAKOUTSIDE(cv))
4067             SvREFCNT_dec(CvOUTSIDE(cv));
4068         CvOUTSIDE(cv) = Nullcv;
4069     }
4070     if (CvCONST(cv)) {
4071         SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4072         CvCONST_off(cv);
4073     }
4074     if (CvXSUB(cv)) {
4075         CvXSUB(cv) = 0;
4076     }
4077     /* delete all flags except WEAKOUTSIDE */
4078     CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
4079 }
4080
4081 void
4082 Perl_cv_ckproto(pTHX_ const CV *cv, const GV *gv, const char *p)
4083 {
4084     if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4085         SV* msg = sv_newmortal();
4086         SV* name = Nullsv;
4087
4088         if (gv)
4089             gv_efullname3(name = sv_newmortal(), gv, Nullch);
4090         sv_setpv(msg, "Prototype mismatch:");
4091         if (name)
4092             Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4093         if (SvPOK(cv))
4094             Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (const SV *)cv);
4095         else
4096             Perl_sv_catpv(aTHX_ msg, ": none");
4097         sv_catpv(msg, " vs ");
4098         if (p)
4099             Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4100         else
4101             sv_catpv(msg, "none");
4102         Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, msg);
4103     }
4104 }
4105
4106 static void const_sv_xsub(pTHX_ CV* cv);
4107
4108 /*
4109
4110 =head1 Optree Manipulation Functions
4111
4112 =for apidoc cv_const_sv
4113
4114 If C<cv> is a constant sub eligible for inlining. returns the constant
4115 value returned by the sub.  Otherwise, returns NULL.
4116
4117 Constant subs can be created with C<newCONSTSUB> or as described in
4118 L<perlsub/"Constant Functions">.
4119
4120 =cut
4121 */
4122 SV *
4123 Perl_cv_const_sv(pTHX_ CV *cv)
4124 {
4125     if (!cv || !CvCONST(cv))
4126         return Nullsv;
4127     return (SV*)CvXSUBANY(cv).any_ptr;
4128 }
4129
4130 /* op_const_sv:  examine an optree to determine whether it's in-lineable.
4131  * Can be called in 3 ways:
4132  *
4133  * !cv
4134  *      look for a single OP_CONST with attached value: return the value
4135  *
4136  * cv && CvCLONE(cv) && !CvCONST(cv)
4137  *
4138  *      examine the clone prototype, and if contains only a single
4139  *      OP_CONST referencing a pad const, or a single PADSV referencing
4140  *      an outer lexical, return a non-zero value to indicate the CV is
4141  *      a candidate for "constizing" at clone time
4142  *
4143  * cv && CvCONST(cv)
4144  *
4145  *      We have just cloned an anon prototype that was marked as a const
4146  *      candidiate. Try to grab the current value, and in the case of
4147  *      PADSV, ignore it if it has multiple references. Return the value.
4148  */
4149
4150 SV *
4151 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
4152 {
4153     SV *sv = Nullsv;
4154
4155     if (!o)
4156         return Nullsv;
4157
4158     if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4159         o = cLISTOPo->op_first->op_sibling;
4160
4161     for (; o; o = o->op_next) {
4162         OPCODE type = o->op_type;
4163
4164         if (sv && o->op_next == o)
4165             return sv;
4166         if (o->op_next != o) {
4167             if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4168                 continue;
4169             if (type == OP_DBSTATE)
4170                 continue;
4171         }
4172         if (type == OP_LEAVESUB || type == OP_RETURN)
4173             break;
4174         if (sv)
4175             return Nullsv;
4176         if (type == OP_CONST && cSVOPo->op_sv)
4177             sv = cSVOPo->op_sv;
4178         else if (cv && type == OP_CONST) {
4179             sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4180             if (!sv)
4181                 return Nullsv;
4182         }
4183         else if (cv && type == OP_PADSV) {
4184             if (CvCONST(cv)) { /* newly cloned anon */
4185                 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4186                 /* the candidate should have 1 ref from this pad and 1 ref
4187                  * from the parent */
4188                 if (!sv || SvREFCNT(sv) != 2)
4189                     return Nullsv;
4190                 sv = newSVsv(sv);
4191                 SvREADONLY_on(sv);
4192                 return sv;
4193             }
4194             else {
4195                 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
4196                     sv = &PL_sv_undef; /* an arbitrary non-null value */
4197             }
4198         }
4199         else {
4200             return Nullsv;
4201         }
4202     }
4203     return sv;
4204 }
4205
4206 void
4207 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4208 {
4209     (void)floor;
4210     if (o)
4211         SAVEFREEOP(o);
4212     if (proto)
4213         SAVEFREEOP(proto);
4214     if (attrs)
4215         SAVEFREEOP(attrs);
4216     if (block)
4217         SAVEFREEOP(block);
4218     Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4219 }
4220
4221 CV *
4222 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4223 {
4224     return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4225 }
4226
4227 CV *
4228 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4229 {
4230     dVAR;
4231     STRLEN n_a;
4232     const char *name;
4233     const char *aname;
4234     GV *gv;
4235     char *ps;
4236     register CV *cv=0;
4237     SV *const_sv;
4238
4239     name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4240
4241     if (proto) {
4242         assert(proto->op_type == OP_CONST);
4243         ps = SvPVx(((SVOP*)proto)->op_sv, n_a);
4244     }
4245     else
4246         ps = Nullch;
4247
4248     if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4249         SV *sv = sv_newmortal();
4250         Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
4251                        PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
4252                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4253         aname = SvPVX(sv);
4254     }
4255     else
4256         aname = Nullch;
4257     gv = name ? gv_fetchsv(cSVOPo->op_sv,
4258                            GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4259                            SVt_PVCV)
4260         : gv_fetchpv(aname ? aname
4261                      : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4262                      GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4263                      SVt_PVCV);
4264
4265     if (o)
4266         SAVEFREEOP(o);
4267     if (proto)
4268         SAVEFREEOP(proto);
4269     if (attrs)
4270         SAVEFREEOP(attrs);
4271
4272     if (SvTYPE(gv) != SVt_PVGV) {       /* Maybe prototype now, and had at
4273                                            maximum a prototype before. */
4274         if (SvTYPE(gv) > SVt_NULL) {
4275             if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4276                 && ckWARN_d(WARN_PROTOTYPE))
4277             {
4278                 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
4279             }
4280             cv_ckproto((CV*)gv, NULL, ps);
4281         }
4282         if (ps)
4283             sv_setpv((SV*)gv, ps);
4284         else
4285             sv_setiv((SV*)gv, -1);
4286         SvREFCNT_dec(PL_compcv);
4287         cv = PL_compcv = NULL;
4288         PL_sub_generation++;
4289         goto done;
4290     }
4291
4292     cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4293
4294 #ifdef GV_UNIQUE_CHECK
4295     if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4296         Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
4297     }
4298 #endif
4299
4300     if (!block || !ps || *ps || attrs)
4301         const_sv = Nullsv;
4302     else
4303         const_sv = op_const_sv(block, Nullcv);
4304
4305     if (cv) {
4306         const bool exists = CvROOT(cv) || CvXSUB(cv);
4307
4308 #ifdef GV_UNIQUE_CHECK
4309         if (exists && GvUNIQUE(gv)) {
4310             Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
4311         }
4312 #endif
4313
4314         /* if the subroutine doesn't exist and wasn't pre-declared
4315          * with a prototype, assume it will be AUTOLOADed,
4316          * skipping the prototype check
4317          */
4318         if (exists || SvPOK(cv))
4319             cv_ckproto(cv, gv, ps);
4320         /* already defined (or promised)? */
4321         if (exists || GvASSUMECV(gv)) {
4322             if (!block && !attrs) {
4323                 if (CvFLAGS(PL_compcv)) {
4324                     /* might have had built-in attrs applied */
4325                     CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4326                 }
4327                 /* just a "sub foo;" when &foo is already defined */
4328                 SAVEFREESV(PL_compcv);
4329                 goto done;
4330             }
4331             /* ahem, death to those who redefine active sort subs */
4332             if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4333                 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4334             if (block) {
4335                 if (ckWARN(WARN_REDEFINE)
4336                     || (CvCONST(cv)
4337                         && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4338                 {
4339                     const line_t oldline = CopLINE(PL_curcop);
4340                     if (PL_copline != NOLINE)
4341                         CopLINE_set(PL_curcop, PL_copline);
4342                     Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4343                         CvCONST(cv) ? "Constant subroutine %s redefined"
4344                                     : "Subroutine %s redefined", name);
4345                     CopLINE_set(PL_curcop, oldline);
4346                 }
4347                 SvREFCNT_dec(cv);
4348                 cv = Nullcv;
4349             }
4350         }
4351     }
4352     if (const_sv) {
4353         (void)SvREFCNT_inc(const_sv);
4354         if (cv) {
4355             assert(!CvROOT(cv) && !CvCONST(cv));
4356             sv_setpv((SV*)cv, "");  /* prototype is "" */
4357             CvXSUBANY(cv).any_ptr = const_sv;
4358             CvXSUB(cv) = const_sv_xsub;
4359             CvCONST_on(cv);
4360         }
4361         else {
4362             GvCV(gv) = Nullcv;
4363             cv = newCONSTSUB(NULL, name, const_sv);
4364         }
4365         op_free(block);
4366         SvREFCNT_dec(PL_compcv);
4367         PL_compcv = NULL;
4368         PL_sub_generation++;
4369         goto done;
4370     }
4371     if (attrs) {
4372         HV *stash;
4373         SV *rcv;
4374
4375         /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4376          * before we clobber PL_compcv.
4377          */
4378         if (cv && !block) {
4379             rcv = (SV*)cv;
4380             /* Might have had built-in attributes applied -- propagate them. */
4381             CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4382             if (CvGV(cv) && GvSTASH(CvGV(cv)))
4383                 stash = GvSTASH(CvGV(cv));
4384             else if (CvSTASH(cv))
4385                 stash = CvSTASH(cv);
4386             else
4387                 stash = PL_curstash;
4388         }
4389         else {
4390             /* possibly about to re-define existing subr -- ignore old cv */
4391             rcv = (SV*)PL_compcv;
4392             if (name && GvSTASH(gv))
4393                 stash = GvSTASH(gv);
4394             else
4395                 stash = PL_curstash;
4396         }
4397         apply_attrs(stash, rcv, attrs, FALSE);
4398     }
4399     if (cv) {                           /* must reuse cv if autoloaded */
4400         if (!block) {
4401             /* got here with just attrs -- work done, so bug out */
4402             SAVEFREESV(PL_compcv);
4403             goto done;
4404         }
4405         /* transfer PL_compcv to cv */
4406         cv_undef(cv);
4407         CvFLAGS(cv) = CvFLAGS(PL_compcv);
4408         if (!CvWEAKOUTSIDE(cv))
4409             SvREFCNT_dec(CvOUTSIDE(cv));
4410         CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4411         CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
4412         CvOUTSIDE(PL_compcv) = 0;
4413         CvPADLIST(cv) = CvPADLIST(PL_compcv);
4414         CvPADLIST(PL_compcv) = 0;
4415         /* inner references to PL_compcv must be fixed up ... */
4416         pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
4417         /* ... before we throw it away */
4418         SvREFCNT_dec(PL_compcv);
4419         PL_compcv = cv;
4420         if (PERLDB_INTER)/* Advice debugger on the new sub. */
4421           ++PL_sub_generation;
4422     }
4423     else {
4424         cv = PL_compcv;
4425         if (name) {
4426             GvCV(gv) = cv;
4427             GvCVGEN(gv) = 0;
4428             PL_sub_generation++;
4429         }
4430     }
4431     CvGV(cv) = gv;
4432     CvFILE_set_from_cop(cv, PL_curcop);
4433     CvSTASH(cv) = PL_curstash;
4434
4435     if (ps)
4436         sv_setpv((SV*)cv, ps);
4437
4438     if (PL_error_count) {
4439         op_free(block);
4440         block = Nullop;
4441         if (name) {
4442             const char *s = strrchr(name, ':');
4443             s = s ? s+1 : name;
4444             if (strEQ(s, "BEGIN")) {
4445                 const char not_safe[] =
4446                     "BEGIN not safe after errors--compilation aborted";
4447                 if (PL_in_eval & EVAL_KEEPERR)
4448                     Perl_croak(aTHX_ not_safe);
4449                 else {
4450                     /* force display of errors found but not reported */
4451                     sv_catpv(ERRSV, not_safe);
4452                     Perl_croak(aTHX_ "%"SVf, ERRSV);
4453                 }
4454             }
4455         }
4456     }
4457     if (!block)
4458         goto done;
4459
4460     if (CvLVALUE(cv)) {
4461         CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4462                              mod(scalarseq(block), OP_LEAVESUBLV));
4463     }
4464     else {
4465         /* This makes sub {}; work as expected.  */
4466         if (block->op_type == OP_STUB) {
4467             op_free(block);
4468             block = newSTATEOP(0, Nullch, 0);
4469         }
4470         CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4471     }
4472     CvROOT(cv)->op_private |= OPpREFCOUNTED;
4473     OpREFCNT_set(CvROOT(cv), 1);
4474     CvSTART(cv) = LINKLIST(CvROOT(cv));
4475     CvROOT(cv)->op_next = 0;
4476     CALL_PEEP(CvSTART(cv));
4477
4478     /* now that optimizer has done its work, adjust pad values */
4479
4480     pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
4481
4482     if (CvCLONE(cv)) {
4483         assert(!CvCONST(cv));
4484         if (ps && !*ps && op_const_sv(block, cv))
4485             CvCONST_on(cv);
4486     }
4487
4488     if (name || aname) {
4489         const char *s;
4490         const char *tname = (name ? name : aname);
4491
4492         if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4493             SV *sv = NEWSV(0,0);
4494             SV *tmpstr = sv_newmortal();
4495             GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4496             CV *pcv;
4497             HV *hv;
4498
4499             Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4500                            CopFILE(PL_curcop),
4501                            (long)PL_subline, (long)CopLINE(PL_curcop));
4502             gv_efullname3(tmpstr, gv, Nullch);
4503             hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
4504             hv = GvHVn(db_postponed);
4505             if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
4506                 && (pcv = GvCV(db_postponed)))
4507             {
4508                 dSP;
4509                 PUSHMARK(SP);
4510                 XPUSHs(tmpstr);
4511                 PUTBACK;
4512                 call_sv((SV*)pcv, G_DISCARD);
4513             }
4514         }
4515
4516         if ((s = strrchr(tname,':')))
4517             s++;
4518         else
4519             s = tname;
4520
4521         if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4522             goto done;
4523
4524         if (strEQ(s, "BEGIN") && !PL_error_count) {
4525             const I32 oldscope = PL_scopestack_ix;
4526             ENTER;
4527             SAVECOPFILE(&PL_compiling);
4528             SAVECOPLINE(&PL_compiling);
4529
4530             if (!PL_beginav)
4531                 PL_beginav = newAV();
4532             DEBUG_x( dump_sub(gv) );
4533             av_push(PL_beginav, (SV*)cv);
4534             GvCV(gv) = 0;               /* cv has been hijacked */
4535             call_list(oldscope, PL_beginav);
4536
4537             PL_curcop = &PL_compiling;
4538             PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4539             LEAVE;
4540         }
4541         else if (strEQ(s, "END") && !PL_error_count) {
4542             if (!PL_endav)
4543                 PL_endav = newAV();
4544             DEBUG_x( dump_sub(gv) );
4545             av_unshift(PL_endav, 1);
4546             av_store(PL_endav, 0, (SV*)cv);
4547             GvCV(gv) = 0;               /* cv has been hijacked */
4548         }
4549         else if (strEQ(s, "CHECK") && !PL_error_count) {
4550             if (!PL_checkav)
4551                 PL_checkav = newAV();
4552             DEBUG_x( dump_sub(gv) );
4553             if (PL_main_start && ckWARN(WARN_VOID))
4554                 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4555             av_unshift(PL_checkav, 1);
4556             av_store(PL_checkav, 0, (SV*)cv);
4557             GvCV(gv) = 0;               /* cv has been hijacked */
4558         }
4559         else if (strEQ(s, "INIT") && !PL_error_count) {
4560             if (!PL_initav)
4561                 PL_initav = newAV();
4562             DEBUG_x( dump_sub(gv) );
4563             if (PL_main_start && ckWARN(WARN_VOID))
4564                 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4565             av_push(PL_initav, (SV*)cv);
4566             GvCV(gv) = 0;               /* cv has been hijacked */
4567         }
4568     }
4569
4570   done:
4571     PL_copline = NOLINE;
4572     LEAVE_SCOPE(floor);
4573     return cv;
4574 }
4575
4576 /* XXX unsafe for threads if eval_owner isn't held */
4577 /*
4578 =for apidoc newCONSTSUB
4579
4580 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4581 eligible for inlining at compile-time.
4582
4583 =cut
4584 */
4585
4586 CV *
4587 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
4588 {
4589     dVAR;
4590     CV* cv;
4591
4592     ENTER;
4593
4594     SAVECOPLINE(PL_curcop);
4595     CopLINE_set(PL_curcop, PL_copline);
4596
4597     SAVEHINTS();
4598     PL_hints &= ~HINT_BLOCK_SCOPE;
4599
4600     if (stash) {
4601         SAVESPTR(PL_curstash);
4602         SAVECOPSTASH(PL_curcop);
4603         PL_curstash = stash;
4604         CopSTASH_set(PL_curcop,stash);
4605     }
4606
4607     cv = newXS(name, const_sv_xsub, savepv(CopFILE(PL_curcop)));
4608     CvXSUBANY(cv).any_ptr = sv;
4609     CvCONST_on(cv);
4610     sv_setpv((SV*)cv, "");  /* prototype is "" */
4611
4612     if (stash)
4613         CopSTASH_free(PL_curcop);
4614
4615     LEAVE;
4616
4617     return cv;
4618 }
4619
4620 /*
4621 =for apidoc U||newXS
4622
4623 Used by C<xsubpp> to hook up XSUBs as Perl subs.
4624
4625 =cut
4626 */
4627
4628 CV *
4629 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
4630 {
4631     GV *gv = gv_fetchpv(name ? name :
4632                         (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4633                         GV_ADDMULTI, SVt_PVCV);
4634     register CV *cv;
4635
4636     if (!subaddr)
4637         Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
4638
4639     if ((cv = (name ? GvCV(gv) : Nullcv))) {
4640         if (GvCVGEN(gv)) {
4641             /* just a cached method */
4642             SvREFCNT_dec(cv);
4643             cv = 0;
4644         }
4645         else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4646             /* already defined (or promised) */
4647             if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
4648                             && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
4649                 const line_t oldline = CopLINE(PL_curcop);
4650                 if (PL_copline != NOLINE)
4651                     CopLINE_set(PL_curcop, PL_copline);
4652                 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4653                             CvCONST(cv) ? "Constant subroutine %s redefined"
4654                                         : "Subroutine %s redefined"
4655                             ,name);
4656                 CopLINE_set(PL_curcop, oldline);
4657             }
4658             SvREFCNT_dec(cv);
4659             cv = 0;
4660         }
4661     }
4662
4663     if (cv)                             /* must reuse cv if autoloaded */
4664         cv_undef(cv);
4665     else {
4666         cv = (CV*)NEWSV(1105,0);
4667         sv_upgrade((SV *)cv, SVt_PVCV);
4668         if (name) {
4669             GvCV(gv) = cv;
4670             GvCVGEN(gv) = 0;
4671             PL_sub_generation++;
4672         }
4673     }
4674     CvGV(cv) = gv;
4675     (void)gv_fetchfile(filename);
4676     CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
4677                                    an external constant string */
4678     CvXSUB(cv) = subaddr;
4679
4680     if (name) {
4681         const char *s = strrchr(name,':');
4682         if (s)
4683             s++;
4684         else
4685             s = name;
4686
4687         if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4688             goto done;
4689
4690         if (strEQ(s, "BEGIN")) {
4691             if (!PL_beginav)
4692                 PL_beginav = newAV();
4693             av_push(PL_beginav, (SV*)cv);
4694             GvCV(gv) = 0;               /* cv has been hijacked */
4695         }
4696         else if (strEQ(s, "END")) {
4697             if (!PL_endav)
4698                 PL_endav = newAV();
4699             av_unshift(PL_endav, 1);
4700             av_store(PL_endav, 0, (SV*)cv);
4701             GvCV(gv) = 0;               /* cv has been hijacked */
4702         }
4703         else if (strEQ(s, "CHECK")) {
4704             if (!PL_checkav)
4705                 PL_checkav = newAV();
4706             if (PL_main_start && ckWARN(WARN_VOID))
4707                 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4708             av_unshift(PL_checkav, 1);
4709             av_store(PL_checkav, 0, (SV*)cv);
4710             GvCV(gv) = 0;               /* cv has been hijacked */
4711         }
4712         else if (strEQ(s, "INIT")) {
4713             if (!PL_initav)
4714                 PL_initav = newAV();
4715             if (PL_main_start && ckWARN(WARN_VOID))
4716                 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4717             av_push(PL_initav, (SV*)cv);
4718             GvCV(gv) = 0;               /* cv has been hijacked */
4719         }
4720     }
4721     else
4722         CvANON_on(cv);
4723
4724 done:
4725     return cv;
4726 }
4727
4728 void
4729 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
4730 {
4731     register CV *cv;
4732     GV *gv;
4733
4734     if (o)
4735         gv = gv_fetchsv(cSVOPo->op_sv, TRUE, SVt_PVFM);
4736     else
4737         gv = gv_fetchpv("STDOUT", TRUE, SVt_PVFM);
4738
4739 #ifdef GV_UNIQUE_CHECK
4740     if (GvUNIQUE(gv)) {
4741         Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
4742     }
4743 #endif
4744     GvMULTI_on(gv);
4745     if ((cv = GvFORM(gv))) {
4746         if (ckWARN(WARN_REDEFINE)) {
4747             const line_t oldline = CopLINE(PL_curcop);
4748             if (PL_copline != NOLINE)
4749                 CopLINE_set(PL_curcop, PL_copline);
4750             Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4751                         o ? "Format %"SVf" redefined"
4752                         : "Format STDOUT redefined" ,cSVOPo->op_sv);
4753             CopLINE_set(PL_curcop, oldline);
4754         }
4755         SvREFCNT_dec(cv);
4756     }
4757     cv = PL_compcv;
4758     GvFORM(gv) = cv;
4759     CvGV(cv) = gv;
4760     CvFILE_set_from_cop(cv, PL_curcop);
4761
4762
4763     pad_tidy(padtidy_FORMAT);
4764     CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
4765     CvROOT(cv)->op_private |= OPpREFCOUNTED;
4766     OpREFCNT_set(CvROOT(cv), 1);
4767     CvSTART(cv) = LINKLIST(CvROOT(cv));
4768     CvROOT(cv)->op_next = 0;
4769     CALL_PEEP(CvSTART(cv));
4770     op_free(o);
4771     PL_copline = NOLINE;
4772     LEAVE_SCOPE(floor);
4773 }
4774
4775 OP *
4776 Perl_newANONLIST(pTHX_ OP *o)
4777 {
4778     return newUNOP(OP_REFGEN, 0,
4779         mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
4780 }
4781
4782 OP *
4783 Perl_newANONHASH(pTHX_ OP *o)
4784 {
4785     return newUNOP(OP_REFGEN, 0,
4786         mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
4787 }
4788
4789 OP *
4790 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
4791 {
4792     return newANONATTRSUB(floor, proto, Nullop, block);
4793 }
4794
4795 OP *
4796 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
4797 {
4798     return newUNOP(OP_REFGEN, 0,
4799         newSVOP(OP_ANONCODE, 0,
4800                 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
4801 }
4802
4803 OP *
4804 Perl_oopsAV(pTHX_ OP *o)
4805 {
4806     dVAR;
4807     switch (o->op_type) {
4808     case OP_PADSV:
4809         o->op_type = OP_PADAV;
4810         o->op_ppaddr = PL_ppaddr[OP_PADAV];
4811         return ref(o, OP_RV2AV);
4812
4813     case OP_RV2SV:
4814         o->op_type = OP_RV2AV;
4815         o->op_ppaddr = PL_ppaddr[OP_RV2AV];
4816         ref(o, OP_RV2AV);
4817         break;
4818
4819     default:
4820         if (ckWARN_d(WARN_INTERNAL))
4821             Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
4822         break;
4823     }
4824     return o;
4825 }
4826
4827 OP *
4828 Perl_oopsHV(pTHX_ OP *o)
4829 {
4830     dVAR;
4831     switch (o->op_type) {
4832     case OP_PADSV:
4833     case OP_PADAV:
4834         o->op_type = OP_PADHV;
4835         o->op_ppaddr = PL_ppaddr[OP_PADHV];
4836         return ref(o, OP_RV2HV);
4837
4838     case OP_RV2SV:
4839     case OP_RV2AV:
4840         o->op_type = OP_RV2HV;
4841         o->op_ppaddr = PL_ppaddr[OP_RV2HV];
4842         ref(o, OP_RV2HV);
4843         break;
4844
4845     default:
4846         if (ckWARN_d(WARN_INTERNAL))
4847             Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
4848         break;
4849     }
4850     return o;
4851 }
4852
4853 OP *
4854 Perl_newAVREF(pTHX_ OP *o)
4855 {
4856     dVAR;
4857     if (o->op_type == OP_PADANY) {
4858         o->op_type = OP_PADAV;
4859         o->op_ppaddr = PL_ppaddr[OP_PADAV];
4860         return o;
4861     }
4862     else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
4863                 && ckWARN(WARN_DEPRECATED)) {
4864         Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4865                 "Using an array as a reference is deprecated");
4866     }
4867     return newUNOP(OP_RV2AV, 0, scalar(o));
4868 }
4869
4870 OP *
4871 Perl_newGVREF(pTHX_ I32 type, OP *o)
4872 {
4873     if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
4874         return newUNOP(OP_NULL, 0, o);
4875     return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
4876 }
4877
4878 OP *
4879 Perl_newHVREF(pTHX_ OP *o)
4880 {
4881     dVAR;
4882     if (o->op_type == OP_PADANY) {
4883         o->op_type = OP_PADHV;
4884         o->op_ppaddr = PL_ppaddr[OP_PADHV];
4885         return o;
4886     }
4887     else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
4888                 && ckWARN(WARN_DEPRECATED)) {
4889         Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4890                 "Using a hash as a reference is deprecated");
4891     }
4892     return newUNOP(OP_RV2HV, 0, scalar(o));
4893 }
4894
4895 OP *
4896 Perl_oopsCV(pTHX_ OP *o)
4897 {
4898     Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
4899     /* STUB */
4900     (void)o;
4901 #ifndef HASATTRIBUTE
4902     /* No __attribute__, so the compiler doesn't know that croak never returns
4903      */
4904     return 0;
4905 #endif
4906 }
4907
4908 OP *
4909 Perl_newCVREF(pTHX_ I32 flags, OP *o)
4910 {
4911     return newUNOP(OP_RV2CV, flags, scalar(o));
4912 }
4913
4914 OP *
4915 Perl_newSVREF(pTHX_ OP *o)
4916 {
4917     dVAR;
4918     if (o->op_type == OP_PADANY) {
4919         o->op_type = OP_PADSV;
4920         o->op_ppaddr = PL_ppaddr[OP_PADSV];
4921         return o;
4922     }
4923     else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
4924         o->op_flags |= OPpDONE_SVREF;
4925         return o;
4926     }
4927     return newUNOP(OP_RV2SV, 0, scalar(o));
4928 }
4929
4930 /* Check routines. See the comments at the top of this file for details
4931  * on when these are called */
4932
4933 OP *
4934 Perl_ck_anoncode(pTHX_ OP *o)
4935 {
4936     cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
4937     cSVOPo->op_sv = Nullsv;
4938     return o;
4939 }
4940
4941 OP *
4942 Perl_ck_bitop(pTHX_ OP *o)
4943 {
4944 #define OP_IS_NUMCOMPARE(op) \
4945         ((op) == OP_LT   || (op) == OP_I_LT || \
4946          (op) == OP_GT   || (op) == OP_I_GT || \
4947          (op) == OP_LE   || (op) == OP_I_LE || \
4948          (op) == OP_GE   || (op) == OP_I_GE || \
4949          (op) == OP_EQ   || (op) == OP_I_EQ || \
4950          (op) == OP_NE   || (op) == OP_I_NE || \
4951          (op) == OP_NCMP || (op) == OP_I_NCMP)
4952     o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4953     if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
4954             && (o->op_type == OP_BIT_OR
4955              || o->op_type == OP_BIT_AND
4956              || o->op_type == OP_BIT_XOR))
4957     {
4958         const OP * left = cBINOPo->op_first;
4959         const OP * right = left->op_sibling;
4960         if ((OP_IS_NUMCOMPARE(left->op_type) &&
4961                 (left->op_flags & OPf_PARENS) == 0) ||
4962             (OP_IS_NUMCOMPARE(right->op_type) &&
4963                 (right->op_flags & OPf_PARENS) == 0))
4964             if (ckWARN(WARN_PRECEDENCE))
4965                 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
4966                         "Possible precedence problem on bitwise %c operator",
4967                         o->op_type == OP_BIT_OR ? '|'
4968                             : o->op_type == OP_BIT_AND ? '&' : '^'
4969                         );
4970     }
4971     return o;
4972 }
4973
4974 OP *
4975 Perl_ck_concat(pTHX_ OP *o)
4976 {
4977     const OP *kid = cUNOPo->op_first;
4978     if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
4979             !(kUNOP->op_first->op_flags & OPf_MOD))
4980         o->op_flags |= OPf_STACKED;
4981     return o;
4982 }
4983
4984 OP *
4985 Perl_ck_spair(pTHX_ OP *o)
4986 {
4987     dVAR;
4988     if (o->op_flags & OPf_KIDS) {
4989         OP* newop;
4990         OP* kid;
4991         const OPCODE type = o->op_type;
4992         o = modkids(ck_fun(o), type);
4993         kid = cUNOPo->op_first;
4994         newop = kUNOP->op_first->op_sibling;
4995         if (newop &&
4996             (newop->op_sibling ||
4997              !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
4998              newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
4999              newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
5000
5001             return o;
5002         }
5003         op_free(kUNOP->op_first);
5004         kUNOP->op_first = newop;
5005     }
5006     o->op_ppaddr = PL_ppaddr[++o->op_type];
5007     return ck_fun(o);
5008 }
5009
5010 OP *
5011 Perl_ck_delete(pTHX_ OP *o)
5012 {
5013     o = ck_fun(o);
5014     o->op_private = 0;
5015     if (o->op_flags & OPf_KIDS) {
5016         OP *kid = cUNOPo->op_first;
5017         switch (kid->op_type) {
5018         case OP_ASLICE:
5019             o->op_flags |= OPf_SPECIAL;
5020             /* FALL THROUGH */
5021         case OP_HSLICE:
5022             o->op_private |= OPpSLICE;
5023             break;
5024         case OP_AELEM:
5025             o->op_flags |= OPf_SPECIAL;
5026             /* FALL THROUGH */
5027         case OP_HELEM:
5028             break;
5029         default:
5030             Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5031                   OP_DESC(o));
5032         }
5033         op_null(kid);
5034     }
5035     return o;
5036 }
5037
5038 OP *
5039 Perl_ck_die(pTHX_ OP *o)
5040 {
5041 #ifdef VMS
5042     if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5043 #endif
5044     return ck_fun(o);
5045 }
5046
5047 OP *
5048 Perl_ck_eof(pTHX_ OP *o)
5049 {
5050     const I32 type = o->op_type;
5051
5052     if (o->op_flags & OPf_KIDS) {
5053         if (cLISTOPo->op_first->op_type == OP_STUB) {
5054             op_free(o);
5055             o = newUNOP(type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
5056         }
5057         return ck_fun(o);
5058     }
5059     return o;
5060 }
5061
5062 OP *
5063 Perl_ck_eval(pTHX_ OP *o)
5064 {
5065     dVAR;
5066     PL_hints |= HINT_BLOCK_SCOPE;
5067     if (o->op_flags & OPf_KIDS) {
5068         SVOP *kid = (SVOP*)cUNOPo->op_first;
5069
5070         if (!kid) {
5071             o->op_flags &= ~OPf_KIDS;
5072             op_null(o);
5073         }
5074         else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
5075             LOGOP *enter;
5076
5077             cUNOPo->op_first = 0;
5078             op_free(o);
5079
5080             NewOp(1101, enter, 1, LOGOP);
5081             enter->op_type = OP_ENTERTRY;
5082             enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5083             enter->op_private = 0;
5084
5085             /* establish postfix order */
5086             enter->op_next = (OP*)enter;
5087
5088             o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5089             o->op_type = OP_LEAVETRY;
5090             o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5091             enter->op_other = o;
5092             return o;
5093         }
5094         else {
5095             scalar((OP*)kid);
5096             PL_cv_has_eval = 1;
5097         }
5098     }
5099     else {
5100         op_free(o);
5101         o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5102     }
5103     o->op_targ = (PADOFFSET)PL_hints;
5104     return o;
5105 }
5106
5107 OP *
5108 Perl_ck_exit(pTHX_ OP *o)
5109 {
5110 #ifdef VMS
5111     HV *table = GvHV(PL_hintgv);
5112     if (table) {
5113        SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
5114        if (svp && *svp && SvTRUE(*svp))
5115            o->op_private |= OPpEXIT_VMSISH;
5116     }
5117     if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5118 #endif
5119     return ck_fun(o);
5120 }
5121
5122 OP *
5123 Perl_ck_exec(pTHX_ OP *o)
5124 {
5125     if (o->op_flags & OPf_STACKED) {
5126         OP *kid;
5127         o = ck_fun(o);
5128         kid = cUNOPo->op_first->op_sibling;
5129         if (kid->op_type == OP_RV2GV)
5130             op_null(kid);
5131     }
5132     else
5133         o = listkids(o);
5134     return o;
5135 }
5136
5137 OP *
5138 Perl_ck_exists(pTHX_ OP *o)
5139 {
5140     o = ck_fun(o);
5141     if (o->op_flags & OPf_KIDS) {
5142         OP *kid = cUNOPo->op_first;
5143         if (kid->op_type == OP_ENTERSUB) {
5144             (void) ref(kid, o->op_type);
5145             if (kid->op_type != OP_RV2CV && !PL_error_count)
5146                 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5147                             OP_DESC(o));
5148             o->op_private |= OPpEXISTS_SUB;
5149         }
5150         else if (kid->op_type == OP_AELEM)
5151             o->op_flags |= OPf_SPECIAL;
5152         else if (kid->op_type != OP_HELEM)
5153             Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5154                         OP_DESC(o));
5155         op_null(kid);
5156     }
5157     return o;
5158 }
5159
5160 #if 0
5161 OP *
5162 Perl_ck_gvconst(pTHX_ register OP *o)
5163 {
5164     o = fold_constants(o);
5165     if (o->op_type == OP_CONST)
5166         o->op_type = OP_GV;
5167     return o;
5168 }
5169 #endif
5170
5171 OP *
5172 Perl_ck_rvconst(pTHX_ register OP *o)
5173 {
5174     dVAR;
5175     SVOP *kid = (SVOP*)cUNOPo->op_first;
5176
5177     o->op_private |= (PL_hints & HINT_STRICT_REFS);
5178     if (kid->op_type == OP_CONST) {
5179         int iscv;
5180         GV *gv;
5181         SV *kidsv = kid->op_sv;
5182
5183         /* Is it a constant from cv_const_sv()? */
5184         if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5185             SV *rsv = SvRV(kidsv);
5186             int svtype = SvTYPE(rsv);
5187             const char *badtype = Nullch;
5188
5189             switch (o->op_type) {
5190             case OP_RV2SV:
5191                 if (svtype > SVt_PVMG)
5192                     badtype = "a SCALAR";
5193                 break;
5194             case OP_RV2AV:
5195                 if (svtype != SVt_PVAV)
5196                     badtype = "an ARRAY";
5197                 break;
5198             case OP_RV2HV:
5199                 if (svtype != SVt_PVHV)
5200                     badtype = "a HASH";
5201                 break;
5202             case OP_RV2CV:
5203                 if (svtype != SVt_PVCV)
5204                     badtype = "a CODE";
5205                 break;
5206             }
5207             if (badtype)
5208                 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5209             return o;
5210         }
5211         if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5212             const char *badthing = Nullch;
5213             switch (o->op_type) {
5214             case OP_RV2SV:
5215                 badthing = "a SCALAR";
5216                 break;
5217             case OP_RV2AV:
5218                 badthing = "an ARRAY";
5219                 break;
5220             case OP_RV2HV:
5221                 badthing = "a HASH";
5222                 break;
5223             }
5224             if (badthing)
5225                 Perl_croak(aTHX_
5226           "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
5227                       kidsv, badthing);
5228         }
5229         /*
5230          * This is a little tricky.  We only want to add the symbol if we
5231          * didn't add it in the lexer.  Otherwise we get duplicate strict
5232          * warnings.  But if we didn't add it in the lexer, we must at
5233          * least pretend like we wanted to add it even if it existed before,
5234          * or we get possible typo warnings.  OPpCONST_ENTERED says
5235          * whether the lexer already added THIS instance of this symbol.
5236          */
5237         iscv = (o->op_type == OP_RV2CV) * 2;
5238         do {
5239             gv = gv_fetchsv(kidsv,
5240                 iscv | !(kid->op_private & OPpCONST_ENTERED),
5241                 iscv
5242                     ? SVt_PVCV
5243                     : o->op_type == OP_RV2SV
5244                         ? SVt_PV
5245                         : o->op_type == OP_RV2AV
5246                             ? SVt_PVAV
5247                             : o->op_type == OP_RV2HV
5248                                 ? SVt_PVHV
5249                                 : SVt_PVGV);
5250         } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5251         if (gv) {
5252             kid->op_type = OP_GV;
5253             SvREFCNT_dec(kid->op_sv);
5254 #ifdef USE_ITHREADS
5255             /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5256             kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5257             SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
5258             GvIN_PAD_on(gv);
5259             PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc(gv));
5260 #else
5261             kid->op_sv = SvREFCNT_inc(gv);
5262 #endif
5263             kid->op_private = 0;
5264             kid->op_ppaddr = PL_ppaddr[OP_GV];
5265         }
5266     }
5267     return o;
5268 }
5269
5270 OP *
5271 Perl_ck_ftst(pTHX_ OP *o)
5272 {
5273     dVAR;
5274     const I32 type = o->op_type;
5275
5276     if (o->op_flags & OPf_REF) {
5277         /* nothing */
5278     }
5279     else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5280         SVOP *kid = (SVOP*)cUNOPo->op_first;
5281
5282         if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5283             OP *newop = newGVOP(type, OPf_REF,
5284                 gv_fetchsv(kid->op_sv, TRUE, SVt_PVIO));
5285             op_free(o);
5286             o = newop;
5287             return o;
5288         }
5289         else {
5290           if ((PL_hints & HINT_FILETEST_ACCESS) &&
5291               OP_IS_FILETEST_ACCESS(o))
5292             o->op_private |= OPpFT_ACCESS;
5293         }
5294         if (PL_check[kid->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst)
5295                 && kid->op_type != OP_STAT && kid->op_type != OP_LSTAT)
5296             o->op_private |= OPpFT_STACKED;
5297     }
5298     else {
5299         op_free(o);
5300         if (type == OP_FTTTY)
5301             o = newGVOP(type, OPf_REF, PL_stdingv);
5302         else
5303             o = newUNOP(type, 0, newDEFSVOP());
5304     }
5305     return o;
5306 }
5307
5308 OP *
5309 Perl_ck_fun(pTHX_ OP *o)
5310 {
5311     const int type = o->op_type;
5312     register I32 oa = PL_opargs[type] >> OASHIFT;
5313
5314     if (o->op_flags & OPf_STACKED) {
5315         if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5316             oa &= ~OA_OPTIONAL;
5317         else
5318             return no_fh_allowed(o);
5319     }
5320
5321     if (o->op_flags & OPf_KIDS) {
5322         OP **tokid = &cLISTOPo->op_first;
5323         register OP *kid = cLISTOPo->op_first;
5324         OP *sibl;
5325         I32 numargs = 0;
5326
5327         if (kid->op_type == OP_PUSHMARK ||
5328             (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5329         {
5330             tokid = &kid->op_sibling;
5331             kid = kid->op_sibling;
5332         }
5333         if (!kid && PL_opargs[type] & OA_DEFGV)
5334             *tokid = kid = newDEFSVOP();
5335
5336         while (oa && kid) {
5337             numargs++;
5338             sibl = kid->op_sibling;
5339             switch (oa & 7) {
5340             case OA_SCALAR:
5341                 /* list seen where single (scalar) arg expected? */
5342                 if (numargs == 1 && !(oa >> 4)
5343                     && kid->op_type == OP_LIST && type != OP_SCALAR)
5344                 {
5345                     return too_many_arguments(o,PL_op_desc[type]);
5346                 }
5347                 scalar(kid);
5348                 break;
5349             case OA_LIST:
5350                 if (oa < 16) {
5351                     kid = 0;
5352                     continue;
5353                 }
5354                 else
5355                     list(kid);
5356                 break;
5357             case OA_AVREF:
5358                 if ((type == OP_PUSH || type == OP_UNSHIFT)
5359                     && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5360                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5361                         "Useless use of %s with no values",
5362                         PL_op_desc[type]);
5363
5364                 if (kid->op_type == OP_CONST &&
5365                     (kid->op_private & OPpCONST_BARE))
5366                 {
5367                     OP *newop = newAVREF(newGVOP(OP_GV, 0,
5368                         gv_fetchsv(((SVOP*)kid)->op_sv, TRUE, SVt_PVAV) ));
5369                     if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5370                         Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5371                             "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
5372                             ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
5373                     op_free(kid);
5374                     kid = newop;
5375                     kid->op_sibling = sibl;
5376                     *tokid = kid;
5377                 }
5378                 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5379                     bad_type(numargs, "array", PL_op_desc[type], kid);
5380                 mod(kid, type);
5381                 break;
5382             case OA_HVREF:
5383                 if (kid->op_type == OP_CONST &&
5384                     (kid->op_private & OPpCONST_BARE))
5385                 {
5386                     OP *newop = newHVREF(newGVOP(OP_GV, 0,
5387                         gv_fetchsv(((SVOP*)kid)->op_sv, TRUE, SVt_PVHV) ));
5388                     if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5389                         Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5390                             "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
5391                             ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
5392                     op_free(kid);
5393                     kid = newop;
5394                     kid->op_sibling = sibl;
5395                     *tokid = kid;
5396                 }
5397                 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5398                     bad_type(numargs, "hash", PL_op_desc[type], kid);
5399                 mod(kid, type);
5400                 break;
5401             case OA_CVREF:
5402                 {
5403                     OP *newop = newUNOP(OP_NULL, 0, kid);
5404                     kid->op_sibling = 0;
5405                     linklist(kid);
5406                     newop->op_next = newop;
5407                     kid = newop;
5408                     kid->op_sibling = sibl;
5409                     *tokid = kid;
5410                 }
5411                 break;
5412             case OA_FILEREF:
5413                 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5414                     if (kid->op_type == OP_CONST &&
5415                         (kid->op_private & OPpCONST_BARE))
5416                     {
5417                         OP *newop = newGVOP(OP_GV, 0,
5418                             gv_fetchsv(((SVOP*)kid)->op_sv, TRUE, SVt_PVIO) );
5419                         if (!(o->op_private & 1) && /* if not unop */
5420                             kid == cLISTOPo->op_last)
5421                             cLISTOPo->op_last = newop;
5422                         op_free(kid);
5423                         kid = newop;
5424                     }
5425                     else if (kid->op_type == OP_READLINE) {
5426                         /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5427                         bad_type(numargs, "HANDLE", OP_DESC(o), kid);
5428                     }
5429                     else {
5430                         I32 flags = OPf_SPECIAL;
5431                         I32 priv = 0;
5432                         PADOFFSET targ = 0;
5433
5434                         /* is this op a FH constructor? */
5435                         if (is_handle_constructor(o,numargs)) {
5436                             const char *name = Nullch;
5437                             STRLEN len = 0;
5438
5439                             flags = 0;
5440                             /* Set a flag to tell rv2gv to vivify
5441                              * need to "prove" flag does not mean something
5442                              * else already - NI-S 1999/05/07
5443                              */
5444                             priv = OPpDEREF;
5445                             if (kid->op_type == OP_PADSV) {
5446                                 name = PAD_COMPNAME_PV(kid->op_targ);
5447                                 /* SvCUR of a pad namesv can't be trusted
5448                                  * (see PL_generation), so calc its length
5449                                  * manually */
5450                                 if (name)
5451                                     len = strlen(name);
5452
5453                             }
5454                             else if (kid->op_type == OP_RV2SV
5455                                      && kUNOP->op_first->op_type == OP_GV)
5456                             {
5457                                 GV *gv = cGVOPx_gv(kUNOP->op_first);
5458                                 name = GvNAME(gv);
5459                                 len = GvNAMELEN(gv);
5460                             }
5461                             else if (kid->op_type == OP_AELEM
5462                                      || kid->op_type == OP_HELEM)
5463                             {
5464                                  OP *op;
5465
5466                                  name = 0;
5467                                  if ((op = ((BINOP*)kid)->op_first)) {
5468                                       SV *tmpstr = Nullsv;
5469                                       const char *a =
5470                                            kid->op_type == OP_AELEM ?
5471                                            "[]" : "{}";
5472                                       if (((op->op_type == OP_RV2AV) ||
5473                                            (op->op_type == OP_RV2HV)) &&
5474                                           (op = ((UNOP*)op)->op_first) &&
5475                                           (op->op_type == OP_GV)) {
5476                                            /* packagevar $a[] or $h{} */
5477                                            GV *gv = cGVOPx_gv(op);
5478                                            if (gv)
5479                                                 tmpstr =
5480                                                      Perl_newSVpvf(aTHX_
5481                                                                    "%s%c...%c",
5482                                                                    GvNAME(gv),
5483                                                                    a[0], a[1]);
5484                                       }
5485                                       else if (op->op_type == OP_PADAV
5486                                                || op->op_type == OP_PADHV) {
5487                                            /* lexicalvar $a[] or $h{} */
5488                                            const char *padname =
5489                                                 PAD_COMPNAME_PV(op->op_targ);
5490                                            if (padname)
5491                                                 tmpstr =
5492                                                      Perl_newSVpvf(aTHX_
5493                                                                    "%s%c...%c",
5494                                                                    padname + 1,
5495                                                                    a[0], a[1]);
5496
5497                                       }
5498                                       if (tmpstr) {
5499                                            name = SvPV(tmpstr, len);
5500                                            sv_2mortal(tmpstr);
5501                                       }
5502                                  }
5503                                  if (!name) {
5504                                       name = "__ANONIO__";
5505                                       len = 10;
5506                                  }
5507                                  mod(kid, type);
5508                             }
5509                             if (name) {
5510                                 SV *namesv;
5511                                 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5512                                 namesv = PAD_SVl(targ);
5513                                 (void)SvUPGRADE(namesv, SVt_PV);
5514                                 if (*name != '$')
5515                                     sv_setpvn(namesv, "$", 1);
5516                                 sv_catpvn(namesv, name, len);
5517                             }
5518                         }
5519                         kid->op_sibling = 0;
5520                         kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5521                         kid->op_targ = targ;
5522                         kid->op_private |= priv;
5523                     }
5524                     kid->op_sibling = sibl;
5525                     *tokid = kid;
5526                 }
5527                 scalar(kid);
5528                 break;
5529             case OA_SCALARREF:
5530                 mod(scalar(kid), type);
5531                 break;
5532             }
5533             oa >>= 4;
5534             tokid = &kid->op_sibling;
5535             kid = kid->op_sibling;
5536         }
5537         o->op_private |= numargs;
5538         if (kid)
5539             return too_many_arguments(o,OP_DESC(o));
5540         listkids(o);
5541     }
5542     else if (PL_opargs[type] & OA_DEFGV) {
5543         op_free(o);
5544         return newUNOP(type, 0, newDEFSVOP());
5545     }
5546
5547     if (oa) {
5548         while (oa & OA_OPTIONAL)
5549             oa >>= 4;
5550         if (oa && oa != OA_LIST)
5551             return too_few_arguments(o,OP_DESC(o));
5552     }
5553     return o;
5554 }
5555
5556 OP *
5557 Perl_ck_glob(pTHX_ OP *o)
5558 {
5559     dVAR;
5560     GV *gv;
5561
5562     o = ck_fun(o);
5563     if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5564         append_elem(OP_GLOB, o, newDEFSVOP());
5565
5566     if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV))
5567           && GvCVu(gv) && GvIMPORTED_CV(gv)))
5568     {
5569         gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5570     }
5571
5572 #if !defined(PERL_EXTERNAL_GLOB)
5573     /* XXX this can be tightened up and made more failsafe. */
5574     if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
5575         GV *glob_gv;
5576         ENTER;
5577         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
5578                 newSVpvn("File::Glob", 10), Nullsv, Nullsv, Nullsv);
5579         gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5580         glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
5581         GvCV(gv) = GvCV(glob_gv);
5582         (void)SvREFCNT_inc((SV*)GvCV(gv));
5583         GvIMPORTED_CV_on(gv);
5584         LEAVE;
5585     }
5586 #endif /* PERL_EXTERNAL_GLOB */
5587
5588     if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5589         append_elem(OP_GLOB, o,
5590                     newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5591         o->op_type = OP_LIST;
5592         o->op_ppaddr = PL_ppaddr[OP_LIST];
5593         cLISTOPo->op_first->op_type = OP_PUSHMARK;
5594         cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5595         cLISTOPo->op_first->op_targ = 0;
5596         o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5597                     append_elem(OP_LIST, o,
5598                                 scalar(newUNOP(OP_RV2CV, 0,
5599                                                newGVOP(OP_GV, 0, gv)))));
5600         o = newUNOP(OP_NULL, 0, ck_subr(o));
5601         o->op_targ = OP_GLOB;           /* hint at what it used to be */
5602         return o;
5603     }
5604     gv = newGVgen("main");
5605     gv_IOadd(gv);
5606     append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5607     scalarkids(o);
5608     return o;
5609 }
5610
5611 OP *
5612 Perl_ck_grep(pTHX_ OP *o)
5613 {
5614     dVAR;
5615     LOGOP *gwop;
5616     OP *kid;
5617     const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5618     I32 offset;
5619
5620     o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5621     NewOp(1101, gwop, 1, LOGOP);
5622
5623     if (o->op_flags & OPf_STACKED) {
5624         OP* k;
5625         o = ck_sort(o);
5626         kid = cLISTOPo->op_first->op_sibling;
5627         if (!cUNOPx(kid)->op_next)
5628             Perl_croak(aTHX_ "panic: ck_grep");
5629         for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
5630             kid = k;
5631         }
5632         kid->op_next = (OP*)gwop;
5633         o->op_flags &= ~OPf_STACKED;
5634     }
5635     kid = cLISTOPo->op_first->op_sibling;
5636     if (type == OP_MAPWHILE)
5637         list(kid);
5638     else
5639         scalar(kid);
5640     o = ck_fun(o);
5641     if (PL_error_count)
5642         return o;
5643     kid = cLISTOPo->op_first->op_sibling;
5644     if (kid->op_type != OP_NULL)
5645         Perl_croak(aTHX_ "panic: ck_grep");
5646     kid = kUNOP->op_first;
5647
5648     gwop->op_type = type;
5649     gwop->op_ppaddr = PL_ppaddr[type];
5650     gwop->op_first = listkids(o);
5651     gwop->op_flags |= OPf_KIDS;
5652     gwop->op_other = LINKLIST(kid);
5653     kid->op_next = (OP*)gwop;
5654     offset = pad_findmy("$_");
5655     if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
5656         o->op_private = gwop->op_private = 0;
5657         gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5658     }
5659     else {
5660         o->op_private = gwop->op_private = OPpGREP_LEX;
5661         gwop->op_targ = o->op_targ = offset;
5662     }
5663
5664     kid = cLISTOPo->op_first->op_sibling;
5665     if (!kid || !kid->op_sibling)
5666         return too_few_arguments(o,OP_DESC(o));
5667     for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5668         mod(kid, OP_GREPSTART);
5669
5670     return (OP*)gwop;
5671 }
5672
5673 OP *
5674 Perl_ck_index(pTHX_ OP *o)
5675 {
5676     if (o->op_flags & OPf_KIDS) {
5677         OP *kid = cLISTOPo->op_first->op_sibling;       /* get past pushmark */
5678         if (kid)
5679             kid = kid->op_sibling;                      /* get past "big" */
5680         if (kid && kid->op_type == OP_CONST)
5681             fbm_compile(((SVOP*)kid)->op_sv, 0);
5682     }
5683     return ck_fun(o);
5684 }
5685
5686 OP *
5687 Perl_ck_lengthconst(pTHX_ OP *o)
5688 {
5689     /* XXX length optimization goes here */
5690     return ck_fun(o);
5691 }
5692
5693 OP *
5694 Perl_ck_lfun(pTHX_ OP *o)
5695 {
5696     const OPCODE type = o->op_type;
5697     return modkids(ck_fun(o), type);
5698 }
5699
5700 OP *
5701 Perl_ck_defined(pTHX_ OP *o)            /* 19990527 MJD */
5702 {
5703     if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
5704         switch (cUNOPo->op_first->op_type) {
5705         case OP_RV2AV:
5706             /* This is needed for
5707                if (defined %stash::)
5708                to work.   Do not break Tk.
5709                */
5710             break;                      /* Globals via GV can be undef */
5711         case OP_PADAV:
5712         case OP_AASSIGN:                /* Is this a good idea? */
5713             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5714                         "defined(@array) is deprecated");
5715             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5716                         "\t(Maybe you should just omit the defined()?)\n");
5717         break;
5718         case OP_RV2HV:
5719             /* This is needed for
5720                if (defined %stash::)
5721                to work.   Do not break Tk.
5722                */
5723             break;                      /* Globals via GV can be undef */
5724         case OP_PADHV:
5725             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5726                         "defined(%%hash) is deprecated");
5727             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5728                         "\t(Maybe you should just omit the defined()?)\n");
5729             break;
5730         default:
5731             /* no warning */
5732             break;
5733         }
5734     }
5735     return ck_rfun(o);
5736 }
5737
5738 OP *
5739 Perl_ck_rfun(pTHX_ OP *o)
5740 {
5741     const OPCODE type = o->op_type;
5742     return refkids(ck_fun(o), type);
5743 }
5744
5745 OP *
5746 Perl_ck_listiob(pTHX_ OP *o)
5747 {
5748     register OP *kid;
5749
5750     kid = cLISTOPo->op_first;
5751     if (!kid) {
5752         o = force_list(o);
5753         kid = cLISTOPo->op_first;
5754     }
5755     if (kid->op_type == OP_PUSHMARK)
5756         kid = kid->op_sibling;
5757     if (kid && o->op_flags & OPf_STACKED)
5758         kid = kid->op_sibling;
5759     else if (kid && !kid->op_sibling) {         /* print HANDLE; */
5760         if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
5761             o->op_flags |= OPf_STACKED; /* make it a filehandle */
5762             kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
5763             cLISTOPo->op_first->op_sibling = kid;
5764             cLISTOPo->op_last = kid;
5765             kid = kid->op_sibling;
5766         }
5767     }
5768
5769     if (!kid)
5770         append_elem(o->op_type, o, newDEFSVOP());
5771
5772     return listkids(o);
5773 }
5774
5775 OP *
5776 Perl_ck_sassign(pTHX_ OP *o)
5777 {
5778     OP *kid = cLISTOPo->op_first;
5779     /* has a disposable target? */
5780     if ((PL_opargs[kid->op_type] & OA_TARGLEX)
5781         && !(kid->op_flags & OPf_STACKED)
5782         /* Cannot steal the second time! */
5783         && !(kid->op_private & OPpTARGET_MY))
5784     {
5785         OP *kkid = kid->op_sibling;
5786
5787         /* Can just relocate the target. */
5788         if (kkid && kkid->op_type == OP_PADSV
5789             && !(kkid->op_private & OPpLVAL_INTRO))
5790         {
5791             kid->op_targ = kkid->op_targ;
5792             kkid->op_targ = 0;
5793             /* Now we do not need PADSV and SASSIGN. */
5794             kid->op_sibling = o->op_sibling;    /* NULL */
5795             cLISTOPo->op_first = NULL;
5796             op_free(o);
5797             op_free(kkid);
5798             kid->op_private |= OPpTARGET_MY;    /* Used for context settings */
5799             return kid;
5800         }
5801     }
5802     /* optimise C<my $x = undef> to C<my $x> */
5803     if (kid->op_type == OP_UNDEF) {
5804         OP *kkid = kid->op_sibling;
5805         if (kkid && kkid->op_type == OP_PADSV
5806                 && (kkid->op_private & OPpLVAL_INTRO))
5807         {
5808             cLISTOPo->op_first = NULL;
5809             kid->op_sibling = NULL;
5810             op_free(o);
5811             op_free(kid);
5812             return kkid;
5813         }
5814     }
5815     return o;
5816 }
5817
5818 OP *
5819 Perl_ck_match(pTHX_ OP *o)
5820 {
5821     if (o->op_type != OP_QR) {
5822         const I32 offset = pad_findmy("$_");
5823         if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS(offset) & SVpad_OUR)) {
5824             o->op_targ = offset;
5825             o->op_private |= OPpTARGET_MY;
5826         }
5827     }
5828     if (o->op_type == OP_MATCH || o->op_type == OP_QR)
5829         o->op_private |= OPpRUNTIME;
5830     return o;
5831 }
5832
5833 OP *
5834 Perl_ck_method(pTHX_ OP *o)
5835 {
5836     OP *kid = cUNOPo->op_first;
5837     if (kid->op_type == OP_CONST) {
5838         SV* sv = kSVOP->op_sv;
5839         if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
5840             OP *cmop;
5841             if (!SvREADONLY(sv) || !SvFAKE(sv)) {
5842                 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
5843             }
5844             else {
5845                 kSVOP->op_sv = Nullsv;
5846             }
5847             cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
5848             op_free(o);
5849             return cmop;
5850         }
5851     }
5852     return o;
5853 }
5854
5855 OP *
5856 Perl_ck_null(pTHX_ OP *o)
5857 {
5858     return o;
5859 }
5860
5861 OP *
5862 Perl_ck_open(pTHX_ OP *o)
5863 {
5864     HV *table = GvHV(PL_hintgv);
5865     if (table) {
5866         SV **svp;
5867         I32 mode;
5868         svp = hv_fetch(table, "open_IN", 7, FALSE);
5869         if (svp && *svp) {
5870             mode = mode_from_discipline(*svp);
5871             if (mode & O_BINARY)
5872                 o->op_private |= OPpOPEN_IN_RAW;
5873             else if (mode & O_TEXT)
5874                 o->op_private |= OPpOPEN_IN_CRLF;
5875         }
5876
5877         svp = hv_fetch(table, "open_OUT", 8, FALSE);
5878         if (svp && *svp) {
5879             mode = mode_from_discipline(*svp);
5880             if (mode & O_BINARY)
5881                 o->op_private |= OPpOPEN_OUT_RAW;
5882             else if (mode & O_TEXT)
5883                 o->op_private |= OPpOPEN_OUT_CRLF;
5884         }
5885     }
5886     if (o->op_type == OP_BACKTICK)
5887         return o;
5888     {
5889          /* In case of three-arg dup open remove strictness
5890           * from the last arg if it is a bareword. */
5891          OP *first = cLISTOPx(o)->op_first; /* The pushmark. */
5892          OP *last  = cLISTOPx(o)->op_last;  /* The bareword. */
5893          OP *oa;
5894          char *mode;
5895
5896          if ((last->op_type == OP_CONST) &&             /* The bareword. */
5897              (last->op_private & OPpCONST_BARE) &&
5898              (last->op_private & OPpCONST_STRICT) &&
5899              (oa = first->op_sibling) &&                /* The fh. */
5900              (oa = oa->op_sibling) &&                   /* The mode. */
5901              SvPOK(((SVOP*)oa)->op_sv) &&
5902              (mode = SvPVX(((SVOP*)oa)->op_sv)) &&
5903              mode[0] == '>' && mode[1] == '&' &&        /* A dup open. */
5904              (last == oa->op_sibling))                  /* The bareword. */
5905               last->op_private &= ~OPpCONST_STRICT;
5906     }
5907     return ck_fun(o);
5908 }
5909
5910 OP *
5911 Perl_ck_repeat(pTHX_ OP *o)
5912 {
5913     if (cBINOPo->op_first->op_flags & OPf_PARENS) {
5914         o->op_private |= OPpREPEAT_DOLIST;
5915         cBINOPo->op_first = force_list(cBINOPo->op_first);
5916     }
5917     else
5918         scalar(o);
5919     return o;
5920 }
5921
5922 OP *
5923 Perl_ck_require(pTHX_ OP *o)
5924 {
5925     GV* gv;
5926
5927     if (o->op_flags & OPf_KIDS) {       /* Shall we supply missing .pm? */
5928         SVOP *kid = (SVOP*)cUNOPo->op_first;
5929
5930         if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5931             char *s;
5932             for (s = SvPVX(kid->op_sv); *s; s++) {
5933                 if (*s == ':' && s[1] == ':') {
5934                     *s = '/';
5935                     Move(s+2, s+1, strlen(s+2)+1, char);
5936                     SvCUR_set(kid->op_sv, SvCUR(kid->op_sv) - 1);
5937                 }
5938             }
5939             if (SvREADONLY(kid->op_sv)) {
5940                 SvREADONLY_off(kid->op_sv);
5941                 sv_catpvn(kid->op_sv, ".pm", 3);
5942                 SvREADONLY_on(kid->op_sv);
5943             }
5944             else
5945                 sv_catpvn(kid->op_sv, ".pm", 3);
5946         }
5947     }
5948
5949     /* handle override, if any */
5950     gv = gv_fetchpv("require", FALSE, SVt_PVCV);
5951     if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
5952         gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
5953
5954     if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5955         OP *kid = cUNOPo->op_first;
5956         cUNOPo->op_first = 0;
5957         op_free(o);
5958         return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
5959                                append_elem(OP_LIST, kid,
5960                                            scalar(newUNOP(OP_RV2CV, 0,
5961                                                           newGVOP(OP_GV, 0,
5962                                                                   gv))))));
5963     }
5964
5965     return ck_fun(o);
5966 }
5967
5968 OP *
5969 Perl_ck_return(pTHX_ OP *o)
5970 {
5971     if (CvLVALUE(PL_compcv)) {
5972         OP *kid;
5973         for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
5974             mod(kid, OP_LEAVESUBLV);
5975     }
5976     return o;
5977 }
5978
5979 #if 0
5980 OP *
5981 Perl_ck_retarget(pTHX_ OP *o)
5982 {
5983     Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5984     /* STUB */
5985     return o;
5986 }
5987 #endif
5988
5989 OP *
5990 Perl_ck_select(pTHX_ OP *o)
5991 {
5992     dVAR;
5993     OP* kid;
5994     if (o->op_flags & OPf_KIDS) {
5995         kid = cLISTOPo->op_first->op_sibling;   /* get past pushmark */
5996         if (kid && kid->op_sibling) {
5997             o->op_type = OP_SSELECT;
5998             o->op_ppaddr = PL_ppaddr[OP_SSELECT];
5999             o = ck_fun(o);
6000             return fold_constants(o);
6001         }
6002     }
6003     o = ck_fun(o);
6004     kid = cLISTOPo->op_first->op_sibling;    /* get past pushmark */
6005     if (kid && kid->op_type == OP_RV2GV)
6006         kid->op_private &= ~HINT_STRICT_REFS;
6007     return o;
6008 }
6009
6010 OP *
6011 Perl_ck_shift(pTHX_ OP *o)
6012 {
6013     const I32 type = o->op_type;
6014
6015     if (!(o->op_flags & OPf_KIDS)) {
6016         OP *argop;
6017
6018         op_free(o);
6019         argop = newUNOP(OP_RV2AV, 0,
6020             scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
6021         return newUNOP(type, 0, scalar(argop));
6022     }
6023     return scalar(modkids(ck_fun(o), type));
6024 }
6025
6026 OP *
6027 Perl_ck_sort(pTHX_ OP *o)
6028 {
6029     OP *firstkid;
6030
6031     if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6032         simplify_sort(o);
6033     firstkid = cLISTOPo->op_first->op_sibling;          /* get past pushmark */
6034     if (o->op_flags & OPf_STACKED) {                    /* may have been cleared */
6035         OP *k = NULL;
6036         OP *kid = cUNOPx(firstkid)->op_first;           /* get past null */
6037
6038         if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
6039             linklist(kid);
6040             if (kid->op_type == OP_SCOPE) {
6041                 k = kid->op_next;
6042                 kid->op_next = 0;
6043             }
6044             else if (kid->op_type == OP_LEAVE) {
6045                 if (o->op_type == OP_SORT) {
6046                     op_null(kid);                       /* wipe out leave */
6047                     kid->op_next = kid;
6048
6049                     for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6050                         if (k->op_next == kid)
6051                             k->op_next = 0;
6052                         /* don't descend into loops */
6053                         else if (k->op_type == OP_ENTERLOOP
6054                                  || k->op_type == OP_ENTERITER)
6055                         {
6056                             k = cLOOPx(k)->op_lastop;
6057                         }
6058                     }
6059                 }
6060                 else
6061                     kid->op_next = 0;           /* just disconnect the leave */
6062                 k = kLISTOP->op_first;
6063             }
6064             CALL_PEEP(k);
6065
6066             kid = firstkid;
6067             if (o->op_type == OP_SORT) {
6068                 /* provide scalar context for comparison function/block */
6069                 kid = scalar(kid);
6070                 kid->op_next = kid;
6071             }
6072             else
6073                 kid->op_next = k;
6074             o->op_flags |= OPf_SPECIAL;
6075         }
6076         else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6077             op_null(firstkid);
6078
6079         firstkid = firstkid->op_sibling;
6080     }
6081
6082     /* provide list context for arguments */
6083     if (o->op_type == OP_SORT)
6084         list(firstkid);
6085
6086     return o;
6087 }
6088
6089 STATIC void
6090 S_simplify_sort(pTHX_ OP *o)
6091 {
6092     register OP *kid = cLISTOPo->op_first->op_sibling;  /* get past pushmark */
6093     OP *k;
6094     int descending;
6095     GV *gv;
6096     const char *gvname;
6097     if (!(o->op_flags & OPf_STACKED))
6098         return;
6099     GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
6100     GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
6101     kid = kUNOP->op_first;                              /* get past null */
6102     if (kid->op_type != OP_SCOPE)
6103         return;
6104     kid = kLISTOP->op_last;                             /* get past scope */
6105     switch(kid->op_type) {
6106         case OP_NCMP:
6107         case OP_I_NCMP:
6108         case OP_SCMP:
6109             break;
6110         default:
6111             return;
6112     }
6113     k = kid;                                            /* remember this node*/
6114     if (kBINOP->op_first->op_type != OP_RV2SV)
6115         return;
6116     kid = kBINOP->op_first;                             /* get past cmp */
6117     if (kUNOP->op_first->op_type != OP_GV)
6118         return;
6119     kid = kUNOP->op_first;                              /* get past rv2sv */
6120     gv = kGVOP_gv;
6121     if (GvSTASH(gv) != PL_curstash)
6122         return;
6123     gvname = GvNAME(gv);
6124     if (*gvname == 'a' && gvname[1] == '\0')
6125         descending = 0;
6126     else if (*gvname == 'b' && gvname[1] == '\0')
6127         descending = 1;
6128     else
6129         return;
6130
6131     kid = k;                                            /* back to cmp */
6132     if (kBINOP->op_last->op_type != OP_RV2SV)
6133         return;
6134     kid = kBINOP->op_last;                              /* down to 2nd arg */
6135     if (kUNOP->op_first->op_type != OP_GV)
6136         return;
6137     kid = kUNOP->op_first;                              /* get past rv2sv */
6138     gv = kGVOP_gv;
6139     if (GvSTASH(gv) != PL_curstash)
6140         return;
6141     gvname = GvNAME(gv);
6142     if ( descending
6143          ? !(*gvname == 'a' && gvname[1] == '\0')
6144          : !(*gvname == 'b' && gvname[1] == '\0'))
6145         return;
6146     o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6147     if (descending)
6148         o->op_private |= OPpSORT_DESCEND;
6149     if (k->op_type == OP_NCMP)
6150         o->op_private |= OPpSORT_NUMERIC;
6151     if (k->op_type == OP_I_NCMP)
6152         o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6153     kid = cLISTOPo->op_first->op_sibling;
6154     cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6155     op_free(kid);                                     /* then delete it */
6156 }
6157
6158 OP *
6159 Perl_ck_split(pTHX_ OP *o)
6160 {
6161     dVAR;
6162     register OP *kid;
6163
6164     if (o->op_flags & OPf_STACKED)
6165         return no_fh_allowed(o);
6166
6167     kid = cLISTOPo->op_first;
6168     if (kid->op_type != OP_NULL)
6169         Perl_croak(aTHX_ "panic: ck_split");
6170     kid = kid->op_sibling;
6171     op_free(cLISTOPo->op_first);
6172     cLISTOPo->op_first = kid;
6173     if (!kid) {
6174         cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
6175         cLISTOPo->op_last = kid; /* There was only one element previously */
6176     }
6177
6178     if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6179         OP *sibl = kid->op_sibling;
6180         kid->op_sibling = 0;
6181         kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
6182         if (cLISTOPo->op_first == cLISTOPo->op_last)
6183             cLISTOPo->op_last = kid;
6184         cLISTOPo->op_first = kid;
6185         kid->op_sibling = sibl;
6186     }
6187
6188     kid->op_type = OP_PUSHRE;
6189     kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6190     scalar(kid);
6191     if (ckWARN(WARN_REGEXP) && ((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
6192       Perl_warner(aTHX_ packWARN(WARN_REGEXP),
6193                   "Use of /g modifier is meaningless in split");
6194     }
6195
6196     if (!kid->op_sibling)
6197         append_elem(OP_SPLIT, o, newDEFSVOP());
6198
6199     kid = kid->op_sibling;
6200     scalar(kid);
6201
6202     if (!kid->op_sibling)
6203         append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6204
6205     kid = kid->op_sibling;
6206     scalar(kid);
6207
6208     if (kid->op_sibling)
6209         return too_many_arguments(o,OP_DESC(o));
6210
6211     return o;
6212 }
6213
6214 OP *
6215 Perl_ck_join(pTHX_ OP *o)
6216 {
6217     if (ckWARN(WARN_SYNTAX)) {
6218         const OP *kid = cLISTOPo->op_first->op_sibling;
6219         if (kid && kid->op_type == OP_MATCH) {
6220             const REGEXP *re = PM_GETRE(kPMOP);
6221             const char *pmstr = re ? re->precomp : "STRING";
6222             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6223                         "/%s/ should probably be written as \"%s\"",
6224                         pmstr, pmstr);
6225         }
6226     }
6227     return ck_fun(o);
6228 }
6229
6230 OP *
6231 Perl_ck_subr(pTHX_ OP *o)
6232 {
6233     OP *prev = ((cUNOPo->op_first->op_sibling)
6234              ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6235     OP *o2 = prev->op_sibling;
6236     OP *cvop;
6237     char *proto = 0;
6238     CV *cv = 0;
6239     GV *namegv = 0;
6240     int optional = 0;
6241     I32 arg = 0;
6242     I32 contextclass = 0;
6243     char *e = 0;
6244     STRLEN n_a;
6245     bool delete_op = 0;
6246
6247     o->op_private |= OPpENTERSUB_HASTARG;
6248     for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6249     if (cvop->op_type == OP_RV2CV) {
6250         SVOP* tmpop;
6251         o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6252         op_null(cvop);          /* disable rv2cv */
6253         tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6254         if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6255             GV *gv = cGVOPx_gv(tmpop);
6256             cv = GvCVu(gv);
6257             if (!cv)
6258                 tmpop->op_private |= OPpEARLY_CV;
6259             else {
6260                 if (SvPOK(cv)) {
6261                     namegv = CvANON(cv) ? gv : CvGV(cv);
6262                     proto = SvPV((SV*)cv, n_a);
6263                 }
6264                 if (CvASSERTION(cv)) {
6265                     if (PL_hints & HINT_ASSERTING) {
6266                         if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
6267                             o->op_private |= OPpENTERSUB_DB;
6268                     }
6269                     else {
6270                         delete_op = 1;
6271                         if (ckWARN(WARN_ASSERTIONS) && !(PL_hints & HINT_ASSERTIONSSEEN)) {
6272                             Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
6273                                         "Impossible to activate assertion call");
6274                         }
6275                     }
6276                 }
6277             }
6278         }
6279     }
6280     else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6281         if (o2->op_type == OP_CONST)
6282             o2->op_private &= ~OPpCONST_STRICT;
6283         else if (o2->op_type == OP_LIST) {
6284             OP *o = ((UNOP*)o2)->op_first->op_sibling;
6285             if (o && o->op_type == OP_CONST)
6286                 o->op_private &= ~OPpCONST_STRICT;
6287         }
6288     }
6289     o->op_private |= (PL_hints & HINT_STRICT_REFS);
6290     if (PERLDB_SUB && PL_curstash != PL_debstash)
6291         o->op_private |= OPpENTERSUB_DB;
6292     while (o2 != cvop) {
6293         if (proto) {
6294             switch (*proto) {
6295             case '\0':
6296                 return too_many_arguments(o, gv_ename(namegv));
6297             case ';':
6298                 optional = 1;
6299                 proto++;
6300                 continue;
6301             case '$':
6302                 proto++;
6303                 arg++;
6304                 scalar(o2);
6305                 break;
6306             case '%':
6307             case '@':
6308                 list(o2);
6309                 arg++;
6310                 break;
6311             case '&':
6312                 proto++;
6313                 arg++;
6314                 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6315                     bad_type(arg,
6316                         arg == 1 ? "block or sub {}" : "sub {}",
6317                         gv_ename(namegv), o2);
6318                 break;
6319             case '*':
6320                 /* '*' allows any scalar type, including bareword */
6321                 proto++;
6322                 arg++;
6323                 if (o2->op_type == OP_RV2GV)
6324                     goto wrapref;       /* autoconvert GLOB -> GLOBref */
6325                 else if (o2->op_type == OP_CONST)
6326                     o2->op_private &= ~OPpCONST_STRICT;
6327                 else if (o2->op_type == OP_ENTERSUB) {
6328                     /* accidental subroutine, revert to bareword */
6329                     OP *gvop = ((UNOP*)o2)->op_first;
6330                     if (gvop && gvop->op_type == OP_NULL) {
6331                         gvop = ((UNOP*)gvop)->op_first;
6332                         if (gvop) {
6333                             for (; gvop->op_sibling; gvop = gvop->op_sibling)
6334                                 ;
6335                             if (gvop &&
6336                                 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6337                                 (gvop = ((UNOP*)gvop)->op_first) &&
6338                                 gvop->op_type == OP_GV)
6339                             {
6340                                 GV *gv = cGVOPx_gv(gvop);
6341                                 OP *sibling = o2->op_sibling;
6342                                 SV *n = newSVpvn("",0);
6343                                 op_free(o2);
6344                                 gv_fullname4(n, gv, "", FALSE);
6345                                 o2 = newSVOP(OP_CONST, 0, n);
6346                                 prev->op_sibling = o2;
6347                                 o2->op_sibling = sibling;
6348                             }
6349                         }
6350                     }
6351                 }
6352                 scalar(o2);
6353                 break;
6354             case '[': case ']':
6355                  goto oops;
6356                  break;
6357             case '\\':
6358                 proto++;
6359                 arg++;
6360             again:
6361                 switch (*proto++) {
6362                 case '[':
6363                      if (contextclass++ == 0) {
6364                           e = strchr(proto, ']');
6365                           if (!e || e == proto)
6366                                goto oops;
6367                      }
6368                      else
6369                           goto oops;
6370                      goto again;
6371                      break;
6372                 case ']':
6373                      if (contextclass) {
6374                          char *p = proto;
6375                          const char s = *p;
6376                          contextclass = 0;
6377                          *p = '\0';
6378                          while (*--p != '[');
6379                          bad_type(arg, Perl_form(aTHX_ "one of %s", p),
6380                                  gv_ename(namegv), o2);
6381                          *proto = s;
6382                      } else
6383                           goto oops;
6384                      break;
6385                 case '*':
6386                      if (o2->op_type == OP_RV2GV)
6387                           goto wrapref;
6388                      if (!contextclass)
6389                           bad_type(arg, "symbol", gv_ename(namegv), o2);
6390                      break;
6391                 case '&':
6392                      if (o2->op_type == OP_ENTERSUB)
6393                           goto wrapref;
6394                      if (!contextclass)
6395                           bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6396                      break;
6397                 case '$':
6398                     if (o2->op_type == OP_RV2SV ||
6399                         o2->op_type == OP_PADSV ||
6400                         o2->op_type == OP_HELEM ||
6401                         o2->op_type == OP_AELEM ||
6402                         o2->op_type == OP_THREADSV)
6403                          goto wrapref;
6404                     if (!contextclass)
6405                         bad_type(arg, "scalar", gv_ename(namegv), o2);
6406                      break;
6407                 case '@':
6408                     if (o2->op_type == OP_RV2AV ||
6409                         o2->op_type == OP_PADAV)
6410                          goto wrapref;
6411                     if (!contextclass)
6412                         bad_type(arg, "array", gv_ename(namegv), o2);
6413                     break;
6414                 case '%':
6415                     if (o2->op_type == OP_RV2HV ||
6416                         o2->op_type == OP_PADHV)
6417                          goto wrapref;
6418                     if (!contextclass)
6419                          bad_type(arg, "hash", gv_ename(namegv), o2);
6420                     break;
6421                 wrapref:
6422                     {
6423                         OP* kid = o2;
6424                         OP* sib = kid->op_sibling;
6425                         kid->op_sibling = 0;
6426                         o2 = newUNOP(OP_REFGEN, 0, kid);
6427                         o2->op_sibling = sib;
6428                         prev->op_sibling = o2;
6429                     }
6430                     if (contextclass && e) {
6431                          proto = e + 1;
6432                          contextclass = 0;
6433                     }
6434                     break;
6435                 default: goto oops;
6436                 }
6437                 if (contextclass)
6438                      goto again;
6439                 break;
6440             case ' ':
6441                 proto++;
6442                 continue;
6443             default:
6444               oops:
6445                 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
6446                            gv_ename(namegv), cv);
6447             }
6448         }
6449         else
6450             list(o2);
6451         mod(o2, OP_ENTERSUB);
6452         prev = o2;
6453         o2 = o2->op_sibling;
6454     }
6455     if (proto && !optional &&
6456           (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6457         return too_few_arguments(o, gv_ename(namegv));
6458     if(delete_op) {
6459         op_free(o);
6460         o=newSVOP(OP_CONST, 0, newSViv(0));
6461     }
6462     return o;
6463 }
6464
6465 OP *
6466 Perl_ck_svconst(pTHX_ OP *o)
6467 {
6468     SvREADONLY_on(cSVOPo->op_sv);
6469     return o;
6470 }
6471
6472 OP *
6473 Perl_ck_trunc(pTHX_ OP *o)
6474 {
6475     if (o->op_flags & OPf_KIDS) {
6476         SVOP *kid = (SVOP*)cUNOPo->op_first;
6477
6478         if (kid->op_type == OP_NULL)
6479             kid = (SVOP*)kid->op_sibling;
6480         if (kid && kid->op_type == OP_CONST &&
6481             (kid->op_private & OPpCONST_BARE))
6482         {
6483             o->op_flags |= OPf_SPECIAL;
6484             kid->op_private &= ~OPpCONST_STRICT;
6485         }
6486     }
6487     return ck_fun(o);
6488 }
6489
6490 OP *
6491 Perl_ck_unpack(pTHX_ OP *o)
6492 {
6493     OP *kid = cLISTOPo->op_first;
6494     if (kid->op_sibling) {
6495         kid = kid->op_sibling;
6496         if (!kid->op_sibling)
6497             kid->op_sibling = newDEFSVOP();
6498     }
6499     return ck_fun(o);
6500 }
6501
6502 OP *
6503 Perl_ck_substr(pTHX_ OP *o)
6504 {
6505     o = ck_fun(o);
6506     if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6507         OP *kid = cLISTOPo->op_first;
6508
6509         if (kid->op_type == OP_NULL)
6510             kid = kid->op_sibling;
6511         if (kid)
6512             kid->op_flags |= OPf_MOD;
6513
6514     }
6515     return o;
6516 }
6517
6518 /* A peephole optimizer.  We visit the ops in the order they're to execute.
6519  * See the comments at the top of this file for more details about when
6520  * peep() is called */
6521
6522 void
6523 Perl_peep(pTHX_ register OP *o)
6524 {
6525     dVAR;
6526     register OP* oldop = 0;
6527
6528     if (!o || o->op_opt)
6529         return;
6530     ENTER;
6531     SAVEOP();
6532     SAVEVPTR(PL_curcop);
6533     for (; o; o = o->op_next) {
6534         if (o->op_opt)
6535             break;
6536         PL_op = o;
6537         switch (o->op_type) {
6538         case OP_SETSTATE:
6539         case OP_NEXTSTATE:
6540         case OP_DBSTATE:
6541             PL_curcop = ((COP*)o);              /* for warnings */
6542             o->op_opt = 1;
6543             break;
6544
6545         case OP_CONST:
6546             if (cSVOPo->op_private & OPpCONST_STRICT)
6547                 no_bareword_allowed(o);
6548 #ifdef USE_ITHREADS
6549         case OP_METHOD_NAMED:
6550             /* Relocate sv to the pad for thread safety.
6551              * Despite being a "constant", the SV is written to,
6552              * for reference counts, sv_upgrade() etc. */
6553             if (cSVOP->op_sv) {
6554                 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6555                 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
6556                     /* If op_sv is already a PADTMP then it is being used by
6557                      * some pad, so make a copy. */
6558                     sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
6559                     SvREADONLY_on(PAD_SVl(ix));
6560                     SvREFCNT_dec(cSVOPo->op_sv);
6561                 }
6562                 else {
6563                     SvREFCNT_dec(PAD_SVl(ix));
6564                     SvPADTMP_on(cSVOPo->op_sv);
6565                     PAD_SETSV(ix, cSVOPo->op_sv);
6566                     /* XXX I don't know how this isn't readonly already. */
6567                     SvREADONLY_on(PAD_SVl(ix));
6568                 }
6569                 cSVOPo->op_sv = Nullsv;
6570                 o->op_targ = ix;
6571             }
6572 #endif
6573             o->op_opt = 1;
6574             break;
6575
6576         case OP_CONCAT:
6577             if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6578                 if (o->op_next->op_private & OPpTARGET_MY) {
6579                     if (o->op_flags & OPf_STACKED) /* chained concats */
6580                         goto ignore_optimization;
6581                     else {
6582                         /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6583                         o->op_targ = o->op_next->op_targ;
6584                         o->op_next->op_targ = 0;
6585                         o->op_private |= OPpTARGET_MY;
6586                     }
6587                 }
6588                 op_null(o->op_next);
6589             }
6590           ignore_optimization:
6591             o->op_opt = 1;
6592             break;
6593         case OP_STUB:
6594             if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6595                 o->op_opt = 1;
6596                 break; /* Scalar stub must produce undef.  List stub is noop */
6597             }
6598             goto nothin;
6599         case OP_NULL:
6600             if (o->op_targ == OP_NEXTSTATE
6601                 || o->op_targ == OP_DBSTATE
6602                 || o->op_targ == OP_SETSTATE)
6603             {
6604                 PL_curcop = ((COP*)o);
6605             }
6606             /* XXX: We avoid setting op_seq here to prevent later calls
6607                to peep() from mistakenly concluding that optimisation
6608                has already occurred. This doesn't fix the real problem,
6609                though (See 20010220.007). AMS 20010719 */
6610             /* op_seq functionality is now replaced by op_opt */
6611             if (oldop && o->op_next) {
6612                 oldop->op_next = o->op_next;
6613                 continue;
6614             }
6615             break;
6616         case OP_SCALAR:
6617         case OP_LINESEQ:
6618         case OP_SCOPE:
6619           nothin:
6620             if (oldop && o->op_next) {
6621                 oldop->op_next = o->op_next;
6622                 continue;
6623             }
6624             o->op_opt = 1;
6625             break;
6626
6627         case OP_PADAV:
6628         case OP_GV:
6629             if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
6630                 OP* pop = (o->op_type == OP_PADAV) ?
6631                             o->op_next : o->op_next->op_next;
6632                 IV i;
6633                 if (pop && pop->op_type == OP_CONST &&
6634                     ((PL_op = pop->op_next)) &&
6635                     pop->op_next->op_type == OP_AELEM &&
6636                     !(pop->op_next->op_private &
6637                       (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6638                     (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
6639                                 <= 255 &&
6640                     i >= 0)
6641                 {
6642                     GV *gv;
6643                     if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
6644                         no_bareword_allowed(pop);
6645                     if (o->op_type == OP_GV)
6646                         op_null(o->op_next);
6647                     op_null(pop->op_next);
6648                     op_null(pop);
6649                     o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6650                     o->op_next = pop->op_next->op_next;
6651                     o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6652                     o->op_private = (U8)i;
6653                     if (o->op_type == OP_GV) {
6654                         gv = cGVOPo_gv;
6655                         GvAVn(gv);
6656                     }
6657                     else
6658                         o->op_flags |= OPf_SPECIAL;
6659                     o->op_type = OP_AELEMFAST;
6660                 }
6661                 o->op_opt = 1;
6662                 break;
6663             }
6664
6665             if (o->op_next->op_type == OP_RV2SV) {
6666                 if (!(o->op_next->op_private & OPpDEREF)) {
6667                     op_null(o->op_next);
6668                     o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6669                                                                | OPpOUR_INTRO);
6670                     o->op_next = o->op_next->op_next;
6671                     o->op_type = OP_GVSV;
6672                     o->op_ppaddr = PL_ppaddr[OP_GVSV];
6673                 }
6674             }
6675             else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6676                 GV *gv = cGVOPo_gv;
6677                 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
6678                     /* XXX could check prototype here instead of just carping */
6679                     SV *sv = sv_newmortal();
6680                     gv_efullname3(sv, gv, Nullch);
6681                     Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
6682                                 "%"SVf"() called too early to check prototype",
6683                                 sv);
6684                 }
6685             }
6686             else if (o->op_next->op_type == OP_READLINE
6687                     && o->op_next->op_next->op_type == OP_CONCAT
6688                     && (o->op_next->op_next->op_flags & OPf_STACKED))
6689             {
6690                 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
6691                 o->op_type   = OP_RCATLINE;
6692                 o->op_flags |= OPf_STACKED;
6693                 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
6694                 op_null(o->op_next->op_next);
6695                 op_null(o->op_next);
6696             }
6697
6698             o->op_opt = 1;
6699             break;
6700
6701         case OP_MAPWHILE:
6702         case OP_GREPWHILE:
6703         case OP_AND:
6704         case OP_OR:
6705         case OP_DOR:
6706         case OP_ANDASSIGN:
6707         case OP_ORASSIGN:
6708         case OP_DORASSIGN:
6709         case OP_COND_EXPR:
6710         case OP_RANGE:
6711             o->op_opt = 1;
6712             while (cLOGOP->op_other->op_type == OP_NULL)
6713                 cLOGOP->op_other = cLOGOP->op_other->op_next;
6714             peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
6715             break;
6716
6717         case OP_ENTERLOOP:
6718         case OP_ENTERITER:
6719             o->op_opt = 1;
6720             while (cLOOP->op_redoop->op_type == OP_NULL)
6721                 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6722             peep(cLOOP->op_redoop);
6723             while (cLOOP->op_nextop->op_type == OP_NULL)
6724                 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6725             peep(cLOOP->op_nextop);
6726             while (cLOOP->op_lastop->op_type == OP_NULL)
6727                 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6728             peep(cLOOP->op_lastop);
6729             break;
6730
6731         case OP_QR:
6732         case OP_MATCH:
6733         case OP_SUBST:
6734             o->op_opt = 1;
6735             while (cPMOP->op_pmreplstart &&
6736                    cPMOP->op_pmreplstart->op_type == OP_NULL)
6737                 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6738             peep(cPMOP->op_pmreplstart);
6739             break;
6740
6741         case OP_EXEC:
6742             o->op_opt = 1;
6743             if (ckWARN(WARN_SYNTAX) && o->op_next
6744                 && o->op_next->op_type == OP_NEXTSTATE) {
6745                 if (o->op_next->op_sibling &&
6746                         o->op_next->op_sibling->op_type != OP_EXIT &&
6747                         o->op_next->op_sibling->op_type != OP_WARN &&
6748                         o->op_next->op_sibling->op_type != OP_DIE) {
6749                     const line_t oldline = CopLINE(PL_curcop);
6750
6751                     CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6752                     Perl_warner(aTHX_ packWARN(WARN_EXEC),
6753                                 "Statement unlikely to be reached");
6754                     Perl_warner(aTHX_ packWARN(WARN_EXEC),
6755                                 "\t(Maybe you meant system() when you said exec()?)\n");
6756                     CopLINE_set(PL_curcop, oldline);
6757                 }
6758             }
6759             break;
6760
6761         case OP_HELEM: {
6762             UNOP *rop;
6763             SV *lexname;
6764             GV **fields;
6765             SV **svp, *sv;
6766             char *key = NULL;
6767             STRLEN keylen;
6768
6769             o->op_opt = 1;
6770
6771             if (((BINOP*)o)->op_last->op_type != OP_CONST)
6772                 break;
6773
6774             /* Make the CONST have a shared SV */
6775             svp = cSVOPx_svp(((BINOP*)o)->op_last);
6776             if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
6777                 key = SvPV(sv, keylen);
6778                 lexname = newSVpvn_share(key,
6779                                          SvUTF8(sv) ? -(I32)keylen : keylen,
6780                                          0);
6781                 SvREFCNT_dec(sv);
6782                 *svp = lexname;
6783             }
6784
6785             if ((o->op_private & (OPpLVAL_INTRO)))
6786                 break;
6787
6788             rop = (UNOP*)((BINOP*)o)->op_first;
6789             if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6790                 break;
6791             lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
6792             if (!(SvFLAGS(lexname) & SVpad_TYPED))
6793                 break;
6794             fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6795             if (!fields || !GvHV(*fields))
6796                 break;
6797             key = SvPV(*svp, keylen);
6798             if (!hv_fetch(GvHV(*fields), key,
6799                         SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
6800             {
6801                 Perl_croak(aTHX_ "No such class field \"%s\" "
6802                            "in variable %s of type %s",
6803                       key, SvPV_nolen(lexname), HvNAME(SvSTASH(lexname)));
6804             }
6805
6806             break;
6807         }
6808
6809         case OP_HSLICE: {
6810             UNOP *rop;
6811             SV *lexname;
6812             GV **fields;
6813             SV **svp;
6814             char *key;
6815             STRLEN keylen;
6816             SVOP *first_key_op, *key_op;
6817
6818             if ((o->op_private & (OPpLVAL_INTRO))
6819                 /* I bet there's always a pushmark... */
6820                 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
6821                 /* hmmm, no optimization if list contains only one key. */
6822                 break;
6823             rop = (UNOP*)((LISTOP*)o)->op_last;
6824             if (rop->op_type != OP_RV2HV)
6825                 break;
6826             if (rop->op_first->op_type == OP_PADSV)
6827                 /* @$hash{qw(keys here)} */
6828                 rop = (UNOP*)rop->op_first;
6829             else {
6830                 /* @{$hash}{qw(keys here)} */
6831                 if (rop->op_first->op_type == OP_SCOPE
6832                     && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
6833                 {
6834                     rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
6835                 }
6836                 else
6837                     break;
6838             }
6839
6840             lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
6841             if (!(SvFLAGS(lexname) & SVpad_TYPED))
6842                 break;
6843             fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6844             if (!fields || !GvHV(*fields))
6845                 break;
6846             /* Again guessing that the pushmark can be jumped over.... */
6847             first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
6848                 ->op_first->op_sibling;
6849             for (key_op = first_key_op; key_op;
6850                  key_op = (SVOP*)key_op->op_sibling) {
6851                 if (key_op->op_type != OP_CONST)
6852                     continue;
6853                 svp = cSVOPx_svp(key_op);
6854                 key = SvPV(*svp, keylen);
6855                 if (!hv_fetch(GvHV(*fields), key,
6856                             SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
6857                 {
6858                     Perl_croak(aTHX_ "No such class field \"%s\" "
6859                                "in variable %s of type %s",
6860                           key, SvPV_nolen(lexname), HvNAME(SvSTASH(lexname)));
6861                 }
6862             }
6863             break;
6864         }
6865
6866         case OP_SORT: {
6867             /* will point to RV2AV or PADAV op on LHS/RHS of assign */
6868             OP *oleft, *oright;
6869             OP *o2;
6870
6871             /* check that RHS of sort is a single plain array */
6872             oright = cUNOPo->op_first;
6873             if (!oright || oright->op_type != OP_PUSHMARK)
6874                 break;
6875
6876             /* reverse sort ... can be optimised.  */
6877             if (!cUNOPo->op_sibling) {
6878                 /* Nothing follows us on the list. */
6879                 OP *reverse = o->op_next;
6880
6881                 if (reverse->op_type == OP_REVERSE &&
6882                     (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
6883                     OP *pushmark = cUNOPx(reverse)->op_first;
6884                     if (pushmark && (pushmark->op_type == OP_PUSHMARK)
6885                         && (cUNOPx(pushmark)->op_sibling == o)) {
6886                         /* reverse -> pushmark -> sort */
6887                         o->op_private |= OPpSORT_REVERSE;
6888                         op_null(reverse);
6889                         pushmark->op_next = oright->op_next;
6890                         op_null(oright);
6891                     }
6892                 }
6893             }
6894
6895             /* make @a = sort @a act in-place */
6896
6897             o->op_opt = 1;
6898
6899             oright = cUNOPx(oright)->op_sibling;
6900             if (!oright)
6901                 break;
6902             if (oright->op_type == OP_NULL) { /* skip sort block/sub */
6903                 oright = cUNOPx(oright)->op_sibling;
6904             }
6905
6906             if (!oright ||
6907                 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
6908                 || oright->op_next != o
6909                 || (oright->op_private & OPpLVAL_INTRO)
6910             )
6911                 break;
6912
6913             /* o2 follows the chain of op_nexts through the LHS of the
6914              * assign (if any) to the aassign op itself */
6915             o2 = o->op_next;
6916             if (!o2 || o2->op_type != OP_NULL)
6917                 break;
6918             o2 = o2->op_next;
6919             if (!o2 || o2->op_type != OP_PUSHMARK)
6920                 break;
6921             o2 = o2->op_next;
6922             if (o2 && o2->op_type == OP_GV)
6923                 o2 = o2->op_next;
6924             if (!o2
6925                 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
6926                 || (o2->op_private & OPpLVAL_INTRO)
6927             )
6928                 break;
6929             oleft = o2;
6930             o2 = o2->op_next;
6931             if (!o2 || o2->op_type != OP_NULL)
6932                 break;
6933             o2 = o2->op_next;
6934             if (!o2 || o2->op_type != OP_AASSIGN
6935                     || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
6936                 break;
6937
6938             /* check that the sort is the first arg on RHS of assign */
6939
6940             o2 = cUNOPx(o2)->op_first;
6941             if (!o2 || o2->op_type != OP_NULL)
6942                 break;
6943             o2 = cUNOPx(o2)->op_first;
6944             if (!o2 || o2->op_type != OP_PUSHMARK)
6945                 break;
6946             if (o2->op_sibling != o)
6947                 break;
6948
6949             /* check the array is the same on both sides */
6950             if (oleft->op_type == OP_RV2AV) {
6951                 if (oright->op_type != OP_RV2AV
6952                     || !cUNOPx(oright)->op_first
6953                     || cUNOPx(oright)->op_first->op_type != OP_GV
6954                     ||  cGVOPx_gv(cUNOPx(oleft)->op_first) !=
6955                         cGVOPx_gv(cUNOPx(oright)->op_first)
6956                 )
6957                     break;
6958             }
6959             else if (oright->op_type != OP_PADAV
6960                 || oright->op_targ != oleft->op_targ
6961             )
6962                 break;
6963
6964             /* transfer MODishness etc from LHS arg to RHS arg */
6965             oright->op_flags = oleft->op_flags;
6966             o->op_private |= OPpSORT_INPLACE;
6967
6968             /* excise push->gv->rv2av->null->aassign */
6969             o2 = o->op_next->op_next;
6970             op_null(o2); /* PUSHMARK */
6971             o2 = o2->op_next;
6972             if (o2->op_type == OP_GV) {
6973                 op_null(o2); /* GV */
6974                 o2 = o2->op_next;
6975             }
6976             op_null(o2); /* RV2AV or PADAV */
6977             o2 = o2->op_next->op_next;
6978             op_null(o2); /* AASSIGN */
6979
6980             o->op_next = o2->op_next;
6981
6982             break;
6983         }
6984
6985         case OP_REVERSE: {
6986             OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
6987             OP *gvop = NULL;
6988             LISTOP *enter, *exlist;
6989             o->op_opt = 1;
6990
6991             enter = (LISTOP *) o->op_next;
6992             if (!enter)
6993                 break;
6994             if (enter->op_type == OP_NULL) {
6995                 enter = (LISTOP *) enter->op_next;
6996                 if (!enter)
6997                     break;
6998             }
6999             /* for $a (...) will have OP_GV then OP_RV2GV here.
7000                for (...) just has an OP_GV.  */
7001             if (enter->op_type == OP_GV) {
7002                 gvop = (OP *) enter;
7003                 enter = (LISTOP *) enter->op_next;
7004                 if (!enter)
7005                     break;
7006                 if (enter->op_type == OP_RV2GV) {
7007                   enter = (LISTOP *) enter->op_next;
7008                   if (!enter)
7009                     break;
7010                 }
7011             }
7012
7013             if (enter->op_type != OP_ENTERITER)
7014                 break;
7015
7016             iter = enter->op_next;
7017             if (!iter || iter->op_type != OP_ITER)
7018                 break;
7019
7020             expushmark = enter->op_first;
7021             if (!expushmark || expushmark->op_type != OP_NULL
7022                 || expushmark->op_targ != OP_PUSHMARK)
7023                 break;
7024
7025             exlist = (LISTOP *) expushmark->op_sibling;
7026             if (!exlist || exlist->op_type != OP_NULL
7027                 || exlist->op_targ != OP_LIST)
7028                 break;
7029
7030             if (exlist->op_last != o) {
7031                 /* Mmm. Was expecting to point back to this op.  */
7032                 break;
7033             }
7034             theirmark = exlist->op_first;
7035             if (!theirmark || theirmark->op_type != OP_PUSHMARK)
7036                 break;
7037
7038             if (theirmark->op_sibling != o) {
7039                 /* There's something between the mark and the reverse, eg
7040                    for (1, reverse (...))
7041                    so no go.  */
7042                 break;
7043             }
7044
7045             ourmark = ((LISTOP *)o)->op_first;
7046             if (!ourmark || ourmark->op_type != OP_PUSHMARK)
7047                 break;
7048
7049             ourlast = ((LISTOP *)o)->op_last;
7050             if (!ourlast || ourlast->op_next != o)
7051                 break;
7052
7053             rv2av = ourmark->op_sibling;
7054             if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
7055                 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
7056                 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
7057                 /* We're just reversing a single array.  */
7058                 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
7059                 enter->op_flags |= OPf_STACKED;
7060             }
7061
7062             /* We don't have control over who points to theirmark, so sacrifice
7063                ours.  */
7064             theirmark->op_next = ourmark->op_next;
7065             theirmark->op_flags = ourmark->op_flags;
7066             ourlast->op_next = gvop ? gvop : (OP *) enter;
7067             op_null(ourmark);
7068             op_null(o);
7069             enter->op_private |= OPpITER_REVERSED;
7070             iter->op_private |= OPpITER_REVERSED;
7071
7072             break;
7073         }
7074
7075         default:
7076             o->op_opt = 1;
7077             break;
7078         }
7079         oldop = o;
7080     }
7081     LEAVE;
7082 }
7083
7084 char*
7085 Perl_custom_op_name(pTHX_ const OP* o)
7086 {
7087     const IV index = PTR2IV(o->op_ppaddr);
7088     SV* keysv;
7089     HE* he;
7090
7091     if (!PL_custom_op_names) /* This probably shouldn't happen */
7092         return (char *)PL_op_name[OP_CUSTOM];
7093
7094     keysv = sv_2mortal(newSViv(index));
7095
7096     he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
7097     if (!he)
7098         return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
7099
7100     return SvPV_nolen(HeVAL(he));
7101 }
7102
7103 char*
7104 Perl_custom_op_desc(pTHX_ const OP* o)
7105 {
7106     const IV index = PTR2IV(o->op_ppaddr);
7107     SV* keysv;
7108     HE* he;
7109
7110     if (!PL_custom_op_descs)
7111         return (char *)PL_op_desc[OP_CUSTOM];
7112
7113     keysv = sv_2mortal(newSViv(index));
7114
7115     he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
7116     if (!he)
7117         return (char *)PL_op_desc[OP_CUSTOM];
7118
7119     return SvPV_nolen(HeVAL(he));
7120 }
7121
7122 #include "XSUB.h"
7123
7124 /* Efficient sub that returns a constant scalar value. */
7125 static void
7126 const_sv_xsub(pTHX_ CV* cv)
7127 {
7128     dXSARGS;
7129     if (items != 0) {
7130 #if 0
7131         Perl_croak(aTHX_ "usage: %s::%s()",
7132                    HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
7133 #endif
7134     }
7135     EXTEND(sp, 1);
7136     ST(0) = (SV*)XSANY.any_ptr;
7137     XSRETURN(1);
7138 }
7139
7140 /*
7141  * Local variables:
7142  * c-indentation-style: bsd
7143  * c-basic-offset: 4
7144  * indent-tabs-mode: t
7145  * End:
7146  *
7147  * vim: shiftwidth=4:
7148 */