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 $_" 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] == '_' && (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
1677     if (ckWARN(WARN_MISC) &&
1678       (left->op_type == OP_RV2AV ||
1679        left->op_type == OP_RV2HV ||
1680        left->op_type == OP_PADAV ||
1681        left->op_type == OP_PADHV)) {
1682       char *desc = PL_op_desc[(right->op_type == OP_SUBST ||
1683                             right->op_type == OP_TRANS)
1684                            ? right->op_type : OP_MATCH];
1685       const char *sample = ((left->op_type == OP_RV2AV ||
1686                              left->op_type == OP_PADAV)
1687                             ? "@array" : "%hash");
1688       Perl_warner(aTHX_ packWARN(WARN_MISC),
1689              "Applying %s to %s will act on scalar(%s)",
1690              desc, sample, sample);
1691     }
1692
1693     if (right->op_type == OP_CONST &&
1694         cSVOPx(right)->op_private & OPpCONST_BARE &&
1695         cSVOPx(right)->op_private & OPpCONST_STRICT)
1696     {
1697         no_bareword_allowed(right);
1698     }
1699
1700     if (!(right->op_flags & OPf_STACKED) &&
1701        (right->op_type == OP_MATCH ||
1702         right->op_type == OP_SUBST ||
1703         right->op_type == OP_TRANS)) {
1704         right->op_flags |= OPf_STACKED;
1705         if (right->op_type != OP_MATCH &&
1706             ! (right->op_type == OP_TRANS &&
1707                right->op_private & OPpTRANS_IDENTICAL))
1708             left = mod(left, right->op_type);
1709         if (right->op_type == OP_TRANS)
1710             o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
1711         else
1712             o = prepend_elem(right->op_type, scalar(left), right);
1713         if (type == OP_NOT)
1714             return newUNOP(OP_NOT, 0, scalar(o));
1715         return o;
1716     }
1717     else
1718         return bind_match(type, left,
1719                 pmruntime(newPMOP(OP_MATCH, 0), right, Nullop));
1720 }
1721
1722 OP *
1723 Perl_invert(pTHX_ OP *o)
1724 {
1725     if (!o)
1726         return o;
1727     /* XXX need to optimize away NOT NOT here?  Or do we let optimizer do it? */
1728     return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
1729 }
1730
1731 OP *
1732 Perl_scope(pTHX_ OP *o)
1733 {
1734     if (o) {
1735         if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
1736             o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
1737             o->op_type = OP_LEAVE;
1738             o->op_ppaddr = PL_ppaddr[OP_LEAVE];
1739         }
1740         else if (o->op_type == OP_LINESEQ) {
1741             OP *kid;
1742             o->op_type = OP_SCOPE;
1743             o->op_ppaddr = PL_ppaddr[OP_SCOPE];
1744             kid = ((LISTOP*)o)->op_first;
1745             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
1746                 op_null(kid);
1747         }
1748         else
1749             o = newLISTOP(OP_SCOPE, 0, o, Nullop);
1750     }
1751     return o;
1752 }
1753
1754 void
1755 Perl_save_hints(pTHX)
1756 {
1757     SAVEI32(PL_hints);
1758     SAVESPTR(GvHV(PL_hintgv));
1759     GvHV(PL_hintgv) = newHVhv(GvHV(PL_hintgv));
1760     SAVEFREESV(GvHV(PL_hintgv));
1761 }
1762
1763 int
1764 Perl_block_start(pTHX_ int full)
1765 {
1766     int retval = PL_savestack_ix;
1767     /* If there were syntax errors, don't try to start a block */
1768     if (PL_yynerrs) return retval;
1769
1770     pad_block_start(full);
1771     SAVEHINTS();
1772     PL_hints &= ~HINT_BLOCK_SCOPE;
1773     SAVESPTR(PL_compiling.cop_warnings);
1774     if (! specialWARN(PL_compiling.cop_warnings)) {
1775         PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
1776         SAVEFREESV(PL_compiling.cop_warnings) ;
1777     }
1778     SAVESPTR(PL_compiling.cop_io);
1779     if (! specialCopIO(PL_compiling.cop_io)) {
1780         PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
1781         SAVEFREESV(PL_compiling.cop_io) ;
1782     }
1783     return retval;
1784 }
1785
1786 OP*
1787 Perl_block_end(pTHX_ I32 floor, OP *seq)
1788 {
1789     int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
1790     OP* retval = scalarseq(seq);
1791     /* If there were syntax errors, don't try to close a block */
1792     if (PL_yynerrs) return retval;
1793     LEAVE_SCOPE(floor);
1794     PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
1795     if (needblockscope)
1796         PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
1797     pad_leavemy();
1798     return retval;
1799 }
1800
1801 STATIC OP *
1802 S_newDEFSVOP(pTHX)
1803 {
1804     return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
1805 }
1806
1807 void
1808 Perl_newPROG(pTHX_ OP *o)
1809 {
1810     if (PL_in_eval) {
1811         if (PL_eval_root)
1812                 return;
1813         PL_eval_root = newUNOP(OP_LEAVEEVAL,
1814                                ((PL_in_eval & EVAL_KEEPERR)
1815                                 ? OPf_SPECIAL : 0), o);
1816         PL_eval_start = linklist(PL_eval_root);
1817         PL_eval_root->op_private |= OPpREFCOUNTED;
1818         OpREFCNT_set(PL_eval_root, 1);
1819         PL_eval_root->op_next = 0;
1820         CALL_PEEP(PL_eval_start);
1821     }
1822     else {
1823         if (o->op_type == OP_STUB) {
1824             PL_comppad_name = 0;
1825             PL_compcv = 0;
1826             FreeOp(o);
1827             return;
1828         }
1829         PL_main_root = scope(sawparens(scalarvoid(o)));
1830         PL_curcop = &PL_compiling;
1831         PL_main_start = LINKLIST(PL_main_root);
1832         PL_main_root->op_private |= OPpREFCOUNTED;
1833         OpREFCNT_set(PL_main_root, 1);
1834         PL_main_root->op_next = 0;
1835         CALL_PEEP(PL_main_start);
1836         PL_compcv = 0;
1837
1838         /* Register with debugger */
1839         if (PERLDB_INTER) {
1840             CV *cv = get_cv("DB::postponed", FALSE);
1841             if (cv) {
1842                 dSP;
1843                 PUSHMARK(SP);
1844                 XPUSHs((SV*)CopFILEGV(&PL_compiling));
1845                 PUTBACK;
1846                 call_sv((SV*)cv, G_DISCARD);
1847             }
1848         }
1849     }
1850 }
1851
1852 OP *
1853 Perl_localize(pTHX_ OP *o, I32 lex)
1854 {
1855     if (o->op_flags & OPf_PARENS)
1856 /* [perl #17376]: this appears to be premature, and results in code such as
1857    C< our(%x); > executing in list mode rather than void mode */
1858 #if 0
1859         list(o);
1860 #else
1861         ;
1862 #endif
1863     else {
1864         if (ckWARN(WARN_PARENTHESIS)
1865             && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',')
1866         {
1867             char *s = PL_bufptr;
1868             int sigil = 0;
1869
1870             /* some heuristics to detect a potential error */
1871             while (*s && (strchr(", \t\n", *s)
1872                         || (strchr("@$%*", *s) && ++sigil) ))
1873                 s++;
1874             if (sigil) {
1875                 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)
1876                             || strchr("@$%*, \t\n", *s)))
1877                     s++;
1878
1879                 if (*s == ';' || *s == '=')
1880                     Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
1881                                 "Parentheses missing around \"%s\" list",
1882                                 lex ? (PL_in_my == KEY_our ? "our" : "my")
1883                                 : "local");
1884             }
1885         }
1886     }
1887     if (lex)
1888         o = my(o);
1889     else
1890         o = mod(o, OP_NULL);            /* a bit kludgey */
1891     PL_in_my = FALSE;
1892     PL_in_my_stash = Nullhv;
1893     return o;
1894 }
1895
1896 OP *
1897 Perl_jmaybe(pTHX_ OP *o)
1898 {
1899     if (o->op_type == OP_LIST) {
1900         OP *o2;
1901         o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
1902         o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
1903     }
1904     return o;
1905 }
1906
1907 OP *
1908 Perl_fold_constants(pTHX_ register OP *o)
1909 {
1910     register OP *curop;
1911     I32 type = o->op_type;
1912     SV *sv;
1913
1914     if (PL_opargs[type] & OA_RETSCALAR)
1915         scalar(o);
1916     if (PL_opargs[type] & OA_TARGET && !o->op_targ)
1917         o->op_targ = pad_alloc(type, SVs_PADTMP);
1918
1919     /* integerize op, unless it happens to be C<-foo>.
1920      * XXX should pp_i_negate() do magic string negation instead? */
1921     if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
1922         && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
1923              && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
1924     {
1925         o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
1926     }
1927
1928     if (!(PL_opargs[type] & OA_FOLDCONST))
1929         goto nope;
1930
1931     switch (type) {
1932     case OP_NEGATE:
1933         /* XXX might want a ck_negate() for this */
1934         cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
1935         break;
1936     case OP_SPRINTF:
1937     case OP_UCFIRST:
1938     case OP_LCFIRST:
1939     case OP_UC:
1940     case OP_LC:
1941     case OP_SLT:
1942     case OP_SGT:
1943     case OP_SLE:
1944     case OP_SGE:
1945     case OP_SCMP:
1946         /* XXX what about the numeric ops? */
1947         if (PL_hints & HINT_LOCALE)
1948             goto nope;
1949     }
1950
1951     if (PL_error_count)
1952         goto nope;              /* Don't try to run w/ errors */
1953
1954     for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
1955         if ((curop->op_type != OP_CONST ||
1956              (curop->op_private & OPpCONST_BARE)) &&
1957             curop->op_type != OP_LIST &&
1958             curop->op_type != OP_SCALAR &&
1959             curop->op_type != OP_NULL &&
1960             curop->op_type != OP_PUSHMARK)
1961         {
1962             goto nope;
1963         }
1964     }
1965
1966     curop = LINKLIST(o);
1967     o->op_next = 0;
1968     PL_op = curop;
1969     CALLRUNOPS(aTHX);
1970     sv = *(PL_stack_sp--);
1971     if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
1972         pad_swipe(o->op_targ,  FALSE);
1973     else if (SvTEMP(sv)) {                      /* grab mortal temp? */
1974         (void)SvREFCNT_inc(sv);
1975         SvTEMP_off(sv);
1976     }
1977     op_free(o);
1978     if (type == OP_RV2GV)
1979         return newGVOP(OP_GV, 0, (GV*)sv);
1980     return newSVOP(OP_CONST, 0, sv);
1981
1982   nope:
1983     return o;
1984 }
1985
1986 OP *
1987 Perl_gen_constant_list(pTHX_ register OP *o)
1988 {
1989     register OP *curop;
1990     I32 oldtmps_floor = PL_tmps_floor;
1991
1992     list(o);
1993     if (PL_error_count)
1994         return o;               /* Don't attempt to run with errors */
1995
1996     PL_op = curop = LINKLIST(o);
1997     o->op_next = 0;
1998     CALL_PEEP(curop);
1999     pp_pushmark();
2000     CALLRUNOPS(aTHX);
2001     PL_op = curop;
2002     pp_anonlist();
2003     PL_tmps_floor = oldtmps_floor;
2004
2005     o->op_type = OP_RV2AV;
2006     o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2007     o->op_flags &= ~OPf_REF;    /* treat \(1..2) like an ordinary list */
2008     o->op_flags |= OPf_PARENS;  /* and flatten \(1..2,3) */
2009     o->op_seq = 0;              /* needs to be revisited in peep() */
2010     curop = ((UNOP*)o)->op_first;
2011     ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
2012     op_free(curop);
2013     linklist(o);
2014     return list(o);
2015 }
2016
2017 OP *
2018 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2019 {
2020     if (!o || o->op_type != OP_LIST)
2021         o = newLISTOP(OP_LIST, 0, o, Nullop);
2022     else
2023         o->op_flags &= ~OPf_WANT;
2024
2025     if (!(PL_opargs[type] & OA_MARK))
2026         op_null(cLISTOPo->op_first);
2027
2028     o->op_type = (OPCODE)type;
2029     o->op_ppaddr = PL_ppaddr[type];
2030     o->op_flags |= flags;
2031
2032     o = CHECKOP(type, o);
2033     if (o->op_type != type)
2034         return o;
2035
2036     return fold_constants(o);
2037 }
2038
2039 /* List constructors */
2040
2041 OP *
2042 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2043 {
2044     if (!first)
2045         return last;
2046
2047     if (!last)
2048         return first;
2049
2050     if (first->op_type != type
2051         || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2052     {
2053         return newLISTOP(type, 0, first, last);
2054     }
2055
2056     if (first->op_flags & OPf_KIDS)
2057         ((LISTOP*)first)->op_last->op_sibling = last;
2058     else {
2059         first->op_flags |= OPf_KIDS;
2060         ((LISTOP*)first)->op_first = last;
2061     }
2062     ((LISTOP*)first)->op_last = last;
2063     return first;
2064 }
2065
2066 OP *
2067 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2068 {
2069     if (!first)
2070         return (OP*)last;
2071
2072     if (!last)
2073         return (OP*)first;
2074
2075     if (first->op_type != type)
2076         return prepend_elem(type, (OP*)first, (OP*)last);
2077
2078     if (last->op_type != type)
2079         return append_elem(type, (OP*)first, (OP*)last);
2080
2081     first->op_last->op_sibling = last->op_first;
2082     first->op_last = last->op_last;
2083     first->op_flags |= (last->op_flags & OPf_KIDS);
2084
2085     FreeOp(last);
2086
2087     return (OP*)first;
2088 }
2089
2090 OP *
2091 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2092 {
2093     if (!first)
2094         return last;
2095
2096     if (!last)
2097         return first;
2098
2099     if (last->op_type == type) {
2100         if (type == OP_LIST) {  /* already a PUSHMARK there */
2101             first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2102             ((LISTOP*)last)->op_first->op_sibling = first;
2103             if (!(first->op_flags & OPf_PARENS))
2104                 last->op_flags &= ~OPf_PARENS;
2105         }
2106         else {
2107             if (!(last->op_flags & OPf_KIDS)) {
2108                 ((LISTOP*)last)->op_last = first;
2109                 last->op_flags |= OPf_KIDS;
2110             }
2111             first->op_sibling = ((LISTOP*)last)->op_first;
2112             ((LISTOP*)last)->op_first = first;
2113         }
2114         last->op_flags |= OPf_KIDS;
2115         return last;
2116     }
2117
2118     return newLISTOP(type, 0, first, last);
2119 }
2120
2121 /* Constructors */
2122
2123 OP *
2124 Perl_newNULLLIST(pTHX)
2125 {
2126     return newOP(OP_STUB, 0);
2127 }
2128
2129 OP *
2130 Perl_force_list(pTHX_ OP *o)
2131 {
2132     if (!o || o->op_type != OP_LIST)
2133         o = newLISTOP(OP_LIST, 0, o, Nullop);
2134     op_null(o);
2135     return o;
2136 }
2137
2138 OP *
2139 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2140 {
2141     LISTOP *listop;
2142
2143     NewOp(1101, listop, 1, LISTOP);
2144
2145     listop->op_type = (OPCODE)type;
2146     listop->op_ppaddr = PL_ppaddr[type];
2147     if (first || last)
2148         flags |= OPf_KIDS;
2149     listop->op_flags = (U8)flags;
2150
2151     if (!last && first)
2152         last = first;
2153     else if (!first && last)
2154         first = last;
2155     else if (first)
2156         first->op_sibling = last;
2157     listop->op_first = first;
2158     listop->op_last = last;
2159     if (type == OP_LIST) {
2160         OP* pushop;
2161         pushop = newOP(OP_PUSHMARK, 0);
2162         pushop->op_sibling = first;
2163         listop->op_first = pushop;
2164         listop->op_flags |= OPf_KIDS;
2165         if (!last)
2166             listop->op_last = pushop;
2167     }
2168
2169     return CHECKOP(type, listop);
2170 }
2171
2172 OP *
2173 Perl_newOP(pTHX_ I32 type, I32 flags)
2174 {
2175     OP *o;
2176     NewOp(1101, o, 1, OP);
2177     o->op_type = (OPCODE)type;
2178     o->op_ppaddr = PL_ppaddr[type];
2179     o->op_flags = (U8)flags;
2180
2181     o->op_next = o;
2182     o->op_private = (U8)(0 | (flags >> 8));
2183     if (PL_opargs[type] & OA_RETSCALAR)
2184         scalar(o);
2185     if (PL_opargs[type] & OA_TARGET)
2186         o->op_targ = pad_alloc(type, SVs_PADTMP);
2187     return CHECKOP(type, o);
2188 }
2189
2190 OP *
2191 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2192 {
2193     UNOP *unop;
2194
2195     if (!first)
2196         first = newOP(OP_STUB, 0);
2197     if (PL_opargs[type] & OA_MARK)
2198         first = force_list(first);
2199
2200     NewOp(1101, unop, 1, UNOP);
2201     unop->op_type = (OPCODE)type;
2202     unop->op_ppaddr = PL_ppaddr[type];
2203     unop->op_first = first;
2204     unop->op_flags = flags | OPf_KIDS;
2205     unop->op_private = (U8)(1 | (flags >> 8));
2206     unop = (UNOP*) CHECKOP(type, unop);
2207     if (unop->op_next)
2208         return (OP*)unop;
2209
2210     return fold_constants((OP *) unop);
2211 }
2212
2213 OP *
2214 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2215 {
2216     BINOP *binop;
2217     NewOp(1101, binop, 1, BINOP);
2218
2219     if (!first)
2220         first = newOP(OP_NULL, 0);
2221
2222     binop->op_type = (OPCODE)type;
2223     binop->op_ppaddr = PL_ppaddr[type];
2224     binop->op_first = first;
2225     binop->op_flags = flags | OPf_KIDS;
2226     if (!last) {
2227         last = first;
2228         binop->op_private = (U8)(1 | (flags >> 8));
2229     }
2230     else {
2231         binop->op_private = (U8)(2 | (flags >> 8));
2232         first->op_sibling = last;
2233     }
2234
2235     binop = (BINOP*)CHECKOP(type, binop);
2236     if (binop->op_next || binop->op_type != (OPCODE)type)
2237         return (OP*)binop;
2238
2239     binop->op_last = binop->op_first->op_sibling;
2240
2241     return fold_constants((OP *)binop);
2242 }
2243
2244 static int
2245 uvcompare(const void *a, const void *b)
2246 {
2247     if (*((UV *)a) < (*(UV *)b))
2248         return -1;
2249     if (*((UV *)a) > (*(UV *)b))
2250         return 1;
2251     if (*((UV *)a+1) < (*(UV *)b+1))
2252         return -1;
2253     if (*((UV *)a+1) > (*(UV *)b+1))
2254         return 1;
2255     return 0;
2256 }
2257
2258 OP *
2259 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2260 {
2261     SV *tstr = ((SVOP*)expr)->op_sv;
2262     SV *rstr = ((SVOP*)repl)->op_sv;
2263     STRLEN tlen;
2264     STRLEN rlen;
2265     U8 *t = (U8*)SvPV(tstr, tlen);
2266     U8 *r = (U8*)SvPV(rstr, rlen);
2267     register I32 i;
2268     register I32 j;
2269     I32 del;
2270     I32 complement;
2271     I32 squash;
2272     I32 grows = 0;
2273     register short *tbl;
2274
2275     PL_hints |= HINT_BLOCK_SCOPE;
2276     complement  = o->op_private & OPpTRANS_COMPLEMENT;
2277     del         = o->op_private & OPpTRANS_DELETE;
2278     squash      = o->op_private & OPpTRANS_SQUASH;
2279
2280     if (SvUTF8(tstr))
2281         o->op_private |= OPpTRANS_FROM_UTF;
2282
2283     if (SvUTF8(rstr))
2284         o->op_private |= OPpTRANS_TO_UTF;
2285
2286     if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2287         SV* listsv = newSVpvn("# comment\n",10);
2288         SV* transv = 0;
2289         U8* tend = t + tlen;
2290         U8* rend = r + rlen;
2291         STRLEN ulen;
2292         UV tfirst = 1;
2293         UV tlast = 0;
2294         IV tdiff;
2295         UV rfirst = 1;
2296         UV rlast = 0;
2297         IV rdiff;
2298         IV diff;
2299         I32 none = 0;
2300         U32 max = 0;
2301         I32 bits;
2302         I32 havefinal = 0;
2303         U32 final = 0;
2304         I32 from_utf    = o->op_private & OPpTRANS_FROM_UTF;
2305         I32 to_utf      = o->op_private & OPpTRANS_TO_UTF;
2306         U8* tsave = NULL;
2307         U8* rsave = NULL;
2308
2309         if (!from_utf) {
2310             STRLEN len = tlen;
2311             tsave = t = bytes_to_utf8(t, &len);
2312             tend = t + len;
2313         }
2314         if (!to_utf && rlen) {
2315             STRLEN len = rlen;
2316             rsave = r = bytes_to_utf8(r, &len);
2317             rend = r + len;
2318         }
2319
2320 /* There are several snags with this code on EBCDIC:
2321    1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2322    2. scan_const() in toke.c has encoded chars in native encoding which makes
2323       ranges at least in EBCDIC 0..255 range the bottom odd.
2324 */
2325
2326         if (complement) {
2327             U8 tmpbuf[UTF8_MAXLEN+1];
2328             UV *cp;
2329             UV nextmin = 0;
2330             New(1109, cp, 2*tlen, UV);
2331             i = 0;
2332             transv = newSVpvn("",0);
2333             while (t < tend) {
2334                 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2335                 t += ulen;
2336                 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2337                     t++;
2338                     cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2339                     t += ulen;
2340                 }
2341                 else {
2342                  cp[2*i+1] = cp[2*i];
2343                 }
2344                 i++;
2345             }
2346             qsort(cp, i, 2*sizeof(UV), uvcompare);
2347             for (j = 0; j < i; j++) {
2348                 UV  val = cp[2*j];
2349                 diff = val - nextmin;
2350                 if (diff > 0) {
2351                     t = uvuni_to_utf8(tmpbuf,nextmin);
2352                     sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2353                     if (diff > 1) {
2354                         U8  range_mark = UTF_TO_NATIVE(0xff);
2355                         t = uvuni_to_utf8(tmpbuf, val - 1);
2356                         sv_catpvn(transv, (char *)&range_mark, 1);
2357                         sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2358                     }
2359                 }
2360                 val = cp[2*j+1];
2361                 if (val >= nextmin)
2362                     nextmin = val + 1;
2363             }
2364             t = uvuni_to_utf8(tmpbuf,nextmin);
2365             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2366             {
2367                 U8 range_mark = UTF_TO_NATIVE(0xff);
2368                 sv_catpvn(transv, (char *)&range_mark, 1);
2369             }
2370             t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
2371                                     UNICODE_ALLOW_SUPER);
2372             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2373             t = (U8*)SvPVX(transv);
2374             tlen = SvCUR(transv);
2375             tend = t + tlen;
2376             Safefree(cp);
2377         }
2378         else if (!rlen && !del) {
2379             r = t; rlen = tlen; rend = tend;
2380         }
2381         if (!squash) {
2382                 if ((!rlen && !del) || t == r ||
2383                     (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2384                 {
2385                     o->op_private |= OPpTRANS_IDENTICAL;
2386                 }
2387         }
2388
2389         while (t < tend || tfirst <= tlast) {
2390             /* see if we need more "t" chars */
2391             if (tfirst > tlast) {
2392                 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2393                 t += ulen;
2394                 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {    /* illegal utf8 val indicates range */
2395                     t++;
2396                     tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2397                     t += ulen;
2398                 }
2399                 else
2400                     tlast = tfirst;
2401             }
2402
2403             /* now see if we need more "r" chars */
2404             if (rfirst > rlast) {
2405                 if (r < rend) {
2406                     rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2407                     r += ulen;
2408                     if (r < rend && NATIVE_TO_UTF(*r) == 0xff) {        /* illegal utf8 val indicates range */
2409                         r++;
2410                         rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2411                         r += ulen;
2412                     }
2413                     else
2414                         rlast = rfirst;
2415                 }
2416                 else {
2417                     if (!havefinal++)
2418                         final = rlast;
2419                     rfirst = rlast = 0xffffffff;
2420                 }
2421             }
2422
2423             /* now see which range will peter our first, if either. */
2424             tdiff = tlast - tfirst;
2425             rdiff = rlast - rfirst;
2426
2427             if (tdiff <= rdiff)
2428                 diff = tdiff;
2429             else
2430                 diff = rdiff;
2431
2432             if (rfirst == 0xffffffff) {
2433                 diff = tdiff;   /* oops, pretend rdiff is infinite */
2434                 if (diff > 0)
2435                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2436                                    (long)tfirst, (long)tlast);
2437                 else
2438                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2439             }
2440             else {
2441                 if (diff > 0)
2442                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2443                                    (long)tfirst, (long)(tfirst + diff),
2444                                    (long)rfirst);
2445                 else
2446                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2447                                    (long)tfirst, (long)rfirst);
2448
2449                 if (rfirst + diff > max)
2450                     max = rfirst + diff;
2451                 if (!grows)
2452                     grows = (tfirst < rfirst &&
2453                              UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2454                 rfirst += diff + 1;
2455             }
2456             tfirst += diff + 1;
2457         }
2458
2459         none = ++max;
2460         if (del)
2461             del = ++max;
2462
2463         if (max > 0xffff)
2464             bits = 32;
2465         else if (max > 0xff)
2466             bits = 16;
2467         else
2468             bits = 8;
2469
2470         Safefree(cPVOPo->op_pv);
2471         cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2472         SvREFCNT_dec(listsv);
2473         if (transv)
2474             SvREFCNT_dec(transv);
2475
2476         if (!del && havefinal && rlen)
2477             (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2478                            newSVuv((UV)final), 0);
2479
2480         if (grows)
2481             o->op_private |= OPpTRANS_GROWS;
2482
2483         if (tsave)
2484             Safefree(tsave);
2485         if (rsave)
2486             Safefree(rsave);
2487
2488         op_free(expr);
2489         op_free(repl);
2490         return o;
2491     }
2492
2493     tbl = (short*)cPVOPo->op_pv;
2494     if (complement) {
2495         Zero(tbl, 256, short);
2496         for (i = 0; i < (I32)tlen; i++)
2497             tbl[t[i]] = -1;
2498         for (i = 0, j = 0; i < 256; i++) {
2499             if (!tbl[i]) {
2500                 if (j >= (I32)rlen) {
2501                     if (del)
2502                         tbl[i] = -2;
2503                     else if (rlen)
2504                         tbl[i] = r[j-1];
2505                     else
2506                         tbl[i] = (short)i;
2507                 }
2508                 else {
2509                     if (i < 128 && r[j] >= 128)
2510                         grows = 1;
2511                     tbl[i] = r[j++];
2512                 }
2513             }
2514         }
2515         if (!del) {
2516             if (!rlen) {
2517                 j = rlen;
2518                 if (!squash)
2519                     o->op_private |= OPpTRANS_IDENTICAL;
2520             }
2521             else if (j >= (I32)rlen)
2522                 j = rlen - 1;
2523             else
2524                 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
2525             tbl[0x100] = rlen - j;
2526             for (i=0; i < (I32)rlen - j; i++)
2527                 tbl[0x101+i] = r[j+i];
2528         }
2529     }
2530     else {
2531         if (!rlen && !del) {
2532             r = t; rlen = tlen;
2533             if (!squash)
2534                 o->op_private |= OPpTRANS_IDENTICAL;
2535         }
2536         else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
2537             o->op_private |= OPpTRANS_IDENTICAL;
2538         }
2539         for (i = 0; i < 256; i++)
2540             tbl[i] = -1;
2541         for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
2542             if (j >= (I32)rlen) {
2543                 if (del) {
2544                     if (tbl[t[i]] == -1)
2545                         tbl[t[i]] = -2;
2546                     continue;
2547                 }
2548                 --j;
2549             }
2550             if (tbl[t[i]] == -1) {
2551                 if (t[i] < 128 && r[j] >= 128)
2552                     grows = 1;
2553                 tbl[t[i]] = r[j];
2554             }
2555         }
2556     }
2557     if (grows)
2558         o->op_private |= OPpTRANS_GROWS;
2559     op_free(expr);
2560     op_free(repl);
2561
2562     return o;
2563 }
2564
2565 OP *
2566 Perl_newPMOP(pTHX_ I32 type, I32 flags)
2567 {
2568     PMOP *pmop;
2569
2570     NewOp(1101, pmop, 1, PMOP);
2571     pmop->op_type = (OPCODE)type;
2572     pmop->op_ppaddr = PL_ppaddr[type];
2573     pmop->op_flags = (U8)flags;
2574     pmop->op_private = (U8)(0 | (flags >> 8));
2575
2576     if (PL_hints & HINT_RE_TAINT)
2577         pmop->op_pmpermflags |= PMf_RETAINT;
2578     if (PL_hints & HINT_LOCALE)
2579         pmop->op_pmpermflags |= PMf_LOCALE;
2580     pmop->op_pmflags = pmop->op_pmpermflags;
2581
2582 #ifdef USE_ITHREADS
2583     {
2584         SV* repointer;
2585         if(av_len((AV*) PL_regex_pad[0]) > -1) {
2586             repointer = av_pop((AV*)PL_regex_pad[0]);
2587             pmop->op_pmoffset = SvIV(repointer);
2588             SvREPADTMP_off(repointer);
2589             sv_setiv(repointer,0);
2590         } else {
2591             repointer = newSViv(0);
2592             av_push(PL_regex_padav,SvREFCNT_inc(repointer));
2593             pmop->op_pmoffset = av_len(PL_regex_padav);
2594             PL_regex_pad = AvARRAY(PL_regex_padav);
2595         }
2596     }
2597 #endif
2598
2599         /* link into pm list */
2600     if (type != OP_TRANS && PL_curstash) {
2601         pmop->op_pmnext = HvPMROOT(PL_curstash);
2602         HvPMROOT(PL_curstash) = pmop;
2603         PmopSTASH_set(pmop,PL_curstash);
2604     }
2605
2606     return CHECKOP(type, pmop);
2607 }
2608
2609 OP *
2610 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl)
2611 {
2612     PMOP *pm;
2613     LOGOP *rcop;
2614     I32 repl_has_vars = 0;
2615
2616     if (o->op_type == OP_TRANS)
2617         return pmtrans(o, expr, repl);
2618
2619     PL_hints |= HINT_BLOCK_SCOPE;
2620     pm = (PMOP*)o;
2621
2622     if (expr->op_type == OP_CONST) {
2623         STRLEN plen;
2624         SV *pat = ((SVOP*)expr)->op_sv;
2625         char *p = SvPV(pat, plen);
2626         if ((o->op_flags & OPf_SPECIAL) && strEQ(p, " ")) {
2627             sv_setpvn(pat, "\\s+", 3);
2628             p = SvPV(pat, plen);
2629             pm->op_pmflags |= PMf_SKIPWHITE;
2630         }
2631         if (DO_UTF8(pat))
2632             pm->op_pmdynflags |= PMdf_UTF8;
2633         PM_SETRE(pm, CALLREGCOMP(aTHX_ p, p + plen, pm));
2634         if (strEQ("\\s+", PM_GETRE(pm)->precomp))
2635             pm->op_pmflags |= PMf_WHITE;
2636         op_free(expr);
2637     }
2638     else {
2639         if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
2640             expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
2641                             ? OP_REGCRESET
2642                             : OP_REGCMAYBE),0,expr);
2643
2644         NewOp(1101, rcop, 1, LOGOP);
2645         rcop->op_type = OP_REGCOMP;
2646         rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
2647         rcop->op_first = scalar(expr);
2648         rcop->op_flags |= ((PL_hints & HINT_RE_EVAL)
2649                            ? (OPf_SPECIAL | OPf_KIDS)
2650                            : OPf_KIDS);
2651         rcop->op_private = 1;
2652         rcop->op_other = o;
2653         /* /$x/ may cause an eval, since $x might be qr/(?{..})/  */
2654         PL_cv_has_eval = 1;
2655
2656         /* establish postfix order */
2657         if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
2658             LINKLIST(expr);
2659             rcop->op_next = expr;
2660             ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
2661         }
2662         else {
2663             rcop->op_next = LINKLIST(expr);
2664             expr->op_next = (OP*)rcop;
2665         }
2666
2667         prepend_elem(o->op_type, scalar((OP*)rcop), o);
2668     }
2669
2670     if (repl) {
2671         OP *curop;
2672         if (pm->op_pmflags & PMf_EVAL) {
2673             curop = 0;
2674             if (CopLINE(PL_curcop) < (line_t)PL_multi_end)
2675                 CopLINE_set(PL_curcop, (line_t)PL_multi_end);
2676         }
2677         else if (repl->op_type == OP_CONST)
2678             curop = repl;
2679         else {
2680             OP *lastop = 0;
2681             for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
2682                 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
2683                     if (curop->op_type == OP_GV) {
2684                         GV *gv = cGVOPx_gv(curop);
2685                         repl_has_vars = 1;
2686                         if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
2687                             break;
2688                     }
2689                     else if (curop->op_type == OP_RV2CV)
2690                         break;
2691                     else if (curop->op_type == OP_RV2SV ||
2692                              curop->op_type == OP_RV2AV ||
2693                              curop->op_type == OP_RV2HV ||
2694                              curop->op_type == OP_RV2GV) {
2695                         if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
2696                             break;
2697                     }
2698                     else if (curop->op_type == OP_PADSV ||
2699                              curop->op_type == OP_PADAV ||
2700                              curop->op_type == OP_PADHV ||
2701                              curop->op_type == OP_PADANY) {
2702                         repl_has_vars = 1;
2703                     }
2704                     else if (curop->op_type == OP_PUSHRE)
2705                         ; /* Okay here, dangerous in newASSIGNOP */
2706                     else
2707                         break;
2708                 }
2709                 lastop = curop;
2710             }
2711         }
2712         if (curop == repl
2713             && !(repl_has_vars
2714                  && (!PM_GETRE(pm)
2715                      || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
2716             pm->op_pmflags |= PMf_CONST;        /* const for long enough */
2717             pm->op_pmpermflags |= PMf_CONST;    /* const for long enough */
2718             prepend_elem(o->op_type, scalar(repl), o);
2719         }
2720         else {
2721             if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
2722                 pm->op_pmflags |= PMf_MAYBE_CONST;
2723                 pm->op_pmpermflags |= PMf_MAYBE_CONST;
2724             }
2725             NewOp(1101, rcop, 1, LOGOP);
2726             rcop->op_type = OP_SUBSTCONT;
2727             rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
2728             rcop->op_first = scalar(repl);
2729             rcop->op_flags |= OPf_KIDS;
2730             rcop->op_private = 1;
2731             rcop->op_other = o;
2732
2733             /* establish postfix order */
2734             rcop->op_next = LINKLIST(repl);
2735             repl->op_next = (OP*)rcop;
2736
2737             pm->op_pmreplroot = scalar((OP*)rcop);
2738             pm->op_pmreplstart = LINKLIST(rcop);
2739             rcop->op_next = 0;
2740         }
2741     }
2742
2743     return (OP*)pm;
2744 }
2745
2746 OP *
2747 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
2748 {
2749     SVOP *svop;
2750     NewOp(1101, svop, 1, SVOP);
2751     svop->op_type = (OPCODE)type;
2752     svop->op_ppaddr = PL_ppaddr[type];
2753     svop->op_sv = sv;
2754     svop->op_next = (OP*)svop;
2755     svop->op_flags = (U8)flags;
2756     if (PL_opargs[type] & OA_RETSCALAR)
2757         scalar((OP*)svop);
2758     if (PL_opargs[type] & OA_TARGET)
2759         svop->op_targ = pad_alloc(type, SVs_PADTMP);
2760     return CHECKOP(type, svop);
2761 }
2762
2763 OP *
2764 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
2765 {
2766     PADOP *padop;
2767     NewOp(1101, padop, 1, PADOP);
2768     padop->op_type = (OPCODE)type;
2769     padop->op_ppaddr = PL_ppaddr[type];
2770     padop->op_padix = pad_alloc(type, SVs_PADTMP);
2771     SvREFCNT_dec(PAD_SVl(padop->op_padix));
2772     PAD_SETSV(padop->op_padix, sv);
2773     if (sv)
2774         SvPADTMP_on(sv);
2775     padop->op_next = (OP*)padop;
2776     padop->op_flags = (U8)flags;
2777     if (PL_opargs[type] & OA_RETSCALAR)
2778         scalar((OP*)padop);
2779     if (PL_opargs[type] & OA_TARGET)
2780         padop->op_targ = pad_alloc(type, SVs_PADTMP);
2781     return CHECKOP(type, padop);
2782 }
2783
2784 OP *
2785 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
2786 {
2787 #ifdef USE_ITHREADS
2788     if (gv)
2789         GvIN_PAD_on(gv);
2790     return newPADOP(type, flags, SvREFCNT_inc(gv));
2791 #else
2792     return newSVOP(type, flags, SvREFCNT_inc(gv));
2793 #endif
2794 }
2795
2796 OP *
2797 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
2798 {
2799     PVOP *pvop;
2800     NewOp(1101, pvop, 1, PVOP);
2801     pvop->op_type = (OPCODE)type;
2802     pvop->op_ppaddr = PL_ppaddr[type];
2803     pvop->op_pv = pv;
2804     pvop->op_next = (OP*)pvop;
2805     pvop->op_flags = (U8)flags;
2806     if (PL_opargs[type] & OA_RETSCALAR)
2807         scalar((OP*)pvop);
2808     if (PL_opargs[type] & OA_TARGET)
2809         pvop->op_targ = pad_alloc(type, SVs_PADTMP);
2810     return CHECKOP(type, pvop);
2811 }
2812
2813 void
2814 Perl_package(pTHX_ OP *o)
2815 {
2816     char *name;
2817     STRLEN len;
2818
2819     save_hptr(&PL_curstash);
2820     save_item(PL_curstname);
2821
2822     name = SvPV(cSVOPo->op_sv, len);
2823     PL_curstash = gv_stashpvn(name, len, TRUE);
2824     sv_setpvn(PL_curstname, name, len);
2825     op_free(o);
2826
2827     PL_hints |= HINT_BLOCK_SCOPE;
2828     PL_copline = NOLINE;
2829     PL_expect = XSTATE;
2830 }
2831
2832 void
2833 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
2834 {
2835     OP *pack;
2836     OP *imop;
2837     OP *veop;
2838
2839     if (idop->op_type != OP_CONST)
2840         Perl_croak(aTHX_ "Module name must be constant");
2841
2842     veop = Nullop;
2843
2844     if (version != Nullop) {
2845         SV *vesv = ((SVOP*)version)->op_sv;
2846
2847         if (arg == Nullop && !SvNIOKp(vesv)) {
2848             arg = version;
2849         }
2850         else {
2851             OP *pack;
2852             SV *meth;
2853
2854             if (version->op_type != OP_CONST || !SvNIOKp(vesv))
2855                 Perl_croak(aTHX_ "Version number must be constant number");
2856
2857             /* Make copy of idop so we don't free it twice */
2858             pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
2859
2860             /* Fake up a method call to VERSION */
2861             meth = newSVpvn("VERSION",7);
2862             sv_upgrade(meth, SVt_PVIV);
2863             (void)SvIOK_on(meth);
2864             PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
2865             veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
2866                             append_elem(OP_LIST,
2867                                         prepend_elem(OP_LIST, pack, list(version)),
2868                                         newSVOP(OP_METHOD_NAMED, 0, meth)));
2869         }
2870     }
2871
2872     /* Fake up an import/unimport */
2873     if (arg && arg->op_type == OP_STUB)
2874         imop = arg;             /* no import on explicit () */
2875     else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
2876         imop = Nullop;          /* use 5.0; */
2877     }
2878     else {
2879         SV *meth;
2880
2881         /* Make copy of idop so we don't free it twice */
2882         pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
2883
2884         /* Fake up a method call to import/unimport */
2885         meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);
2886         (void)SvUPGRADE(meth, SVt_PVIV);
2887         (void)SvIOK_on(meth);
2888         PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
2889         imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
2890                        append_elem(OP_LIST,
2891                                    prepend_elem(OP_LIST, pack, list(arg)),
2892                                    newSVOP(OP_METHOD_NAMED, 0, meth)));
2893     }
2894
2895     /* Fake up the BEGIN {}, which does its thing immediately. */
2896     newATTRSUB(floor,
2897         newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
2898         Nullop,
2899         Nullop,
2900         append_elem(OP_LINESEQ,
2901             append_elem(OP_LINESEQ,
2902                 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, idop)),
2903                 newSTATEOP(0, Nullch, veop)),
2904             newSTATEOP(0, Nullch, imop) ));
2905
2906     /* The "did you use incorrect case?" warning used to be here.
2907      * The problem is that on case-insensitive filesystems one
2908      * might get false positives for "use" (and "require"):
2909      * "use Strict" or "require CARP" will work.  This causes
2910      * portability problems for the script: in case-strict
2911      * filesystems the script will stop working.
2912      *
2913      * The "incorrect case" warning checked whether "use Foo"
2914      * imported "Foo" to your namespace, but that is wrong, too:
2915      * there is no requirement nor promise in the language that
2916      * a Foo.pm should or would contain anything in package "Foo".
2917      *
2918      * There is very little Configure-wise that can be done, either:
2919      * the case-sensitivity of the build filesystem of Perl does not
2920      * help in guessing the case-sensitivity of the runtime environment.
2921      */
2922
2923     PL_hints |= HINT_BLOCK_SCOPE;
2924     PL_copline = NOLINE;
2925     PL_expect = XSTATE;
2926     PL_cop_seqmax++; /* Purely for B::*'s benefit */
2927 }
2928
2929 /*
2930 =head1 Embedding Functions
2931
2932 =for apidoc load_module
2933
2934 Loads the module whose name is pointed to by the string part of name.
2935 Note that the actual module name, not its filename, should be given.
2936 Eg, "Foo::Bar" instead of "Foo/Bar.pm".  flags can be any of
2937 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
2938 (or 0 for no flags). ver, if specified, provides version semantics
2939 similar to C<use Foo::Bar VERSION>.  The optional trailing SV*
2940 arguments can be used to specify arguments to the module's import()
2941 method, similar to C<use Foo::Bar VERSION LIST>.
2942
2943 =cut */
2944
2945 void
2946 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
2947 {
2948     va_list args;
2949     va_start(args, ver);
2950     vload_module(flags, name, ver, &args);
2951     va_end(args);
2952 }
2953
2954 #ifdef PERL_IMPLICIT_CONTEXT
2955 void
2956 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
2957 {
2958     dTHX;
2959     va_list args;
2960     va_start(args, ver);
2961     vload_module(flags, name, ver, &args);
2962     va_end(args);
2963 }
2964 #endif
2965
2966 void
2967 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
2968 {
2969     OP *modname, *veop, *imop;
2970
2971     modname = newSVOP(OP_CONST, 0, name);
2972     modname->op_private |= OPpCONST_BARE;
2973     if (ver) {
2974         veop = newSVOP(OP_CONST, 0, ver);
2975     }
2976     else
2977         veop = Nullop;
2978     if (flags & PERL_LOADMOD_NOIMPORT) {
2979         imop = sawparens(newNULLLIST());
2980     }
2981     else if (flags & PERL_LOADMOD_IMPORT_OPS) {
2982         imop = va_arg(*args, OP*);
2983     }
2984     else {
2985         SV *sv;
2986         imop = Nullop;
2987         sv = va_arg(*args, SV*);
2988         while (sv) {
2989             imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
2990             sv = va_arg(*args, SV*);
2991         }
2992     }
2993     {
2994         line_t ocopline = PL_copline;
2995         COP *ocurcop = PL_curcop;
2996         int oexpect = PL_expect;
2997
2998         utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
2999                 veop, modname, imop);
3000         PL_expect = oexpect;
3001         PL_copline = ocopline;
3002         PL_curcop = ocurcop;
3003     }
3004 }
3005
3006 OP *
3007 Perl_dofile(pTHX_ OP *term)
3008 {
3009     OP *doop;
3010     GV *gv;
3011
3012     gv = gv_fetchpv("do", FALSE, SVt_PVCV);
3013     if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
3014         gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3015
3016     if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3017         doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3018                                append_elem(OP_LIST, term,
3019                                            scalar(newUNOP(OP_RV2CV, 0,
3020                                                           newGVOP(OP_GV, 0,
3021                                                                   gv))))));
3022     }
3023     else {
3024         doop = newUNOP(OP_DOFILE, 0, scalar(term));
3025     }
3026     return doop;
3027 }
3028
3029 OP *
3030 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3031 {
3032     return newBINOP(OP_LSLICE, flags,
3033             list(force_list(subscript)),
3034             list(force_list(listval)) );
3035 }
3036
3037 STATIC I32
3038 S_list_assignment(pTHX_ register OP *o)
3039 {
3040     if (!o)
3041         return TRUE;
3042
3043     if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3044         o = cUNOPo->op_first;
3045
3046     if (o->op_type == OP_COND_EXPR) {
3047         I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3048         I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3049
3050         if (t && f)
3051             return TRUE;
3052         if (t || f)
3053             yyerror("Assignment to both a list and a scalar");
3054         return FALSE;
3055     }
3056
3057     if (o->op_type == OP_LIST &&
3058         (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR &&
3059         o->op_private & OPpLVAL_INTRO)
3060         return FALSE;
3061
3062     if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3063         o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3064         o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3065         return TRUE;
3066
3067     if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3068         return TRUE;
3069
3070     if (o->op_type == OP_RV2SV)
3071         return FALSE;
3072
3073     return FALSE;
3074 }
3075
3076 OP *
3077 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3078 {
3079     OP *o;
3080
3081     if (optype) {
3082         if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
3083             return newLOGOP(optype, 0,
3084                 mod(scalar(left), optype),
3085                 newUNOP(OP_SASSIGN, 0, scalar(right)));
3086         }
3087         else {
3088             return newBINOP(optype, OPf_STACKED,
3089                 mod(scalar(left), optype), scalar(right));
3090         }
3091     }
3092
3093     if (list_assignment(left)) {
3094         OP *curop;
3095
3096         PL_modcount = 0;
3097         PL_eval_start = right;  /* Grandfathering $[ assignment here.  Bletch.*/
3098         left = mod(left, OP_AASSIGN);
3099         if (PL_eval_start)
3100             PL_eval_start = 0;
3101         else {
3102             op_free(left);
3103             op_free(right);
3104             return Nullop;
3105         }
3106         curop = list(force_list(left));
3107         o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3108         o->op_private = (U8)(0 | (flags >> 8));
3109
3110         /* PL_generation sorcery:
3111          * an assignment like ($a,$b) = ($c,$d) is easier than
3112          * ($a,$b) = ($c,$a), since there is no need for temporary vars.
3113          * To detect whether there are common vars, the global var
3114          * PL_generation is incremented for each assign op we compile.
3115          * Then, while compiling the assign op, we run through all the
3116          * variables on both sides of the assignment, setting a spare slot
3117          * in each of them to PL_generation. If any of them already have
3118          * that value, we know we've got commonality.  We could use a
3119          * single bit marker, but then we'd have to make 2 passes, first
3120          * to clear the flag, then to test and set it.  To find somewhere
3121          * to store these values, evil chicanery is done with SvCUR().
3122          */
3123
3124         if (!(left->op_private & OPpLVAL_INTRO)) {
3125             OP *lastop = o;
3126             PL_generation++;
3127             for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3128                 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3129                     if (curop->op_type == OP_GV) {
3130                         GV *gv = cGVOPx_gv(curop);
3131                         if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3132                             break;
3133                         SvCUR(gv) = PL_generation;
3134                     }
3135                     else if (curop->op_type == OP_PADSV ||
3136                              curop->op_type == OP_PADAV ||
3137                              curop->op_type == OP_PADHV ||
3138                              curop->op_type == OP_PADANY)
3139                     {
3140                         if (PAD_COMPNAME_GEN(curop->op_targ)
3141                                                     == (STRLEN)PL_generation)
3142                             break;
3143                         PAD_COMPNAME_GEN(curop->op_targ)
3144                                                         = PL_generation;
3145
3146                     }
3147                     else if (curop->op_type == OP_RV2CV)
3148                         break;
3149                     else if (curop->op_type == OP_RV2SV ||
3150                              curop->op_type == OP_RV2AV ||
3151                              curop->op_type == OP_RV2HV ||
3152                              curop->op_type == OP_RV2GV) {
3153                         if (lastop->op_type != OP_GV)   /* funny deref? */
3154                             break;
3155                     }
3156                     else if (curop->op_type == OP_PUSHRE) {
3157                         if (((PMOP*)curop)->op_pmreplroot) {
3158 #ifdef USE_ITHREADS
3159                             GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET,
3160                                         ((PMOP*)curop)->op_pmreplroot));
3161 #else
3162                             GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3163 #endif
3164                             if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3165                                 break;
3166                             SvCUR(gv) = PL_generation;
3167                         }
3168                     }
3169                     else
3170                         break;
3171                 }
3172                 lastop = curop;
3173             }
3174             if (curop != o)
3175                 o->op_private |= OPpASSIGN_COMMON;
3176         }
3177         if (right && right->op_type == OP_SPLIT) {
3178             OP* tmpop;
3179             if ((tmpop = ((LISTOP*)right)->op_first) &&
3180                 tmpop->op_type == OP_PUSHRE)
3181             {
3182                 PMOP *pm = (PMOP*)tmpop;
3183                 if (left->op_type == OP_RV2AV &&
3184                     !(left->op_private & OPpLVAL_INTRO) &&
3185                     !(o->op_private & OPpASSIGN_COMMON) )
3186                 {
3187                     tmpop = ((UNOP*)left)->op_first;
3188                     if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3189 #ifdef USE_ITHREADS
3190                         pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
3191                         cPADOPx(tmpop)->op_padix = 0;   /* steal it */
3192 #else
3193                         pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3194                         cSVOPx(tmpop)->op_sv = Nullsv;  /* steal it */
3195 #endif
3196                         pm->op_pmflags |= PMf_ONCE;
3197                         tmpop = cUNOPo->op_first;       /* to list (nulled) */
3198                         tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3199                         tmpop->op_sibling = Nullop;     /* don't free split */
3200                         right->op_next = tmpop->op_next;  /* fix starting loc */
3201                         op_free(o);                     /* blow off assign */
3202                         right->op_flags &= ~OPf_WANT;
3203                                 /* "I don't know and I don't care." */
3204                         return right;
3205                     }
3206                 }
3207                 else {
3208                    if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3209                       ((LISTOP*)right)->op_last->op_type == OP_CONST)
3210                     {
3211                         SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3212                         if (SvIVX(sv) == 0)
3213                             sv_setiv(sv, PL_modcount+1);
3214                     }
3215                 }
3216             }
3217         }
3218         return o;
3219     }
3220     if (!right)
3221         right = newOP(OP_UNDEF, 0);
3222     if (right->op_type == OP_READLINE) {
3223         right->op_flags |= OPf_STACKED;
3224         return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3225     }
3226     else {
3227         PL_eval_start = right;  /* Grandfathering $[ assignment here.  Bletch.*/
3228         o = newBINOP(OP_SASSIGN, flags,
3229             scalar(right), mod(scalar(left), OP_SASSIGN) );
3230         if (PL_eval_start)
3231             PL_eval_start = 0;
3232         else {
3233             op_free(o);
3234             return Nullop;
3235         }
3236     }
3237     return o;
3238 }
3239
3240 OP *
3241 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3242 {
3243     U32 seq = intro_my();
3244     register COP *cop;
3245
3246     NewOp(1101, cop, 1, COP);
3247     if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3248         cop->op_type = OP_DBSTATE;
3249         cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3250     }
3251     else {
3252         cop->op_type = OP_NEXTSTATE;
3253         cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3254     }
3255     cop->op_flags = (U8)flags;
3256     cop->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
3257 #ifdef NATIVE_HINTS
3258     cop->op_private |= NATIVE_HINTS;
3259 #endif
3260     PL_compiling.op_private = cop->op_private;
3261     cop->op_next = (OP*)cop;
3262
3263     if (label) {
3264         cop->cop_label = label;
3265         PL_hints |= HINT_BLOCK_SCOPE;
3266     }
3267     cop->cop_seq = seq;
3268     cop->cop_arybase = PL_curcop->cop_arybase;
3269     if (specialWARN(PL_curcop->cop_warnings))
3270         cop->cop_warnings = PL_curcop->cop_warnings ;
3271     else
3272         cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3273     if (specialCopIO(PL_curcop->cop_io))
3274         cop->cop_io = PL_curcop->cop_io;
3275     else
3276         cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3277
3278
3279     if (PL_copline == NOLINE)
3280         CopLINE_set(cop, CopLINE(PL_curcop));
3281     else {
3282         CopLINE_set(cop, PL_copline);
3283         PL_copline = NOLINE;
3284     }
3285 #ifdef USE_ITHREADS
3286     CopFILE_set(cop, CopFILE(PL_curcop));       /* XXX share in a pvtable? */
3287 #else
3288     CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3289 #endif
3290     CopSTASH_set(cop, PL_curstash);
3291
3292     if (PERLDB_LINE && PL_curstash != PL_debstash) {
3293         SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3294         if (svp && *svp != &PL_sv_undef ) {
3295            (void)SvIOK_on(*svp);
3296             SvIVX(*svp) = PTR2IV(cop);
3297         }
3298     }
3299
3300     return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3301 }
3302
3303
3304 OP *
3305 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3306 {
3307     return new_logop(type, flags, &first, &other);
3308 }
3309
3310 STATIC OP *
3311 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3312 {
3313     LOGOP *logop;
3314     OP *o;
3315     OP *first = *firstp;
3316     OP *other = *otherp;
3317
3318     if (type == OP_XOR)         /* Not short circuit, but here by precedence. */
3319         return newBINOP(type, flags, scalar(first), scalar(other));
3320
3321     scalarboolean(first);
3322     /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3323     if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3324         if (type == OP_AND || type == OP_OR) {
3325             if (type == OP_AND)
3326                 type = OP_OR;
3327             else
3328                 type = OP_AND;
3329             o = first;
3330             first = *firstp = cUNOPo->op_first;
3331             if (o->op_next)
3332                 first->op_next = o->op_next;
3333             cUNOPo->op_first = Nullop;
3334             op_free(o);
3335         }
3336     }
3337     if (first->op_type == OP_CONST) {
3338         if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE)) {
3339             if (first->op_private & OPpCONST_STRICT)
3340                 no_bareword_allowed(first);
3341             else
3342                 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
3343         }
3344         if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
3345             op_free(first);
3346             *firstp = Nullop;
3347             return other;
3348         }
3349         else {
3350             op_free(other);
3351             *otherp = Nullop;
3352             return first;
3353         }
3354     }
3355     else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS) &&
3356              type != OP_DOR) /* [#24076] Don't warn for <FH> err FOO. */
3357     {
3358         OP *k1 = ((UNOP*)first)->op_first;
3359         OP *k2 = k1->op_sibling;
3360         OPCODE warnop = 0;
3361         switch (first->op_type)
3362         {
3363         case OP_NULL:
3364             if (k2 && k2->op_type == OP_READLINE
3365                   && (k2->op_flags & OPf_STACKED)
3366                   && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3367             {
3368                 warnop = k2->op_type;
3369             }
3370             break;
3371
3372         case OP_SASSIGN:
3373             if (k1->op_type == OP_READDIR
3374                   || k1->op_type == OP_GLOB
3375                   || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3376                   || k1->op_type == OP_EACH)
3377             {
3378                 warnop = ((k1->op_type == OP_NULL)
3379                           ? (OPCODE)k1->op_targ : k1->op_type);
3380             }
3381             break;
3382         }
3383         if (warnop) {
3384             line_t oldline = CopLINE(PL_curcop);
3385             CopLINE_set(PL_curcop, PL_copline);
3386             Perl_warner(aTHX_ packWARN(WARN_MISC),
3387                  "Value of %s%s can be \"0\"; test with defined()",
3388                  PL_op_desc[warnop],
3389                  ((warnop == OP_READLINE || warnop == OP_GLOB)
3390                   ? " construct" : "() operator"));
3391             CopLINE_set(PL_curcop, oldline);
3392         }
3393     }
3394
3395     if (!other)
3396         return first;
3397
3398     if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
3399         other->op_private |= OPpASSIGN_BACKWARDS;  /* other is an OP_SASSIGN */
3400
3401     NewOp(1101, logop, 1, LOGOP);
3402
3403     logop->op_type = (OPCODE)type;
3404     logop->op_ppaddr = PL_ppaddr[type];
3405     logop->op_first = first;
3406     logop->op_flags = flags | OPf_KIDS;
3407     logop->op_other = LINKLIST(other);
3408     logop->op_private = (U8)(1 | (flags >> 8));
3409
3410     /* establish postfix order */
3411     logop->op_next = LINKLIST(first);
3412     first->op_next = (OP*)logop;
3413     first->op_sibling = other;
3414
3415     CHECKOP(type,logop);
3416
3417     o = newUNOP(OP_NULL, 0, (OP*)logop);
3418     other->op_next = o;
3419
3420     return o;
3421 }
3422
3423 OP *
3424 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3425 {
3426     LOGOP *logop;
3427     OP *start;
3428     OP *o;
3429
3430     if (!falseop)
3431         return newLOGOP(OP_AND, 0, first, trueop);
3432     if (!trueop)
3433         return newLOGOP(OP_OR, 0, first, falseop);
3434
3435     scalarboolean(first);
3436     if (first->op_type == OP_CONST) {
3437         if (first->op_private & OPpCONST_BARE &&
3438            first->op_private & OPpCONST_STRICT) {
3439            no_bareword_allowed(first);
3440        }
3441         if (SvTRUE(((SVOP*)first)->op_sv)) {
3442             op_free(first);
3443             op_free(falseop);
3444             return trueop;
3445         }
3446         else {
3447             op_free(first);
3448             op_free(trueop);
3449             return falseop;
3450         }
3451     }
3452     NewOp(1101, logop, 1, LOGOP);
3453     logop->op_type = OP_COND_EXPR;
3454     logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3455     logop->op_first = first;
3456     logop->op_flags = flags | OPf_KIDS;
3457     logop->op_private = (U8)(1 | (flags >> 8));
3458     logop->op_other = LINKLIST(trueop);
3459     logop->op_next = LINKLIST(falseop);
3460
3461     CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
3462             logop);
3463
3464     /* establish postfix order */
3465     start = LINKLIST(first);
3466     first->op_next = (OP*)logop;
3467
3468     first->op_sibling = trueop;
3469     trueop->op_sibling = falseop;
3470     o = newUNOP(OP_NULL, 0, (OP*)logop);
3471
3472     trueop->op_next = falseop->op_next = o;
3473
3474     o->op_next = start;
3475     return o;
3476 }
3477
3478 OP *
3479 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3480 {
3481     LOGOP *range;
3482     OP *flip;
3483     OP *flop;
3484     OP *leftstart;
3485     OP *o;
3486
3487     NewOp(1101, range, 1, LOGOP);
3488
3489     range->op_type = OP_RANGE;
3490     range->op_ppaddr = PL_ppaddr[OP_RANGE];
3491     range->op_first = left;
3492     range->op_flags = OPf_KIDS;
3493     leftstart = LINKLIST(left);
3494     range->op_other = LINKLIST(right);
3495     range->op_private = (U8)(1 | (flags >> 8));
3496
3497     left->op_sibling = right;
3498
3499     range->op_next = (OP*)range;
3500     flip = newUNOP(OP_FLIP, flags, (OP*)range);
3501     flop = newUNOP(OP_FLOP, 0, flip);
3502     o = newUNOP(OP_NULL, 0, flop);
3503     linklist(flop);
3504     range->op_next = leftstart;
3505
3506     left->op_next = flip;
3507     right->op_next = flop;
3508
3509     range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3510     sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3511     flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3512     sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3513
3514     flip->op_private =  left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3515     flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3516
3517     flip->op_next = o;
3518     if (!flip->op_private || !flop->op_private)
3519         linklist(o);            /* blow off optimizer unless constant */
3520
3521     return o;
3522 }
3523
3524 OP *
3525 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3526 {
3527     OP* listop;
3528     OP* o;
3529     int once = block && block->op_flags & OPf_SPECIAL &&
3530       (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3531
3532     if (expr) {
3533         if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3534             return block;       /* do {} while 0 does once */
3535         if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3536             || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3537             expr = newUNOP(OP_DEFINED, 0,
3538                 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3539         } else if (expr->op_flags & OPf_KIDS) {
3540             OP *k1 = ((UNOP*)expr)->op_first;
3541             OP *k2 = (k1) ? k1->op_sibling : NULL;
3542             switch (expr->op_type) {
3543               case OP_NULL:
3544                 if (k2 && k2->op_type == OP_READLINE
3545                       && (k2->op_flags & OPf_STACKED)
3546                       && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3547                     expr = newUNOP(OP_DEFINED, 0, expr);
3548                 break;
3549
3550               case OP_SASSIGN:
3551                 if (k1->op_type == OP_READDIR
3552                       || k1->op_type == OP_GLOB
3553                       || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3554                       || k1->op_type == OP_EACH)
3555                     expr = newUNOP(OP_DEFINED, 0, expr);
3556                 break;
3557             }
3558         }
3559     }
3560
3561     listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3562     o = new_logop(OP_AND, 0, &expr, &listop);
3563
3564     if (listop)
3565         ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3566
3567     if (once && o != listop)
3568         o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3569
3570     if (o == listop)
3571         o = newUNOP(OP_NULL, 0, o);     /* or do {} while 1 loses outer block */
3572
3573     o->op_flags |= flags;
3574     o = scope(o);
3575     o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3576     return o;
3577 }
3578
3579 OP *
3580 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
3581 {
3582     OP *redo;
3583     OP *next = 0;
3584     OP *listop;
3585     OP *o;
3586     U8 loopflags = 0;
3587
3588     if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3589                  || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
3590         expr = newUNOP(OP_DEFINED, 0,
3591             newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3592     } else if (expr && (expr->op_flags & OPf_KIDS)) {
3593         OP *k1 = ((UNOP*)expr)->op_first;
3594         OP *k2 = (k1) ? k1->op_sibling : NULL;
3595         switch (expr->op_type) {
3596           case OP_NULL:
3597             if (k2 && k2->op_type == OP_READLINE
3598                   && (k2->op_flags & OPf_STACKED)
3599                   && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3600                 expr = newUNOP(OP_DEFINED, 0, expr);
3601             break;
3602
3603           case OP_SASSIGN:
3604             if (k1->op_type == OP_READDIR
3605                   || k1->op_type == OP_GLOB
3606                   || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3607                   || k1->op_type == OP_EACH)
3608                 expr = newUNOP(OP_DEFINED, 0, expr);
3609             break;
3610         }
3611     }
3612
3613     if (!block)
3614         block = newOP(OP_NULL, 0);
3615     else if (cont) {
3616         block = scope(block);
3617     }
3618
3619     if (cont) {
3620         next = LINKLIST(cont);
3621     }
3622     if (expr) {
3623         OP *unstack = newOP(OP_UNSTACK, 0);
3624         if (!next)
3625             next = unstack;
3626         cont = append_elem(OP_LINESEQ, cont, unstack);
3627     }
3628
3629     listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
3630     redo = LINKLIST(listop);
3631
3632     if (expr) {
3633         PL_copline = (line_t)whileline;
3634         scalar(listop);
3635         o = new_logop(OP_AND, 0, &expr, &listop);
3636         if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
3637             op_free(expr);              /* oops, it's a while (0) */
3638             op_free((OP*)loop);
3639             return Nullop;              /* listop already freed by new_logop */
3640         }
3641         if (listop)
3642             ((LISTOP*)listop)->op_last->op_next =
3643                 (o == listop ? redo : LINKLIST(o));
3644     }
3645     else
3646         o = listop;
3647
3648     if (!loop) {
3649         NewOp(1101,loop,1,LOOP);
3650         loop->op_type = OP_ENTERLOOP;
3651         loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
3652         loop->op_private = 0;
3653         loop->op_next = (OP*)loop;
3654     }
3655
3656     o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
3657
3658     loop->op_redoop = redo;
3659     loop->op_lastop = o;
3660     o->op_private |= loopflags;
3661
3662     if (next)
3663         loop->op_nextop = next;
3664     else
3665         loop->op_nextop = o;
3666
3667     o->op_flags |= flags;
3668     o->op_private |= (flags >> 8);
3669     return o;
3670 }
3671
3672 OP *
3673 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
3674 {
3675     LOOP *loop;
3676     OP *wop;
3677     PADOFFSET padoff = 0;
3678     I32 iterflags = 0;
3679     I32 iterpflags = 0;
3680
3681     if (sv) {
3682         if (sv->op_type == OP_RV2SV) {  /* symbol table variable */
3683             iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
3684             sv->op_type = OP_RV2GV;
3685             sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
3686         }
3687         else if (sv->op_type == OP_PADSV) { /* private variable */
3688             iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
3689             padoff = sv->op_targ;
3690             sv->op_targ = 0;
3691             op_free(sv);
3692             sv = Nullop;
3693         }
3694         else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
3695             padoff = sv->op_targ;
3696             sv->op_targ = 0;
3697             iterflags |= OPf_SPECIAL;
3698             op_free(sv);
3699             sv = Nullop;
3700         }
3701         else
3702             Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
3703     }
3704     else {
3705         sv = newGVOP(OP_GV, 0, PL_defgv);
3706     }
3707     if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
3708         expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
3709         iterflags |= OPf_STACKED;
3710     }
3711     else if (expr->op_type == OP_NULL &&
3712              (expr->op_flags & OPf_KIDS) &&
3713              ((BINOP*)expr)->op_first->op_type == OP_FLOP)
3714     {
3715         /* Basically turn for($x..$y) into the same as for($x,$y), but we
3716          * set the STACKED flag to indicate that these values are to be
3717          * treated as min/max values by 'pp_iterinit'.
3718          */
3719         UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
3720         LOGOP* range = (LOGOP*) flip->op_first;
3721         OP* left  = range->op_first;
3722         OP* right = left->op_sibling;
3723         LISTOP* listop;
3724
3725         range->op_flags &= ~OPf_KIDS;
3726         range->op_first = Nullop;
3727
3728         listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
3729         listop->op_first->op_next = range->op_next;
3730         left->op_next = range->op_other;
3731         right->op_next = (OP*)listop;
3732         listop->op_next = listop->op_first;
3733
3734         op_free(expr);
3735         expr = (OP*)(listop);
3736         op_null(expr);
3737         iterflags |= OPf_STACKED;
3738     }
3739     else {
3740         expr = mod(force_list(expr), OP_GREPSTART);
3741     }
3742
3743
3744     loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
3745                                append_elem(OP_LIST, expr, scalar(sv))));
3746     assert(!loop->op_next);
3747     /* for my  $x () sets OPpLVAL_INTRO;
3748      * for our $x () sets OPpOUR_INTRO */
3749     loop->op_private = (U8)iterpflags;
3750 #ifdef PL_OP_SLAB_ALLOC
3751     {
3752         LOOP *tmp;
3753         NewOp(1234,tmp,1,LOOP);
3754         Copy(loop,tmp,1,LOOP);
3755         FreeOp(loop);
3756         loop = tmp;
3757     }
3758 #else
3759     Renew(loop, 1, LOOP);
3760 #endif
3761     loop->op_targ = padoff;
3762     wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
3763     PL_copline = forline;
3764     return newSTATEOP(0, label, wop);
3765 }
3766
3767 OP*
3768 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
3769 {
3770     OP *o;
3771     STRLEN n_a;
3772
3773     if (type != OP_GOTO || label->op_type == OP_CONST) {
3774         /* "last()" means "last" */
3775         if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
3776             o = newOP(type, OPf_SPECIAL);
3777         else {
3778             o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
3779                                         ? SvPVx(((SVOP*)label)->op_sv, n_a)
3780                                         : ""));
3781         }
3782         op_free(label);
3783     }
3784     else {
3785         /* Check whether it's going to be a goto &function */
3786         if (label->op_type == OP_ENTERSUB
3787                 && !(label->op_flags & OPf_STACKED))
3788             label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
3789         o = newUNOP(type, OPf_STACKED, label);
3790     }
3791     PL_hints |= HINT_BLOCK_SCOPE;
3792     return o;
3793 }
3794
3795 /*
3796 =for apidoc cv_undef
3797
3798 Clear out all the active components of a CV. This can happen either
3799 by an explicit C<undef &foo>, or by the reference count going to zero.
3800 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
3801 children can still follow the full lexical scope chain.
3802
3803 =cut
3804 */
3805
3806 void
3807 Perl_cv_undef(pTHX_ CV *cv)
3808 {
3809 #ifdef USE_ITHREADS
3810     if (CvFILE(cv) && !CvXSUB(cv)) {
3811         /* for XSUBs CvFILE point directly to static memory; __FILE__ */
3812         Safefree(CvFILE(cv));
3813     }
3814     CvFILE(cv) = 0;
3815 #endif
3816
3817     if (!CvXSUB(cv) && CvROOT(cv)) {
3818         if (CvDEPTH(cv))
3819             Perl_croak(aTHX_ "Can't undef active subroutine");
3820         ENTER;
3821
3822         PAD_SAVE_SETNULLPAD();
3823
3824         op_free(CvROOT(cv));
3825         CvROOT(cv) = Nullop;
3826         LEAVE;
3827     }
3828     SvPOK_off((SV*)cv);         /* forget prototype */
3829     CvGV(cv) = Nullgv;
3830
3831     pad_undef(cv);
3832
3833     /* remove CvOUTSIDE unless this is an undef rather than a free */
3834     if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
3835         if (!CvWEAKOUTSIDE(cv))
3836             SvREFCNT_dec(CvOUTSIDE(cv));
3837         CvOUTSIDE(cv) = Nullcv;
3838     }
3839     if (CvCONST(cv)) {
3840         SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
3841         CvCONST_off(cv);
3842     }
3843     if (CvXSUB(cv)) {
3844         CvXSUB(cv) = 0;
3845     }
3846     /* delete all flags except WEAKOUTSIDE */
3847     CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
3848 }
3849
3850 void
3851 Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
3852 {
3853     if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
3854         SV* msg = sv_newmortal();
3855         SV* name = Nullsv;
3856
3857         if (gv)
3858             gv_efullname3(name = sv_newmortal(), gv, Nullch);
3859         sv_setpv(msg, "Prototype mismatch:");
3860         if (name)
3861             Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
3862         if (SvPOK(cv))
3863             Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (SV *)cv);
3864         sv_catpv(msg, " vs ");
3865         if (p)
3866             Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
3867         else
3868             sv_catpv(msg, "none");
3869         Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, msg);
3870     }
3871 }
3872
3873 static void const_sv_xsub(pTHX_ CV* cv);
3874
3875 /*
3876
3877 =head1 Optree Manipulation Functions
3878
3879 =for apidoc cv_const_sv
3880
3881 If C<cv> is a constant sub eligible for inlining. returns the constant
3882 value returned by the sub.  Otherwise, returns NULL.
3883
3884 Constant subs can be created with C<newCONSTSUB> or as described in
3885 L<perlsub/"Constant Functions">.
3886
3887 =cut
3888 */
3889 SV *
3890 Perl_cv_const_sv(pTHX_ CV *cv)
3891 {
3892     if (!cv || !CvCONST(cv))
3893         return Nullsv;
3894     return (SV*)CvXSUBANY(cv).any_ptr;
3895 }
3896
3897 /* op_const_sv:  examine an optree to determine whether it's in-lineable.
3898  * Can be called in 3 ways:
3899  *
3900  * !cv
3901  *      look for a single OP_CONST with attached value: return the value
3902  *
3903  * cv && CvCLONE(cv) && !CvCONST(cv)
3904  *
3905  *      examine the clone prototype, and if contains only a single
3906  *      OP_CONST referencing a pad const, or a single PADSV referencing
3907  *      an outer lexical, return a non-zero value to indicate the CV is
3908  *      a candidate for "constizing" at clone time
3909  *
3910  * cv && CvCONST(cv)
3911  *
3912  *      We have just cloned an anon prototype that was marked as a const
3913  *      candidiate. Try to grab the current value, and in the case of
3914  *      PADSV, ignore it if it has multiple references. Return the value.
3915  */
3916
3917 SV *
3918 Perl_op_const_sv(pTHX_ OP *o, CV *cv)
3919 {
3920     SV *sv = Nullsv;
3921
3922     if (!o)
3923         return Nullsv;
3924
3925     if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
3926         o = cLISTOPo->op_first->op_sibling;
3927
3928     for (; o; o = o->op_next) {
3929         OPCODE type = o->op_type;
3930
3931         if (sv && o->op_next == o)
3932             return sv;
3933         if (o->op_next != o) {
3934             if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
3935                 continue;
3936             if (type == OP_DBSTATE)
3937                 continue;
3938         }
3939         if (type == OP_LEAVESUB || type == OP_RETURN)
3940             break;
3941         if (sv)
3942             return Nullsv;
3943         if (type == OP_CONST && cSVOPo->op_sv)
3944             sv = cSVOPo->op_sv;
3945         else if (cv && type == OP_CONST) {
3946             sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
3947             if (!sv)
3948                 return Nullsv;
3949         }
3950         else if (cv && type == OP_PADSV) {
3951             if (CvCONST(cv)) { /* newly cloned anon */
3952                 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
3953                 /* the candidate should have 1 ref from this pad and 1 ref
3954                  * from the parent */
3955                 if (!sv || SvREFCNT(sv) != 2)
3956                     return Nullsv;
3957                 sv = newSVsv(sv);
3958                 SvREADONLY_on(sv);
3959                 return sv;
3960             }
3961             else {
3962                 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
3963                     sv = &PL_sv_undef; /* an arbitrary non-null value */
3964             }
3965         }
3966         else {
3967             return Nullsv;
3968         }
3969     }
3970     return sv;
3971 }
3972
3973 void
3974 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
3975 {
3976     if (o)
3977         SAVEFREEOP(o);
3978     if (proto)
3979         SAVEFREEOP(proto);
3980     if (attrs)
3981         SAVEFREEOP(attrs);
3982     if (block)
3983         SAVEFREEOP(block);
3984     Perl_croak(aTHX_ "\"my sub\" not yet implemented");
3985 }
3986
3987 CV *
3988 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
3989 {
3990     return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
3991 }
3992
3993 CV *
3994 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
3995 {
3996     STRLEN n_a;
3997     char *name;
3998     char *aname;
3999     GV *gv;
4000     char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
4001     register CV *cv=0;
4002     SV *const_sv;
4003
4004     name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4005     if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4006         SV *sv = sv_newmortal();
4007         Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
4008                        PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
4009                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4010         aname = SvPVX(sv);
4011     }
4012     else
4013         aname = Nullch;
4014     gv = gv_fetchpv(name ? name : (aname ? aname :
4015                     (PL_curstash ? "__ANON__" : "__ANON__::__ANON__")),
4016                     GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4017                     SVt_PVCV);
4018
4019     if (o)
4020         SAVEFREEOP(o);
4021     if (proto)
4022         SAVEFREEOP(proto);
4023     if (attrs)
4024         SAVEFREEOP(attrs);
4025
4026     if (SvTYPE(gv) != SVt_PVGV) {       /* Maybe prototype now, and had at
4027                                            maximum a prototype before. */
4028         if (SvTYPE(gv) > SVt_NULL) {
4029             if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4030                 && ckWARN_d(WARN_PROTOTYPE))
4031             {
4032                 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
4033             }
4034             cv_ckproto((CV*)gv, NULL, ps);
4035         }
4036         if (ps)
4037             sv_setpv((SV*)gv, ps);
4038         else
4039             sv_setiv((SV*)gv, -1);
4040         SvREFCNT_dec(PL_compcv);
4041         cv = PL_compcv = NULL;
4042         PL_sub_generation++;
4043         goto done;
4044     }
4045
4046     cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4047
4048 #ifdef GV_UNIQUE_CHECK
4049     if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4050         Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
4051     }
4052 #endif
4053
4054     if (!block || !ps || *ps || attrs)
4055         const_sv = Nullsv;
4056     else
4057         const_sv = op_const_sv(block, Nullcv);
4058
4059     if (cv) {
4060         bool exists = CvROOT(cv) || CvXSUB(cv);
4061
4062 #ifdef GV_UNIQUE_CHECK
4063         if (exists && GvUNIQUE(gv)) {
4064             Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
4065         }
4066 #endif
4067
4068         /* if the subroutine doesn't exist and wasn't pre-declared
4069          * with a prototype, assume it will be AUTOLOADed,
4070          * skipping the prototype check
4071          */
4072         if (exists || SvPOK(cv))
4073             cv_ckproto(cv, gv, ps);
4074         /* already defined (or promised)? */
4075         if (exists || GvASSUMECV(gv)) {
4076             if (!block && !attrs) {
4077                 if (CvFLAGS(PL_compcv)) {
4078                     /* might have had built-in attrs applied */
4079                     CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4080                 }
4081                 /* just a "sub foo;" when &foo is already defined */
4082                 SAVEFREESV(PL_compcv);
4083                 goto done;
4084             }
4085             /* ahem, death to those who redefine active sort subs */
4086             if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4087                 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4088             if (block) {
4089                 if (ckWARN(WARN_REDEFINE)
4090                     || (CvCONST(cv)
4091                         && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4092                 {
4093                     line_t oldline = CopLINE(PL_curcop);
4094                     if (PL_copline != NOLINE)
4095                         CopLINE_set(PL_curcop, PL_copline);
4096                     Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4097                         CvCONST(cv) ? "Constant subroutine %s redefined"
4098                                     : "Subroutine %s redefined", name);
4099                     CopLINE_set(PL_curcop, oldline);
4100                 }
4101                 SvREFCNT_dec(cv);
4102                 cv = Nullcv;
4103             }
4104         }
4105     }
4106     if (const_sv) {
4107         SvREFCNT_inc(const_sv);
4108         if (cv) {
4109             assert(!CvROOT(cv) && !CvCONST(cv));
4110             sv_setpv((SV*)cv, "");  /* prototype is "" */
4111             CvXSUBANY(cv).any_ptr = const_sv;
4112             CvXSUB(cv) = const_sv_xsub;
4113             CvCONST_on(cv);
4114         }
4115         else {
4116             GvCV(gv) = Nullcv;
4117             cv = newCONSTSUB(NULL, name, const_sv);
4118         }
4119         op_free(block);
4120         SvREFCNT_dec(PL_compcv);
4121         PL_compcv = NULL;
4122         PL_sub_generation++;
4123         goto done;
4124     }
4125     if (attrs) {
4126         HV *stash;
4127         SV *rcv;
4128
4129         /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4130          * before we clobber PL_compcv.
4131          */
4132         if (cv && !block) {
4133             rcv = (SV*)cv;
4134             /* Might have had built-in attributes applied -- propagate them. */
4135             CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4136             if (CvGV(cv) && GvSTASH(CvGV(cv)))
4137                 stash = GvSTASH(CvGV(cv));
4138             else if (CvSTASH(cv))
4139                 stash = CvSTASH(cv);
4140             else
4141                 stash = PL_curstash;
4142         }
4143         else {
4144             /* possibly about to re-define existing subr -- ignore old cv */
4145             rcv = (SV*)PL_compcv;
4146             if (name && GvSTASH(gv))
4147                 stash = GvSTASH(gv);
4148             else
4149                 stash = PL_curstash;
4150         }
4151         apply_attrs(stash, rcv, attrs, FALSE);
4152     }
4153     if (cv) {                           /* must reuse cv if autoloaded */
4154         if (!block) {
4155             /* got here with just attrs -- work done, so bug out */
4156             SAVEFREESV(PL_compcv);
4157             goto done;
4158         }
4159         /* transfer PL_compcv to cv */
4160         cv_undef(cv);
4161         CvFLAGS(cv) = CvFLAGS(PL_compcv);
4162         CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4163         CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
4164         CvOUTSIDE(PL_compcv) = 0;
4165         CvPADLIST(cv) = CvPADLIST(PL_compcv);
4166         CvPADLIST(PL_compcv) = 0;
4167         /* inner references to PL_compcv must be fixed up ... */
4168         pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
4169         /* ... before we throw it away */
4170         SvREFCNT_dec(PL_compcv);
4171         PL_compcv = cv;
4172         if (PERLDB_INTER)/* Advice debugger on the new sub. */
4173           ++PL_sub_generation;
4174     }
4175     else {
4176         cv = PL_compcv;
4177         if (name) {
4178             GvCV(gv) = cv;
4179             GvCVGEN(gv) = 0;
4180             PL_sub_generation++;
4181         }
4182     }
4183     CvGV(cv) = gv;
4184     CvFILE_set_from_cop(cv, PL_curcop);
4185     CvSTASH(cv) = PL_curstash;
4186
4187     if (ps)
4188         sv_setpv((SV*)cv, ps);
4189
4190     if (PL_error_count) {
4191         op_free(block);
4192         block = Nullop;
4193         if (name) {
4194             char *s = strrchr(name, ':');
4195             s = s ? s+1 : name;
4196             if (strEQ(s, "BEGIN")) {
4197                 char *not_safe =
4198                     "BEGIN not safe after errors--compilation aborted";
4199                 if (PL_in_eval & EVAL_KEEPERR)
4200                     Perl_croak(aTHX_ not_safe);
4201                 else {
4202                     /* force display of errors found but not reported */
4203                     sv_catpv(ERRSV, not_safe);
4204                     Perl_croak(aTHX_ "%"SVf, ERRSV);
4205                 }
4206             }
4207         }
4208     }
4209     if (!block)
4210         goto done;
4211
4212     if (CvLVALUE(cv)) {
4213         CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4214                              mod(scalarseq(block), OP_LEAVESUBLV));
4215     }
4216     else {
4217         /* This makes sub {}; work as expected.  */
4218         if (block->op_type == OP_STUB) {
4219             op_free(block);
4220             block = newSTATEOP(0, Nullch, 0);
4221         }
4222         CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4223     }
4224     CvROOT(cv)->op_private |= OPpREFCOUNTED;
4225     OpREFCNT_set(CvROOT(cv), 1);
4226     CvSTART(cv) = LINKLIST(CvROOT(cv));
4227     CvROOT(cv)->op_next = 0;
4228     CALL_PEEP(CvSTART(cv));
4229
4230     /* now that optimizer has done its work, adjust pad values */
4231
4232     pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
4233
4234     if (CvCLONE(cv)) {
4235         assert(!CvCONST(cv));
4236         if (ps && !*ps && op_const_sv(block, cv))
4237             CvCONST_on(cv);
4238     }
4239
4240     if (name || aname) {
4241         char *s;
4242         char *tname = (name ? name : aname);
4243
4244         if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4245             SV *sv = NEWSV(0,0);
4246             SV *tmpstr = sv_newmortal();
4247             GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4248             CV *pcv;
4249             HV *hv;
4250
4251             Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4252                            CopFILE(PL_curcop),
4253                            (long)PL_subline, (long)CopLINE(PL_curcop));
4254             gv_efullname3(tmpstr, gv, Nullch);
4255             hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
4256             hv = GvHVn(db_postponed);
4257             if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
4258                 && (pcv = GvCV(db_postponed)))
4259             {
4260                 dSP;
4261                 PUSHMARK(SP);
4262                 XPUSHs(tmpstr);
4263                 PUTBACK;
4264                 call_sv((SV*)pcv, G_DISCARD);
4265             }
4266         }
4267
4268         if ((s = strrchr(tname,':')))
4269             s++;
4270         else
4271             s = tname;
4272
4273         if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4274             goto done;
4275
4276         if (strEQ(s, "BEGIN") && !PL_error_count) {
4277             I32 oldscope = PL_scopestack_ix;
4278             ENTER;
4279             SAVECOPFILE(&PL_compiling);
4280             SAVECOPLINE(&PL_compiling);
4281
4282             if (!PL_beginav)
4283                 PL_beginav = newAV();
4284             DEBUG_x( dump_sub(gv) );
4285             av_push(PL_beginav, (SV*)cv);
4286             GvCV(gv) = 0;               /* cv has been hijacked */
4287             call_list(oldscope, PL_beginav);
4288
4289             PL_curcop = &PL_compiling;
4290             PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4291             LEAVE;
4292         }
4293         else if (strEQ(s, "END") && !PL_error_count) {
4294             if (!PL_endav)
4295                 PL_endav = newAV();
4296             DEBUG_x( dump_sub(gv) );
4297             av_unshift(PL_endav, 1);
4298             av_store(PL_endav, 0, (SV*)cv);
4299             GvCV(gv) = 0;               /* cv has been hijacked */
4300         }
4301         else if (strEQ(s, "CHECK") && !PL_error_count) {
4302             if (!PL_checkav)
4303                 PL_checkav = newAV();
4304             DEBUG_x( dump_sub(gv) );
4305             if (PL_main_start && ckWARN(WARN_VOID))
4306                 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4307             av_unshift(PL_checkav, 1);
4308             av_store(PL_checkav, 0, (SV*)cv);
4309             GvCV(gv) = 0;               /* cv has been hijacked */
4310         }
4311         else if (strEQ(s, "INIT") && !PL_error_count) {
4312             if (!PL_initav)
4313                 PL_initav = newAV();
4314             DEBUG_x( dump_sub(gv) );
4315             if (PL_main_start && ckWARN(WARN_VOID))
4316                 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4317             av_push(PL_initav, (SV*)cv);
4318             GvCV(gv) = 0;               /* cv has been hijacked */
4319         }
4320     }
4321
4322   done:
4323     PL_copline = NOLINE;
4324     LEAVE_SCOPE(floor);
4325     return cv;
4326 }
4327
4328 /* XXX unsafe for threads if eval_owner isn't held */
4329 /*
4330 =for apidoc newCONSTSUB
4331
4332 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4333 eligible for inlining at compile-time.
4334
4335 =cut
4336 */
4337
4338 CV *
4339 Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
4340 {
4341     CV* cv;
4342
4343     ENTER;
4344
4345     SAVECOPLINE(PL_curcop);
4346     CopLINE_set(PL_curcop, PL_copline);
4347
4348     SAVEHINTS();
4349     PL_hints &= ~HINT_BLOCK_SCOPE;
4350
4351     if (stash) {
4352         SAVESPTR(PL_curstash);
4353         SAVECOPSTASH(PL_curcop);
4354         PL_curstash = stash;
4355         CopSTASH_set(PL_curcop,stash);
4356     }
4357
4358     cv = newXS(name, const_sv_xsub, savepv(CopFILE(PL_curcop)));
4359     CvXSUBANY(cv).any_ptr = sv;
4360     CvCONST_on(cv);
4361     sv_setpv((SV*)cv, "");  /* prototype is "" */
4362
4363     if (stash)
4364         CopSTASH_free(PL_curcop);
4365
4366     LEAVE;
4367
4368     return cv;
4369 }
4370
4371 /*
4372 =for apidoc U||newXS
4373
4374 Used by C<xsubpp> to hook up XSUBs as Perl subs.
4375
4376 =cut
4377 */
4378
4379 CV *
4380 Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
4381 {
4382     GV *gv = gv_fetchpv(name ? name :
4383                         (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4384                         GV_ADDMULTI, SVt_PVCV);
4385     register CV *cv;
4386
4387     if (!subaddr)
4388         Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
4389
4390     if ((cv = (name ? GvCV(gv) : Nullcv))) {
4391         if (GvCVGEN(gv)) {
4392             /* just a cached method */
4393             SvREFCNT_dec(cv);
4394             cv = 0;
4395         }
4396         else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4397             /* already defined (or promised) */
4398             if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
4399                             && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
4400                 line_t oldline = CopLINE(PL_curcop);
4401                 if (PL_copline != NOLINE)
4402                     CopLINE_set(PL_curcop, PL_copline);
4403                 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4404                             CvCONST(cv) ? "Constant subroutine %s redefined"
4405                                         : "Subroutine %s redefined"
4406                             ,name);
4407                 CopLINE_set(PL_curcop, oldline);
4408             }
4409             SvREFCNT_dec(cv);
4410             cv = 0;
4411         }
4412     }
4413
4414     if (cv)                             /* must reuse cv if autoloaded */
4415         cv_undef(cv);
4416     else {
4417         cv = (CV*)NEWSV(1105,0);
4418         sv_upgrade((SV *)cv, SVt_PVCV);
4419         if (name) {
4420             GvCV(gv) = cv;
4421             GvCVGEN(gv) = 0;
4422             PL_sub_generation++;
4423         }
4424     }
4425     CvGV(cv) = gv;
4426     (void)gv_fetchfile(filename);
4427     CvFILE(cv) = filename;      /* NOTE: not copied, as it is expected to be
4428                                    an external constant string */
4429     CvXSUB(cv) = subaddr;
4430
4431     if (name) {
4432         char *s = strrchr(name,':');
4433         if (s)
4434             s++;
4435         else
4436             s = name;
4437
4438         if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4439             goto done;
4440
4441         if (strEQ(s, "BEGIN")) {
4442             if (!PL_beginav)
4443                 PL_beginav = newAV();
4444             av_push(PL_beginav, (SV*)cv);
4445             GvCV(gv) = 0;               /* cv has been hijacked */
4446         }
4447         else if (strEQ(s, "END")) {
4448             if (!PL_endav)
4449                 PL_endav = newAV();
4450             av_unshift(PL_endav, 1);
4451             av_store(PL_endav, 0, (SV*)cv);
4452             GvCV(gv) = 0;               /* cv has been hijacked */
4453         }
4454         else if (strEQ(s, "CHECK")) {
4455             if (!PL_checkav)
4456                 PL_checkav = newAV();
4457             if (PL_main_start && ckWARN(WARN_VOID))
4458                 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4459             av_unshift(PL_checkav, 1);
4460             av_store(PL_checkav, 0, (SV*)cv);
4461             GvCV(gv) = 0;               /* cv has been hijacked */
4462         }
4463         else if (strEQ(s, "INIT")) {
4464             if (!PL_initav)
4465                 PL_initav = newAV();
4466             if (PL_main_start && ckWARN(WARN_VOID))
4467                 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4468             av_push(PL_initav, (SV*)cv);
4469             GvCV(gv) = 0;               /* cv has been hijacked */
4470         }
4471     }
4472     else
4473         CvANON_on(cv);
4474
4475 done:
4476     return cv;
4477 }
4478
4479 void
4480 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
4481 {
4482     register CV *cv;
4483     char *name;
4484     GV *gv;
4485     STRLEN n_a;
4486
4487     if (o)
4488         name = SvPVx(cSVOPo->op_sv, n_a);
4489     else
4490         name = "STDOUT";
4491     gv = gv_fetchpv(name,TRUE, SVt_PVFM);
4492 #ifdef GV_UNIQUE_CHECK
4493     if (GvUNIQUE(gv)) {
4494         Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
4495     }
4496 #endif
4497     GvMULTI_on(gv);
4498     if ((cv = GvFORM(gv))) {
4499         if (ckWARN(WARN_REDEFINE)) {
4500             line_t oldline = CopLINE(PL_curcop);
4501             if (PL_copline != NOLINE)
4502                 CopLINE_set(PL_curcop, PL_copline);
4503             Perl_warner(aTHX_ packWARN(WARN_REDEFINE), "Format %s redefined",name);
4504             CopLINE_set(PL_curcop, oldline);
4505         }
4506         SvREFCNT_dec(cv);
4507     }
4508     cv = PL_compcv;
4509     GvFORM(gv) = cv;
4510     CvGV(cv) = gv;
4511     CvFILE_set_from_cop(cv, PL_curcop);
4512
4513
4514     pad_tidy(padtidy_FORMAT);
4515     CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
4516     CvROOT(cv)->op_private |= OPpREFCOUNTED;
4517     OpREFCNT_set(CvROOT(cv), 1);
4518     CvSTART(cv) = LINKLIST(CvROOT(cv));
4519     CvROOT(cv)->op_next = 0;
4520     CALL_PEEP(CvSTART(cv));
4521     op_free(o);
4522     PL_copline = NOLINE;
4523     LEAVE_SCOPE(floor);
4524 }
4525
4526 OP *
4527 Perl_newANONLIST(pTHX_ OP *o)
4528 {
4529     return newUNOP(OP_REFGEN, 0,
4530         mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
4531 }
4532
4533 OP *
4534 Perl_newANONHASH(pTHX_ OP *o)
4535 {
4536     return newUNOP(OP_REFGEN, 0,
4537         mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
4538 }
4539
4540 OP *
4541 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
4542 {
4543     return newANONATTRSUB(floor, proto, Nullop, block);
4544 }
4545
4546 OP *
4547 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
4548 {
4549     return newUNOP(OP_REFGEN, 0,
4550         newSVOP(OP_ANONCODE, 0,
4551                 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
4552 }
4553
4554 OP *
4555 Perl_oopsAV(pTHX_ OP *o)
4556 {
4557     switch (o->op_type) {
4558     case OP_PADSV:
4559         o->op_type = OP_PADAV;
4560         o->op_ppaddr = PL_ppaddr[OP_PADAV];
4561         return ref(o, OP_RV2AV);
4562
4563     case OP_RV2SV:
4564         o->op_type = OP_RV2AV;
4565         o->op_ppaddr = PL_ppaddr[OP_RV2AV];
4566         ref(o, OP_RV2AV);
4567         break;
4568
4569     default:
4570         if (ckWARN_d(WARN_INTERNAL))
4571             Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
4572         break;
4573     }
4574     return o;
4575 }
4576
4577 OP *
4578 Perl_oopsHV(pTHX_ OP *o)
4579 {
4580     switch (o->op_type) {
4581     case OP_PADSV:
4582     case OP_PADAV:
4583         o->op_type = OP_PADHV;
4584         o->op_ppaddr = PL_ppaddr[OP_PADHV];
4585         return ref(o, OP_RV2HV);
4586
4587     case OP_RV2SV:
4588     case OP_RV2AV:
4589         o->op_type = OP_RV2HV;
4590         o->op_ppaddr = PL_ppaddr[OP_RV2HV];
4591         ref(o, OP_RV2HV);
4592         break;
4593
4594     default:
4595         if (ckWARN_d(WARN_INTERNAL))
4596             Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
4597         break;
4598     }
4599     return o;
4600 }
4601
4602 OP *
4603 Perl_newAVREF(pTHX_ OP *o)
4604 {
4605     if (o->op_type == OP_PADANY) {
4606         o->op_type = OP_PADAV;
4607         o->op_ppaddr = PL_ppaddr[OP_PADAV];
4608         return o;
4609     }
4610     else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
4611                 && ckWARN(WARN_DEPRECATED)) {
4612         Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4613                 "Using an array as a reference is deprecated");
4614     }
4615     return newUNOP(OP_RV2AV, 0, scalar(o));
4616 }
4617
4618 OP *
4619 Perl_newGVREF(pTHX_ I32 type, OP *o)
4620 {
4621     if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
4622         return newUNOP(OP_NULL, 0, o);
4623     return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
4624 }
4625
4626 OP *
4627 Perl_newHVREF(pTHX_ OP *o)
4628 {
4629     if (o->op_type == OP_PADANY) {
4630         o->op_type = OP_PADHV;
4631         o->op_ppaddr = PL_ppaddr[OP_PADHV];
4632         return o;
4633     }
4634     else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
4635                 && ckWARN(WARN_DEPRECATED)) {
4636         Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4637                 "Using a hash as a reference is deprecated");
4638     }
4639     return newUNOP(OP_RV2HV, 0, scalar(o));
4640 }
4641
4642 OP *
4643 Perl_oopsCV(pTHX_ OP *o)
4644 {
4645     Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
4646     /* STUB */
4647     return o;
4648 }
4649
4650 OP *
4651 Perl_newCVREF(pTHX_ I32 flags, OP *o)
4652 {
4653     return newUNOP(OP_RV2CV, flags, scalar(o));
4654 }
4655
4656 OP *
4657 Perl_newSVREF(pTHX_ OP *o)
4658 {
4659     if (o->op_type == OP_PADANY) {
4660         o->op_type = OP_PADSV;
4661         o->op_ppaddr = PL_ppaddr[OP_PADSV];
4662         return o;
4663     }
4664     else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
4665         o->op_flags |= OPpDONE_SVREF;
4666         return o;
4667     }
4668     return newUNOP(OP_RV2SV, 0, scalar(o));
4669 }
4670
4671 /* Check routines. */
4672
4673 OP *
4674 Perl_ck_anoncode(pTHX_ OP *o)
4675 {
4676     cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
4677     cSVOPo->op_sv = Nullsv;
4678     return o;
4679 }
4680
4681 OP *
4682 Perl_ck_bitop(pTHX_ OP *o)
4683 {
4684 #define OP_IS_NUMCOMPARE(op) \
4685         ((op) == OP_LT   || (op) == OP_I_LT || \
4686          (op) == OP_GT   || (op) == OP_I_GT || \
4687          (op) == OP_LE   || (op) == OP_I_LE || \
4688          (op) == OP_GE   || (op) == OP_I_GE || \
4689          (op) == OP_EQ   || (op) == OP_I_EQ || \
4690          (op) == OP_NE   || (op) == OP_I_NE || \
4691          (op) == OP_NCMP || (op) == OP_I_NCMP)
4692     o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4693     if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
4694             && (o->op_type == OP_BIT_OR
4695              || o->op_type == OP_BIT_AND
4696              || o->op_type == OP_BIT_XOR))
4697     {
4698         OP * left = cBINOPo->op_first;
4699         OP * right = left->op_sibling;
4700         if ((OP_IS_NUMCOMPARE(left->op_type) &&
4701                 (left->op_flags & OPf_PARENS) == 0) ||
4702             (OP_IS_NUMCOMPARE(right->op_type) &&
4703                 (right->op_flags & OPf_PARENS) == 0))
4704             if (ckWARN(WARN_PRECEDENCE))
4705                 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
4706                         "Possible precedence problem on bitwise %c operator",
4707                         o->op_type == OP_BIT_OR ? '|'
4708                             : o->op_type == OP_BIT_AND ? '&' : '^'
4709                         );
4710     }
4711     return o;
4712 }
4713
4714 OP *
4715 Perl_ck_concat(pTHX_ OP *o)
4716 {
4717     OP *kid = cUNOPo->op_first;
4718     if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
4719             !(kUNOP->op_first->op_flags & OPf_MOD))
4720         o->op_flags |= OPf_STACKED;
4721     return o;
4722 }
4723
4724 OP *
4725 Perl_ck_spair(pTHX_ OP *o)
4726 {
4727     if (o->op_flags & OPf_KIDS) {
4728         OP* newop;
4729         OP* kid;
4730         OPCODE type = o->op_type;
4731         o = modkids(ck_fun(o), type);
4732         kid = cUNOPo->op_first;
4733         newop = kUNOP->op_first->op_sibling;
4734         if (newop &&
4735             (newop->op_sibling ||
4736              !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
4737              newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
4738              newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
4739
4740             return o;
4741         }
4742         op_free(kUNOP->op_first);
4743         kUNOP->op_first = newop;
4744     }
4745     o->op_ppaddr = PL_ppaddr[++o->op_type];
4746     return ck_fun(o);
4747 }
4748
4749 OP *
4750 Perl_ck_delete(pTHX_ OP *o)
4751 {
4752     o = ck_fun(o);
4753     o->op_private = 0;
4754     if (o->op_flags & OPf_KIDS) {
4755         OP *kid = cUNOPo->op_first;
4756         switch (kid->op_type) {
4757         case OP_ASLICE:
4758             o->op_flags |= OPf_SPECIAL;
4759             /* FALL THROUGH */
4760         case OP_HSLICE:
4761             o->op_private |= OPpSLICE;
4762             break;
4763         case OP_AELEM:
4764             o->op_flags |= OPf_SPECIAL;
4765             /* FALL THROUGH */
4766         case OP_HELEM:
4767             break;
4768         default:
4769             Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
4770                   OP_DESC(o));
4771         }
4772         op_null(kid);
4773     }
4774     return o;
4775 }
4776
4777 OP *
4778 Perl_ck_die(pTHX_ OP *o)
4779 {
4780 #ifdef VMS
4781     if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
4782 #endif
4783     return ck_fun(o);
4784 }
4785
4786 OP *
4787 Perl_ck_eof(pTHX_ OP *o)
4788 {
4789     I32 type = o->op_type;
4790
4791     if (o->op_flags & OPf_KIDS) {
4792         if (cLISTOPo->op_first->op_type == OP_STUB) {
4793             op_free(o);
4794             o = newUNOP(type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
4795         }
4796         return ck_fun(o);
4797     }
4798     return o;
4799 }
4800
4801 OP *
4802 Perl_ck_eval(pTHX_ OP *o)
4803 {
4804     PL_hints |= HINT_BLOCK_SCOPE;
4805     if (o->op_flags & OPf_KIDS) {
4806         SVOP *kid = (SVOP*)cUNOPo->op_first;
4807
4808         if (!kid) {
4809             o->op_flags &= ~OPf_KIDS;
4810             op_null(o);
4811         }
4812         else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
4813             LOGOP *enter;
4814
4815             cUNOPo->op_first = 0;
4816             op_free(o);
4817
4818             NewOp(1101, enter, 1, LOGOP);
4819             enter->op_type = OP_ENTERTRY;
4820             enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
4821             enter->op_private = 0;
4822
4823             /* establish postfix order */
4824             enter->op_next = (OP*)enter;
4825
4826             o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
4827             o->op_type = OP_LEAVETRY;
4828             o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
4829             enter->op_other = o;
4830             return o;
4831         }
4832         else {
4833             scalar((OP*)kid);
4834             PL_cv_has_eval = 1;
4835         }
4836     }
4837     else {
4838         op_free(o);
4839         o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
4840     }
4841     o->op_targ = (PADOFFSET)PL_hints;
4842     return o;
4843 }
4844
4845 OP *
4846 Perl_ck_exit(pTHX_ OP *o)
4847 {
4848 #ifdef VMS
4849     HV *table = GvHV(PL_hintgv);
4850     if (table) {
4851        SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
4852        if (svp && *svp && SvTRUE(*svp))
4853            o->op_private |= OPpEXIT_VMSISH;
4854     }
4855     if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
4856 #endif
4857     return ck_fun(o);
4858 }
4859
4860 OP *
4861 Perl_ck_exec(pTHX_ OP *o)
4862 {
4863     OP *kid;
4864     if (o->op_flags & OPf_STACKED) {
4865         o = ck_fun(o);
4866         kid = cUNOPo->op_first->op_sibling;
4867         if (kid->op_type == OP_RV2GV)
4868             op_null(kid);
4869     }
4870     else
4871         o = listkids(o);
4872     return o;
4873 }
4874
4875 OP *
4876 Perl_ck_exists(pTHX_ OP *o)
4877 {
4878     o = ck_fun(o);
4879     if (o->op_flags & OPf_KIDS) {
4880         OP *kid = cUNOPo->op_first;
4881         if (kid->op_type == OP_ENTERSUB) {
4882             (void) ref(kid, o->op_type);
4883             if (kid->op_type != OP_RV2CV && !PL_error_count)
4884                 Perl_croak(aTHX_ "%s argument is not a subroutine name",
4885                             OP_DESC(o));
4886             o->op_private |= OPpEXISTS_SUB;
4887         }
4888         else if (kid->op_type == OP_AELEM)
4889             o->op_flags |= OPf_SPECIAL;
4890         else if (kid->op_type != OP_HELEM)
4891             Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
4892                         OP_DESC(o));
4893         op_null(kid);
4894     }
4895     return o;
4896 }
4897
4898 #if 0
4899 OP *
4900 Perl_ck_gvconst(pTHX_ register OP *o)
4901 {
4902     o = fold_constants(o);
4903     if (o->op_type == OP_CONST)
4904         o->op_type = OP_GV;
4905     return o;
4906 }
4907 #endif
4908
4909 OP *
4910 Perl_ck_rvconst(pTHX_ register OP *o)
4911 {
4912     SVOP *kid = (SVOP*)cUNOPo->op_first;
4913
4914     o->op_private |= (PL_hints & HINT_STRICT_REFS);
4915     if (kid->op_type == OP_CONST) {
4916         char *name;
4917         int iscv;
4918         GV *gv;
4919         SV *kidsv = kid->op_sv;
4920         STRLEN n_a;
4921
4922         /* Is it a constant from cv_const_sv()? */
4923         if (SvROK(kidsv) && SvREADONLY(kidsv)) {
4924             SV *rsv = SvRV(kidsv);
4925             int svtype = SvTYPE(rsv);
4926             char *badtype = Nullch;
4927
4928             switch (o->op_type) {
4929             case OP_RV2SV:
4930                 if (svtype > SVt_PVMG)
4931                     badtype = "a SCALAR";
4932                 break;
4933             case OP_RV2AV:
4934                 if (svtype != SVt_PVAV)
4935                     badtype = "an ARRAY";
4936                 break;
4937             case OP_RV2HV:
4938                 if (svtype != SVt_PVHV)
4939                     badtype = "a HASH";
4940                 break;
4941             case OP_RV2CV:
4942                 if (svtype != SVt_PVCV)
4943                     badtype = "a CODE";
4944                 break;
4945             }
4946             if (badtype)
4947                 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
4948             return o;
4949         }
4950         name = SvPV(kidsv, n_a);
4951         if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
4952             char *badthing = Nullch;
4953             switch (o->op_type) {
4954             case OP_RV2SV:
4955                 badthing = "a SCALAR";
4956                 break;
4957             case OP_RV2AV:
4958                 badthing = "an ARRAY";
4959                 break;
4960             case OP_RV2HV:
4961                 badthing = "a HASH";
4962                 break;
4963             }
4964             if (badthing)
4965                 Perl_croak(aTHX_
4966           "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
4967                       name, badthing);
4968         }
4969         /*
4970          * This is a little tricky.  We only want to add the symbol if we
4971          * didn't add it in the lexer.  Otherwise we get duplicate strict
4972          * warnings.  But if we didn't add it in the lexer, we must at
4973          * least pretend like we wanted to add it even if it existed before,
4974          * or we get possible typo warnings.  OPpCONST_ENTERED says
4975          * whether the lexer already added THIS instance of this symbol.
4976          */
4977         iscv = (o->op_type == OP_RV2CV) * 2;
4978         do {
4979             gv = gv_fetchpv(name,
4980                 iscv | !(kid->op_private & OPpCONST_ENTERED),
4981                 iscv
4982                     ? SVt_PVCV
4983                     : o->op_type == OP_RV2SV
4984                         ? SVt_PV
4985                         : o->op_type == OP_RV2AV
4986                             ? SVt_PVAV
4987                             : o->op_type == OP_RV2HV
4988                                 ? SVt_PVHV
4989                                 : SVt_PVGV);
4990         } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
4991         if (gv) {
4992             kid->op_type = OP_GV;
4993             SvREFCNT_dec(kid->op_sv);
4994 #ifdef USE_ITHREADS
4995             /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
4996             kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
4997             SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
4998             GvIN_PAD_on(gv);
4999             PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc(gv));
5000 #else
5001             kid->op_sv = SvREFCNT_inc(gv);
5002 #endif
5003             kid->op_private = 0;
5004             kid->op_ppaddr = PL_ppaddr[OP_GV];
5005         }
5006     }
5007     return o;
5008 }
5009
5010 OP *
5011 Perl_ck_ftst(pTHX_ OP *o)
5012 {
5013     I32 type = o->op_type;
5014
5015     if (o->op_flags & OPf_REF) {
5016         /* nothing */
5017     }
5018     else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5019         SVOP *kid = (SVOP*)cUNOPo->op_first;
5020
5021         if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5022             STRLEN n_a;
5023             OP *newop = newGVOP(type, OPf_REF,
5024                 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
5025             op_free(o);
5026             o = newop;
5027         }
5028         else {
5029           if ((PL_hints & HINT_FILETEST_ACCESS) &&
5030               OP_IS_FILETEST_ACCESS(o))
5031             o->op_private |= OPpFT_ACCESS;
5032         }
5033     }
5034     else {
5035         op_free(o);
5036         if (type == OP_FTTTY)
5037             o = newGVOP(type, OPf_REF, PL_stdingv);
5038         else
5039             o = newUNOP(type, 0, newDEFSVOP());
5040     }
5041     return o;
5042 }
5043
5044 OP *
5045 Perl_ck_fun(pTHX_ OP *o)
5046 {
5047     register OP *kid;
5048     OP **tokid;
5049     OP *sibl;
5050     I32 numargs = 0;
5051     int type = o->op_type;
5052     register I32 oa = PL_opargs[type] >> OASHIFT;
5053
5054     if (o->op_flags & OPf_STACKED) {
5055         if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5056             oa &= ~OA_OPTIONAL;
5057         else
5058             return no_fh_allowed(o);
5059     }
5060
5061     if (o->op_flags & OPf_KIDS) {
5062         STRLEN n_a;
5063         tokid = &cLISTOPo->op_first;
5064         kid = cLISTOPo->op_first;
5065         if (kid->op_type == OP_PUSHMARK ||
5066             (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5067         {
5068             tokid = &kid->op_sibling;
5069             kid = kid->op_sibling;
5070         }
5071         if (!kid && PL_opargs[type] & OA_DEFGV)
5072             *tokid = kid = newDEFSVOP();
5073
5074         while (oa && kid) {
5075             numargs++;
5076             sibl = kid->op_sibling;
5077             switch (oa & 7) {
5078             case OA_SCALAR:
5079                 /* list seen where single (scalar) arg expected? */
5080                 if (numargs == 1 && !(oa >> 4)
5081                     && kid->op_type == OP_LIST && type != OP_SCALAR)
5082                 {
5083                     return too_many_arguments(o,PL_op_desc[type]);
5084                 }
5085                 scalar(kid);
5086                 break;
5087             case OA_LIST:
5088                 if (oa < 16) {
5089                     kid = 0;
5090                     continue;
5091                 }
5092                 else
5093                     list(kid);
5094                 break;
5095             case OA_AVREF:
5096                 if ((type == OP_PUSH || type == OP_UNSHIFT)
5097                     && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5098                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5099                         "Useless use of %s with no values",
5100                         PL_op_desc[type]);
5101
5102                 if (kid->op_type == OP_CONST &&
5103                     (kid->op_private & OPpCONST_BARE))
5104                 {
5105                     char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5106                     OP *newop = newAVREF(newGVOP(OP_GV, 0,
5107                         gv_fetchpv(name, TRUE, SVt_PVAV) ));
5108                     if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5109                         Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5110                             "Array @%s missing the @ in argument %"IVdf" of %s()",
5111                             name, (IV)numargs, PL_op_desc[type]);
5112                     op_free(kid);
5113                     kid = newop;
5114                     kid->op_sibling = sibl;
5115                     *tokid = kid;
5116                 }
5117                 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5118                     bad_type(numargs, "array", PL_op_desc[type], kid);
5119                 mod(kid, type);
5120                 break;
5121             case OA_HVREF:
5122                 if (kid->op_type == OP_CONST &&
5123                     (kid->op_private & OPpCONST_BARE))
5124                 {
5125                     char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5126                     OP *newop = newHVREF(newGVOP(OP_GV, 0,
5127                         gv_fetchpv(name, TRUE, SVt_PVHV) ));
5128                     if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5129                         Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5130                             "Hash %%%s missing the %% in argument %"IVdf" of %s()",
5131                             name, (IV)numargs, PL_op_desc[type]);
5132                     op_free(kid);
5133                     kid = newop;
5134                     kid->op_sibling = sibl;
5135                     *tokid = kid;
5136                 }
5137                 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5138                     bad_type(numargs, "hash", PL_op_desc[type], kid);
5139                 mod(kid, type);
5140                 break;
5141             case OA_CVREF:
5142                 {
5143                     OP *newop = newUNOP(OP_NULL, 0, kid);
5144                     kid->op_sibling = 0;
5145                     linklist(kid);
5146                     newop->op_next = newop;
5147                     kid = newop;
5148                     kid->op_sibling = sibl;
5149                     *tokid = kid;
5150                 }
5151                 break;
5152             case OA_FILEREF:
5153                 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5154                     if (kid->op_type == OP_CONST &&
5155                         (kid->op_private & OPpCONST_BARE))
5156                     {
5157                         OP *newop = newGVOP(OP_GV, 0,
5158                             gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
5159                                         SVt_PVIO) );
5160                         if (!(o->op_private & 1) && /* if not unop */
5161                             kid == cLISTOPo->op_last)
5162                             cLISTOPo->op_last = newop;
5163                         op_free(kid);
5164                         kid = newop;
5165                     }
5166                     else if (kid->op_type == OP_READLINE) {
5167                         /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5168                         bad_type(numargs, "HANDLE", OP_DESC(o), kid);
5169                     }
5170                     else {
5171                         I32 flags = OPf_SPECIAL;
5172                         I32 priv = 0;
5173                         PADOFFSET targ = 0;
5174
5175                         /* is this op a FH constructor? */
5176                         if (is_handle_constructor(o,numargs)) {
5177                             char *name = Nullch;
5178                             STRLEN len = 0;
5179
5180                             flags = 0;
5181                             /* Set a flag to tell rv2gv to vivify
5182                              * need to "prove" flag does not mean something
5183                              * else already - NI-S 1999/05/07
5184                              */
5185                             priv = OPpDEREF;
5186                             if (kid->op_type == OP_PADSV) {
5187                                 name = PAD_COMPNAME_PV(kid->op_targ);
5188                                 /* SvCUR of a pad namesv can't be trusted
5189                                  * (see PL_generation), so calc its length
5190                                  * manually */
5191                                 if (name)
5192                                     len = strlen(name);
5193
5194                             }
5195                             else if (kid->op_type == OP_RV2SV
5196                                      && kUNOP->op_first->op_type == OP_GV)
5197                             {
5198                                 GV *gv = cGVOPx_gv(kUNOP->op_first);
5199                                 name = GvNAME(gv);
5200                                 len = GvNAMELEN(gv);
5201                             }
5202                             else if (kid->op_type == OP_AELEM
5203                                      || kid->op_type == OP_HELEM)
5204                             {
5205                                  OP *op;
5206
5207                                  name = 0;
5208                                  if ((op = ((BINOP*)kid)->op_first)) {
5209                                       SV *tmpstr = Nullsv;
5210                                       char *a =
5211                                            kid->op_type == OP_AELEM ?
5212                                            "[]" : "{}";
5213                                       if (((op->op_type == OP_RV2AV) ||
5214                                            (op->op_type == OP_RV2HV)) &&
5215                                           (op = ((UNOP*)op)->op_first) &&
5216                                           (op->op_type == OP_GV)) {
5217                                            /* packagevar $a[] or $h{} */
5218                                            GV *gv = cGVOPx_gv(op);
5219                                            if (gv)
5220                                                 tmpstr =
5221                                                      Perl_newSVpvf(aTHX_
5222                                                                    "%s%c...%c",
5223                                                                    GvNAME(gv),
5224                                                                    a[0], a[1]);
5225                                       }
5226                                       else if (op->op_type == OP_PADAV
5227                                                || op->op_type == OP_PADHV) {
5228                                            /* lexicalvar $a[] or $h{} */
5229                                            char *padname =
5230                                                 PAD_COMPNAME_PV(op->op_targ);
5231                                            if (padname)
5232                                                 tmpstr =
5233                                                      Perl_newSVpvf(aTHX_
5234                                                                    "%s%c...%c",
5235                                                                    padname + 1,
5236                                                                    a[0], a[1]);
5237
5238                                       }
5239                                       if (tmpstr) {
5240                                            name = SvPV(tmpstr, len);
5241                                            sv_2mortal(tmpstr);
5242                                       }
5243                                  }
5244                                  if (!name) {
5245                                       name = "__ANONIO__";
5246                                       len = 10;
5247                                  }
5248                                  mod(kid, type);
5249                             }
5250                             if (name) {
5251                                 SV *namesv;
5252                                 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5253                                 namesv = PAD_SVl(targ);
5254                                 (void)SvUPGRADE(namesv, SVt_PV);
5255                                 if (*name != '$')
5256                                     sv_setpvn(namesv, "$", 1);
5257                                 sv_catpvn(namesv, name, len);
5258                             }
5259                         }
5260                         kid->op_sibling = 0;
5261                         kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5262                         kid->op_targ = targ;
5263                         kid->op_private |= priv;
5264                     }
5265                     kid->op_sibling = sibl;
5266                     *tokid = kid;
5267                 }
5268                 scalar(kid);
5269                 break;
5270             case OA_SCALARREF:
5271                 mod(scalar(kid), type);
5272                 break;
5273             }
5274             oa >>= 4;
5275             tokid = &kid->op_sibling;
5276             kid = kid->op_sibling;
5277         }
5278         o->op_private |= numargs;
5279         if (kid)
5280             return too_many_arguments(o,OP_DESC(o));
5281         listkids(o);
5282     }
5283     else if (PL_opargs[type] & OA_DEFGV) {
5284         op_free(o);
5285         return newUNOP(type, 0, newDEFSVOP());
5286     }
5287
5288     if (oa) {
5289         while (oa & OA_OPTIONAL)
5290             oa >>= 4;
5291         if (oa && oa != OA_LIST)
5292             return too_few_arguments(o,OP_DESC(o));
5293     }
5294     return o;
5295 }
5296
5297 OP *
5298 Perl_ck_glob(pTHX_ OP *o)
5299 {
5300     GV *gv;
5301
5302     o = ck_fun(o);
5303     if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5304         append_elem(OP_GLOB, o, newDEFSVOP());
5305
5306     if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV))
5307           && GvCVu(gv) && GvIMPORTED_CV(gv)))
5308     {
5309         gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5310     }
5311
5312 #if !defined(PERL_EXTERNAL_GLOB)
5313     /* XXX this can be tightened up and made more failsafe. */
5314     if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
5315         GV *glob_gv;
5316         ENTER;
5317         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
5318                 newSVpvn("File::Glob", 10), Nullsv, Nullsv, Nullsv);
5319         gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5320         glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
5321         GvCV(gv) = GvCV(glob_gv);
5322         SvREFCNT_inc((SV*)GvCV(gv));
5323         GvIMPORTED_CV_on(gv);
5324         LEAVE;
5325     }
5326 #endif /* PERL_EXTERNAL_GLOB */
5327
5328     if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5329         append_elem(OP_GLOB, o,
5330                     newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5331         o->op_type = OP_LIST;
5332         o->op_ppaddr = PL_ppaddr[OP_LIST];
5333         cLISTOPo->op_first->op_type = OP_PUSHMARK;
5334         cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5335         cLISTOPo->op_first->op_targ = 0;
5336         o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5337                     append_elem(OP_LIST, o,
5338                                 scalar(newUNOP(OP_RV2CV, 0,
5339                                                newGVOP(OP_GV, 0, gv)))));
5340         o = newUNOP(OP_NULL, 0, ck_subr(o));
5341         o->op_targ = OP_GLOB;           /* hint at what it used to be */
5342         return o;
5343     }
5344     gv = newGVgen("main");
5345     gv_IOadd(gv);
5346     append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5347     scalarkids(o);
5348     return o;
5349 }
5350
5351 OP *
5352 Perl_ck_grep(pTHX_ OP *o)
5353 {
5354     LOGOP *gwop;
5355     OP *kid;
5356     OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5357
5358     o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5359     NewOp(1101, gwop, 1, LOGOP);
5360
5361     if (o->op_flags & OPf_STACKED) {
5362         OP* k;
5363         o = ck_sort(o);
5364         kid = cLISTOPo->op_first->op_sibling;
5365         for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
5366             kid = k;
5367         }
5368         kid->op_next = (OP*)gwop;
5369         o->op_flags &= ~OPf_STACKED;
5370     }
5371     kid = cLISTOPo->op_first->op_sibling;
5372     if (type == OP_MAPWHILE)
5373         list(kid);
5374     else
5375         scalar(kid);
5376     o = ck_fun(o);
5377     if (PL_error_count)
5378         return o;
5379     kid = cLISTOPo->op_first->op_sibling;
5380     if (kid->op_type != OP_NULL)
5381         Perl_croak(aTHX_ "panic: ck_grep");
5382     kid = kUNOP->op_first;
5383
5384     gwop->op_type = type;
5385     gwop->op_ppaddr = PL_ppaddr[type];
5386     gwop->op_first = listkids(o);
5387     gwop->op_flags |= OPf_KIDS;
5388     gwop->op_private = 1;
5389     gwop->op_other = LINKLIST(kid);
5390     gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5391     kid->op_next = (OP*)gwop;
5392
5393     kid = cLISTOPo->op_first->op_sibling;
5394     if (!kid || !kid->op_sibling)
5395         return too_few_arguments(o,OP_DESC(o));
5396     for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5397         mod(kid, OP_GREPSTART);
5398
5399     return (OP*)gwop;
5400 }
5401
5402 OP *
5403 Perl_ck_index(pTHX_ OP *o)
5404 {
5405     if (o->op_flags & OPf_KIDS) {
5406         OP *kid = cLISTOPo->op_first->op_sibling;       /* get past pushmark */
5407         if (kid)
5408             kid = kid->op_sibling;                      /* get past "big" */
5409         if (kid && kid->op_type == OP_CONST)
5410             fbm_compile(((SVOP*)kid)->op_sv, 0);
5411     }
5412     return ck_fun(o);
5413 }
5414
5415 OP *
5416 Perl_ck_lengthconst(pTHX_ OP *o)
5417 {
5418     /* XXX length optimization goes here */
5419     return ck_fun(o);
5420 }
5421
5422 OP *
5423 Perl_ck_lfun(pTHX_ OP *o)
5424 {
5425     OPCODE type = o->op_type;
5426     return modkids(ck_fun(o), type);
5427 }
5428
5429 OP *
5430 Perl_ck_defined(pTHX_ OP *o)            /* 19990527 MJD */
5431 {
5432     if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
5433         switch (cUNOPo->op_first->op_type) {
5434         case OP_RV2AV:
5435             /* This is needed for
5436                if (defined %stash::)
5437                to work.   Do not break Tk.
5438                */
5439             break;                      /* Globals via GV can be undef */
5440         case OP_PADAV:
5441         case OP_AASSIGN:                /* Is this a good idea? */
5442             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5443                         "defined(@array) is deprecated");
5444             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5445                         "\t(Maybe you should just omit the defined()?)\n");
5446         break;
5447         case OP_RV2HV:
5448             /* This is needed for
5449                if (defined %stash::)
5450                to work.   Do not break Tk.
5451                */
5452             break;                      /* Globals via GV can be undef */
5453         case OP_PADHV:
5454             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5455                         "defined(%%hash) is deprecated");
5456             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5457                         "\t(Maybe you should just omit the defined()?)\n");
5458             break;
5459         default:
5460             /* no warning */
5461             break;
5462         }
5463     }
5464     return ck_rfun(o);
5465 }
5466
5467 OP *
5468 Perl_ck_rfun(pTHX_ OP *o)
5469 {
5470     OPCODE type = o->op_type;
5471     return refkids(ck_fun(o), type);
5472 }
5473
5474 OP *
5475 Perl_ck_listiob(pTHX_ OP *o)
5476 {
5477     register OP *kid;
5478
5479     kid = cLISTOPo->op_first;
5480     if (!kid) {
5481         o = force_list(o);
5482         kid = cLISTOPo->op_first;
5483     }
5484     if (kid->op_type == OP_PUSHMARK)
5485         kid = kid->op_sibling;
5486     if (kid && o->op_flags & OPf_STACKED)
5487         kid = kid->op_sibling;
5488     else if (kid && !kid->op_sibling) {         /* print HANDLE; */
5489         if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
5490             o->op_flags |= OPf_STACKED; /* make it a filehandle */
5491             kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
5492             cLISTOPo->op_first->op_sibling = kid;
5493             cLISTOPo->op_last = kid;
5494             kid = kid->op_sibling;
5495         }
5496     }
5497
5498     if (!kid)
5499         append_elem(o->op_type, o, newDEFSVOP());
5500
5501     return listkids(o);
5502 }
5503
5504 OP *
5505 Perl_ck_sassign(pTHX_ OP *o)
5506 {
5507     OP *kid = cLISTOPo->op_first;
5508     /* has a disposable target? */
5509     if ((PL_opargs[kid->op_type] & OA_TARGLEX)
5510         && !(kid->op_flags & OPf_STACKED)
5511         /* Cannot steal the second time! */
5512         && !(kid->op_private & OPpTARGET_MY))
5513     {
5514         OP *kkid = kid->op_sibling;
5515
5516         /* Can just relocate the target. */
5517         if (kkid && kkid->op_type == OP_PADSV
5518             && !(kkid->op_private & OPpLVAL_INTRO))
5519         {
5520             kid->op_targ = kkid->op_targ;
5521             kkid->op_targ = 0;
5522             /* Now we do not need PADSV and SASSIGN. */
5523             kid->op_sibling = o->op_sibling;    /* NULL */
5524             cLISTOPo->op_first = NULL;
5525             op_free(o);
5526             op_free(kkid);
5527             kid->op_private |= OPpTARGET_MY;    /* Used for context settings */
5528             return kid;
5529         }
5530     }
5531     return o;
5532 }
5533
5534 OP *
5535 Perl_ck_match(pTHX_ OP *o)
5536 {
5537     o->op_private |= OPpRUNTIME;
5538     return o;
5539 }
5540
5541 OP *
5542 Perl_ck_method(pTHX_ OP *o)
5543 {
5544     OP *kid = cUNOPo->op_first;
5545     if (kid->op_type == OP_CONST) {
5546         SV* sv = kSVOP->op_sv;
5547         if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
5548             OP *cmop;
5549             if (!SvREADONLY(sv) || !SvFAKE(sv)) {
5550                 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
5551             }
5552             else {
5553                 kSVOP->op_sv = Nullsv;
5554             }
5555             cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
5556             op_free(o);
5557             return cmop;
5558         }
5559     }
5560     return o;
5561 }
5562
5563 OP *
5564 Perl_ck_null(pTHX_ OP *o)
5565 {
5566     return o;
5567 }
5568
5569 OP *
5570 Perl_ck_open(pTHX_ OP *o)
5571 {
5572     HV *table = GvHV(PL_hintgv);
5573     if (table) {
5574         SV **svp;
5575         I32 mode;
5576         svp = hv_fetch(table, "open_IN", 7, FALSE);
5577         if (svp && *svp) {
5578             mode = mode_from_discipline(*svp);
5579             if (mode & O_BINARY)
5580                 o->op_private |= OPpOPEN_IN_RAW;
5581             else if (mode & O_TEXT)
5582                 o->op_private |= OPpOPEN_IN_CRLF;
5583         }
5584
5585         svp = hv_fetch(table, "open_OUT", 8, FALSE);
5586         if (svp && *svp) {
5587             mode = mode_from_discipline(*svp);
5588             if (mode & O_BINARY)
5589                 o->op_private |= OPpOPEN_OUT_RAW;
5590             else if (mode & O_TEXT)
5591                 o->op_private |= OPpOPEN_OUT_CRLF;
5592         }
5593     }
5594     if (o->op_type == OP_BACKTICK)
5595         return o;
5596     {
5597          /* In case of three-arg dup open remove strictness
5598           * from the last arg if it is a bareword. */
5599          OP *first = cLISTOPx(o)->op_first; /* The pushmark. */
5600          OP *last  = cLISTOPx(o)->op_last;  /* The bareword. */
5601          OP *oa;
5602          char *mode;
5603
5604          if ((last->op_type == OP_CONST) &&             /* The bareword. */
5605              (last->op_private & OPpCONST_BARE) &&
5606              (last->op_private & OPpCONST_STRICT) &&
5607              (oa = first->op_sibling) &&                /* The fh. */
5608              (oa = oa->op_sibling) &&                   /* The mode. */
5609              SvPOK(((SVOP*)oa)->op_sv) &&
5610              (mode = SvPVX(((SVOP*)oa)->op_sv)) &&
5611              mode[0] == '>' && mode[1] == '&' &&        /* A dup open. */
5612              (last == oa->op_sibling))                  /* The bareword. */
5613               last->op_private &= ~OPpCONST_STRICT;
5614     }
5615     return ck_fun(o);
5616 }
5617
5618 OP *
5619 Perl_ck_repeat(pTHX_ OP *o)
5620 {
5621     if (cBINOPo->op_first->op_flags & OPf_PARENS) {
5622         o->op_private |= OPpREPEAT_DOLIST;
5623         cBINOPo->op_first = force_list(cBINOPo->op_first);
5624     }
5625     else
5626         scalar(o);
5627     return o;
5628 }
5629
5630 OP *
5631 Perl_ck_require(pTHX_ OP *o)
5632 {
5633     GV* gv;
5634
5635     if (o->op_flags & OPf_KIDS) {       /* Shall we supply missing .pm? */
5636         SVOP *kid = (SVOP*)cUNOPo->op_first;
5637
5638         if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5639             char *s;
5640             for (s = SvPVX(kid->op_sv); *s; s++) {
5641                 if (*s == ':' && s[1] == ':') {
5642                     *s = '/';
5643                     Move(s+2, s+1, strlen(s+2)+1, char);
5644                     --SvCUR(kid->op_sv);
5645                 }
5646             }
5647             if (SvREADONLY(kid->op_sv)) {
5648                 SvREADONLY_off(kid->op_sv);
5649                 sv_catpvn(kid->op_sv, ".pm", 3);
5650                 SvREADONLY_on(kid->op_sv);
5651             }
5652             else
5653                 sv_catpvn(kid->op_sv, ".pm", 3);
5654         }
5655     }
5656
5657     /* handle override, if any */
5658     gv = gv_fetchpv("require", FALSE, SVt_PVCV);
5659     if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
5660         gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
5661
5662     if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5663         OP *kid = cUNOPo->op_first;
5664         cUNOPo->op_first = 0;
5665         op_free(o);
5666         return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
5667                                append_elem(OP_LIST, kid,
5668                                            scalar(newUNOP(OP_RV2CV, 0,
5669                                                           newGVOP(OP_GV, 0,
5670                                                                   gv))))));
5671     }
5672
5673     return ck_fun(o);
5674 }
5675
5676 OP *
5677 Perl_ck_return(pTHX_ OP *o)
5678 {
5679     OP *kid;
5680     if (CvLVALUE(PL_compcv)) {
5681         for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
5682             mod(kid, OP_LEAVESUBLV);
5683     }
5684     return o;
5685 }
5686
5687 #if 0
5688 OP *
5689 Perl_ck_retarget(pTHX_ OP *o)
5690 {
5691     Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5692     /* STUB */
5693     return o;
5694 }
5695 #endif
5696
5697 OP *
5698 Perl_ck_select(pTHX_ OP *o)
5699 {
5700     OP* kid;
5701     if (o->op_flags & OPf_KIDS) {
5702         kid = cLISTOPo->op_first->op_sibling;   /* get past pushmark */
5703         if (kid && kid->op_sibling) {
5704             o->op_type = OP_SSELECT;
5705             o->op_ppaddr = PL_ppaddr[OP_SSELECT];
5706             o = ck_fun(o);
5707             return fold_constants(o);
5708         }
5709     }
5710     o = ck_fun(o);
5711     kid = cLISTOPo->op_first->op_sibling;    /* get past pushmark */
5712     if (kid && kid->op_type == OP_RV2GV)
5713         kid->op_private &= ~HINT_STRICT_REFS;
5714     return o;
5715 }
5716
5717 OP *
5718 Perl_ck_shift(pTHX_ OP *o)
5719 {
5720     I32 type = o->op_type;
5721
5722     if (!(o->op_flags & OPf_KIDS)) {
5723         OP *argop;
5724
5725         op_free(o);
5726         argop = newUNOP(OP_RV2AV, 0,
5727             scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
5728         return newUNOP(type, 0, scalar(argop));
5729     }
5730     return scalar(modkids(ck_fun(o), type));
5731 }
5732
5733 OP *
5734 Perl_ck_sort(pTHX_ OP *o)
5735 {
5736     OP *firstkid;
5737
5738     if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
5739         simplify_sort(o);
5740     firstkid = cLISTOPo->op_first->op_sibling;          /* get past pushmark */
5741     if (o->op_flags & OPf_STACKED) {                    /* may have been cleared */
5742         OP *k = NULL;
5743         OP *kid = cUNOPx(firstkid)->op_first;           /* get past null */
5744
5745         if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
5746             linklist(kid);
5747             if (kid->op_type == OP_SCOPE) {
5748                 k = kid->op_next;
5749                 kid->op_next = 0;
5750             }
5751             else if (kid->op_type == OP_LEAVE) {
5752                 if (o->op_type == OP_SORT) {
5753                     op_null(kid);                       /* wipe out leave */
5754                     kid->op_next = kid;
5755
5756                     for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
5757                         if (k->op_next == kid)
5758                             k->op_next = 0;
5759                         /* don't descend into loops */
5760                         else if (k->op_type == OP_ENTERLOOP
5761                                  || k->op_type == OP_ENTERITER)
5762                         {
5763                             k = cLOOPx(k)->op_lastop;
5764                         }
5765                     }
5766                 }
5767                 else
5768                     kid->op_next = 0;           /* just disconnect the leave */
5769                 k = kLISTOP->op_first;
5770             }
5771             CALL_PEEP(k);
5772
5773             kid = firstkid;
5774             if (o->op_type == OP_SORT) {
5775                 /* provide scalar context for comparison function/block */
5776                 kid = scalar(kid);
5777                 kid->op_next = kid;
5778             }
5779             else
5780                 kid->op_next = k;
5781             o->op_flags |= OPf_SPECIAL;
5782         }
5783         else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
5784             op_null(firstkid);
5785
5786         firstkid = firstkid->op_sibling;
5787     }
5788
5789     /* provide list context for arguments */
5790     if (o->op_type == OP_SORT)
5791         list(firstkid);
5792
5793     return o;
5794 }
5795
5796 STATIC void
5797 S_simplify_sort(pTHX_ OP *o)
5798 {
5799     register OP *kid = cLISTOPo->op_first->op_sibling;  /* get past pushmark */
5800     OP *k;
5801     int reversed;
5802     GV *gv;
5803     if (!(o->op_flags & OPf_STACKED))
5804         return;
5805     GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
5806     GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
5807     kid = kUNOP->op_first;                              /* get past null */
5808     if (kid->op_type != OP_SCOPE)
5809         return;
5810     kid = kLISTOP->op_last;                             /* get past scope */
5811     switch(kid->op_type) {
5812         case OP_NCMP:
5813         case OP_I_NCMP:
5814         case OP_SCMP:
5815             break;
5816         default:
5817             return;
5818     }
5819     k = kid;                                            /* remember this node*/
5820     if (kBINOP->op_first->op_type != OP_RV2SV)
5821         return;
5822     kid = kBINOP->op_first;                             /* get past cmp */
5823     if (kUNOP->op_first->op_type != OP_GV)
5824         return;
5825     kid = kUNOP->op_first;                              /* get past rv2sv */
5826     gv = kGVOP_gv;
5827     if (GvSTASH(gv) != PL_curstash)
5828         return;
5829     if (strEQ(GvNAME(gv), "a"))
5830         reversed = 0;
5831     else if (strEQ(GvNAME(gv), "b"))
5832         reversed = 1;
5833     else
5834         return;
5835     kid = k;                                            /* back to cmp */
5836     if (kBINOP->op_last->op_type != OP_RV2SV)
5837         return;
5838     kid = kBINOP->op_last;                              /* down to 2nd arg */
5839     if (kUNOP->op_first->op_type != OP_GV)
5840         return;
5841     kid = kUNOP->op_first;                              /* get past rv2sv */
5842     gv = kGVOP_gv;
5843     if (GvSTASH(gv) != PL_curstash
5844         || ( reversed
5845             ? strNE(GvNAME(gv), "a")
5846             : strNE(GvNAME(gv), "b")))
5847         return;
5848     o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
5849     if (reversed)
5850         o->op_private |= OPpSORT_REVERSE;
5851     if (k->op_type == OP_NCMP)
5852         o->op_private |= OPpSORT_NUMERIC;
5853     if (k->op_type == OP_I_NCMP)
5854         o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
5855     kid = cLISTOPo->op_first->op_sibling;
5856     cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
5857     op_free(kid);                                     /* then delete it */
5858 }
5859
5860 OP *
5861 Perl_ck_split(pTHX_ OP *o)
5862 {
5863     register OP *kid;
5864
5865     if (o->op_flags & OPf_STACKED)
5866         return no_fh_allowed(o);
5867
5868     kid = cLISTOPo->op_first;
5869     if (kid->op_type != OP_NULL)
5870         Perl_croak(aTHX_ "panic: ck_split");
5871     kid = kid->op_sibling;
5872     op_free(cLISTOPo->op_first);
5873     cLISTOPo->op_first = kid;
5874     if (!kid) {
5875         cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
5876         cLISTOPo->op_last = kid; /* There was only one element previously */
5877     }
5878
5879     if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
5880         OP *sibl = kid->op_sibling;
5881         kid->op_sibling = 0;
5882         kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
5883         if (cLISTOPo->op_first == cLISTOPo->op_last)
5884             cLISTOPo->op_last = kid;
5885         cLISTOPo->op_first = kid;
5886         kid->op_sibling = sibl;
5887     }
5888
5889     kid->op_type = OP_PUSHRE;
5890     kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
5891     scalar(kid);
5892     if (ckWARN(WARN_REGEXP) && ((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
5893       Perl_warner(aTHX_ packWARN(WARN_REGEXP),
5894                   "Use of /g modifier is meaningless in split");
5895     }
5896
5897     if (!kid->op_sibling)
5898         append_elem(OP_SPLIT, o, newDEFSVOP());
5899
5900     kid = kid->op_sibling;
5901     scalar(kid);
5902
5903     if (!kid->op_sibling)
5904         append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
5905
5906     kid = kid->op_sibling;
5907     scalar(kid);
5908
5909     if (kid->op_sibling)
5910         return too_many_arguments(o,OP_DESC(o));
5911
5912     return o;
5913 }
5914
5915 OP *
5916 Perl_ck_join(pTHX_ OP *o)
5917 {
5918     if (ckWARN(WARN_SYNTAX)) {
5919         OP *kid = cLISTOPo->op_first->op_sibling;
5920         if (kid && kid->op_type == OP_MATCH) {
5921             char *pmstr = "STRING";
5922             if (PM_GETRE(kPMOP))
5923                 pmstr = PM_GETRE(kPMOP)->precomp;
5924             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5925                         "/%s/ should probably be written as \"%s\"",
5926                         pmstr, pmstr);
5927         }
5928     }
5929     return ck_fun(o);
5930 }
5931
5932 OP *
5933 Perl_ck_subr(pTHX_ OP *o)
5934 {
5935     OP *prev = ((cUNOPo->op_first->op_sibling)
5936              ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
5937     OP *o2 = prev->op_sibling;
5938     OP *cvop;
5939     char *proto = 0;
5940     CV *cv = 0;
5941     GV *namegv = 0;
5942     int optional = 0;
5943     I32 arg = 0;
5944     I32 contextclass = 0;
5945     char *e = 0;
5946     STRLEN n_a;
5947     bool delete=0;
5948
5949     o->op_private |= OPpENTERSUB_HASTARG;
5950     for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
5951     if (cvop->op_type == OP_RV2CV) {
5952         SVOP* tmpop;
5953         o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
5954         op_null(cvop);          /* disable rv2cv */
5955         tmpop = (SVOP*)((UNOP*)cvop)->op_first;
5956         if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
5957             GV *gv = cGVOPx_gv(tmpop);
5958             cv = GvCVu(gv);
5959             if (!cv)
5960                 tmpop->op_private |= OPpEARLY_CV;
5961             else {
5962                 if (SvPOK(cv)) {
5963                     namegv = CvANON(cv) ? gv : CvGV(cv);
5964                     proto = SvPV((SV*)cv, n_a);
5965                 }
5966                 if (CvASSERTION(cv)) {
5967                     if (PL_hints & HINT_ASSERTING) {
5968                         if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
5969                             o->op_private |= OPpENTERSUB_DB;
5970                     }
5971                     else {
5972                         delete=1;
5973                         if (ckWARN(WARN_ASSERTIONS) && !(PL_hints & HINT_ASSERTIONSSEEN)) {
5974                             Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
5975                                         "Impossible to activate assertion call");
5976                         }
5977                     }
5978                 }
5979             }
5980         }
5981     }
5982     else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
5983         if (o2->op_type == OP_CONST)
5984             o2->op_private &= ~OPpCONST_STRICT;
5985         else if (o2->op_type == OP_LIST) {
5986             OP *o = ((UNOP*)o2)->op_first->op_sibling;
5987             if (o && o->op_type == OP_CONST)
5988                 o->op_private &= ~OPpCONST_STRICT;
5989         }
5990     }
5991     o->op_private |= (PL_hints & HINT_STRICT_REFS);
5992     if (PERLDB_SUB && PL_curstash != PL_debstash)
5993         o->op_private |= OPpENTERSUB_DB;
5994     while (o2 != cvop) {
5995         if (proto) {
5996             switch (*proto) {
5997             case '\0':
5998                 return too_many_arguments(o, gv_ename(namegv));
5999             case ';':
6000                 optional = 1;
6001                 proto++;
6002                 continue;
6003             case '$':
6004                 proto++;
6005                 arg++;
6006                 scalar(o2);
6007                 break;
6008             case '%':
6009             case '@':
6010                 list(o2);
6011                 arg++;
6012                 break;
6013             case '&':
6014                 proto++;
6015                 arg++;
6016                 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6017                     bad_type(arg,
6018                         arg == 1 ? "block or sub {}" : "sub {}",
6019                         gv_ename(namegv), o2);
6020                 break;
6021             case '*':
6022                 /* '*' allows any scalar type, including bareword */
6023                 proto++;
6024                 arg++;
6025                 if (o2->op_type == OP_RV2GV)
6026                     goto wrapref;       /* autoconvert GLOB -> GLOBref */
6027                 else if (o2->op_type == OP_CONST)
6028                     o2->op_private &= ~OPpCONST_STRICT;
6029                 else if (o2->op_type == OP_ENTERSUB) {
6030                     /* accidental subroutine, revert to bareword */
6031                     OP *gvop = ((UNOP*)o2)->op_first;
6032                     if (gvop && gvop->op_type == OP_NULL) {
6033                         gvop = ((UNOP*)gvop)->op_first;
6034                         if (gvop) {
6035                             for (; gvop->op_sibling; gvop = gvop->op_sibling)
6036                                 ;
6037                             if (gvop &&
6038                                 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6039                                 (gvop = ((UNOP*)gvop)->op_first) &&
6040                                 gvop->op_type == OP_GV)
6041                             {
6042                                 GV *gv = cGVOPx_gv(gvop);
6043                                 OP *sibling = o2->op_sibling;
6044                                 SV *n = newSVpvn("",0);
6045                                 op_free(o2);
6046                                 gv_fullname3(n, gv, "");
6047                                 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
6048                                     sv_chop(n, SvPVX(n)+6);
6049                                 o2 = newSVOP(OP_CONST, 0, n);
6050                                 prev->op_sibling = o2;
6051                                 o2->op_sibling = sibling;
6052                             }
6053                         }
6054                     }
6055                 }
6056                 scalar(o2);
6057                 break;
6058             case '[': case ']':
6059                  goto oops;
6060                  break;
6061             case '\\':
6062                 proto++;
6063                 arg++;
6064             again:
6065                 switch (*proto++) {
6066                 case '[':
6067                      if (contextclass++ == 0) {
6068                           e = strchr(proto, ']');
6069                           if (!e || e == proto)
6070                                goto oops;
6071                      }
6072                      else
6073                           goto oops;
6074                      goto again;
6075                      break;
6076                 case ']':
6077                      if (contextclass) {
6078                          char *p = proto;
6079                          char s = *p;
6080                          contextclass = 0;
6081                          *p = '\0';
6082                          while (*--p != '[');
6083                          bad_type(arg, Perl_form(aTHX_ "one of %s", p),
6084                                  gv_ename(namegv), o2);
6085                          *proto = s;
6086                      } else
6087                           goto oops;
6088                      break;
6089                 case '*':
6090                      if (o2->op_type == OP_RV2GV)
6091                           goto wrapref;
6092                      if (!contextclass)
6093                           bad_type(arg, "symbol", gv_ename(namegv), o2);
6094                      break;
6095                 case '&':
6096                      if (o2->op_type == OP_ENTERSUB)
6097                           goto wrapref;
6098                      if (!contextclass)
6099                           bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6100                      break;
6101                 case '$':
6102                     if (o2->op_type == OP_RV2SV ||
6103                         o2->op_type == OP_PADSV ||
6104                         o2->op_type == OP_HELEM ||
6105                         o2->op_type == OP_AELEM ||
6106                         o2->op_type == OP_THREADSV)
6107                          goto wrapref;
6108                     if (!contextclass)
6109                         bad_type(arg, "scalar", gv_ename(namegv), o2);
6110                      break;
6111                 case '@':
6112                     if (o2->op_type == OP_RV2AV ||
6113                         o2->op_type == OP_PADAV)
6114                          goto wrapref;
6115                     if (!contextclass)
6116                         bad_type(arg, "array", gv_ename(namegv), o2);
6117                     break;
6118                 case '%':
6119                     if (o2->op_type == OP_RV2HV ||
6120                         o2->op_type == OP_PADHV)
6121                          goto wrapref;
6122                     if (!contextclass)
6123                          bad_type(arg, "hash", gv_ename(namegv), o2);
6124                     break;
6125                 wrapref:
6126                     {
6127                         OP* kid = o2;
6128                         OP* sib = kid->op_sibling;
6129                         kid->op_sibling = 0;
6130                         o2 = newUNOP(OP_REFGEN, 0, kid);
6131                         o2->op_sibling = sib;
6132                         prev->op_sibling = o2;
6133                     }
6134                     if (contextclass && e) {
6135                          proto = e + 1;
6136                          contextclass = 0;
6137                     }
6138                     break;
6139                 default: goto oops;
6140                 }
6141                 if (contextclass)
6142                      goto again;
6143                 break;
6144             case ' ':
6145                 proto++;
6146                 continue;
6147             default:
6148               oops:
6149                 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
6150                            gv_ename(namegv), cv);
6151             }
6152         }
6153         else
6154             list(o2);
6155         mod(o2, OP_ENTERSUB);
6156         prev = o2;
6157         o2 = o2->op_sibling;
6158     }
6159     if (proto && !optional &&
6160           (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6161         return too_few_arguments(o, gv_ename(namegv));
6162     if(delete) {
6163         op_free(o);
6164         o=newSVOP(OP_CONST, 0, newSViv(0));
6165     }
6166     return o;
6167 }
6168
6169 OP *
6170 Perl_ck_svconst(pTHX_ OP *o)
6171 {
6172     SvREADONLY_on(cSVOPo->op_sv);
6173     return o;
6174 }
6175
6176 OP *
6177 Perl_ck_trunc(pTHX_ OP *o)
6178 {
6179     if (o->op_flags & OPf_KIDS) {
6180         SVOP *kid = (SVOP*)cUNOPo->op_first;
6181
6182         if (kid->op_type == OP_NULL)
6183             kid = (SVOP*)kid->op_sibling;
6184         if (kid && kid->op_type == OP_CONST &&
6185             (kid->op_private & OPpCONST_BARE))
6186         {
6187             o->op_flags |= OPf_SPECIAL;
6188             kid->op_private &= ~OPpCONST_STRICT;
6189         }
6190     }
6191     return ck_fun(o);
6192 }
6193
6194 OP *
6195 Perl_ck_unpack(pTHX_ OP *o)
6196 {
6197     OP *kid = cLISTOPo->op_first;
6198     if (kid->op_sibling) {
6199         kid = kid->op_sibling;
6200         if (!kid->op_sibling)
6201             kid->op_sibling = newDEFSVOP();
6202     }
6203     return ck_fun(o);
6204 }
6205
6206 OP *
6207 Perl_ck_substr(pTHX_ OP *o)
6208 {
6209     o = ck_fun(o);
6210     if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6211         OP *kid = cLISTOPo->op_first;
6212
6213         if (kid->op_type == OP_NULL)
6214             kid = kid->op_sibling;
6215         if (kid)
6216             kid->op_flags |= OPf_MOD;
6217
6218     }
6219     return o;
6220 }
6221
6222 /* A peephole optimizer.  We visit the ops in the order they're to execute. */
6223
6224 void
6225 Perl_peep(pTHX_ register OP *o)
6226 {
6227     register OP* oldop = 0;
6228
6229     if (!o || o->op_seq)
6230         return;
6231     ENTER;
6232     SAVEOP();
6233     SAVEVPTR(PL_curcop);
6234     for (; o; o = o->op_next) {
6235         if (o->op_seq)
6236             break;
6237         /* The special value -1 is used by the B::C compiler backend to indicate
6238          * that an op is statically defined and should not be freed */
6239         if (!PL_op_seqmax || PL_op_seqmax == (U16)-1)
6240             PL_op_seqmax = 1;
6241         PL_op = o;
6242         switch (o->op_type) {
6243         case OP_SETSTATE:
6244         case OP_NEXTSTATE:
6245         case OP_DBSTATE:
6246             PL_curcop = ((COP*)o);              /* for warnings */
6247             o->op_seq = PL_op_seqmax++;
6248             break;
6249
6250         case OP_CONST:
6251             if (cSVOPo->op_private & OPpCONST_STRICT)
6252                 no_bareword_allowed(o);
6253 #ifdef USE_ITHREADS
6254         case OP_METHOD_NAMED:
6255             /* Relocate sv to the pad for thread safety.
6256              * Despite being a "constant", the SV is written to,
6257              * for reference counts, sv_upgrade() etc. */
6258             if (cSVOP->op_sv) {
6259                 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6260                 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
6261                     /* If op_sv is already a PADTMP then it is being used by
6262                      * some pad, so make a copy. */
6263                     sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
6264                     SvREADONLY_on(PAD_SVl(ix));
6265                     SvREFCNT_dec(cSVOPo->op_sv);
6266                 }
6267                 else {
6268                     SvREFCNT_dec(PAD_SVl(ix));
6269                     SvPADTMP_on(cSVOPo->op_sv);
6270                     PAD_SETSV(ix, cSVOPo->op_sv);
6271                     /* XXX I don't know how this isn't readonly already. */
6272                     SvREADONLY_on(PAD_SVl(ix));
6273                 }
6274                 cSVOPo->op_sv = Nullsv;
6275                 o->op_targ = ix;
6276             }
6277 #endif
6278             o->op_seq = PL_op_seqmax++;
6279             break;
6280
6281         case OP_CONCAT:
6282             if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6283                 if (o->op_next->op_private & OPpTARGET_MY) {
6284                     if (o->op_flags & OPf_STACKED) /* chained concats */
6285                         goto ignore_optimization;
6286                     else {
6287                         /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6288                         o->op_targ = o->op_next->op_targ;
6289                         o->op_next->op_targ = 0;
6290                         o->op_private |= OPpTARGET_MY;
6291                     }
6292                 }
6293                 op_null(o->op_next);
6294             }
6295           ignore_optimization:
6296             o->op_seq = PL_op_seqmax++;
6297             break;
6298         case OP_STUB:
6299             if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6300                 o->op_seq = PL_op_seqmax++;
6301                 break; /* Scalar stub must produce undef.  List stub is noop */
6302             }
6303             goto nothin;
6304         case OP_NULL:
6305             if (o->op_targ == OP_NEXTSTATE
6306                 || o->op_targ == OP_DBSTATE
6307                 || o->op_targ == OP_SETSTATE)
6308             {
6309                 PL_curcop = ((COP*)o);
6310             }
6311             /* XXX: We avoid setting op_seq here to prevent later calls
6312                to peep() from mistakenly concluding that optimisation
6313                has already occurred. This doesn't fix the real problem,
6314                though (See 20010220.007). AMS 20010719 */
6315             if (oldop && o->op_next) {
6316                 oldop->op_next = o->op_next;
6317                 continue;
6318             }
6319             break;
6320         case OP_SCALAR:
6321         case OP_LINESEQ:
6322         case OP_SCOPE:
6323           nothin:
6324             if (oldop && o->op_next) {
6325                 oldop->op_next = o->op_next;
6326                 continue;
6327             }
6328             o->op_seq = PL_op_seqmax++;
6329             break;
6330
6331         case OP_GV:
6332             if (o->op_next->op_type == OP_RV2SV) {
6333                 if (!(o->op_next->op_private & OPpDEREF)) {
6334                     op_null(o->op_next);
6335                     o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6336                                                                | OPpOUR_INTRO);
6337                     o->op_next = o->op_next->op_next;
6338                     o->op_type = OP_GVSV;
6339                     o->op_ppaddr = PL_ppaddr[OP_GVSV];
6340                 }
6341             }
6342             else if (o->op_next->op_type == OP_RV2AV) {
6343                 OP* pop = o->op_next->op_next;
6344                 IV i;
6345                 if (pop && pop->op_type == OP_CONST &&
6346                     (PL_op = pop->op_next) &&
6347                     pop->op_next->op_type == OP_AELEM &&
6348                     !(pop->op_next->op_private &
6349                       (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6350                     (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
6351                                 <= 255 &&
6352                     i >= 0)
6353                 {
6354                     GV *gv;
6355                     op_null(o->op_next);
6356                     op_null(pop->op_next);
6357                     op_null(pop);
6358                     o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6359                     o->op_next = pop->op_next->op_next;
6360                     o->op_type = OP_AELEMFAST;
6361                     o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6362                     o->op_private = (U8)i;
6363                     gv = cGVOPo_gv;
6364                     GvAVn(gv);
6365                 }
6366             }
6367             else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6368                 GV *gv = cGVOPo_gv;
6369                 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
6370                     /* XXX could check prototype here instead of just carping */
6371                     SV *sv = sv_newmortal();
6372                     gv_efullname3(sv, gv, Nullch);
6373                     Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
6374                                 "%"SVf"() called too early to check prototype",
6375                                 sv);
6376                 }
6377             }
6378             else if (o->op_next->op_type == OP_READLINE
6379                     && o->op_next->op_next->op_type == OP_CONCAT
6380                     && (o->op_next->op_next->op_flags & OPf_STACKED))
6381             {
6382                 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
6383                 o->op_type   = OP_RCATLINE;
6384                 o->op_flags |= OPf_STACKED;
6385                 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
6386                 op_null(o->op_next->op_next);
6387                 op_null(o->op_next);
6388             }
6389
6390             o->op_seq = PL_op_seqmax++;
6391             break;
6392
6393         case OP_MAPWHILE:
6394         case OP_GREPWHILE:
6395         case OP_AND:
6396         case OP_OR:
6397         case OP_DOR:
6398         case OP_ANDASSIGN:
6399         case OP_ORASSIGN:
6400         case OP_DORASSIGN:
6401         case OP_COND_EXPR:
6402         case OP_RANGE:
6403             o->op_seq = PL_op_seqmax++;
6404             while (cLOGOP->op_other->op_type == OP_NULL)
6405                 cLOGOP->op_other = cLOGOP->op_other->op_next;
6406             peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
6407             break;
6408
6409         case OP_ENTERLOOP:
6410         case OP_ENTERITER:
6411             o->op_seq = PL_op_seqmax++;
6412             while (cLOOP->op_redoop->op_type == OP_NULL)
6413                 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6414             peep(cLOOP->op_redoop);
6415             while (cLOOP->op_nextop->op_type == OP_NULL)
6416                 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6417             peep(cLOOP->op_nextop);
6418             while (cLOOP->op_lastop->op_type == OP_NULL)
6419                 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6420             peep(cLOOP->op_lastop);
6421             break;
6422
6423         case OP_QR:
6424         case OP_MATCH:
6425         case OP_SUBST:
6426             o->op_seq = PL_op_seqmax++;
6427             while (cPMOP->op_pmreplstart &&
6428                    cPMOP->op_pmreplstart->op_type == OP_NULL)
6429                 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6430             peep(cPMOP->op_pmreplstart);
6431             break;
6432
6433         case OP_EXEC:
6434             o->op_seq = PL_op_seqmax++;
6435             if (ckWARN(WARN_SYNTAX) && o->op_next
6436                 && o->op_next->op_type == OP_NEXTSTATE) {
6437                 if (o->op_next->op_sibling &&
6438                         o->op_next->op_sibling->op_type != OP_EXIT &&
6439                         o->op_next->op_sibling->op_type != OP_WARN &&
6440                         o->op_next->op_sibling->op_type != OP_DIE) {
6441                     line_t oldline = CopLINE(PL_curcop);
6442
6443                     CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6444                     Perl_warner(aTHX_ packWARN(WARN_EXEC),
6445                                 "Statement unlikely to be reached");
6446                     Perl_warner(aTHX_ packWARN(WARN_EXEC),
6447                                 "\t(Maybe you meant system() when you said exec()?)\n");
6448                     CopLINE_set(PL_curcop, oldline);
6449                 }
6450             }
6451             break;
6452
6453         case OP_HELEM: {
6454             SV *lexname;
6455             SV **svp, *sv;
6456             char *key = NULL;
6457             STRLEN keylen;
6458
6459             o->op_seq = PL_op_seqmax++;
6460
6461             if (((BINOP*)o)->op_last->op_type != OP_CONST)
6462                 break;
6463
6464             /* Make the CONST have a shared SV */
6465             svp = cSVOPx_svp(((BINOP*)o)->op_last);
6466             if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
6467                 key = SvPV(sv, keylen);
6468                 lexname = newSVpvn_share(key,
6469                                          SvUTF8(sv) ? -(I32)keylen : keylen,
6470                                          0);
6471                 SvREFCNT_dec(sv);
6472                 *svp = lexname;
6473             }
6474             break;
6475         }
6476
6477         default:
6478             o->op_seq = PL_op_seqmax++;
6479             break;
6480         }
6481         oldop = o;
6482     }
6483     LEAVE;
6484 }
6485
6486
6487
6488 char* Perl_custom_op_name(pTHX_ OP* o)
6489 {
6490     IV  index = PTR2IV(o->op_ppaddr);
6491     SV* keysv;
6492     HE* he;
6493
6494     if (!PL_custom_op_names) /* This probably shouldn't happen */
6495         return PL_op_name[OP_CUSTOM];
6496
6497     keysv = sv_2mortal(newSViv(index));
6498
6499     he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
6500     if (!he)
6501         return PL_op_name[OP_CUSTOM]; /* Don't know who you are */
6502
6503     return SvPV_nolen(HeVAL(he));
6504 }
6505
6506 char* Perl_custom_op_desc(pTHX_ OP* o)
6507 {
6508     IV  index = PTR2IV(o->op_ppaddr);
6509     SV* keysv;
6510     HE* he;
6511
6512     if (!PL_custom_op_descs)
6513         return PL_op_desc[OP_CUSTOM];
6514
6515     keysv = sv_2mortal(newSViv(index));
6516
6517     he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
6518     if (!he)
6519         return PL_op_desc[OP_CUSTOM];
6520
6521     return SvPV_nolen(HeVAL(he));
6522 }
6523
6524
6525 #include "XSUB.h"
6526
6527 /* Efficient sub that returns a constant scalar value. */
6528 static void
6529 const_sv_xsub(pTHX_ CV* cv)
6530 {
6531     dXSARGS;
6532     if (items != 0) {
6533 #if 0
6534         Perl_croak(aTHX_ "usage: %s::%s()",
6535                    HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
6536 #endif
6537     }
6538     EXTEND(sp, 1);
6539     ST(0) = (SV*)XSANY.any_ptr;
6540     XSRETURN(1);
6541 }