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         sv = newGVOP(OP_GV, 0, PL_defgv);
3725     }
3726     if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
3727         expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
3728         iterflags |= OPf_STACKED;
3729     }
3730     else if (expr->op_type == OP_NULL &&
3731              (expr->op_flags & OPf_KIDS) &&
3732              ((BINOP*)expr)->op_first->op_type == OP_FLOP)
3733     {
3734         /* Basically turn for($x..$y) into the same as for($x,$y), but we
3735          * set the STACKED flag to indicate that these values are to be
3736          * treated as min/max values by 'pp_iterinit'.
3737          */
3738         UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
3739         LOGOP* range = (LOGOP*) flip->op_first;
3740         OP* left  = range->op_first;
3741         OP* right = left->op_sibling;
3742         LISTOP* listop;
3743
3744         range->op_flags &= ~OPf_KIDS;
3745         range->op_first = Nullop;
3746
3747         listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
3748         listop->op_first->op_next = range->op_next;
3749         left->op_next = range->op_other;
3750         right->op_next = (OP*)listop;
3751         listop->op_next = listop->op_first;
3752
3753         op_free(expr);
3754         expr = (OP*)(listop);
3755         op_null(expr);
3756         iterflags |= OPf_STACKED;
3757     }
3758     else {
3759         expr = mod(force_list(expr), OP_GREPSTART);
3760     }
3761
3762
3763     loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
3764                                append_elem(OP_LIST, expr, scalar(sv))));
3765     assert(!loop->op_next);
3766     /* for my  $x () sets OPpLVAL_INTRO;
3767      * for our $x () sets OPpOUR_INTRO */
3768     loop->op_private = (U8)iterpflags;
3769 #ifdef PL_OP_SLAB_ALLOC
3770     {
3771         LOOP *tmp;
3772         NewOp(1234,tmp,1,LOOP);
3773         Copy(loop,tmp,1,LOOP);
3774         FreeOp(loop);
3775         loop = tmp;
3776     }
3777 #else
3778     Renew(loop, 1, LOOP);
3779 #endif
3780     loop->op_targ = padoff;
3781     wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
3782     PL_copline = forline;
3783     return newSTATEOP(0, label, wop);
3784 }
3785
3786 OP*
3787 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
3788 {
3789     OP *o;
3790     STRLEN n_a;
3791
3792     if (type != OP_GOTO || label->op_type == OP_CONST) {
3793         /* "last()" means "last" */
3794         if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
3795             o = newOP(type, OPf_SPECIAL);
3796         else {
3797             o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
3798                                         ? SvPVx(((SVOP*)label)->op_sv, n_a)
3799                                         : ""));
3800         }
3801         op_free(label);
3802     }
3803     else {
3804         /* Check whether it's going to be a goto &function */
3805         if (label->op_type == OP_ENTERSUB
3806                 && !(label->op_flags & OPf_STACKED))
3807             label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
3808         o = newUNOP(type, OPf_STACKED, label);
3809     }
3810     PL_hints |= HINT_BLOCK_SCOPE;
3811     return o;
3812 }
3813
3814 /*
3815 =for apidoc cv_undef
3816
3817 Clear out all the active components of a CV. This can happen either
3818 by an explicit C<undef &foo>, or by the reference count going to zero.
3819 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
3820 children can still follow the full lexical scope chain.
3821
3822 =cut
3823 */
3824
3825 void
3826 Perl_cv_undef(pTHX_ CV *cv)
3827 {
3828 #ifdef USE_ITHREADS
3829     if (CvFILE(cv) && !CvXSUB(cv)) {
3830         /* for XSUBs CvFILE point directly to static memory; __FILE__ */
3831         Safefree(CvFILE(cv));
3832     }
3833     CvFILE(cv) = 0;
3834 #endif
3835
3836     if (!CvXSUB(cv) && CvROOT(cv)) {
3837         if (CvDEPTH(cv))
3838             Perl_croak(aTHX_ "Can't undef active subroutine");
3839         ENTER;
3840
3841         PAD_SAVE_SETNULLPAD();
3842
3843         op_free(CvROOT(cv));
3844         CvROOT(cv) = Nullop;
3845         LEAVE;
3846     }
3847     SvPOK_off((SV*)cv);         /* forget prototype */
3848     CvGV(cv) = Nullgv;
3849
3850     pad_undef(cv);
3851
3852     /* remove CvOUTSIDE unless this is an undef rather than a free */
3853     if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
3854         if (!CvWEAKOUTSIDE(cv))
3855             SvREFCNT_dec(CvOUTSIDE(cv));
3856         CvOUTSIDE(cv) = Nullcv;
3857     }
3858     if (CvCONST(cv)) {
3859         SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
3860         CvCONST_off(cv);
3861     }
3862     if (CvXSUB(cv)) {
3863         CvXSUB(cv) = 0;
3864     }
3865     /* delete all flags except WEAKOUTSIDE */
3866     CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
3867 }
3868
3869 void
3870 Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
3871 {
3872     if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
3873         SV* msg = sv_newmortal();
3874         SV* name = Nullsv;
3875
3876         if (gv)
3877             gv_efullname3(name = sv_newmortal(), gv, Nullch);
3878         sv_setpv(msg, "Prototype mismatch:");
3879         if (name)
3880             Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
3881         if (SvPOK(cv))
3882             Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (SV *)cv);
3883         sv_catpv(msg, " vs ");
3884         if (p)
3885             Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
3886         else
3887             sv_catpv(msg, "none");
3888         Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, msg);
3889     }
3890 }
3891
3892 static void const_sv_xsub(pTHX_ CV* cv);
3893
3894 /*
3895
3896 =head1 Optree Manipulation Functions
3897
3898 =for apidoc cv_const_sv
3899
3900 If C<cv> is a constant sub eligible for inlining. returns the constant
3901 value returned by the sub.  Otherwise, returns NULL.
3902
3903 Constant subs can be created with C<newCONSTSUB> or as described in
3904 L<perlsub/"Constant Functions">.
3905
3906 =cut
3907 */
3908 SV *
3909 Perl_cv_const_sv(pTHX_ CV *cv)
3910 {
3911     if (!cv || !CvCONST(cv))
3912         return Nullsv;
3913     return (SV*)CvXSUBANY(cv).any_ptr;
3914 }
3915
3916 /* op_const_sv:  examine an optree to determine whether it's in-lineable.
3917  * Can be called in 3 ways:
3918  *
3919  * !cv
3920  *      look for a single OP_CONST with attached value: return the value
3921  *
3922  * cv && CvCLONE(cv) && !CvCONST(cv)
3923  *
3924  *      examine the clone prototype, and if contains only a single
3925  *      OP_CONST referencing a pad const, or a single PADSV referencing
3926  *      an outer lexical, return a non-zero value to indicate the CV is
3927  *      a candidate for "constizing" at clone time
3928  *
3929  * cv && CvCONST(cv)
3930  *
3931  *      We have just cloned an anon prototype that was marked as a const
3932  *      candidiate. Try to grab the current value, and in the case of
3933  *      PADSV, ignore it if it has multiple references. Return the value.
3934  */
3935
3936 SV *
3937 Perl_op_const_sv(pTHX_ OP *o, CV *cv)
3938 {
3939     SV *sv = Nullsv;
3940
3941     if (!o)
3942         return Nullsv;
3943
3944     if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
3945         o = cLISTOPo->op_first->op_sibling;
3946
3947     for (; o; o = o->op_next) {
3948         OPCODE type = o->op_type;
3949
3950         if (sv && o->op_next == o)
3951             return sv;
3952         if (o->op_next != o) {
3953             if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
3954                 continue;
3955             if (type == OP_DBSTATE)
3956                 continue;
3957         }
3958         if (type == OP_LEAVESUB || type == OP_RETURN)
3959             break;
3960         if (sv)
3961             return Nullsv;
3962         if (type == OP_CONST && cSVOPo->op_sv)
3963             sv = cSVOPo->op_sv;
3964         else if (cv && type == OP_CONST) {
3965             sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
3966             if (!sv)
3967                 return Nullsv;
3968         }
3969         else if (cv && type == OP_PADSV) {
3970             if (CvCONST(cv)) { /* newly cloned anon */
3971                 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
3972                 /* the candidate should have 1 ref from this pad and 1 ref
3973                  * from the parent */
3974                 if (!sv || SvREFCNT(sv) != 2)
3975                     return Nullsv;
3976                 sv = newSVsv(sv);
3977                 SvREADONLY_on(sv);
3978                 return sv;
3979             }
3980             else {
3981                 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
3982                     sv = &PL_sv_undef; /* an arbitrary non-null value */
3983             }
3984         }
3985         else {
3986             return Nullsv;
3987         }
3988     }
3989     return sv;
3990 }
3991
3992 void
3993 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
3994 {
3995     if (o)
3996         SAVEFREEOP(o);
3997     if (proto)
3998         SAVEFREEOP(proto);
3999     if (attrs)
4000         SAVEFREEOP(attrs);
4001     if (block)
4002         SAVEFREEOP(block);
4003     Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4004 }
4005
4006 CV *
4007 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4008 {
4009     return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4010 }
4011
4012 CV *
4013 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4014 {
4015     STRLEN n_a;
4016     char *name;
4017     char *aname;
4018     GV *gv;
4019     char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
4020     register CV *cv=0;
4021     SV *const_sv;
4022
4023     name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4024     if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4025         SV *sv = sv_newmortal();
4026         Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
4027                        PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
4028                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4029         aname = SvPVX(sv);
4030     }
4031     else
4032         aname = Nullch;
4033     gv = gv_fetchpv(name ? name : (aname ? aname :
4034                     (PL_curstash ? "__ANON__" : "__ANON__::__ANON__")),
4035                     GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4036                     SVt_PVCV);
4037
4038     if (o)
4039         SAVEFREEOP(o);
4040     if (proto)
4041         SAVEFREEOP(proto);
4042     if (attrs)
4043         SAVEFREEOP(attrs);
4044
4045     if (SvTYPE(gv) != SVt_PVGV) {       /* Maybe prototype now, and had at
4046                                            maximum a prototype before. */
4047         if (SvTYPE(gv) > SVt_NULL) {
4048             if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4049                 && ckWARN_d(WARN_PROTOTYPE))
4050             {
4051                 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
4052             }
4053             cv_ckproto((CV*)gv, NULL, ps);
4054         }
4055         if (ps)
4056             sv_setpv((SV*)gv, ps);
4057         else
4058             sv_setiv((SV*)gv, -1);
4059         SvREFCNT_dec(PL_compcv);
4060         cv = PL_compcv = NULL;
4061         PL_sub_generation++;
4062         goto done;
4063     }
4064
4065     cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4066
4067 #ifdef GV_UNIQUE_CHECK
4068     if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4069         Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
4070     }
4071 #endif
4072
4073     if (!block || !ps || *ps || attrs)
4074         const_sv = Nullsv;
4075     else
4076         const_sv = op_const_sv(block, Nullcv);
4077
4078     if (cv) {
4079         bool exists = CvROOT(cv) || CvXSUB(cv);
4080
4081 #ifdef GV_UNIQUE_CHECK
4082         if (exists && GvUNIQUE(gv)) {
4083             Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
4084         }
4085 #endif
4086
4087         /* if the subroutine doesn't exist and wasn't pre-declared
4088          * with a prototype, assume it will be AUTOLOADed,
4089          * skipping the prototype check
4090          */
4091         if (exists || SvPOK(cv))
4092             cv_ckproto(cv, gv, ps);
4093         /* already defined (or promised)? */
4094         if (exists || GvASSUMECV(gv)) {
4095             if (!block && !attrs) {
4096                 if (CvFLAGS(PL_compcv)) {
4097                     /* might have had built-in attrs applied */
4098                     CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4099                 }
4100                 /* just a "sub foo;" when &foo is already defined */
4101                 SAVEFREESV(PL_compcv);
4102                 goto done;
4103             }
4104             /* ahem, death to those who redefine active sort subs */
4105             if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4106                 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4107             if (block) {
4108                 if (ckWARN(WARN_REDEFINE)
4109                     || (CvCONST(cv)
4110                         && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4111                 {
4112                     line_t oldline = CopLINE(PL_curcop);
4113                     if (PL_copline != NOLINE)
4114                         CopLINE_set(PL_curcop, PL_copline);
4115                     Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4116                         CvCONST(cv) ? "Constant subroutine %s redefined"
4117                                     : "Subroutine %s redefined", name);
4118                     CopLINE_set(PL_curcop, oldline);
4119                 }
4120                 SvREFCNT_dec(cv);
4121                 cv = Nullcv;
4122             }
4123         }
4124     }
4125     if (const_sv) {
4126         SvREFCNT_inc(const_sv);
4127         if (cv) {
4128             assert(!CvROOT(cv) && !CvCONST(cv));
4129             sv_setpv((SV*)cv, "");  /* prototype is "" */
4130             CvXSUBANY(cv).any_ptr = const_sv;
4131             CvXSUB(cv) = const_sv_xsub;
4132             CvCONST_on(cv);
4133         }
4134         else {
4135             GvCV(gv) = Nullcv;
4136             cv = newCONSTSUB(NULL, name, const_sv);
4137         }
4138         op_free(block);
4139         SvREFCNT_dec(PL_compcv);
4140         PL_compcv = NULL;
4141         PL_sub_generation++;
4142         goto done;
4143     }
4144     if (attrs) {
4145         HV *stash;
4146         SV *rcv;
4147
4148         /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4149          * before we clobber PL_compcv.
4150          */
4151         if (cv && !block) {
4152             rcv = (SV*)cv;
4153             /* Might have had built-in attributes applied -- propagate them. */
4154             CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4155             if (CvGV(cv) && GvSTASH(CvGV(cv)))
4156                 stash = GvSTASH(CvGV(cv));
4157             else if (CvSTASH(cv))
4158                 stash = CvSTASH(cv);
4159             else
4160                 stash = PL_curstash;
4161         }
4162         else {
4163             /* possibly about to re-define existing subr -- ignore old cv */
4164             rcv = (SV*)PL_compcv;
4165             if (name && GvSTASH(gv))
4166                 stash = GvSTASH(gv);
4167             else
4168                 stash = PL_curstash;
4169         }
4170         apply_attrs(stash, rcv, attrs, FALSE);
4171     }
4172     if (cv) {                           /* must reuse cv if autoloaded */
4173         if (!block) {
4174             /* got here with just attrs -- work done, so bug out */
4175             SAVEFREESV(PL_compcv);
4176             goto done;
4177         }
4178         /* transfer PL_compcv to cv */
4179         cv_undef(cv);
4180         CvFLAGS(cv) = CvFLAGS(PL_compcv);
4181         if (!CvWEAKOUTSIDE(cv))
4182             SvREFCNT_dec(CvOUTSIDE(cv));
4183         CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4184         CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
4185         CvOUTSIDE(PL_compcv) = 0;
4186         CvPADLIST(cv) = CvPADLIST(PL_compcv);
4187         CvPADLIST(PL_compcv) = 0;
4188         /* inner references to PL_compcv must be fixed up ... */
4189         pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
4190         /* ... before we throw it away */
4191         SvREFCNT_dec(PL_compcv);
4192         PL_compcv = cv;
4193         if (PERLDB_INTER)/* Advice debugger on the new sub. */
4194           ++PL_sub_generation;
4195     }
4196     else {
4197         cv = PL_compcv;
4198         if (name) {
4199             GvCV(gv) = cv;
4200             GvCVGEN(gv) = 0;
4201             PL_sub_generation++;
4202         }
4203     }
4204     CvGV(cv) = gv;
4205     CvFILE_set_from_cop(cv, PL_curcop);
4206     CvSTASH(cv) = PL_curstash;
4207
4208     if (ps)
4209         sv_setpv((SV*)cv, ps);
4210
4211     if (PL_error_count) {
4212         op_free(block);
4213         block = Nullop;
4214         if (name) {
4215             char *s = strrchr(name, ':');
4216             s = s ? s+1 : name;
4217             if (strEQ(s, "BEGIN")) {
4218                 char *not_safe =
4219                     "BEGIN not safe after errors--compilation aborted";
4220                 if (PL_in_eval & EVAL_KEEPERR)
4221                     Perl_croak(aTHX_ not_safe);
4222                 else {
4223                     /* force display of errors found but not reported */
4224                     sv_catpv(ERRSV, not_safe);
4225                     Perl_croak(aTHX_ "%"SVf, ERRSV);
4226                 }
4227             }
4228         }
4229     }
4230     if (!block)
4231         goto done;
4232
4233     if (CvLVALUE(cv)) {
4234         CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4235                              mod(scalarseq(block), OP_LEAVESUBLV));
4236     }
4237     else {
4238         /* This makes sub {}; work as expected.  */
4239         if (block->op_type == OP_STUB) {
4240             op_free(block);
4241             block = newSTATEOP(0, Nullch, 0);
4242         }
4243         CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4244     }
4245     CvROOT(cv)->op_private |= OPpREFCOUNTED;
4246     OpREFCNT_set(CvROOT(cv), 1);
4247     CvSTART(cv) = LINKLIST(CvROOT(cv));
4248     CvROOT(cv)->op_next = 0;
4249     CALL_PEEP(CvSTART(cv));
4250
4251     /* now that optimizer has done its work, adjust pad values */
4252
4253     pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
4254
4255     if (CvCLONE(cv)) {
4256         assert(!CvCONST(cv));
4257         if (ps && !*ps && op_const_sv(block, cv))
4258             CvCONST_on(cv);
4259     }
4260
4261     if (name || aname) {
4262         char *s;
4263         char *tname = (name ? name : aname);
4264
4265         if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4266             SV *sv = NEWSV(0,0);
4267             SV *tmpstr = sv_newmortal();
4268             GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4269             CV *pcv;
4270             HV *hv;
4271
4272             Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4273                            CopFILE(PL_curcop),
4274                            (long)PL_subline, (long)CopLINE(PL_curcop));
4275             gv_efullname3(tmpstr, gv, Nullch);
4276             hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
4277             hv = GvHVn(db_postponed);
4278             if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
4279                 && (pcv = GvCV(db_postponed)))
4280             {
4281                 dSP;
4282                 PUSHMARK(SP);
4283                 XPUSHs(tmpstr);
4284                 PUTBACK;
4285                 call_sv((SV*)pcv, G_DISCARD);
4286             }
4287         }
4288
4289         if ((s = strrchr(tname,':')))
4290             s++;
4291         else
4292             s = tname;
4293
4294         if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4295             goto done;
4296
4297         if (strEQ(s, "BEGIN") && !PL_error_count) {
4298             I32 oldscope = PL_scopestack_ix;
4299             ENTER;
4300             SAVECOPFILE(&PL_compiling);
4301             SAVECOPLINE(&PL_compiling);
4302
4303             if (!PL_beginav)
4304                 PL_beginav = newAV();
4305             DEBUG_x( dump_sub(gv) );
4306             av_push(PL_beginav, (SV*)cv);
4307             GvCV(gv) = 0;               /* cv has been hijacked */
4308             call_list(oldscope, PL_beginav);
4309
4310             PL_curcop = &PL_compiling;
4311             PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4312             LEAVE;
4313         }
4314         else if (strEQ(s, "END") && !PL_error_count) {
4315             if (!PL_endav)
4316                 PL_endav = newAV();
4317             DEBUG_x( dump_sub(gv) );
4318             av_unshift(PL_endav, 1);
4319             av_store(PL_endav, 0, (SV*)cv);
4320             GvCV(gv) = 0;               /* cv has been hijacked */
4321         }
4322         else if (strEQ(s, "CHECK") && !PL_error_count) {
4323             if (!PL_checkav)
4324                 PL_checkav = newAV();
4325             DEBUG_x( dump_sub(gv) );
4326             if (PL_main_start && ckWARN(WARN_VOID))
4327                 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4328             av_unshift(PL_checkav, 1);
4329             av_store(PL_checkav, 0, (SV*)cv);
4330             GvCV(gv) = 0;               /* cv has been hijacked */
4331         }
4332         else if (strEQ(s, "INIT") && !PL_error_count) {
4333             if (!PL_initav)
4334                 PL_initav = newAV();
4335             DEBUG_x( dump_sub(gv) );
4336             if (PL_main_start && ckWARN(WARN_VOID))
4337                 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4338             av_push(PL_initav, (SV*)cv);
4339             GvCV(gv) = 0;               /* cv has been hijacked */
4340         }
4341     }
4342
4343   done:
4344     PL_copline = NOLINE;
4345     LEAVE_SCOPE(floor);
4346     return cv;
4347 }
4348
4349 /* XXX unsafe for threads if eval_owner isn't held */
4350 /*
4351 =for apidoc newCONSTSUB
4352
4353 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4354 eligible for inlining at compile-time.
4355
4356 =cut
4357 */
4358
4359 CV *
4360 Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
4361 {
4362     CV* cv;
4363
4364     ENTER;
4365
4366     SAVECOPLINE(PL_curcop);
4367     CopLINE_set(PL_curcop, PL_copline);
4368
4369     SAVEHINTS();
4370     PL_hints &= ~HINT_BLOCK_SCOPE;
4371
4372     if (stash) {
4373         SAVESPTR(PL_curstash);
4374         SAVECOPSTASH(PL_curcop);
4375         PL_curstash = stash;
4376         CopSTASH_set(PL_curcop,stash);
4377     }
4378
4379     cv = newXS(name, const_sv_xsub, savepv(CopFILE(PL_curcop)));
4380     CvXSUBANY(cv).any_ptr = sv;
4381     CvCONST_on(cv);
4382     sv_setpv((SV*)cv, "");  /* prototype is "" */
4383
4384     if (stash)
4385         CopSTASH_free(PL_curcop);
4386
4387     LEAVE;
4388
4389     return cv;
4390 }
4391
4392 /*
4393 =for apidoc U||newXS
4394
4395 Used by C<xsubpp> to hook up XSUBs as Perl subs.
4396
4397 =cut
4398 */
4399
4400 CV *
4401 Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
4402 {
4403     GV *gv = gv_fetchpv(name ? name :
4404                         (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4405                         GV_ADDMULTI, SVt_PVCV);
4406     register CV *cv;
4407
4408     if (!subaddr)
4409         Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
4410
4411     if ((cv = (name ? GvCV(gv) : Nullcv))) {
4412         if (GvCVGEN(gv)) {
4413             /* just a cached method */
4414             SvREFCNT_dec(cv);
4415             cv = 0;
4416         }
4417         else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4418             /* already defined (or promised) */
4419             if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
4420                             && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
4421                 line_t oldline = CopLINE(PL_curcop);
4422                 if (PL_copline != NOLINE)
4423                     CopLINE_set(PL_curcop, PL_copline);
4424                 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4425                             CvCONST(cv) ? "Constant subroutine %s redefined"
4426                                         : "Subroutine %s redefined"
4427                             ,name);
4428                 CopLINE_set(PL_curcop, oldline);
4429             }
4430             SvREFCNT_dec(cv);
4431             cv = 0;
4432         }
4433     }
4434
4435     if (cv)                             /* must reuse cv if autoloaded */
4436         cv_undef(cv);
4437     else {
4438         cv = (CV*)NEWSV(1105,0);
4439         sv_upgrade((SV *)cv, SVt_PVCV);
4440         if (name) {
4441             GvCV(gv) = cv;
4442             GvCVGEN(gv) = 0;
4443             PL_sub_generation++;
4444         }
4445     }
4446     CvGV(cv) = gv;
4447     (void)gv_fetchfile(filename);
4448     CvFILE(cv) = filename;      /* NOTE: not copied, as it is expected to be
4449                                    an external constant string */
4450     CvXSUB(cv) = subaddr;
4451
4452     if (name) {
4453         char *s = strrchr(name,':');
4454         if (s)
4455             s++;
4456         else
4457             s = name;
4458
4459         if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4460             goto done;
4461
4462         if (strEQ(s, "BEGIN")) {
4463             if (!PL_beginav)
4464                 PL_beginav = newAV();
4465             av_push(PL_beginav, (SV*)cv);
4466             GvCV(gv) = 0;               /* cv has been hijacked */
4467         }
4468         else if (strEQ(s, "END")) {
4469             if (!PL_endav)
4470                 PL_endav = newAV();
4471             av_unshift(PL_endav, 1);
4472             av_store(PL_endav, 0, (SV*)cv);
4473             GvCV(gv) = 0;               /* cv has been hijacked */
4474         }
4475         else if (strEQ(s, "CHECK")) {
4476             if (!PL_checkav)
4477                 PL_checkav = newAV();
4478             if (PL_main_start && ckWARN(WARN_VOID))
4479                 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4480             av_unshift(PL_checkav, 1);
4481             av_store(PL_checkav, 0, (SV*)cv);
4482             GvCV(gv) = 0;               /* cv has been hijacked */
4483         }
4484         else if (strEQ(s, "INIT")) {
4485             if (!PL_initav)
4486                 PL_initav = newAV();
4487             if (PL_main_start && ckWARN(WARN_VOID))
4488                 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4489             av_push(PL_initav, (SV*)cv);
4490             GvCV(gv) = 0;               /* cv has been hijacked */
4491         }
4492     }
4493     else
4494         CvANON_on(cv);
4495
4496 done:
4497     return cv;
4498 }
4499
4500 void
4501 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
4502 {
4503     register CV *cv;
4504     char *name;
4505     GV *gv;
4506     STRLEN n_a;
4507
4508     if (o)
4509         name = SvPVx(cSVOPo->op_sv, n_a);
4510     else
4511         name = "STDOUT";
4512     gv = gv_fetchpv(name,TRUE, SVt_PVFM);
4513 #ifdef GV_UNIQUE_CHECK
4514     if (GvUNIQUE(gv)) {
4515         Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
4516     }
4517 #endif
4518     GvMULTI_on(gv);
4519     if ((cv = GvFORM(gv))) {
4520         if (ckWARN(WARN_REDEFINE)) {
4521             line_t oldline = CopLINE(PL_curcop);
4522             if (PL_copline != NOLINE)
4523                 CopLINE_set(PL_curcop, PL_copline);
4524             Perl_warner(aTHX_ packWARN(WARN_REDEFINE), "Format %s redefined",name);
4525             CopLINE_set(PL_curcop, oldline);
4526         }
4527         SvREFCNT_dec(cv);
4528     }
4529     cv = PL_compcv;
4530     GvFORM(gv) = cv;
4531     CvGV(cv) = gv;
4532     CvFILE_set_from_cop(cv, PL_curcop);
4533
4534
4535     pad_tidy(padtidy_FORMAT);
4536     CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
4537     CvROOT(cv)->op_private |= OPpREFCOUNTED;
4538     OpREFCNT_set(CvROOT(cv), 1);
4539     CvSTART(cv) = LINKLIST(CvROOT(cv));
4540     CvROOT(cv)->op_next = 0;
4541     CALL_PEEP(CvSTART(cv));
4542     op_free(o);
4543     PL_copline = NOLINE;
4544     LEAVE_SCOPE(floor);
4545 }
4546
4547 OP *
4548 Perl_newANONLIST(pTHX_ OP *o)
4549 {
4550     return newUNOP(OP_REFGEN, 0,
4551         mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
4552 }
4553
4554 OP *
4555 Perl_newANONHASH(pTHX_ OP *o)
4556 {
4557     return newUNOP(OP_REFGEN, 0,
4558         mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
4559 }
4560
4561 OP *
4562 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
4563 {
4564     return newANONATTRSUB(floor, proto, Nullop, block);
4565 }
4566
4567 OP *
4568 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
4569 {
4570     return newUNOP(OP_REFGEN, 0,
4571         newSVOP(OP_ANONCODE, 0,
4572                 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
4573 }
4574
4575 OP *
4576 Perl_oopsAV(pTHX_ OP *o)
4577 {
4578     switch (o->op_type) {
4579     case OP_PADSV:
4580         o->op_type = OP_PADAV;
4581         o->op_ppaddr = PL_ppaddr[OP_PADAV];
4582         return ref(o, OP_RV2AV);
4583
4584     case OP_RV2SV:
4585         o->op_type = OP_RV2AV;
4586         o->op_ppaddr = PL_ppaddr[OP_RV2AV];
4587         ref(o, OP_RV2AV);
4588         break;
4589
4590     default:
4591         if (ckWARN_d(WARN_INTERNAL))
4592             Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
4593         break;
4594     }
4595     return o;
4596 }
4597
4598 OP *
4599 Perl_oopsHV(pTHX_ OP *o)
4600 {
4601     switch (o->op_type) {
4602     case OP_PADSV:
4603     case OP_PADAV:
4604         o->op_type = OP_PADHV;
4605         o->op_ppaddr = PL_ppaddr[OP_PADHV];
4606         return ref(o, OP_RV2HV);
4607
4608     case OP_RV2SV:
4609     case OP_RV2AV:
4610         o->op_type = OP_RV2HV;
4611         o->op_ppaddr = PL_ppaddr[OP_RV2HV];
4612         ref(o, OP_RV2HV);
4613         break;
4614
4615     default:
4616         if (ckWARN_d(WARN_INTERNAL))
4617             Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
4618         break;
4619     }
4620     return o;
4621 }
4622
4623 OP *
4624 Perl_newAVREF(pTHX_ OP *o)
4625 {
4626     if (o->op_type == OP_PADANY) {
4627         o->op_type = OP_PADAV;
4628         o->op_ppaddr = PL_ppaddr[OP_PADAV];
4629         return o;
4630     }
4631     else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
4632                 && ckWARN(WARN_DEPRECATED)) {
4633         Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4634                 "Using an array as a reference is deprecated");
4635     }
4636     return newUNOP(OP_RV2AV, 0, scalar(o));
4637 }
4638
4639 OP *
4640 Perl_newGVREF(pTHX_ I32 type, OP *o)
4641 {
4642     if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
4643         return newUNOP(OP_NULL, 0, o);
4644     return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
4645 }
4646
4647 OP *
4648 Perl_newHVREF(pTHX_ OP *o)
4649 {
4650     if (o->op_type == OP_PADANY) {
4651         o->op_type = OP_PADHV;
4652         o->op_ppaddr = PL_ppaddr[OP_PADHV];
4653         return o;
4654     }
4655     else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
4656                 && ckWARN(WARN_DEPRECATED)) {
4657         Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4658                 "Using a hash as a reference is deprecated");
4659     }
4660     return newUNOP(OP_RV2HV, 0, scalar(o));
4661 }
4662
4663 OP *
4664 Perl_oopsCV(pTHX_ OP *o)
4665 {
4666     Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
4667     /* STUB */
4668     return o;
4669 }
4670
4671 OP *
4672 Perl_newCVREF(pTHX_ I32 flags, OP *o)
4673 {
4674     return newUNOP(OP_RV2CV, flags, scalar(o));
4675 }
4676
4677 OP *
4678 Perl_newSVREF(pTHX_ OP *o)
4679 {
4680     if (o->op_type == OP_PADANY) {
4681         o->op_type = OP_PADSV;
4682         o->op_ppaddr = PL_ppaddr[OP_PADSV];
4683         return o;
4684     }
4685     else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
4686         o->op_flags |= OPpDONE_SVREF;
4687         return o;
4688     }
4689     return newUNOP(OP_RV2SV, 0, scalar(o));
4690 }
4691
4692 /* Check routines. */
4693
4694 OP *
4695 Perl_ck_anoncode(pTHX_ OP *o)
4696 {
4697     cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
4698     cSVOPo->op_sv = Nullsv;
4699     return o;
4700 }
4701
4702 OP *
4703 Perl_ck_bitop(pTHX_ OP *o)
4704 {
4705 #define OP_IS_NUMCOMPARE(op) \
4706         ((op) == OP_LT   || (op) == OP_I_LT || \
4707          (op) == OP_GT   || (op) == OP_I_GT || \
4708          (op) == OP_LE   || (op) == OP_I_LE || \
4709          (op) == OP_GE   || (op) == OP_I_GE || \
4710          (op) == OP_EQ   || (op) == OP_I_EQ || \
4711          (op) == OP_NE   || (op) == OP_I_NE || \
4712          (op) == OP_NCMP || (op) == OP_I_NCMP)
4713     o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4714     if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
4715             && (o->op_type == OP_BIT_OR
4716              || o->op_type == OP_BIT_AND
4717              || o->op_type == OP_BIT_XOR))
4718     {
4719         OP * left = cBINOPo->op_first;
4720         OP * right = left->op_sibling;
4721         if ((OP_IS_NUMCOMPARE(left->op_type) &&
4722                 (left->op_flags & OPf_PARENS) == 0) ||
4723             (OP_IS_NUMCOMPARE(right->op_type) &&
4724                 (right->op_flags & OPf_PARENS) == 0))
4725             if (ckWARN(WARN_PRECEDENCE))
4726                 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
4727                         "Possible precedence problem on bitwise %c operator",
4728                         o->op_type == OP_BIT_OR ? '|'
4729                             : o->op_type == OP_BIT_AND ? '&' : '^'
4730                         );
4731     }
4732     return o;
4733 }
4734
4735 OP *
4736 Perl_ck_concat(pTHX_ OP *o)
4737 {
4738     OP *kid = cUNOPo->op_first;
4739     if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
4740             !(kUNOP->op_first->op_flags & OPf_MOD))
4741         o->op_flags |= OPf_STACKED;
4742     return o;
4743 }
4744
4745 OP *
4746 Perl_ck_spair(pTHX_ OP *o)
4747 {
4748     if (o->op_flags & OPf_KIDS) {
4749         OP* newop;
4750         OP* kid;
4751         OPCODE type = o->op_type;
4752         o = modkids(ck_fun(o), type);
4753         kid = cUNOPo->op_first;
4754         newop = kUNOP->op_first->op_sibling;
4755         if (newop &&
4756             (newop->op_sibling ||
4757              !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
4758              newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
4759              newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
4760
4761             return o;
4762         }
4763         op_free(kUNOP->op_first);
4764         kUNOP->op_first = newop;
4765     }
4766     o->op_ppaddr = PL_ppaddr[++o->op_type];
4767     return ck_fun(o);
4768 }
4769
4770 OP *
4771 Perl_ck_delete(pTHX_ OP *o)
4772 {
4773     o = ck_fun(o);
4774     o->op_private = 0;
4775     if (o->op_flags & OPf_KIDS) {
4776         OP *kid = cUNOPo->op_first;
4777         switch (kid->op_type) {
4778         case OP_ASLICE:
4779             o->op_flags |= OPf_SPECIAL;
4780             /* FALL THROUGH */
4781         case OP_HSLICE:
4782             o->op_private |= OPpSLICE;
4783             break;
4784         case OP_AELEM:
4785             o->op_flags |= OPf_SPECIAL;
4786             /* FALL THROUGH */
4787         case OP_HELEM:
4788             break;
4789         default:
4790             Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
4791                   OP_DESC(o));
4792         }
4793         op_null(kid);
4794     }
4795     return o;
4796 }
4797
4798 OP *
4799 Perl_ck_die(pTHX_ OP *o)
4800 {
4801 #ifdef VMS
4802     if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
4803 #endif
4804     return ck_fun(o);
4805 }
4806
4807 OP *
4808 Perl_ck_eof(pTHX_ OP *o)
4809 {
4810     I32 type = o->op_type;
4811
4812     if (o->op_flags & OPf_KIDS) {
4813         if (cLISTOPo->op_first->op_type == OP_STUB) {
4814             op_free(o);
4815             o = newUNOP(type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
4816         }
4817         return ck_fun(o);
4818     }
4819     return o;
4820 }
4821
4822 OP *
4823 Perl_ck_eval(pTHX_ OP *o)
4824 {
4825     PL_hints |= HINT_BLOCK_SCOPE;
4826     if (o->op_flags & OPf_KIDS) {
4827         SVOP *kid = (SVOP*)cUNOPo->op_first;
4828
4829         if (!kid) {
4830             o->op_flags &= ~OPf_KIDS;
4831             op_null(o);
4832         }
4833         else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
4834             LOGOP *enter;
4835
4836             cUNOPo->op_first = 0;
4837             op_free(o);
4838
4839             NewOp(1101, enter, 1, LOGOP);
4840             enter->op_type = OP_ENTERTRY;
4841             enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
4842             enter->op_private = 0;
4843
4844             /* establish postfix order */
4845             enter->op_next = (OP*)enter;
4846
4847             o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
4848             o->op_type = OP_LEAVETRY;
4849             o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
4850             enter->op_other = o;
4851             return o;
4852         }
4853         else {
4854             scalar((OP*)kid);
4855             PL_cv_has_eval = 1;
4856         }
4857     }
4858     else {
4859         op_free(o);
4860         o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
4861     }
4862     o->op_targ = (PADOFFSET)PL_hints;
4863     return o;
4864 }
4865
4866 OP *
4867 Perl_ck_exit(pTHX_ OP *o)
4868 {
4869 #ifdef VMS
4870     HV *table = GvHV(PL_hintgv);
4871     if (table) {
4872        SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
4873        if (svp && *svp && SvTRUE(*svp))
4874            o->op_private |= OPpEXIT_VMSISH;
4875     }
4876     if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
4877 #endif
4878     return ck_fun(o);
4879 }
4880
4881 OP *
4882 Perl_ck_exec(pTHX_ OP *o)
4883 {
4884     OP *kid;
4885     if (o->op_flags & OPf_STACKED) {
4886         o = ck_fun(o);
4887         kid = cUNOPo->op_first->op_sibling;
4888         if (kid->op_type == OP_RV2GV)
4889             op_null(kid);
4890     }
4891     else
4892         o = listkids(o);
4893     return o;
4894 }
4895
4896 OP *
4897 Perl_ck_exists(pTHX_ OP *o)
4898 {
4899     o = ck_fun(o);
4900     if (o->op_flags & OPf_KIDS) {
4901         OP *kid = cUNOPo->op_first;
4902         if (kid->op_type == OP_ENTERSUB) {
4903             (void) ref(kid, o->op_type);
4904             if (kid->op_type != OP_RV2CV && !PL_error_count)
4905                 Perl_croak(aTHX_ "%s argument is not a subroutine name",
4906                             OP_DESC(o));
4907             o->op_private |= OPpEXISTS_SUB;
4908         }
4909         else if (kid->op_type == OP_AELEM)
4910             o->op_flags |= OPf_SPECIAL;
4911         else if (kid->op_type != OP_HELEM)
4912             Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
4913                         OP_DESC(o));
4914         op_null(kid);
4915     }
4916     return o;
4917 }
4918
4919 #if 0
4920 OP *
4921 Perl_ck_gvconst(pTHX_ register OP *o)
4922 {
4923     o = fold_constants(o);
4924     if (o->op_type == OP_CONST)
4925         o->op_type = OP_GV;
4926     return o;
4927 }
4928 #endif
4929
4930 OP *
4931 Perl_ck_rvconst(pTHX_ register OP *o)
4932 {
4933     SVOP *kid = (SVOP*)cUNOPo->op_first;
4934
4935     o->op_private |= (PL_hints & HINT_STRICT_REFS);
4936     if (kid->op_type == OP_CONST) {
4937         char *name;
4938         int iscv;
4939         GV *gv;
4940         SV *kidsv = kid->op_sv;
4941         STRLEN n_a;
4942
4943         /* Is it a constant from cv_const_sv()? */
4944         if (SvROK(kidsv) && SvREADONLY(kidsv)) {
4945             SV *rsv = SvRV(kidsv);
4946             int svtype = SvTYPE(rsv);
4947             char *badtype = Nullch;
4948
4949             switch (o->op_type) {
4950             case OP_RV2SV:
4951                 if (svtype > SVt_PVMG)
4952                     badtype = "a SCALAR";
4953                 break;
4954             case OP_RV2AV:
4955                 if (svtype != SVt_PVAV)
4956                     badtype = "an ARRAY";
4957                 break;
4958             case OP_RV2HV:
4959                 if (svtype != SVt_PVHV)
4960                     badtype = "a HASH";
4961                 break;
4962             case OP_RV2CV:
4963                 if (svtype != SVt_PVCV)
4964                     badtype = "a CODE";
4965                 break;
4966             }
4967             if (badtype)
4968                 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
4969             return o;
4970         }
4971         name = SvPV(kidsv, n_a);
4972         if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
4973             char *badthing = Nullch;
4974             switch (o->op_type) {
4975             case OP_RV2SV:
4976                 badthing = "a SCALAR";
4977                 break;
4978             case OP_RV2AV:
4979                 badthing = "an ARRAY";
4980                 break;
4981             case OP_RV2HV:
4982                 badthing = "a HASH";
4983                 break;
4984             }
4985             if (badthing)
4986                 Perl_croak(aTHX_
4987           "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
4988                       name, badthing);
4989         }
4990         /*
4991          * This is a little tricky.  We only want to add the symbol if we
4992          * didn't add it in the lexer.  Otherwise we get duplicate strict
4993          * warnings.  But if we didn't add it in the lexer, we must at
4994          * least pretend like we wanted to add it even if it existed before,
4995          * or we get possible typo warnings.  OPpCONST_ENTERED says
4996          * whether the lexer already added THIS instance of this symbol.
4997          */
4998         iscv = (o->op_type == OP_RV2CV) * 2;
4999         do {
5000             gv = gv_fetchpv(name,
5001                 iscv | !(kid->op_private & OPpCONST_ENTERED),
5002                 iscv
5003                     ? SVt_PVCV
5004                     : o->op_type == OP_RV2SV
5005                         ? SVt_PV
5006                         : o->op_type == OP_RV2AV
5007                             ? SVt_PVAV
5008                             : o->op_type == OP_RV2HV
5009                                 ? SVt_PVHV
5010                                 : SVt_PVGV);
5011         } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5012         if (gv) {
5013             kid->op_type = OP_GV;
5014             SvREFCNT_dec(kid->op_sv);
5015 #ifdef USE_ITHREADS
5016             /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5017             kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5018             SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
5019             GvIN_PAD_on(gv);
5020             PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc(gv));
5021 #else
5022             kid->op_sv = SvREFCNT_inc(gv);
5023 #endif
5024             kid->op_private = 0;
5025             kid->op_ppaddr = PL_ppaddr[OP_GV];
5026         }
5027     }
5028     return o;
5029 }
5030
5031 OP *
5032 Perl_ck_ftst(pTHX_ OP *o)
5033 {
5034     I32 type = o->op_type;
5035
5036     if (o->op_flags & OPf_REF) {
5037         /* nothing */
5038     }
5039     else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5040         SVOP *kid = (SVOP*)cUNOPo->op_first;
5041
5042         if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5043             STRLEN n_a;
5044             OP *newop = newGVOP(type, OPf_REF,
5045                 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
5046             op_free(o);
5047             o = newop;
5048         }
5049         else {
5050           if ((PL_hints & HINT_FILETEST_ACCESS) &&
5051               OP_IS_FILETEST_ACCESS(o))
5052             o->op_private |= OPpFT_ACCESS;
5053         }
5054     }
5055     else {
5056         op_free(o);
5057         if (type == OP_FTTTY)
5058             o = newGVOP(type, OPf_REF, PL_stdingv);
5059         else
5060             o = newUNOP(type, 0, newDEFSVOP());
5061     }
5062     return o;
5063 }
5064
5065 OP *
5066 Perl_ck_fun(pTHX_ OP *o)
5067 {
5068     register OP *kid;
5069     OP **tokid;
5070     OP *sibl;
5071     I32 numargs = 0;
5072     int type = o->op_type;
5073     register I32 oa = PL_opargs[type] >> OASHIFT;
5074
5075     if (o->op_flags & OPf_STACKED) {
5076         if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5077             oa &= ~OA_OPTIONAL;
5078         else
5079             return no_fh_allowed(o);
5080     }
5081
5082     if (o->op_flags & OPf_KIDS) {
5083         STRLEN n_a;
5084         tokid = &cLISTOPo->op_first;
5085         kid = cLISTOPo->op_first;
5086         if (kid->op_type == OP_PUSHMARK ||
5087             (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5088         {
5089             tokid = &kid->op_sibling;
5090             kid = kid->op_sibling;
5091         }
5092         if (!kid && PL_opargs[type] & OA_DEFGV)
5093             *tokid = kid = newDEFSVOP();
5094
5095         while (oa && kid) {
5096             numargs++;
5097             sibl = kid->op_sibling;
5098             switch (oa & 7) {
5099             case OA_SCALAR:
5100                 /* list seen where single (scalar) arg expected? */
5101                 if (numargs == 1 && !(oa >> 4)
5102                     && kid->op_type == OP_LIST && type != OP_SCALAR)
5103                 {
5104                     return too_many_arguments(o,PL_op_desc[type]);
5105                 }
5106                 scalar(kid);
5107                 break;
5108             case OA_LIST:
5109                 if (oa < 16) {
5110                     kid = 0;
5111                     continue;
5112                 }
5113                 else
5114                     list(kid);
5115                 break;
5116             case OA_AVREF:
5117                 if ((type == OP_PUSH || type == OP_UNSHIFT)
5118                     && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5119                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5120                         "Useless use of %s with no values",
5121                         PL_op_desc[type]);
5122
5123                 if (kid->op_type == OP_CONST &&
5124                     (kid->op_private & OPpCONST_BARE))
5125                 {
5126                     char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5127                     OP *newop = newAVREF(newGVOP(OP_GV, 0,
5128                         gv_fetchpv(name, TRUE, SVt_PVAV) ));
5129                     if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5130                         Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5131                             "Array @%s missing the @ in argument %"IVdf" of %s()",
5132                             name, (IV)numargs, PL_op_desc[type]);
5133                     op_free(kid);
5134                     kid = newop;
5135                     kid->op_sibling = sibl;
5136                     *tokid = kid;
5137                 }
5138                 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5139                     bad_type(numargs, "array", PL_op_desc[type], kid);
5140                 mod(kid, type);
5141                 break;
5142             case OA_HVREF:
5143                 if (kid->op_type == OP_CONST &&
5144                     (kid->op_private & OPpCONST_BARE))
5145                 {
5146                     char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5147                     OP *newop = newHVREF(newGVOP(OP_GV, 0,
5148                         gv_fetchpv(name, TRUE, SVt_PVHV) ));
5149                     if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5150                         Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5151                             "Hash %%%s missing the %% in argument %"IVdf" of %s()",
5152                             name, (IV)numargs, PL_op_desc[type]);
5153                     op_free(kid);
5154                     kid = newop;
5155                     kid->op_sibling = sibl;
5156                     *tokid = kid;
5157                 }
5158                 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5159                     bad_type(numargs, "hash", PL_op_desc[type], kid);
5160                 mod(kid, type);
5161                 break;
5162             case OA_CVREF:
5163                 {
5164                     OP *newop = newUNOP(OP_NULL, 0, kid);
5165                     kid->op_sibling = 0;
5166                     linklist(kid);
5167                     newop->op_next = newop;
5168                     kid = newop;
5169                     kid->op_sibling = sibl;
5170                     *tokid = kid;
5171                 }
5172                 break;
5173             case OA_FILEREF:
5174                 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5175                     if (kid->op_type == OP_CONST &&
5176                         (kid->op_private & OPpCONST_BARE))
5177                     {
5178                         OP *newop = newGVOP(OP_GV, 0,
5179                             gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
5180                                         SVt_PVIO) );
5181                         if (!(o->op_private & 1) && /* if not unop */
5182                             kid == cLISTOPo->op_last)
5183                             cLISTOPo->op_last = newop;
5184                         op_free(kid);
5185                         kid = newop;
5186                     }
5187                     else if (kid->op_type == OP_READLINE) {
5188                         /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5189                         bad_type(numargs, "HANDLE", OP_DESC(o), kid);
5190                     }
5191                     else {
5192                         I32 flags = OPf_SPECIAL;
5193                         I32 priv = 0;
5194                         PADOFFSET targ = 0;
5195
5196                         /* is this op a FH constructor? */
5197                         if (is_handle_constructor(o,numargs)) {
5198                             char *name = Nullch;
5199                             STRLEN len = 0;
5200
5201                             flags = 0;
5202                             /* Set a flag to tell rv2gv to vivify
5203                              * need to "prove" flag does not mean something
5204                              * else already - NI-S 1999/05/07
5205                              */
5206                             priv = OPpDEREF;
5207                             if (kid->op_type == OP_PADSV) {
5208                                 name = PAD_COMPNAME_PV(kid->op_targ);
5209                                 /* SvCUR of a pad namesv can't be trusted
5210                                  * (see PL_generation), so calc its length
5211                                  * manually */
5212                                 if (name)
5213                                     len = strlen(name);
5214
5215                             }
5216                             else if (kid->op_type == OP_RV2SV
5217                                      && kUNOP->op_first->op_type == OP_GV)
5218                             {
5219                                 GV *gv = cGVOPx_gv(kUNOP->op_first);
5220                                 name = GvNAME(gv);
5221                                 len = GvNAMELEN(gv);
5222                             }
5223                             else if (kid->op_type == OP_AELEM
5224                                      || kid->op_type == OP_HELEM)
5225                             {
5226                                  OP *op;
5227
5228                                  name = 0;
5229                                  if ((op = ((BINOP*)kid)->op_first)) {
5230                                       SV *tmpstr = Nullsv;
5231                                       char *a =
5232                                            kid->op_type == OP_AELEM ?
5233                                            "[]" : "{}";
5234                                       if (((op->op_type == OP_RV2AV) ||
5235                                            (op->op_type == OP_RV2HV)) &&
5236                                           (op = ((UNOP*)op)->op_first) &&
5237                                           (op->op_type == OP_GV)) {
5238                                            /* packagevar $a[] or $h{} */
5239                                            GV *gv = cGVOPx_gv(op);
5240                                            if (gv)
5241                                                 tmpstr =
5242                                                      Perl_newSVpvf(aTHX_
5243                                                                    "%s%c...%c",
5244                                                                    GvNAME(gv),
5245                                                                    a[0], a[1]);
5246                                       }
5247                                       else if (op->op_type == OP_PADAV
5248                                                || op->op_type == OP_PADHV) {
5249                                            /* lexicalvar $a[] or $h{} */
5250                                            char *padname =
5251                                                 PAD_COMPNAME_PV(op->op_targ);
5252                                            if (padname)
5253                                                 tmpstr =
5254                                                      Perl_newSVpvf(aTHX_
5255                                                                    "%s%c...%c",
5256                                                                    padname + 1,
5257                                                                    a[0], a[1]);
5258
5259                                       }
5260                                       if (tmpstr) {
5261                                            name = SvPV(tmpstr, len);
5262                                            sv_2mortal(tmpstr);
5263                                       }
5264                                  }
5265                                  if (!name) {
5266                                       name = "__ANONIO__";
5267                                       len = 10;
5268                                  }
5269                                  mod(kid, type);
5270                             }
5271                             if (name) {
5272                                 SV *namesv;
5273                                 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5274                                 namesv = PAD_SVl(targ);
5275                                 (void)SvUPGRADE(namesv, SVt_PV);
5276                                 if (*name != '$')
5277                                     sv_setpvn(namesv, "$", 1);
5278                                 sv_catpvn(namesv, name, len);
5279                             }
5280                         }
5281                         kid->op_sibling = 0;
5282                         kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5283                         kid->op_targ = targ;
5284                         kid->op_private |= priv;
5285                     }
5286                     kid->op_sibling = sibl;
5287                     *tokid = kid;
5288                 }
5289                 scalar(kid);
5290                 break;
5291             case OA_SCALARREF:
5292                 mod(scalar(kid), type);
5293                 break;
5294             }
5295             oa >>= 4;
5296             tokid = &kid->op_sibling;
5297             kid = kid->op_sibling;
5298         }
5299         o->op_private |= numargs;
5300         if (kid)
5301             return too_many_arguments(o,OP_DESC(o));
5302         listkids(o);
5303     }
5304     else if (PL_opargs[type] & OA_DEFGV) {
5305         op_free(o);
5306         return newUNOP(type, 0, newDEFSVOP());
5307     }
5308
5309     if (oa) {
5310         while (oa & OA_OPTIONAL)
5311             oa >>= 4;
5312         if (oa && oa != OA_LIST)
5313             return too_few_arguments(o,OP_DESC(o));
5314     }
5315     return o;
5316 }
5317
5318 OP *
5319 Perl_ck_glob(pTHX_ OP *o)
5320 {
5321     GV *gv;
5322
5323     o = ck_fun(o);
5324     if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5325         append_elem(OP_GLOB, o, newDEFSVOP());
5326
5327     if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV))
5328           && GvCVu(gv) && GvIMPORTED_CV(gv)))
5329     {
5330         gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5331     }
5332
5333 #if !defined(PERL_EXTERNAL_GLOB)
5334     /* XXX this can be tightened up and made more failsafe. */
5335     if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
5336         GV *glob_gv;
5337         ENTER;
5338         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
5339                 newSVpvn("File::Glob", 10), Nullsv, Nullsv, Nullsv);
5340         gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5341         glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
5342         GvCV(gv) = GvCV(glob_gv);
5343         SvREFCNT_inc((SV*)GvCV(gv));
5344         GvIMPORTED_CV_on(gv);
5345         LEAVE;
5346     }
5347 #endif /* PERL_EXTERNAL_GLOB */
5348
5349     if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5350         append_elem(OP_GLOB, o,
5351                     newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5352         o->op_type = OP_LIST;
5353         o->op_ppaddr = PL_ppaddr[OP_LIST];
5354         cLISTOPo->op_first->op_type = OP_PUSHMARK;
5355         cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5356         cLISTOPo->op_first->op_targ = 0;
5357         o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5358                     append_elem(OP_LIST, o,
5359                                 scalar(newUNOP(OP_RV2CV, 0,
5360                                                newGVOP(OP_GV, 0, gv)))));
5361         o = newUNOP(OP_NULL, 0, ck_subr(o));
5362         o->op_targ = OP_GLOB;           /* hint at what it used to be */
5363         return o;
5364     }
5365     gv = newGVgen("main");
5366     gv_IOadd(gv);
5367     append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5368     scalarkids(o);
5369     return o;
5370 }
5371
5372 OP *
5373 Perl_ck_grep(pTHX_ OP *o)
5374 {
5375     LOGOP *gwop;
5376     OP *kid;
5377     OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5378     I32 offset;
5379
5380     o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5381     NewOp(1101, gwop, 1, LOGOP);
5382
5383     if (o->op_flags & OPf_STACKED) {
5384         OP* k;
5385         o = ck_sort(o);
5386         kid = cLISTOPo->op_first->op_sibling;
5387         for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
5388             kid = k;
5389         }
5390         kid->op_next = (OP*)gwop;
5391         o->op_flags &= ~OPf_STACKED;
5392     }
5393     kid = cLISTOPo->op_first->op_sibling;
5394     if (type == OP_MAPWHILE)
5395         list(kid);
5396     else
5397         scalar(kid);
5398     o = ck_fun(o);
5399     if (PL_error_count)
5400         return o;
5401     kid = cLISTOPo->op_first->op_sibling;
5402     if (kid->op_type != OP_NULL)
5403         Perl_croak(aTHX_ "panic: ck_grep");
5404     kid = kUNOP->op_first;
5405
5406     gwop->op_type = type;
5407     gwop->op_ppaddr = PL_ppaddr[type];
5408     gwop->op_first = listkids(o);
5409     gwop->op_flags |= OPf_KIDS;
5410     gwop->op_other = LINKLIST(kid);
5411     kid->op_next = (OP*)gwop;
5412     offset = pad_findmy("$_");
5413     if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
5414         o->op_private = gwop->op_private = 0;
5415         gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5416     }
5417     else {
5418         o->op_private = gwop->op_private = OPpGREP_LEX;
5419         gwop->op_targ = o->op_targ = offset;
5420     }
5421
5422     kid = cLISTOPo->op_first->op_sibling;
5423     if (!kid || !kid->op_sibling)
5424         return too_few_arguments(o,OP_DESC(o));
5425     for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5426         mod(kid, OP_GREPSTART);
5427
5428     return (OP*)gwop;
5429 }
5430
5431 OP *
5432 Perl_ck_index(pTHX_ OP *o)
5433 {
5434     if (o->op_flags & OPf_KIDS) {
5435         OP *kid = cLISTOPo->op_first->op_sibling;       /* get past pushmark */
5436         if (kid)
5437             kid = kid->op_sibling;                      /* get past "big" */
5438         if (kid && kid->op_type == OP_CONST)
5439             fbm_compile(((SVOP*)kid)->op_sv, 0);
5440     }
5441     return ck_fun(o);
5442 }
5443
5444 OP *
5445 Perl_ck_lengthconst(pTHX_ OP *o)
5446 {
5447     /* XXX length optimization goes here */
5448     return ck_fun(o);
5449 }
5450
5451 OP *
5452 Perl_ck_lfun(pTHX_ OP *o)
5453 {
5454     OPCODE type = o->op_type;
5455     return modkids(ck_fun(o), type);
5456 }
5457
5458 OP *
5459 Perl_ck_defined(pTHX_ OP *o)            /* 19990527 MJD */
5460 {
5461     if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
5462         switch (cUNOPo->op_first->op_type) {
5463         case OP_RV2AV:
5464             /* This is needed for
5465                if (defined %stash::)
5466                to work.   Do not break Tk.
5467                */
5468             break;                      /* Globals via GV can be undef */
5469         case OP_PADAV:
5470         case OP_AASSIGN:                /* Is this a good idea? */
5471             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5472                         "defined(@array) is deprecated");
5473             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5474                         "\t(Maybe you should just omit the defined()?)\n");
5475         break;
5476         case OP_RV2HV:
5477             /* This is needed for
5478                if (defined %stash::)
5479                to work.   Do not break Tk.
5480                */
5481             break;                      /* Globals via GV can be undef */
5482         case OP_PADHV:
5483             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5484                         "defined(%%hash) is deprecated");
5485             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5486                         "\t(Maybe you should just omit the defined()?)\n");
5487             break;
5488         default:
5489             /* no warning */
5490             break;
5491         }
5492     }
5493     return ck_rfun(o);
5494 }
5495
5496 OP *
5497 Perl_ck_rfun(pTHX_ OP *o)
5498 {
5499     OPCODE type = o->op_type;
5500     return refkids(ck_fun(o), type);
5501 }
5502
5503 OP *
5504 Perl_ck_listiob(pTHX_ OP *o)
5505 {
5506     register OP *kid;
5507
5508     kid = cLISTOPo->op_first;
5509     if (!kid) {
5510         o = force_list(o);
5511         kid = cLISTOPo->op_first;
5512     }
5513     if (kid->op_type == OP_PUSHMARK)
5514         kid = kid->op_sibling;
5515     if (kid && o->op_flags & OPf_STACKED)
5516         kid = kid->op_sibling;
5517     else if (kid && !kid->op_sibling) {         /* print HANDLE; */
5518         if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
5519             o->op_flags |= OPf_STACKED; /* make it a filehandle */
5520             kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
5521             cLISTOPo->op_first->op_sibling = kid;
5522             cLISTOPo->op_last = kid;
5523             kid = kid->op_sibling;
5524         }
5525     }
5526
5527     if (!kid)
5528         append_elem(o->op_type, o, newDEFSVOP());
5529
5530     return listkids(o);
5531 }
5532
5533 OP *
5534 Perl_ck_sassign(pTHX_ OP *o)
5535 {
5536     OP *kid = cLISTOPo->op_first;
5537     /* has a disposable target? */
5538     if ((PL_opargs[kid->op_type] & OA_TARGLEX)
5539         && !(kid->op_flags & OPf_STACKED)
5540         /* Cannot steal the second time! */
5541         && !(kid->op_private & OPpTARGET_MY))
5542     {
5543         OP *kkid = kid->op_sibling;
5544
5545         /* Can just relocate the target. */
5546         if (kkid && kkid->op_type == OP_PADSV
5547             && !(kkid->op_private & OPpLVAL_INTRO))
5548         {
5549             kid->op_targ = kkid->op_targ;
5550             kkid->op_targ = 0;
5551             /* Now we do not need PADSV and SASSIGN. */
5552             kid->op_sibling = o->op_sibling;    /* NULL */
5553             cLISTOPo->op_first = NULL;
5554             op_free(o);
5555             op_free(kkid);
5556             kid->op_private |= OPpTARGET_MY;    /* Used for context settings */
5557             return kid;
5558         }
5559     }
5560     return o;
5561 }
5562
5563 OP *
5564 Perl_ck_match(pTHX_ OP *o)
5565 {
5566     if (o->op_type != OP_QR) {
5567         I32 offset = pad_findmy("$_");
5568         if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS(offset) & SVpad_OUR)) {
5569             o->op_targ = offset;
5570             o->op_private |= OPpTARGET_MY;
5571         }
5572     }
5573     if (o->op_type == OP_MATCH || o->op_type == OP_QR)
5574         o->op_private |= OPpRUNTIME;
5575     return o;
5576 }
5577
5578 OP *
5579 Perl_ck_method(pTHX_ OP *o)
5580 {
5581     OP *kid = cUNOPo->op_first;
5582     if (kid->op_type == OP_CONST) {
5583         SV* sv = kSVOP->op_sv;
5584         if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
5585             OP *cmop;
5586             if (!SvREADONLY(sv) || !SvFAKE(sv)) {
5587                 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
5588             }
5589             else {
5590                 kSVOP->op_sv = Nullsv;
5591             }
5592             cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
5593             op_free(o);
5594             return cmop;
5595         }
5596     }
5597     return o;
5598 }
5599
5600 OP *
5601 Perl_ck_null(pTHX_ OP *o)
5602 {
5603     return o;
5604 }
5605
5606 OP *
5607 Perl_ck_open(pTHX_ OP *o)
5608 {
5609     HV *table = GvHV(PL_hintgv);
5610     if (table) {
5611         SV **svp;
5612         I32 mode;
5613         svp = hv_fetch(table, "open_IN", 7, FALSE);
5614         if (svp && *svp) {
5615             mode = mode_from_discipline(*svp);
5616             if (mode & O_BINARY)
5617                 o->op_private |= OPpOPEN_IN_RAW;
5618             else if (mode & O_TEXT)
5619                 o->op_private |= OPpOPEN_IN_CRLF;
5620         }
5621
5622         svp = hv_fetch(table, "open_OUT", 8, FALSE);
5623         if (svp && *svp) {
5624             mode = mode_from_discipline(*svp);
5625             if (mode & O_BINARY)
5626                 o->op_private |= OPpOPEN_OUT_RAW;
5627             else if (mode & O_TEXT)
5628                 o->op_private |= OPpOPEN_OUT_CRLF;
5629         }
5630     }
5631     if (o->op_type == OP_BACKTICK)
5632         return o;
5633     {
5634          /* In case of three-arg dup open remove strictness
5635           * from the last arg if it is a bareword. */
5636          OP *first = cLISTOPx(o)->op_first; /* The pushmark. */
5637          OP *last  = cLISTOPx(o)->op_last;  /* The bareword. */
5638          OP *oa;
5639          char *mode;
5640
5641          if ((last->op_type == OP_CONST) &&             /* The bareword. */
5642              (last->op_private & OPpCONST_BARE) &&
5643              (last->op_private & OPpCONST_STRICT) &&
5644              (oa = first->op_sibling) &&                /* The fh. */
5645              (oa = oa->op_sibling) &&                   /* The mode. */
5646              SvPOK(((SVOP*)oa)->op_sv) &&
5647              (mode = SvPVX(((SVOP*)oa)->op_sv)) &&
5648              mode[0] == '>' && mode[1] == '&' &&        /* A dup open. */
5649              (last == oa->op_sibling))                  /* The bareword. */
5650               last->op_private &= ~OPpCONST_STRICT;
5651     }
5652     return ck_fun(o);
5653 }
5654
5655 OP *
5656 Perl_ck_repeat(pTHX_ OP *o)
5657 {
5658     if (cBINOPo->op_first->op_flags & OPf_PARENS) {
5659         o->op_private |= OPpREPEAT_DOLIST;
5660         cBINOPo->op_first = force_list(cBINOPo->op_first);
5661     }
5662     else
5663         scalar(o);
5664     return o;
5665 }
5666
5667 OP *
5668 Perl_ck_require(pTHX_ OP *o)
5669 {
5670     GV* gv;
5671
5672     if (o->op_flags & OPf_KIDS) {       /* Shall we supply missing .pm? */
5673         SVOP *kid = (SVOP*)cUNOPo->op_first;
5674
5675         if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5676             char *s;
5677             for (s = SvPVX(kid->op_sv); *s; s++) {
5678                 if (*s == ':' && s[1] == ':') {
5679                     *s = '/';
5680                     Move(s+2, s+1, strlen(s+2)+1, char);
5681                     --SvCUR(kid->op_sv);
5682                 }
5683             }
5684             if (SvREADONLY(kid->op_sv)) {
5685                 SvREADONLY_off(kid->op_sv);
5686                 sv_catpvn(kid->op_sv, ".pm", 3);
5687                 SvREADONLY_on(kid->op_sv);
5688             }
5689             else
5690                 sv_catpvn(kid->op_sv, ".pm", 3);
5691         }
5692     }
5693
5694     /* handle override, if any */
5695     gv = gv_fetchpv("require", FALSE, SVt_PVCV);
5696     if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
5697         gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
5698
5699     if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5700         OP *kid = cUNOPo->op_first;
5701         cUNOPo->op_first = 0;
5702         op_free(o);
5703         return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
5704                                append_elem(OP_LIST, kid,
5705                                            scalar(newUNOP(OP_RV2CV, 0,
5706                                                           newGVOP(OP_GV, 0,
5707                                                                   gv))))));
5708     }
5709
5710     return ck_fun(o);
5711 }
5712
5713 OP *
5714 Perl_ck_return(pTHX_ OP *o)
5715 {
5716     OP *kid;
5717     if (CvLVALUE(PL_compcv)) {
5718         for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
5719             mod(kid, OP_LEAVESUBLV);
5720     }
5721     return o;
5722 }
5723
5724 #if 0
5725 OP *
5726 Perl_ck_retarget(pTHX_ OP *o)
5727 {
5728     Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5729     /* STUB */
5730     return o;
5731 }
5732 #endif
5733
5734 OP *
5735 Perl_ck_select(pTHX_ OP *o)
5736 {
5737     OP* kid;
5738     if (o->op_flags & OPf_KIDS) {
5739         kid = cLISTOPo->op_first->op_sibling;   /* get past pushmark */
5740         if (kid && kid->op_sibling) {
5741             o->op_type = OP_SSELECT;
5742             o->op_ppaddr = PL_ppaddr[OP_SSELECT];
5743             o = ck_fun(o);
5744             return fold_constants(o);
5745         }
5746     }
5747     o = ck_fun(o);
5748     kid = cLISTOPo->op_first->op_sibling;    /* get past pushmark */
5749     if (kid && kid->op_type == OP_RV2GV)
5750         kid->op_private &= ~HINT_STRICT_REFS;
5751     return o;
5752 }
5753
5754 OP *
5755 Perl_ck_shift(pTHX_ OP *o)
5756 {
5757     I32 type = o->op_type;
5758
5759     if (!(o->op_flags & OPf_KIDS)) {
5760         OP *argop;
5761
5762         op_free(o);
5763         argop = newUNOP(OP_RV2AV, 0,
5764             scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
5765         return newUNOP(type, 0, scalar(argop));
5766     }
5767     return scalar(modkids(ck_fun(o), type));
5768 }
5769
5770 OP *
5771 Perl_ck_sort(pTHX_ OP *o)
5772 {
5773     OP *firstkid;
5774
5775     if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
5776         simplify_sort(o);
5777     firstkid = cLISTOPo->op_first->op_sibling;          /* get past pushmark */
5778     if (o->op_flags & OPf_STACKED) {                    /* may have been cleared */
5779         OP *k = NULL;
5780         OP *kid = cUNOPx(firstkid)->op_first;           /* get past null */
5781
5782         if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
5783             linklist(kid);
5784             if (kid->op_type == OP_SCOPE) {
5785                 k = kid->op_next;
5786                 kid->op_next = 0;
5787             }
5788             else if (kid->op_type == OP_LEAVE) {
5789                 if (o->op_type == OP_SORT) {
5790                     op_null(kid);                       /* wipe out leave */
5791                     kid->op_next = kid;
5792
5793                     for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
5794                         if (k->op_next == kid)
5795                             k->op_next = 0;
5796                         /* don't descend into loops */
5797                         else if (k->op_type == OP_ENTERLOOP
5798                                  || k->op_type == OP_ENTERITER)
5799                         {
5800                             k = cLOOPx(k)->op_lastop;
5801                         }
5802                     }
5803                 }
5804                 else
5805                     kid->op_next = 0;           /* just disconnect the leave */
5806                 k = kLISTOP->op_first;
5807             }
5808             CALL_PEEP(k);
5809
5810             kid = firstkid;
5811             if (o->op_type == OP_SORT) {
5812                 /* provide scalar context for comparison function/block */
5813                 kid = scalar(kid);
5814                 kid->op_next = kid;
5815             }
5816             else
5817                 kid->op_next = k;
5818             o->op_flags |= OPf_SPECIAL;
5819         }
5820         else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
5821             op_null(firstkid);
5822
5823         firstkid = firstkid->op_sibling;
5824     }
5825
5826     /* provide list context for arguments */
5827     if (o->op_type == OP_SORT)
5828         list(firstkid);
5829
5830     return o;
5831 }
5832
5833 STATIC void
5834 S_simplify_sort(pTHX_ OP *o)
5835 {
5836     register OP *kid = cLISTOPo->op_first->op_sibling;  /* get past pushmark */
5837     OP *k;
5838     int reversed;
5839     GV *gv;
5840     if (!(o->op_flags & OPf_STACKED))
5841         return;
5842     GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
5843     GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
5844     kid = kUNOP->op_first;                              /* get past null */
5845     if (kid->op_type != OP_SCOPE)
5846         return;
5847     kid = kLISTOP->op_last;                             /* get past scope */
5848     switch(kid->op_type) {
5849         case OP_NCMP:
5850         case OP_I_NCMP:
5851         case OP_SCMP:
5852             break;
5853         default:
5854             return;
5855     }
5856     k = kid;                                            /* remember this node*/
5857     if (kBINOP->op_first->op_type != OP_RV2SV)
5858         return;
5859     kid = kBINOP->op_first;                             /* get past cmp */
5860     if (kUNOP->op_first->op_type != OP_GV)
5861         return;
5862     kid = kUNOP->op_first;                              /* get past rv2sv */
5863     gv = kGVOP_gv;
5864     if (GvSTASH(gv) != PL_curstash)
5865         return;
5866     if (strEQ(GvNAME(gv), "a"))
5867         reversed = 0;
5868     else if (strEQ(GvNAME(gv), "b"))
5869         reversed = 1;
5870     else
5871         return;
5872     kid = k;                                            /* back to cmp */
5873     if (kBINOP->op_last->op_type != OP_RV2SV)
5874         return;
5875     kid = kBINOP->op_last;                              /* down to 2nd arg */
5876     if (kUNOP->op_first->op_type != OP_GV)
5877         return;
5878     kid = kUNOP->op_first;                              /* get past rv2sv */
5879     gv = kGVOP_gv;
5880     if (GvSTASH(gv) != PL_curstash
5881         || ( reversed
5882             ? strNE(GvNAME(gv), "a")
5883             : strNE(GvNAME(gv), "b")))
5884         return;
5885     o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
5886     if (reversed)
5887         o->op_private |= OPpSORT_REVERSE;
5888     if (k->op_type == OP_NCMP)
5889         o->op_private |= OPpSORT_NUMERIC;
5890     if (k->op_type == OP_I_NCMP)
5891         o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
5892     kid = cLISTOPo->op_first->op_sibling;
5893     cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
5894     op_free(kid);                                     /* then delete it */
5895 }
5896
5897 OP *
5898 Perl_ck_split(pTHX_ OP *o)
5899 {
5900     register OP *kid;
5901
5902     if (o->op_flags & OPf_STACKED)
5903         return no_fh_allowed(o);
5904
5905     kid = cLISTOPo->op_first;
5906     if (kid->op_type != OP_NULL)
5907         Perl_croak(aTHX_ "panic: ck_split");
5908     kid = kid->op_sibling;
5909     op_free(cLISTOPo->op_first);
5910     cLISTOPo->op_first = kid;
5911     if (!kid) {
5912         cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
5913         cLISTOPo->op_last = kid; /* There was only one element previously */
5914     }
5915
5916     if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
5917         OP *sibl = kid->op_sibling;
5918         kid->op_sibling = 0;
5919         kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
5920         if (cLISTOPo->op_first == cLISTOPo->op_last)
5921             cLISTOPo->op_last = kid;
5922         cLISTOPo->op_first = kid;
5923         kid->op_sibling = sibl;
5924     }
5925
5926     kid->op_type = OP_PUSHRE;
5927     kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
5928     scalar(kid);
5929     if (ckWARN(WARN_REGEXP) && ((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
5930       Perl_warner(aTHX_ packWARN(WARN_REGEXP),
5931                   "Use of /g modifier is meaningless in split");
5932     }
5933
5934     if (!kid->op_sibling)
5935         append_elem(OP_SPLIT, o, newDEFSVOP());
5936
5937     kid = kid->op_sibling;
5938     scalar(kid);
5939
5940     if (!kid->op_sibling)
5941         append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
5942
5943     kid = kid->op_sibling;
5944     scalar(kid);
5945
5946     if (kid->op_sibling)
5947         return too_many_arguments(o,OP_DESC(o));
5948
5949     return o;
5950 }
5951
5952 OP *
5953 Perl_ck_join(pTHX_ OP *o)
5954 {
5955     if (ckWARN(WARN_SYNTAX)) {
5956         OP *kid = cLISTOPo->op_first->op_sibling;
5957         if (kid && kid->op_type == OP_MATCH) {
5958             char *pmstr = "STRING";
5959             if (PM_GETRE(kPMOP))
5960                 pmstr = PM_GETRE(kPMOP)->precomp;
5961             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5962                         "/%s/ should probably be written as \"%s\"",
5963                         pmstr, pmstr);
5964         }
5965     }
5966     return ck_fun(o);
5967 }
5968
5969 OP *
5970 Perl_ck_subr(pTHX_ OP *o)
5971 {
5972     OP *prev = ((cUNOPo->op_first->op_sibling)
5973              ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
5974     OP *o2 = prev->op_sibling;
5975     OP *cvop;
5976     char *proto = 0;
5977     CV *cv = 0;
5978     GV *namegv = 0;
5979     int optional = 0;
5980     I32 arg = 0;
5981     I32 contextclass = 0;
5982     char *e = 0;
5983     STRLEN n_a;
5984     bool delete=0;
5985
5986     o->op_private |= OPpENTERSUB_HASTARG;
5987     for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
5988     if (cvop->op_type == OP_RV2CV) {
5989         SVOP* tmpop;
5990         o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
5991         op_null(cvop);          /* disable rv2cv */
5992         tmpop = (SVOP*)((UNOP*)cvop)->op_first;
5993         if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
5994             GV *gv = cGVOPx_gv(tmpop);
5995             cv = GvCVu(gv);
5996             if (!cv)
5997                 tmpop->op_private |= OPpEARLY_CV;
5998             else {
5999                 if (SvPOK(cv)) {
6000                     namegv = CvANON(cv) ? gv : CvGV(cv);
6001                     proto = SvPV((SV*)cv, n_a);
6002                 }
6003                 if (CvASSERTION(cv)) {
6004                     if (PL_hints & HINT_ASSERTING) {
6005                         if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
6006                             o->op_private |= OPpENTERSUB_DB;
6007                     }
6008                     else {
6009                         delete=1;
6010                         if (ckWARN(WARN_ASSERTIONS) && !(PL_hints & HINT_ASSERTIONSSEEN)) {
6011                             Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
6012                                         "Impossible to activate assertion call");
6013                         }
6014                     }
6015                 }
6016             }
6017         }
6018     }
6019     else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6020         if (o2->op_type == OP_CONST)
6021             o2->op_private &= ~OPpCONST_STRICT;
6022         else if (o2->op_type == OP_LIST) {
6023             OP *o = ((UNOP*)o2)->op_first->op_sibling;
6024             if (o && o->op_type == OP_CONST)
6025                 o->op_private &= ~OPpCONST_STRICT;
6026         }
6027     }
6028     o->op_private |= (PL_hints & HINT_STRICT_REFS);
6029     if (PERLDB_SUB && PL_curstash != PL_debstash)
6030         o->op_private |= OPpENTERSUB_DB;
6031     while (o2 != cvop) {
6032         if (proto) {
6033             switch (*proto) {
6034             case '\0':
6035                 return too_many_arguments(o, gv_ename(namegv));
6036             case ';':
6037                 optional = 1;
6038                 proto++;
6039                 continue;
6040             case '$':
6041                 proto++;
6042                 arg++;
6043                 scalar(o2);
6044                 break;
6045             case '%':
6046             case '@':
6047                 list(o2);
6048                 arg++;
6049                 break;
6050             case '&':
6051                 proto++;
6052                 arg++;
6053                 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6054                     bad_type(arg,
6055                         arg == 1 ? "block or sub {}" : "sub {}",
6056                         gv_ename(namegv), o2);
6057                 break;
6058             case '*':
6059                 /* '*' allows any scalar type, including bareword */
6060                 proto++;
6061                 arg++;
6062                 if (o2->op_type == OP_RV2GV)
6063                     goto wrapref;       /* autoconvert GLOB -> GLOBref */
6064                 else if (o2->op_type == OP_CONST)
6065                     o2->op_private &= ~OPpCONST_STRICT;
6066                 else if (o2->op_type == OP_ENTERSUB) {
6067                     /* accidental subroutine, revert to bareword */
6068                     OP *gvop = ((UNOP*)o2)->op_first;
6069                     if (gvop && gvop->op_type == OP_NULL) {
6070                         gvop = ((UNOP*)gvop)->op_first;
6071                         if (gvop) {
6072                             for (; gvop->op_sibling; gvop = gvop->op_sibling)
6073                                 ;
6074                             if (gvop &&
6075                                 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6076                                 (gvop = ((UNOP*)gvop)->op_first) &&
6077                                 gvop->op_type == OP_GV)
6078                             {
6079                                 GV *gv = cGVOPx_gv(gvop);
6080                                 OP *sibling = o2->op_sibling;
6081                                 SV *n = newSVpvn("",0);
6082                                 op_free(o2);
6083                                 gv_fullname3(n, gv, "");
6084                                 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
6085                                     sv_chop(n, SvPVX(n)+6);
6086                                 o2 = newSVOP(OP_CONST, 0, n);
6087                                 prev->op_sibling = o2;
6088                                 o2->op_sibling = sibling;
6089                             }
6090                         }
6091                     }
6092                 }
6093                 scalar(o2);
6094                 break;
6095             case '[': case ']':
6096                  goto oops;
6097                  break;
6098             case '\\':
6099                 proto++;
6100                 arg++;
6101             again:
6102                 switch (*proto++) {
6103                 case '[':
6104                      if (contextclass++ == 0) {
6105                           e = strchr(proto, ']');
6106                           if (!e || e == proto)
6107                                goto oops;
6108                      }
6109                      else
6110                           goto oops;
6111                      goto again;
6112                      break;
6113                 case ']':
6114                      if (contextclass) {
6115                          char *p = proto;
6116                          char s = *p;
6117                          contextclass = 0;
6118                          *p = '\0';
6119                          while (*--p != '[');
6120                          bad_type(arg, Perl_form(aTHX_ "one of %s", p),
6121                                  gv_ename(namegv), o2);
6122                          *proto = s;
6123                      } else
6124                           goto oops;
6125                      break;
6126                 case '*':
6127                      if (o2->op_type == OP_RV2GV)
6128                           goto wrapref;
6129                      if (!contextclass)
6130                           bad_type(arg, "symbol", gv_ename(namegv), o2);
6131                      break;
6132                 case '&':
6133                      if (o2->op_type == OP_ENTERSUB)
6134                           goto wrapref;
6135                      if (!contextclass)
6136                           bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6137                      break;
6138                 case '$':
6139                     if (o2->op_type == OP_RV2SV ||
6140                         o2->op_type == OP_PADSV ||
6141                         o2->op_type == OP_HELEM ||
6142                         o2->op_type == OP_AELEM ||
6143                         o2->op_type == OP_THREADSV)
6144                          goto wrapref;
6145                     if (!contextclass)
6146                         bad_type(arg, "scalar", gv_ename(namegv), o2);
6147                      break;
6148                 case '@':
6149                     if (o2->op_type == OP_RV2AV ||
6150                         o2->op_type == OP_PADAV)
6151                          goto wrapref;
6152                     if (!contextclass)
6153                         bad_type(arg, "array", gv_ename(namegv), o2);
6154                     break;
6155                 case '%':
6156                     if (o2->op_type == OP_RV2HV ||
6157                         o2->op_type == OP_PADHV)
6158                          goto wrapref;
6159                     if (!contextclass)
6160                          bad_type(arg, "hash", gv_ename(namegv), o2);
6161                     break;
6162                 wrapref:
6163                     {
6164                         OP* kid = o2;
6165                         OP* sib = kid->op_sibling;
6166                         kid->op_sibling = 0;
6167                         o2 = newUNOP(OP_REFGEN, 0, kid);
6168                         o2->op_sibling = sib;
6169                         prev->op_sibling = o2;
6170                     }
6171                     if (contextclass && e) {
6172                          proto = e + 1;
6173                          contextclass = 0;
6174                     }
6175                     break;
6176                 default: goto oops;
6177                 }
6178                 if (contextclass)
6179                      goto again;
6180                 break;
6181             case ' ':
6182                 proto++;
6183                 continue;
6184             default:
6185               oops:
6186                 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
6187                            gv_ename(namegv), cv);
6188             }
6189         }
6190         else
6191             list(o2);
6192         mod(o2, OP_ENTERSUB);
6193         prev = o2;
6194         o2 = o2->op_sibling;
6195     }
6196     if (proto && !optional &&
6197           (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6198         return too_few_arguments(o, gv_ename(namegv));
6199     if(delete) {
6200         op_free(o);
6201         o=newSVOP(OP_CONST, 0, newSViv(0));
6202     }
6203     return o;
6204 }
6205
6206 OP *
6207 Perl_ck_svconst(pTHX_ OP *o)
6208 {
6209     SvREADONLY_on(cSVOPo->op_sv);
6210     return o;
6211 }
6212
6213 OP *
6214 Perl_ck_trunc(pTHX_ OP *o)
6215 {
6216     if (o->op_flags & OPf_KIDS) {
6217         SVOP *kid = (SVOP*)cUNOPo->op_first;
6218
6219         if (kid->op_type == OP_NULL)
6220             kid = (SVOP*)kid->op_sibling;
6221         if (kid && kid->op_type == OP_CONST &&
6222             (kid->op_private & OPpCONST_BARE))
6223         {
6224             o->op_flags |= OPf_SPECIAL;
6225             kid->op_private &= ~OPpCONST_STRICT;
6226         }
6227     }
6228     return ck_fun(o);
6229 }
6230
6231 OP *
6232 Perl_ck_unpack(pTHX_ OP *o)
6233 {
6234     OP *kid = cLISTOPo->op_first;
6235     if (kid->op_sibling) {
6236         kid = kid->op_sibling;
6237         if (!kid->op_sibling)
6238             kid->op_sibling = newDEFSVOP();
6239     }
6240     return ck_fun(o);
6241 }
6242
6243 OP *
6244 Perl_ck_substr(pTHX_ OP *o)
6245 {
6246     o = ck_fun(o);
6247     if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6248         OP *kid = cLISTOPo->op_first;
6249
6250         if (kid->op_type == OP_NULL)
6251             kid = kid->op_sibling;
6252         if (kid)
6253             kid->op_flags |= OPf_MOD;
6254
6255     }
6256     return o;
6257 }
6258
6259 /* A peephole optimizer.  We visit the ops in the order they're to execute. */
6260
6261 void
6262 Perl_peep(pTHX_ register OP *o)
6263 {
6264     register OP* oldop = 0;
6265
6266     if (!o || o->op_seq)
6267         return;
6268     ENTER;
6269     SAVEOP();
6270     SAVEVPTR(PL_curcop);
6271     for (; o; o = o->op_next) {
6272         if (o->op_seq)
6273             break;
6274         /* The special value -1 is used by the B::C compiler backend to indicate
6275          * that an op is statically defined and should not be freed */
6276         if (!PL_op_seqmax || PL_op_seqmax == (U16)-1)
6277             PL_op_seqmax = 1;
6278         PL_op = o;
6279         switch (o->op_type) {
6280         case OP_SETSTATE:
6281         case OP_NEXTSTATE:
6282         case OP_DBSTATE:
6283             PL_curcop = ((COP*)o);              /* for warnings */
6284             o->op_seq = PL_op_seqmax++;
6285             break;
6286
6287         case OP_CONST:
6288             if (cSVOPo->op_private & OPpCONST_STRICT)
6289                 no_bareword_allowed(o);
6290 #ifdef USE_ITHREADS
6291         case OP_METHOD_NAMED:
6292             /* Relocate sv to the pad for thread safety.
6293              * Despite being a "constant", the SV is written to,
6294              * for reference counts, sv_upgrade() etc. */
6295             if (cSVOP->op_sv) {
6296                 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6297                 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
6298                     /* If op_sv is already a PADTMP then it is being used by
6299                      * some pad, so make a copy. */
6300                     sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
6301                     SvREADONLY_on(PAD_SVl(ix));
6302                     SvREFCNT_dec(cSVOPo->op_sv);
6303                 }
6304                 else {
6305                     SvREFCNT_dec(PAD_SVl(ix));
6306                     SvPADTMP_on(cSVOPo->op_sv);
6307                     PAD_SETSV(ix, cSVOPo->op_sv);
6308                     /* XXX I don't know how this isn't readonly already. */
6309                     SvREADONLY_on(PAD_SVl(ix));
6310                 }
6311                 cSVOPo->op_sv = Nullsv;
6312                 o->op_targ = ix;
6313             }
6314 #endif
6315             o->op_seq = PL_op_seqmax++;
6316             break;
6317
6318         case OP_CONCAT:
6319             if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6320                 if (o->op_next->op_private & OPpTARGET_MY) {
6321                     if (o->op_flags & OPf_STACKED) /* chained concats */
6322                         goto ignore_optimization;
6323                     else {
6324                         /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6325                         o->op_targ = o->op_next->op_targ;
6326                         o->op_next->op_targ = 0;
6327                         o->op_private |= OPpTARGET_MY;
6328                     }
6329                 }
6330                 op_null(o->op_next);
6331             }
6332           ignore_optimization:
6333             o->op_seq = PL_op_seqmax++;
6334             break;
6335         case OP_STUB:
6336             if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6337                 o->op_seq = PL_op_seqmax++;
6338                 break; /* Scalar stub must produce undef.  List stub is noop */
6339             }
6340             goto nothin;
6341         case OP_NULL:
6342             if (o->op_targ == OP_NEXTSTATE
6343                 || o->op_targ == OP_DBSTATE
6344                 || o->op_targ == OP_SETSTATE)
6345             {
6346                 PL_curcop = ((COP*)o);
6347             }
6348             /* XXX: We avoid setting op_seq here to prevent later calls
6349                to peep() from mistakenly concluding that optimisation
6350                has already occurred. This doesn't fix the real problem,
6351                though (See 20010220.007). AMS 20010719 */
6352             if (oldop && o->op_next) {
6353                 oldop->op_next = o->op_next;
6354                 continue;
6355             }
6356             break;
6357         case OP_SCALAR:
6358         case OP_LINESEQ:
6359         case OP_SCOPE:
6360           nothin:
6361             if (oldop && o->op_next) {
6362                 oldop->op_next = o->op_next;
6363                 continue;
6364             }
6365             o->op_seq = PL_op_seqmax++;
6366             break;
6367
6368         case OP_GV:
6369             if (o->op_next->op_type == OP_RV2SV) {
6370                 if (!(o->op_next->op_private & OPpDEREF)) {
6371                     op_null(o->op_next);
6372                     o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6373                                                                | OPpOUR_INTRO);
6374                     o->op_next = o->op_next->op_next;
6375                     o->op_type = OP_GVSV;
6376                     o->op_ppaddr = PL_ppaddr[OP_GVSV];
6377                 }
6378             }
6379             else if (o->op_next->op_type == OP_RV2AV) {
6380                 OP* pop = o->op_next->op_next;
6381                 IV i;
6382                 if (pop && pop->op_type == OP_CONST &&
6383                     (PL_op = pop->op_next) &&
6384                     pop->op_next->op_type == OP_AELEM &&
6385                     !(pop->op_next->op_private &
6386                       (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6387                     (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
6388                                 <= 255 &&
6389                     i >= 0)
6390                 {
6391                     GV *gv;
6392                     op_null(o->op_next);
6393                     op_null(pop->op_next);
6394                     op_null(pop);
6395                     o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6396                     o->op_next = pop->op_next->op_next;
6397                     o->op_type = OP_AELEMFAST;
6398                     o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6399                     o->op_private = (U8)i;
6400                     gv = cGVOPo_gv;
6401                     GvAVn(gv);
6402                 }
6403             }
6404             else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6405                 GV *gv = cGVOPo_gv;
6406                 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
6407                     /* XXX could check prototype here instead of just carping */
6408                     SV *sv = sv_newmortal();
6409                     gv_efullname3(sv, gv, Nullch);
6410                     Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
6411                                 "%"SVf"() called too early to check prototype",
6412                                 sv);
6413                 }
6414             }
6415             else if (o->op_next->op_type == OP_READLINE
6416                     && o->op_next->op_next->op_type == OP_CONCAT
6417                     && (o->op_next->op_next->op_flags & OPf_STACKED))
6418             {
6419                 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
6420                 o->op_type   = OP_RCATLINE;
6421                 o->op_flags |= OPf_STACKED;
6422                 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
6423                 op_null(o->op_next->op_next);
6424                 op_null(o->op_next);
6425             }
6426
6427             o->op_seq = PL_op_seqmax++;
6428             break;
6429
6430         case OP_MAPWHILE:
6431         case OP_GREPWHILE:
6432         case OP_AND:
6433         case OP_OR:
6434         case OP_DOR:
6435         case OP_ANDASSIGN:
6436         case OP_ORASSIGN:
6437         case OP_DORASSIGN:
6438         case OP_COND_EXPR:
6439         case OP_RANGE:
6440             o->op_seq = PL_op_seqmax++;
6441             while (cLOGOP->op_other->op_type == OP_NULL)
6442                 cLOGOP->op_other = cLOGOP->op_other->op_next;
6443             peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
6444             break;
6445
6446         case OP_ENTERLOOP:
6447         case OP_ENTERITER:
6448             o->op_seq = PL_op_seqmax++;
6449             while (cLOOP->op_redoop->op_type == OP_NULL)
6450                 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6451             peep(cLOOP->op_redoop);
6452             while (cLOOP->op_nextop->op_type == OP_NULL)
6453                 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6454             peep(cLOOP->op_nextop);
6455             while (cLOOP->op_lastop->op_type == OP_NULL)
6456                 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6457             peep(cLOOP->op_lastop);
6458             break;
6459
6460         case OP_QR:
6461         case OP_MATCH:
6462         case OP_SUBST:
6463             o->op_seq = PL_op_seqmax++;
6464             while (cPMOP->op_pmreplstart &&
6465                    cPMOP->op_pmreplstart->op_type == OP_NULL)
6466                 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6467             peep(cPMOP->op_pmreplstart);
6468             break;
6469
6470         case OP_EXEC:
6471             o->op_seq = PL_op_seqmax++;
6472             if (ckWARN(WARN_SYNTAX) && o->op_next
6473                 && o->op_next->op_type == OP_NEXTSTATE) {
6474                 if (o->op_next->op_sibling &&
6475                         o->op_next->op_sibling->op_type != OP_EXIT &&
6476                         o->op_next->op_sibling->op_type != OP_WARN &&
6477                         o->op_next->op_sibling->op_type != OP_DIE) {
6478                     line_t oldline = CopLINE(PL_curcop);
6479
6480                     CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6481                     Perl_warner(aTHX_ packWARN(WARN_EXEC),
6482                                 "Statement unlikely to be reached");
6483                     Perl_warner(aTHX_ packWARN(WARN_EXEC),
6484                                 "\t(Maybe you meant system() when you said exec()?)\n");
6485                     CopLINE_set(PL_curcop, oldline);
6486                 }
6487             }
6488             break;
6489
6490         case OP_HELEM: {
6491             SV *lexname;
6492             SV **svp, *sv;
6493             char *key = NULL;
6494             STRLEN keylen;
6495
6496             o->op_seq = PL_op_seqmax++;
6497
6498             if (((BINOP*)o)->op_last->op_type != OP_CONST)
6499                 break;
6500
6501             /* Make the CONST have a shared SV */
6502             svp = cSVOPx_svp(((BINOP*)o)->op_last);
6503             if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
6504                 key = SvPV(sv, keylen);
6505                 lexname = newSVpvn_share(key,
6506                                          SvUTF8(sv) ? -(I32)keylen : keylen,
6507                                          0);
6508                 SvREFCNT_dec(sv);
6509                 *svp = lexname;
6510             }
6511             break;
6512         }
6513
6514         default:
6515             o->op_seq = PL_op_seqmax++;
6516             break;
6517         }
6518         oldop = o;
6519     }
6520     LEAVE;
6521 }
6522
6523
6524
6525 char* Perl_custom_op_name(pTHX_ OP* o)
6526 {
6527     IV  index = PTR2IV(o->op_ppaddr);
6528     SV* keysv;
6529     HE* he;
6530
6531     if (!PL_custom_op_names) /* This probably shouldn't happen */
6532         return PL_op_name[OP_CUSTOM];
6533
6534     keysv = sv_2mortal(newSViv(index));
6535
6536     he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
6537     if (!he)
6538         return PL_op_name[OP_CUSTOM]; /* Don't know who you are */
6539
6540     return SvPV_nolen(HeVAL(he));
6541 }
6542
6543 char* Perl_custom_op_desc(pTHX_ OP* o)
6544 {
6545     IV  index = PTR2IV(o->op_ppaddr);
6546     SV* keysv;
6547     HE* he;
6548
6549     if (!PL_custom_op_descs)
6550         return PL_op_desc[OP_CUSTOM];
6551
6552     keysv = sv_2mortal(newSViv(index));
6553
6554     he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
6555     if (!he)
6556         return PL_op_desc[OP_CUSTOM];
6557
6558     return SvPV_nolen(HeVAL(he));
6559 }
6560
6561
6562 #include "XSUB.h"
6563
6564 /* Efficient sub that returns a constant scalar value. */
6565 static void
6566 const_sv_xsub(pTHX_ CV* cv)
6567 {
6568     dXSARGS;
6569     if (items != 0) {
6570 #if 0
6571         Perl_croak(aTHX_ "usage: %s::%s()",
6572                    HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
6573 #endif
6574     }
6575     EXTEND(sp, 1);
6576     ST(0) = (SV*)XSANY.any_ptr;
6577     XSRETURN(1);
6578 }