op.c

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