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