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 \"%"SVf"\" not allowed while \"strict subs\" in use",
 156                      cSVOPo_sv));
 157 }
 158
 159 /* "register" allocation */
 160
 161 PADOFFSET
 162 Perl_allocmy(pTHX_ char *name)
 163 {
 164     PADOFFSET off;
 165
 166     /* complain about "my $_" etc etc */
 167     if (!(PL_in_my == KEY_our ||
 168           isALPHA(name[1]) ||
 169           (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
 170           (name[1] == '_' && (int)strlen(name) > 2)))
 171     {
 172         if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
 173             /* 1999-02-27 mjd@plover.com */
 174             char *p;
 175             p = strchr(name, '\0');
 176             /* The next block assumes the buffer is at least 205 chars
 177                long.  At present, it's always at least 256 chars. */
 178             if (p-name > 200) {
 179                 strcpy(name+200, "...");
 180                 p = name+199;
 181             }
 182             else {
 183                 p[1] = '\0';
 184             }
 185             /* Move everything else down one character */
 186             for (; p-name > 2; p--)
 187                 *p = *(p-1);
 188             name[2] = toCTRL(name[1]);
 189             name[1] = '^';
 190         }
 191         yyerror(Perl_form(aTHX_ "Can't use global %s in \"my\"",name));
 192     }
 193
 194     /* check for duplicate declaration */
 195     pad_check_dup(name,
 196                 PL_in_my == KEY_our,
 197                 (PL_curstash ? PL_curstash : PL_defstash)
 198     );
 199
 200     if (PL_in_my_stash && *name != '$') {
 201         yyerror(Perl_form(aTHX_
 202                     "Can't declare class for non-scalar %s in \"%s\"",
 203                      name, PL_in_my == KEY_our ? "our" : "my"));
 204     }
 205
 206     /* allocate a spare slot and store the name in that slot */
 207
 208     off = pad_add_name(name,
 209                     PL_in_my_stash,
 210                     (PL_in_my == KEY_our
 211                         ? (PL_curstash ? PL_curstash : PL_defstash)
 212                         : Nullhv
 213                     ),
 214                     0 /*  not fake */
 215     );
 216     return off;
 217 }
 218
 219 /* Destructor */
 220
 221 void
 222 Perl_op_free(pTHX_ OP *o)
 223 {
 224     register OP *kid, *nextkid;
 225     OPCODE type;
 226
 227     if (!o || o->op_seq == (U16)-1)
 228         return;
 229
 230     if (o->op_private & OPpREFCOUNTED) {
 231         switch (o->op_type) {
 232         case OP_LEAVESUB:
 233         case OP_LEAVESUBLV:
 234         case OP_LEAVEEVAL:
 235         case OP_LEAVE:
 236         case OP_SCOPE:
 237         case OP_LEAVEWRITE:
 238             OP_REFCNT_LOCK;
 239             if (OpREFCNT_dec(o)) {
 240                 OP_REFCNT_UNLOCK;
 241                 return;
 242             }
 243             OP_REFCNT_UNLOCK;
 244             break;
 245         default:
 246             break;
 247         }
 248     }
 249
 250     if (o->op_flags & OPf_KIDS) {
 251         for (kid = cUNOPo->op_first; kid; kid = nextkid) {
 252             nextkid = kid->op_sibling; /* Get before next freeing kid */
 253             op_free(kid);
 254         }
 255     }
 256     type = o->op_type;
 257     if (type == OP_NULL)
 258         type = (OPCODE)o->op_targ;
 259
 260     /* COP* is not cleared by op_clear() so that we may track line
 261      * numbers etc even after null() */
 262     if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE)
 263         cop_free((COP*)o);
 264
 265     op_clear(o);
 266     FreeOp(o);
 267 }
 268
 269 void
 270 Perl_op_clear(pTHX_ OP *o)
 271 {
 272
 273     switch (o->op_type) {
 274     case OP_NULL:       /* Was holding old type, if any. */
 275     case OP_ENTEREVAL:  /* Was holding hints. */
 276         o->op_targ = 0;
 277         break;
 278     default:
 279         if (!(o->op_flags & OPf_REF)
 280             || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
 281             break;
 282         /* FALL THROUGH */
 283     case OP_GVSV:
 284     case OP_GV:
 285     case OP_AELEMFAST:
 286 #ifdef USE_ITHREADS
 287         if (cPADOPo->op_padix > 0) {
 288             /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
 289              * may still exist on the pad */
 290             pad_swipe(cPADOPo->op_padix, TRUE);
 291             cPADOPo->op_padix = 0;
 292         }
 293 #else
 294         SvREFCNT_dec(cSVOPo->op_sv);
 295         cSVOPo->op_sv = Nullsv;
 296 #endif
 297         break;
 298     case OP_METHOD_NAMED:
 299     case OP_CONST:
 300         SvREFCNT_dec(cSVOPo->op_sv);
 301         cSVOPo->op_sv = Nullsv;
 302         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     return newSVOP(OP_CONST, 0, sv);
1946
1947   nope:
1948     return o;
1949 }
1950
1951 OP *
1952 Perl_gen_constant_list(pTHX_ register OP *o)
1953 {
1954     register OP *curop;
1955     I32 oldtmps_floor = PL_tmps_floor;
1956
1957     list(o);
1958     if (PL_error_count)
1959         return o;               /* Don't attempt to run with errors */
1960
1961     PL_op = curop = LINKLIST(o);
1962     o->op_next = 0;
1963     CALL_PEEP(curop);
1964     pp_pushmark();
1965     CALLRUNOPS(aTHX);
1966     PL_op = curop;
1967     pp_anonlist();
1968     PL_tmps_floor = oldtmps_floor;
1969
1970     o->op_type = OP_RV2AV;
1971     o->op_ppaddr = PL_ppaddr[OP_RV2AV];
1972     o->op_seq = 0;              /* needs to be revisited in peep() */
1973     curop = ((UNOP*)o)->op_first;
1974     ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
1975     op_free(curop);
1976     linklist(o);
1977     return list(o);
1978 }
1979
1980 OP *
1981 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
1982 {
1983     if (!o || o->op_type != OP_LIST)
1984         o = newLISTOP(OP_LIST, 0, o, Nullop);
1985     else
1986         o->op_flags &= ~OPf_WANT;
1987
1988     if (!(PL_opargs[type] & OA_MARK))
1989         op_null(cLISTOPo->op_first);
1990
1991     o->op_type = (OPCODE)type;
1992     o->op_ppaddr = PL_ppaddr[type];
1993     o->op_flags |= flags;
1994
1995     o = CHECKOP(type, o);
1996     if (o->op_type != type)
1997         return o;
1998
1999     return fold_constants(o);
2000 }
2001
2002 /* List constructors */
2003
2004 OP *
2005 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2006 {
2007     if (!first)
2008         return last;
2009
2010     if (!last)
2011         return first;
2012
2013     if (first->op_type != type
2014         || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2015     {
2016         return newLISTOP(type, 0, first, last);
2017     }
2018
2019     if (first->op_flags & OPf_KIDS)
2020         ((LISTOP*)first)->op_last->op_sibling = last;
2021     else {
2022         first->op_flags |= OPf_KIDS;
2023         ((LISTOP*)first)->op_first = last;
2024     }
2025     ((LISTOP*)first)->op_last = last;
2026     return first;
2027 }
2028
2029 OP *
2030 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2031 {
2032     if (!first)
2033         return (OP*)last;
2034
2035     if (!last)
2036         return (OP*)first;
2037
2038     if (first->op_type != type)
2039         return prepend_elem(type, (OP*)first, (OP*)last);
2040
2041     if (last->op_type != type)
2042         return append_elem(type, (OP*)first, (OP*)last);
2043
2044     first->op_last->op_sibling = last->op_first;
2045     first->op_last = last->op_last;
2046     first->op_flags |= (last->op_flags & OPf_KIDS);
2047
2048     FreeOp(last);
2049
2050     return (OP*)first;
2051 }
2052
2053 OP *
2054 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2055 {
2056     if (!first)
2057         return last;
2058
2059     if (!last)
2060         return first;
2061
2062     if (last->op_type == type) {
2063         if (type == OP_LIST) {  /* already a PUSHMARK there */
2064             first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2065             ((LISTOP*)last)->op_first->op_sibling = first;
2066             if (!(first->op_flags & OPf_PARENS))
2067                 last->op_flags &= ~OPf_PARENS;
2068         }
2069         else {
2070             if (!(last->op_flags & OPf_KIDS)) {
2071                 ((LISTOP*)last)->op_last = first;
2072                 last->op_flags |= OPf_KIDS;
2073             }
2074             first->op_sibling = ((LISTOP*)last)->op_first;
2075             ((LISTOP*)last)->op_first = first;
2076         }
2077         last->op_flags |= OPf_KIDS;
2078         return last;
2079     }
2080
2081     return newLISTOP(type, 0, first, last);
2082 }
2083
2084 /* Constructors */
2085
2086 OP *
2087 Perl_newNULLLIST(pTHX)
2088 {
2089     return newOP(OP_STUB, 0);
2090 }
2091
2092 OP *
2093 Perl_force_list(pTHX_ OP *o)
2094 {
2095     if (!o || o->op_type != OP_LIST)
2096         o = newLISTOP(OP_LIST, 0, o, Nullop);
2097     op_null(o);
2098     return o;
2099 }
2100
2101 OP *
2102 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2103 {
2104     LISTOP *listop;
2105
2106     NewOp(1101, listop, 1, LISTOP);
2107
2108     listop->op_type = (OPCODE)type;
2109     listop->op_ppaddr = PL_ppaddr[type];
2110     if (first || last)
2111         flags |= OPf_KIDS;
2112     listop->op_flags = (U8)flags;
2113
2114     if (!last && first)
2115         last = first;
2116     else if (!first && last)
2117         first = last;
2118     else if (first)
2119         first->op_sibling = last;
2120     listop->op_first = first;
2121     listop->op_last = last;
2122     if (type == OP_LIST) {
2123         OP* pushop;
2124         pushop = newOP(OP_PUSHMARK, 0);
2125         pushop->op_sibling = first;
2126         listop->op_first = pushop;
2127         listop->op_flags |= OPf_KIDS;
2128         if (!last)
2129             listop->op_last = pushop;
2130     }
2131
2132     return (OP*)listop;
2133 }
2134
2135 OP *
2136 Perl_newOP(pTHX_ I32 type, I32 flags)
2137 {
2138     OP *o;
2139     NewOp(1101, o, 1, OP);
2140     o->op_type = (OPCODE)type;
2141     o->op_ppaddr = PL_ppaddr[type];
2142     o->op_flags = (U8)flags;
2143
2144     o->op_next = o;
2145     o->op_private = (U8)(0 | (flags >> 8));
2146     if (PL_opargs[type] & OA_RETSCALAR)
2147         scalar(o);
2148     if (PL_opargs[type] & OA_TARGET)
2149         o->op_targ = pad_alloc(type, SVs_PADTMP);
2150     return CHECKOP(type, o);
2151 }
2152
2153 OP *
2154 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2155 {
2156     UNOP *unop;
2157
2158     if (!first)
2159         first = newOP(OP_STUB, 0);
2160     if (PL_opargs[type] & OA_MARK)
2161         first = force_list(first);
2162
2163     NewOp(1101, unop, 1, UNOP);
2164     unop->op_type = (OPCODE)type;
2165     unop->op_ppaddr = PL_ppaddr[type];
2166     unop->op_first = first;
2167     unop->op_flags = flags | OPf_KIDS;
2168     unop->op_private = (U8)(1 | (flags >> 8));
2169     unop = (UNOP*) CHECKOP(type, unop);
2170     if (unop->op_next)
2171         return (OP*)unop;
2172
2173     return fold_constants((OP *) unop);
2174 }
2175
2176 OP *
2177 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2178 {
2179     BINOP *binop;
2180     NewOp(1101, binop, 1, BINOP);
2181
2182     if (!first)
2183         first = newOP(OP_NULL, 0);
2184
2185     binop->op_type = (OPCODE)type;
2186     binop->op_ppaddr = PL_ppaddr[type];
2187     binop->op_first = first;
2188     binop->op_flags = flags | OPf_KIDS;
2189     if (!last) {
2190         last = first;
2191         binop->op_private = (U8)(1 | (flags >> 8));
2192     }
2193     else {
2194         binop->op_private = (U8)(2 | (flags >> 8));
2195         first->op_sibling = last;
2196     }
2197
2198     binop = (BINOP*)CHECKOP(type, binop);
2199     if (binop->op_next || binop->op_type != (OPCODE)type)
2200         return (OP*)binop;
2201
2202     binop->op_last = binop->op_first->op_sibling;
2203
2204     return fold_constants((OP *)binop);
2205 }
2206
2207 static int
2208 uvcompare(const void *a, const void *b)
2209 {
2210     if (*((UV *)a) < (*(UV *)b))
2211         return -1;
2212     if (*((UV *)a) > (*(UV *)b))
2213         return 1;
2214     if (*((UV *)a+1) < (*(UV *)b+1))
2215         return -1;
2216     if (*((UV *)a+1) > (*(UV *)b+1))
2217         return 1;
2218     return 0;
2219 }
2220
2221 OP *
2222 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2223 {
2224     SV *tstr = ((SVOP*)expr)->op_sv;
2225     SV *rstr = ((SVOP*)repl)->op_sv;
2226     STRLEN tlen;
2227     STRLEN rlen;
2228     U8 *t = (U8*)SvPV(tstr, tlen);
2229     U8 *r = (U8*)SvPV(rstr, rlen);
2230     register I32 i;
2231     register I32 j;
2232     I32 del;
2233     I32 complement;
2234     I32 squash;
2235     I32 grows = 0;
2236     register short *tbl;
2237
2238     PL_hints |= HINT_BLOCK_SCOPE;
2239     complement  = o->op_private & OPpTRANS_COMPLEMENT;
2240     del         = o->op_private & OPpTRANS_DELETE;
2241     squash      = o->op_private & OPpTRANS_SQUASH;
2242
2243     if (SvUTF8(tstr))
2244         o->op_private |= OPpTRANS_FROM_UTF;
2245
2246     if (SvUTF8(rstr))
2247         o->op_private |= OPpTRANS_TO_UTF;
2248
2249     if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2250         SV* listsv = newSVpvn("# comment\n",10);
2251         SV* transv = 0;
2252         U8* tend = t + tlen;
2253         U8* rend = r + rlen;
2254         STRLEN ulen;
2255         U32 tfirst = 1;
2256         U32 tlast = 0;
2257         I32 tdiff;
2258         U32 rfirst = 1;
2259         U32 rlast = 0;
2260         I32 rdiff;
2261         I32 diff;
2262         I32 none = 0;
2263         U32 max = 0;
2264         I32 bits;
2265         I32 havefinal = 0;
2266         U32 final = 0;
2267         I32 from_utf    = o->op_private & OPpTRANS_FROM_UTF;
2268         I32 to_utf      = o->op_private & OPpTRANS_TO_UTF;
2269         U8* tsave = NULL;
2270         U8* rsave = NULL;
2271
2272         if (!from_utf) {
2273             STRLEN len = tlen;
2274             tsave = t = bytes_to_utf8(t, &len);
2275             tend = t + len;
2276         }
2277         if (!to_utf && rlen) {
2278             STRLEN len = rlen;
2279             rsave = r = bytes_to_utf8(r, &len);
2280             rend = r + len;
2281         }
2282
2283 /* There are several snags with this code on EBCDIC:
2284    1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2285    2. scan_const() in toke.c has encoded chars in native encoding which makes
2286       ranges at least in EBCDIC 0..255 range the bottom odd.
2287 */
2288
2289         if (complement) {
2290             U8 tmpbuf[UTF8_MAXLEN+1];
2291             UV *cp;
2292             UV nextmin = 0;
2293             New(1109, cp, 2*tlen, UV);
2294             i = 0;
2295             transv = newSVpvn("",0);
2296             while (t < tend) {
2297                 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2298                 t += ulen;
2299                 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2300                     t++;
2301                     cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2302                     t += ulen;
2303                 }
2304                 else {
2305                  cp[2*i+1] = cp[2*i];
2306                 }
2307                 i++;
2308             }
2309             qsort(cp, i, 2*sizeof(UV), uvcompare);
2310             for (j = 0; j < i; j++) {
2311                 UV  val = cp[2*j];
2312                 diff = val - nextmin;
2313                 if (diff > 0) {
2314                     t = uvuni_to_utf8(tmpbuf,nextmin);
2315                     sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2316                     if (diff > 1) {
2317                         U8  range_mark = UTF_TO_NATIVE(0xff);
2318                         t = uvuni_to_utf8(tmpbuf, val - 1);
2319                         sv_catpvn(transv, (char *)&range_mark, 1);
2320                         sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2321                     }
2322                 }
2323                 val = cp[2*j+1];
2324                 if (val >= nextmin)
2325                     nextmin = val + 1;
2326             }
2327             t = uvuni_to_utf8(tmpbuf,nextmin);
2328             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2329             {
2330                 U8 range_mark = UTF_TO_NATIVE(0xff);
2331                 sv_catpvn(transv, (char *)&range_mark, 1);
2332             }
2333             t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
2334                                     UNICODE_ALLOW_SUPER);
2335             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2336             t = (U8*)SvPVX(transv);
2337             tlen = SvCUR(transv);
2338             tend = t + tlen;
2339             Safefree(cp);
2340         }
2341         else if (!rlen && !del) {
2342             r = t; rlen = tlen; rend = tend;
2343         }
2344         if (!squash) {
2345                 if ((!rlen && !del) || t == r ||
2346                     (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2347                 {
2348                     o->op_private |= OPpTRANS_IDENTICAL;
2349                 }
2350         }
2351
2352         while (t < tend || tfirst <= tlast) {
2353             /* see if we need more "t" chars */
2354             if (tfirst > tlast) {
2355                 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2356                 t += ulen;
2357                 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {    /* illegal utf8 val indicates range */
2358                     t++;
2359                     tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2360                     t += ulen;
2361                 }
2362                 else
2363                     tlast = tfirst;
2364             }
2365
2366             /* now see if we need more "r" chars */
2367             if (rfirst > rlast) {
2368                 if (r < rend) {
2369                     rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2370                     r += ulen;
2371                     if (r < rend && NATIVE_TO_UTF(*r) == 0xff) {        /* illegal utf8 val indicates range */
2372                         r++;
2373                         rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2374                         r += ulen;
2375                     }
2376                     else
2377                         rlast = rfirst;
2378                 }
2379                 else {
2380                     if (!havefinal++)
2381                         final = rlast;
2382                     rfirst = rlast = 0xffffffff;
2383                 }
2384             }
2385
2386             /* now see which range will peter our first, if either. */
2387             tdiff = tlast - tfirst;
2388             rdiff = rlast - rfirst;
2389
2390             if (tdiff <= rdiff)
2391                 diff = tdiff;
2392             else
2393                 diff = rdiff;
2394
2395             if (rfirst == 0xffffffff) {
2396                 diff = tdiff;   /* oops, pretend rdiff is infinite */
2397                 if (diff > 0)
2398                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2399                                    (long)tfirst, (long)tlast);
2400                 else
2401                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2402             }
2403             else {
2404                 if (diff > 0)
2405                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2406                                    (long)tfirst, (long)(tfirst + diff),
2407                                    (long)rfirst);
2408                 else
2409                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2410                                    (long)tfirst, (long)rfirst);
2411
2412                 if (rfirst + diff > max)
2413                     max = rfirst + diff;
2414                 if (!grows)
2415                     grows = (tfirst < rfirst &&
2416                              UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2417                 rfirst += diff + 1;
2418             }
2419             tfirst += diff + 1;
2420         }
2421
2422         none = ++max;
2423         if (del)
2424             del = ++max;
2425
2426         if (max > 0xffff)
2427             bits = 32;
2428         else if (max > 0xff)
2429             bits = 16;
2430         else
2431             bits = 8;
2432
2433         Safefree(cPVOPo->op_pv);
2434         cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2435         SvREFCNT_dec(listsv);
2436         if (transv)
2437             SvREFCNT_dec(transv);
2438
2439         if (!del && havefinal && rlen)
2440             (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2441                            newSVuv((UV)final), 0);
2442
2443         if (grows)
2444             o->op_private |= OPpTRANS_GROWS;
2445
2446         if (tsave)
2447             Safefree(tsave);
2448         if (rsave)
2449             Safefree(rsave);
2450
2451         op_free(expr);
2452         op_free(repl);
2453         return o;
2454     }
2455
2456     tbl = (short*)cPVOPo->op_pv;
2457     if (complement) {
2458         Zero(tbl, 256, short);
2459         for (i = 0; i < (I32)tlen; i++)
2460             tbl[t[i]] = -1;
2461         for (i = 0, j = 0; i < 256; i++) {
2462             if (!tbl[i]) {
2463                 if (j >= (I32)rlen) {
2464                     if (del)
2465                         tbl[i] = -2;
2466                     else if (rlen)
2467                         tbl[i] = r[j-1];
2468                     else
2469                         tbl[i] = (short)i;
2470                 }
2471                 else {
2472                     if (i < 128 && r[j] >= 128)
2473                         grows = 1;
2474                     tbl[i] = r[j++];
2475                 }
2476             }
2477         }
2478         if (!del) {
2479             if (!rlen) {
2480                 j = rlen;
2481                 if (!squash)
2482                     o->op_private |= OPpTRANS_IDENTICAL;
2483             }
2484             else if (j >= (I32)rlen)
2485                 j = rlen - 1;
2486             else
2487                 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
2488             tbl[0x100] = rlen - j;
2489             for (i=0; i < (I32)rlen - j; i++)
2490                 tbl[0x101+i] = r[j+i];
2491         }
2492     }
2493     else {
2494         if (!rlen && !del) {
2495             r = t; rlen = tlen;
2496             if (!squash)
2497                 o->op_private |= OPpTRANS_IDENTICAL;
2498         }
2499         else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
2500             o->op_private |= OPpTRANS_IDENTICAL;
2501         }
2502         for (i = 0; i < 256; i++)
2503             tbl[i] = -1;
2504         for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
2505             if (j >= (I32)rlen) {
2506                 if (del) {
2507                     if (tbl[t[i]] == -1)
2508                         tbl[t[i]] = -2;
2509                     continue;
2510                 }
2511                 --j;
2512             }
2513             if (tbl[t[i]] == -1) {
2514                 if (t[i] < 128 && r[j] >= 128)
2515                     grows = 1;
2516                 tbl[t[i]] = r[j];
2517             }
2518         }
2519     }
2520     if (grows)
2521         o->op_private |= OPpTRANS_GROWS;
2522     op_free(expr);
2523     op_free(repl);
2524
2525     return o;
2526 }
2527
2528 OP *
2529 Perl_newPMOP(pTHX_ I32 type, I32 flags)
2530 {
2531     PMOP *pmop;
2532
2533     NewOp(1101, pmop, 1, PMOP);
2534     pmop->op_type = (OPCODE)type;
2535     pmop->op_ppaddr = PL_ppaddr[type];
2536     pmop->op_flags = (U8)flags;
2537     pmop->op_private = (U8)(0 | (flags >> 8));
2538
2539     if (PL_hints & HINT_RE_TAINT)
2540         pmop->op_pmpermflags |= PMf_RETAINT;
2541     if (PL_hints & HINT_LOCALE)
2542         pmop->op_pmpermflags |= PMf_LOCALE;
2543     pmop->op_pmflags = pmop->op_pmpermflags;
2544
2545 #ifdef USE_ITHREADS
2546     {
2547         SV* repointer;
2548         if(av_len((AV*) PL_regex_pad[0]) > -1) {
2549             repointer = av_pop((AV*)PL_regex_pad[0]);
2550             pmop->op_pmoffset = SvIV(repointer);
2551             SvREPADTMP_off(repointer);
2552             sv_setiv(repointer,0);
2553         } else {
2554             repointer = newSViv(0);
2555             av_push(PL_regex_padav,SvREFCNT_inc(repointer));
2556             pmop->op_pmoffset = av_len(PL_regex_padav);
2557             PL_regex_pad = AvARRAY(PL_regex_padav);
2558         }
2559     }
2560 #endif
2561
2562         /* link into pm list */
2563     if (type != OP_TRANS && PL_curstash) {
2564         pmop->op_pmnext = HvPMROOT(PL_curstash);
2565         HvPMROOT(PL_curstash) = pmop;
2566         PmopSTASH_set(pmop,PL_curstash);
2567     }
2568
2569     return (OP*)pmop;
2570 }
2571
2572 OP *
2573 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl)
2574 {
2575     PMOP *pm;
2576     LOGOP *rcop;
2577     I32 repl_has_vars = 0;
2578
2579     if (o->op_type == OP_TRANS)
2580         return pmtrans(o, expr, repl);
2581
2582     PL_hints |= HINT_BLOCK_SCOPE;
2583     pm = (PMOP*)o;
2584
2585     if (expr->op_type == OP_CONST) {
2586         STRLEN plen;
2587         SV *pat = ((SVOP*)expr)->op_sv;
2588         char *p = SvPV(pat, plen);
2589         if ((o->op_flags & OPf_SPECIAL) && strEQ(p, " ")) {
2590             sv_setpvn(pat, "\\s+", 3);
2591             p = SvPV(pat, plen);
2592             pm->op_pmflags |= PMf_SKIPWHITE;
2593         }
2594         if (DO_UTF8(pat))
2595             pm->op_pmdynflags |= PMdf_UTF8;
2596         PM_SETRE(pm, CALLREGCOMP(aTHX_ p, p + plen, pm));
2597         if (strEQ("\\s+", PM_GETRE(pm)->precomp))
2598             pm->op_pmflags |= PMf_WHITE;
2599         op_free(expr);
2600     }
2601     else {
2602         if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
2603             expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
2604                             ? OP_REGCRESET
2605                             : OP_REGCMAYBE),0,expr);
2606
2607         NewOp(1101, rcop, 1, LOGOP);
2608         rcop->op_type = OP_REGCOMP;
2609         rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
2610         rcop->op_first = scalar(expr);
2611         rcop->op_flags |= ((PL_hints & HINT_RE_EVAL)
2612                            ? (OPf_SPECIAL | OPf_KIDS)
2613                            : OPf_KIDS);
2614         rcop->op_private = 1;
2615         rcop->op_other = o;
2616
2617         /* establish postfix order */
2618         if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
2619             LINKLIST(expr);
2620             rcop->op_next = expr;
2621             ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
2622         }
2623         else {
2624             rcop->op_next = LINKLIST(expr);
2625             expr->op_next = (OP*)rcop;
2626         }
2627
2628         prepend_elem(o->op_type, scalar((OP*)rcop), o);
2629     }
2630
2631     if (repl) {
2632         OP *curop;
2633         if (pm->op_pmflags & PMf_EVAL) {
2634             curop = 0;
2635             if (CopLINE(PL_curcop) < PL_multi_end)
2636                 CopLINE_set(PL_curcop, (line_t)PL_multi_end);
2637         }
2638         else if (repl->op_type == OP_CONST)
2639             curop = repl;
2640         else {
2641             OP *lastop = 0;
2642             for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
2643                 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
2644                     if (curop->op_type == OP_GV) {
2645                         GV *gv = cGVOPx_gv(curop);
2646                         repl_has_vars = 1;
2647                         if (strchr("&`'123456789+", *GvENAME(gv)))
2648                             break;
2649                     }
2650                     else if (curop->op_type == OP_RV2CV)
2651                         break;
2652                     else if (curop->op_type == OP_RV2SV ||
2653                              curop->op_type == OP_RV2AV ||
2654                              curop->op_type == OP_RV2HV ||
2655                              curop->op_type == OP_RV2GV) {
2656                         if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
2657                             break;
2658                     }
2659                     else if (curop->op_type == OP_PADSV ||
2660                              curop->op_type == OP_PADAV ||
2661                              curop->op_type == OP_PADHV ||
2662                              curop->op_type == OP_PADANY) {
2663                         repl_has_vars = 1;
2664                     }
2665                     else if (curop->op_type == OP_PUSHRE)
2666                         ; /* Okay here, dangerous in newASSIGNOP */
2667                     else
2668                         break;
2669                 }
2670                 lastop = curop;
2671             }
2672         }
2673         if (curop == repl
2674             && !(repl_has_vars
2675                  && (!PM_GETRE(pm)
2676                      || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
2677             pm->op_pmflags |= PMf_CONST;        /* const for long enough */
2678             pm->op_pmpermflags |= PMf_CONST;    /* const for long enough */
2679             prepend_elem(o->op_type, scalar(repl), o);
2680         }
2681         else {
2682             if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
2683                 pm->op_pmflags |= PMf_MAYBE_CONST;
2684                 pm->op_pmpermflags |= PMf_MAYBE_CONST;
2685             }
2686             NewOp(1101, rcop, 1, LOGOP);
2687             rcop->op_type = OP_SUBSTCONT;
2688             rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
2689             rcop->op_first = scalar(repl);
2690             rcop->op_flags |= OPf_KIDS;
2691             rcop->op_private = 1;
2692             rcop->op_other = o;
2693
2694             /* establish postfix order */
2695             rcop->op_next = LINKLIST(repl);
2696             repl->op_next = (OP*)rcop;
2697
2698             pm->op_pmreplroot = scalar((OP*)rcop);
2699             pm->op_pmreplstart = LINKLIST(rcop);
2700             rcop->op_next = 0;
2701         }
2702     }
2703
2704     return (OP*)pm;
2705 }
2706
2707 OP *
2708 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
2709 {
2710     SVOP *svop;
2711     NewOp(1101, svop, 1, SVOP);
2712     svop->op_type = (OPCODE)type;
2713     svop->op_ppaddr = PL_ppaddr[type];
2714     svop->op_sv = sv;
2715     svop->op_next = (OP*)svop;
2716     svop->op_flags = (U8)flags;
2717     if (PL_opargs[type] & OA_RETSCALAR)
2718         scalar((OP*)svop);
2719     if (PL_opargs[type] & OA_TARGET)
2720         svop->op_targ = pad_alloc(type, SVs_PADTMP);
2721     return CHECKOP(type, svop);
2722 }
2723
2724 OP *
2725 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
2726 {
2727     PADOP *padop;
2728     NewOp(1101, padop, 1, PADOP);
2729     padop->op_type = (OPCODE)type;
2730     padop->op_ppaddr = PL_ppaddr[type];
2731     padop->op_padix = pad_alloc(type, SVs_PADTMP);
2732     SvREFCNT_dec(PAD_SVl(padop->op_padix));
2733     PAD_SETSV(padop->op_padix, sv);
2734     if (sv)
2735         SvPADTMP_on(sv);
2736     padop->op_next = (OP*)padop;
2737     padop->op_flags = (U8)flags;
2738     if (PL_opargs[type] & OA_RETSCALAR)
2739         scalar((OP*)padop);
2740     if (PL_opargs[type] & OA_TARGET)
2741         padop->op_targ = pad_alloc(type, SVs_PADTMP);
2742     return CHECKOP(type, padop);
2743 }
2744
2745 OP *
2746 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
2747 {
2748 #ifdef USE_ITHREADS
2749     if (gv)
2750         GvIN_PAD_on(gv);
2751     return newPADOP(type, flags, SvREFCNT_inc(gv));
2752 #else
2753     return newSVOP(type, flags, SvREFCNT_inc(gv));
2754 #endif
2755 }
2756
2757 OP *
2758 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
2759 {
2760     PVOP *pvop;
2761     NewOp(1101, pvop, 1, PVOP);
2762     pvop->op_type = (OPCODE)type;
2763     pvop->op_ppaddr = PL_ppaddr[type];
2764     pvop->op_pv = pv;
2765     pvop->op_next = (OP*)pvop;
2766     pvop->op_flags = (U8)flags;
2767     if (PL_opargs[type] & OA_RETSCALAR)
2768         scalar((OP*)pvop);
2769     if (PL_opargs[type] & OA_TARGET)
2770         pvop->op_targ = pad_alloc(type, SVs_PADTMP);
2771     return CHECKOP(type, pvop);
2772 }
2773
2774 void
2775 Perl_package(pTHX_ OP *o)
2776 {
2777     char *name;
2778     STRLEN len;
2779
2780     save_hptr(&PL_curstash);
2781     save_item(PL_curstname);
2782
2783     name = SvPV(cSVOPo->op_sv, len);
2784     PL_curstash = gv_stashpvn(name, len, TRUE);
2785     sv_setpvn(PL_curstname, name, len);
2786     op_free(o);
2787
2788     PL_hints |= HINT_BLOCK_SCOPE;
2789     PL_copline = NOLINE;
2790     PL_expect = XSTATE;
2791 }
2792
2793 void
2794 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg)
2795 {
2796     OP *pack;
2797     OP *imop;
2798     OP *veop;
2799
2800     if (id->op_type != OP_CONST)
2801         Perl_croak(aTHX_ "Module name must be constant");
2802
2803     veop = Nullop;
2804
2805     if (version != Nullop) {
2806         SV *vesv = ((SVOP*)version)->op_sv;
2807
2808         if (arg == Nullop && !SvNIOKp(vesv)) {
2809             arg = version;
2810         }
2811         else {
2812             OP *pack;
2813             SV *meth;
2814
2815             if (version->op_type != OP_CONST || !SvNIOKp(vesv))
2816                 Perl_croak(aTHX_ "Version number must be constant number");
2817
2818             /* Make copy of id so we don't free it twice */
2819             pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
2820
2821             /* Fake up a method call to VERSION */
2822             meth = newSVpvn("VERSION",7);
2823             sv_upgrade(meth, SVt_PVIV);
2824             (void)SvIOK_on(meth);
2825             PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
2826             veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
2827                             append_elem(OP_LIST,
2828                                         prepend_elem(OP_LIST, pack, list(version)),
2829                                         newSVOP(OP_METHOD_NAMED, 0, meth)));
2830         }
2831     }
2832
2833     /* Fake up an import/unimport */
2834     if (arg && arg->op_type == OP_STUB)
2835         imop = arg;             /* no import on explicit () */
2836     else if (SvNIOKp(((SVOP*)id)->op_sv)) {
2837         imop = Nullop;          /* use 5.0; */
2838     }
2839     else {
2840         SV *meth;
2841
2842         /* Make copy of id so we don't free it twice */
2843         pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
2844
2845         /* Fake up a method call to import/unimport */
2846         meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);
2847         (void)SvUPGRADE(meth, SVt_PVIV);
2848         (void)SvIOK_on(meth);
2849         PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
2850         imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
2851                        append_elem(OP_LIST,
2852                                    prepend_elem(OP_LIST, pack, list(arg)),
2853                                    newSVOP(OP_METHOD_NAMED, 0, meth)));
2854     }
2855
2856     /* Fake up the BEGIN {}, which does its thing immediately. */
2857     newATTRSUB(floor,
2858         newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
2859         Nullop,
2860         Nullop,
2861         append_elem(OP_LINESEQ,
2862             append_elem(OP_LINESEQ,
2863                 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, id)),
2864                 newSTATEOP(0, Nullch, veop)),
2865             newSTATEOP(0, Nullch, imop) ));
2866
2867     /* The "did you use incorrect case?" warning used to be here.
2868      * The problem is that on case-insensitive filesystems one
2869      * might get false positives for "use" (and "require"):
2870      * "use Strict" or "require CARP" will work.  This causes
2871      * portability problems for the script: in case-strict
2872      * filesystems the script will stop working.
2873      *
2874      * The "incorrect case" warning checked whether "use Foo"
2875      * imported "Foo" to your namespace, but that is wrong, too:
2876      * there is no requirement nor promise in the language that
2877      * a Foo.pm should or would contain anything in package "Foo".
2878      *
2879      * There is very little Configure-wise that can be done, either:
2880      * the case-sensitivity of the build filesystem of Perl does not
2881      * help in guessing the case-sensitivity of the runtime environment.
2882      */
2883
2884     PL_hints |= HINT_BLOCK_SCOPE;
2885     PL_copline = NOLINE;
2886     PL_expect = XSTATE;
2887 }
2888
2889 /*
2890 =head1 Embedding Functions
2891
2892 =for apidoc load_module
2893
2894 Loads the module whose name is pointed to by the string part of name.
2895 Note that the actual module name, not its filename, should be given.
2896 Eg, "Foo::Bar" instead of "Foo/Bar.pm".  flags can be any of
2897 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
2898 (or 0 for no flags). ver, if specified, provides version semantics
2899 similar to C<use Foo::Bar VERSION>.  The optional trailing SV*
2900 arguments can be used to specify arguments to the module's import()
2901 method, similar to C<use Foo::Bar VERSION LIST>.
2902
2903 =cut */
2904
2905 void
2906 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
2907 {
2908     va_list args;
2909     va_start(args, ver);
2910     vload_module(flags, name, ver, &args);
2911     va_end(args);
2912 }
2913
2914 #ifdef PERL_IMPLICIT_CONTEXT
2915 void
2916 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
2917 {
2918     dTHX;
2919     va_list args;
2920     va_start(args, ver);
2921     vload_module(flags, name, ver, &args);
2922     va_end(args);
2923 }
2924 #endif
2925
2926 void
2927 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
2928 {
2929     OP *modname, *veop, *imop;
2930
2931     modname = newSVOP(OP_CONST, 0, name);
2932     modname->op_private |= OPpCONST_BARE;
2933     if (ver) {
2934         veop = newSVOP(OP_CONST, 0, ver);
2935     }
2936     else
2937         veop = Nullop;
2938     if (flags & PERL_LOADMOD_NOIMPORT) {
2939         imop = sawparens(newNULLLIST());
2940     }
2941     else if (flags & PERL_LOADMOD_IMPORT_OPS) {
2942         imop = va_arg(*args, OP*);
2943     }
2944     else {
2945         SV *sv;
2946         imop = Nullop;
2947         sv = va_arg(*args, SV*);
2948         while (sv) {
2949             imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
2950             sv = va_arg(*args, SV*);
2951         }
2952     }
2953     {
2954         line_t ocopline = PL_copline;
2955         COP *ocurcop = PL_curcop;
2956         int oexpect = PL_expect;
2957
2958         utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
2959                 veop, modname, imop);
2960         PL_expect = oexpect;
2961         PL_copline = ocopline;
2962         PL_curcop = ocurcop;
2963     }
2964 }
2965
2966 OP *
2967 Perl_dofile(pTHX_ OP *term)
2968 {
2969     OP *doop;
2970     GV *gv;
2971
2972     gv = gv_fetchpv("do", FALSE, SVt_PVCV);
2973     if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
2974         gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
2975
2976     if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
2977         doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
2978                                append_elem(OP_LIST, term,
2979                                            scalar(newUNOP(OP_RV2CV, 0,
2980                                                           newGVOP(OP_GV, 0,
2981                                                                   gv))))));
2982     }
2983     else {
2984         doop = newUNOP(OP_DOFILE, 0, scalar(term));
2985     }
2986     return doop;
2987 }
2988
2989 OP *
2990 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
2991 {
2992     return newBINOP(OP_LSLICE, flags,
2993             list(force_list(subscript)),
2994             list(force_list(listval)) );
2995 }
2996
2997 STATIC I32
2998 S_list_assignment(pTHX_ register OP *o)
2999 {
3000     if (!o)
3001         return TRUE;
3002
3003     if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3004         o = cUNOPo->op_first;
3005
3006     if (o->op_type == OP_COND_EXPR) {
3007         I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3008         I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3009
3010         if (t && f)
3011             return TRUE;
3012         if (t || f)
3013             yyerror("Assignment to both a list and a scalar");
3014         return FALSE;
3015     }
3016
3017     if (o->op_type == OP_LIST &&
3018         (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR &&
3019         o->op_private & OPpLVAL_INTRO)
3020         return FALSE;
3021
3022     if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3023         o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3024         o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3025         return TRUE;
3026
3027     if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3028         return TRUE;
3029
3030     if (o->op_type == OP_RV2SV)
3031         return FALSE;
3032
3033     return FALSE;
3034 }
3035
3036 OP *
3037 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3038 {
3039     OP *o;
3040
3041     if (optype) {
3042         if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
3043             return newLOGOP(optype, 0,
3044                 mod(scalar(left), optype),
3045                 newUNOP(OP_SASSIGN, 0, scalar(right)));
3046         }
3047         else {
3048             return newBINOP(optype, OPf_STACKED,
3049                 mod(scalar(left), optype), scalar(right));
3050         }
3051     }
3052
3053     if (list_assignment(left)) {
3054         OP *curop;
3055
3056         PL_modcount = 0;
3057         PL_eval_start = right;  /* Grandfathering $[ assignment here.  Bletch.*/
3058         left = mod(left, OP_AASSIGN);
3059         if (PL_eval_start)
3060             PL_eval_start = 0;
3061         else {
3062             op_free(left);
3063             op_free(right);
3064             return Nullop;
3065         }
3066         curop = list(force_list(left));
3067         o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3068         o->op_private = (U8)(0 | (flags >> 8));
3069
3070         /* PL_generation sorcery:
3071          * an assignment like ($a,$b) = ($c,$d) is easier than
3072          * ($a,$b) = ($c,$a), since there is no need for temporary vars.
3073          * To detect whether there are common vars, the global var
3074          * PL_generation is incremented for each assign op we compile.
3075          * Then, while compiling the assign op, we run through all the
3076          * variables on both sides of the assignment, setting a spare slot
3077          * in each of them to PL_generation. If any of them already have
3078          * that value, we know we've got commonality.  We could use a
3079          * single bit marker, but then we'd have to make 2 passes, first
3080          * to clear the flag, then to test and set it.  To find somewhere
3081          * to store these values, evil chicanery is done with SvCUR().
3082          */
3083
3084         if (!(left->op_private & OPpLVAL_INTRO)) {
3085             OP *lastop = o;
3086             PL_generation++;
3087             for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3088                 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3089                     if (curop->op_type == OP_GV) {
3090                         GV *gv = cGVOPx_gv(curop);
3091                         if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3092                             break;
3093                         SvCUR(gv) = PL_generation;
3094                     }
3095                     else if (curop->op_type == OP_PADSV ||
3096                              curop->op_type == OP_PADAV ||
3097                              curop->op_type == OP_PADHV ||
3098                              curop->op_type == OP_PADANY)
3099                     {
3100                         if (PAD_COMPNAME_GEN(curop->op_targ)
3101                                                     == (STRLEN)PL_generation)
3102                             break;
3103                         PAD_COMPNAME_GEN(curop->op_targ)
3104                                                         = PL_generation;
3105
3106                     }
3107                     else if (curop->op_type == OP_RV2CV)
3108                         break;
3109                     else if (curop->op_type == OP_RV2SV ||
3110                              curop->op_type == OP_RV2AV ||
3111                              curop->op_type == OP_RV2HV ||
3112                              curop->op_type == OP_RV2GV) {
3113                         if (lastop->op_type != OP_GV)   /* funny deref? */
3114                             break;
3115                     }
3116                     else if (curop->op_type == OP_PUSHRE) {
3117                         if (((PMOP*)curop)->op_pmreplroot) {
3118 #ifdef USE_ITHREADS
3119                             GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET,
3120                                         ((PMOP*)curop)->op_pmreplroot));
3121 #else
3122                             GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3123 #endif
3124                             if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3125                                 break;
3126                             SvCUR(gv) = PL_generation;
3127                         }
3128                     }
3129                     else
3130                         break;
3131                 }
3132                 lastop = curop;
3133             }
3134             if (curop != o)
3135                 o->op_private |= OPpASSIGN_COMMON;
3136         }
3137         if (right && right->op_type == OP_SPLIT) {
3138             OP* tmpop;
3139             if ((tmpop = ((LISTOP*)right)->op_first) &&
3140                 tmpop->op_type == OP_PUSHRE)
3141             {
3142                 PMOP *pm = (PMOP*)tmpop;
3143                 if (left->op_type == OP_RV2AV &&
3144                     !(left->op_private & OPpLVAL_INTRO) &&
3145                     !(o->op_private & OPpASSIGN_COMMON) )
3146                 {
3147                     tmpop = ((UNOP*)left)->op_first;
3148                     if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3149 #ifdef USE_ITHREADS
3150                         pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
3151                         cPADOPx(tmpop)->op_padix = 0;   /* steal it */
3152 #else
3153                         pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3154                         cSVOPx(tmpop)->op_sv = Nullsv;  /* steal it */
3155 #endif
3156                         pm->op_pmflags |= PMf_ONCE;
3157                         tmpop = cUNOPo->op_first;       /* to list (nulled) */
3158                         tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3159                         tmpop->op_sibling = Nullop;     /* don't free split */
3160                         right->op_next = tmpop->op_next;  /* fix starting loc */
3161                         op_free(o);                     /* blow off assign */
3162                         right->op_flags &= ~OPf_WANT;
3163                                 /* "I don't know and I don't care." */
3164                         return right;
3165                     }
3166                 }
3167                 else {
3168                    if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3169                       ((LISTOP*)right)->op_last->op_type == OP_CONST)
3170                     {
3171                         SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3172                         if (SvIVX(sv) == 0)
3173                             sv_setiv(sv, PL_modcount+1);
3174                     }
3175                 }
3176             }
3177         }
3178         return o;
3179     }
3180     if (!right)
3181         right = newOP(OP_UNDEF, 0);
3182     if (right->op_type == OP_READLINE) {
3183         right->op_flags |= OPf_STACKED;
3184         return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3185     }
3186     else {
3187         PL_eval_start = right;  /* Grandfathering $[ assignment here.  Bletch.*/
3188         o = newBINOP(OP_SASSIGN, flags,
3189             scalar(right), mod(scalar(left), OP_SASSIGN) );
3190         if (PL_eval_start)
3191             PL_eval_start = 0;
3192         else {
3193             op_free(o);
3194             return Nullop;
3195         }
3196     }
3197     return o;
3198 }
3199
3200 OP *
3201 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3202 {
3203     U32 seq = intro_my();
3204     register COP *cop;
3205
3206     NewOp(1101, cop, 1, COP);
3207     if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3208         cop->op_type = OP_DBSTATE;
3209         cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3210     }
3211     else {
3212         cop->op_type = OP_NEXTSTATE;
3213         cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3214     }
3215     cop->op_flags = (U8)flags;
3216     cop->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
3217 #ifdef NATIVE_HINTS
3218     cop->op_private |= NATIVE_HINTS;
3219 #endif
3220     PL_compiling.op_private = cop->op_private;
3221     cop->op_next = (OP*)cop;
3222
3223     if (label) {
3224         cop->cop_label = label;
3225         PL_hints |= HINT_BLOCK_SCOPE;
3226     }
3227     cop->cop_seq = seq;
3228     cop->cop_arybase = PL_curcop->cop_arybase;
3229     if (specialWARN(PL_curcop->cop_warnings))
3230         cop->cop_warnings = PL_curcop->cop_warnings ;
3231     else
3232         cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3233     if (specialCopIO(PL_curcop->cop_io))
3234         cop->cop_io = PL_curcop->cop_io;
3235     else
3236         cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3237
3238
3239     if (PL_copline == NOLINE)
3240         CopLINE_set(cop, CopLINE(PL_curcop));
3241     else {
3242         CopLINE_set(cop, PL_copline);
3243         PL_copline = NOLINE;
3244     }
3245 #ifdef USE_ITHREADS
3246     CopFILE_set(cop, CopFILE(PL_curcop));       /* XXX share in a pvtable? */
3247 #else
3248     CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3249 #endif
3250     CopSTASH_set(cop, PL_curstash);
3251
3252     if (PERLDB_LINE && PL_curstash != PL_debstash) {
3253         SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3254         if (svp && *svp != &PL_sv_undef ) {
3255            (void)SvIOK_on(*svp);
3256             SvIVX(*svp) = PTR2IV(cop);
3257         }
3258     }
3259
3260     return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3261 }
3262
3263
3264 OP *
3265 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3266 {
3267     return new_logop(type, flags, &first, &other);
3268 }
3269
3270 STATIC OP *
3271 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3272 {
3273     LOGOP *logop;
3274     OP *o;
3275     OP *first = *firstp;
3276     OP *other = *otherp;
3277
3278     if (type == OP_XOR)         /* Not short circuit, but here by precedence. */
3279         return newBINOP(type, flags, scalar(first), scalar(other));
3280
3281     scalarboolean(first);
3282     /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3283     if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3284         if (type == OP_AND || type == OP_OR) {
3285             if (type == OP_AND)
3286                 type = OP_OR;
3287             else
3288                 type = OP_AND;
3289             o = first;
3290             first = *firstp = cUNOPo->op_first;
3291             if (o->op_next)
3292                 first->op_next = o->op_next;
3293             cUNOPo->op_first = Nullop;
3294             op_free(o);
3295         }
3296     }
3297     if (first->op_type == OP_CONST) {
3298         if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE)) {
3299             if (first->op_private & OPpCONST_STRICT)
3300                 no_bareword_allowed(first);
3301             else
3302                 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
3303         }
3304         if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
3305             op_free(first);
3306             *firstp = Nullop;
3307             return other;
3308         }
3309         else {
3310             op_free(other);
3311             *otherp = Nullop;
3312             return first;
3313         }
3314     }
3315     else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS)) {
3316         OP *k1 = ((UNOP*)first)->op_first;
3317         OP *k2 = k1->op_sibling;
3318         OPCODE warnop = 0;
3319         switch (first->op_type)
3320         {
3321         case OP_NULL:
3322             if (k2 && k2->op_type == OP_READLINE
3323                   && (k2->op_flags & OPf_STACKED)
3324                   && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3325             {
3326                 warnop = k2->op_type;
3327             }
3328             break;
3329
3330         case OP_SASSIGN:
3331             if (k1->op_type == OP_READDIR
3332                   || k1->op_type == OP_GLOB
3333                   || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3334                   || k1->op_type == OP_EACH)
3335             {
3336                 warnop = ((k1->op_type == OP_NULL)
3337                           ? (OPCODE)k1->op_targ : k1->op_type);
3338             }
3339             break;
3340         }
3341         if (warnop) {
3342             line_t oldline = CopLINE(PL_curcop);
3343             CopLINE_set(PL_curcop, PL_copline);
3344             Perl_warner(aTHX_ packWARN(WARN_MISC),
3345                  "Value of %s%s can be \"0\"; test with defined()",
3346                  PL_op_desc[warnop],
3347                  ((warnop == OP_READLINE || warnop == OP_GLOB)
3348                   ? " construct" : "() operator"));
3349             CopLINE_set(PL_curcop, oldline);
3350         }
3351     }
3352
3353     if (!other)
3354         return first;
3355
3356     if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
3357         other->op_private |= OPpASSIGN_BACKWARDS;  /* other is an OP_SASSIGN */
3358
3359     NewOp(1101, logop, 1, LOGOP);
3360
3361     logop->op_type = (OPCODE)type;
3362     logop->op_ppaddr = PL_ppaddr[type];
3363     logop->op_first = first;
3364     logop->op_flags = flags | OPf_KIDS;
3365     logop->op_other = LINKLIST(other);
3366     logop->op_private = (U8)(1 | (flags >> 8));
3367
3368     /* establish postfix order */
3369     logop->op_next = LINKLIST(first);
3370     first->op_next = (OP*)logop;
3371     first->op_sibling = other;
3372
3373     o = newUNOP(OP_NULL, 0, (OP*)logop);
3374     other->op_next = o;
3375
3376     return o;
3377 }
3378
3379 OP *
3380 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3381 {
3382     LOGOP *logop;
3383     OP *start;
3384     OP *o;
3385
3386     if (!falseop)
3387         return newLOGOP(OP_AND, 0, first, trueop);
3388     if (!trueop)
3389         return newLOGOP(OP_OR, 0, first, falseop);
3390
3391     scalarboolean(first);
3392     if (first->op_type == OP_CONST) {
3393         if (first->op_private & OPpCONST_BARE &&
3394            first->op_private & OPpCONST_STRICT) {
3395            no_bareword_allowed(first);
3396        }
3397         if (SvTRUE(((SVOP*)first)->op_sv)) {
3398             op_free(first);
3399             op_free(falseop);
3400             return trueop;
3401         }
3402         else {
3403             op_free(first);
3404             op_free(trueop);
3405             return falseop;
3406         }
3407     }
3408     NewOp(1101, logop, 1, LOGOP);
3409     logop->op_type = OP_COND_EXPR;
3410     logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3411     logop->op_first = first;
3412     logop->op_flags = flags | OPf_KIDS;
3413     logop->op_private = (U8)(1 | (flags >> 8));
3414     logop->op_other = LINKLIST(trueop);
3415     logop->op_next = LINKLIST(falseop);
3416
3417
3418     /* establish postfix order */
3419     start = LINKLIST(first);
3420     first->op_next = (OP*)logop;
3421
3422     first->op_sibling = trueop;
3423     trueop->op_sibling = falseop;
3424     o = newUNOP(OP_NULL, 0, (OP*)logop);
3425
3426     trueop->op_next = falseop->op_next = o;
3427
3428     o->op_next = start;
3429     return o;
3430 }
3431
3432 OP *
3433 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3434 {
3435     LOGOP *range;
3436     OP *flip;
3437     OP *flop;
3438     OP *leftstart;
3439     OP *o;
3440
3441     NewOp(1101, range, 1, LOGOP);
3442
3443     range->op_type = OP_RANGE;
3444     range->op_ppaddr = PL_ppaddr[OP_RANGE];
3445     range->op_first = left;
3446     range->op_flags = OPf_KIDS;
3447     leftstart = LINKLIST(left);
3448     range->op_other = LINKLIST(right);
3449     range->op_private = (U8)(1 | (flags >> 8));
3450
3451     left->op_sibling = right;
3452
3453     range->op_next = (OP*)range;
3454     flip = newUNOP(OP_FLIP, flags, (OP*)range);
3455     flop = newUNOP(OP_FLOP, 0, flip);
3456     o = newUNOP(OP_NULL, 0, flop);
3457     linklist(flop);
3458     range->op_next = leftstart;
3459
3460     left->op_next = flip;
3461     right->op_next = flop;
3462
3463     range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3464     sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3465     flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3466     sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3467
3468     flip->op_private =  left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3469     flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3470
3471     flip->op_next = o;
3472     if (!flip->op_private || !flop->op_private)
3473         linklist(o);            /* blow off optimizer unless constant */
3474
3475     return o;
3476 }
3477
3478 OP *
3479 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3480 {
3481     OP* listop;
3482     OP* o;
3483     int once = block && block->op_flags & OPf_SPECIAL &&
3484       (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3485
3486     if (expr) {
3487         if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3488             return block;       /* do {} while 0 does once */
3489         if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3490             || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3491             expr = newUNOP(OP_DEFINED, 0,
3492                 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3493         } else if (expr->op_flags & OPf_KIDS) {
3494             OP *k1 = ((UNOP*)expr)->op_first;
3495             OP *k2 = (k1) ? k1->op_sibling : NULL;
3496             switch (expr->op_type) {
3497               case OP_NULL:
3498                 if (k2 && k2->op_type == OP_READLINE
3499                       && (k2->op_flags & OPf_STACKED)
3500                       && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3501                     expr = newUNOP(OP_DEFINED, 0, expr);
3502                 break;
3503
3504               case OP_SASSIGN:
3505                 if (k1->op_type == OP_READDIR
3506                       || k1->op_type == OP_GLOB
3507                       || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3508                       || k1->op_type == OP_EACH)
3509                     expr = newUNOP(OP_DEFINED, 0, expr);
3510                 break;
3511             }
3512         }
3513     }
3514
3515     listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3516     o = new_logop(OP_AND, 0, &expr, &listop);
3517
3518     if (listop)
3519         ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3520
3521     if (once && o != listop)
3522         o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3523
3524     if (o == listop)
3525         o = newUNOP(OP_NULL, 0, o);     /* or do {} while 1 loses outer block */
3526
3527     o->op_flags |= flags;
3528     o = scope(o);
3529     o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3530     return o;
3531 }
3532
3533 OP *
3534 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
3535 {
3536     OP *redo;
3537     OP *next = 0;
3538     OP *listop;
3539     OP *o;
3540     U8 loopflags = 0;
3541
3542     if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3543                  || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
3544         expr = newUNOP(OP_DEFINED, 0,
3545             newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3546     } else if (expr && (expr->op_flags & OPf_KIDS)) {
3547         OP *k1 = ((UNOP*)expr)->op_first;
3548         OP *k2 = (k1) ? k1->op_sibling : NULL;
3549         switch (expr->op_type) {
3550           case OP_NULL:
3551             if (k2 && k2->op_type == OP_READLINE
3552                   && (k2->op_flags & OPf_STACKED)
3553                   && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3554                 expr = newUNOP(OP_DEFINED, 0, expr);
3555             break;
3556
3557           case OP_SASSIGN:
3558             if (k1->op_type == OP_READDIR
3559                   || k1->op_type == OP_GLOB
3560                   || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3561                   || k1->op_type == OP_EACH)
3562                 expr = newUNOP(OP_DEFINED, 0, expr);
3563             break;
3564         }
3565     }
3566
3567     if (!block)
3568         block = newOP(OP_NULL, 0);
3569     else if (cont) {
3570         block = scope(block);
3571     }
3572
3573     if (cont) {
3574         next = LINKLIST(cont);
3575     }
3576     if (expr) {
3577         OP *unstack = newOP(OP_UNSTACK, 0);
3578         if (!next)
3579             next = unstack;
3580         cont = append_elem(OP_LINESEQ, cont, unstack);
3581         if ((line_t)whileline != NOLINE) {
3582             PL_copline = (line_t)whileline;
3583             cont = append_elem(OP_LINESEQ, cont,
3584                                newSTATEOP(0, Nullch, Nullop));
3585         }
3586     }
3587
3588     listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
3589     redo = LINKLIST(listop);
3590
3591     if (expr) {
3592         PL_copline = (line_t)whileline;
3593         scalar(listop);
3594         o = new_logop(OP_AND, 0, &expr, &listop);
3595         if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
3596             op_free(expr);              /* oops, it's a while (0) */
3597             op_free((OP*)loop);
3598             return Nullop;              /* listop already freed by new_logop */
3599         }
3600         if (listop)
3601             ((LISTOP*)listop)->op_last->op_next =
3602                 (o == listop ? redo : LINKLIST(o));
3603     }
3604     else
3605         o = listop;
3606
3607     if (!loop) {
3608         NewOp(1101,loop,1,LOOP);
3609         loop->op_type = OP_ENTERLOOP;
3610         loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
3611         loop->op_private = 0;
3612         loop->op_next = (OP*)loop;
3613     }
3614
3615     o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
3616
3617     loop->op_redoop = redo;
3618     loop->op_lastop = o;
3619     o->op_private |= loopflags;
3620
3621     if (next)
3622         loop->op_nextop = next;
3623     else
3624         loop->op_nextop = o;
3625
3626     o->op_flags |= flags;
3627     o->op_private |= (flags >> 8);
3628     return o;
3629 }
3630
3631 OP *
3632 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
3633 {
3634     LOOP *loop;
3635     OP *wop;
3636     PADOFFSET padoff = 0;
3637     I32 iterflags = 0;
3638
3639     if (sv) {
3640         if (sv->op_type == OP_RV2SV) {  /* symbol table variable */
3641             sv->op_type = OP_RV2GV;
3642             sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
3643         }
3644         else if (sv->op_type == OP_PADSV) { /* private variable */
3645             padoff = sv->op_targ;
3646             sv->op_targ = 0;
3647             op_free(sv);
3648             sv = Nullop;
3649         }
3650         else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
3651             padoff = sv->op_targ;
3652             sv->op_targ = 0;
3653             iterflags |= OPf_SPECIAL;
3654             op_free(sv);
3655             sv = Nullop;
3656         }
3657         else
3658             Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
3659     }
3660     else {
3661         sv = newGVOP(OP_GV, 0, PL_defgv);
3662     }
3663     if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
3664         expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
3665         iterflags |= OPf_STACKED;
3666     }
3667     else if (expr->op_type == OP_NULL &&
3668              (expr->op_flags & OPf_KIDS) &&
3669              ((BINOP*)expr)->op_first->op_type == OP_FLOP)
3670     {
3671         /* Basically turn for($x..$y) into the same as for($x,$y), but we
3672          * set the STACKED flag to indicate that these values are to be
3673          * treated as min/max values by 'pp_iterinit'.
3674          */
3675         UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
3676         LOGOP* range = (LOGOP*) flip->op_first;
3677         OP* left  = range->op_first;
3678         OP* right = left->op_sibling;
3679         LISTOP* listop;
3680
3681         range->op_flags &= ~OPf_KIDS;
3682         range->op_first = Nullop;
3683
3684         listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
3685         listop->op_first->op_next = range->op_next;
3686         left->op_next = range->op_other;
3687         right->op_next = (OP*)listop;
3688         listop->op_next = listop->op_first;
3689
3690         op_free(expr);
3691         expr = (OP*)(listop);
3692         op_null(expr);
3693         iterflags |= OPf_STACKED;
3694     }
3695     else {
3696         expr = mod(force_list(expr), OP_GREPSTART);
3697     }
3698
3699
3700     loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
3701                                append_elem(OP_LIST, expr, scalar(sv))));
3702     assert(!loop->op_next);
3703 #ifdef PL_OP_SLAB_ALLOC
3704     {
3705         LOOP *tmp;
3706         NewOp(1234,tmp,1,LOOP);
3707         Copy(loop,tmp,1,LOOP);
3708         FreeOp(loop);
3709         loop = tmp;
3710     }
3711 #else
3712     Renew(loop, 1, LOOP);
3713 #endif
3714     loop->op_targ = padoff;
3715     wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
3716     PL_copline = forline;
3717     return newSTATEOP(0, label, wop);
3718 }
3719
3720 OP*
3721 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
3722 {
3723     OP *o;
3724     STRLEN n_a;
3725
3726     if (type != OP_GOTO || label->op_type == OP_CONST) {
3727         /* "last()" means "last" */
3728         if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
3729             o = newOP(type, OPf_SPECIAL);
3730         else {
3731             o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
3732                                         ? SvPVx(((SVOP*)label)->op_sv, n_a)
3733                                         : ""));
3734         }
3735         op_free(label);
3736     }
3737     else {
3738         if (label->op_type == OP_ENTERSUB)
3739             label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
3740         o = newUNOP(type, OPf_STACKED, label);
3741     }
3742     PL_hints |= HINT_BLOCK_SCOPE;
3743     return o;
3744 }
3745
3746 /*
3747 =for apidoc cv_undef
3748
3749 Clear out all the active components of a CV. This can happen either
3750 by an explicit C<undef &foo>, or by the reference count going to zero.
3751 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
3752 children can still follow the full lexical scope chain.
3753
3754 =cut
3755 */
3756
3757 void
3758 Perl_cv_undef(pTHX_ CV *cv)
3759 {
3760 #ifdef USE_ITHREADS
3761     if (CvFILE(cv) && !CvXSUB(cv)) {
3762         /* for XSUBs CvFILE point directly to static memory; __FILE__ */
3763         Safefree(CvFILE(cv));
3764     }
3765     CvFILE(cv) = 0;
3766 #endif
3767
3768     if (!CvXSUB(cv) && CvROOT(cv)) {
3769         if (CvDEPTH(cv))
3770             Perl_croak(aTHX_ "Can't undef active subroutine");
3771         ENTER;
3772
3773         PAD_SAVE_SETNULLPAD();
3774
3775         op_free(CvROOT(cv));
3776         CvROOT(cv) = Nullop;
3777         LEAVE;
3778     }
3779     SvPOK_off((SV*)cv);         /* forget prototype */
3780     CvGV(cv) = Nullgv;
3781
3782     pad_undef(cv);
3783
3784     /* remove CvOUTSIDE unless this is an undef rather than a free */
3785     if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
3786         if (!CvWEAKOUTSIDE(cv))
3787             SvREFCNT_dec(CvOUTSIDE(cv));
3788         CvOUTSIDE(cv) = Nullcv;
3789     }
3790     if (CvCONST(cv)) {
3791         SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
3792         CvCONST_off(cv);
3793     }
3794     if (CvXSUB(cv)) {
3795         CvXSUB(cv) = 0;
3796     }
3797     /* delete all flags except WEAKOUTSIDE */
3798     CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
3799 }
3800
3801 void
3802 Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
3803 {
3804     if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
3805         SV* msg = sv_newmortal();
3806         SV* name = Nullsv;
3807
3808         if (gv)
3809             gv_efullname3(name = sv_newmortal(), gv, Nullch);
3810         sv_setpv(msg, "Prototype mismatch:");
3811         if (name)
3812             Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
3813         if (SvPOK(cv))
3814             Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (SV *)cv);
3815         sv_catpv(msg, " vs ");
3816         if (p)
3817             Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
3818         else
3819             sv_catpv(msg, "none");
3820         Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, msg);
3821     }
3822 }
3823
3824 static void const_sv_xsub(pTHX_ CV* cv);
3825
3826 /*
3827
3828 =head1 Optree Manipulation Functions
3829
3830 =for apidoc cv_const_sv
3831
3832 If C<cv> is a constant sub eligible for inlining. returns the constant
3833 value returned by the sub.  Otherwise, returns NULL.
3834
3835 Constant subs can be created with C<newCONSTSUB> or as described in
3836 L<perlsub/"Constant Functions">.
3837
3838 =cut
3839 */
3840 SV *
3841 Perl_cv_const_sv(pTHX_ CV *cv)
3842 {
3843     if (!cv || !CvCONST(cv))
3844         return Nullsv;
3845     return (SV*)CvXSUBANY(cv).any_ptr;
3846 }
3847
3848 SV *
3849 Perl_op_const_sv(pTHX_ OP *o, CV *cv)
3850 {
3851     SV *sv = Nullsv;
3852
3853     if (!o)
3854         return Nullsv;
3855
3856     if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
3857         o = cLISTOPo->op_first->op_sibling;
3858
3859     for (; o; o = o->op_next) {
3860         OPCODE type = o->op_type;
3861
3862         if (sv && o->op_next == o)
3863             return sv;
3864         if (o->op_next != o) {
3865             if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
3866                 continue;
3867             if (type == OP_DBSTATE)
3868                 continue;
3869         }
3870         if (type == OP_LEAVESUB || type == OP_RETURN)
3871             break;
3872         if (sv)
3873             return Nullsv;
3874         if (type == OP_CONST && cSVOPo->op_sv)
3875             sv = cSVOPo->op_sv;
3876         else if ((type == OP_PADSV || type == OP_CONST) && cv) {
3877             sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
3878             if (!sv)
3879                 return Nullsv;
3880             if (CvCONST(cv)) {
3881                 /* We get here only from cv_clone2() while creating a closure.
3882                    Copy the const value here instead of in cv_clone2 so that
3883                    SvREADONLY_on doesn't lead to problems when leaving
3884                    scope.
3885                 */
3886                 sv = newSVsv(sv);
3887             }
3888             if (!SvREADONLY(sv) && SvREFCNT(sv) > 1)
3889                 return Nullsv;
3890         }
3891         else
3892             return Nullsv;
3893     }
3894     if (sv)
3895         SvREADONLY_on(sv);
3896     return sv;
3897 }
3898
3899 void
3900 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
3901 {
3902     if (o)
3903         SAVEFREEOP(o);
3904     if (proto)
3905         SAVEFREEOP(proto);
3906     if (attrs)
3907         SAVEFREEOP(attrs);
3908     if (block)
3909         SAVEFREEOP(block);
3910     Perl_croak(aTHX_ "\"my sub\" not yet implemented");
3911 }
3912
3913 CV *
3914 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
3915 {
3916     return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
3917 }
3918
3919 CV *
3920 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
3921 {
3922     STRLEN n_a;
3923     char *name;
3924     char *aname;
3925     GV *gv;
3926     char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
3927     register CV *cv=0;
3928     SV *const_sv;
3929
3930     name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
3931     if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
3932         SV *sv = sv_newmortal();
3933         Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
3934                        PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
3935                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3936         aname = SvPVX(sv);
3937     }
3938     else
3939         aname = Nullch;
3940     gv = gv_fetchpv(name ? name : (aname ? aname :
3941                     (PL_curstash ? "__ANON__" : "__ANON__::__ANON__")),
3942                     GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
3943                     SVt_PVCV);
3944
3945     if (o)
3946         SAVEFREEOP(o);
3947     if (proto)
3948         SAVEFREEOP(proto);
3949     if (attrs)
3950         SAVEFREEOP(attrs);
3951
3952     if (SvTYPE(gv) != SVt_PVGV) {       /* Maybe prototype now, and had at
3953                                            maximum a prototype before. */
3954         if (SvTYPE(gv) > SVt_NULL) {
3955             if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
3956                 && ckWARN_d(WARN_PROTOTYPE))
3957             {
3958                 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
3959             }
3960             cv_ckproto((CV*)gv, NULL, ps);
3961         }
3962         if (ps)
3963             sv_setpv((SV*)gv, ps);
3964         else
3965             sv_setiv((SV*)gv, -1);
3966         SvREFCNT_dec(PL_compcv);
3967         cv = PL_compcv = NULL;
3968         PL_sub_generation++;
3969         goto done;
3970     }
3971
3972     cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
3973
3974 #ifdef GV_UNIQUE_CHECK
3975     if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
3976         Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
3977     }
3978 #endif
3979
3980     if (!block || !ps || *ps || attrs)
3981         const_sv = Nullsv;
3982     else
3983         const_sv = op_const_sv(block, Nullcv);
3984
3985     if (cv) {
3986         bool exists = CvROOT(cv) || CvXSUB(cv);
3987
3988 #ifdef GV_UNIQUE_CHECK
3989         if (exists && GvUNIQUE(gv)) {
3990             Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
3991         }
3992 #endif
3993
3994         /* if the subroutine doesn't exist and wasn't pre-declared
3995          * with a prototype, assume it will be AUTOLOADed,
3996          * skipping the prototype check
3997          */
3998         if (exists || SvPOK(cv))
3999             cv_ckproto(cv, gv, ps);
4000         /* already defined (or promised)? */
4001         if (exists || GvASSUMECV(gv)) {
4002             if (!block && !attrs) {
4003                 if (CvFLAGS(PL_compcv)) {
4004                     /* might have had built-in attrs applied */
4005                     CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4006                 }
4007                 /* just a "sub foo;" when &foo is already defined */
4008                 SAVEFREESV(PL_compcv);
4009                 goto done;
4010             }
4011             /* ahem, death to those who redefine active sort subs */
4012             if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4013                 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4014             if (block) {
4015                 if (ckWARN(WARN_REDEFINE)
4016                     || (CvCONST(cv)
4017                         && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4018                 {
4019                     line_t oldline = CopLINE(PL_curcop);
4020                     if (PL_copline != NOLINE)
4021                         CopLINE_set(PL_curcop, PL_copline);
4022                     Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4023                         CvCONST(cv) ? "Constant subroutine %s redefined"
4024                                     : "Subroutine %s redefined", name);
4025                     CopLINE_set(PL_curcop, oldline);
4026                 }
4027                 SvREFCNT_dec(cv);
4028                 cv = Nullcv;
4029             }
4030         }
4031     }
4032     if (const_sv) {
4033         SvREFCNT_inc(const_sv);
4034         if (cv) {
4035             assert(!CvROOT(cv) && !CvCONST(cv));
4036             sv_setpv((SV*)cv, "");  /* prototype is "" */
4037             CvXSUBANY(cv).any_ptr = const_sv;
4038             CvXSUB(cv) = const_sv_xsub;
4039             CvCONST_on(cv);
4040         }
4041         else {
4042             GvCV(gv) = Nullcv;
4043             cv = newCONSTSUB(NULL, name, const_sv);
4044         }
4045         op_free(block);
4046         SvREFCNT_dec(PL_compcv);
4047         PL_compcv = NULL;
4048         PL_sub_generation++;
4049         goto done;
4050     }
4051     if (attrs) {
4052         HV *stash;
4053         SV *rcv;
4054
4055         /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4056          * before we clobber PL_compcv.
4057          */
4058         if (cv && !block) {
4059             rcv = (SV*)cv;
4060             /* Might have had built-in attributes applied -- propagate them. */
4061             CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4062             if (CvGV(cv) && GvSTASH(CvGV(cv)))
4063                 stash = GvSTASH(CvGV(cv));
4064             else if (CvSTASH(cv))
4065                 stash = CvSTASH(cv);
4066             else
4067                 stash = PL_curstash;
4068         }
4069         else {
4070             /* possibly about to re-define existing subr -- ignore old cv */
4071             rcv = (SV*)PL_compcv;
4072             if (name && GvSTASH(gv))
4073                 stash = GvSTASH(gv);
4074             else
4075                 stash = PL_curstash;
4076         }
4077         apply_attrs(stash, rcv, attrs, FALSE);
4078     }
4079     if (cv) {                           /* must reuse cv if autoloaded */
4080         if (!block) {
4081             /* got here with just attrs -- work done, so bug out */
4082             SAVEFREESV(PL_compcv);
4083             goto done;
4084         }
4085         /* transfer PL_compcv to cv */
4086         cv_undef(cv);
4087         CvFLAGS(cv) = CvFLAGS(PL_compcv);
4088         CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4089         CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
4090         CvOUTSIDE(PL_compcv) = 0;
4091         CvPADLIST(cv) = CvPADLIST(PL_compcv);
4092         CvPADLIST(PL_compcv) = 0;
4093         /* inner references to PL_compcv must be fixed up ... */
4094         pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
4095         /* ... before we throw it away */
4096         SvREFCNT_dec(PL_compcv);
4097         if (PERLDB_INTER)/* Advice debugger on the new sub. */
4098           ++PL_sub_generation;
4099     }
4100     else {
4101         cv = PL_compcv;
4102         if (name) {
4103             GvCV(gv) = cv;
4104             GvCVGEN(gv) = 0;
4105             PL_sub_generation++;
4106         }
4107     }
4108     CvGV(cv) = gv;
4109     CvFILE_set_from_cop(cv, PL_curcop);
4110     CvSTASH(cv) = PL_curstash;
4111
4112     if (ps)
4113         sv_setpv((SV*)cv, ps);
4114
4115     if (PL_error_count) {
4116         op_free(block);
4117         block = Nullop;
4118         if (name) {
4119             char *s = strrchr(name, ':');
4120             s = s ? s+1 : name;
4121             if (strEQ(s, "BEGIN")) {
4122                 char *not_safe =
4123                     "BEGIN not safe after errors--compilation aborted";
4124                 if (PL_in_eval & EVAL_KEEPERR)
4125                     Perl_croak(aTHX_ not_safe);
4126                 else {
4127                     /* force display of errors found but not reported */
4128                     sv_catpv(ERRSV, not_safe);
4129                     Perl_croak(aTHX_ "%"SVf, ERRSV);
4130                 }
4131             }
4132         }
4133     }
4134     if (!block)
4135         goto done;
4136
4137     if (CvLVALUE(cv)) {
4138         CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4139                              mod(scalarseq(block), OP_LEAVESUBLV));
4140     }
4141     else {
4142         CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4143     }
4144     CvROOT(cv)->op_private |= OPpREFCOUNTED;
4145     OpREFCNT_set(CvROOT(cv), 1);
4146     CvSTART(cv) = LINKLIST(CvROOT(cv));
4147     CvROOT(cv)->op_next = 0;
4148     CALL_PEEP(CvSTART(cv));
4149
4150     /* now that optimizer has done its work, adjust pad values */
4151
4152     pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
4153
4154     if (CvCLONE(cv)) {
4155         assert(!CvCONST(cv));
4156         if (ps && !*ps && op_const_sv(block, cv))
4157             CvCONST_on(cv);
4158     }
4159
4160     if (name || aname) {
4161         char *s;
4162         char *tname = (name ? name : aname);
4163
4164         if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4165             SV *sv = NEWSV(0,0);
4166             SV *tmpstr = sv_newmortal();
4167             GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4168             CV *pcv;
4169             HV *hv;
4170
4171             Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4172                            CopFILE(PL_curcop),
4173                            (long)PL_subline, (long)CopLINE(PL_curcop));
4174             gv_efullname3(tmpstr, gv, Nullch);
4175             hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
4176             hv = GvHVn(db_postponed);
4177             if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
4178                 && (pcv = GvCV(db_postponed)))
4179             {
4180                 dSP;
4181                 PUSHMARK(SP);
4182                 XPUSHs(tmpstr);
4183                 PUTBACK;
4184                 call_sv((SV*)pcv, G_DISCARD);
4185             }
4186         }
4187
4188         if ((s = strrchr(tname,':')))
4189             s++;
4190         else
4191             s = tname;
4192
4193         if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4194             goto done;
4195
4196         if (strEQ(s, "BEGIN")) {
4197             I32 oldscope = PL_scopestack_ix;
4198             ENTER;
4199             SAVECOPFILE(&PL_compiling);
4200             SAVECOPLINE(&PL_compiling);
4201
4202             if (!PL_beginav)
4203                 PL_beginav = newAV();
4204             DEBUG_x( dump_sub(gv) );
4205             av_push(PL_beginav, (SV*)cv);
4206             GvCV(gv) = 0;               /* cv has been hijacked */
4207             call_list(oldscope, PL_beginav);
4208
4209             PL_curcop = &PL_compiling;
4210             PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4211             LEAVE;
4212         }
4213         else if (strEQ(s, "END") && !PL_error_count) {
4214             if (!PL_endav)
4215                 PL_endav = newAV();
4216             DEBUG_x( dump_sub(gv) );
4217             av_unshift(PL_endav, 1);
4218             av_store(PL_endav, 0, (SV*)cv);
4219             GvCV(gv) = 0;               /* cv has been hijacked */
4220         }
4221         else if (strEQ(s, "CHECK") && !PL_error_count) {
4222             if (!PL_checkav)
4223                 PL_checkav = newAV();
4224             DEBUG_x( dump_sub(gv) );
4225             if (PL_main_start && ckWARN(WARN_VOID))
4226                 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4227             av_unshift(PL_checkav, 1);
4228             av_store(PL_checkav, 0, (SV*)cv);
4229             GvCV(gv) = 0;               /* cv has been hijacked */
4230         }
4231         else if (strEQ(s, "INIT") && !PL_error_count) {
4232             if (!PL_initav)
4233                 PL_initav = 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 INIT block");
4237             av_push(PL_initav, (SV*)cv);
4238             GvCV(gv) = 0;               /* cv has been hijacked */
4239         }
4240     }
4241
4242   done:
4243     PL_copline = NOLINE;
4244     LEAVE_SCOPE(floor);
4245     return cv;
4246 }
4247
4248 /* XXX unsafe for threads if eval_owner isn't held */
4249 /*
4250 =for apidoc newCONSTSUB
4251
4252 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4253 eligible for inlining at compile-time.
4254
4255 =cut
4256 */
4257
4258 CV *
4259 Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
4260 {
4261     CV* cv;
4262
4263     ENTER;
4264
4265     SAVECOPLINE(PL_curcop);
4266     CopLINE_set(PL_curcop, PL_copline);
4267
4268     SAVEHINTS();
4269     PL_hints &= ~HINT_BLOCK_SCOPE;
4270
4271     if (stash) {
4272         SAVESPTR(PL_curstash);
4273         SAVECOPSTASH(PL_curcop);
4274         PL_curstash = stash;
4275         CopSTASH_set(PL_curcop,stash);
4276     }
4277
4278     cv = newXS(name, const_sv_xsub, __FILE__);
4279     CvXSUBANY(cv).any_ptr = sv;
4280     CvCONST_on(cv);
4281     sv_setpv((SV*)cv, "");  /* prototype is "" */
4282
4283     LEAVE;
4284
4285     return cv;
4286 }
4287
4288 /*
4289 =for apidoc U||newXS
4290
4291 Used by C<xsubpp> to hook up XSUBs as Perl subs.
4292
4293 =cut
4294 */
4295
4296 CV *
4297 Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
4298 {
4299     GV *gv = gv_fetchpv(name ? name :
4300                         (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4301                         GV_ADDMULTI, SVt_PVCV);
4302     register CV *cv;
4303
4304     if (!subaddr)
4305         Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
4306
4307     if ((cv = (name ? GvCV(gv) : Nullcv))) {
4308         if (GvCVGEN(gv)) {
4309             /* just a cached method */
4310             SvREFCNT_dec(cv);
4311             cv = 0;
4312         }
4313         else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4314             /* already defined (or promised) */
4315             if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
4316                             && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
4317                 line_t oldline = CopLINE(PL_curcop);
4318                 if (PL_copline != NOLINE)
4319                     CopLINE_set(PL_curcop, PL_copline);
4320                 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4321                             CvCONST(cv) ? "Constant subroutine %s redefined"
4322                                         : "Subroutine %s redefined"
4323                             ,name);
4324                 CopLINE_set(PL_curcop, oldline);
4325             }
4326             SvREFCNT_dec(cv);
4327             cv = 0;
4328         }
4329     }
4330
4331     if (cv)                             /* must reuse cv if autoloaded */
4332         cv_undef(cv);
4333     else {
4334         cv = (CV*)NEWSV(1105,0);
4335         sv_upgrade((SV *)cv, SVt_PVCV);
4336         if (name) {
4337             GvCV(gv) = cv;
4338             GvCVGEN(gv) = 0;
4339             PL_sub_generation++;
4340         }
4341     }
4342     CvGV(cv) = gv;
4343     (void)gv_fetchfile(filename);
4344     CvFILE(cv) = filename;      /* NOTE: not copied, as it is expected to be
4345                                    an external constant string */
4346     CvXSUB(cv) = subaddr;
4347
4348     if (name) {
4349         char *s = strrchr(name,':');
4350         if (s)
4351             s++;
4352         else
4353             s = name;
4354
4355         if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4356             goto done;
4357
4358         if (strEQ(s, "BEGIN")) {
4359             if (!PL_beginav)
4360                 PL_beginav = newAV();
4361             av_push(PL_beginav, (SV*)cv);
4362             GvCV(gv) = 0;               /* cv has been hijacked */
4363         }
4364         else if (strEQ(s, "END")) {
4365             if (!PL_endav)
4366                 PL_endav = newAV();
4367             av_unshift(PL_endav, 1);
4368             av_store(PL_endav, 0, (SV*)cv);
4369             GvCV(gv) = 0;               /* cv has been hijacked */
4370         }
4371         else if (strEQ(s, "CHECK")) {
4372             if (!PL_checkav)
4373                 PL_checkav = newAV();
4374             if (PL_main_start && ckWARN(WARN_VOID))
4375                 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4376             av_unshift(PL_checkav, 1);
4377             av_store(PL_checkav, 0, (SV*)cv);
4378             GvCV(gv) = 0;               /* cv has been hijacked */
4379         }
4380         else if (strEQ(s, "INIT")) {
4381             if (!PL_initav)
4382                 PL_initav = newAV();
4383             if (PL_main_start && ckWARN(WARN_VOID))
4384                 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4385             av_push(PL_initav, (SV*)cv);
4386             GvCV(gv) = 0;               /* cv has been hijacked */
4387         }
4388     }
4389     else
4390         CvANON_on(cv);
4391
4392 done:
4393     return cv;
4394 }
4395
4396 void
4397 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
4398 {
4399     register CV *cv;
4400     char *name;
4401     GV *gv;
4402     STRLEN n_a;
4403
4404     if (o)
4405         name = SvPVx(cSVOPo->op_sv, n_a);
4406     else
4407         name = "STDOUT";
4408     gv = gv_fetchpv(name,TRUE, SVt_PVFM);
4409 #ifdef GV_UNIQUE_CHECK
4410     if (GvUNIQUE(gv)) {
4411         Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
4412     }
4413 #endif
4414     GvMULTI_on(gv);
4415     if ((cv = GvFORM(gv))) {
4416         if (ckWARN(WARN_REDEFINE)) {
4417             line_t oldline = CopLINE(PL_curcop);
4418             if (PL_copline != NOLINE)
4419                 CopLINE_set(PL_curcop, PL_copline);
4420             Perl_warner(aTHX_ packWARN(WARN_REDEFINE), "Format %s redefined",name);
4421             CopLINE_set(PL_curcop, oldline);
4422         }
4423         SvREFCNT_dec(cv);
4424     }
4425     cv = PL_compcv;
4426     GvFORM(gv) = cv;
4427     CvGV(cv) = gv;
4428     CvFILE_set_from_cop(cv, PL_curcop);
4429
4430
4431     pad_tidy(padtidy_FORMAT);
4432     CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
4433     CvROOT(cv)->op_private |= OPpREFCOUNTED;
4434     OpREFCNT_set(CvROOT(cv), 1);
4435     CvSTART(cv) = LINKLIST(CvROOT(cv));
4436     CvROOT(cv)->op_next = 0;
4437     CALL_PEEP(CvSTART(cv));
4438     op_free(o);
4439     PL_copline = NOLINE;
4440     LEAVE_SCOPE(floor);
4441 }
4442
4443 OP *
4444 Perl_newANONLIST(pTHX_ OP *o)
4445 {
4446     return newUNOP(OP_REFGEN, 0,
4447         mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
4448 }
4449
4450 OP *
4451 Perl_newANONHASH(pTHX_ OP *o)
4452 {
4453     return newUNOP(OP_REFGEN, 0,
4454         mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
4455 }
4456
4457 OP *
4458 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
4459 {
4460     return newANONATTRSUB(floor, proto, Nullop, block);
4461 }
4462
4463 OP *
4464 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
4465 {
4466     return newUNOP(OP_REFGEN, 0,
4467         newSVOP(OP_ANONCODE, 0,
4468                 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
4469 }
4470
4471 OP *
4472 Perl_oopsAV(pTHX_ OP *o)
4473 {
4474     switch (o->op_type) {
4475     case OP_PADSV:
4476         o->op_type = OP_PADAV;
4477         o->op_ppaddr = PL_ppaddr[OP_PADAV];
4478         return ref(o, OP_RV2AV);
4479
4480     case OP_RV2SV:
4481         o->op_type = OP_RV2AV;
4482         o->op_ppaddr = PL_ppaddr[OP_RV2AV];
4483         ref(o, OP_RV2AV);
4484         break;
4485
4486     default:
4487         if (ckWARN_d(WARN_INTERNAL))
4488             Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
4489         break;
4490     }
4491     return o;
4492 }
4493
4494 OP *
4495 Perl_oopsHV(pTHX_ OP *o)
4496 {
4497     switch (o->op_type) {
4498     case OP_PADSV:
4499     case OP_PADAV:
4500         o->op_type = OP_PADHV;
4501         o->op_ppaddr = PL_ppaddr[OP_PADHV];
4502         return ref(o, OP_RV2HV);
4503
4504     case OP_RV2SV:
4505     case OP_RV2AV:
4506         o->op_type = OP_RV2HV;
4507         o->op_ppaddr = PL_ppaddr[OP_RV2HV];
4508         ref(o, OP_RV2HV);
4509         break;
4510
4511     default:
4512         if (ckWARN_d(WARN_INTERNAL))
4513             Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
4514         break;
4515     }
4516     return o;
4517 }
4518
4519 OP *
4520 Perl_newAVREF(pTHX_ OP *o)
4521 {
4522     if (o->op_type == OP_PADANY) {
4523         o->op_type = OP_PADAV;
4524         o->op_ppaddr = PL_ppaddr[OP_PADAV];
4525         return o;
4526     }
4527     else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
4528                 && ckWARN(WARN_DEPRECATED)) {
4529         Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4530                 "Using an array as a reference is deprecated");
4531     }
4532     return newUNOP(OP_RV2AV, 0, scalar(o));
4533 }
4534
4535 OP *
4536 Perl_newGVREF(pTHX_ I32 type, OP *o)
4537 {
4538     if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
4539         return newUNOP(OP_NULL, 0, o);
4540     return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
4541 }
4542
4543 OP *
4544 Perl_newHVREF(pTHX_ OP *o)
4545 {
4546     if (o->op_type == OP_PADANY) {
4547         o->op_type = OP_PADHV;
4548         o->op_ppaddr = PL_ppaddr[OP_PADHV];
4549         return o;
4550     }
4551     else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
4552                 && ckWARN(WARN_DEPRECATED)) {
4553         Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4554                 "Using a hash as a reference is deprecated");
4555     }
4556     return newUNOP(OP_RV2HV, 0, scalar(o));
4557 }
4558
4559 OP *
4560 Perl_oopsCV(pTHX_ OP *o)
4561 {
4562     Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
4563     /* STUB */
4564     return o;
4565 }
4566
4567 OP *
4568 Perl_newCVREF(pTHX_ I32 flags, OP *o)
4569 {
4570     return newUNOP(OP_RV2CV, flags, scalar(o));
4571 }
4572
4573 OP *
4574 Perl_newSVREF(pTHX_ OP *o)
4575 {
4576     if (o->op_type == OP_PADANY) {
4577         o->op_type = OP_PADSV;
4578         o->op_ppaddr = PL_ppaddr[OP_PADSV];
4579         return o;
4580     }
4581     else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
4582         o->op_flags |= OPpDONE_SVREF;
4583         return o;
4584     }
4585     return newUNOP(OP_RV2SV, 0, scalar(o));
4586 }
4587
4588 /* Check routines. */
4589
4590 OP *
4591 Perl_ck_anoncode(pTHX_ OP *o)
4592 {
4593     cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
4594     cSVOPo->op_sv = Nullsv;
4595     return o;
4596 }
4597
4598 OP *
4599 Perl_ck_bitop(pTHX_ OP *o)
4600 {
4601 #define OP_IS_NUMCOMPARE(op) \
4602         ((op) == OP_LT   || (op) == OP_I_LT || \
4603          (op) == OP_GT   || (op) == OP_I_GT || \
4604          (op) == OP_LE   || (op) == OP_I_LE || \
4605          (op) == OP_GE   || (op) == OP_I_GE || \
4606          (op) == OP_EQ   || (op) == OP_I_EQ || \
4607          (op) == OP_NE   || (op) == OP_I_NE || \
4608          (op) == OP_NCMP || (op) == OP_I_NCMP)
4609     o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4610     if (o->op_type == OP_BIT_OR
4611             || o->op_type == OP_BIT_AND
4612             || o->op_type == OP_BIT_XOR)
4613     {
4614         OPCODE typfirst = cBINOPo->op_first->op_type;
4615         OPCODE typlast  = cBINOPo->op_first->op_sibling->op_type;
4616         if (OP_IS_NUMCOMPARE(typfirst) || OP_IS_NUMCOMPARE(typlast))
4617             if (ckWARN(WARN_PRECEDENCE))
4618                 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
4619                         "Possible precedence problem on bitwise %c operator",
4620                         o->op_type == OP_BIT_OR ? '|'
4621                             : o->op_type == OP_BIT_AND ? '&' : '^'
4622                         );
4623     }
4624     return o;
4625 }
4626
4627 OP *
4628 Perl_ck_concat(pTHX_ OP *o)
4629 {
4630     if (cUNOPo->op_first->op_type == OP_CONCAT)
4631         o->op_flags |= OPf_STACKED;
4632     return o;
4633 }
4634
4635 OP *
4636 Perl_ck_spair(pTHX_ OP *o)
4637 {
4638     if (o->op_flags & OPf_KIDS) {
4639         OP* newop;
4640         OP* kid;
4641         OPCODE type = o->op_type;
4642         o = modkids(ck_fun(o), type);
4643         kid = cUNOPo->op_first;
4644         newop = kUNOP->op_first->op_sibling;
4645         if (newop &&
4646             (newop->op_sibling ||
4647              !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
4648              newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
4649              newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
4650
4651             return o;
4652         }
4653         op_free(kUNOP->op_first);
4654         kUNOP->op_first = newop;
4655     }
4656     o->op_ppaddr = PL_ppaddr[++o->op_type];
4657     return ck_fun(o);
4658 }
4659
4660 OP *
4661 Perl_ck_delete(pTHX_ OP *o)
4662 {
4663     o = ck_fun(o);
4664     o->op_private = 0;
4665     if (o->op_flags & OPf_KIDS) {
4666         OP *kid = cUNOPo->op_first;
4667         switch (kid->op_type) {
4668         case OP_ASLICE:
4669             o->op_flags |= OPf_SPECIAL;
4670             /* FALL THROUGH */
4671         case OP_HSLICE:
4672             o->op_private |= OPpSLICE;
4673             break;
4674         case OP_AELEM:
4675             o->op_flags |= OPf_SPECIAL;
4676             /* FALL THROUGH */
4677         case OP_HELEM:
4678             break;
4679         default:
4680             Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
4681                   OP_DESC(o));
4682         }
4683         op_null(kid);
4684     }
4685     return o;
4686 }
4687
4688 OP *
4689 Perl_ck_die(pTHX_ OP *o)
4690 {
4691 #ifdef VMS
4692     if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
4693 #endif
4694     return ck_fun(o);
4695 }
4696
4697 OP *
4698 Perl_ck_eof(pTHX_ OP *o)
4699 {
4700     I32 type = o->op_type;
4701
4702     if (o->op_flags & OPf_KIDS) {
4703         if (cLISTOPo->op_first->op_type == OP_STUB) {
4704             op_free(o);
4705             o = newUNOP(type, OPf_SPECIAL,
4706                 newGVOP(OP_GV, 0, gv_fetchpv("main::ARGV", TRUE, SVt_PVAV)));
4707         }
4708         return ck_fun(o);
4709     }
4710     return o;
4711 }
4712
4713 OP *
4714 Perl_ck_eval(pTHX_ OP *o)
4715 {
4716     PL_hints |= HINT_BLOCK_SCOPE;
4717     if (o->op_flags & OPf_KIDS) {
4718         SVOP *kid = (SVOP*)cUNOPo->op_first;
4719
4720         if (!kid) {
4721             o->op_flags &= ~OPf_KIDS;
4722             op_null(o);
4723         }
4724         else if (kid->op_type == OP_LINESEQ) {
4725             LOGOP *enter;
4726
4727             kid->op_next = o->op_next;
4728             cUNOPo->op_first = 0;
4729             op_free(o);
4730
4731             NewOp(1101, enter, 1, LOGOP);
4732             enter->op_type = OP_ENTERTRY;
4733             enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
4734             enter->op_private = 0;
4735
4736             /* establish postfix order */
4737             enter->op_next = (OP*)enter;
4738
4739             o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
4740             o->op_type = OP_LEAVETRY;
4741             o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
4742             enter->op_other = o;
4743             return o;
4744         }
4745         else
4746             scalar((OP*)kid);
4747     }
4748     else {
4749         op_free(o);
4750         o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
4751     }
4752     o->op_targ = (PADOFFSET)PL_hints;
4753     return o;
4754 }
4755
4756 OP *
4757 Perl_ck_exit(pTHX_ OP *o)
4758 {
4759 #ifdef VMS
4760     HV *table = GvHV(PL_hintgv);
4761     if (table) {
4762        SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
4763        if (svp && *svp && SvTRUE(*svp))
4764            o->op_private |= OPpEXIT_VMSISH;
4765     }
4766     if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
4767 #endif
4768     return ck_fun(o);
4769 }
4770
4771 OP *
4772 Perl_ck_exec(pTHX_ OP *o)
4773 {
4774     OP *kid;
4775     if (o->op_flags & OPf_STACKED) {
4776         o = ck_fun(o);
4777         kid = cUNOPo->op_first->op_sibling;
4778         if (kid->op_type == OP_RV2GV)
4779             op_null(kid);
4780     }
4781     else
4782         o = listkids(o);
4783     return o;
4784 }
4785
4786 OP *
4787 Perl_ck_exists(pTHX_ OP *o)
4788 {
4789     o = ck_fun(o);
4790     if (o->op_flags & OPf_KIDS) {
4791         OP *kid = cUNOPo->op_first;
4792         if (kid->op_type == OP_ENTERSUB) {
4793             (void) ref(kid, o->op_type);
4794             if (kid->op_type != OP_RV2CV && !PL_error_count)
4795                 Perl_croak(aTHX_ "%s argument is not a subroutine name",
4796                             OP_DESC(o));
4797             o->op_private |= OPpEXISTS_SUB;
4798         }
4799         else if (kid->op_type == OP_AELEM)
4800             o->op_flags |= OPf_SPECIAL;
4801         else if (kid->op_type != OP_HELEM)
4802             Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
4803                         OP_DESC(o));
4804         op_null(kid);
4805     }
4806     return o;
4807 }
4808
4809 #if 0
4810 OP *
4811 Perl_ck_gvconst(pTHX_ register OP *o)
4812 {
4813     o = fold_constants(o);
4814     if (o->op_type == OP_CONST)
4815         o->op_type = OP_GV;
4816     return o;
4817 }
4818 #endif
4819
4820 OP *
4821 Perl_ck_rvconst(pTHX_ register OP *o)
4822 {
4823     SVOP *kid = (SVOP*)cUNOPo->op_first;
4824
4825     o->op_private |= (PL_hints & HINT_STRICT_REFS);
4826     if (kid->op_type == OP_CONST) {
4827         char *name;
4828         int iscv;
4829         GV *gv;
4830         SV *kidsv = kid->op_sv;
4831         STRLEN n_a;
4832
4833         /* Is it a constant from cv_const_sv()? */
4834         if (SvROK(kidsv) && SvREADONLY(kidsv)) {
4835             SV *rsv = SvRV(kidsv);
4836             int svtype = SvTYPE(rsv);
4837             char *badtype = Nullch;
4838
4839             switch (o->op_type) {
4840             case OP_RV2SV:
4841                 if (svtype > SVt_PVMG)
4842                     badtype = "a SCALAR";
4843                 break;
4844             case OP_RV2AV:
4845                 if (svtype != SVt_PVAV)
4846                     badtype = "an ARRAY";
4847                 break;
4848             case OP_RV2HV:
4849                 if (svtype != SVt_PVHV)
4850                     badtype = "a HASH";
4851                 break;
4852             case OP_RV2CV:
4853                 if (svtype != SVt_PVCV)
4854                     badtype = "a CODE";
4855                 break;
4856             }
4857             if (badtype)
4858                 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
4859             return o;
4860         }
4861         name = SvPV(kidsv, n_a);
4862         if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
4863             char *badthing = Nullch;
4864             switch (o->op_type) {
4865             case OP_RV2SV:
4866                 badthing = "a SCALAR";
4867                 break;
4868             case OP_RV2AV:
4869                 badthing = "an ARRAY";
4870                 break;
4871             case OP_RV2HV:
4872                 badthing = "a HASH";
4873                 break;
4874             }
4875             if (badthing)
4876                 Perl_croak(aTHX_
4877           "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
4878                       name, badthing);
4879         }
4880         /*
4881          * This is a little tricky.  We only want to add the symbol if we
4882          * didn't add it in the lexer.  Otherwise we get duplicate strict
4883          * warnings.  But if we didn't add it in the lexer, we must at
4884          * least pretend like we wanted to add it even if it existed before,
4885          * or we get possible typo warnings.  OPpCONST_ENTERED says
4886          * whether the lexer already added THIS instance of this symbol.
4887          */
4888         iscv = (o->op_type == OP_RV2CV) * 2;
4889         do {
4890             gv = gv_fetchpv(name,
4891                 iscv | !(kid->op_private & OPpCONST_ENTERED),
4892                 iscv
4893                     ? SVt_PVCV
4894                     : o->op_type == OP_RV2SV
4895                         ? SVt_PV
4896                         : o->op_type == OP_RV2AV
4897                             ? SVt_PVAV
4898                             : o->op_type == OP_RV2HV
4899                                 ? SVt_PVHV
4900                                 : SVt_PVGV);
4901         } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
4902         if (gv) {
4903             kid->op_type = OP_GV;
4904             SvREFCNT_dec(kid->op_sv);
4905 #ifdef USE_ITHREADS
4906             /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
4907             kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
4908             SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
4909             GvIN_PAD_on(gv);
4910             PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc(gv));
4911 #else
4912             kid->op_sv = SvREFCNT_inc(gv);
4913 #endif
4914             kid->op_private = 0;
4915             kid->op_ppaddr = PL_ppaddr[OP_GV];
4916         }
4917     }
4918     return o;
4919 }
4920
4921 OP *
4922 Perl_ck_ftst(pTHX_ OP *o)
4923 {
4924     I32 type = o->op_type;
4925
4926     if (o->op_flags & OPf_REF) {
4927         /* nothing */
4928     }
4929     else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
4930         SVOP *kid = (SVOP*)cUNOPo->op_first;
4931
4932         if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
4933             STRLEN n_a;
4934             OP *newop = newGVOP(type, OPf_REF,
4935                 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
4936             op_free(o);
4937             o = newop;
4938         }
4939     }
4940     else {
4941         op_free(o);
4942         if (type == OP_FTTTY)
4943            o =  newGVOP(type, OPf_REF, gv_fetchpv("main::STDIN", TRUE,
4944                                 SVt_PVIO));
4945         else
4946             o = newUNOP(type, 0, newDEFSVOP());
4947     }
4948     return o;
4949 }
4950
4951 OP *
4952 Perl_ck_fun(pTHX_ OP *o)
4953 {
4954     register OP *kid;
4955     OP **tokid;
4956     OP *sibl;
4957     I32 numargs = 0;
4958     int type = o->op_type;
4959     register I32 oa = PL_opargs[type] >> OASHIFT;
4960
4961     if (o->op_flags & OPf_STACKED) {
4962         if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
4963             oa &= ~OA_OPTIONAL;
4964         else
4965             return no_fh_allowed(o);
4966     }
4967
4968     if (o->op_flags & OPf_KIDS) {
4969         STRLEN n_a;
4970         tokid = &cLISTOPo->op_first;
4971         kid = cLISTOPo->op_first;
4972         if (kid->op_type == OP_PUSHMARK ||
4973             (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
4974         {
4975             tokid = &kid->op_sibling;
4976             kid = kid->op_sibling;
4977         }
4978         if (!kid && PL_opargs[type] & OA_DEFGV)
4979             *tokid = kid = newDEFSVOP();
4980
4981         while (oa && kid) {
4982             numargs++;
4983             sibl = kid->op_sibling;
4984             switch (oa & 7) {
4985             case OA_SCALAR:
4986                 /* list seen where single (scalar) arg expected? */
4987                 if (numargs == 1 && !(oa >> 4)
4988                     && kid->op_type == OP_LIST && type != OP_SCALAR)
4989                 {
4990                     return too_many_arguments(o,PL_op_desc[type]);
4991                 }
4992                 scalar(kid);
4993                 break;
4994             case OA_LIST:
4995                 if (oa < 16) {
4996                     kid = 0;
4997                     continue;
4998                 }
4999                 else
5000                     list(kid);
5001                 break;
5002             case OA_AVREF:
5003                 if ((type == OP_PUSH || type == OP_UNSHIFT)
5004                     && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5005                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5006                         "Useless use of %s with no values",
5007                         PL_op_desc[type]);
5008
5009                 if (kid->op_type == OP_CONST &&
5010                     (kid->op_private & OPpCONST_BARE))
5011                 {
5012                     char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5013                     OP *newop = newAVREF(newGVOP(OP_GV, 0,
5014                         gv_fetchpv(name, TRUE, SVt_PVAV) ));
5015                     if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5016                         Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5017                             "Array @%s missing the @ in argument %"IVdf" of %s()",
5018                             name, (IV)numargs, PL_op_desc[type]);
5019                     op_free(kid);
5020                     kid = newop;
5021                     kid->op_sibling = sibl;
5022                     *tokid = kid;
5023                 }
5024                 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5025                     bad_type(numargs, "array", PL_op_desc[type], kid);
5026                 mod(kid, type);
5027                 break;
5028             case OA_HVREF:
5029                 if (kid->op_type == OP_CONST &&
5030                     (kid->op_private & OPpCONST_BARE))
5031                 {
5032                     char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5033                     OP *newop = newHVREF(newGVOP(OP_GV, 0,
5034                         gv_fetchpv(name, TRUE, SVt_PVHV) ));
5035                     if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5036                         Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5037                             "Hash %%%s missing the %% in argument %"IVdf" of %s()",
5038                             name, (IV)numargs, PL_op_desc[type]);
5039                     op_free(kid);
5040                     kid = newop;
5041                     kid->op_sibling = sibl;
5042                     *tokid = kid;
5043                 }
5044                 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5045                     bad_type(numargs, "hash", PL_op_desc[type], kid);
5046                 mod(kid, type);
5047                 break;
5048             case OA_CVREF:
5049                 {
5050                     OP *newop = newUNOP(OP_NULL, 0, kid);
5051                     kid->op_sibling = 0;
5052                     linklist(kid);
5053                     newop->op_next = newop;
5054                     kid = newop;
5055                     kid->op_sibling = sibl;
5056                     *tokid = kid;
5057                 }
5058                 break;
5059             case OA_FILEREF:
5060                 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5061                     if (kid->op_type == OP_CONST &&
5062                         (kid->op_private & OPpCONST_BARE))
5063                     {
5064                         OP *newop = newGVOP(OP_GV, 0,
5065                             gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
5066                                         SVt_PVIO) );
5067                         if (!(o->op_private & 1) && /* if not unop */
5068                             kid == cLISTOPo->op_last)
5069                             cLISTOPo->op_last = newop;
5070                         op_free(kid);
5071                         kid = newop;
5072                     }
5073                     else if (kid->op_type == OP_READLINE) {
5074                         /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5075                         bad_type(numargs, "HANDLE", OP_DESC(o), kid);
5076                     }
5077                     else {
5078                         I32 flags = OPf_SPECIAL;
5079                         I32 priv = 0;
5080                         PADOFFSET targ = 0;
5081
5082                         /* is this op a FH constructor? */
5083                         if (is_handle_constructor(o,numargs)) {
5084                             char *name = Nullch;
5085                             STRLEN len = 0;
5086
5087                             flags = 0;
5088                             /* Set a flag to tell rv2gv to vivify
5089                              * need to "prove" flag does not mean something
5090                              * else already - NI-S 1999/05/07
5091                              */
5092                             priv = OPpDEREF;
5093                             if (kid->op_type == OP_PADSV) {
5094                                 /*XXX DAPM 2002.08.25 tmp assert test */
5095                                 /*XXX*/ assert(av_fetch(PL_comppad_name, (kid->op_targ), FALSE));
5096                                 /*XXX*/ assert(*av_fetch(PL_comppad_name, (kid->op_targ), FALSE));
5097
5098                                 name = PAD_COMPNAME_PV(kid->op_targ);
5099                                 /* SvCUR of a pad namesv can't be trusted
5100                                  * (see PL_generation), so calc its length
5101                                  * manually */
5102                                 if (name)
5103                                     len = strlen(name);
5104
5105                             }
5106                             else if (kid->op_type == OP_RV2SV
5107                                      && kUNOP->op_first->op_type == OP_GV)
5108                             {
5109                                 GV *gv = cGVOPx_gv(kUNOP->op_first);
5110                                 name = GvNAME(gv);
5111                                 len = GvNAMELEN(gv);
5112                             }
5113                             else if (kid->op_type == OP_AELEM
5114                                      || kid->op_type == OP_HELEM)
5115                             {
5116                                 name = "__ANONIO__";
5117                                 len = 10;
5118                                 mod(kid,type);
5119                             }
5120                             if (name) {
5121                                 SV *namesv;
5122                                 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5123                                 namesv = PAD_SVl(targ);
5124                                 (void)SvUPGRADE(namesv, SVt_PV);
5125                                 if (*name != '$')
5126                                     sv_setpvn(namesv, "$", 1);
5127                                 sv_catpvn(namesv, name, len);
5128                             }
5129                         }
5130                         kid->op_sibling = 0;
5131                         kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5132                         kid->op_targ = targ;
5133                         kid->op_private |= priv;
5134                     }
5135                     kid->op_sibling = sibl;
5136                     *tokid = kid;
5137                 }
5138                 scalar(kid);
5139                 break;
5140             case OA_SCALARREF:
5141                 mod(scalar(kid), type);
5142                 break;
5143             }
5144             oa >>= 4;
5145             tokid = &kid->op_sibling;
5146             kid = kid->op_sibling;
5147         }
5148         o->op_private |= numargs;
5149         if (kid)
5150             return too_many_arguments(o,OP_DESC(o));
5151         listkids(o);
5152     }
5153     else if (PL_opargs[type] & OA_DEFGV) {
5154         op_free(o);
5155         return newUNOP(type, 0, newDEFSVOP());
5156     }
5157
5158     if (oa) {
5159         while (oa & OA_OPTIONAL)
5160             oa >>= 4;
5161         if (oa && oa != OA_LIST)
5162             return too_few_arguments(o,OP_DESC(o));
5163     }
5164     return o;
5165 }
5166
5167 OP *
5168 Perl_ck_glob(pTHX_ OP *o)
5169 {
5170     GV *gv;
5171
5172     o = ck_fun(o);
5173     if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5174         append_elem(OP_GLOB, o, newDEFSVOP());
5175
5176     if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV))
5177           && GvCVu(gv) && GvIMPORTED_CV(gv)))
5178     {
5179         gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5180     }
5181
5182 #if !defined(PERL_EXTERNAL_GLOB)
5183     /* XXX this can be tightened up and made more failsafe. */
5184     if (!gv) {
5185         GV *glob_gv;
5186         ENTER;
5187         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
5188                 newSVpvn("File::Glob", 10), Nullsv, Nullsv, Nullsv);
5189         gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5190         glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
5191         GvCV(gv) = GvCV(glob_gv);
5192         SvREFCNT_inc((SV*)GvCV(gv));
5193         GvIMPORTED_CV_on(gv);
5194         LEAVE;
5195     }
5196 #endif /* PERL_EXTERNAL_GLOB */
5197
5198     if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5199         append_elem(OP_GLOB, o,
5200                     newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5201         o->op_type = OP_LIST;
5202         o->op_ppaddr = PL_ppaddr[OP_LIST];
5203         cLISTOPo->op_first->op_type = OP_PUSHMARK;
5204         cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5205         o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5206                     append_elem(OP_LIST, o,
5207                                 scalar(newUNOP(OP_RV2CV, 0,
5208                                                newGVOP(OP_GV, 0, gv)))));
5209         o = newUNOP(OP_NULL, 0, ck_subr(o));
5210         o->op_targ = OP_GLOB;           /* hint at what it used to be */
5211         return o;
5212     }
5213     gv = newGVgen("main");
5214     gv_IOadd(gv);
5215     append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5216     scalarkids(o);
5217     return o;
5218 }
5219
5220 OP *
5221 Perl_ck_grep(pTHX_ OP *o)
5222 {
5223     LOGOP *gwop;
5224     OP *kid;
5225     OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5226
5227     o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5228     NewOp(1101, gwop, 1, LOGOP);
5229
5230     if (o->op_flags & OPf_STACKED) {
5231         OP* k;
5232         o = ck_sort(o);
5233         kid = cLISTOPo->op_first->op_sibling;
5234         for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
5235             kid = k;
5236         }
5237         kid->op_next = (OP*)gwop;
5238         o->op_flags &= ~OPf_STACKED;
5239     }
5240     kid = cLISTOPo->op_first->op_sibling;
5241     if (type == OP_MAPWHILE)
5242         list(kid);
5243     else
5244         scalar(kid);
5245     o = ck_fun(o);
5246     if (PL_error_count)
5247         return o;
5248     kid = cLISTOPo->op_first->op_sibling;
5249     if (kid->op_type != OP_NULL)
5250         Perl_croak(aTHX_ "panic: ck_grep");
5251     kid = kUNOP->op_first;
5252
5253     gwop->op_type = type;
5254     gwop->op_ppaddr = PL_ppaddr[type];
5255     gwop->op_first = listkids(o);
5256     gwop->op_flags |= OPf_KIDS;
5257     gwop->op_private = 1;
5258     gwop->op_other = LINKLIST(kid);
5259     gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5260     kid->op_next = (OP*)gwop;
5261
5262     kid = cLISTOPo->op_first->op_sibling;
5263     if (!kid || !kid->op_sibling)
5264         return too_few_arguments(o,OP_DESC(o));
5265     for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5266         mod(kid, OP_GREPSTART);
5267
5268     return (OP*)gwop;
5269 }
5270
5271 OP *
5272 Perl_ck_index(pTHX_ OP *o)
5273 {
5274     if (o->op_flags & OPf_KIDS) {
5275         OP *kid = cLISTOPo->op_first->op_sibling;       /* get past pushmark */
5276         if (kid)
5277             kid = kid->op_sibling;                      /* get past "big" */
5278         if (kid && kid->op_type == OP_CONST)
5279             fbm_compile(((SVOP*)kid)->op_sv, 0);
5280     }
5281     return ck_fun(o);
5282 }
5283
5284 OP *
5285 Perl_ck_lengthconst(pTHX_ OP *o)
5286 {
5287     /* XXX length optimization goes here */
5288     return ck_fun(o);
5289 }
5290
5291 OP *
5292 Perl_ck_lfun(pTHX_ OP *o)
5293 {
5294     OPCODE type = o->op_type;
5295     return modkids(ck_fun(o), type);
5296 }
5297
5298 OP *
5299 Perl_ck_defined(pTHX_ OP *o)            /* 19990527 MJD */
5300 {
5301     if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
5302         switch (cUNOPo->op_first->op_type) {
5303         case OP_RV2AV:
5304             /* This is needed for
5305                if (defined %stash::)
5306                to work.   Do not break Tk.
5307                */
5308             break;                      /* Globals via GV can be undef */
5309         case OP_PADAV:
5310         case OP_AASSIGN:                /* Is this a good idea? */
5311             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5312                         "defined(@array) is deprecated");
5313             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5314                         "\t(Maybe you should just omit the defined()?)\n");
5315         break;
5316         case OP_RV2HV:
5317             /* This is needed for
5318                if (defined %stash::)
5319                to work.   Do not break Tk.
5320                */
5321             break;                      /* Globals via GV can be undef */
5322         case OP_PADHV:
5323             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5324                         "defined(%%hash) is deprecated");
5325             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5326                         "\t(Maybe you should just omit the defined()?)\n");
5327             break;
5328         default:
5329             /* no warning */
5330             break;
5331         }
5332     }
5333     return ck_rfun(o);
5334 }
5335
5336 OP *
5337 Perl_ck_rfun(pTHX_ OP *o)
5338 {
5339     OPCODE type = o->op_type;
5340     return refkids(ck_fun(o), type);
5341 }
5342
5343 OP *
5344 Perl_ck_listiob(pTHX_ OP *o)
5345 {
5346     register OP *kid;
5347
5348     kid = cLISTOPo->op_first;
5349     if (!kid) {
5350         o = force_list(o);
5351         kid = cLISTOPo->op_first;
5352     }
5353     if (kid->op_type == OP_PUSHMARK)
5354         kid = kid->op_sibling;
5355     if (kid && o->op_flags & OPf_STACKED)
5356         kid = kid->op_sibling;
5357     else if (kid && !kid->op_sibling) {         /* print HANDLE; */
5358         if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
5359             o->op_flags |= OPf_STACKED; /* make it a filehandle */
5360             kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
5361             cLISTOPo->op_first->op_sibling = kid;
5362             cLISTOPo->op_last = kid;
5363             kid = kid->op_sibling;
5364         }
5365     }
5366
5367     if (!kid)
5368         append_elem(o->op_type, o, newDEFSVOP());
5369
5370     return listkids(o);
5371 }
5372
5373 OP *
5374 Perl_ck_sassign(pTHX_ OP *o)
5375 {
5376     OP *kid = cLISTOPo->op_first;
5377     /* has a disposable target? */
5378     if ((PL_opargs[kid->op_type] & OA_TARGLEX)
5379         && !(kid->op_flags & OPf_STACKED)
5380         /* Cannot steal the second time! */
5381         && !(kid->op_private & OPpTARGET_MY))
5382     {
5383         OP *kkid = kid->op_sibling;
5384
5385         /* Can just relocate the target. */
5386         if (kkid && kkid->op_type == OP_PADSV
5387             && !(kkid->op_private & OPpLVAL_INTRO))
5388         {
5389             kid->op_targ = kkid->op_targ;
5390             kkid->op_targ = 0;
5391             /* Now we do not need PADSV and SASSIGN. */
5392             kid->op_sibling = o->op_sibling;    /* NULL */
5393             cLISTOPo->op_first = NULL;
5394             op_free(o);
5395             op_free(kkid);
5396             kid->op_private |= OPpTARGET_MY;    /* Used for context settings */
5397             return kid;
5398         }
5399     }
5400     return o;
5401 }
5402
5403 OP *
5404 Perl_ck_match(pTHX_ OP *o)
5405 {
5406     o->op_private |= OPpRUNTIME;
5407     return o;
5408 }
5409
5410 OP *
5411 Perl_ck_method(pTHX_ OP *o)
5412 {
5413     OP *kid = cUNOPo->op_first;
5414     if (kid->op_type == OP_CONST) {
5415         SV* sv = kSVOP->op_sv;
5416         if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
5417             OP *cmop;
5418             if (!SvREADONLY(sv) || !SvFAKE(sv)) {
5419                 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
5420             }
5421             else {
5422                 kSVOP->op_sv = Nullsv;
5423             }
5424             cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
5425             op_free(o);
5426             return cmop;
5427         }
5428     }
5429     return o;
5430 }
5431
5432 OP *
5433 Perl_ck_null(pTHX_ OP *o)
5434 {
5435     return o;
5436 }
5437
5438 OP *
5439 Perl_ck_open(pTHX_ OP *o)
5440 {
5441     HV *table = GvHV(PL_hintgv);
5442     if (table) {
5443         SV **svp;
5444         I32 mode;
5445         svp = hv_fetch(table, "open_IN", 7, FALSE);
5446         if (svp && *svp) {
5447             mode = mode_from_discipline(*svp);
5448             if (mode & O_BINARY)
5449                 o->op_private |= OPpOPEN_IN_RAW;
5450             else if (mode & O_TEXT)
5451                 o->op_private |= OPpOPEN_IN_CRLF;
5452         }
5453
5454         svp = hv_fetch(table, "open_OUT", 8, FALSE);
5455         if (svp && *svp) {
5456             mode = mode_from_discipline(*svp);
5457             if (mode & O_BINARY)
5458                 o->op_private |= OPpOPEN_OUT_RAW;
5459             else if (mode & O_TEXT)
5460                 o->op_private |= OPpOPEN_OUT_CRLF;
5461         }
5462     }
5463     if (o->op_type == OP_BACKTICK)
5464         return o;
5465     return ck_fun(o);
5466 }
5467
5468 OP *
5469 Perl_ck_repeat(pTHX_ OP *o)
5470 {
5471     if (cBINOPo->op_first->op_flags & OPf_PARENS) {
5472         o->op_private |= OPpREPEAT_DOLIST;
5473         cBINOPo->op_first = force_list(cBINOPo->op_first);
5474     }
5475     else
5476         scalar(o);
5477     return o;
5478 }
5479
5480 OP *
5481 Perl_ck_require(pTHX_ OP *o)
5482 {
5483     GV* gv;
5484
5485     if (o->op_flags & OPf_KIDS) {       /* Shall we supply missing .pm? */
5486         SVOP *kid = (SVOP*)cUNOPo->op_first;
5487
5488         if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5489             char *s;
5490             for (s = SvPVX(kid->op_sv); *s; s++) {
5491                 if (*s == ':' && s[1] == ':') {
5492                     *s = '/';
5493                     Move(s+2, s+1, strlen(s+2)+1, char);
5494                     --SvCUR(kid->op_sv);
5495                 }
5496             }
5497             if (SvREADONLY(kid->op_sv)) {
5498                 SvREADONLY_off(kid->op_sv);
5499                 sv_catpvn(kid->op_sv, ".pm", 3);
5500                 SvREADONLY_on(kid->op_sv);
5501             }
5502             else
5503                 sv_catpvn(kid->op_sv, ".pm", 3);
5504         }
5505     }
5506
5507     /* handle override, if any */
5508     gv = gv_fetchpv("require", FALSE, SVt_PVCV);
5509     if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
5510         gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
5511
5512     if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5513         OP *kid = cUNOPo->op_first;
5514         cUNOPo->op_first = 0;
5515         op_free(o);
5516         return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
5517                                append_elem(OP_LIST, kid,
5518                                            scalar(newUNOP(OP_RV2CV, 0,
5519                                                           newGVOP(OP_GV, 0,
5520                                                                   gv))))));
5521     }
5522
5523     return ck_fun(o);
5524 }
5525
5526 OP *
5527 Perl_ck_return(pTHX_ OP *o)
5528 {
5529     OP *kid;
5530     if (CvLVALUE(PL_compcv)) {
5531         for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
5532             mod(kid, OP_LEAVESUBLV);
5533     }
5534     return o;
5535 }
5536
5537 #if 0
5538 OP *
5539 Perl_ck_retarget(pTHX_ OP *o)
5540 {
5541     Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5542     /* STUB */
5543     return o;
5544 }
5545 #endif
5546
5547 OP *
5548 Perl_ck_select(pTHX_ OP *o)
5549 {
5550     OP* kid;
5551     if (o->op_flags & OPf_KIDS) {
5552         kid = cLISTOPo->op_first->op_sibling;   /* get past pushmark */
5553         if (kid && kid->op_sibling) {
5554             o->op_type = OP_SSELECT;
5555             o->op_ppaddr = PL_ppaddr[OP_SSELECT];
5556             o = ck_fun(o);
5557             return fold_constants(o);
5558         }
5559     }
5560     o = ck_fun(o);
5561     kid = cLISTOPo->op_first->op_sibling;    /* get past pushmark */
5562     if (kid && kid->op_type == OP_RV2GV)
5563         kid->op_private &= ~HINT_STRICT_REFS;
5564     return o;
5565 }
5566
5567 OP *
5568 Perl_ck_shift(pTHX_ OP *o)
5569 {
5570     I32 type = o->op_type;
5571
5572     if (!(o->op_flags & OPf_KIDS)) {
5573         OP *argop;
5574
5575         op_free(o);
5576         argop = newUNOP(OP_RV2AV, 0,
5577             scalar(newGVOP(OP_GV, 0, !CvUNIQUE(PL_compcv) ?
5578                            PL_defgv : gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
5579         return newUNOP(type, 0, scalar(argop));
5580     }
5581     return scalar(modkids(ck_fun(o), type));
5582 }
5583
5584 OP *
5585 Perl_ck_sort(pTHX_ OP *o)
5586 {
5587     OP *firstkid;
5588
5589     if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
5590         simplify_sort(o);
5591     firstkid = cLISTOPo->op_first->op_sibling;          /* get past pushmark */
5592     if (o->op_flags & OPf_STACKED) {                    /* may have been cleared */
5593         OP *k = NULL;
5594         OP *kid = cUNOPx(firstkid)->op_first;           /* get past null */
5595
5596         if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
5597             linklist(kid);
5598             if (kid->op_type == OP_SCOPE) {
5599                 k = kid->op_next;
5600                 kid->op_next = 0;
5601             }
5602             else if (kid->op_type == OP_LEAVE) {
5603                 if (o->op_type == OP_SORT) {
5604                     op_null(kid);                       /* wipe out leave */
5605                     kid->op_next = kid;
5606
5607                     for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
5608                         if (k->op_next == kid)
5609                             k->op_next = 0;
5610                         /* don't descend into loops */
5611                         else if (k->op_type == OP_ENTERLOOP
5612                                  || k->op_type == OP_ENTERITER)
5613                         {
5614                             k = cLOOPx(k)->op_lastop;
5615                         }
5616                     }
5617                 }
5618                 else
5619                     kid->op_next = 0;           /* just disconnect the leave */
5620                 k = kLISTOP->op_first;
5621             }
5622             CALL_PEEP(k);
5623
5624             kid = firstkid;
5625             if (o->op_type == OP_SORT) {
5626                 /* provide scalar context for comparison function/block */
5627                 kid = scalar(kid);
5628                 kid->op_next = kid;
5629             }
5630             else
5631                 kid->op_next = k;
5632             o->op_flags |= OPf_SPECIAL;
5633         }
5634         else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
5635             op_null(firstkid);
5636
5637         firstkid = firstkid->op_sibling;
5638     }
5639
5640     /* provide list context for arguments */
5641     if (o->op_type == OP_SORT)
5642         list(firstkid);
5643
5644     return o;
5645 }
5646
5647 STATIC void
5648 S_simplify_sort(pTHX_ OP *o)
5649 {
5650     register OP *kid = cLISTOPo->op_first->op_sibling;  /* get past pushmark */
5651     OP *k;
5652     int reversed;
5653     GV *gv;
5654     if (!(o->op_flags & OPf_STACKED))
5655         return;
5656     GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
5657     GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
5658     kid = kUNOP->op_first;                              /* get past null */
5659     if (kid->op_type != OP_SCOPE)
5660         return;
5661     kid = kLISTOP->op_last;                             /* get past scope */
5662     switch(kid->op_type) {
5663         case OP_NCMP:
5664         case OP_I_NCMP:
5665         case OP_SCMP:
5666             break;
5667         default:
5668             return;
5669     }
5670     k = kid;                                            /* remember this node*/
5671     if (kBINOP->op_first->op_type != OP_RV2SV)
5672         return;
5673     kid = kBINOP->op_first;                             /* get past cmp */
5674     if (kUNOP->op_first->op_type != OP_GV)
5675         return;
5676     kid = kUNOP->op_first;                              /* get past rv2sv */
5677     gv = kGVOP_gv;
5678     if (GvSTASH(gv) != PL_curstash)
5679         return;
5680     if (strEQ(GvNAME(gv), "a"))
5681         reversed = 0;
5682     else if (strEQ(GvNAME(gv), "b"))
5683         reversed = 1;
5684     else
5685         return;
5686     kid = k;                                            /* back to cmp */
5687     if (kBINOP->op_last->op_type != OP_RV2SV)
5688         return;
5689     kid = kBINOP->op_last;                              /* down to 2nd arg */
5690     if (kUNOP->op_first->op_type != OP_GV)
5691         return;
5692     kid = kUNOP->op_first;                              /* get past rv2sv */
5693     gv = kGVOP_gv;
5694     if (GvSTASH(gv) != PL_curstash
5695         || ( reversed
5696             ? strNE(GvNAME(gv), "a")
5697             : strNE(GvNAME(gv), "b")))
5698         return;
5699     o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
5700     if (reversed)
5701         o->op_private |= OPpSORT_REVERSE;
5702     if (k->op_type == OP_NCMP)
5703         o->op_private |= OPpSORT_NUMERIC;
5704     if (k->op_type == OP_I_NCMP)
5705         o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
5706     kid = cLISTOPo->op_first->op_sibling;
5707     cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
5708     op_free(kid);                                     /* then delete it */
5709 }
5710
5711 OP *
5712 Perl_ck_split(pTHX_ OP *o)
5713 {
5714     register OP *kid;
5715
5716     if (o->op_flags & OPf_STACKED)
5717         return no_fh_allowed(o);
5718
5719     kid = cLISTOPo->op_first;
5720     if (kid->op_type != OP_NULL)
5721         Perl_croak(aTHX_ "panic: ck_split");
5722     kid = kid->op_sibling;
5723     op_free(cLISTOPo->op_first);
5724     cLISTOPo->op_first = kid;
5725     if (!kid) {
5726         cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
5727         cLISTOPo->op_last = kid; /* There was only one element previously */
5728     }
5729
5730     if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
5731         OP *sibl = kid->op_sibling;
5732         kid->op_sibling = 0;
5733         kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
5734         if (cLISTOPo->op_first == cLISTOPo->op_last)
5735             cLISTOPo->op_last = kid;
5736         cLISTOPo->op_first = kid;
5737         kid->op_sibling = sibl;
5738     }
5739
5740     kid->op_type = OP_PUSHRE;
5741     kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
5742     scalar(kid);
5743     if (ckWARN(WARN_REGEXP) && ((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
5744       Perl_warner(aTHX_ packWARN(WARN_REGEXP),
5745                   "Use of /g modifier is meaningless in split");
5746     }
5747
5748     if (!kid->op_sibling)
5749         append_elem(OP_SPLIT, o, newDEFSVOP());
5750
5751     kid = kid->op_sibling;
5752     scalar(kid);
5753
5754     if (!kid->op_sibling)
5755         append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
5756
5757     kid = kid->op_sibling;
5758     scalar(kid);
5759
5760     if (kid->op_sibling)
5761         return too_many_arguments(o,OP_DESC(o));
5762
5763     return o;
5764 }
5765
5766 OP *
5767 Perl_ck_join(pTHX_ OP *o)
5768 {
5769     if (ckWARN(WARN_SYNTAX)) {
5770         OP *kid = cLISTOPo->op_first->op_sibling;
5771         if (kid && kid->op_type == OP_MATCH) {
5772             char *pmstr = "STRING";
5773             if (PM_GETRE(kPMOP))
5774                 pmstr = PM_GETRE(kPMOP)->precomp;
5775             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5776                         "/%s/ should probably be written as \"%s\"",
5777                         pmstr, pmstr);
5778         }
5779     }
5780     return ck_fun(o);
5781 }
5782
5783 OP *
5784 Perl_ck_subr(pTHX_ OP *o)
5785 {
5786     OP *prev = ((cUNOPo->op_first->op_sibling)
5787              ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
5788     OP *o2 = prev->op_sibling;
5789     OP *cvop;
5790     char *proto = 0;
5791     CV *cv = 0;
5792     GV *namegv = 0;
5793     int optional = 0;
5794     I32 arg = 0;
5795     I32 contextclass = 0;
5796     char *e = 0;
5797     STRLEN n_a;
5798
5799     o->op_private |= OPpENTERSUB_HASTARG;
5800     for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
5801     if (cvop->op_type == OP_RV2CV) {
5802         SVOP* tmpop;
5803         o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
5804         op_null(cvop);          /* disable rv2cv */
5805         tmpop = (SVOP*)((UNOP*)cvop)->op_first;
5806         if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
5807             GV *gv = cGVOPx_gv(tmpop);
5808             cv = GvCVu(gv);
5809             if (!cv)
5810                 tmpop->op_private |= OPpEARLY_CV;
5811             else if (SvPOK(cv)) {
5812                 namegv = CvANON(cv) ? gv : CvGV(cv);
5813                 proto = SvPV((SV*)cv, n_a);
5814             }
5815         }
5816     }
5817     else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
5818         if (o2->op_type == OP_CONST)
5819             o2->op_private &= ~OPpCONST_STRICT;
5820         else if (o2->op_type == OP_LIST) {
5821             OP *o = ((UNOP*)o2)->op_first->op_sibling;
5822             if (o && o->op_type == OP_CONST)
5823                 o->op_private &= ~OPpCONST_STRICT;
5824         }
5825     }
5826     o->op_private |= (PL_hints & HINT_STRICT_REFS);
5827     if (PERLDB_SUB && PL_curstash != PL_debstash)
5828         o->op_private |= OPpENTERSUB_DB;
5829     while (o2 != cvop) {
5830         if (proto) {
5831             switch (*proto) {
5832             case '\0':
5833                 return too_many_arguments(o, gv_ename(namegv));
5834             case ';':
5835                 optional = 1;
5836                 proto++;
5837                 continue;
5838             case '$':
5839                 proto++;
5840                 arg++;
5841                 scalar(o2);
5842                 break;
5843             case '%':
5844             case '@':
5845                 list(o2);
5846                 arg++;
5847                 break;
5848             case '&':
5849                 proto++;
5850                 arg++;
5851                 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
5852                     bad_type(arg,
5853                         arg == 1 ? "block or sub {}" : "sub {}",
5854                         gv_ename(namegv), o2);
5855                 break;
5856             case '*':
5857                 /* '*' allows any scalar type, including bareword */
5858                 proto++;
5859                 arg++;
5860                 if (o2->op_type == OP_RV2GV)
5861                     goto wrapref;       /* autoconvert GLOB -> GLOBref */
5862                 else if (o2->op_type == OP_CONST)
5863                     o2->op_private &= ~OPpCONST_STRICT;
5864                 else if (o2->op_type == OP_ENTERSUB) {
5865                     /* accidental subroutine, revert to bareword */
5866                     OP *gvop = ((UNOP*)o2)->op_first;
5867                     if (gvop && gvop->op_type == OP_NULL) {
5868                         gvop = ((UNOP*)gvop)->op_first;
5869                         if (gvop) {
5870                             for (; gvop->op_sibling; gvop = gvop->op_sibling)
5871                                 ;
5872                             if (gvop &&
5873                                 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
5874                                 (gvop = ((UNOP*)gvop)->op_first) &&
5875                                 gvop->op_type == OP_GV)
5876                             {
5877                                 GV *gv = cGVOPx_gv(gvop);
5878                                 OP *sibling = o2->op_sibling;
5879                                 SV *n = newSVpvn("",0);
5880                                 op_free(o2);
5881                                 gv_fullname3(n, gv, "");
5882                                 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
5883                                     sv_chop(n, SvPVX(n)+6);
5884                                 o2 = newSVOP(OP_CONST, 0, n);
5885                                 prev->op_sibling = o2;
5886                                 o2->op_sibling = sibling;
5887                             }
5888                         }
5889                     }
5890                 }
5891                 scalar(o2);
5892                 break;
5893             case '[': case ']':
5894                  goto oops;
5895                  break;
5896             case '\\':
5897                 proto++;
5898                 arg++;
5899             again:
5900                 switch (*proto++) {
5901                 case '[':
5902                      if (contextclass++ == 0) {
5903                           e = strchr(proto, ']');
5904                           if (!e || e == proto)
5905                                goto oops;
5906                      }
5907                      else
5908                           goto oops;
5909                      goto again;
5910                      break;
5911                 case ']':
5912                      if (contextclass) {
5913                          char *p = proto;
5914                          char s = *p;
5915                          contextclass = 0;
5916                          *p = '\0';
5917                          while (*--p != '[');
5918                          bad_type(arg, Perl_form(aTHX_ "one of %s", p),
5919                                  gv_ename(namegv), o2);
5920                          *proto = s;
5921                      } else
5922                           goto oops;
5923                      break;
5924                 case '*':
5925                      if (o2->op_type == OP_RV2GV)
5926                           goto wrapref;
5927                      if (!contextclass)
5928                           bad_type(arg, "symbol", gv_ename(namegv), o2);
5929                      break;
5930                 case '&':
5931                      if (o2->op_type == OP_ENTERSUB)
5932                           goto wrapref;
5933                      if (!contextclass)
5934                           bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
5935                      break;
5936                 case '$':
5937                     if (o2->op_type == OP_RV2SV ||
5938                         o2->op_type == OP_PADSV ||
5939                         o2->op_type == OP_HELEM ||
5940                         o2->op_type == OP_AELEM ||
5941                         o2->op_type == OP_THREADSV)
5942                          goto wrapref;
5943                     if (!contextclass)
5944                         bad_type(arg, "scalar", gv_ename(namegv), o2);
5945                      break;
5946                 case '@':
5947                     if (o2->op_type == OP_RV2AV ||
5948                         o2->op_type == OP_PADAV)
5949                          goto wrapref;
5950                     if (!contextclass)
5951                         bad_type(arg, "array", gv_ename(namegv), o2);
5952                     break;
5953                 case '%':
5954                     if (o2->op_type == OP_RV2HV ||
5955                         o2->op_type == OP_PADHV)
5956                          goto wrapref;
5957                     if (!contextclass)
5958                          bad_type(arg, "hash", gv_ename(namegv), o2);
5959                     break;
5960                 wrapref:
5961                     {
5962                         OP* kid = o2;
5963                         OP* sib = kid->op_sibling;
5964                         kid->op_sibling = 0;
5965                         o2 = newUNOP(OP_REFGEN, 0, kid);
5966                         o2->op_sibling = sib;
5967                         prev->op_sibling = o2;
5968                     }
5969                     if (contextclass && e) {
5970                          proto = e + 1;
5971                          contextclass = 0;
5972                     }
5973                     break;
5974                 default: goto oops;
5975                 }
5976                 if (contextclass)
5977                      goto again;
5978                 break;
5979             case ' ':
5980                 proto++;
5981                 continue;
5982             default:
5983               oops:
5984                 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
5985                            gv_ename(namegv), cv);
5986             }
5987         }
5988         else
5989             list(o2);
5990         mod(o2, OP_ENTERSUB);
5991         prev = o2;
5992         o2 = o2->op_sibling;
5993     }
5994     if (proto && !optional &&
5995           (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
5996         return too_few_arguments(o, gv_ename(namegv));
5997     return o;
5998 }
5999
6000 OP *
6001 Perl_ck_svconst(pTHX_ OP *o)
6002 {
6003     SvREADONLY_on(cSVOPo->op_sv);
6004     return o;
6005 }
6006
6007 OP *
6008 Perl_ck_trunc(pTHX_ OP *o)
6009 {
6010     if (o->op_flags & OPf_KIDS) {
6011         SVOP *kid = (SVOP*)cUNOPo->op_first;
6012
6013         if (kid->op_type == OP_NULL)
6014             kid = (SVOP*)kid->op_sibling;
6015         if (kid && kid->op_type == OP_CONST &&
6016             (kid->op_private & OPpCONST_BARE))
6017         {
6018             o->op_flags |= OPf_SPECIAL;
6019             kid->op_private &= ~OPpCONST_STRICT;
6020         }
6021     }
6022     return ck_fun(o);
6023 }
6024
6025 OP *
6026 Perl_ck_substr(pTHX_ OP *o)
6027 {
6028     o = ck_fun(o);
6029     if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6030         OP *kid = cLISTOPo->op_first;
6031
6032         if (kid->op_type == OP_NULL)
6033             kid = kid->op_sibling;
6034         if (kid)
6035             kid->op_flags |= OPf_MOD;
6036
6037     }
6038     return o;
6039 }
6040
6041 /* A peephole optimizer.  We visit the ops in the order they're to execute. */
6042
6043 void
6044 Perl_peep(pTHX_ register OP *o)
6045 {
6046     register OP* oldop = 0;
6047
6048     if (!o || o->op_seq)
6049         return;
6050     ENTER;
6051     SAVEOP();
6052     SAVEVPTR(PL_curcop);
6053     for (; o; o = o->op_next) {
6054         if (o->op_seq)
6055             break;
6056         /* The special value -1 is used by the B::C compiler backend to indicate
6057          * that an op is statically defined and should not be freed */
6058         if (!PL_op_seqmax || PL_op_seqmax == (U16)-1)
6059             PL_op_seqmax = 1;
6060         PL_op = o;
6061         switch (o->op_type) {
6062         case OP_SETSTATE:
6063         case OP_NEXTSTATE:
6064         case OP_DBSTATE:
6065             PL_curcop = ((COP*)o);              /* for warnings */
6066             o->op_seq = PL_op_seqmax++;
6067             break;
6068
6069         case OP_CONST:
6070             if (cSVOPo->op_private & OPpCONST_STRICT)
6071                 no_bareword_allowed(o);
6072 #ifdef USE_ITHREADS
6073         case OP_METHOD_NAMED:
6074             /* Relocate sv to the pad for thread safety.
6075              * Despite being a "constant", the SV is written to,
6076              * for reference counts, sv_upgrade() etc. */
6077             if (cSVOP->op_sv) {
6078                 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6079                 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
6080                     /* If op_sv is already a PADTMP then it is being used by
6081                      * some pad, so make a copy. */
6082                     sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
6083                     SvREADONLY_on(PAD_SVl(ix));
6084                     SvREFCNT_dec(cSVOPo->op_sv);
6085                 }
6086                 else {
6087                     SvREFCNT_dec(PAD_SVl(ix));
6088                     SvPADTMP_on(cSVOPo->op_sv);
6089                     PAD_SETSV(ix, cSVOPo->op_sv);
6090                     /* XXX I don't know how this isn't readonly already. */
6091                     SvREADONLY_on(PAD_SVl(ix));
6092                 }
6093                 cSVOPo->op_sv = Nullsv;
6094                 o->op_targ = ix;
6095             }
6096 #endif
6097             o->op_seq = PL_op_seqmax++;
6098             break;
6099
6100         case OP_CONCAT:
6101             if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6102                 if (o->op_next->op_private & OPpTARGET_MY) {
6103                     if (o->op_flags & OPf_STACKED) /* chained concats */
6104                         goto ignore_optimization;
6105                     else {
6106                         /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6107                         o->op_targ = o->op_next->op_targ;
6108                         o->op_next->op_targ = 0;
6109                         o->op_private |= OPpTARGET_MY;
6110                     }
6111                 }
6112                 op_null(o->op_next);
6113             }
6114           ignore_optimization:
6115             o->op_seq = PL_op_seqmax++;
6116             break;
6117         case OP_STUB:
6118             if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6119                 o->op_seq = PL_op_seqmax++;
6120                 break; /* Scalar stub must produce undef.  List stub is noop */
6121             }
6122             goto nothin;
6123         case OP_NULL:
6124             if (o->op_targ == OP_NEXTSTATE
6125                 || o->op_targ == OP_DBSTATE
6126                 || o->op_targ == OP_SETSTATE)
6127             {
6128                 PL_curcop = ((COP*)o);
6129             }
6130             /* XXX: We avoid setting op_seq here to prevent later calls
6131                to peep() from mistakenly concluding that optimisation
6132                has already occurred. This doesn't fix the real problem,
6133                though (See 20010220.007). AMS 20010719 */
6134             if (oldop && o->op_next) {
6135                 oldop->op_next = o->op_next;
6136                 continue;
6137             }
6138             break;
6139         case OP_SCALAR:
6140         case OP_LINESEQ:
6141         case OP_SCOPE:
6142           nothin:
6143             if (oldop && o->op_next) {
6144                 oldop->op_next = o->op_next;
6145                 continue;
6146             }
6147             o->op_seq = PL_op_seqmax++;
6148             break;
6149
6150         case OP_GV:
6151             if (o->op_next->op_type == OP_RV2SV) {
6152                 if (!(o->op_next->op_private & OPpDEREF)) {
6153                     op_null(o->op_next);
6154                     o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6155                                                                | OPpOUR_INTRO);
6156                     o->op_next = o->op_next->op_next;
6157                     o->op_type = OP_GVSV;
6158                     o->op_ppaddr = PL_ppaddr[OP_GVSV];
6159                 }
6160             }
6161             else if (o->op_next->op_type == OP_RV2AV) {
6162                 OP* pop = o->op_next->op_next;
6163                 IV i;
6164                 if (pop && pop->op_type == OP_CONST &&
6165                     (PL_op = pop->op_next) &&
6166                     pop->op_next->op_type == OP_AELEM &&
6167                     !(pop->op_next->op_private &
6168                       (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6169                     (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
6170                                 <= 255 &&
6171                     i >= 0)
6172                 {
6173                     GV *gv;
6174                     op_null(o->op_next);
6175                     op_null(pop->op_next);
6176                     op_null(pop);
6177                     o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6178                     o->op_next = pop->op_next->op_next;
6179                     o->op_type = OP_AELEMFAST;
6180                     o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6181                     o->op_private = (U8)i;
6182                     gv = cGVOPo_gv;
6183                     GvAVn(gv);
6184                 }
6185             }
6186             else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6187                 GV *gv = cGVOPo_gv;
6188                 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
6189                     /* XXX could check prototype here instead of just carping */
6190                     SV *sv = sv_newmortal();
6191                     gv_efullname3(sv, gv, Nullch);
6192                     Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
6193                                 "%"SVf"() called too early to check prototype",
6194                                 sv);
6195                 }
6196             }
6197             else if (o->op_next->op_type == OP_READLINE
6198                     && o->op_next->op_next->op_type == OP_CONCAT
6199                     && (o->op_next->op_next->op_flags & OPf_STACKED))
6200             {
6201                 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
6202                 o->op_type   = OP_RCATLINE;
6203                 o->op_flags |= OPf_STACKED;
6204                 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
6205                 op_null(o->op_next->op_next);
6206                 op_null(o->op_next);
6207             }
6208
6209             o->op_seq = PL_op_seqmax++;
6210             break;
6211
6212         case OP_MAPWHILE:
6213         case OP_GREPWHILE:
6214         case OP_AND:
6215         case OP_OR:
6216         case OP_DOR:
6217         case OP_ANDASSIGN:
6218         case OP_ORASSIGN:
6219         case OP_DORASSIGN:
6220         case OP_COND_EXPR:
6221         case OP_RANGE:
6222             o->op_seq = PL_op_seqmax++;
6223             while (cLOGOP->op_other->op_type == OP_NULL)
6224                 cLOGOP->op_other = cLOGOP->op_other->op_next;
6225             peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
6226             break;
6227
6228         case OP_ENTERLOOP:
6229         case OP_ENTERITER:
6230             o->op_seq = PL_op_seqmax++;
6231             while (cLOOP->op_redoop->op_type == OP_NULL)
6232                 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6233             peep(cLOOP->op_redoop);
6234             while (cLOOP->op_nextop->op_type == OP_NULL)
6235                 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6236             peep(cLOOP->op_nextop);
6237             while (cLOOP->op_lastop->op_type == OP_NULL)
6238                 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6239             peep(cLOOP->op_lastop);
6240             break;
6241
6242         case OP_QR:
6243         case OP_MATCH:
6244         case OP_SUBST:
6245             o->op_seq = PL_op_seqmax++;
6246             while (cPMOP->op_pmreplstart &&
6247                    cPMOP->op_pmreplstart->op_type == OP_NULL)
6248                 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6249             peep(cPMOP->op_pmreplstart);
6250             break;
6251
6252         case OP_EXEC:
6253             o->op_seq = PL_op_seqmax++;
6254             if (ckWARN(WARN_SYNTAX) && o->op_next
6255                 && o->op_next->op_type == OP_NEXTSTATE) {
6256                 if (o->op_next->op_sibling &&
6257                         o->op_next->op_sibling->op_type != OP_EXIT &&
6258                         o->op_next->op_sibling->op_type != OP_WARN &&
6259                         o->op_next->op_sibling->op_type != OP_DIE) {
6260                     line_t oldline = CopLINE(PL_curcop);
6261
6262                     CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6263                     Perl_warner(aTHX_ packWARN(WARN_EXEC),
6264                                 "Statement unlikely to be reached");
6265                     Perl_warner(aTHX_ packWARN(WARN_EXEC),
6266                                 "\t(Maybe you meant system() when you said exec()?)\n");
6267                     CopLINE_set(PL_curcop, oldline);
6268                 }
6269             }
6270             break;
6271
6272         case OP_HELEM: {
6273             SV *lexname;
6274             SV **svp, *sv;
6275             char *key = NULL;
6276             STRLEN keylen;
6277
6278             o->op_seq = PL_op_seqmax++;
6279
6280             if (((BINOP*)o)->op_last->op_type != OP_CONST)
6281                 break;
6282
6283             /* Make the CONST have a shared SV */
6284             svp = cSVOPx_svp(((BINOP*)o)->op_last);
6285             if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
6286                 key = SvPV(sv, keylen);
6287                 lexname = newSVpvn_share(key,
6288                                          SvUTF8(sv) ? -(I32)keylen : keylen,
6289                                          0);
6290                 SvREFCNT_dec(sv);
6291                 *svp = lexname;
6292             }
6293             break;
6294         }
6295
6296         default:
6297             o->op_seq = PL_op_seqmax++;
6298             break;
6299         }
6300         oldop = o;
6301     }
6302     LEAVE;
6303 }
6304
6305
6306
6307 char* Perl_custom_op_name(pTHX_ OP* o)
6308 {
6309     IV  index = PTR2IV(o->op_ppaddr);
6310     SV* keysv;
6311     HE* he;
6312
6313     if (!PL_custom_op_names) /* This probably shouldn't happen */
6314         return PL_op_name[OP_CUSTOM];
6315
6316     keysv = sv_2mortal(newSViv(index));
6317
6318     he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
6319     if (!he)
6320         return PL_op_name[OP_CUSTOM]; /* Don't know who you are */
6321
6322     return SvPV_nolen(HeVAL(he));
6323 }
6324
6325 char* Perl_custom_op_desc(pTHX_ OP* o)
6326 {
6327     IV  index = PTR2IV(o->op_ppaddr);
6328     SV* keysv;
6329     HE* he;
6330
6331     if (!PL_custom_op_descs)
6332         return PL_op_desc[OP_CUSTOM];
6333
6334     keysv = sv_2mortal(newSViv(index));
6335
6336     he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
6337     if (!he)
6338         return PL_op_desc[OP_CUSTOM];
6339
6340     return SvPV_nolen(HeVAL(he));
6341 }
6342
6343
6344 #include "XSUB.h"
6345
6346 /* Efficient sub that returns a constant scalar value. */
6347 static void
6348 const_sv_xsub(pTHX_ CV* cv)
6349 {
6350     dXSARGS;
6351     if (items != 0) {
6352 #if 0
6353         Perl_croak(aTHX_ "usage: %s::%s()",
6354                    HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
6355 #endif
6356     }
6357     EXTEND(sp, 1);
6358     ST(0) = (SV*)XSANY.any_ptr;
6359     XSRETURN(1);
6360 }