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