op.c

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