op.c

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