op.c

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