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