op.c

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