op.c

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