op.c

   1 /*    op.c
   2  *
   3  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
   4  *    2000, 2001, 2002, 2003, 2004, by Larry Wall and others
   5  *
   6  *    You may distribute under the terms of either the GNU General Public
   7  *    License or the Artistic License, as specified in the README file.
   8  *
   9  */
  10
  11 /*
  12  * "You see: Mr. Drogo, he married poor Miss Primula Brandybuck.  She was
  13  * our Mr. Bilbo's first cousin on the mother's side (her mother being the
  14  * youngest of the Old Took's daughters); and Mr. Drogo was his second
  15  * cousin.  So Mr. Frodo is his first *and* second cousin, once removed
  16  * either way, as the saying is, if you follow me."  --the Gaffer
  17  */
  18
  19 /* This file contains the functions that create, manipulate and optimize
  20  * the OP structures that hold a compiled perl program.
  21  *
  22  * A Perl program is compiled into a tree of OPs. Each op contains
  23  * structural pointers (eg to its siblings and the next op in the
  24  * execution sequence), a pointer to the function that would execute the
  25  * op, plus any data specific to that op. For example, an OP_CONST op
  26  * points to the pp_const() function and to an SV containing the constant
  27  * value. When pp_const() is executed, its job is to push that SV onto the
  28  * stack.
  29  *
  30  * OPs are mainly created by the newFOO() functions, which are mainly
  31  * called from the parser (in perly.y) as the code is parsed. For example
  32  * the Perl code $a + $b * $c would cause the equivalent of the following
  33  * to be called (oversimplifying a bit):
  34  *
  35  *  newBINOP(OP_ADD, flags,
  36  *      newSVREF($a),
  37  *      newBINOP(OP_MULTIPLY, flags, newSVREF($b), newSVREF($c))
  38  *  )
  39  *
  40  * Note that during the build of miniperl, a temporary copy of this file
  41  * is made, called opmini.c.
  42  */
  43
  44 #include "EXTERN.h"
  45 #define PERL_IN_OP_C
  46 #include "perl.h"
  47 #include "keywords.h"
  48
  49 #define CALL_PEEP(o) CALL_FPTR(PL_peepp)(aTHX_ o)
  50
  51 #if defined(PL_OP_SLAB_ALLOC)
  52
  53 #ifndef PERL_SLAB_SIZE
  54 #define PERL_SLAB_SIZE 2048
  55 #endif
  56
  57 void *
  58 Perl_Slab_Alloc(pTHX_ int m, size_t sz)
  59 {
  60     /*
  61      * To make incrementing use count easy PL_OpSlab is an I32 *
  62      * To make inserting the link to slab PL_OpPtr is I32 **
  63      * So compute size in units of sizeof(I32 *) as that is how Pl_OpPtr increments
  64      * Add an overhead for pointer to slab and round up as a number of pointers
  65      */
  66     sz = (sz + 2*sizeof(I32 *) -1)/sizeof(I32 *);
  67     if ((PL_OpSpace -= sz) < 0) {
  68         PL_OpPtr = (I32 **) PerlMemShared_malloc(PERL_SLAB_SIZE*sizeof(I32*));
  69         if (!PL_OpPtr) {
  70             return NULL;
  71         }
  72         Zero(PL_OpPtr,PERL_SLAB_SIZE,I32 **);
  73         /* We reserve the 0'th I32 sized chunk as a use count */
  74         PL_OpSlab = (I32 *) PL_OpPtr;
  75         /* Reduce size by the use count word, and by the size we need.
  76          * Latter is to mimic the '-=' in the if() above
  77          */
  78         PL_OpSpace = PERL_SLAB_SIZE - (sizeof(I32)+sizeof(I32 **)-1)/sizeof(I32 **) - sz;
  79         /* Allocation pointer starts at the top.
  80            Theory: because we build leaves before trunk allocating at end
  81            means that at run time access is cache friendly upward
  82          */
  83         PL_OpPtr += PERL_SLAB_SIZE;
  84     }
  85     assert( PL_OpSpace >= 0 );
  86     /* Move the allocation pointer down */
  87     PL_OpPtr   -= sz;
  88     assert( PL_OpPtr > (I32 **) PL_OpSlab );
  89     *PL_OpPtr   = PL_OpSlab;    /* Note which slab it belongs to */
  90     (*PL_OpSlab)++;             /* Increment use count of slab */
  91     assert( PL_OpPtr+sz <= ((I32 **) PL_OpSlab + PERL_SLAB_SIZE) );
  92     assert( *PL_OpSlab > 0 );
  93     return (void *)(PL_OpPtr + 1);
  94 }
  95
  96 void
  97 Perl_Slab_Free(pTHX_ void *op)
  98 {
  99     I32 **ptr = (I32 **) op;
 100     I32 *slab = ptr[-1];
 101     assert( ptr-1 > (I32 **) slab );
 102     assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
 103     assert( *slab > 0 );
 104     if (--(*slab) == 0) {
 105 #  ifdef NETWARE
 106 #    define PerlMemShared PerlMem
 107 #  endif
 108
 109     PerlMemShared_free(slab);
 110         if (slab == PL_OpSlab) {
 111             PL_OpSpace = 0;
 112         }
 113     }
 114 }
 115 #endif
 116 /*
 117  * In the following definition, the ", Nullop" is just to make the compiler
 118  * think the expression is of the right type: croak actually does a Siglongjmp.
 119  */
 120 #define CHECKOP(type,o) \
 121     ((PL_op_mask && PL_op_mask[type])                                   \
 122      ? ( op_free((OP*)o),                                       \
 123          Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]),  \
 124          Nullop )                                               \
 125      : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o))
 126
 127 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
 128
 129 STATIC char*
 130 S_gv_ename(pTHX_ GV *gv)
 131 {
 132     STRLEN n_a;
 133     SV* tmpsv = sv_newmortal();
 134     gv_efullname3(tmpsv, gv, Nullch);
 135     return SvPV(tmpsv,n_a);
 136 }
 137
 138 STATIC OP *
 139 S_no_fh_allowed(pTHX_ OP *o)
 140 {
 141     yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
 142                  OP_DESC(o)));
 143     return o;
 144 }
 145
 146 STATIC OP *
 147 S_too_few_arguments(pTHX_ OP *o, char *name)
 148 {
 149     yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
 150     return o;
 151 }
 152
 153 STATIC OP *
 154 S_too_many_arguments(pTHX_ OP *o, char *name)
 155 {
 156     yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
 157     return o;
 158 }
 159
 160 STATIC void
 161 S_bad_type(pTHX_ I32 n, char *t, char *name, OP *kid)
 162 {
 163     yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
 164                  (int)n, name, t, OP_DESC(kid)));
 165 }
 166
 167 STATIC void
 168 S_no_bareword_allowed(pTHX_ OP *o)
 169 {
 170     qerror(Perl_mess(aTHX_
 171                      "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
 172                      cSVOPo_sv));
 173 }
 174
 175 /* "register" allocation */
 176
 177 PADOFFSET
 178 Perl_allocmy(pTHX_ char *name)
 179 {
 180     PADOFFSET off;
 181
 182     /* complain about "my $<special_var>" etc etc */
 183     if (!(PL_in_my == KEY_our ||
 184           isALPHA(name[1]) ||
 185           (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
 186           (name[1] == '_' && (*name == '$' || (int)strlen(name) > 2))))
 187     {
 188         if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
 189             /* 1999-02-27 mjd@plover.com */
 190             char *p;
 191             p = strchr(name, '\0');
 192             /* The next block assumes the buffer is at least 205 chars
 193                long.  At present, it's always at least 256 chars. */
 194             if (p-name > 200) {
 195                 strcpy(name+200, "...");
 196                 p = name+199;
 197             }
 198             else {
 199                 p[1] = '\0';
 200             }
 201             /* Move everything else down one character */
 202             for (; p-name > 2; p--)
 203                 *p = *(p-1);
 204             name[2] = toCTRL(name[1]);
 205             name[1] = '^';
 206         }
 207         yyerror(Perl_form(aTHX_ "Can't use global %s in \"my\"",name));
 208     }
 209
 210     /* check for duplicate declaration */
 211     pad_check_dup(name,
 212                 (bool)(PL_in_my == KEY_our),
 213                 (PL_curstash ? PL_curstash : PL_defstash)
 214     );
 215
 216     if (PL_in_my_stash && *name != '$') {
 217         yyerror(Perl_form(aTHX_
 218                     "Can't declare class for non-scalar %s in \"%s\"",
 219                      name, PL_in_my == KEY_our ? "our" : "my"));
 220     }
 221
 222     /* allocate a spare slot and store the name in that slot */
 223
 224     off = pad_add_name(name,
 225                     PL_in_my_stash,
 226                     (PL_in_my == KEY_our
 227                         ? (PL_curstash ? PL_curstash : PL_defstash)
 228                         : Nullhv
 229                     ),
 230                     0 /*  not fake */
 231     );
 232     return off;
 233 }
 234
 235 /* Destructor */
 236
 237 void
 238 Perl_op_free(pTHX_ OP *o)
 239 {
 240     register OP *kid, *nextkid;
 241     OPCODE type;
 242
 243     if (!o || o->op_static)
 244         return;
 245
 246     if (o->op_private & OPpREFCOUNTED) {
 247         switch (o->op_type) {
 248         case OP_LEAVESUB:
 249         case OP_LEAVESUBLV:
 250         case OP_LEAVEEVAL:
 251         case OP_LEAVE:
 252         case OP_SCOPE:
 253         case OP_LEAVEWRITE:
 254             OP_REFCNT_LOCK;
 255             if (OpREFCNT_dec(o)) {
 256                 OP_REFCNT_UNLOCK;
 257                 return;
 258             }
 259             OP_REFCNT_UNLOCK;
 260             break;
 261         default:
 262             break;
 263         }
 264     }
 265
 266     if (o->op_flags & OPf_KIDS) {
 267         for (kid = cUNOPo->op_first; kid; kid = nextkid) {
 268             nextkid = kid->op_sibling; /* Get before next freeing kid */
 269             op_free(kid);
 270         }
 271     }
 272     type = o->op_type;
 273     if (type == OP_NULL)
 274         type = (OPCODE)o->op_targ;
 275
 276     /* COP* is not cleared by op_clear() so that we may track line
 277      * numbers etc even after null() */
 278     if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE)
 279         cop_free((COP*)o);
 280
 281     op_clear(o);
 282     FreeOp(o);
 283 }
 284
 285 void
 286 Perl_op_clear(pTHX_ OP *o)
 287 {
 288
 289     switch (o->op_type) {
 290     case OP_NULL:       /* Was holding old type, if any. */
 291     case OP_ENTEREVAL:  /* Was holding hints. */
 292         o->op_targ = 0;
 293         break;
 294     default:
 295         if (!(o->op_flags & OPf_REF)
 296             || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
 297             break;
 298         /* FALL THROUGH */
 299     case OP_GVSV:
 300     case OP_GV:
 301     case OP_AELEMFAST:
 302         if (! (o->op_type == OP_AELEMFAST && o->op_flags & OPf_SPECIAL)) {
 303             /* not an OP_PADAV replacement */
 304 #ifdef USE_ITHREADS
 305             if (cPADOPo->op_padix > 0) {
 306                 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
 307                  * may still exist on the pad */
 308                 pad_swipe(cPADOPo->op_padix, TRUE);
 309                 cPADOPo->op_padix = 0;
 310             }
 311 #else
 312             SvREFCNT_dec(cSVOPo->op_sv);
 313             cSVOPo->op_sv = Nullsv;
 314 #endif
 315         }
 316         break;
 317     case OP_METHOD_NAMED:
 318     case OP_CONST:
 319         SvREFCNT_dec(cSVOPo->op_sv);
 320         cSVOPo->op_sv = Nullsv;
 321 #ifdef USE_ITHREADS
 322         /** Bug #15654
 323           Even if op_clear does a pad_free for the target of the op,
 324           pad_free doesn't actually remove the sv that exists in the pad;
 325           instead it lives on. This results in that it could be reused as
 326           a target later on when the pad was reallocated.
 327         **/
 328         if(o->op_targ) {
 329           pad_swipe(o->op_targ,1);
 330           o->op_targ = 0;
 331         }
 332 #endif
 333         break;
 334     case OP_GOTO:
 335     case OP_NEXT:
 336     case OP_LAST:
 337     case OP_REDO:
 338         if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
 339             break;
 340         /* FALL THROUGH */
 341     case OP_TRANS:
 342         if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
 343             SvREFCNT_dec(cSVOPo->op_sv);
 344             cSVOPo->op_sv = Nullsv;
 345         }
 346         else {
 347             Safefree(cPVOPo->op_pv);
 348             cPVOPo->op_pv = Nullch;
 349         }
 350         break;
 351     case OP_SUBST:
 352         op_free(cPMOPo->op_pmreplroot);
 353         goto clear_pmop;
 354     case OP_PUSHRE:
 355 #ifdef USE_ITHREADS
 356         if (INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)) {
 357             /* No GvIN_PAD_off here, because other references may still
 358              * exist on the pad */
 359             pad_swipe(INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot), TRUE);
 360         }
 361 #else
 362         SvREFCNT_dec((SV*)cPMOPo->op_pmreplroot);
 363 #endif
 364         /* FALL THROUGH */
 365     case OP_MATCH:
 366     case OP_QR:
 367 clear_pmop:
 368         {
 369             HV *pmstash = PmopSTASH(cPMOPo);
 370             if (pmstash && SvREFCNT(pmstash)) {
 371                 PMOP *pmop = HvPMROOT(pmstash);
 372                 PMOP *lastpmop = NULL;
 373                 while (pmop) {
 374                     if (cPMOPo == pmop) {
 375                         if (lastpmop)
 376                             lastpmop->op_pmnext = pmop->op_pmnext;
 377                         else
 378                             HvPMROOT(pmstash) = pmop->op_pmnext;
 379                         break;
 380                     }
 381                     lastpmop = pmop;
 382                     pmop = pmop->op_pmnext;
 383                 }
 384             }
 385             PmopSTASH_free(cPMOPo);
 386         }
 387         cPMOPo->op_pmreplroot = Nullop;
 388         /* we use the "SAFE" version of the PM_ macros here
 389          * since sv_clean_all might release some PMOPs
 390          * after PL_regex_padav has been cleared
 391          * and the clearing of PL_regex_padav needs to
 392          * happen before sv_clean_all
 393          */
 394         ReREFCNT_dec(PM_GETRE_SAFE(cPMOPo));
 395         PM_SETRE_SAFE(cPMOPo, (REGEXP*)NULL);
 396 #ifdef USE_ITHREADS
 397         if(PL_regex_pad) {        /* We could be in destruction */
 398             av_push((AV*) PL_regex_pad[0],(SV*) PL_regex_pad[(cPMOPo)->op_pmoffset]);
 399             SvREPADTMP_on(PL_regex_pad[(cPMOPo)->op_pmoffset]);
 400             PM_SETRE(cPMOPo, (cPMOPo)->op_pmoffset);
 401         }
 402 #endif
 403
 404         break;
 405     }
 406
 407     if (o->op_targ > 0) {
 408         pad_free(o->op_targ);
 409         o->op_targ = 0;
 410     }
 411 }
 412
 413 STATIC void
 414 S_cop_free(pTHX_ COP* cop)
 415 {
 416     Safefree(cop->cop_label);   /* FIXME: treaddead ??? */
 417     CopFILE_free(cop);
 418     CopSTASH_free(cop);
 419     if (! specialWARN(cop->cop_warnings))
 420         SvREFCNT_dec(cop->cop_warnings);
 421     if (! specialCopIO(cop->cop_io)) {
 422 #ifdef USE_ITHREADS
 423 #if 0
 424         STRLEN len;
 425         char *s = SvPV(cop->cop_io,len);
 426         Perl_warn(aTHX_ "io='%.*s'",(int) len,s); /* ??? --jhi */
 427 #endif
 428 #else
 429         SvREFCNT_dec(cop->cop_io);
 430 #endif
 431     }
 432 }
 433
 434 void
 435 Perl_op_null(pTHX_ OP *o)
 436 {
 437     if (o->op_type == OP_NULL)
 438         return;
 439     op_clear(o);
 440     o->op_targ = o->op_type;
 441     o->op_type = OP_NULL;
 442     o->op_ppaddr = PL_ppaddr[OP_NULL];
 443 }
 444
 445 /* Contextualizers */
 446
 447 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
 448
 449 OP *
 450 Perl_linklist(pTHX_ OP *o)
 451 {
 452     register OP *kid;
 453
 454     if (o->op_next)
 455         return o->op_next;
 456
 457     /* establish postfix order */
 458     if (cUNOPo->op_first) {
 459         o->op_next = LINKLIST(cUNOPo->op_first);
 460         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
 461             if (kid->op_sibling)
 462                 kid->op_next = LINKLIST(kid->op_sibling);
 463             else
 464                 kid->op_next = o;
 465         }
 466     }
 467     else
 468         o->op_next = o;
 469
 470     return o->op_next;
 471 }
 472
 473 OP *
 474 Perl_scalarkids(pTHX_ OP *o)
 475 {
 476     OP *kid;
 477     if (o && o->op_flags & OPf_KIDS) {
 478         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
 479             scalar(kid);
 480     }
 481     return o;
 482 }
 483
 484 STATIC OP *
 485 S_scalarboolean(pTHX_ OP *o)
 486 {
 487     if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
 488         if (ckWARN(WARN_SYNTAX)) {
 489             line_t oldline = CopLINE(PL_curcop);
 490
 491             if (PL_copline != NOLINE)
 492                 CopLINE_set(PL_curcop, PL_copline);
 493             Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
 494             CopLINE_set(PL_curcop, oldline);
 495         }
 496     }
 497     return scalar(o);
 498 }
 499
 500 OP *
 501 Perl_scalar(pTHX_ OP *o)
 502 {
 503     OP *kid;
 504
 505     /* assumes no premature commitment */
 506     if (!o || (o->op_flags & OPf_WANT) || PL_error_count
 507          || o->op_type == OP_RETURN)
 508     {
 509         return o;
 510     }
 511
 512     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
 513
 514     switch (o->op_type) {
 515     case OP_REPEAT:
 516         scalar(cBINOPo->op_first);
 517         break;
 518     case OP_OR:
 519     case OP_AND:
 520     case OP_COND_EXPR:
 521         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
 522             scalar(kid);
 523         break;
 524     case OP_SPLIT:
 525         if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
 526             if (!kPMOP->op_pmreplroot)
 527                 deprecate_old("implicit split to @_");
 528         }
 529         /* FALL THROUGH */
 530     case OP_MATCH:
 531     case OP_QR:
 532     case OP_SUBST:
 533     case OP_NULL:
 534     default:
 535         if (o->op_flags & OPf_KIDS) {
 536             for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
 537                 scalar(kid);
 538         }
 539         break;
 540     case OP_LEAVE:
 541     case OP_LEAVETRY:
 542         kid = cLISTOPo->op_first;
 543         scalar(kid);
 544         while ((kid = kid->op_sibling)) {
 545             if (kid->op_sibling)
 546                 scalarvoid(kid);
 547             else
 548                 scalar(kid);
 549         }
 550         WITH_THR(PL_curcop = &PL_compiling);
 551         break;
 552     case OP_SCOPE:
 553     case OP_LINESEQ:
 554     case OP_LIST:
 555         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
 556             if (kid->op_sibling)
 557                 scalarvoid(kid);
 558             else
 559                 scalar(kid);
 560         }
 561         WITH_THR(PL_curcop = &PL_compiling);
 562         break;
 563     case OP_SORT:
 564         if (ckWARN(WARN_VOID))
 565             Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
 566     }
 567     return o;
 568 }
 569
 570 OP *
 571 Perl_scalarvoid(pTHX_ OP *o)
 572 {
 573     OP *kid;
 574     char* useless = 0;
 575     SV* sv;
 576     U8 want;
 577
 578     if (o->op_type == OP_NEXTSTATE
 579         || o->op_type == OP_SETSTATE
 580         || o->op_type == OP_DBSTATE
 581         || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
 582                                       || o->op_targ == OP_SETSTATE
 583                                       || o->op_targ == OP_DBSTATE)))
 584         PL_curcop = (COP*)o;            /* for warning below */
 585
 586     /* assumes no premature commitment */
 587     want = o->op_flags & OPf_WANT;
 588     if ((want && want != OPf_WANT_SCALAR) || PL_error_count
 589          || o->op_type == OP_RETURN)
 590     {
 591         return o;
 592     }
 593
 594     if ((o->op_private & OPpTARGET_MY)
 595         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
 596     {
 597         return scalar(o);                       /* As if inside SASSIGN */
 598     }
 599
 600     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
 601
 602     switch (o->op_type) {
 603     default:
 604         if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
 605             break;
 606         /* FALL THROUGH */
 607     case OP_REPEAT:
 608         if (o->op_flags & OPf_STACKED)
 609             break;
 610         goto func_ops;
 611     case OP_SUBSTR:
 612         if (o->op_private == 4)
 613             break;
 614         /* FALL THROUGH */
 615     case OP_GVSV:
 616     case OP_WANTARRAY:
 617     case OP_GV:
 618     case OP_PADSV:
 619     case OP_PADAV:
 620     case OP_PADHV:
 621     case OP_PADANY:
 622     case OP_AV2ARYLEN:
 623     case OP_REF:
 624     case OP_REFGEN:
 625     case OP_SREFGEN:
 626     case OP_DEFINED:
 627     case OP_HEX:
 628     case OP_OCT:
 629     case OP_LENGTH:
 630     case OP_VEC:
 631     case OP_INDEX:
 632     case OP_RINDEX:
 633     case OP_SPRINTF:
 634     case OP_AELEM:
 635     case OP_AELEMFAST:
 636     case OP_ASLICE:
 637     case OP_HELEM:
 638     case OP_HSLICE:
 639     case OP_UNPACK:
 640     case OP_PACK:
 641     case OP_JOIN:
 642     case OP_LSLICE:
 643     case OP_ANONLIST:
 644     case OP_ANONHASH:
 645     case OP_SORT:
 646     case OP_REVERSE:
 647     case OP_RANGE:
 648     case OP_FLIP:
 649     case OP_FLOP:
 650     case OP_CALLER:
 651     case OP_FILENO:
 652     case OP_EOF:
 653     case OP_TELL:
 654     case OP_GETSOCKNAME:
 655     case OP_GETPEERNAME:
 656     case OP_READLINK:
 657     case OP_TELLDIR:
 658     case OP_GETPPID:
 659     case OP_GETPGRP:
 660     case OP_GETPRIORITY:
 661     case OP_TIME:
 662     case OP_TMS:
 663     case OP_LOCALTIME:
 664     case OP_GMTIME:
 665     case OP_GHBYNAME:
 666     case OP_GHBYADDR:
 667     case OP_GHOSTENT:
 668     case OP_GNBYNAME:
 669     case OP_GNBYADDR:
 670     case OP_GNETENT:
 671     case OP_GPBYNAME:
 672     case OP_GPBYNUMBER:
 673     case OP_GPROTOENT:
 674     case OP_GSBYNAME:
 675     case OP_GSBYPORT:
 676     case OP_GSERVENT:
 677     case OP_GPWNAM:
 678     case OP_GPWUID:
 679     case OP_GGRNAM:
 680     case OP_GGRGID:
 681     case OP_GETLOGIN:
 682     case OP_PROTOTYPE:
 683       func_ops:
 684         if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
 685             useless = OP_DESC(o);
 686         break;
 687
 688     case OP_NOT:
 689        kid = cUNOPo->op_first;
 690        if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
 691            kid->op_type != OP_TRANS) {
 692                 goto func_ops;
 693        }
 694        useless = "negative pattern binding (!~)";
 695        break;
 696
 697     case OP_RV2GV:
 698     case OP_RV2SV:
 699     case OP_RV2AV:
 700     case OP_RV2HV:
 701         if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
 702                 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
 703             useless = "a variable";
 704         break;
 705
 706     case OP_CONST:
 707         sv = cSVOPo_sv;
 708         if (cSVOPo->op_private & OPpCONST_STRICT)
 709             no_bareword_allowed(o);
 710         else {
 711             if (ckWARN(WARN_VOID)) {
 712                 useless = "a constant";
 713                 /* don't warn on optimised away booleans, eg
 714                  * use constant Foo, 5; Foo || print; */
 715                 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
 716                     useless = 0;
 717                 /* the constants 0 and 1 are permitted as they are
 718                    conventionally used as dummies in constructs like
 719                         1 while some_condition_with_side_effects;  */
 720                 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
 721                     useless = 0;
 722                 else if (SvPOK(sv)) {
 723                   /* perl4's way of mixing documentation and code
 724                      (before the invention of POD) was based on a
 725                      trick to mix nroff and perl code. The trick was
 726                      built upon these three nroff macros being used in
 727                      void context. The pink camel has the details in
 728                      the script wrapman near page 319. */
 729                     if (strnEQ(SvPVX(sv), "di", 2) ||
 730                         strnEQ(SvPVX(sv), "ds", 2) ||
 731                         strnEQ(SvPVX(sv), "ig", 2))
 732                             useless = 0;
 733                 }
 734             }
 735         }
 736         op_null(o);             /* don't execute or even remember it */
 737         break;
 738
 739     case OP_POSTINC:
 740         o->op_type = OP_PREINC;         /* pre-increment is faster */
 741         o->op_ppaddr = PL_ppaddr[OP_PREINC];
 742         break;
 743
 744     case OP_POSTDEC:
 745         o->op_type = OP_PREDEC;         /* pre-decrement is faster */
 746         o->op_ppaddr = PL_ppaddr[OP_PREDEC];
 747         break;
 748
 749     case OP_OR:
 750     case OP_AND:
 751     case OP_DOR:
 752     case OP_COND_EXPR:
 753         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
 754             scalarvoid(kid);
 755         break;
 756
 757     case OP_NULL:
 758         if (o->op_flags & OPf_STACKED)
 759             break;
 760         /* FALL THROUGH */
 761     case OP_NEXTSTATE:
 762     case OP_DBSTATE:
 763     case OP_ENTERTRY:
 764     case OP_ENTER:
 765         if (!(o->op_flags & OPf_KIDS))
 766             break;
 767         /* FALL THROUGH */
 768     case OP_SCOPE:
 769     case OP_LEAVE:
 770     case OP_LEAVETRY:
 771     case OP_LEAVELOOP:
 772     case OP_LINESEQ:
 773     case OP_LIST:
 774         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
 775             scalarvoid(kid);
 776         break;
 777     case OP_ENTEREVAL:
 778         scalarkids(o);
 779         break;
 780     case OP_REQUIRE:
 781         /* all requires must return a boolean value */
 782         o->op_flags &= ~OPf_WANT;
 783         /* FALL THROUGH */
 784     case OP_SCALAR:
 785         return scalar(o);
 786     case OP_SPLIT:
 787         if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
 788             if (!kPMOP->op_pmreplroot)
 789                 deprecate_old("implicit split to @_");
 790         }
 791         break;
 792     }
 793     if (useless && ckWARN(WARN_VOID))
 794         Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
 795     return o;
 796 }
 797
 798 OP *
 799 Perl_listkids(pTHX_ OP *o)
 800 {
 801     OP *kid;
 802     if (o && o->op_flags & OPf_KIDS) {
 803         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
 804             list(kid);
 805     }
 806     return o;
 807 }
 808
 809 OP *
 810 Perl_list(pTHX_ OP *o)
 811 {
 812     OP *kid;
 813
 814     /* assumes no premature commitment */
 815     if (!o || (o->op_flags & OPf_WANT) || PL_error_count
 816          || o->op_type == OP_RETURN)
 817     {
 818         return o;
 819     }
 820
 821     if ((o->op_private & OPpTARGET_MY)
 822         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
 823     {
 824         return o;                               /* As if inside SASSIGN */
 825     }
 826
 827     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
 828
 829     switch (o->op_type) {
 830     case OP_FLOP:
 831     case OP_REPEAT:
 832         list(cBINOPo->op_first);
 833         break;
 834     case OP_OR:
 835     case OP_AND:
 836     case OP_COND_EXPR:
 837         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
 838             list(kid);
 839         break;
 840     default:
 841     case OP_MATCH:
 842     case OP_QR:
 843     case OP_SUBST:
 844     case OP_NULL:
 845         if (!(o->op_flags & OPf_KIDS))
 846             break;
 847         if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
 848             list(cBINOPo->op_first);
 849             return gen_constant_list(o);
 850         }
 851     case OP_LIST:
 852         listkids(o);
 853         break;
 854     case OP_LEAVE:
 855     case OP_LEAVETRY:
 856         kid = cLISTOPo->op_first;
 857         list(kid);
 858         while ((kid = kid->op_sibling)) {
 859             if (kid->op_sibling)
 860                 scalarvoid(kid);
 861             else
 862                 list(kid);
 863         }
 864         WITH_THR(PL_curcop = &PL_compiling);
 865         break;
 866     case OP_SCOPE:
 867     case OP_LINESEQ:
 868         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
 869             if (kid->op_sibling)
 870                 scalarvoid(kid);
 871             else
 872                 list(kid);
 873         }
 874         WITH_THR(PL_curcop = &PL_compiling);
 875         break;
 876     case OP_REQUIRE:
 877         /* all requires must return a boolean value */
 878         o->op_flags &= ~OPf_WANT;
 879         return scalar(o);
 880     }
 881     return o;
 882 }
 883
 884 OP *
 885 Perl_scalarseq(pTHX_ OP *o)
 886 {
 887     OP *kid;
 888
 889     if (o) {
 890         if (o->op_type == OP_LINESEQ ||
 891              o->op_type == OP_SCOPE ||
 892              o->op_type == OP_LEAVE ||
 893              o->op_type == OP_LEAVETRY)
 894         {
 895             for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
 896                 if (kid->op_sibling) {
 897                     scalarvoid(kid);
 898                 }
 899             }
 900             PL_curcop = &PL_compiling;
 901         }
 902         o->op_flags &= ~OPf_PARENS;
 903         if (PL_hints & HINT_BLOCK_SCOPE)
 904             o->op_flags |= OPf_PARENS;
 905     }
 906     else
 907         o = newOP(OP_STUB, 0);
 908     return o;
 909 }
 910
 911 STATIC OP *
 912 S_modkids(pTHX_ OP *o, I32 type)
 913 {
 914     OP *kid;
 915     if (o && o->op_flags & OPf_KIDS) {
 916         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
 917             mod(kid, type);
 918     }
 919     return o;
 920 }
 921
 922 /* Propagate lvalue ("modifiable") context to an op and it's children.
 923  * 'type' represents the context type, roughly based on the type of op that
 924  * would do the modifying, although local() is represented by OP_NULL.
 925  * It's responsible for detecting things that can't be modified,  flag
 926  * things that need to behave specially in an lvalue context (e.g., "$$x = 5"
 927  * might have to vivify a reference in $x), and so on.
 928  *
 929  * For example, "$a+1 = 2" would cause mod() to be called with o being
 930  * OP_ADD and type being OP_SASSIGN, and would output an error.
 931  */
 932
 933 OP *
 934 Perl_mod(pTHX_ OP *o, I32 type)
 935 {
 936     OP *kid;
 937     /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
 938     int localize = -1;
 939
 940     if (!o || PL_error_count)
 941         return o;
 942
 943     if ((o->op_private & OPpTARGET_MY)
 944         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
 945     {
 946         return o;
 947     }
 948
 949     switch (o->op_type) {
 950     case OP_UNDEF:
 951         localize = 0;
 952         PL_modcount++;
 953         return o;
 954     case OP_CONST:
 955         if (!(o->op_private & (OPpCONST_ARYBASE)))
 956             goto nomod;
 957         if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
 958             PL_compiling.cop_arybase = (I32)SvIV(cSVOPx(PL_eval_start)->op_sv);
 959             PL_eval_start = 0;
 960         }
 961         else if (!type) {
 962             SAVEI32(PL_compiling.cop_arybase);
 963             PL_compiling.cop_arybase = 0;
 964         }
 965         else if (type == OP_REFGEN)
 966             goto nomod;
 967         else
 968             Perl_croak(aTHX_ "That use of $[ is unsupported");
 969         break;
 970     case OP_STUB:
 971         if (o->op_flags & OPf_PARENS)
 972             break;
 973         goto nomod;
 974     case OP_ENTERSUB:
 975         if ((type == OP_UNDEF || type == OP_REFGEN) &&
 976             !(o->op_flags & OPf_STACKED)) {
 977             o->op_type = OP_RV2CV;              /* entersub => rv2cv */
 978             o->op_ppaddr = PL_ppaddr[OP_RV2CV];
 979             assert(cUNOPo->op_first->op_type == OP_NULL);
 980             op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
 981             break;
 982         }
 983         else if (o->op_private & OPpENTERSUB_NOMOD)
 984             return o;
 985         else {                          /* lvalue subroutine call */
 986             o->op_private |= OPpLVAL_INTRO;
 987             PL_modcount = RETURN_UNLIMITED_NUMBER;
 988             if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
 989                 /* Backward compatibility mode: */
 990                 o->op_private |= OPpENTERSUB_INARGS;
 991                 break;
 992             }
 993             else {                      /* Compile-time error message: */
 994                 OP *kid = cUNOPo->op_first;
 995                 CV *cv;
 996                 OP *okid;
 997
 998                 if (kid->op_type == OP_PUSHMARK)
 999                     goto skip_kids;
1000                 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1001                     Perl_croak(aTHX_
1002                                "panic: unexpected lvalue entersub "
1003                                "args: type/targ %ld:%"UVuf,
1004                                (long)kid->op_type, (UV)kid->op_targ);
1005                 kid = kLISTOP->op_first;
1006               skip_kids:
1007                 while (kid->op_sibling)
1008                     kid = kid->op_sibling;
1009                 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1010                     /* Indirect call */
1011                     if (kid->op_type == OP_METHOD_NAMED
1012                         || kid->op_type == OP_METHOD)
1013                     {
1014                         UNOP *newop;
1015
1016                         NewOp(1101, newop, 1, UNOP);
1017                         newop->op_type = OP_RV2CV;
1018                         newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1019                         newop->op_first = Nullop;
1020                         newop->op_next = (OP*)newop;
1021                         kid->op_sibling = (OP*)newop;
1022                         newop->op_private |= OPpLVAL_INTRO;
1023                         break;
1024                     }
1025
1026                     if (kid->op_type != OP_RV2CV)
1027                         Perl_croak(aTHX_
1028                                    "panic: unexpected lvalue entersub "
1029                                    "entry via type/targ %ld:%"UVuf,
1030                                    (long)kid->op_type, (UV)kid->op_targ);
1031                     kid->op_private |= OPpLVAL_INTRO;
1032                     break;      /* Postpone until runtime */
1033                 }
1034
1035                 okid = kid;
1036                 kid = kUNOP->op_first;
1037                 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1038                     kid = kUNOP->op_first;
1039                 if (kid->op_type == OP_NULL)
1040                     Perl_croak(aTHX_
1041                                "Unexpected constant lvalue entersub "
1042                                "entry via type/targ %ld:%"UVuf,
1043                                (long)kid->op_type, (UV)kid->op_targ);
1044                 if (kid->op_type != OP_GV) {
1045                     /* Restore RV2CV to check lvalueness */
1046                   restore_2cv:
1047                     if (kid->op_next && kid->op_next != kid) { /* Happens? */
1048                         okid->op_next = kid->op_next;
1049                         kid->op_next = okid;
1050                     }
1051                     else
1052                         okid->op_next = Nullop;
1053                     okid->op_type = OP_RV2CV;
1054                     okid->op_targ = 0;
1055                     okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1056                     okid->op_private |= OPpLVAL_INTRO;
1057                     break;
1058                 }
1059
1060                 cv = GvCV(kGVOP_gv);
1061                 if (!cv)
1062                     goto restore_2cv;
1063                 if (CvLVALUE(cv))
1064                     break;
1065             }
1066         }
1067         /* FALL THROUGH */
1068     default:
1069       nomod:
1070         /* grep, foreach, subcalls, refgen */
1071         if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1072             break;
1073         yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1074                      (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1075                       ? "do block"
1076                       : (o->op_type == OP_ENTERSUB
1077                         ? "non-lvalue subroutine call"
1078                         : OP_DESC(o))),
1079                      type ? PL_op_desc[type] : "local"));
1080         return o;
1081
1082     case OP_PREINC:
1083     case OP_PREDEC:
1084     case OP_POW:
1085     case OP_MULTIPLY:
1086     case OP_DIVIDE:
1087     case OP_MODULO:
1088     case OP_REPEAT:
1089     case OP_ADD:
1090     case OP_SUBTRACT:
1091     case OP_CONCAT:
1092     case OP_LEFT_SHIFT:
1093     case OP_RIGHT_SHIFT:
1094     case OP_BIT_AND:
1095     case OP_BIT_XOR:
1096     case OP_BIT_OR:
1097     case OP_I_MULTIPLY:
1098     case OP_I_DIVIDE:
1099     case OP_I_MODULO:
1100     case OP_I_ADD:
1101     case OP_I_SUBTRACT:
1102         if (!(o->op_flags & OPf_STACKED))
1103             goto nomod;
1104         PL_modcount++;
1105         break;
1106
1107     case OP_COND_EXPR:
1108         localize = 1;
1109         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1110             mod(kid, type);
1111         break;
1112
1113     case OP_RV2AV:
1114     case OP_RV2HV:
1115         if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1116            PL_modcount = RETURN_UNLIMITED_NUMBER;
1117             return o;           /* Treat \(@foo) like ordinary list. */
1118         }
1119         /* FALL THROUGH */
1120     case OP_RV2GV:
1121         if (scalar_mod_type(o, type))
1122             goto nomod;
1123         ref(cUNOPo->op_first, o->op_type);
1124         /* FALL THROUGH */
1125     case OP_ASLICE:
1126     case OP_HSLICE:
1127         if (type == OP_LEAVESUBLV)
1128             o->op_private |= OPpMAYBE_LVSUB;
1129         localize = 1;
1130         /* FALL THROUGH */
1131     case OP_AASSIGN:
1132     case OP_NEXTSTATE:
1133     case OP_DBSTATE:
1134        PL_modcount = RETURN_UNLIMITED_NUMBER;
1135         break;
1136     case OP_RV2SV:
1137         ref(cUNOPo->op_first, o->op_type);
1138         localize = 1;
1139         /* FALL THROUGH */
1140     case OP_GV:
1141     case OP_AV2ARYLEN:
1142         PL_hints |= HINT_BLOCK_SCOPE;
1143     case OP_SASSIGN:
1144     case OP_ANDASSIGN:
1145     case OP_ORASSIGN:
1146     case OP_DORASSIGN:
1147         PL_modcount++;
1148         break;
1149
1150     case OP_AELEMFAST:
1151         localize = -1;
1152         PL_modcount++;
1153         break;
1154
1155     case OP_PADAV:
1156     case OP_PADHV:
1157        PL_modcount = RETURN_UNLIMITED_NUMBER;
1158         if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1159             return o;           /* Treat \(@foo) like ordinary list. */
1160         if (scalar_mod_type(o, type))
1161             goto nomod;
1162         if (type == OP_LEAVESUBLV)
1163             o->op_private |= OPpMAYBE_LVSUB;
1164         /* FALL THROUGH */
1165     case OP_PADSV:
1166         PL_modcount++;
1167         if (!type) /* local() */
1168             Perl_croak(aTHX_ "Can't localize lexical variable %s",
1169                  PAD_COMPNAME_PV(o->op_targ));
1170         break;
1171
1172     case OP_PUSHMARK:
1173         localize = 0;
1174         break;
1175
1176     case OP_KEYS:
1177         if (type != OP_SASSIGN)
1178             goto nomod;
1179         goto lvalue_func;
1180     case OP_SUBSTR:
1181         if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1182             goto nomod;
1183         /* FALL THROUGH */
1184     case OP_POS:
1185     case OP_VEC:
1186         if (type == OP_LEAVESUBLV)
1187             o->op_private |= OPpMAYBE_LVSUB;
1188       lvalue_func:
1189         pad_free(o->op_targ);
1190         o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1191         assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1192         if (o->op_flags & OPf_KIDS)
1193             mod(cBINOPo->op_first->op_sibling, type);
1194         break;
1195
1196     case OP_AELEM:
1197     case OP_HELEM:
1198         ref(cBINOPo->op_first, o->op_type);
1199         if (type == OP_ENTERSUB &&
1200              !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1201             o->op_private |= OPpLVAL_DEFER;
1202         if (type == OP_LEAVESUBLV)
1203             o->op_private |= OPpMAYBE_LVSUB;
1204         localize = 1;
1205         PL_modcount++;
1206         break;
1207
1208     case OP_SCOPE:
1209     case OP_LEAVE:
1210     case OP_ENTER:
1211     case OP_LINESEQ:
1212         localize = 0;
1213         if (o->op_flags & OPf_KIDS)
1214             mod(cLISTOPo->op_last, type);
1215         break;
1216
1217     case OP_NULL:
1218         localize = 0;
1219         if (o->op_flags & OPf_SPECIAL)          /* do BLOCK */
1220             goto nomod;
1221         else if (!(o->op_flags & OPf_KIDS))
1222             break;
1223         if (o->op_targ != OP_LIST) {
1224             mod(cBINOPo->op_first, type);
1225             break;
1226         }
1227         /* FALL THROUGH */
1228     case OP_LIST:
1229         localize = 0;
1230         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1231             mod(kid, type);
1232         break;
1233
1234     case OP_RETURN:
1235         if (type != OP_LEAVESUBLV)
1236             goto nomod;
1237         break; /* mod()ing was handled by ck_return() */
1238     }
1239
1240     /* [20011101.069] File test operators interpret OPf_REF to mean that
1241        their argument is a filehandle; thus \stat(".") should not set
1242        it. AMS 20011102 */
1243     if (type == OP_REFGEN &&
1244         PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1245         return o;
1246
1247     if (type != OP_LEAVESUBLV)
1248         o->op_flags |= OPf_MOD;
1249
1250     if (type == OP_AASSIGN || type == OP_SASSIGN)
1251         o->op_flags |= OPf_SPECIAL|OPf_REF;
1252     else if (!type) { /* local() */
1253         switch (localize) {
1254         case 1:
1255             o->op_private |= OPpLVAL_INTRO;
1256             o->op_flags &= ~OPf_SPECIAL;
1257             PL_hints |= HINT_BLOCK_SCOPE;
1258             break;
1259         case 0:
1260             break;
1261         case -1:
1262             if (ckWARN(WARN_SYNTAX)) {
1263                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1264                     "Useless localization of %s", OP_DESC(o));
1265             }
1266         }
1267     }
1268     else if (type != OP_GREPSTART && type != OP_ENTERSUB
1269              && type != OP_LEAVESUBLV)
1270         o->op_flags |= OPf_REF;
1271     return o;
1272 }
1273
1274 STATIC bool
1275 S_scalar_mod_type(pTHX_ OP *o, I32 type)
1276 {
1277     switch (type) {
1278     case OP_SASSIGN:
1279         if (o->op_type == OP_RV2GV)
1280             return FALSE;
1281         /* FALL THROUGH */
1282     case OP_PREINC:
1283     case OP_PREDEC:
1284     case OP_POSTINC:
1285     case OP_POSTDEC:
1286     case OP_I_PREINC:
1287     case OP_I_PREDEC:
1288     case OP_I_POSTINC:
1289     case OP_I_POSTDEC:
1290     case OP_POW:
1291     case OP_MULTIPLY:
1292     case OP_DIVIDE:
1293     case OP_MODULO:
1294     case OP_REPEAT:
1295     case OP_ADD:
1296     case OP_SUBTRACT:
1297     case OP_I_MULTIPLY:
1298     case OP_I_DIVIDE:
1299     case OP_I_MODULO:
1300     case OP_I_ADD:
1301     case OP_I_SUBTRACT:
1302     case OP_LEFT_SHIFT:
1303     case OP_RIGHT_SHIFT:
1304     case OP_BIT_AND:
1305     case OP_BIT_XOR:
1306     case OP_BIT_OR:
1307     case OP_CONCAT:
1308     case OP_SUBST:
1309     case OP_TRANS:
1310     case OP_READ:
1311     case OP_SYSREAD:
1312     case OP_RECV:
1313     case OP_ANDASSIGN:
1314     case OP_ORASSIGN:
1315         return TRUE;
1316     default:
1317         return FALSE;
1318     }
1319 }
1320
1321 STATIC bool
1322 S_is_handle_constructor(pTHX_ OP *o, I32 argnum)
1323 {
1324     switch (o->op_type) {
1325     case OP_PIPE_OP:
1326     case OP_SOCKPAIR:
1327         if (argnum == 2)
1328             return TRUE;
1329         /* FALL THROUGH */
1330     case OP_SYSOPEN:
1331     case OP_OPEN:
1332     case OP_SELECT:             /* XXX c.f. SelectSaver.pm */
1333     case OP_SOCKET:
1334     case OP_OPEN_DIR:
1335     case OP_ACCEPT:
1336         if (argnum == 1)
1337             return TRUE;
1338         /* FALL THROUGH */
1339     default:
1340         return FALSE;
1341     }
1342 }
1343
1344 OP *
1345 Perl_refkids(pTHX_ OP *o, I32 type)
1346 {
1347     OP *kid;
1348     if (o && o->op_flags & OPf_KIDS) {
1349         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1350             ref(kid, type);
1351     }
1352     return o;
1353 }
1354
1355 OP *
1356 Perl_ref(pTHX_ OP *o, I32 type)
1357 {
1358     OP *kid;
1359
1360     if (!o || PL_error_count)
1361         return o;
1362
1363     switch (o->op_type) {
1364     case OP_ENTERSUB:
1365         if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1366             !(o->op_flags & OPf_STACKED)) {
1367             o->op_type = OP_RV2CV;             /* entersub => rv2cv */
1368             o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1369             assert(cUNOPo->op_first->op_type == OP_NULL);
1370             op_null(((LISTOP*)cUNOPo->op_first)->op_first);     /* disable pushmark */
1371             o->op_flags |= OPf_SPECIAL;
1372         }
1373         break;
1374
1375     case OP_COND_EXPR:
1376         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1377             ref(kid, type);
1378         break;
1379     case OP_RV2SV:
1380         if (type == OP_DEFINED)
1381             o->op_flags |= OPf_SPECIAL;         /* don't create GV */
1382         ref(cUNOPo->op_first, o->op_type);
1383         /* FALL THROUGH */
1384     case OP_PADSV:
1385         if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1386             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1387                               : type == OP_RV2HV ? OPpDEREF_HV
1388                               : OPpDEREF_SV);
1389             o->op_flags |= OPf_MOD;
1390         }
1391         break;
1392
1393     case OP_THREADSV:
1394         o->op_flags |= OPf_MOD;         /* XXX ??? */
1395         break;
1396
1397     case OP_RV2AV:
1398     case OP_RV2HV:
1399         o->op_flags |= OPf_REF;
1400         /* FALL THROUGH */
1401     case OP_RV2GV:
1402         if (type == OP_DEFINED)
1403             o->op_flags |= OPf_SPECIAL;         /* don't create GV */
1404         ref(cUNOPo->op_first, o->op_type);
1405         break;
1406
1407     case OP_PADAV:
1408     case OP_PADHV:
1409         o->op_flags |= OPf_REF;
1410         break;
1411
1412     case OP_SCALAR:
1413     case OP_NULL:
1414         if (!(o->op_flags & OPf_KIDS))
1415             break;
1416         ref(cBINOPo->op_first, type);
1417         break;
1418     case OP_AELEM:
1419     case OP_HELEM:
1420         ref(cBINOPo->op_first, o->op_type);
1421         if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1422             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1423                               : type == OP_RV2HV ? OPpDEREF_HV
1424                               : OPpDEREF_SV);
1425             o->op_flags |= OPf_MOD;
1426         }
1427         break;
1428
1429     case OP_SCOPE:
1430     case OP_LEAVE:
1431     case OP_ENTER:
1432     case OP_LIST:
1433         if (!(o->op_flags & OPf_KIDS))
1434             break;
1435         ref(cLISTOPo->op_last, type);
1436         break;
1437     default:
1438         break;
1439     }
1440     return scalar(o);
1441
1442 }
1443
1444 STATIC OP *
1445 S_dup_attrlist(pTHX_ OP *o)
1446 {
1447     OP *rop = Nullop;
1448
1449     /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1450      * where the first kid is OP_PUSHMARK and the remaining ones
1451      * are OP_CONST.  We need to push the OP_CONST values.
1452      */
1453     if (o->op_type == OP_CONST)
1454         rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc(cSVOPo->op_sv));
1455     else {
1456         assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1457         for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1458             if (o->op_type == OP_CONST)
1459                 rop = append_elem(OP_LIST, rop,
1460                                   newSVOP(OP_CONST, o->op_flags,
1461                                           SvREFCNT_inc(cSVOPo->op_sv)));
1462         }
1463     }
1464     return rop;
1465 }
1466
1467 STATIC void
1468 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1469 {
1470     SV *stashsv;
1471
1472     /* fake up C<use attributes $pkg,$rv,@attrs> */
1473     ENTER;              /* need to protect against side-effects of 'use' */
1474     SAVEINT(PL_expect);
1475     if (stash)
1476         stashsv = newSVpv(HvNAME(stash), 0);
1477     else
1478         stashsv = &PL_sv_no;
1479
1480 #define ATTRSMODULE "attributes"
1481 #define ATTRSMODULE_PM "attributes.pm"
1482
1483     if (for_my) {
1484         SV **svp;
1485         /* Don't force the C<use> if we don't need it. */
1486         svp = hv_fetch(GvHVn(PL_incgv), ATTRSMODULE_PM,
1487                        sizeof(ATTRSMODULE_PM)-1, 0);
1488         if (svp && *svp != &PL_sv_undef)
1489             ;           /* already in %INC */
1490         else
1491             Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1492                              newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1493                              Nullsv);
1494     }
1495     else {
1496         Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1497                          newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1498                          Nullsv,
1499                          prepend_elem(OP_LIST,
1500                                       newSVOP(OP_CONST, 0, stashsv),
1501                                       prepend_elem(OP_LIST,
1502                                                    newSVOP(OP_CONST, 0,
1503                                                            newRV(target)),
1504                                                    dup_attrlist(attrs))));
1505     }
1506     LEAVE;
1507 }
1508
1509 STATIC void
1510 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1511 {
1512     OP *pack, *imop, *arg;
1513     SV *meth, *stashsv;
1514
1515     if (!attrs)
1516         return;
1517
1518     assert(target->op_type == OP_PADSV ||
1519            target->op_type == OP_PADHV ||
1520            target->op_type == OP_PADAV);
1521
1522     /* Ensure that attributes.pm is loaded. */
1523     apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
1524
1525     /* Need package name for method call. */
1526     pack = newSVOP(OP_CONST, 0, newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1));
1527
1528     /* Build up the real arg-list. */
1529     if (stash)
1530         stashsv = newSVpv(HvNAME(stash), 0);
1531     else
1532         stashsv = &PL_sv_no;
1533     arg = newOP(OP_PADSV, 0);
1534     arg->op_targ = target->op_targ;
1535     arg = prepend_elem(OP_LIST,
1536                        newSVOP(OP_CONST, 0, stashsv),
1537                        prepend_elem(OP_LIST,
1538                                     newUNOP(OP_REFGEN, 0,
1539                                             mod(arg, OP_REFGEN)),
1540                                     dup_attrlist(attrs)));
1541
1542     /* Fake up a method call to import */
1543     meth = newSVpvn("import", 6);
1544     (void)SvUPGRADE(meth, SVt_PVIV);
1545     (void)SvIOK_on(meth);
1546     PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
1547     imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
1548                    append_elem(OP_LIST,
1549                                prepend_elem(OP_LIST, pack, list(arg)),
1550                                newSVOP(OP_METHOD_NAMED, 0, meth)));
1551     imop->op_private |= OPpENTERSUB_NOMOD;
1552
1553     /* Combine the ops. */
1554     *imopsp = append_elem(OP_LIST, *imopsp, imop);
1555 }
1556
1557 /*
1558 =notfor apidoc apply_attrs_string
1559
1560 Attempts to apply a list of attributes specified by the C<attrstr> and
1561 C<len> arguments to the subroutine identified by the C<cv> argument which
1562 is expected to be associated with the package identified by the C<stashpv>
1563 argument (see L<attributes>).  It gets this wrong, though, in that it
1564 does not correctly identify the boundaries of the individual attribute
1565 specifications within C<attrstr>.  This is not really intended for the
1566 public API, but has to be listed here for systems such as AIX which
1567 need an explicit export list for symbols.  (It's called from XS code
1568 in support of the C<ATTRS:> keyword from F<xsubpp>.)  Patches to fix it
1569 to respect attribute syntax properly would be welcome.
1570
1571 =cut
1572 */
1573
1574 void
1575 Perl_apply_attrs_string(pTHX_ char *stashpv, CV *cv,
1576                         char *attrstr, STRLEN len)
1577 {
1578     OP *attrs = Nullop;
1579
1580     if (!len) {
1581         len = strlen(attrstr);
1582     }
1583
1584     while (len) {
1585         for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1586         if (len) {
1587             char *sstr = attrstr;
1588             for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1589             attrs = append_elem(OP_LIST, attrs,
1590                                 newSVOP(OP_CONST, 0,
1591                                         newSVpvn(sstr, attrstr-sstr)));
1592         }
1593     }
1594
1595     Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1596                      newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1597                      Nullsv, prepend_elem(OP_LIST,
1598                                   newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1599                                   prepend_elem(OP_LIST,
1600                                                newSVOP(OP_CONST, 0,
1601                                                        newRV((SV*)cv)),
1602                                                attrs)));
1603 }
1604
1605 STATIC OP *
1606 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
1607 {
1608     OP *kid;
1609     I32 type;
1610
1611     if (!o || PL_error_count)
1612         return o;
1613
1614     type = o->op_type;
1615     if (type == OP_LIST) {
1616         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1617             my_kid(kid, attrs, imopsp);
1618     } else if (type == OP_UNDEF) {
1619         return o;
1620     } else if (type == OP_RV2SV ||      /* "our" declaration */
1621                type == OP_RV2AV ||
1622                type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1623         if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
1624             yyerror(Perl_form(aTHX_ "Can't declare %s in %s",
1625                         OP_DESC(o), PL_in_my == KEY_our ? "our" : "my"));
1626         } else if (attrs) {
1627             GV *gv = cGVOPx_gv(cUNOPo->op_first);
1628             PL_in_my = FALSE;
1629             PL_in_my_stash = Nullhv;
1630             apply_attrs(GvSTASH(gv),
1631                         (type == OP_RV2SV ? GvSV(gv) :
1632                          type == OP_RV2AV ? (SV*)GvAV(gv) :
1633                          type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1634                         attrs, FALSE);
1635         }
1636         o->op_private |= OPpOUR_INTRO;
1637         return o;
1638     }
1639     else if (type != OP_PADSV &&
1640              type != OP_PADAV &&
1641              type != OP_PADHV &&
1642              type != OP_PUSHMARK)
1643     {
1644         yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1645                           OP_DESC(o),
1646                           PL_in_my == KEY_our ? "our" : "my"));
1647         return o;
1648     }
1649     else if (attrs && type != OP_PUSHMARK) {
1650         HV *stash;
1651
1652         PL_in_my = FALSE;
1653         PL_in_my_stash = Nullhv;
1654
1655         /* check for C<my Dog $spot> when deciding package */
1656         stash = PAD_COMPNAME_TYPE(o->op_targ);
1657         if (!stash)
1658             stash = PL_curstash;
1659         apply_attrs_my(stash, o, attrs, imopsp);
1660     }
1661     o->op_flags |= OPf_MOD;
1662     o->op_private |= OPpLVAL_INTRO;
1663     return o;
1664 }
1665
1666 OP *
1667 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
1668 {
1669     OP *rops = Nullop;
1670     int maybe_scalar = 0;
1671
1672 /* [perl #17376]: this appears to be premature, and results in code such as
1673    C< our(%x); > executing in list mode rather than void mode */
1674 #if 0
1675     if (o->op_flags & OPf_PARENS)
1676         list(o);
1677     else
1678         maybe_scalar = 1;
1679 #else
1680     maybe_scalar = 1;
1681 #endif
1682     if (attrs)
1683         SAVEFREEOP(attrs);
1684     o = my_kid(o, attrs, &rops);
1685     if (rops) {
1686         if (maybe_scalar && o->op_type == OP_PADSV) {
1687             o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
1688             o->op_private |= OPpLVAL_INTRO;
1689         }
1690         else
1691             o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
1692     }
1693     PL_in_my = FALSE;
1694     PL_in_my_stash = Nullhv;
1695     return o;
1696 }
1697
1698 OP *
1699 Perl_my(pTHX_ OP *o)
1700 {
1701     return my_attrs(o, Nullop);
1702 }
1703
1704 OP *
1705 Perl_sawparens(pTHX_ OP *o)
1706 {
1707     if (o)
1708         o->op_flags |= OPf_PARENS;
1709     return o;
1710 }
1711
1712 OP *
1713 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
1714 {
1715     OP *o;
1716     bool ismatchop = 0;
1717
1718     if (ckWARN(WARN_MISC) &&
1719       (left->op_type == OP_RV2AV ||
1720        left->op_type == OP_RV2HV ||
1721        left->op_type == OP_PADAV ||
1722        left->op_type == OP_PADHV)) {
1723       char *desc = PL_op_desc[(right->op_type == OP_SUBST ||
1724                             right->op_type == OP_TRANS)
1725                            ? right->op_type : OP_MATCH];
1726       const char *sample = ((left->op_type == OP_RV2AV ||
1727                              left->op_type == OP_PADAV)
1728                             ? "@array" : "%hash");
1729       Perl_warner(aTHX_ packWARN(WARN_MISC),
1730              "Applying %s to %s will act on scalar(%s)",
1731              desc, sample, sample);
1732     }
1733
1734     if (right->op_type == OP_CONST &&
1735         cSVOPx(right)->op_private & OPpCONST_BARE &&
1736         cSVOPx(right)->op_private & OPpCONST_STRICT)
1737     {
1738         no_bareword_allowed(right);
1739     }
1740
1741     ismatchop = right->op_type == OP_MATCH ||
1742                 right->op_type == OP_SUBST ||
1743                 right->op_type == OP_TRANS;
1744     if (ismatchop && right->op_private & OPpTARGET_MY) {
1745         right->op_targ = 0;
1746         right->op_private &= ~OPpTARGET_MY;
1747     }
1748     if (!(right->op_flags & OPf_STACKED) && ismatchop) {
1749         right->op_flags |= OPf_STACKED;
1750         if (right->op_type != OP_MATCH &&
1751             ! (right->op_type == OP_TRANS &&
1752                right->op_private & OPpTRANS_IDENTICAL))
1753             left = mod(left, right->op_type);
1754         if (right->op_type == OP_TRANS)
1755             o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
1756         else
1757             o = prepend_elem(right->op_type, scalar(left), right);
1758         if (type == OP_NOT)
1759             return newUNOP(OP_NOT, 0, scalar(o));
1760         return o;
1761     }
1762     else
1763         return bind_match(type, left,
1764                 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
1765 }
1766
1767 OP *
1768 Perl_invert(pTHX_ OP *o)
1769 {
1770     if (!o)
1771         return o;
1772     /* XXX need to optimize away NOT NOT here?  Or do we let optimizer do it? */
1773     return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
1774 }
1775
1776 OP *
1777 Perl_scope(pTHX_ OP *o)
1778 {
1779     if (o) {
1780         if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
1781             o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
1782             o->op_type = OP_LEAVE;
1783             o->op_ppaddr = PL_ppaddr[OP_LEAVE];
1784         }
1785         else if (o->op_type == OP_LINESEQ) {
1786             OP *kid;
1787             o->op_type = OP_SCOPE;
1788             o->op_ppaddr = PL_ppaddr[OP_SCOPE];
1789             kid = ((LISTOP*)o)->op_first;
1790             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
1791                 op_null(kid);
1792         }
1793         else
1794             o = newLISTOP(OP_SCOPE, 0, o, Nullop);
1795     }
1796     return o;
1797 }
1798
1799 /* XXX kept for BINCOMPAT only */
1800 void
1801 Perl_save_hints(pTHX)
1802 {
1803     Perl_croak(aTHX_ "internal error: obsolete function save_hints() called");
1804 }
1805
1806 int
1807 Perl_block_start(pTHX_ int full)
1808 {
1809     int retval = PL_savestack_ix;
1810     pad_block_start(full);
1811     SAVEHINTS();
1812     PL_hints &= ~HINT_BLOCK_SCOPE;
1813     SAVESPTR(PL_compiling.cop_warnings);
1814     if (! specialWARN(PL_compiling.cop_warnings)) {
1815         PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
1816         SAVEFREESV(PL_compiling.cop_warnings) ;
1817     }
1818     SAVESPTR(PL_compiling.cop_io);
1819     if (! specialCopIO(PL_compiling.cop_io)) {
1820         PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
1821         SAVEFREESV(PL_compiling.cop_io) ;
1822     }
1823     return retval;
1824 }
1825
1826 OP*
1827 Perl_block_end(pTHX_ I32 floor, OP *seq)
1828 {
1829     int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
1830     OP* retval = scalarseq(seq);
1831     LEAVE_SCOPE(floor);
1832     PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
1833     if (needblockscope)
1834         PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
1835     pad_leavemy();
1836     return retval;
1837 }
1838
1839 STATIC OP *
1840 S_newDEFSVOP(pTHX)
1841 {
1842     I32 offset = pad_findmy("$_");
1843     if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
1844         return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
1845     }
1846     else {
1847         OP *o = newOP(OP_PADSV, 0);
1848         o->op_targ = offset;
1849         return o;
1850     }
1851 }
1852
1853 void
1854 Perl_newPROG(pTHX_ OP *o)
1855 {
1856     if (PL_in_eval) {
1857         if (PL_eval_root)
1858                 return;
1859         PL_eval_root = newUNOP(OP_LEAVEEVAL,
1860                                ((PL_in_eval & EVAL_KEEPERR)
1861                                 ? OPf_SPECIAL : 0), o);
1862         PL_eval_start = linklist(PL_eval_root);
1863         PL_eval_root->op_private |= OPpREFCOUNTED;
1864         OpREFCNT_set(PL_eval_root, 1);
1865         PL_eval_root->op_next = 0;
1866         CALL_PEEP(PL_eval_start);
1867     }
1868     else {
1869         if (o->op_type == OP_STUB) {
1870             PL_comppad_name = 0;
1871             PL_compcv = 0;
1872             FreeOp(o);
1873             return;
1874         }
1875         PL_main_root = scope(sawparens(scalarvoid(o)));
1876         PL_curcop = &PL_compiling;
1877         PL_main_start = LINKLIST(PL_main_root);
1878         PL_main_root->op_private |= OPpREFCOUNTED;
1879         OpREFCNT_set(PL_main_root, 1);
1880         PL_main_root->op_next = 0;
1881         CALL_PEEP(PL_main_start);
1882         PL_compcv = 0;
1883
1884         /* Register with debugger */
1885         if (PERLDB_INTER) {
1886             CV *cv = get_cv("DB::postponed", FALSE);
1887             if (cv) {
1888                 dSP;
1889                 PUSHMARK(SP);
1890                 XPUSHs((SV*)CopFILEGV(&PL_compiling));
1891                 PUTBACK;
1892                 call_sv((SV*)cv, G_DISCARD);
1893             }
1894         }
1895     }
1896 }
1897
1898 OP *
1899 Perl_localize(pTHX_ OP *o, I32 lex)
1900 {
1901     if (o->op_flags & OPf_PARENS)
1902 /* [perl #17376]: this appears to be premature, and results in code such as
1903    C< our(%x); > executing in list mode rather than void mode */
1904 #if 0
1905         list(o);
1906 #else
1907         ;
1908 #endif
1909     else {
1910         if (ckWARN(WARN_PARENTHESIS)
1911             && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',')
1912         {
1913             char *s = PL_bufptr;
1914             bool sigil = FALSE;
1915
1916             /* some heuristics to detect a potential error */
1917             while (*s && (strchr(", \t\n", *s)))
1918                 s++;
1919
1920             while (1) {
1921                 if (*s && strchr("@$%*", *s) && *++s
1922                        && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
1923                     s++;
1924                     sigil = TRUE;
1925                     while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
1926                         s++;
1927                     while (*s && (strchr(", \t\n", *s)))
1928                         s++;
1929                 }
1930                 else
1931                     break;
1932             }
1933             if (sigil && (*s == ';' || *s == '=')) {
1934                 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
1935                                 "Parentheses missing around \"%s\" list",
1936                                 lex ? (PL_in_my == KEY_our ? "our" : "my")
1937                                 : "local");
1938             }
1939         }
1940     }
1941     if (lex)
1942         o = my(o);
1943     else
1944         o = mod(o, OP_NULL);            /* a bit kludgey */
1945     PL_in_my = FALSE;
1946     PL_in_my_stash = Nullhv;
1947     return o;
1948 }
1949
1950 OP *
1951 Perl_jmaybe(pTHX_ OP *o)
1952 {
1953     if (o->op_type == OP_LIST) {
1954         OP *o2;
1955         o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
1956         o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
1957     }
1958     return o;
1959 }
1960
1961 OP *
1962 Perl_fold_constants(pTHX_ register OP *o)
1963 {
1964     register OP *curop;
1965     I32 type = o->op_type;
1966     SV *sv;
1967
1968     if (PL_opargs[type] & OA_RETSCALAR)
1969         scalar(o);
1970     if (PL_opargs[type] & OA_TARGET && !o->op_targ)
1971         o->op_targ = pad_alloc(type, SVs_PADTMP);
1972
1973     /* integerize op, unless it happens to be C<-foo>.
1974      * XXX should pp_i_negate() do magic string negation instead? */
1975     if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
1976         && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
1977              && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
1978     {
1979         o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
1980     }
1981
1982     if (!(PL_opargs[type] & OA_FOLDCONST))
1983         goto nope;
1984
1985     switch (type) {
1986     case OP_NEGATE:
1987         /* XXX might want a ck_negate() for this */
1988         cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
1989         break;
1990     case OP_SPRINTF:
1991     case OP_UCFIRST:
1992     case OP_LCFIRST:
1993     case OP_UC:
1994     case OP_LC:
1995     case OP_SLT:
1996     case OP_SGT:
1997     case OP_SLE:
1998     case OP_SGE:
1999     case OP_SCMP:
2000         /* XXX what about the numeric ops? */
2001         if (PL_hints & HINT_LOCALE)
2002             goto nope;
2003     }
2004
2005     if (PL_error_count)
2006         goto nope;              /* Don't try to run w/ errors */
2007
2008     for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2009         if ((curop->op_type != OP_CONST ||
2010              (curop->op_private & OPpCONST_BARE)) &&
2011             curop->op_type != OP_LIST &&
2012             curop->op_type != OP_SCALAR &&
2013             curop->op_type != OP_NULL &&
2014             curop->op_type != OP_PUSHMARK)
2015         {
2016             goto nope;
2017         }
2018     }
2019
2020     curop = LINKLIST(o);
2021     o->op_next = 0;
2022     PL_op = curop;
2023     CALLRUNOPS(aTHX);
2024     sv = *(PL_stack_sp--);
2025     if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2026         pad_swipe(o->op_targ,  FALSE);
2027     else if (SvTEMP(sv)) {                      /* grab mortal temp? */
2028         (void)SvREFCNT_inc(sv);
2029         SvTEMP_off(sv);
2030     }
2031     op_free(o);
2032     if (type == OP_RV2GV)
2033         return newGVOP(OP_GV, 0, (GV*)sv);
2034     return newSVOP(OP_CONST, 0, sv);
2035
2036   nope:
2037     return o;
2038 }
2039
2040 OP *
2041 Perl_gen_constant_list(pTHX_ register OP *o)
2042 {
2043     register OP *curop;
2044     I32 oldtmps_floor = PL_tmps_floor;
2045
2046     list(o);
2047     if (PL_error_count)
2048         return o;               /* Don't attempt to run with errors */
2049
2050     PL_op = curop = LINKLIST(o);
2051     o->op_next = 0;
2052     CALL_PEEP(curop);
2053     pp_pushmark();
2054     CALLRUNOPS(aTHX);
2055     PL_op = curop;
2056     pp_anonlist();
2057     PL_tmps_floor = oldtmps_floor;
2058
2059     o->op_type = OP_RV2AV;
2060     o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2061     o->op_flags &= ~OPf_REF;    /* treat \(1..2) like an ordinary list */
2062     o->op_flags |= OPf_PARENS;  /* and flatten \(1..2,3) */
2063     o->op_opt = 0;              /* needs to be revisited in peep() */
2064     curop = ((UNOP*)o)->op_first;
2065     ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
2066     op_free(curop);
2067     linklist(o);
2068     return list(o);
2069 }
2070
2071 OP *
2072 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2073 {
2074     if (!o || o->op_type != OP_LIST)
2075         o = newLISTOP(OP_LIST, 0, o, Nullop);
2076     else
2077         o->op_flags &= ~OPf_WANT;
2078
2079     if (!(PL_opargs[type] & OA_MARK))
2080         op_null(cLISTOPo->op_first);
2081
2082     o->op_type = (OPCODE)type;
2083     o->op_ppaddr = PL_ppaddr[type];
2084     o->op_flags |= flags;
2085
2086     o = CHECKOP(type, o);
2087     if (o->op_type != type)
2088         return o;
2089
2090     return fold_constants(o);
2091 }
2092
2093 /* List constructors */
2094
2095 OP *
2096 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2097 {
2098     if (!first)
2099         return last;
2100
2101     if (!last)
2102         return first;
2103
2104     if (first->op_type != type
2105         || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2106     {
2107         return newLISTOP(type, 0, first, last);
2108     }
2109
2110     if (first->op_flags & OPf_KIDS)
2111         ((LISTOP*)first)->op_last->op_sibling = last;
2112     else {
2113         first->op_flags |= OPf_KIDS;
2114         ((LISTOP*)first)->op_first = last;
2115     }
2116     ((LISTOP*)first)->op_last = last;
2117     return first;
2118 }
2119
2120 OP *
2121 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2122 {
2123     if (!first)
2124         return (OP*)last;
2125
2126     if (!last)
2127         return (OP*)first;
2128
2129     if (first->op_type != type)
2130         return prepend_elem(type, (OP*)first, (OP*)last);
2131
2132     if (last->op_type != type)
2133         return append_elem(type, (OP*)first, (OP*)last);
2134
2135     first->op_last->op_sibling = last->op_first;
2136     first->op_last = last->op_last;
2137     first->op_flags |= (last->op_flags & OPf_KIDS);
2138
2139     FreeOp(last);
2140
2141     return (OP*)first;
2142 }
2143
2144 OP *
2145 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2146 {
2147     if (!first)
2148         return last;
2149
2150     if (!last)
2151         return first;
2152
2153     if (last->op_type == type) {
2154         if (type == OP_LIST) {  /* already a PUSHMARK there */
2155             first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2156             ((LISTOP*)last)->op_first->op_sibling = first;
2157             if (!(first->op_flags & OPf_PARENS))
2158                 last->op_flags &= ~OPf_PARENS;
2159         }
2160         else {
2161             if (!(last->op_flags & OPf_KIDS)) {
2162                 ((LISTOP*)last)->op_last = first;
2163                 last->op_flags |= OPf_KIDS;
2164             }
2165             first->op_sibling = ((LISTOP*)last)->op_first;
2166             ((LISTOP*)last)->op_first = first;
2167         }
2168         last->op_flags |= OPf_KIDS;
2169         return last;
2170     }
2171
2172     return newLISTOP(type, 0, first, last);
2173 }
2174
2175 /* Constructors */
2176
2177 OP *
2178 Perl_newNULLLIST(pTHX)
2179 {
2180     return newOP(OP_STUB, 0);
2181 }
2182
2183 OP *
2184 Perl_force_list(pTHX_ OP *o)
2185 {
2186     if (!o || o->op_type != OP_LIST)
2187         o = newLISTOP(OP_LIST, 0, o, Nullop);
2188     op_null(o);
2189     return o;
2190 }
2191
2192 OP *
2193 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2194 {
2195     LISTOP *listop;
2196
2197     NewOp(1101, listop, 1, LISTOP);
2198
2199     listop->op_type = (OPCODE)type;
2200     listop->op_ppaddr = PL_ppaddr[type];
2201     if (first || last)
2202         flags |= OPf_KIDS;
2203     listop->op_flags = (U8)flags;
2204
2205     if (!last && first)
2206         last = first;
2207     else if (!first && last)
2208         first = last;
2209     else if (first)
2210         first->op_sibling = last;
2211     listop->op_first = first;
2212     listop->op_last = last;
2213     if (type == OP_LIST) {
2214         OP* pushop;
2215         pushop = newOP(OP_PUSHMARK, 0);
2216         pushop->op_sibling = first;
2217         listop->op_first = pushop;
2218         listop->op_flags |= OPf_KIDS;
2219         if (!last)
2220             listop->op_last = pushop;
2221     }
2222
2223     return CHECKOP(type, listop);
2224 }
2225
2226 OP *
2227 Perl_newOP(pTHX_ I32 type, I32 flags)
2228 {
2229     OP *o;
2230     NewOp(1101, o, 1, OP);
2231     o->op_type = (OPCODE)type;
2232     o->op_ppaddr = PL_ppaddr[type];
2233     o->op_flags = (U8)flags;
2234
2235     o->op_next = o;
2236     o->op_private = (U8)(0 | (flags >> 8));
2237     if (PL_opargs[type] & OA_RETSCALAR)
2238         scalar(o);
2239     if (PL_opargs[type] & OA_TARGET)
2240         o->op_targ = pad_alloc(type, SVs_PADTMP);
2241     return CHECKOP(type, o);
2242 }
2243
2244 OP *
2245 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2246 {
2247     UNOP *unop;
2248
2249     if (!first)
2250         first = newOP(OP_STUB, 0);
2251     if (PL_opargs[type] & OA_MARK)
2252         first = force_list(first);
2253
2254     NewOp(1101, unop, 1, UNOP);
2255     unop->op_type = (OPCODE)type;
2256     unop->op_ppaddr = PL_ppaddr[type];
2257     unop->op_first = first;
2258     unop->op_flags = flags | OPf_KIDS;
2259     unop->op_private = (U8)(1 | (flags >> 8));
2260     unop = (UNOP*) CHECKOP(type, unop);
2261     if (unop->op_next)
2262         return (OP*)unop;
2263
2264     return fold_constants((OP *) unop);
2265 }
2266
2267 OP *
2268 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2269 {
2270     BINOP *binop;
2271     NewOp(1101, binop, 1, BINOP);
2272
2273     if (!first)
2274         first = newOP(OP_NULL, 0);
2275
2276     binop->op_type = (OPCODE)type;
2277     binop->op_ppaddr = PL_ppaddr[type];
2278     binop->op_first = first;
2279     binop->op_flags = flags | OPf_KIDS;
2280     if (!last) {
2281         last = first;
2282         binop->op_private = (U8)(1 | (flags >> 8));
2283     }
2284     else {
2285         binop->op_private = (U8)(2 | (flags >> 8));
2286         first->op_sibling = last;
2287     }
2288
2289     binop = (BINOP*)CHECKOP(type, binop);
2290     if (binop->op_next || binop->op_type != (OPCODE)type)
2291         return (OP*)binop;
2292
2293     binop->op_last = binop->op_first->op_sibling;
2294
2295     return fold_constants((OP *)binop);
2296 }
2297
2298 static int
2299 uvcompare(const void *a, const void *b)
2300 {
2301     if (*((UV *)a) < (*(UV *)b))
2302         return -1;
2303     if (*((UV *)a) > (*(UV *)b))
2304         return 1;
2305     if (*((UV *)a+1) < (*(UV *)b+1))
2306         return -1;
2307     if (*((UV *)a+1) > (*(UV *)b+1))
2308         return 1;
2309     return 0;
2310 }
2311
2312 OP *
2313 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2314 {
2315     SV *tstr = ((SVOP*)expr)->op_sv;
2316     SV *rstr = ((SVOP*)repl)->op_sv;
2317     STRLEN tlen;
2318     STRLEN rlen;
2319     U8 *t = (U8*)SvPV(tstr, tlen);
2320     U8 *r = (U8*)SvPV(rstr, rlen);
2321     register I32 i;
2322     register I32 j;
2323     I32 del;
2324     I32 complement;
2325     I32 squash;
2326     I32 grows = 0;
2327     register short *tbl;
2328
2329     PL_hints |= HINT_BLOCK_SCOPE;
2330     complement  = o->op_private & OPpTRANS_COMPLEMENT;
2331     del         = o->op_private & OPpTRANS_DELETE;
2332     squash      = o->op_private & OPpTRANS_SQUASH;
2333
2334     if (SvUTF8(tstr))
2335         o->op_private |= OPpTRANS_FROM_UTF;
2336
2337     if (SvUTF8(rstr))
2338         o->op_private |= OPpTRANS_TO_UTF;
2339
2340     if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2341         SV* listsv = newSVpvn("# comment\n",10);
2342         SV* transv = 0;
2343         U8* tend = t + tlen;
2344         U8* rend = r + rlen;
2345         STRLEN ulen;
2346         UV tfirst = 1;
2347         UV tlast = 0;
2348         IV tdiff;
2349         UV rfirst = 1;
2350         UV rlast = 0;
2351         IV rdiff;
2352         IV diff;
2353         I32 none = 0;
2354         U32 max = 0;
2355         I32 bits;
2356         I32 havefinal = 0;
2357         U32 final = 0;
2358         I32 from_utf    = o->op_private & OPpTRANS_FROM_UTF;
2359         I32 to_utf      = o->op_private & OPpTRANS_TO_UTF;
2360         U8* tsave = NULL;
2361         U8* rsave = NULL;
2362
2363         if (!from_utf) {
2364             STRLEN len = tlen;
2365             tsave = t = bytes_to_utf8(t, &len);
2366             tend = t + len;
2367         }
2368         if (!to_utf && rlen) {
2369             STRLEN len = rlen;
2370             rsave = r = bytes_to_utf8(r, &len);
2371             rend = r + len;
2372         }
2373
2374 /* There are several snags with this code on EBCDIC:
2375    1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2376    2. scan_const() in toke.c has encoded chars in native encoding which makes
2377       ranges at least in EBCDIC 0..255 range the bottom odd.
2378 */
2379
2380         if (complement) {
2381             U8 tmpbuf[UTF8_MAXLEN+1];
2382             UV *cp;
2383             UV nextmin = 0;
2384             New(1109, cp, 2*tlen, UV);
2385             i = 0;
2386             transv = newSVpvn("",0);
2387             while (t < tend) {
2388                 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2389                 t += ulen;
2390                 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2391                     t++;
2392                     cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2393                     t += ulen;
2394                 }
2395                 else {
2396                  cp[2*i+1] = cp[2*i];
2397                 }
2398                 i++;
2399             }
2400             qsort(cp, i, 2*sizeof(UV), uvcompare);
2401             for (j = 0; j < i; j++) {
2402                 UV  val = cp[2*j];
2403                 diff = val - nextmin;
2404                 if (diff > 0) {
2405                     t = uvuni_to_utf8(tmpbuf,nextmin);
2406                     sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2407                     if (diff > 1) {
2408                         U8  range_mark = UTF_TO_NATIVE(0xff);
2409                         t = uvuni_to_utf8(tmpbuf, val - 1);
2410                         sv_catpvn(transv, (char *)&range_mark, 1);
2411                         sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2412                     }
2413                 }
2414                 val = cp[2*j+1];
2415                 if (val >= nextmin)
2416                     nextmin = val + 1;
2417             }
2418             t = uvuni_to_utf8(tmpbuf,nextmin);
2419             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2420             {
2421                 U8 range_mark = UTF_TO_NATIVE(0xff);
2422                 sv_catpvn(transv, (char *)&range_mark, 1);
2423             }
2424             t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
2425                                     UNICODE_ALLOW_SUPER);
2426             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2427             t = (U8*)SvPVX(transv);
2428             tlen = SvCUR(transv);
2429             tend = t + tlen;
2430             Safefree(cp);
2431         }
2432         else if (!rlen && !del) {
2433             r = t; rlen = tlen; rend = tend;
2434         }
2435         if (!squash) {
2436                 if ((!rlen && !del) || t == r ||
2437                     (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2438                 {
2439                     o->op_private |= OPpTRANS_IDENTICAL;
2440                 }
2441         }
2442
2443         while (t < tend || tfirst <= tlast) {
2444             /* see if we need more "t" chars */
2445             if (tfirst > tlast) {
2446                 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2447                 t += ulen;
2448                 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {    /* illegal utf8 val indicates range */
2449                     t++;
2450                     tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2451                     t += ulen;
2452                 }
2453                 else
2454                     tlast = tfirst;
2455             }
2456
2457             /* now see if we need more "r" chars */
2458             if (rfirst > rlast) {
2459                 if (r < rend) {
2460                     rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2461                     r += ulen;
2462                     if (r < rend && NATIVE_TO_UTF(*r) == 0xff) {        /* illegal utf8 val indicates range */
2463                         r++;
2464                         rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2465                         r += ulen;
2466                     }
2467                     else
2468                         rlast = rfirst;
2469                 }
2470                 else {
2471                     if (!havefinal++)
2472                         final = rlast;
2473                     rfirst = rlast = 0xffffffff;
2474                 }
2475             }
2476
2477             /* now see which range will peter our first, if either. */
2478             tdiff = tlast - tfirst;
2479             rdiff = rlast - rfirst;
2480
2481             if (tdiff <= rdiff)
2482                 diff = tdiff;
2483             else
2484                 diff = rdiff;
2485
2486             if (rfirst == 0xffffffff) {
2487                 diff = tdiff;   /* oops, pretend rdiff is infinite */
2488                 if (diff > 0)
2489                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2490                                    (long)tfirst, (long)tlast);
2491                 else
2492                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2493             }
2494             else {
2495                 if (diff > 0)
2496                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2497                                    (long)tfirst, (long)(tfirst + diff),
2498                                    (long)rfirst);
2499                 else
2500                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2501                                    (long)tfirst, (long)rfirst);
2502
2503                 if (rfirst + diff > max)
2504                     max = rfirst + diff;
2505                 if (!grows)
2506                     grows = (tfirst < rfirst &&
2507                              UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2508                 rfirst += diff + 1;
2509             }
2510             tfirst += diff + 1;
2511         }
2512
2513         none = ++max;
2514         if (del)
2515             del = ++max;
2516
2517         if (max > 0xffff)
2518             bits = 32;
2519         else if (max > 0xff)
2520             bits = 16;
2521         else
2522             bits = 8;
2523
2524         Safefree(cPVOPo->op_pv);
2525         cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2526         SvREFCNT_dec(listsv);
2527         if (transv)
2528             SvREFCNT_dec(transv);
2529
2530         if (!del && havefinal && rlen)
2531             (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2532                            newSVuv((UV)final), 0);
2533
2534         if (grows)
2535             o->op_private |= OPpTRANS_GROWS;
2536
2537         if (tsave)
2538             Safefree(tsave);
2539         if (rsave)
2540             Safefree(rsave);
2541
2542         op_free(expr);
2543         op_free(repl);
2544         return o;
2545     }
2546
2547     tbl = (short*)cPVOPo->op_pv;
2548     if (complement) {
2549         Zero(tbl, 256, short);
2550         for (i = 0; i < (I32)tlen; i++)
2551             tbl[t[i]] = -1;
2552         for (i = 0, j = 0; i < 256; i++) {
2553             if (!tbl[i]) {
2554                 if (j >= (I32)rlen) {
2555                     if (del)
2556                         tbl[i] = -2;
2557                     else if (rlen)
2558                         tbl[i] = r[j-1];
2559                     else
2560                         tbl[i] = (short)i;
2561                 }
2562                 else {
2563                     if (i < 128 && r[j] >= 128)
2564                         grows = 1;
2565                     tbl[i] = r[j++];
2566                 }
2567             }
2568         }
2569         if (!del) {
2570             if (!rlen) {
2571                 j = rlen;
2572                 if (!squash)
2573                     o->op_private |= OPpTRANS_IDENTICAL;
2574             }
2575             else if (j >= (I32)rlen)
2576                 j = rlen - 1;
2577             else
2578                 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
2579             tbl[0x100] = rlen - j;
2580             for (i=0; i < (I32)rlen - j; i++)
2581                 tbl[0x101+i] = r[j+i];
2582         }
2583     }
2584     else {
2585         if (!rlen && !del) {
2586             r = t; rlen = tlen;
2587             if (!squash)
2588                 o->op_private |= OPpTRANS_IDENTICAL;
2589         }
2590         else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
2591             o->op_private |= OPpTRANS_IDENTICAL;
2592         }
2593         for (i = 0; i < 256; i++)
2594             tbl[i] = -1;
2595         for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
2596             if (j >= (I32)rlen) {
2597                 if (del) {
2598                     if (tbl[t[i]] == -1)
2599                         tbl[t[i]] = -2;
2600                     continue;
2601                 }
2602                 --j;
2603             }
2604             if (tbl[t[i]] == -1) {
2605                 if (t[i] < 128 && r[j] >= 128)
2606                     grows = 1;
2607                 tbl[t[i]] = r[j];
2608             }
2609         }
2610     }
2611     if (grows)
2612         o->op_private |= OPpTRANS_GROWS;
2613     op_free(expr);
2614     op_free(repl);
2615
2616     return o;
2617 }
2618
2619 OP *
2620 Perl_newPMOP(pTHX_ I32 type, I32 flags)
2621 {
2622     PMOP *pmop;
2623
2624     NewOp(1101, pmop, 1, PMOP);
2625     pmop->op_type = (OPCODE)type;
2626     pmop->op_ppaddr = PL_ppaddr[type];
2627     pmop->op_flags = (U8)flags;
2628     pmop->op_private = (U8)(0 | (flags >> 8));
2629
2630     if (PL_hints & HINT_RE_TAINT)
2631         pmop->op_pmpermflags |= PMf_RETAINT;
2632     if (PL_hints & HINT_LOCALE)
2633         pmop->op_pmpermflags |= PMf_LOCALE;
2634     pmop->op_pmflags = pmop->op_pmpermflags;
2635
2636 #ifdef USE_ITHREADS
2637     {
2638         SV* repointer;
2639         if(av_len((AV*) PL_regex_pad[0]) > -1) {
2640             repointer = av_pop((AV*)PL_regex_pad[0]);
2641             pmop->op_pmoffset = SvIV(repointer);
2642             SvREPADTMP_off(repointer);
2643             sv_setiv(repointer,0);
2644         } else {
2645             repointer = newSViv(0);
2646             av_push(PL_regex_padav,SvREFCNT_inc(repointer));
2647             pmop->op_pmoffset = av_len(PL_regex_padav);
2648             PL_regex_pad = AvARRAY(PL_regex_padav);
2649         }
2650     }
2651 #endif
2652
2653         /* link into pm list */
2654     if (type != OP_TRANS && PL_curstash) {
2655         pmop->op_pmnext = HvPMROOT(PL_curstash);
2656         HvPMROOT(PL_curstash) = pmop;
2657         PmopSTASH_set(pmop,PL_curstash);
2658     }
2659
2660     return CHECKOP(type, pmop);
2661 }
2662
2663 /* Given some sort of match op o, and an expression expr containing a
2664  * pattern, either compile expr into a regex and attach it to o (if it's
2665  * constant), or convert expr into a runtime regcomp op sequence (if it's
2666  * not)
2667  *
2668  * isreg indicates that the pattern is part of a regex construct, eg
2669  * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
2670  * split "pattern", which aren't. In the former case, expr will be a list
2671  * if the pattern contains more than one term (eg /a$b/) or if it contains
2672  * a replacement, ie s/// or tr///.
2673  */
2674
2675 OP *
2676 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
2677 {
2678     PMOP *pm;
2679     LOGOP *rcop;
2680     I32 repl_has_vars = 0;
2681     OP* repl  = Nullop;
2682     bool reglist;
2683
2684     if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
2685         /* last element in list is the replacement; pop it */
2686         OP* kid;
2687         repl = cLISTOPx(expr)->op_last;
2688         kid = cLISTOPx(expr)->op_first;
2689         while (kid->op_sibling != repl)
2690             kid = kid->op_sibling;
2691         kid->op_sibling = Nullop;
2692         cLISTOPx(expr)->op_last = kid;
2693     }
2694
2695     if (isreg && expr->op_type == OP_LIST &&
2696         cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
2697     {
2698         /* convert single element list to element */
2699         OP* oe = expr;
2700         expr = cLISTOPx(oe)->op_first->op_sibling;
2701         cLISTOPx(oe)->op_first->op_sibling = Nullop;
2702         cLISTOPx(oe)->op_last = Nullop;
2703         op_free(oe);
2704     }
2705
2706     if (o->op_type == OP_TRANS) {
2707         return pmtrans(o, expr, repl);
2708     }
2709
2710     reglist = isreg && expr->op_type == OP_LIST;
2711     if (reglist)
2712         op_null(expr);
2713
2714     PL_hints |= HINT_BLOCK_SCOPE;
2715     pm = (PMOP*)o;
2716
2717     if (expr->op_type == OP_CONST) {
2718         STRLEN plen;
2719         SV *pat = ((SVOP*)expr)->op_sv;
2720         char *p = SvPV(pat, plen);
2721         if ((o->op_flags & OPf_SPECIAL) && strEQ(p, " ")) {
2722             sv_setpvn(pat, "\\s+", 3);
2723             p = SvPV(pat, plen);
2724             pm->op_pmflags |= PMf_SKIPWHITE;
2725         }
2726         if (DO_UTF8(pat))
2727             pm->op_pmdynflags |= PMdf_UTF8;
2728         PM_SETRE(pm, CALLREGCOMP(aTHX_ p, p + plen, pm));
2729         if (strEQ("\\s+", PM_GETRE(pm)->precomp))
2730             pm->op_pmflags |= PMf_WHITE;
2731         op_free(expr);
2732     }
2733     else {
2734         if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
2735             expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
2736                             ? OP_REGCRESET
2737                             : OP_REGCMAYBE),0,expr);
2738
2739         NewOp(1101, rcop, 1, LOGOP);
2740         rcop->op_type = OP_REGCOMP;
2741         rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
2742         rcop->op_first = scalar(expr);
2743         rcop->op_flags |= OPf_KIDS
2744                             | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
2745                             | (reglist ? OPf_STACKED : 0);
2746         rcop->op_private = 1;
2747         rcop->op_other = o;
2748         if (reglist)
2749             rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
2750
2751         /* /$x/ may cause an eval, since $x might be qr/(?{..})/  */
2752         PL_cv_has_eval = 1;
2753
2754         /* establish postfix order */
2755         if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
2756             LINKLIST(expr);
2757             rcop->op_next = expr;
2758             ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
2759         }
2760         else {
2761             rcop->op_next = LINKLIST(expr);
2762             expr->op_next = (OP*)rcop;
2763         }
2764
2765         prepend_elem(o->op_type, scalar((OP*)rcop), o);
2766     }
2767
2768     if (repl) {
2769         OP *curop;
2770         if (pm->op_pmflags & PMf_EVAL) {
2771             curop = 0;
2772             if (CopLINE(PL_curcop) < (line_t)PL_multi_end)
2773                 CopLINE_set(PL_curcop, (line_t)PL_multi_end);
2774         }
2775         else if (repl->op_type == OP_CONST)
2776             curop = repl;
2777         else {
2778             OP *lastop = 0;
2779             for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
2780                 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
2781                     if (curop->op_type == OP_GV) {
2782                         GV *gv = cGVOPx_gv(curop);
2783                         repl_has_vars = 1;
2784                         if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
2785                             break;
2786                     }
2787                     else if (curop->op_type == OP_RV2CV)
2788                         break;
2789                     else if (curop->op_type == OP_RV2SV ||
2790                              curop->op_type == OP_RV2AV ||
2791                              curop->op_type == OP_RV2HV ||
2792                              curop->op_type == OP_RV2GV) {
2793                         if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
2794                             break;
2795                     }
2796                     else if (curop->op_type == OP_PADSV ||
2797                              curop->op_type == OP_PADAV ||
2798                              curop->op_type == OP_PADHV ||
2799                              curop->op_type == OP_PADANY) {
2800                         repl_has_vars = 1;
2801                     }
2802                     else if (curop->op_type == OP_PUSHRE)
2803                         ; /* Okay here, dangerous in newASSIGNOP */
2804                     else
2805                         break;
2806                 }
2807                 lastop = curop;
2808             }
2809         }
2810         if (curop == repl
2811             && !(repl_has_vars
2812                  && (!PM_GETRE(pm)
2813                      || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
2814             pm->op_pmflags |= PMf_CONST;        /* const for long enough */
2815             pm->op_pmpermflags |= PMf_CONST;    /* const for long enough */
2816             prepend_elem(o->op_type, scalar(repl), o);
2817         }
2818         else {
2819             if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
2820                 pm->op_pmflags |= PMf_MAYBE_CONST;
2821                 pm->op_pmpermflags |= PMf_MAYBE_CONST;
2822             }
2823             NewOp(1101, rcop, 1, LOGOP);
2824             rcop->op_type = OP_SUBSTCONT;
2825             rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
2826             rcop->op_first = scalar(repl);
2827             rcop->op_flags |= OPf_KIDS;
2828             rcop->op_private = 1;
2829             rcop->op_other = o;
2830
2831             /* establish postfix order */
2832             rcop->op_next = LINKLIST(repl);
2833             repl->op_next = (OP*)rcop;
2834
2835             pm->op_pmreplroot = scalar((OP*)rcop);
2836             pm->op_pmreplstart = LINKLIST(rcop);
2837             rcop->op_next = 0;
2838         }
2839     }
2840
2841     return (OP*)pm;
2842 }
2843
2844 OP *
2845 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
2846 {
2847     SVOP *svop;
2848     NewOp(1101, svop, 1, SVOP);
2849     svop->op_type = (OPCODE)type;
2850     svop->op_ppaddr = PL_ppaddr[type];
2851     svop->op_sv = sv;
2852     svop->op_next = (OP*)svop;
2853     svop->op_flags = (U8)flags;
2854     if (PL_opargs[type] & OA_RETSCALAR)
2855         scalar((OP*)svop);
2856     if (PL_opargs[type] & OA_TARGET)
2857         svop->op_targ = pad_alloc(type, SVs_PADTMP);
2858     return CHECKOP(type, svop);
2859 }
2860
2861 OP *
2862 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
2863 {
2864     PADOP *padop;
2865     NewOp(1101, padop, 1, PADOP);
2866     padop->op_type = (OPCODE)type;
2867     padop->op_ppaddr = PL_ppaddr[type];
2868     padop->op_padix = pad_alloc(type, SVs_PADTMP);
2869     SvREFCNT_dec(PAD_SVl(padop->op_padix));
2870     PAD_SETSV(padop->op_padix, sv);
2871     if (sv)
2872         SvPADTMP_on(sv);
2873     padop->op_next = (OP*)padop;
2874     padop->op_flags = (U8)flags;
2875     if (PL_opargs[type] & OA_RETSCALAR)
2876         scalar((OP*)padop);
2877     if (PL_opargs[type] & OA_TARGET)
2878         padop->op_targ = pad_alloc(type, SVs_PADTMP);
2879     return CHECKOP(type, padop);
2880 }
2881
2882 OP *
2883 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
2884 {
2885 #ifdef USE_ITHREADS
2886     if (gv)
2887         GvIN_PAD_on(gv);
2888     return newPADOP(type, flags, SvREFCNT_inc(gv));
2889 #else
2890     return newSVOP(type, flags, SvREFCNT_inc(gv));
2891 #endif
2892 }
2893
2894 OP *
2895 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
2896 {
2897     PVOP *pvop;
2898     NewOp(1101, pvop, 1, PVOP);
2899     pvop->op_type = (OPCODE)type;
2900     pvop->op_ppaddr = PL_ppaddr[type];
2901     pvop->op_pv = pv;
2902     pvop->op_next = (OP*)pvop;
2903     pvop->op_flags = (U8)flags;
2904     if (PL_opargs[type] & OA_RETSCALAR)
2905         scalar((OP*)pvop);
2906     if (PL_opargs[type] & OA_TARGET)
2907         pvop->op_targ = pad_alloc(type, SVs_PADTMP);
2908     return CHECKOP(type, pvop);
2909 }
2910
2911 void
2912 Perl_package(pTHX_ OP *o)
2913 {
2914     char *name;
2915     STRLEN len;
2916
2917     save_hptr(&PL_curstash);
2918     save_item(PL_curstname);
2919
2920     name = SvPV(cSVOPo->op_sv, len);
2921     PL_curstash = gv_stashpvn(name, len, TRUE);
2922     sv_setpvn(PL_curstname, name, len);
2923     op_free(o);
2924
2925     PL_hints |= HINT_BLOCK_SCOPE;
2926     PL_copline = NOLINE;
2927     PL_expect = XSTATE;
2928 }
2929
2930 void
2931 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
2932 {
2933     OP *pack;
2934     OP *imop;
2935     OP *veop;
2936
2937     if (idop->op_type != OP_CONST)
2938         Perl_croak(aTHX_ "Module name must be constant");
2939
2940     veop = Nullop;
2941
2942     if (version != Nullop) {
2943         SV *vesv = ((SVOP*)version)->op_sv;
2944
2945         if (arg == Nullop && !SvNIOKp(vesv)) {
2946             arg = version;
2947         }
2948         else {
2949             OP *pack;
2950             SV *meth;
2951
2952             if (version->op_type != OP_CONST || !SvNIOKp(vesv))
2953                 Perl_croak(aTHX_ "Version number must be constant number");
2954
2955             /* Make copy of idop so we don't free it twice */
2956             pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
2957
2958             /* Fake up a method call to VERSION */
2959             meth = newSVpvn("VERSION",7);
2960             sv_upgrade(meth, SVt_PVIV);
2961             (void)SvIOK_on(meth);
2962             PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
2963             veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
2964                             append_elem(OP_LIST,
2965                                         prepend_elem(OP_LIST, pack, list(version)),
2966                                         newSVOP(OP_METHOD_NAMED, 0, meth)));
2967         }
2968     }
2969
2970     /* Fake up an import/unimport */
2971     if (arg && arg->op_type == OP_STUB)
2972         imop = arg;             /* no import on explicit () */
2973     else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
2974         imop = Nullop;          /* use 5.0; */
2975     }
2976     else {
2977         SV *meth;
2978
2979         /* Make copy of idop so we don't free it twice */
2980         pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
2981
2982         /* Fake up a method call to import/unimport */
2983         meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);
2984         (void)SvUPGRADE(meth, SVt_PVIV);
2985         (void)SvIOK_on(meth);
2986         PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
2987         imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
2988                        append_elem(OP_LIST,
2989                                    prepend_elem(OP_LIST, pack, list(arg)),
2990                                    newSVOP(OP_METHOD_NAMED, 0, meth)));
2991     }
2992
2993     /* Fake up the BEGIN {}, which does its thing immediately. */
2994     newATTRSUB(floor,
2995         newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
2996         Nullop,
2997         Nullop,
2998         append_elem(OP_LINESEQ,
2999             append_elem(OP_LINESEQ,
3000                 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, idop)),
3001                 newSTATEOP(0, Nullch, veop)),
3002             newSTATEOP(0, Nullch, imop) ));
3003
3004     /* The "did you use incorrect case?" warning used to be here.
3005      * The problem is that on case-insensitive filesystems one
3006      * might get false positives for "use" (and "require"):
3007      * "use Strict" or "require CARP" will work.  This causes
3008      * portability problems for the script: in case-strict
3009      * filesystems the script will stop working.
3010      *
3011      * The "incorrect case" warning checked whether "use Foo"
3012      * imported "Foo" to your namespace, but that is wrong, too:
3013      * there is no requirement nor promise in the language that
3014      * a Foo.pm should or would contain anything in package "Foo".
3015      *
3016      * There is very little Configure-wise that can be done, either:
3017      * the case-sensitivity of the build filesystem of Perl does not
3018      * help in guessing the case-sensitivity of the runtime environment.
3019      */
3020
3021     PL_hints |= HINT_BLOCK_SCOPE;
3022     PL_copline = NOLINE;
3023     PL_expect = XSTATE;
3024     PL_cop_seqmax++; /* Purely for B::*'s benefit */
3025 }
3026
3027 /*
3028 =head1 Embedding Functions
3029
3030 =for apidoc load_module
3031
3032 Loads the module whose name is pointed to by the string part of name.
3033 Note that the actual module name, not its filename, should be given.
3034 Eg, "Foo::Bar" instead of "Foo/Bar.pm".  flags can be any of
3035 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3036 (or 0 for no flags). ver, if specified, provides version semantics
3037 similar to C<use Foo::Bar VERSION>.  The optional trailing SV*
3038 arguments can be used to specify arguments to the module's import()
3039 method, similar to C<use Foo::Bar VERSION LIST>.
3040
3041 =cut */
3042
3043 void
3044 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3045 {
3046     va_list args;
3047     va_start(args, ver);
3048     vload_module(flags, name, ver, &args);
3049     va_end(args);
3050 }
3051
3052 #ifdef PERL_IMPLICIT_CONTEXT
3053 void
3054 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3055 {
3056     dTHX;
3057     va_list args;
3058     va_start(args, ver);
3059     vload_module(flags, name, ver, &args);
3060     va_end(args);
3061 }
3062 #endif
3063
3064 void
3065 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3066 {
3067     OP *modname, *veop, *imop;
3068
3069     modname = newSVOP(OP_CONST, 0, name);
3070     modname->op_private |= OPpCONST_BARE;
3071     if (ver) {
3072         veop = newSVOP(OP_CONST, 0, ver);
3073     }
3074     else
3075         veop = Nullop;
3076     if (flags & PERL_LOADMOD_NOIMPORT) {
3077         imop = sawparens(newNULLLIST());
3078     }
3079     else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3080         imop = va_arg(*args, OP*);
3081     }
3082     else {
3083         SV *sv;
3084         imop = Nullop;
3085         sv = va_arg(*args, SV*);
3086         while (sv) {
3087             imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3088             sv = va_arg(*args, SV*);
3089         }
3090     }
3091     {
3092         line_t ocopline = PL_copline;
3093         COP *ocurcop = PL_curcop;
3094         int oexpect = PL_expect;
3095
3096         utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3097                 veop, modname, imop);
3098         PL_expect = oexpect;
3099         PL_copline = ocopline;
3100         PL_curcop = ocurcop;
3101     }
3102 }
3103
3104 OP *
3105 Perl_dofile(pTHX_ OP *term)
3106 {
3107     OP *doop;
3108     GV *gv;
3109
3110     gv = gv_fetchpv("do", FALSE, SVt_PVCV);
3111     if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
3112         gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3113
3114     if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3115         doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3116                                append_elem(OP_LIST, term,
3117                                            scalar(newUNOP(OP_RV2CV, 0,
3118                                                           newGVOP(OP_GV, 0,
3119                                                                   gv))))));
3120     }
3121     else {
3122         doop = newUNOP(OP_DOFILE, 0, scalar(term));
3123     }
3124     return doop;
3125 }
3126
3127 OP *
3128 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3129 {
3130     return newBINOP(OP_LSLICE, flags,
3131             list(force_list(subscript)),
3132             list(force_list(listval)) );
3133 }
3134
3135 STATIC I32
3136 S_list_assignment(pTHX_ register OP *o)
3137 {
3138     if (!o)
3139         return TRUE;
3140
3141     if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3142         o = cUNOPo->op_first;
3143
3144     if (o->op_type == OP_COND_EXPR) {
3145         I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3146         I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3147
3148         if (t && f)
3149             return TRUE;
3150         if (t || f)
3151             yyerror("Assignment to both a list and a scalar");
3152         return FALSE;
3153     }
3154
3155     if (o->op_type == OP_LIST &&
3156         (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR &&
3157         o->op_private & OPpLVAL_INTRO)
3158         return FALSE;
3159
3160     if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3161         o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3162         o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3163         return TRUE;
3164
3165     if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3166         return TRUE;
3167
3168     if (o->op_type == OP_RV2SV)
3169         return FALSE;
3170
3171     return FALSE;
3172 }
3173
3174 OP *
3175 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3176 {
3177     OP *o;
3178
3179     if (optype) {
3180         if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
3181             return newLOGOP(optype, 0,
3182                 mod(scalar(left), optype),
3183                 newUNOP(OP_SASSIGN, 0, scalar(right)));
3184         }
3185         else {
3186             return newBINOP(optype, OPf_STACKED,
3187                 mod(scalar(left), optype), scalar(right));
3188         }
3189     }
3190
3191     if (list_assignment(left)) {
3192         OP *curop;
3193
3194         PL_modcount = 0;
3195         PL_eval_start = right;  /* Grandfathering $[ assignment here.  Bletch.*/
3196         left = mod(left, OP_AASSIGN);
3197         if (PL_eval_start)
3198             PL_eval_start = 0;
3199         else {
3200             op_free(left);
3201             op_free(right);
3202             return Nullop;
3203         }
3204         /* optimise C<my @x = ()> to C<my @x>, and likewise for hashes */
3205         if ((left->op_type == OP_PADAV || left->op_type == OP_PADHV)
3206                 && right->op_type == OP_STUB
3207                 && (left->op_private & OPpLVAL_INTRO))
3208         {
3209             op_free(right);
3210             left->op_flags &= ~(OPf_REF|OPf_SPECIAL);
3211             return left;
3212         }
3213         curop = list(force_list(left));
3214         o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3215         o->op_private = (U8)(0 | (flags >> 8));
3216
3217         /* PL_generation sorcery:
3218          * an assignment like ($a,$b) = ($c,$d) is easier than
3219          * ($a,$b) = ($c,$a), since there is no need for temporary vars.
3220          * To detect whether there are common vars, the global var
3221          * PL_generation is incremented for each assign op we compile.
3222          * Then, while compiling the assign op, we run through all the
3223          * variables on both sides of the assignment, setting a spare slot
3224          * in each of them to PL_generation. If any of them already have
3225          * that value, we know we've got commonality.  We could use a
3226          * single bit marker, but then we'd have to make 2 passes, first
3227          * to clear the flag, then to test and set it.  To find somewhere
3228          * to store these values, evil chicanery is done with SvCUR().
3229          */
3230
3231         if (!(left->op_private & OPpLVAL_INTRO)) {
3232             OP *lastop = o;
3233             PL_generation++;
3234             for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3235                 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3236                     if (curop->op_type == OP_GV) {
3237                         GV *gv = cGVOPx_gv(curop);
3238                         if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3239                             break;
3240                         SvCUR(gv) = PL_generation;
3241                     }
3242                     else if (curop->op_type == OP_PADSV ||
3243                              curop->op_type == OP_PADAV ||
3244                              curop->op_type == OP_PADHV ||
3245                              curop->op_type == OP_PADANY)
3246                     {
3247                         if (PAD_COMPNAME_GEN(curop->op_targ)
3248                                                     == (STRLEN)PL_generation)
3249                             break;
3250                         PAD_COMPNAME_GEN(curop->op_targ)
3251                                                         = PL_generation;
3252
3253                     }
3254                     else if (curop->op_type == OP_RV2CV)
3255                         break;
3256                     else if (curop->op_type == OP_RV2SV ||
3257                              curop->op_type == OP_RV2AV ||
3258                              curop->op_type == OP_RV2HV ||
3259                              curop->op_type == OP_RV2GV) {
3260                         if (lastop->op_type != OP_GV)   /* funny deref? */
3261                             break;
3262                     }
3263                     else if (curop->op_type == OP_PUSHRE) {
3264                         if (((PMOP*)curop)->op_pmreplroot) {
3265 #ifdef USE_ITHREADS
3266                             GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET,
3267                                         ((PMOP*)curop)->op_pmreplroot));
3268 #else
3269                             GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3270 #endif
3271                             if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3272                                 break;
3273                             SvCUR(gv) = PL_generation;
3274                         }
3275                     }
3276                     else
3277                         break;
3278                 }
3279                 lastop = curop;
3280             }
3281             if (curop != o)
3282                 o->op_private |= OPpASSIGN_COMMON;
3283         }
3284         if (right && right->op_type == OP_SPLIT) {
3285             OP* tmpop;
3286             if ((tmpop = ((LISTOP*)right)->op_first) &&
3287                 tmpop->op_type == OP_PUSHRE)
3288             {
3289                 PMOP *pm = (PMOP*)tmpop;
3290                 if (left->op_type == OP_RV2AV &&
3291                     !(left->op_private & OPpLVAL_INTRO) &&
3292                     !(o->op_private & OPpASSIGN_COMMON) )
3293                 {
3294                     tmpop = ((UNOP*)left)->op_first;
3295                     if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3296 #ifdef USE_ITHREADS
3297                         pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
3298                         cPADOPx(tmpop)->op_padix = 0;   /* steal it */
3299 #else
3300                         pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3301                         cSVOPx(tmpop)->op_sv = Nullsv;  /* steal it */
3302 #endif
3303                         pm->op_pmflags |= PMf_ONCE;
3304                         tmpop = cUNOPo->op_first;       /* to list (nulled) */
3305                         tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3306                         tmpop->op_sibling = Nullop;     /* don't free split */
3307                         right->op_next = tmpop->op_next;  /* fix starting loc */
3308                         op_free(o);                     /* blow off assign */
3309                         right->op_flags &= ~OPf_WANT;
3310                                 /* "I don't know and I don't care." */
3311                         return right;
3312                     }
3313                 }
3314                 else {
3315                    if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3316                       ((LISTOP*)right)->op_last->op_type == OP_CONST)
3317                     {
3318                         SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3319                         if (SvIVX(sv) == 0)
3320                             sv_setiv(sv, PL_modcount+1);
3321                     }
3322                 }
3323             }
3324         }
3325         return o;
3326     }
3327     if (!right)
3328         right = newOP(OP_UNDEF, 0);
3329     if (right->op_type == OP_READLINE) {
3330         right->op_flags |= OPf_STACKED;
3331         return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3332     }
3333     else {
3334         PL_eval_start = right;  /* Grandfathering $[ assignment here.  Bletch.*/
3335         o = newBINOP(OP_SASSIGN, flags,
3336             scalar(right), mod(scalar(left), OP_SASSIGN) );
3337         if (PL_eval_start)
3338             PL_eval_start = 0;
3339         else {
3340             op_free(o);
3341             return Nullop;
3342         }
3343     }
3344     return o;
3345 }
3346
3347 OP *
3348 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3349 {
3350     U32 seq = intro_my();
3351     register COP *cop;
3352
3353     NewOp(1101, cop, 1, COP);
3354     if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3355         cop->op_type = OP_DBSTATE;
3356         cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3357     }
3358     else {
3359         cop->op_type = OP_NEXTSTATE;
3360         cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3361     }
3362     cop->op_flags = (U8)flags;
3363     cop->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
3364 #ifdef NATIVE_HINTS
3365     cop->op_private |= NATIVE_HINTS;
3366 #endif
3367     PL_compiling.op_private = cop->op_private;
3368     cop->op_next = (OP*)cop;
3369
3370     if (label) {
3371         cop->cop_label = label;
3372         PL_hints |= HINT_BLOCK_SCOPE;
3373     }
3374     cop->cop_seq = seq;
3375     cop->cop_arybase = PL_curcop->cop_arybase;
3376     if (specialWARN(PL_curcop->cop_warnings))
3377         cop->cop_warnings = PL_curcop->cop_warnings ;
3378     else
3379         cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3380     if (specialCopIO(PL_curcop->cop_io))
3381         cop->cop_io = PL_curcop->cop_io;
3382     else
3383         cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3384
3385
3386     if (PL_copline == NOLINE)
3387         CopLINE_set(cop, CopLINE(PL_curcop));
3388     else {
3389         CopLINE_set(cop, PL_copline);
3390         PL_copline = NOLINE;
3391     }
3392 #ifdef USE_ITHREADS
3393     CopFILE_set(cop, CopFILE(PL_curcop));       /* XXX share in a pvtable? */
3394 #else
3395     CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3396 #endif
3397     CopSTASH_set(cop, PL_curstash);
3398
3399     if (PERLDB_LINE && PL_curstash != PL_debstash) {
3400         SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3401         if (svp && *svp != &PL_sv_undef ) {
3402            (void)SvIOK_on(*svp);
3403             SvIVX(*svp) = PTR2IV(cop);
3404         }
3405     }
3406
3407     return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3408 }
3409
3410
3411 OP *
3412 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3413 {
3414     return new_logop(type, flags, &first, &other);
3415 }
3416
3417 STATIC OP *
3418 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3419 {
3420     LOGOP *logop;
3421     OP *o;
3422     OP *first = *firstp;
3423     OP *other = *otherp;
3424
3425     if (type == OP_XOR)         /* Not short circuit, but here by precedence. */
3426         return newBINOP(type, flags, scalar(first), scalar(other));
3427
3428     scalarboolean(first);
3429     /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3430     if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3431         if (type == OP_AND || type == OP_OR) {
3432             if (type == OP_AND)
3433                 type = OP_OR;
3434             else
3435                 type = OP_AND;
3436             o = first;
3437             first = *firstp = cUNOPo->op_first;
3438             if (o->op_next)
3439                 first->op_next = o->op_next;
3440             cUNOPo->op_first = Nullop;
3441             op_free(o);
3442         }
3443     }
3444     if (first->op_type == OP_CONST) {
3445         if (first->op_private & OPpCONST_STRICT)
3446             no_bareword_allowed(first);
3447         else if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
3448                 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
3449         if ((type == OP_AND &&  SvTRUE(((SVOP*)first)->op_sv)) ||
3450             (type == OP_OR  && !SvTRUE(((SVOP*)first)->op_sv)) ||
3451             (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) {
3452             op_free(first);
3453             *firstp = Nullop;
3454             if (other->op_type == OP_CONST)
3455                 other->op_private |= OPpCONST_SHORTCIRCUIT;
3456             return other;
3457         }
3458         else {
3459             /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
3460             OP *o2 = other;
3461             if ( ! (o2->op_type == OP_LIST
3462                     && (( o2 = cUNOPx(o2)->op_first))
3463                     && o2->op_type == OP_PUSHMARK
3464                     && (( o2 = o2->op_sibling)) )
3465             )
3466                 o2 = other;
3467             if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
3468                         || o2->op_type == OP_PADHV)
3469                 && o2->op_private & OPpLVAL_INTRO
3470                 && ckWARN(WARN_DEPRECATED))
3471             {
3472                 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
3473                             "Deprecated use of my() in false conditional");
3474             }
3475
3476             op_free(other);
3477             *otherp = Nullop;
3478             if (first->op_type == OP_CONST)
3479                 first->op_private |= OPpCONST_SHORTCIRCUIT;
3480             return first;
3481         }
3482     }
3483     else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS) &&
3484              type != OP_DOR) /* [#24076] Don't warn for <FH> err FOO. */
3485     {
3486         OP *k1 = ((UNOP*)first)->op_first;
3487         OP *k2 = k1->op_sibling;
3488         OPCODE warnop = 0;
3489         switch (first->op_type)
3490         {
3491         case OP_NULL:
3492             if (k2 && k2->op_type == OP_READLINE
3493                   && (k2->op_flags & OPf_STACKED)
3494                   && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3495             {
3496                 warnop = k2->op_type;
3497             }
3498             break;
3499
3500         case OP_SASSIGN:
3501             if (k1->op_type == OP_READDIR
3502                   || k1->op_type == OP_GLOB
3503                   || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3504                   || k1->op_type == OP_EACH)
3505             {
3506                 warnop = ((k1->op_type == OP_NULL)
3507                           ? (OPCODE)k1->op_targ : k1->op_type);
3508             }
3509             break;
3510         }
3511         if (warnop) {
3512             line_t oldline = CopLINE(PL_curcop);
3513             CopLINE_set(PL_curcop, PL_copline);
3514             Perl_warner(aTHX_ packWARN(WARN_MISC),
3515                  "Value of %s%s can be \"0\"; test with defined()",
3516                  PL_op_desc[warnop],
3517                  ((warnop == OP_READLINE || warnop == OP_GLOB)
3518                   ? " construct" : "() operator"));
3519             CopLINE_set(PL_curcop, oldline);
3520         }
3521     }
3522
3523     if (!other)
3524         return first;
3525
3526     if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
3527         other->op_private |= OPpASSIGN_BACKWARDS;  /* other is an OP_SASSIGN */
3528
3529     NewOp(1101, logop, 1, LOGOP);
3530
3531     logop->op_type = (OPCODE)type;
3532     logop->op_ppaddr = PL_ppaddr[type];
3533     logop->op_first = first;
3534     logop->op_flags = flags | OPf_KIDS;
3535     logop->op_other = LINKLIST(other);
3536     logop->op_private = (U8)(1 | (flags >> 8));
3537
3538     /* establish postfix order */
3539     logop->op_next = LINKLIST(first);
3540     first->op_next = (OP*)logop;
3541     first->op_sibling = other;
3542
3543     CHECKOP(type,logop);
3544
3545     o = newUNOP(OP_NULL, 0, (OP*)logop);
3546     other->op_next = o;
3547
3548     return o;
3549 }
3550
3551 OP *
3552 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3553 {
3554     LOGOP *logop;
3555     OP *start;
3556     OP *o;
3557
3558     if (!falseop)
3559         return newLOGOP(OP_AND, 0, first, trueop);
3560     if (!trueop)
3561         return newLOGOP(OP_OR, 0, first, falseop);
3562
3563     scalarboolean(first);
3564     if (first->op_type == OP_CONST) {
3565         if (first->op_private & OPpCONST_BARE &&
3566            first->op_private & OPpCONST_STRICT) {
3567            no_bareword_allowed(first);
3568        }
3569         if (SvTRUE(((SVOP*)first)->op_sv)) {
3570             op_free(first);
3571             op_free(falseop);
3572             return trueop;
3573         }
3574         else {
3575             op_free(first);
3576             op_free(trueop);
3577             return falseop;
3578         }
3579     }
3580     NewOp(1101, logop, 1, LOGOP);
3581     logop->op_type = OP_COND_EXPR;
3582     logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3583     logop->op_first = first;
3584     logop->op_flags = flags | OPf_KIDS;
3585     logop->op_private = (U8)(1 | (flags >> 8));
3586     logop->op_other = LINKLIST(trueop);
3587     logop->op_next = LINKLIST(falseop);
3588
3589     CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
3590             logop);
3591
3592     /* establish postfix order */
3593     start = LINKLIST(first);
3594     first->op_next = (OP*)logop;
3595
3596     first->op_sibling = trueop;
3597     trueop->op_sibling = falseop;
3598     o = newUNOP(OP_NULL, 0, (OP*)logop);
3599
3600     trueop->op_next = falseop->op_next = o;
3601
3602     o->op_next = start;
3603     return o;
3604 }
3605
3606 OP *
3607 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3608 {
3609     LOGOP *range;
3610     OP *flip;
3611     OP *flop;
3612     OP *leftstart;
3613     OP *o;
3614
3615     NewOp(1101, range, 1, LOGOP);
3616
3617     range->op_type = OP_RANGE;
3618     range->op_ppaddr = PL_ppaddr[OP_RANGE];
3619     range->op_first = left;
3620     range->op_flags = OPf_KIDS;
3621     leftstart = LINKLIST(left);
3622     range->op_other = LINKLIST(right);
3623     range->op_private = (U8)(1 | (flags >> 8));
3624
3625     left->op_sibling = right;
3626
3627     range->op_next = (OP*)range;
3628     flip = newUNOP(OP_FLIP, flags, (OP*)range);
3629     flop = newUNOP(OP_FLOP, 0, flip);
3630     o = newUNOP(OP_NULL, 0, flop);
3631     linklist(flop);
3632     range->op_next = leftstart;
3633
3634     left->op_next = flip;
3635     right->op_next = flop;
3636
3637     range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3638     sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3639     flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3640     sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3641
3642     flip->op_private =  left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3643     flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3644
3645     flip->op_next = o;
3646     if (!flip->op_private || !flop->op_private)
3647         linklist(o);            /* blow off optimizer unless constant */
3648
3649     return o;
3650 }
3651
3652 OP *
3653 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3654 {
3655     OP* listop;
3656     OP* o;
3657     int once = block && block->op_flags & OPf_SPECIAL &&
3658       (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3659
3660     if (expr) {
3661         if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3662             return block;       /* do {} while 0 does once */
3663         if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3664             || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3665             expr = newUNOP(OP_DEFINED, 0,
3666                 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3667         } else if (expr->op_flags & OPf_KIDS) {
3668             OP *k1 = ((UNOP*)expr)->op_first;
3669             OP *k2 = (k1) ? k1->op_sibling : NULL;
3670             switch (expr->op_type) {
3671               case OP_NULL:
3672                 if (k2 && k2->op_type == OP_READLINE
3673                       && (k2->op_flags & OPf_STACKED)
3674                       && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3675                     expr = newUNOP(OP_DEFINED, 0, expr);
3676                 break;
3677
3678               case OP_SASSIGN:
3679                 if (k1->op_type == OP_READDIR
3680                       || k1->op_type == OP_GLOB
3681                       || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3682                       || k1->op_type == OP_EACH)
3683                     expr = newUNOP(OP_DEFINED, 0, expr);
3684                 break;
3685             }
3686         }
3687     }
3688
3689     /* if block is null, the next append_elem() would put UNSTACK, a scalar
3690      * op, in listop. This is wrong. [perl #27024] */
3691     if (!block)
3692         block = newOP(OP_NULL, 0);
3693     listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3694     o = new_logop(OP_AND, 0, &expr, &listop);
3695
3696     if (listop)
3697         ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3698
3699     if (once && o != listop)
3700         o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3701
3702     if (o == listop)
3703         o = newUNOP(OP_NULL, 0, o);     /* or do {} while 1 loses outer block */
3704
3705     o->op_flags |= flags;
3706     o = scope(o);
3707     o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3708     return o;
3709 }
3710
3711 OP *
3712 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
3713 {
3714     OP *redo;
3715     OP *next = 0;
3716     OP *listop;
3717     OP *o;
3718     U8 loopflags = 0;
3719
3720     if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3721                  || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
3722         expr = newUNOP(OP_DEFINED, 0,
3723             newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3724     } else if (expr && (expr->op_flags & OPf_KIDS)) {
3725         OP *k1 = ((UNOP*)expr)->op_first;
3726         OP *k2 = (k1) ? k1->op_sibling : NULL;
3727         switch (expr->op_type) {
3728           case OP_NULL:
3729             if (k2 && k2->op_type == OP_READLINE
3730                   && (k2->op_flags & OPf_STACKED)
3731                   && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3732                 expr = newUNOP(OP_DEFINED, 0, expr);
3733             break;
3734
3735           case OP_SASSIGN:
3736             if (k1->op_type == OP_READDIR
3737                   || k1->op_type == OP_GLOB
3738                   || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3739                   || k1->op_type == OP_EACH)
3740                 expr = newUNOP(OP_DEFINED, 0, expr);
3741             break;
3742         }
3743     }
3744
3745     if (!block)
3746         block = newOP(OP_NULL, 0);
3747     else if (cont) {
3748         block = scope(block);
3749     }
3750
3751     if (cont) {
3752         next = LINKLIST(cont);
3753     }
3754     if (expr) {
3755         OP *unstack = newOP(OP_UNSTACK, 0);
3756         if (!next)
3757             next = unstack;
3758         cont = append_elem(OP_LINESEQ, cont, unstack);
3759     }
3760
3761     listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
3762     redo = LINKLIST(listop);
3763
3764     if (expr) {
3765         PL_copline = (line_t)whileline;
3766         scalar(listop);
3767         o = new_logop(OP_AND, 0, &expr, &listop);
3768         if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
3769             op_free(expr);              /* oops, it's a while (0) */
3770             op_free((OP*)loop);
3771             return Nullop;              /* listop already freed by new_logop */
3772         }
3773         if (listop)
3774             ((LISTOP*)listop)->op_last->op_next =
3775                 (o == listop ? redo : LINKLIST(o));
3776     }
3777     else
3778         o = listop;
3779
3780     if (!loop) {
3781         NewOp(1101,loop,1,LOOP);
3782         loop->op_type = OP_ENTERLOOP;
3783         loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
3784         loop->op_private = 0;
3785         loop->op_next = (OP*)loop;
3786     }
3787
3788     o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
3789
3790     loop->op_redoop = redo;
3791     loop->op_lastop = o;
3792     o->op_private |= loopflags;
3793
3794     if (next)
3795         loop->op_nextop = next;
3796     else
3797         loop->op_nextop = o;
3798
3799     o->op_flags |= flags;
3800     o->op_private |= (flags >> 8);
3801     return o;
3802 }
3803
3804 OP *
3805 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
3806 {
3807     LOOP *loop;
3808     OP *wop;
3809     PADOFFSET padoff = 0;
3810     I32 iterflags = 0;
3811     I32 iterpflags = 0;
3812
3813     if (sv) {
3814         if (sv->op_type == OP_RV2SV) {  /* symbol table variable */
3815             iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
3816             sv->op_type = OP_RV2GV;
3817             sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
3818         }
3819         else if (sv->op_type == OP_PADSV) { /* private variable */
3820             iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
3821             padoff = sv->op_targ;
3822             sv->op_targ = 0;
3823             op_free(sv);
3824             sv = Nullop;
3825         }
3826         else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
3827             padoff = sv->op_targ;
3828             sv->op_targ = 0;
3829             iterflags |= OPf_SPECIAL;
3830             op_free(sv);
3831             sv = Nullop;
3832         }
3833         else
3834             Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
3835     }
3836     else {
3837         I32 offset = pad_findmy("$_");
3838         if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
3839             sv = newGVOP(OP_GV, 0, PL_defgv);
3840         }
3841         else {
3842             padoff = offset;
3843         }
3844     }
3845     if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
3846         expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
3847         iterflags |= OPf_STACKED;
3848     }
3849     else if (expr->op_type == OP_NULL &&
3850              (expr->op_flags & OPf_KIDS) &&
3851              ((BINOP*)expr)->op_first->op_type == OP_FLOP)
3852     {
3853         /* Basically turn for($x..$y) into the same as for($x,$y), but we
3854          * set the STACKED flag to indicate that these values are to be
3855          * treated as min/max values by 'pp_iterinit'.
3856          */
3857         UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
3858         LOGOP* range = (LOGOP*) flip->op_first;
3859         OP* left  = range->op_first;
3860         OP* right = left->op_sibling;
3861         LISTOP* listop;
3862
3863         range->op_flags &= ~OPf_KIDS;
3864         range->op_first = Nullop;
3865
3866         listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
3867         listop->op_first->op_next = range->op_next;
3868         left->op_next = range->op_other;
3869         right->op_next = (OP*)listop;
3870         listop->op_next = listop->op_first;
3871
3872         op_free(expr);
3873         expr = (OP*)(listop);
3874         op_null(expr);
3875         iterflags |= OPf_STACKED;
3876     }
3877     else {
3878         expr = mod(force_list(expr), OP_GREPSTART);
3879     }
3880
3881
3882     loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
3883                                append_elem(OP_LIST, expr, scalar(sv))));
3884     assert(!loop->op_next);
3885     /* for my  $x () sets OPpLVAL_INTRO;
3886      * for our $x () sets OPpOUR_INTRO */
3887     loop->op_private = (U8)iterpflags;
3888 #ifdef PL_OP_SLAB_ALLOC
3889     {
3890         LOOP *tmp;
3891         NewOp(1234,tmp,1,LOOP);
3892         Copy(loop,tmp,1,LOOP);
3893         FreeOp(loop);
3894         loop = tmp;
3895     }
3896 #else
3897     Renew(loop, 1, LOOP);
3898 #endif
3899     loop->op_targ = padoff;
3900     wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
3901     PL_copline = forline;
3902     return newSTATEOP(0, label, wop);
3903 }
3904
3905 OP*
3906 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
3907 {
3908     OP *o;
3909     STRLEN n_a;
3910
3911     if (type != OP_GOTO || label->op_type == OP_CONST) {
3912         /* "last()" means "last" */
3913         if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
3914             o = newOP(type, OPf_SPECIAL);
3915         else {
3916             o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
3917                                         ? SvPVx(((SVOP*)label)->op_sv, n_a)
3918                                         : ""));
3919         }
3920         op_free(label);
3921     }
3922     else {
3923         /* Check whether it's going to be a goto &function */
3924         if (label->op_type == OP_ENTERSUB
3925                 && !(label->op_flags & OPf_STACKED))
3926             label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
3927         o = newUNOP(type, OPf_STACKED, label);
3928     }
3929     PL_hints |= HINT_BLOCK_SCOPE;
3930     return o;
3931 }
3932
3933 /*
3934 =for apidoc cv_undef
3935
3936 Clear out all the active components of a CV. This can happen either
3937 by an explicit C<undef &foo>, or by the reference count going to zero.
3938 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
3939 children can still follow the full lexical scope chain.
3940
3941 =cut
3942 */
3943
3944 void
3945 Perl_cv_undef(pTHX_ CV *cv)
3946 {
3947 #ifdef USE_ITHREADS
3948     if (CvFILE(cv) && !CvXSUB(cv)) {
3949         /* for XSUBs CvFILE point directly to static memory; __FILE__ */
3950         Safefree(CvFILE(cv));
3951     }
3952     CvFILE(cv) = 0;
3953 #endif
3954
3955     if (!CvXSUB(cv) && CvROOT(cv)) {
3956         if (CvDEPTH(cv))
3957             Perl_croak(aTHX_ "Can't undef active subroutine");
3958         ENTER;
3959
3960         PAD_SAVE_SETNULLPAD();
3961
3962         op_free(CvROOT(cv));
3963         CvROOT(cv) = Nullop;
3964         LEAVE;
3965     }
3966     SvPOK_off((SV*)cv);         /* forget prototype */
3967     CvGV(cv) = Nullgv;
3968
3969     pad_undef(cv);
3970
3971     /* remove CvOUTSIDE unless this is an undef rather than a free */
3972     if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
3973         if (!CvWEAKOUTSIDE(cv))
3974             SvREFCNT_dec(CvOUTSIDE(cv));
3975         CvOUTSIDE(cv) = Nullcv;
3976     }
3977     if (CvCONST(cv)) {
3978         SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
3979         CvCONST_off(cv);
3980     }
3981     if (CvXSUB(cv)) {
3982         CvXSUB(cv) = 0;
3983     }
3984     /* delete all flags except WEAKOUTSIDE */
3985     CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
3986 }
3987
3988 void
3989 Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
3990 {
3991     if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
3992         SV* msg = sv_newmortal();
3993         SV* name = Nullsv;
3994
3995         if (gv)
3996             gv_efullname3(name = sv_newmortal(), gv, Nullch);
3997         sv_setpv(msg, "Prototype mismatch:");
3998         if (name)
3999             Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4000         if (SvPOK(cv))
4001             Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (SV *)cv);
4002         else
4003             Perl_sv_catpvf(aTHX_ msg, ": none");
4004         sv_catpv(msg, " vs ");
4005         if (p)
4006             Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4007         else
4008             sv_catpv(msg, "none");
4009         Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, msg);
4010     }
4011 }
4012
4013 static void const_sv_xsub(pTHX_ CV* cv);
4014
4015 /*
4016
4017 =head1 Optree Manipulation Functions
4018
4019 =for apidoc cv_const_sv
4020
4021 If C<cv> is a constant sub eligible for inlining. returns the constant
4022 value returned by the sub.  Otherwise, returns NULL.
4023
4024 Constant subs can be created with C<newCONSTSUB> or as described in
4025 L<perlsub/"Constant Functions">.
4026
4027 =cut
4028 */
4029 SV *
4030 Perl_cv_const_sv(pTHX_ CV *cv)
4031 {
4032     if (!cv || !CvCONST(cv))
4033         return Nullsv;
4034     return (SV*)CvXSUBANY(cv).any_ptr;
4035 }
4036
4037 /* op_const_sv:  examine an optree to determine whether it's in-lineable.
4038  * Can be called in 3 ways:
4039  *
4040  * !cv
4041  *      look for a single OP_CONST with attached value: return the value
4042  *
4043  * cv && CvCLONE(cv) && !CvCONST(cv)
4044  *
4045  *      examine the clone prototype, and if contains only a single
4046  *      OP_CONST referencing a pad const, or a single PADSV referencing
4047  *      an outer lexical, return a non-zero value to indicate the CV is
4048  *      a candidate for "constizing" at clone time
4049  *
4050  * cv && CvCONST(cv)
4051  *
4052  *      We have just cloned an anon prototype that was marked as a const
4053  *      candidiate. Try to grab the current value, and in the case of
4054  *      PADSV, ignore it if it has multiple references. Return the value.
4055  */
4056
4057 SV *
4058 Perl_op_const_sv(pTHX_ OP *o, CV *cv)
4059 {
4060     SV *sv = Nullsv;
4061
4062     if (!o)
4063         return Nullsv;
4064
4065     if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4066         o = cLISTOPo->op_first->op_sibling;
4067
4068     for (; o; o = o->op_next) {
4069         OPCODE type = o->op_type;
4070
4071         if (sv && o->op_next == o)
4072             return sv;
4073         if (o->op_next != o) {
4074             if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4075                 continue;
4076             if (type == OP_DBSTATE)
4077                 continue;
4078         }
4079         if (type == OP_LEAVESUB || type == OP_RETURN)
4080             break;
4081         if (sv)
4082             return Nullsv;
4083         if (type == OP_CONST && cSVOPo->op_sv)
4084             sv = cSVOPo->op_sv;
4085         else if (cv && type == OP_CONST) {
4086             sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4087             if (!sv)
4088                 return Nullsv;
4089         }
4090         else if (cv && type == OP_PADSV) {
4091             if (CvCONST(cv)) { /* newly cloned anon */
4092                 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4093                 /* the candidate should have 1 ref from this pad and 1 ref
4094                  * from the parent */
4095                 if (!sv || SvREFCNT(sv) != 2)
4096                     return Nullsv;
4097                 sv = newSVsv(sv);
4098                 SvREADONLY_on(sv);
4099                 return sv;
4100             }
4101             else {
4102                 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
4103                     sv = &PL_sv_undef; /* an arbitrary non-null value */
4104             }
4105         }
4106         else {
4107             return Nullsv;
4108         }
4109     }
4110     return sv;
4111 }
4112
4113 void
4114 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4115 {
4116     if (o)
4117         SAVEFREEOP(o);
4118     if (proto)
4119         SAVEFREEOP(proto);
4120     if (attrs)
4121         SAVEFREEOP(attrs);
4122     if (block)
4123         SAVEFREEOP(block);
4124     Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4125 }
4126
4127 CV *
4128 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4129 {
4130     return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4131 }
4132
4133 CV *
4134 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4135 {
4136     STRLEN n_a;
4137     char *name;
4138     char *aname;
4139     GV *gv;
4140     char *ps;
4141     register CV *cv=0;
4142     SV *const_sv;
4143
4144     name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4145
4146     if (proto) {
4147         assert(proto->op_type == OP_CONST);
4148         ps = SvPVx(((SVOP*)proto)->op_sv, n_a);
4149     }
4150     else
4151         ps = Nullch;
4152
4153     if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4154         SV *sv = sv_newmortal();
4155         Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
4156                        PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
4157                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4158         aname = SvPVX(sv);
4159     }
4160     else
4161         aname = Nullch;
4162     gv = gv_fetchpv(name ? name : (aname ? aname :
4163                     (PL_curstash ? "__ANON__" : "__ANON__::__ANON__")),
4164                     GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4165                     SVt_PVCV);
4166
4167     if (o)
4168         SAVEFREEOP(o);
4169     if (proto)
4170         SAVEFREEOP(proto);
4171     if (attrs)
4172         SAVEFREEOP(attrs);
4173
4174     if (SvTYPE(gv) != SVt_PVGV) {       /* Maybe prototype now, and had at
4175                                            maximum a prototype before. */
4176         if (SvTYPE(gv) > SVt_NULL) {
4177             if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4178                 && ckWARN_d(WARN_PROTOTYPE))
4179             {
4180                 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
4181             }
4182             cv_ckproto((CV*)gv, NULL, ps);
4183         }
4184         if (ps)
4185             sv_setpv((SV*)gv, ps);
4186         else
4187             sv_setiv((SV*)gv, -1);
4188         SvREFCNT_dec(PL_compcv);
4189         cv = PL_compcv = NULL;
4190         PL_sub_generation++;
4191         goto done;
4192     }
4193
4194     cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4195
4196 #ifdef GV_UNIQUE_CHECK
4197     if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4198         Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
4199     }
4200 #endif
4201
4202     if (!block || !ps || *ps || attrs)
4203         const_sv = Nullsv;
4204     else
4205         const_sv = op_const_sv(block, Nullcv);
4206
4207     if (cv) {
4208         bool exists = CvROOT(cv) || CvXSUB(cv);
4209
4210 #ifdef GV_UNIQUE_CHECK
4211         if (exists && GvUNIQUE(gv)) {
4212             Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
4213         }
4214 #endif
4215
4216         /* if the subroutine doesn't exist and wasn't pre-declared
4217          * with a prototype, assume it will be AUTOLOADed,
4218          * skipping the prototype check
4219          */
4220         if (exists || SvPOK(cv))
4221             cv_ckproto(cv, gv, ps);
4222         /* already defined (or promised)? */
4223         if (exists || GvASSUMECV(gv)) {
4224             if (!block && !attrs) {
4225                 if (CvFLAGS(PL_compcv)) {
4226                     /* might have had built-in attrs applied */
4227                     CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4228                 }
4229                 /* just a "sub foo;" when &foo is already defined */
4230                 SAVEFREESV(PL_compcv);
4231                 goto done;
4232             }
4233             /* ahem, death to those who redefine active sort subs */
4234             if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4235                 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4236             if (block) {
4237                 if (ckWARN(WARN_REDEFINE)
4238                     || (CvCONST(cv)
4239                         && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4240                 {
4241                     line_t oldline = CopLINE(PL_curcop);
4242                     if (PL_copline != NOLINE)
4243                         CopLINE_set(PL_curcop, PL_copline);
4244                     Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4245                         CvCONST(cv) ? "Constant subroutine %s redefined"
4246                                     : "Subroutine %s redefined", name);
4247                     CopLINE_set(PL_curcop, oldline);
4248                 }
4249                 SvREFCNT_dec(cv);
4250                 cv = Nullcv;
4251             }
4252         }
4253     }
4254     if (const_sv) {
4255         SvREFCNT_inc(const_sv);
4256         if (cv) {
4257             assert(!CvROOT(cv) && !CvCONST(cv));
4258             sv_setpv((SV*)cv, "");  /* prototype is "" */
4259             CvXSUBANY(cv).any_ptr = const_sv;
4260             CvXSUB(cv) = const_sv_xsub;
4261             CvCONST_on(cv);
4262         }
4263         else {
4264             GvCV(gv) = Nullcv;
4265             cv = newCONSTSUB(NULL, name, const_sv);
4266         }
4267         op_free(block);
4268         SvREFCNT_dec(PL_compcv);
4269         PL_compcv = NULL;
4270         PL_sub_generation++;
4271         goto done;
4272     }
4273     if (attrs) {
4274         HV *stash;
4275         SV *rcv;
4276
4277         /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4278          * before we clobber PL_compcv.
4279          */
4280         if (cv && !block) {
4281             rcv = (SV*)cv;
4282             /* Might have had built-in attributes applied -- propagate them. */
4283             CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4284             if (CvGV(cv) && GvSTASH(CvGV(cv)))
4285                 stash = GvSTASH(CvGV(cv));
4286             else if (CvSTASH(cv))
4287                 stash = CvSTASH(cv);
4288             else
4289                 stash = PL_curstash;
4290         }
4291         else {
4292             /* possibly about to re-define existing subr -- ignore old cv */
4293             rcv = (SV*)PL_compcv;
4294             if (name && GvSTASH(gv))
4295                 stash = GvSTASH(gv);
4296             else
4297                 stash = PL_curstash;
4298         }
4299         apply_attrs(stash, rcv, attrs, FALSE);
4300     }
4301     if (cv) {                           /* must reuse cv if autoloaded */
4302         if (!block) {
4303             /* got here with just attrs -- work done, so bug out */
4304             SAVEFREESV(PL_compcv);
4305             goto done;
4306         }
4307         /* transfer PL_compcv to cv */
4308         cv_undef(cv);
4309         CvFLAGS(cv) = CvFLAGS(PL_compcv);
4310         if (!CvWEAKOUTSIDE(cv))
4311             SvREFCNT_dec(CvOUTSIDE(cv));
4312         CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4313         CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
4314         CvOUTSIDE(PL_compcv) = 0;
4315         CvPADLIST(cv) = CvPADLIST(PL_compcv);
4316         CvPADLIST(PL_compcv) = 0;
4317         /* inner references to PL_compcv must be fixed up ... */
4318         pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
4319         /* ... before we throw it away */
4320         SvREFCNT_dec(PL_compcv);
4321         PL_compcv = cv;
4322         if (PERLDB_INTER)/* Advice debugger on the new sub. */
4323           ++PL_sub_generation;
4324     }
4325     else {
4326         cv = PL_compcv;
4327         if (name) {
4328             GvCV(gv) = cv;
4329             GvCVGEN(gv) = 0;
4330             PL_sub_generation++;
4331         }
4332     }
4333     CvGV(cv) = gv;
4334     CvFILE_set_from_cop(cv, PL_curcop);
4335     CvSTASH(cv) = PL_curstash;
4336
4337     if (ps)
4338         sv_setpv((SV*)cv, ps);
4339
4340     if (PL_error_count) {
4341         op_free(block);
4342         block = Nullop;
4343         if (name) {
4344             char *s = strrchr(name, ':');
4345             s = s ? s+1 : name;
4346             if (strEQ(s, "BEGIN")) {
4347                 char *not_safe =
4348                     "BEGIN not safe after errors--compilation aborted";
4349                 if (PL_in_eval & EVAL_KEEPERR)
4350                     Perl_croak(aTHX_ not_safe);
4351                 else {
4352                     /* force display of errors found but not reported */
4353                     sv_catpv(ERRSV, not_safe);
4354                     Perl_croak(aTHX_ "%"SVf, ERRSV);
4355                 }
4356             }
4357         }
4358     }
4359     if (!block)
4360         goto done;
4361
4362     if (CvLVALUE(cv)) {
4363         CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4364                              mod(scalarseq(block), OP_LEAVESUBLV));
4365     }
4366     else {
4367         /* This makes sub {}; work as expected.  */
4368         if (block->op_type == OP_STUB) {
4369             op_free(block);
4370             block = newSTATEOP(0, Nullch, 0);
4371         }
4372         CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4373     }
4374     CvROOT(cv)->op_private |= OPpREFCOUNTED;
4375     OpREFCNT_set(CvROOT(cv), 1);
4376     CvSTART(cv) = LINKLIST(CvROOT(cv));
4377     CvROOT(cv)->op_next = 0;
4378     CALL_PEEP(CvSTART(cv));
4379
4380     /* now that optimizer has done its work, adjust pad values */
4381
4382     pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
4383
4384     if (CvCLONE(cv)) {
4385         assert(!CvCONST(cv));
4386         if (ps && !*ps && op_const_sv(block, cv))
4387             CvCONST_on(cv);
4388     }
4389
4390     if (name || aname) {
4391         char *s;
4392         char *tname = (name ? name : aname);
4393
4394         if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4395             SV *sv = NEWSV(0,0);
4396             SV *tmpstr = sv_newmortal();
4397             GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4398             CV *pcv;
4399             HV *hv;
4400
4401             Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4402                            CopFILE(PL_curcop),
4403                            (long)PL_subline, (long)CopLINE(PL_curcop));
4404             gv_efullname3(tmpstr, gv, Nullch);
4405             hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
4406             hv = GvHVn(db_postponed);
4407             if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
4408                 && (pcv = GvCV(db_postponed)))
4409             {
4410                 dSP;
4411                 PUSHMARK(SP);
4412                 XPUSHs(tmpstr);
4413                 PUTBACK;
4414                 call_sv((SV*)pcv, G_DISCARD);
4415             }
4416         }
4417
4418         if ((s = strrchr(tname,':')))
4419             s++;
4420         else
4421             s = tname;
4422
4423         if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4424             goto done;
4425
4426         if (strEQ(s, "BEGIN") && !PL_error_count) {
4427             I32 oldscope = PL_scopestack_ix;
4428             ENTER;
4429             SAVECOPFILE(&PL_compiling);
4430             SAVECOPLINE(&PL_compiling);
4431
4432             if (!PL_beginav)
4433                 PL_beginav = newAV();
4434             DEBUG_x( dump_sub(gv) );
4435             av_push(PL_beginav, (SV*)cv);
4436             GvCV(gv) = 0;               /* cv has been hijacked */
4437             call_list(oldscope, PL_beginav);
4438
4439             PL_curcop = &PL_compiling;
4440             PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4441             LEAVE;
4442         }
4443         else if (strEQ(s, "END") && !PL_error_count) {
4444             if (!PL_endav)
4445                 PL_endav = newAV();
4446             DEBUG_x( dump_sub(gv) );
4447             av_unshift(PL_endav, 1);
4448             av_store(PL_endav, 0, (SV*)cv);
4449             GvCV(gv) = 0;               /* cv has been hijacked */
4450         }
4451         else if (strEQ(s, "CHECK") && !PL_error_count) {
4452             if (!PL_checkav)
4453                 PL_checkav = newAV();
4454             DEBUG_x( dump_sub(gv) );
4455             if (PL_main_start && ckWARN(WARN_VOID))
4456                 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4457             av_unshift(PL_checkav, 1);
4458             av_store(PL_checkav, 0, (SV*)cv);
4459             GvCV(gv) = 0;               /* cv has been hijacked */
4460         }
4461         else if (strEQ(s, "INIT") && !PL_error_count) {
4462             if (!PL_initav)
4463                 PL_initav = newAV();
4464             DEBUG_x( dump_sub(gv) );
4465             if (PL_main_start && ckWARN(WARN_VOID))
4466                 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4467             av_push(PL_initav, (SV*)cv);
4468             GvCV(gv) = 0;               /* cv has been hijacked */
4469         }
4470     }
4471
4472   done:
4473     PL_copline = NOLINE;
4474     LEAVE_SCOPE(floor);
4475     return cv;
4476 }
4477
4478 /* XXX unsafe for threads if eval_owner isn't held */
4479 /*
4480 =for apidoc newCONSTSUB
4481
4482 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4483 eligible for inlining at compile-time.
4484
4485 =cut
4486 */
4487
4488 CV *
4489 Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
4490 {
4491     CV* cv;
4492
4493     ENTER;
4494
4495     SAVECOPLINE(PL_curcop);
4496     CopLINE_set(PL_curcop, PL_copline);
4497
4498     SAVEHINTS();
4499     PL_hints &= ~HINT_BLOCK_SCOPE;
4500
4501     if (stash) {
4502         SAVESPTR(PL_curstash);
4503         SAVECOPSTASH(PL_curcop);
4504         PL_curstash = stash;
4505         CopSTASH_set(PL_curcop,stash);
4506     }
4507
4508     cv = newXS(name, const_sv_xsub, savepv(CopFILE(PL_curcop)));
4509     CvXSUBANY(cv).any_ptr = sv;
4510     CvCONST_on(cv);
4511     sv_setpv((SV*)cv, "");  /* prototype is "" */
4512
4513     if (stash)
4514         CopSTASH_free(PL_curcop);
4515
4516     LEAVE;
4517
4518     return cv;
4519 }
4520
4521 /*
4522 =for apidoc U||newXS
4523
4524 Used by C<xsubpp> to hook up XSUBs as Perl subs.
4525
4526 =cut
4527 */
4528
4529 CV *
4530 Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
4531 {
4532     GV *gv = gv_fetchpv(name ? name :
4533                         (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4534                         GV_ADDMULTI, SVt_PVCV);
4535     register CV *cv;
4536
4537     if (!subaddr)
4538         Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
4539
4540     if ((cv = (name ? GvCV(gv) : Nullcv))) {
4541         if (GvCVGEN(gv)) {
4542             /* just a cached method */
4543             SvREFCNT_dec(cv);
4544             cv = 0;
4545         }
4546         else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4547             /* already defined (or promised) */
4548             if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
4549                             && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
4550                 line_t oldline = CopLINE(PL_curcop);
4551                 if (PL_copline != NOLINE)
4552                     CopLINE_set(PL_curcop, PL_copline);
4553                 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4554                             CvCONST(cv) ? "Constant subroutine %s redefined"
4555                                         : "Subroutine %s redefined"
4556                             ,name);
4557                 CopLINE_set(PL_curcop, oldline);
4558             }
4559             SvREFCNT_dec(cv);
4560             cv = 0;
4561         }
4562     }
4563
4564     if (cv)                             /* must reuse cv if autoloaded */
4565         cv_undef(cv);
4566     else {
4567         cv = (CV*)NEWSV(1105,0);
4568         sv_upgrade((SV *)cv, SVt_PVCV);
4569         if (name) {
4570             GvCV(gv) = cv;
4571             GvCVGEN(gv) = 0;
4572             PL_sub_generation++;
4573         }
4574     }
4575     CvGV(cv) = gv;
4576     (void)gv_fetchfile(filename);
4577     CvFILE(cv) = filename;      /* NOTE: not copied, as it is expected to be
4578                                    an external constant string */
4579     CvXSUB(cv) = subaddr;
4580
4581     if (name) {
4582         char *s = strrchr(name,':');
4583         if (s)
4584             s++;
4585         else
4586             s = name;
4587
4588         if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4589             goto done;
4590
4591         if (strEQ(s, "BEGIN")) {
4592             if (!PL_beginav)
4593                 PL_beginav = newAV();
4594             av_push(PL_beginav, (SV*)cv);
4595             GvCV(gv) = 0;               /* cv has been hijacked */
4596         }
4597         else if (strEQ(s, "END")) {
4598             if (!PL_endav)
4599                 PL_endav = newAV();
4600             av_unshift(PL_endav, 1);
4601             av_store(PL_endav, 0, (SV*)cv);
4602             GvCV(gv) = 0;               /* cv has been hijacked */
4603         }
4604         else if (strEQ(s, "CHECK")) {
4605             if (!PL_checkav)
4606                 PL_checkav = newAV();
4607             if (PL_main_start && ckWARN(WARN_VOID))
4608                 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4609             av_unshift(PL_checkav, 1);
4610             av_store(PL_checkav, 0, (SV*)cv);
4611             GvCV(gv) = 0;               /* cv has been hijacked */
4612         }
4613         else if (strEQ(s, "INIT")) {
4614             if (!PL_initav)
4615                 PL_initav = newAV();
4616             if (PL_main_start && ckWARN(WARN_VOID))
4617                 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4618             av_push(PL_initav, (SV*)cv);
4619             GvCV(gv) = 0;               /* cv has been hijacked */
4620         }
4621     }
4622     else
4623         CvANON_on(cv);
4624
4625 done:
4626     return cv;
4627 }
4628
4629 void
4630 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
4631 {
4632     register CV *cv;
4633     char *name;
4634     GV *gv;
4635     STRLEN n_a;
4636
4637     if (o)
4638         name = SvPVx(cSVOPo->op_sv, n_a);
4639     else
4640         name = "STDOUT";
4641     gv = gv_fetchpv(name,TRUE, SVt_PVFM);
4642 #ifdef GV_UNIQUE_CHECK
4643     if (GvUNIQUE(gv)) {
4644         Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
4645     }
4646 #endif
4647     GvMULTI_on(gv);
4648     if ((cv = GvFORM(gv))) {
4649         if (ckWARN(WARN_REDEFINE)) {
4650             line_t oldline = CopLINE(PL_curcop);
4651             if (PL_copline != NOLINE)
4652                 CopLINE_set(PL_curcop, PL_copline);
4653             Perl_warner(aTHX_ packWARN(WARN_REDEFINE), "Format %s redefined",name);
4654             CopLINE_set(PL_curcop, oldline);
4655         }
4656         SvREFCNT_dec(cv);
4657     }
4658     cv = PL_compcv;
4659     GvFORM(gv) = cv;
4660     CvGV(cv) = gv;
4661     CvFILE_set_from_cop(cv, PL_curcop);
4662
4663
4664     pad_tidy(padtidy_FORMAT);
4665     CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
4666     CvROOT(cv)->op_private |= OPpREFCOUNTED;
4667     OpREFCNT_set(CvROOT(cv), 1);
4668     CvSTART(cv) = LINKLIST(CvROOT(cv));
4669     CvROOT(cv)->op_next = 0;
4670     CALL_PEEP(CvSTART(cv));
4671     op_free(o);
4672     PL_copline = NOLINE;
4673     LEAVE_SCOPE(floor);
4674 }
4675
4676 OP *
4677 Perl_newANONLIST(pTHX_ OP *o)
4678 {
4679     return newUNOP(OP_REFGEN, 0,
4680         mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
4681 }
4682
4683 OP *
4684 Perl_newANONHASH(pTHX_ OP *o)
4685 {
4686     return newUNOP(OP_REFGEN, 0,
4687         mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
4688 }
4689
4690 OP *
4691 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
4692 {
4693     return newANONATTRSUB(floor, proto, Nullop, block);
4694 }
4695
4696 OP *
4697 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
4698 {
4699     return newUNOP(OP_REFGEN, 0,
4700         newSVOP(OP_ANONCODE, 0,
4701                 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
4702 }
4703
4704 OP *
4705 Perl_oopsAV(pTHX_ OP *o)
4706 {
4707     switch (o->op_type) {
4708     case OP_PADSV:
4709         o->op_type = OP_PADAV;
4710         o->op_ppaddr = PL_ppaddr[OP_PADAV];
4711         return ref(o, OP_RV2AV);
4712
4713     case OP_RV2SV:
4714         o->op_type = OP_RV2AV;
4715         o->op_ppaddr = PL_ppaddr[OP_RV2AV];
4716         ref(o, OP_RV2AV);
4717         break;
4718
4719     default:
4720         if (ckWARN_d(WARN_INTERNAL))
4721             Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
4722         break;
4723     }
4724     return o;
4725 }
4726
4727 OP *
4728 Perl_oopsHV(pTHX_ OP *o)
4729 {
4730     switch (o->op_type) {
4731     case OP_PADSV:
4732     case OP_PADAV:
4733         o->op_type = OP_PADHV;
4734         o->op_ppaddr = PL_ppaddr[OP_PADHV];
4735         return ref(o, OP_RV2HV);
4736
4737     case OP_RV2SV:
4738     case OP_RV2AV:
4739         o->op_type = OP_RV2HV;
4740         o->op_ppaddr = PL_ppaddr[OP_RV2HV];
4741         ref(o, OP_RV2HV);
4742         break;
4743
4744     default:
4745         if (ckWARN_d(WARN_INTERNAL))
4746             Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
4747         break;
4748     }
4749     return o;
4750 }
4751
4752 OP *
4753 Perl_newAVREF(pTHX_ OP *o)
4754 {
4755     if (o->op_type == OP_PADANY) {
4756         o->op_type = OP_PADAV;
4757         o->op_ppaddr = PL_ppaddr[OP_PADAV];
4758         return o;
4759     }
4760     else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
4761                 && ckWARN(WARN_DEPRECATED)) {
4762         Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4763                 "Using an array as a reference is deprecated");
4764     }
4765     return newUNOP(OP_RV2AV, 0, scalar(o));
4766 }
4767
4768 OP *
4769 Perl_newGVREF(pTHX_ I32 type, OP *o)
4770 {
4771     if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
4772         return newUNOP(OP_NULL, 0, o);
4773     return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
4774 }
4775
4776 OP *
4777 Perl_newHVREF(pTHX_ OP *o)
4778 {
4779     if (o->op_type == OP_PADANY) {
4780         o->op_type = OP_PADHV;
4781         o->op_ppaddr = PL_ppaddr[OP_PADHV];
4782         return o;
4783     }
4784     else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
4785                 && ckWARN(WARN_DEPRECATED)) {
4786         Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4787                 "Using a hash as a reference is deprecated");
4788     }
4789     return newUNOP(OP_RV2HV, 0, scalar(o));
4790 }
4791
4792 OP *
4793 Perl_oopsCV(pTHX_ OP *o)
4794 {
4795     Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
4796     /* STUB */
4797     return o;
4798 }
4799
4800 OP *
4801 Perl_newCVREF(pTHX_ I32 flags, OP *o)
4802 {
4803     return newUNOP(OP_RV2CV, flags, scalar(o));
4804 }
4805
4806 OP *
4807 Perl_newSVREF(pTHX_ OP *o)
4808 {
4809     if (o->op_type == OP_PADANY) {
4810         o->op_type = OP_PADSV;
4811         o->op_ppaddr = PL_ppaddr[OP_PADSV];
4812         return o;
4813     }
4814     else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
4815         o->op_flags |= OPpDONE_SVREF;
4816         return o;
4817     }
4818     return newUNOP(OP_RV2SV, 0, scalar(o));
4819 }
4820
4821 /* Check routines. */
4822
4823 OP *
4824 Perl_ck_anoncode(pTHX_ OP *o)
4825 {
4826     cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);