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