op.c

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