op.c

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