op.c

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