op.c

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