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