op.c

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