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