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(";", GV_ADD, 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", 0, 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)
4322         return NULL;
4323     if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
4324         return NULL;
4325     return CvCONST(cv) ? (SV*)CvXSUBANY(cv).any_ptr : NULL;
4326 }
4327
4328 /* op_const_sv:  examine an optree to determine whether it's in-lineable.
4329  * Can be called in 3 ways:
4330  *
4331  * !cv
4332  *      look for a single OP_CONST with attached value: return the value
4333  *
4334  * cv && CvCLONE(cv) && !CvCONST(cv)
4335  *
4336  *      examine the clone prototype, and if contains only a single
4337  *      OP_CONST referencing a pad const, or a single PADSV referencing
4338  *      an outer lexical, return a non-zero value to indicate the CV is
4339  *      a candidate for "constizing" at clone time
4340  *
4341  * cv && CvCONST(cv)
4342  *
4343  *      We have just cloned an anon prototype that was marked as a const
4344  *      candidiate. Try to grab the current value, and in the case of
4345  *      PADSV, ignore it if it has multiple references. Return the value.
4346  */
4347
4348 SV *
4349 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
4350 {
4351     SV *sv = Nullsv;
4352
4353     if (!o)
4354         return Nullsv;
4355
4356     if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4357         o = cLISTOPo->op_first->op_sibling;
4358
4359     for (; o; o = o->op_next) {
4360         const OPCODE type = o->op_type;
4361
4362         if (sv && o->op_next == o)
4363             return sv;
4364         if (o->op_next != o) {
4365             if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4366                 continue;
4367             if (type == OP_DBSTATE)
4368                 continue;
4369         }
4370         if (type == OP_LEAVESUB || type == OP_RETURN)
4371             break;
4372         if (sv)
4373             return Nullsv;
4374         if (type == OP_CONST && cSVOPo->op_sv)
4375             sv = cSVOPo->op_sv;
4376         else if (cv && type == OP_CONST) {
4377             sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4378             if (!sv)
4379                 return Nullsv;
4380         }
4381         else if (cv && type == OP_PADSV) {
4382             if (CvCONST(cv)) { /* newly cloned anon */
4383                 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4384                 /* the candidate should have 1 ref from this pad and 1 ref
4385                  * from the parent */
4386                 if (!sv || SvREFCNT(sv) != 2)
4387                     return Nullsv;
4388                 sv = newSVsv(sv);
4389                 SvREADONLY_on(sv);
4390                 return sv;
4391             }
4392             else {
4393                 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
4394                     sv = &PL_sv_undef; /* an arbitrary non-null value */
4395             }
4396         }
4397         else {
4398             return Nullsv;
4399         }
4400     }
4401     return sv;
4402 }
4403
4404 void
4405 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4406 {
4407     PERL_UNUSED_ARG(floor);
4408
4409     if (o)
4410         SAVEFREEOP(o);
4411     if (proto)
4412         SAVEFREEOP(proto);
4413     if (attrs)
4414         SAVEFREEOP(attrs);
4415     if (block)
4416         SAVEFREEOP(block);
4417     Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4418 }
4419
4420 CV *
4421 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4422 {
4423     return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4424 }
4425
4426 CV *
4427 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4428 {
4429     dVAR;
4430     const char *aname;
4431     GV *gv;
4432     const char *ps;
4433     STRLEN ps_len;
4434     register CV *cv=0;
4435     SV *const_sv;
4436     I32 gv_fetch_flags;
4437
4438     const char * const name = o ? SvPVx_nolen_const(cSVOPo->op_sv) : Nullch;
4439
4440     if (proto) {
4441         assert(proto->op_type == OP_CONST);
4442         ps = SvPVx_const(((SVOP*)proto)->op_sv, ps_len);
4443     }
4444     else
4445         ps = Nullch;
4446
4447     if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4448         SV * const sv = sv_newmortal();
4449         Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
4450                        PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
4451                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4452         aname = SvPVX_const(sv);
4453     }
4454     else
4455         aname = Nullch;
4456
4457     gv_fetch_flags = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
4458         ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
4459     gv = name ? gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV)
4460         : gv_fetchpv(aname ? aname
4461                      : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4462                      gv_fetch_flags, SVt_PVCV);
4463
4464     if (o)
4465         SAVEFREEOP(o);
4466     if (proto)
4467         SAVEFREEOP(proto);
4468     if (attrs)
4469         SAVEFREEOP(attrs);
4470
4471     if (SvTYPE(gv) != SVt_PVGV) {       /* Maybe prototype now, and had at
4472                                            maximum a prototype before. */
4473         if (SvTYPE(gv) > SVt_NULL) {
4474             if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4475                 && ckWARN_d(WARN_PROTOTYPE))
4476             {
4477                 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
4478             }
4479             cv_ckproto((CV*)gv, NULL, ps);
4480         }
4481         if (ps)
4482             sv_setpvn((SV*)gv, ps, ps_len);
4483         else
4484             sv_setiv((SV*)gv, -1);
4485         SvREFCNT_dec(PL_compcv);
4486         cv = PL_compcv = NULL;
4487         PL_sub_generation++;
4488         goto done;
4489     }
4490
4491     cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4492
4493 #ifdef GV_UNIQUE_CHECK
4494     if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4495         Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
4496     }
4497 #endif
4498
4499     if (!block || !ps || *ps || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
4500         const_sv = Nullsv;
4501     else
4502         const_sv = op_const_sv(block, Nullcv);
4503
4504     if (cv) {
4505         const bool exists = CvROOT(cv) || CvXSUB(cv);
4506
4507 #ifdef GV_UNIQUE_CHECK
4508         if (exists && GvUNIQUE(gv)) {
4509             Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
4510         }
4511 #endif
4512
4513         /* if the subroutine doesn't exist and wasn't pre-declared
4514          * with a prototype, assume it will be AUTOLOADed,
4515          * skipping the prototype check
4516          */
4517         if (exists || SvPOK(cv))
4518             cv_ckproto(cv, gv, ps);
4519         /* already defined (or promised)? */
4520         if (exists || GvASSUMECV(gv)) {
4521             if (!block && !attrs) {
4522                 if (CvFLAGS(PL_compcv)) {
4523                     /* might have had built-in attrs applied */
4524                     CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4525                 }
4526                 /* just a "sub foo;" when &foo is already defined */
4527                 SAVEFREESV(PL_compcv);
4528                 goto done;
4529             }
4530             if (block) {
4531                 if (ckWARN(WARN_REDEFINE)
4532                     || (CvCONST(cv)
4533                         && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4534                 {
4535                     const line_t oldline = CopLINE(PL_curcop);
4536                     if (PL_copline != NOLINE)
4537                         CopLINE_set(PL_curcop, PL_copline);
4538                     Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4539                         CvCONST(cv) ? "Constant subroutine %s redefined"
4540                                     : "Subroutine %s redefined", name);
4541                     CopLINE_set(PL_curcop, oldline);
4542                 }
4543                 SvREFCNT_dec(cv);
4544                 cv = Nullcv;
4545             }
4546         }
4547     }
4548     if (const_sv) {
4549         (void)SvREFCNT_inc(const_sv);
4550         if (cv) {
4551             assert(!CvROOT(cv) && !CvCONST(cv));
4552             sv_setpvn((SV*)cv, "", 0);  /* prototype is "" */
4553             CvXSUBANY(cv).any_ptr = const_sv;
4554             CvXSUB(cv) = const_sv_xsub;
4555             CvCONST_on(cv);
4556         }
4557         else {
4558             GvCV(gv) = Nullcv;
4559             cv = newCONSTSUB(NULL, name, const_sv);
4560         }
4561         op_free(block);
4562         SvREFCNT_dec(PL_compcv);
4563         PL_compcv = NULL;
4564         PL_sub_generation++;
4565         goto done;
4566     }
4567     if (attrs) {
4568         HV *stash;
4569         SV *rcv;
4570
4571         /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4572          * before we clobber PL_compcv.
4573          */
4574         if (cv && !block) {
4575             rcv = (SV*)cv;
4576             /* Might have had built-in attributes applied -- propagate them. */
4577             CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4578             if (CvGV(cv) && GvSTASH(CvGV(cv)))
4579                 stash = GvSTASH(CvGV(cv));
4580             else if (CvSTASH(cv))
4581                 stash = CvSTASH(cv);
4582             else
4583                 stash = PL_curstash;
4584         }
4585         else {
4586             /* possibly about to re-define existing subr -- ignore old cv */
4587             rcv = (SV*)PL_compcv;
4588             if (name && GvSTASH(gv))
4589                 stash = GvSTASH(gv);
4590             else
4591                 stash = PL_curstash;
4592         }
4593         apply_attrs(stash, rcv, attrs, FALSE);
4594     }
4595     if (cv) {                           /* must reuse cv if autoloaded */
4596         if (!block) {
4597             /* got here with just attrs -- work done, so bug out */
4598             SAVEFREESV(PL_compcv);
4599             goto done;
4600         }
4601         /* transfer PL_compcv to cv */
4602         cv_undef(cv);
4603         CvFLAGS(cv) = CvFLAGS(PL_compcv);
4604         if (!CvWEAKOUTSIDE(cv))
4605             SvREFCNT_dec(CvOUTSIDE(cv));
4606         CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4607         CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
4608         CvOUTSIDE(PL_compcv) = 0;
4609         CvPADLIST(cv) = CvPADLIST(PL_compcv);
4610         CvPADLIST(PL_compcv) = 0;
4611         /* inner references to PL_compcv must be fixed up ... */
4612         pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
4613         /* ... before we throw it away */
4614         SvREFCNT_dec(PL_compcv);
4615         PL_compcv = cv;
4616         if (PERLDB_INTER)/* Advice debugger on the new sub. */
4617           ++PL_sub_generation;
4618     }
4619     else {
4620         cv = PL_compcv;
4621         if (name) {
4622             GvCV(gv) = cv;
4623             GvCVGEN(gv) = 0;
4624             PL_sub_generation++;
4625         }
4626     }
4627     CvGV(cv) = gv;
4628     CvFILE_set_from_cop(cv, PL_curcop);
4629     CvSTASH(cv) = PL_curstash;
4630
4631     if (ps)
4632         sv_setpvn((SV*)cv, ps, ps_len);
4633
4634     if (PL_error_count) {
4635         op_free(block);
4636         block = Nullop;
4637         if (name) {
4638             const char *s = strrchr(name, ':');
4639             s = s ? s+1 : name;
4640             if (strEQ(s, "BEGIN")) {
4641                 const char not_safe[] =
4642                     "BEGIN not safe after errors--compilation aborted";
4643                 if (PL_in_eval & EVAL_KEEPERR)
4644                     Perl_croak(aTHX_ not_safe);
4645                 else {
4646                     /* force display of errors found but not reported */
4647                     sv_catpv(ERRSV, not_safe);
4648                     Perl_croak(aTHX_ "%"SVf, ERRSV);
4649                 }
4650             }
4651         }
4652     }
4653     if (!block)
4654         goto done;
4655
4656     if (CvLVALUE(cv)) {
4657         CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4658                              mod(scalarseq(block), OP_LEAVESUBLV));
4659     }
4660     else {
4661         /* This makes sub {}; work as expected.  */
4662         if (block->op_type == OP_STUB) {
4663             op_free(block);
4664             block = newSTATEOP(0, Nullch, 0);
4665         }
4666         CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4667     }
4668     CvROOT(cv)->op_private |= OPpREFCOUNTED;
4669     OpREFCNT_set(CvROOT(cv), 1);
4670     CvSTART(cv) = LINKLIST(CvROOT(cv));
4671     CvROOT(cv)->op_next = 0;
4672     CALL_PEEP(CvSTART(cv));
4673
4674     /* now that optimizer has done its work, adjust pad values */
4675
4676     pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
4677
4678     if (CvCLONE(cv)) {
4679         assert(!CvCONST(cv));
4680         if (ps && !*ps && op_const_sv(block, cv))
4681             CvCONST_on(cv);
4682     }
4683
4684     if (name || aname) {
4685         const char *s;
4686         const char * const tname = (name ? name : aname);
4687
4688         if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4689             SV * const sv = NEWSV(0,0);
4690             SV * const tmpstr = sv_newmortal();
4691             GV * const db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4692             HV *hv;
4693
4694             Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4695                            CopFILE(PL_curcop),
4696                            (long)PL_subline, (long)CopLINE(PL_curcop));
4697             gv_efullname3(tmpstr, gv, Nullch);
4698             hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr), SvCUR(tmpstr), sv, 0);
4699             hv = GvHVn(db_postponed);
4700             if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
4701                 CV * const pcv = GvCV(db_postponed);
4702                 if (pcv) {
4703                     dSP;
4704                     PUSHMARK(SP);
4705                     XPUSHs(tmpstr);
4706                     PUTBACK;
4707                     call_sv((SV*)pcv, G_DISCARD);
4708                 }
4709             }
4710         }
4711
4712         if ((s = strrchr(tname,':')))
4713             s++;
4714         else
4715             s = tname;
4716
4717         if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4718             goto done;
4719
4720         if (strEQ(s, "BEGIN") && !PL_error_count) {
4721             const I32 oldscope = PL_scopestack_ix;
4722             ENTER;
4723             SAVECOPFILE(&PL_compiling);
4724             SAVECOPLINE(&PL_compiling);
4725
4726             if (!PL_beginav)
4727                 PL_beginav = newAV();
4728             DEBUG_x( dump_sub(gv) );
4729             av_push(PL_beginav, (SV*)cv);
4730             GvCV(gv) = 0;               /* cv has been hijacked */
4731             call_list(oldscope, PL_beginav);
4732
4733             PL_curcop = &PL_compiling;
4734             PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4735             LEAVE;
4736         }
4737         else if (strEQ(s, "END") && !PL_error_count) {
4738             if (!PL_endav)
4739                 PL_endav = newAV();
4740             DEBUG_x( dump_sub(gv) );
4741             av_unshift(PL_endav, 1);
4742             av_store(PL_endav, 0, (SV*)cv);
4743             GvCV(gv) = 0;               /* cv has been hijacked */
4744         }
4745         else if (strEQ(s, "CHECK") && !PL_error_count) {
4746             if (!PL_checkav)
4747                 PL_checkav = newAV();
4748             DEBUG_x( dump_sub(gv) );
4749             if (PL_main_start && ckWARN(WARN_VOID))
4750                 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4751             av_unshift(PL_checkav, 1);
4752             av_store(PL_checkav, 0, (SV*)cv);
4753             GvCV(gv) = 0;               /* cv has been hijacked */
4754         }
4755         else if (strEQ(s, "INIT") && !PL_error_count) {
4756             if (!PL_initav)
4757                 PL_initav = newAV();
4758             DEBUG_x( dump_sub(gv) );
4759             if (PL_main_start && ckWARN(WARN_VOID))
4760                 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4761             av_push(PL_initav, (SV*)cv);
4762             GvCV(gv) = 0;               /* cv has been hijacked */
4763         }
4764     }
4765
4766   done:
4767     PL_copline = NOLINE;
4768     LEAVE_SCOPE(floor);
4769     return cv;
4770 }
4771
4772 /* XXX unsafe for threads if eval_owner isn't held */
4773 /*
4774 =for apidoc newCONSTSUB
4775
4776 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4777 eligible for inlining at compile-time.
4778
4779 =cut
4780 */
4781
4782 CV *
4783 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
4784 {
4785     dVAR;
4786     CV* cv;
4787
4788     ENTER;
4789
4790     SAVECOPLINE(PL_curcop);
4791     CopLINE_set(PL_curcop, PL_copline);
4792
4793     SAVEHINTS();
4794     PL_hints &= ~HINT_BLOCK_SCOPE;
4795
4796     if (stash) {
4797         SAVESPTR(PL_curstash);
4798         SAVECOPSTASH(PL_curcop);
4799         PL_curstash = stash;
4800         CopSTASH_set(PL_curcop,stash);
4801     }
4802
4803     cv = newXS(name, const_sv_xsub, savepv(CopFILE(PL_curcop)));
4804     CvXSUBANY(cv).any_ptr = sv;
4805     CvCONST_on(cv);
4806     sv_setpvn((SV*)cv, "", 0);  /* prototype is "" */
4807
4808 #ifdef USE_ITHREADS
4809     if (stash)
4810         CopSTASH_free(PL_curcop);
4811 #endif
4812     LEAVE;
4813
4814     return cv;
4815 }
4816
4817 /*
4818 =for apidoc U||newXS
4819
4820 Used by C<xsubpp> to hook up XSUBs as Perl subs.
4821
4822 =cut
4823 */
4824
4825 CV *
4826 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
4827 {
4828     GV * const gv = gv_fetchpv(name ? name :
4829                         (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4830                         GV_ADDMULTI, SVt_PVCV);
4831     register CV *cv;
4832
4833     if (!subaddr)
4834         Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
4835
4836     if ((cv = (name ? GvCV(gv) : Nullcv))) {
4837         if (GvCVGEN(gv)) {
4838             /* just a cached method */
4839             SvREFCNT_dec(cv);
4840             cv = Nullcv;
4841         }
4842         else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4843             /* already defined (or promised) */
4844             /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
4845             if (ckWARN(WARN_REDEFINE)) {
4846                 GV * const gvcv = CvGV(cv);
4847                 if (gvcv) {
4848                     HV * const stash = GvSTASH(gvcv);
4849                     if (stash) {
4850                         const char *name = HvNAME_get(stash);
4851                         if ( strEQ(name,"autouse") ) {
4852                             const line_t oldline = CopLINE(PL_curcop);
4853                             if (PL_copline != NOLINE)
4854                                 CopLINE_set(PL_curcop, PL_copline);
4855                             Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4856                                         CvCONST(cv) ? "Constant subroutine %s redefined"
4857                                                     : "Subroutine %s redefined"
4858                                         ,name);
4859                             CopLINE_set(PL_curcop, oldline);
4860                         }
4861                     }
4862                 }
4863             }
4864             SvREFCNT_dec(cv);
4865             cv = Nullcv;
4866         }
4867     }
4868
4869     if (cv)                             /* must reuse cv if autoloaded */
4870         cv_undef(cv);
4871     else {
4872         cv = (CV*)NEWSV(1105,0);
4873         sv_upgrade((SV *)cv, SVt_PVCV);
4874         if (name) {
4875             GvCV(gv) = cv;
4876             GvCVGEN(gv) = 0;
4877             PL_sub_generation++;
4878         }
4879     }
4880     CvGV(cv) = gv;
4881     (void)gv_fetchfile(filename);
4882     CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
4883                                    an external constant string */
4884     CvXSUB(cv) = subaddr;
4885
4886     if (name) {
4887         const char *s = strrchr(name,':');
4888         if (s)
4889             s++;
4890         else
4891             s = name;
4892
4893         if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4894             goto done;
4895
4896         if (strEQ(s, "BEGIN")) {
4897             if (!PL_beginav)
4898                 PL_beginav = newAV();
4899             av_push(PL_beginav, (SV*)cv);
4900             GvCV(gv) = 0;               /* cv has been hijacked */
4901         }
4902         else if (strEQ(s, "END")) {
4903             if (!PL_endav)
4904                 PL_endav = newAV();
4905             av_unshift(PL_endav, 1);
4906             av_store(PL_endav, 0, (SV*)cv);
4907             GvCV(gv) = 0;               /* cv has been hijacked */
4908         }
4909         else if (strEQ(s, "CHECK")) {
4910             if (!PL_checkav)
4911                 PL_checkav = newAV();
4912             if (PL_main_start && ckWARN(WARN_VOID))
4913                 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4914             av_unshift(PL_checkav, 1);
4915             av_store(PL_checkav, 0, (SV*)cv);
4916             GvCV(gv) = 0;               /* cv has been hijacked */
4917         }
4918         else if (strEQ(s, "INIT")) {
4919             if (!PL_initav)
4920                 PL_initav = newAV();
4921             if (PL_main_start && ckWARN(WARN_VOID))
4922                 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4923             av_push(PL_initav, (SV*)cv);
4924             GvCV(gv) = 0;               /* cv has been hijacked */
4925         }
4926     }
4927     else
4928         CvANON_on(cv);
4929
4930 done:
4931     return cv;
4932 }
4933
4934 void
4935 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
4936 {
4937     register CV *cv;
4938
4939     GV * const gv = o
4940         ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
4941         : gv_fetchpv("STDOUT", GV_ADD, SVt_PVFM);
4942
4943 #ifdef GV_UNIQUE_CHECK
4944     if (GvUNIQUE(gv)) {
4945         Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
4946     }
4947 #endif
4948     GvMULTI_on(gv);
4949     if ((cv = GvFORM(gv))) {
4950         if (ckWARN(WARN_REDEFINE)) {
4951             const line_t oldline = CopLINE(PL_curcop);
4952             if (PL_copline != NOLINE)
4953                 CopLINE_set(PL_curcop, PL_copline);
4954             Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4955                         o ? "Format %"SVf" redefined"
4956                         : "Format STDOUT redefined" ,cSVOPo->op_sv);
4957             CopLINE_set(PL_curcop, oldline);
4958         }
4959         SvREFCNT_dec(cv);
4960     }
4961     cv = PL_compcv;
4962     GvFORM(gv) = cv;
4963     CvGV(cv) = gv;
4964     CvFILE_set_from_cop(cv, PL_curcop);
4965
4966
4967     pad_tidy(padtidy_FORMAT);
4968     CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
4969     CvROOT(cv)->op_private |= OPpREFCOUNTED;
4970     OpREFCNT_set(CvROOT(cv), 1);
4971     CvSTART(cv) = LINKLIST(CvROOT(cv));
4972     CvROOT(cv)->op_next = 0;
4973     CALL_PEEP(CvSTART(cv));
4974     op_free(o);
4975     PL_copline = NOLINE;
4976     LEAVE_SCOPE(floor);
4977 }
4978
4979 OP *
4980 Perl_newANONLIST(pTHX_ OP *o)
4981 {
4982     return newUNOP(OP_REFGEN, 0,
4983         mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
4984 }
4985
4986 OP *
4987 Perl_newANONHASH(pTHX_ OP *o)
4988 {
4989     return newUNOP(OP_REFGEN, 0,
4990         mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
4991 }
4992
4993 OP *
4994 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
4995 {
4996     return newANONATTRSUB(floor, proto, Nullop, block);
4997 }
4998
4999 OP *
5000 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5001 {
5002     return newUNOP(OP_REFGEN, 0,
5003         newSVOP(OP_ANONCODE, 0,
5004                 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5005 }
5006
5007 OP *
5008 Perl_oopsAV(pTHX_ OP *o)
5009 {
5010     dVAR;
5011     switch (o->op_type) {
5012     case OP_PADSV:
5013         o->op_type = OP_PADAV;
5014         o->op_ppaddr = PL_ppaddr[OP_PADAV];
5015         return ref(o, OP_RV2AV);
5016
5017     case OP_RV2SV:
5018         o->op_type = OP_RV2AV;
5019         o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5020         ref(o, OP_RV2AV);
5021         break;
5022
5023     default:
5024         if (ckWARN_d(WARN_INTERNAL))
5025             Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
5026         break;
5027     }
5028     return o;
5029 }
5030
5031 OP *
5032 Perl_oopsHV(pTHX_ OP *o)
5033 {
5034     dVAR;
5035     switch (o->op_type) {
5036     case OP_PADSV:
5037     case OP_PADAV:
5038         o->op_type = OP_PADHV;
5039         o->op_ppaddr = PL_ppaddr[OP_PADHV];
5040         return ref(o, OP_RV2HV);
5041
5042     case OP_RV2SV:
5043     case OP_RV2AV:
5044         o->op_type = OP_RV2HV;
5045         o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5046         ref(o, OP_RV2HV);
5047         break;
5048
5049     default:
5050         if (ckWARN_d(WARN_INTERNAL))
5051             Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
5052         break;
5053     }
5054     return o;
5055 }
5056
5057 OP *
5058 Perl_newAVREF(pTHX_ OP *o)
5059 {
5060     dVAR;
5061     if (o->op_type == OP_PADANY) {
5062         o->op_type = OP_PADAV;
5063         o->op_ppaddr = PL_ppaddr[OP_PADAV];
5064         return o;
5065     }
5066     else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
5067                 && ckWARN(WARN_DEPRECATED)) {
5068         Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5069                 "Using an array as a reference is deprecated");
5070     }
5071     return newUNOP(OP_RV2AV, 0, scalar(o));
5072 }
5073
5074 OP *
5075 Perl_newGVREF(pTHX_ I32 type, OP *o)
5076 {
5077     if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5078         return newUNOP(OP_NULL, 0, o);
5079     return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5080 }
5081
5082 OP *
5083 Perl_newHVREF(pTHX_ OP *o)
5084 {
5085     dVAR;
5086     if (o->op_type == OP_PADANY) {
5087         o->op_type = OP_PADHV;
5088         o->op_ppaddr = PL_ppaddr[OP_PADHV];
5089         return o;
5090     }
5091     else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
5092                 && ckWARN(WARN_DEPRECATED)) {
5093         Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5094                 "Using a hash as a reference is deprecated");
5095     }
5096     return newUNOP(OP_RV2HV, 0, scalar(o));
5097 }
5098
5099 OP *
5100 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5101 {
5102     return newUNOP(OP_RV2CV, flags, scalar(o));
5103 }
5104
5105 OP *
5106 Perl_newSVREF(pTHX_ OP *o)
5107 {
5108     dVAR;
5109     if (o->op_type == OP_PADANY) {
5110         o->op_type = OP_PADSV;
5111         o->op_ppaddr = PL_ppaddr[OP_PADSV];
5112         return o;
5113     }
5114     else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5115         o->op_flags |= OPpDONE_SVREF;
5116         return o;
5117     }
5118     return newUNOP(OP_RV2SV, 0, scalar(o));
5119 }
5120
5121 /* Check routines. See the comments at the top of this file for details
5122  * on when these are called */
5123
5124 OP *
5125 Perl_ck_anoncode(pTHX_ OP *o)
5126 {
5127     cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
5128     cSVOPo->op_sv = Nullsv;
5129     return o;
5130 }
5131
5132 OP *
5133 Perl_ck_bitop(pTHX_ OP *o)
5134 {
5135 #define OP_IS_NUMCOMPARE(op) \
5136         ((op) == OP_LT   || (op) == OP_I_LT || \
5137          (op) == OP_GT   || (op) == OP_I_GT || \
5138          (op) == OP_LE   || (op) == OP_I_LE || \
5139          (op) == OP_GE   || (op) == OP_I_GE || \
5140          (op) == OP_EQ   || (op) == OP_I_EQ || \
5141          (op) == OP_NE   || (op) == OP_I_NE || \
5142          (op) == OP_NCMP || (op) == OP_I_NCMP)
5143     o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
5144     if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
5145             && (o->op_type == OP_BIT_OR
5146              || o->op_type == OP_BIT_AND
5147              || o->op_type == OP_BIT_XOR))
5148     {
5149         const OP * const left = cBINOPo->op_first;
5150         const OP * const right = left->op_sibling;
5151         if ((OP_IS_NUMCOMPARE(left->op_type) &&
5152                 (left->op_flags & OPf_PARENS) == 0) ||
5153             (OP_IS_NUMCOMPARE(right->op_type) &&
5154                 (right->op_flags & OPf_PARENS) == 0))
5155             if (ckWARN(WARN_PRECEDENCE))
5156                 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
5157                         "Possible precedence problem on bitwise %c operator",
5158                         o->op_type == OP_BIT_OR ? '|'
5159                             : o->op_type == OP_BIT_AND ? '&' : '^'
5160                         );
5161     }
5162     return o;
5163 }
5164
5165 OP *
5166 Perl_ck_concat(pTHX_ OP *o)
5167 {
5168     const OP * const kid = cUNOPo->op_first;
5169     if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
5170             !(kUNOP->op_first->op_flags & OPf_MOD))
5171         o->op_flags |= OPf_STACKED;
5172     return o;
5173 }
5174
5175 OP *
5176 Perl_ck_spair(pTHX_ OP *o)
5177 {
5178     dVAR;
5179     if (o->op_flags & OPf_KIDS) {
5180         OP* newop;
5181         OP* kid;
5182         const OPCODE type = o->op_type;
5183         o = modkids(ck_fun(o), type);
5184         kid = cUNOPo->op_first;
5185         newop = kUNOP->op_first->op_sibling;
5186         if (newop &&
5187             (newop->op_sibling ||
5188              !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
5189              newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5190              newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
5191
5192             return o;
5193         }
5194         op_free(kUNOP->op_first);
5195         kUNOP->op_first = newop;
5196     }
5197     o->op_ppaddr = PL_ppaddr[++o->op_type];
5198     return ck_fun(o);
5199 }
5200
5201 OP *
5202 Perl_ck_delete(pTHX_ OP *o)
5203 {
5204     o = ck_fun(o);
5205     o->op_private = 0;
5206     if (o->op_flags & OPf_KIDS) {
5207         OP * const kid = cUNOPo->op_first;
5208         switch (kid->op_type) {
5209         case OP_ASLICE:
5210             o->op_flags |= OPf_SPECIAL;
5211             /* FALL THROUGH */
5212         case OP_HSLICE:
5213             o->op_private |= OPpSLICE;
5214             break;
5215         case OP_AELEM:
5216             o->op_flags |= OPf_SPECIAL;
5217             /* FALL THROUGH */
5218         case OP_HELEM:
5219             break;
5220         default:
5221             Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5222                   OP_DESC(o));
5223         }
5224         op_null(kid);
5225     }
5226     return o;
5227 }
5228
5229 OP *
5230 Perl_ck_die(pTHX_ OP *o)
5231 {
5232 #ifdef VMS
5233     if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5234 #endif
5235     return ck_fun(o);
5236 }
5237
5238 OP *
5239 Perl_ck_eof(pTHX_ OP *o)
5240 {
5241     const I32 type = o->op_type;
5242
5243     if (o->op_flags & OPf_KIDS) {
5244         if (cLISTOPo->op_first->op_type == OP_STUB) {
5245             op_free(o);
5246             o = newUNOP(type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
5247         }
5248         return ck_fun(o);
5249     }
5250     return o;
5251 }
5252
5253 OP *
5254 Perl_ck_eval(pTHX_ OP *o)
5255 {
5256     dVAR;
5257     PL_hints |= HINT_BLOCK_SCOPE;
5258     if (o->op_flags & OPf_KIDS) {
5259         SVOP * const kid = (SVOP*)cUNOPo->op_first;
5260
5261         if (!kid) {
5262             o->op_flags &= ~OPf_KIDS;
5263             op_null(o);
5264         }
5265         else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
5266             LOGOP *enter;
5267
5268             cUNOPo->op_first = 0;
5269             op_free(o);
5270
5271             NewOp(1101, enter, 1, LOGOP);
5272             enter->op_type = OP_ENTERTRY;
5273             enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5274             enter->op_private = 0;
5275
5276             /* establish postfix order */
5277             enter->op_next = (OP*)enter;
5278
5279             o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5280             o->op_type = OP_LEAVETRY;
5281             o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5282             enter->op_other = o;
5283             return o;
5284         }
5285         else {
5286             scalar((OP*)kid);
5287             PL_cv_has_eval = 1;
5288         }
5289     }
5290     else {
5291         op_free(o);
5292         o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5293     }
5294     o->op_targ = (PADOFFSET)PL_hints;
5295     if ((PL_hints & HINT_HH_FOR_EVAL) != 0 && GvHV(PL_hintgv))
5296     {
5297         /* Store a copy of %^H that pp_entereval can pick up */
5298         OP *hhop = newSVOP(OP_CONST, 0, (SV*)newHVhv(GvHV(PL_hintgv)));
5299         cUNOPo->op_first->op_sibling = hhop;
5300         o->op_private |= OPpEVAL_HAS_HH;
5301     }
5302     return o;
5303 }
5304
5305 OP *
5306 Perl_ck_exit(pTHX_ OP *o)
5307 {
5308 #ifdef VMS
5309     HV * const table = GvHV(PL_hintgv);
5310     if (table) {
5311        SV * const * const svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
5312        if (svp && *svp && SvTRUE(*svp))
5313            o->op_private |= OPpEXIT_VMSISH;
5314     }
5315     if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5316 #endif
5317     return ck_fun(o);
5318 }
5319
5320 OP *
5321 Perl_ck_exec(pTHX_ OP *o)
5322 {
5323     if (o->op_flags & OPf_STACKED) {
5324         OP *kid;
5325         o = ck_fun(o);
5326         kid = cUNOPo->op_first->op_sibling;
5327         if (kid->op_type == OP_RV2GV)
5328             op_null(kid);
5329     }
5330     else
5331         o = listkids(o);
5332     return o;
5333 }
5334
5335 OP *
5336 Perl_ck_exists(pTHX_ OP *o)
5337 {
5338     o = ck_fun(o);
5339     if (o->op_flags & OPf_KIDS) {
5340         OP * const kid = cUNOPo->op_first;
5341         if (kid->op_type == OP_ENTERSUB) {
5342             (void) ref(kid, o->op_type);
5343             if (kid->op_type != OP_RV2CV && !PL_error_count)
5344                 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5345                             OP_DESC(o));
5346             o->op_private |= OPpEXISTS_SUB;
5347         }
5348         else if (kid->op_type == OP_AELEM)
5349             o->op_flags |= OPf_SPECIAL;
5350         else if (kid->op_type != OP_HELEM)
5351             Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5352                         OP_DESC(o));
5353         op_null(kid);
5354     }
5355     return o;
5356 }
5357
5358 OP *
5359 Perl_ck_rvconst(pTHX_ register OP *o)
5360 {
5361     dVAR;
5362     SVOP * const kid = (SVOP*)cUNOPo->op_first;
5363
5364     o->op_private |= (PL_hints & HINT_STRICT_REFS);
5365     if (kid->op_type == OP_CONST) {
5366         int iscv;
5367         GV *gv;
5368         SV * const kidsv = kid->op_sv;
5369
5370         /* Is it a constant from cv_const_sv()? */
5371         if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5372             SV * const rsv = SvRV(kidsv);
5373             const int svtype = SvTYPE(rsv);
5374             const char *badtype = Nullch;
5375
5376             switch (o->op_type) {
5377             case OP_RV2SV:
5378                 if (svtype > SVt_PVMG)
5379                     badtype = "a SCALAR";
5380                 break;
5381             case OP_RV2AV:
5382                 if (svtype != SVt_PVAV)
5383                     badtype = "an ARRAY";
5384                 break;
5385             case OP_RV2HV:
5386                 if (svtype != SVt_PVHV)
5387                     badtype = "a HASH";
5388                 break;
5389             case OP_RV2CV:
5390                 if (svtype != SVt_PVCV)
5391                     badtype = "a CODE";
5392                 break;
5393             }
5394             if (badtype)
5395                 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5396             return o;
5397         }
5398         if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5399             const char *badthing = Nullch;
5400             switch (o->op_type) {
5401             case OP_RV2SV:
5402                 badthing = "a SCALAR";
5403                 break;
5404             case OP_RV2AV:
5405                 badthing = "an ARRAY";
5406                 break;
5407             case OP_RV2HV:
5408                 badthing = "a HASH";
5409                 break;
5410             }
5411             if (badthing)
5412                 Perl_croak(aTHX_
5413           "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
5414                       kidsv, badthing);
5415         }
5416         /*
5417          * This is a little tricky.  We only want to add the symbol if we
5418          * didn't add it in the lexer.  Otherwise we get duplicate strict
5419          * warnings.  But if we didn't add it in the lexer, we must at
5420          * least pretend like we wanted to add it even if it existed before,
5421          * or we get possible typo warnings.  OPpCONST_ENTERED says
5422          * whether the lexer already added THIS instance of this symbol.
5423          */
5424         iscv = (o->op_type == OP_RV2CV) * 2;
5425         do {
5426             gv = gv_fetchsv(kidsv,
5427                 iscv | !(kid->op_private & OPpCONST_ENTERED),
5428                 iscv
5429                     ? SVt_PVCV
5430                     : o->op_type == OP_RV2SV
5431                         ? SVt_PV
5432                         : o->op_type == OP_RV2AV
5433                             ? SVt_PVAV
5434                             : o->op_type == OP_RV2HV
5435                                 ? SVt_PVHV
5436                                 : SVt_PVGV);
5437         } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5438         if (gv) {
5439             kid->op_type = OP_GV;
5440             SvREFCNT_dec(kid->op_sv);
5441 #ifdef USE_ITHREADS
5442             /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5443             kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5444             SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
5445             GvIN_PAD_on(gv);
5446             PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc(gv));
5447 #else
5448             kid->op_sv = SvREFCNT_inc(gv);
5449 #endif
5450             kid->op_private = 0;
5451             kid->op_ppaddr = PL_ppaddr[OP_GV];
5452         }
5453     }
5454     return o;
5455 }
5456
5457 OP *
5458 Perl_ck_ftst(pTHX_ OP *o)
5459 {
5460     dVAR;
5461     const I32 type = o->op_type;
5462
5463     if (o->op_flags & OPf_REF) {
5464         /* nothing */
5465     }
5466     else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5467         SVOP * const kid = (SVOP*)cUNOPo->op_first;
5468
5469         if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5470             OP * const newop = newGVOP(type, OPf_REF,
5471                 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
5472             op_free(o);
5473             o = newop;
5474             return o;
5475         }
5476         else {
5477           if ((PL_hints & HINT_FILETEST_ACCESS) &&
5478               OP_IS_FILETEST_ACCESS(o))
5479             o->op_private |= OPpFT_ACCESS;
5480         }
5481         if (PL_check[kid->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst)
5482                 && kid->op_type != OP_STAT && kid->op_type != OP_LSTAT)
5483             o->op_private |= OPpFT_STACKED;
5484     }
5485     else {
5486         op_free(o);
5487         if (type == OP_FTTTY)
5488             o = newGVOP(type, OPf_REF, PL_stdingv);
5489         else
5490             o = newUNOP(type, 0, newDEFSVOP());
5491     }
5492     return o;
5493 }
5494
5495 OP *
5496 Perl_ck_fun(pTHX_ OP *o)
5497 {
5498     const int type = o->op_type;
5499     register I32 oa = PL_opargs[type] >> OASHIFT;
5500
5501     if (o->op_flags & OPf_STACKED) {
5502         if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5503             oa &= ~OA_OPTIONAL;
5504         else
5505             return no_fh_allowed(o);
5506     }
5507
5508     if (o->op_flags & OPf_KIDS) {
5509         OP **tokid = &cLISTOPo->op_first;
5510         register OP *kid = cLISTOPo->op_first;
5511         OP *sibl;
5512         I32 numargs = 0;
5513
5514         if (kid->op_type == OP_PUSHMARK ||
5515             (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5516         {
5517             tokid = &kid->op_sibling;
5518             kid = kid->op_sibling;
5519         }
5520         if (!kid && PL_opargs[type] & OA_DEFGV)
5521             *tokid = kid = newDEFSVOP();
5522
5523         while (oa && kid) {
5524             numargs++;
5525             sibl = kid->op_sibling;
5526             switch (oa & 7) {
5527             case OA_SCALAR:
5528                 /* list seen where single (scalar) arg expected? */
5529                 if (numargs == 1 && !(oa >> 4)
5530                     && kid->op_type == OP_LIST && type != OP_SCALAR)
5531                 {
5532                     return too_many_arguments(o,PL_op_desc[type]);
5533                 }
5534                 scalar(kid);
5535                 break;
5536             case OA_LIST:
5537                 if (oa < 16) {
5538                     kid = 0;
5539                     continue;
5540                 }
5541                 else
5542                     list(kid);
5543                 break;
5544             case OA_AVREF:
5545                 if ((type == OP_PUSH || type == OP_UNSHIFT)
5546                     && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5547                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5548                         "Useless use of %s with no values",
5549                         PL_op_desc[type]);
5550
5551                 if (kid->op_type == OP_CONST &&
5552                     (kid->op_private & OPpCONST_BARE))
5553                 {
5554                     OP * const newop = newAVREF(newGVOP(OP_GV, 0,
5555                         gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
5556                     if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5557                         Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5558                             "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
5559                             ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
5560                     op_free(kid);
5561                     kid = newop;
5562                     kid->op_sibling = sibl;
5563                     *tokid = kid;
5564                 }
5565                 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5566                     bad_type(numargs, "array", PL_op_desc[type], kid);
5567                 mod(kid, type);
5568                 break;
5569             case OA_HVREF:
5570                 if (kid->op_type == OP_CONST &&
5571                     (kid->op_private & OPpCONST_BARE))
5572                 {
5573                     OP * const newop = newHVREF(newGVOP(OP_GV, 0,
5574                         gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
5575                     if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5576                         Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5577                             "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
5578                             ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
5579                     op_free(kid);
5580                     kid = newop;
5581                     kid->op_sibling = sibl;
5582                     *tokid = kid;
5583                 }
5584                 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5585                     bad_type(numargs, "hash", PL_op_desc[type], kid);
5586                 mod(kid, type);
5587                 break;
5588             case OA_CVREF:
5589                 {
5590                     OP * const newop = newUNOP(OP_NULL, 0, kid);
5591                     kid->op_sibling = 0;
5592                     linklist(kid);
5593                     newop->op_next = newop;
5594                     kid = newop;
5595                     kid->op_sibling = sibl;
5596                     *tokid = kid;
5597                 }
5598                 break;
5599             case OA_FILEREF:
5600                 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5601                     if (kid->op_type == OP_CONST &&
5602                         (kid->op_private & OPpCONST_BARE))
5603                     {
5604                         OP * const newop = newGVOP(OP_GV, 0,
5605                             gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
5606                         if (!(o->op_private & 1) && /* if not unop */
5607                             kid == cLISTOPo->op_last)
5608                             cLISTOPo->op_last = newop;
5609                         op_free(kid);
5610                         kid = newop;
5611                     }
5612                     else if (kid->op_type == OP_READLINE) {
5613                         /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5614                         bad_type(numargs, "HANDLE", OP_DESC(o), kid);
5615                     }
5616                     else {
5617                         I32 flags = OPf_SPECIAL;
5618                         I32 priv = 0;
5619                         PADOFFSET targ = 0;
5620
5621                         /* is this op a FH constructor? */
5622                         if (is_handle_constructor(o,numargs)) {
5623                             const char *name = Nullch;
5624                             STRLEN len = 0;
5625
5626                             flags = 0;
5627                             /* Set a flag to tell rv2gv to vivify
5628                              * need to "prove" flag does not mean something
5629                              * else already - NI-S 1999/05/07
5630                              */
5631                             priv = OPpDEREF;
5632                             if (kid->op_type == OP_PADSV) {
5633                                 name = PAD_COMPNAME_PV(kid->op_targ);
5634                                 /* SvCUR of a pad namesv can't be trusted
5635                                  * (see PL_generation), so calc its length
5636                                  * manually */
5637                                 if (name)
5638                                     len = strlen(name);
5639
5640                             }
5641                             else if (kid->op_type == OP_RV2SV
5642                                      && kUNOP->op_first->op_type == OP_GV)
5643                             {
5644                                 GV * const gv = cGVOPx_gv(kUNOP->op_first);
5645                                 name = GvNAME(gv);
5646                                 len = GvNAMELEN(gv);
5647                             }
5648                             else if (kid->op_type == OP_AELEM
5649                                      || kid->op_type == OP_HELEM)
5650                             {
5651                                  OP *op = ((BINOP*)kid)->op_first;
5652                                  name = 0;
5653                                  if (op) {
5654                                       SV *tmpstr = Nullsv;
5655                                       const char * const a =
5656                                            kid->op_type == OP_AELEM ?
5657                                            "[]" : "{}";
5658                                       if (((op->op_type == OP_RV2AV) ||
5659                                            (op->op_type == OP_RV2HV)) &&
5660                                           (op = ((UNOP*)op)->op_first) &&
5661                                           (op->op_type == OP_GV)) {
5662                                            /* packagevar $a[] or $h{} */
5663                                            GV * const gv = cGVOPx_gv(op);
5664                                            if (gv)
5665                                                 tmpstr =
5666                                                      Perl_newSVpvf(aTHX_
5667                                                                    "%s%c...%c",
5668                                                                    GvNAME(gv),
5669                                                                    a[0], a[1]);
5670                                       }
5671                                       else if (op->op_type == OP_PADAV
5672                                                || op->op_type == OP_PADHV) {
5673                                            /* lexicalvar $a[] or $h{} */
5674                                            const char * const padname =
5675                                                 PAD_COMPNAME_PV(op->op_targ);
5676                                            if (padname)
5677                                                 tmpstr =
5678                                                      Perl_newSVpvf(aTHX_
5679                                                                    "%s%c...%c",
5680                                                                    padname + 1,
5681                                                                    a[0], a[1]);
5682                                       }
5683                                       if (tmpstr) {
5684                                            name = SvPV_const(tmpstr, len);
5685                                            sv_2mortal(tmpstr);
5686                                       }
5687                                  }
5688                                  if (!name) {
5689                                       name = "__ANONIO__";
5690                                       len = 10;
5691                                  }
5692                                  mod(kid, type);
5693                             }
5694                             if (name) {
5695                                 SV *namesv;
5696                                 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5697                                 namesv = PAD_SVl(targ);
5698                                 SvUPGRADE(namesv, SVt_PV);
5699                                 if (*name != '$')
5700                                     sv_setpvn(namesv, "$", 1);
5701                                 sv_catpvn(namesv, name, len);
5702                             }
5703                         }
5704                         kid->op_sibling = 0;
5705                         kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5706                         kid->op_targ = targ;
5707                         kid->op_private |= priv;
5708                     }
5709                     kid->op_sibling = sibl;
5710                     *tokid = kid;
5711                 }
5712                 scalar(kid);
5713                 break;
5714             case OA_SCALARREF:
5715                 mod(scalar(kid), type);
5716                 break;
5717             }
5718             oa >>= 4;
5719             tokid = &kid->op_sibling;
5720             kid = kid->op_sibling;
5721         }
5722         o->op_private |= numargs;
5723         if (kid)
5724             return too_many_arguments(o,OP_DESC(o));
5725         listkids(o);
5726     }
5727     else if (PL_opargs[type] & OA_DEFGV) {
5728         op_free(o);
5729         return newUNOP(type, 0, newDEFSVOP());
5730     }
5731
5732     if (oa) {
5733         while (oa & OA_OPTIONAL)
5734             oa >>= 4;
5735         if (oa && oa != OA_LIST)
5736             return too_few_arguments(o,OP_DESC(o));
5737     }
5738     return o;
5739 }
5740
5741 OP *
5742 Perl_ck_glob(pTHX_ OP *o)
5743 {
5744     dVAR;
5745     GV *gv;
5746
5747     o = ck_fun(o);
5748     if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5749         append_elem(OP_GLOB, o, newDEFSVOP());
5750
5751     if (!((gv = gv_fetchpv("glob", 0, SVt_PVCV))
5752           && GvCVu(gv) && GvIMPORTED_CV(gv)))
5753     {
5754         gv = gv_fetchpv("CORE::GLOBAL::glob", 0, SVt_PVCV);
5755     }
5756
5757 #if !defined(PERL_EXTERNAL_GLOB)
5758     /* XXX this can be tightened up and made more failsafe. */
5759     if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
5760         GV *glob_gv;
5761         ENTER;
5762         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
5763                 newSVpvn("File::Glob", 10), Nullsv, Nullsv, Nullsv);
5764         gv = gv_fetchpv("CORE::GLOBAL::glob", 0, SVt_PVCV);
5765         glob_gv = gv_fetchpv("File::Glob::csh_glob", 0, SVt_PVCV);
5766         GvCV(gv) = GvCV(glob_gv);
5767         (void)SvREFCNT_inc((SV*)GvCV(gv));
5768         GvIMPORTED_CV_on(gv);
5769         LEAVE;
5770     }
5771 #endif /* PERL_EXTERNAL_GLOB */
5772
5773     if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5774         append_elem(OP_GLOB, o,
5775                     newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5776         o->op_type = OP_LIST;
5777         o->op_ppaddr = PL_ppaddr[OP_LIST];
5778         cLISTOPo->op_first->op_type = OP_PUSHMARK;
5779         cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5780         cLISTOPo->op_first->op_targ = 0;
5781         o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5782                     append_elem(OP_LIST, o,
5783                                 scalar(newUNOP(OP_RV2CV, 0,
5784                                                newGVOP(OP_GV, 0, gv)))));
5785         o = newUNOP(OP_NULL, 0, ck_subr(o));
5786         o->op_targ = OP_GLOB;           /* hint at what it used to be */
5787         return o;
5788     }
5789     gv = newGVgen("main");
5790     gv_IOadd(gv);
5791     append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5792     scalarkids(o);
5793     return o;
5794 }
5795
5796 OP *
5797 Perl_ck_grep(pTHX_ OP *o)
5798 {
5799     dVAR;
5800     LOGOP *gwop;
5801     OP *kid;
5802     const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5803     I32 offset;
5804
5805     o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5806     NewOp(1101, gwop, 1, LOGOP);
5807
5808     if (o->op_flags & OPf_STACKED) {
5809         OP* k;
5810         o = ck_sort(o);
5811         kid = cLISTOPo->op_first->op_sibling;
5812         if (!cUNOPx(kid)->op_next)
5813             Perl_croak(aTHX_ "panic: ck_grep");
5814         for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
5815             kid = k;
5816         }
5817         kid->op_next = (OP*)gwop;
5818         o->op_flags &= ~OPf_STACKED;
5819     }
5820     kid = cLISTOPo->op_first->op_sibling;
5821     if (type == OP_MAPWHILE)
5822         list(kid);
5823     else
5824         scalar(kid);
5825     o = ck_fun(o);
5826     if (PL_error_count)
5827         return o;
5828     kid = cLISTOPo->op_first->op_sibling;
5829     if (kid->op_type != OP_NULL)
5830         Perl_croak(aTHX_ "panic: ck_grep");
5831     kid = kUNOP->op_first;
5832
5833     gwop->op_type = type;
5834     gwop->op_ppaddr = PL_ppaddr[type];
5835     gwop->op_first = listkids(o);
5836     gwop->op_flags |= OPf_KIDS;
5837     gwop->op_other = LINKLIST(kid);
5838     kid->op_next = (OP*)gwop;
5839     offset = pad_findmy("$_");
5840     if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
5841         o->op_private = gwop->op_private = 0;
5842         gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5843     }
5844     else {
5845         o->op_private = gwop->op_private = OPpGREP_LEX;
5846         gwop->op_targ = o->op_targ = offset;
5847     }
5848
5849     kid = cLISTOPo->op_first->op_sibling;
5850     if (!kid || !kid->op_sibling)
5851         return too_few_arguments(o,OP_DESC(o));
5852     for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5853         mod(kid, OP_GREPSTART);
5854
5855     return (OP*)gwop;
5856 }
5857
5858 OP *
5859 Perl_ck_index(pTHX_ OP *o)
5860 {
5861     if (o->op_flags & OPf_KIDS) {
5862         OP *kid = cLISTOPo->op_first->op_sibling;       /* get past pushmark */
5863         if (kid)
5864             kid = kid->op_sibling;                      /* get past "big" */
5865         if (kid && kid->op_type == OP_CONST)
5866             fbm_compile(((SVOP*)kid)->op_sv, 0);
5867     }
5868     return ck_fun(o);
5869 }
5870
5871 OP *
5872 Perl_ck_lengthconst(pTHX_ OP *o)
5873 {
5874     /* XXX length optimization goes here */
5875     return ck_fun(o);
5876 }
5877
5878 OP *
5879 Perl_ck_lfun(pTHX_ OP *o)
5880 {
5881     const OPCODE type = o->op_type;
5882     return modkids(ck_fun(o), type);
5883 }
5884
5885 OP *
5886 Perl_ck_defined(pTHX_ OP *o)            /* 19990527 MJD */
5887 {
5888     if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
5889         switch (cUNOPo->op_first->op_type) {
5890         case OP_RV2AV:
5891             /* This is needed for
5892                if (defined %stash::)
5893                to work.   Do not break Tk.
5894                */
5895             break;                      /* Globals via GV can be undef */
5896         case OP_PADAV:
5897         case OP_AASSIGN:                /* Is this a good idea? */
5898             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5899                         "defined(@array) is deprecated");
5900             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5901                         "\t(Maybe you should just omit the defined()?)\n");
5902         break;
5903         case OP_RV2HV:
5904             /* This is needed for
5905                if (defined %stash::)
5906                to work.   Do not break Tk.
5907                */
5908             break;                      /* Globals via GV can be undef */
5909         case OP_PADHV:
5910             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5911                         "defined(%%hash) is deprecated");
5912             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5913                         "\t(Maybe you should just omit the defined()?)\n");
5914             break;
5915         default:
5916             /* no warning */
5917             break;
5918         }
5919     }
5920     return ck_rfun(o);
5921 }
5922
5923 OP *
5924 Perl_ck_rfun(pTHX_ OP *o)
5925 {
5926     const OPCODE type = o->op_type;
5927     return refkids(ck_fun(o), type);
5928 }
5929
5930 OP *
5931 Perl_ck_listiob(pTHX_ OP *o)
5932 {
5933     register OP *kid;
5934
5935     kid = cLISTOPo->op_first;
5936     if (!kid) {
5937         o = force_list(o);
5938         kid = cLISTOPo->op_first;
5939     }
5940     if (kid->op_type == OP_PUSHMARK)
5941         kid = kid->op_sibling;
5942     if (kid && o->op_flags & OPf_STACKED)
5943         kid = kid->op_sibling;
5944     else if (kid && !kid->op_sibling) {         /* print HANDLE; */
5945         if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
5946             o->op_flags |= OPf_STACKED; /* make it a filehandle */
5947             kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
5948             cLISTOPo->op_first->op_sibling = kid;
5949             cLISTOPo->op_last = kid;
5950             kid = kid->op_sibling;
5951         }
5952     }
5953
5954     if (!kid)
5955         append_elem(o->op_type, o, newDEFSVOP());
5956
5957     return listkids(o);
5958 }
5959
5960 OP *
5961 Perl_ck_say(pTHX_ OP *o)
5962 {
5963     o = ck_listiob(o);
5964     o->op_type = OP_PRINT;
5965     cLISTOPo->op_last = cLISTOPo->op_last->op_sibling
5966         = newSVOP(OP_CONST, 0, newSVpvn("\n", 1));
5967     return o;
5968 }
5969
5970 OP *
5971 Perl_ck_smartmatch(pTHX_ OP *o)
5972 {
5973     if (0 == (o->op_flags & OPf_SPECIAL)) {
5974         OP *first  = cBINOPo->op_first;
5975         OP *second = first->op_sibling;
5976
5977         /* Implicitly take a reference to an array or hash */
5978         first->op_sibling = Nullop;
5979         first = cBINOPo->op_first = ref_array_or_hash(first);
5980         second = first->op_sibling = ref_array_or_hash(second);
5981
5982         /* Implicitly take a reference to a regular expression */
5983         if (first->op_type == OP_MATCH) {
5984             first->op_type = OP_QR;
5985             first->op_ppaddr = PL_ppaddr[OP_QR];
5986         }
5987         if (second->op_type == OP_MATCH) {
5988             second->op_type = OP_QR;
5989             second->op_ppaddr = PL_ppaddr[OP_QR];
5990         }
5991     }
5992
5993     return o;
5994 }
5995
5996
5997 OP *
5998 Perl_ck_sassign(pTHX_ OP *o)
5999 {
6000     OP *kid = cLISTOPo->op_first;
6001     /* has a disposable target? */
6002     if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6003         && !(kid->op_flags & OPf_STACKED)
6004         /* Cannot steal the second time! */
6005         && !(kid->op_private & OPpTARGET_MY))
6006     {
6007         OP * const kkid = kid->op_sibling;
6008
6009         /* Can just relocate the target. */
6010         if (kkid && kkid->op_type == OP_PADSV
6011             && !(kkid->op_private & OPpLVAL_INTRO))
6012         {
6013             kid->op_targ = kkid->op_targ;
6014             kkid->op_targ = 0;
6015             /* Now we do not need PADSV and SASSIGN. */
6016             kid->op_sibling = o->op_sibling;    /* NULL */
6017             cLISTOPo->op_first = NULL;
6018             op_free(o);
6019             op_free(kkid);
6020             kid->op_private |= OPpTARGET_MY;    /* Used for context settings */
6021             return kid;
6022         }
6023     }
6024     return o;
6025 }
6026
6027 OP *
6028 Perl_ck_match(pTHX_ OP *o)
6029 {
6030     if (o->op_type != OP_QR && PL_compcv) {
6031         const I32 offset = pad_findmy("$_");
6032         if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS(offset) & SVpad_OUR)) {
6033             o->op_targ = offset;
6034             o->op_private |= OPpTARGET_MY;
6035         }
6036     }
6037     if (o->op_type == OP_MATCH || o->op_type == OP_QR)
6038         o->op_private |= OPpRUNTIME;
6039     return o;
6040 }
6041
6042 OP *
6043 Perl_ck_method(pTHX_ OP *o)
6044 {
6045     OP * const kid = cUNOPo->op_first;
6046     if (kid->op_type == OP_CONST) {
6047         SV* sv = kSVOP->op_sv;
6048         if (!(strchr(SvPVX_const(sv), ':') || strchr(SvPVX_const(sv), '\''))) {
6049             OP *cmop;
6050             if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6051                 sv = newSVpvn_share(SvPVX_const(sv), SvCUR(sv), 0);
6052             }
6053             else {
6054                 kSVOP->op_sv = Nullsv;
6055             }
6056             cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6057             op_free(o);
6058             return cmop;
6059         }
6060     }
6061     return o;
6062 }
6063
6064 OP *
6065 Perl_ck_null(pTHX_ OP *o)
6066 {
6067     return o;
6068 }
6069
6070 OP *
6071 Perl_ck_open(pTHX_ OP *o)
6072 {
6073     HV * const table = GvHV(PL_hintgv);
6074     if (table) {
6075         SV **svp = hv_fetch(table, "open_IN", 7, FALSE);
6076         if (svp && *svp) {
6077             const I32 mode = mode_from_discipline(*svp);
6078             if (mode & O_BINARY)
6079                 o->op_private |= OPpOPEN_IN_RAW;
6080             else if (mode & O_TEXT)
6081                 o->op_private |= OPpOPEN_IN_CRLF;
6082         }
6083
6084         svp = hv_fetch(table, "open_OUT", 8, FALSE);
6085         if (svp && *svp) {
6086             const I32 mode = mode_from_discipline(*svp);
6087             if (mode & O_BINARY)
6088                 o->op_private |= OPpOPEN_OUT_RAW;
6089             else if (mode & O_TEXT)
6090                 o->op_private |= OPpOPEN_OUT_CRLF;
6091         }
6092     }
6093     if (o->op_type == OP_BACKTICK)
6094         return o;
6095     {
6096          /* In case of three-arg dup open remove strictness
6097           * from the last arg if it is a bareword. */
6098          OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
6099          OP * const last  = cLISTOPx(o)->op_last;  /* The bareword. */
6100          OP *oa;
6101          const char *mode;
6102
6103          if ((last->op_type == OP_CONST) &&             /* The bareword. */
6104              (last->op_private & OPpCONST_BARE) &&
6105              (last->op_private & OPpCONST_STRICT) &&
6106              (oa = first->op_sibling) &&                /* The fh. */
6107              (oa = oa->op_sibling) &&                   /* The mode. */
6108              (oa->op_type == OP_CONST) &&
6109              SvPOK(((SVOP*)oa)->op_sv) &&
6110              (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
6111              mode[0] == '>' && mode[1] == '&' &&        /* A dup open. */
6112              (last == oa->op_sibling))                  /* The bareword. */
6113               last->op_private &= ~OPpCONST_STRICT;
6114     }
6115     return ck_fun(o);
6116 }
6117
6118 OP *
6119 Perl_ck_repeat(pTHX_ OP *o)
6120 {
6121     if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6122         o->op_private |= OPpREPEAT_DOLIST;
6123         cBINOPo->op_first = force_list(cBINOPo->op_first);
6124     }
6125     else
6126         scalar(o);
6127     return o;
6128 }
6129
6130 OP *
6131 Perl_ck_require(pTHX_ OP *o)
6132 {
6133     GV* gv = Nullgv;
6134
6135     if (o->op_flags & OPf_KIDS) {       /* Shall we supply missing .pm? */
6136         SVOP * const kid = (SVOP*)cUNOPo->op_first;
6137
6138         if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6139             SV * const sv = kid->op_sv;
6140             U32 was_readonly = SvREADONLY(sv);
6141             char *s;
6142
6143             if (was_readonly) {
6144                 if (SvFAKE(sv)) {
6145                     sv_force_normal_flags(sv, 0);
6146                     assert(!SvREADONLY(sv));
6147                     was_readonly = 0;
6148                 } else {
6149                     SvREADONLY_off(sv);
6150                 }
6151             }
6152
6153             for (s = SvPVX(sv); *s; s++) {
6154                 if (*s == ':' && s[1] == ':') {
6155                     const STRLEN len = strlen(s+2)+1;
6156                     *s = '/';
6157                     Move(s+2, s+1, len, char);
6158                     SvCUR_set(sv, SvCUR(sv) - 1);
6159                 }
6160             }
6161             sv_catpvn(sv, ".pm", 3);
6162             SvFLAGS(sv) |= was_readonly;
6163         }
6164     }
6165
6166     if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
6167         /* handle override, if any */
6168         gv = gv_fetchpv("require", 0, SVt_PVCV);
6169         if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
6170             GV * const * const gvp = (GV**)hv_fetch(PL_globalstash, "require", 7, FALSE);
6171             gv = gvp ? *gvp : Nullgv;
6172         }
6173     }
6174
6175     if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6176         OP * const kid = cUNOPo->op_first;
6177         cUNOPo->op_first = 0;
6178         op_free(o);
6179         return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
6180                                append_elem(OP_LIST, kid,
6181                                            scalar(newUNOP(OP_RV2CV, 0,
6182                                                           newGVOP(OP_GV, 0,
6183                                                                   gv))))));
6184     }
6185
6186     return ck_fun(o);
6187 }
6188
6189 OP *
6190 Perl_ck_return(pTHX_ OP *o)
6191 {
6192     if (CvLVALUE(PL_compcv)) {
6193         OP *kid;
6194         for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
6195             mod(kid, OP_LEAVESUBLV);
6196     }
6197     return o;
6198 }
6199
6200 OP *
6201 Perl_ck_select(pTHX_ OP *o)
6202 {
6203     dVAR;
6204     OP* kid;
6205     if (o->op_flags & OPf_KIDS) {
6206         kid = cLISTOPo->op_first->op_sibling;   /* get past pushmark */
6207         if (kid && kid->op_sibling) {
6208             o->op_type = OP_SSELECT;
6209             o->op_ppaddr = PL_ppaddr[OP_SSELECT];
6210             o = ck_fun(o);
6211             return fold_constants(o);
6212         }
6213     }
6214     o = ck_fun(o);
6215     kid = cLISTOPo->op_first->op_sibling;    /* get past pushmark */
6216     if (kid && kid->op_type == OP_RV2GV)
6217         kid->op_private &= ~HINT_STRICT_REFS;
6218     return o;
6219 }
6220
6221 OP *
6222 Perl_ck_shift(pTHX_ OP *o)
6223 {
6224     const I32 type = o->op_type;
6225
6226     if (!(o->op_flags & OPf_KIDS)) {
6227         OP *argop;
6228
6229         op_free(o);
6230         argop = newUNOP(OP_RV2AV, 0,
6231             scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
6232         return newUNOP(type, 0, scalar(argop));
6233     }
6234     return scalar(modkids(ck_fun(o), type));
6235 }
6236
6237 OP *
6238 Perl_ck_sort(pTHX_ OP *o)
6239 {
6240     OP *firstkid;
6241
6242     if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0)
6243     {
6244         HV *hinthv = GvHV(PL_hintgv);
6245         if (hinthv) {
6246             SV **svp = hv_fetch(hinthv, "sort", 4, 0);
6247             if (svp) {
6248                 I32 sorthints = (I32)SvIV(*svp);
6249                 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
6250                     o->op_private |= OPpSORT_QSORT;
6251                 if ((sorthints & HINT_SORT_STABLE) != 0)
6252                     o->op_private |= OPpSORT_STABLE;
6253             }
6254         }
6255     }
6256
6257     if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6258         simplify_sort(o);
6259     firstkid = cLISTOPo->op_first->op_sibling;          /* get past pushmark */
6260     if (o->op_flags & OPf_STACKED) {                    /* may have been cleared */
6261         OP *k = NULL;
6262         OP *kid = cUNOPx(firstkid)->op_first;           /* get past null */
6263
6264         if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
6265             linklist(kid);
6266             if (kid->op_type == OP_SCOPE) {
6267                 k = kid->op_next;
6268                 kid->op_next = 0;
6269             }
6270             else if (kid->op_type == OP_LEAVE) {
6271                 if (o->op_type == OP_SORT) {
6272                     op_null(kid);                       /* wipe out leave */
6273                     kid->op_next = kid;
6274
6275                     for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6276                         if (k->op_next == kid)
6277                             k->op_next = 0;
6278                         /* don't descend into loops */
6279                         else if (k->op_type == OP_ENTERLOOP
6280                                  || k->op_type == OP_ENTERITER)
6281                         {
6282                             k = cLOOPx(k)->op_lastop;
6283                         }
6284                     }
6285                 }
6286                 else
6287                     kid->op_next = 0;           /* just disconnect the leave */
6288                 k = kLISTOP->op_first;
6289             }
6290             CALL_PEEP(k);
6291
6292             kid = firstkid;
6293             if (o->op_type == OP_SORT) {
6294                 /* provide scalar context for comparison function/block */
6295                 kid = scalar(kid);
6296                 kid->op_next = kid;
6297             }
6298             else
6299                 kid->op_next = k;
6300             o->op_flags |= OPf_SPECIAL;
6301         }
6302         else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6303             op_null(firstkid);
6304
6305         firstkid = firstkid->op_sibling;
6306     }
6307
6308     /* provide list context for arguments */
6309     if (o->op_type == OP_SORT)
6310         list(firstkid);
6311
6312     return o;
6313 }
6314
6315 STATIC void
6316 S_simplify_sort(pTHX_ OP *o)
6317 {
6318     register OP *kid = cLISTOPo->op_first->op_sibling;  /* get past pushmark */
6319     OP *k;
6320     int descending;
6321     GV *gv;
6322     const char *gvname;
6323     if (!(o->op_flags & OPf_STACKED))
6324         return;
6325     GvMULTI_on(gv_fetchpv("a", GV_ADD, SVt_PV));
6326     GvMULTI_on(gv_fetchpv("b", GV_ADD, SVt_PV));
6327     kid = kUNOP->op_first;                              /* get past null */
6328     if (kid->op_type != OP_SCOPE)
6329         return;
6330     kid = kLISTOP->op_last;                             /* get past scope */
6331     switch(kid->op_type) {
6332         case OP_NCMP:
6333         case OP_I_NCMP:
6334         case OP_SCMP:
6335             break;
6336         default:
6337             return;
6338     }
6339     k = kid;                                            /* remember this node*/
6340     if (kBINOP->op_first->op_type != OP_RV2SV)
6341         return;
6342     kid = kBINOP->op_first;                             /* get past cmp */
6343     if (kUNOP->op_first->op_type != OP_GV)
6344         return;
6345     kid = kUNOP->op_first;                              /* get past rv2sv */
6346     gv = kGVOP_gv;
6347     if (GvSTASH(gv) != PL_curstash)
6348         return;
6349     gvname = GvNAME(gv);
6350     if (*gvname == 'a' && gvname[1] == '\0')
6351         descending = 0;
6352     else if (*gvname == 'b' && gvname[1] == '\0')
6353         descending = 1;
6354     else
6355         return;
6356
6357     kid = k;                                            /* back to cmp */
6358     if (kBINOP->op_last->op_type != OP_RV2SV)
6359         return;
6360     kid = kBINOP->op_last;                              /* down to 2nd arg */
6361     if (kUNOP->op_first->op_type != OP_GV)
6362         return;
6363     kid = kUNOP->op_first;                              /* get past rv2sv */
6364     gv = kGVOP_gv;
6365     if (GvSTASH(gv) != PL_curstash)
6366         return;
6367     gvname = GvNAME(gv);
6368     if ( descending
6369          ? !(*gvname == 'a' && gvname[1] == '\0')
6370          : !(*gvname == 'b' && gvname[1] == '\0'))
6371         return;
6372     o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6373     if (descending)
6374         o->op_private |= OPpSORT_DESCEND;
6375     if (k->op_type == OP_NCMP)
6376         o->op_private |= OPpSORT_NUMERIC;
6377     if (k->op_type == OP_I_NCMP)
6378         o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6379     kid = cLISTOPo->op_first->op_sibling;
6380     cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6381     op_free(kid);                                     /* then delete it */
6382 }
6383
6384 OP *
6385 Perl_ck_split(pTHX_ OP *o)
6386 {
6387     dVAR;
6388     register OP *kid;
6389
6390     if (o->op_flags & OPf_STACKED)
6391         return no_fh_allowed(o);
6392
6393     kid = cLISTOPo->op_first;
6394     if (kid->op_type != OP_NULL)
6395         Perl_croak(aTHX_ "panic: ck_split");
6396     kid = kid->op_sibling;
6397     op_free(cLISTOPo->op_first);
6398     cLISTOPo->op_first = kid;
6399     if (!kid) {
6400         cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
6401         cLISTOPo->op_last = kid; /* There was only one element previously */
6402     }
6403
6404     if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6405         OP * const sibl = kid->op_sibling;
6406         kid->op_sibling = 0;
6407         kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
6408         if (cLISTOPo->op_first == cLISTOPo->op_last)
6409             cLISTOPo->op_last = kid;
6410         cLISTOPo->op_first = kid;
6411         kid->op_sibling = sibl;
6412     }
6413
6414     kid->op_type = OP_PUSHRE;
6415     kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6416     scalar(kid);
6417     if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL && ckWARN(WARN_REGEXP)) {
6418       Perl_warner(aTHX_ packWARN(WARN_REGEXP),
6419                   "Use of /g modifier is meaningless in split");
6420     }
6421
6422     if (!kid->op_sibling)
6423         append_elem(OP_SPLIT, o, newDEFSVOP());
6424
6425     kid = kid->op_sibling;
6426     scalar(kid);
6427
6428     if (!kid->op_sibling)
6429         append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6430
6431     kid = kid->op_sibling;
6432     scalar(kid);
6433
6434     if (kid->op_sibling)
6435         return too_many_arguments(o,OP_DESC(o));
6436
6437     return o;
6438 }
6439
6440 OP *
6441 Perl_ck_join(pTHX_ OP *o)
6442 {
6443     const OP * const kid = cLISTOPo->op_first->op_sibling;
6444     if (kid && kid->op_type == OP_MATCH) {
6445         if (ckWARN(WARN_SYNTAX)) {
6446             const REGEXP *re = PM_GETRE(kPMOP);
6447             const char *pmstr = re ? re->precomp : "STRING";
6448             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6449                         "/%s/ should probably be written as \"%s\"",
6450                         pmstr, pmstr);
6451         }
6452     }
6453     return ck_fun(o);
6454 }
6455
6456 OP *
6457 Perl_ck_subr(pTHX_ OP *o)
6458 {
6459     OP *prev = ((cUNOPo->op_first->op_sibling)
6460              ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6461     OP *o2 = prev->op_sibling;
6462     OP *cvop;
6463     char *proto = 0;
6464     CV *cv = 0;
6465     GV *namegv = 0;
6466     int optional = 0;
6467     I32 arg = 0;
6468     I32 contextclass = 0;
6469     char *e = 0;
6470     bool delete_op = 0;
6471
6472     o->op_private |= OPpENTERSUB_HASTARG;
6473     for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6474     if (cvop->op_type == OP_RV2CV) {
6475         SVOP* tmpop;
6476         o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6477         op_null(cvop);          /* disable rv2cv */
6478         tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6479         if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6480             GV *gv = cGVOPx_gv(tmpop);
6481             cv = GvCVu(gv);
6482             if (!cv)
6483                 tmpop->op_private |= OPpEARLY_CV;
6484             else {
6485                 if (SvPOK(cv)) {
6486                     namegv = CvANON(cv) ? gv : CvGV(cv);
6487                     proto = SvPV_nolen((SV*)cv);
6488                 }
6489                 if (CvASSERTION(cv)) {
6490                     if (PL_hints & HINT_ASSERTING) {
6491                         if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
6492                             o->op_private |= OPpENTERSUB_DB;
6493                     }
6494                     else {
6495                         delete_op = 1;
6496                         if (!(PL_hints & HINT_ASSERTIONSSEEN) && ckWARN(WARN_ASSERTIONS)) {
6497                             Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
6498                                         "Impossible to activate assertion call");
6499                         }
6500                     }
6501                 }
6502             }
6503         }
6504     }
6505     else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6506         if (o2->op_type == OP_CONST)
6507             o2->op_private &= ~OPpCONST_STRICT;
6508         else if (o2->op_type == OP_LIST) {
6509             OP * const o = ((UNOP*)o2)->op_first->op_sibling;
6510             if (o && o->op_type == OP_CONST)
6511                 o->op_private &= ~OPpCONST_STRICT;
6512         }
6513     }
6514     o->op_private |= (PL_hints & HINT_STRICT_REFS);
6515     if (PERLDB_SUB && PL_curstash != PL_debstash)
6516         o->op_private |= OPpENTERSUB_DB;
6517     while (o2 != cvop) {
6518         if (proto) {
6519             switch (*proto) {
6520             case '\0':
6521                 return too_many_arguments(o, gv_ename(namegv));
6522             case ';':
6523                 optional = 1;
6524                 proto++;
6525                 continue;
6526             case '$':
6527                 proto++;
6528                 arg++;
6529                 scalar(o2);
6530                 break;
6531             case '%':
6532             case '@':
6533                 list(o2);
6534                 arg++;
6535                 break;
6536             case '&':
6537                 proto++;
6538                 arg++;
6539                 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6540                     bad_type(arg,
6541                         arg == 1 ? "block or sub {}" : "sub {}",
6542                         gv_ename(namegv), o2);
6543                 break;
6544             case '*':
6545                 /* '*' allows any scalar type, including bareword */
6546                 proto++;
6547                 arg++;
6548                 if (o2->op_type == OP_RV2GV)
6549                     goto wrapref;       /* autoconvert GLOB -> GLOBref */
6550                 else if (o2->op_type == OP_CONST)
6551                     o2->op_private &= ~OPpCONST_STRICT;
6552                 else if (o2->op_type == OP_ENTERSUB) {
6553                     /* accidental subroutine, revert to bareword */
6554                     OP *gvop = ((UNOP*)o2)->op_first;
6555                     if (gvop && gvop->op_type == OP_NULL) {
6556                         gvop = ((UNOP*)gvop)->op_first;
6557                         if (gvop) {
6558                             for (; gvop->op_sibling; gvop = gvop->op_sibling)
6559                                 ;
6560                             if (gvop &&
6561                                 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6562                                 (gvop = ((UNOP*)gvop)->op_first) &&
6563                                 gvop->op_type == OP_GV)
6564                             {
6565                                 GV * const gv = cGVOPx_gv(gvop);
6566                                 OP * const sibling = o2->op_sibling;
6567                                 SV * const n = newSVpvn("",0);
6568                                 op_free(o2);
6569                                 gv_fullname4(n, gv, "", FALSE);
6570                                 o2 = newSVOP(OP_CONST, 0, n);
6571                                 prev->op_sibling = o2;
6572                                 o2->op_sibling = sibling;
6573                             }
6574                         }
6575                     }
6576                 }
6577                 scalar(o2);
6578                 break;
6579             case '[': case ']':
6580                  goto oops;
6581                  break;
6582             case '\\':
6583                 proto++;
6584                 arg++;
6585             again:
6586                 switch (*proto++) {
6587                 case '[':
6588                      if (contextclass++ == 0) {
6589                           e = strchr(proto, ']');
6590                           if (!e || e == proto)
6591                                goto oops;
6592                      }
6593                      else
6594                           goto oops;
6595                      goto again;
6596                      break;
6597                 case ']':
6598                      if (contextclass) {
6599                          /* XXX We shouldn't be modifying proto, so we can const proto */
6600                          char *p = proto;
6601                          const char s = *p;
6602                          contextclass = 0;
6603                          *p = '\0';
6604                          while (*--p != '[');
6605                          bad_type(arg, Perl_form(aTHX_ "one of %s", p),
6606                                  gv_ename(namegv), o2);
6607                          *proto = s;
6608                      } else
6609                           goto oops;
6610                      break;
6611                 case '*':
6612                      if (o2->op_type == OP_RV2GV)
6613                           goto wrapref;
6614                      if (!contextclass)
6615                           bad_type(arg, "symbol", gv_ename(namegv), o2);
6616                      break;
6617                 case '&':
6618                      if (o2->op_type == OP_ENTERSUB)
6619                           goto wrapref;
6620                      if (!contextclass)
6621                           bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6622                      break;
6623                 case '$':
6624                     if (o2->op_type == OP_RV2SV ||
6625                         o2->op_type == OP_PADSV ||
6626                         o2->op_type == OP_HELEM ||
6627                         o2->op_type == OP_AELEM ||
6628                         o2->op_type == OP_THREADSV)
6629                          goto wrapref;
6630                     if (!contextclass)
6631                         bad_type(arg, "scalar", gv_ename(namegv), o2);
6632                      break;
6633                 case '@':
6634                     if (o2->op_type == OP_RV2AV ||
6635                         o2->op_type == OP_PADAV)
6636                          goto wrapref;
6637                     if (!contextclass)
6638                         bad_type(arg, "array", gv_ename(namegv), o2);
6639                     break;
6640                 case '%':
6641                     if (o2->op_type == OP_RV2HV ||
6642                         o2->op_type == OP_PADHV)
6643                          goto wrapref;
6644                     if (!contextclass)
6645                          bad_type(arg, "hash", gv_ename(namegv), o2);
6646                     break;
6647                 wrapref:
6648                     {
6649                         OP* const kid = o2;
6650                         OP* const sib = kid->op_sibling;
6651                         kid->op_sibling = 0;
6652                         o2 = newUNOP(OP_REFGEN, 0, kid);
6653                         o2->op_sibling = sib;
6654                         prev->op_sibling = o2;
6655                     }
6656                     if (contextclass && e) {
6657                          proto = e + 1;
6658                          contextclass = 0;
6659                     }
6660                     break;
6661                 default: goto oops;
6662                 }
6663                 if (contextclass)
6664                      goto again;
6665                 break;
6666             case ' ':
6667                 proto++;
6668                 continue;
6669             default:
6670               oops:
6671                 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
6672                            gv_ename(namegv), cv);
6673             }
6674         }
6675         else
6676             list(o2);
6677         mod(o2, OP_ENTERSUB);
6678         prev = o2;
6679         o2 = o2->op_sibling;
6680     } /* while */
6681     if (proto && !optional &&
6682           (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6683         return too_few_arguments(o, gv_ename(namegv));
6684     if(delete_op) {
6685         op_free(o);
6686         o=newSVOP(OP_CONST, 0, newSViv(0));
6687     }
6688     return o;
6689 }
6690
6691 OP *
6692 Perl_ck_svconst(pTHX_ OP *o)
6693 {
6694     SvREADONLY_on(cSVOPo->op_sv);
6695     return o;
6696 }
6697
6698 OP *
6699 Perl_ck_trunc(pTHX_ OP *o)
6700 {
6701     if (o->op_flags & OPf_KIDS) {
6702         SVOP *kid = (SVOP*)cUNOPo->op_first;
6703
6704         if (kid->op_type == OP_NULL)
6705             kid = (SVOP*)kid->op_sibling;
6706         if (kid && kid->op_type == OP_CONST &&
6707             (kid->op_private & OPpCONST_BARE))
6708         {
6709             o->op_flags |= OPf_SPECIAL;
6710             kid->op_private &= ~OPpCONST_STRICT;
6711         }
6712     }
6713     return ck_fun(o);
6714 }
6715
6716 OP *
6717 Perl_ck_unpack(pTHX_ OP *o)
6718 {
6719     OP *kid = cLISTOPo->op_first;
6720     if (kid->op_sibling) {
6721         kid = kid->op_sibling;
6722         if (!kid->op_sibling)
6723             kid->op_sibling = newDEFSVOP();
6724     }
6725     return ck_fun(o);
6726 }
6727
6728 OP *
6729 Perl_ck_substr(pTHX_ OP *o)
6730 {
6731     o = ck_fun(o);
6732     if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6733         OP *kid = cLISTOPo->op_first;
6734
6735         if (kid->op_type == OP_NULL)
6736             kid = kid->op_sibling;
6737         if (kid)
6738             kid->op_flags |= OPf_MOD;
6739
6740     }
6741     return o;
6742 }
6743
6744 /* A peephole optimizer.  We visit the ops in the order they're to execute.
6745  * See the comments at the top of this file for more details about when
6746  * peep() is called */
6747
6748 void
6749 Perl_peep(pTHX_ register OP *o)
6750 {
6751     dVAR;
6752     register OP* oldop = 0;
6753
6754     if (!o || o->op_opt)
6755         return;
6756     ENTER;
6757     SAVEOP();
6758     SAVEVPTR(PL_curcop);
6759     for (; o; o = o->op_next) {
6760         if (o->op_opt)
6761             break;
6762         PL_op = o;
6763         switch (o->op_type) {
6764         case OP_SETSTATE:
6765         case OP_NEXTSTATE:
6766         case OP_DBSTATE:
6767             PL_curcop = ((COP*)o);              /* for warnings */
6768             o->op_opt = 1;
6769             break;
6770
6771         case OP_CONST:
6772             if (cSVOPo->op_private & OPpCONST_STRICT)
6773                 no_bareword_allowed(o);
6774 #ifdef USE_ITHREADS
6775         case OP_METHOD_NAMED:
6776             /* Relocate sv to the pad for thread safety.
6777              * Despite being a "constant", the SV is written to,
6778              * for reference counts, sv_upgrade() etc. */
6779             if (cSVOP->op_sv) {
6780                 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6781                 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
6782                     /* If op_sv is already a PADTMP then it is being used by
6783                      * some pad, so make a copy. */
6784                     sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
6785                     SvREADONLY_on(PAD_SVl(ix));
6786                     SvREFCNT_dec(cSVOPo->op_sv);
6787                 }
6788                 else {
6789                     SvREFCNT_dec(PAD_SVl(ix));
6790                     SvPADTMP_on(cSVOPo->op_sv);
6791                     PAD_SETSV(ix, cSVOPo->op_sv);
6792                     /* XXX I don't know how this isn't readonly already. */
6793                     SvREADONLY_on(PAD_SVl(ix));
6794                 }
6795                 cSVOPo->op_sv = Nullsv;
6796                 o->op_targ = ix;
6797             }
6798 #endif
6799             o->op_opt = 1;
6800             break;
6801
6802         case OP_CONCAT:
6803             if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6804                 if (o->op_next->op_private & OPpTARGET_MY) {
6805                     if (o->op_flags & OPf_STACKED) /* chained concats */
6806                         goto ignore_optimization;
6807                     else {
6808                         /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6809                         o->op_targ = o->op_next->op_targ;
6810                         o->op_next->op_targ = 0;
6811                         o->op_private |= OPpTARGET_MY;
6812                     }
6813                 }
6814                 op_null(o->op_next);
6815             }
6816           ignore_optimization:
6817             o->op_opt = 1;
6818             break;
6819         case OP_STUB:
6820             if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6821                 o->op_opt = 1;
6822                 break; /* Scalar stub must produce undef.  List stub is noop */
6823             }
6824             goto nothin;
6825         case OP_NULL:
6826             if (o->op_targ == OP_NEXTSTATE
6827                 || o->op_targ == OP_DBSTATE
6828                 || o->op_targ == OP_SETSTATE)
6829             {
6830                 PL_curcop = ((COP*)o);
6831             }
6832             /* XXX: We avoid setting op_seq here to prevent later calls
6833                to peep() from mistakenly concluding that optimisation
6834                has already occurred. This doesn't fix the real problem,
6835                though (See 20010220.007). AMS 20010719 */
6836             /* op_seq functionality is now replaced by op_opt */
6837             if (oldop && o->op_next) {
6838                 oldop->op_next = o->op_next;
6839                 continue;
6840             }
6841             break;
6842         case OP_SCALAR:
6843         case OP_LINESEQ:
6844         case OP_SCOPE:
6845           nothin:
6846             if (oldop && o->op_next) {
6847                 oldop->op_next = o->op_next;
6848                 continue;
6849             }
6850             o->op_opt = 1;
6851             break;
6852
6853         case OP_PADAV:
6854         case OP_GV:
6855             if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
6856                 OP* const pop = (o->op_type == OP_PADAV) ?
6857                             o->op_next : o->op_next->op_next;
6858                 IV i;
6859                 if (pop && pop->op_type == OP_CONST &&
6860                     ((PL_op = pop->op_next)) &&
6861                     pop->op_next->op_type == OP_AELEM &&
6862                     !(pop->op_next->op_private &
6863                       (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6864                     (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
6865                                 <= 255 &&
6866                     i >= 0)
6867                 {
6868                     GV *gv;
6869                     if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
6870                         no_bareword_allowed(pop);
6871                     if (o->op_type == OP_GV)
6872                         op_null(o->op_next);
6873                     op_null(pop->op_next);
6874                     op_null(pop);
6875                     o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6876                     o->op_next = pop->op_next->op_next;
6877                     o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6878                     o->op_private = (U8)i;
6879                     if (o->op_type == OP_GV) {
6880                         gv = cGVOPo_gv;
6881                         GvAVn(gv);
6882                     }
6883                     else
6884                         o->op_flags |= OPf_SPECIAL;
6885                     o->op_type = OP_AELEMFAST;
6886                 }
6887                 o->op_opt = 1;
6888                 break;
6889             }
6890
6891             if (o->op_next->op_type == OP_RV2SV) {
6892                 if (!(o->op_next->op_private & OPpDEREF)) {
6893                     op_null(o->op_next);
6894                     o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6895                                                                | OPpOUR_INTRO);
6896                     o->op_next = o->op_next->op_next;
6897                     o->op_type = OP_GVSV;
6898                     o->op_ppaddr = PL_ppaddr[OP_GVSV];
6899                 }
6900             }
6901             else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6902                 GV * const gv = cGVOPo_gv;
6903                 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
6904                     /* XXX could check prototype here instead of just carping */
6905                     SV * const sv = sv_newmortal();
6906                     gv_efullname3(sv, gv, Nullch);
6907                     Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
6908                                 "%"SVf"() called too early to check prototype",
6909                                 sv);
6910                 }
6911             }
6912             else if (o->op_next->op_type == OP_READLINE
6913                     && o->op_next->op_next->op_type == OP_CONCAT
6914                     && (o->op_next->op_next->op_flags & OPf_STACKED))
6915             {
6916                 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
6917                 o->op_type   = OP_RCATLINE;
6918                 o->op_flags |= OPf_STACKED;
6919                 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
6920                 op_null(o->op_next->op_next);
6921                 op_null(o->op_next);
6922             }
6923
6924             o->op_opt = 1;
6925             break;
6926
6927         case OP_MAPWHILE:
6928         case OP_GREPWHILE:
6929         case OP_AND:
6930         case OP_OR:
6931         case OP_DOR:
6932         case OP_ANDASSIGN:
6933         case OP_ORASSIGN:
6934         case OP_DORASSIGN:
6935         case OP_COND_EXPR:
6936         case OP_RANGE:
6937             o->op_opt = 1;
6938             while (cLOGOP->op_other->op_type == OP_NULL)
6939                 cLOGOP->op_other = cLOGOP->op_other->op_next;
6940             peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
6941             break;
6942
6943         case OP_ENTERLOOP:
6944         case OP_ENTERITER:
6945             o->op_opt = 1;
6946             while (cLOOP->op_redoop->op_type == OP_NULL)
6947                 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6948             peep(cLOOP->op_redoop);
6949             while (cLOOP->op_nextop->op_type == OP_NULL)
6950                 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6951             peep(cLOOP->op_nextop);
6952             while (cLOOP->op_lastop->op_type == OP_NULL)
6953                 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6954             peep(cLOOP->op_lastop);
6955             break;
6956
6957         case OP_QR:
6958         case OP_MATCH:
6959         case OP_SUBST:
6960             o->op_opt = 1;
6961             while (cPMOP->op_pmreplstart &&
6962                    cPMOP->op_pmreplstart->op_type == OP_NULL)
6963                 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6964             peep(cPMOP->op_pmreplstart);
6965             break;
6966
6967         case OP_EXEC:
6968             o->op_opt = 1;
6969             if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
6970                 && ckWARN(WARN_SYNTAX))
6971             {
6972                 if (o->op_next->op_sibling &&
6973                         o->op_next->op_sibling->op_type != OP_EXIT &&
6974                         o->op_next->op_sibling->op_type != OP_WARN &&
6975                         o->op_next->op_sibling->op_type != OP_DIE) {
6976                     const line_t oldline = CopLINE(PL_curcop);
6977
6978                     CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6979                     Perl_warner(aTHX_ packWARN(WARN_EXEC),
6980                                 "Statement unlikely to be reached");
6981                     Perl_warner(aTHX_ packWARN(WARN_EXEC),
6982                                 "\t(Maybe you meant system() when you said exec()?)\n");
6983                     CopLINE_set(PL_curcop, oldline);
6984                 }
6985             }
6986             break;
6987
6988         case OP_HELEM: {
6989             UNOP *rop;
6990             SV *lexname;
6991             GV **fields;
6992             SV **svp, *sv;
6993             const char *key = NULL;
6994             STRLEN keylen;
6995
6996             o->op_opt = 1;
6997
6998             if (((BINOP*)o)->op_last->op_type != OP_CONST)
6999                 break;
7000
7001             /* Make the CONST have a shared SV */
7002             svp = cSVOPx_svp(((BINOP*)o)->op_last);
7003             if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
7004                 key = SvPV_const(sv, keylen);
7005                 lexname = newSVpvn_share(key,
7006                                          SvUTF8(sv) ? -(I32)keylen : keylen,
7007                                          0);
7008                 SvREFCNT_dec(sv);
7009                 *svp = lexname;
7010             }
7011
7012             if ((o->op_private & (OPpLVAL_INTRO)))
7013                 break;
7014
7015             rop = (UNOP*)((BINOP*)o)->op_first;
7016             if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
7017                 break;
7018             lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
7019             if (!(SvFLAGS(lexname) & SVpad_TYPED))
7020                 break;
7021             fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
7022             if (!fields || !GvHV(*fields))
7023                 break;
7024             key = SvPV_const(*svp, keylen);
7025             if (!hv_fetch(GvHV(*fields), key,
7026                         SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
7027             {
7028                 Perl_croak(aTHX_ "No such class field \"%s\" "
7029                            "in variable %s of type %s",
7030                       key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
7031             }
7032
7033             break;
7034         }
7035
7036         case OP_HSLICE: {
7037             UNOP *rop;
7038             SV *lexname;
7039             GV **fields;
7040             SV **svp;
7041             const char *key;
7042             STRLEN keylen;
7043             SVOP *first_key_op, *key_op;
7044
7045             if ((o->op_private & (OPpLVAL_INTRO))
7046                 /* I bet there's always a pushmark... */
7047                 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
7048                 /* hmmm, no optimization if list contains only one key. */
7049                 break;
7050             rop = (UNOP*)((LISTOP*)o)->op_last;
7051             if (rop->op_type != OP_RV2HV)
7052                 break;
7053             if (rop->op_first->op_type == OP_PADSV)
7054                 /* @$hash{qw(keys here)} */
7055                 rop = (UNOP*)rop->op_first;
7056             else {
7057                 /* @{$hash}{qw(keys here)} */
7058                 if (rop->op_first->op_type == OP_SCOPE
7059                     && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
7060                 {
7061                     rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
7062                 }
7063                 else
7064                     break;
7065             }
7066
7067             lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
7068             if (!(SvFLAGS(lexname) & SVpad_TYPED))
7069                 break;
7070             fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
7071             if (!fields || !GvHV(*fields))
7072                 break;
7073             /* Again guessing that the pushmark can be jumped over.... */
7074             first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
7075                 ->op_first->op_sibling;
7076             for (key_op = first_key_op; key_op;
7077                  key_op = (SVOP*)key_op->op_sibling) {
7078                 if (key_op->op_type != OP_CONST)
7079                     continue;
7080                 svp = cSVOPx_svp(key_op);
7081                 key = SvPV_const(*svp, keylen);
7082                 if (!hv_fetch(GvHV(*fields), key,
7083                             SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
7084                 {
7085                     Perl_croak(aTHX_ "No such class field \"%s\" "
7086                                "in variable %s of type %s",
7087                           key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
7088                 }
7089             }
7090             break;
7091         }
7092
7093         case OP_SORT: {
7094             /* will point to RV2AV or PADAV op on LHS/RHS of assign */
7095             OP *oleft;
7096             OP *o2;
7097
7098             /* check that RHS of sort is a single plain array */
7099             OP *oright = cUNOPo->op_first;
7100             if (!oright || oright->op_type != OP_PUSHMARK)
7101                 break;
7102
7103             /* reverse sort ... can be optimised.  */
7104             if (!cUNOPo->op_sibling) {
7105                 /* Nothing follows us on the list. */
7106                 OP * const reverse = o->op_next;
7107
7108                 if (reverse->op_type == OP_REVERSE &&
7109                     (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
7110                     OP * const pushmark = cUNOPx(reverse)->op_first;
7111                     if (pushmark && (pushmark->op_type == OP_PUSHMARK)
7112                         && (cUNOPx(pushmark)->op_sibling == o)) {
7113                         /* reverse -> pushmark -> sort */
7114                         o->op_private |= OPpSORT_REVERSE;
7115                         op_null(reverse);
7116                         pushmark->op_next = oright->op_next;
7117                         op_null(oright);
7118                     }
7119                 }
7120             }
7121
7122             /* make @a = sort @a act in-place */
7123
7124             o->op_opt = 1;
7125
7126             oright = cUNOPx(oright)->op_sibling;
7127             if (!oright)
7128                 break;
7129             if (oright->op_type == OP_NULL) { /* skip sort block/sub */
7130                 oright = cUNOPx(oright)->op_sibling;
7131             }
7132
7133             if (!oright ||
7134                 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
7135                 || oright->op_next != o
7136                 || (oright->op_private & OPpLVAL_INTRO)
7137             )
7138                 break;
7139
7140             /* o2 follows the chain of op_nexts through the LHS of the
7141              * assign (if any) to the aassign op itself */
7142             o2 = o->op_next;
7143             if (!o2 || o2->op_type != OP_NULL)
7144                 break;
7145             o2 = o2->op_next;
7146             if (!o2 || o2->op_type != OP_PUSHMARK)
7147                 break;
7148             o2 = o2->op_next;
7149             if (o2 && o2->op_type == OP_GV)
7150                 o2 = o2->op_next;
7151             if (!o2
7152                 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
7153                 || (o2->op_private & OPpLVAL_INTRO)
7154             )
7155                 break;
7156             oleft = o2;
7157             o2 = o2->op_next;
7158             if (!o2 || o2->op_type != OP_NULL)
7159                 break;
7160             o2 = o2->op_next;
7161             if (!o2 || o2->op_type != OP_AASSIGN
7162                     || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
7163                 break;
7164
7165             /* check that the sort is the first arg on RHS of assign */
7166
7167             o2 = cUNOPx(o2)->op_first;
7168             if (!o2 || o2->op_type != OP_NULL)
7169                 break;
7170             o2 = cUNOPx(o2)->op_first;
7171             if (!o2 || o2->op_type != OP_PUSHMARK)
7172                 break;
7173             if (o2->op_sibling != o)
7174                 break;
7175
7176             /* check the array is the same on both sides */
7177             if (oleft->op_type == OP_RV2AV) {
7178                 if (oright->op_type != OP_RV2AV
7179                     || !cUNOPx(oright)->op_first
7180                     || cUNOPx(oright)->op_first->op_type != OP_GV
7181                     ||  cGVOPx_gv(cUNOPx(oleft)->op_first) !=
7182                         cGVOPx_gv(cUNOPx(oright)->op_first)
7183                 )
7184                     break;
7185             }
7186             else if (oright->op_type != OP_PADAV
7187                 || oright->op_targ != oleft->op_targ
7188             )
7189                 break;
7190
7191             /* transfer MODishness etc from LHS arg to RHS arg */
7192             oright->op_flags = oleft->op_flags;
7193             o->op_private |= OPpSORT_INPLACE;
7194
7195             /* excise push->gv->rv2av->null->aassign */
7196             o2 = o->op_next->op_next;
7197             op_null(o2); /* PUSHMARK */
7198             o2 = o2->op_next;
7199             if (o2->op_type == OP_GV) {
7200                 op_null(o2); /* GV */
7201                 o2 = o2->op_next;
7202             }
7203             op_null(o2); /* RV2AV or PADAV */
7204             o2 = o2->op_next->op_next;
7205             op_null(o2); /* AASSIGN */
7206
7207             o->op_next = o2->op_next;
7208
7209             break;
7210         }
7211
7212         case OP_REVERSE: {
7213             OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
7214             OP *gvop = NULL;
7215             LISTOP *enter, *exlist;
7216             o->op_opt = 1;
7217
7218             enter = (LISTOP *) o->op_next;
7219             if (!enter)
7220                 break;
7221             if (enter->op_type == OP_NULL) {
7222                 enter = (LISTOP *) enter->op_next;
7223                 if (!enter)
7224                     break;
7225             }
7226             /* for $a (...) will have OP_GV then OP_RV2GV here.
7227                for (...) just has an OP_GV.  */
7228             if (enter->op_type == OP_GV) {
7229                 gvop = (OP *) enter;
7230                 enter = (LISTOP *) enter->op_next;
7231                 if (!enter)
7232                     break;
7233                 if (enter->op_type == OP_RV2GV) {
7234                   enter = (LISTOP *) enter->op_next;
7235                   if (!enter)
7236                     break;
7237                 }
7238             }
7239
7240             if (enter->op_type != OP_ENTERITER)
7241                 break;
7242
7243             iter = enter->op_next;
7244             if (!iter || iter->op_type != OP_ITER)
7245                 break;
7246
7247             expushmark = enter->op_first;
7248             if (!expushmark || expushmark->op_type != OP_NULL
7249                 || expushmark->op_targ != OP_PUSHMARK)
7250                 break;
7251
7252             exlist = (LISTOP *) expushmark->op_sibling;
7253             if (!exlist || exlist->op_type != OP_NULL
7254                 || exlist->op_targ != OP_LIST)
7255                 break;
7256
7257             if (exlist->op_last != o) {
7258                 /* Mmm. Was expecting to point back to this op.  */
7259                 break;
7260             }
7261             theirmark = exlist->op_first;
7262             if (!theirmark || theirmark->op_type != OP_PUSHMARK)
7263                 break;
7264
7265             if (theirmark->op_sibling != o) {
7266                 /* There's something between the mark and the reverse, eg
7267                    for (1, reverse (...))
7268                    so no go.  */
7269                 break;
7270             }
7271
7272             ourmark = ((LISTOP *)o)->op_first;
7273             if (!ourmark || ourmark->op_type != OP_PUSHMARK)
7274                 break;
7275
7276             ourlast = ((LISTOP *)o)->op_last;
7277             if (!ourlast || ourlast->op_next != o)
7278                 break;
7279
7280             rv2av = ourmark->op_sibling;
7281             if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
7282                 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
7283                 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
7284                 /* We're just reversing a single array.  */
7285                 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
7286                 enter->op_flags |= OPf_STACKED;
7287             }
7288
7289             /* We don't have control over who points to theirmark, so sacrifice
7290                ours.  */
7291             theirmark->op_next = ourmark->op_next;
7292             theirmark->op_flags = ourmark->op_flags;
7293             ourlast->op_next = gvop ? gvop : (OP *) enter;
7294             op_null(ourmark);
7295             op_null(o);
7296             enter->op_private |= OPpITER_REVERSED;
7297             iter->op_private |= OPpITER_REVERSED;
7298
7299             break;
7300         }
7301
7302         default:
7303             o->op_opt = 1;
7304             break;
7305         }
7306         oldop = o;
7307     }
7308     LEAVE;
7309 }
7310
7311 char*
7312 Perl_custom_op_name(pTHX_ const OP* o)
7313 {
7314     const IV index = PTR2IV(o->op_ppaddr);
7315     SV* keysv;
7316     HE* he;
7317
7318     if (!PL_custom_op_names) /* This probably shouldn't happen */
7319         return (char *)PL_op_name[OP_CUSTOM];
7320
7321     keysv = sv_2mortal(newSViv(index));
7322
7323     he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
7324     if (!he)
7325         return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
7326
7327     return SvPV_nolen(HeVAL(he));
7328 }
7329
7330 char*
7331 Perl_custom_op_desc(pTHX_ const OP* o)
7332 {
7333     const IV index = PTR2IV(o->op_ppaddr);
7334     SV* keysv;
7335     HE* he;
7336
7337     if (!PL_custom_op_descs)
7338         return (char *)PL_op_desc[OP_CUSTOM];
7339
7340     keysv = sv_2mortal(newSViv(index));
7341
7342     he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
7343     if (!he)
7344         return (char *)PL_op_desc[OP_CUSTOM];
7345
7346     return SvPV_nolen(HeVAL(he));
7347 }
7348
7349 #include "XSUB.h"
7350
7351 /* Efficient sub that returns a constant scalar value. */
7352 static void
7353 const_sv_xsub(pTHX_ CV* cv)
7354 {
7355     dXSARGS;
7356     if (items != 0) {
7357 #if 0
7358         Perl_croak(aTHX_ "usage: %s::%s()",
7359                    HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
7360 #endif
7361     }
7362     EXTEND(sp, 1);
7363     ST(0) = (SV*)XSANY.any_ptr;
7364     XSRETURN(1);
7365 }
7366
7367 /*
7368  * Local variables:
7369  * c-indentation-style: bsd
7370  * c-basic-offset: 4
7371  * indent-tabs-mode: t
7372  * End:
7373  *
7374  * ex: set ts=8 sts=4 sw=4 noet:
7375  */