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