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