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