op.c

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