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, Nullop));
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 OP *
2664 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl)
2665 {
2666     PMOP *pm;
2667     LOGOP *rcop;
2668     I32 repl_has_vars = 0;
2669
2670     if (o->op_type == OP_TRANS)
2671         return pmtrans(o, expr, repl);
2672
2673     PL_hints |= HINT_BLOCK_SCOPE;
2674     pm = (PMOP*)o;
2675
2676     if (expr->op_type == OP_CONST) {
2677         STRLEN plen;
2678         SV *pat = ((SVOP*)expr)->op_sv;
2679         char *p = SvPV(pat, plen);
2680         if ((o->op_flags & OPf_SPECIAL) && strEQ(p, " ")) {
2681             sv_setpvn(pat, "\\s+", 3);
2682             p = SvPV(pat, plen);
2683             pm->op_pmflags |= PMf_SKIPWHITE;
2684         }
2685         if (DO_UTF8(pat))
2686             pm->op_pmdynflags |= PMdf_UTF8;
2687         PM_SETRE(pm, CALLREGCOMP(aTHX_ p, p + plen, pm));
2688         if (strEQ("\\s+", PM_GETRE(pm)->precomp))
2689             pm->op_pmflags |= PMf_WHITE;
2690         op_free(expr);
2691     }
2692     else {
2693         if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
2694             expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
2695                             ? OP_REGCRESET
2696                             : OP_REGCMAYBE),0,expr);
2697
2698         NewOp(1101, rcop, 1, LOGOP);
2699         rcop->op_type = OP_REGCOMP;
2700         rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
2701         rcop->op_first = scalar(expr);
2702         rcop->op_flags |= ((PL_hints & HINT_RE_EVAL)
2703                            ? (OPf_SPECIAL | OPf_KIDS)
2704                            : OPf_KIDS);
2705         rcop->op_private = 1;
2706         rcop->op_other = o;
2707         /* /$x/ may cause an eval, since $x might be qr/(?{..})/  */
2708         PL_cv_has_eval = 1;
2709
2710         /* establish postfix order */
2711         if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
2712             LINKLIST(expr);
2713             rcop->op_next = expr;
2714             ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
2715         }
2716         else {
2717             rcop->op_next = LINKLIST(expr);
2718             expr->op_next = (OP*)rcop;
2719         }
2720
2721         prepend_elem(o->op_type, scalar((OP*)rcop), o);
2722     }
2723
2724     if (repl) {
2725         OP *curop;
2726         if (pm->op_pmflags & PMf_EVAL) {
2727             curop = 0;
2728             if (CopLINE(PL_curcop) < (line_t)PL_multi_end)
2729                 CopLINE_set(PL_curcop, (line_t)PL_multi_end);
2730         }
2731         else if (repl->op_type == OP_CONST)
2732             curop = repl;
2733         else {
2734             OP *lastop = 0;
2735             for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
2736                 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
2737                     if (curop->op_type == OP_GV) {
2738                         GV *gv = cGVOPx_gv(curop);
2739                         repl_has_vars = 1;
2740                         if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
2741                             break;
2742                     }
2743                     else if (curop->op_type == OP_RV2CV)
2744                         break;
2745                     else if (curop->op_type == OP_RV2SV ||
2746                              curop->op_type == OP_RV2AV ||
2747                              curop->op_type == OP_RV2HV ||
2748                              curop->op_type == OP_RV2GV) {
2749                         if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
2750                             break;
2751                     }
2752                     else if (curop->op_type == OP_PADSV ||
2753                              curop->op_type == OP_PADAV ||
2754                              curop->op_type == OP_PADHV ||
2755                              curop->op_type == OP_PADANY) {
2756                         repl_has_vars = 1;
2757                     }
2758                     else if (curop->op_type == OP_PUSHRE)
2759                         ; /* Okay here, dangerous in newASSIGNOP */
2760                     else
2761                         break;
2762                 }
2763                 lastop = curop;
2764             }
2765         }
2766         if (curop == repl
2767             && !(repl_has_vars
2768                  && (!PM_GETRE(pm)
2769                      || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
2770             pm->op_pmflags |= PMf_CONST;        /* const for long enough */
2771             pm->op_pmpermflags |= PMf_CONST;    /* const for long enough */
2772             prepend_elem(o->op_type, scalar(repl), o);
2773         }
2774         else {
2775             if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
2776                 pm->op_pmflags |= PMf_MAYBE_CONST;
2777                 pm->op_pmpermflags |= PMf_MAYBE_CONST;
2778             }
2779             NewOp(1101, rcop, 1, LOGOP);
2780             rcop->op_type = OP_SUBSTCONT;
2781             rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
2782             rcop->op_first = scalar(repl);
2783             rcop->op_flags |= OPf_KIDS;
2784             rcop->op_private = 1;
2785             rcop->op_other = o;
2786
2787             /* establish postfix order */
2788             rcop->op_next = LINKLIST(repl);
2789             repl->op_next = (OP*)rcop;
2790
2791             pm->op_pmreplroot = scalar((OP*)rcop);
2792             pm->op_pmreplstart = LINKLIST(rcop);
2793             rcop->op_next = 0;
2794         }
2795     }
2796
2797     return (OP*)pm;
2798 }
2799
2800 OP *
2801 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
2802 {
2803     SVOP *svop;
2804     NewOp(1101, svop, 1, SVOP);
2805     svop->op_type = (OPCODE)type;
2806     svop->op_ppaddr = PL_ppaddr[type];
2807     svop->op_sv = sv;
2808     svop->op_next = (OP*)svop;
2809     svop->op_flags = (U8)flags;
2810     if (PL_opargs[type] & OA_RETSCALAR)
2811         scalar((OP*)svop);
2812     if (PL_opargs[type] & OA_TARGET)
2813         svop->op_targ = pad_alloc(type, SVs_PADTMP);
2814     return CHECKOP(type, svop);
2815 }
2816
2817 OP *
2818 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
2819 {
2820     PADOP *padop;
2821     NewOp(1101, padop, 1, PADOP);
2822     padop->op_type = (OPCODE)type;
2823     padop->op_ppaddr = PL_ppaddr[type];
2824     padop->op_padix = pad_alloc(type, SVs_PADTMP);
2825     SvREFCNT_dec(PAD_SVl(padop->op_padix));
2826     PAD_SETSV(padop->op_padix, sv);
2827     if (sv)
2828         SvPADTMP_on(sv);
2829     padop->op_next = (OP*)padop;
2830     padop->op_flags = (U8)flags;
2831     if (PL_opargs[type] & OA_RETSCALAR)
2832         scalar((OP*)padop);
2833     if (PL_opargs[type] & OA_TARGET)
2834         padop->op_targ = pad_alloc(type, SVs_PADTMP);
2835     return CHECKOP(type, padop);
2836 }
2837
2838 OP *
2839 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
2840 {
2841 #ifdef USE_ITHREADS
2842     if (gv)
2843         GvIN_PAD_on(gv);
2844     return newPADOP(type, flags, SvREFCNT_inc(gv));
2845 #else
2846     return newSVOP(type, flags, SvREFCNT_inc(gv));
2847 #endif
2848 }
2849
2850 OP *
2851 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
2852 {
2853     PVOP *pvop;
2854     NewOp(1101, pvop, 1, PVOP);
2855     pvop->op_type = (OPCODE)type;
2856     pvop->op_ppaddr = PL_ppaddr[type];
2857     pvop->op_pv = pv;
2858     pvop->op_next = (OP*)pvop;
2859     pvop->op_flags = (U8)flags;
2860     if (PL_opargs[type] & OA_RETSCALAR)
2861         scalar((OP*)pvop);
2862     if (PL_opargs[type] & OA_TARGET)
2863         pvop->op_targ = pad_alloc(type, SVs_PADTMP);
2864     return CHECKOP(type, pvop);
2865 }
2866
2867 void
2868 Perl_package(pTHX_ OP *o)
2869 {
2870     char *name;
2871     STRLEN len;
2872
2873     save_hptr(&PL_curstash);
2874     save_item(PL_curstname);
2875
2876     name = SvPV(cSVOPo->op_sv, len);
2877     PL_curstash = gv_stashpvn(name, len, TRUE);
2878     sv_setpvn(PL_curstname, name, len);
2879     op_free(o);
2880
2881     PL_hints |= HINT_BLOCK_SCOPE;
2882     PL_copline = NOLINE;
2883     PL_expect = XSTATE;
2884 }
2885
2886 void
2887 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
2888 {
2889     OP *pack;
2890     OP *imop;
2891     OP *veop;
2892
2893     if (idop->op_type != OP_CONST)
2894         Perl_croak(aTHX_ "Module name must be constant");
2895
2896     veop = Nullop;
2897
2898     if (version != Nullop) {
2899         SV *vesv = ((SVOP*)version)->op_sv;
2900
2901         if (arg == Nullop && !SvNIOKp(vesv)) {
2902             arg = version;
2903         }
2904         else {
2905             OP *pack;
2906             SV *meth;
2907
2908             if (version->op_type != OP_CONST || !SvNIOKp(vesv))
2909                 Perl_croak(aTHX_ "Version number must be constant number");
2910
2911             /* Make copy of idop so we don't free it twice */
2912             pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
2913
2914             /* Fake up a method call to VERSION */
2915             meth = newSVpvn("VERSION",7);
2916             sv_upgrade(meth, SVt_PVIV);
2917             (void)SvIOK_on(meth);
2918             PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
2919             veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
2920                             append_elem(OP_LIST,
2921                                         prepend_elem(OP_LIST, pack, list(version)),
2922                                         newSVOP(OP_METHOD_NAMED, 0, meth)));
2923         }
2924     }
2925
2926     /* Fake up an import/unimport */
2927     if (arg && arg->op_type == OP_STUB)
2928         imop = arg;             /* no import on explicit () */
2929     else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
2930         imop = Nullop;          /* use 5.0; */
2931     }
2932     else {
2933         SV *meth;
2934
2935         /* Make copy of idop so we don't free it twice */
2936         pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
2937
2938         /* Fake up a method call to import/unimport */
2939         meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);
2940         (void)SvUPGRADE(meth, SVt_PVIV);
2941         (void)SvIOK_on(meth);
2942         PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
2943         imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
2944                        append_elem(OP_LIST,
2945                                    prepend_elem(OP_LIST, pack, list(arg)),
2946                                    newSVOP(OP_METHOD_NAMED, 0, meth)));
2947     }
2948
2949     /* Fake up the BEGIN {}, which does its thing immediately. */
2950     newATTRSUB(floor,
2951         newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
2952         Nullop,
2953         Nullop,
2954         append_elem(OP_LINESEQ,
2955             append_elem(OP_LINESEQ,
2956                 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, idop)),
2957                 newSTATEOP(0, Nullch, veop)),
2958             newSTATEOP(0, Nullch, imop) ));
2959
2960     /* The "did you use incorrect case?" warning used to be here.
2961      * The problem is that on case-insensitive filesystems one
2962      * might get false positives for "use" (and "require"):
2963      * "use Strict" or "require CARP" will work.  This causes
2964      * portability problems for the script: in case-strict
2965      * filesystems the script will stop working.
2966      *
2967      * The "incorrect case" warning checked whether "use Foo"
2968      * imported "Foo" to your namespace, but that is wrong, too:
2969      * there is no requirement nor promise in the language that
2970      * a Foo.pm should or would contain anything in package "Foo".
2971      *
2972      * There is very little Configure-wise that can be done, either:
2973      * the case-sensitivity of the build filesystem of Perl does not
2974      * help in guessing the case-sensitivity of the runtime environment.
2975      */
2976
2977     PL_hints |= HINT_BLOCK_SCOPE;
2978     PL_copline = NOLINE;
2979     PL_expect = XSTATE;
2980     PL_cop_seqmax++; /* Purely for B::*'s benefit */
2981 }
2982
2983 /*
2984 =head1 Embedding Functions
2985
2986 =for apidoc load_module
2987
2988 Loads the module whose name is pointed to by the string part of name.
2989 Note that the actual module name, not its filename, should be given.
2990 Eg, "Foo::Bar" instead of "Foo/Bar.pm".  flags can be any of
2991 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
2992 (or 0 for no flags). ver, if specified, provides version semantics
2993 similar to C<use Foo::Bar VERSION>.  The optional trailing SV*
2994 arguments can be used to specify arguments to the module's import()
2995 method, similar to C<use Foo::Bar VERSION LIST>.
2996
2997 =cut */
2998
2999 void
3000 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3001 {
3002     va_list args;
3003     va_start(args, ver);
3004     vload_module(flags, name, ver, &args);
3005     va_end(args);
3006 }
3007
3008 #ifdef PERL_IMPLICIT_CONTEXT
3009 void
3010 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3011 {
3012     dTHX;
3013     va_list args;
3014     va_start(args, ver);
3015     vload_module(flags, name, ver, &args);
3016     va_end(args);
3017 }
3018 #endif
3019
3020 void
3021 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3022 {
3023     OP *modname, *veop, *imop;
3024
3025     modname = newSVOP(OP_CONST, 0, name);
3026     modname->op_private |= OPpCONST_BARE;
3027     if (ver) {
3028         veop = newSVOP(OP_CONST, 0, ver);
3029     }
3030     else
3031         veop = Nullop;
3032     if (flags & PERL_LOADMOD_NOIMPORT) {
3033         imop = sawparens(newNULLLIST());
3034     }
3035     else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3036         imop = va_arg(*args, OP*);
3037     }
3038     else {
3039         SV *sv;
3040         imop = Nullop;
3041         sv = va_arg(*args, SV*);
3042         while (sv) {
3043             imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3044             sv = va_arg(*args, SV*);
3045         }
3046     }
3047     {
3048         line_t ocopline = PL_copline;
3049         COP *ocurcop = PL_curcop;
3050         int oexpect = PL_expect;
3051
3052         utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3053                 veop, modname, imop);
3054         PL_expect = oexpect;
3055         PL_copline = ocopline;
3056         PL_curcop = ocurcop;
3057     }
3058 }
3059
3060 OP *
3061 Perl_dofile(pTHX_ OP *term)
3062 {
3063     OP *doop;
3064     GV *gv;
3065
3066     gv = gv_fetchpv("do", FALSE, SVt_PVCV);
3067     if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
3068         gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3069
3070     if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3071         doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3072                                append_elem(OP_LIST, term,
3073                                            scalar(newUNOP(OP_RV2CV, 0,
3074                                                           newGVOP(OP_GV, 0,
3075                                                                   gv))))));
3076     }
3077     else {
3078         doop = newUNOP(OP_DOFILE, 0, scalar(term));
3079     }
3080     return doop;
3081 }
3082
3083 OP *
3084 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3085 {
3086     return newBINOP(OP_LSLICE, flags,
3087             list(force_list(subscript)),
3088             list(force_list(listval)) );
3089 }
3090
3091 STATIC I32
3092 S_list_assignment(pTHX_ register OP *o)
3093 {
3094     if (!o)
3095         return TRUE;
3096
3097     if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3098         o = cUNOPo->op_first;
3099
3100     if (o->op_type == OP_COND_EXPR) {
3101         I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3102         I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3103
3104         if (t && f)
3105             return TRUE;
3106         if (t || f)
3107             yyerror("Assignment to both a list and a scalar");
3108         return FALSE;
3109     }
3110
3111     if (o->op_type == OP_LIST &&
3112         (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR &&
3113         o->op_private & OPpLVAL_INTRO)
3114         return FALSE;
3115
3116     if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3117         o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3118         o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3119         return TRUE;
3120
3121     if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3122         return TRUE;
3123
3124     if (o->op_type == OP_RV2SV)
3125         return FALSE;
3126
3127     return FALSE;
3128 }
3129
3130 OP *
3131 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3132 {
3133     OP *o;
3134
3135     if (optype) {
3136         if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
3137             return newLOGOP(optype, 0,
3138                 mod(scalar(left), optype),
3139                 newUNOP(OP_SASSIGN, 0, scalar(right)));
3140         }
3141         else {
3142             return newBINOP(optype, OPf_STACKED,
3143                 mod(scalar(left), optype), scalar(right));
3144         }
3145     }
3146
3147     if (list_assignment(left)) {
3148         OP *curop;
3149
3150         PL_modcount = 0;
3151         PL_eval_start = right;  /* Grandfathering $[ assignment here.  Bletch.*/
3152         left = mod(left, OP_AASSIGN);
3153         if (PL_eval_start)
3154             PL_eval_start = 0;
3155         else {
3156             op_free(left);
3157             op_free(right);
3158             return Nullop;
3159         }
3160         /* optimise C<my @x = ()> to C<my @x>, and likewise for hashes */
3161         if ((left->op_type == OP_PADAV || left->op_type == OP_PADHV)
3162                 && right->op_type == OP_STUB
3163                 && (left->op_private & OPpLVAL_INTRO))
3164         {
3165             op_free(right);
3166             left->op_flags &= ~(OPf_REF|OPf_SPECIAL);
3167             return left;
3168         }
3169         curop = list(force_list(left));
3170         o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3171         o->op_private = (U8)(0 | (flags >> 8));
3172
3173         /* PL_generation sorcery:
3174          * an assignment like ($a,$b) = ($c,$d) is easier than
3175          * ($a,$b) = ($c,$a), since there is no need for temporary vars.
3176          * To detect whether there are common vars, the global var
3177          * PL_generation is incremented for each assign op we compile.
3178          * Then, while compiling the assign op, we run through all the
3179          * variables on both sides of the assignment, setting a spare slot
3180          * in each of them to PL_generation. If any of them already have
3181          * that value, we know we've got commonality.  We could use a
3182          * single bit marker, but then we'd have to make 2 passes, first
3183          * to clear the flag, then to test and set it.  To find somewhere
3184          * to store these values, evil chicanery is done with SvCUR().
3185          */
3186
3187         if (!(left->op_private & OPpLVAL_INTRO)) {
3188             OP *lastop = o;
3189             PL_generation++;
3190             for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3191                 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3192                     if (curop->op_type == OP_GV) {
3193                         GV *gv = cGVOPx_gv(curop);
3194                         if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3195                             break;
3196                         SvCUR(gv) = PL_generation;
3197                     }
3198                     else if (curop->op_type == OP_PADSV ||
3199                              curop->op_type == OP_PADAV ||
3200                              curop->op_type == OP_PADHV ||
3201                              curop->op_type == OP_PADANY)
3202                     {
3203                         if (PAD_COMPNAME_GEN(curop->op_targ)
3204                                                     == (STRLEN)PL_generation)
3205                             break;
3206                         PAD_COMPNAME_GEN(curop->op_targ)
3207                                                         = PL_generation;
3208
3209                     }
3210                     else if (curop->op_type == OP_RV2CV)
3211                         break;
3212                     else if (curop->op_type == OP_RV2SV ||
3213                              curop->op_type == OP_RV2AV ||
3214                              curop->op_type == OP_RV2HV ||
3215                              curop->op_type == OP_RV2GV) {
3216                         if (lastop->op_type != OP_GV)   /* funny deref? */
3217                             break;
3218                     }
3219                     else if (curop->op_type == OP_PUSHRE) {
3220                         if (((PMOP*)curop)->op_pmreplroot) {
3221 #ifdef USE_ITHREADS
3222                             GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET,
3223                                         ((PMOP*)curop)->op_pmreplroot));
3224 #else
3225                             GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3226 #endif
3227                             if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3228                                 break;
3229                             SvCUR(gv) = PL_generation;
3230                         }
3231                     }
3232                     else
3233                         break;
3234                 }
3235                 lastop = curop;
3236             }
3237             if (curop != o)
3238                 o->op_private |= OPpASSIGN_COMMON;
3239         }
3240         if (right && right->op_type == OP_SPLIT) {
3241             OP* tmpop;
3242             if ((tmpop = ((LISTOP*)right)->op_first) &&
3243                 tmpop->op_type == OP_PUSHRE)
3244             {
3245                 PMOP *pm = (PMOP*)tmpop;
3246                 if (left->op_type == OP_RV2AV &&
3247                     !(left->op_private & OPpLVAL_INTRO) &&
3248                     !(o->op_private & OPpASSIGN_COMMON) )
3249                 {
3250                     tmpop = ((UNOP*)left)->op_first;
3251                     if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3252 #ifdef USE_ITHREADS
3253                         pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
3254                         cPADOPx(tmpop)->op_padix = 0;   /* steal it */
3255 #else
3256                         pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3257                         cSVOPx(tmpop)->op_sv = Nullsv;  /* steal it */
3258 #endif
3259                         pm->op_pmflags |= PMf_ONCE;
3260                         tmpop = cUNOPo->op_first;       /* to list (nulled) */
3261                         tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3262                         tmpop->op_sibling = Nullop;     /* don't free split */
3263                         right->op_next = tmpop->op_next;  /* fix starting loc */
3264                         op_free(o);                     /* blow off assign */
3265                         right->op_flags &= ~OPf_WANT;
3266                                 /* "I don't know and I don't care." */
3267                         return right;
3268                     }
3269                 }
3270                 else {
3271                    if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3272                       ((LISTOP*)right)->op_last->op_type == OP_CONST)
3273                     {
3274                         SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3275                         if (SvIVX(sv) == 0)
3276                             sv_setiv(sv, PL_modcount+1);
3277                     }
3278                 }
3279             }
3280         }
3281         return o;
3282     }
3283     if (!right)
3284         right = newOP(OP_UNDEF, 0);
3285     if (right->op_type == OP_READLINE) {
3286         right->op_flags |= OPf_STACKED;
3287         return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3288     }
3289     else {
3290         PL_eval_start = right;  /* Grandfathering $[ assignment here.  Bletch.*/
3291         o = newBINOP(OP_SASSIGN, flags,
3292             scalar(right), mod(scalar(left), OP_SASSIGN) );
3293         if (PL_eval_start)
3294             PL_eval_start = 0;
3295         else {
3296             op_free(o);
3297             return Nullop;
3298         }
3299     }
3300     return o;
3301 }
3302
3303 OP *
3304 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3305 {
3306     U32 seq = intro_my();
3307     register COP *cop;
3308
3309     NewOp(1101, cop, 1, COP);
3310     if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3311         cop->op_type = OP_DBSTATE;
3312         cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3313     }
3314     else {
3315         cop->op_type = OP_NEXTSTATE;
3316         cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3317     }
3318     cop->op_flags = (U8)flags;
3319     cop->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
3320 #ifdef NATIVE_HINTS
3321     cop->op_private |= NATIVE_HINTS;
3322 #endif
3323     PL_compiling.op_private = cop->op_private;
3324     cop->op_next = (OP*)cop;
3325
3326     if (label) {
3327         cop->cop_label = label;
3328         PL_hints |= HINT_BLOCK_SCOPE;
3329     }
3330     cop->cop_seq = seq;
3331     cop->cop_arybase = PL_curcop->cop_arybase;
3332     if (specialWARN(PL_curcop->cop_warnings))
3333         cop->cop_warnings = PL_curcop->cop_warnings ;
3334     else
3335         cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3336     if (specialCopIO(PL_curcop->cop_io))
3337         cop->cop_io = PL_curcop->cop_io;
3338     else
3339         cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3340
3341
3342     if (PL_copline == NOLINE)
3343         CopLINE_set(cop, CopLINE(PL_curcop));
3344     else {
3345         CopLINE_set(cop, PL_copline);
3346         PL_copline = NOLINE;
3347     }
3348 #ifdef USE_ITHREADS
3349     CopFILE_set(cop, CopFILE(PL_curcop));       /* XXX share in a pvtable? */
3350 #else
3351     CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3352 #endif
3353     CopSTASH_set(cop, PL_curstash);
3354
3355     if (PERLDB_LINE && PL_curstash != PL_debstash) {
3356         SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3357         if (svp && *svp != &PL_sv_undef ) {
3358            (void)SvIOK_on(*svp);
3359             SvIVX(*svp) = PTR2IV(cop);
3360         }
3361     }
3362
3363     return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3364 }
3365
3366
3367 OP *
3368 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3369 {
3370     return new_logop(type, flags, &first, &other);
3371 }
3372
3373 STATIC OP *
3374 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3375 {
3376     LOGOP *logop;
3377     OP *o;
3378     OP *first = *firstp;
3379     OP *other = *otherp;
3380
3381     if (type == OP_XOR)         /* Not short circuit, but here by precedence. */
3382         return newBINOP(type, flags, scalar(first), scalar(other));
3383
3384     scalarboolean(first);
3385     /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3386     if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3387         if (type == OP_AND || type == OP_OR) {
3388             if (type == OP_AND)
3389                 type = OP_OR;
3390             else
3391                 type = OP_AND;
3392             o = first;
3393             first = *firstp = cUNOPo->op_first;
3394             if (o->op_next)
3395                 first->op_next = o->op_next;
3396             cUNOPo->op_first = Nullop;
3397             op_free(o);
3398         }
3399     }
3400     if (first->op_type == OP_CONST) {
3401         if (first->op_private & OPpCONST_STRICT)
3402             no_bareword_allowed(first);
3403         else if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
3404                 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
3405         if ((type == OP_AND &&  SvTRUE(((SVOP*)first)->op_sv)) ||
3406             (type == OP_OR  && !SvTRUE(((SVOP*)first)->op_sv)) ||
3407             (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) {
3408             op_free(first);
3409             *firstp = Nullop;
3410             if (other->op_type == OP_CONST)
3411                 other->op_private |= OPpCONST_SHORTCIRCUIT;
3412             return other;
3413         }
3414         else {
3415             /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
3416             OP *o2 = other;
3417             if ( ! (o2->op_type == OP_LIST
3418                     && (( o2 = cUNOPx(o2)->op_first))
3419                     && o2->op_type == OP_PUSHMARK
3420                     && (( o2 = o2->op_sibling)) )
3421             )
3422                 o2 = other;
3423             if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
3424                         || o2->op_type == OP_PADHV)
3425                 && o2->op_private & OPpLVAL_INTRO
3426                 && ckWARN(WARN_DEPRECATED))
3427             {
3428                 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
3429                             "Deprecated use of my() in false conditional");
3430             }
3431
3432             op_free(other);
3433             *otherp = Nullop;
3434             if (first->op_type == OP_CONST)
3435                 first->op_private |= OPpCONST_SHORTCIRCUIT;
3436             return first;
3437         }
3438     }
3439     else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS) &&
3440              type != OP_DOR) /* [#24076] Don't warn for <FH> err FOO. */
3441     {
3442         OP *k1 = ((UNOP*)first)->op_first;
3443         OP *k2 = k1->op_sibling;
3444         OPCODE warnop = 0;
3445         switch (first->op_type)
3446         {
3447         case OP_NULL:
3448             if (k2 && k2->op_type == OP_READLINE
3449                   && (k2->op_flags & OPf_STACKED)
3450                   && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3451             {
3452                 warnop = k2->op_type;
3453             }
3454             break;
3455
3456         case OP_SASSIGN:
3457             if (k1->op_type == OP_READDIR
3458                   || k1->op_type == OP_GLOB
3459                   || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3460                   || k1->op_type == OP_EACH)
3461             {
3462                 warnop = ((k1->op_type == OP_NULL)
3463                           ? (OPCODE)k1->op_targ : k1->op_type);
3464             }
3465             break;
3466         }
3467         if (warnop) {
3468             line_t oldline = CopLINE(PL_curcop);
3469             CopLINE_set(PL_curcop, PL_copline);
3470             Perl_warner(aTHX_ packWARN(WARN_MISC),
3471                  "Value of %s%s can be \"0\"; test with defined()",
3472                  PL_op_desc[warnop],
3473                  ((warnop == OP_READLINE || warnop == OP_GLOB)
3474                   ? " construct" : "() operator"));
3475             CopLINE_set(PL_curcop, oldline);
3476         }
3477     }
3478
3479     if (!other)
3480         return first;
3481
3482     if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
3483         other->op_private |= OPpASSIGN_BACKWARDS;  /* other is an OP_SASSIGN */
3484
3485     NewOp(1101, logop, 1, LOGOP);
3486
3487     logop->op_type = (OPCODE)type;
3488     logop->op_ppaddr = PL_ppaddr[type];
3489     logop->op_first = first;
3490     logop->op_flags = flags | OPf_KIDS;
3491     logop->op_other = LINKLIST(other);
3492     logop->op_private = (U8)(1 | (flags >> 8));
3493
3494     /* establish postfix order */
3495     logop->op_next = LINKLIST(first);
3496     first->op_next = (OP*)logop;
3497     first->op_sibling = other;
3498
3499     CHECKOP(type,logop);
3500
3501     o = newUNOP(OP_NULL, 0, (OP*)logop);
3502     other->op_next = o;
3503
3504     return o;
3505 }
3506
3507 OP *
3508 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3509 {
3510     LOGOP *logop;
3511     OP *start;
3512     OP *o;
3513
3514     if (!falseop)
3515         return newLOGOP(OP_AND, 0, first, trueop);
3516     if (!trueop)
3517         return newLOGOP(OP_OR, 0, first, falseop);
3518
3519     scalarboolean(first);
3520     if (first->op_type == OP_CONST) {
3521         if (first->op_private & OPpCONST_BARE &&
3522            first->op_private & OPpCONST_STRICT) {
3523            no_bareword_allowed(first);
3524        }
3525         if (SvTRUE(((SVOP*)first)->op_sv)) {
3526             op_free(first);
3527             op_free(falseop);
3528             return trueop;
3529         }
3530         else {
3531             op_free(first);
3532             op_free(trueop);
3533             return falseop;
3534         }
3535     }
3536     NewOp(1101, logop, 1, LOGOP);
3537     logop->op_type = OP_COND_EXPR;
3538     logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3539     logop->op_first = first;
3540     logop->op_flags = flags | OPf_KIDS;
3541     logop->op_private = (U8)(1 | (flags >> 8));
3542     logop->op_other = LINKLIST(trueop);
3543     logop->op_next = LINKLIST(falseop);
3544
3545     CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
3546             logop);
3547
3548     /* establish postfix order */
3549     start = LINKLIST(first);
3550     first->op_next = (OP*)logop;
3551
3552     first->op_sibling = trueop;
3553     trueop->op_sibling = falseop;
3554     o = newUNOP(OP_NULL, 0, (OP*)logop);
3555
3556     trueop->op_next = falseop->op_next = o;
3557
3558     o->op_next = start;
3559     return o;
3560 }
3561
3562 OP *
3563 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3564 {
3565     LOGOP *range;
3566     OP *flip;
3567     OP *flop;
3568     OP *leftstart;
3569     OP *o;
3570
3571     NewOp(1101, range, 1, LOGOP);
3572
3573     range->op_type = OP_RANGE;
3574     range->op_ppaddr = PL_ppaddr[OP_RANGE];
3575     range->op_first = left;
3576     range->op_flags = OPf_KIDS;
3577     leftstart = LINKLIST(left);
3578     range->op_other = LINKLIST(right);
3579     range->op_private = (U8)(1 | (flags >> 8));
3580
3581     left->op_sibling = right;
3582
3583     range->op_next = (OP*)range;
3584     flip = newUNOP(OP_FLIP, flags, (OP*)range);
3585     flop = newUNOP(OP_FLOP, 0, flip);
3586     o = newUNOP(OP_NULL, 0, flop);
3587     linklist(flop);
3588     range->op_next = leftstart;
3589
3590     left->op_next = flip;
3591     right->op_next = flop;
3592
3593     range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3594     sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3595     flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3596     sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3597
3598     flip->op_private =  left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3599     flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3600
3601     flip->op_next = o;
3602     if (!flip->op_private || !flop->op_private)
3603         linklist(o);            /* blow off optimizer unless constant */
3604
3605     return o;
3606 }
3607
3608 OP *
3609 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3610 {
3611     OP* listop;
3612     OP* o;
3613     int once = block && block->op_flags & OPf_SPECIAL &&
3614       (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3615
3616     if (expr) {
3617         if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3618             return block;       /* do {} while 0 does once */
3619         if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3620             || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3621             expr = newUNOP(OP_DEFINED, 0,
3622                 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3623         } else if (expr->op_flags & OPf_KIDS) {
3624             OP *k1 = ((UNOP*)expr)->op_first;
3625             OP *k2 = (k1) ? k1->op_sibling : NULL;
3626             switch (expr->op_type) {
3627               case OP_NULL:
3628                 if (k2 && k2->op_type == OP_READLINE
3629                       && (k2->op_flags & OPf_STACKED)
3630                       && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3631                     expr = newUNOP(OP_DEFINED, 0, expr);
3632                 break;
3633
3634               case OP_SASSIGN:
3635                 if (k1->op_type == OP_READDIR
3636                       || k1->op_type == OP_GLOB
3637                       || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3638                       || k1->op_type == OP_EACH)
3639                     expr = newUNOP(OP_DEFINED, 0, expr);
3640                 break;
3641             }
3642         }
3643     }
3644
3645     /* if block is null, the next append_elem() would put UNSTACK, a scalar
3646      * op, in listop. This is wrong. [perl #27024] */
3647     if (!block)
3648         block = newOP(OP_NULL, 0);
3649     listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3650     o = new_logop(OP_AND, 0, &expr, &listop);
3651
3652     if (listop)
3653         ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3654
3655     if (once && o != listop)
3656         o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3657
3658     if (o == listop)
3659         o = newUNOP(OP_NULL, 0, o);     /* or do {} while 1 loses outer block */
3660
3661     o->op_flags |= flags;
3662     o = scope(o);
3663     o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3664     return o;
3665 }
3666
3667 OP *
3668 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
3669 {
3670     OP *redo;
3671     OP *next = 0;
3672     OP *listop;
3673     OP *o;
3674     U8 loopflags = 0;
3675
3676     if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3677                  || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
3678         expr = newUNOP(OP_DEFINED, 0,
3679             newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3680     } else if (expr && (expr->op_flags & OPf_KIDS)) {
3681         OP *k1 = ((UNOP*)expr)->op_first;
3682         OP *k2 = (k1) ? k1->op_sibling : NULL;
3683         switch (expr->op_type) {
3684           case OP_NULL:
3685             if (k2 && k2->op_type == OP_READLINE
3686                   && (k2->op_flags & OPf_STACKED)
3687                   && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3688                 expr = newUNOP(OP_DEFINED, 0, expr);
3689             break;
3690
3691           case OP_SASSIGN:
3692             if (k1->op_type == OP_READDIR
3693                   || k1->op_type == OP_GLOB
3694                   || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3695                   || k1->op_type == OP_EACH)
3696                 expr = newUNOP(OP_DEFINED, 0, expr);
3697             break;
3698         }
3699     }
3700
3701     if (!block)
3702         block = newOP(OP_NULL, 0);
3703     else if (cont) {
3704         block = scope(block);
3705     }
3706
3707     if (cont) {
3708         next = LINKLIST(cont);
3709     }
3710     if (expr) {
3711         OP *unstack = newOP(OP_UNSTACK, 0);
3712         if (!next)
3713             next = unstack;
3714         cont = append_elem(OP_LINESEQ, cont, unstack);
3715     }
3716
3717     listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
3718     redo = LINKLIST(listop);
3719
3720     if (expr) {
3721         PL_copline = (line_t)whileline;
3722         scalar(listop);
3723         o = new_logop(OP_AND, 0, &expr, &listop);
3724         if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
3725             op_free(expr);              /* oops, it's a while (0) */
3726             op_free((OP*)loop);
3727             return Nullop;              /* listop already freed by new_logop */
3728         }
3729         if (listop)
3730             ((LISTOP*)listop)->op_last->op_next =
3731                 (o == listop ? redo : LINKLIST(o));
3732     }
3733     else
3734         o = listop;
3735
3736     if (!loop) {
3737         NewOp(1101,loop,1,LOOP);
3738         loop->op_type = OP_ENTERLOOP;
3739         loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
3740         loop->op_private = 0;
3741         loop->op_next = (OP*)loop;
3742     }
3743
3744     o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
3745
3746     loop->op_redoop = redo;
3747     loop->op_lastop = o;
3748     o->op_private |= loopflags;
3749
3750     if (next)
3751         loop->op_nextop = next;
3752     else
3753         loop->op_nextop = o;
3754
3755     o->op_flags |= flags;
3756     o->op_private |= (flags >> 8);
3757     return o;
3758 }
3759
3760 OP *
3761 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
3762 {
3763     LOOP *loop;
3764     OP *wop;
3765     PADOFFSET padoff = 0;
3766     I32 iterflags = 0;
3767     I32 iterpflags = 0;
3768
3769     if (sv) {
3770         if (sv->op_type == OP_RV2SV) {  /* symbol table variable */
3771             iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
3772             sv->op_type = OP_RV2GV;
3773             sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
3774         }
3775         else if (sv->op_type == OP_PADSV) { /* private variable */
3776             iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
3777             padoff = sv->op_targ;
3778             sv->op_targ = 0;
3779             op_free(sv);
3780             sv = Nullop;
3781         }
3782         else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
3783             padoff = sv->op_targ;
3784             sv->op_targ = 0;
3785             iterflags |= OPf_SPECIAL;
3786             op_free(sv);
3787             sv = Nullop;
3788         }
3789         else
3790             Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
3791     }
3792     else {
3793         I32 offset = pad_findmy("$_");
3794         if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
3795             sv = newGVOP(OP_GV, 0, PL_defgv);
3796         }
3797         else {
3798             padoff = offset;
3799         }
3800     }
3801     if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
3802         expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
3803         iterflags |= OPf_STACKED;
3804     }
3805     else if (expr->op_type == OP_NULL &&
3806              (expr->op_flags & OPf_KIDS) &&
3807              ((BINOP*)expr)->op_first->op_type == OP_FLOP)
3808     {
3809         /* Basically turn for($x..$y) into the same as for($x,$y), but we
3810          * set the STACKED flag to indicate that these values are to be
3811          * treated as min/max values by 'pp_iterinit'.
3812          */
3813         UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
3814         LOGOP* range = (LOGOP*) flip->op_first;
3815         OP* left  = range->op_first;
3816         OP* right = left->op_sibling;
3817         LISTOP* listop;
3818
3819         range->op_flags &= ~OPf_KIDS;
3820         range->op_first = Nullop;
3821
3822         listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
3823         listop->op_first->op_next = range->op_next;
3824         left->op_next = range->op_other;
3825         right->op_next = (OP*)listop;
3826         listop->op_next = listop->op_first;
3827
3828         op_free(expr);
3829         expr = (OP*)(listop);
3830         op_null(expr);
3831         iterflags |= OPf_STACKED;
3832     }
3833     else {
3834         expr = mod(force_list(expr), OP_GREPSTART);
3835     }
3836
3837
3838     loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
3839                                append_elem(OP_LIST, expr, scalar(sv))));
3840     assert(!loop->op_next);
3841     /* for my  $x () sets OPpLVAL_INTRO;
3842      * for our $x () sets OPpOUR_INTRO */
3843     loop->op_private = (U8)iterpflags;
3844 #ifdef PL_OP_SLAB_ALLOC
3845     {
3846         LOOP *tmp;
3847         NewOp(1234,tmp,1,LOOP);
3848         Copy(loop,tmp,1,LOOP);
3849         FreeOp(loop);
3850         loop = tmp;
3851     }
3852 #else
3853     Renew(loop, 1, LOOP);
3854 #endif
3855     loop->op_targ = padoff;
3856     wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
3857     PL_copline = forline;
3858     return newSTATEOP(0, label, wop);
3859 }
3860
3861 OP*
3862 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
3863 {
3864     OP *o;
3865     STRLEN n_a;
3866
3867     if (type != OP_GOTO || label->op_type == OP_CONST) {
3868         /* "last()" means "last" */
3869         if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
3870             o = newOP(type, OPf_SPECIAL);
3871         else {
3872             o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
3873                                         ? SvPVx(((SVOP*)label)->op_sv, n_a)
3874                                         : ""));
3875         }
3876         op_free(label);
3877     }
3878     else {
3879         /* Check whether it's going to be a goto &function */
3880         if (label->op_type == OP_ENTERSUB
3881                 && !(label->op_flags & OPf_STACKED))
3882             label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
3883         o = newUNOP(type, OPf_STACKED, label);
3884     }
3885     PL_hints |= HINT_BLOCK_SCOPE;
3886     return o;
3887 }
3888
3889 /*
3890 =for apidoc cv_undef
3891
3892 Clear out all the active components of a CV. This can happen either
3893 by an explicit C<undef &foo>, or by the reference count going to zero.
3894 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
3895 children can still follow the full lexical scope chain.
3896
3897 =cut
3898 */
3899
3900 void
3901 Perl_cv_undef(pTHX_ CV *cv)
3902 {
3903 #ifdef USE_ITHREADS
3904     if (CvFILE(cv) && !CvXSUB(cv)) {
3905         /* for XSUBs CvFILE point directly to static memory; __FILE__ */
3906         Safefree(CvFILE(cv));
3907     }
3908     CvFILE(cv) = 0;
3909 #endif
3910
3911     if (!CvXSUB(cv) && CvROOT(cv)) {
3912         if (CvDEPTH(cv))
3913             Perl_croak(aTHX_ "Can't undef active subroutine");
3914         ENTER;
3915
3916         PAD_SAVE_SETNULLPAD();
3917
3918         op_free(CvROOT(cv));
3919         CvROOT(cv) = Nullop;
3920         LEAVE;
3921     }
3922     SvPOK_off((SV*)cv);         /* forget prototype */
3923     CvGV(cv) = Nullgv;
3924
3925     pad_undef(cv);
3926
3927     /* remove CvOUTSIDE unless this is an undef rather than a free */
3928     if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
3929         if (!CvWEAKOUTSIDE(cv))
3930             SvREFCNT_dec(CvOUTSIDE(cv));
3931         CvOUTSIDE(cv) = Nullcv;
3932     }
3933     if (CvCONST(cv)) {
3934         SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
3935         CvCONST_off(cv);
3936     }
3937     if (CvXSUB(cv)) {
3938         CvXSUB(cv) = 0;
3939     }
3940     /* delete all flags except WEAKOUTSIDE */
3941     CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
3942 }
3943
3944 void
3945 Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
3946 {
3947     if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
3948         SV* msg = sv_newmortal();
3949         SV* name = Nullsv;
3950
3951         if (gv)
3952             gv_efullname3(name = sv_newmortal(), gv, Nullch);
3953         sv_setpv(msg, "Prototype mismatch:");
3954         if (name)
3955             Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
3956         if (SvPOK(cv))
3957             Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (SV *)cv);
3958         else
3959             Perl_sv_catpvf(aTHX_ msg, ": none");
3960         sv_catpv(msg, " vs ");
3961         if (p)
3962             Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
3963         else
3964             sv_catpv(msg, "none");
3965         Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, msg);
3966     }
3967 }
3968
3969 static void const_sv_xsub(pTHX_ CV* cv);
3970
3971 /*
3972
3973 =head1 Optree Manipulation Functions
3974
3975 =for apidoc cv_const_sv
3976
3977 If C<cv> is a constant sub eligible for inlining. returns the constant
3978 value returned by the sub.  Otherwise, returns NULL.
3979
3980 Constant subs can be created with C<newCONSTSUB> or as described in
3981 L<perlsub/"Constant Functions">.
3982
3983 =cut
3984 */
3985 SV *
3986 Perl_cv_const_sv(pTHX_ CV *cv)
3987 {
3988     if (!cv || !CvCONST(cv))
3989         return Nullsv;
3990     return (SV*)CvXSUBANY(cv).any_ptr;
3991 }
3992
3993 /* op_const_sv:  examine an optree to determine whether it's in-lineable.
3994  * Can be called in 3 ways:
3995  *
3996  * !cv
3997  *      look for a single OP_CONST with attached value: return the value
3998  *
3999  * cv && CvCLONE(cv) && !CvCONST(cv)
4000  *
4001  *      examine the clone prototype, and if contains only a single
4002  *      OP_CONST referencing a pad const, or a single PADSV referencing
4003  *      an outer lexical, return a non-zero value to indicate the CV is
4004  *      a candidate for "constizing" at clone time
4005  *
4006  * cv && CvCONST(cv)
4007  *
4008  *      We have just cloned an anon prototype that was marked as a const
4009  *      candidiate. Try to grab the current value, and in the case of
4010  *      PADSV, ignore it if it has multiple references. Return the value.
4011  */
4012
4013 SV *
4014 Perl_op_const_sv(pTHX_ OP *o, CV *cv)
4015 {
4016     SV *sv = Nullsv;
4017
4018     if (!o)
4019         return Nullsv;
4020
4021     if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4022         o = cLISTOPo->op_first->op_sibling;
4023
4024     for (; o; o = o->op_next) {
4025         OPCODE type = o->op_type;
4026
4027         if (sv && o->op_next == o)
4028             return sv;
4029         if (o->op_next != o) {
4030             if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4031                 continue;
4032             if (type == OP_DBSTATE)
4033                 continue;
4034         }
4035         if (type == OP_LEAVESUB || type == OP_RETURN)
4036             break;
4037         if (sv)
4038             return Nullsv;
4039         if (type == OP_CONST && cSVOPo->op_sv)
4040             sv = cSVOPo->op_sv;
4041         else if (cv && type == OP_CONST) {
4042             sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4043             if (!sv)
4044                 return Nullsv;
4045         }
4046         else if (cv && type == OP_PADSV) {
4047             if (CvCONST(cv)) { /* newly cloned anon */
4048                 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4049                 /* the candidate should have 1 ref from this pad and 1 ref
4050                  * from the parent */
4051                 if (!sv || SvREFCNT(sv) != 2)
4052                     return Nullsv;
4053                 sv = newSVsv(sv);
4054                 SvREADONLY_on(sv);
4055                 return sv;
4056             }
4057             else {
4058                 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
4059                     sv = &PL_sv_undef; /* an arbitrary non-null value */
4060             }
4061         }
4062         else {
4063             return Nullsv;
4064         }
4065     }
4066     return sv;
4067 }
4068
4069 void
4070 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4071 {
4072     if (o)
4073         SAVEFREEOP(o);
4074     if (proto)
4075         SAVEFREEOP(proto);
4076     if (attrs)
4077         SAVEFREEOP(attrs);
4078     if (block)
4079         SAVEFREEOP(block);
4080     Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4081 }
4082
4083 CV *
4084 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4085 {
4086     return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4087 }
4088
4089 CV *
4090 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4091 {
4092     STRLEN n_a;
4093     char *name;
4094     char *aname;
4095     GV *gv;
4096     char *ps;
4097     register CV *cv=0;
4098     SV *const_sv;
4099
4100     name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4101
4102     if (proto) {
4103         assert(proto->op_type == OP_CONST);
4104         ps = SvPVx(((SVOP*)proto)->op_sv, n_a);
4105     }
4106     else
4107         ps = Nullch;
4108
4109     if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4110         SV *sv = sv_newmortal();
4111         Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
4112                        PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
4113                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4114         aname = SvPVX(sv);
4115     }
4116     else
4117         aname = Nullch;
4118     gv = gv_fetchpv(name ? name : (aname ? aname :
4119                     (PL_curstash ? "__ANON__" : "__ANON__::__ANON__")),
4120                     GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4121                     SVt_PVCV);
4122
4123     if (o)
4124         SAVEFREEOP(o);
4125     if (proto)
4126         SAVEFREEOP(proto);
4127     if (attrs)
4128         SAVEFREEOP(attrs);
4129
4130     if (SvTYPE(gv) != SVt_PVGV) {       /* Maybe prototype now, and had at
4131                                            maximum a prototype before. */
4132         if (SvTYPE(gv) > SVt_NULL) {
4133             if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4134                 && ckWARN_d(WARN_PROTOTYPE))
4135             {
4136                 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
4137             }
4138             cv_ckproto((CV*)gv, NULL, ps);
4139         }
4140         if (ps)
4141             sv_setpv((SV*)gv, ps);
4142         else
4143             sv_setiv((SV*)gv, -1);
4144         SvREFCNT_dec(PL_compcv);
4145         cv = PL_compcv = NULL;
4146         PL_sub_generation++;
4147         goto done;
4148     }
4149
4150     cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4151
4152 #ifdef GV_UNIQUE_CHECK
4153     if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4154         Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
4155     }
4156 #endif
4157
4158     if (!block || !ps || *ps || attrs)
4159         const_sv = Nullsv;
4160     else
4161         const_sv = op_const_sv(block, Nullcv);
4162
4163     if (cv) {
4164         bool exists = CvROOT(cv) || CvXSUB(cv);
4165
4166 #ifdef GV_UNIQUE_CHECK
4167         if (exists && GvUNIQUE(gv)) {
4168             Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
4169         }
4170 #endif
4171
4172         /* if the subroutine doesn't exist and wasn't pre-declared
4173          * with a prototype, assume it will be AUTOLOADed,
4174          * skipping the prototype check
4175          */
4176         if (exists || SvPOK(cv))
4177             cv_ckproto(cv, gv, ps);
4178         /* already defined (or promised)? */
4179         if (exists || GvASSUMECV(gv)) {
4180             if (!block && !attrs) {
4181                 if (CvFLAGS(PL_compcv)) {
4182                     /* might have had built-in attrs applied */
4183                     CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4184                 }
4185                 /* just a "sub foo;" when &foo is already defined */
4186                 SAVEFREESV(PL_compcv);
4187                 goto done;
4188             }
4189             /* ahem, death to those who redefine active sort subs */
4190             if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4191                 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4192             if (block) {
4193                 if (ckWARN(WARN_REDEFINE)
4194                     || (CvCONST(cv)
4195                         && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4196                 {
4197                     line_t oldline = CopLINE(PL_curcop);
4198                     if (PL_copline != NOLINE)
4199                         CopLINE_set(PL_curcop, PL_copline);
4200                     Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4201                         CvCONST(cv) ? "Constant subroutine %s redefined"
4202                                     : "Subroutine %s redefined", name);
4203                     CopLINE_set(PL_curcop, oldline);
4204                 }
4205                 SvREFCNT_dec(cv);
4206                 cv = Nullcv;
4207             }
4208         }
4209     }
4210     if (const_sv) {
4211         SvREFCNT_inc(const_sv);
4212         if (cv) {
4213             assert(!CvROOT(cv) && !CvCONST(cv));
4214             sv_setpv((SV*)cv, "");  /* prototype is "" */
4215             CvXSUBANY(cv).any_ptr = const_sv;
4216             CvXSUB(cv) = const_sv_xsub;
4217             CvCONST_on(cv);
4218         }
4219         else {
4220             GvCV(gv) = Nullcv;
4221             cv = newCONSTSUB(NULL, name, const_sv);
4222         }
4223         op_free(block);
4224         SvREFCNT_dec(PL_compcv);
4225         PL_compcv = NULL;
4226         PL_sub_generation++;
4227         goto done;
4228     }
4229     if (attrs) {
4230         HV *stash;
4231         SV *rcv;
4232
4233         /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4234          * before we clobber PL_compcv.
4235          */
4236         if (cv && !block) {
4237             rcv = (SV*)cv;
4238             /* Might have had built-in attributes applied -- propagate them. */
4239             CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4240             if (CvGV(cv) && GvSTASH(CvGV(cv)))
4241                 stash = GvSTASH(CvGV(cv));
4242             else if (CvSTASH(cv))
4243                 stash = CvSTASH(cv);
4244             else
4245                 stash = PL_curstash;
4246         }
4247         else {
4248             /* possibly about to re-define existing subr -- ignore old cv */
4249             rcv = (SV*)PL_compcv;
4250             if (name && GvSTASH(gv))
4251                 stash = GvSTASH(gv);
4252             else
4253                 stash = PL_curstash;
4254         }
4255         apply_attrs(stash, rcv, attrs, FALSE);
4256     }
4257     if (cv) {                           /* must reuse cv if autoloaded */
4258         if (!block) {
4259             /* got here with just attrs -- work done, so bug out */
4260             SAVEFREESV(PL_compcv);
4261             goto done;
4262         }
4263         /* transfer PL_compcv to cv */
4264         cv_undef(cv);
4265         CvFLAGS(cv) = CvFLAGS(PL_compcv);
4266         if (!CvWEAKOUTSIDE(cv))
4267             SvREFCNT_dec(CvOUTSIDE(cv));
4268         CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4269         CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
4270         CvOUTSIDE(PL_compcv) = 0;
4271         CvPADLIST(cv) = CvPADLIST(PL_compcv);
4272         CvPADLIST(PL_compcv) = 0;
4273         /* inner references to PL_compcv must be fixed up ... */
4274         pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
4275         /* ... before we throw it away */
4276         SvREFCNT_dec(PL_compcv);
4277         PL_compcv = cv;
4278         if (PERLDB_INTER)/* Advice debugger on the new sub. */
4279           ++PL_sub_generation;
4280     }
4281     else {
4282         cv = PL_compcv;
4283         if (name) {
4284             GvCV(gv) = cv;
4285             GvCVGEN(gv) = 0;
4286             PL_sub_generation++;
4287         }
4288     }
4289     CvGV(cv) = gv;
4290     CvFILE_set_from_cop(cv, PL_curcop);
4291     CvSTASH(cv) = PL_curstash;
4292
4293     if (ps)
4294         sv_setpv((SV*)cv, ps);
4295
4296     if (PL_error_count) {
4297         op_free(block);
4298         block = Nullop;
4299         if (name) {
4300             char *s = strrchr(name, ':');
4301             s = s ? s+1 : name;
4302             if (strEQ(s, "BEGIN")) {
4303                 char *not_safe =
4304                     "BEGIN not safe after errors--compilation aborted";
4305                 if (PL_in_eval & EVAL_KEEPERR)
4306                     Perl_croak(aTHX_ not_safe);
4307                 else {
4308                     /* force display of errors found but not reported */
4309                     sv_catpv(ERRSV, not_safe);
4310                     Perl_croak(aTHX_ "%"SVf, ERRSV);
4311                 }
4312             }
4313         }
4314     }
4315     if (!block)
4316         goto done;
4317
4318     if (CvLVALUE(cv)) {
4319         CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4320                              mod(scalarseq(block), OP_LEAVESUBLV));
4321     }
4322     else {
4323         /* This makes sub {}; work as expected.  */
4324         if (block->op_type == OP_STUB) {
4325             op_free(block);
4326             block = newSTATEOP(0, Nullch, 0);
4327         }
4328         CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4329     }
4330     CvROOT(cv)->op_private |= OPpREFCOUNTED;
4331     OpREFCNT_set(CvROOT(cv), 1);
4332     CvSTART(cv) = LINKLIST(CvROOT(cv));
4333     CvROOT(cv)->op_next = 0;
4334     CALL_PEEP(CvSTART(cv));
4335
4336     /* now that optimizer has done its work, adjust pad values */
4337
4338     pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
4339
4340     if (CvCLONE(cv)) {
4341         assert(!CvCONST(cv));
4342         if (ps && !*ps && op_const_sv(block, cv))
4343             CvCONST_on(cv);
4344     }
4345
4346     if (name || aname) {
4347         char *s;
4348         char *tname = (name ? name : aname);
4349
4350         if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4351             SV *sv = NEWSV(0,0);
4352             SV *tmpstr = sv_newmortal();
4353             GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4354             CV *pcv;
4355             HV *hv;
4356
4357             Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4358                            CopFILE(PL_curcop),
4359                            (long)PL_subline, (long)CopLINE(PL_curcop));
4360             gv_efullname3(tmpstr, gv, Nullch);
4361             hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
4362             hv = GvHVn(db_postponed);
4363             if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
4364                 && (pcv = GvCV(db_postponed)))
4365             {
4366                 dSP;
4367                 PUSHMARK(SP);
4368                 XPUSHs(tmpstr);
4369                 PUTBACK;
4370                 call_sv((SV*)pcv, G_DISCARD);
4371             }
4372         }
4373
4374         if ((s = strrchr(tname,':')))
4375             s++;
4376         else
4377             s = tname;
4378
4379         if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4380             goto done;
4381
4382         if (strEQ(s, "BEGIN") && !PL_error_count) {
4383             I32 oldscope = PL_scopestack_ix;
4384             ENTER;
4385             SAVECOPFILE(&PL_compiling);
4386             SAVECOPLINE(&PL_compiling);
4387
4388             if (!PL_beginav)
4389                 PL_beginav = newAV();
4390             DEBUG_x( dump_sub(gv) );
4391             av_push(PL_beginav, (SV*)cv);
4392             GvCV(gv) = 0;               /* cv has been hijacked */
4393             call_list(oldscope, PL_beginav);
4394
4395             PL_curcop = &PL_compiling;
4396             PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4397             LEAVE;
4398         }
4399         else if (strEQ(s, "END") && !PL_error_count) {
4400             if (!PL_endav)
4401                 PL_endav = newAV();
4402             DEBUG_x( dump_sub(gv) );
4403             av_unshift(PL_endav, 1);
4404             av_store(PL_endav, 0, (SV*)cv);
4405             GvCV(gv) = 0;               /* cv has been hijacked */
4406         }
4407         else if (strEQ(s, "CHECK") && !PL_error_count) {
4408             if (!PL_checkav)
4409                 PL_checkav = newAV();
4410             DEBUG_x( dump_sub(gv) );
4411             if (PL_main_start && ckWARN(WARN_VOID))
4412                 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4413             av_unshift(PL_checkav, 1);
4414             av_store(PL_checkav, 0, (SV*)cv);
4415             GvCV(gv) = 0;               /* cv has been hijacked */
4416         }
4417         else if (strEQ(s, "INIT") && !PL_error_count) {
4418             if (!PL_initav)
4419                 PL_initav = newAV();
4420             DEBUG_x( dump_sub(gv) );
4421             if (PL_main_start && ckWARN(WARN_VOID))
4422                 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4423             av_push(PL_initav, (SV*)cv);
4424             GvCV(gv) = 0;               /* cv has been hijacked */
4425         }
4426     }
4427
4428   done:
4429     PL_copline = NOLINE;
4430     LEAVE_SCOPE(floor);
4431     return cv;
4432 }
4433
4434 /* XXX unsafe for threads if eval_owner isn't held */
4435 /*
4436 =for apidoc newCONSTSUB
4437
4438 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4439 eligible for inlining at compile-time.
4440
4441 =cut
4442 */
4443
4444 CV *
4445 Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
4446 {
4447     CV* cv;
4448
4449     ENTER;
4450
4451     SAVECOPLINE(PL_curcop);
4452     CopLINE_set(PL_curcop, PL_copline);
4453
4454     SAVEHINTS();
4455     PL_hints &= ~HINT_BLOCK_SCOPE;
4456
4457     if (stash) {
4458         SAVESPTR(PL_curstash);
4459         SAVECOPSTASH(PL_curcop);
4460         PL_curstash = stash;
4461         CopSTASH_set(PL_curcop,stash);
4462     }
4463
4464     cv = newXS(name, const_sv_xsub, savepv(CopFILE(PL_curcop)));
4465     CvXSUBANY(cv).any_ptr = sv;
4466     CvCONST_on(cv);
4467     sv_setpv((SV*)cv, "");  /* prototype is "" */
4468
4469     if (stash)
4470         CopSTASH_free(PL_curcop);
4471
4472     LEAVE;
4473
4474     return cv;
4475 }
4476
4477 /*
4478 =for apidoc U||newXS
4479
4480 Used by C<xsubpp> to hook up XSUBs as Perl subs.
4481
4482 =cut
4483 */
4484
4485 CV *
4486 Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
4487 {
4488     GV *gv = gv_fetchpv(name ? name :
4489                         (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4490                         GV_ADDMULTI, SVt_PVCV);
4491     register CV *cv;
4492
4493     if (!subaddr)
4494         Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
4495
4496     if ((cv = (name ? GvCV(gv) : Nullcv))) {
4497         if (GvCVGEN(gv)) {
4498             /* just a cached method */
4499             SvREFCNT_dec(cv);
4500             cv = 0;
4501         }
4502         else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4503             /* already defined (or promised) */
4504             if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
4505                             && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
4506                 line_t oldline = CopLINE(PL_curcop);
4507                 if (PL_copline != NOLINE)
4508                     CopLINE_set(PL_curcop, PL_copline);
4509                 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4510                             CvCONST(cv) ? "Constant subroutine %s redefined"
4511                                         : "Subroutine %s redefined"
4512                             ,name);
4513                 CopLINE_set(PL_curcop, oldline);
4514             }
4515             SvREFCNT_dec(cv);
4516             cv = 0;
4517         }
4518     }
4519
4520     if (cv)                             /* must reuse cv if autoloaded */
4521         cv_undef(cv);
4522     else {
4523         cv = (CV*)NEWSV(1105,0);
4524         sv_upgrade((SV *)cv, SVt_PVCV);
4525         if (name) {
4526             GvCV(gv) = cv;
4527             GvCVGEN(gv) = 0;
4528             PL_sub_generation++;
4529         }
4530     }
4531     CvGV(cv) = gv;
4532     (void)gv_fetchfile(filename);
4533     CvFILE(cv) = filename;      /* NOTE: not copied, as it is expected to be
4534                                    an external constant string */
4535     CvXSUB(cv) = subaddr;
4536
4537     if (name) {
4538         char *s = strrchr(name,':');
4539         if (s)
4540             s++;
4541         else
4542             s = name;
4543
4544         if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4545             goto done;
4546
4547         if (strEQ(s, "BEGIN")) {
4548             if (!PL_beginav)
4549                 PL_beginav = newAV();
4550             av_push(PL_beginav, (SV*)cv);
4551             GvCV(gv) = 0;               /* cv has been hijacked */
4552         }
4553         else if (strEQ(s, "END")) {
4554             if (!PL_endav)
4555                 PL_endav = newAV();
4556             av_unshift(PL_endav, 1);
4557             av_store(PL_endav, 0, (SV*)cv);
4558             GvCV(gv) = 0;               /* cv has been hijacked */
4559         }
4560         else if (strEQ(s, "CHECK")) {
4561             if (!PL_checkav)
4562                 PL_checkav = newAV();
4563             if (PL_main_start && ckWARN(WARN_VOID))
4564                 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4565             av_unshift(PL_checkav, 1);
4566             av_store(PL_checkav, 0, (SV*)cv);
4567             GvCV(gv) = 0;               /* cv has been hijacked */
4568         }
4569         else if (strEQ(s, "INIT")) {
4570             if (!PL_initav)
4571                 PL_initav = newAV();
4572             if (PL_main_start && ckWARN(WARN_VOID))
4573                 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4574             av_push(PL_initav, (SV*)cv);
4575             GvCV(gv) = 0;               /* cv has been hijacked */
4576         }
4577     }
4578     else
4579         CvANON_on(cv);
4580
4581 done:
4582     return cv;
4583 }
4584
4585 void
4586 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
4587 {
4588     register CV *cv;
4589     char *name;
4590     GV *gv;
4591     STRLEN n_a;
4592
4593     if (o)
4594         name = SvPVx(cSVOPo->op_sv, n_a);
4595     else
4596         name = "STDOUT";
4597     gv = gv_fetchpv(name,TRUE, SVt_PVFM);
4598 #ifdef GV_UNIQUE_CHECK
4599     if (GvUNIQUE(gv)) {
4600         Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
4601     }
4602 #endif
4603     GvMULTI_on(gv);
4604     if ((cv = GvFORM(gv))) {
4605         if (ckWARN(WARN_REDEFINE)) {
4606             line_t oldline = CopLINE(PL_curcop);
4607             if (PL_copline != NOLINE)
4608                 CopLINE_set(PL_curcop, PL_copline);
4609             Perl_warner(aTHX_ packWARN(WARN_REDEFINE), "Format %s redefined",name);
4610             CopLINE_set(PL_curcop, oldline);
4611         }
4612         SvREFCNT_dec(cv);
4613     }
4614     cv = PL_compcv;
4615     GvFORM(gv) = cv;
4616     CvGV(cv) = gv;
4617     CvFILE_set_from_cop(cv, PL_curcop);
4618
4619
4620     pad_tidy(padtidy_FORMAT);
4621     CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
4622     CvROOT(cv)->op_private |= OPpREFCOUNTED;
4623     OpREFCNT_set(CvROOT(cv), 1);
4624     CvSTART(cv) = LINKLIST(CvROOT(cv));
4625     CvROOT(cv)->op_next = 0;
4626     CALL_PEEP(CvSTART(cv));
4627     op_free(o);
4628     PL_copline = NOLINE;
4629     LEAVE_SCOPE(floor);
4630 }
4631
4632 OP *
4633 Perl_newANONLIST(pTHX_ OP *o)
4634 {
4635     return newUNOP(OP_REFGEN, 0,
4636         mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
4637 }
4638
4639 OP *
4640 Perl_newANONHASH(pTHX_ OP *o)
4641 {
4642     return newUNOP(OP_REFGEN, 0,
4643         mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
4644 }
4645
4646 OP *
4647 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
4648 {
4649     return newANONATTRSUB(floor, proto, Nullop, block);
4650 }
4651
4652 OP *
4653 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
4654 {
4655     return newUNOP(OP_REFGEN, 0,
4656         newSVOP(OP_ANONCODE, 0,
4657                 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
4658 }
4659
4660 OP *
4661 Perl_oopsAV(pTHX_ OP *o)
4662 {
4663     switch (o->op_type) {
4664     case OP_PADSV:
4665         o->op_type = OP_PADAV;
4666         o->op_ppaddr = PL_ppaddr[OP_PADAV];
4667         return ref(o, OP_RV2AV);
4668
4669     case OP_RV2SV:
4670         o->op_type = OP_RV2AV;
4671         o->op_ppaddr = PL_ppaddr[OP_RV2AV];
4672         ref(o, OP_RV2AV);
4673         break;
4674
4675     default:
4676         if (ckWARN_d(WARN_INTERNAL))
4677             Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
4678         break;
4679     }
4680     return o;
4681 }
4682
4683 OP *
4684 Perl_oopsHV(pTHX_ OP *o)
4685 {
4686     switch (o->op_type) {
4687     case OP_PADSV:
4688     case OP_PADAV:
4689         o->op_type = OP_PADHV;
4690         o->op_ppaddr = PL_ppaddr[OP_PADHV];
4691         return ref(o, OP_RV2HV);
4692
4693     case OP_RV2SV:
4694     case OP_RV2AV:
4695         o->op_type = OP_RV2HV;
4696         o->op_ppaddr = PL_ppaddr[OP_RV2HV];
4697         ref(o, OP_RV2HV);
4698         break;
4699
4700     default:
4701         if (ckWARN_d(WARN_INTERNAL))
4702             Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
4703         break;
4704     }
4705     return o;
4706 }
4707
4708 OP *
4709 Perl_newAVREF(pTHX_ OP *o)
4710 {
4711     if (o->op_type == OP_PADANY) {
4712         o->op_type = OP_PADAV;
4713         o->op_ppaddr = PL_ppaddr[OP_PADAV];
4714         return o;
4715     }
4716     else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
4717                 && ckWARN(WARN_DEPRECATED)) {
4718         Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4719                 "Using an array as a reference is deprecated");
4720     }
4721     return newUNOP(OP_RV2AV, 0, scalar(o));
4722 }
4723
4724 OP *
4725 Perl_newGVREF(pTHX_ I32 type, OP *o)
4726 {
4727     if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
4728         return newUNOP(OP_NULL, 0, o);
4729     return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
4730 }
4731
4732 OP *
4733 Perl_newHVREF(pTHX_ OP *o)
4734 {
4735     if (o->op_type == OP_PADANY) {
4736         o->op_type = OP_PADHV;
4737         o->op_ppaddr = PL_ppaddr[OP_PADHV];
4738         return o;
4739     }
4740     else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
4741                 && ckWARN(WARN_DEPRECATED)) {
4742         Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4743                 "Using a hash as a reference is deprecated");
4744     }
4745     return newUNOP(OP_RV2HV, 0, scalar(o));
4746 }
4747
4748 OP *
4749 Perl_oopsCV(pTHX_ OP *o)
4750 {
4751     Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
4752     /* STUB */
4753     return o;
4754 }
4755
4756 OP *
4757 Perl_newCVREF(pTHX_ I32 flags, OP *o)
4758 {
4759     return newUNOP(OP_RV2CV, flags, scalar(o));
4760 }
4761
4762 OP *
4763 Perl_newSVREF(pTHX_ OP *o)
4764 {
4765     if (o->op_type == OP_PADANY) {
4766         o->op_type = OP_PADSV;
4767         o->op_ppaddr = PL_ppaddr[OP_PADSV];
4768         return o;
4769     }
4770     else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
4771         o->op_flags |= OPpDONE_SVREF;
4772         return o;
4773     }
4774     return newUNOP(OP_RV2SV, 0, scalar(o));
4775 }
4776
4777 /* Check routines. */
4778
4779 OP *
4780 Perl_ck_anoncode(pTHX_ OP *o)
4781 {
4782     cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
4783     cSVOPo->op_sv = Nullsv;
4784     return o;
4785 }
4786
4787 OP *
4788 Perl_ck_bitop(pTHX_ OP *o)
4789 {
4790 #define OP_IS_NUMCOMPARE(op) \
4791         ((op) == OP_LT   || (op) == OP_I_LT || \
4792          (op) == OP_GT   || (op) == OP_I_GT || \
4793          (op) == OP_LE   || (op) == OP_I_LE || \
4794          (op) == OP_GE   || (op) == OP_I_GE || \
4795          (op) == OP_EQ   || (op) == OP_I_EQ || \
4796          (op) == OP_NE   || (op) == OP_I_NE || \
4797          (op) == OP_NCMP || (op) == OP_I_NCMP)
4798     o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4799     if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
4800             && (o->op_type == OP_BIT_OR
4801              || o->op_type == OP_BIT_AND
4802              || o->op_type == OP_BIT_XOR))
4803     {
4804         OP * left = cBINOPo->op_first;
4805         OP * right = left->op_sibling;
4806         if ((OP_IS_NUMCOMPARE(left->op_type) &&
4807                 (left->op_flags & OPf_PARENS) == 0) ||
4808             (OP_IS_NUMCOMPARE(right->op_type) &&
4809                 (right->op_flags & OPf_PARENS) == 0))
4810             if (ckWARN(WARN_PRECEDENCE))
4811                 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
4812                         "Possible precedence problem on bitwise %c operator",
4813                         o->op_type == OP_BIT_OR ? '|'
4814                             : o->op_type == OP_BIT_AND ? '&' : '^'
4815                         );
4816     }
4817     return o;
4818 }
4819
4820 OP *
4821 Perl_ck_concat(pTHX_ OP *o)
4822 {
4823     OP *kid = cUNOPo->op_first;
4824     if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
4825             !(kUNOP->op_first->op_flags & OPf_MOD))
4826         o->op_flags |= OPf_STACKED;
4827     return o;
4828 }
4829
4830 OP *
4831 Perl_ck_spair(pTHX_ OP *o)
4832 {
4833     if (o->op_flags & OPf_KIDS) {
4834         OP* newop;
4835         OP* kid;
4836         OPCODE type = o->op_type;
4837         o = modkids(ck_fun(o), type);
4838         kid = cUNOPo->op_first;
4839         newop = kUNOP->op_first->op_sibling;
4840         if (newop &&
4841             (newop->op_sibling ||
4842              !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
4843              newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
4844              newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
4845
4846             return o;
4847         }
4848         op_free(kUNOP->op_first);
4849         kUNOP->op_first = newop;
4850     }
4851     o->op_ppaddr = PL_ppaddr[++o->op_type];
4852     return ck_fun(o);
4853 }
4854
4855 OP *
4856 Perl_ck_delete(pTHX_ OP *o)
4857 {
4858     o = ck_fun(o);
4859     o->op_private = 0;
4860     if (o->op_flags & OPf_KIDS) {
4861         OP *kid = cUNOPo->op_first;
4862         switch (kid->op_type) {
4863         case OP_ASLICE:
4864             o->op_flags |= OPf_SPECIAL;
4865             /* FALL THROUGH */
4866         case OP_HSLICE:
4867             o->op_private |= OPpSLICE;
4868             break;
4869         case OP_AELEM:
4870             o->op_flags |= OPf_SPECIAL;
4871             /* FALL THROUGH */
4872         case OP_HELEM:
4873             break;
4874         default:
4875             Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
4876                   OP_DESC(o));
4877         }
4878         op_null(kid);
4879     }
4880     return o;
4881 }
4882
4883 OP *
4884 Perl_ck_die(pTHX_ OP *o)
4885 {
4886 #ifdef VMS
4887     if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
4888 #endif
4889     return ck_fun(o);
4890 }
4891
4892 OP *
4893 Perl_ck_eof(pTHX_ OP *o)
4894 {
4895     I32 type = o->op_type;
4896
4897     if (o->op_flags & OPf_KIDS) {
4898         if (cLISTOPo->op_first->op_type == OP_STUB) {
4899             op_free(o);
4900             o = newUNOP(type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
4901         }
4902         return ck_fun(o);
4903     }
4904     return o;
4905 }
4906
4907 OP *
4908 Perl_ck_eval(pTHX_ OP *o)
4909 {
4910     PL_hints |= HINT_BLOCK_SCOPE;
4911     if (o->op_flags & OPf_KIDS) {
4912         SVOP *kid = (SVOP*)cUNOPo->op_first;
4913
4914         if (!kid) {
4915             o->op_flags &= ~OPf_KIDS;
4916             op_null(o);
4917         }
4918         else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
4919             LOGOP *enter;
4920
4921             cUNOPo->op_first = 0;
4922             op_free(o);
4923
4924             NewOp(1101, enter, 1, LOGOP);
4925             enter->op_type = OP_ENTERTRY;
4926             enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
4927             enter->op_private = 0;
4928
4929             /* establish postfix order */
4930             enter->op_next = (OP*)enter;
4931
4932             o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
4933             o->op_type = OP_LEAVETRY;
4934             o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
4935             enter->op_other = o;
4936             return o;
4937         }
4938         else {
4939             scalar((OP*)kid);
4940             PL_cv_has_eval = 1;
4941         }
4942     }
4943     else {
4944         op_free(o);
4945         o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
4946     }
4947     o->op_targ = (PADOFFSET)PL_hints;
4948     return o;
4949 }
4950
4951 OP *
4952 Perl_ck_exit(pTHX_ OP *o)
4953 {
4954 #ifdef VMS
4955     HV *table = GvHV(PL_hintgv);
4956     if (table) {
4957        SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
4958        if (svp && *svp && SvTRUE(*svp))
4959            o->op_private |= OPpEXIT_VMSISH;
4960     }
4961     if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
4962 #endif
4963     return ck_fun(o);
4964 }
4965
4966 OP *
4967 Perl_ck_exec(pTHX_ OP *o)
4968 {
4969     OP *kid;
4970     if (o->op_flags & OPf_STACKED) {
4971         o = ck_fun(o);
4972         kid = cUNOPo->op_first->op_sibling;
4973         if (kid->op_type == OP_RV2GV)
4974             op_null(kid);
4975     }
4976     else
4977         o = listkids(o);
4978     return o;
4979 }
4980
4981 OP *
4982 Perl_ck_exists(pTHX_ OP *o)
4983 {
4984     o = ck_fun(o);
4985     if (o->op_flags & OPf_KIDS) {
4986         OP *kid = cUNOPo->op_first;
4987         if (kid->op_type == OP_ENTERSUB) {
4988             (void) ref(kid, o->op_type);
4989             if (kid->op_type != OP_RV2CV && !PL_error_count)
4990                 Perl_croak(aTHX_ "%s argument is not a subroutine name",
4991                             OP_DESC(o));
4992             o->op_private |= OPpEXISTS_SUB;
4993         }
4994         else if (kid->op_type == OP_AELEM)
4995             o->op_flags |= OPf_SPECIAL;
4996         else if (kid->op_type != OP_HELEM)
4997             Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
4998                         OP_DESC(o));
4999         op_null(kid);
5000     }
5001     return o;
5002 }
5003
5004 #if 0
5005 OP *
5006 Perl_ck_gvconst(pTHX_ register OP *o)
5007 {
5008     o = fold_constants(o);
5009     if (o->op_type == OP_CONST)
5010         o->op_type = OP_GV;
5011     return o;
5012 }
5013 #endif
5014
5015 OP *
5016 Perl_ck_rvconst(pTHX_ register OP *o)
5017 {
5018     SVOP *kid = (SVOP*)cUNOPo->op_first;
5019
5020     o->op_private |= (PL_hints & HINT_STRICT_REFS);
5021     if (kid->op_type == OP_CONST) {
5022         char *name;
5023         int iscv;
5024         GV *gv;
5025         SV *kidsv = kid->op_sv;
5026         STRLEN n_a;
5027
5028         /* Is it a constant from cv_const_sv()? */
5029         if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5030             SV *rsv = SvRV(kidsv);
5031             int svtype = SvTYPE(rsv);
5032             char *badtype = Nullch;
5033
5034             switch (o->op_type) {
5035             case OP_RV2SV:
5036                 if (svtype > SVt_PVMG)
5037                     badtype = "a SCALAR";
5038                 break;
5039             case OP_RV2AV:
5040                 if (svtype != SVt_PVAV)
5041                     badtype = "an ARRAY";
5042                 break;
5043             case OP_RV2HV:
5044                 if (svtype != SVt_PVHV)
5045                     badtype = "a HASH";
5046                 break;
5047             case OP_RV2CV:
5048                 if (svtype != SVt_PVCV)
5049                     badtype = "a CODE";
5050                 break;
5051             }
5052             if (badtype)
5053                 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5054             return o;
5055         }
5056         name = SvPV(kidsv, n_a);
5057         if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5058             char *badthing = Nullch;
5059             switch (o->op_type) {
5060             case OP_RV2SV:
5061                 badthing = "a SCALAR";
5062                 break;
5063             case OP_RV2AV:
5064                 badthing = "an ARRAY";
5065                 break;
5066             case OP_RV2HV:
5067                 badthing = "a HASH";
5068                 break;
5069             }
5070             if (badthing)
5071                 Perl_croak(aTHX_
5072           "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
5073                       name, badthing);
5074         }
5075         /*
5076          * This is a little tricky.  We only want to add the symbol if we
5077          * didn't add it in the lexer.  Otherwise we get duplicate strict
5078          * warnings.  But if we didn't add it in the lexer, we must at
5079          * least pretend like we wanted to add it even if it existed before,
5080          * or we get possible typo warnings.  OPpCONST_ENTERED says
5081          * whether the lexer already added THIS instance of this symbol.
5082          */
5083         iscv = (o->op_type == OP_RV2CV) * 2;
5084         do {
5085             gv = gv_fetchpv(name,
5086                 iscv | !(kid->op_private & OPpCONST_ENTERED),
5087                 iscv
5088                     ? SVt_PVCV
5089                     : o->op_type == OP_RV2SV
5090                         ? SVt_PV
5091                         : o->op_type == OP_RV2AV
5092                             ? SVt_PVAV
5093                             : o->op_type == OP_RV2HV
5094                                 ? SVt_PVHV
5095                                 : SVt_PVGV);
5096         } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5097         if (gv) {
5098             kid->op_type = OP_GV;
5099             SvREFCNT_dec(kid->op_sv);
5100 #ifdef USE_ITHREADS
5101             /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5102             kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5103             SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
5104             GvIN_PAD_on(gv);
5105             PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc(gv));
5106 #else
5107             kid->op_sv = SvREFCNT_inc(gv);
5108 #endif
5109             kid->op_private = 0;
5110             kid->op_ppaddr = PL_ppaddr[OP_GV];
5111         }
5112     }
5113     return o;
5114 }
5115
5116 OP *
5117 Perl_ck_ftst(pTHX_ OP *o)
5118 {
5119     I32 type = o->op_type;
5120
5121     if (o->op_flags & OPf_REF) {
5122         /* nothing */
5123     }
5124     else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5125         SVOP *kid = (SVOP*)cUNOPo->op_first;
5126
5127         if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5128             STRLEN n_a;
5129             OP *newop = newGVOP(type, OPf_REF,
5130                 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
5131             op_free(o);
5132             o = newop;
5133             return o;
5134         }
5135         else {
5136           if ((PL_hints & HINT_FILETEST_ACCESS) &&
5137               OP_IS_FILETEST_ACCESS(o))
5138             o->op_private |= OPpFT_ACCESS;
5139         }
5140         if (PL_check[kid->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst)
5141                 && kid->op_type != OP_STAT && kid->op_type != OP_LSTAT)
5142             o->op_private |= OPpFT_STACKED;
5143     }
5144     else {
5145         op_free(o);
5146         if (type == OP_FTTTY)
5147             o = newGVOP(type, OPf_REF, PL_stdingv);
5148         else
5149             o = newUNOP(type, 0, newDEFSVOP());
5150     }
5151     return o;
5152 }
5153
5154 OP *
5155 Perl_ck_fun(pTHX_ OP *o)
5156 {
5157     register OP *kid;
5158     OP **tokid;
5159     OP *sibl;
5160     I32 numargs = 0;
5161     int type = o->op_type;
5162     register I32 oa = PL_opargs[type] >> OASHIFT;
5163
5164     if (o->op_flags & OPf_STACKED) {
5165         if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5166             oa &= ~OA_OPTIONAL;
5167         else
5168             return no_fh_allowed(o);
5169     }
5170
5171     if (o->op_flags & OPf_KIDS) {
5172         STRLEN n_a;
5173         tokid = &cLISTOPo->op_first;
5174         kid = cLISTOPo->op_first;
5175         if (kid->op_type == OP_PUSHMARK ||
5176             (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5177         {
5178             tokid = &kid->op_sibling;
5179             kid = kid->op_sibling;
5180         }
5181         if (!kid && PL_opargs[type] & OA_DEFGV)
5182             *tokid = kid = newDEFSVOP();
5183
5184         while (oa && kid) {
5185             numargs++;
5186             sibl = kid->op_sibling;
5187             switch (oa & 7) {
5188             case OA_SCALAR:
5189                 /* list seen where single (scalar) arg expected? */
5190                 if (numargs == 1 && !(oa >> 4)
5191                     && kid->op_type == OP_LIST && type != OP_SCALAR)
5192                 {
5193                     return too_many_arguments(o,PL_op_desc[type]);
5194                 }
5195                 scalar(kid);
5196                 break;
5197             case OA_LIST:
5198                 if (oa < 16) {
5199                     kid = 0;
5200                     continue;
5201                 }
5202                 else
5203                     list(kid);
5204                 break;
5205             case OA_AVREF:
5206                 if ((type == OP_PUSH || type == OP_UNSHIFT)
5207                     && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5208                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5209                         "Useless use of %s with no values",
5210                         PL_op_desc[type]);
5211
5212                 if (kid->op_type == OP_CONST &&
5213                     (kid->op_private & OPpCONST_BARE))
5214                 {
5215                     char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5216                     OP *newop = newAVREF(newGVOP(OP_GV, 0,
5217                         gv_fetchpv(name, TRUE, SVt_PVAV) ));
5218                     if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5219                         Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5220                             "Array @%s missing the @ in argument %"IVdf" of %s()",
5221                             name, (IV)numargs, PL_op_desc[type]);
5222                     op_free(kid);
5223                     kid = newop;
5224                     kid->op_sibling = sibl;
5225                     *tokid = kid;
5226                 }
5227                 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5228                     bad_type(numargs, "array", PL_op_desc[type], kid);
5229                 mod(kid, type);
5230                 break;
5231             case OA_HVREF:
5232                 if (kid->op_type == OP_CONST &&
5233                     (kid->op_private & OPpCONST_BARE))
5234                 {
5235                     char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5236                     OP *newop = newHVREF(newGVOP(OP_GV, 0,
5237                         gv_fetchpv(name, TRUE, SVt_PVHV) ));
5238                     if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5239                         Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5240                             "Hash %%%s missing the %% in argument %"IVdf" of %s()",
5241                             name, (IV)numargs, PL_op_desc[type]);
5242                     op_free(kid);
5243                     kid = newop;
5244                     kid->op_sibling = sibl;
5245                     *tokid = kid;
5246                 }
5247                 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5248                     bad_type(numargs, "hash", PL_op_desc[type], kid);
5249                 mod(kid, type);
5250                 break;
5251             case OA_CVREF:
5252                 {
5253                     OP *newop = newUNOP(OP_NULL, 0, kid);
5254                     kid->op_sibling = 0;
5255                     linklist(kid);
5256                     newop->op_next = newop;
5257                     kid = newop;
5258                     kid->op_sibling = sibl;
5259                     *tokid = kid;
5260                 }
5261                 break;
5262             case OA_FILEREF:
5263                 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5264                     if (kid->op_type == OP_CONST &&
5265                         (kid->op_private & OPpCONST_BARE))
5266                     {
5267                         OP *newop = newGVOP(OP_GV, 0,
5268                             gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
5269                                         SVt_PVIO) );
5270                         if (!(o->op_private & 1) && /* if not unop */
5271                             kid == cLISTOPo->op_last)
5272                             cLISTOPo->op_last = newop;
5273                         op_free(kid);
5274                         kid = newop;
5275                     }
5276                     else if (kid->op_type == OP_READLINE) {
5277                         /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5278                         bad_type(numargs, "HANDLE", OP_DESC(o), kid);
5279                     }
5280                     else {
5281                         I32 flags = OPf_SPECIAL;
5282                         I32 priv = 0;
5283                         PADOFFSET targ = 0;
5284
5285                         /* is this op a FH constructor? */
5286                         if (is_handle_constructor(o,numargs)) {
5287                             char *name = Nullch;
5288                             STRLEN len = 0;
5289
5290                             flags = 0;
5291                             /* Set a flag to tell rv2gv to vivify
5292                              * need to "prove" flag does not mean something
5293                              * else already - NI-S 1999/05/07
5294                              */
5295                             priv = OPpDEREF;
5296                             if (kid->op_type == OP_PADSV) {
5297                                 name = PAD_COMPNAME_PV(kid->op_targ);
5298                                 /* SvCUR of a pad namesv can't be trusted
5299                                  * (see PL_generation), so calc its length
5300                                  * manually */
5301                                 if (name)
5302                                     len = strlen(name);
5303
5304                             }
5305                             else if (kid->op_type == OP_RV2SV
5306                                      && kUNOP->op_first->op_type == OP_GV)
5307                             {
5308                                 GV *gv = cGVOPx_gv(kUNOP->op_first);
5309                                 name = GvNAME(gv);
5310                                 len = GvNAMELEN(gv);
5311                             }
5312                             else if (kid->op_type == OP_AELEM
5313                                      || kid->op_type == OP_HELEM)
5314                             {
5315                                  OP *op;
5316
5317                                  name = 0;
5318                                  if ((op = ((BINOP*)kid)->op_first)) {
5319                                       SV *tmpstr = Nullsv;
5320                                       char *a =
5321                                            kid->op_type == OP_AELEM ?
5322                                            "[]" : "{}";
5323                                       if (((op->op_type == OP_RV2AV) ||
5324                                            (op->op_type == OP_RV2HV)) &&
5325                                           (op = ((UNOP*)op)->op_first) &&
5326                                           (op->op_type == OP_GV)) {
5327                                            /* packagevar $a[] or $h{} */
5328                                            GV *gv = cGVOPx_gv(op);
5329                                            if (gv)
5330                                                 tmpstr =
5331                                                      Perl_newSVpvf(aTHX_
5332                                                                    "%s%c...%c",
5333                                                                    GvNAME(gv),
5334                                                                    a[0], a[1]);
5335                                       }
5336                                       else if (op->op_type == OP_PADAV
5337                                                || op->op_type == OP_PADHV) {
5338                                            /* lexicalvar $a[] or $h{} */
5339                                            char *padname =
5340                                                 PAD_COMPNAME_PV(op->op_targ);
5341                                            if (padname)
5342                                                 tmpstr =
5343                                                      Perl_newSVpvf(aTHX_
5344                                                                    "%s%c...%c",
5345                                                                    padname + 1,
5346                                                                    a[0], a[1]);
5347
5348                                       }
5349                                       if (tmpstr) {
5350                                            name = SvPV(tmpstr, len);
5351                                            sv_2mortal(tmpstr);
5352                                       }
5353                                  }
5354                                  if (!name) {
5355                                       name = "__ANONIO__";
5356                                       len = 10;
5357                                  }
5358                                  mod(kid, type);
5359                             }
5360                             if (name) {
5361                                 SV *namesv;
5362                                 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5363                                 namesv = PAD_SVl(targ);
5364                                 (void)SvUPGRADE(namesv, SVt_PV);
5365                                 if (*name != '$')
5366                                     sv_setpvn(namesv, "$", 1);
5367                                 sv_catpvn(namesv, name, len);
5368                             }
5369                         }
5370                         kid->op_sibling = 0;
5371                         kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5372                         kid->op_targ = targ;
5373                         kid->op_private |= priv;
5374                     }
5375                     kid->op_sibling = sibl;
5376                     *tokid = kid;
5377                 }
5378                 scalar(kid);
5379                 break;
5380             case OA_SCALARREF:
5381                 mod(scalar(kid), type);
5382                 break;
5383             }
5384             oa >>= 4;
5385             tokid = &kid->op_sibling;
5386             kid = kid->op_sibling;
5387         }
5388         o->op_private |= numargs;
5389         if (kid)
5390             return too_many_arguments(o,OP_DESC(o));
5391         listkids(o);
5392     }
5393     else if (PL_opargs[type] & OA_DEFGV) {
5394         op_free(o);
5395         return newUNOP(type, 0, newDEFSVOP());
5396     }
5397
5398     if (oa) {
5399         while (oa & OA_OPTIONAL)
5400             oa >>= 4;
5401         if (oa && oa != OA_LIST)
5402             return too_few_arguments(o,OP_DESC(o));
5403     }
5404     return o;
5405 }
5406
5407 OP *
5408 Perl_ck_glob(pTHX_ OP *o)
5409 {
5410     GV *gv;
5411
5412     o = ck_fun(o);
5413     if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5414         append_elem(OP_GLOB, o, newDEFSVOP());
5415
5416     if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV))
5417           && GvCVu(gv) && GvIMPORTED_CV(gv)))
5418     {
5419         gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5420     }
5421
5422 #if !defined(PERL_EXTERNAL_GLOB)
5423     /* XXX this can be tightened up and made more failsafe. */
5424     if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
5425         GV *glob_gv;
5426         ENTER;
5427         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
5428                 newSVpvn("File::Glob", 10), Nullsv, Nullsv, Nullsv);
5429         gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5430         glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
5431         GvCV(gv) = GvCV(glob_gv);
5432         SvREFCNT_inc((SV*)GvCV(gv));
5433         GvIMPORTED_CV_on(gv);
5434         LEAVE;
5435     }
5436 #endif /* PERL_EXTERNAL_GLOB */
5437
5438     if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5439         append_elem(OP_GLOB, o,
5440                     newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5441         o->op_type = OP_LIST;
5442         o->op_ppaddr = PL_ppaddr[OP_LIST];
5443         cLISTOPo->op_first->op_type = OP_PUSHMARK;
5444         cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5445         cLISTOPo->op_first->op_targ = 0;
5446         o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5447                     append_elem(OP_LIST, o,
5448                                 scalar(newUNOP(OP_RV2CV, 0,
5449                                                newGVOP(OP_GV, 0, gv)))));
5450         o = newUNOP(OP_NULL, 0, ck_subr(o));
5451         o->op_targ = OP_GLOB;           /* hint at what it used to be */
5452         return o;
5453     }
5454     gv = newGVgen("main");
5455     gv_IOadd(gv);
5456     append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5457     scalarkids(o);
5458     return o;
5459 }
5460
5461 OP *
5462 Perl_ck_grep(pTHX_ OP *o)
5463 {
5464     LOGOP *gwop;
5465     OP *kid;
5466     OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5467     I32 offset;
5468
5469     o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5470     NewOp(1101, gwop, 1, LOGOP);
5471
5472     if (o->op_flags & OPf_STACKED) {
5473         OP* k;
5474         o = ck_sort(o);
5475         kid = cLISTOPo->op_first->op_sibling;
5476         for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
5477             kid = k;
5478         }
5479         kid->op_next = (OP*)gwop;
5480         o->op_flags &= ~OPf_STACKED;
5481     }
5482     kid = cLISTOPo->op_first->op_sibling;
5483     if (type == OP_MAPWHILE)
5484         list(kid);
5485     else
5486         scalar(kid);
5487     o = ck_fun(o);
5488     if (PL_error_count)
5489         return o;
5490     kid = cLISTOPo->op_first->op_sibling;
5491     if (kid->op_type != OP_NULL)
5492         Perl_croak(aTHX_ "panic: ck_grep");
5493     kid = kUNOP->op_first;
5494
5495     gwop->op_type = type;
5496     gwop->op_ppaddr = PL_ppaddr[type];
5497     gwop->op_first = listkids(o);
5498     gwop->op_flags |= OPf_KIDS;
5499     gwop->op_other = LINKLIST(kid);
5500     kid->op_next = (OP*)gwop;
5501     offset = pad_findmy("$_");
5502     if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
5503         o->op_private = gwop->op_private = 0;
5504         gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5505     }
5506     else {
5507         o->op_private = gwop->op_private = OPpGREP_LEX;
5508         gwop->op_targ = o->op_targ = offset;
5509     }
5510
5511     kid = cLISTOPo->op_first->op_sibling;
5512     if (!kid || !kid->op_sibling)
5513         return too_few_arguments(o,OP_DESC(o));
5514     for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5515         mod(kid, OP_GREPSTART);
5516
5517     return (OP*)gwop;
5518 }
5519
5520 OP *
5521 Perl_ck_index(pTHX_ OP *o)
5522 {
5523     if (o->op_flags & OPf_KIDS) {
5524         OP *kid = cLISTOPo->op_first->op_sibling;       /* get past pushmark */
5525         if (kid)
5526             kid = kid->op_sibling;                      /* get past "big" */
5527         if (kid && kid->op_type == OP_CONST)
5528             fbm_compile(((SVOP*)kid)->op_sv, 0);
5529     }
5530     return ck_fun(o);
5531 }
5532
5533 OP *
5534 Perl_ck_lengthconst(pTHX_ OP *o)
5535 {
5536     /* XXX length optimization goes here */
5537     return ck_fun(o);
5538 }
5539
5540 OP *
5541 Perl_ck_lfun(pTHX_ OP *o)
5542 {
5543     OPCODE type = o->op_type;
5544     return modkids(ck_fun(o), type);
5545 }
5546
5547 OP *
5548 Perl_ck_defined(pTHX_ OP *o)            /* 19990527 MJD */
5549 {
5550     if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
5551         switch (cUNOPo->op_first->op_type) {
5552         case OP_RV2AV:
5553             /* This is needed for
5554                if (defined %stash::)
5555                to work.   Do not break Tk.
5556                */
5557             break;                      /* Globals via GV can be undef */
5558         case OP_PADAV:
5559         case OP_AASSIGN:                /* Is this a good idea? */
5560             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5561                         "defined(@array) is deprecated");
5562             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5563                         "\t(Maybe you should just omit the defined()?)\n");
5564         break;
5565         case OP_RV2HV:
5566             /* This is needed for
5567                if (defined %stash::)
5568                to work.   Do not break Tk.
5569                */
5570             break;                      /* Globals via GV can be undef */
5571         case OP_PADHV:
5572             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5573                         "defined(%%hash) is deprecated");
5574             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5575                         "\t(Maybe you should just omit the defined()?)\n");
5576             break;
5577         default:
5578             /* no warning */
5579             break;
5580         }
5581     }
5582     return ck_rfun(o);
5583 }
5584
5585 OP *
5586 Perl_ck_rfun(pTHX_ OP *o)
5587 {
5588     OPCODE type = o->op_type;
5589     return refkids(ck_fun(o), type);
5590 }
5591
5592 OP *
5593 Perl_ck_listiob(pTHX_ OP *o)
5594 {
5595     register OP *kid;
5596
5597     kid = cLISTOPo->op_first;
5598     if (!kid) {
5599         o = force_list(o);
5600         kid = cLISTOPo->op_first;
5601     }
5602     if (kid->op_type == OP_PUSHMARK)
5603         kid = kid->op_sibling;
5604     if (kid && o->op_flags & OPf_STACKED)
5605         kid = kid->op_sibling;
5606     else if (kid && !kid->op_sibling) {         /* print HANDLE; */
5607         if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
5608             o->op_flags |= OPf_STACKED; /* make it a filehandle */
5609             kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
5610             cLISTOPo->op_first->op_sibling = kid;
5611             cLISTOPo->op_last = kid;
5612             kid = kid->op_sibling;
5613         }
5614     }
5615
5616     if (!kid)
5617         append_elem(o->op_type, o, newDEFSVOP());
5618
5619     return listkids(o);
5620 }
5621
5622 OP *
5623 Perl_ck_sassign(pTHX_ OP *o)
5624 {
5625     OP *kid = cLISTOPo->op_first;
5626     /* has a disposable target? */
5627     if ((PL_opargs[kid->op_type] & OA_TARGLEX)
5628         && !(kid->op_flags & OPf_STACKED)
5629         /* Cannot steal the second time! */
5630         && !(kid->op_private & OPpTARGET_MY))
5631     {
5632         OP *kkid = kid->op_sibling;
5633
5634         /* Can just relocate the target. */
5635         if (kkid && kkid->op_type == OP_PADSV
5636             && !(kkid->op_private & OPpLVAL_INTRO))
5637         {
5638             kid->op_targ = kkid->op_targ;
5639             kkid->op_targ = 0;
5640             /* Now we do not need PADSV and SASSIGN. */
5641             kid->op_sibling = o->op_sibling;    /* NULL */
5642             cLISTOPo->op_first = NULL;
5643             op_free(o);
5644             op_free(kkid);
5645             kid->op_private |= OPpTARGET_MY;    /* Used for context settings */
5646             return kid;
5647         }
5648     }
5649     /* optimise C<my $x = undef> to C<my $x> */
5650     if (kid->op_type == OP_UNDEF) {
5651         OP *kkid = kid->op_sibling;
5652         if (kkid && kkid->op_type == OP_PADSV
5653                 && (kkid->op_private & OPpLVAL_INTRO))
5654         {
5655             cLISTOPo->op_first = NULL;
5656             kid->op_sibling = NULL;
5657             op_free(o);
5658             op_free(kid);
5659             return kkid;
5660         }
5661     }
5662     return o;
5663 }
5664
5665 OP *
5666 Perl_ck_match(pTHX_ OP *o)
5667 {
5668     if (o->op_type != OP_QR) {
5669         I32 offset = pad_findmy("$_");
5670         if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS(offset) & SVpad_OUR)) {
5671             o->op_targ = offset;
5672             o->op_private |= OPpTARGET_MY;
5673         }
5674     }
5675     if (o->op_type == OP_MATCH || o->op_type == OP_QR)
5676         o->op_private |= OPpRUNTIME;
5677     return o;
5678 }
5679
5680 OP *
5681 Perl_ck_method(pTHX_ OP *o)
5682 {
5683     OP *kid = cUNOPo->op_first;
5684     if (kid->op_type == OP_CONST) {
5685         SV* sv = kSVOP->op_sv;
5686         if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
5687             OP *cmop;
5688             if (!SvREADONLY(sv) || !SvFAKE(sv)) {
5689                 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
5690             }
5691             else {
5692                 kSVOP->op_sv = Nullsv;
5693             }
5694             cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
5695             op_free(o);
5696             return cmop;
5697         }
5698     }
5699     return o;
5700 }
5701
5702 OP *
5703 Perl_ck_null(pTHX_ OP *o)
5704 {
5705     return o;
5706 }
5707
5708 OP *
5709 Perl_ck_open(pTHX_ OP *o)
5710 {
5711     HV *table = GvHV(PL_hintgv);
5712     if (table) {
5713         SV **svp;
5714         I32 mode;
5715         svp = hv_fetch(table, "open_IN", 7, FALSE);
5716         if (svp && *svp) {
5717             mode = mode_from_discipline(*svp);
5718             if (mode & O_BINARY)
5719                 o->op_private |= OPpOPEN_IN_RAW;
5720             else if (mode & O_TEXT)
5721                 o->op_private |= OPpOPEN_IN_CRLF;
5722         }
5723
5724         svp = hv_fetch(table, "open_OUT", 8, FALSE);
5725         if (svp && *svp) {
5726             mode = mode_from_discipline(*svp);
5727             if (mode & O_BINARY)
5728                 o->op_private |= OPpOPEN_OUT_RAW;
5729             else if (mode & O_TEXT)
5730                 o->op_private |= OPpOPEN_OUT_CRLF;
5731         }
5732     }
5733     if (o->op_type == OP_BACKTICK)
5734         return o;
5735     {
5736          /* In case of three-arg dup open remove strictness
5737           * from the last arg if it is a bareword. */
5738          OP *first = cLISTOPx(o)->op_first; /* The pushmark. */
5739          OP *last  = cLISTOPx(o)->op_last;  /* The bareword. */
5740          OP *oa;
5741          char *mode;
5742
5743          if ((last->op_type == OP_CONST) &&             /* The bareword. */
5744              (last->op_private & OPpCONST_BARE) &&
5745              (last->op_private & OPpCONST_STRICT) &&
5746              (oa = first->op_sibling) &&                /* The fh. */
5747              (oa = oa->op_sibling) &&                   /* The mode. */
5748              SvPOK(((SVOP*)oa)->op_sv) &&
5749              (mode = SvPVX(((SVOP*)oa)->op_sv)) &&
5750              mode[0] == '>' && mode[1] == '&' &&        /* A dup open. */
5751              (last == oa->op_sibling))                  /* The bareword. */
5752               last->op_private &= ~OPpCONST_STRICT;
5753     }
5754     return ck_fun(o);
5755 }
5756
5757 OP *
5758 Perl_ck_repeat(pTHX_ OP *o)
5759 {
5760     if (cBINOPo->op_first->op_flags & OPf_PARENS) {
5761         o->op_private |= OPpREPEAT_DOLIST;
5762         cBINOPo->op_first = force_list(cBINOPo->op_first);
5763     }
5764     else
5765         scalar(o);
5766     return o;
5767 }
5768
5769 OP *
5770 Perl_ck_require(pTHX_ OP *o)
5771 {
5772     GV* gv;
5773
5774     if (o->op_flags & OPf_KIDS) {       /* Shall we supply missing .pm? */
5775         SVOP *kid = (SVOP*)cUNOPo->op_first;
5776
5777         if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5778             char *s;
5779             for (s = SvPVX(kid->op_sv); *s; s++) {
5780                 if (*s == ':' && s[1] == ':') {
5781                     *s = '/';
5782                     Move(s+2, s+1, strlen(s+2)+1, char);
5783                     --SvCUR(kid->op_sv);
5784                 }
5785             }
5786             if (SvREADONLY(kid->op_sv)) {
5787                 SvREADONLY_off(kid->op_sv);
5788                 sv_catpvn(kid->op_sv, ".pm", 3);
5789                 SvREADONLY_on(kid->op_sv);
5790             }
5791             else
5792                 sv_catpvn(kid->op_sv, ".pm", 3);
5793         }
5794     }
5795
5796     /* handle override, if any */
5797     gv = gv_fetchpv("require", FALSE, SVt_PVCV);
5798     if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
5799         gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
5800
5801     if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5802         OP *kid = cUNOPo->op_first;
5803         cUNOPo->op_first = 0;
5804         op_free(o);
5805         return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
5806                                append_elem(OP_LIST, kid,
5807                                            scalar(newUNOP(OP_RV2CV, 0,
5808                                                           newGVOP(OP_GV, 0,
5809                                                                   gv))))));
5810     }
5811
5812     return ck_fun(o);
5813 }
5814
5815 OP *
5816 Perl_ck_return(pTHX_ OP *o)
5817 {
5818     OP *kid;
5819     if (CvLVALUE(PL_compcv)) {
5820         for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
5821             mod(kid, OP_LEAVESUBLV);
5822     }
5823     return o;
5824 }
5825
5826 #if 0
5827 OP *
5828 Perl_ck_retarget(pTHX_ OP *o)
5829 {
5830     Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5831     /* STUB */
5832     return o;
5833 }
5834 #endif
5835
5836 OP *
5837 Perl_ck_select(pTHX_ OP *o)
5838 {
5839     OP* kid;
5840     if (o->op_flags & OPf_KIDS) {
5841         kid = cLISTOPo->op_first->op_sibling;   /* get past pushmark */
5842         if (kid && kid->op_sibling) {
5843             o->op_type = OP_SSELECT;
5844             o->op_ppaddr = PL_ppaddr[OP_SSELECT];
5845             o = ck_fun(o);
5846             return fold_constants(o);
5847         }
5848     }
5849     o = ck_fun(o);
5850     kid = cLISTOPo->op_first->op_sibling;    /* get past pushmark */
5851     if (kid && kid->op_type == OP_RV2GV)
5852         kid->op_private &= ~HINT_STRICT_REFS;
5853     return o;
5854 }
5855
5856 OP *
5857 Perl_ck_shift(pTHX_ OP *o)
5858 {
5859     I32 type = o->op_type;
5860
5861     if (!(o->op_flags & OPf_KIDS)) {
5862         OP *argop;
5863
5864         op_free(o);
5865         argop = newUNOP(OP_RV2AV, 0,
5866             scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
5867         return newUNOP(type, 0, scalar(argop));
5868     }
5869     return scalar(modkids(ck_fun(o), type));
5870 }
5871
5872 OP *
5873 Perl_ck_sort(pTHX_ OP *o)
5874 {
5875     OP *firstkid;
5876
5877     if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
5878         simplify_sort(o);
5879     firstkid = cLISTOPo->op_first->op_sibling;          /* get past pushmark */
5880     if (o->op_flags & OPf_STACKED) {                    /* may have been cleared */
5881         OP *k = NULL;
5882         OP *kid = cUNOPx(firstkid)->op_first;           /* get past null */
5883
5884         if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
5885             linklist(kid);
5886             if (kid->op_type == OP_SCOPE) {
5887                 k = kid->op_next;
5888                 kid->op_next = 0;
5889             }
5890             else if (kid->op_type == OP_LEAVE) {
5891                 if (o->op_type == OP_SORT) {
5892                     op_null(kid);                       /* wipe out leave */
5893                     kid->op_next = kid;
5894
5895                     for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
5896                         if (k->op_next == kid)
5897                             k->op_next = 0;
5898                         /* don't descend into loops */
5899                         else if (k->op_type == OP_ENTERLOOP
5900                                  || k->op_type == OP_ENTERITER)
5901                         {
5902                             k = cLOOPx(k)->op_lastop;
5903                         }
5904                     }
5905                 }
5906                 else
5907                     kid->op_next = 0;           /* just disconnect the leave */
5908                 k = kLISTOP->op_first;
5909             }
5910             CALL_PEEP(k);
5911
5912             kid = firstkid;
5913             if (o->op_type == OP_SORT) {
5914                 /* provide scalar context for comparison function/block */
5915                 kid = scalar(kid);
5916                 kid->op_next = kid;
5917             }
5918             else
5919                 kid->op_next = k;
5920             o->op_flags |= OPf_SPECIAL;
5921         }
5922         else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
5923             op_null(firstkid);
5924
5925         firstkid = firstkid->op_sibling;
5926     }
5927
5928     /* provide list context for arguments */
5929     if (o->op_type == OP_SORT)
5930         list(firstkid);
5931
5932     return o;
5933 }
5934
5935 STATIC void
5936 S_simplify_sort(pTHX_ OP *o)
5937 {
5938     register OP *kid = cLISTOPo->op_first->op_sibling;  /* get past pushmark */
5939     OP *k;
5940     int descending;
5941     GV *gv;
5942     if (!(o->op_flags & OPf_STACKED))
5943         return;
5944     GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
5945     GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
5946     kid = kUNOP->op_first;                              /* get past null */
5947     if (kid->op_type != OP_SCOPE)
5948         return;
5949     kid = kLISTOP->op_last;                             /* get past scope */
5950     switch(kid->op_type) {
5951         case OP_NCMP:
5952         case OP_I_NCMP:
5953         case OP_SCMP:
5954             break;
5955         default:
5956             return;
5957     }
5958     k = kid;                                            /* remember this node*/
5959     if (kBINOP->op_first->op_type != OP_RV2SV)
5960         return;
5961     kid = kBINOP->op_first;                             /* get past cmp */
5962     if (kUNOP->op_first->op_type != OP_GV)
5963         return;
5964     kid = kUNOP->op_first;                              /* get past rv2sv */
5965     gv = kGVOP_gv;
5966     if (GvSTASH(gv) != PL_curstash)
5967         return;
5968     if (strEQ(GvNAME(gv), "a"))
5969         descending = 0;
5970     else if (strEQ(GvNAME(gv), "b"))
5971         descending = 1;
5972     else
5973         return;
5974
5975     kid = k;                                            /* back to cmp */
5976     if (kBINOP->op_last->op_type != OP_RV2SV)
5977         return;
5978     kid = kBINOP->op_last;                              /* down to 2nd arg */
5979     if (kUNOP->op_first->op_type != OP_GV)
5980         return;
5981     kid = kUNOP->op_first;                              /* get past rv2sv */
5982     gv = kGVOP_gv;
5983     if (GvSTASH(gv) != PL_curstash
5984         || ( descending
5985             ? strNE(GvNAME(gv), "a")
5986             : strNE(GvNAME(gv), "b")))
5987         return;
5988     o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
5989     if (descending)
5990         o->op_private |= OPpSORT_DESCEND;
5991     if (k->op_type == OP_NCMP)
5992         o->op_private |= OPpSORT_NUMERIC;
5993     if (k->op_type == OP_I_NCMP)
5994         o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
5995     kid = cLISTOPo->op_first->op_sibling;
5996     cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
5997     op_free(kid);                                     /* then delete it */
5998 }
5999
6000 OP *
6001 Perl_ck_split(pTHX_ OP *o)
6002 {
6003     register OP *kid;
6004
6005     if (o->op_flags & OPf_STACKED)
6006         return no_fh_allowed(o);
6007
6008     kid = cLISTOPo->op_first;
6009     if (kid->op_type != OP_NULL)
6010         Perl_croak(aTHX_ "panic: ck_split");
6011     kid = kid->op_sibling;
6012     op_free(cLISTOPo->op_first);
6013     cLISTOPo->op_first = kid;
6014     if (!kid) {
6015         cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
6016         cLISTOPo->op_last = kid; /* There was only one element previously */
6017     }
6018
6019     if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6020         OP *sibl = kid->op_sibling;
6021         kid->op_sibling = 0;
6022         kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
6023         if (cLISTOPo->op_first == cLISTOPo->op_last)
6024             cLISTOPo->op_last = kid;
6025         cLISTOPo->op_first = kid;
6026         kid->op_sibling = sibl;
6027     }
6028
6029     kid->op_type = OP_PUSHRE;
6030     kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6031     scalar(kid);
6032     if (ckWARN(WARN_REGEXP) && ((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
6033       Perl_warner(aTHX_ packWARN(WARN_REGEXP),
6034                   "Use of /g modifier is meaningless in split");
6035     }
6036
6037     if (!kid->op_sibling)
6038         append_elem(OP_SPLIT, o, newDEFSVOP());
6039
6040     kid = kid->op_sibling;
6041     scalar(kid);
6042
6043     if (!kid->op_sibling)
6044         append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6045
6046     kid = kid->op_sibling;
6047     scalar(kid);
6048
6049     if (kid->op_sibling)
6050         return too_many_arguments(o,OP_DESC(o));
6051
6052     return o;
6053 }
6054
6055 OP *
6056 Perl_ck_join(pTHX_ OP *o)
6057 {
6058     if (ckWARN(WARN_SYNTAX)) {
6059         OP *kid = cLISTOPo->op_first->op_sibling;
6060         if (kid && kid->op_type == OP_MATCH) {
6061             char *pmstr = "STRING";
6062             if (PM_GETRE(kPMOP))
6063                 pmstr = PM_GETRE(kPMOP)->precomp;
6064             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6065                         "/%s/ should probably be written as \"%s\"",
6066                         pmstr, pmstr);
6067         }
6068     }
6069     return ck_fun(o);
6070 }
6071
6072 OP *
6073 Perl_ck_subr(pTHX_ OP *o)
6074 {
6075     OP *prev = ((cUNOPo->op_first->op_sibling)
6076              ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6077     OP *o2 = prev->op_sibling;
6078     OP *cvop;
6079     char *proto = 0;
6080     CV *cv = 0;
6081     GV *namegv = 0;
6082     int optional = 0;
6083     I32 arg = 0;
6084     I32 contextclass = 0;
6085     char *e = 0;
6086     STRLEN n_a;
6087     bool delete=0;
6088
6089     o->op_private |= OPpENTERSUB_HASTARG;
6090     for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6091     if (cvop->op_type == OP_RV2CV) {
6092         SVOP* tmpop;
6093         o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6094         op_null(cvop);          /* disable rv2cv */
6095         tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6096         if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6097             GV *gv = cGVOPx_gv(tmpop);
6098             cv = GvCVu(gv);
6099             if (!cv)
6100                 tmpop->op_private |= OPpEARLY_CV;
6101             else {
6102                 if (SvPOK(cv)) {
6103                     namegv = CvANON(cv) ? gv : CvGV(cv);
6104                     proto = SvPV((SV*)cv, n_a);
6105                 }
6106                 if (CvASSERTION(cv)) {
6107                     if (PL_hints & HINT_ASSERTING) {
6108                         if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
6109                             o->op_private |= OPpENTERSUB_DB;
6110                     }
6111                     else {
6112                         delete=1;
6113                         if (ckWARN(WARN_ASSERTIONS) && !(PL_hints & HINT_ASSERTIONSSEEN)) {
6114                             Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
6115                                         "Impossible to activate assertion call");
6116                         }
6117                     }
6118                 }
6119             }
6120         }
6121     }
6122     else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6123         if (o2->op_type == OP_CONST)
6124             o2->op_private &= ~OPpCONST_STRICT;
6125         else if (o2->op_type == OP_LIST) {
6126             OP *o = ((UNOP*)o2)->op_first->op_sibling;
6127             if (o && o->op_type == OP_CONST)
6128                 o->op_private &= ~OPpCONST_STRICT;
6129         }
6130     }
6131     o->op_private |= (PL_hints & HINT_STRICT_REFS);
6132     if (PERLDB_SUB && PL_curstash != PL_debstash)
6133         o->op_private |= OPpENTERSUB_DB;
6134     while (o2 != cvop) {
6135         if (proto) {
6136             switch (*proto) {
6137             case '\0':
6138                 return too_many_arguments(o, gv_ename(namegv));
6139             case ';':
6140                 optional = 1;
6141                 proto++;
6142                 continue;
6143             case '$':
6144                 proto++;
6145                 arg++;
6146                 scalar(o2);
6147                 break;
6148             case '%':
6149             case '@':
6150                 list(o2);
6151                 arg++;
6152                 break;
6153             case '&':
6154                 proto++;
6155                 arg++;
6156                 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6157                     bad_type(arg,
6158                         arg == 1 ? "block or sub {}" : "sub {}",
6159                         gv_ename(namegv), o2);
6160                 break;
6161             case '*':
6162                 /* '*' allows any scalar type, including bareword */
6163                 proto++;
6164                 arg++;
6165                 if (o2->op_type == OP_RV2GV)
6166                     goto wrapref;       /* autoconvert GLOB -> GLOBref */
6167                 else if (o2->op_type == OP_CONST)
6168                     o2->op_private &= ~OPpCONST_STRICT;
6169                 else if (o2->op_type == OP_ENTERSUB) {
6170                     /* accidental subroutine, revert to bareword */
6171                     OP *gvop = ((UNOP*)o2)->op_first;
6172                     if (gvop && gvop->op_type == OP_NULL) {
6173                         gvop = ((UNOP*)gvop)->op_first;
6174                         if (gvop) {
6175                             for (; gvop->op_sibling; gvop = gvop->op_sibling)
6176                                 ;
6177                             if (gvop &&
6178                                 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6179                                 (gvop = ((UNOP*)gvop)->op_first) &&
6180                                 gvop->op_type == OP_GV)
6181                             {
6182                                 GV *gv = cGVOPx_gv(gvop);
6183                                 OP *sibling = o2->op_sibling;
6184                                 SV *n = newSVpvn("",0);
6185                                 op_free(o2);
6186                                 gv_fullname3(n, gv, "");
6187                                 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
6188                                     sv_chop(n, SvPVX(n)+6);
6189                                 o2 = newSVOP(OP_CONST, 0, n);
6190                                 prev->op_sibling = o2;
6191                                 o2->op_sibling = sibling;
6192                             }
6193                         }
6194                     }
6195                 }
6196                 scalar(o2);
6197                 break;
6198             case '[': case ']':
6199                  goto oops;
6200                  break;
6201             case '\\':
6202                 proto++;
6203                 arg++;
6204             again:
6205                 switch (*proto++) {
6206                 case '[':
6207                      if (contextclass++ == 0) {
6208                           e = strchr(proto, ']');
6209                           if (!e || e == proto)
6210                                goto oops;
6211                      }
6212                      else
6213                           goto oops;
6214                      goto again;
6215                      break;
6216                 case ']':
6217                      if (contextclass) {
6218                          char *p = proto;
6219                          char s = *p;
6220                          contextclass = 0;
6221                          *p = '\0';
6222                          while (*--p != '[');
6223                          bad_type(arg, Perl_form(aTHX_ "one of %s", p),
6224                                  gv_ename(namegv), o2);
6225                          *proto = s;
6226                      } else
6227                           goto oops;
6228                      break;
6229                 case '*':
6230                      if (o2->op_type == OP_RV2GV)
6231                           goto wrapref;
6232                      if (!contextclass)
6233                           bad_type(arg, "symbol", gv_ename(namegv), o2);
6234                      break;
6235                 case '&':
6236                      if (o2->op_type == OP_ENTERSUB)
6237                           goto wrapref;
6238                      if (!contextclass)
6239                           bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6240                      break;
6241                 case '$':
6242                     if (o2->op_type == OP_RV2SV ||
6243                         o2->op_type == OP_PADSV ||
6244                         o2->op_type == OP_HELEM ||
6245                         o2->op_type == OP_AELEM ||
6246                         o2->op_type == OP_THREADSV)
6247                          goto wrapref;
6248                     if (!contextclass)
6249                         bad_type(arg, "scalar", gv_ename(namegv), o2);
6250                      break;
6251                 case '@':
6252                     if (o2->op_type == OP_RV2AV ||
6253                         o2->op_type == OP_PADAV)
6254                          goto wrapref;
6255                     if (!contextclass)
6256                         bad_type(arg, "array", gv_ename(namegv), o2);
6257                     break;
6258                 case '%':
6259                     if (o2->op_type == OP_RV2HV ||
6260                         o2->op_type == OP_PADHV)
6261                          goto wrapref;
6262                     if (!contextclass)
6263                          bad_type(arg, "hash", gv_ename(namegv), o2);
6264                     break;
6265                 wrapref:
6266                     {
6267                         OP* kid = o2;
6268                         OP* sib = kid->op_sibling;
6269                         kid->op_sibling = 0;
6270                         o2 = newUNOP(OP_REFGEN, 0, kid);
6271                         o2->op_sibling = sib;
6272                         prev->op_sibling = o2;
6273                     }
6274                     if (contextclass && e) {
6275                          proto = e + 1;
6276                          contextclass = 0;
6277                     }
6278                     break;
6279                 default: goto oops;
6280                 }
6281                 if (contextclass)
6282                      goto again;
6283                 break;
6284             case ' ':
6285                 proto++;
6286                 continue;
6287             default:
6288               oops:
6289                 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
6290                            gv_ename(namegv), cv);
6291             }
6292         }
6293         else
6294             list(o2);
6295         mod(o2, OP_ENTERSUB);
6296         prev = o2;
6297         o2 = o2->op_sibling;
6298     }
6299     if (proto && !optional &&
6300           (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6301         return too_few_arguments(o, gv_ename(namegv));
6302     if(delete) {
6303         op_free(o);
6304         o=newSVOP(OP_CONST, 0, newSViv(0));
6305     }
6306     return o;
6307 }
6308
6309 OP *
6310 Perl_ck_svconst(pTHX_ OP *o)
6311 {
6312     SvREADONLY_on(cSVOPo->op_sv);
6313     return o;
6314 }
6315
6316 OP *
6317 Perl_ck_trunc(pTHX_ OP *o)
6318 {
6319     if (o->op_flags & OPf_KIDS) {
6320         SVOP *kid = (SVOP*)cUNOPo->op_first;
6321
6322         if (kid->op_type == OP_NULL)
6323             kid = (SVOP*)kid->op_sibling;
6324         if (kid && kid->op_type == OP_CONST &&
6325             (kid->op_private & OPpCONST_BARE))
6326         {
6327             o->op_flags |= OPf_SPECIAL;
6328             kid->op_private &= ~OPpCONST_STRICT;
6329         }
6330     }
6331     return ck_fun(o);
6332 }
6333
6334 OP *
6335 Perl_ck_unpack(pTHX_ OP *o)
6336 {
6337     OP *kid = cLISTOPo->op_first;
6338     if (kid->op_sibling) {
6339         kid = kid->op_sibling;
6340         if (!kid->op_sibling)
6341             kid->op_sibling = newDEFSVOP();
6342     }
6343     return ck_fun(o);
6344 }
6345
6346 OP *
6347 Perl_ck_substr(pTHX_ OP *o)
6348 {
6349     o = ck_fun(o);
6350     if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6351         OP *kid = cLISTOPo->op_first;
6352
6353         if (kid->op_type == OP_NULL)
6354             kid = kid->op_sibling;
6355         if (kid)
6356             kid->op_flags |= OPf_MOD;
6357
6358     }
6359     return o;
6360 }
6361
6362 /* A peephole optimizer.  We visit the ops in the order they're to execute. */
6363
6364 void
6365 Perl_peep(pTHX_ register OP *o)
6366 {
6367     register OP* oldop = 0;
6368
6369     if (!o || o->op_opt)
6370         return;
6371     ENTER;
6372     SAVEOP();
6373     SAVEVPTR(PL_curcop);
6374     for (; o; o = o->op_next) {
6375         if (o->op_opt)
6376             break;
6377         PL_op = o;
6378         switch (o->op_type) {
6379         case OP_SETSTATE:
6380         case OP_NEXTSTATE:
6381         case OP_DBSTATE:
6382             PL_curcop = ((COP*)o);              /* for warnings */
6383             o->op_opt = 1;
6384             break;
6385
6386         case OP_CONST:
6387             if (cSVOPo->op_private & OPpCONST_STRICT)
6388                 no_bareword_allowed(o);
6389 #ifdef USE_ITHREADS
6390         case OP_METHOD_NAMED:
6391             /* Relocate sv to the pad for thread safety.
6392              * Despite being a "constant", the SV is written to,
6393              * for reference counts, sv_upgrade() etc. */
6394             if (cSVOP->op_sv) {
6395                 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6396                 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
6397                     /* If op_sv is already a PADTMP then it is being used by
6398                      * some pad, so make a copy. */
6399                     sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
6400                     SvREADONLY_on(PAD_SVl(ix));
6401                     SvREFCNT_dec(cSVOPo->op_sv);
6402                 }
6403                 else {
6404                     SvREFCNT_dec(PAD_SVl(ix));
6405                     SvPADTMP_on(cSVOPo->op_sv);
6406                     PAD_SETSV(ix, cSVOPo->op_sv);
6407                     /* XXX I don't know how this isn't readonly already. */
6408                     SvREADONLY_on(PAD_SVl(ix));
6409                 }
6410                 cSVOPo->op_sv = Nullsv;
6411                 o->op_targ = ix;
6412             }
6413 #endif
6414             o->op_opt = 1;
6415             break;
6416
6417         case OP_CONCAT:
6418             if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6419                 if (o->op_next->op_private & OPpTARGET_MY) {
6420                     if (o->op_flags & OPf_STACKED) /* chained concats */
6421                         goto ignore_optimization;
6422                     else {
6423                         /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6424                         o->op_targ = o->op_next->op_targ;
6425                         o->op_next->op_targ = 0;
6426                         o->op_private |= OPpTARGET_MY;
6427                     }
6428                 }
6429                 op_null(o->op_next);
6430             }
6431           ignore_optimization:
6432             o->op_opt = 1;
6433             break;
6434         case OP_STUB:
6435             if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6436                 o->op_opt = 1;
6437                 break; /* Scalar stub must produce undef.  List stub is noop */
6438             }
6439             goto nothin;
6440         case OP_NULL:
6441             if (o->op_targ == OP_NEXTSTATE
6442                 || o->op_targ == OP_DBSTATE
6443                 || o->op_targ == OP_SETSTATE)
6444             {
6445                 PL_curcop = ((COP*)o);
6446             }
6447             /* XXX: We avoid setting op_seq here to prevent later calls
6448                to peep() from mistakenly concluding that optimisation
6449                has already occurred. This doesn't fix the real problem,
6450                though (See 20010220.007). AMS 20010719 */
6451             /* op_seq functionality is now replaced by op_opt */
6452             if (oldop && o->op_next) {
6453                 oldop->op_next = o->op_next;
6454                 continue;
6455             }
6456             break;
6457         case OP_SCALAR:
6458         case OP_LINESEQ:
6459         case OP_SCOPE:
6460           nothin:
6461             if (oldop && o->op_next) {
6462                 oldop->op_next = o->op_next;
6463                 continue;
6464             }
6465             o->op_opt = 1;
6466             break;
6467
6468         case OP_PADAV:
6469         case OP_GV:
6470             if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
6471                 OP* pop = (o->op_type == OP_PADAV) ?
6472                             o->op_next : o->op_next->op_next;
6473                 IV i;
6474                 if (pop && pop->op_type == OP_CONST &&
6475                     ((PL_op = pop->op_next)) &&
6476                     pop->op_next->op_type == OP_AELEM &&
6477                     !(pop->op_next->op_private &
6478                       (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6479                     (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
6480                                 <= 255 &&
6481                     i >= 0)
6482                 {
6483                     GV *gv;
6484                     if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
6485                         no_bareword_allowed(pop);
6486                     if (o->op_type == OP_GV)
6487                         op_null(o->op_next);
6488                     op_null(pop->op_next);
6489                     op_null(pop);
6490                     o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6491                     o->op_next = pop->op_next->op_next;
6492                     o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6493                     o->op_private = (U8)i;
6494                     if (o->op_type == OP_GV) {
6495                         gv = cGVOPo_gv;
6496                         GvAVn(gv);
6497                     }
6498                     else
6499                         o->op_flags |= OPf_SPECIAL;
6500                     o->op_type = OP_AELEMFAST;
6501                 }
6502                 o->op_opt = 1;
6503                 break;
6504             }
6505
6506             if (o->op_next->op_type == OP_RV2SV) {
6507                 if (!(o->op_next->op_private & OPpDEREF)) {
6508                     op_null(o->op_next);
6509                     o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6510                                                                | OPpOUR_INTRO);
6511                     o->op_next = o->op_next->op_next;
6512                     o->op_type = OP_GVSV;
6513                     o->op_ppaddr = PL_ppaddr[OP_GVSV];
6514                 }
6515             }
6516             else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6517                 GV *gv = cGVOPo_gv;
6518                 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
6519                     /* XXX could check prototype here instead of just carping */
6520                     SV *sv = sv_newmortal();
6521                     gv_efullname3(sv, gv, Nullch);
6522                     Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
6523                                 "%"SVf"() called too early to check prototype",
6524                                 sv);
6525                 }
6526             }
6527             else if (o->op_next->op_type == OP_READLINE
6528                     && o->op_next->op_next->op_type == OP_CONCAT
6529                     && (o->op_next->op_next->op_flags & OPf_STACKED))
6530             {
6531                 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
6532                 o->op_type   = OP_RCATLINE;
6533                 o->op_flags |= OPf_STACKED;
6534                 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
6535                 op_null(o->op_next->op_next);
6536                 op_null(o->op_next);
6537             }
6538
6539             o->op_opt = 1;
6540             break;
6541
6542         case OP_MAPWHILE:
6543         case OP_GREPWHILE:
6544         case OP_AND:
6545         case OP_OR:
6546         case OP_DOR:
6547         case OP_ANDASSIGN:
6548         case OP_ORASSIGN:
6549         case OP_DORASSIGN:
6550         case OP_COND_EXPR:
6551         case OP_RANGE:
6552             o->op_opt = 1;
6553             while (cLOGOP->op_other->op_type == OP_NULL)
6554                 cLOGOP->op_other = cLOGOP->op_other->op_next;
6555             peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
6556             break;
6557
6558         case OP_ENTERLOOP:
6559         case OP_ENTERITER:
6560             o->op_opt = 1;
6561             while (cLOOP->op_redoop->op_type == OP_NULL)
6562                 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6563             peep(cLOOP->op_redoop);
6564             while (cLOOP->op_nextop->op_type == OP_NULL)
6565                 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6566             peep(cLOOP->op_nextop);
6567             while (cLOOP->op_lastop->op_type == OP_NULL)
6568                 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6569             peep(cLOOP->op_lastop);
6570             break;
6571
6572         case OP_QR:
6573         case OP_MATCH:
6574         case OP_SUBST:
6575             o->op_opt = 1;
6576             while (cPMOP->op_pmreplstart &&
6577                    cPMOP->op_pmreplstart->op_type == OP_NULL)
6578                 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6579             peep(cPMOP->op_pmreplstart);
6580             break;
6581
6582         case OP_EXEC:
6583             o->op_opt = 1;
6584             if (ckWARN(WARN_SYNTAX) && o->op_next
6585                 && o->op_next->op_type == OP_NEXTSTATE) {
6586                 if (o->op_next->op_sibling &&
6587                         o->op_next->op_sibling->op_type != OP_EXIT &&
6588                         o->op_next->op_sibling->op_type != OP_WARN &&
6589                         o->op_next->op_sibling->op_type != OP_DIE) {
6590                     line_t oldline = CopLINE(PL_curcop);
6591
6592                     CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6593                     Perl_warner(aTHX_ packWARN(WARN_EXEC),
6594                                 "Statement unlikely to be reached");
6595                     Perl_warner(aTHX_ packWARN(WARN_EXEC),
6596                                 "\t(Maybe you meant system() when you said exec()?)\n");
6597                     CopLINE_set(PL_curcop, oldline);
6598                 }
6599             }
6600             break;
6601
6602         case OP_HELEM: {
6603             SV *lexname;
6604             SV **svp, *sv;
6605             char *key = NULL;
6606             STRLEN keylen;
6607
6608             o->op_opt = 1;
6609
6610             if (((BINOP*)o)->op_last->op_type != OP_CONST)
6611                 break;
6612
6613             /* Make the CONST have a shared SV */
6614             svp = cSVOPx_svp(((BINOP*)o)->op_last);
6615             if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
6616                 key = SvPV(sv, keylen);
6617                 lexname = newSVpvn_share(key,
6618                                          SvUTF8(sv) ? -(I32)keylen : keylen,
6619                                          0);
6620                 SvREFCNT_dec(sv);
6621                 *svp = lexname;
6622             }
6623             break;
6624         }
6625
6626         case OP_SORT: {
6627             /* will point to RV2AV or PADAV op on LHS/RHS of assign */
6628             OP *oleft, *oright;
6629             OP *o2;
6630
6631             /* check that RHS of sort is a single plain array */
6632             oright = cUNOPo->op_first;
6633             if (!oright || oright->op_type != OP_PUSHMARK)
6634                 break;
6635
6636             /* reverse sort ... can be optimised.  */
6637             if (!cUNOPo->op_sibling) {
6638                 /* Nothing follows us on the list. */
6639                 OP *reverse = o->op_next;
6640
6641                 if (reverse->op_type == OP_REVERSE &&
6642                     (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
6643                     OP *pushmark = cUNOPx(reverse)->op_first;
6644                     if (pushmark && (pushmark->op_type == OP_PUSHMARK)
6645                         && (cUNOPx(pushmark)->op_sibling == o)) {
6646                         /* reverse -> pushmark -> sort */
6647                         o->op_private |= OPpSORT_REVERSE;
6648                         op_null(reverse);
6649                         pushmark->op_next = oright->op_next;
6650                         op_null(oright);
6651                     }
6652                 }
6653             }
6654
6655             /* make @a = sort @a act in-place */
6656
6657             o->op_opt = 1;
6658
6659             oright = cUNOPx(oright)->op_sibling;
6660             if (!oright)
6661                 break;
6662             if (oright->op_type == OP_NULL) { /* skip sort block/sub */
6663                 oright = cUNOPx(oright)->op_sibling;
6664             }
6665
6666             if (!oright ||
6667                 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
6668                 || oright->op_next != o
6669                 || (oright->op_private & OPpLVAL_INTRO)
6670             )
6671                 break;
6672
6673             /* o2 follows the chain of op_nexts through the LHS of the
6674              * assign (if any) to the aassign op itself */
6675             o2 = o->op_next;
6676             if (!o2 || o2->op_type != OP_NULL)
6677                 break;
6678             o2 = o2->op_next;
6679             if (!o2 || o2->op_type != OP_PUSHMARK)
6680                 break;
6681             o2 = o2->op_next;
6682             if (o2 && o2->op_type == OP_GV)
6683                 o2 = o2->op_next;
6684             if (!o2
6685                 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
6686                 || (o2->op_private & OPpLVAL_INTRO)
6687             )
6688                 break;
6689             oleft = o2;
6690             o2 = o2->op_next;
6691             if (!o2 || o2->op_type != OP_NULL)
6692                 break;
6693             o2 = o2->op_next;
6694             if (!o2 || o2->op_type != OP_AASSIGN
6695                     || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
6696                 break;
6697
6698             /* check that the sort is the first arg on RHS of assign */
6699
6700             o2 = cUNOPx(o2)->op_first;
6701             if (!o2 || o2->op_type != OP_NULL)
6702                 break;
6703             o2 = cUNOPx(o2)->op_first;
6704             if (!o2 || o2->op_type != OP_PUSHMARK)
6705                 break;
6706             if (o2->op_sibling != o)
6707                 break;
6708
6709             /* check the array is the same on both sides */
6710             if (oleft->op_type == OP_RV2AV) {
6711                 if (oright->op_type != OP_RV2AV
6712                     || !cUNOPx(oright)->op_first
6713                     || cUNOPx(oright)->op_first->op_type != OP_GV
6714                     ||  cGVOPx_gv(cUNOPx(oleft)->op_first) !=
6715                         cGVOPx_gv(cUNOPx(oright)->op_first)
6716                 )
6717                     break;
6718             }
6719             else if (oright->op_type != OP_PADAV
6720                 || oright->op_targ != oleft->op_targ
6721             )
6722                 break;
6723
6724             /* transfer MODishness etc from LHS arg to RHS arg */
6725             oright->op_flags = oleft->op_flags;
6726             o->op_private |= OPpSORT_INPLACE;
6727
6728             /* excise push->gv->rv2av->null->aassign */
6729             o2 = o->op_next->op_next;
6730             op_null(o2); /* PUSHMARK */
6731             o2 = o2->op_next;
6732             if (o2->op_type == OP_GV) {
6733                 op_null(o2); /* GV */
6734                 o2 = o2->op_next;
6735             }
6736             op_null(o2); /* RV2AV or PADAV */
6737             o2 = o2->op_next->op_next;
6738             op_null(o2); /* AASSIGN */
6739
6740             o->op_next = o2->op_next;
6741
6742             break;
6743         }
6744
6745         case OP_REVERSE: {
6746             OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
6747             OP *gvop = NULL;
6748             LISTOP *enter, *exlist;
6749             o->op_opt = 1;
6750
6751             enter = (LISTOP *) o->op_next;
6752             if (!enter)
6753                 break;
6754             if (enter->op_type == OP_NULL) {
6755                 enter = (LISTOP *) enter->op_next;
6756                 if (!enter)
6757                     break;
6758             }
6759             /* for $a (...) will have OP_GV then OP_RV2GV here.
6760                for (...) just has an OP_GV.  */
6761             if (enter->op_type == OP_GV) {
6762                 gvop = (OP *) enter;
6763                 enter = (LISTOP *) enter->op_next;
6764                 if (!enter)
6765                     break;
6766                 if (enter->op_type == OP_RV2GV) {
6767                   enter = (LISTOP *) enter->op_next;
6768                   if (!enter)
6769                     break;
6770                 }
6771             }
6772
6773             if (enter->op_type != OP_ENTERITER)
6774                 break;
6775
6776             iter = enter->op_next;
6777             if (!iter || iter->op_type != OP_ITER)
6778                 break;
6779
6780             expushmark = enter->op_first;
6781             if (!expushmark || expushmark->op_type != OP_NULL
6782                 || expushmark->op_targ != OP_PUSHMARK)
6783                 break;
6784
6785             exlist = (LISTOP *) expushmark->op_sibling;
6786             if (!exlist || exlist->op_type != OP_NULL
6787                 || exlist->op_targ != OP_LIST)
6788                 break;
6789
6790             if (exlist->op_last != o) {
6791                 /* Mmm. Was expecting to point back to this op.  */
6792                 break;
6793             }
6794             theirmark = exlist->op_first;
6795             if (!theirmark || theirmark->op_type != OP_PUSHMARK)
6796                 break;
6797
6798             if (theirmark->op_sibling != o) {
6799                 /* There's something between the mark and the reverse, eg
6800                    for (1, reverse (...))
6801                    so no go.  */
6802                 break;
6803             }
6804
6805             ourmark = ((LISTOP *)o)->op_first;
6806             if (!ourmark || ourmark->op_type != OP_PUSHMARK)
6807                 break;
6808
6809             ourlast = ((LISTOP *)o)->op_last;
6810             if (!ourlast || ourlast->op_next != o)
6811                 break;
6812
6813             rv2av = ourmark->op_sibling;
6814             if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
6815                 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
6816                 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
6817                 /* We're just reversing a single array.  */
6818                 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
6819                 enter->op_flags |= OPf_STACKED;
6820             }
6821
6822             /* We don't have control over who points to theirmark, so sacrifice
6823                ours.  */
6824             theirmark->op_next = ourmark->op_next;
6825             theirmark->op_flags = ourmark->op_flags;
6826             ourlast->op_next = gvop ? gvop : (OP *) enter;
6827             op_null(ourmark);
6828             op_null(o);
6829             enter->op_private |= OPpITER_REVERSED;
6830             iter->op_private |= OPpITER_REVERSED;
6831
6832             break;
6833         }
6834
6835         default:
6836             o->op_opt = 1;
6837             break;
6838         }
6839         oldop = o;
6840     }
6841     LEAVE;
6842 }
6843
6844
6845
6846 char* Perl_custom_op_name(pTHX_ OP* o)
6847 {
6848     IV  index = PTR2IV(o->op_ppaddr);
6849     SV* keysv;
6850     HE* he;
6851
6852     if (!PL_custom_op_names) /* This probably shouldn't happen */
6853         return PL_op_name[OP_CUSTOM];
6854
6855     keysv = sv_2mortal(newSViv(index));
6856
6857     he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
6858     if (!he)
6859         return PL_op_name[OP_CUSTOM]; /* Don't know who you are */
6860
6861     return SvPV_nolen(HeVAL(he));
6862 }
6863
6864 char* Perl_custom_op_desc(pTHX_ OP* o)
6865 {
6866     IV  index = PTR2IV(o->op_ppaddr);
6867     SV* keysv;
6868     HE* he;
6869
6870     if (!PL_custom_op_descs)
6871         return PL_op_desc[OP_CUSTOM];
6872
6873     keysv = sv_2mortal(newSViv(index));
6874
6875     he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
6876     if (!he)
6877         return PL_op_desc[OP_CUSTOM];
6878
6879     return SvPV_nolen(HeVAL(he));
6880 }
6881
6882
6883 #include "XSUB.h"
6884
6885 /* Efficient sub that returns a constant scalar value. */
6886 static void
6887 const_sv_xsub(pTHX_ CV* cv)
6888 {
6889     dXSARGS;
6890     if (items != 0) {
6891 #if 0
6892         Perl_croak(aTHX_ "usage: %s::%s()",
6893                    HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
6894 #endif
6895     }
6896     EXTEND(sp, 1);
6897     ST(0) = (SV*)XSANY.any_ptr;
6898     XSRETURN(1);
6899 }