op.c

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