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