op.c

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