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