op.c

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