op.c

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