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;
4073     register CV *cv=0;
4074     SV *const_sv;
4075
4076     name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4077
4078     if (proto) {
4079         assert(proto->op_type == OP_CONST);
4080         ps = SvPVx(((SVOP*)proto)->op_sv, n_a);
4081     }
4082     else
4083         ps = Nullch;
4084
4085     if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4086         SV *sv = sv_newmortal();
4087         Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
4088                        PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
4089                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4090         aname = SvPVX(sv);
4091     }
4092     else
4093         aname = Nullch;
4094     gv = gv_fetchpv(name ? name : (aname ? aname :
4095                     (PL_curstash ? "__ANON__" : "__ANON__::__ANON__")),
4096                     GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4097                     SVt_PVCV);
4098
4099     if (o)
4100         SAVEFREEOP(o);
4101     if (proto)
4102         SAVEFREEOP(proto);
4103     if (attrs)
4104         SAVEFREEOP(attrs);
4105
4106     if (SvTYPE(gv) != SVt_PVGV) {       /* Maybe prototype now, and had at
4107                                            maximum a prototype before. */
4108         if (SvTYPE(gv) > SVt_NULL) {
4109             if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4110                 && ckWARN_d(WARN_PROTOTYPE))
4111             {
4112                 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
4113             }
4114             cv_ckproto((CV*)gv, NULL, ps);
4115         }
4116         if (ps)
4117             sv_setpv((SV*)gv, ps);
4118         else
4119             sv_setiv((SV*)gv, -1);
4120         SvREFCNT_dec(PL_compcv);
4121         cv = PL_compcv = NULL;
4122         PL_sub_generation++;
4123         goto done;
4124     }
4125
4126     cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4127
4128 #ifdef GV_UNIQUE_CHECK
4129     if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4130         Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
4131     }
4132 #endif
4133
4134     if (!block || !ps || *ps || attrs)
4135         const_sv = Nullsv;
4136     else
4137         const_sv = op_const_sv(block, Nullcv);
4138
4139     if (cv) {
4140         bool exists = CvROOT(cv) || CvXSUB(cv);
4141
4142 #ifdef GV_UNIQUE_CHECK
4143         if (exists && GvUNIQUE(gv)) {
4144             Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
4145         }
4146 #endif
4147
4148         /* if the subroutine doesn't exist and wasn't pre-declared
4149          * with a prototype, assume it will be AUTOLOADed,
4150          * skipping the prototype check
4151          */
4152         if (exists || SvPOK(cv))
4153             cv_ckproto(cv, gv, ps);
4154         /* already defined (or promised)? */
4155         if (exists || GvASSUMECV(gv)) {
4156             if (!block && !attrs) {
4157                 if (CvFLAGS(PL_compcv)) {
4158                     /* might have had built-in attrs applied */
4159                     CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4160                 }
4161                 /* just a "sub foo;" when &foo is already defined */
4162                 SAVEFREESV(PL_compcv);
4163                 goto done;
4164             }
4165             /* ahem, death to those who redefine active sort subs */
4166             if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4167                 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4168             if (block) {
4169                 if (ckWARN(WARN_REDEFINE)
4170                     || (CvCONST(cv)
4171                         && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4172                 {
4173                     line_t oldline = CopLINE(PL_curcop);
4174                     if (PL_copline != NOLINE)
4175                         CopLINE_set(PL_curcop, PL_copline);
4176                     Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4177                         CvCONST(cv) ? "Constant subroutine %s redefined"
4178                                     : "Subroutine %s redefined", name);
4179                     CopLINE_set(PL_curcop, oldline);
4180                 }
4181                 SvREFCNT_dec(cv);
4182                 cv = Nullcv;
4183             }
4184         }
4185     }
4186     if (const_sv) {
4187         SvREFCNT_inc(const_sv);
4188         if (cv) {
4189             assert(!CvROOT(cv) && !CvCONST(cv));
4190             sv_setpv((SV*)cv, "");  /* prototype is "" */
4191             CvXSUBANY(cv).any_ptr = const_sv;
4192             CvXSUB(cv) = const_sv_xsub;
4193             CvCONST_on(cv);
4194         }
4195         else {
4196             GvCV(gv) = Nullcv;
4197             cv = newCONSTSUB(NULL, name, const_sv);
4198         }
4199         op_free(block);
4200         SvREFCNT_dec(PL_compcv);
4201         PL_compcv = NULL;
4202         PL_sub_generation++;
4203         goto done;
4204     }
4205     if (attrs) {
4206         HV *stash;
4207         SV *rcv;
4208
4209         /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4210          * before we clobber PL_compcv.
4211          */
4212         if (cv && !block) {
4213             rcv = (SV*)cv;
4214             /* Might have had built-in attributes applied -- propagate them. */
4215             CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4216             if (CvGV(cv) && GvSTASH(CvGV(cv)))
4217                 stash = GvSTASH(CvGV(cv));
4218             else if (CvSTASH(cv))
4219                 stash = CvSTASH(cv);
4220             else
4221                 stash = PL_curstash;
4222         }
4223         else {
4224             /* possibly about to re-define existing subr -- ignore old cv */
4225             rcv = (SV*)PL_compcv;
4226             if (name && GvSTASH(gv))
4227                 stash = GvSTASH(gv);
4228             else
4229                 stash = PL_curstash;
4230         }
4231         apply_attrs(stash, rcv, attrs, FALSE);
4232     }
4233     if (cv) {                           /* must reuse cv if autoloaded */
4234         if (!block) {
4235             /* got here with just attrs -- work done, so bug out */
4236             SAVEFREESV(PL_compcv);
4237             goto done;
4238         }
4239         /* transfer PL_compcv to cv */
4240         cv_undef(cv);
4241         CvFLAGS(cv) = CvFLAGS(PL_compcv);
4242         if (!CvWEAKOUTSIDE(cv))
4243             SvREFCNT_dec(CvOUTSIDE(cv));
4244         CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4245         CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
4246         CvOUTSIDE(PL_compcv) = 0;
4247         CvPADLIST(cv) = CvPADLIST(PL_compcv);
4248         CvPADLIST(PL_compcv) = 0;
4249         /* inner references to PL_compcv must be fixed up ... */
4250         pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
4251         /* ... before we throw it away */
4252         SvREFCNT_dec(PL_compcv);
4253         PL_compcv = cv;
4254         if (PERLDB_INTER)/* Advice debugger on the new sub. */
4255           ++PL_sub_generation;
4256     }
4257     else {
4258         cv = PL_compcv;
4259         if (name) {
4260             GvCV(gv) = cv;
4261             GvCVGEN(gv) = 0;
4262             PL_sub_generation++;
4263         }
4264     }
4265     CvGV(cv) = gv;
4266     CvFILE_set_from_cop(cv, PL_curcop);
4267     CvSTASH(cv) = PL_curstash;
4268
4269     if (ps)
4270         sv_setpv((SV*)cv, ps);
4271
4272     if (PL_error_count) {
4273         op_free(block);
4274         block = Nullop;
4275         if (name) {
4276             char *s = strrchr(name, ':');
4277             s = s ? s+1 : name;
4278             if (strEQ(s, "BEGIN")) {
4279                 char *not_safe =
4280                     "BEGIN not safe after errors--compilation aborted";
4281                 if (PL_in_eval & EVAL_KEEPERR)
4282                     Perl_croak(aTHX_ not_safe);
4283                 else {
4284                     /* force display of errors found but not reported */
4285                     sv_catpv(ERRSV, not_safe);
4286                     Perl_croak(aTHX_ "%"SVf, ERRSV);
4287                 }
4288             }
4289         }
4290     }
4291     if (!block)
4292         goto done;
4293
4294     if (CvLVALUE(cv)) {
4295         CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4296                              mod(scalarseq(block), OP_LEAVESUBLV));
4297     }
4298     else {
4299         /* This makes sub {}; work as expected.  */
4300         if (block->op_type == OP_STUB) {
4301             op_free(block);
4302             block = newSTATEOP(0, Nullch, 0);
4303         }
4304         CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4305     }
4306     CvROOT(cv)->op_private |= OPpREFCOUNTED;
4307     OpREFCNT_set(CvROOT(cv), 1);
4308     CvSTART(cv) = LINKLIST(CvROOT(cv));
4309     CvROOT(cv)->op_next = 0;
4310     CALL_PEEP(CvSTART(cv));
4311
4312     /* now that optimizer has done its work, adjust pad values */
4313
4314     pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
4315
4316     if (CvCLONE(cv)) {
4317         assert(!CvCONST(cv));
4318         if (ps && !*ps && op_const_sv(block, cv))
4319             CvCONST_on(cv);
4320     }
4321
4322     if (name || aname) {
4323         char *s;
4324         char *tname = (name ? name : aname);
4325
4326         if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4327             SV *sv = NEWSV(0,0);
4328             SV *tmpstr = sv_newmortal();
4329             GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4330             CV *pcv;
4331             HV *hv;
4332
4333             Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4334                            CopFILE(PL_curcop),
4335                            (long)PL_subline, (long)CopLINE(PL_curcop));
4336             gv_efullname3(tmpstr, gv, Nullch);
4337             hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
4338             hv = GvHVn(db_postponed);
4339             if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
4340                 && (pcv = GvCV(db_postponed)))
4341             {
4342                 dSP;
4343                 PUSHMARK(SP);
4344                 XPUSHs(tmpstr);
4345                 PUTBACK;
4346                 call_sv((SV*)pcv, G_DISCARD);
4347             }
4348         }
4349
4350         if ((s = strrchr(tname,':')))
4351             s++;
4352         else
4353             s = tname;
4354
4355         if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4356             goto done;
4357
4358         if (strEQ(s, "BEGIN") && !PL_error_count) {
4359             I32 oldscope = PL_scopestack_ix;
4360             ENTER;
4361             SAVECOPFILE(&PL_compiling);
4362             SAVECOPLINE(&PL_compiling);
4363
4364             if (!PL_beginav)
4365                 PL_beginav = newAV();
4366             DEBUG_x( dump_sub(gv) );
4367             av_push(PL_beginav, (SV*)cv);
4368             GvCV(gv) = 0;               /* cv has been hijacked */
4369             call_list(oldscope, PL_beginav);
4370
4371             PL_curcop = &PL_compiling;
4372             PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4373             LEAVE;
4374         }
4375         else if (strEQ(s, "END") && !PL_error_count) {
4376             if (!PL_endav)
4377                 PL_endav = newAV();
4378             DEBUG_x( dump_sub(gv) );
4379             av_unshift(PL_endav, 1);
4380             av_store(PL_endav, 0, (SV*)cv);
4381             GvCV(gv) = 0;               /* cv has been hijacked */
4382         }
4383         else if (strEQ(s, "CHECK") && !PL_error_count) {
4384             if (!PL_checkav)
4385                 PL_checkav = newAV();
4386             DEBUG_x( dump_sub(gv) );
4387             if (PL_main_start && ckWARN(WARN_VOID))
4388                 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4389             av_unshift(PL_checkav, 1);
4390             av_store(PL_checkav, 0, (SV*)cv);
4391             GvCV(gv) = 0;               /* cv has been hijacked */
4392         }
4393         else if (strEQ(s, "INIT") && !PL_error_count) {
4394             if (!PL_initav)
4395                 PL_initav = newAV();
4396             DEBUG_x( dump_sub(gv) );
4397             if (PL_main_start && ckWARN(WARN_VOID))
4398                 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4399             av_push(PL_initav, (SV*)cv);
4400             GvCV(gv) = 0;               /* cv has been hijacked */
4401         }
4402     }
4403
4404   done:
4405     PL_copline = NOLINE;
4406     LEAVE_SCOPE(floor);
4407     return cv;
4408 }
4409
4410 /* XXX unsafe for threads if eval_owner isn't held */
4411 /*
4412 =for apidoc newCONSTSUB
4413
4414 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4415 eligible for inlining at compile-time.
4416
4417 =cut
4418 */
4419
4420 CV *
4421 Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
4422 {
4423     CV* cv;
4424
4425     ENTER;
4426
4427     SAVECOPLINE(PL_curcop);
4428     CopLINE_set(PL_curcop, PL_copline);
4429
4430     SAVEHINTS();
4431     PL_hints &= ~HINT_BLOCK_SCOPE;
4432
4433     if (stash) {
4434         SAVESPTR(PL_curstash);
4435         SAVECOPSTASH(PL_curcop);
4436         PL_curstash = stash;
4437         CopSTASH_set(PL_curcop,stash);
4438     }
4439
4440     cv = newXS(name, const_sv_xsub, savepv(CopFILE(PL_curcop)));
4441     CvXSUBANY(cv).any_ptr = sv;
4442     CvCONST_on(cv);
4443     sv_setpv((SV*)cv, "");  /* prototype is "" */
4444
4445     if (stash)
4446         CopSTASH_free(PL_curcop);
4447
4448     LEAVE;
4449
4450     return cv;
4451 }
4452
4453 /*
4454 =for apidoc U||newXS
4455
4456 Used by C<xsubpp> to hook up XSUBs as Perl subs.
4457
4458 =cut
4459 */
4460
4461 CV *
4462 Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
4463 {
4464     GV *gv = gv_fetchpv(name ? name :
4465                         (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4466                         GV_ADDMULTI, SVt_PVCV);
4467     register CV *cv;
4468
4469     if (!subaddr)
4470         Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
4471
4472     if ((cv = (name ? GvCV(gv) : Nullcv))) {
4473         if (GvCVGEN(gv)) {
4474             /* just a cached method */
4475             SvREFCNT_dec(cv);
4476             cv = 0;
4477         }
4478         else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4479             /* already defined (or promised) */
4480             if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
4481                             && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
4482                 line_t oldline = CopLINE(PL_curcop);
4483                 if (PL_copline != NOLINE)
4484                     CopLINE_set(PL_curcop, PL_copline);
4485                 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4486                             CvCONST(cv) ? "Constant subroutine %s redefined"
4487                                         : "Subroutine %s redefined"
4488                             ,name);
4489                 CopLINE_set(PL_curcop, oldline);
4490             }
4491             SvREFCNT_dec(cv);
4492             cv = 0;
4493         }
4494     }
4495
4496     if (cv)                             /* must reuse cv if autoloaded */
4497         cv_undef(cv);
4498     else {
4499         cv = (CV*)NEWSV(1105,0);
4500         sv_upgrade((SV *)cv, SVt_PVCV);
4501         if (name) {
4502             GvCV(gv) = cv;
4503             GvCVGEN(gv) = 0;
4504             PL_sub_generation++;
4505         }
4506     }
4507     CvGV(cv) = gv;
4508     (void)gv_fetchfile(filename);
4509     CvFILE(cv) = filename;      /* NOTE: not copied, as it is expected to be
4510                                    an external constant string */
4511     CvXSUB(cv) = subaddr;
4512
4513     if (name) {
4514         char *s = strrchr(name,':');
4515         if (s)
4516             s++;
4517         else
4518             s = name;
4519
4520         if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4521             goto done;
4522
4523         if (strEQ(s, "BEGIN")) {
4524             if (!PL_beginav)
4525                 PL_beginav = newAV();
4526             av_push(PL_beginav, (SV*)cv);
4527             GvCV(gv) = 0;               /* cv has been hijacked */
4528         }
4529         else if (strEQ(s, "END")) {
4530             if (!PL_endav)
4531                 PL_endav = newAV();
4532             av_unshift(PL_endav, 1);
4533             av_store(PL_endav, 0, (SV*)cv);
4534             GvCV(gv) = 0;               /* cv has been hijacked */
4535         }
4536         else if (strEQ(s, "CHECK")) {
4537             if (!PL_checkav)
4538                 PL_checkav = newAV();
4539             if (PL_main_start && ckWARN(WARN_VOID))
4540                 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4541             av_unshift(PL_checkav, 1);
4542             av_store(PL_checkav, 0, (SV*)cv);
4543             GvCV(gv) = 0;               /* cv has been hijacked */
4544         }
4545         else if (strEQ(s, "INIT")) {
4546             if (!PL_initav)
4547                 PL_initav = newAV();
4548             if (PL_main_start && ckWARN(WARN_VOID))
4549                 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4550             av_push(PL_initav, (SV*)cv);
4551             GvCV(gv) = 0;               /* cv has been hijacked */
4552         }
4553     }
4554     else
4555         CvANON_on(cv);
4556
4557 done:
4558     return cv;
4559 }
4560
4561 void
4562 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
4563 {
4564     register CV *cv;
4565     char *name;
4566     GV *gv;
4567     STRLEN n_a;
4568
4569     if (o)
4570         name = SvPVx(cSVOPo->op_sv, n_a);
4571     else
4572         name = "STDOUT";
4573     gv = gv_fetchpv(name,TRUE, SVt_PVFM);
4574 #ifdef GV_UNIQUE_CHECK
4575     if (GvUNIQUE(gv)) {
4576         Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
4577     }
4578 #endif
4579     GvMULTI_on(gv);
4580     if ((cv = GvFORM(gv))) {
4581         if (ckWARN(WARN_REDEFINE)) {
4582             line_t oldline = CopLINE(PL_curcop);
4583             if (PL_copline != NOLINE)
4584                 CopLINE_set(PL_curcop, PL_copline);
4585             Perl_warner(aTHX_ packWARN(WARN_REDEFINE), "Format %s redefined",name);
4586             CopLINE_set(PL_curcop, oldline);
4587         }
4588         SvREFCNT_dec(cv);
4589     }
4590     cv = PL_compcv;
4591     GvFORM(gv) = cv;
4592     CvGV(cv) = gv;
4593     CvFILE_set_from_cop(cv, PL_curcop);
4594
4595
4596     pad_tidy(padtidy_FORMAT);
4597     CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
4598     CvROOT(cv)->op_private |= OPpREFCOUNTED;
4599     OpREFCNT_set(CvROOT(cv), 1);
4600     CvSTART(cv) = LINKLIST(CvROOT(cv));
4601     CvROOT(cv)->op_next = 0;
4602     CALL_PEEP(CvSTART(cv));
4603     op_free(o);
4604     PL_copline = NOLINE;
4605     LEAVE_SCOPE(floor);
4606 }
4607
4608 OP *
4609 Perl_newANONLIST(pTHX_ OP *o)
4610 {
4611     return newUNOP(OP_REFGEN, 0,
4612         mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
4613 }
4614
4615 OP *
4616 Perl_newANONHASH(pTHX_ OP *o)
4617 {
4618     return newUNOP(OP_REFGEN, 0,
4619         mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
4620 }
4621
4622 OP *
4623 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
4624 {
4625     return newANONATTRSUB(floor, proto, Nullop, block);
4626 }
4627
4628 OP *
4629 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
4630 {
4631     return newUNOP(OP_REFGEN, 0,
4632         newSVOP(OP_ANONCODE, 0,
4633                 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
4634 }
4635
4636 OP *
4637 Perl_oopsAV(pTHX_ OP *o)
4638 {
4639     switch (o->op_type) {
4640     case OP_PADSV:
4641         o->op_type = OP_PADAV;
4642         o->op_ppaddr = PL_ppaddr[OP_PADAV];
4643         return ref(o, OP_RV2AV);
4644
4645     case OP_RV2SV:
4646         o->op_type = OP_RV2AV;
4647         o->op_ppaddr = PL_ppaddr[OP_RV2AV];
4648         ref(o, OP_RV2AV);
4649         break;
4650
4651     default:
4652         if (ckWARN_d(WARN_INTERNAL))
4653             Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
4654         break;
4655     }
4656     return o;
4657 }
4658
4659 OP *
4660 Perl_oopsHV(pTHX_ OP *o)
4661 {
4662     switch (o->op_type) {
4663     case OP_PADSV:
4664     case OP_PADAV:
4665         o->op_type = OP_PADHV;
4666         o->op_ppaddr = PL_ppaddr[OP_PADHV];
4667         return ref(o, OP_RV2HV);
4668
4669     case OP_RV2SV:
4670     case OP_RV2AV:
4671         o->op_type = OP_RV2HV;
4672         o->op_ppaddr = PL_ppaddr[OP_RV2HV];
4673         ref(o, OP_RV2HV);
4674         break;
4675
4676     default:
4677         if (ckWARN_d(WARN_INTERNAL))
4678             Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
4679         break;
4680     }
4681     return o;
4682 }
4683
4684 OP *
4685 Perl_newAVREF(pTHX_ OP *o)
4686 {
4687     if (o->op_type == OP_PADANY) {
4688         o->op_type = OP_PADAV;
4689         o->op_ppaddr = PL_ppaddr[OP_PADAV];
4690         return o;
4691     }
4692     else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
4693                 && ckWARN(WARN_DEPRECATED)) {
4694         Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4695                 "Using an array as a reference is deprecated");
4696     }
4697     return newUNOP(OP_RV2AV, 0, scalar(o));
4698 }
4699
4700 OP *
4701 Perl_newGVREF(pTHX_ I32 type, OP *o)
4702 {
4703     if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
4704         return newUNOP(OP_NULL, 0, o);
4705     return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
4706 }
4707
4708 OP *
4709 Perl_newHVREF(pTHX_ OP *o)
4710 {
4711     if (o->op_type == OP_PADANY) {
4712         o->op_type = OP_PADHV;
4713         o->op_ppaddr = PL_ppaddr[OP_PADHV];
4714         return o;
4715     }
4716     else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
4717                 && ckWARN(WARN_DEPRECATED)) {
4718         Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4719                 "Using a hash as a reference is deprecated");
4720     }
4721     return newUNOP(OP_RV2HV, 0, scalar(o));
4722 }
4723
4724 OP *
4725 Perl_oopsCV(pTHX_ OP *o)
4726 {
4727     Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
4728     /* STUB */
4729     return o;
4730 }
4731
4732 OP *
4733 Perl_newCVREF(pTHX_ I32 flags, OP *o)
4734 {
4735     return newUNOP(OP_RV2CV, flags, scalar(o));
4736 }
4737
4738 OP *
4739 Perl_newSVREF(pTHX_ OP *o)
4740 {
4741     if (o->op_type == OP_PADANY) {
4742         o->op_type = OP_PADSV;
4743         o->op_ppaddr = PL_ppaddr[OP_PADSV];
4744         return o;
4745     }
4746     else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
4747         o->op_flags |= OPpDONE_SVREF;
4748         return o;
4749     }
4750     return newUNOP(OP_RV2SV, 0, scalar(o));
4751 }
4752
4753 /* Check routines. */
4754
4755 OP *
4756 Perl_ck_anoncode(pTHX_ OP *o)
4757 {
4758     cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
4759     cSVOPo->op_sv = Nullsv;
4760     return o;
4761 }
4762
4763 OP *
4764 Perl_ck_bitop(pTHX_ OP *o)
4765 {
4766 #define OP_IS_NUMCOMPARE(op) \
4767         ((op) == OP_LT   || (op) == OP_I_LT || \
4768          (op) == OP_GT   || (op) == OP_I_GT || \
4769          (op) == OP_LE   || (op) == OP_I_LE || \
4770          (op) == OP_GE   || (op) == OP_I_GE || \
4771          (op) == OP_EQ   || (op) == OP_I_EQ || \
4772          (op) == OP_NE   || (op) == OP_I_NE || \
4773          (op) == OP_NCMP || (op) == OP_I_NCMP)
4774     o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4775     if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
4776             && (o->op_type == OP_BIT_OR
4777              || o->op_type == OP_BIT_AND
4778              || o->op_type == OP_BIT_XOR))
4779     {
4780         OP * left = cBINOPo->op_first;
4781         OP * right = left->op_sibling;
4782         if ((OP_IS_NUMCOMPARE(left->op_type) &&
4783                 (left->op_flags & OPf_PARENS) == 0) ||
4784             (OP_IS_NUMCOMPARE(right->op_type) &&
4785                 (right->op_flags & OPf_PARENS) == 0))
4786             if (ckWARN(WARN_PRECEDENCE))
4787                 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
4788                         "Possible precedence problem on bitwise %c operator",
4789                         o->op_type == OP_BIT_OR ? '|'
4790                             : o->op_type == OP_BIT_AND ? '&' : '^'
4791                         );
4792     }
4793     return o;
4794 }
4795
4796 OP *
4797 Perl_ck_concat(pTHX_ OP *o)
4798 {
4799     OP *kid = cUNOPo->op_first;
4800     if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
4801             !(kUNOP->op_first->op_flags & OPf_MOD))
4802         o->op_flags |= OPf_STACKED;
4803     return o;
4804 }
4805
4806 OP *
4807 Perl_ck_spair(pTHX_ OP *o)
4808 {
4809     if (o->op_flags & OPf_KIDS) {
4810         OP* newop;
4811         OP* kid;
4812         OPCODE type = o->op_type;
4813         o = modkids(ck_fun(o), type);
4814         kid = cUNOPo->op_first;
4815         newop = kUNOP->op_first->op_sibling;
4816         if (newop &&
4817             (newop->op_sibling ||
4818              !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
4819              newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
4820              newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
4821
4822             return o;
4823         }
4824         op_free(kUNOP->op_first);
4825         kUNOP->op_first = newop;
4826     }
4827     o->op_ppaddr = PL_ppaddr[++o->op_type];
4828     return ck_fun(o);
4829 }
4830
4831 OP *
4832 Perl_ck_delete(pTHX_ OP *o)
4833 {
4834     o = ck_fun(o);
4835     o->op_private = 0;
4836     if (o->op_flags & OPf_KIDS) {
4837         OP *kid = cUNOPo->op_first;
4838         switch (kid->op_type) {
4839         case OP_ASLICE:
4840             o->op_flags |= OPf_SPECIAL;
4841             /* FALL THROUGH */
4842         case OP_HSLICE:
4843             o->op_private |= OPpSLICE;
4844             break;
4845         case OP_AELEM:
4846             o->op_flags |= OPf_SPECIAL;
4847             /* FALL THROUGH */
4848         case OP_HELEM:
4849             break;
4850         default:
4851             Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
4852                   OP_DESC(o));
4853         }
4854         op_null(kid);
4855     }
4856     return o;
4857 }
4858
4859 OP *
4860 Perl_ck_die(pTHX_ OP *o)
4861 {
4862 #ifdef VMS
4863     if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
4864 #endif
4865     return ck_fun(o);
4866 }
4867
4868 OP *
4869 Perl_ck_eof(pTHX_ OP *o)
4870 {
4871     I32 type = o->op_type;
4872
4873     if (o->op_flags & OPf_KIDS) {
4874         if (cLISTOPo->op_first->op_type == OP_STUB) {
4875             op_free(o);
4876             o = newUNOP(type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
4877         }
4878         return ck_fun(o);
4879     }
4880     return o;
4881 }
4882
4883 OP *
4884 Perl_ck_eval(pTHX_ OP *o)
4885 {
4886     PL_hints |= HINT_BLOCK_SCOPE;
4887     if (o->op_flags & OPf_KIDS) {
4888         SVOP *kid = (SVOP*)cUNOPo->op_first;
4889
4890         if (!kid) {
4891             o->op_flags &= ~OPf_KIDS;
4892             op_null(o);
4893         }
4894         else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
4895             LOGOP *enter;
4896
4897             cUNOPo->op_first = 0;
4898             op_free(o);
4899
4900             NewOp(1101, enter, 1, LOGOP);
4901             enter->op_type = OP_ENTERTRY;
4902             enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
4903             enter->op_private = 0;
4904
4905             /* establish postfix order */
4906             enter->op_next = (OP*)enter;
4907
4908             o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
4909             o->op_type = OP_LEAVETRY;
4910             o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
4911             enter->op_other = o;
4912             return o;
4913         }
4914         else {
4915             scalar((OP*)kid);
4916             PL_cv_has_eval = 1;
4917         }
4918     }
4919     else {
4920         op_free(o);
4921         o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
4922     }
4923     o->op_targ = (PADOFFSET)PL_hints;
4924     return o;
4925 }
4926
4927 OP *
4928 Perl_ck_exit(pTHX_ OP *o)
4929 {
4930 #ifdef VMS
4931     HV *table = GvHV(PL_hintgv);
4932     if (table) {
4933        SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
4934        if (svp && *svp && SvTRUE(*svp))
4935            o->op_private |= OPpEXIT_VMSISH;
4936     }
4937     if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
4938 #endif
4939     return ck_fun(o);
4940 }
4941
4942 OP *
4943 Perl_ck_exec(pTHX_ OP *o)
4944 {
4945     OP *kid;
4946     if (o->op_flags & OPf_STACKED) {
4947         o = ck_fun(o);
4948         kid = cUNOPo->op_first->op_sibling;
4949         if (kid->op_type == OP_RV2GV)
4950             op_null(kid);
4951     }
4952     else
4953         o = listkids(o);
4954     return o;
4955 }
4956
4957 OP *
4958 Perl_ck_exists(pTHX_ OP *o)
4959 {
4960     o = ck_fun(o);
4961     if (o->op_flags & OPf_KIDS) {
4962         OP *kid = cUNOPo->op_first;
4963         if (kid->op_type == OP_ENTERSUB) {
4964             (void) ref(kid, o->op_type);
4965             if (kid->op_type != OP_RV2CV && !PL_error_count)
4966                 Perl_croak(aTHX_ "%s argument is not a subroutine name",
4967                             OP_DESC(o));
4968             o->op_private |= OPpEXISTS_SUB;
4969         }
4970         else if (kid->op_type == OP_AELEM)
4971             o->op_flags |= OPf_SPECIAL;
4972         else if (kid->op_type != OP_HELEM)
4973             Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
4974                         OP_DESC(o));
4975         op_null(kid);
4976     }
4977     return o;
4978 }
4979
4980 #if 0
4981 OP *
4982 Perl_ck_gvconst(pTHX_ register OP *o)
4983 {
4984     o = fold_constants(o);
4985     if (o->op_type == OP_CONST)
4986         o->op_type = OP_GV;
4987     return o;
4988 }
4989 #endif
4990
4991 OP *
4992 Perl_ck_rvconst(pTHX_ register OP *o)
4993 {
4994     SVOP *kid = (SVOP*)cUNOPo->op_first;
4995
4996     o->op_private |= (PL_hints & HINT_STRICT_REFS);
4997     if (kid->op_type == OP_CONST) {
4998         char *name;
4999         int iscv;
5000         GV *gv;
5001         SV *kidsv = kid->op_sv;
5002         STRLEN n_a;
5003
5004         /* Is it a constant from cv_const_sv()? */
5005         if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5006             SV *rsv = SvRV(kidsv);
5007             int svtype = SvTYPE(rsv);
5008             char *badtype = Nullch;
5009
5010             switch (o->op_type) {
5011             case OP_RV2SV:
5012                 if (svtype > SVt_PVMG)
5013                     badtype = "a SCALAR";
5014                 break;
5015             case OP_RV2AV:
5016                 if (svtype != SVt_PVAV)
5017                     badtype = "an ARRAY";
5018                 break;
5019             case OP_RV2HV:
5020                 if (svtype != SVt_PVHV)
5021                     badtype = "a HASH";
5022                 break;
5023             case OP_RV2CV:
5024                 if (svtype != SVt_PVCV)
5025                     badtype = "a CODE";
5026                 break;
5027             }
5028             if (badtype)
5029                 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5030             return o;
5031         }
5032         name = SvPV(kidsv, n_a);
5033         if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5034             char *badthing = Nullch;
5035             switch (o->op_type) {
5036             case OP_RV2SV:
5037                 badthing = "a SCALAR";
5038                 break;
5039             case OP_RV2AV:
5040                 badthing = "an ARRAY";
5041                 break;
5042             case OP_RV2HV:
5043                 badthing = "a HASH";
5044                 break;
5045             }
5046             if (badthing)
5047                 Perl_croak(aTHX_
5048           "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
5049                       name, badthing);
5050         }
5051         /*
5052          * This is a little tricky.  We only want to add the symbol if we
5053          * didn't add it in the lexer.  Otherwise we get duplicate strict
5054          * warnings.  But if we didn't add it in the lexer, we must at
5055          * least pretend like we wanted to add it even if it existed before,
5056          * or we get possible typo warnings.  OPpCONST_ENTERED says
5057          * whether the lexer already added THIS instance of this symbol.
5058          */
5059         iscv = (o->op_type == OP_RV2CV) * 2;
5060         do {
5061             gv = gv_fetchpv(name,
5062                 iscv | !(kid->op_private & OPpCONST_ENTERED),
5063                 iscv
5064                     ? SVt_PVCV
5065                     : o->op_type == OP_RV2SV
5066                         ? SVt_PV
5067                         : o->op_type == OP_RV2AV
5068                             ? SVt_PVAV
5069                             : o->op_type == OP_RV2HV
5070                                 ? SVt_PVHV
5071                                 : SVt_PVGV);
5072         } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5073         if (gv) {
5074             kid->op_type = OP_GV;
5075             SvREFCNT_dec(kid->op_sv);
5076 #ifdef USE_ITHREADS
5077             /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5078             kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5079             SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
5080             GvIN_PAD_on(gv);
5081             PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc(gv));
5082 #else
5083             kid->op_sv = SvREFCNT_inc(gv);
5084 #endif
5085             kid->op_private = 0;
5086             kid->op_ppaddr = PL_ppaddr[OP_GV];
5087         }
5088     }
5089     return o;
5090 }
5091
5092 OP *
5093 Perl_ck_ftst(pTHX_ OP *o)
5094 {
5095     I32 type = o->op_type;
5096
5097     if (o->op_flags & OPf_REF) {
5098         /* nothing */
5099     }
5100     else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5101         SVOP *kid = (SVOP*)cUNOPo->op_first;
5102
5103         if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5104             STRLEN n_a;
5105             OP *newop = newGVOP(type, OPf_REF,
5106                 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
5107             op_free(o);
5108             o = newop;
5109             return o;
5110         }
5111         else {
5112           if ((PL_hints & HINT_FILETEST_ACCESS) &&
5113               OP_IS_FILETEST_ACCESS(o))
5114             o->op_private |= OPpFT_ACCESS;
5115         }
5116         if (PL_check[kid->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst)
5117                 && kid->op_type != OP_STAT && kid->op_type != OP_LSTAT)
5118             o->op_private |= OPpFT_STACKED;
5119     }
5120     else {
5121         op_free(o);
5122         if (type == OP_FTTTY)
5123             o = newGVOP(type, OPf_REF, PL_stdingv);
5124         else
5125             o = newUNOP(type, 0, newDEFSVOP());
5126     }
5127     return o;
5128 }
5129
5130 OP *
5131 Perl_ck_fun(pTHX_ OP *o)
5132 {
5133     register OP *kid;
5134     OP **tokid;
5135     OP *sibl;
5136     I32 numargs = 0;
5137     int type = o->op_type;
5138     register I32 oa = PL_opargs[type] >> OASHIFT;
5139
5140     if (o->op_flags & OPf_STACKED) {
5141         if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5142             oa &= ~OA_OPTIONAL;
5143         else
5144             return no_fh_allowed(o);
5145     }
5146
5147     if (o->op_flags & OPf_KIDS) {
5148         STRLEN n_a;
5149         tokid = &cLISTOPo->op_first;
5150         kid = cLISTOPo->op_first;
5151         if (kid->op_type == OP_PUSHMARK ||
5152             (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5153         {
5154             tokid = &kid->op_sibling;
5155             kid = kid->op_sibling;
5156         }
5157         if (!kid && PL_opargs[type] & OA_DEFGV)
5158             *tokid = kid = newDEFSVOP();
5159
5160         while (oa && kid) {
5161             numargs++;
5162             sibl = kid->op_sibling;
5163             switch (oa & 7) {
5164             case OA_SCALAR:
5165                 /* list seen where single (scalar) arg expected? */
5166                 if (numargs == 1 && !(oa >> 4)
5167                     && kid->op_type == OP_LIST && type != OP_SCALAR)
5168                 {
5169                     return too_many_arguments(o,PL_op_desc[type]);
5170                 }
5171                 scalar(kid);
5172                 break;
5173             case OA_LIST:
5174                 if (oa < 16) {
5175                     kid = 0;
5176                     continue;
5177                 }
5178                 else
5179                     list(kid);
5180                 break;
5181             case OA_AVREF:
5182                 if ((type == OP_PUSH || type == OP_UNSHIFT)
5183                     && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5184                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5185                         "Useless use of %s with no values",
5186                         PL_op_desc[type]);
5187
5188                 if (kid->op_type == OP_CONST &&
5189                     (kid->op_private & OPpCONST_BARE))
5190                 {
5191                     char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5192                     OP *newop = newAVREF(newGVOP(OP_GV, 0,
5193                         gv_fetchpv(name, TRUE, SVt_PVAV) ));
5194                     if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5195                         Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5196                             "Array @%s missing the @ in argument %"IVdf" of %s()",
5197                             name, (IV)numargs, PL_op_desc[type]);
5198                     op_free(kid);
5199                     kid = newop;
5200                     kid->op_sibling = sibl;
5201                     *tokid = kid;
5202                 }
5203                 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5204                     bad_type(numargs, "array", PL_op_desc[type], kid);
5205                 mod(kid, type);
5206                 break;
5207             case OA_HVREF:
5208                 if (kid->op_type == OP_CONST &&
5209                     (kid->op_private & OPpCONST_BARE))
5210                 {
5211                     char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5212                     OP *newop = newHVREF(newGVOP(OP_GV, 0,
5213                         gv_fetchpv(name, TRUE, SVt_PVHV) ));
5214                     if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5215                         Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5216                             "Hash %%%s missing the %% in argument %"IVdf" of %s()",
5217                             name, (IV)numargs, PL_op_desc[type]);
5218                     op_free(kid);
5219                     kid = newop;
5220                     kid->op_sibling = sibl;
5221                     *tokid = kid;
5222                 }
5223                 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5224                     bad_type(numargs, "hash", PL_op_desc[type], kid);
5225                 mod(kid, type);
5226                 break;
5227             case OA_CVREF:
5228                 {
5229                     OP *newop = newUNOP(OP_NULL, 0, kid);
5230                     kid->op_sibling = 0;
5231                     linklist(kid);
5232                     newop->op_next = newop;
5233                     kid = newop;
5234                     kid->op_sibling = sibl;
5235                     *tokid = kid;
5236                 }
5237                 break;
5238             case OA_FILEREF:
5239                 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5240                     if (kid->op_type == OP_CONST &&
5241                         (kid->op_private & OPpCONST_BARE))
5242                     {
5243                         OP *newop = newGVOP(OP_GV, 0,
5244                             gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
5245                                         SVt_PVIO) );
5246                         if (!(o->op_private & 1) && /* if not unop */
5247                             kid == cLISTOPo->op_last)
5248                             cLISTOPo->op_last = newop;
5249                         op_free(kid);
5250                         kid = newop;
5251                     }
5252                     else if (kid->op_type == OP_READLINE) {
5253                         /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5254                         bad_type(numargs, "HANDLE", OP_DESC(o), kid);
5255                     }
5256                     else {
5257                         I32 flags = OPf_SPECIAL;
5258                         I32 priv = 0;
5259                         PADOFFSET targ = 0;
5260
5261                         /* is this op a FH constructor? */
5262                         if (is_handle_constructor(o,numargs)) {
5263                             char *name = Nullch;
5264                             STRLEN len = 0;
5265
5266                             flags = 0;
5267                             /* Set a flag to tell rv2gv to vivify
5268                              * need to "prove" flag does not mean something
5269                              * else already - NI-S 1999/05/07
5270                              */
5271                             priv = OPpDEREF;
5272                             if (kid->op_type == OP_PADSV) {
5273                                 name = PAD_COMPNAME_PV(kid->op_targ);
5274                                 /* SvCUR of a pad namesv can't be trusted
5275                                  * (see PL_generation), so calc its length
5276                                  * manually */
5277                                 if (name)
5278                                     len = strlen(name);
5279
5280                             }
5281                             else if (kid->op_type == OP_RV2SV
5282                                      && kUNOP->op_first->op_type == OP_GV)
5283                             {
5284                                 GV *gv = cGVOPx_gv(kUNOP->op_first);
5285                                 name = GvNAME(gv);
5286                                 len = GvNAMELEN(gv);
5287                             }
5288                             else if (kid->op_type == OP_AELEM
5289                                      || kid->op_type == OP_HELEM)
5290                             {
5291                                  OP *op;
5292
5293                                  name = 0;
5294                                  if ((op = ((BINOP*)kid)->op_first)) {
5295                                       SV *tmpstr = Nullsv;
5296                                       char *a =
5297                                            kid->op_type == OP_AELEM ?
5298                                            "[]" : "{}";
5299                                       if (((op->op_type == OP_RV2AV) ||
5300                                            (op->op_type == OP_RV2HV)) &&
5301                                           (op = ((UNOP*)op)->op_first) &&
5302                                           (op->op_type == OP_GV)) {
5303                                            /* packagevar $a[] or $h{} */
5304                                            GV *gv = cGVOPx_gv(op);
5305                                            if (gv)
5306                                                 tmpstr =
5307                                                      Perl_newSVpvf(aTHX_
5308                                                                    "%s%c...%c",
5309                                                                    GvNAME(gv),
5310                                                                    a[0], a[1]);
5311                                       }
5312                                       else if (op->op_type == OP_PADAV
5313                                                || op->op_type == OP_PADHV) {
5314                                            /* lexicalvar $a[] or $h{} */
5315                                            char *padname =
5316                                                 PAD_COMPNAME_PV(op->op_targ);
5317                                            if (padname)
5318                                                 tmpstr =
5319                                                      Perl_newSVpvf(aTHX_
5320                                                                    "%s%c...%c",
5321                                                                    padname + 1,
5322                                                                    a[0], a[1]);
5323
5324                                       }
5325                                       if (tmpstr) {
5326                                            name = SvPV(tmpstr, len);
5327                                            sv_2mortal(tmpstr);
5328                                       }
5329                                  }
5330                                  if (!name) {
5331                                       name = "__ANONIO__";
5332                                       len = 10;
5333                                  }
5334                                  mod(kid, type);
5335                             }
5336                             if (name) {
5337                                 SV *namesv;
5338                                 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5339                                 namesv = PAD_SVl(targ);
5340                                 (void)SvUPGRADE(namesv, SVt_PV);
5341                                 if (*name != '$')
5342                                     sv_setpvn(namesv, "$", 1);
5343                                 sv_catpvn(namesv, name, len);
5344                             }
5345                         }
5346                         kid->op_sibling = 0;
5347                         kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5348                         kid->op_targ = targ;
5349                         kid->op_private |= priv;
5350                     }
5351                     kid->op_sibling = sibl;
5352                     *tokid = kid;
5353                 }
5354                 scalar(kid);
5355                 break;
5356             case OA_SCALARREF:
5357                 mod(scalar(kid), type);
5358                 break;
5359             }
5360             oa >>= 4;
5361             tokid = &kid->op_sibling;
5362             kid = kid->op_sibling;
5363         }
5364         o->op_private |= numargs;
5365         if (kid)
5366             return too_many_arguments(o,OP_DESC(o));
5367         listkids(o);
5368     }
5369     else if (PL_opargs[type] & OA_DEFGV) {
5370         op_free(o);
5371         return newUNOP(type, 0, newDEFSVOP());
5372     }
5373
5374     if (oa) {
5375         while (oa & OA_OPTIONAL)
5376             oa >>= 4;
5377         if (oa && oa != OA_LIST)
5378             return too_few_arguments(o,OP_DESC(o));
5379     }
5380     return o;
5381 }
5382
5383 OP *
5384 Perl_ck_glob(pTHX_ OP *o)
5385 {
5386     GV *gv;
5387
5388     o = ck_fun(o);
5389     if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5390         append_elem(OP_GLOB, o, newDEFSVOP());
5391
5392     if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV))
5393           && GvCVu(gv) && GvIMPORTED_CV(gv)))
5394     {
5395         gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5396     }
5397
5398 #if !defined(PERL_EXTERNAL_GLOB)
5399     /* XXX this can be tightened up and made more failsafe. */
5400     if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
5401         GV *glob_gv;
5402         ENTER;
5403         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
5404                 newSVpvn("File::Glob", 10), Nullsv, Nullsv, Nullsv);
5405         gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5406         glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
5407         GvCV(gv) = GvCV(glob_gv);
5408         SvREFCNT_inc((SV*)GvCV(gv));
5409         GvIMPORTED_CV_on(gv);
5410         LEAVE;
5411     }
5412 #endif /* PERL_EXTERNAL_GLOB */
5413
5414     if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5415         append_elem(OP_GLOB, o,
5416                     newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5417         o->op_type = OP_LIST;
5418         o->op_ppaddr = PL_ppaddr[OP_LIST];
5419         cLISTOPo->op_first->op_type = OP_PUSHMARK;
5420         cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5421         cLISTOPo->op_first->op_targ = 0;
5422         o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5423                     append_elem(OP_LIST, o,
5424                                 scalar(newUNOP(OP_RV2CV, 0,
5425                                                newGVOP(OP_GV, 0, gv)))));
5426         o = newUNOP(OP_NULL, 0, ck_subr(o));
5427         o->op_targ = OP_GLOB;           /* hint at what it used to be */
5428         return o;
5429     }
5430     gv = newGVgen("main");
5431     gv_IOadd(gv);
5432     append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5433     scalarkids(o);
5434     return o;
5435 }
5436
5437 OP *
5438 Perl_ck_grep(pTHX_ OP *o)
5439 {
5440     LOGOP *gwop;
5441     OP *kid;
5442     OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5443     I32 offset;
5444
5445     o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5446     NewOp(1101, gwop, 1, LOGOP);
5447
5448     if (o->op_flags & OPf_STACKED) {
5449         OP* k;
5450         o = ck_sort(o);
5451         kid = cLISTOPo->op_first->op_sibling;
5452         for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
5453             kid = k;
5454         }
5455         kid->op_next = (OP*)gwop;
5456         o->op_flags &= ~OPf_STACKED;
5457     }
5458     kid = cLISTOPo->op_first->op_sibling;
5459     if (type == OP_MAPWHILE)
5460         list(kid);
5461     else
5462         scalar(kid);
5463     o = ck_fun(o);
5464     if (PL_error_count)
5465         return o;
5466     kid = cLISTOPo->op_first->op_sibling;
5467     if (kid->op_type != OP_NULL)
5468         Perl_croak(aTHX_ "panic: ck_grep");
5469     kid = kUNOP->op_first;
5470
5471     gwop->op_type = type;
5472     gwop->op_ppaddr = PL_ppaddr[type];
5473     gwop->op_first = listkids(o);
5474     gwop->op_flags |= OPf_KIDS;
5475     gwop->op_other = LINKLIST(kid);
5476     kid->op_next = (OP*)gwop;
5477     offset = pad_findmy("$_");
5478     if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
5479         o->op_private = gwop->op_private = 0;
5480         gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5481     }
5482     else {
5483         o->op_private = gwop->op_private = OPpGREP_LEX;
5484         gwop->op_targ = o->op_targ = offset;
5485     }
5486
5487     kid = cLISTOPo->op_first->op_sibling;
5488     if (!kid || !kid->op_sibling)
5489         return too_few_arguments(o,OP_DESC(o));
5490     for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5491         mod(kid, OP_GREPSTART);
5492
5493     return (OP*)gwop;
5494 }
5495
5496 OP *
5497 Perl_ck_index(pTHX_ OP *o)
5498 {
5499     if (o->op_flags & OPf_KIDS) {
5500         OP *kid = cLISTOPo->op_first->op_sibling;       /* get past pushmark */
5501         if (kid)
5502             kid = kid->op_sibling;                      /* get past "big" */
5503         if (kid && kid->op_type == OP_CONST)
5504             fbm_compile(((SVOP*)kid)->op_sv, 0);
5505     }
5506     return ck_fun(o);
5507 }
5508
5509 OP *
5510 Perl_ck_lengthconst(pTHX_ OP *o)
5511 {
5512     /* XXX length optimization goes here */
5513     return ck_fun(o);
5514 }
5515
5516 OP *
5517 Perl_ck_lfun(pTHX_ OP *o)
5518 {
5519     OPCODE type = o->op_type;
5520     return modkids(ck_fun(o), type);
5521 }
5522
5523 OP *
5524 Perl_ck_defined(pTHX_ OP *o)            /* 19990527 MJD */
5525 {
5526     if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
5527         switch (cUNOPo->op_first->op_type) {
5528         case OP_RV2AV:
5529             /* This is needed for
5530                if (defined %stash::)
5531                to work.   Do not break Tk.
5532                */
5533             break;                      /* Globals via GV can be undef */
5534         case OP_PADAV:
5535         case OP_AASSIGN:                /* Is this a good idea? */
5536             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5537                         "defined(@array) is deprecated");
5538             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5539                         "\t(Maybe you should just omit the defined()?)\n");
5540         break;
5541         case OP_RV2HV:
5542             /* This is needed for
5543                if (defined %stash::)
5544                to work.   Do not break Tk.
5545                */
5546             break;                      /* Globals via GV can be undef */
5547         case OP_PADHV:
5548             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5549                         "defined(%%hash) is deprecated");
5550             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5551                         "\t(Maybe you should just omit the defined()?)\n");
5552             break;
5553         default:
5554             /* no warning */
5555             break;
5556         }
5557     }
5558     return ck_rfun(o);
5559 }
5560
5561 OP *
5562 Perl_ck_rfun(pTHX_ OP *o)
5563 {
5564     OPCODE type = o->op_type;
5565     return refkids(ck_fun(o), type);
5566 }
5567
5568 OP *
5569 Perl_ck_listiob(pTHX_ OP *o)
5570 {
5571     register OP *kid;
5572
5573     kid = cLISTOPo->op_first;
5574     if (!kid) {
5575         o = force_list(o);
5576         kid = cLISTOPo->op_first;
5577     }
5578     if (kid->op_type == OP_PUSHMARK)
5579         kid = kid->op_sibling;
5580     if (kid && o->op_flags & OPf_STACKED)
5581         kid = kid->op_sibling;
5582     else if (kid && !kid->op_sibling) {         /* print HANDLE; */
5583         if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
5584             o->op_flags |= OPf_STACKED; /* make it a filehandle */
5585             kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
5586             cLISTOPo->op_first->op_sibling = kid;
5587             cLISTOPo->op_last = kid;
5588             kid = kid->op_sibling;
5589         }
5590     }
5591
5592     if (!kid)
5593         append_elem(o->op_type, o, newDEFSVOP());
5594
5595     return listkids(o);
5596 }
5597
5598 OP *
5599 Perl_ck_sassign(pTHX_ OP *o)
5600 {
5601     OP *kid = cLISTOPo->op_first;
5602     /* has a disposable target? */
5603     if ((PL_opargs[kid->op_type] & OA_TARGLEX)
5604         && !(kid->op_flags & OPf_STACKED)
5605         /* Cannot steal the second time! */
5606         && !(kid->op_private & OPpTARGET_MY))
5607     {
5608         OP *kkid = kid->op_sibling;
5609
5610         /* Can just relocate the target. */
5611         if (kkid && kkid->op_type == OP_PADSV
5612             && !(kkid->op_private & OPpLVAL_INTRO))
5613         {
5614             kid->op_targ = kkid->op_targ;
5615             kkid->op_targ = 0;
5616             /* Now we do not need PADSV and SASSIGN. */
5617             kid->op_sibling = o->op_sibling;    /* NULL */
5618             cLISTOPo->op_first = NULL;
5619             op_free(o);
5620             op_free(kkid);
5621             kid->op_private |= OPpTARGET_MY;    /* Used for context settings */
5622             return kid;
5623         }
5624     }
5625     /* optimise C<my $x = undef> to C<my $x> */
5626     if (kid->op_type == OP_UNDEF) {
5627         OP *kkid = kid->op_sibling;
5628         if (kkid && kkid->op_type == OP_PADSV
5629                 && (kkid->op_private & OPpLVAL_INTRO))
5630         {
5631             cLISTOPo->op_first = NULL;
5632             kid->op_sibling = NULL;
5633             op_free(o);
5634             op_free(kid);
5635             return kkid;
5636         }
5637     }
5638     return o;
5639 }
5640
5641 OP *
5642 Perl_ck_match(pTHX_ OP *o)
5643 {
5644     if (o->op_type != OP_QR) {
5645         I32 offset = pad_findmy("$_");
5646         if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS(offset) & SVpad_OUR)) {
5647             o->op_targ = offset;
5648             o->op_private |= OPpTARGET_MY;
5649         }
5650     }
5651     if (o->op_type == OP_MATCH || o->op_type == OP_QR)
5652         o->op_private |= OPpRUNTIME;
5653     return o;
5654 }
5655
5656 OP *
5657 Perl_ck_method(pTHX_ OP *o)
5658 {
5659     OP *kid = cUNOPo->op_first;
5660     if (kid->op_type == OP_CONST) {
5661         SV* sv = kSVOP->op_sv;
5662         if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
5663             OP *cmop;
5664             if (!SvREADONLY(sv) || !SvFAKE(sv)) {
5665                 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
5666             }
5667             else {
5668                 kSVOP->op_sv = Nullsv;
5669             }
5670             cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
5671             op_free(o);
5672             return cmop;
5673         }
5674     }
5675     return o;
5676 }
5677
5678 OP *
5679 Perl_ck_null(pTHX_ OP *o)
5680 {
5681     return o;
5682 }
5683
5684 OP *
5685 Perl_ck_open(pTHX_ OP *o)
5686 {
5687     HV *table = GvHV(PL_hintgv);
5688     if (table) {
5689         SV **svp;
5690         I32 mode;
5691         svp = hv_fetch(table, "open_IN", 7, FALSE);
5692         if (svp && *svp) {
5693             mode = mode_from_discipline(*svp);
5694             if (mode & O_BINARY)
5695                 o->op_private |= OPpOPEN_IN_RAW;
5696             else if (mode & O_TEXT)
5697                 o->op_private |= OPpOPEN_IN_CRLF;
5698         }
5699
5700         svp = hv_fetch(table, "open_OUT", 8, FALSE);
5701         if (svp && *svp) {
5702             mode = mode_from_discipline(*svp);
5703             if (mode & O_BINARY)
5704                 o->op_private |= OPpOPEN_OUT_RAW;
5705             else if (mode & O_TEXT)
5706                 o->op_private |= OPpOPEN_OUT_CRLF;
5707         }
5708     }
5709     if (o->op_type == OP_BACKTICK)
5710         return o;
5711     {
5712          /* In case of three-arg dup open remove strictness
5713           * from the last arg if it is a bareword. */
5714          OP *first = cLISTOPx(o)->op_first; /* The pushmark. */
5715          OP *last  = cLISTOPx(o)->op_last;  /* The bareword. */
5716          OP *oa;
5717          char *mode;
5718
5719          if ((last->op_type == OP_CONST) &&             /* The bareword. */
5720              (last->op_private & OPpCONST_BARE) &&
5721              (last->op_private & OPpCONST_STRICT) &&
5722              (oa = first->op_sibling) &&                /* The fh. */
5723              (oa = oa->op_sibling) &&                   /* The mode. */
5724              SvPOK(((SVOP*)oa)->op_sv) &&
5725              (mode = SvPVX(((SVOP*)oa)->op_sv)) &&
5726              mode[0] == '>' && mode[1] == '&' &&        /* A dup open. */
5727              (last == oa->op_sibling))                  /* The bareword. */
5728               last->op_private &= ~OPpCONST_STRICT;
5729     }
5730     return ck_fun(o);
5731 }
5732
5733 OP *
5734 Perl_ck_repeat(pTHX_ OP *o)
5735 {
5736     if (cBINOPo->op_first->op_flags & OPf_PARENS) {
5737         o->op_private |= OPpREPEAT_DOLIST;
5738         cBINOPo->op_first = force_list(cBINOPo->op_first);
5739     }
5740     else
5741         scalar(o);
5742     return o;
5743 }
5744
5745 OP *
5746 Perl_ck_require(pTHX_ OP *o)
5747 {
5748     GV* gv;
5749
5750     if (o->op_flags & OPf_KIDS) {       /* Shall we supply missing .pm? */
5751         SVOP *kid = (SVOP*)cUNOPo->op_first;
5752
5753         if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5754             char *s;
5755             for (s = SvPVX(kid->op_sv); *s; s++) {
5756                 if (*s == ':' && s[1] == ':') {
5757                     *s = '/';
5758                     Move(s+2, s+1, strlen(s+2)+1, char);
5759                     --SvCUR(kid->op_sv);
5760                 }
5761             }
5762             if (SvREADONLY(kid->op_sv)) {
5763                 SvREADONLY_off(kid->op_sv);
5764                 sv_catpvn(kid->op_sv, ".pm", 3);
5765                 SvREADONLY_on(kid->op_sv);
5766             }
5767             else
5768                 sv_catpvn(kid->op_sv, ".pm", 3);
5769         }
5770     }
5771
5772     /* handle override, if any */
5773     gv = gv_fetchpv("require", FALSE, SVt_PVCV);
5774     if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
5775         gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
5776
5777     if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5778         OP *kid = cUNOPo->op_first;
5779         cUNOPo->op_first = 0;
5780         op_free(o);
5781         return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
5782                                append_elem(OP_LIST, kid,
5783                                            scalar(newUNOP(OP_RV2CV, 0,
5784                                                           newGVOP(OP_GV, 0,
5785                                                                   gv))))));
5786     }
5787
5788     return ck_fun(o);
5789 }
5790
5791 OP *
5792 Perl_ck_return(pTHX_ OP *o)
5793 {
5794     OP *kid;
5795     if (CvLVALUE(PL_compcv)) {
5796         for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
5797             mod(kid, OP_LEAVESUBLV);
5798     }
5799     return o;
5800 }
5801
5802 #if 0
5803 OP *
5804 Perl_ck_retarget(pTHX_ OP *o)
5805 {
5806     Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5807     /* STUB */
5808     return o;
5809 }
5810 #endif
5811
5812 OP *
5813 Perl_ck_select(pTHX_ OP *o)
5814 {
5815     OP* kid;
5816     if (o->op_flags & OPf_KIDS) {
5817         kid = cLISTOPo->op_first->op_sibling;   /* get past pushmark */
5818         if (kid && kid->op_sibling) {
5819             o->op_type = OP_SSELECT;
5820             o->op_ppaddr = PL_ppaddr[OP_SSELECT];
5821             o = ck_fun(o);
5822             return fold_constants(o);
5823         }
5824     }
5825     o = ck_fun(o);
5826     kid = cLISTOPo->op_first->op_sibling;    /* get past pushmark */
5827     if (kid && kid->op_type == OP_RV2GV)
5828         kid->op_private &= ~HINT_STRICT_REFS;
5829     return o;
5830 }
5831
5832 OP *
5833 Perl_ck_shift(pTHX_ OP *o)
5834 {
5835     I32 type = o->op_type;
5836
5837     if (!(o->op_flags & OPf_KIDS)) {
5838         OP *argop;
5839
5840         op_free(o);
5841         argop = newUNOP(OP_RV2AV, 0,
5842             scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
5843         return newUNOP(type, 0, scalar(argop));
5844     }
5845     return scalar(modkids(ck_fun(o), type));
5846 }
5847
5848 OP *
5849 Perl_ck_sort(pTHX_ OP *o)
5850 {
5851     OP *firstkid;
5852
5853     if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
5854         simplify_sort(o);
5855     firstkid = cLISTOPo->op_first->op_sibling;          /* get past pushmark */
5856     if (o->op_flags & OPf_STACKED) {                    /* may have been cleared */
5857         OP *k = NULL;
5858         OP *kid = cUNOPx(firstkid)->op_first;           /* get past null */
5859
5860         if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
5861             linklist(kid);
5862             if (kid->op_type == OP_SCOPE) {
5863                 k = kid->op_next;
5864                 kid->op_next = 0;
5865             }
5866             else if (kid->op_type == OP_LEAVE) {
5867                 if (o->op_type == OP_SORT) {
5868                     op_null(kid);                       /* wipe out leave */
5869                     kid->op_next = kid;
5870
5871                     for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
5872                         if (k->op_next == kid)
5873                             k->op_next = 0;
5874                         /* don't descend into loops */
5875                         else if (k->op_type == OP_ENTERLOOP
5876                                  || k->op_type == OP_ENTERITER)
5877                         {
5878                             k = cLOOPx(k)->op_lastop;
5879                         }
5880                     }
5881                 }
5882                 else
5883                     kid->op_next = 0;           /* just disconnect the leave */
5884                 k = kLISTOP->op_first;
5885             }
5886             CALL_PEEP(k);
5887
5888             kid = firstkid;
5889             if (o->op_type == OP_SORT) {
5890                 /* provide scalar context for comparison function/block */
5891                 kid = scalar(kid);
5892                 kid->op_next = kid;
5893             }
5894             else
5895                 kid->op_next = k;
5896             o->op_flags |= OPf_SPECIAL;
5897         }
5898         else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
5899             op_null(firstkid);
5900
5901         firstkid = firstkid->op_sibling;
5902     }
5903
5904     /* provide list context for arguments */
5905     if (o->op_type == OP_SORT)
5906         list(firstkid);
5907
5908     return o;
5909 }
5910
5911 STATIC void
5912 S_simplify_sort(pTHX_ OP *o)
5913 {
5914     register OP *kid = cLISTOPo->op_first->op_sibling;  /* get past pushmark */
5915     OP *k;
5916     int descending;
5917     GV *gv;
5918     if (!(o->op_flags & OPf_STACKED))
5919         return;
5920     GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
5921     GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
5922     kid = kUNOP->op_first;                              /* get past null */
5923     if (kid->op_type != OP_SCOPE)
5924         return;
5925     kid = kLISTOP->op_last;                             /* get past scope */
5926     switch(kid->op_type) {
5927         case OP_NCMP:
5928         case OP_I_NCMP:
5929         case OP_SCMP:
5930             break;
5931         default:
5932             return;
5933     }
5934     k = kid;                                            /* remember this node*/
5935     if (kBINOP->op_first->op_type != OP_RV2SV)
5936         return;
5937     kid = kBINOP->op_first;                             /* get past cmp */
5938     if (kUNOP->op_first->op_type != OP_GV)
5939         return;
5940     kid = kUNOP->op_first;                              /* get past rv2sv */
5941     gv = kGVOP_gv;
5942     if (GvSTASH(gv) != PL_curstash)
5943         return;
5944     if (strEQ(GvNAME(gv), "a"))
5945         descending = 0;
5946     else if (strEQ(GvNAME(gv), "b"))
5947         descending = 1;
5948     else
5949         return;
5950
5951     kid = k;                                            /* back to cmp */
5952     if (kBINOP->op_last->op_type != OP_RV2SV)
5953         return;
5954     kid = kBINOP->op_last;                              /* down to 2nd arg */
5955     if (kUNOP->op_first->op_type != OP_GV)
5956         return;
5957     kid = kUNOP->op_first;                              /* get past rv2sv */
5958     gv = kGVOP_gv;
5959     if (GvSTASH(gv) != PL_curstash
5960         || ( descending
5961             ? strNE(GvNAME(gv), "a")
5962             : strNE(GvNAME(gv), "b")))
5963         return;
5964     o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
5965     if (descending)
5966         o->op_private |= OPpSORT_DESCEND;
5967     if (k->op_type == OP_NCMP)
5968         o->op_private |= OPpSORT_NUMERIC;
5969     if (k->op_type == OP_I_NCMP)
5970         o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
5971     kid = cLISTOPo->op_first->op_sibling;
5972     cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
5973     op_free(kid);                                     /* then delete it */
5974 }
5975
5976 OP *
5977 Perl_ck_split(pTHX_ OP *o)
5978 {
5979     register OP *kid;
5980
5981     if (o->op_flags & OPf_STACKED)
5982         return no_fh_allowed(o);
5983
5984     kid = cLISTOPo->op_first;
5985     if (kid->op_type != OP_NULL)
5986         Perl_croak(aTHX_ "panic: ck_split");
5987     kid = kid->op_sibling;
5988     op_free(cLISTOPo->op_first);
5989     cLISTOPo->op_first = kid;
5990     if (!kid) {
5991         cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
5992         cLISTOPo->op_last = kid; /* There was only one element previously */
5993     }
5994
5995     if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
5996         OP *sibl = kid->op_sibling;
5997         kid->op_sibling = 0;
5998         kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
5999         if (cLISTOPo->op_first == cLISTOPo->op_last)
6000             cLISTOPo->op_last = kid;
6001         cLISTOPo->op_first = kid;
6002         kid->op_sibling = sibl;
6003     }
6004
6005     kid->op_type = OP_PUSHRE;
6006     kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6007     scalar(kid);
6008     if (ckWARN(WARN_REGEXP) && ((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
6009       Perl_warner(aTHX_ packWARN(WARN_REGEXP),
6010                   "Use of /g modifier is meaningless in split");
6011     }
6012
6013     if (!kid->op_sibling)
6014         append_elem(OP_SPLIT, o, newDEFSVOP());
6015
6016     kid = kid->op_sibling;
6017     scalar(kid);
6018
6019     if (!kid->op_sibling)
6020         append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6021
6022     kid = kid->op_sibling;
6023     scalar(kid);
6024
6025     if (kid->op_sibling)
6026         return too_many_arguments(o,OP_DESC(o));
6027
6028     return o;
6029 }
6030
6031 OP *
6032 Perl_ck_join(pTHX_ OP *o)
6033 {
6034     if (ckWARN(WARN_SYNTAX)) {
6035         OP *kid = cLISTOPo->op_first->op_sibling;
6036         if (kid && kid->op_type == OP_MATCH) {
6037             char *pmstr = "STRING";
6038             if (PM_GETRE(kPMOP))
6039                 pmstr = PM_GETRE(kPMOP)->precomp;
6040             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6041                         "/%s/ should probably be written as \"%s\"",
6042                         pmstr, pmstr);
6043         }
6044     }
6045     return ck_fun(o);
6046 }
6047
6048 OP *
6049 Perl_ck_subr(pTHX_ OP *o)
6050 {
6051     OP *prev = ((cUNOPo->op_first->op_sibling)
6052              ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6053     OP *o2 = prev->op_sibling;
6054     OP *cvop;
6055     char *proto = 0;
6056     CV *cv = 0;
6057     GV *namegv = 0;
6058     int optional = 0;
6059     I32 arg = 0;
6060     I32 contextclass = 0;
6061     char *e = 0;
6062     STRLEN n_a;
6063     bool delete=0;
6064
6065     o->op_private |= OPpENTERSUB_HASTARG;
6066     for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6067     if (cvop->op_type == OP_RV2CV) {
6068         SVOP* tmpop;
6069         o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6070         op_null(cvop);          /* disable rv2cv */
6071         tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6072         if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6073             GV *gv = cGVOPx_gv(tmpop);
6074             cv = GvCVu(gv);
6075             if (!cv)
6076                 tmpop->op_private |= OPpEARLY_CV;
6077             else {
6078                 if (SvPOK(cv)) {
6079                     namegv = CvANON(cv) ? gv : CvGV(cv);
6080                     proto = SvPV((SV*)cv, n_a);
6081                 }
6082                 if (CvASSERTION(cv)) {
6083                     if (PL_hints & HINT_ASSERTING) {
6084                         if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
6085                             o->op_private |= OPpENTERSUB_DB;
6086                     }
6087                     else {
6088                         delete=1;
6089                         if (ckWARN(WARN_ASSERTIONS) && !(PL_hints & HINT_ASSERTIONSSEEN)) {
6090                             Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
6091                                         "Impossible to activate assertion call");
6092                         }
6093                     }
6094                 }
6095             }
6096         }
6097     }
6098     else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6099         if (o2->op_type == OP_CONST)
6100             o2->op_private &= ~OPpCONST_STRICT;
6101         else if (o2->op_type == OP_LIST) {
6102             OP *o = ((UNOP*)o2)->op_first->op_sibling;
6103             if (o && o->op_type == OP_CONST)
6104                 o->op_private &= ~OPpCONST_STRICT;
6105         }
6106     }
6107     o->op_private |= (PL_hints & HINT_STRICT_REFS);
6108     if (PERLDB_SUB && PL_curstash != PL_debstash)
6109         o->op_private |= OPpENTERSUB_DB;
6110     while (o2 != cvop) {
6111         if (proto) {
6112             switch (*proto) {
6113             case '\0':
6114                 return too_many_arguments(o, gv_ename(namegv));
6115             case ';':
6116                 optional = 1;
6117                 proto++;
6118                 continue;
6119             case '$':
6120                 proto++;
6121                 arg++;
6122                 scalar(o2);
6123                 break;
6124             case '%':
6125             case '@':
6126                 list(o2);
6127                 arg++;
6128                 break;
6129             case '&':
6130                 proto++;
6131                 arg++;
6132                 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6133                     bad_type(arg,
6134                         arg == 1 ? "block or sub {}" : "sub {}",
6135                         gv_ename(namegv), o2);
6136                 break;
6137             case '*':
6138                 /* '*' allows any scalar type, including bareword */
6139                 proto++;
6140                 arg++;
6141                 if (o2->op_type == OP_RV2GV)
6142                     goto wrapref;       /* autoconvert GLOB -> GLOBref */
6143                 else if (o2->op_type == OP_CONST)
6144                     o2->op_private &= ~OPpCONST_STRICT;
6145                 else if (o2->op_type == OP_ENTERSUB) {
6146                     /* accidental subroutine, revert to bareword */
6147                     OP *gvop = ((UNOP*)o2)->op_first;
6148                     if (gvop && gvop->op_type == OP_NULL) {
6149                         gvop = ((UNOP*)gvop)->op_first;
6150                         if (gvop) {
6151                             for (; gvop->op_sibling; gvop = gvop->op_sibling)
6152                                 ;
6153                             if (gvop &&
6154                                 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6155                                 (gvop = ((UNOP*)gvop)->op_first) &&
6156                                 gvop->op_type == OP_GV)
6157                             {
6158                                 GV *gv = cGVOPx_gv(gvop);
6159                                 OP *sibling = o2->op_sibling;
6160                                 SV *n = newSVpvn("",0);
6161                                 op_free(o2);
6162                                 gv_fullname3(n, gv, "");
6163                                 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
6164                                     sv_chop(n, SvPVX(n)+6);
6165                                 o2 = newSVOP(OP_CONST, 0, n);
6166                                 prev->op_sibling = o2;
6167                                 o2->op_sibling = sibling;
6168                             }
6169                         }
6170                     }
6171                 }
6172                 scalar(o2);
6173                 break;
6174             case '[': case ']':
6175                  goto oops;
6176                  break;
6177             case '\\':
6178                 proto++;
6179                 arg++;
6180             again:
6181                 switch (*proto++) {
6182                 case '[':
6183                      if (contextclass++ == 0) {
6184                           e = strchr(proto, ']');
6185                           if (!e || e == proto)
6186                                goto oops;
6187                      }
6188                      else
6189                           goto oops;
6190                      goto again;
6191                      break;
6192                 case ']':
6193                      if (contextclass) {
6194                          char *p = proto;
6195                          char s = *p;
6196                          contextclass = 0;
6197                          *p = '\0';
6198                          while (*--p != '[');
6199                          bad_type(arg, Perl_form(aTHX_ "one of %s", p),
6200                                  gv_ename(namegv), o2);
6201                          *proto = s;
6202                      } else
6203                           goto oops;
6204                      break;
6205                 case '*':
6206                      if (o2->op_type == OP_RV2GV)
6207                           goto wrapref;
6208                      if (!contextclass)
6209                           bad_type(arg, "symbol", gv_ename(namegv), o2);
6210                      break;
6211                 case '&':
6212                      if (o2->op_type == OP_ENTERSUB)
6213                           goto wrapref;
6214                      if (!contextclass)
6215                           bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6216                      break;
6217                 case '$':
6218                     if (o2->op_type == OP_RV2SV ||
6219                         o2->op_type == OP_PADSV ||
6220                         o2->op_type == OP_HELEM ||
6221                         o2->op_type == OP_AELEM ||
6222                         o2->op_type == OP_THREADSV)
6223                          goto wrapref;
6224                     if (!contextclass)
6225                         bad_type(arg, "scalar", gv_ename(namegv), o2);
6226                      break;
6227                 case '@':
6228                     if (o2->op_type == OP_RV2AV ||
6229                         o2->op_type == OP_PADAV)
6230                          goto wrapref;
6231                     if (!contextclass)
6232                         bad_type(arg, "array", gv_ename(namegv), o2);
6233                     break;
6234                 case '%':
6235                     if (o2->op_type == OP_RV2HV ||
6236                         o2->op_type == OP_PADHV)
6237                          goto wrapref;
6238                     if (!contextclass)
6239                          bad_type(arg, "hash", gv_ename(namegv), o2);
6240                     break;
6241                 wrapref:
6242                     {
6243                         OP* kid = o2;
6244                         OP* sib = kid->op_sibling;
6245                         kid->op_sibling = 0;
6246                         o2 = newUNOP(OP_REFGEN, 0, kid);
6247                         o2->op_sibling = sib;
6248                         prev->op_sibling = o2;
6249                     }
6250                     if (contextclass && e) {
6251                          proto = e + 1;
6252                          contextclass = 0;
6253                     }
6254                     break;
6255                 default: goto oops;
6256                 }
6257                 if (contextclass)
6258                      goto again;
6259                 break;
6260             case ' ':
6261                 proto++;
6262                 continue;
6263             default:
6264               oops:
6265                 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
6266                            gv_ename(namegv), cv);
6267             }
6268         }
6269         else
6270             list(o2);
6271         mod(o2, OP_ENTERSUB);
6272         prev = o2;
6273         o2 = o2->op_sibling;
6274     }
6275     if (proto && !optional &&
6276           (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6277         return too_few_arguments(o, gv_ename(namegv));
6278     if(delete) {
6279         op_free(o);
6280         o=newSVOP(OP_CONST, 0, newSViv(0));
6281     }
6282     return o;
6283 }
6284
6285 OP *
6286 Perl_ck_svconst(pTHX_ OP *o)
6287 {
6288     SvREADONLY_on(cSVOPo->op_sv);
6289     return o;
6290 }
6291
6292 OP *
6293 Perl_ck_trunc(pTHX_ OP *o)
6294 {
6295     if (o->op_flags & OPf_KIDS) {
6296         SVOP *kid = (SVOP*)cUNOPo->op_first;
6297
6298         if (kid->op_type == OP_NULL)
6299             kid = (SVOP*)kid->op_sibling;
6300         if (kid && kid->op_type == OP_CONST &&
6301             (kid->op_private & OPpCONST_BARE))
6302         {
6303             o->op_flags |= OPf_SPECIAL;
6304             kid->op_private &= ~OPpCONST_STRICT;
6305         }
6306     }
6307     return ck_fun(o);
6308 }
6309
6310 OP *
6311 Perl_ck_unpack(pTHX_ OP *o)
6312 {
6313     OP *kid = cLISTOPo->op_first;
6314     if (kid->op_sibling) {
6315         kid = kid->op_sibling;
6316         if (!kid->op_sibling)
6317             kid->op_sibling = newDEFSVOP();
6318     }
6319     return ck_fun(o);
6320 }
6321
6322 OP *
6323 Perl_ck_substr(pTHX_ OP *o)
6324 {
6325     o = ck_fun(o);
6326     if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6327         OP *kid = cLISTOPo->op_first;
6328
6329         if (kid->op_type == OP_NULL)
6330             kid = kid->op_sibling;
6331         if (kid)
6332             kid->op_flags |= OPf_MOD;
6333
6334     }
6335     return o;
6336 }
6337
6338 /* A peephole optimizer.  We visit the ops in the order they're to execute. */
6339
6340 void
6341 Perl_peep(pTHX_ register OP *o)
6342 {
6343     register OP* oldop = 0;
6344
6345     if (!o || o->op_opt)
6346         return;
6347     ENTER;
6348     SAVEOP();
6349     SAVEVPTR(PL_curcop);
6350     for (; o; o = o->op_next) {
6351         if (o->op_opt)
6352             break;
6353         PL_op = o;
6354         switch (o->op_type) {
6355         case OP_SETSTATE:
6356         case OP_NEXTSTATE:
6357         case OP_DBSTATE:
6358             PL_curcop = ((COP*)o);              /* for warnings */
6359             o->op_opt = 1;
6360             break;
6361
6362         case OP_CONST:
6363             if (cSVOPo->op_private & OPpCONST_STRICT)
6364                 no_bareword_allowed(o);
6365 #ifdef USE_ITHREADS
6366         case OP_METHOD_NAMED:
6367             /* Relocate sv to the pad for thread safety.
6368              * Despite being a "constant", the SV is written to,
6369              * for reference counts, sv_upgrade() etc. */
6370             if (cSVOP->op_sv) {
6371                 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6372                 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
6373                     /* If op_sv is already a PADTMP then it is being used by
6374                      * some pad, so make a copy. */
6375                     sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
6376                     SvREADONLY_on(PAD_SVl(ix));
6377                     SvREFCNT_dec(cSVOPo->op_sv);
6378                 }
6379                 else {
6380                     SvREFCNT_dec(PAD_SVl(ix));
6381                     SvPADTMP_on(cSVOPo->op_sv);
6382                     PAD_SETSV(ix, cSVOPo->op_sv);
6383                     /* XXX I don't know how this isn't readonly already. */
6384                     SvREADONLY_on(PAD_SVl(ix));
6385                 }
6386                 cSVOPo->op_sv = Nullsv;
6387                 o->op_targ = ix;
6388             }
6389 #endif
6390             o->op_opt = 1;
6391             break;
6392
6393         case OP_CONCAT:
6394             if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6395                 if (o->op_next->op_private & OPpTARGET_MY) {
6396                     if (o->op_flags & OPf_STACKED) /* chained concats */
6397                         goto ignore_optimization;
6398                     else {
6399                         /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6400                         o->op_targ = o->op_next->op_targ;
6401                         o->op_next->op_targ = 0;
6402                         o->op_private |= OPpTARGET_MY;
6403                     }
6404                 }
6405                 op_null(o->op_next);
6406             }
6407           ignore_optimization:
6408             o->op_opt = 1;
6409             break;
6410         case OP_STUB:
6411             if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6412                 o->op_opt = 1;
6413                 break; /* Scalar stub must produce undef.  List stub is noop */
6414             }
6415             goto nothin;
6416         case OP_NULL:
6417             if (o->op_targ == OP_NEXTSTATE
6418                 || o->op_targ == OP_DBSTATE
6419                 || o->op_targ == OP_SETSTATE)
6420             {
6421                 PL_curcop = ((COP*)o);
6422             }
6423             /* XXX: We avoid setting op_seq here to prevent later calls
6424                to peep() from mistakenly concluding that optimisation
6425                has already occurred. This doesn't fix the real problem,
6426                though (See 20010220.007). AMS 20010719 */
6427             /* op_seq functionality is now replaced by op_opt */
6428             if (oldop && o->op_next) {
6429                 oldop->op_next = o->op_next;
6430                 continue;
6431             }
6432             break;
6433         case OP_SCALAR:
6434         case OP_LINESEQ:
6435         case OP_SCOPE:
6436           nothin:
6437             if (oldop && o->op_next) {
6438                 oldop->op_next = o->op_next;
6439                 continue;
6440             }
6441             o->op_opt = 1;
6442             break;
6443
6444         case OP_PADAV:
6445         case OP_GV:
6446             if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
6447                 OP* pop = (o->op_type == OP_PADAV) ?
6448                             o->op_next : o->op_next->op_next;
6449                 IV i;
6450                 if (pop && pop->op_type == OP_CONST &&
6451                     ((PL_op = pop->op_next)) &&
6452                     pop->op_next->op_type == OP_AELEM &&
6453                     !(pop->op_next->op_private &
6454                       (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6455                     (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
6456                                 <= 255 &&
6457                     i >= 0)
6458                 {
6459                     GV *gv;
6460                     if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
6461                         no_bareword_allowed(pop);
6462                     if (o->op_type == OP_GV)
6463                         op_null(o->op_next);
6464                     op_null(pop->op_next);
6465                     op_null(pop);
6466                     o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6467                     o->op_next = pop->op_next->op_next;
6468                     o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6469                     o->op_private = (U8)i;
6470                     if (o->op_type == OP_GV) {
6471                         gv = cGVOPo_gv;
6472                         GvAVn(gv);
6473                     }
6474                     else
6475                         o->op_flags |= OPf_SPECIAL;
6476                     o->op_type = OP_AELEMFAST;
6477                 }
6478                 o->op_opt = 1;
6479                 break;
6480             }
6481
6482             if (o->op_next->op_type == OP_RV2SV) {
6483                 if (!(o->op_next->op_private & OPpDEREF)) {
6484                     op_null(o->op_next);
6485                     o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6486                                                                | OPpOUR_INTRO);
6487                     o->op_next = o->op_next->op_next;
6488                     o->op_type = OP_GVSV;
6489                     o->op_ppaddr = PL_ppaddr[OP_GVSV];
6490                 }
6491             }
6492             else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6493                 GV *gv = cGVOPo_gv;
6494                 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
6495                     /* XXX could check prototype here instead of just carping */
6496                     SV *sv = sv_newmortal();
6497                     gv_efullname3(sv, gv, Nullch);
6498                     Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
6499                                 "%"SVf"() called too early to check prototype",
6500                                 sv);
6501                 }
6502             }
6503             else if (o->op_next->op_type == OP_READLINE
6504                     && o->op_next->op_next->op_type == OP_CONCAT
6505                     && (o->op_next->op_next->op_flags & OPf_STACKED))
6506             {
6507                 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
6508                 o->op_type   = OP_RCATLINE;
6509                 o->op_flags |= OPf_STACKED;
6510                 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
6511                 op_null(o->op_next->op_next);
6512                 op_null(o->op_next);
6513             }
6514
6515             o->op_opt = 1;
6516             break;
6517
6518         case OP_MAPWHILE:
6519         case OP_GREPWHILE:
6520         case OP_AND:
6521         case OP_OR:
6522         case OP_DOR:
6523         case OP_ANDASSIGN:
6524         case OP_ORASSIGN:
6525         case OP_DORASSIGN:
6526         case OP_COND_EXPR:
6527         case OP_RANGE:
6528             o->op_opt = 1;
6529             while (cLOGOP->op_other->op_type == OP_NULL)
6530                 cLOGOP->op_other = cLOGOP->op_other->op_next;
6531             peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
6532             break;
6533
6534         case OP_ENTERLOOP:
6535         case OP_ENTERITER:
6536             o->op_opt = 1;
6537             while (cLOOP->op_redoop->op_type == OP_NULL)
6538                 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6539             peep(cLOOP->op_redoop);
6540             while (cLOOP->op_nextop->op_type == OP_NULL)
6541                 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6542             peep(cLOOP->op_nextop);
6543             while (cLOOP->op_lastop->op_type == OP_NULL)
6544                 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6545             peep(cLOOP->op_lastop);
6546             break;
6547
6548         case OP_QR:
6549         case OP_MATCH:
6550         case OP_SUBST:
6551             o->op_opt = 1;
6552             while (cPMOP->op_pmreplstart &&
6553                    cPMOP->op_pmreplstart->op_type == OP_NULL)
6554                 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6555             peep(cPMOP->op_pmreplstart);
6556             break;
6557
6558         case OP_EXEC:
6559             o->op_opt = 1;
6560             if (ckWARN(WARN_SYNTAX) && o->op_next
6561                 && o->op_next->op_type == OP_NEXTSTATE) {
6562                 if (o->op_next->op_sibling &&
6563                         o->op_next->op_sibling->op_type != OP_EXIT &&
6564                         o->op_next->op_sibling->op_type != OP_WARN &&
6565                         o->op_next->op_sibling->op_type != OP_DIE) {
6566                     line_t oldline = CopLINE(PL_curcop);
6567
6568                     CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6569                     Perl_warner(aTHX_ packWARN(WARN_EXEC),
6570                                 "Statement unlikely to be reached");
6571                     Perl_warner(aTHX_ packWARN(WARN_EXEC),
6572                                 "\t(Maybe you meant system() when you said exec()?)\n");
6573                     CopLINE_set(PL_curcop, oldline);
6574                 }
6575             }
6576             break;
6577
6578         case OP_HELEM: {
6579             SV *lexname;
6580             SV **svp, *sv;
6581             char *key = NULL;
6582             STRLEN keylen;
6583
6584             o->op_opt = 1;
6585
6586             if (((BINOP*)o)->op_last->op_type != OP_CONST)
6587                 break;
6588
6589             /* Make the CONST have a shared SV */
6590             svp = cSVOPx_svp(((BINOP*)o)->op_last);
6591             if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
6592                 key = SvPV(sv, keylen);
6593                 lexname = newSVpvn_share(key,
6594                                          SvUTF8(sv) ? -(I32)keylen : keylen,
6595                                          0);
6596                 SvREFCNT_dec(sv);
6597                 *svp = lexname;
6598             }
6599             break;
6600         }
6601
6602         case OP_SORT: {
6603             /* will point to RV2AV or PADAV op on LHS/RHS of assign */
6604             OP *oleft, *oright;
6605             OP *o2;
6606
6607             /* check that RHS of sort is a single plain array */
6608             oright = cUNOPo->op_first;
6609             if (!oright || oright->op_type != OP_PUSHMARK)
6610                 break;
6611
6612             /* reverse sort ... can be optimised.  */
6613             if (!cUNOPo->op_sibling) {
6614                 /* Nothing follows us on the list. */
6615                 OP *reverse = o->op_next;
6616
6617                 if (reverse->op_type == OP_REVERSE &&
6618                     (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
6619                     OP *pushmark = cUNOPx(reverse)->op_first;
6620                     if (pushmark && (pushmark->op_type == OP_PUSHMARK)
6621                         && (cUNOPx(pushmark)->op_sibling == o)) {
6622                         /* reverse -> pushmark -> sort */
6623                         o->op_private |= OPpSORT_REVERSE;
6624                         op_null(reverse);
6625                         pushmark->op_next = oright->op_next;
6626                         op_null(oright);
6627                     }
6628                 }
6629             }
6630
6631             /* make @a = sort @a act in-place */
6632
6633             o->op_opt = 1;
6634
6635             oright = cUNOPx(oright)->op_sibling;
6636             if (!oright)
6637                 break;
6638             if (oright->op_type == OP_NULL) { /* skip sort block/sub */
6639                 oright = cUNOPx(oright)->op_sibling;
6640             }
6641
6642             if (!oright ||
6643                 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
6644                 || oright->op_next != o
6645                 || (oright->op_private & OPpLVAL_INTRO)
6646             )
6647                 break;
6648
6649             /* o2 follows the chain of op_nexts through the LHS of the
6650              * assign (if any) to the aassign op itself */
6651             o2 = o->op_next;
6652             if (!o2 || o2->op_type != OP_NULL)
6653                 break;
6654             o2 = o2->op_next;
6655             if (!o2 || o2->op_type != OP_PUSHMARK)
6656                 break;
6657             o2 = o2->op_next;
6658             if (o2 && o2->op_type == OP_GV)
6659                 o2 = o2->op_next;
6660             if (!o2
6661                 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
6662                 || (o2->op_private & OPpLVAL_INTRO)
6663             )
6664                 break;
6665             oleft = o2;
6666             o2 = o2->op_next;
6667             if (!o2 || o2->op_type != OP_NULL)
6668                 break;
6669             o2 = o2->op_next;
6670             if (!o2 || o2->op_type != OP_AASSIGN
6671                     || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
6672                 break;
6673
6674             /* check that the sort is the first arg on RHS of assign */
6675
6676             o2 = cUNOPx(o2)->op_first;
6677             if (!o2 || o2->op_type != OP_NULL)
6678                 break;
6679             o2 = cUNOPx(o2)->op_first;
6680             if (!o2 || o2->op_type != OP_PUSHMARK)
6681                 break;
6682             if (o2->op_sibling != o)
6683                 break;
6684
6685             /* check the array is the same on both sides */
6686             if (oleft->op_type == OP_RV2AV) {
6687                 if (oright->op_type != OP_RV2AV
6688                     || !cUNOPx(oright)->op_first
6689                     || cUNOPx(oright)->op_first->op_type != OP_GV
6690                     ||  cGVOPx_gv(cUNOPx(oleft)->op_first) !=
6691                         cGVOPx_gv(cUNOPx(oright)->op_first)
6692                 )
6693                     break;
6694             }
6695             else if (oright->op_type != OP_PADAV
6696                 || oright->op_targ != oleft->op_targ
6697             )
6698                 break;
6699
6700             /* transfer MODishness etc from LHS arg to RHS arg */
6701             oright->op_flags = oleft->op_flags;
6702             o->op_private |= OPpSORT_INPLACE;
6703
6704             /* excise push->gv->rv2av->null->aassign */
6705             o2 = o->op_next->op_next;
6706             op_null(o2); /* PUSHMARK */
6707             o2 = o2->op_next;
6708             if (o2->op_type == OP_GV) {
6709                 op_null(o2); /* GV */
6710                 o2 = o2->op_next;
6711             }
6712             op_null(o2); /* RV2AV or PADAV */
6713             o2 = o2->op_next->op_next;
6714             op_null(o2); /* AASSIGN */
6715
6716             o->op_next = o2->op_next;
6717
6718             break;
6719         }
6720
6721         case OP_REVERSE: {
6722             OP *ourmark, *theirmark, *ourlast, *iter, *expushmark;
6723             OP *gvop = NULL;
6724             LISTOP *enter, *exlist;
6725             o->op_opt = 1;
6726
6727             enter = (LISTOP *) o->op_next;
6728             if (!enter)
6729                 break;
6730             if (enter->op_type == OP_NULL) {
6731                 enter = (LISTOP *) enter->op_next;
6732                 if (!enter)
6733                     break;
6734             }
6735             /* for $a (...) will have OP_GV then OP_RV2GV here.  */
6736             if (enter->op_type == OP_GV) {
6737                 gvop = (OP *) enter;
6738                 enter = (LISTOP *) enter->op_next;
6739                 if (!enter)
6740                     break;
6741                 if (enter->op_type != OP_RV2GV)
6742                     break;
6743                 enter = (LISTOP *) enter->op_next;
6744                 if (!enter)
6745                     break;
6746             }
6747
6748             if (enter->op_type != OP_ENTERITER)
6749                 break;
6750
6751             iter = enter->op_next;
6752             if (!iter || iter->op_type != OP_ITER)
6753                 break;
6754
6755             expushmark = enter->op_first;
6756             if (!expushmark || expushmark->op_type != OP_NULL
6757                 || expushmark->op_targ != OP_PUSHMARK)
6758                 break;
6759
6760             exlist = (LISTOP *) expushmark->op_sibling;
6761             if (!exlist || exlist->op_type != OP_NULL
6762                 || exlist->op_targ != OP_LIST)
6763                 break;
6764
6765             if (exlist->op_last != o) {
6766                 /* Mmm. Was expecting to point back to this op.  */
6767                 break;
6768             }
6769             theirmark = exlist->op_first;
6770             if (!theirmark || theirmark->op_type != OP_PUSHMARK)
6771                 break;
6772
6773             if (theirmark->op_sibling != o) {
6774                 /* There's something between the mark and the reverse, eg
6775                    for (1, reverse (...))
6776                    so no go.  */
6777                 break;
6778             }
6779
6780             ourmark = ((LISTOP *)o)->op_first;
6781             if (!ourmark || ourmark->op_type != OP_PUSHMARK)
6782                 break;
6783
6784             ourlast = ((LISTOP *)o)->op_last;
6785             if (!ourlast || ourlast->op_next != o)
6786                 break;
6787
6788             /* We don't have control over who points to theirmark, so sacrifice
6789                ours.  */
6790             theirmark->op_next = ourmark->op_next;
6791             theirmark->op_flags = ourmark->op_flags;
6792             ourlast->op_next = gvop ? gvop : (OP *) enter;
6793             op_null(ourmark);
6794             op_null(o);
6795             enter->op_private |= OPpITER_REVERSED;
6796             iter->op_private |= OPpITER_REVERSED;
6797
6798             break;
6799         }
6800
6801         default:
6802             o->op_opt = 1;
6803             break;
6804         }
6805         oldop = o;
6806     }
6807     LEAVE;
6808 }
6809
6810
6811
6812 char* Perl_custom_op_name(pTHX_ OP* o)
6813 {
6814     IV  index = PTR2IV(o->op_ppaddr);
6815     SV* keysv;
6816     HE* he;
6817
6818     if (!PL_custom_op_names) /* This probably shouldn't happen */
6819         return PL_op_name[OP_CUSTOM];
6820
6821     keysv = sv_2mortal(newSViv(index));
6822
6823     he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
6824     if (!he)
6825         return PL_op_name[OP_CUSTOM]; /* Don't know who you are */
6826
6827     return SvPV_nolen(HeVAL(he));
6828 }
6829
6830 char* Perl_custom_op_desc(pTHX_ OP* o)
6831 {
6832     IV  index = PTR2IV(o->op_ppaddr);
6833     SV* keysv;
6834     HE* he;
6835
6836     if (!PL_custom_op_descs)
6837         return PL_op_desc[OP_CUSTOM];
6838
6839     keysv = sv_2mortal(newSViv(index));
6840
6841     he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
6842     if (!he)
6843         return PL_op_desc[OP_CUSTOM];
6844
6845     return SvPV_nolen(HeVAL(he));
6846 }
6847
6848
6849 #include "XSUB.h"
6850
6851 /* Efficient sub that returns a constant scalar value. */
6852 static void
6853 const_sv_xsub(pTHX_ CV* cv)
6854 {
6855     dXSARGS;
6856     if (items != 0) {
6857 #if 0
6858         Perl_croak(aTHX_ "usage: %s::%s()",
6859                    HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
6860 #endif
6861     }
6862     EXTEND(sp, 1);
6863     ST(0) = (SV*)XSANY.any_ptr;
6864     XSRETURN(1);
6865 }