op.c

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