op.c

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