op.c

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