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