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") && !PL_error_count) {
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, CopFILE(PL_curcop));
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                                  OP *op;
5112
5113                                  name = 0;
5114                                  if ((op = ((BINOP*)kid)->op_first)) {
5115                                       SV *tmpstr = Nullsv;
5116                                       char *a =
5117                                            kid->op_type == OP_AELEM ?
5118                                            "[]" : "{}";
5119                                       if (((op->op_type == OP_RV2AV) ||
5120                                            (op->op_type == OP_RV2HV)) &&
5121                                           (op = ((UNOP*)op)->op_first) &&
5122                                           (op->op_type == OP_GV)) {
5123                                            /* packagevar $a[] or $h{} */
5124                                            GV *gv = cGVOPx_gv(op);
5125                                            if (gv)
5126                                                 tmpstr =
5127                                                      Perl_newSVpvf(aTHX_
5128                                                                    "%s%c...%c",
5129                                                                    GvNAME(gv),
5130                                                                    a[0], a[1]);
5131                                       }
5132                                       else if (op->op_type == OP_PADAV
5133                                                || op->op_type == OP_PADHV) {
5134                                            /* lexicalvar $a[] or $h{} */
5135                                            char *padname =
5136                                                 PAD_COMPNAME_PV(op->op_targ);
5137                                            if (padname)
5138                                                 tmpstr =
5139                                                      Perl_newSVpvf(aTHX_
5140                                                                    "%s%c...%c",
5141                                                                    padname + 1,
5142                                                                    a[0], a[1]);
5143
5144                                       }
5145                                       if (tmpstr) {
5146                                            name = savepv(SvPVX(tmpstr));
5147                                            len = strlen(name);
5148                                            sv_2mortal(tmpstr);
5149                                       }
5150                                  }
5151                                  if (!name) {
5152                                       name = "__ANONIO__";
5153                                       len = 10;
5154                                  }
5155                                  mod(kid, type);
5156                             }
5157                             if (name) {
5158                                 SV *namesv;
5159                                 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5160                                 namesv = PAD_SVl(targ);
5161                                 (void)SvUPGRADE(namesv, SVt_PV);
5162                                 if (*name != '$')
5163                                     sv_setpvn(namesv, "$", 1);
5164                                 sv_catpvn(namesv, name, len);
5165                             }
5166                         }
5167                         kid->op_sibling = 0;
5168                         kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5169                         kid->op_targ = targ;
5170                         kid->op_private |= priv;
5171                     }
5172                     kid->op_sibling = sibl;
5173                     *tokid = kid;
5174                 }
5175                 scalar(kid);
5176                 break;
5177             case OA_SCALARREF:
5178                 mod(scalar(kid), type);
5179                 break;
5180             }
5181             oa >>= 4;
5182             tokid = &kid->op_sibling;
5183             kid = kid->op_sibling;
5184         }
5185         o->op_private |= numargs;
5186         if (kid)
5187             return too_many_arguments(o,OP_DESC(o));
5188         listkids(o);
5189     }
5190     else if (PL_opargs[type] & OA_DEFGV) {
5191         op_free(o);
5192         return newUNOP(type, 0, newDEFSVOP());
5193     }
5194
5195     if (oa) {
5196         while (oa & OA_OPTIONAL)
5197             oa >>= 4;
5198         if (oa && oa != OA_LIST)
5199             return too_few_arguments(o,OP_DESC(o));
5200     }
5201     return o;
5202 }
5203
5204 OP *
5205 Perl_ck_glob(pTHX_ OP *o)
5206 {
5207     GV *gv;
5208
5209     o = ck_fun(o);
5210     if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5211         append_elem(OP_GLOB, o, newDEFSVOP());
5212
5213     if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV))
5214           && GvCVu(gv) && GvIMPORTED_CV(gv)))
5215     {
5216         gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5217     }
5218
5219 #if !defined(PERL_EXTERNAL_GLOB)
5220     /* XXX this can be tightened up and made more failsafe. */
5221     if (!gv) {
5222         GV *glob_gv;
5223         ENTER;
5224         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
5225                 newSVpvn("File::Glob", 10), Nullsv, Nullsv, Nullsv);
5226         gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5227         glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
5228         GvCV(gv) = GvCV(glob_gv);
5229         SvREFCNT_inc((SV*)GvCV(gv));
5230         GvIMPORTED_CV_on(gv);
5231         LEAVE;
5232     }
5233 #endif /* PERL_EXTERNAL_GLOB */
5234
5235     if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5236         append_elem(OP_GLOB, o,
5237                     newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5238         o->op_type = OP_LIST;
5239         o->op_ppaddr = PL_ppaddr[OP_LIST];
5240         cLISTOPo->op_first->op_type = OP_PUSHMARK;
5241         cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5242         o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5243                     append_elem(OP_LIST, o,
5244                                 scalar(newUNOP(OP_RV2CV, 0,
5245                                                newGVOP(OP_GV, 0, gv)))));
5246         o = newUNOP(OP_NULL, 0, ck_subr(o));
5247         o->op_targ = OP_GLOB;           /* hint at what it used to be */
5248         return o;
5249     }
5250     gv = newGVgen("main");
5251     gv_IOadd(gv);
5252     append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5253     scalarkids(o);
5254     return o;
5255 }
5256
5257 OP *
5258 Perl_ck_grep(pTHX_ OP *o)
5259 {
5260     LOGOP *gwop;
5261     OP *kid;
5262     OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5263
5264     o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5265     NewOp(1101, gwop, 1, LOGOP);
5266
5267     if (o->op_flags & OPf_STACKED) {
5268         OP* k;
5269         o = ck_sort(o);
5270         kid = cLISTOPo->op_first->op_sibling;
5271         for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
5272             kid = k;
5273         }
5274         kid->op_next = (OP*)gwop;
5275         o->op_flags &= ~OPf_STACKED;
5276     }
5277     kid = cLISTOPo->op_first->op_sibling;
5278     if (type == OP_MAPWHILE)
5279         list(kid);
5280     else
5281         scalar(kid);
5282     o = ck_fun(o);
5283     if (PL_error_count)
5284         return o;
5285     kid = cLISTOPo->op_first->op_sibling;
5286     if (kid->op_type != OP_NULL)
5287         Perl_croak(aTHX_ "panic: ck_grep");
5288     kid = kUNOP->op_first;
5289
5290     gwop->op_type = type;
5291     gwop->op_ppaddr = PL_ppaddr[type];
5292     gwop->op_first = listkids(o);
5293     gwop->op_flags |= OPf_KIDS;
5294     gwop->op_private = 1;
5295     gwop->op_other = LINKLIST(kid);
5296     gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5297     kid->op_next = (OP*)gwop;
5298
5299     kid = cLISTOPo->op_first->op_sibling;
5300     if (!kid || !kid->op_sibling)
5301         return too_few_arguments(o,OP_DESC(o));
5302     for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5303         mod(kid, OP_GREPSTART);
5304
5305     return (OP*)gwop;
5306 }
5307
5308 OP *
5309 Perl_ck_index(pTHX_ OP *o)
5310 {
5311     if (o->op_flags & OPf_KIDS) {
5312         OP *kid = cLISTOPo->op_first->op_sibling;       /* get past pushmark */
5313         if (kid)
5314             kid = kid->op_sibling;                      /* get past "big" */
5315         if (kid && kid->op_type == OP_CONST)
5316             fbm_compile(((SVOP*)kid)->op_sv, 0);
5317     }
5318     return ck_fun(o);
5319 }
5320
5321 OP *
5322 Perl_ck_lengthconst(pTHX_ OP *o)
5323 {
5324     /* XXX length optimization goes here */
5325     return ck_fun(o);
5326 }
5327
5328 OP *
5329 Perl_ck_lfun(pTHX_ OP *o)
5330 {
5331     OPCODE type = o->op_type;
5332     return modkids(ck_fun(o), type);
5333 }
5334
5335 OP *
5336 Perl_ck_defined(pTHX_ OP *o)            /* 19990527 MJD */
5337 {
5338     if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
5339         switch (cUNOPo->op_first->op_type) {
5340         case OP_RV2AV:
5341             /* This is needed for
5342                if (defined %stash::)
5343                to work.   Do not break Tk.
5344                */
5345             break;                      /* Globals via GV can be undef */
5346         case OP_PADAV:
5347         case OP_AASSIGN:                /* Is this a good idea? */
5348             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5349                         "defined(@array) is deprecated");
5350             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5351                         "\t(Maybe you should just omit the defined()?)\n");
5352         break;
5353         case OP_RV2HV:
5354             /* This is needed for
5355                if (defined %stash::)
5356                to work.   Do not break Tk.
5357                */
5358             break;                      /* Globals via GV can be undef */
5359         case OP_PADHV:
5360             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5361                         "defined(%%hash) is deprecated");
5362             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5363                         "\t(Maybe you should just omit the defined()?)\n");
5364             break;
5365         default:
5366             /* no warning */
5367             break;
5368         }
5369     }
5370     return ck_rfun(o);
5371 }
5372
5373 OP *
5374 Perl_ck_rfun(pTHX_ OP *o)
5375 {
5376     OPCODE type = o->op_type;
5377     return refkids(ck_fun(o), type);
5378 }
5379
5380 OP *
5381 Perl_ck_listiob(pTHX_ OP *o)
5382 {
5383     register OP *kid;
5384
5385     kid = cLISTOPo->op_first;
5386     if (!kid) {
5387         o = force_list(o);
5388         kid = cLISTOPo->op_first;
5389     }
5390     if (kid->op_type == OP_PUSHMARK)
5391         kid = kid->op_sibling;
5392     if (kid && o->op_flags & OPf_STACKED)
5393         kid = kid->op_sibling;
5394     else if (kid && !kid->op_sibling) {         /* print HANDLE; */
5395         if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
5396             o->op_flags |= OPf_STACKED; /* make it a filehandle */
5397             kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
5398             cLISTOPo->op_first->op_sibling = kid;
5399             cLISTOPo->op_last = kid;
5400             kid = kid->op_sibling;
5401         }
5402     }
5403
5404     if (!kid)
5405         append_elem(o->op_type, o, newDEFSVOP());
5406
5407     return listkids(o);
5408 }
5409
5410 OP *
5411 Perl_ck_sassign(pTHX_ OP *o)
5412 {
5413     OP *kid = cLISTOPo->op_first;
5414     /* has a disposable target? */
5415     if ((PL_opargs[kid->op_type] & OA_TARGLEX)
5416         && !(kid->op_flags & OPf_STACKED)
5417         /* Cannot steal the second time! */
5418         && !(kid->op_private & OPpTARGET_MY))
5419     {
5420         OP *kkid = kid->op_sibling;
5421
5422         /* Can just relocate the target. */
5423         if (kkid && kkid->op_type == OP_PADSV
5424             && !(kkid->op_private & OPpLVAL_INTRO))
5425         {
5426             kid->op_targ = kkid->op_targ;
5427             kkid->op_targ = 0;
5428             /* Now we do not need PADSV and SASSIGN. */
5429             kid->op_sibling = o->op_sibling;    /* NULL */
5430             cLISTOPo->op_first = NULL;
5431             op_free(o);
5432             op_free(kkid);
5433             kid->op_private |= OPpTARGET_MY;    /* Used for context settings */
5434             return kid;
5435         }
5436     }
5437     return o;
5438 }
5439
5440 OP *
5441 Perl_ck_match(pTHX_ OP *o)
5442 {
5443     o->op_private |= OPpRUNTIME;
5444     return o;
5445 }
5446
5447 OP *
5448 Perl_ck_method(pTHX_ OP *o)
5449 {
5450     OP *kid = cUNOPo->op_first;
5451     if (kid->op_type == OP_CONST) {
5452         SV* sv = kSVOP->op_sv;
5453         if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
5454             OP *cmop;
5455             if (!SvREADONLY(sv) || !SvFAKE(sv)) {
5456                 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
5457             }
5458             else {
5459                 kSVOP->op_sv = Nullsv;
5460             }
5461             cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
5462             op_free(o);
5463             return cmop;
5464         }
5465     }
5466     return o;
5467 }
5468
5469 OP *
5470 Perl_ck_null(pTHX_ OP *o)
5471 {
5472     return o;
5473 }
5474
5475 OP *
5476 Perl_ck_open(pTHX_ OP *o)
5477 {
5478     HV *table = GvHV(PL_hintgv);
5479     if (table) {
5480         SV **svp;
5481         I32 mode;
5482         svp = hv_fetch(table, "open_IN", 7, FALSE);
5483         if (svp && *svp) {
5484             mode = mode_from_discipline(*svp);
5485             if (mode & O_BINARY)
5486                 o->op_private |= OPpOPEN_IN_RAW;
5487             else if (mode & O_TEXT)
5488                 o->op_private |= OPpOPEN_IN_CRLF;
5489         }
5490
5491         svp = hv_fetch(table, "open_OUT", 8, FALSE);
5492         if (svp && *svp) {
5493             mode = mode_from_discipline(*svp);
5494             if (mode & O_BINARY)
5495                 o->op_private |= OPpOPEN_OUT_RAW;
5496             else if (mode & O_TEXT)
5497                 o->op_private |= OPpOPEN_OUT_CRLF;
5498         }
5499     }
5500     if (o->op_type == OP_BACKTICK)
5501         return o;
5502     return ck_fun(o);
5503 }
5504
5505 OP *
5506 Perl_ck_repeat(pTHX_ OP *o)
5507 {
5508     if (cBINOPo->op_first->op_flags & OPf_PARENS) {
5509         o->op_private |= OPpREPEAT_DOLIST;
5510         cBINOPo->op_first = force_list(cBINOPo->op_first);
5511     }
5512     else
5513         scalar(o);
5514     return o;
5515 }
5516
5517 OP *
5518 Perl_ck_require(pTHX_ OP *o)
5519 {
5520     GV* gv;
5521
5522     if (o->op_flags & OPf_KIDS) {       /* Shall we supply missing .pm? */
5523         SVOP *kid = (SVOP*)cUNOPo->op_first;
5524
5525         if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5526             char *s;
5527             for (s = SvPVX(kid->op_sv); *s; s++) {
5528                 if (*s == ':' && s[1] == ':') {
5529                     *s = '/';
5530                     Move(s+2, s+1, strlen(s+2)+1, char);
5531                     --SvCUR(kid->op_sv);
5532                 }
5533             }
5534             if (SvREADONLY(kid->op_sv)) {
5535                 SvREADONLY_off(kid->op_sv);
5536                 sv_catpvn(kid->op_sv, ".pm", 3);
5537                 SvREADONLY_on(kid->op_sv);
5538             }
5539             else
5540                 sv_catpvn(kid->op_sv, ".pm", 3);
5541         }
5542     }
5543
5544     /* handle override, if any */
5545     gv = gv_fetchpv("require", FALSE, SVt_PVCV);
5546     if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
5547         gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
5548
5549     if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5550         OP *kid = cUNOPo->op_first;
5551         cUNOPo->op_first = 0;
5552         op_free(o);
5553         return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
5554                                append_elem(OP_LIST, kid,
5555                                            scalar(newUNOP(OP_RV2CV, 0,
5556                                                           newGVOP(OP_GV, 0,
5557                                                                   gv))))));
5558     }
5559
5560     return ck_fun(o);
5561 }
5562
5563 OP *
5564 Perl_ck_return(pTHX_ OP *o)
5565 {
5566     OP *kid;
5567     if (CvLVALUE(PL_compcv)) {
5568         for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
5569             mod(kid, OP_LEAVESUBLV);
5570     }
5571     return o;
5572 }
5573
5574 #if 0
5575 OP *
5576 Perl_ck_retarget(pTHX_ OP *o)
5577 {
5578     Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5579     /* STUB */
5580     return o;
5581 }
5582 #endif
5583
5584 OP *
5585 Perl_ck_select(pTHX_ OP *o)
5586 {
5587     OP* kid;
5588     if (o->op_flags & OPf_KIDS) {
5589         kid = cLISTOPo->op_first->op_sibling;   /* get past pushmark */
5590         if (kid && kid->op_sibling) {
5591             o->op_type = OP_SSELECT;
5592             o->op_ppaddr = PL_ppaddr[OP_SSELECT];
5593             o = ck_fun(o);
5594             return fold_constants(o);
5595         }
5596     }
5597     o = ck_fun(o);
5598     kid = cLISTOPo->op_first->op_sibling;    /* get past pushmark */
5599     if (kid && kid->op_type == OP_RV2GV)
5600         kid->op_private &= ~HINT_STRICT_REFS;
5601     return o;
5602 }
5603
5604 OP *
5605 Perl_ck_shift(pTHX_ OP *o)
5606 {
5607     I32 type = o->op_type;
5608
5609     if (!(o->op_flags & OPf_KIDS)) {
5610         OP *argop;
5611
5612         op_free(o);
5613         argop = newUNOP(OP_RV2AV, 0,
5614             scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
5615         return newUNOP(type, 0, scalar(argop));
5616     }
5617     return scalar(modkids(ck_fun(o), type));
5618 }
5619
5620 OP *
5621 Perl_ck_sort(pTHX_ OP *o)
5622 {
5623     OP *firstkid;
5624
5625     if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
5626         simplify_sort(o);
5627     firstkid = cLISTOPo->op_first->op_sibling;          /* get past pushmark */
5628     if (o->op_flags & OPf_STACKED) {                    /* may have been cleared */
5629         OP *k = NULL;
5630         OP *kid = cUNOPx(firstkid)->op_first;           /* get past null */
5631
5632         if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
5633             linklist(kid);
5634             if (kid->op_type == OP_SCOPE) {
5635                 k = kid->op_next;
5636                 kid->op_next = 0;
5637             }
5638             else if (kid->op_type == OP_LEAVE) {
5639                 if (o->op_type == OP_SORT) {
5640                     op_null(kid);                       /* wipe out leave */
5641                     kid->op_next = kid;
5642
5643                     for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
5644                         if (k->op_next == kid)
5645                             k->op_next = 0;
5646                         /* don't descend into loops */
5647                         else if (k->op_type == OP_ENTERLOOP
5648                                  || k->op_type == OP_ENTERITER)
5649                         {
5650                             k = cLOOPx(k)->op_lastop;
5651                         }
5652                     }
5653                 }
5654                 else
5655                     kid->op_next = 0;           /* just disconnect the leave */
5656                 k = kLISTOP->op_first;
5657             }
5658             CALL_PEEP(k);
5659
5660             kid = firstkid;
5661             if (o->op_type == OP_SORT) {
5662                 /* provide scalar context for comparison function/block */
5663                 kid = scalar(kid);
5664                 kid->op_next = kid;
5665             }
5666             else
5667                 kid->op_next = k;
5668             o->op_flags |= OPf_SPECIAL;
5669         }
5670         else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
5671             op_null(firstkid);
5672
5673         firstkid = firstkid->op_sibling;
5674     }
5675
5676     /* provide list context for arguments */
5677     if (o->op_type == OP_SORT)
5678         list(firstkid);
5679
5680     return o;
5681 }
5682
5683 STATIC void
5684 S_simplify_sort(pTHX_ OP *o)
5685 {
5686     register OP *kid = cLISTOPo->op_first->op_sibling;  /* get past pushmark */
5687     OP *k;
5688     int reversed;
5689     GV *gv;
5690     if (!(o->op_flags & OPf_STACKED))
5691         return;
5692     GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
5693     GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
5694     kid = kUNOP->op_first;                              /* get past null */
5695     if (kid->op_type != OP_SCOPE)
5696         return;
5697     kid = kLISTOP->op_last;                             /* get past scope */
5698     switch(kid->op_type) {
5699         case OP_NCMP:
5700         case OP_I_NCMP:
5701         case OP_SCMP:
5702             break;
5703         default:
5704             return;
5705     }
5706     k = kid;                                            /* remember this node*/
5707     if (kBINOP->op_first->op_type != OP_RV2SV)
5708         return;
5709     kid = kBINOP->op_first;                             /* get past cmp */
5710     if (kUNOP->op_first->op_type != OP_GV)
5711         return;
5712     kid = kUNOP->op_first;                              /* get past rv2sv */
5713     gv = kGVOP_gv;
5714     if (GvSTASH(gv) != PL_curstash)
5715         return;
5716     if (strEQ(GvNAME(gv), "a"))
5717         reversed = 0;
5718     else if (strEQ(GvNAME(gv), "b"))
5719         reversed = 1;
5720     else
5721         return;
5722     kid = k;                                            /* back to cmp */
5723     if (kBINOP->op_last->op_type != OP_RV2SV)
5724         return;
5725     kid = kBINOP->op_last;                              /* down to 2nd arg */
5726     if (kUNOP->op_first->op_type != OP_GV)
5727         return;
5728     kid = kUNOP->op_first;                              /* get past rv2sv */
5729     gv = kGVOP_gv;
5730     if (GvSTASH(gv) != PL_curstash
5731         || ( reversed
5732             ? strNE(GvNAME(gv), "a")
5733             : strNE(GvNAME(gv), "b")))
5734         return;
5735     o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
5736     if (reversed)
5737         o->op_private |= OPpSORT_REVERSE;
5738     if (k->op_type == OP_NCMP)
5739         o->op_private |= OPpSORT_NUMERIC;
5740     if (k->op_type == OP_I_NCMP)
5741         o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
5742     kid = cLISTOPo->op_first->op_sibling;
5743     cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
5744     op_free(kid);                                     /* then delete it */
5745 }
5746
5747 OP *
5748 Perl_ck_split(pTHX_ OP *o)
5749 {
5750     register OP *kid;
5751
5752     if (o->op_flags & OPf_STACKED)
5753         return no_fh_allowed(o);
5754
5755     kid = cLISTOPo->op_first;
5756     if (kid->op_type != OP_NULL)
5757         Perl_croak(aTHX_ "panic: ck_split");
5758     kid = kid->op_sibling;
5759     op_free(cLISTOPo->op_first);
5760     cLISTOPo->op_first = kid;
5761     if (!kid) {
5762         cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
5763         cLISTOPo->op_last = kid; /* There was only one element previously */
5764     }
5765
5766     if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
5767         OP *sibl = kid->op_sibling;
5768         kid->op_sibling = 0;
5769         kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
5770         if (cLISTOPo->op_first == cLISTOPo->op_last)
5771             cLISTOPo->op_last = kid;
5772         cLISTOPo->op_first = kid;
5773         kid->op_sibling = sibl;
5774     }
5775
5776     kid->op_type = OP_PUSHRE;
5777     kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
5778     scalar(kid);
5779     if (ckWARN(WARN_REGEXP) && ((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
5780       Perl_warner(aTHX_ packWARN(WARN_REGEXP),
5781                   "Use of /g modifier is meaningless in split");
5782     }
5783
5784     if (!kid->op_sibling)
5785         append_elem(OP_SPLIT, o, newDEFSVOP());
5786
5787     kid = kid->op_sibling;
5788     scalar(kid);
5789
5790     if (!kid->op_sibling)
5791         append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
5792
5793     kid = kid->op_sibling;
5794     scalar(kid);
5795
5796     if (kid->op_sibling)
5797         return too_many_arguments(o,OP_DESC(o));
5798
5799     return o;
5800 }
5801
5802 OP *
5803 Perl_ck_join(pTHX_ OP *o)
5804 {
5805     if (ckWARN(WARN_SYNTAX)) {
5806         OP *kid = cLISTOPo->op_first->op_sibling;
5807         if (kid && kid->op_type == OP_MATCH) {
5808             char *pmstr = "STRING";
5809             if (PM_GETRE(kPMOP))
5810                 pmstr = PM_GETRE(kPMOP)->precomp;
5811             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5812                         "/%s/ should probably be written as \"%s\"",
5813                         pmstr, pmstr);
5814         }
5815     }
5816     return ck_fun(o);
5817 }
5818
5819 OP *
5820 Perl_ck_subr(pTHX_ OP *o)
5821 {
5822     OP *prev = ((cUNOPo->op_first->op_sibling)
5823              ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
5824     OP *o2 = prev->op_sibling;
5825     OP *cvop;
5826     char *proto = 0;
5827     CV *cv = 0;
5828     GV *namegv = 0;
5829     int optional = 0;
5830     I32 arg = 0;
5831     I32 contextclass = 0;
5832     char *e = 0;
5833     STRLEN n_a;
5834     bool delete=0;
5835
5836     o->op_private |= OPpENTERSUB_HASTARG;
5837     for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
5838     if (cvop->op_type == OP_RV2CV) {
5839         SVOP* tmpop;
5840         o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
5841         op_null(cvop);          /* disable rv2cv */
5842         tmpop = (SVOP*)((UNOP*)cvop)->op_first;
5843         if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
5844             GV *gv = cGVOPx_gv(tmpop);
5845             cv = GvCVu(gv);
5846             if (!cv)
5847                 tmpop->op_private |= OPpEARLY_CV;
5848             else {
5849                 if (SvPOK(cv)) {
5850                     namegv = CvANON(cv) ? gv : CvGV(cv);
5851                     proto = SvPV((SV*)cv, n_a);
5852                 }
5853                 if (CvASSERTION(cv)) {
5854                     if (PL_hints & HINT_ASSERTING) {
5855                         if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
5856                             o->op_private |= OPpENTERSUB_DB;
5857                     }
5858                     else {
5859                         delete=1;
5860                         if (ckWARN(WARN_ASSERTIONS) && !(PL_hints & HINT_ASSERTIONSSEEN)) {
5861                             Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
5862                                         "Impossible to activate assertion call");
5863                         }
5864                     }
5865                 }
5866             }
5867         }
5868     }
5869     else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
5870         if (o2->op_type == OP_CONST)
5871             o2->op_private &= ~OPpCONST_STRICT;
5872         else if (o2->op_type == OP_LIST) {
5873             OP *o = ((UNOP*)o2)->op_first->op_sibling;
5874             if (o && o->op_type == OP_CONST)
5875                 o->op_private &= ~OPpCONST_STRICT;
5876         }
5877     }
5878     o->op_private |= (PL_hints & HINT_STRICT_REFS);
5879     if (PERLDB_SUB && PL_curstash != PL_debstash)
5880         o->op_private |= OPpENTERSUB_DB;
5881     while (o2 != cvop) {
5882         if (proto) {
5883             switch (*proto) {
5884             case '\0':
5885                 return too_many_arguments(o, gv_ename(namegv));
5886             case ';':
5887                 optional = 1;
5888                 proto++;
5889                 continue;
5890             case '$':
5891                 proto++;
5892                 arg++;
5893                 scalar(o2);
5894                 break;
5895             case '%':
5896             case '@':
5897                 list(o2);
5898                 arg++;
5899                 break;
5900             case '&':
5901                 proto++;
5902                 arg++;
5903                 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
5904                     bad_type(arg,
5905                         arg == 1 ? "block or sub {}" : "sub {}",
5906                         gv_ename(namegv), o2);
5907                 break;
5908             case '*':
5909                 /* '*' allows any scalar type, including bareword */
5910                 proto++;
5911                 arg++;
5912                 if (o2->op_type == OP_RV2GV)
5913                     goto wrapref;       /* autoconvert GLOB -> GLOBref */
5914                 else if (o2->op_type == OP_CONST)
5915                     o2->op_private &= ~OPpCONST_STRICT;
5916                 else if (o2->op_type == OP_ENTERSUB) {
5917                     /* accidental subroutine, revert to bareword */
5918                     OP *gvop = ((UNOP*)o2)->op_first;
5919                     if (gvop && gvop->op_type == OP_NULL) {
5920                         gvop = ((UNOP*)gvop)->op_first;
5921                         if (gvop) {
5922                             for (; gvop->op_sibling; gvop = gvop->op_sibling)
5923                                 ;
5924                             if (gvop &&
5925                                 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
5926                                 (gvop = ((UNOP*)gvop)->op_first) &&
5927                                 gvop->op_type == OP_GV)
5928                             {
5929                                 GV *gv = cGVOPx_gv(gvop);
5930                                 OP *sibling = o2->op_sibling;
5931                                 SV *n = newSVpvn("",0);
5932                                 op_free(o2);
5933                                 gv_fullname3(n, gv, "");
5934                                 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
5935                                     sv_chop(n, SvPVX(n)+6);
5936                                 o2 = newSVOP(OP_CONST, 0, n);
5937                                 prev->op_sibling = o2;
5938                                 o2->op_sibling = sibling;
5939                             }
5940                         }
5941                     }
5942                 }
5943                 scalar(o2);
5944                 break;
5945             case '[': case ']':
5946                  goto oops;
5947                  break;
5948             case '\\':
5949                 proto++;
5950                 arg++;
5951             again:
5952                 switch (*proto++) {
5953                 case '[':
5954                      if (contextclass++ == 0) {
5955                           e = strchr(proto, ']');
5956                           if (!e || e == proto)
5957                                goto oops;
5958                      }
5959                      else
5960                           goto oops;
5961                      goto again;
5962                      break;
5963                 case ']':
5964                      if (contextclass) {
5965                          char *p = proto;
5966                          char s = *p;
5967                          contextclass = 0;
5968                          *p = '\0';
5969                          while (*--p != '[');
5970                          bad_type(arg, Perl_form(aTHX_ "one of %s", p),
5971                                  gv_ename(namegv), o2);
5972                          *proto = s;
5973                      } else
5974                           goto oops;
5975                      break;
5976                 case '*':
5977                      if (o2->op_type == OP_RV2GV)
5978                           goto wrapref;
5979                      if (!contextclass)
5980                           bad_type(arg, "symbol", gv_ename(namegv), o2);
5981                      break;
5982                 case '&':
5983                      if (o2->op_type == OP_ENTERSUB)
5984                           goto wrapref;
5985                      if (!contextclass)
5986                           bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
5987                      break;
5988                 case '$':
5989                     if (o2->op_type == OP_RV2SV ||
5990                         o2->op_type == OP_PADSV ||
5991                         o2->op_type == OP_HELEM ||
5992                         o2->op_type == OP_AELEM ||
5993                         o2->op_type == OP_THREADSV)
5994                          goto wrapref;
5995                     if (!contextclass)
5996                         bad_type(arg, "scalar", gv_ename(namegv), o2);
5997                      break;
5998                 case '@':
5999                     if (o2->op_type == OP_RV2AV ||
6000                         o2->op_type == OP_PADAV)
6001                          goto wrapref;
6002                     if (!contextclass)
6003                         bad_type(arg, "array", gv_ename(namegv), o2);
6004                     break;
6005                 case '%':
6006                     if (o2->op_type == OP_RV2HV ||
6007                         o2->op_type == OP_PADHV)
6008                          goto wrapref;
6009                     if (!contextclass)
6010                          bad_type(arg, "hash", gv_ename(namegv), o2);
6011                     break;
6012                 wrapref:
6013                     {
6014                         OP* kid = o2;
6015                         OP* sib = kid->op_sibling;
6016                         kid->op_sibling = 0;
6017                         o2 = newUNOP(OP_REFGEN, 0, kid);
6018                         o2->op_sibling = sib;
6019                         prev->op_sibling = o2;
6020                     }
6021                     if (contextclass && e) {
6022                          proto = e + 1;
6023                          contextclass = 0;
6024                     }
6025                     break;
6026                 default: goto oops;
6027                 }
6028                 if (contextclass)
6029                      goto again;
6030                 break;
6031             case ' ':
6032                 proto++;
6033                 continue;
6034             default:
6035               oops:
6036                 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
6037                            gv_ename(namegv), cv);
6038             }
6039         }
6040         else
6041             list(o2);
6042         mod(o2, OP_ENTERSUB);
6043         prev = o2;
6044         o2 = o2->op_sibling;
6045     }
6046     if (proto && !optional &&
6047           (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6048         return too_few_arguments(o, gv_ename(namegv));
6049     if(delete) {
6050         op_free(o);
6051         o=newSVOP(OP_CONST, 0, newSViv(0));
6052     }
6053     return o;
6054 }
6055
6056 OP *
6057 Perl_ck_svconst(pTHX_ OP *o)
6058 {
6059     SvREADONLY_on(cSVOPo->op_sv);
6060     return o;
6061 }
6062
6063 OP *
6064 Perl_ck_trunc(pTHX_ OP *o)
6065 {
6066     if (o->op_flags & OPf_KIDS) {
6067         SVOP *kid = (SVOP*)cUNOPo->op_first;
6068
6069         if (kid->op_type == OP_NULL)
6070             kid = (SVOP*)kid->op_sibling;
6071         if (kid && kid->op_type == OP_CONST &&
6072             (kid->op_private & OPpCONST_BARE))
6073         {
6074             o->op_flags |= OPf_SPECIAL;
6075             kid->op_private &= ~OPpCONST_STRICT;
6076         }
6077     }
6078     return ck_fun(o);
6079 }
6080
6081 OP *
6082 Perl_ck_substr(pTHX_ OP *o)
6083 {
6084     o = ck_fun(o);
6085     if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6086         OP *kid = cLISTOPo->op_first;
6087
6088         if (kid->op_type == OP_NULL)
6089             kid = kid->op_sibling;
6090         if (kid)
6091             kid->op_flags |= OPf_MOD;
6092
6093     }
6094     return o;
6095 }
6096
6097 /* A peephole optimizer.  We visit the ops in the order they're to execute. */
6098
6099 void
6100 Perl_peep(pTHX_ register OP *o)
6101 {
6102     register OP* oldop = 0;
6103
6104     if (!o || o->op_seq)
6105         return;
6106     ENTER;
6107     SAVEOP();
6108     SAVEVPTR(PL_curcop);
6109     for (; o; o = o->op_next) {
6110         if (o->op_seq)
6111             break;
6112         /* The special value -1 is used by the B::C compiler backend to indicate
6113          * that an op is statically defined and should not be freed */
6114         if (!PL_op_seqmax || PL_op_seqmax == (U16)-1)
6115             PL_op_seqmax = 1;
6116         PL_op = o;
6117         switch (o->op_type) {
6118         case OP_SETSTATE:
6119         case OP_NEXTSTATE:
6120         case OP_DBSTATE:
6121             PL_curcop = ((COP*)o);              /* for warnings */
6122             o->op_seq = PL_op_seqmax++;
6123             break;
6124
6125         case OP_CONST:
6126             if (cSVOPo->op_private & OPpCONST_STRICT)
6127                 no_bareword_allowed(o);
6128 #ifdef USE_ITHREADS
6129         case OP_METHOD_NAMED:
6130             /* Relocate sv to the pad for thread safety.
6131              * Despite being a "constant", the SV is written to,
6132              * for reference counts, sv_upgrade() etc. */
6133             if (cSVOP->op_sv) {
6134                 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6135                 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
6136                     /* If op_sv is already a PADTMP then it is being used by
6137                      * some pad, so make a copy. */
6138                     sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
6139                     SvREADONLY_on(PAD_SVl(ix));
6140                     SvREFCNT_dec(cSVOPo->op_sv);
6141                 }
6142                 else {
6143                     SvREFCNT_dec(PAD_SVl(ix));
6144                     SvPADTMP_on(cSVOPo->op_sv);
6145                     PAD_SETSV(ix, cSVOPo->op_sv);
6146                     /* XXX I don't know how this isn't readonly already. */
6147                     SvREADONLY_on(PAD_SVl(ix));
6148                 }
6149                 cSVOPo->op_sv = Nullsv;
6150                 o->op_targ = ix;
6151             }
6152 #endif
6153             o->op_seq = PL_op_seqmax++;
6154             break;
6155
6156         case OP_CONCAT:
6157             if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6158                 if (o->op_next->op_private & OPpTARGET_MY) {
6159                     if (o->op_flags & OPf_STACKED) /* chained concats */
6160                         goto ignore_optimization;
6161                     else {
6162                         /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6163                         o->op_targ = o->op_next->op_targ;
6164                         o->op_next->op_targ = 0;
6165                         o->op_private |= OPpTARGET_MY;
6166                     }
6167                 }
6168                 op_null(o->op_next);
6169             }
6170           ignore_optimization:
6171             o->op_seq = PL_op_seqmax++;
6172             break;
6173         case OP_STUB:
6174             if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6175                 o->op_seq = PL_op_seqmax++;
6176                 break; /* Scalar stub must produce undef.  List stub is noop */
6177             }
6178             goto nothin;
6179         case OP_NULL:
6180             if (o->op_targ == OP_NEXTSTATE
6181                 || o->op_targ == OP_DBSTATE
6182                 || o->op_targ == OP_SETSTATE)
6183             {
6184                 PL_curcop = ((COP*)o);
6185             }
6186             /* XXX: We avoid setting op_seq here to prevent later calls
6187                to peep() from mistakenly concluding that optimisation
6188                has already occurred. This doesn't fix the real problem,
6189                though (See 20010220.007). AMS 20010719 */
6190             if (oldop && o->op_next) {
6191                 oldop->op_next = o->op_next;
6192                 continue;
6193             }
6194             break;
6195         case OP_SCALAR:
6196         case OP_LINESEQ:
6197         case OP_SCOPE:
6198           nothin:
6199             if (oldop && o->op_next) {
6200                 oldop->op_next = o->op_next;
6201                 continue;
6202             }
6203             o->op_seq = PL_op_seqmax++;
6204             break;
6205
6206         case OP_GV:
6207             if (o->op_next->op_type == OP_RV2SV) {
6208                 if (!(o->op_next->op_private & OPpDEREF)) {
6209                     op_null(o->op_next);
6210                     o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6211                                                                | OPpOUR_INTRO);
6212                     o->op_next = o->op_next->op_next;
6213                     o->op_type = OP_GVSV;
6214                     o->op_ppaddr = PL_ppaddr[OP_GVSV];
6215                 }
6216             }
6217             else if (o->op_next->op_type == OP_RV2AV) {
6218                 OP* pop = o->op_next->op_next;
6219                 IV i;
6220                 if (pop && pop->op_type == OP_CONST &&
6221                     (PL_op = pop->op_next) &&
6222                     pop->op_next->op_type == OP_AELEM &&
6223                     !(pop->op_next->op_private &
6224                       (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6225                     (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
6226                                 <= 255 &&
6227                     i >= 0)
6228                 {
6229                     GV *gv;
6230                     op_null(o->op_next);
6231                     op_null(pop->op_next);
6232                     op_null(pop);
6233                     o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6234                     o->op_next = pop->op_next->op_next;
6235                     o->op_type = OP_AELEMFAST;
6236                     o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6237                     o->op_private = (U8)i;
6238                     gv = cGVOPo_gv;
6239                     GvAVn(gv);
6240                 }
6241             }
6242             else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6243                 GV *gv = cGVOPo_gv;
6244                 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
6245                     /* XXX could check prototype here instead of just carping */
6246                     SV *sv = sv_newmortal();
6247                     gv_efullname3(sv, gv, Nullch);
6248                     Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
6249                                 "%"SVf"() called too early to check prototype",
6250                                 sv);
6251                 }
6252             }
6253             else if (o->op_next->op_type == OP_READLINE
6254                     && o->op_next->op_next->op_type == OP_CONCAT
6255                     && (o->op_next->op_next->op_flags & OPf_STACKED))
6256             {
6257                 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
6258                 o->op_type   = OP_RCATLINE;
6259                 o->op_flags |= OPf_STACKED;
6260                 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
6261                 op_null(o->op_next->op_next);
6262                 op_null(o->op_next);
6263             }
6264
6265             o->op_seq = PL_op_seqmax++;
6266             break;
6267
6268         case OP_MAPWHILE:
6269         case OP_GREPWHILE:
6270         case OP_AND:
6271         case OP_OR:
6272         case OP_DOR:
6273         case OP_ANDASSIGN:
6274         case OP_ORASSIGN:
6275         case OP_DORASSIGN:
6276         case OP_COND_EXPR:
6277         case OP_RANGE:
6278             o->op_seq = PL_op_seqmax++;
6279             while (cLOGOP->op_other->op_type == OP_NULL)
6280                 cLOGOP->op_other = cLOGOP->op_other->op_next;
6281             peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
6282             break;
6283
6284         case OP_ENTERLOOP:
6285         case OP_ENTERITER:
6286             o->op_seq = PL_op_seqmax++;
6287             while (cLOOP->op_redoop->op_type == OP_NULL)
6288                 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6289             peep(cLOOP->op_redoop);
6290             while (cLOOP->op_nextop->op_type == OP_NULL)
6291                 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6292             peep(cLOOP->op_nextop);
6293             while (cLOOP->op_lastop->op_type == OP_NULL)
6294                 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6295             peep(cLOOP->op_lastop);
6296             break;
6297
6298         case OP_QR:
6299         case OP_MATCH:
6300         case OP_SUBST:
6301             o->op_seq = PL_op_seqmax++;
6302             while (cPMOP->op_pmreplstart &&
6303                    cPMOP->op_pmreplstart->op_type == OP_NULL)
6304                 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6305             peep(cPMOP->op_pmreplstart);
6306             break;
6307
6308         case OP_EXEC:
6309             o->op_seq = PL_op_seqmax++;
6310             if (ckWARN(WARN_SYNTAX) && o->op_next
6311                 && o->op_next->op_type == OP_NEXTSTATE) {
6312                 if (o->op_next->op_sibling &&
6313                         o->op_next->op_sibling->op_type != OP_EXIT &&
6314                         o->op_next->op_sibling->op_type != OP_WARN &&
6315                         o->op_next->op_sibling->op_type != OP_DIE) {
6316                     line_t oldline = CopLINE(PL_curcop);
6317
6318                     CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6319                     Perl_warner(aTHX_ packWARN(WARN_EXEC),
6320                                 "Statement unlikely to be reached");
6321                     Perl_warner(aTHX_ packWARN(WARN_EXEC),
6322                                 "\t(Maybe you meant system() when you said exec()?)\n");
6323                     CopLINE_set(PL_curcop, oldline);
6324                 }
6325             }
6326             break;
6327
6328         case OP_HELEM: {
6329             SV *lexname;
6330             SV **svp, *sv;
6331             char *key = NULL;
6332             STRLEN keylen;
6333
6334             o->op_seq = PL_op_seqmax++;
6335
6336             if (((BINOP*)o)->op_last->op_type != OP_CONST)
6337                 break;
6338
6339             /* Make the CONST have a shared SV */
6340             svp = cSVOPx_svp(((BINOP*)o)->op_last);
6341             if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
6342                 key = SvPV(sv, keylen);
6343                 lexname = newSVpvn_share(key,
6344                                          SvUTF8(sv) ? -(I32)keylen : keylen,
6345                                          0);
6346                 SvREFCNT_dec(sv);
6347                 *svp = lexname;
6348             }
6349             break;
6350         }
6351
6352         default:
6353             o->op_seq = PL_op_seqmax++;
6354             break;
6355         }
6356         oldop = o;
6357     }
6358     LEAVE;
6359 }
6360
6361
6362
6363 char* Perl_custom_op_name(pTHX_ OP* o)
6364 {
6365     IV  index = PTR2IV(o->op_ppaddr);
6366     SV* keysv;
6367     HE* he;
6368
6369     if (!PL_custom_op_names) /* This probably shouldn't happen */
6370         return PL_op_name[OP_CUSTOM];
6371
6372     keysv = sv_2mortal(newSViv(index));
6373
6374     he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
6375     if (!he)
6376         return PL_op_name[OP_CUSTOM]; /* Don't know who you are */
6377
6378     return SvPV_nolen(HeVAL(he));
6379 }
6380
6381 char* Perl_custom_op_desc(pTHX_ OP* o)
6382 {
6383     IV  index = PTR2IV(o->op_ppaddr);
6384     SV* keysv;
6385     HE* he;
6386
6387     if (!PL_custom_op_descs)
6388         return PL_op_desc[OP_CUSTOM];
6389
6390     keysv = sv_2mortal(newSViv(index));
6391
6392     he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
6393     if (!he)
6394         return PL_op_desc[OP_CUSTOM];
6395
6396     return SvPV_nolen(HeVAL(he));
6397 }
6398
6399
6400 #include "XSUB.h"
6401
6402 /* Efficient sub that returns a constant scalar value. */
6403 static void
6404 const_sv_xsub(pTHX_ CV* cv)
6405 {
6406     dXSARGS;
6407     if (items != 0) {
6408 #if 0
6409         Perl_croak(aTHX_ "usage: %s::%s()",
6410                    HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
6411 #endif
6412     }
6413     EXTEND(sp, 1);
6414     ST(0) = (SV*)XSANY.any_ptr;
6415     XSRETURN(1);
6416 }