op.c

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