op.c

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