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