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