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             left->op_flags &= ~(OPf_REF|OPf_SPECIAL);
3134             return left;
3135         }
3136         curop = list(force_list(left));
3137         o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3138         o->op_private = (U8)(0 | (flags >> 8));
3139
3140         /* PL_generation sorcery:
3141          * an assignment like ($a,$b) = ($c,$d) is easier than
3142          * ($a,$b) = ($c,$a), since there is no need for temporary vars.
3143          * To detect whether there are common vars, the global var
3144          * PL_generation is incremented for each assign op we compile.
3145          * Then, while compiling the assign op, we run through all the
3146          * variables on both sides of the assignment, setting a spare slot
3147          * in each of them to PL_generation. If any of them already have
3148          * that value, we know we've got commonality.  We could use a
3149          * single bit marker, but then we'd have to make 2 passes, first
3150          * to clear the flag, then to test and set it.  To find somewhere
3151          * to store these values, evil chicanery is done with SvCUR().
3152          */
3153
3154         if (!(left->op_private & OPpLVAL_INTRO)) {
3155             OP *lastop = o;
3156             PL_generation++;
3157             for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3158                 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3159                     if (curop->op_type == OP_GV) {
3160                         GV *gv = cGVOPx_gv(curop);
3161                         if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3162                             break;
3163                         SvCUR(gv) = PL_generation;
3164                     }
3165                     else if (curop->op_type == OP_PADSV ||
3166                              curop->op_type == OP_PADAV ||
3167                              curop->op_type == OP_PADHV ||
3168                              curop->op_type == OP_PADANY)
3169                     {
3170                         if (PAD_COMPNAME_GEN(curop->op_targ)
3171                                                     == (STRLEN)PL_generation)
3172                             break;
3173                         PAD_COMPNAME_GEN(curop->op_targ)
3174                                                         = PL_generation;
3175
3176                     }
3177                     else if (curop->op_type == OP_RV2CV)
3178                         break;
3179                     else if (curop->op_type == OP_RV2SV ||
3180                              curop->op_type == OP_RV2AV ||
3181                              curop->op_type == OP_RV2HV ||
3182                              curop->op_type == OP_RV2GV) {
3183                         if (lastop->op_type != OP_GV)   /* funny deref? */
3184                             break;
3185                     }
3186                     else if (curop->op_type == OP_PUSHRE) {
3187                         if (((PMOP*)curop)->op_pmreplroot) {
3188 #ifdef USE_ITHREADS
3189                             GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET,
3190                                         ((PMOP*)curop)->op_pmreplroot));
3191 #else
3192                             GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3193 #endif
3194                             if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3195                                 break;
3196                             SvCUR(gv) = PL_generation;
3197                         }
3198                     }
3199                     else
3200                         break;
3201                 }
3202                 lastop = curop;
3203             }
3204             if (curop != o)
3205                 o->op_private |= OPpASSIGN_COMMON;
3206         }
3207         if (right && right->op_type == OP_SPLIT) {
3208             OP* tmpop;
3209             if ((tmpop = ((LISTOP*)right)->op_first) &&
3210                 tmpop->op_type == OP_PUSHRE)
3211             {
3212                 PMOP *pm = (PMOP*)tmpop;
3213                 if (left->op_type == OP_RV2AV &&
3214                     !(left->op_private & OPpLVAL_INTRO) &&
3215                     !(o->op_private & OPpASSIGN_COMMON) )
3216                 {
3217                     tmpop = ((UNOP*)left)->op_first;
3218                     if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3219 #ifdef USE_ITHREADS
3220                         pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
3221                         cPADOPx(tmpop)->op_padix = 0;   /* steal it */
3222 #else
3223                         pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3224                         cSVOPx(tmpop)->op_sv = Nullsv;  /* steal it */
3225 #endif
3226                         pm->op_pmflags |= PMf_ONCE;
3227                         tmpop = cUNOPo->op_first;       /* to list (nulled) */
3228                         tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3229                         tmpop->op_sibling = Nullop;     /* don't free split */
3230                         right->op_next = tmpop->op_next;  /* fix starting loc */
3231                         op_free(o);                     /* blow off assign */
3232                         right->op_flags &= ~OPf_WANT;
3233                                 /* "I don't know and I don't care." */
3234                         return right;
3235                     }
3236                 }
3237                 else {
3238                    if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3239                       ((LISTOP*)right)->op_last->op_type == OP_CONST)
3240                     {
3241                         SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3242                         if (SvIVX(sv) == 0)
3243                             sv_setiv(sv, PL_modcount+1);
3244                     }
3245                 }
3246             }
3247         }
3248         return o;
3249     }
3250     if (!right)
3251         right = newOP(OP_UNDEF, 0);
3252     if (right->op_type == OP_READLINE) {
3253         right->op_flags |= OPf_STACKED;
3254         return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3255     }
3256     else {
3257         PL_eval_start = right;  /* Grandfathering $[ assignment here.  Bletch.*/
3258         o = newBINOP(OP_SASSIGN, flags,
3259             scalar(right), mod(scalar(left), OP_SASSIGN) );
3260         if (PL_eval_start)
3261             PL_eval_start = 0;
3262         else {
3263             op_free(o);
3264             return Nullop;
3265         }
3266     }
3267     return o;
3268 }
3269
3270 OP *
3271 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3272 {
3273     U32 seq = intro_my();
3274     register COP *cop;
3275
3276     NewOp(1101, cop, 1, COP);
3277     if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3278         cop->op_type = OP_DBSTATE;
3279         cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3280     }
3281     else {
3282         cop->op_type = OP_NEXTSTATE;
3283         cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3284     }
3285     cop->op_flags = (U8)flags;
3286     cop->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
3287 #ifdef NATIVE_HINTS
3288     cop->op_private |= NATIVE_HINTS;
3289 #endif
3290     PL_compiling.op_private = cop->op_private;
3291     cop->op_next = (OP*)cop;
3292
3293     if (label) {
3294         cop->cop_label = label;
3295         PL_hints |= HINT_BLOCK_SCOPE;
3296     }
3297     cop->cop_seq = seq;
3298     cop->cop_arybase = PL_curcop->cop_arybase;
3299     if (specialWARN(PL_curcop->cop_warnings))
3300         cop->cop_warnings = PL_curcop->cop_warnings ;
3301     else
3302         cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3303     if (specialCopIO(PL_curcop->cop_io))
3304         cop->cop_io = PL_curcop->cop_io;
3305     else
3306         cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3307
3308
3309     if (PL_copline == NOLINE)
3310         CopLINE_set(cop, CopLINE(PL_curcop));
3311     else {
3312         CopLINE_set(cop, PL_copline);
3313         PL_copline = NOLINE;
3314     }
3315 #ifdef USE_ITHREADS
3316     CopFILE_set(cop, CopFILE(PL_curcop));       /* XXX share in a pvtable? */
3317 #else
3318     CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3319 #endif
3320     CopSTASH_set(cop, PL_curstash);
3321
3322     if (PERLDB_LINE && PL_curstash != PL_debstash) {
3323         SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3324         if (svp && *svp != &PL_sv_undef ) {
3325            (void)SvIOK_on(*svp);
3326             SvIVX(*svp) = PTR2IV(cop);
3327         }
3328     }
3329
3330     return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3331 }
3332
3333
3334 OP *
3335 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3336 {
3337     return new_logop(type, flags, &first, &other);
3338 }
3339
3340 STATIC OP *
3341 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3342 {
3343     LOGOP *logop;
3344     OP *o;
3345     OP *first = *firstp;
3346     OP *other = *otherp;
3347
3348     if (type == OP_XOR)         /* Not short circuit, but here by precedence. */
3349         return newBINOP(type, flags, scalar(first), scalar(other));
3350
3351     scalarboolean(first);
3352     /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3353     if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3354         if (type == OP_AND || type == OP_OR) {
3355             if (type == OP_AND)
3356                 type = OP_OR;
3357             else
3358                 type = OP_AND;
3359             o = first;
3360             first = *firstp = cUNOPo->op_first;
3361             if (o->op_next)
3362                 first->op_next = o->op_next;
3363             cUNOPo->op_first = Nullop;
3364             op_free(o);
3365         }
3366     }
3367     if (first->op_type == OP_CONST) {
3368         if (first->op_private & OPpCONST_STRICT)
3369             no_bareword_allowed(first);
3370         else if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
3371                 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
3372         if ((type == OP_AND &&  SvTRUE(((SVOP*)first)->op_sv)) ||
3373             (type == OP_OR  && !SvTRUE(((SVOP*)first)->op_sv)) ||
3374             (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) {
3375             op_free(first);
3376             *firstp = Nullop;
3377             if (other->op_type == OP_CONST)
3378                 other->op_private |= OPpCONST_SHORTCIRCUIT;
3379             return other;
3380         }
3381         else {
3382             /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
3383             OP *o2 = other;
3384             if ( ! (o2->op_type == OP_LIST
3385                     && (( o2 = cUNOPx(o2)->op_first))
3386                     && o2->op_type == OP_PUSHMARK
3387                     && (( o2 = o2->op_sibling)) )
3388             )
3389                 o2 = other;
3390             if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
3391                         || o2->op_type == OP_PADHV)
3392                 && o2->op_private & OPpLVAL_INTRO
3393                 && ckWARN(WARN_DEPRECATED))
3394             {
3395                 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
3396                             "Deprecated use of my() in false conditional");
3397             }
3398
3399             op_free(other);
3400             *otherp = Nullop;
3401             if (first->op_type == OP_CONST)
3402                 first->op_private |= OPpCONST_SHORTCIRCUIT;
3403             return first;
3404         }
3405     }
3406     else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS) &&
3407              type != OP_DOR) /* [#24076] Don't warn for <FH> err FOO. */
3408     {
3409         OP *k1 = ((UNOP*)first)->op_first;
3410         OP *k2 = k1->op_sibling;
3411         OPCODE warnop = 0;
3412         switch (first->op_type)
3413         {
3414         case OP_NULL:
3415             if (k2 && k2->op_type == OP_READLINE
3416                   && (k2->op_flags & OPf_STACKED)
3417                   && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3418             {
3419                 warnop = k2->op_type;
3420             }
3421             break;
3422
3423         case OP_SASSIGN:
3424             if (k1->op_type == OP_READDIR
3425                   || k1->op_type == OP_GLOB
3426                   || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3427                   || k1->op_type == OP_EACH)
3428             {
3429                 warnop = ((k1->op_type == OP_NULL)
3430                           ? (OPCODE)k1->op_targ : k1->op_type);
3431             }
3432             break;
3433         }
3434         if (warnop) {
3435             line_t oldline = CopLINE(PL_curcop);
3436             CopLINE_set(PL_curcop, PL_copline);
3437             Perl_warner(aTHX_ packWARN(WARN_MISC),
3438                  "Value of %s%s can be \"0\"; test with defined()",
3439                  PL_op_desc[warnop],
3440                  ((warnop == OP_READLINE || warnop == OP_GLOB)
3441                   ? " construct" : "() operator"));
3442             CopLINE_set(PL_curcop, oldline);
3443         }
3444     }
3445
3446     if (!other)
3447         return first;
3448
3449     if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
3450         other->op_private |= OPpASSIGN_BACKWARDS;  /* other is an OP_SASSIGN */
3451
3452     NewOp(1101, logop, 1, LOGOP);
3453
3454     logop->op_type = (OPCODE)type;
3455     logop->op_ppaddr = PL_ppaddr[type];
3456     logop->op_first = first;
3457     logop->op_flags = flags | OPf_KIDS;
3458     logop->op_other = LINKLIST(other);
3459     logop->op_private = (U8)(1 | (flags >> 8));
3460
3461     /* establish postfix order */
3462     logop->op_next = LINKLIST(first);
3463     first->op_next = (OP*)logop;
3464     first->op_sibling = other;
3465
3466     CHECKOP(type,logop);
3467
3468     o = newUNOP(OP_NULL, 0, (OP*)logop);
3469     other->op_next = o;
3470
3471     return o;
3472 }
3473
3474 OP *
3475 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3476 {
3477     LOGOP *logop;
3478     OP *start;
3479     OP *o;
3480
3481     if (!falseop)
3482         return newLOGOP(OP_AND, 0, first, trueop);
3483     if (!trueop)
3484         return newLOGOP(OP_OR, 0, first, falseop);
3485
3486     scalarboolean(first);
3487     if (first->op_type == OP_CONST) {
3488         if (first->op_private & OPpCONST_BARE &&
3489            first->op_private & OPpCONST_STRICT) {
3490            no_bareword_allowed(first);
3491        }
3492         if (SvTRUE(((SVOP*)first)->op_sv)) {
3493             op_free(first);
3494             op_free(falseop);
3495             return trueop;
3496         }
3497         else {
3498             op_free(first);
3499             op_free(trueop);
3500             return falseop;
3501         }
3502     }
3503     NewOp(1101, logop, 1, LOGOP);
3504     logop->op_type = OP_COND_EXPR;
3505     logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3506     logop->op_first = first;
3507     logop->op_flags = flags | OPf_KIDS;
3508     logop->op_private = (U8)(1 | (flags >> 8));
3509     logop->op_other = LINKLIST(trueop);
3510     logop->op_next = LINKLIST(falseop);
3511
3512     CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
3513             logop);
3514
3515     /* establish postfix order */
3516     start = LINKLIST(first);
3517     first->op_next = (OP*)logop;
3518
3519     first->op_sibling = trueop;
3520     trueop->op_sibling = falseop;
3521     o = newUNOP(OP_NULL, 0, (OP*)logop);
3522
3523     trueop->op_next = falseop->op_next = o;
3524
3525     o->op_next = start;
3526     return o;
3527 }
3528
3529 OP *
3530 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3531 {
3532     LOGOP *range;
3533     OP *flip;
3534     OP *flop;
3535     OP *leftstart;
3536     OP *o;
3537
3538     NewOp(1101, range, 1, LOGOP);
3539
3540     range->op_type = OP_RANGE;
3541     range->op_ppaddr = PL_ppaddr[OP_RANGE];
3542     range->op_first = left;
3543     range->op_flags = OPf_KIDS;
3544     leftstart = LINKLIST(left);
3545     range->op_other = LINKLIST(right);
3546     range->op_private = (U8)(1 | (flags >> 8));
3547
3548     left->op_sibling = right;
3549
3550     range->op_next = (OP*)range;
3551     flip = newUNOP(OP_FLIP, flags, (OP*)range);
3552     flop = newUNOP(OP_FLOP, 0, flip);
3553     o = newUNOP(OP_NULL, 0, flop);
3554     linklist(flop);
3555     range->op_next = leftstart;
3556
3557     left->op_next = flip;
3558     right->op_next = flop;
3559
3560     range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3561     sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3562     flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3563     sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3564
3565     flip->op_private =  left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3566     flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3567
3568     flip->op_next = o;
3569     if (!flip->op_private || !flop->op_private)
3570         linklist(o);            /* blow off optimizer unless constant */
3571
3572     return o;
3573 }
3574
3575 OP *
3576 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3577 {
3578     OP* listop;
3579     OP* o;
3580     int once = block && block->op_flags & OPf_SPECIAL &&
3581       (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3582
3583     if (expr) {
3584         if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3585             return block;       /* do {} while 0 does once */
3586         if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3587             || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3588             expr = newUNOP(OP_DEFINED, 0,
3589                 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3590         } else if (expr->op_flags & OPf_KIDS) {
3591             OP *k1 = ((UNOP*)expr)->op_first;
3592             OP *k2 = (k1) ? k1->op_sibling : NULL;
3593             switch (expr->op_type) {
3594               case OP_NULL:
3595                 if (k2 && k2->op_type == OP_READLINE
3596                       && (k2->op_flags & OPf_STACKED)
3597                       && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3598                     expr = newUNOP(OP_DEFINED, 0, expr);
3599                 break;
3600
3601               case OP_SASSIGN:
3602                 if (k1->op_type == OP_READDIR
3603                       || k1->op_type == OP_GLOB
3604                       || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3605                       || k1->op_type == OP_EACH)
3606                     expr = newUNOP(OP_DEFINED, 0, expr);
3607                 break;
3608             }
3609         }
3610     }
3611
3612     /* if block is null, the next append_elem() would put UNSTACK, a scalar
3613      * op, in listop. This is wrong. [perl #27024] */
3614     if (!block)
3615         block = newOP(OP_NULL, 0);
3616     listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3617     o = new_logop(OP_AND, 0, &expr, &listop);
3618
3619     if (listop)
3620         ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3621
3622     if (once && o != listop)
3623         o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3624
3625     if (o == listop)
3626         o = newUNOP(OP_NULL, 0, o);     /* or do {} while 1 loses outer block */
3627
3628     o->op_flags |= flags;
3629     o = scope(o);
3630     o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3631     return o;
3632 }
3633
3634 OP *
3635 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
3636 {
3637     OP *redo;
3638     OP *next = 0;
3639     OP *listop;
3640     OP *o;
3641     U8 loopflags = 0;
3642
3643     if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3644                  || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
3645         expr = newUNOP(OP_DEFINED, 0,
3646             newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3647     } else if (expr && (expr->op_flags & OPf_KIDS)) {
3648         OP *k1 = ((UNOP*)expr)->op_first;
3649         OP *k2 = (k1) ? k1->op_sibling : NULL;
3650         switch (expr->op_type) {
3651           case OP_NULL:
3652             if (k2 && k2->op_type == OP_READLINE
3653                   && (k2->op_flags & OPf_STACKED)
3654                   && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3655                 expr = newUNOP(OP_DEFINED, 0, expr);
3656             break;
3657
3658           case OP_SASSIGN:
3659             if (k1->op_type == OP_READDIR
3660                   || k1->op_type == OP_GLOB
3661                   || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3662                   || k1->op_type == OP_EACH)
3663                 expr = newUNOP(OP_DEFINED, 0, expr);
3664             break;
3665         }
3666     }
3667
3668     if (!block)
3669         block = newOP(OP_NULL, 0);
3670     else if (cont) {
3671         block = scope(block);
3672     }
3673
3674     if (cont) {
3675         next = LINKLIST(cont);
3676     }
3677     if (expr) {
3678         OP *unstack = newOP(OP_UNSTACK, 0);
3679         if (!next)
3680             next = unstack;
3681         cont = append_elem(OP_LINESEQ, cont, unstack);
3682     }
3683
3684     listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
3685     redo = LINKLIST(listop);
3686
3687     if (expr) {
3688         PL_copline = (line_t)whileline;
3689         scalar(listop);
3690         o = new_logop(OP_AND, 0, &expr, &listop);
3691         if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
3692             op_free(expr);              /* oops, it's a while (0) */
3693             op_free((OP*)loop);
3694             return Nullop;              /* listop already freed by new_logop */
3695         }
3696         if (listop)
3697             ((LISTOP*)listop)->op_last->op_next =
3698                 (o == listop ? redo : LINKLIST(o));
3699     }
3700     else
3701         o = listop;
3702
3703     if (!loop) {
3704         NewOp(1101,loop,1,LOOP);
3705         loop->op_type = OP_ENTERLOOP;
3706         loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
3707         loop->op_private = 0;
3708         loop->op_next = (OP*)loop;
3709     }
3710
3711     o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
3712
3713     loop->op_redoop = redo;
3714     loop->op_lastop = o;
3715     o->op_private |= loopflags;
3716
3717     if (next)
3718         loop->op_nextop = next;
3719     else
3720         loop->op_nextop = o;
3721
3722     o->op_flags |= flags;
3723     o->op_private |= (flags >> 8);
3724     return o;
3725 }
3726
3727 OP *
3728 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
3729 {
3730     LOOP *loop;
3731     OP *wop;
3732     PADOFFSET padoff = 0;
3733     I32 iterflags = 0;
3734     I32 iterpflags = 0;
3735
3736     if (sv) {
3737         if (sv->op_type == OP_RV2SV) {  /* symbol table variable */
3738             iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
3739             sv->op_type = OP_RV2GV;
3740             sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
3741         }
3742         else if (sv->op_type == OP_PADSV) { /* private variable */
3743             iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
3744             padoff = sv->op_targ;
3745             sv->op_targ = 0;
3746             op_free(sv);
3747             sv = Nullop;
3748         }
3749         else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
3750             padoff = sv->op_targ;
3751             sv->op_targ = 0;
3752             iterflags |= OPf_SPECIAL;
3753             op_free(sv);
3754             sv = Nullop;
3755         }
3756         else
3757             Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
3758     }
3759     else {
3760         I32 offset = pad_findmy("$_");
3761         if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
3762             sv = newGVOP(OP_GV, 0, PL_defgv);
3763         }
3764         else {
3765             padoff = offset;
3766         }
3767     }
3768     if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
3769         expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
3770         iterflags |= OPf_STACKED;
3771     }
3772     else if (expr->op_type == OP_NULL &&
3773              (expr->op_flags & OPf_KIDS) &&
3774              ((BINOP*)expr)->op_first->op_type == OP_FLOP)
3775     {
3776         /* Basically turn for($x..$y) into the same as for($x,$y), but we
3777          * set the STACKED flag to indicate that these values are to be
3778          * treated as min/max values by 'pp_iterinit'.
3779          */
3780         UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
3781         LOGOP* range = (LOGOP*) flip->op_first;
3782         OP* left  = range->op_first;
3783         OP* right = left->op_sibling;
3784         LISTOP* listop;
3785
3786         range->op_flags &= ~OPf_KIDS;
3787         range->op_first = Nullop;
3788
3789         listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
3790         listop->op_first->op_next = range->op_next;
3791         left->op_next = range->op_other;
3792         right->op_next = (OP*)listop;
3793         listop->op_next = listop->op_first;
3794
3795         op_free(expr);
3796         expr = (OP*)(listop);
3797         op_null(expr);
3798         iterflags |= OPf_STACKED;
3799     }
3800     else {
3801         expr = mod(force_list(expr), OP_GREPSTART);
3802     }
3803
3804
3805     loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
3806                                append_elem(OP_LIST, expr, scalar(sv))));
3807     assert(!loop->op_next);
3808     /* for my  $x () sets OPpLVAL_INTRO;
3809      * for our $x () sets OPpOUR_INTRO */
3810     loop->op_private = (U8)iterpflags;
3811 #ifdef PL_OP_SLAB_ALLOC
3812     {
3813         LOOP *tmp;
3814         NewOp(1234,tmp,1,LOOP);
3815         Copy(loop,tmp,1,LOOP);
3816         FreeOp(loop);
3817         loop = tmp;
3818     }
3819 #else
3820     Renew(loop, 1, LOOP);
3821 #endif
3822     loop->op_targ = padoff;
3823     wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
3824     PL_copline = forline;
3825     return newSTATEOP(0, label, wop);
3826 }
3827
3828 OP*
3829 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
3830 {
3831     OP *o;
3832     STRLEN n_a;
3833
3834     if (type != OP_GOTO || label->op_type == OP_CONST) {
3835         /* "last()" means "last" */
3836         if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
3837             o = newOP(type, OPf_SPECIAL);
3838         else {
3839             o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
3840                                         ? SvPVx(((SVOP*)label)->op_sv, n_a)
3841                                         : ""));
3842         }
3843         op_free(label);
3844     }
3845     else {
3846         /* Check whether it's going to be a goto &function */
3847         if (label->op_type == OP_ENTERSUB
3848                 && !(label->op_flags & OPf_STACKED))
3849             label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
3850         o = newUNOP(type, OPf_STACKED, label);
3851     }
3852     PL_hints |= HINT_BLOCK_SCOPE;
3853     return o;
3854 }
3855
3856 /*
3857 =for apidoc cv_undef
3858
3859 Clear out all the active components of a CV. This can happen either
3860 by an explicit C<undef &foo>, or by the reference count going to zero.
3861 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
3862 children can still follow the full lexical scope chain.
3863
3864 =cut
3865 */
3866
3867 void
3868 Perl_cv_undef(pTHX_ CV *cv)
3869 {
3870 #ifdef USE_ITHREADS
3871     if (CvFILE(cv) && !CvXSUB(cv)) {
3872         /* for XSUBs CvFILE point directly to static memory; __FILE__ */
3873         Safefree(CvFILE(cv));
3874     }
3875     CvFILE(cv) = 0;
3876 #endif
3877
3878     if (!CvXSUB(cv) && CvROOT(cv)) {
3879         if (CvDEPTH(cv))
3880             Perl_croak(aTHX_ "Can't undef active subroutine");
3881         ENTER;
3882
3883         PAD_SAVE_SETNULLPAD();
3884
3885         op_free(CvROOT(cv));
3886         CvROOT(cv) = Nullop;
3887         LEAVE;
3888     }
3889     SvPOK_off((SV*)cv);         /* forget prototype */
3890     CvGV(cv) = Nullgv;
3891
3892     pad_undef(cv);
3893
3894     /* remove CvOUTSIDE unless this is an undef rather than a free */
3895     if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
3896         if (!CvWEAKOUTSIDE(cv))
3897             SvREFCNT_dec(CvOUTSIDE(cv));
3898         CvOUTSIDE(cv) = Nullcv;
3899     }
3900     if (CvCONST(cv)) {
3901         SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
3902         CvCONST_off(cv);
3903     }
3904     if (CvXSUB(cv)) {
3905         CvXSUB(cv) = 0;
3906     }
3907     /* delete all flags except WEAKOUTSIDE */
3908     CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
3909 }
3910
3911 void
3912 Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
3913 {
3914     if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
3915         SV* msg = sv_newmortal();
3916         SV* name = Nullsv;
3917
3918         if (gv)
3919             gv_efullname3(name = sv_newmortal(), gv, Nullch);
3920         sv_setpv(msg, "Prototype mismatch:");
3921         if (name)
3922             Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
3923         if (SvPOK(cv))
3924             Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (SV *)cv);
3925         else
3926             Perl_sv_catpvf(aTHX_ msg, ": none");
3927         sv_catpv(msg, " vs ");
3928         if (p)
3929             Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
3930         else
3931             sv_catpv(msg, "none");
3932         Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, msg);
3933     }
3934 }
3935
3936 static void const_sv_xsub(pTHX_ CV* cv);
3937
3938 /*
3939
3940 =head1 Optree Manipulation Functions
3941
3942 =for apidoc cv_const_sv
3943
3944 If C<cv> is a constant sub eligible for inlining. returns the constant
3945 value returned by the sub.  Otherwise, returns NULL.
3946
3947 Constant subs can be created with C<newCONSTSUB> or as described in
3948 L<perlsub/"Constant Functions">.
3949
3950 =cut
3951 */
3952 SV *
3953 Perl_cv_const_sv(pTHX_ CV *cv)
3954 {
3955     if (!cv || !CvCONST(cv))
3956         return Nullsv;
3957     return (SV*)CvXSUBANY(cv).any_ptr;
3958 }
3959
3960 /* op_const_sv:  examine an optree to determine whether it's in-lineable.
3961  * Can be called in 3 ways:
3962  *
3963  * !cv
3964  *      look for a single OP_CONST with attached value: return the value
3965  *
3966  * cv && CvCLONE(cv) && !CvCONST(cv)
3967  *
3968  *      examine the clone prototype, and if contains only a single
3969  *      OP_CONST referencing a pad const, or a single PADSV referencing
3970  *      an outer lexical, return a non-zero value to indicate the CV is
3971  *      a candidate for "constizing" at clone time
3972  *
3973  * cv && CvCONST(cv)
3974  *
3975  *      We have just cloned an anon prototype that was marked as a const
3976  *      candidiate. Try to grab the current value, and in the case of
3977  *      PADSV, ignore it if it has multiple references. Return the value.
3978  */
3979
3980 SV *
3981 Perl_op_const_sv(pTHX_ OP *o, CV *cv)
3982 {
3983     SV *sv = Nullsv;
3984
3985     if (!o)
3986         return Nullsv;
3987
3988     if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
3989         o = cLISTOPo->op_first->op_sibling;
3990
3991     for (; o; o = o->op_next) {
3992         OPCODE type = o->op_type;
3993
3994         if (sv && o->op_next == o)
3995             return sv;
3996         if (o->op_next != o) {
3997             if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
3998                 continue;
3999             if (type == OP_DBSTATE)
4000                 continue;
4001         }
4002         if (type == OP_LEAVESUB || type == OP_RETURN)
4003             break;
4004         if (sv)
4005             return Nullsv;
4006         if (type == OP_CONST && cSVOPo->op_sv)
4007             sv = cSVOPo->op_sv;
4008         else if (cv && type == OP_CONST) {
4009             sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4010             if (!sv)
4011                 return Nullsv;
4012         }
4013         else if (cv && type == OP_PADSV) {
4014             if (CvCONST(cv)) { /* newly cloned anon */
4015                 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4016                 /* the candidate should have 1 ref from this pad and 1 ref
4017                  * from the parent */
4018                 if (!sv || SvREFCNT(sv) != 2)
4019                     return Nullsv;
4020                 sv = newSVsv(sv);
4021                 SvREADONLY_on(sv);
4022                 return sv;
4023             }
4024             else {
4025                 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
4026                     sv = &PL_sv_undef; /* an arbitrary non-null value */
4027             }
4028         }
4029         else {
4030             return Nullsv;
4031         }
4032     }
4033     return sv;
4034 }
4035
4036 void
4037 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4038 {
4039     if (o)
4040         SAVEFREEOP(o);
4041     if (proto)
4042         SAVEFREEOP(proto);
4043     if (attrs)
4044         SAVEFREEOP(attrs);
4045     if (block)
4046         SAVEFREEOP(block);
4047     Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4048 }
4049
4050 CV *
4051 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4052 {
4053     return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4054 }
4055
4056 CV *
4057 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4058 {
4059     STRLEN n_a;
4060     char *name;
4061     char *aname;
4062     GV *gv;
4063     char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
4064     register CV *cv=0;
4065     SV *const_sv;
4066
4067     name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4068     if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4069         SV *sv = sv_newmortal();
4070         Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
4071                        PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
4072                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4073         aname = SvPVX(sv);
4074     }
4075     else
4076         aname = Nullch;
4077     gv = gv_fetchpv(name ? name : (aname ? aname :
4078                     (PL_curstash ? "__ANON__" : "__ANON__::__ANON__")),
4079                     GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4080                     SVt_PVCV);
4081
4082     if (o)
4083         SAVEFREEOP(o);
4084     if (proto)
4085         SAVEFREEOP(proto);
4086     if (attrs)
4087         SAVEFREEOP(attrs);
4088
4089     if (SvTYPE(gv) != SVt_PVGV) {       /* Maybe prototype now, and had at
4090                                            maximum a prototype before. */
4091         if (SvTYPE(gv) > SVt_NULL) {
4092             if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4093                 && ckWARN_d(WARN_PROTOTYPE))
4094             {
4095                 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
4096             }
4097             cv_ckproto((CV*)gv, NULL, ps);
4098         }
4099         if (ps)
4100             sv_setpv((SV*)gv, ps);
4101         else
4102             sv_setiv((SV*)gv, -1);
4103         SvREFCNT_dec(PL_compcv);
4104         cv = PL_compcv = NULL;
4105         PL_sub_generation++;
4106         goto done;
4107     }
4108
4109     cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4110
4111 #ifdef GV_UNIQUE_CHECK
4112     if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4113         Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
4114     }
4115 #endif
4116
4117     if (!block || !ps || *ps || attrs)
4118         const_sv = Nullsv;
4119     else
4120         const_sv = op_const_sv(block, Nullcv);
4121
4122     if (cv) {
4123         bool exists = CvROOT(cv) || CvXSUB(cv);
4124
4125 #ifdef GV_UNIQUE_CHECK
4126         if (exists && GvUNIQUE(gv)) {
4127             Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
4128         }
4129 #endif
4130
4131         /* if the subroutine doesn't exist and wasn't pre-declared
4132          * with a prototype, assume it will be AUTOLOADed,
4133          * skipping the prototype check
4134          */
4135         if (exists || SvPOK(cv))
4136             cv_ckproto(cv, gv, ps);
4137         /* already defined (or promised)? */
4138         if (exists || GvASSUMECV(gv)) {
4139             if (!block && !attrs) {
4140                 if (CvFLAGS(PL_compcv)) {
4141                     /* might have had built-in attrs applied */
4142                     CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4143                 }
4144                 /* just a "sub foo;" when &foo is already defined */
4145                 SAVEFREESV(PL_compcv);
4146                 goto done;
4147             }
4148             /* ahem, death to those who redefine active sort subs */
4149             if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4150                 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4151             if (block) {
4152                 if (ckWARN(WARN_REDEFINE)
4153                     || (CvCONST(cv)
4154                         && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4155                 {
4156                     line_t oldline = CopLINE(PL_curcop);
4157                     if (PL_copline != NOLINE)
4158                         CopLINE_set(PL_curcop, PL_copline);
4159                     Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4160                         CvCONST(cv) ? "Constant subroutine %s redefined"
4161                                     : "Subroutine %s redefined", name);
4162                     CopLINE_set(PL_curcop, oldline);
4163                 }
4164                 SvREFCNT_dec(cv);
4165                 cv = Nullcv;
4166             }
4167         }
4168     }
4169     if (const_sv) {
4170         SvREFCNT_inc(const_sv);
4171         if (cv) {
4172             assert(!CvROOT(cv) && !CvCONST(cv));
4173             sv_setpv((SV*)cv, "");  /* prototype is "" */
4174             CvXSUBANY(cv).any_ptr = const_sv;
4175             CvXSUB(cv) = const_sv_xsub;
4176             CvCONST_on(cv);
4177         }
4178         else {
4179             GvCV(gv) = Nullcv;
4180             cv = newCONSTSUB(NULL, name, const_sv);
4181         }
4182         op_free(block);
4183         SvREFCNT_dec(PL_compcv);
4184         PL_compcv = NULL;
4185         PL_sub_generation++;
4186         goto done;
4187     }
4188     if (attrs) {
4189         HV *stash;
4190         SV *rcv;
4191
4192         /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4193          * before we clobber PL_compcv.
4194          */
4195         if (cv && !block) {
4196             rcv = (SV*)cv;
4197             /* Might have had built-in attributes applied -- propagate them. */
4198             CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4199             if (CvGV(cv) && GvSTASH(CvGV(cv)))
4200                 stash = GvSTASH(CvGV(cv));
4201             else if (CvSTASH(cv))
4202                 stash = CvSTASH(cv);
4203             else
4204                 stash = PL_curstash;
4205         }
4206         else {
4207             /* possibly about to re-define existing subr -- ignore old cv */
4208             rcv = (SV*)PL_compcv;
4209             if (name && GvSTASH(gv))
4210                 stash = GvSTASH(gv);
4211             else
4212                 stash = PL_curstash;
4213         }
4214         apply_attrs(stash, rcv, attrs, FALSE);
4215     }
4216     if (cv) {                           /* must reuse cv if autoloaded */
4217         if (!block) {
4218             /* got here with just attrs -- work done, so bug out */
4219             SAVEFREESV(PL_compcv);
4220             goto done;
4221         }
4222         /* transfer PL_compcv to cv */
4223         cv_undef(cv);
4224         CvFLAGS(cv) = CvFLAGS(PL_compcv);
4225         if (!CvWEAKOUTSIDE(cv))
4226             SvREFCNT_dec(CvOUTSIDE(cv));
4227         CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4228         CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
4229         CvOUTSIDE(PL_compcv) = 0;
4230         CvPADLIST(cv) = CvPADLIST(PL_compcv);
4231         CvPADLIST(PL_compcv) = 0;
4232         /* inner references to PL_compcv must be fixed up ... */
4233         pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
4234         /* ... before we throw it away */
4235         SvREFCNT_dec(PL_compcv);
4236         PL_compcv = cv;
4237         if (PERLDB_INTER)/* Advice debugger on the new sub. */
4238           ++PL_sub_generation;
4239     }
4240     else {
4241         cv = PL_compcv;
4242         if (name) {
4243             GvCV(gv) = cv;
4244             GvCVGEN(gv) = 0;
4245             PL_sub_generation++;
4246         }
4247     }
4248     CvGV(cv) = gv;
4249     CvFILE_set_from_cop(cv, PL_curcop);
4250     CvSTASH(cv) = PL_curstash;
4251
4252     if (ps)
4253         sv_setpv((SV*)cv, ps);
4254
4255     if (PL_error_count) {
4256         op_free(block);
4257         block = Nullop;
4258         if (name) {
4259             char *s = strrchr(name, ':');
4260             s = s ? s+1 : name;
4261             if (strEQ(s, "BEGIN")) {
4262                 char *not_safe =
4263                     "BEGIN not safe after errors--compilation aborted";
4264                 if (PL_in_eval & EVAL_KEEPERR)
4265                     Perl_croak(aTHX_ not_safe);
4266                 else {
4267                     /* force display of errors found but not reported */
4268                     sv_catpv(ERRSV, not_safe);
4269                     Perl_croak(aTHX_ "%"SVf, ERRSV);
4270                 }
4271             }
4272         }
4273     }
4274     if (!block)
4275         goto done;
4276
4277     if (CvLVALUE(cv)) {
4278         CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4279                              mod(scalarseq(block), OP_LEAVESUBLV));
4280     }
4281     else {
4282         /* This makes sub {}; work as expected.  */
4283         if (block->op_type == OP_STUB) {
4284             op_free(block);
4285             block = newSTATEOP(0, Nullch, 0);
4286         }
4287         CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4288     }
4289     CvROOT(cv)->op_private |= OPpREFCOUNTED;
4290     OpREFCNT_set(CvROOT(cv), 1);
4291     CvSTART(cv) = LINKLIST(CvROOT(cv));
4292     CvROOT(cv)->op_next = 0;
4293     CALL_PEEP(CvSTART(cv));
4294
4295     /* now that optimizer has done its work, adjust pad values */
4296
4297     pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
4298
4299     if (CvCLONE(cv)) {
4300         assert(!CvCONST(cv));
4301         if (ps && !*ps && op_const_sv(block, cv))
4302             CvCONST_on(cv);
4303     }
4304
4305     if (name || aname) {
4306         char *s;
4307         char *tname = (name ? name : aname);
4308
4309         if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4310             SV *sv = NEWSV(0,0);
4311             SV *tmpstr = sv_newmortal();
4312             GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4313             CV *pcv;
4314             HV *hv;
4315
4316             Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4317                            CopFILE(PL_curcop),
4318                            (long)PL_subline, (long)CopLINE(PL_curcop));
4319             gv_efullname3(tmpstr, gv, Nullch);
4320             hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
4321             hv = GvHVn(db_postponed);
4322             if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
4323                 && (pcv = GvCV(db_postponed)))
4324             {
4325                 dSP;
4326                 PUSHMARK(SP);
4327                 XPUSHs(tmpstr);
4328                 PUTBACK;
4329                 call_sv((SV*)pcv, G_DISCARD);
4330             }
4331         }
4332
4333         if ((s = strrchr(tname,':')))
4334             s++;
4335         else
4336             s = tname;
4337
4338         if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4339             goto done;
4340
4341         if (strEQ(s, "BEGIN") && !PL_error_count) {
4342             I32 oldscope = PL_scopestack_ix;
4343             ENTER;
4344             SAVECOPFILE(&PL_compiling);
4345             SAVECOPLINE(&PL_compiling);
4346
4347             if (!PL_beginav)
4348                 PL_beginav = newAV();
4349             DEBUG_x( dump_sub(gv) );
4350             av_push(PL_beginav, (SV*)cv);
4351             GvCV(gv) = 0;               /* cv has been hijacked */
4352             call_list(oldscope, PL_beginav);
4353
4354             PL_curcop = &PL_compiling;
4355             PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4356             LEAVE;
4357         }
4358         else if (strEQ(s, "END") && !PL_error_count) {
4359             if (!PL_endav)
4360                 PL_endav = newAV();
4361             DEBUG_x( dump_sub(gv) );
4362             av_unshift(PL_endav, 1);
4363             av_store(PL_endav, 0, (SV*)cv);
4364             GvCV(gv) = 0;               /* cv has been hijacked */
4365         }
4366         else if (strEQ(s, "CHECK") && !PL_error_count) {
4367             if (!PL_checkav)
4368                 PL_checkav = newAV();
4369             DEBUG_x( dump_sub(gv) );
4370             if (PL_main_start && ckWARN(WARN_VOID))
4371                 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4372             av_unshift(PL_checkav, 1);
4373             av_store(PL_checkav, 0, (SV*)cv);
4374             GvCV(gv) = 0;               /* cv has been hijacked */
4375         }
4376         else if (strEQ(s, "INIT") && !PL_error_count) {
4377             if (!PL_initav)
4378                 PL_initav = newAV();
4379             DEBUG_x( dump_sub(gv) );
4380             if (PL_main_start && ckWARN(WARN_VOID))
4381                 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4382             av_push(PL_initav, (SV*)cv);
4383             GvCV(gv) = 0;               /* cv has been hijacked */
4384         }
4385     }
4386
4387   done:
4388     PL_copline = NOLINE;
4389     LEAVE_SCOPE(floor);
4390     return cv;
4391 }
4392
4393 /* XXX unsafe for threads if eval_owner isn't held */
4394 /*
4395 =for apidoc newCONSTSUB
4396
4397 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4398 eligible for inlining at compile-time.
4399
4400 =cut
4401 */
4402
4403 CV *
4404 Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
4405 {
4406     CV* cv;
4407
4408     ENTER;
4409
4410     SAVECOPLINE(PL_curcop);
4411     CopLINE_set(PL_curcop, PL_copline);
4412
4413     SAVEHINTS();
4414     PL_hints &= ~HINT_BLOCK_SCOPE;
4415
4416     if (stash) {
4417         SAVESPTR(PL_curstash);
4418         SAVECOPSTASH(PL_curcop);
4419         PL_curstash = stash;
4420         CopSTASH_set(PL_curcop,stash);
4421     }
4422
4423     cv = newXS(name, const_sv_xsub, savepv(CopFILE(PL_curcop)));
4424     CvXSUBANY(cv).any_ptr = sv;
4425     CvCONST_on(cv);
4426     sv_setpv((SV*)cv, "");  /* prototype is "" */
4427
4428     if (stash)
4429         CopSTASH_free(PL_curcop);
4430
4431     LEAVE;
4432
4433     return cv;
4434 }
4435
4436 /*
4437 =for apidoc U||newXS
4438
4439 Used by C<xsubpp> to hook up XSUBs as Perl subs.
4440
4441 =cut
4442 */
4443
4444 CV *
4445 Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
4446 {
4447     GV *gv = gv_fetchpv(name ? name :
4448                         (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4449                         GV_ADDMULTI, SVt_PVCV);
4450     register CV *cv;
4451
4452     if (!subaddr)
4453         Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
4454
4455     if ((cv = (name ? GvCV(gv) : Nullcv))) {
4456         if (GvCVGEN(gv)) {
4457             /* just a cached method */
4458             SvREFCNT_dec(cv);
4459             cv = 0;
4460         }
4461         else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4462             /* already defined (or promised) */
4463             if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
4464                             && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
4465                 line_t oldline = CopLINE(PL_curcop);
4466                 if (PL_copline != NOLINE)
4467                     CopLINE_set(PL_curcop, PL_copline);
4468                 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4469                             CvCONST(cv) ? "Constant subroutine %s redefined"
4470                                         : "Subroutine %s redefined"
4471                             ,name);
4472                 CopLINE_set(PL_curcop, oldline);
4473             }
4474             SvREFCNT_dec(cv);
4475             cv = 0;
4476         }
4477     }
4478
4479     if (cv)                             /* must reuse cv if autoloaded */
4480         cv_undef(cv);
4481     else {
4482         cv = (CV*)NEWSV(1105,0);
4483         sv_upgrade((SV *)cv, SVt_PVCV);
4484         if (name) {
4485             GvCV(gv) = cv;
4486             GvCVGEN(gv) = 0;
4487             PL_sub_generation++;
4488         }
4489     }
4490     CvGV(cv) = gv;
4491     (void)gv_fetchfile(filename);
4492     CvFILE(cv) = filename;      /* NOTE: not copied, as it is expected to be
4493                                    an external constant string */
4494     CvXSUB(cv) = subaddr;
4495
4496     if (name) {
4497         char *s = strrchr(name,':');
4498         if (s)
4499             s++;
4500         else
4501             s = name;
4502
4503         if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4504             goto done;
4505
4506         if (strEQ(s, "BEGIN")) {
4507             if (!PL_beginav)
4508                 PL_beginav = newAV();
4509             av_push(PL_beginav, (SV*)cv);
4510             GvCV(gv) = 0;               /* cv has been hijacked */
4511         }
4512         else if (strEQ(s, "END")) {
4513             if (!PL_endav)
4514                 PL_endav = newAV();
4515             av_unshift(PL_endav, 1);
4516             av_store(PL_endav, 0, (SV*)cv);
4517             GvCV(gv) = 0;               /* cv has been hijacked */
4518         }
4519         else if (strEQ(s, "CHECK")) {
4520             if (!PL_checkav)
4521                 PL_checkav = newAV();
4522             if (PL_main_start && ckWARN(WARN_VOID))
4523                 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4524             av_unshift(PL_checkav, 1);
4525             av_store(PL_checkav, 0, (SV*)cv);
4526             GvCV(gv) = 0;               /* cv has been hijacked */
4527         }
4528         else if (strEQ(s, "INIT")) {
4529             if (!PL_initav)
4530                 PL_initav = newAV();
4531             if (PL_main_start && ckWARN(WARN_VOID))
4532                 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4533             av_push(PL_initav, (SV*)cv);
4534             GvCV(gv) = 0;               /* cv has been hijacked */
4535         }
4536     }
4537     else
4538         CvANON_on(cv);
4539
4540 done:
4541     return cv;
4542 }
4543
4544 void
4545 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
4546 {
4547     register CV *cv;
4548     char *name;
4549     GV *gv;
4550     STRLEN n_a;
4551
4552     if (o)
4553         name = SvPVx(cSVOPo->op_sv, n_a);
4554     else
4555         name = "STDOUT";
4556     gv = gv_fetchpv(name,TRUE, SVt_PVFM);
4557 #ifdef GV_UNIQUE_CHECK
4558     if (GvUNIQUE(gv)) {
4559         Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
4560     }
4561 #endif
4562     GvMULTI_on(gv);
4563     if ((cv = GvFORM(gv))) {
4564         if (ckWARN(WARN_REDEFINE)) {
4565             line_t oldline = CopLINE(PL_curcop);
4566             if (PL_copline != NOLINE)
4567                 CopLINE_set(PL_curcop, PL_copline);
4568             Perl_warner(aTHX_ packWARN(WARN_REDEFINE), "Format %s redefined",name);
4569             CopLINE_set(PL_curcop, oldline);
4570         }
4571         SvREFCNT_dec(cv);
4572     }
4573     cv = PL_compcv;
4574     GvFORM(gv) = cv;
4575     CvGV(cv) = gv;
4576     CvFILE_set_from_cop(cv, PL_curcop);
4577
4578
4579     pad_tidy(padtidy_FORMAT);
4580     CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
4581     CvROOT(cv)->op_private |= OPpREFCOUNTED;
4582     OpREFCNT_set(CvROOT(cv), 1);
4583     CvSTART(cv) = LINKLIST(CvROOT(cv));
4584     CvROOT(cv)->op_next = 0;
4585     CALL_PEEP(CvSTART(cv));
4586     op_free(o);
4587     PL_copline = NOLINE;
4588     LEAVE_SCOPE(floor);
4589 }
4590
4591 OP *
4592 Perl_newANONLIST(pTHX_ OP *o)
4593 {
4594     return newUNOP(OP_REFGEN, 0,
4595         mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
4596 }
4597
4598 OP *
4599 Perl_newANONHASH(pTHX_ OP *o)
4600 {
4601     return newUNOP(OP_REFGEN, 0,
4602         mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
4603 }
4604
4605 OP *
4606 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
4607 {
4608     return newANONATTRSUB(floor, proto, Nullop, block);
4609 }
4610
4611 OP *
4612 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
4613 {
4614     return newUNOP(OP_REFGEN, 0,
4615         newSVOP(OP_ANONCODE, 0,
4616                 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
4617 }
4618
4619 OP *
4620 Perl_oopsAV(pTHX_ OP *o)
4621 {
4622     switch (o->op_type) {
4623     case OP_PADSV:
4624         o->op_type = OP_PADAV;
4625         o->op_ppaddr = PL_ppaddr[OP_PADAV];
4626         return ref(o, OP_RV2AV);
4627
4628     case OP_RV2SV:
4629         o->op_type = OP_RV2AV;
4630         o->op_ppaddr = PL_ppaddr[OP_RV2AV];
4631         ref(o, OP_RV2AV);
4632         break;
4633
4634     default:
4635         if (ckWARN_d(WARN_INTERNAL))
4636             Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
4637         break;
4638     }
4639     return o;
4640 }
4641
4642 OP *
4643 Perl_oopsHV(pTHX_ OP *o)
4644 {
4645     switch (o->op_type) {
4646     case OP_PADSV:
4647     case OP_PADAV:
4648         o->op_type = OP_PADHV;
4649         o->op_ppaddr = PL_ppaddr[OP_PADHV];
4650         return ref(o, OP_RV2HV);
4651
4652     case OP_RV2SV:
4653     case OP_RV2AV:
4654         o->op_type = OP_RV2HV;
4655         o->op_ppaddr = PL_ppaddr[OP_RV2HV];
4656         ref(o, OP_RV2HV);
4657         break;
4658
4659     default:
4660         if (ckWARN_d(WARN_INTERNAL))
4661             Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
4662         break;
4663     }
4664     return o;
4665 }
4666
4667 OP *
4668 Perl_newAVREF(pTHX_ OP *o)
4669 {
4670     if (o->op_type == OP_PADANY) {
4671         o->op_type = OP_PADAV;
4672         o->op_ppaddr = PL_ppaddr[OP_PADAV];
4673         return o;
4674     }
4675     else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
4676                 && ckWARN(WARN_DEPRECATED)) {
4677         Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4678                 "Using an array as a reference is deprecated");
4679     }
4680     return newUNOP(OP_RV2AV, 0, scalar(o));
4681 }
4682
4683 OP *
4684 Perl_newGVREF(pTHX_ I32 type, OP *o)
4685 {
4686     if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
4687         return newUNOP(OP_NULL, 0, o);
4688     return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
4689 }
4690
4691 OP *
4692 Perl_newHVREF(pTHX_ OP *o)
4693 {
4694     if (o->op_type == OP_PADANY) {
4695         o->op_type = OP_PADHV;
4696         o->op_ppaddr = PL_ppaddr[OP_PADHV];
4697         return o;
4698     }
4699     else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
4700                 && ckWARN(WARN_DEPRECATED)) {
4701         Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4702                 "Using a hash as a reference is deprecated");
4703     }
4704     return newUNOP(OP_RV2HV, 0, scalar(o));
4705 }
4706
4707 OP *
4708 Perl_oopsCV(pTHX_ OP *o)
4709 {
4710     Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
4711     /* STUB */
4712     return o;
4713 }
4714
4715 OP *
4716 Perl_newCVREF(pTHX_ I32 flags, OP *o)
4717 {
4718     return newUNOP(OP_RV2CV, flags, scalar(o));
4719 }
4720
4721 OP *
4722 Perl_newSVREF(pTHX_ OP *o)
4723 {
4724     if (o->op_type == OP_PADANY) {
4725         o->op_type = OP_PADSV;
4726         o->op_ppaddr = PL_ppaddr[OP_PADSV];
4727         return o;
4728     }
4729     else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
4730         o->op_flags |= OPpDONE_SVREF;
4731         return o;
4732     }
4733     return newUNOP(OP_RV2SV, 0, scalar(o));
4734 }
4735
4736 /* Check routines. */
4737
4738 OP *
4739 Perl_ck_anoncode(pTHX_ OP *o)
4740 {
4741     cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
4742     cSVOPo->op_sv = Nullsv;
4743     return o;
4744 }
4745
4746 OP *
4747 Perl_ck_bitop(pTHX_ OP *o)
4748 {
4749 #define OP_IS_NUMCOMPARE(op) \
4750         ((op) == OP_LT   || (op) == OP_I_LT || \
4751          (op) == OP_GT   || (op) == OP_I_GT || \
4752          (op) == OP_LE   || (op) == OP_I_LE || \
4753          (op) == OP_GE   || (op) == OP_I_GE || \
4754          (op) == OP_EQ   || (op) == OP_I_EQ || \
4755          (op) == OP_NE   || (op) == OP_I_NE || \
4756          (op) == OP_NCMP || (op) == OP_I_NCMP)
4757     o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4758     if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
4759             && (o->op_type == OP_BIT_OR
4760              || o->op_type == OP_BIT_AND
4761              || o->op_type == OP_BIT_XOR))
4762     {
4763         OP * left = cBINOPo->op_first;
4764         OP * right = left->op_sibling;
4765         if ((OP_IS_NUMCOMPARE(left->op_type) &&
4766                 (left->op_flags & OPf_PARENS) == 0) ||
4767             (OP_IS_NUMCOMPARE(right->op_type) &&
4768                 (right->op_flags & OPf_PARENS) == 0))
4769             if (ckWARN(WARN_PRECEDENCE))
4770                 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
4771                         "Possible precedence problem on bitwise %c operator",
4772                         o->op_type == OP_BIT_OR ? '|'
4773                             : o->op_type == OP_BIT_AND ? '&' : '^'
4774                         );
4775     }
4776     return o;
4777 }
4778
4779 OP *
4780 Perl_ck_concat(pTHX_ OP *o)
4781 {
4782     OP *kid = cUNOPo->op_first;
4783     if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
4784             !(kUNOP->op_first->op_flags & OPf_MOD))
4785         o->op_flags |= OPf_STACKED;
4786     return o;
4787 }
4788
4789 OP *
4790 Perl_ck_spair(pTHX_ OP *o)
4791 {
4792     if (o->op_flags & OPf_KIDS) {
4793         OP* newop;
4794         OP* kid;
4795         OPCODE type = o->op_type;
4796         o = modkids(ck_fun(o), type);
4797         kid = cUNOPo->op_first;
4798         newop = kUNOP->op_first->op_sibling;
4799         if (newop &&
4800             (newop->op_sibling ||
4801              !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
4802              newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
4803              newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
4804
4805             return o;
4806         }
4807         op_free(kUNOP->op_first);
4808         kUNOP->op_first = newop;
4809     }
4810     o->op_ppaddr = PL_ppaddr[++o->op_type];
4811     return ck_fun(o);
4812 }
4813
4814 OP *
4815 Perl_ck_delete(pTHX_ OP *o)
4816 {
4817     o = ck_fun(o);
4818     o->op_private = 0;
4819     if (o->op_flags & OPf_KIDS) {
4820         OP *kid = cUNOPo->op_first;
4821         switch (kid->op_type) {
4822         case OP_ASLICE:
4823             o->op_flags |= OPf_SPECIAL;
4824             /* FALL THROUGH */
4825         case OP_HSLICE:
4826             o->op_private |= OPpSLICE;
4827             break;
4828         case OP_AELEM:
4829             o->op_flags |= OPf_SPECIAL;
4830             /* FALL THROUGH */
4831         case OP_HELEM:
4832             break;
4833         default:
4834             Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
4835                   OP_DESC(o));
4836         }
4837         op_null(kid);
4838     }
4839     return o;
4840 }
4841
4842 OP *
4843 Perl_ck_die(pTHX_ OP *o)
4844 {
4845 #ifdef VMS
4846     if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
4847 #endif
4848     return ck_fun(o);
4849 }
4850
4851 OP *
4852 Perl_ck_eof(pTHX_ OP *o)
4853 {
4854     I32 type = o->op_type;
4855
4856     if (o->op_flags & OPf_KIDS) {
4857         if (cLISTOPo->op_first->op_type == OP_STUB) {
4858             op_free(o);
4859             o = newUNOP(type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
4860         }
4861         return ck_fun(o);
4862     }
4863     return o;
4864 }
4865
4866 OP *
4867 Perl_ck_eval(pTHX_ OP *o)
4868 {
4869     PL_hints |= HINT_BLOCK_SCOPE;
4870     if (o->op_flags & OPf_KIDS) {
4871         SVOP *kid = (SVOP*)cUNOPo->op_first;
4872
4873         if (!kid) {
4874             o->op_flags &= ~OPf_KIDS;
4875             op_null(o);
4876         }
4877         else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
4878             LOGOP *enter;
4879
4880             cUNOPo->op_first = 0;
4881             op_free(o);
4882
4883             NewOp(1101, enter, 1, LOGOP);
4884             enter->op_type = OP_ENTERTRY;
4885             enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
4886             enter->op_private = 0;
4887
4888             /* establish postfix order */
4889             enter->op_next = (OP*)enter;
4890
4891             o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
4892             o->op_type = OP_LEAVETRY;
4893             o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
4894             enter->op_other = o;
4895             return o;
4896         }
4897         else {
4898             scalar((OP*)kid);
4899             PL_cv_has_eval = 1;
4900         }
4901     }
4902     else {
4903         op_free(o);
4904         o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
4905     }
4906     o->op_targ = (PADOFFSET)PL_hints;
4907     return o;
4908 }
4909
4910 OP *
4911 Perl_ck_exit(pTHX_ OP *o)
4912 {
4913 #ifdef VMS
4914     HV *table = GvHV(PL_hintgv);
4915     if (table) {
4916        SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
4917        if (svp && *svp && SvTRUE(*svp))
4918            o->op_private |= OPpEXIT_VMSISH;
4919     }
4920     if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
4921 #endif
4922     return ck_fun(o);
4923 }
4924
4925 OP *
4926 Perl_ck_exec(pTHX_ OP *o)
4927 {
4928     OP *kid;
4929     if (o->op_flags & OPf_STACKED) {
4930         o = ck_fun(o);
4931         kid = cUNOPo->op_first->op_sibling;
4932         if (kid->op_type == OP_RV2GV)
4933             op_null(kid);
4934     }
4935     else
4936         o = listkids(o);
4937     return o;
4938 }
4939
4940 OP *
4941 Perl_ck_exists(pTHX_ OP *o)
4942 {
4943     o = ck_fun(o);
4944     if (o->op_flags & OPf_KIDS) {
4945         OP *kid = cUNOPo->op_first;
4946         if (kid->op_type == OP_ENTERSUB) {
4947             (void) ref(kid, o->op_type);
4948             if (kid->op_type != OP_RV2CV && !PL_error_count)
4949                 Perl_croak(aTHX_ "%s argument is not a subroutine name",
4950                             OP_DESC(o));
4951             o->op_private |= OPpEXISTS_SUB;
4952         }
4953         else if (kid->op_type == OP_AELEM)
4954             o->op_flags |= OPf_SPECIAL;
4955         else if (kid->op_type != OP_HELEM)
4956             Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
4957                         OP_DESC(o));
4958         op_null(kid);
4959     }
4960     return o;
4961 }
4962
4963 #if 0
4964 OP *
4965 Perl_ck_gvconst(pTHX_ register OP *o)
4966 {
4967     o = fold_constants(o);
4968     if (o->op_type == OP_CONST)
4969         o->op_type = OP_GV;
4970     return o;
4971 }
4972 #endif
4973
4974 OP *
4975 Perl_ck_rvconst(pTHX_ register OP *o)
4976 {
4977     SVOP *kid = (SVOP*)cUNOPo->op_first;
4978
4979     o->op_private |= (PL_hints & HINT_STRICT_REFS);
4980     if (kid->op_type == OP_CONST) {
4981         char *name;
4982         int iscv;
4983         GV *gv;
4984         SV *kidsv = kid->op_sv;
4985         STRLEN n_a;
4986
4987         /* Is it a constant from cv_const_sv()? */
4988         if (SvROK(kidsv) && SvREADONLY(kidsv)) {
4989             SV *rsv = SvRV(kidsv);
4990             int svtype = SvTYPE(rsv);
4991             char *badtype = Nullch;
4992
4993             switch (o->op_type) {
4994             case OP_RV2SV:
4995                 if (svtype > SVt_PVMG)
4996                     badtype = "a SCALAR";
4997                 break;
4998             case OP_RV2AV:
4999                 if (svtype != SVt_PVAV)
5000                     badtype = "an ARRAY";
5001                 break;
5002             case OP_RV2HV:
5003                 if (svtype != SVt_PVHV)
5004                     badtype = "a HASH";
5005                 break;
5006             case OP_RV2CV:
5007                 if (svtype != SVt_PVCV)
5008                     badtype = "a CODE";
5009                 break;
5010             }
5011             if (badtype)
5012                 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5013             return o;
5014         }
5015         name = SvPV(kidsv, n_a);
5016         if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5017             char *badthing = Nullch;
5018             switch (o->op_type) {
5019             case OP_RV2SV:
5020                 badthing = "a SCALAR";
5021                 break;
5022             case OP_RV2AV:
5023                 badthing = "an ARRAY";
5024                 break;
5025             case OP_RV2HV:
5026                 badthing = "a HASH";
5027                 break;
5028             }
5029             if (badthing)
5030                 Perl_croak(aTHX_
5031           "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
5032                       name, badthing);
5033         }
5034         /*
5035          * This is a little tricky.  We only want to add the symbol if we
5036          * didn't add it in the lexer.  Otherwise we get duplicate strict
5037          * warnings.  But if we didn't add it in the lexer, we must at
5038          * least pretend like we wanted to add it even if it existed before,
5039          * or we get possible typo warnings.  OPpCONST_ENTERED says
5040          * whether the lexer already added THIS instance of this symbol.
5041          */
5042         iscv = (o->op_type == OP_RV2CV) * 2;
5043         do {
5044             gv = gv_fetchpv(name,
5045                 iscv | !(kid->op_private & OPpCONST_ENTERED),
5046                 iscv
5047                     ? SVt_PVCV
5048                     : o->op_type == OP_RV2SV
5049                         ? SVt_PV
5050                         : o->op_type == OP_RV2AV
5051                             ? SVt_PVAV
5052                             : o->op_type == OP_RV2HV
5053                                 ? SVt_PVHV
5054                                 : SVt_PVGV);
5055         } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5056         if (gv) {
5057             kid->op_type = OP_GV;
5058             SvREFCNT_dec(kid->op_sv);
5059 #ifdef USE_ITHREADS
5060             /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5061             kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5062             SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
5063             GvIN_PAD_on(gv);
5064             PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc(gv));
5065 #else
5066             kid->op_sv = SvREFCNT_inc(gv);
5067 #endif
5068             kid->op_private = 0;
5069             kid->op_ppaddr = PL_ppaddr[OP_GV];
5070         }
5071     }
5072     return o;
5073 }
5074
5075 OP *
5076 Perl_ck_ftst(pTHX_ OP *o)
5077 {
5078     I32 type = o->op_type;
5079
5080     if (o->op_flags & OPf_REF) {
5081         /* nothing */
5082     }
5083     else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5084         SVOP *kid = (SVOP*)cUNOPo->op_first;
5085
5086         if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5087             STRLEN n_a;
5088             OP *newop = newGVOP(type, OPf_REF,
5089                 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
5090             op_free(o);
5091             o = newop;
5092             return o;
5093         }
5094         else {
5095           if ((PL_hints & HINT_FILETEST_ACCESS) &&
5096               OP_IS_FILETEST_ACCESS(o))
5097             o->op_private |= OPpFT_ACCESS;
5098         }
5099         if (PL_check[kid->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst)
5100                 && kid->op_type != OP_STAT && kid->op_type != OP_LSTAT)
5101             o->op_private |= OPpFT_STACKED;
5102     }
5103     else {
5104         op_free(o);
5105         if (type == OP_FTTTY)
5106             o = newGVOP(type, OPf_REF, PL_stdingv);
5107         else
5108             o = newUNOP(type, 0, newDEFSVOP());
5109     }
5110     return o;
5111 }
5112
5113 OP *
5114 Perl_ck_fun(pTHX_ OP *o)
5115 {
5116     register OP *kid;
5117     OP **tokid;
5118     OP *sibl;
5119     I32 numargs = 0;
5120     int type = o->op_type;
5121     register I32 oa = PL_opargs[type] >> OASHIFT;
5122
5123     if (o->op_flags & OPf_STACKED) {
5124         if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5125             oa &= ~OA_OPTIONAL;
5126         else
5127             return no_fh_allowed(o);
5128     }
5129
5130     if (o->op_flags & OPf_KIDS) {
5131         STRLEN n_a;
5132         tokid = &cLISTOPo->op_first;
5133         kid = cLISTOPo->op_first;
5134         if (kid->op_type == OP_PUSHMARK ||
5135             (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5136         {
5137             tokid = &kid->op_sibling;
5138             kid = kid->op_sibling;
5139         }
5140         if (!kid && PL_opargs[type] & OA_DEFGV)
5141             *tokid = kid = newDEFSVOP();
5142
5143         while (oa && kid) {
5144             numargs++;
5145             sibl = kid->op_sibling;
5146             switch (oa & 7) {
5147             case OA_SCALAR:
5148                 /* list seen where single (scalar) arg expected? */
5149                 if (numargs == 1 && !(oa >> 4)
5150                     && kid->op_type == OP_LIST && type != OP_SCALAR)
5151                 {
5152                     return too_many_arguments(o,PL_op_desc[type]);
5153                 }
5154                 scalar(kid);
5155                 break;
5156             case OA_LIST:
5157                 if (oa < 16) {
5158                     kid = 0;
5159                     continue;
5160                 }
5161                 else
5162                     list(kid);
5163                 break;
5164             case OA_AVREF:
5165                 if ((type == OP_PUSH || type == OP_UNSHIFT)
5166                     && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5167                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5168                         "Useless use of %s with no values",
5169                         PL_op_desc[type]);
5170
5171                 if (kid->op_type == OP_CONST &&
5172                     (kid->op_private & OPpCONST_BARE))
5173                 {
5174                     char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5175                     OP *newop = newAVREF(newGVOP(OP_GV, 0,
5176                         gv_fetchpv(name, TRUE, SVt_PVAV) ));
5177                     if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5178                         Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5179                             "Array @%s missing the @ in argument %"IVdf" of %s()",
5180                             name, (IV)numargs, PL_op_desc[type]);
5181                     op_free(kid);
5182                     kid = newop;
5183                     kid->op_sibling = sibl;
5184                     *tokid = kid;
5185                 }
5186                 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5187                     bad_type(numargs, "array", PL_op_desc[type], kid);
5188                 mod(kid, type);
5189                 break;
5190             case OA_HVREF:
5191                 if (kid->op_type == OP_CONST &&
5192                     (kid->op_private & OPpCONST_BARE))
5193                 {
5194                     char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5195                     OP *newop = newHVREF(newGVOP(OP_GV, 0,
5196                         gv_fetchpv(name, TRUE, SVt_PVHV) ));
5197                     if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5198                         Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5199                             "Hash %%%s missing the %% in argument %"IVdf" of %s()",
5200                             name, (IV)numargs, PL_op_desc[type]);
5201                     op_free(kid);
5202                     kid = newop;
5203                     kid->op_sibling = sibl;
5204                     *tokid = kid;
5205                 }
5206                 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5207                     bad_type(numargs, "hash", PL_op_desc[type], kid);
5208                 mod(kid, type);
5209                 break;
5210             case OA_CVREF:
5211                 {
5212                     OP *newop = newUNOP(OP_NULL, 0, kid);
5213                     kid->op_sibling = 0;
5214                     linklist(kid);
5215                     newop->op_next = newop;
5216                     kid = newop;
5217                     kid->op_sibling = sibl;
5218                     *tokid = kid;
5219                 }
5220                 break;
5221             case OA_FILEREF:
5222                 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5223                     if (kid->op_type == OP_CONST &&
5224                         (kid->op_private & OPpCONST_BARE))
5225                     {
5226                         OP *newop = newGVOP(OP_GV, 0,
5227                             gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
5228                                         SVt_PVIO) );
5229                         if (!(o->op_private & 1) && /* if not unop */
5230                             kid == cLISTOPo->op_last)
5231                             cLISTOPo->op_last = newop;
5232                         op_free(kid);
5233                         kid = newop;
5234                     }
5235                     else if (kid->op_type == OP_READLINE) {
5236                         /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5237                         bad_type(numargs, "HANDLE", OP_DESC(o), kid);
5238                     }
5239                     else {
5240                         I32 flags = OPf_SPECIAL;
5241                         I32 priv = 0;
5242                         PADOFFSET targ = 0;
5243
5244                         /* is this op a FH constructor? */
5245                         if (is_handle_constructor(o,numargs)) {
5246                             char *name = Nullch;
5247                             STRLEN len = 0;
5248
5249                             flags = 0;
5250                             /* Set a flag to tell rv2gv to vivify
5251                              * need to "prove" flag does not mean something
5252                              * else already - NI-S 1999/05/07
5253                              */
5254                             priv = OPpDEREF;
5255                             if (kid->op_type == OP_PADSV) {
5256                                 name = PAD_COMPNAME_PV(kid->op_targ);
5257                                 /* SvCUR of a pad namesv can't be trusted
5258                                  * (see PL_generation), so calc its length
5259                                  * manually */
5260                                 if (name)
5261                                     len = strlen(name);
5262
5263                             }
5264                             else if (kid->op_type == OP_RV2SV
5265                                      && kUNOP->op_first->op_type == OP_GV)
5266                             {
5267                                 GV *gv = cGVOPx_gv(kUNOP->op_first);
5268                                 name = GvNAME(gv);
5269                                 len = GvNAMELEN(gv);
5270                             }
5271                             else if (kid->op_type == OP_AELEM
5272                                      || kid->op_type == OP_HELEM)
5273                             {
5274                                  OP *op;
5275
5276                                  name = 0;
5277                                  if ((op = ((BINOP*)kid)->op_first)) {
5278                                       SV *tmpstr = Nullsv;
5279                                       char *a =
5280                                            kid->op_type == OP_AELEM ?
5281                                            "[]" : "{}";
5282                                       if (((op->op_type == OP_RV2AV) ||
5283                                            (op->op_type == OP_RV2HV)) &&
5284                                           (op = ((UNOP*)op)->op_first) &&
5285                                           (op->op_type == OP_GV)) {
5286                                            /* packagevar $a[] or $h{} */
5287                                            GV *gv = cGVOPx_gv(op);
5288                                            if (gv)
5289                                                 tmpstr =
5290                                                      Perl_newSVpvf(aTHX_
5291                                                                    "%s%c...%c",
5292                                                                    GvNAME(gv),
5293                                                                    a[0], a[1]);
5294                                       }
5295                                       else if (op->op_type == OP_PADAV
5296                                                || op->op_type == OP_PADHV) {
5297                                            /* lexicalvar $a[] or $h{} */
5298                                            char *padname =
5299                                                 PAD_COMPNAME_PV(op->op_targ);
5300                                            if (padname)
5301                                                 tmpstr =
5302                                                      Perl_newSVpvf(aTHX_
5303                                                                    "%s%c...%c",
5304                                                                    padname + 1,
5305                                                                    a[0], a[1]);
5306
5307                                       }
5308                                       if (tmpstr) {
5309                                            name = SvPV(tmpstr, len);
5310                                            sv_2mortal(tmpstr);
5311                                       }
5312                                  }
5313                                  if (!name) {
5314                                       name = "__ANONIO__";
5315                                       len = 10;
5316                                  }
5317                                  mod(kid, type);
5318                             }
5319                             if (name) {
5320                                 SV *namesv;
5321                                 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5322                                 namesv = PAD_SVl(targ);
5323                                 (void)SvUPGRADE(namesv, SVt_PV);
5324                                 if (*name != '$')
5325                                     sv_setpvn(namesv, "$", 1);
5326                                 sv_catpvn(namesv, name, len);
5327                             }
5328                         }
5329                         kid->op_sibling = 0;
5330                         kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5331                         kid->op_targ = targ;
5332                         kid->op_private |= priv;
5333                     }
5334                     kid->op_sibling = sibl;
5335                     *tokid = kid;
5336                 }
5337                 scalar(kid);
5338                 break;
5339             case OA_SCALARREF:
5340                 mod(scalar(kid), type);
5341                 break;
5342             }
5343             oa >>= 4;
5344             tokid = &kid->op_sibling;
5345             kid = kid->op_sibling;
5346         }
5347         o->op_private |= numargs;
5348         if (kid)
5349             return too_many_arguments(o,OP_DESC(o));
5350         listkids(o);
5351     }
5352     else if (PL_opargs[type] & OA_DEFGV) {
5353         op_free(o);
5354         return newUNOP(type, 0, newDEFSVOP());
5355     }
5356
5357     if (oa) {
5358         while (oa & OA_OPTIONAL)
5359             oa >>= 4;
5360         if (oa && oa != OA_LIST)
5361             return too_few_arguments(o,OP_DESC(o));
5362     }
5363     return o;
5364 }
5365
5366 OP *
5367 Perl_ck_glob(pTHX_ OP *o)
5368 {
5369     GV *gv;
5370
5371     o = ck_fun(o);
5372     if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5373         append_elem(OP_GLOB, o, newDEFSVOP());
5374
5375     if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV))
5376           && GvCVu(gv) && GvIMPORTED_CV(gv)))
5377     {
5378         gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5379     }
5380
5381 #if !defined(PERL_EXTERNAL_GLOB)
5382     /* XXX this can be tightened up and made more failsafe. */
5383     if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
5384         GV *glob_gv;
5385         ENTER;
5386         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
5387                 newSVpvn("File::Glob", 10), Nullsv, Nullsv, Nullsv);
5388         gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5389         glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
5390         GvCV(gv) = GvCV(glob_gv);
5391         SvREFCNT_inc((SV*)GvCV(gv));
5392         GvIMPORTED_CV_on(gv);
5393         LEAVE;
5394     }
5395 #endif /* PERL_EXTERNAL_GLOB */
5396
5397     if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5398         append_elem(OP_GLOB, o,
5399                     newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5400         o->op_type = OP_LIST;
5401         o->op_ppaddr = PL_ppaddr[OP_LIST];
5402         cLISTOPo->op_first->op_type = OP_PUSHMARK;
5403         cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5404         cLISTOPo->op_first->op_targ = 0;
5405         o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5406                     append_elem(OP_LIST, o,
5407                                 scalar(newUNOP(OP_RV2CV, 0,
5408                                                newGVOP(OP_GV, 0, gv)))));
5409         o = newUNOP(OP_NULL, 0, ck_subr(o));
5410         o->op_targ = OP_GLOB;           /* hint at what it used to be */
5411         return o;
5412     }
5413     gv = newGVgen("main");
5414     gv_IOadd(gv);
5415     append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5416     scalarkids(o);
5417     return o;
5418 }
5419
5420 OP *
5421 Perl_ck_grep(pTHX_ OP *o)
5422 {
5423     LOGOP *gwop;
5424     OP *kid;
5425     OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5426     I32 offset;
5427
5428     o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5429     NewOp(1101, gwop, 1, LOGOP);
5430
5431     if (o->op_flags & OPf_STACKED) {
5432         OP* k;
5433         o = ck_sort(o);
5434         kid = cLISTOPo->op_first->op_sibling;
5435         for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
5436             kid = k;
5437         }
5438         kid->op_next = (OP*)gwop;
5439         o->op_flags &= ~OPf_STACKED;
5440     }
5441     kid = cLISTOPo->op_first->op_sibling;
5442     if (type == OP_MAPWHILE)
5443         list(kid);
5444     else
5445         scalar(kid);
5446     o = ck_fun(o);
5447     if (PL_error_count)
5448         return o;
5449     kid = cLISTOPo->op_first->op_sibling;
5450     if (kid->op_type != OP_NULL)
5451         Perl_croak(aTHX_ "panic: ck_grep");
5452     kid = kUNOP->op_first;
5453
5454     gwop->op_type = type;
5455     gwop->op_ppaddr = PL_ppaddr[type];
5456     gwop->op_first = listkids(o);
5457     gwop->op_flags |= OPf_KIDS;
5458     gwop->op_other = LINKLIST(kid);
5459     kid->op_next = (OP*)gwop;
5460     offset = pad_findmy("$_");
5461     if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
5462         o->op_private = gwop->op_private = 0;
5463         gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5464     }
5465     else {
5466         o->op_private = gwop->op_private = OPpGREP_LEX;
5467         gwop->op_targ = o->op_targ = offset;
5468     }
5469
5470     kid = cLISTOPo->op_first->op_sibling;
5471     if (!kid || !kid->op_sibling)
5472         return too_few_arguments(o,OP_DESC(o));
5473     for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5474         mod(kid, OP_GREPSTART);
5475
5476     return (OP*)gwop;
5477 }
5478
5479 OP *
5480 Perl_ck_index(pTHX_ OP *o)
5481 {
5482     if (o->op_flags & OPf_KIDS) {
5483         OP *kid = cLISTOPo->op_first->op_sibling;       /* get past pushmark */
5484         if (kid)
5485             kid = kid->op_sibling;                      /* get past "big" */
5486         if (kid && kid->op_type == OP_CONST)
5487             fbm_compile(((SVOP*)kid)->op_sv, 0);
5488     }
5489     return ck_fun(o);
5490 }
5491
5492 OP *
5493 Perl_ck_lengthconst(pTHX_ OP *o)
5494 {
5495     /* XXX length optimization goes here */
5496     return ck_fun(o);
5497 }
5498
5499 OP *
5500 Perl_ck_lfun(pTHX_ OP *o)
5501 {
5502     OPCODE type = o->op_type;
5503     return modkids(ck_fun(o), type);
5504 }
5505
5506 OP *
5507 Perl_ck_defined(pTHX_ OP *o)            /* 19990527 MJD */
5508 {
5509     if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
5510         switch (cUNOPo->op_first->op_type) {
5511         case OP_RV2AV:
5512             /* This is needed for
5513                if (defined %stash::)
5514                to work.   Do not break Tk.
5515                */
5516             break;                      /* Globals via GV can be undef */
5517         case OP_PADAV:
5518         case OP_AASSIGN:                /* Is this a good idea? */
5519             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5520                         "defined(@array) is deprecated");
5521             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5522                         "\t(Maybe you should just omit the defined()?)\n");
5523         break;
5524         case OP_RV2HV:
5525             /* This is needed for
5526                if (defined %stash::)
5527                to work.   Do not break Tk.
5528                */
5529             break;                      /* Globals via GV can be undef */
5530         case OP_PADHV:
5531             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5532                         "defined(%%hash) is deprecated");
5533             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5534                         "\t(Maybe you should just omit the defined()?)\n");
5535             break;
5536         default:
5537             /* no warning */
5538             break;
5539         }
5540     }
5541     return ck_rfun(o);
5542 }
5543
5544 OP *
5545 Perl_ck_rfun(pTHX_ OP *o)
5546 {
5547     OPCODE type = o->op_type;
5548     return refkids(ck_fun(o), type);
5549 }
5550
5551 OP *
5552 Perl_ck_listiob(pTHX_ OP *o)
5553 {
5554     register OP *kid;
5555
5556     kid = cLISTOPo->op_first;
5557     if (!kid) {
5558         o = force_list(o);
5559         kid = cLISTOPo->op_first;
5560     }
5561     if (kid->op_type == OP_PUSHMARK)
5562         kid = kid->op_sibling;
5563     if (kid && o->op_flags & OPf_STACKED)
5564         kid = kid->op_sibling;
5565     else if (kid && !kid->op_sibling) {         /* print HANDLE; */
5566         if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
5567             o->op_flags |= OPf_STACKED; /* make it a filehandle */
5568             kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
5569             cLISTOPo->op_first->op_sibling = kid;
5570             cLISTOPo->op_last = kid;
5571             kid = kid->op_sibling;
5572         }
5573     }
5574
5575     if (!kid)
5576         append_elem(o->op_type, o, newDEFSVOP());
5577
5578     return listkids(o);
5579 }
5580
5581 OP *
5582 Perl_ck_sassign(pTHX_ OP *o)
5583 {
5584     OP *kid = cLISTOPo->op_first;
5585     /* has a disposable target? */
5586     if ((PL_opargs[kid->op_type] & OA_TARGLEX)
5587         && !(kid->op_flags & OPf_STACKED)
5588         /* Cannot steal the second time! */
5589         && !(kid->op_private & OPpTARGET_MY))
5590     {
5591         OP *kkid = kid->op_sibling;
5592
5593         /* Can just relocate the target. */
5594         if (kkid && kkid->op_type == OP_PADSV
5595             && !(kkid->op_private & OPpLVAL_INTRO))
5596         {
5597             kid->op_targ = kkid->op_targ;
5598             kkid->op_targ = 0;
5599             /* Now we do not need PADSV and SASSIGN. */
5600             kid->op_sibling = o->op_sibling;    /* NULL */
5601             cLISTOPo->op_first = NULL;
5602             op_free(o);
5603             op_free(kkid);
5604             kid->op_private |= OPpTARGET_MY;    /* Used for context settings */
5605             return kid;
5606         }
5607     }
5608     /* optimise C<my $x = undef> to C<my $x> */
5609     if (kid->op_type == OP_UNDEF) {
5610         OP *kkid = kid->op_sibling;
5611         if (kkid && kkid->op_type == OP_PADSV
5612                 && (kkid->op_private & OPpLVAL_INTRO))
5613         {
5614             cLISTOPo->op_first = NULL;
5615             kid->op_sibling = NULL;
5616             op_free(o);
5617             op_free(kid);
5618             return kkid;
5619         }
5620     }
5621     return o;
5622 }
5623
5624 OP *
5625 Perl_ck_match(pTHX_ OP *o)
5626 {
5627     if (o->op_type != OP_QR) {
5628         I32 offset = pad_findmy("$_");
5629         if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS(offset) & SVpad_OUR)) {
5630             o->op_targ = offset;
5631             o->op_private |= OPpTARGET_MY;
5632         }
5633     }
5634     if (o->op_type == OP_MATCH || o->op_type == OP_QR)
5635         o->op_private |= OPpRUNTIME;
5636     return o;
5637 }
5638
5639 OP *
5640 Perl_ck_method(pTHX_ OP *o)
5641 {
5642     OP *kid = cUNOPo->op_first;
5643     if (kid->op_type == OP_CONST) {
5644         SV* sv = kSVOP->op_sv;
5645         if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
5646             OP *cmop;
5647             if (!SvREADONLY(sv) || !SvFAKE(sv)) {
5648                 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
5649             }
5650             else {
5651                 kSVOP->op_sv = Nullsv;
5652             }
5653             cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
5654             op_free(o);
5655             return cmop;
5656         }
5657     }
5658     return o;
5659 }
5660
5661 OP *
5662 Perl_ck_null(pTHX_ OP *o)
5663 {
5664     return o;
5665 }
5666
5667 OP *
5668 Perl_ck_open(pTHX_ OP *o)
5669 {
5670     HV *table = GvHV(PL_hintgv);
5671     if (table) {
5672         SV **svp;
5673         I32 mode;
5674         svp = hv_fetch(table, "open_IN", 7, FALSE);
5675         if (svp && *svp) {
5676             mode = mode_from_discipline(*svp);
5677             if (mode & O_BINARY)
5678                 o->op_private |= OPpOPEN_IN_RAW;
5679             else if (mode & O_TEXT)
5680                 o->op_private |= OPpOPEN_IN_CRLF;
5681         }
5682
5683         svp = hv_fetch(table, "open_OUT", 8, FALSE);
5684         if (svp && *svp) {
5685             mode = mode_from_discipline(*svp);
5686             if (mode & O_BINARY)
5687                 o->op_private |= OPpOPEN_OUT_RAW;
5688             else if (mode & O_TEXT)
5689                 o->op_private |= OPpOPEN_OUT_CRLF;
5690         }
5691     }
5692     if (o->op_type == OP_BACKTICK)
5693         return o;
5694     {
5695          /* In case of three-arg dup open remove strictness
5696           * from the last arg if it is a bareword. */
5697          OP *first = cLISTOPx(o)->op_first; /* The pushmark. */
5698          OP *last  = cLISTOPx(o)->op_last;  /* The bareword. */
5699          OP *oa;
5700          char *mode;
5701
5702          if ((last->op_type == OP_CONST) &&             /* The bareword. */
5703              (last->op_private & OPpCONST_BARE) &&
5704              (last->op_private & OPpCONST_STRICT) &&
5705              (oa = first->op_sibling) &&                /* The fh. */
5706              (oa = oa->op_sibling) &&                   /* The mode. */
5707              SvPOK(((SVOP*)oa)->op_sv) &&
5708              (mode = SvPVX(((SVOP*)oa)->op_sv)) &&
5709              mode[0] == '>' && mode[1] == '&' &&        /* A dup open. */
5710              (last == oa->op_sibling))                  /* The bareword. */
5711               last->op_private &= ~OPpCONST_STRICT;
5712     }
5713     return ck_fun(o);
5714 }
5715
5716 OP *
5717 Perl_ck_repeat(pTHX_ OP *o)
5718 {
5719     if (cBINOPo->op_first->op_flags & OPf_PARENS) {
5720         o->op_private |= OPpREPEAT_DOLIST;
5721         cBINOPo->op_first = force_list(cBINOPo->op_first);
5722     }
5723     else
5724         scalar(o);
5725     return o;
5726 }
5727
5728 OP *
5729 Perl_ck_require(pTHX_ OP *o)
5730 {
5731     GV* gv;
5732
5733     if (o->op_flags & OPf_KIDS) {       /* Shall we supply missing .pm? */
5734         SVOP *kid = (SVOP*)cUNOPo->op_first;
5735
5736         if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5737             char *s;
5738             for (s = SvPVX(kid->op_sv); *s; s++) {
5739                 if (*s == ':' && s[1] == ':') {
5740                     *s = '/';
5741                     Move(s+2, s+1, strlen(s+2)+1, char);
5742                     --SvCUR(kid->op_sv);
5743                 }
5744             }
5745             if (SvREADONLY(kid->op_sv)) {
5746                 SvREADONLY_off(kid->op_sv);
5747                 sv_catpvn(kid->op_sv, ".pm", 3);
5748                 SvREADONLY_on(kid->op_sv);
5749             }
5750             else
5751                 sv_catpvn(kid->op_sv, ".pm", 3);
5752         }
5753     }
5754
5755     /* handle override, if any */
5756     gv = gv_fetchpv("require", FALSE, SVt_PVCV);
5757     if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
5758         gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
5759
5760     if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5761         OP *kid = cUNOPo->op_first;
5762         cUNOPo->op_first = 0;
5763         op_free(o);
5764         return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
5765                                append_elem(OP_LIST, kid,
5766                                            scalar(newUNOP(OP_RV2CV, 0,
5767                                                           newGVOP(OP_GV, 0,
5768                                                                   gv))))));
5769     }
5770
5771     return ck_fun(o);
5772 }
5773
5774 OP *
5775 Perl_ck_return(pTHX_ OP *o)
5776 {
5777     OP *kid;
5778     if (CvLVALUE(PL_compcv)) {
5779         for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
5780             mod(kid, OP_LEAVESUBLV);
5781     }
5782     return o;
5783 }
5784
5785 #if 0
5786 OP *
5787 Perl_ck_retarget(pTHX_ OP *o)
5788 {
5789     Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5790     /* STUB */
5791     return o;
5792 }
5793 #endif
5794
5795 OP *
5796 Perl_ck_select(pTHX_ OP *o)
5797 {
5798     OP* kid;
5799     if (o->op_flags & OPf_KIDS) {
5800         kid = cLISTOPo->op_first->op_sibling;   /* get past pushmark */
5801         if (kid && kid->op_sibling) {
5802             o->op_type = OP_SSELECT;
5803             o->op_ppaddr = PL_ppaddr[OP_SSELECT];
5804             o = ck_fun(o);
5805             return fold_constants(o);
5806         }
5807     }
5808     o = ck_fun(o);
5809     kid = cLISTOPo->op_first->op_sibling;    /* get past pushmark */
5810     if (kid && kid->op_type == OP_RV2GV)
5811         kid->op_private &= ~HINT_STRICT_REFS;
5812     return o;
5813 }
5814
5815 OP *
5816 Perl_ck_shift(pTHX_ OP *o)
5817 {
5818     I32 type = o->op_type;
5819
5820     if (!(o->op_flags & OPf_KIDS)) {
5821         OP *argop;
5822
5823         op_free(o);
5824         argop = newUNOP(OP_RV2AV, 0,
5825             scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
5826         return newUNOP(type, 0, scalar(argop));
5827     }
5828     return scalar(modkids(ck_fun(o), type));
5829 }
5830
5831 OP *
5832 Perl_ck_sort(pTHX_ OP *o)
5833 {
5834     OP *firstkid;
5835
5836     if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
5837         simplify_sort(o);
5838     firstkid = cLISTOPo->op_first->op_sibling;          /* get past pushmark */
5839     if (o->op_flags & OPf_STACKED) {                    /* may have been cleared */
5840         OP *k = NULL;
5841         OP *kid = cUNOPx(firstkid)->op_first;           /* get past null */
5842
5843         if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
5844             linklist(kid);
5845             if (kid->op_type == OP_SCOPE) {
5846                 k = kid->op_next;
5847                 kid->op_next = 0;
5848             }
5849             else if (kid->op_type == OP_LEAVE) {
5850                 if (o->op_type == OP_SORT) {
5851                     op_null(kid);                       /* wipe out leave */
5852                     kid->op_next = kid;
5853
5854                     for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
5855                         if (k->op_next == kid)
5856                             k->op_next = 0;
5857                         /* don't descend into loops */
5858                         else if (k->op_type == OP_ENTERLOOP
5859                                  || k->op_type == OP_ENTERITER)
5860                         {
5861                             k = cLOOPx(k)->op_lastop;
5862                         }
5863                     }
5864                 }
5865                 else
5866                     kid->op_next = 0;           /* just disconnect the leave */
5867                 k = kLISTOP->op_first;
5868             }
5869             CALL_PEEP(k);
5870
5871             kid = firstkid;
5872             if (o->op_type == OP_SORT) {
5873                 /* provide scalar context for comparison function/block */
5874                 kid = scalar(kid);
5875                 kid->op_next = kid;
5876             }
5877             else
5878                 kid->op_next = k;
5879             o->op_flags |= OPf_SPECIAL;
5880         }
5881         else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
5882             op_null(firstkid);
5883
5884         firstkid = firstkid->op_sibling;
5885     }
5886
5887     /* provide list context for arguments */
5888     if (o->op_type == OP_SORT)
5889         list(firstkid);
5890
5891     return o;
5892 }
5893
5894 STATIC void
5895 S_simplify_sort(pTHX_ OP *o)
5896 {
5897     register OP *kid = cLISTOPo->op_first->op_sibling;  /* get past pushmark */
5898     OP *k;
5899     int reversed;
5900     GV *gv;
5901     if (!(o->op_flags & OPf_STACKED))
5902         return;
5903     GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
5904     GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
5905     kid = kUNOP->op_first;                              /* get past null */
5906     if (kid->op_type != OP_SCOPE)
5907         return;
5908     kid = kLISTOP->op_last;                             /* get past scope */
5909     switch(kid->op_type) {
5910         case OP_NCMP:
5911         case OP_I_NCMP:
5912         case OP_SCMP:
5913             break;
5914         default:
5915             return;
5916     }
5917     k = kid;                                            /* remember this node*/
5918     if (kBINOP->op_first->op_type != OP_RV2SV)
5919         return;
5920     kid = kBINOP->op_first;                             /* get past cmp */
5921     if (kUNOP->op_first->op_type != OP_GV)
5922         return;
5923     kid = kUNOP->op_first;                              /* get past rv2sv */
5924     gv = kGVOP_gv;
5925     if (GvSTASH(gv) != PL_curstash)
5926         return;
5927     if (strEQ(GvNAME(gv), "a"))
5928         reversed = 0;
5929     else if (strEQ(GvNAME(gv), "b"))
5930         reversed = 1;
5931     else
5932         return;
5933     kid = k;                                            /* back to cmp */
5934     if (kBINOP->op_last->op_type != OP_RV2SV)
5935         return;
5936     kid = kBINOP->op_last;                              /* down to 2nd arg */
5937     if (kUNOP->op_first->op_type != OP_GV)
5938         return;
5939     kid = kUNOP->op_first;                              /* get past rv2sv */
5940     gv = kGVOP_gv;
5941     if (GvSTASH(gv) != PL_curstash
5942         || ( reversed
5943             ? strNE(GvNAME(gv), "a")
5944             : strNE(GvNAME(gv), "b")))
5945         return;
5946     o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
5947     if (reversed)
5948         o->op_private |= OPpSORT_REVERSE;
5949     if (k->op_type == OP_NCMP)
5950         o->op_private |= OPpSORT_NUMERIC;
5951     if (k->op_type == OP_I_NCMP)
5952         o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
5953     kid = cLISTOPo->op_first->op_sibling;
5954     cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
5955     op_free(kid);                                     /* then delete it */
5956 }
5957
5958 OP *
5959 Perl_ck_split(pTHX_ OP *o)
5960 {
5961     register OP *kid;
5962
5963     if (o->op_flags & OPf_STACKED)
5964         return no_fh_allowed(o);
5965
5966     kid = cLISTOPo->op_first;
5967     if (kid->op_type != OP_NULL)
5968         Perl_croak(aTHX_ "panic: ck_split");
5969     kid = kid->op_sibling;
5970     op_free(cLISTOPo->op_first);
5971     cLISTOPo->op_first = kid;
5972     if (!kid) {
5973         cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
5974         cLISTOPo->op_last = kid; /* There was only one element previously */
5975     }
5976
5977     if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
5978         OP *sibl = kid->op_sibling;
5979         kid->op_sibling = 0;
5980         kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
5981         if (cLISTOPo->op_first == cLISTOPo->op_last)
5982             cLISTOPo->op_last = kid;
5983         cLISTOPo->op_first = kid;
5984         kid->op_sibling = sibl;
5985     }
5986
5987     kid->op_type = OP_PUSHRE;
5988     kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
5989     scalar(kid);
5990     if (ckWARN(WARN_REGEXP) && ((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
5991       Perl_warner(aTHX_ packWARN(WARN_REGEXP),
5992                   "Use of /g modifier is meaningless in split");
5993     }
5994
5995     if (!kid->op_sibling)
5996         append_elem(OP_SPLIT, o, newDEFSVOP());
5997
5998     kid = kid->op_sibling;
5999     scalar(kid);
6000
6001     if (!kid->op_sibling)
6002         append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6003
6004     kid = kid->op_sibling;
6005     scalar(kid);
6006
6007     if (kid->op_sibling)
6008         return too_many_arguments(o,OP_DESC(o));
6009
6010     return o;
6011 }
6012
6013 OP *
6014 Perl_ck_join(pTHX_ OP *o)
6015 {
6016     if (ckWARN(WARN_SYNTAX)) {
6017         OP *kid = cLISTOPo->op_first->op_sibling;
6018         if (kid && kid->op_type == OP_MATCH) {
6019             char *pmstr = "STRING";
6020             if (PM_GETRE(kPMOP))
6021                 pmstr = PM_GETRE(kPMOP)->precomp;
6022             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6023                         "/%s/ should probably be written as \"%s\"",
6024                         pmstr, pmstr);
6025         }
6026     }
6027     return ck_fun(o);
6028 }
6029
6030 OP *
6031 Perl_ck_subr(pTHX_ OP *o)
6032 {
6033     OP *prev = ((cUNOPo->op_first->op_sibling)
6034              ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6035     OP *o2 = prev->op_sibling;
6036     OP *cvop;
6037     char *proto = 0;
6038     CV *cv = 0;
6039     GV *namegv = 0;
6040     int optional = 0;
6041     I32 arg = 0;
6042     I32 contextclass = 0;
6043     char *e = 0;
6044     STRLEN n_a;
6045     bool delete=0;
6046
6047     o->op_private |= OPpENTERSUB_HASTARG;
6048     for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6049     if (cvop->op_type == OP_RV2CV) {
6050         SVOP* tmpop;
6051         o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6052         op_null(cvop);          /* disable rv2cv */
6053         tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6054         if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6055             GV *gv = cGVOPx_gv(tmpop);
6056             cv = GvCVu(gv);
6057             if (!cv)
6058                 tmpop->op_private |= OPpEARLY_CV;
6059             else {
6060                 if (SvPOK(cv)) {
6061                     namegv = CvANON(cv) ? gv : CvGV(cv);
6062                     proto = SvPV((SV*)cv, n_a);
6063                 }
6064                 if (CvASSERTION(cv)) {
6065                     if (PL_hints & HINT_ASSERTING) {
6066                         if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
6067                             o->op_private |= OPpENTERSUB_DB;
6068                     }
6069                     else {
6070                         delete=1;
6071                         if (ckWARN(WARN_ASSERTIONS) && !(PL_hints & HINT_ASSERTIONSSEEN)) {
6072                             Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
6073                                         "Impossible to activate assertion call");
6074                         }
6075                     }
6076                 }
6077             }
6078         }
6079     }
6080     else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6081         if (o2->op_type == OP_CONST)
6082             o2->op_private &= ~OPpCONST_STRICT;
6083         else if (o2->op_type == OP_LIST) {
6084             OP *o = ((UNOP*)o2)->op_first->op_sibling;
6085             if (o && o->op_type == OP_CONST)
6086                 o->op_private &= ~OPpCONST_STRICT;
6087         }
6088     }
6089     o->op_private |= (PL_hints & HINT_STRICT_REFS);
6090     if (PERLDB_SUB && PL_curstash != PL_debstash)
6091         o->op_private |= OPpENTERSUB_DB;
6092     while (o2 != cvop) {
6093         if (proto) {
6094             switch (*proto) {
6095             case '\0':
6096                 return too_many_arguments(o, gv_ename(namegv));
6097             case ';':
6098                 optional = 1;
6099                 proto++;
6100                 continue;
6101             case '$':
6102                 proto++;
6103                 arg++;
6104                 scalar(o2);
6105                 break;
6106             case '%':
6107             case '@':
6108                 list(o2);
6109                 arg++;
6110                 break;
6111             case '&':
6112                 proto++;
6113                 arg++;
6114                 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6115                     bad_type(arg,
6116                         arg == 1 ? "block or sub {}" : "sub {}",
6117                         gv_ename(namegv), o2);
6118                 break;
6119             case '*':
6120                 /* '*' allows any scalar type, including bareword */
6121                 proto++;
6122                 arg++;
6123                 if (o2->op_type == OP_RV2GV)
6124                     goto wrapref;       /* autoconvert GLOB -> GLOBref */
6125                 else if (o2->op_type == OP_CONST)
6126                     o2->op_private &= ~OPpCONST_STRICT;
6127                 else if (o2->op_type == OP_ENTERSUB) {
6128                     /* accidental subroutine, revert to bareword */
6129                     OP *gvop = ((UNOP*)o2)->op_first;
6130                     if (gvop && gvop->op_type == OP_NULL) {
6131                         gvop = ((UNOP*)gvop)->op_first;
6132                         if (gvop) {
6133                             for (; gvop->op_sibling; gvop = gvop->op_sibling)
6134                                 ;
6135                             if (gvop &&
6136                                 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6137                                 (gvop = ((UNOP*)gvop)->op_first) &&
6138                                 gvop->op_type == OP_GV)
6139                             {
6140                                 GV *gv = cGVOPx_gv(gvop);
6141                                 OP *sibling = o2->op_sibling;
6142                                 SV *n = newSVpvn("",0);
6143                                 op_free(o2);
6144                                 gv_fullname3(n, gv, "");
6145                                 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
6146                                     sv_chop(n, SvPVX(n)+6);
6147                                 o2 = newSVOP(OP_CONST, 0, n);
6148                                 prev->op_sibling = o2;
6149                                 o2->op_sibling = sibling;
6150                             }
6151                         }
6152                     }
6153                 }
6154                 scalar(o2);
6155                 break;
6156             case '[': case ']':
6157                  goto oops;
6158                  break;
6159             case '\\':
6160                 proto++;
6161                 arg++;
6162             again:
6163                 switch (*proto++) {
6164                 case '[':
6165                      if (contextclass++ == 0) {
6166                           e = strchr(proto, ']');
6167                           if (!e || e == proto)
6168                                goto oops;
6169                      }
6170                      else
6171                           goto oops;
6172                      goto again;
6173                      break;
6174                 case ']':
6175                      if (contextclass) {
6176                          char *p = proto;
6177                          char s = *p;
6178                          contextclass = 0;
6179                          *p = '\0';
6180                          while (*--p != '[');
6181                          bad_type(arg, Perl_form(aTHX_ "one of %s", p),
6182                                  gv_ename(namegv), o2);
6183                          *proto = s;
6184                      } else
6185                           goto oops;
6186                      break;
6187                 case '*':
6188                      if (o2->op_type == OP_RV2GV)
6189                           goto wrapref;
6190                      if (!contextclass)
6191                           bad_type(arg, "symbol", gv_ename(namegv), o2);
6192                      break;
6193                 case '&':
6194                      if (o2->op_type == OP_ENTERSUB)
6195                           goto wrapref;
6196                      if (!contextclass)
6197                           bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6198                      break;
6199                 case '$':
6200                     if (o2->op_type == OP_RV2SV ||
6201                         o2->op_type == OP_PADSV ||
6202                         o2->op_type == OP_HELEM ||
6203                         o2->op_type == OP_AELEM ||
6204                         o2->op_type == OP_THREADSV)
6205                          goto wrapref;
6206                     if (!contextclass)
6207                         bad_type(arg, "scalar", gv_ename(namegv), o2);
6208                      break;
6209                 case '@':
6210                     if (o2->op_type == OP_RV2AV ||
6211                         o2->op_type == OP_PADAV)
6212                          goto wrapref;
6213                     if (!contextclass)
6214                         bad_type(arg, "array", gv_ename(namegv), o2);
6215                     break;
6216                 case '%':
6217                     if (o2->op_type == OP_RV2HV ||
6218                         o2->op_type == OP_PADHV)
6219                          goto wrapref;
6220                     if (!contextclass)
6221                          bad_type(arg, "hash", gv_ename(namegv), o2);
6222                     break;
6223                 wrapref:
6224                     {
6225                         OP* kid = o2;
6226                         OP* sib = kid->op_sibling;
6227                         kid->op_sibling = 0;
6228                         o2 = newUNOP(OP_REFGEN, 0, kid);
6229                         o2->op_sibling = sib;
6230                         prev->op_sibling = o2;
6231                     }
6232                     if (contextclass && e) {
6233                          proto = e + 1;
6234                          contextclass = 0;
6235                     }
6236                     break;
6237                 default: goto oops;
6238                 }
6239                 if (contextclass)
6240                      goto again;
6241                 break;
6242             case ' ':
6243                 proto++;
6244                 continue;
6245             default:
6246               oops:
6247                 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
6248                            gv_ename(namegv), cv);
6249             }
6250         }
6251         else
6252             list(o2);
6253         mod(o2, OP_ENTERSUB);
6254         prev = o2;
6255         o2 = o2->op_sibling;
6256     }
6257     if (proto && !optional &&
6258           (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6259         return too_few_arguments(o, gv_ename(namegv));
6260     if(delete) {
6261         op_free(o);
6262         o=newSVOP(OP_CONST, 0, newSViv(0));
6263     }
6264     return o;
6265 }
6266
6267 OP *
6268 Perl_ck_svconst(pTHX_ OP *o)
6269 {
6270     SvREADONLY_on(cSVOPo->op_sv);
6271     return o;
6272 }
6273
6274 OP *
6275 Perl_ck_trunc(pTHX_ OP *o)
6276 {
6277     if (o->op_flags & OPf_KIDS) {
6278         SVOP *kid = (SVOP*)cUNOPo->op_first;
6279
6280         if (kid->op_type == OP_NULL)
6281             kid = (SVOP*)kid->op_sibling;
6282         if (kid && kid->op_type == OP_CONST &&
6283             (kid->op_private & OPpCONST_BARE))
6284         {
6285             o->op_flags |= OPf_SPECIAL;
6286             kid->op_private &= ~OPpCONST_STRICT;
6287         }
6288     }
6289     return ck_fun(o);
6290 }
6291
6292 OP *
6293 Perl_ck_unpack(pTHX_ OP *o)
6294 {
6295     OP *kid = cLISTOPo->op_first;
6296     if (kid->op_sibling) {
6297         kid = kid->op_sibling;
6298         if (!kid->op_sibling)
6299             kid->op_sibling = newDEFSVOP();
6300     }
6301     return ck_fun(o);
6302 }
6303
6304 OP *
6305 Perl_ck_substr(pTHX_ OP *o)
6306 {
6307     o = ck_fun(o);
6308     if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6309         OP *kid = cLISTOPo->op_first;
6310
6311         if (kid->op_type == OP_NULL)
6312             kid = kid->op_sibling;
6313         if (kid)
6314             kid->op_flags |= OPf_MOD;
6315
6316     }
6317     return o;
6318 }
6319
6320 /* A peephole optimizer.  We visit the ops in the order they're to execute. */
6321
6322 void
6323 Perl_peep(pTHX_ register OP *o)
6324 {
6325     register OP* oldop = 0;
6326
6327     if (!o || o->op_opt)
6328         return;
6329     ENTER;
6330     SAVEOP();
6331     SAVEVPTR(PL_curcop);
6332     for (; o; o = o->op_next) {
6333         if (o->op_opt)
6334             break;
6335         PL_op = o;
6336         switch (o->op_type) {
6337         case OP_SETSTATE:
6338         case OP_NEXTSTATE:
6339         case OP_DBSTATE:
6340             PL_curcop = ((COP*)o);              /* for warnings */
6341             o->op_opt = 1;
6342             break;
6343
6344         case OP_CONST:
6345             if (cSVOPo->op_private & OPpCONST_STRICT)
6346                 no_bareword_allowed(o);
6347 #ifdef USE_ITHREADS
6348         case OP_METHOD_NAMED:
6349             /* Relocate sv to the pad for thread safety.
6350              * Despite being a "constant", the SV is written to,
6351              * for reference counts, sv_upgrade() etc. */
6352             if (cSVOP->op_sv) {
6353                 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6354                 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
6355                     /* If op_sv is already a PADTMP then it is being used by
6356                      * some pad, so make a copy. */
6357                     sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
6358                     SvREADONLY_on(PAD_SVl(ix));
6359                     SvREFCNT_dec(cSVOPo->op_sv);
6360                 }
6361                 else {
6362                     SvREFCNT_dec(PAD_SVl(ix));
6363                     SvPADTMP_on(cSVOPo->op_sv);
6364                     PAD_SETSV(ix, cSVOPo->op_sv);
6365                     /* XXX I don't know how this isn't readonly already. */
6366                     SvREADONLY_on(PAD_SVl(ix));
6367                 }
6368                 cSVOPo->op_sv = Nullsv;
6369                 o->op_targ = ix;
6370             }
6371 #endif
6372             o->op_opt = 1;
6373             break;
6374
6375         case OP_CONCAT:
6376             if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6377                 if (o->op_next->op_private & OPpTARGET_MY) {
6378                     if (o->op_flags & OPf_STACKED) /* chained concats */
6379                         goto ignore_optimization;
6380                     else {
6381                         /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6382                         o->op_targ = o->op_next->op_targ;
6383                         o->op_next->op_targ = 0;
6384                         o->op_private |= OPpTARGET_MY;
6385                     }
6386                 }
6387                 op_null(o->op_next);
6388             }
6389           ignore_optimization:
6390             o->op_opt = 1;
6391             break;
6392         case OP_STUB:
6393             if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6394                 o->op_opt = 1;
6395                 break; /* Scalar stub must produce undef.  List stub is noop */
6396             }
6397             goto nothin;
6398         case OP_NULL:
6399             if (o->op_targ == OP_NEXTSTATE
6400                 || o->op_targ == OP_DBSTATE
6401                 || o->op_targ == OP_SETSTATE)
6402             {
6403                 PL_curcop = ((COP*)o);
6404             }
6405             /* XXX: We avoid setting op_seq here to prevent later calls
6406                to peep() from mistakenly concluding that optimisation
6407                has already occurred. This doesn't fix the real problem,
6408                though (See 20010220.007). AMS 20010719 */
6409             /* op_seq functionality is now replaced by op_opt */
6410             if (oldop && o->op_next) {
6411                 oldop->op_next = o->op_next;
6412                 continue;
6413             }
6414             break;
6415         case OP_SCALAR:
6416         case OP_LINESEQ:
6417         case OP_SCOPE:
6418           nothin:
6419             if (oldop && o->op_next) {
6420                 oldop->op_next = o->op_next;
6421                 continue;
6422             }
6423             o->op_opt = 1;
6424             break;
6425
6426         case OP_PADAV:
6427         case OP_GV:
6428             if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
6429                 OP* pop = (o->op_type == OP_PADAV) ?
6430                             o->op_next : o->op_next->op_next;
6431                 IV i;
6432                 if (pop && pop->op_type == OP_CONST &&
6433                     ((PL_op = pop->op_next)) &&
6434                     pop->op_next->op_type == OP_AELEM &&
6435                     !(pop->op_next->op_private &
6436                       (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6437                     (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
6438                                 <= 255 &&
6439                     i >= 0)
6440                 {
6441                     GV *gv;
6442                     if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
6443                         no_bareword_allowed(pop);
6444                     if (o->op_type == OP_GV)
6445                         op_null(o->op_next);
6446                     op_null(pop->op_next);
6447                     op_null(pop);
6448                     o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6449                     o->op_next = pop->op_next->op_next;
6450                     o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6451                     o->op_private = (U8)i;
6452                     if (o->op_type == OP_GV) {
6453                         gv = cGVOPo_gv;
6454                         GvAVn(gv);
6455                     }
6456                     else
6457                         o->op_flags |= OPf_SPECIAL;
6458                     o->op_type = OP_AELEMFAST;
6459                 }
6460                 o->op_opt = 1;
6461                 break;
6462             }
6463
6464             if (o->op_next->op_type == OP_RV2SV) {
6465                 if (!(o->op_next->op_private & OPpDEREF)) {
6466                     op_null(o->op_next);
6467                     o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6468                                                                | OPpOUR_INTRO);
6469                     o->op_next = o->op_next->op_next;
6470                     o->op_type = OP_GVSV;
6471                     o->op_ppaddr = PL_ppaddr[OP_GVSV];
6472                 }
6473             }
6474             else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6475                 GV *gv = cGVOPo_gv;
6476                 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
6477                     /* XXX could check prototype here instead of just carping */
6478                     SV *sv = sv_newmortal();
6479                     gv_efullname3(sv, gv, Nullch);
6480                     Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
6481                                 "%"SVf"() called too early to check prototype",
6482                                 sv);
6483                 }
6484             }
6485             else if (o->op_next->op_type == OP_READLINE
6486                     && o->op_next->op_next->op_type == OP_CONCAT
6487                     && (o->op_next->op_next->op_flags & OPf_STACKED))
6488             {
6489                 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
6490                 o->op_type   = OP_RCATLINE;
6491                 o->op_flags |= OPf_STACKED;
6492                 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
6493                 op_null(o->op_next->op_next);
6494                 op_null(o->op_next);
6495             }
6496
6497             o->op_opt = 1;
6498             break;
6499
6500         case OP_MAPWHILE:
6501         case OP_GREPWHILE:
6502         case OP_AND:
6503         case OP_OR:
6504         case OP_DOR:
6505         case OP_ANDASSIGN:
6506         case OP_ORASSIGN:
6507         case OP_DORASSIGN:
6508         case OP_COND_EXPR:
6509         case OP_RANGE:
6510             o->op_opt = 1;
6511             while (cLOGOP->op_other->op_type == OP_NULL)
6512                 cLOGOP->op_other = cLOGOP->op_other->op_next;
6513             peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
6514             break;
6515
6516         case OP_ENTERLOOP:
6517         case OP_ENTERITER:
6518             o->op_opt = 1;
6519             while (cLOOP->op_redoop->op_type == OP_NULL)
6520                 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6521             peep(cLOOP->op_redoop);
6522             while (cLOOP->op_nextop->op_type == OP_NULL)
6523                 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6524             peep(cLOOP->op_nextop);
6525             while (cLOOP->op_lastop->op_type == OP_NULL)
6526                 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6527             peep(cLOOP->op_lastop);
6528             break;
6529
6530         case OP_QR:
6531         case OP_MATCH:
6532         case OP_SUBST:
6533             o->op_opt = 1;
6534             while (cPMOP->op_pmreplstart &&
6535                    cPMOP->op_pmreplstart->op_type == OP_NULL)
6536                 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6537             peep(cPMOP->op_pmreplstart);
6538             break;
6539
6540         case OP_EXEC:
6541             o->op_opt = 1;
6542             if (ckWARN(WARN_SYNTAX) && o->op_next
6543                 && o->op_next->op_type == OP_NEXTSTATE) {
6544                 if (o->op_next->op_sibling &&
6545                         o->op_next->op_sibling->op_type != OP_EXIT &&
6546                         o->op_next->op_sibling->op_type != OP_WARN &&
6547                         o->op_next->op_sibling->op_type != OP_DIE) {
6548                     line_t oldline = CopLINE(PL_curcop);
6549
6550                     CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6551                     Perl_warner(aTHX_ packWARN(WARN_EXEC),
6552                                 "Statement unlikely to be reached");
6553                     Perl_warner(aTHX_ packWARN(WARN_EXEC),
6554                                 "\t(Maybe you meant system() when you said exec()?)\n");
6555                     CopLINE_set(PL_curcop, oldline);
6556                 }
6557             }
6558             break;
6559
6560         case OP_HELEM: {
6561             SV *lexname;
6562             SV **svp, *sv;
6563             char *key = NULL;
6564             STRLEN keylen;
6565
6566             o->op_opt = 1;
6567
6568             if (((BINOP*)o)->op_last->op_type != OP_CONST)
6569                 break;
6570
6571             /* Make the CONST have a shared SV */
6572             svp = cSVOPx_svp(((BINOP*)o)->op_last);
6573             if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
6574                 key = SvPV(sv, keylen);
6575                 lexname = newSVpvn_share(key,
6576                                          SvUTF8(sv) ? -(I32)keylen : keylen,
6577                                          0);
6578                 SvREFCNT_dec(sv);
6579                 *svp = lexname;
6580             }
6581             break;
6582         }
6583
6584         case OP_SORT: {
6585             /* make @a = sort @a act in-place */
6586
6587             /* will point to RV2AV or PADAV op on LHS/RHS of assign */
6588             OP *oleft, *oright;
6589             OP *o2;
6590
6591             o->op_opt = 1;
6592
6593             /* check that RHS of sort is a single plain array */
6594             oright = cUNOPo->op_first;
6595             if (!oright || oright->op_type != OP_PUSHMARK)
6596                 break;
6597             oright = cUNOPx(oright)->op_sibling;
6598             if (!oright)
6599                 break;
6600             if (oright->op_type == OP_NULL) { /* skip sort block/sub */
6601                 oright = cUNOPx(oright)->op_sibling;
6602             }
6603
6604             if (!oright ||
6605                 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
6606                 || oright->op_next != o
6607                 || (oright->op_private & OPpLVAL_INTRO)
6608             )
6609                 break;
6610
6611             /* o2 follows the chain of op_nexts through the LHS of the
6612              * assign (if any) to the aassign op itself */
6613             o2 = o->op_next;
6614             if (!o2 || o2->op_type != OP_NULL)
6615                 break;
6616             o2 = o2->op_next;
6617             if (!o2 || o2->op_type != OP_PUSHMARK)
6618                 break;
6619             o2 = o2->op_next;
6620             if (o2 && o2->op_type == OP_GV)
6621                 o2 = o2->op_next;
6622             if (!o2
6623                 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
6624                 || (o2->op_private & OPpLVAL_INTRO)
6625             )
6626                 break;
6627             oleft = o2;
6628             o2 = o2->op_next;
6629             if (!o2 || o2->op_type != OP_NULL)
6630                 break;
6631             o2 = o2->op_next;
6632             if (!o2 || o2->op_type != OP_AASSIGN
6633                     || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
6634                 break;
6635
6636             /* check the array is the same on both sides */
6637             if (oleft->op_type == OP_RV2AV) {
6638                 if (oright->op_type != OP_RV2AV
6639                     || !cUNOPx(oright)->op_first
6640                     || cUNOPx(oright)->op_first->op_type != OP_GV
6641                     ||  cGVOPx_gv(cUNOPx(oleft)->op_first) !=
6642                         cGVOPx_gv(cUNOPx(oright)->op_first)
6643                 )
6644                     break;
6645             }
6646             else if (oright->op_type != OP_PADAV
6647                 || oright->op_targ != oleft->op_targ
6648             )
6649                 break;
6650
6651             /* transfer MODishness etc from LHS arg to RHS arg */
6652             oright->op_flags = oleft->op_flags;
6653             o->op_private |= OPpSORT_INPLACE;
6654
6655             /* excise push->gv->rv2av->null->aassign */
6656             o2 = o->op_next->op_next;
6657             op_null(o2); /* PUSHMARK */
6658             o2 = o2->op_next;
6659             if (o2->op_type == OP_GV) {
6660                 op_null(o2); /* GV */
6661                 o2 = o2->op_next;
6662             }
6663             op_null(o2); /* RV2AV or PADAV */
6664             o2 = o2->op_next->op_next;
6665             op_null(o2); /* AASSIGN */
6666
6667             o->op_next = o2->op_next;
6668
6669             break;
6670         }
6671
6672
6673
6674         default:
6675             o->op_opt = 1;
6676             break;
6677         }
6678         oldop = o;
6679     }
6680     LEAVE;
6681 }
6682
6683
6684
6685 char* Perl_custom_op_name(pTHX_ OP* o)
6686 {
6687     IV  index = PTR2IV(o->op_ppaddr);
6688     SV* keysv;
6689     HE* he;
6690
6691     if (!PL_custom_op_names) /* This probably shouldn't happen */
6692         return PL_op_name[OP_CUSTOM];
6693
6694     keysv = sv_2mortal(newSViv(index));
6695
6696     he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
6697     if (!he)
6698         return PL_op_name[OP_CUSTOM]; /* Don't know who you are */
6699
6700     return SvPV_nolen(HeVAL(he));
6701 }
6702
6703 char* Perl_custom_op_desc(pTHX_ OP* o)
6704 {
6705     IV  index = PTR2IV(o->op_ppaddr);
6706     SV* keysv;
6707     HE* he;
6708
6709     if (!PL_custom_op_descs)
6710         return PL_op_desc[OP_CUSTOM];
6711
6712     keysv = sv_2mortal(newSViv(index));
6713
6714     he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
6715     if (!he)
6716         return PL_op_desc[OP_CUSTOM];
6717
6718     return SvPV_nolen(HeVAL(he));
6719 }
6720
6721
6722 #include "XSUB.h"
6723
6724 /* Efficient sub that returns a constant scalar value. */
6725 static void
6726 const_sv_xsub(pTHX_ CV* cv)
6727 {
6728     dXSARGS;
6729     if (items != 0) {
6730 #if 0
6731         Perl_croak(aTHX_ "usage: %s::%s()",
6732                    HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
6733 #endif
6734     }
6735     EXTEND(sp, 1);
6736     ST(0) = (SV*)XSANY.any_ptr;
6737     XSRETURN(1);
6738 }