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