op.c

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