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