op.c

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