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         OPCODE typfirst = cBINOPo->op_first->op_type;
4623         OPCODE typlast  = cBINOPo->op_first->op_sibling->op_type;
4624         if (OP_IS_NUMCOMPARE(typfirst) || OP_IS_NUMCOMPARE(typlast))
4625             if (ckWARN(WARN_PRECEDENCE))
4626                 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
4627                         "Possible precedence problem on bitwise %c operator",
4628                         o->op_type == OP_BIT_OR ? '|'
4629                             : o->op_type == OP_BIT_AND ? '&' : '^'
4630                         );
4631     }
4632     return o;
4633 }
4634
4635 OP *
4636 Perl_ck_concat(pTHX_ OP *o)
4637 {
4638     if (cUNOPo->op_first->op_type == OP_CONCAT)
4639         o->op_flags |= OPf_STACKED;
4640     return o;
4641 }
4642
4643 OP *
4644 Perl_ck_spair(pTHX_ OP *o)
4645 {
4646     if (o->op_flags & OPf_KIDS) {
4647         OP* newop;
4648         OP* kid;
4649         OPCODE type = o->op_type;
4650         o = modkids(ck_fun(o), type);
4651         kid = cUNOPo->op_first;
4652         newop = kUNOP->op_first->op_sibling;
4653         if (newop &&
4654             (newop->op_sibling ||
4655              !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
4656              newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
4657              newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
4658
4659             return o;
4660         }
4661         op_free(kUNOP->op_first);
4662         kUNOP->op_first = newop;
4663     }
4664     o->op_ppaddr = PL_ppaddr[++o->op_type];
4665     return ck_fun(o);
4666 }
4667
4668 OP *
4669 Perl_ck_delete(pTHX_ OP *o)
4670 {
4671     o = ck_fun(o);
4672     o->op_private = 0;
4673     if (o->op_flags & OPf_KIDS) {
4674         OP *kid = cUNOPo->op_first;
4675         switch (kid->op_type) {
4676         case OP_ASLICE:
4677             o->op_flags |= OPf_SPECIAL;
4678             /* FALL THROUGH */
4679         case OP_HSLICE:
4680             o->op_private |= OPpSLICE;
4681             break;
4682         case OP_AELEM:
4683             o->op_flags |= OPf_SPECIAL;
4684             /* FALL THROUGH */
4685         case OP_HELEM:
4686             break;
4687         default:
4688             Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
4689                   OP_DESC(o));
4690         }
4691         op_null(kid);
4692     }
4693     return o;
4694 }
4695
4696 OP *
4697 Perl_ck_die(pTHX_ OP *o)
4698 {
4699 #ifdef VMS
4700     if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
4701 #endif
4702     return ck_fun(o);
4703 }
4704
4705 OP *
4706 Perl_ck_eof(pTHX_ OP *o)
4707 {
4708     I32 type = o->op_type;
4709
4710     if (o->op_flags & OPf_KIDS) {
4711         if (cLISTOPo->op_first->op_type == OP_STUB) {
4712             op_free(o);
4713             o = newUNOP(type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
4714         }
4715         return ck_fun(o);
4716     }
4717     return o;
4718 }
4719
4720 OP *
4721 Perl_ck_eval(pTHX_ OP *o)
4722 {
4723     PL_hints |= HINT_BLOCK_SCOPE;
4724     if (o->op_flags & OPf_KIDS) {
4725         SVOP *kid = (SVOP*)cUNOPo->op_first;
4726
4727         if (!kid) {
4728             o->op_flags &= ~OPf_KIDS;
4729             op_null(o);
4730         }
4731         else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
4732             LOGOP *enter;
4733
4734             cUNOPo->op_first = 0;
4735             op_free(o);
4736
4737             NewOp(1101, enter, 1, LOGOP);
4738             enter->op_type = OP_ENTERTRY;
4739             enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
4740             enter->op_private = 0;
4741
4742             /* establish postfix order */
4743             enter->op_next = (OP*)enter;
4744
4745             o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
4746             o->op_type = OP_LEAVETRY;
4747             o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
4748             enter->op_other = o;
4749             return o;
4750         }
4751         else
4752             scalar((OP*)kid);
4753     }
4754     else {
4755         op_free(o);
4756         o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
4757     }
4758     o->op_targ = (PADOFFSET)PL_hints;
4759     return o;
4760 }
4761
4762 OP *
4763 Perl_ck_exit(pTHX_ OP *o)
4764 {
4765 #ifdef VMS
4766     HV *table = GvHV(PL_hintgv);
4767     if (table) {
4768        SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
4769        if (svp && *svp && SvTRUE(*svp))
4770            o->op_private |= OPpEXIT_VMSISH;
4771     }
4772     if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
4773 #endif
4774     return ck_fun(o);
4775 }
4776
4777 OP *
4778 Perl_ck_exec(pTHX_ OP *o)
4779 {
4780     OP *kid;
4781     if (o->op_flags & OPf_STACKED) {
4782         o = ck_fun(o);
4783         kid = cUNOPo->op_first->op_sibling;
4784         if (kid->op_type == OP_RV2GV)
4785             op_null(kid);
4786     }
4787     else
4788         o = listkids(o);
4789     return o;
4790 }
4791
4792 OP *
4793 Perl_ck_exists(pTHX_ OP *o)
4794 {
4795     o = ck_fun(o);
4796     if (o->op_flags & OPf_KIDS) {
4797         OP *kid = cUNOPo->op_first;
4798         if (kid->op_type == OP_ENTERSUB) {
4799             (void) ref(kid, o->op_type);
4800             if (kid->op_type != OP_RV2CV && !PL_error_count)
4801                 Perl_croak(aTHX_ "%s argument is not a subroutine name",
4802                             OP_DESC(o));
4803             o->op_private |= OPpEXISTS_SUB;
4804         }
4805         else if (kid->op_type == OP_AELEM)
4806             o->op_flags |= OPf_SPECIAL;
4807         else if (kid->op_type != OP_HELEM)
4808             Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
4809                         OP_DESC(o));
4810         op_null(kid);
4811     }
4812     return o;
4813 }
4814
4815 #if 0
4816 OP *
4817 Perl_ck_gvconst(pTHX_ register OP *o)
4818 {
4819     o = fold_constants(o);
4820     if (o->op_type == OP_CONST)
4821         o->op_type = OP_GV;
4822     return o;
4823 }
4824 #endif
4825
4826 OP *
4827 Perl_ck_rvconst(pTHX_ register OP *o)
4828 {
4829     SVOP *kid = (SVOP*)cUNOPo->op_first;
4830
4831     o->op_private |= (PL_hints & HINT_STRICT_REFS);
4832     if (kid->op_type == OP_CONST) {
4833         char *name;
4834         int iscv;
4835         GV *gv;
4836         SV *kidsv = kid->op_sv;
4837         STRLEN n_a;
4838
4839         /* Is it a constant from cv_const_sv()? */
4840         if (SvROK(kidsv) && SvREADONLY(kidsv)) {
4841             SV *rsv = SvRV(kidsv);
4842             int svtype = SvTYPE(rsv);
4843             char *badtype = Nullch;
4844
4845             switch (o->op_type) {
4846             case OP_RV2SV:
4847                 if (svtype > SVt_PVMG)
4848                     badtype = "a SCALAR";
4849                 break;
4850             case OP_RV2AV:
4851                 if (svtype != SVt_PVAV)
4852                     badtype = "an ARRAY";
4853                 break;
4854             case OP_RV2HV:
4855                 if (svtype != SVt_PVHV)
4856                     badtype = "a HASH";
4857                 break;
4858             case OP_RV2CV:
4859                 if (svtype != SVt_PVCV)
4860                     badtype = "a CODE";
4861                 break;
4862             }
4863             if (badtype)
4864                 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
4865             return o;
4866         }
4867         name = SvPV(kidsv, n_a);
4868         if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
4869             char *badthing = Nullch;
4870             switch (o->op_type) {
4871             case OP_RV2SV:
4872                 badthing = "a SCALAR";
4873                 break;
4874             case OP_RV2AV:
4875                 badthing = "an ARRAY";
4876                 break;
4877             case OP_RV2HV:
4878                 badthing = "a HASH";
4879                 break;
4880             }
4881             if (badthing)
4882                 Perl_croak(aTHX_
4883           "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
4884                       name, badthing);
4885         }
4886         /*
4887          * This is a little tricky.  We only want to add the symbol if we
4888          * didn't add it in the lexer.  Otherwise we get duplicate strict
4889          * warnings.  But if we didn't add it in the lexer, we must at
4890          * least pretend like we wanted to add it even if it existed before,
4891          * or we get possible typo warnings.  OPpCONST_ENTERED says
4892          * whether the lexer already added THIS instance of this symbol.
4893          */
4894         iscv = (o->op_type == OP_RV2CV) * 2;
4895         do {
4896             gv = gv_fetchpv(name,
4897                 iscv | !(kid->op_private & OPpCONST_ENTERED),
4898                 iscv
4899                     ? SVt_PVCV
4900                     : o->op_type == OP_RV2SV
4901                         ? SVt_PV
4902                         : o->op_type == OP_RV2AV
4903                             ? SVt_PVAV
4904                             : o->op_type == OP_RV2HV
4905                                 ? SVt_PVHV
4906                                 : SVt_PVGV);
4907         } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
4908         if (gv) {
4909             kid->op_type = OP_GV;
4910             SvREFCNT_dec(kid->op_sv);
4911 #ifdef USE_ITHREADS
4912             /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
4913             kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
4914             SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
4915             GvIN_PAD_on(gv);
4916             PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc(gv));
4917 #else
4918             kid->op_sv = SvREFCNT_inc(gv);
4919 #endif
4920             kid->op_private = 0;
4921             kid->op_ppaddr = PL_ppaddr[OP_GV];
4922         }
4923     }
4924     return o;
4925 }
4926
4927 OP *
4928 Perl_ck_ftst(pTHX_ OP *o)
4929 {
4930     I32 type = o->op_type;
4931
4932     if (o->op_flags & OPf_REF) {
4933         /* nothing */
4934     }
4935     else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
4936         SVOP *kid = (SVOP*)cUNOPo->op_first;
4937
4938         if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
4939             STRLEN n_a;
4940             OP *newop = newGVOP(type, OPf_REF,
4941                 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
4942             op_free(o);
4943             o = newop;
4944         }
4945         else {
4946           if ((PL_hints & HINT_FILETEST_ACCESS) &&
4947               OP_IS_FILETEST_ACCESS(o))
4948             o->op_private |= OPpFT_ACCESS;
4949         }
4950     }
4951     else {
4952         op_free(o);
4953         if (type == OP_FTTTY)
4954             o = newGVOP(type, OPf_REF, PL_stdingv);
4955         else
4956             o = newUNOP(type, 0, newDEFSVOP());
4957     }
4958     return o;
4959 }
4960
4961 OP *
4962 Perl_ck_fun(pTHX_ OP *o)
4963 {
4964     register OP *kid;
4965     OP **tokid;
4966     OP *sibl;
4967     I32 numargs = 0;
4968     int type = o->op_type;
4969     register I32 oa = PL_opargs[type] >> OASHIFT;
4970
4971     if (o->op_flags & OPf_STACKED) {
4972         if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
4973             oa &= ~OA_OPTIONAL;
4974         else
4975             return no_fh_allowed(o);
4976     }
4977
4978     if (o->op_flags & OPf_KIDS) {
4979         STRLEN n_a;
4980         tokid = &cLISTOPo->op_first;
4981         kid = cLISTOPo->op_first;
4982         if (kid->op_type == OP_PUSHMARK ||
4983             (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
4984         {
4985             tokid = &kid->op_sibling;
4986             kid = kid->op_sibling;
4987         }
4988         if (!kid && PL_opargs[type] & OA_DEFGV)
4989             *tokid = kid = newDEFSVOP();
4990
4991         while (oa && kid) {
4992             numargs++;
4993             sibl = kid->op_sibling;
4994             switch (oa & 7) {
4995             case OA_SCALAR:
4996                 /* list seen where single (scalar) arg expected? */
4997                 if (numargs == 1 && !(oa >> 4)
4998                     && kid->op_type == OP_LIST && type != OP_SCALAR)
4999                 {
5000                     return too_many_arguments(o,PL_op_desc[type]);
5001                 }
5002                 scalar(kid);
5003                 break;
5004             case OA_LIST:
5005                 if (oa < 16) {
5006                     kid = 0;
5007                     continue;
5008                 }
5009                 else
5010                     list(kid);
5011                 break;
5012             case OA_AVREF:
5013                 if ((type == OP_PUSH || type == OP_UNSHIFT)
5014                     && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5015                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5016                         "Useless use of %s with no values",
5017                         PL_op_desc[type]);
5018
5019                 if (kid->op_type == OP_CONST &&
5020                     (kid->op_private & OPpCONST_BARE))
5021                 {
5022                     char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5023                     OP *newop = newAVREF(newGVOP(OP_GV, 0,
5024                         gv_fetchpv(name, TRUE, SVt_PVAV) ));
5025                     if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5026                         Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5027                             "Array @%s missing the @ in argument %"IVdf" of %s()",
5028                             name, (IV)numargs, PL_op_desc[type]);
5029                     op_free(kid);
5030                     kid = newop;
5031                     kid->op_sibling = sibl;
5032                     *tokid = kid;
5033                 }
5034                 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5035                     bad_type(numargs, "array", PL_op_desc[type], kid);
5036                 mod(kid, type);
5037                 break;
5038             case OA_HVREF:
5039                 if (kid->op_type == OP_CONST &&
5040                     (kid->op_private & OPpCONST_BARE))
5041                 {
5042                     char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5043                     OP *newop = newHVREF(newGVOP(OP_GV, 0,
5044                         gv_fetchpv(name, TRUE, SVt_PVHV) ));
5045                     if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5046                         Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5047                             "Hash %%%s missing the %% in argument %"IVdf" of %s()",
5048                             name, (IV)numargs, PL_op_desc[type]);
5049                     op_free(kid);
5050                     kid = newop;
5051                     kid->op_sibling = sibl;
5052                     *tokid = kid;
5053                 }
5054                 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5055                     bad_type(numargs, "hash", PL_op_desc[type], kid);
5056                 mod(kid, type);
5057                 break;
5058             case OA_CVREF:
5059                 {
5060                     OP *newop = newUNOP(OP_NULL, 0, kid);
5061                     kid->op_sibling = 0;
5062                     linklist(kid);
5063                     newop->op_next = newop;
5064                     kid = newop;
5065                     kid->op_sibling = sibl;
5066                     *tokid = kid;
5067                 }
5068                 break;
5069             case OA_FILEREF:
5070                 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5071                     if (kid->op_type == OP_CONST &&
5072                         (kid->op_private & OPpCONST_BARE))
5073                     {
5074                         OP *newop = newGVOP(OP_GV, 0,
5075                             gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
5076                                         SVt_PVIO) );
5077                         if (!(o->op_private & 1) && /* if not unop */
5078                             kid == cLISTOPo->op_last)
5079                             cLISTOPo->op_last = newop;
5080                         op_free(kid);
5081                         kid = newop;
5082                     }
5083                     else if (kid->op_type == OP_READLINE) {
5084                         /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5085                         bad_type(numargs, "HANDLE", OP_DESC(o), kid);
5086                     }
5087                     else {
5088                         I32 flags = OPf_SPECIAL;
5089                         I32 priv = 0;
5090                         PADOFFSET targ = 0;
5091
5092                         /* is this op a FH constructor? */
5093                         if (is_handle_constructor(o,numargs)) {
5094                             char *name = Nullch;
5095                             STRLEN len = 0;
5096
5097                             flags = 0;
5098                             /* Set a flag to tell rv2gv to vivify
5099                              * need to "prove" flag does not mean something
5100                              * else already - NI-S 1999/05/07
5101                              */
5102                             priv = OPpDEREF;
5103                             if (kid->op_type == OP_PADSV) {
5104                                 /*XXX DAPM 2002.08.25 tmp assert test */
5105                                 /*XXX*/ assert(av_fetch(PL_comppad_name, (kid->op_targ), FALSE));
5106                                 /*XXX*/ assert(*av_fetch(PL_comppad_name, (kid->op_targ), FALSE));
5107
5108                                 name = PAD_COMPNAME_PV(kid->op_targ);
5109                                 /* SvCUR of a pad namesv can't be trusted
5110                                  * (see PL_generation), so calc its length
5111                                  * manually */
5112                                 if (name)
5113                                     len = strlen(name);
5114
5115                             }
5116                             else if (kid->op_type == OP_RV2SV
5117                                      && kUNOP->op_first->op_type == OP_GV)
5118                             {
5119                                 GV *gv = cGVOPx_gv(kUNOP->op_first);
5120                                 name = GvNAME(gv);
5121                                 len = GvNAMELEN(gv);
5122                             }
5123                             else if (kid->op_type == OP_AELEM
5124                                      || kid->op_type == OP_HELEM)
5125                             {
5126                                  OP *op;
5127
5128                                  name = 0;
5129                                  if ((op = ((BINOP*)kid)->op_first)) {
5130                                       SV *tmpstr = Nullsv;
5131                                       char *a =
5132                                            kid->op_type == OP_AELEM ?
5133                                            "[]" : "{}";
5134                                       if (((op->op_type == OP_RV2AV) ||
5135                                            (op->op_type == OP_RV2HV)) &&
5136                                           (op = ((UNOP*)op)->op_first) &&
5137                                           (op->op_type == OP_GV)) {
5138                                            /* packagevar $a[] or $h{} */
5139                                            GV *gv = cGVOPx_gv(op);
5140                                            if (gv)
5141                                                 tmpstr =
5142                                                      Perl_newSVpvf(aTHX_
5143                                                                    "%s%c...%c",
5144                                                                    GvNAME(gv),
5145                                                                    a[0], a[1]);
5146                                       }
5147                                       else if (op->op_type == OP_PADAV
5148                                                || op->op_type == OP_PADHV) {
5149                                            /* lexicalvar $a[] or $h{} */
5150                                            char *padname =
5151                                                 PAD_COMPNAME_PV(op->op_targ);
5152                                            if (padname)
5153                                                 tmpstr =
5154                                                      Perl_newSVpvf(aTHX_
5155                                                                    "%s%c...%c",
5156                                                                    padname + 1,
5157                                                                    a[0], a[1]);
5158
5159                                       }
5160                                       if (tmpstr) {
5161                                            name = savepv(SvPVX(tmpstr));
5162                                            len = strlen(name);
5163                                            sv_2mortal(tmpstr);
5164                                       }
5165                                  }
5166                                  if (!name) {
5167                                       name = "__ANONIO__";
5168                                       len = 10;
5169                                  }
5170                                  mod(kid, type);
5171                             }
5172                             if (name) {
5173                                 SV *namesv;
5174                                 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5175                                 namesv = PAD_SVl(targ);
5176                                 (void)SvUPGRADE(namesv, SVt_PV);
5177                                 if (*name != '$')
5178                                     sv_setpvn(namesv, "$", 1);
5179                                 sv_catpvn(namesv, name, len);
5180                             }
5181                         }
5182                         kid->op_sibling = 0;
5183                         kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5184                         kid->op_targ = targ;
5185                         kid->op_private |= priv;
5186                     }
5187                     kid->op_sibling = sibl;
5188                     *tokid = kid;
5189                 }
5190                 scalar(kid);
5191                 break;
5192             case OA_SCALARREF:
5193                 mod(scalar(kid), type);
5194                 break;
5195             }
5196             oa >>= 4;
5197             tokid = &kid->op_sibling;
5198             kid = kid->op_sibling;
5199         }
5200         o->op_private |= numargs;
5201         if (kid)
5202             return too_many_arguments(o,OP_DESC(o));
5203         listkids(o);
5204     }
5205     else if (PL_opargs[type] & OA_DEFGV) {
5206         op_free(o);
5207         return newUNOP(type, 0, newDEFSVOP());
5208     }
5209
5210     if (oa) {
5211         while (oa & OA_OPTIONAL)
5212             oa >>= 4;
5213         if (oa && oa != OA_LIST)
5214             return too_few_arguments(o,OP_DESC(o));
5215     }
5216     return o;
5217 }
5218
5219 OP *
5220 Perl_ck_glob(pTHX_ OP *o)
5221 {
5222     GV *gv;
5223
5224     o = ck_fun(o);
5225     if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5226         append_elem(OP_GLOB, o, newDEFSVOP());
5227
5228     if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV))
5229           && GvCVu(gv) && GvIMPORTED_CV(gv)))
5230     {
5231         gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5232     }
5233
5234 #if !defined(PERL_EXTERNAL_GLOB)
5235     /* XXX this can be tightened up and made more failsafe. */
5236     if (!gv) {
5237         GV *glob_gv;
5238         ENTER;
5239         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
5240                 newSVpvn("File::Glob", 10), Nullsv, Nullsv, Nullsv);
5241         gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5242         glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
5243         GvCV(gv) = GvCV(glob_gv);
5244         SvREFCNT_inc((SV*)GvCV(gv));
5245         GvIMPORTED_CV_on(gv);
5246         LEAVE;
5247     }
5248 #endif /* PERL_EXTERNAL_GLOB */
5249
5250     if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5251         append_elem(OP_GLOB, o,
5252                     newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5253         o->op_type = OP_LIST;
5254         o->op_ppaddr = PL_ppaddr[OP_LIST];
5255         cLISTOPo->op_first->op_type = OP_PUSHMARK;
5256         cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5257         o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5258                     append_elem(OP_LIST, o,
5259                                 scalar(newUNOP(OP_RV2CV, 0,
5260                                                newGVOP(OP_GV, 0, gv)))));
5261         o = newUNOP(OP_NULL, 0, ck_subr(o));
5262         o->op_targ = OP_GLOB;           /* hint at what it used to be */
5263         return o;
5264     }
5265     gv = newGVgen("main");
5266     gv_IOadd(gv);
5267     append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5268     scalarkids(o);
5269     return o;
5270 }
5271
5272 OP *
5273 Perl_ck_grep(pTHX_ OP *o)
5274 {
5275     LOGOP *gwop;
5276     OP *kid;
5277     OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5278
5279     o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5280     NewOp(1101, gwop, 1, LOGOP);
5281
5282     if (o->op_flags & OPf_STACKED) {
5283         OP* k;
5284         o = ck_sort(o);
5285         kid = cLISTOPo->op_first->op_sibling;
5286         for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
5287             kid = k;
5288         }
5289         kid->op_next = (OP*)gwop;
5290         o->op_flags &= ~OPf_STACKED;
5291     }
5292     kid = cLISTOPo->op_first->op_sibling;
5293     if (type == OP_MAPWHILE)
5294         list(kid);
5295     else
5296         scalar(kid);
5297     o = ck_fun(o);
5298     if (PL_error_count)
5299         return o;
5300     kid = cLISTOPo->op_first->op_sibling;
5301     if (kid->op_type != OP_NULL)
5302         Perl_croak(aTHX_ "panic: ck_grep");
5303     kid = kUNOP->op_first;
5304
5305     gwop->op_type = type;
5306     gwop->op_ppaddr = PL_ppaddr[type];
5307     gwop->op_first = listkids(o);
5308     gwop->op_flags |= OPf_KIDS;
5309     gwop->op_private = 1;
5310     gwop->op_other = LINKLIST(kid);
5311     gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5312     kid->op_next = (OP*)gwop;
5313
5314     kid = cLISTOPo->op_first->op_sibling;
5315     if (!kid || !kid->op_sibling)
5316         return too_few_arguments(o,OP_DESC(o));
5317     for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5318         mod(kid, OP_GREPSTART);
5319
5320     return (OP*)gwop;
5321 }
5322
5323 OP *
5324 Perl_ck_index(pTHX_ OP *o)
5325 {
5326     if (o->op_flags & OPf_KIDS) {
5327         OP *kid = cLISTOPo->op_first->op_sibling;       /* get past pushmark */
5328         if (kid)
5329             kid = kid->op_sibling;                      /* get past "big" */
5330         if (kid && kid->op_type == OP_CONST)
5331             fbm_compile(((SVOP*)kid)->op_sv, 0);
5332     }
5333     return ck_fun(o);
5334 }
5335
5336 OP *
5337 Perl_ck_lengthconst(pTHX_ OP *o)
5338 {
5339     /* XXX length optimization goes here */
5340     return ck_fun(o);
5341 }
5342
5343 OP *
5344 Perl_ck_lfun(pTHX_ OP *o)
5345 {
5346     OPCODE type = o->op_type;
5347     return modkids(ck_fun(o), type);
5348 }
5349
5350 OP *
5351 Perl_ck_defined(pTHX_ OP *o)            /* 19990527 MJD */
5352 {
5353     if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
5354         switch (cUNOPo->op_first->op_type) {
5355         case OP_RV2AV:
5356             /* This is needed for
5357                if (defined %stash::)
5358                to work.   Do not break Tk.
5359                */
5360             break;                      /* Globals via GV can be undef */
5361         case OP_PADAV:
5362         case OP_AASSIGN:                /* Is this a good idea? */
5363             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5364                         "defined(@array) is deprecated");
5365             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5366                         "\t(Maybe you should just omit the defined()?)\n");
5367         break;
5368         case OP_RV2HV:
5369             /* This is needed for
5370                if (defined %stash::)
5371                to work.   Do not break Tk.
5372                */
5373             break;                      /* Globals via GV can be undef */
5374         case OP_PADHV:
5375             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5376                         "defined(%%hash) is deprecated");
5377             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5378                         "\t(Maybe you should just omit the defined()?)\n");
5379             break;
5380         default:
5381             /* no warning */
5382             break;
5383         }
5384     }
5385     return ck_rfun(o);
5386 }
5387
5388 OP *
5389 Perl_ck_rfun(pTHX_ OP *o)
5390 {
5391     OPCODE type = o->op_type;
5392     return refkids(ck_fun(o), type);
5393 }
5394
5395 OP *
5396 Perl_ck_listiob(pTHX_ OP *o)
5397 {
5398     register OP *kid;
5399
5400     kid = cLISTOPo->op_first;
5401     if (!kid) {
5402         o = force_list(o);
5403         kid = cLISTOPo->op_first;
5404     }
5405     if (kid->op_type == OP_PUSHMARK)
5406         kid = kid->op_sibling;
5407     if (kid && o->op_flags & OPf_STACKED)
5408         kid = kid->op_sibling;
5409     else if (kid && !kid->op_sibling) {         /* print HANDLE; */
5410         if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
5411             o->op_flags |= OPf_STACKED; /* make it a filehandle */
5412             kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
5413             cLISTOPo->op_first->op_sibling = kid;
5414             cLISTOPo->op_last = kid;
5415             kid = kid->op_sibling;
5416         }
5417     }
5418
5419     if (!kid)
5420         append_elem(o->op_type, o, newDEFSVOP());
5421
5422     return listkids(o);
5423 }
5424
5425 OP *
5426 Perl_ck_sassign(pTHX_ OP *o)
5427 {
5428     OP *kid = cLISTOPo->op_first;
5429     /* has a disposable target? */
5430     if ((PL_opargs[kid->op_type] & OA_TARGLEX)
5431         && !(kid->op_flags & OPf_STACKED)
5432         /* Cannot steal the second time! */
5433         && !(kid->op_private & OPpTARGET_MY))
5434     {
5435         OP *kkid = kid->op_sibling;
5436
5437         /* Can just relocate the target. */
5438         if (kkid && kkid->op_type == OP_PADSV
5439             && !(kkid->op_private & OPpLVAL_INTRO))
5440         {
5441             kid->op_targ = kkid->op_targ;
5442             kkid->op_targ = 0;
5443             /* Now we do not need PADSV and SASSIGN. */
5444             kid->op_sibling = o->op_sibling;    /* NULL */
5445             cLISTOPo->op_first = NULL;
5446             op_free(o);
5447             op_free(kkid);
5448             kid->op_private |= OPpTARGET_MY;    /* Used for context settings */
5449             return kid;
5450         }
5451     }
5452     return o;
5453 }
5454
5455 OP *
5456 Perl_ck_match(pTHX_ OP *o)
5457 {
5458     o->op_private |= OPpRUNTIME;
5459     return o;
5460 }
5461
5462 OP *
5463 Perl_ck_method(pTHX_ OP *o)
5464 {
5465     OP *kid = cUNOPo->op_first;
5466     if (kid->op_type == OP_CONST) {
5467         SV* sv = kSVOP->op_sv;
5468         if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
5469             OP *cmop;
5470             if (!SvREADONLY(sv) || !SvFAKE(sv)) {
5471                 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
5472             }
5473             else {
5474                 kSVOP->op_sv = Nullsv;
5475             }
5476             cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
5477             op_free(o);
5478             return cmop;
5479         }
5480     }
5481     return o;
5482 }
5483
5484 OP *
5485 Perl_ck_null(pTHX_ OP *o)
5486 {
5487     return o;
5488 }
5489
5490 OP *
5491 Perl_ck_open(pTHX_ OP *o)
5492 {
5493     HV *table = GvHV(PL_hintgv);
5494     if (table) {
5495         SV **svp;
5496         I32 mode;
5497         svp = hv_fetch(table, "open_IN", 7, FALSE);
5498         if (svp && *svp) {
5499             mode = mode_from_discipline(*svp);
5500             if (mode & O_BINARY)
5501                 o->op_private |= OPpOPEN_IN_RAW;
5502             else if (mode & O_TEXT)
5503                 o->op_private |= OPpOPEN_IN_CRLF;
5504         }
5505
5506         svp = hv_fetch(table, "open_OUT", 8, FALSE);
5507         if (svp && *svp) {
5508             mode = mode_from_discipline(*svp);
5509             if (mode & O_BINARY)
5510                 o->op_private |= OPpOPEN_OUT_RAW;
5511             else if (mode & O_TEXT)
5512                 o->op_private |= OPpOPEN_OUT_CRLF;
5513         }
5514     }
5515     if (o->op_type == OP_BACKTICK)
5516         return o;
5517     {
5518          /* In case of three-arg dup open remove strictness
5519           * from the last arg if it is a bareword. */
5520          OP *first = cLISTOPx(o)->op_first; /* The pushmark. */
5521          OP *last  = cLISTOPx(o)->op_last;  /* The bareword. */
5522          OP *oa;
5523          char *mode;
5524
5525          if ((last->op_type == OP_CONST) &&             /* The bareword. */
5526              (last->op_private & OPpCONST_BARE) &&
5527              (last->op_private & OPpCONST_STRICT) &&
5528              (oa = first->op_sibling) &&                /* The fh. */
5529              (oa = oa->op_sibling) &&                   /* The mode. */
5530              SvPOK(((SVOP*)oa)->op_sv) &&
5531              (mode = SvPVX(((SVOP*)oa)->op_sv)) &&
5532              mode[0] == '>' && mode[1] == '&' &&        /* A dup open. */
5533              (last == oa->op_sibling))                  /* The bareword. */
5534               last->op_private &= ~OPpCONST_STRICT;
5535     }
5536     return ck_fun(o);
5537 }
5538
5539 OP *
5540 Perl_ck_repeat(pTHX_ OP *o)
5541 {
5542     if (cBINOPo->op_first->op_flags & OPf_PARENS) {
5543         o->op_private |= OPpREPEAT_DOLIST;
5544         cBINOPo->op_first = force_list(cBINOPo->op_first);
5545     }
5546     else
5547         scalar(o);
5548     return o;
5549 }
5550
5551 OP *
5552 Perl_ck_require(pTHX_ OP *o)
5553 {
5554     GV* gv;
5555
5556     if (o->op_flags & OPf_KIDS) {       /* Shall we supply missing .pm? */
5557         SVOP *kid = (SVOP*)cUNOPo->op_first;
5558
5559         if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5560             char *s;
5561             for (s = SvPVX(kid->op_sv); *s; s++) {
5562                 if (*s == ':' && s[1] == ':') {
5563                     *s = '/';
5564                     Move(s+2, s+1, strlen(s+2)+1, char);
5565                     --SvCUR(kid->op_sv);
5566                 }
5567             }
5568             if (SvREADONLY(kid->op_sv)) {
5569                 SvREADONLY_off(kid->op_sv);
5570                 sv_catpvn(kid->op_sv, ".pm", 3);
5571                 SvREADONLY_on(kid->op_sv);
5572             }
5573             else
5574                 sv_catpvn(kid->op_sv, ".pm", 3);
5575         }
5576     }
5577
5578     /* handle override, if any */
5579     gv = gv_fetchpv("require", FALSE, SVt_PVCV);
5580     if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
5581         gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
5582
5583     if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5584         OP *kid = cUNOPo->op_first;
5585         cUNOPo->op_first = 0;
5586         op_free(o);
5587         return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
5588                                append_elem(OP_LIST, kid,
5589                                            scalar(newUNOP(OP_RV2CV, 0,
5590                                                           newGVOP(OP_GV, 0,
5591                                                                   gv))))));
5592     }
5593
5594     return ck_fun(o);
5595 }
5596
5597 OP *
5598 Perl_ck_return(pTHX_ OP *o)
5599 {
5600     OP *kid;
5601     if (CvLVALUE(PL_compcv)) {
5602         for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
5603             mod(kid, OP_LEAVESUBLV);
5604     }
5605     return o;
5606 }
5607
5608 #if 0
5609 OP *
5610 Perl_ck_retarget(pTHX_ OP *o)
5611 {
5612     Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5613     /* STUB */
5614     return o;
5615 }
5616 #endif
5617
5618 OP *
5619 Perl_ck_select(pTHX_ OP *o)
5620 {
5621     OP* kid;
5622     if (o->op_flags & OPf_KIDS) {
5623         kid = cLISTOPo->op_first->op_sibling;   /* get past pushmark */
5624         if (kid && kid->op_sibling) {
5625             o->op_type = OP_SSELECT;
5626             o->op_ppaddr = PL_ppaddr[OP_SSELECT];
5627             o = ck_fun(o);
5628             return fold_constants(o);
5629         }
5630     }
5631     o = ck_fun(o);
5632     kid = cLISTOPo->op_first->op_sibling;    /* get past pushmark */
5633     if (kid && kid->op_type == OP_RV2GV)
5634         kid->op_private &= ~HINT_STRICT_REFS;
5635     return o;
5636 }
5637
5638 OP *
5639 Perl_ck_shift(pTHX_ OP *o)
5640 {
5641     I32 type = o->op_type;
5642
5643     if (!(o->op_flags & OPf_KIDS)) {
5644         OP *argop;
5645
5646         op_free(o);
5647         argop = newUNOP(OP_RV2AV, 0,
5648             scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
5649         return newUNOP(type, 0, scalar(argop));
5650     }
5651     return scalar(modkids(ck_fun(o), type));
5652 }
5653
5654 OP *
5655 Perl_ck_sort(pTHX_ OP *o)
5656 {
5657     OP *firstkid;
5658
5659     if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
5660         simplify_sort(o);
5661     firstkid = cLISTOPo->op_first->op_sibling;          /* get past pushmark */
5662     if (o->op_flags & OPf_STACKED) {                    /* may have been cleared */
5663         OP *k = NULL;
5664         OP *kid = cUNOPx(firstkid)->op_first;           /* get past null */
5665
5666         if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
5667             linklist(kid);
5668             if (kid->op_type == OP_SCOPE) {
5669                 k = kid->op_next;
5670                 kid->op_next = 0;
5671             }
5672             else if (kid->op_type == OP_LEAVE) {
5673                 if (o->op_type == OP_SORT) {
5674                     op_null(kid);                       /* wipe out leave */
5675                     kid->op_next = kid;
5676
5677                     for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
5678                         if (k->op_next == kid)
5679                             k->op_next = 0;
5680                         /* don't descend into loops */
5681                         else if (k->op_type == OP_ENTERLOOP
5682                                  || k->op_type == OP_ENTERITER)
5683                         {
5684                             k = cLOOPx(k)->op_lastop;
5685                         }
5686                     }
5687                 }
5688                 else
5689                     kid->op_next = 0;           /* just disconnect the leave */
5690                 k = kLISTOP->op_first;
5691             }
5692             CALL_PEEP(k);
5693
5694             kid = firstkid;
5695             if (o->op_type == OP_SORT) {
5696                 /* provide scalar context for comparison function/block */
5697                 kid = scalar(kid);
5698                 kid->op_next = kid;
5699             }
5700             else
5701                 kid->op_next = k;
5702             o->op_flags |= OPf_SPECIAL;
5703         }
5704         else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
5705             op_null(firstkid);
5706
5707         firstkid = firstkid->op_sibling;
5708     }
5709
5710     /* provide list context for arguments */
5711     if (o->op_type == OP_SORT)
5712         list(firstkid);
5713
5714     return o;
5715 }
5716
5717 STATIC void
5718 S_simplify_sort(pTHX_ OP *o)
5719 {
5720     register OP *kid = cLISTOPo->op_first->op_sibling;  /* get past pushmark */
5721     OP *k;
5722     int reversed;
5723     GV *gv;
5724     if (!(o->op_flags & OPf_STACKED))
5725         return;
5726     GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
5727     GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
5728     kid = kUNOP->op_first;                              /* get past null */
5729     if (kid->op_type != OP_SCOPE)
5730         return;
5731     kid = kLISTOP->op_last;                             /* get past scope */
5732     switch(kid->op_type) {
5733         case OP_NCMP:
5734         case OP_I_NCMP:
5735         case OP_SCMP:
5736             break;
5737         default:
5738             return;
5739     }
5740     k = kid;                                            /* remember this node*/
5741     if (kBINOP->op_first->op_type != OP_RV2SV)
5742         return;
5743     kid = kBINOP->op_first;                             /* get past cmp */
5744     if (kUNOP->op_first->op_type != OP_GV)
5745         return;
5746     kid = kUNOP->op_first;                              /* get past rv2sv */
5747     gv = kGVOP_gv;
5748     if (GvSTASH(gv) != PL_curstash)
5749         return;
5750     if (strEQ(GvNAME(gv), "a"))
5751         reversed = 0;
5752     else if (strEQ(GvNAME(gv), "b"))
5753         reversed = 1;
5754     else
5755         return;
5756     kid = k;                                            /* back to cmp */
5757     if (kBINOP->op_last->op_type != OP_RV2SV)
5758         return;
5759     kid = kBINOP->op_last;                              /* down to 2nd arg */
5760     if (kUNOP->op_first->op_type != OP_GV)
5761         return;
5762     kid = kUNOP->op_first;                              /* get past rv2sv */
5763     gv = kGVOP_gv;
5764     if (GvSTASH(gv) != PL_curstash
5765         || ( reversed
5766             ? strNE(GvNAME(gv), "a")
5767             : strNE(GvNAME(gv), "b")))
5768         return;
5769     o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
5770     if (reversed)
5771         o->op_private |= OPpSORT_REVERSE;
5772     if (k->op_type == OP_NCMP)
5773         o->op_private |= OPpSORT_NUMERIC;
5774     if (k->op_type == OP_I_NCMP)
5775         o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
5776     kid = cLISTOPo->op_first->op_sibling;
5777     cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
5778     op_free(kid);                                     /* then delete it */
5779 }
5780
5781 OP *
5782 Perl_ck_split(pTHX_ OP *o)
5783 {
5784     register OP *kid;
5785
5786     if (o->op_flags & OPf_STACKED)
5787         return no_fh_allowed(o);
5788
5789     kid = cLISTOPo->op_first;
5790     if (kid->op_type != OP_NULL)
5791         Perl_croak(aTHX_ "panic: ck_split");
5792     kid = kid->op_sibling;
5793     op_free(cLISTOPo->op_first);
5794     cLISTOPo->op_first = kid;
5795     if (!kid) {
5796         cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
5797         cLISTOPo->op_last = kid; /* There was only one element previously */
5798     }
5799
5800     if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
5801         OP *sibl = kid->op_sibling;
5802         kid->op_sibling = 0;
5803         kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
5804         if (cLISTOPo->op_first == cLISTOPo->op_last)
5805             cLISTOPo->op_last = kid;
5806         cLISTOPo->op_first = kid;
5807         kid->op_sibling = sibl;
5808     }
5809
5810     kid->op_type = OP_PUSHRE;
5811     kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
5812     scalar(kid);
5813     if (ckWARN(WARN_REGEXP) && ((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
5814       Perl_warner(aTHX_ packWARN(WARN_REGEXP),
5815                   "Use of /g modifier is meaningless in split");
5816     }
5817
5818     if (!kid->op_sibling)
5819         append_elem(OP_SPLIT, o, newDEFSVOP());
5820
5821     kid = kid->op_sibling;
5822     scalar(kid);
5823
5824     if (!kid->op_sibling)
5825         append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
5826
5827     kid = kid->op_sibling;
5828     scalar(kid);
5829
5830     if (kid->op_sibling)
5831         return too_many_arguments(o,OP_DESC(o));
5832
5833     return o;
5834 }
5835
5836 OP *
5837 Perl_ck_join(pTHX_ OP *o)
5838 {
5839     if (ckWARN(WARN_SYNTAX)) {
5840         OP *kid = cLISTOPo->op_first->op_sibling;
5841         if (kid && kid->op_type == OP_MATCH) {
5842             char *pmstr = "STRING";
5843             if (PM_GETRE(kPMOP))
5844                 pmstr = PM_GETRE(kPMOP)->precomp;
5845             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5846                         "/%s/ should probably be written as \"%s\"",
5847                         pmstr, pmstr);
5848         }
5849     }
5850     return ck_fun(o);
5851 }
5852
5853 OP *
5854 Perl_ck_subr(pTHX_ OP *o)
5855 {
5856     OP *prev = ((cUNOPo->op_first->op_sibling)
5857              ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
5858     OP *o2 = prev->op_sibling;
5859     OP *cvop;
5860     char *proto = 0;
5861     CV *cv = 0;
5862     GV *namegv = 0;
5863     int optional = 0;
5864     I32 arg = 0;
5865     I32 contextclass = 0;
5866     char *e = 0;
5867     STRLEN n_a;
5868     bool delete=0;
5869
5870     o->op_private |= OPpENTERSUB_HASTARG;
5871     for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
5872     if (cvop->op_type == OP_RV2CV) {
5873         SVOP* tmpop;
5874         o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
5875         op_null(cvop);          /* disable rv2cv */
5876         tmpop = (SVOP*)((UNOP*)cvop)->op_first;
5877         if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
5878             GV *gv = cGVOPx_gv(tmpop);
5879             cv = GvCVu(gv);
5880             if (!cv)
5881                 tmpop->op_private |= OPpEARLY_CV;
5882             else {
5883                 if (SvPOK(cv)) {
5884                     namegv = CvANON(cv) ? gv : CvGV(cv);
5885                     proto = SvPV((SV*)cv, n_a);
5886                 }
5887                 if (CvASSERTION(cv)) {
5888                     if (PL_hints & HINT_ASSERTING) {
5889                         if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
5890                             o->op_private |= OPpENTERSUB_DB;
5891                     }
5892                     else {
5893                         delete=1;
5894                         if (ckWARN(WARN_ASSERTIONS) && !(PL_hints & HINT_ASSERTIONSSEEN)) {
5895                             Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
5896                                         "Impossible to activate assertion call");
5897                         }
5898                     }
5899                 }
5900             }
5901         }
5902     }
5903     else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
5904         if (o2->op_type == OP_CONST)
5905             o2->op_private &= ~OPpCONST_STRICT;
5906         else if (o2->op_type == OP_LIST) {
5907             OP *o = ((UNOP*)o2)->op_first->op_sibling;
5908             if (o && o->op_type == OP_CONST)
5909                 o->op_private &= ~OPpCONST_STRICT;
5910         }
5911     }
5912     o->op_private |= (PL_hints & HINT_STRICT_REFS);
5913     if (PERLDB_SUB && PL_curstash != PL_debstash)
5914         o->op_private |= OPpENTERSUB_DB;
5915     while (o2 != cvop) {
5916         if (proto) {
5917             switch (*proto) {
5918             case '\0':
5919                 return too_many_arguments(o, gv_ename(namegv));
5920             case ';':
5921                 optional = 1;
5922                 proto++;
5923                 continue;
5924             case '$':
5925                 proto++;
5926                 arg++;
5927                 scalar(o2);
5928                 break;
5929             case '%':
5930             case '@':
5931                 list(o2);
5932                 arg++;
5933                 break;
5934             case '&':
5935                 proto++;
5936                 arg++;
5937                 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
5938                     bad_type(arg,
5939                         arg == 1 ? "block or sub {}" : "sub {}",
5940                         gv_ename(namegv), o2);
5941                 break;
5942             case '*':
5943                 /* '*' allows any scalar type, including bareword */
5944                 proto++;
5945                 arg++;
5946                 if (o2->op_type == OP_RV2GV)
5947                     goto wrapref;       /* autoconvert GLOB -> GLOBref */
5948                 else if (o2->op_type == OP_CONST)
5949                     o2->op_private &= ~OPpCONST_STRICT;
5950                 else if (o2->op_type == OP_ENTERSUB) {
5951                     /* accidental subroutine, revert to bareword */
5952                     OP *gvop = ((UNOP*)o2)->op_first;
5953                     if (gvop && gvop->op_type == OP_NULL) {
5954                         gvop = ((UNOP*)gvop)->op_first;
5955                         if (gvop) {
5956                             for (; gvop->op_sibling; gvop = gvop->op_sibling)
5957                                 ;
5958                             if (gvop &&
5959                                 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
5960                                 (gvop = ((UNOP*)gvop)->op_first) &&
5961                                 gvop->op_type == OP_GV)
5962                             {
5963                                 GV *gv = cGVOPx_gv(gvop);
5964                                 OP *sibling = o2->op_sibling;
5965                                 SV *n = newSVpvn("",0);
5966                                 op_free(o2);
5967                                 gv_fullname3(n, gv, "");
5968                                 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
5969                                     sv_chop(n, SvPVX(n)+6);
5970                                 o2 = newSVOP(OP_CONST, 0, n);
5971                                 prev->op_sibling = o2;
5972                                 o2->op_sibling = sibling;
5973                             }
5974                         }
5975                     }
5976                 }
5977                 scalar(o2);
5978                 break;
5979             case '[': case ']':
5980                  goto oops;
5981                  break;
5982             case '\\':
5983                 proto++;
5984                 arg++;
5985             again:
5986                 switch (*proto++) {
5987                 case '[':
5988                      if (contextclass++ == 0) {
5989                           e = strchr(proto, ']');
5990                           if (!e || e == proto)
5991                                goto oops;
5992                      }
5993                      else
5994                           goto oops;
5995                      goto again;
5996                      break;
5997                 case ']':
5998                      if (contextclass) {
5999                          char *p = proto;
6000                          char s = *p;
6001                          contextclass = 0;
6002                          *p = '\0';
6003                          while (*--p != '[');
6004                          bad_type(arg, Perl_form(aTHX_ "one of %s", p),
6005                                  gv_ename(namegv), o2);
6006                          *proto = s;
6007                      } else
6008                           goto oops;
6009                      break;
6010                 case '*':
6011                      if (o2->op_type == OP_RV2GV)
6012                           goto wrapref;
6013                      if (!contextclass)
6014                           bad_type(arg, "symbol", gv_ename(namegv), o2);
6015                      break;
6016                 case '&':
6017                      if (o2->op_type == OP_ENTERSUB)
6018                           goto wrapref;
6019                      if (!contextclass)
6020                           bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6021                      break;
6022                 case '$':
6023                     if (o2->op_type == OP_RV2SV ||
6024                         o2->op_type == OP_PADSV ||
6025                         o2->op_type == OP_HELEM ||
6026                         o2->op_type == OP_AELEM ||
6027                         o2->op_type == OP_THREADSV)
6028                          goto wrapref;
6029                     if (!contextclass)
6030                         bad_type(arg, "scalar", gv_ename(namegv), o2);
6031                      break;
6032                 case '@':
6033                     if (o2->op_type == OP_RV2AV ||
6034                         o2->op_type == OP_PADAV)
6035                          goto wrapref;
6036                     if (!contextclass)
6037                         bad_type(arg, "array", gv_ename(namegv), o2);
6038                     break;
6039                 case '%':
6040                     if (o2->op_type == OP_RV2HV ||
6041                         o2->op_type == OP_PADHV)
6042                          goto wrapref;
6043                     if (!contextclass)
6044                          bad_type(arg, "hash", gv_ename(namegv), o2);
6045                     break;
6046                 wrapref:
6047                     {
6048                         OP* kid = o2;
6049                         OP* sib = kid->op_sibling;
6050                         kid->op_sibling = 0;
6051                         o2 = newUNOP(OP_REFGEN, 0, kid);
6052                         o2->op_sibling = sib;
6053                         prev->op_sibling = o2;
6054                     }
6055                     if (contextclass && e) {
6056                          proto = e + 1;
6057                          contextclass = 0;
6058                     }
6059                     break;
6060                 default: goto oops;
6061                 }
6062                 if (contextclass)
6063                      goto again;
6064                 break;
6065             case ' ':
6066                 proto++;
6067                 continue;
6068             default:
6069               oops:
6070                 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
6071                            gv_ename(namegv), cv);
6072             }
6073         }
6074         else
6075             list(o2);
6076         mod(o2, OP_ENTERSUB);
6077         prev = o2;
6078         o2 = o2->op_sibling;
6079     }
6080     if (proto && !optional &&
6081           (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6082         return too_few_arguments(o, gv_ename(namegv));
6083     if(delete) {
6084         op_free(o);
6085         o=newSVOP(OP_CONST, 0, newSViv(0));
6086     }
6087     return o;
6088 }
6089
6090 OP *
6091 Perl_ck_svconst(pTHX_ OP *o)
6092 {
6093     SvREADONLY_on(cSVOPo->op_sv);
6094     return o;
6095 }
6096
6097 OP *
6098 Perl_ck_trunc(pTHX_ OP *o)
6099 {
6100     if (o->op_flags & OPf_KIDS) {
6101         SVOP *kid = (SVOP*)cUNOPo->op_first;
6102
6103         if (kid->op_type == OP_NULL)
6104             kid = (SVOP*)kid->op_sibling;
6105         if (kid && kid->op_type == OP_CONST &&
6106             (kid->op_private & OPpCONST_BARE))
6107         {
6108             o->op_flags |= OPf_SPECIAL;
6109             kid->op_private &= ~OPpCONST_STRICT;
6110         }
6111     }
6112     return ck_fun(o);
6113 }
6114
6115 OP *
6116 Perl_ck_substr(pTHX_ OP *o)
6117 {
6118     o = ck_fun(o);
6119     if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6120         OP *kid = cLISTOPo->op_first;
6121
6122         if (kid->op_type == OP_NULL)
6123             kid = kid->op_sibling;
6124         if (kid)
6125             kid->op_flags |= OPf_MOD;
6126
6127     }
6128     return o;
6129 }
6130
6131 /* A peephole optimizer.  We visit the ops in the order they're to execute. */
6132
6133 void
6134 Perl_peep(pTHX_ register OP *o)
6135 {
6136     register OP* oldop = 0;
6137
6138     if (!o || o->op_seq)
6139         return;
6140     ENTER;
6141     SAVEOP();
6142     SAVEVPTR(PL_curcop);
6143     for (; o; o = o->op_next) {
6144         if (o->op_seq)
6145             break;
6146         /* The special value -1 is used by the B::C compiler backend to indicate
6147          * that an op is statically defined and should not be freed */
6148         if (!PL_op_seqmax || PL_op_seqmax == (U16)-1)
6149             PL_op_seqmax = 1;
6150         PL_op = o;
6151         switch (o->op_type) {
6152         case OP_SETSTATE:
6153         case OP_NEXTSTATE:
6154         case OP_DBSTATE:
6155             PL_curcop = ((COP*)o);              /* for warnings */
6156             o->op_seq = PL_op_seqmax++;
6157             break;
6158
6159         case OP_CONST:
6160             if (cSVOPo->op_private & OPpCONST_STRICT)
6161                 no_bareword_allowed(o);
6162 #ifdef USE_ITHREADS
6163         case OP_METHOD_NAMED:
6164             /* Relocate sv to the pad for thread safety.
6165              * Despite being a "constant", the SV is written to,
6166              * for reference counts, sv_upgrade() etc. */
6167             if (cSVOP->op_sv) {
6168                 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6169                 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
6170                     /* If op_sv is already a PADTMP then it is being used by
6171                      * some pad, so make a copy. */
6172                     sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
6173                     SvREADONLY_on(PAD_SVl(ix));
6174                     SvREFCNT_dec(cSVOPo->op_sv);
6175                 }
6176                 else {
6177                     SvREFCNT_dec(PAD_SVl(ix));
6178                     SvPADTMP_on(cSVOPo->op_sv);
6179                     PAD_SETSV(ix, cSVOPo->op_sv);
6180                     /* XXX I don't know how this isn't readonly already. */
6181                     SvREADONLY_on(PAD_SVl(ix));
6182                 }
6183                 cSVOPo->op_sv = Nullsv;
6184                 o->op_targ = ix;
6185             }
6186 #endif
6187             o->op_seq = PL_op_seqmax++;
6188             break;
6189
6190         case OP_CONCAT:
6191             if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6192                 if (o->op_next->op_private & OPpTARGET_MY) {
6193                     if (o->op_flags & OPf_STACKED) /* chained concats */
6194                         goto ignore_optimization;
6195                     else {
6196                         /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6197                         o->op_targ = o->op_next->op_targ;
6198                         o->op_next->op_targ = 0;
6199                         o->op_private |= OPpTARGET_MY;
6200                     }
6201                 }
6202                 op_null(o->op_next);
6203             }
6204           ignore_optimization:
6205             o->op_seq = PL_op_seqmax++;
6206             break;
6207         case OP_STUB:
6208             if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6209                 o->op_seq = PL_op_seqmax++;
6210                 break; /* Scalar stub must produce undef.  List stub is noop */
6211             }
6212             goto nothin;
6213         case OP_NULL:
6214             if (o->op_targ == OP_NEXTSTATE
6215                 || o->op_targ == OP_DBSTATE
6216                 || o->op_targ == OP_SETSTATE)
6217             {
6218                 PL_curcop = ((COP*)o);
6219             }
6220             /* XXX: We avoid setting op_seq here to prevent later calls
6221                to peep() from mistakenly concluding that optimisation
6222                has already occurred. This doesn't fix the real problem,
6223                though (See 20010220.007). AMS 20010719 */
6224             if (oldop && o->op_next) {
6225                 oldop->op_next = o->op_next;
6226                 continue;
6227             }
6228             break;
6229         case OP_SCALAR:
6230         case OP_LINESEQ:
6231         case OP_SCOPE:
6232           nothin:
6233             if (oldop && o->op_next) {
6234                 oldop->op_next = o->op_next;
6235                 continue;
6236             }
6237             o->op_seq = PL_op_seqmax++;
6238             break;
6239
6240         case OP_GV:
6241             if (o->op_next->op_type == OP_RV2SV) {
6242                 if (!(o->op_next->op_private & OPpDEREF)) {
6243                     op_null(o->op_next);
6244                     o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6245                                                                | OPpOUR_INTRO);
6246                     o->op_next = o->op_next->op_next;
6247                     o->op_type = OP_GVSV;
6248                     o->op_ppaddr = PL_ppaddr[OP_GVSV];
6249                 }
6250             }
6251             else if (o->op_next->op_type == OP_RV2AV) {
6252                 OP* pop = o->op_next->op_next;
6253                 IV i;
6254                 if (pop && pop->op_type == OP_CONST &&
6255                     (PL_op = pop->op_next) &&
6256                     pop->op_next->op_type == OP_AELEM &&
6257                     !(pop->op_next->op_private &
6258                       (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6259                     (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
6260                                 <= 255 &&
6261                     i >= 0)
6262                 {
6263                     GV *gv;
6264                     op_null(o->op_next);
6265                     op_null(pop->op_next);
6266                     op_null(pop);
6267                     o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6268                     o->op_next = pop->op_next->op_next;
6269                     o->op_type = OP_AELEMFAST;
6270                     o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6271                     o->op_private = (U8)i;
6272                     gv = cGVOPo_gv;
6273                     GvAVn(gv);
6274                 }
6275             }
6276             else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6277                 GV *gv = cGVOPo_gv;
6278                 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
6279                     /* XXX could check prototype here instead of just carping */
6280                     SV *sv = sv_newmortal();
6281                     gv_efullname3(sv, gv, Nullch);
6282                     Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
6283                                 "%"SVf"() called too early to check prototype",
6284                                 sv);
6285                 }
6286             }
6287             else if (o->op_next->op_type == OP_READLINE
6288                     && o->op_next->op_next->op_type == OP_CONCAT
6289                     && (o->op_next->op_next->op_flags & OPf_STACKED))
6290             {
6291                 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
6292                 o->op_type   = OP_RCATLINE;
6293                 o->op_flags |= OPf_STACKED;
6294                 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
6295                 op_null(o->op_next->op_next);
6296                 op_null(o->op_next);
6297             }
6298
6299             o->op_seq = PL_op_seqmax++;
6300             break;
6301
6302         case OP_MAPWHILE:
6303         case OP_GREPWHILE:
6304         case OP_AND:
6305         case OP_OR:
6306         case OP_DOR:
6307         case OP_ANDASSIGN:
6308         case OP_ORASSIGN:
6309         case OP_DORASSIGN:
6310         case OP_COND_EXPR:
6311         case OP_RANGE:
6312             o->op_seq = PL_op_seqmax++;
6313             while (cLOGOP->op_other->op_type == OP_NULL)
6314                 cLOGOP->op_other = cLOGOP->op_other->op_next;
6315             peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
6316             break;
6317
6318         case OP_ENTERLOOP:
6319         case OP_ENTERITER:
6320             o->op_seq = PL_op_seqmax++;
6321             while (cLOOP->op_redoop->op_type == OP_NULL)
6322                 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6323             peep(cLOOP->op_redoop);
6324             while (cLOOP->op_nextop->op_type == OP_NULL)
6325                 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6326             peep(cLOOP->op_nextop);
6327             while (cLOOP->op_lastop->op_type == OP_NULL)
6328                 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6329             peep(cLOOP->op_lastop);
6330             break;
6331
6332         case OP_QR:
6333         case OP_MATCH:
6334         case OP_SUBST:
6335             o->op_seq = PL_op_seqmax++;
6336             while (cPMOP->op_pmreplstart &&
6337                    cPMOP->op_pmreplstart->op_type == OP_NULL)
6338                 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6339             peep(cPMOP->op_pmreplstart);
6340             break;
6341
6342         case OP_EXEC:
6343             o->op_seq = PL_op_seqmax++;
6344             if (ckWARN(WARN_SYNTAX) && o->op_next
6345                 && o->op_next->op_type == OP_NEXTSTATE) {
6346                 if (o->op_next->op_sibling &&
6347                         o->op_next->op_sibling->op_type != OP_EXIT &&
6348                         o->op_next->op_sibling->op_type != OP_WARN &&
6349                         o->op_next->op_sibling->op_type != OP_DIE) {
6350                     line_t oldline = CopLINE(PL_curcop);
6351
6352                     CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6353                     Perl_warner(aTHX_ packWARN(WARN_EXEC),
6354                                 "Statement unlikely to be reached");
6355                     Perl_warner(aTHX_ packWARN(WARN_EXEC),
6356                                 "\t(Maybe you meant system() when you said exec()?)\n");
6357                     CopLINE_set(PL_curcop, oldline);
6358                 }
6359             }
6360             break;
6361
6362         case OP_HELEM: {
6363             SV *lexname;
6364             SV **svp, *sv;
6365             char *key = NULL;
6366             STRLEN keylen;
6367
6368             o->op_seq = PL_op_seqmax++;
6369
6370             if (((BINOP*)o)->op_last->op_type != OP_CONST)
6371                 break;
6372
6373             /* Make the CONST have a shared SV */
6374             svp = cSVOPx_svp(((BINOP*)o)->op_last);
6375             if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
6376                 key = SvPV(sv, keylen);
6377                 lexname = newSVpvn_share(key,
6378                                          SvUTF8(sv) ? -(I32)keylen : keylen,
6379                                          0);
6380                 SvREFCNT_dec(sv);
6381                 *svp = lexname;
6382             }
6383             break;
6384         }
6385
6386         default:
6387             o->op_seq = PL_op_seqmax++;
6388             break;
6389         }
6390         oldop = o;
6391     }
6392     LEAVE;
6393 }
6394
6395
6396
6397 char* Perl_custom_op_name(pTHX_ OP* o)
6398 {
6399     IV  index = PTR2IV(o->op_ppaddr);
6400     SV* keysv;
6401     HE* he;
6402
6403     if (!PL_custom_op_names) /* This probably shouldn't happen */
6404         return PL_op_name[OP_CUSTOM];
6405
6406     keysv = sv_2mortal(newSViv(index));
6407
6408     he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
6409     if (!he)
6410         return PL_op_name[OP_CUSTOM]; /* Don't know who you are */
6411
6412     return SvPV_nolen(HeVAL(he));
6413 }
6414
6415 char* Perl_custom_op_desc(pTHX_ OP* o)
6416 {
6417     IV  index = PTR2IV(o->op_ppaddr);
6418     SV* keysv;
6419     HE* he;
6420
6421     if (!PL_custom_op_descs)
6422         return PL_op_desc[OP_CUSTOM];
6423
6424     keysv = sv_2mortal(newSViv(index));
6425
6426     he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
6427     if (!he)
6428         return PL_op_desc[OP_CUSTOM];
6429
6430     return SvPV_nolen(HeVAL(he));
6431 }
6432
6433
6434 #include "XSUB.h"
6435
6436 /* Efficient sub that returns a constant scalar value. */
6437 static void
6438 const_sv_xsub(pTHX_ CV* cv)
6439 {
6440     dXSARGS;
6441     if (items != 0) {
6442 #if 0
6443         Perl_croak(aTHX_ "usage: %s::%s()",
6444                    HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
6445 #endif
6446     }
6447     EXTEND(sp, 1);
6448     ST(0) = (SV*)XSANY.any_ptr;
6449     XSRETURN(1);
6450 }