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                                                     == (STRLEN)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 /*
3757 =for apidoc cv_undef
3758
3759 Clear out all the active components of a CV. This can happen either
3760 by an explicit C<undef &foo>, or by the reference count going to zero.
3761 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
3762 children can still follow the full lexical scope chain.
3763
3764 =cut
3765 */
3766
3767 void
3768 Perl_cv_undef(pTHX_ CV *cv)
3769 {
3770 #ifdef USE_ITHREADS
3771     if (CvFILE(cv) && !CvXSUB(cv)) {
3772         /* for XSUBs CvFILE point directly to static memory; __FILE__ */
3773         Safefree(CvFILE(cv));
3774     }
3775     CvFILE(cv) = 0;
3776 #endif
3777
3778     if (!CvXSUB(cv) && CvROOT(cv)) {
3779         if (CvDEPTH(cv))
3780             Perl_croak(aTHX_ "Can't undef active subroutine");
3781         ENTER;
3782
3783         PAD_SAVE_SETNULLPAD();
3784
3785         op_free(CvROOT(cv));
3786         CvROOT(cv) = Nullop;
3787         LEAVE;
3788     }
3789     SvPOK_off((SV*)cv);         /* forget prototype */
3790     CvGV(cv) = Nullgv;
3791
3792     pad_undef(cv);
3793
3794     /* remove CvOUTSIDE unless this is an undef rather than a free */
3795     if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
3796         if (!CvWEAKOUTSIDE(cv))
3797             SvREFCNT_dec(CvOUTSIDE(cv));
3798         CvOUTSIDE(cv) = Nullcv;
3799     }
3800     if (CvCONST(cv)) {
3801         SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
3802         CvCONST_off(cv);
3803     }
3804     if (CvXSUB(cv)) {
3805         CvXSUB(cv) = 0;
3806     }
3807     /* delete all flags except WEAKOUTSIDE */
3808     CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
3809 }
3810
3811 void
3812 Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
3813 {
3814     if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
3815         SV* msg = sv_newmortal();
3816         SV* name = Nullsv;
3817
3818         if (gv)
3819             gv_efullname3(name = sv_newmortal(), gv, Nullch);
3820         sv_setpv(msg, "Prototype mismatch:");
3821         if (name)
3822             Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
3823         if (SvPOK(cv))
3824             Perl_sv_catpvf(aTHX_ msg, " (%s)", SvPVX(cv));
3825         sv_catpv(msg, " vs ");
3826         if (p)
3827             Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
3828         else
3829             sv_catpv(msg, "none");
3830         Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, msg);
3831     }
3832 }
3833
3834 static void const_sv_xsub(pTHX_ CV* cv);
3835
3836 /*
3837
3838 =head1 Optree Manipulation Functions
3839
3840 =for apidoc cv_const_sv
3841
3842 If C<cv> is a constant sub eligible for inlining. returns the constant
3843 value returned by the sub.  Otherwise, returns NULL.
3844
3845 Constant subs can be created with C<newCONSTSUB> or as described in
3846 L<perlsub/"Constant Functions">.
3847
3848 =cut
3849 */
3850 SV *
3851 Perl_cv_const_sv(pTHX_ CV *cv)
3852 {
3853     if (!cv || !CvCONST(cv))
3854         return Nullsv;
3855     return (SV*)CvXSUBANY(cv).any_ptr;
3856 }
3857
3858 SV *
3859 Perl_op_const_sv(pTHX_ OP *o, CV *cv)
3860 {
3861     SV *sv = Nullsv;
3862
3863     if (!o)
3864         return Nullsv;
3865
3866     if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
3867         o = cLISTOPo->op_first->op_sibling;
3868
3869     for (; o; o = o->op_next) {
3870         OPCODE type = o->op_type;
3871
3872         if (sv && o->op_next == o)
3873             return sv;
3874         if (o->op_next != o) {
3875             if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
3876                 continue;
3877             if (type == OP_DBSTATE)
3878                 continue;
3879         }
3880         if (type == OP_LEAVESUB || type == OP_RETURN)
3881             break;
3882         if (sv)
3883             return Nullsv;
3884         if (type == OP_CONST && cSVOPo->op_sv)
3885             sv = cSVOPo->op_sv;
3886         else if ((type == OP_PADSV || type == OP_CONST) && cv) {
3887             sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
3888             if (!sv)
3889                 return Nullsv;
3890             if (CvCONST(cv)) {
3891                 /* We get here only from cv_clone2() while creating a closure.
3892                    Copy the const value here instead of in cv_clone2 so that
3893                    SvREADONLY_on doesn't lead to problems when leaving
3894                    scope.
3895                 */
3896                 sv = newSVsv(sv);
3897             }
3898             if (!SvREADONLY(sv) && SvREFCNT(sv) > 1)
3899                 return Nullsv;
3900         }
3901         else
3902             return Nullsv;
3903     }
3904     if (sv)
3905         SvREADONLY_on(sv);
3906     return sv;
3907 }
3908
3909 void
3910 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
3911 {
3912     if (o)
3913         SAVEFREEOP(o);
3914     if (proto)
3915         SAVEFREEOP(proto);
3916     if (attrs)
3917         SAVEFREEOP(attrs);
3918     if (block)
3919         SAVEFREEOP(block);
3920     Perl_croak(aTHX_ "\"my sub\" not yet implemented");
3921 }
3922
3923 CV *
3924 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
3925 {
3926     return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
3927 }
3928
3929 CV *
3930 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
3931 {
3932     STRLEN n_a;
3933     char *name;
3934     char *aname;
3935     GV *gv;
3936     char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
3937     register CV *cv=0;
3938     SV *const_sv;
3939
3940     name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
3941     if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
3942         SV *sv = sv_newmortal();
3943         Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
3944                        PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
3945                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3946         aname = SvPVX(sv);
3947     }
3948     else
3949         aname = Nullch;
3950     gv = gv_fetchpv(name ? name : (aname ? aname :
3951                     (PL_curstash ? "__ANON__" : "__ANON__::__ANON__")),
3952                     GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
3953                     SVt_PVCV);
3954
3955     if (o)
3956         SAVEFREEOP(o);
3957     if (proto)
3958         SAVEFREEOP(proto);
3959     if (attrs)
3960         SAVEFREEOP(attrs);
3961
3962     if (SvTYPE(gv) != SVt_PVGV) {       /* Maybe prototype now, and had at
3963                                            maximum a prototype before. */
3964         if (SvTYPE(gv) > SVt_NULL) {
3965             if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
3966                 && ckWARN_d(WARN_PROTOTYPE))
3967             {
3968                 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
3969             }
3970             cv_ckproto((CV*)gv, NULL, ps);
3971         }
3972         if (ps)
3973             sv_setpv((SV*)gv, ps);
3974         else
3975             sv_setiv((SV*)gv, -1);
3976         SvREFCNT_dec(PL_compcv);
3977         cv = PL_compcv = NULL;
3978         PL_sub_generation++;
3979         goto done;
3980     }
3981
3982     cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
3983
3984 #ifdef GV_UNIQUE_CHECK
3985     if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
3986         Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
3987     }
3988 #endif
3989
3990     if (!block || !ps || *ps || attrs)
3991         const_sv = Nullsv;
3992     else
3993         const_sv = op_const_sv(block, Nullcv);
3994
3995     if (cv) {
3996         bool exists = CvROOT(cv) || CvXSUB(cv);
3997
3998 #ifdef GV_UNIQUE_CHECK
3999         if (exists && GvUNIQUE(gv)) {
4000             Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
4001         }
4002 #endif
4003
4004         /* if the subroutine doesn't exist and wasn't pre-declared
4005          * with a prototype, assume it will be AUTOLOADed,
4006          * skipping the prototype check
4007          */
4008         if (exists || SvPOK(cv))
4009             cv_ckproto(cv, gv, ps);
4010         /* already defined (or promised)? */
4011         if (exists || GvASSUMECV(gv)) {
4012             if (!block && !attrs) {
4013                 if (CvFLAGS(PL_compcv)) {
4014                     /* might have had built-in attrs applied */
4015                     CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4016                 }
4017                 /* just a "sub foo;" when &foo is already defined */
4018                 SAVEFREESV(PL_compcv);
4019                 goto done;
4020             }
4021             /* ahem, death to those who redefine active sort subs */
4022             if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4023                 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4024             if (block) {
4025                 if (ckWARN(WARN_REDEFINE)
4026                     || (CvCONST(cv)
4027                         && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4028                 {
4029                     line_t oldline = CopLINE(PL_curcop);
4030                     if (PL_copline != NOLINE)
4031                         CopLINE_set(PL_curcop, PL_copline);
4032                     Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4033                         CvCONST(cv) ? "Constant subroutine %s redefined"
4034                                     : "Subroutine %s redefined", name);
4035                     CopLINE_set(PL_curcop, oldline);
4036                 }
4037                 SvREFCNT_dec(cv);
4038                 cv = Nullcv;
4039             }
4040         }
4041     }
4042     if (const_sv) {
4043         SvREFCNT_inc(const_sv);
4044         if (cv) {
4045             assert(!CvROOT(cv) && !CvCONST(cv));
4046             sv_setpv((SV*)cv, "");  /* prototype is "" */
4047             CvXSUBANY(cv).any_ptr = const_sv;
4048             CvXSUB(cv) = const_sv_xsub;
4049             CvCONST_on(cv);
4050         }
4051         else {
4052             GvCV(gv) = Nullcv;
4053             cv = newCONSTSUB(NULL, name, const_sv);
4054         }
4055         op_free(block);
4056         SvREFCNT_dec(PL_compcv);
4057         PL_compcv = NULL;
4058         PL_sub_generation++;
4059         goto done;
4060     }
4061     if (attrs) {
4062         HV *stash;
4063         SV *rcv;
4064
4065         /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4066          * before we clobber PL_compcv.
4067          */
4068         if (cv && !block) {
4069             rcv = (SV*)cv;
4070             /* Might have had built-in attributes applied -- propagate them. */
4071             CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4072             if (CvGV(cv) && GvSTASH(CvGV(cv)))
4073                 stash = GvSTASH(CvGV(cv));
4074             else if (CvSTASH(cv))
4075                 stash = CvSTASH(cv);
4076             else
4077                 stash = PL_curstash;
4078         }
4079         else {
4080             /* possibly about to re-define existing subr -- ignore old cv */
4081             rcv = (SV*)PL_compcv;
4082             if (name && GvSTASH(gv))
4083                 stash = GvSTASH(gv);
4084             else
4085                 stash = PL_curstash;
4086         }
4087         apply_attrs(stash, rcv, attrs, FALSE);
4088     }
4089     if (cv) {                           /* must reuse cv if autoloaded */
4090         if (!block) {
4091             /* got here with just attrs -- work done, so bug out */
4092             SAVEFREESV(PL_compcv);
4093             goto done;
4094         }
4095         /* transfer PL_compcv to cv */
4096         cv_undef(cv);
4097         CvFLAGS(cv) = CvFLAGS(PL_compcv);
4098         CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4099         CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
4100         CvOUTSIDE(PL_compcv) = 0;
4101         CvPADLIST(cv) = CvPADLIST(PL_compcv);
4102         CvPADLIST(PL_compcv) = 0;
4103         /* inner references to PL_compcv must be fixed up ... */
4104         pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
4105         /* ... before we throw it away */
4106         SvREFCNT_dec(PL_compcv);
4107         if (PERLDB_INTER)/* Advice debugger on the new sub. */
4108           ++PL_sub_generation;
4109     }
4110     else {
4111         cv = PL_compcv;
4112         if (name) {
4113             GvCV(gv) = cv;
4114             GvCVGEN(gv) = 0;
4115             PL_sub_generation++;
4116         }
4117     }
4118     CvGV(cv) = gv;
4119     CvFILE_set_from_cop(cv, PL_curcop);
4120     CvSTASH(cv) = PL_curstash;
4121
4122     if (ps)
4123         sv_setpv((SV*)cv, ps);
4124
4125     if (PL_error_count) {
4126         op_free(block);
4127         block = Nullop;
4128         if (name) {
4129             char *s = strrchr(name, ':');
4130             s = s ? s+1 : name;
4131             if (strEQ(s, "BEGIN")) {
4132                 char *not_safe =
4133                     "BEGIN not safe after errors--compilation aborted";
4134                 if (PL_in_eval & EVAL_KEEPERR)
4135                     Perl_croak(aTHX_ not_safe);
4136                 else {
4137                     /* force display of errors found but not reported */
4138                     sv_catpv(ERRSV, not_safe);
4139                     Perl_croak(aTHX_ "%s", SvPVx(ERRSV, n_a));
4140                 }
4141             }
4142         }
4143     }
4144     if (!block)
4145         goto done;
4146
4147     if (CvLVALUE(cv)) {
4148         CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4149                              mod(scalarseq(block), OP_LEAVESUBLV));
4150     }
4151     else {
4152         CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4153     }
4154     CvROOT(cv)->op_private |= OPpREFCOUNTED;
4155     OpREFCNT_set(CvROOT(cv), 1);
4156     CvSTART(cv) = LINKLIST(CvROOT(cv));
4157     CvROOT(cv)->op_next = 0;
4158     CALL_PEEP(CvSTART(cv));
4159
4160     /* now that optimizer has done its work, adjust pad values */
4161
4162     pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
4163
4164     if (CvCLONE(cv)) {
4165         assert(!CvCONST(cv));
4166         if (ps && !*ps && op_const_sv(block, cv))
4167             CvCONST_on(cv);
4168     }
4169
4170     if (name || aname) {
4171         char *s;
4172         char *tname = (name ? name : aname);
4173
4174         if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4175             SV *sv = NEWSV(0,0);
4176             SV *tmpstr = sv_newmortal();
4177             GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4178             CV *pcv;
4179             HV *hv;
4180
4181             Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4182                            CopFILE(PL_curcop),
4183                            (long)PL_subline, (long)CopLINE(PL_curcop));
4184             gv_efullname3(tmpstr, gv, Nullch);
4185             hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
4186             hv = GvHVn(db_postponed);
4187             if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
4188                 && (pcv = GvCV(db_postponed)))
4189             {
4190                 dSP;
4191                 PUSHMARK(SP);
4192                 XPUSHs(tmpstr);
4193                 PUTBACK;
4194                 call_sv((SV*)pcv, G_DISCARD);
4195             }
4196         }
4197
4198         if ((s = strrchr(tname,':')))
4199             s++;
4200         else
4201             s = tname;
4202
4203         if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4204             goto done;
4205
4206         if (strEQ(s, "BEGIN")) {
4207             I32 oldscope = PL_scopestack_ix;
4208             ENTER;
4209             SAVECOPFILE(&PL_compiling);
4210             SAVECOPLINE(&PL_compiling);
4211
4212             if (!PL_beginav)
4213                 PL_beginav = newAV();
4214             DEBUG_x( dump_sub(gv) );
4215             av_push(PL_beginav, (SV*)cv);
4216             GvCV(gv) = 0;               /* cv has been hijacked */
4217             call_list(oldscope, PL_beginav);
4218
4219             PL_curcop = &PL_compiling;
4220             PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4221             LEAVE;
4222         }
4223         else if (strEQ(s, "END") && !PL_error_count) {
4224             if (!PL_endav)
4225                 PL_endav = newAV();
4226             DEBUG_x( dump_sub(gv) );
4227             av_unshift(PL_endav, 1);
4228             av_store(PL_endav, 0, (SV*)cv);
4229             GvCV(gv) = 0;               /* cv has been hijacked */
4230         }
4231         else if (strEQ(s, "CHECK") && !PL_error_count) {
4232             if (!PL_checkav)
4233                 PL_checkav = newAV();
4234             DEBUG_x( dump_sub(gv) );
4235             if (PL_main_start && ckWARN(WARN_VOID))
4236                 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4237             av_unshift(PL_checkav, 1);
4238             av_store(PL_checkav, 0, (SV*)cv);
4239             GvCV(gv) = 0;               /* cv has been hijacked */
4240         }
4241         else if (strEQ(s, "INIT") && !PL_error_count) {
4242             if (!PL_initav)
4243                 PL_initav = newAV();
4244             DEBUG_x( dump_sub(gv) );
4245             if (PL_main_start && ckWARN(WARN_VOID))
4246                 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4247             av_push(PL_initav, (SV*)cv);
4248             GvCV(gv) = 0;               /* cv has been hijacked */
4249         }
4250     }
4251
4252   done:
4253     PL_copline = NOLINE;
4254     LEAVE_SCOPE(floor);
4255     return cv;
4256 }
4257
4258 /* XXX unsafe for threads if eval_owner isn't held */
4259 /*
4260 =for apidoc newCONSTSUB
4261
4262 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4263 eligible for inlining at compile-time.
4264
4265 =cut
4266 */
4267
4268 CV *
4269 Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
4270 {
4271     CV* cv;
4272
4273     ENTER;
4274
4275     SAVECOPLINE(PL_curcop);
4276     CopLINE_set(PL_curcop, PL_copline);
4277
4278     SAVEHINTS();
4279     PL_hints &= ~HINT_BLOCK_SCOPE;
4280
4281     if (stash) {
4282         SAVESPTR(PL_curstash);
4283         SAVECOPSTASH(PL_curcop);
4284         PL_curstash = stash;
4285         CopSTASH_set(PL_curcop,stash);
4286     }
4287
4288     cv = newXS(name, const_sv_xsub, __FILE__);
4289     CvXSUBANY(cv).any_ptr = sv;
4290     CvCONST_on(cv);
4291     sv_setpv((SV*)cv, "");  /* prototype is "" */
4292
4293     LEAVE;
4294
4295     return cv;
4296 }
4297
4298 /*
4299 =for apidoc U||newXS
4300
4301 Used by C<xsubpp> to hook up XSUBs as Perl subs.
4302
4303 =cut
4304 */
4305
4306 CV *
4307 Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
4308 {
4309     GV *gv = gv_fetchpv(name ? name :
4310                         (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4311                         GV_ADDMULTI, SVt_PVCV);
4312     register CV *cv;
4313
4314     if (!subaddr)
4315         Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
4316
4317     if ((cv = (name ? GvCV(gv) : Nullcv))) {
4318         if (GvCVGEN(gv)) {
4319             /* just a cached method */
4320             SvREFCNT_dec(cv);
4321             cv = 0;
4322         }
4323         else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4324             /* already defined (or promised) */
4325             if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
4326                             && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
4327                 line_t oldline = CopLINE(PL_curcop);
4328                 if (PL_copline != NOLINE)
4329                     CopLINE_set(PL_curcop, PL_copline);
4330                 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4331                             CvCONST(cv) ? "Constant subroutine %s redefined"
4332                                         : "Subroutine %s redefined"
4333                             ,name);
4334                 CopLINE_set(PL_curcop, oldline);
4335             }
4336             SvREFCNT_dec(cv);
4337             cv = 0;
4338         }
4339     }
4340
4341     if (cv)                             /* must reuse cv if autoloaded */
4342         cv_undef(cv);
4343     else {
4344         cv = (CV*)NEWSV(1105,0);
4345         sv_upgrade((SV *)cv, SVt_PVCV);
4346         if (name) {
4347             GvCV(gv) = cv;
4348             GvCVGEN(gv) = 0;
4349             PL_sub_generation++;
4350         }
4351     }
4352     CvGV(cv) = gv;
4353     (void)gv_fetchfile(filename);
4354     CvFILE(cv) = filename;      /* NOTE: not copied, as it is expected to be
4355                                    an external constant string */
4356     CvXSUB(cv) = subaddr;
4357
4358     if (name) {
4359         char *s = strrchr(name,':');
4360         if (s)
4361             s++;
4362         else
4363             s = name;
4364
4365         if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4366             goto done;
4367
4368         if (strEQ(s, "BEGIN")) {
4369             if (!PL_beginav)
4370                 PL_beginav = newAV();
4371             av_push(PL_beginav, (SV*)cv);
4372             GvCV(gv) = 0;               /* cv has been hijacked */
4373         }
4374         else if (strEQ(s, "END")) {
4375             if (!PL_endav)
4376                 PL_endav = newAV();
4377             av_unshift(PL_endav, 1);
4378             av_store(PL_endav, 0, (SV*)cv);
4379             GvCV(gv) = 0;               /* cv has been hijacked */
4380         }
4381         else if (strEQ(s, "CHECK")) {
4382             if (!PL_checkav)
4383                 PL_checkav = newAV();
4384             if (PL_main_start && ckWARN(WARN_VOID))
4385                 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4386             av_unshift(PL_checkav, 1);
4387             av_store(PL_checkav, 0, (SV*)cv);
4388             GvCV(gv) = 0;               /* cv has been hijacked */
4389         }
4390         else if (strEQ(s, "INIT")) {
4391             if (!PL_initav)
4392                 PL_initav = newAV();
4393             if (PL_main_start && ckWARN(WARN_VOID))
4394                 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4395             av_push(PL_initav, (SV*)cv);
4396             GvCV(gv) = 0;               /* cv has been hijacked */
4397         }
4398     }
4399     else
4400         CvANON_on(cv);
4401
4402 done:
4403     return cv;
4404 }
4405
4406 void
4407 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
4408 {
4409     register CV *cv;
4410     char *name;
4411     GV *gv;
4412     STRLEN n_a;
4413
4414     if (o)
4415         name = SvPVx(cSVOPo->op_sv, n_a);
4416     else
4417         name = "STDOUT";
4418     gv = gv_fetchpv(name,TRUE, SVt_PVFM);
4419 #ifdef GV_UNIQUE_CHECK
4420     if (GvUNIQUE(gv)) {
4421         Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
4422     }
4423 #endif
4424     GvMULTI_on(gv);
4425     if ((cv = GvFORM(gv))) {
4426         if (ckWARN(WARN_REDEFINE)) {
4427             line_t oldline = CopLINE(PL_curcop);
4428             if (PL_copline != NOLINE)
4429                 CopLINE_set(PL_curcop, PL_copline);
4430             Perl_warner(aTHX_ packWARN(WARN_REDEFINE), "Format %s redefined",name);
4431             CopLINE_set(PL_curcop, oldline);
4432         }
4433         SvREFCNT_dec(cv);
4434     }
4435     cv = PL_compcv;
4436     GvFORM(gv) = cv;
4437     CvGV(cv) = gv;
4438     CvFILE_set_from_cop(cv, PL_curcop);
4439
4440
4441     pad_tidy(padtidy_FORMAT);
4442     CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
4443     CvROOT(cv)->op_private |= OPpREFCOUNTED;
4444     OpREFCNT_set(CvROOT(cv), 1);
4445     CvSTART(cv) = LINKLIST(CvROOT(cv));
4446     CvROOT(cv)->op_next = 0;
4447     CALL_PEEP(CvSTART(cv));
4448     op_free(o);
4449     PL_copline = NOLINE;
4450     LEAVE_SCOPE(floor);
4451 }
4452
4453 OP *
4454 Perl_newANONLIST(pTHX_ OP *o)
4455 {
4456     return newUNOP(OP_REFGEN, 0,
4457         mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
4458 }
4459
4460 OP *
4461 Perl_newANONHASH(pTHX_ OP *o)
4462 {
4463     return newUNOP(OP_REFGEN, 0,
4464         mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
4465 }
4466
4467 OP *
4468 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
4469 {
4470     return newANONATTRSUB(floor, proto, Nullop, block);
4471 }
4472
4473 OP *
4474 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
4475 {
4476     return newUNOP(OP_REFGEN, 0,
4477         newSVOP(OP_ANONCODE, 0,
4478                 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
4479 }
4480
4481 OP *
4482 Perl_oopsAV(pTHX_ OP *o)
4483 {
4484     switch (o->op_type) {
4485     case OP_PADSV:
4486         o->op_type = OP_PADAV;
4487         o->op_ppaddr = PL_ppaddr[OP_PADAV];
4488         return ref(o, OP_RV2AV);
4489
4490     case OP_RV2SV:
4491         o->op_type = OP_RV2AV;
4492         o->op_ppaddr = PL_ppaddr[OP_RV2AV];
4493         ref(o, OP_RV2AV);
4494         break;
4495
4496     default:
4497         if (ckWARN_d(WARN_INTERNAL))
4498             Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
4499         break;
4500     }
4501     return o;
4502 }
4503
4504 OP *
4505 Perl_oopsHV(pTHX_ OP *o)
4506 {
4507     switch (o->op_type) {
4508     case OP_PADSV:
4509     case OP_PADAV:
4510         o->op_type = OP_PADHV;
4511         o->op_ppaddr = PL_ppaddr[OP_PADHV];
4512         return ref(o, OP_RV2HV);
4513
4514     case OP_RV2SV:
4515     case OP_RV2AV:
4516         o->op_type = OP_RV2HV;
4517         o->op_ppaddr = PL_ppaddr[OP_RV2HV];
4518         ref(o, OP_RV2HV);
4519         break;
4520
4521     default:
4522         if (ckWARN_d(WARN_INTERNAL))
4523             Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
4524         break;
4525     }
4526     return o;
4527 }
4528
4529 OP *
4530 Perl_newAVREF(pTHX_ OP *o)
4531 {
4532     if (o->op_type == OP_PADANY) {
4533         o->op_type = OP_PADAV;
4534         o->op_ppaddr = PL_ppaddr[OP_PADAV];
4535         return o;
4536     }
4537     else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
4538                 && ckWARN(WARN_DEPRECATED)) {
4539         Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4540                 "Using an array as a reference is deprecated");
4541     }
4542     return newUNOP(OP_RV2AV, 0, scalar(o));
4543 }
4544
4545 OP *
4546 Perl_newGVREF(pTHX_ I32 type, OP *o)
4547 {
4548     if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
4549         return newUNOP(OP_NULL, 0, o);
4550     return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
4551 }
4552
4553 OP *
4554 Perl_newHVREF(pTHX_ OP *o)
4555 {
4556     if (o->op_type == OP_PADANY) {
4557         o->op_type = OP_PADHV;
4558         o->op_ppaddr = PL_ppaddr[OP_PADHV];
4559         return o;
4560     }
4561     else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
4562                 && ckWARN(WARN_DEPRECATED)) {
4563         Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4564                 "Using a hash as a reference is deprecated");
4565     }
4566     return newUNOP(OP_RV2HV, 0, scalar(o));
4567 }
4568
4569 OP *
4570 Perl_oopsCV(pTHX_ OP *o)
4571 {
4572     Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
4573     /* STUB */
4574     return o;
4575 }
4576
4577 OP *
4578 Perl_newCVREF(pTHX_ I32 flags, OP *o)
4579 {
4580     return newUNOP(OP_RV2CV, flags, scalar(o));
4581 }
4582
4583 OP *
4584 Perl_newSVREF(pTHX_ OP *o)
4585 {
4586     if (o->op_type == OP_PADANY) {
4587         o->op_type = OP_PADSV;
4588         o->op_ppaddr = PL_ppaddr[OP_PADSV];
4589         return o;
4590     }
4591     else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
4592         o->op_flags |= OPpDONE_SVREF;
4593         return o;
4594     }
4595     return newUNOP(OP_RV2SV, 0, scalar(o));
4596 }
4597
4598 /* Check routines. */
4599
4600 OP *
4601 Perl_ck_anoncode(pTHX_ OP *o)
4602 {
4603     cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
4604     cSVOPo->op_sv = Nullsv;
4605     return o;
4606 }
4607
4608 OP *
4609 Perl_ck_bitop(pTHX_ OP *o)
4610 {
4611 #define OP_IS_NUMCOMPARE(op) \
4612         ((op) == OP_LT   || (op) == OP_I_LT || \
4613          (op) == OP_GT   || (op) == OP_I_GT || \
4614          (op) == OP_LE   || (op) == OP_I_LE || \
4615          (op) == OP_GE   || (op) == OP_I_GE || \
4616          (op) == OP_EQ   || (op) == OP_I_EQ || \
4617          (op) == OP_NE   || (op) == OP_I_NE || \
4618          (op) == OP_NCMP || (op) == OP_I_NCMP)
4619     o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4620     if (o->op_type == OP_BIT_OR
4621             || o->op_type == OP_BIT_AND
4622             || o->op_type == OP_BIT_XOR)
4623     {
4624         OPCODE typfirst = cBINOPo->op_first->op_type;
4625         OPCODE typlast  = cBINOPo->op_first->op_sibling->op_type;
4626         if (OP_IS_NUMCOMPARE(typfirst) || OP_IS_NUMCOMPARE(typlast))
4627             if (ckWARN(WARN_PRECEDENCE))
4628                 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
4629                         "Possible precedence problem on bitwise %c operator",
4630                         o->op_type == OP_BIT_OR ? '|'
4631                             : o->op_type == OP_BIT_AND ? '&' : '^'
4632                         );
4633     }
4634     return o;
4635 }
4636
4637 OP *
4638 Perl_ck_concat(pTHX_ OP *o)
4639 {
4640     if (cUNOPo->op_first->op_type == OP_CONCAT)
4641         o->op_flags |= OPf_STACKED;
4642     return o;
4643 }
4644
4645 OP *
4646 Perl_ck_spair(pTHX_ OP *o)
4647 {
4648     if (o->op_flags & OPf_KIDS) {
4649         OP* newop;
4650         OP* kid;
4651         OPCODE type = o->op_type;
4652         o = modkids(ck_fun(o), type);
4653         kid = cUNOPo->op_first;
4654         newop = kUNOP->op_first->op_sibling;
4655         if (newop &&
4656             (newop->op_sibling ||
4657              !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
4658              newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
4659              newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
4660
4661             return o;
4662         }
4663         op_free(kUNOP->op_first);
4664         kUNOP->op_first = newop;
4665     }
4666     o->op_ppaddr = PL_ppaddr[++o->op_type];
4667     return ck_fun(o);
4668 }
4669
4670 OP *
4671 Perl_ck_delete(pTHX_ OP *o)
4672 {
4673     o = ck_fun(o);
4674     o->op_private = 0;
4675     if (o->op_flags & OPf_KIDS) {
4676         OP *kid = cUNOPo->op_first;
4677         switch (kid->op_type) {
4678         case OP_ASLICE:
4679             o->op_flags |= OPf_SPECIAL;
4680             /* FALL THROUGH */
4681         case OP_HSLICE:
4682             o->op_private |= OPpSLICE;
4683             break;
4684         case OP_AELEM:
4685             o->op_flags |= OPf_SPECIAL;
4686             /* FALL THROUGH */
4687         case OP_HELEM:
4688             break;
4689         default:
4690             Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
4691                   OP_DESC(o));
4692         }
4693         op_null(kid);
4694     }
4695     return o;
4696 }
4697
4698 OP *
4699 Perl_ck_die(pTHX_ OP *o)
4700 {
4701 #ifdef VMS
4702     if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
4703 #endif
4704     return ck_fun(o);
4705 }
4706
4707 OP *
4708 Perl_ck_eof(pTHX_ OP *o)
4709 {
4710     I32 type = o->op_type;
4711
4712     if (o->op_flags & OPf_KIDS) {
4713         if (cLISTOPo->op_first->op_type == OP_STUB) {
4714             op_free(o);
4715             o = newUNOP(type, OPf_SPECIAL,
4716                 newGVOP(OP_GV, 0, gv_fetchpv("main::ARGV", TRUE, SVt_PVAV)));
4717         }
4718         return ck_fun(o);
4719     }
4720     return o;
4721 }
4722
4723 OP *
4724 Perl_ck_eval(pTHX_ OP *o)
4725 {
4726     PL_hints |= HINT_BLOCK_SCOPE;
4727     if (o->op_flags & OPf_KIDS) {
4728         SVOP *kid = (SVOP*)cUNOPo->op_first;
4729
4730         if (!kid) {
4731             o->op_flags &= ~OPf_KIDS;
4732             op_null(o);
4733         }
4734         else if (kid->op_type == OP_LINESEQ) {
4735             LOGOP *enter;
4736
4737             kid->op_next = o->op_next;
4738             cUNOPo->op_first = 0;
4739             op_free(o);
4740
4741             NewOp(1101, enter, 1, LOGOP);
4742             enter->op_type = OP_ENTERTRY;
4743             enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
4744             enter->op_private = 0;
4745
4746             /* establish postfix order */
4747             enter->op_next = (OP*)enter;
4748
4749             o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
4750             o->op_type = OP_LEAVETRY;
4751             o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
4752             enter->op_other = o;
4753             return o;
4754         }
4755         else
4756             scalar((OP*)kid);
4757     }
4758     else {
4759         op_free(o);
4760         o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
4761     }
4762     o->op_targ = (PADOFFSET)PL_hints;
4763     return o;
4764 }
4765
4766 OP *
4767 Perl_ck_exit(pTHX_ OP *o)
4768 {
4769 #ifdef VMS
4770     HV *table = GvHV(PL_hintgv);
4771     if (table) {
4772        SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
4773        if (svp && *svp && SvTRUE(*svp))
4774            o->op_private |= OPpEXIT_VMSISH;
4775     }
4776     if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
4777 #endif
4778     return ck_fun(o);
4779 }
4780
4781 OP *
4782 Perl_ck_exec(pTHX_ OP *o)
4783 {
4784     OP *kid;
4785     if (o->op_flags & OPf_STACKED) {
4786         o = ck_fun(o);
4787         kid = cUNOPo->op_first->op_sibling;
4788         if (kid->op_type == OP_RV2GV)
4789             op_null(kid);
4790     }
4791     else
4792         o = listkids(o);
4793     return o;
4794 }
4795
4796 OP *
4797 Perl_ck_exists(pTHX_ OP *o)
4798 {
4799     o = ck_fun(o);
4800     if (o->op_flags & OPf_KIDS) {
4801         OP *kid = cUNOPo->op_first;
4802         if (kid->op_type == OP_ENTERSUB) {
4803             (void) ref(kid, o->op_type);
4804             if (kid->op_type != OP_RV2CV && !PL_error_count)
4805                 Perl_croak(aTHX_ "%s argument is not a subroutine name",
4806                             OP_DESC(o));
4807             o->op_private |= OPpEXISTS_SUB;
4808         }
4809         else if (kid->op_type == OP_AELEM)
4810             o->op_flags |= OPf_SPECIAL;
4811         else if (kid->op_type != OP_HELEM)
4812             Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
4813                         OP_DESC(o));
4814         op_null(kid);
4815     }
4816     return o;
4817 }
4818
4819 #if 0
4820 OP *
4821 Perl_ck_gvconst(pTHX_ register OP *o)
4822 {
4823     o = fold_constants(o);
4824     if (o->op_type == OP_CONST)
4825         o->op_type = OP_GV;
4826     return o;
4827 }
4828 #endif
4829
4830 OP *
4831 Perl_ck_rvconst(pTHX_ register OP *o)
4832 {
4833     SVOP *kid = (SVOP*)cUNOPo->op_first;
4834
4835     o->op_private |= (PL_hints & HINT_STRICT_REFS);
4836     if (kid->op_type == OP_CONST) {
4837         char *name;
4838         int iscv;
4839         GV *gv;
4840         SV *kidsv = kid->op_sv;
4841         STRLEN n_a;
4842
4843         /* Is it a constant from cv_const_sv()? */
4844         if (SvROK(kidsv) && SvREADONLY(kidsv)) {
4845             SV *rsv = SvRV(kidsv);
4846             int svtype = SvTYPE(rsv);
4847             char *badtype = Nullch;
4848
4849             switch (o->op_type) {
4850             case OP_RV2SV:
4851                 if (svtype > SVt_PVMG)
4852                     badtype = "a SCALAR";
4853                 break;
4854             case OP_RV2AV:
4855                 if (svtype != SVt_PVAV)
4856                     badtype = "an ARRAY";
4857                 break;
4858             case OP_RV2HV:
4859                 if (svtype != SVt_PVHV)
4860                     badtype = "a HASH";
4861                 break;
4862             case OP_RV2CV:
4863                 if (svtype != SVt_PVCV)
4864                     badtype = "a CODE";
4865                 break;
4866             }
4867             if (badtype)
4868                 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
4869             return o;
4870         }
4871         name = SvPV(kidsv, n_a);
4872         if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
4873             char *badthing = Nullch;
4874             switch (o->op_type) {
4875             case OP_RV2SV:
4876                 badthing = "a SCALAR";
4877                 break;
4878             case OP_RV2AV:
4879                 badthing = "an ARRAY";
4880                 break;
4881             case OP_RV2HV:
4882                 badthing = "a HASH";
4883                 break;
4884             }
4885             if (badthing)
4886                 Perl_croak(aTHX_
4887           "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
4888                       name, badthing);
4889         }
4890         /*
4891          * This is a little tricky.  We only want to add the symbol if we
4892          * didn't add it in the lexer.  Otherwise we get duplicate strict
4893          * warnings.  But if we didn't add it in the lexer, we must at
4894          * least pretend like we wanted to add it even if it existed before,
4895          * or we get possible typo warnings.  OPpCONST_ENTERED says
4896          * whether the lexer already added THIS instance of this symbol.
4897          */
4898         iscv = (o->op_type == OP_RV2CV) * 2;
4899         do {
4900             gv = gv_fetchpv(name,
4901                 iscv | !(kid->op_private & OPpCONST_ENTERED),
4902                 iscv
4903                     ? SVt_PVCV
4904                     : o->op_type == OP_RV2SV
4905                         ? SVt_PV
4906                         : o->op_type == OP_RV2AV
4907                             ? SVt_PVAV
4908                             : o->op_type == OP_RV2HV
4909                                 ? SVt_PVHV
4910                                 : SVt_PVGV);
4911         } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
4912         if (gv) {
4913             kid->op_type = OP_GV;
4914             SvREFCNT_dec(kid->op_sv);
4915 #ifdef USE_ITHREADS
4916             /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
4917             kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
4918             SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
4919             GvIN_PAD_on(gv);
4920             PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc(gv));
4921 #else
4922             kid->op_sv = SvREFCNT_inc(gv);
4923 #endif
4924             kid->op_private = 0;
4925             kid->op_ppaddr = PL_ppaddr[OP_GV];
4926         }
4927     }
4928     return o;
4929 }
4930
4931 OP *
4932 Perl_ck_ftst(pTHX_ OP *o)
4933 {
4934     I32 type = o->op_type;
4935
4936     if (o->op_flags & OPf_REF) {
4937         /* nothing */
4938     }
4939     else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
4940         SVOP *kid = (SVOP*)cUNOPo->op_first;
4941
4942         if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
4943             STRLEN n_a;
4944             OP *newop = newGVOP(type, OPf_REF,
4945                 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
4946             op_free(o);
4947             o = newop;
4948         }
4949     }
4950     else {
4951         op_free(o);
4952         if (type == OP_FTTTY)
4953            o =  newGVOP(type, OPf_REF, gv_fetchpv("main::STDIN", TRUE,
4954                                 SVt_PVIO));
4955         else
4956             o = newUNOP(type, 0, newDEFSVOP());
4957     }
4958     return o;
4959 }
4960
4961 OP *
4962 Perl_ck_fun(pTHX_ OP *o)
4963 {
4964     register OP *kid;
4965     OP **tokid;
4966     OP *sibl;
4967     I32 numargs = 0;
4968     int type = o->op_type;
4969     register I32 oa = PL_opargs[type] >> OASHIFT;
4970
4971     if (o->op_flags & OPf_STACKED) {
4972         if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
4973             oa &= ~OA_OPTIONAL;
4974         else
4975             return no_fh_allowed(o);
4976     }
4977
4978     if (o->op_flags & OPf_KIDS) {
4979         STRLEN n_a;
4980         tokid = &cLISTOPo->op_first;
4981         kid = cLISTOPo->op_first;
4982         if (kid->op_type == OP_PUSHMARK ||
4983             (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
4984         {
4985             tokid = &kid->op_sibling;
4986             kid = kid->op_sibling;
4987         }
4988         if (!kid && PL_opargs[type] & OA_DEFGV)
4989             *tokid = kid = newDEFSVOP();
4990
4991         while (oa && kid) {
4992             numargs++;
4993             sibl = kid->op_sibling;
4994             switch (oa & 7) {
4995             case OA_SCALAR:
4996                 /* list seen where single (scalar) arg expected? */
4997                 if (numargs == 1 && !(oa >> 4)
4998                     && kid->op_type == OP_LIST && type != OP_SCALAR)
4999                 {
5000                     return too_many_arguments(o,PL_op_desc[type]);
5001                 }
5002                 scalar(kid);
5003                 break;
5004             case OA_LIST:
5005                 if (oa < 16) {
5006                     kid = 0;
5007                     continue;
5008                 }
5009                 else
5010                     list(kid);
5011                 break;
5012             case OA_AVREF:
5013                 if ((type == OP_PUSH || type == OP_UNSHIFT)
5014                     && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5015                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5016                         "Useless use of %s with no values",
5017                         PL_op_desc[type]);
5018
5019                 if (kid->op_type == OP_CONST &&
5020                     (kid->op_private & OPpCONST_BARE))
5021                 {
5022                     char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5023                     OP *newop = newAVREF(newGVOP(OP_GV, 0,
5024                         gv_fetchpv(name, TRUE, SVt_PVAV) ));
5025                     if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5026                         Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5027                             "Array @%s missing the @ in argument %"IVdf" of %s()",
5028                             name, (IV)numargs, PL_op_desc[type]);
5029                     op_free(kid);
5030                     kid = newop;
5031                     kid->op_sibling = sibl;
5032                     *tokid = kid;
5033                 }
5034                 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5035                     bad_type(numargs, "array", PL_op_desc[type], kid);
5036                 mod(kid, type);
5037                 break;
5038             case OA_HVREF:
5039                 if (kid->op_type == OP_CONST &&
5040                     (kid->op_private & OPpCONST_BARE))
5041                 {
5042                     char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5043                     OP *newop = newHVREF(newGVOP(OP_GV, 0,
5044                         gv_fetchpv(name, TRUE, SVt_PVHV) ));
5045                     if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5046                         Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5047                             "Hash %%%s missing the %% in argument %"IVdf" of %s()",
5048                             name, (IV)numargs, PL_op_desc[type]);
5049                     op_free(kid);
5050                     kid = newop;
5051                     kid->op_sibling = sibl;
5052                     *tokid = kid;
5053                 }
5054                 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5055                     bad_type(numargs, "hash", PL_op_desc[type], kid);
5056                 mod(kid, type);
5057                 break;
5058             case OA_CVREF:
5059                 {
5060                     OP *newop = newUNOP(OP_NULL, 0, kid);
5061                     kid->op_sibling = 0;
5062                     linklist(kid);
5063                     newop->op_next = newop;
5064                     kid = newop;
5065                     kid->op_sibling = sibl;
5066                     *tokid = kid;
5067                 }
5068                 break;
5069             case OA_FILEREF:
5070                 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5071                     if (kid->op_type == OP_CONST &&
5072                         (kid->op_private & OPpCONST_BARE))
5073                     {
5074                         OP *newop = newGVOP(OP_GV, 0,
5075                             gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
5076                                         SVt_PVIO) );
5077                         if (!(o->op_private & 1) && /* if not unop */
5078                             kid == cLISTOPo->op_last)
5079                             cLISTOPo->op_last = newop;
5080                         op_free(kid);
5081                         kid = newop;
5082                     }
5083                     else if (kid->op_type == OP_READLINE) {
5084                         /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5085                         bad_type(numargs, "HANDLE", OP_DESC(o), kid);
5086                     }
5087                     else {
5088                         I32 flags = OPf_SPECIAL;
5089                         I32 priv = 0;
5090                         PADOFFSET targ = 0;
5091
5092                         /* is this op a FH constructor? */
5093                         if (is_handle_constructor(o,numargs)) {
5094                             char *name = Nullch;
5095                             STRLEN len = 0;
5096
5097                             flags = 0;
5098                             /* Set a flag to tell rv2gv to vivify
5099                              * need to "prove" flag does not mean something
5100                              * else already - NI-S 1999/05/07
5101                              */
5102                             priv = OPpDEREF;
5103                             if (kid->op_type == OP_PADSV) {
5104                                 /*XXX DAPM 2002.08.25 tmp assert test */
5105                                 /*XXX*/ assert(av_fetch(PL_comppad_name, (kid->op_targ), FALSE));
5106                                 /*XXX*/ assert(*av_fetch(PL_comppad_name, (kid->op_targ), FALSE));
5107
5108                                 name = PAD_COMPNAME_PV(kid->op_targ);
5109                                 /* SvCUR of a pad namesv can't be trusted
5110                                  * (see PL_generation), so calc its length
5111                                  * manually */
5112                                 if (name)
5113                                     len = strlen(name);
5114
5115                             }
5116                             else if (kid->op_type == OP_RV2SV
5117                                      && kUNOP->op_first->op_type == OP_GV)
5118                             {
5119                                 GV *gv = cGVOPx_gv(kUNOP->op_first);
5120                                 name = GvNAME(gv);
5121                                 len = GvNAMELEN(gv);
5122                             }
5123                             else if (kid->op_type == OP_AELEM
5124                                      || kid->op_type == OP_HELEM)
5125                             {
5126                                 name = "__ANONIO__";
5127                                 len = 10;
5128                                 mod(kid,type);
5129                             }
5130                             if (name) {
5131                                 SV *namesv;
5132                                 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5133                                 namesv = PAD_SVl(targ);
5134                                 (void)SvUPGRADE(namesv, SVt_PV);
5135                                 if (*name != '$')
5136                                     sv_setpvn(namesv, "$", 1);
5137                                 sv_catpvn(namesv, name, len);
5138                             }
5139                         }
5140                         kid->op_sibling = 0;
5141                         kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5142                         kid->op_targ = targ;
5143                         kid->op_private |= priv;
5144                     }
5145                     kid->op_sibling = sibl;
5146                     *tokid = kid;
5147                 }
5148                 scalar(kid);
5149                 break;
5150             case OA_SCALARREF:
5151                 mod(scalar(kid), type);
5152                 break;
5153             }
5154             oa >>= 4;
5155             tokid = &kid->op_sibling;
5156             kid = kid->op_sibling;
5157         }
5158         o->op_private |= numargs;
5159         if (kid)
5160             return too_many_arguments(o,OP_DESC(o));
5161         listkids(o);
5162     }
5163     else if (PL_opargs[type] & OA_DEFGV) {
5164         op_free(o);
5165         return newUNOP(type, 0, newDEFSVOP());
5166     }
5167
5168     if (oa) {
5169         while (oa & OA_OPTIONAL)
5170             oa >>= 4;
5171         if (oa && oa != OA_LIST)
5172             return too_few_arguments(o,OP_DESC(o));
5173     }
5174     return o;
5175 }
5176
5177 OP *
5178 Perl_ck_glob(pTHX_ OP *o)
5179 {
5180     GV *gv;
5181
5182     o = ck_fun(o);
5183     if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5184         append_elem(OP_GLOB, o, newDEFSVOP());
5185
5186     if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV))
5187           && GvCVu(gv) && GvIMPORTED_CV(gv)))
5188     {
5189         gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5190     }
5191
5192 #if !defined(PERL_EXTERNAL_GLOB)
5193     /* XXX this can be tightened up and made more failsafe. */
5194     if (!gv) {
5195         GV *glob_gv;
5196         ENTER;
5197         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
5198                 newSVpvn("File::Glob", 10), Nullsv, Nullsv, Nullsv);
5199         gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5200         glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
5201         GvCV(gv) = GvCV(glob_gv);
5202         SvREFCNT_inc((SV*)GvCV(gv));
5203         GvIMPORTED_CV_on(gv);
5204         LEAVE;
5205     }
5206 #endif /* PERL_EXTERNAL_GLOB */
5207
5208     if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5209         append_elem(OP_GLOB, o,
5210                     newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5211         o->op_type = OP_LIST;
5212         o->op_ppaddr = PL_ppaddr[OP_LIST];
5213         cLISTOPo->op_first->op_type = OP_PUSHMARK;
5214         cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5215         o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5216                     append_elem(OP_LIST, o,
5217                                 scalar(newUNOP(OP_RV2CV, 0,
5218                                                newGVOP(OP_GV, 0, gv)))));
5219         o = newUNOP(OP_NULL, 0, ck_subr(o));
5220         o->op_targ = OP_GLOB;           /* hint at what it used to be */
5221         return o;
5222     }
5223     gv = newGVgen("main");
5224     gv_IOadd(gv);
5225     append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5226     scalarkids(o);
5227     return o;
5228 }
5229
5230 OP *
5231 Perl_ck_grep(pTHX_ OP *o)
5232 {
5233     LOGOP *gwop;
5234     OP *kid;
5235     OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5236
5237     o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5238     NewOp(1101, gwop, 1, LOGOP);
5239
5240     if (o->op_flags & OPf_STACKED) {
5241         OP* k;
5242         o = ck_sort(o);
5243         kid = cLISTOPo->op_first->op_sibling;
5244         for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
5245             kid = k;
5246         }
5247         kid->op_next = (OP*)gwop;
5248         o->op_flags &= ~OPf_STACKED;
5249     }
5250     kid = cLISTOPo->op_first->op_sibling;
5251     if (type == OP_MAPWHILE)
5252         list(kid);
5253     else
5254         scalar(kid);
5255     o = ck_fun(o);
5256     if (PL_error_count)
5257         return o;
5258     kid = cLISTOPo->op_first->op_sibling;
5259     if (kid->op_type != OP_NULL)
5260         Perl_croak(aTHX_ "panic: ck_grep");
5261     kid = kUNOP->op_first;
5262
5263     gwop->op_type = type;
5264     gwop->op_ppaddr = PL_ppaddr[type];
5265     gwop->op_first = listkids(o);
5266     gwop->op_flags |= OPf_KIDS;
5267     gwop->op_private = 1;
5268     gwop->op_other = LINKLIST(kid);
5269     gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5270     kid->op_next = (OP*)gwop;
5271
5272     kid = cLISTOPo->op_first->op_sibling;
5273     if (!kid || !kid->op_sibling)
5274         return too_few_arguments(o,OP_DESC(o));
5275     for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5276         mod(kid, OP_GREPSTART);
5277
5278     return (OP*)gwop;
5279 }
5280
5281 OP *
5282 Perl_ck_index(pTHX_ OP *o)
5283 {
5284     if (o->op_flags & OPf_KIDS) {
5285         OP *kid = cLISTOPo->op_first->op_sibling;       /* get past pushmark */
5286         if (kid)
5287             kid = kid->op_sibling;                      /* get past "big" */
5288         if (kid && kid->op_type == OP_CONST)
5289             fbm_compile(((SVOP*)kid)->op_sv, 0);
5290     }
5291     return ck_fun(o);
5292 }
5293
5294 OP *
5295 Perl_ck_lengthconst(pTHX_ OP *o)
5296 {
5297     /* XXX length optimization goes here */
5298     return ck_fun(o);
5299 }
5300
5301 OP *
5302 Perl_ck_lfun(pTHX_ OP *o)
5303 {
5304     OPCODE type = o->op_type;
5305     return modkids(ck_fun(o), type);
5306 }
5307
5308 OP *
5309 Perl_ck_defined(pTHX_ OP *o)            /* 19990527 MJD */
5310 {
5311     if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
5312         switch (cUNOPo->op_first->op_type) {
5313         case OP_RV2AV:
5314             /* This is needed for
5315                if (defined %stash::)
5316                to work.   Do not break Tk.
5317                */
5318             break;                      /* Globals via GV can be undef */
5319         case OP_PADAV:
5320         case OP_AASSIGN:                /* Is this a good idea? */
5321             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5322                         "defined(@array) is deprecated");
5323             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5324                         "\t(Maybe you should just omit the defined()?)\n");
5325         break;
5326         case OP_RV2HV:
5327             /* This is needed for
5328                if (defined %stash::)
5329                to work.   Do not break Tk.
5330                */
5331             break;                      /* Globals via GV can be undef */
5332         case OP_PADHV:
5333             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5334                         "defined(%%hash) is deprecated");
5335             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5336                         "\t(Maybe you should just omit the defined()?)\n");
5337             break;
5338         default:
5339             /* no warning */
5340             break;
5341         }
5342     }
5343     return ck_rfun(o);
5344 }
5345
5346 OP *
5347 Perl_ck_rfun(pTHX_ OP *o)
5348 {
5349     OPCODE type = o->op_type;
5350     return refkids(ck_fun(o), type);
5351 }
5352
5353 OP *
5354 Perl_ck_listiob(pTHX_ OP *o)
5355 {
5356     register OP *kid;
5357
5358     kid = cLISTOPo->op_first;
5359     if (!kid) {
5360         o = force_list(o);
5361         kid = cLISTOPo->op_first;
5362     }
5363     if (kid->op_type == OP_PUSHMARK)
5364         kid = kid->op_sibling;
5365     if (kid && o->op_flags & OPf_STACKED)
5366         kid = kid->op_sibling;
5367     else if (kid && !kid->op_sibling) {         /* print HANDLE; */
5368         if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
5369             o->op_flags |= OPf_STACKED; /* make it a filehandle */
5370             kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
5371             cLISTOPo->op_first->op_sibling = kid;
5372             cLISTOPo->op_last = kid;
5373             kid = kid->op_sibling;
5374         }
5375     }
5376
5377     if (!kid)
5378         append_elem(o->op_type, o, newDEFSVOP());
5379
5380     return listkids(o);
5381 }
5382
5383 OP *
5384 Perl_ck_sassign(pTHX_ OP *o)
5385 {
5386     OP *kid = cLISTOPo->op_first;
5387     /* has a disposable target? */
5388     if ((PL_opargs[kid->op_type] & OA_TARGLEX)
5389         && !(kid->op_flags & OPf_STACKED)
5390         /* Cannot steal the second time! */
5391         && !(kid->op_private & OPpTARGET_MY))
5392     {
5393         OP *kkid = kid->op_sibling;
5394
5395         /* Can just relocate the target. */
5396         if (kkid && kkid->op_type == OP_PADSV
5397             && !(kkid->op_private & OPpLVAL_INTRO))
5398         {
5399             kid->op_targ = kkid->op_targ;
5400             kkid->op_targ = 0;
5401             /* Now we do not need PADSV and SASSIGN. */
5402             kid->op_sibling = o->op_sibling;    /* NULL */
5403             cLISTOPo->op_first = NULL;
5404             op_free(o);
5405             op_free(kkid);
5406             kid->op_private |= OPpTARGET_MY;    /* Used for context settings */
5407             return kid;
5408         }
5409     }
5410     return o;
5411 }
5412
5413 OP *
5414 Perl_ck_match(pTHX_ OP *o)
5415 {
5416     o->op_private |= OPpRUNTIME;
5417     return o;
5418 }
5419
5420 OP *
5421 Perl_ck_method(pTHX_ OP *o)
5422 {
5423     OP *kid = cUNOPo->op_first;
5424     if (kid->op_type == OP_CONST) {
5425         SV* sv = kSVOP->op_sv;
5426         if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
5427             OP *cmop;
5428             if (!SvREADONLY(sv) || !SvFAKE(sv)) {
5429                 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
5430             }
5431             else {
5432                 kSVOP->op_sv = Nullsv;
5433             }
5434             cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
5435             op_free(o);
5436             return cmop;
5437         }
5438     }
5439     return o;
5440 }
5441
5442 OP *
5443 Perl_ck_null(pTHX_ OP *o)
5444 {
5445     return o;
5446 }
5447
5448 OP *
5449 Perl_ck_open(pTHX_ OP *o)
5450 {
5451     HV *table = GvHV(PL_hintgv);
5452     if (table) {
5453         SV **svp;
5454         I32 mode;
5455         svp = hv_fetch(table, "open_IN", 7, FALSE);
5456         if (svp && *svp) {
5457             mode = mode_from_discipline(*svp);
5458             if (mode & O_BINARY)
5459                 o->op_private |= OPpOPEN_IN_RAW;
5460             else if (mode & O_TEXT)
5461                 o->op_private |= OPpOPEN_IN_CRLF;
5462         }
5463
5464         svp = hv_fetch(table, "open_OUT", 8, FALSE);
5465         if (svp && *svp) {
5466             mode = mode_from_discipline(*svp);
5467             if (mode & O_BINARY)
5468                 o->op_private |= OPpOPEN_OUT_RAW;
5469             else if (mode & O_TEXT)
5470                 o->op_private |= OPpOPEN_OUT_CRLF;
5471         }
5472     }
5473     if (o->op_type == OP_BACKTICK)
5474         return o;
5475     return ck_fun(o);
5476 }
5477
5478 OP *
5479 Perl_ck_repeat(pTHX_ OP *o)
5480 {
5481     if (cBINOPo->op_first->op_flags & OPf_PARENS) {
5482         o->op_private |= OPpREPEAT_DOLIST;
5483         cBINOPo->op_first = force_list(cBINOPo->op_first);
5484     }
5485     else
5486         scalar(o);
5487     return o;
5488 }
5489
5490 OP *
5491 Perl_ck_require(pTHX_ OP *o)
5492 {
5493     GV* gv;
5494
5495     if (o->op_flags & OPf_KIDS) {       /* Shall we supply missing .pm? */
5496         SVOP *kid = (SVOP*)cUNOPo->op_first;
5497
5498         if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5499             char *s;
5500             for (s = SvPVX(kid->op_sv); *s; s++) {
5501                 if (*s == ':' && s[1] == ':') {
5502                     *s = '/';
5503                     Move(s+2, s+1, strlen(s+2)+1, char);
5504                     --SvCUR(kid->op_sv);
5505                 }
5506             }
5507             if (SvREADONLY(kid->op_sv)) {
5508                 SvREADONLY_off(kid->op_sv);
5509                 sv_catpvn(kid->op_sv, ".pm", 3);
5510                 SvREADONLY_on(kid->op_sv);
5511             }
5512             else
5513                 sv_catpvn(kid->op_sv, ".pm", 3);
5514         }
5515     }
5516
5517     /* handle override, if any */
5518     gv = gv_fetchpv("require", FALSE, SVt_PVCV);
5519     if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
5520         gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
5521
5522     if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5523         OP *kid = cUNOPo->op_first;
5524         cUNOPo->op_first = 0;
5525         op_free(o);
5526         return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
5527                                append_elem(OP_LIST, kid,
5528                                            scalar(newUNOP(OP_RV2CV, 0,
5529                                                           newGVOP(OP_GV, 0,
5530                                                                   gv))))));
5531     }
5532
5533     return ck_fun(o);
5534 }
5535
5536 OP *
5537 Perl_ck_return(pTHX_ OP *o)
5538 {
5539     OP *kid;
5540     if (CvLVALUE(PL_compcv)) {
5541         for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
5542             mod(kid, OP_LEAVESUBLV);
5543     }
5544     return o;
5545 }
5546
5547 #if 0
5548 OP *
5549 Perl_ck_retarget(pTHX_ OP *o)
5550 {
5551     Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5552     /* STUB */
5553     return o;
5554 }
5555 #endif
5556
5557 OP *
5558 Perl_ck_select(pTHX_ OP *o)
5559 {
5560     OP* kid;
5561     if (o->op_flags & OPf_KIDS) {
5562         kid = cLISTOPo->op_first->op_sibling;   /* get past pushmark */
5563         if (kid && kid->op_sibling) {
5564             o->op_type = OP_SSELECT;
5565             o->op_ppaddr = PL_ppaddr[OP_SSELECT];
5566             o = ck_fun(o);
5567             return fold_constants(o);
5568         }
5569     }
5570     o = ck_fun(o);
5571     kid = cLISTOPo->op_first->op_sibling;    /* get past pushmark */
5572     if (kid && kid->op_type == OP_RV2GV)
5573         kid->op_private &= ~HINT_STRICT_REFS;
5574     return o;
5575 }
5576
5577 OP *
5578 Perl_ck_shift(pTHX_ OP *o)
5579 {
5580     I32 type = o->op_type;
5581
5582     if (!(o->op_flags & OPf_KIDS)) {
5583         OP *argop;
5584
5585         op_free(o);
5586         argop = newUNOP(OP_RV2AV, 0,
5587             scalar(newGVOP(OP_GV, 0, !CvUNIQUE(PL_compcv) ?
5588                            PL_defgv : gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
5589         return newUNOP(type, 0, scalar(argop));
5590     }
5591     return scalar(modkids(ck_fun(o), type));
5592 }
5593
5594 OP *
5595 Perl_ck_sort(pTHX_ OP *o)
5596 {
5597     OP *firstkid;
5598
5599     if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
5600         simplify_sort(o);
5601     firstkid = cLISTOPo->op_first->op_sibling;          /* get past pushmark */
5602     if (o->op_flags & OPf_STACKED) {                    /* may have been cleared */
5603         OP *k = NULL;
5604         OP *kid = cUNOPx(firstkid)->op_first;           /* get past null */
5605
5606         if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
5607             linklist(kid);
5608             if (kid->op_type == OP_SCOPE) {
5609                 k = kid->op_next;
5610                 kid->op_next = 0;
5611             }
5612             else if (kid->op_type == OP_LEAVE) {
5613                 if (o->op_type == OP_SORT) {
5614                     op_null(kid);                       /* wipe out leave */
5615                     kid->op_next = kid;
5616
5617                     for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
5618                         if (k->op_next == kid)
5619                             k->op_next = 0;
5620                         /* don't descend into loops */
5621                         else if (k->op_type == OP_ENTERLOOP
5622                                  || k->op_type == OP_ENTERITER)
5623                         {
5624                             k = cLOOPx(k)->op_lastop;
5625                         }
5626                     }
5627                 }
5628                 else
5629                     kid->op_next = 0;           /* just disconnect the leave */
5630                 k = kLISTOP->op_first;
5631             }
5632             CALL_PEEP(k);
5633
5634             kid = firstkid;
5635             if (o->op_type == OP_SORT) {
5636                 /* provide scalar context for comparison function/block */
5637                 kid = scalar(kid);
5638                 kid->op_next = kid;
5639             }
5640             else
5641                 kid->op_next = k;
5642             o->op_flags |= OPf_SPECIAL;
5643         }
5644         else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
5645             op_null(firstkid);
5646
5647         firstkid = firstkid->op_sibling;
5648     }
5649
5650     /* provide list context for arguments */
5651     if (o->op_type == OP_SORT)
5652         list(firstkid);
5653
5654     return o;
5655 }
5656
5657 STATIC void
5658 S_simplify_sort(pTHX_ OP *o)
5659 {
5660     register OP *kid = cLISTOPo->op_first->op_sibling;  /* get past pushmark */
5661     OP *k;
5662     int reversed;
5663     GV *gv;
5664     if (!(o->op_flags & OPf_STACKED))
5665         return;
5666     GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
5667     GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
5668     kid = kUNOP->op_first;                              /* get past null */
5669     if (kid->op_type != OP_SCOPE)
5670         return;
5671     kid = kLISTOP->op_last;                             /* get past scope */
5672     switch(kid->op_type) {
5673         case OP_NCMP:
5674         case OP_I_NCMP:
5675         case OP_SCMP:
5676             break;
5677         default:
5678             return;
5679     }
5680     k = kid;                                            /* remember this node*/
5681     if (kBINOP->op_first->op_type != OP_RV2SV)
5682         return;
5683     kid = kBINOP->op_first;                             /* get past cmp */
5684     if (kUNOP->op_first->op_type != OP_GV)
5685         return;
5686     kid = kUNOP->op_first;                              /* get past rv2sv */
5687     gv = kGVOP_gv;
5688     if (GvSTASH(gv) != PL_curstash)
5689         return;
5690     if (strEQ(GvNAME(gv), "a"))
5691         reversed = 0;
5692     else if (strEQ(GvNAME(gv), "b"))
5693         reversed = 1;
5694     else
5695         return;
5696     kid = k;                                            /* back to cmp */
5697     if (kBINOP->op_last->op_type != OP_RV2SV)
5698         return;
5699     kid = kBINOP->op_last;                              /* down to 2nd arg */
5700     if (kUNOP->op_first->op_type != OP_GV)
5701         return;
5702     kid = kUNOP->op_first;                              /* get past rv2sv */
5703     gv = kGVOP_gv;
5704     if (GvSTASH(gv) != PL_curstash
5705         || ( reversed
5706             ? strNE(GvNAME(gv), "a")
5707             : strNE(GvNAME(gv), "b")))
5708         return;
5709     o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
5710     if (reversed)
5711         o->op_private |= OPpSORT_REVERSE;
5712     if (k->op_type == OP_NCMP)
5713         o->op_private |= OPpSORT_NUMERIC;
5714     if (k->op_type == OP_I_NCMP)
5715         o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
5716     kid = cLISTOPo->op_first->op_sibling;
5717     cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
5718     op_free(kid);                                     /* then delete it */
5719 }
5720
5721 OP *
5722 Perl_ck_split(pTHX_ OP *o)
5723 {
5724     register OP *kid;
5725
5726     if (o->op_flags & OPf_STACKED)
5727         return no_fh_allowed(o);
5728
5729     kid = cLISTOPo->op_first;
5730     if (kid->op_type != OP_NULL)
5731         Perl_croak(aTHX_ "panic: ck_split");
5732     kid = kid->op_sibling;
5733     op_free(cLISTOPo->op_first);
5734     cLISTOPo->op_first = kid;
5735     if (!kid) {
5736         cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
5737         cLISTOPo->op_last = kid; /* There was only one element previously */
5738     }
5739
5740     if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
5741         OP *sibl = kid->op_sibling;
5742         kid->op_sibling = 0;
5743         kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
5744         if (cLISTOPo->op_first == cLISTOPo->op_last)
5745             cLISTOPo->op_last = kid;
5746         cLISTOPo->op_first = kid;
5747         kid->op_sibling = sibl;
5748     }
5749
5750     kid->op_type = OP_PUSHRE;
5751     kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
5752     scalar(kid);
5753     if (ckWARN(WARN_REGEXP) && ((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
5754       Perl_warner(aTHX_ packWARN(WARN_REGEXP),
5755                   "Use of /g modifier is meaningless in split");
5756     }
5757
5758     if (!kid->op_sibling)
5759         append_elem(OP_SPLIT, o, newDEFSVOP());
5760
5761     kid = kid->op_sibling;
5762     scalar(kid);
5763
5764     if (!kid->op_sibling)
5765         append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
5766
5767     kid = kid->op_sibling;
5768     scalar(kid);
5769
5770     if (kid->op_sibling)
5771         return too_many_arguments(o,OP_DESC(o));
5772
5773     return o;
5774 }
5775
5776 OP *
5777 Perl_ck_join(pTHX_ OP *o)
5778 {
5779     if (ckWARN(WARN_SYNTAX)) {
5780         OP *kid = cLISTOPo->op_first->op_sibling;
5781         if (kid && kid->op_type == OP_MATCH) {
5782             char *pmstr = "STRING";
5783             if (PM_GETRE(kPMOP))
5784                 pmstr = PM_GETRE(kPMOP)->precomp;
5785             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5786                         "/%s/ should probably be written as \"%s\"",
5787                         pmstr, pmstr);
5788         }
5789     }
5790     return ck_fun(o);
5791 }
5792
5793 OP *
5794 Perl_ck_subr(pTHX_ OP *o)
5795 {
5796     OP *prev = ((cUNOPo->op_first->op_sibling)
5797              ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
5798     OP *o2 = prev->op_sibling;
5799     OP *cvop;
5800     char *proto = 0;
5801     CV *cv = 0;
5802     GV *namegv = 0;
5803     int optional = 0;
5804     I32 arg = 0;
5805     I32 contextclass = 0;
5806     char *e = 0;
5807     STRLEN n_a;
5808
5809     o->op_private |= OPpENTERSUB_HASTARG;
5810     for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
5811     if (cvop->op_type == OP_RV2CV) {
5812         SVOP* tmpop;
5813         o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
5814         op_null(cvop);          /* disable rv2cv */
5815         tmpop = (SVOP*)((UNOP*)cvop)->op_first;
5816         if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
5817             GV *gv = cGVOPx_gv(tmpop);
5818             cv = GvCVu(gv);
5819             if (!cv)
5820                 tmpop->op_private |= OPpEARLY_CV;
5821             else if (SvPOK(cv)) {
5822                 namegv = CvANON(cv) ? gv : CvGV(cv);
5823                 proto = SvPV((SV*)cv, n_a);
5824             }
5825         }
5826     }
5827     else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
5828         if (o2->op_type == OP_CONST)
5829             o2->op_private &= ~OPpCONST_STRICT;
5830         else if (o2->op_type == OP_LIST) {
5831             OP *o = ((UNOP*)o2)->op_first->op_sibling;
5832             if (o && o->op_type == OP_CONST)
5833                 o->op_private &= ~OPpCONST_STRICT;
5834         }
5835     }
5836     o->op_private |= (PL_hints & HINT_STRICT_REFS);
5837     if (PERLDB_SUB && PL_curstash != PL_debstash)
5838         o->op_private |= OPpENTERSUB_DB;
5839     while (o2 != cvop) {
5840         if (proto) {
5841             switch (*proto) {
5842             case '\0':
5843                 return too_many_arguments(o, gv_ename(namegv));
5844             case ';':
5845                 optional = 1;
5846                 proto++;
5847                 continue;
5848             case '$':
5849                 proto++;
5850                 arg++;
5851                 scalar(o2);
5852                 break;
5853             case '%':
5854             case '@':
5855                 list(o2);
5856                 arg++;
5857                 break;
5858             case '&':
5859                 proto++;
5860                 arg++;
5861                 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
5862                     bad_type(arg,
5863                         arg == 1 ? "block or sub {}" : "sub {}",
5864                         gv_ename(namegv), o2);
5865                 break;
5866             case '*':
5867                 /* '*' allows any scalar type, including bareword */
5868                 proto++;
5869                 arg++;
5870                 if (o2->op_type == OP_RV2GV)
5871                     goto wrapref;       /* autoconvert GLOB -> GLOBref */
5872                 else if (o2->op_type == OP_CONST)
5873                     o2->op_private &= ~OPpCONST_STRICT;
5874                 else if (o2->op_type == OP_ENTERSUB) {
5875                     /* accidental subroutine, revert to bareword */
5876                     OP *gvop = ((UNOP*)o2)->op_first;
5877                     if (gvop && gvop->op_type == OP_NULL) {
5878                         gvop = ((UNOP*)gvop)->op_first;
5879                         if (gvop) {
5880                             for (; gvop->op_sibling; gvop = gvop->op_sibling)
5881                                 ;
5882                             if (gvop &&
5883                                 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
5884                                 (gvop = ((UNOP*)gvop)->op_first) &&
5885                                 gvop->op_type == OP_GV)
5886                             {
5887                                 GV *gv = cGVOPx_gv(gvop);
5888                                 OP *sibling = o2->op_sibling;
5889                                 SV *n = newSVpvn("",0);
5890                                 op_free(o2);
5891                                 gv_fullname3(n, gv, "");
5892                                 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
5893                                     sv_chop(n, SvPVX(n)+6);
5894                                 o2 = newSVOP(OP_CONST, 0, n);
5895                                 prev->op_sibling = o2;
5896                                 o2->op_sibling = sibling;
5897                             }
5898                         }
5899                     }
5900                 }
5901                 scalar(o2);
5902                 break;
5903             case '[': case ']':
5904                  goto oops;
5905                  break;
5906             case '\\':
5907                 proto++;
5908                 arg++;
5909             again:
5910                 switch (*proto++) {
5911                 case '[':
5912                      if (contextclass++ == 0) {
5913                           e = strchr(proto, ']');
5914                           if (!e || e == proto)
5915                                goto oops;
5916                      }
5917                      else
5918                           goto oops;
5919                      goto again;
5920                      break;
5921                 case ']':
5922                      if (contextclass) {
5923                          char *p = proto;
5924                          char s = *p;
5925                          contextclass = 0;
5926                          *p = '\0';
5927                          while (*--p != '[');
5928                          bad_type(arg, Perl_form(aTHX_ "one of %s", p),
5929                                  gv_ename(namegv), o2);
5930                          *proto = s;
5931                      } else
5932                           goto oops;
5933                      break;
5934                 case '*':
5935                      if (o2->op_type == OP_RV2GV)
5936                           goto wrapref;
5937                      if (!contextclass)
5938                           bad_type(arg, "symbol", gv_ename(namegv), o2);
5939                      break;
5940                 case '&':
5941                      if (o2->op_type == OP_ENTERSUB)
5942                           goto wrapref;
5943                      if (!contextclass)
5944                           bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
5945                      break;
5946                 case '$':
5947                     if (o2->op_type == OP_RV2SV ||
5948                         o2->op_type == OP_PADSV ||
5949                         o2->op_type == OP_HELEM ||
5950                         o2->op_type == OP_AELEM ||
5951                         o2->op_type == OP_THREADSV)
5952                          goto wrapref;
5953                     if (!contextclass)
5954                         bad_type(arg, "scalar", gv_ename(namegv), o2);
5955                      break;
5956                 case '@':
5957                     if (o2->op_type == OP_RV2AV ||
5958                         o2->op_type == OP_PADAV)
5959                          goto wrapref;
5960                     if (!contextclass)
5961                         bad_type(arg, "array", gv_ename(namegv), o2);
5962                     break;
5963                 case '%':
5964                     if (o2->op_type == OP_RV2HV ||
5965                         o2->op_type == OP_PADHV)
5966                          goto wrapref;
5967                     if (!contextclass)
5968                          bad_type(arg, "hash", gv_ename(namegv), o2);
5969                     break;
5970                 wrapref:
5971                     {
5972                         OP* kid = o2;
5973                         OP* sib = kid->op_sibling;
5974                         kid->op_sibling = 0;
5975                         o2 = newUNOP(OP_REFGEN, 0, kid);
5976                         o2->op_sibling = sib;
5977                         prev->op_sibling = o2;
5978                     }
5979                     if (contextclass && e) {
5980                          proto = e + 1;
5981                          contextclass = 0;
5982                     }
5983                     break;
5984                 default: goto oops;
5985                 }
5986                 if (contextclass)
5987                      goto again;
5988                 break;
5989             case ' ':
5990                 proto++;
5991                 continue;
5992             default:
5993               oops:
5994                 Perl_croak(aTHX_ "Malformed prototype for %s: %s",
5995                            gv_ename(namegv), SvPV((SV*)cv, n_a));
5996             }
5997         }
5998         else
5999             list(o2);
6000         mod(o2, OP_ENTERSUB);
6001         prev = o2;
6002         o2 = o2->op_sibling;
6003     }
6004     if (proto && !optional &&
6005           (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6006         return too_few_arguments(o, gv_ename(namegv));
6007     return o;
6008 }
6009
6010 OP *
6011 Perl_ck_svconst(pTHX_ OP *o)
6012 {
6013     SvREADONLY_on(cSVOPo->op_sv);
6014     return o;
6015 }
6016
6017 OP *
6018 Perl_ck_trunc(pTHX_ OP *o)
6019 {
6020     if (o->op_flags & OPf_KIDS) {
6021         SVOP *kid = (SVOP*)cUNOPo->op_first;
6022
6023         if (kid->op_type == OP_NULL)
6024             kid = (SVOP*)kid->op_sibling;
6025         if (kid && kid->op_type == OP_CONST &&
6026             (kid->op_private & OPpCONST_BARE))
6027         {
6028             o->op_flags |= OPf_SPECIAL;
6029             kid->op_private &= ~OPpCONST_STRICT;
6030         }
6031     }
6032     return ck_fun(o);
6033 }
6034
6035 OP *
6036 Perl_ck_substr(pTHX_ OP *o)
6037 {
6038     o = ck_fun(o);
6039     if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6040         OP *kid = cLISTOPo->op_first;
6041
6042         if (kid->op_type == OP_NULL)
6043             kid = kid->op_sibling;
6044         if (kid)
6045             kid->op_flags |= OPf_MOD;
6046
6047     }
6048     return o;
6049 }
6050
6051 /* A peephole optimizer.  We visit the ops in the order they're to execute. */
6052
6053 void
6054 Perl_peep(pTHX_ register OP *o)
6055 {
6056     register OP* oldop = 0;
6057
6058     if (!o || o->op_seq)
6059         return;
6060     ENTER;
6061     SAVEOP();
6062     SAVEVPTR(PL_curcop);
6063     for (; o; o = o->op_next) {
6064         if (o->op_seq)
6065             break;
6066         if (!PL_op_seqmax)
6067             PL_op_seqmax++;
6068         PL_op = o;
6069         switch (o->op_type) {
6070         case OP_SETSTATE:
6071         case OP_NEXTSTATE:
6072         case OP_DBSTATE:
6073             PL_curcop = ((COP*)o);              /* for warnings */
6074             o->op_seq = PL_op_seqmax++;
6075             break;
6076
6077         case OP_CONST:
6078             if (cSVOPo->op_private & OPpCONST_STRICT)
6079                 no_bareword_allowed(o);
6080 #ifdef USE_ITHREADS
6081             /* Relocate sv to the pad for thread safety.
6082              * Despite being a "constant", the SV is written to,
6083              * for reference counts, sv_upgrade() etc. */
6084             if (cSVOP->op_sv) {
6085                 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6086                 if (SvPADTMP(cSVOPo->op_sv)) {
6087                     /* If op_sv is already a PADTMP then it is being used by
6088                      * some pad, so make a copy. */
6089                     sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
6090                     SvREADONLY_on(PAD_SVl(ix));
6091                     SvREFCNT_dec(cSVOPo->op_sv);
6092                 }
6093                 else {
6094                     SvREFCNT_dec(PAD_SVl(ix));
6095                     SvPADTMP_on(cSVOPo->op_sv);
6096                     PAD_SETSV(ix, cSVOPo->op_sv);
6097                     /* XXX I don't know how this isn't readonly already. */
6098                     SvREADONLY_on(PAD_SVl(ix));
6099                 }
6100                 cSVOPo->op_sv = Nullsv;
6101                 o->op_targ = ix;
6102             }
6103 #endif
6104             o->op_seq = PL_op_seqmax++;
6105             break;
6106
6107         case OP_CONCAT:
6108             if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6109                 if (o->op_next->op_private & OPpTARGET_MY) {
6110                     if (o->op_flags & OPf_STACKED) /* chained concats */
6111                         goto ignore_optimization;
6112                     else {
6113                         /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6114                         o->op_targ = o->op_next->op_targ;
6115                         o->op_next->op_targ = 0;
6116                         o->op_private |= OPpTARGET_MY;
6117                     }
6118                 }
6119                 op_null(o->op_next);
6120             }
6121           ignore_optimization:
6122             o->op_seq = PL_op_seqmax++;
6123             break;
6124         case OP_STUB:
6125             if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6126                 o->op_seq = PL_op_seqmax++;
6127                 break; /* Scalar stub must produce undef.  List stub is noop */
6128             }
6129             goto nothin;
6130         case OP_NULL:
6131             if (o->op_targ == OP_NEXTSTATE
6132                 || o->op_targ == OP_DBSTATE
6133                 || o->op_targ == OP_SETSTATE)
6134             {
6135                 PL_curcop = ((COP*)o);
6136             }
6137             /* XXX: We avoid setting op_seq here to prevent later calls
6138                to peep() from mistakenly concluding that optimisation
6139                has already occurred. This doesn't fix the real problem,
6140                though (See 20010220.007). AMS 20010719 */
6141             if (oldop && o->op_next) {
6142                 oldop->op_next = o->op_next;
6143                 continue;
6144             }
6145             break;
6146         case OP_SCALAR:
6147         case OP_LINESEQ:
6148         case OP_SCOPE:
6149           nothin:
6150             if (oldop && o->op_next) {
6151                 oldop->op_next = o->op_next;
6152                 continue;
6153             }
6154             o->op_seq = PL_op_seqmax++;
6155             break;
6156
6157         case OP_GV:
6158             if (o->op_next->op_type == OP_RV2SV) {
6159                 if (!(o->op_next->op_private & OPpDEREF)) {
6160                     op_null(o->op_next);
6161                     o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6162                                                                | OPpOUR_INTRO);
6163                     o->op_next = o->op_next->op_next;
6164                     o->op_type = OP_GVSV;
6165                     o->op_ppaddr = PL_ppaddr[OP_GVSV];
6166                 }
6167             }
6168             else if (o->op_next->op_type == OP_RV2AV) {
6169                 OP* pop = o->op_next->op_next;
6170                 IV i;
6171                 if (pop && pop->op_type == OP_CONST &&
6172                     (PL_op = pop->op_next) &&
6173                     pop->op_next->op_type == OP_AELEM &&
6174                     !(pop->op_next->op_private &
6175                       (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6176                     (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
6177                                 <= 255 &&
6178                     i >= 0)
6179                 {
6180                     GV *gv;
6181                     op_null(o->op_next);
6182                     op_null(pop->op_next);
6183                     op_null(pop);
6184                     o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6185                     o->op_next = pop->op_next->op_next;
6186                     o->op_type = OP_AELEMFAST;
6187                     o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6188                     o->op_private = (U8)i;
6189                     gv = cGVOPo_gv;
6190                     GvAVn(gv);
6191                 }
6192             }
6193             else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6194                 GV *gv = cGVOPo_gv;
6195                 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
6196                     /* XXX could check prototype here instead of just carping */
6197                     SV *sv = sv_newmortal();
6198                     gv_efullname3(sv, gv, Nullch);
6199                     Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
6200                                 "%s() called too early to check prototype",
6201                                 SvPV_nolen(sv));
6202                 }
6203             }
6204             else if (o->op_next->op_type == OP_READLINE
6205                     && o->op_next->op_next->op_type == OP_CONCAT
6206                     && (o->op_next->op_next->op_flags & OPf_STACKED))
6207             {
6208                 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
6209                 o->op_type   = OP_RCATLINE;
6210                 o->op_flags |= OPf_STACKED;
6211                 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
6212                 op_null(o->op_next->op_next);
6213                 op_null(o->op_next);
6214             }
6215
6216             o->op_seq = PL_op_seqmax++;
6217             break;
6218
6219         case OP_MAPWHILE:
6220         case OP_GREPWHILE:
6221         case OP_AND:
6222         case OP_OR:
6223         case OP_DOR:
6224         case OP_ANDASSIGN:
6225         case OP_ORASSIGN:
6226         case OP_DORASSIGN:
6227         case OP_COND_EXPR:
6228         case OP_RANGE:
6229             o->op_seq = PL_op_seqmax++;
6230             while (cLOGOP->op_other->op_type == OP_NULL)
6231                 cLOGOP->op_other = cLOGOP->op_other->op_next;
6232             peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
6233             break;
6234
6235         case OP_ENTERLOOP:
6236         case OP_ENTERITER:
6237             o->op_seq = PL_op_seqmax++;
6238             while (cLOOP->op_redoop->op_type == OP_NULL)
6239                 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6240             peep(cLOOP->op_redoop);
6241             while (cLOOP->op_nextop->op_type == OP_NULL)
6242                 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6243             peep(cLOOP->op_nextop);
6244             while (cLOOP->op_lastop->op_type == OP_NULL)
6245                 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6246             peep(cLOOP->op_lastop);
6247             break;
6248
6249         case OP_QR:
6250         case OP_MATCH:
6251         case OP_SUBST:
6252             o->op_seq = PL_op_seqmax++;
6253             while (cPMOP->op_pmreplstart &&
6254                    cPMOP->op_pmreplstart->op_type == OP_NULL)
6255                 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6256             peep(cPMOP->op_pmreplstart);
6257             break;
6258
6259         case OP_EXEC:
6260             o->op_seq = PL_op_seqmax++;
6261             if (ckWARN(WARN_SYNTAX) && o->op_next
6262                 && o->op_next->op_type == OP_NEXTSTATE) {
6263                 if (o->op_next->op_sibling &&
6264                         o->op_next->op_sibling->op_type != OP_EXIT &&
6265                         o->op_next->op_sibling->op_type != OP_WARN &&
6266                         o->op_next->op_sibling->op_type != OP_DIE) {
6267                     line_t oldline = CopLINE(PL_curcop);
6268
6269                     CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6270                     Perl_warner(aTHX_ packWARN(WARN_EXEC),
6271                                 "Statement unlikely to be reached");
6272                     Perl_warner(aTHX_ packWARN(WARN_EXEC),
6273                                 "\t(Maybe you meant system() when you said exec()?)\n");
6274                     CopLINE_set(PL_curcop, oldline);
6275                 }
6276             }
6277             break;
6278
6279         case OP_HELEM: {
6280             SV *lexname;
6281             SV **svp, *sv;
6282             char *key = NULL;
6283             STRLEN keylen;
6284
6285             o->op_seq = PL_op_seqmax++;
6286
6287             if (((BINOP*)o)->op_last->op_type != OP_CONST)
6288                 break;
6289
6290             /* Make the CONST have a shared SV */
6291             svp = cSVOPx_svp(((BINOP*)o)->op_last);
6292             if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
6293                 key = SvPV(sv, keylen);
6294                 lexname = newSVpvn_share(key,
6295                                          SvUTF8(sv) ? -(I32)keylen : keylen,
6296                                          0);
6297                 SvREFCNT_dec(sv);
6298                 *svp = lexname;
6299             }
6300             break;
6301         }
6302
6303         default:
6304             o->op_seq = PL_op_seqmax++;
6305             break;
6306         }
6307         oldop = o;
6308     }
6309     LEAVE;
6310 }
6311
6312
6313
6314 char* Perl_custom_op_name(pTHX_ OP* o)
6315 {
6316     IV  index = PTR2IV(o->op_ppaddr);
6317     SV* keysv;
6318     HE* he;
6319
6320     if (!PL_custom_op_names) /* This probably shouldn't happen */
6321         return PL_op_name[OP_CUSTOM];
6322
6323     keysv = sv_2mortal(newSViv(index));
6324
6325     he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
6326     if (!he)
6327         return PL_op_name[OP_CUSTOM]; /* Don't know who you are */
6328
6329     return SvPV_nolen(HeVAL(he));
6330 }
6331
6332 char* Perl_custom_op_desc(pTHX_ OP* o)
6333 {
6334     IV  index = PTR2IV(o->op_ppaddr);
6335     SV* keysv;
6336     HE* he;
6337
6338     if (!PL_custom_op_descs)
6339         return PL_op_desc[OP_CUSTOM];
6340
6341     keysv = sv_2mortal(newSViv(index));
6342
6343     he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
6344     if (!he)
6345         return PL_op_desc[OP_CUSTOM];
6346
6347     return SvPV_nolen(HeVAL(he));
6348 }
6349
6350
6351 #include "XSUB.h"
6352
6353 /* Efficient sub that returns a constant scalar value. */
6354 static void
6355 const_sv_xsub(pTHX_ CV* cv)
6356 {
6357     dXSARGS;
6358     if (items != 0) {
6359 #if 0
6360         Perl_croak(aTHX_ "usage: %s::%s()",
6361                    HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
6362 #endif
6363     }
6364     EXTEND(sp, 1);
6365     ST(0) = (SV*)XSANY.any_ptr;
6366     XSRETURN(1);
6367 }