op.c

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