op.c

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