op.c

   1 /*    op.c
   2  *
   3  *    Copyright (c) 1991-2002, Larry Wall
   4  *
   5  *    You may distribute under the terms of either the GNU General Public
   6  *    License or the Artistic License, as specified in the README file.
   7  *
   8  */
   9
  10 /*
  11  * "You see: Mr. Drogo, he married poor Miss Primula Brandybuck.  She was
  12  * our Mr. Bilbo's first cousin on the mother's side (her mother being the
  13  * youngest of the Old Took's daughters); and Mr. Drogo was his second
  14  * cousin.  So Mr. Frodo is his first *and* second cousin, once removed
  15  * either way, as the saying is, if you follow me."  --the Gaffer
  16  */
  17
  18
  19 #include "EXTERN.h"
  20 #define PERL_IN_OP_C
  21 #include "perl.h"
  22 #include "keywords.h"
  23
  24 #define CALL_PEEP(o) CALL_FPTR(PL_peepp)(aTHX_ o)
  25
  26 #if defined(PL_OP_SLAB_ALLOC)
  27
  28 #ifndef PERL_SLAB_SIZE
  29 #define PERL_SLAB_SIZE 2048
  30 #endif
  31
  32 #define NewOp(m,var,c,type) \
  33         STMT_START { var = (type *) Slab_Alloc(m,c*sizeof(type)); } STMT_END
  34
  35 #define FreeOp(p) Slab_Free(p)
  36
  37 STATIC void *
  38 S_Slab_Alloc(pTHX_ int m, size_t sz)
  39 {
  40     /*
  41      * To make incrementing use count easy PL_OpSlab is an I32 *
  42      * To make inserting the link to slab PL_OpPtr is I32 **
  43      * So compute size in units of sizeof(I32 *) as that is how Pl_OpPtr increments
  44      * Add an overhead for pointer to slab and round up as a number of pointers
  45      */
  46     sz = (sz + 2*sizeof(I32 *) -1)/sizeof(I32 *);
  47     if ((PL_OpSpace -= sz) < 0) {
  48         PL_OpPtr = (I32 **) PerlMemShared_malloc(PERL_SLAB_SIZE*sizeof(I32*));
  49         if (!PL_OpPtr) {
  50             return NULL;
  51         }
  52         Zero(PL_OpPtr,PERL_SLAB_SIZE,I32 **);
  53         /* We reserve the 0'th I32 sized chunk as a use count */
  54         PL_OpSlab = (I32 *) PL_OpPtr;
  55         /* Reduce size by the use count word, and by the size we need.
  56          * Latter is to mimic the '-=' in the if() above
  57          */
  58         PL_OpSpace = PERL_SLAB_SIZE - (sizeof(I32)+sizeof(I32 **)-1)/sizeof(I32 **) - sz;
  59         /* Allocation pointer starts at the top.
  60            Theory: because we build leaves before trunk allocating at end
  61            means that at run time access is cache friendly upward
  62          */
  63         PL_OpPtr += PERL_SLAB_SIZE;
  64     }
  65     assert( PL_OpSpace >= 0 );
  66     /* Move the allocation pointer down */
  67     PL_OpPtr   -= sz;
  68     assert( PL_OpPtr > (I32 **) PL_OpSlab );
  69     *PL_OpPtr   = PL_OpSlab;    /* Note which slab it belongs to */
  70     (*PL_OpSlab)++;             /* Increment use count of slab */
  71     assert( PL_OpPtr+sz <= ((I32 **) PL_OpSlab + PERL_SLAB_SIZE) );
  72     assert( *PL_OpSlab > 0 );
  73     return (void *)(PL_OpPtr + 1);
  74 }
  75
  76 STATIC void
  77 S_Slab_Free(pTHX_ void *op)
  78 {
  79     I32 **ptr = (I32 **) op;
  80     I32 *slab = ptr[-1];
  81     assert( ptr-1 > (I32 **) slab );
  82     assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
  83     assert( *slab > 0 );
  84     if (--(*slab) == 0) {
  85      #ifdef NETWARE
  86       #define PerlMemShared PerlMem
  87      #endif
  88
  89     PerlMemShared_free(slab);
  90         if (slab == PL_OpSlab) {
  91             PL_OpSpace = 0;
  92         }
  93     }
  94 }
  95
  96 #else
  97 #define NewOp(m, var, c, type) Newz(m, var, c, type)
  98 #define FreeOp(p) Safefree(p)
  99 #endif
 100 /*
 101  * In the following definition, the ", Nullop" is just to make the compiler
 102  * think the expression is of the right type: croak actually does a Siglongjmp.
 103  */
 104 #define CHECKOP(type,o) \
 105     ((PL_op_mask && PL_op_mask[type])                                   \
 106      ? ( op_free((OP*)o),                                       \
 107          Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]),  \
 108          Nullop )                                               \
 109      : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o))
 110
 111 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
 112
 113 STATIC char*
 114 S_gv_ename(pTHX_ GV *gv)
 115 {
 116     STRLEN n_a;
 117     SV* tmpsv = sv_newmortal();
 118     gv_efullname3(tmpsv, gv, Nullch);
 119     return SvPV(tmpsv,n_a);
 120 }
 121
 122 STATIC OP *
 123 S_no_fh_allowed(pTHX_ OP *o)
 124 {
 125     yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
 126                  OP_DESC(o)));
 127     return o;
 128 }
 129
 130 STATIC OP *
 131 S_too_few_arguments(pTHX_ OP *o, char *name)
 132 {
 133     yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
 134     return o;
 135 }
 136
 137 STATIC OP *
 138 S_too_many_arguments(pTHX_ OP *o, char *name)
 139 {
 140     yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
 141     return o;
 142 }
 143
 144 STATIC void
 145 S_bad_type(pTHX_ I32 n, char *t, char *name, OP *kid)
 146 {
 147     yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
 148                  (int)n, name, t, OP_DESC(kid)));
 149 }
 150
 151 STATIC void
 152 S_no_bareword_allowed(pTHX_ OP *o)
 153 {
 154     qerror(Perl_mess(aTHX_
 155                      "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
 156                      cSVOPo_sv));
 157 }
 158
 159 /* "register" allocation */
 160
 161 PADOFFSET
 162 Perl_allocmy(pTHX_ char *name)
 163 {
 164     PADOFFSET off;
 165
 166     /* complain about "my $_" etc etc */
 167     if (!(PL_in_my == KEY_our ||
 168           isALPHA(name[1]) ||
 169           (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
 170           (name[1] == '_' && (int)strlen(name) > 2)))
 171     {
 172         if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
 173             /* 1999-02-27 mjd@plover.com */
 174             char *p;
 175             p = strchr(name, '\0');
 176             /* The next block assumes the buffer is at least 205 chars
 177                long.  At present, it's always at least 256 chars. */
 178             if (p-name > 200) {
 179                 strcpy(name+200, "...");
 180                 p = name+199;
 181             }
 182             else {
 183                 p[1] = '\0';
 184             }
 185             /* Move everything else down one character */
 186             for (; p-name > 2; p--)
 187                 *p = *(p-1);
 188             name[2] = toCTRL(name[1]);
 189             name[1] = '^';
 190         }
 191         yyerror(Perl_form(aTHX_ "Can't use global %s in \"my\"",name));
 192     }
 193
 194     /* check for duplicate declaration */
 195     pad_check_dup(name,
 196                 PL_in_my == KEY_our,
 197                 (PL_curstash ? PL_curstash : PL_defstash)
 198     );
 199
 200     if (PL_in_my_stash && *name != '$') {
 201         yyerror(Perl_form(aTHX_
 202                     "Can't declare class for non-scalar %s in \"%s\"",
 203                      name, PL_in_my == KEY_our ? "our" : "my"));
 204     }
 205
 206     /* allocate a spare slot and store the name in that slot */
 207
 208     off = pad_add_name(name,
 209                     PL_in_my_stash,
 210                     (PL_in_my == KEY_our
 211                         ? (PL_curstash ? PL_curstash : PL_defstash)
 212                         : Nullhv
 213                     ),
 214                     0 /*  not fake */
 215     );
 216     return off;
 217 }
 218
 219 /* Destructor */
 220
 221 void
 222 Perl_op_free(pTHX_ OP *o)
 223 {
 224     register OP *kid, *nextkid;
 225     OPCODE type;
 226
 227     if (!o || o->op_seq == (U16)-1)
 228         return;
 229
 230     if (o->op_private & OPpREFCOUNTED) {
 231         switch (o->op_type) {
 232         case OP_LEAVESUB:
 233         case OP_LEAVESUBLV:
 234         case OP_LEAVEEVAL:
 235         case OP_LEAVE:
 236         case OP_SCOPE:
 237         case OP_LEAVEWRITE:
 238             OP_REFCNT_LOCK;
 239             if (OpREFCNT_dec(o)) {
 240                 OP_REFCNT_UNLOCK;
 241                 return;
 242             }
 243             OP_REFCNT_UNLOCK;
 244             break;
 245         default:
 246             break;
 247         }
 248     }
 249
 250     if (o->op_flags & OPf_KIDS) {
 251         for (kid = cUNOPo->op_first; kid; kid = nextkid) {
 252             nextkid = kid->op_sibling; /* Get before next freeing kid */
 253             op_free(kid);
 254         }
 255     }
 256     type = o->op_type;
 257     if (type == OP_NULL)
 258         type = (OPCODE)o->op_targ;
 259
 260     /* COP* is not cleared by op_clear() so that we may track line
 261      * numbers etc even after null() */
 262     if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE)
 263         cop_free((COP*)o);
 264
 265     op_clear(o);
 266     FreeOp(o);
 267 }
 268
 269 void
 270 Perl_op_clear(pTHX_ OP *o)
 271 {
 272
 273     switch (o->op_type) {
 274     case OP_NULL:       /* Was holding old type, if any. */
 275     case OP_ENTEREVAL:  /* Was holding hints. */
 276         o->op_targ = 0;
 277         break;
 278     default:
 279         if (!(o->op_flags & OPf_REF)
 280             || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
 281             break;
 282         /* FALL THROUGH */
 283     case OP_GVSV:
 284     case OP_GV:
 285     case OP_AELEMFAST:
 286 #ifdef USE_ITHREADS
 287         if (cPADOPo->op_padix > 0) {
 288             /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
 289              * may still exist on the pad */
 290             pad_swipe(cPADOPo->op_padix, TRUE);
 291             cPADOPo->op_padix = 0;
 292         }
 293 #else
 294         SvREFCNT_dec(cSVOPo->op_sv);
 295         cSVOPo->op_sv = Nullsv;
 296 #endif
 297         break;
 298     case OP_METHOD_NAMED:
 299     case OP_CONST:
 300         SvREFCNT_dec(cSVOPo->op_sv);
 301         cSVOPo->op_sv = Nullsv;
 302         break;
 303     case OP_GOTO:
 304     case OP_NEXT:
 305     case OP_LAST:
 306     case OP_REDO:
 307         if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
 308             break;
 309         /* FALL THROUGH */
 310     case OP_TRANS:
 311         if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
 312             SvREFCNT_dec(cSVOPo->op_sv);
 313             cSVOPo->op_sv = Nullsv;
 314         }
 315         else {
 316             Safefree(cPVOPo->op_pv);
 317             cPVOPo->op_pv = Nullch;
 318         }
 319         break;
 320     case OP_SUBST:
 321         op_free(cPMOPo->op_pmreplroot);
 322         goto clear_pmop;
 323     case OP_PUSHRE:
 324 #ifdef USE_ITHREADS
 325         if (INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)) {
 326             /* No GvIN_PAD_off here, because other references may still
 327              * exist on the pad */
 328             pad_swipe(INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot), TRUE);
 329         }
 330 #else
 331         SvREFCNT_dec((SV*)cPMOPo->op_pmreplroot);
 332 #endif
 333         /* FALL THROUGH */
 334     case OP_MATCH:
 335     case OP_QR:
 336 clear_pmop:
 337         {
 338             HV *pmstash = PmopSTASH(cPMOPo);
 339             if (pmstash && SvREFCNT(pmstash)) {
 340                 PMOP *pmop = HvPMROOT(pmstash);
 341                 PMOP *lastpmop = NULL;
 342                 while (pmop) {
 343                     if (cPMOPo == pmop) {
 344                         if (lastpmop)
 345                             lastpmop->op_pmnext = pmop->op_pmnext;
 346                         else
 347                             HvPMROOT(pmstash) = pmop->op_pmnext;
 348                         break;
 349                     }
 350                     lastpmop = pmop;
 351                     pmop = pmop->op_pmnext;
 352                 }
 353             }
 354             PmopSTASH_free(cPMOPo);
 355         }
 356         cPMOPo->op_pmreplroot = Nullop;
 357         /* we use the "SAFE" version of the PM_ macros here
 358          * since sv_clean_all might release some PMOPs
 359          * after PL_regex_padav has been cleared
 360          * and the clearing of PL_regex_padav needs to
 361          * happen before sv_clean_all
 362          */
 363         ReREFCNT_dec(PM_GETRE_SAFE(cPMOPo));
 364         PM_SETRE_SAFE(cPMOPo, (REGEXP*)NULL);
 365 #ifdef USE_ITHREADS
 366         if(PL_regex_pad) {        /* We could be in destruction */
 367             av_push((AV*) PL_regex_pad[0],(SV*) PL_regex_pad[(cPMOPo)->op_pmoffset]);
 368             SvREPADTMP_on(PL_regex_pad[(cPMOPo)->op_pmoffset]);
 369             PM_SETRE(cPMOPo, (cPMOPo)->op_pmoffset);
 370         }
 371 #endif
 372
 373         break;
 374     }
 375
 376     if (o->op_targ > 0) {
 377         pad_free(o->op_targ);
 378         o->op_targ = 0;
 379     }
 380 }
 381
 382 STATIC void
 383 S_cop_free(pTHX_ COP* cop)
 384 {
 385     Safefree(cop->cop_label);   /* FIXME: treaddead ??? */
 386     CopFILE_free(cop);
 387     CopSTASH_free(cop);
 388     if (! specialWARN(cop->cop_warnings))
 389         SvREFCNT_dec(cop->cop_warnings);
 390     if (! specialCopIO(cop->cop_io)) {
 391 #ifdef USE_ITHREADS
 392 #if 0
 393         STRLEN len;
 394         char *s = SvPV(cop->cop_io,len);
 395         Perl_warn(aTHX_ "io='%.*s'",(int) len,s); /* ??? --jhi */
 396 #endif
 397 #else
 398         SvREFCNT_dec(cop->cop_io);
 399 #endif
 400     }
 401 }
 402
 403 void
 404 Perl_op_null(pTHX_ OP *o)
 405 {
 406     if (o->op_type == OP_NULL)
 407         return;
 408     op_clear(o);
 409     o->op_targ = o->op_type;
 410     o->op_type = OP_NULL;
 411     o->op_ppaddr = PL_ppaddr[OP_NULL];
 412 }
 413
 414 /* Contextualizers */
 415
 416 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
 417
 418 OP *
 419 Perl_linklist(pTHX_ OP *o)
 420 {
 421     register OP *kid;
 422
 423     if (o->op_next)
 424         return o->op_next;
 425
 426     /* establish postfix order */
 427     if (cUNOPo->op_first) {
 428         o->op_next = LINKLIST(cUNOPo->op_first);
 429         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
 430             if (kid->op_sibling)
 431                 kid->op_next = LINKLIST(kid->op_sibling);
 432             else
 433                 kid->op_next = o;
 434         }
 435     }
 436     else
 437         o->op_next = o;
 438
 439     return o->op_next;
 440 }
 441
 442 OP *
 443 Perl_scalarkids(pTHX_ OP *o)
 444 {
 445     OP *kid;
 446     if (o && o->op_flags & OPf_KIDS) {
 447         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
 448             scalar(kid);
 449     }
 450     return o;
 451 }
 452
 453 STATIC OP *
 454 S_scalarboolean(pTHX_ OP *o)
 455 {
 456     if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
 457         if (ckWARN(WARN_SYNTAX)) {
 458             line_t oldline = CopLINE(PL_curcop);
 459
 460             if (PL_copline != NOLINE)
 461                 CopLINE_set(PL_curcop, PL_copline);
 462             Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
 463             CopLINE_set(PL_curcop, oldline);
 464         }
 465     }
 466     return scalar(o);
 467 }
 468
 469 OP *
 470 Perl_scalar(pTHX_ OP *o)
 471 {
 472     OP *kid;
 473
 474     /* assumes no premature commitment */
 475     if (!o || (o->op_flags & OPf_WANT) || PL_error_count
 476          || o->op_type == OP_RETURN)
 477     {
 478         return o;
 479     }
 480
 481     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
 482
 483     switch (o->op_type) {
 484     case OP_REPEAT:
 485         scalar(cBINOPo->op_first);
 486         break;
 487     case OP_OR:
 488     case OP_AND:
 489     case OP_COND_EXPR:
 490         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
 491             scalar(kid);
 492         break;
 493     case OP_SPLIT:
 494         if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
 495             if (!kPMOP->op_pmreplroot)
 496                 deprecate_old("implicit split to @_");
 497         }
 498         /* FALL THROUGH */
 499     case OP_MATCH:
 500     case OP_QR:
 501     case OP_SUBST:
 502     case OP_NULL:
 503     default:
 504         if (o->op_flags & OPf_KIDS) {
 505             for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
 506                 scalar(kid);
 507         }
 508         break;
 509     case OP_LEAVE:
 510     case OP_LEAVETRY:
 511         kid = cLISTOPo->op_first;
 512         scalar(kid);
 513         while ((kid = kid->op_sibling)) {
 514             if (kid->op_sibling)
 515                 scalarvoid(kid);
 516             else
 517                 scalar(kid);
 518         }
 519         WITH_THR(PL_curcop = &PL_compiling);
 520         break;
 521     case OP_SCOPE:
 522     case OP_LINESEQ:
 523     case OP_LIST:
 524         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
 525             if (kid->op_sibling)
 526                 scalarvoid(kid);
 527             else
 528                 scalar(kid);
 529         }
 530         WITH_THR(PL_curcop = &PL_compiling);
 531         break;
 532     case OP_SORT:
 533         if (ckWARN(WARN_VOID))
 534             Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
 535     }
 536     return o;
 537 }
 538
 539 OP *
 540 Perl_scalarvoid(pTHX_ OP *o)
 541 {
 542     OP *kid;
 543     char* useless = 0;
 544     SV* sv;
 545     U8 want;
 546
 547     if (o->op_type == OP_NEXTSTATE
 548         || o->op_type == OP_SETSTATE
 549         || o->op_type == OP_DBSTATE
 550         || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
 551                                       || o->op_targ == OP_SETSTATE
 552                                       || o->op_targ == OP_DBSTATE)))
 553         PL_curcop = (COP*)o;            /* for warning below */
 554
 555     /* assumes no premature commitment */
 556     want = o->op_flags & OPf_WANT;
 557     if ((want && want != OPf_WANT_SCALAR) || PL_error_count
 558          || o->op_type == OP_RETURN)
 559     {
 560         return o;
 561     }
 562
 563     if ((o->op_private & OPpTARGET_MY)
 564         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
 565     {
 566         return scalar(o);                       /* As if inside SASSIGN */
 567     }
 568
 569     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
 570
 571     switch (o->op_type) {
 572     default:
 573         if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
 574             break;
 575         /* FALL THROUGH */
 576     case OP_REPEAT:
 577         if (o->op_flags & OPf_STACKED)
 578             break;
 579         goto func_ops;
 580     case OP_SUBSTR:
 581         if (o->op_private == 4)
 582             break;
 583         /* FALL THROUGH */
 584     case OP_GVSV:
 585     case OP_WANTARRAY:
 586     case OP_GV:
 587     case OP_PADSV:
 588     case OP_PADAV:
 589     case OP_PADHV:
 590     case OP_PADANY:
 591     case OP_AV2ARYLEN:
 592     case OP_REF:
 593     case OP_REFGEN:
 594     case OP_SREFGEN:
 595     case OP_DEFINED:
 596     case OP_HEX:
 597     case OP_OCT:
 598     case OP_LENGTH:
 599     case OP_VEC:
 600     case OP_INDEX:
 601     case OP_RINDEX:
 602     case OP_SPRINTF:
 603     case OP_AELEM:
 604     case OP_AELEMFAST:
 605     case OP_ASLICE:
 606     case OP_HELEM:
 607     case OP_HSLICE:
 608     case OP_UNPACK:
 609     case OP_PACK:
 610     case OP_JOIN:
 611     case OP_LSLICE:
 612     case OP_ANONLIST:
 613     case OP_ANONHASH:
 614     case OP_SORT:
 615     case OP_REVERSE:
 616     case OP_RANGE:
 617     case OP_FLIP:
 618     case OP_FLOP:
 619     case OP_CALLER:
 620     case OP_FILENO:
 621     case OP_EOF:
 622     case OP_TELL:
 623     case OP_GETSOCKNAME:
 624     case OP_GETPEERNAME:
 625     case OP_READLINK:
 626     case OP_TELLDIR:
 627     case OP_GETPPID:
 628     case OP_GETPGRP:
 629     case OP_GETPRIORITY:
 630     case OP_TIME:
 631     case OP_TMS:
 632     case OP_LOCALTIME:
 633     case OP_GMTIME:
 634     case OP_GHBYNAME:
 635     case OP_GHBYADDR:
 636     case OP_GHOSTENT:
 637     case OP_GNBYNAME:
 638     case OP_GNBYADDR:
 639     case OP_GNETENT:
 640     case OP_GPBYNAME:
 641     case OP_GPBYNUMBER:
 642     case OP_GPROTOENT:
 643     case OP_GSBYNAME:
 644     case OP_GSBYPORT:
 645     case OP_GSERVENT:
 646     case OP_GPWNAM:
 647     case OP_GPWUID:
 648     case OP_GGRNAM:
 649     case OP_GGRGID:
 650     case OP_GETLOGIN:
 651     case OP_PROTOTYPE:
 652       func_ops:
 653         if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
 654             useless = OP_DESC(o);
 655         break;
 656
 657     case OP_RV2GV:
 658     case OP_RV2SV:
 659     case OP_RV2AV:
 660     case OP_RV2HV:
 661         if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
 662                 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
 663             useless = "a variable";
 664         break;
 665
 666     case OP_CONST:
 667         sv = cSVOPo_sv;
 668         if (cSVOPo->op_private & OPpCONST_STRICT)
 669             no_bareword_allowed(o);
 670         else {
 671             if (ckWARN(WARN_VOID)) {
 672                 useless = "a constant";
 673                 /* the constants 0 and 1 are permitted as they are
 674                    conventionally used as dummies in constructs like
 675                         1 while some_condition_with_side_effects;  */
 676                 if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
 677                     useless = 0;
 678                 else if (SvPOK(sv)) {
 679                   /* perl4's way of mixing documentation and code
 680                      (before the invention of POD) was based on a
 681                      trick to mix nroff and perl code. The trick was
 682                      built upon these three nroff macros being used in
 683                      void context. The pink camel has the details in
 684                      the script wrapman near page 319. */
 685                     if (strnEQ(SvPVX(sv), "di", 2) ||
 686                         strnEQ(SvPVX(sv), "ds", 2) ||
 687                         strnEQ(SvPVX(sv), "ig", 2))
 688                             useless = 0;
 689                 }
 690             }
 691         }
 692         op_null(o);             /* don't execute or even remember it */
 693         break;
 694
 695     case OP_POSTINC:
 696         o->op_type = OP_PREINC;         /* pre-increment is faster */
 697         o->op_ppaddr = PL_ppaddr[OP_PREINC];
 698         break;
 699
 700     case OP_POSTDEC:
 701         o->op_type = OP_PREDEC;         /* pre-decrement is faster */
 702         o->op_ppaddr = PL_ppaddr[OP_PREDEC];
 703         break;
 704
 705     case OP_OR:
 706     case OP_AND:
 707     case OP_DOR:
 708     case OP_COND_EXPR:
 709         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
 710             scalarvoid(kid);
 711         break;
 712
 713     case OP_NULL:
 714         if (o->op_flags & OPf_STACKED)
 715             break;
 716         /* FALL THROUGH */
 717     case OP_NEXTSTATE:
 718     case OP_DBSTATE:
 719     case OP_ENTERTRY:
 720     case OP_ENTER:
 721         if (!(o->op_flags & OPf_KIDS))
 722             break;
 723         /* FALL THROUGH */
 724     case OP_SCOPE:
 725     case OP_LEAVE:
 726     case OP_LEAVETRY:
 727     case OP_LEAVELOOP:
 728     case OP_LINESEQ:
 729     case OP_LIST:
 730         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
 731             scalarvoid(kid);
 732         break;
 733     case OP_ENTEREVAL:
 734         scalarkids(o);
 735         break;
 736     case OP_REQUIRE:
 737         /* all requires must return a boolean value */
 738         o->op_flags &= ~OPf_WANT;
 739         /* FALL THROUGH */
 740     case OP_SCALAR:
 741         return scalar(o);
 742     case OP_SPLIT:
 743         if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
 744             if (!kPMOP->op_pmreplroot)
 745                 deprecate_old("implicit split to @_");
 746         }
 747         break;
 748     }
 749     if (useless && ckWARN(WARN_VOID))
 750         Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
 751     return o;
 752 }
 753
 754 OP *
 755 Perl_listkids(pTHX_ OP *o)
 756 {
 757     OP *kid;
 758     if (o && o->op_flags & OPf_KIDS) {
 759         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
 760             list(kid);
 761     }
 762     return o;
 763 }
 764
 765 OP *
 766 Perl_list(pTHX_ OP *o)
 767 {
 768     OP *kid;
 769
 770     /* assumes no premature commitment */
 771     if (!o || (o->op_flags & OPf_WANT) || PL_error_count
 772          || o->op_type == OP_RETURN)
 773     {
 774         return o;
 775     }
 776
 777     if ((o->op_private & OPpTARGET_MY)
 778         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
 779     {
 780         return o;                               /* As if inside SASSIGN */
 781     }
 782
 783     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
 784
 785     switch (o->op_type) {
 786     case OP_FLOP:
 787     case OP_REPEAT:
 788         list(cBINOPo->op_first);
 789         break;
 790     case OP_OR:
 791     case OP_AND:
 792     case OP_COND_EXPR:
 793         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
 794             list(kid);
 795         break;
 796     default:
 797     case OP_MATCH:
 798     case OP_QR:
 799     case OP_SUBST:
 800     case OP_NULL:
 801         if (!(o->op_flags & OPf_KIDS))
 802             break;
 803         if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
 804             list(cBINOPo->op_first);
 805             return gen_constant_list(o);
 806         }
 807     case OP_LIST:
 808         listkids(o);
 809         break;
 810     case OP_LEAVE:
 811     case OP_LEAVETRY:
 812         kid = cLISTOPo->op_first;
 813         list(kid);
 814         while ((kid = kid->op_sibling)) {
 815             if (kid->op_sibling)
 816                 scalarvoid(kid);
 817             else
 818                 list(kid);
 819         }
 820         WITH_THR(PL_curcop = &PL_compiling);
 821         break;
 822     case OP_SCOPE:
 823     case OP_LINESEQ:
 824         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
 825             if (kid->op_sibling)
 826                 scalarvoid(kid);
 827             else
 828                 list(kid);
 829         }
 830         WITH_THR(PL_curcop = &PL_compiling);
 831         break;
 832     case OP_REQUIRE:
 833         /* all requires must return a boolean value */
 834         o->op_flags &= ~OPf_WANT;
 835         return scalar(o);
 836     }
 837     return o;
 838 }
 839
 840 OP *
 841 Perl_scalarseq(pTHX_ OP *o)
 842 {
 843     OP *kid;
 844
 845     if (o) {
 846         if (o->op_type == OP_LINESEQ ||
 847              o->op_type == OP_SCOPE ||
 848              o->op_type == OP_LEAVE ||
 849              o->op_type == OP_LEAVETRY)
 850         {
 851             for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
 852                 if (kid->op_sibling) {
 853                     scalarvoid(kid);
 854                 }
 855             }
 856             PL_curcop = &PL_compiling;
 857         }
 858         o->op_flags &= ~OPf_PARENS;
 859         if (PL_hints & HINT_BLOCK_SCOPE)
 860             o->op_flags |= OPf_PARENS;
 861     }
 862     else
 863         o = newOP(OP_STUB, 0);
 864     return o;
 865 }
 866
 867 STATIC OP *
 868 S_modkids(pTHX_ OP *o, I32 type)
 869 {
 870     OP *kid;
 871     if (o && o->op_flags & OPf_KIDS) {
 872         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
 873             mod(kid, type);
 874     }
 875     return o;
 876 }
 877
 878 OP *
 879 Perl_mod(pTHX_ OP *o, I32 type)
 880 {
 881     OP *kid;
 882
 883     if (!o || PL_error_count)
 884         return o;
 885
 886     if ((o->op_private & OPpTARGET_MY)
 887         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
 888     {
 889         return o;
 890     }
 891
 892     switch (o->op_type) {
 893     case OP_UNDEF:
 894         PL_modcount++;
 895         return o;
 896     case OP_CONST:
 897         if (!(o->op_private & (OPpCONST_ARYBASE)))
 898             goto nomod;
 899         if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
 900             PL_compiling.cop_arybase = (I32)SvIV(cSVOPx(PL_eval_start)->op_sv);
 901             PL_eval_start = 0;
 902         }
 903         else if (!type) {
 904             SAVEI32(PL_compiling.cop_arybase);
 905             PL_compiling.cop_arybase = 0;
 906         }
 907         else if (type == OP_REFGEN)
 908             goto nomod;
 909         else
 910             Perl_croak(aTHX_ "That use of $[ is unsupported");
 911         break;
 912     case OP_STUB:
 913         if (o->op_flags & OPf_PARENS)
 914             break;
 915         goto nomod;
 916     case OP_ENTERSUB:
 917         if ((type == OP_UNDEF || type == OP_REFGEN) &&
 918             !(o->op_flags & OPf_STACKED)) {
 919             o->op_type = OP_RV2CV;              /* entersub => rv2cv */
 920             o->op_ppaddr = PL_ppaddr[OP_RV2CV];
 921             assert(cUNOPo->op_first->op_type == OP_NULL);
 922             op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
 923             break;
 924         }
 925         else if (o->op_private & OPpENTERSUB_NOMOD)
 926             return o;
 927         else {                          /* lvalue subroutine call */
 928             o->op_private |= OPpLVAL_INTRO;
 929             PL_modcount = RETURN_UNLIMITED_NUMBER;
 930             if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
 931                 /* Backward compatibility mode: */
 932                 o->op_private |= OPpENTERSUB_INARGS;
 933                 break;
 934             }
 935             else {                      /* Compile-time error message: */
 936                 OP *kid = cUNOPo->op_first;
 937                 CV *cv;
 938                 OP *okid;
 939
 940                 if (kid->op_type == OP_PUSHMARK)
 941                     goto skip_kids;
 942                 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
 943                     Perl_croak(aTHX_
 944                                "panic: unexpected lvalue entersub "
 945                                "args: type/targ %ld:%"UVuf,
 946                                (long)kid->op_type, (UV)kid->op_targ);
 947                 kid = kLISTOP->op_first;
 948               skip_kids:
 949                 while (kid->op_sibling)
 950                     kid = kid->op_sibling;
 951                 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
 952                     /* Indirect call */
 953                     if (kid->op_type == OP_METHOD_NAMED
 954                         || kid->op_type == OP_METHOD)
 955                     {
 956                         UNOP *newop;
 957
 958                         NewOp(1101, newop, 1, UNOP);
 959                         newop->op_type = OP_RV2CV;
 960                         newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
 961                         newop->op_first = Nullop;
 962                         newop->op_next = (OP*)newop;
 963                         kid->op_sibling = (OP*)newop;
 964                         newop->op_private |= OPpLVAL_INTRO;
 965                         break;
 966                     }
 967
 968                     if (kid->op_type != OP_RV2CV)
 969                         Perl_croak(aTHX_
 970                                    "panic: unexpected lvalue entersub "
 971                                    "entry via type/targ %ld:%"UVuf,
 972                                    (long)kid->op_type, (UV)kid->op_targ);
 973                     kid->op_private |= OPpLVAL_INTRO;
 974                     break;      /* Postpone until runtime */
 975                 }
 976
 977                 okid = kid;
 978                 kid = kUNOP->op_first;
 979                 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
 980                     kid = kUNOP->op_first;
 981                 if (kid->op_type == OP_NULL)
 982                     Perl_croak(aTHX_
 983                                "Unexpected constant lvalue entersub "
 984                                "entry via type/targ %ld:%"UVuf,
 985                                (long)kid->op_type, (UV)kid->op_targ);
 986                 if (kid->op_type != OP_GV) {
 987                     /* Restore RV2CV to check lvalueness */
 988                   restore_2cv:
 989                     if (kid->op_next && kid->op_next != kid) { /* Happens? */
 990                         okid->op_next = kid->op_next;
 991                         kid->op_next = okid;
 992                     }
 993                     else
 994                         okid->op_next = Nullop;
 995                     okid->op_type = OP_RV2CV;
 996                     okid->op_targ = 0;
 997                     okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
 998                     okid->op_private |= OPpLVAL_INTRO;
 999                     break;
1000                 }
1001
1002                 cv = GvCV(kGVOP_gv);
1003                 if (!cv)
1004                     goto restore_2cv;
1005                 if (CvLVALUE(cv))
1006                     break;
1007             }
1008         }
1009         /* FALL THROUGH */
1010     default:
1011       nomod:
1012         /* grep, foreach, subcalls, refgen */
1013         if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1014             break;
1015         yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1016                      (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1017                       ? "do block"
1018                       : (o->op_type == OP_ENTERSUB
1019                         ? "non-lvalue subroutine call"
1020                         : OP_DESC(o))),
1021                      type ? PL_op_desc[type] : "local"));
1022         return o;
1023
1024     case OP_PREINC:
1025     case OP_PREDEC:
1026     case OP_POW:
1027     case OP_MULTIPLY:
1028     case OP_DIVIDE:
1029     case OP_MODULO:
1030     case OP_REPEAT:
1031     case OP_ADD:
1032     case OP_SUBTRACT:
1033     case OP_CONCAT:
1034     case OP_LEFT_SHIFT:
1035     case OP_RIGHT_SHIFT:
1036     case OP_BIT_AND:
1037     case OP_BIT_XOR:
1038     case OP_BIT_OR:
1039     case OP_I_MULTIPLY:
1040     case OP_I_DIVIDE:
1041     case OP_I_MODULO:
1042     case OP_I_ADD:
1043     case OP_I_SUBTRACT:
1044         if (!(o->op_flags & OPf_STACKED))
1045             goto nomod;
1046         PL_modcount++;
1047         break;
1048
1049     case OP_COND_EXPR:
1050         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1051             mod(kid, type);
1052         break;
1053
1054     case OP_RV2AV:
1055     case OP_RV2HV:
1056         if (!type && cUNOPo->op_first->op_type != OP_GV)
1057             Perl_croak(aTHX_ "Can't localize through a reference");
1058         if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1059            PL_modcount = RETURN_UNLIMITED_NUMBER;
1060             return o;           /* Treat \(@foo) like ordinary list. */
1061         }
1062         /* FALL THROUGH */
1063     case OP_RV2GV:
1064         if (scalar_mod_type(o, type))
1065             goto nomod;
1066         ref(cUNOPo->op_first, o->op_type);
1067         /* FALL THROUGH */
1068     case OP_ASLICE:
1069     case OP_HSLICE:
1070         if (type == OP_LEAVESUBLV)
1071             o->op_private |= OPpMAYBE_LVSUB;
1072         /* FALL THROUGH */
1073     case OP_AASSIGN:
1074     case OP_NEXTSTATE:
1075     case OP_DBSTATE:
1076        PL_modcount = RETURN_UNLIMITED_NUMBER;
1077         break;
1078     case OP_RV2SV:
1079         if (!type && cUNOPo->op_first->op_type != OP_GV)
1080             Perl_croak(aTHX_ "Can't localize through a reference");
1081         ref(cUNOPo->op_first, o->op_type);
1082         /* FALL THROUGH */
1083     case OP_GV:
1084     case OP_AV2ARYLEN:
1085         PL_hints |= HINT_BLOCK_SCOPE;
1086     case OP_SASSIGN:
1087     case OP_ANDASSIGN:
1088     case OP_ORASSIGN:
1089     case OP_DORASSIGN:
1090     case OP_AELEMFAST:
1091         PL_modcount++;
1092         break;
1093
1094     case OP_PADAV:
1095     case OP_PADHV:
1096        PL_modcount = RETURN_UNLIMITED_NUMBER;
1097         if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1098             return o;           /* Treat \(@foo) like ordinary list. */
1099         if (scalar_mod_type(o, type))
1100             goto nomod;
1101         if (type == OP_LEAVESUBLV)
1102             o->op_private |= OPpMAYBE_LVSUB;
1103         /* FALL THROUGH */
1104     case OP_PADSV:
1105         PL_modcount++;
1106         if (!type)
1107         {   /* XXX DAPM 2002.08.25 tmp assert test */
1108             /* XXX */ assert(av_fetch(PL_comppad_name, (o->op_targ), FALSE));
1109             /* XXX */ assert(*av_fetch(PL_comppad_name, (o->op_targ), FALSE));
1110
1111             Perl_croak(aTHX_ "Can't localize lexical variable %s",
1112                  PAD_COMPNAME_PV(o->op_targ));
1113         }
1114         break;
1115
1116     case OP_PUSHMARK:
1117         break;
1118
1119     case OP_KEYS:
1120         if (type != OP_SASSIGN)
1121             goto nomod;
1122         goto lvalue_func;
1123     case OP_SUBSTR:
1124         if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1125             goto nomod;
1126         /* FALL THROUGH */
1127     case OP_POS:
1128     case OP_VEC:
1129         if (type == OP_LEAVESUBLV)
1130             o->op_private |= OPpMAYBE_LVSUB;
1131       lvalue_func:
1132         pad_free(o->op_targ);
1133         o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1134         assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1135         if (o->op_flags & OPf_KIDS)
1136             mod(cBINOPo->op_first->op_sibling, type);
1137         break;
1138
1139     case OP_AELEM:
1140     case OP_HELEM:
1141         ref(cBINOPo->op_first, o->op_type);
1142         if (type == OP_ENTERSUB &&
1143              !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1144             o->op_private |= OPpLVAL_DEFER;
1145         if (type == OP_LEAVESUBLV)
1146             o->op_private |= OPpMAYBE_LVSUB;
1147         PL_modcount++;
1148         break;
1149
1150     case OP_SCOPE:
1151     case OP_LEAVE:
1152     case OP_ENTER:
1153     case OP_LINESEQ:
1154         if (o->op_flags & OPf_KIDS)
1155             mod(cLISTOPo->op_last, type);
1156         break;
1157
1158     case OP_NULL:
1159         if (o->op_flags & OPf_SPECIAL)          /* do BLOCK */
1160             goto nomod;
1161         else if (!(o->op_flags & OPf_KIDS))
1162             break;
1163         if (o->op_targ != OP_LIST) {
1164             mod(cBINOPo->op_first, type);
1165             break;
1166         }
1167         /* FALL THROUGH */
1168     case OP_LIST:
1169         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1170             mod(kid, type);
1171         break;
1172
1173     case OP_RETURN:
1174         if (type != OP_LEAVESUBLV)
1175             goto nomod;
1176         break; /* mod()ing was handled by ck_return() */
1177     }
1178
1179     /* [20011101.069] File test operators interpret OPf_REF to mean that
1180        their argument is a filehandle; thus \stat(".") should not set
1181        it. AMS 20011102 */
1182     if (type == OP_REFGEN &&
1183         PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1184         return o;
1185
1186     if (type != OP_LEAVESUBLV)
1187         o->op_flags |= OPf_MOD;
1188
1189     if (type == OP_AASSIGN || type == OP_SASSIGN)
1190         o->op_flags |= OPf_SPECIAL|OPf_REF;
1191     else if (!type) {
1192         o->op_private |= OPpLVAL_INTRO;
1193         o->op_flags &= ~OPf_SPECIAL;
1194         PL_hints |= HINT_BLOCK_SCOPE;
1195     }
1196     else if (type != OP_GREPSTART && type != OP_ENTERSUB
1197              && type != OP_LEAVESUBLV)
1198         o->op_flags |= OPf_REF;
1199     return o;
1200 }
1201
1202 STATIC bool
1203 S_scalar_mod_type(pTHX_ OP *o, I32 type)
1204 {
1205     switch (type) {
1206     case OP_SASSIGN:
1207         if (o->op_type == OP_RV2GV)
1208             return FALSE;
1209         /* FALL THROUGH */
1210     case OP_PREINC:
1211     case OP_PREDEC:
1212     case OP_POSTINC:
1213     case OP_POSTDEC:
1214     case OP_I_PREINC:
1215     case OP_I_PREDEC:
1216     case OP_I_POSTINC:
1217     case OP_I_POSTDEC:
1218     case OP_POW:
1219     case OP_MULTIPLY:
1220     case OP_DIVIDE:
1221     case OP_MODULO:
1222     case OP_REPEAT:
1223     case OP_ADD:
1224     case OP_SUBTRACT:
1225     case OP_I_MULTIPLY:
1226     case OP_I_DIVIDE:
1227     case OP_I_MODULO:
1228     case OP_I_ADD:
1229     case OP_I_SUBTRACT:
1230     case OP_LEFT_SHIFT:
1231     case OP_RIGHT_SHIFT:
1232     case OP_BIT_AND:
1233     case OP_BIT_XOR:
1234     case OP_BIT_OR:
1235     case OP_CONCAT:
1236     case OP_SUBST:
1237     case OP_TRANS:
1238     case OP_READ:
1239     case OP_SYSREAD:
1240     case OP_RECV:
1241     case OP_ANDASSIGN:
1242     case OP_ORASSIGN:
1243         return TRUE;
1244     default:
1245         return FALSE;
1246     }
1247 }
1248
1249 STATIC bool
1250 S_is_handle_constructor(pTHX_ OP *o, I32 argnum)
1251 {
1252     switch (o->op_type) {
1253     case OP_PIPE_OP:
1254     case OP_SOCKPAIR:
1255         if (argnum == 2)
1256             return TRUE;
1257         /* FALL THROUGH */
1258     case OP_SYSOPEN:
1259     case OP_OPEN:
1260     case OP_SELECT:             /* XXX c.f. SelectSaver.pm */
1261     case OP_SOCKET:
1262     case OP_OPEN_DIR:
1263     case OP_ACCEPT:
1264         if (argnum == 1)
1265             return TRUE;
1266         /* FALL THROUGH */
1267     default:
1268         return FALSE;
1269     }
1270 }
1271
1272 OP *
1273 Perl_refkids(pTHX_ OP *o, I32 type)
1274 {
1275     OP *kid;
1276     if (o && o->op_flags & OPf_KIDS) {
1277         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1278             ref(kid, type);
1279     }
1280     return o;
1281 }
1282
1283 OP *
1284 Perl_ref(pTHX_ OP *o, I32 type)
1285 {
1286     OP *kid;
1287
1288     if (!o || PL_error_count)
1289         return o;
1290
1291     switch (o->op_type) {
1292     case OP_ENTERSUB:
1293         if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1294             !(o->op_flags & OPf_STACKED)) {
1295             o->op_type = OP_RV2CV;             /* entersub => rv2cv */
1296             o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1297             assert(cUNOPo->op_first->op_type == OP_NULL);
1298             op_null(((LISTOP*)cUNOPo->op_first)->op_first);     /* disable pushmark */
1299             o->op_flags |= OPf_SPECIAL;
1300         }
1301         break;
1302
1303     case OP_COND_EXPR:
1304         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1305             ref(kid, type);
1306         break;
1307     case OP_RV2SV:
1308         if (type == OP_DEFINED)
1309             o->op_flags |= OPf_SPECIAL;         /* don't create GV */
1310         ref(cUNOPo->op_first, o->op_type);
1311         /* FALL THROUGH */
1312     case OP_PADSV:
1313         if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1314             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1315                               : type == OP_RV2HV ? OPpDEREF_HV
1316                               : OPpDEREF_SV);
1317             o->op_flags |= OPf_MOD;
1318         }
1319         break;
1320
1321     case OP_THREADSV:
1322         o->op_flags |= OPf_MOD;         /* XXX ??? */
1323         break;
1324
1325     case OP_RV2AV:
1326     case OP_RV2HV:
1327         o->op_flags |= OPf_REF;
1328         /* FALL THROUGH */
1329     case OP_RV2GV:
1330         if (type == OP_DEFINED)
1331             o->op_flags |= OPf_SPECIAL;         /* don't create GV */
1332         ref(cUNOPo->op_first, o->op_type);
1333         break;
1334
1335     case OP_PADAV:
1336     case OP_PADHV:
1337         o->op_flags |= OPf_REF;
1338         break;
1339
1340     case OP_SCALAR:
1341     case OP_NULL:
1342         if (!(o->op_flags & OPf_KIDS))
1343             break;
1344         ref(cBINOPo->op_first, type);
1345         break;
1346     case OP_AELEM:
1347     case OP_HELEM:
1348         ref(cBINOPo->op_first, o->op_type);
1349         if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1350             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1351                               : type == OP_RV2HV ? OPpDEREF_HV
1352                               : OPpDEREF_SV);
1353             o->op_flags |= OPf_MOD;
1354         }
1355         break;
1356
1357     case OP_SCOPE:
1358     case OP_LEAVE:
1359     case OP_ENTER:
1360     case OP_LIST:
1361         if (!(o->op_flags & OPf_KIDS))
1362             break;
1363         ref(cLISTOPo->op_last, type);
1364         break;
1365     default:
1366         break;
1367     }
1368     return scalar(o);
1369
1370 }
1371
1372 STATIC OP *
1373 S_dup_attrlist(pTHX_ OP *o)
1374 {
1375     OP *rop = Nullop;
1376
1377     /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1378      * where the first kid is OP_PUSHMARK and the remaining ones
1379      * are OP_CONST.  We need to push the OP_CONST values.
1380      */
1381     if (o->op_type == OP_CONST)
1382         rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc(cSVOPo->op_sv));
1383     else {
1384         assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1385         for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1386             if (o->op_type == OP_CONST)
1387                 rop = append_elem(OP_LIST, rop,
1388                                   newSVOP(OP_CONST, o->op_flags,
1389                                           SvREFCNT_inc(cSVOPo->op_sv)));
1390         }
1391     }
1392     return rop;
1393 }
1394
1395 STATIC void
1396 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1397 {
1398     SV *stashsv;
1399
1400     /* fake up C<use attributes $pkg,$rv,@attrs> */
1401     ENTER;              /* need to protect against side-effects of 'use' */
1402     SAVEINT(PL_expect);
1403     if (stash)
1404         stashsv = newSVpv(HvNAME(stash), 0);
1405     else
1406         stashsv = &PL_sv_no;
1407
1408 #define ATTRSMODULE "attributes"
1409 #define ATTRSMODULE_PM "attributes.pm"
1410
1411     if (for_my) {
1412         SV **svp;
1413         /* Don't force the C<use> if we don't need it. */
1414         svp = hv_fetch(GvHVn(PL_incgv), ATTRSMODULE_PM,
1415                        sizeof(ATTRSMODULE_PM)-1, 0);
1416         if (svp && *svp != &PL_sv_undef)
1417             ;           /* already in %INC */
1418         else
1419             Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1420                              newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1421                              Nullsv);
1422     }
1423     else {
1424         Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1425                          newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1426                          Nullsv,
1427                          prepend_elem(OP_LIST,
1428                                       newSVOP(OP_CONST, 0, stashsv),
1429                                       prepend_elem(OP_LIST,
1430                                                    newSVOP(OP_CONST, 0,
1431                                                            newRV(target)),
1432                                                    dup_attrlist(attrs))));
1433     }
1434     LEAVE;
1435 }
1436
1437 STATIC void
1438 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1439 {
1440     OP *pack, *imop, *arg;
1441     SV *meth, *stashsv;
1442
1443     if (!attrs)
1444         return;
1445
1446     assert(target->op_type == OP_PADSV ||
1447            target->op_type == OP_PADHV ||
1448            target->op_type == OP_PADAV);
1449
1450     /* Ensure that attributes.pm is loaded. */
1451     apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
1452
1453     /* Need package name for method call. */
1454     pack = newSVOP(OP_CONST, 0, newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1));
1455
1456     /* Build up the real arg-list. */
1457     if (stash)
1458         stashsv = newSVpv(HvNAME(stash), 0);
1459     else
1460         stashsv = &PL_sv_no;
1461     arg = newOP(OP_PADSV, 0);
1462     arg->op_targ = target->op_targ;
1463     arg = prepend_elem(OP_LIST,
1464                        newSVOP(OP_CONST, 0, stashsv),
1465                        prepend_elem(OP_LIST,
1466                                     newUNOP(OP_REFGEN, 0,
1467                                             mod(arg, OP_REFGEN)),
1468                                     dup_attrlist(attrs)));
1469
1470     /* Fake up a method call to import */
1471     meth = newSVpvn("import", 6);
1472     (void)SvUPGRADE(meth, SVt_PVIV);
1473     (void)SvIOK_on(meth);
1474     PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
1475     imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
1476                    append_elem(OP_LIST,
1477                                prepend_elem(OP_LIST, pack, list(arg)),
1478                                newSVOP(OP_METHOD_NAMED, 0, meth)));
1479     imop->op_private |= OPpENTERSUB_NOMOD;
1480
1481     /* Combine the ops. */
1482     *imopsp = append_elem(OP_LIST, *imopsp, imop);
1483 }
1484
1485 /*
1486 =notfor apidoc apply_attrs_string
1487
1488 Attempts to apply a list of attributes specified by the C<attrstr> and
1489 C<len> arguments to the subroutine identified by the C<cv> argument which
1490 is expected to be associated with the package identified by the C<stashpv>
1491 argument (see L<attributes>).  It gets this wrong, though, in that it
1492 does not correctly identify the boundaries of the individual attribute
1493 specifications within C<attrstr>.  This is not really intended for the
1494 public API, but has to be listed here for systems such as AIX which
1495 need an explicit export list for symbols.  (It's called from XS code
1496 in support of the C<ATTRS:> keyword from F<xsubpp>.)  Patches to fix it
1497 to respect attribute syntax properly would be welcome.
1498
1499 =cut
1500 */
1501
1502 void
1503 Perl_apply_attrs_string(pTHX_ char *stashpv, CV *cv,
1504                         char *attrstr, STRLEN len)
1505 {
1506     OP *attrs = Nullop;
1507
1508     if (!len) {
1509         len = strlen(attrstr);
1510     }
1511
1512     while (len) {
1513         for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1514         if (len) {
1515             char *sstr = attrstr;
1516             for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1517             attrs = append_elem(OP_LIST, attrs,
1518                                 newSVOP(OP_CONST, 0,
1519                                         newSVpvn(sstr, attrstr-sstr)));
1520         }
1521     }
1522
1523     Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1524                      newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1525                      Nullsv, prepend_elem(OP_LIST,
1526                                   newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1527                                   prepend_elem(OP_LIST,
1528                                                newSVOP(OP_CONST, 0,
1529                                                        newRV((SV*)cv)),
1530                                                attrs)));
1531 }
1532
1533 STATIC OP *
1534 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
1535 {
1536     OP *kid;
1537     I32 type;
1538
1539     if (!o || PL_error_count)
1540         return o;
1541
1542     type = o->op_type;
1543     if (type == OP_LIST) {
1544         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1545             my_kid(kid, attrs, imopsp);
1546     } else if (type == OP_UNDEF) {
1547         return o;
1548     } else if (type == OP_RV2SV ||      /* "our" declaration */
1549                type == OP_RV2AV ||
1550                type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1551         if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
1552             yyerror(Perl_form(aTHX_ "Can't declare %s in %s",
1553                         OP_DESC(o), PL_in_my == KEY_our ? "our" : "my"));
1554         } else if (attrs) {
1555             GV *gv = cGVOPx_gv(cUNOPo->op_first);
1556             PL_in_my = FALSE;
1557             PL_in_my_stash = Nullhv;
1558             apply_attrs(GvSTASH(gv),
1559                         (type == OP_RV2SV ? GvSV(gv) :
1560                          type == OP_RV2AV ? (SV*)GvAV(gv) :
1561                          type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1562                         attrs, FALSE);
1563         }
1564         o->op_private |= OPpOUR_INTRO;
1565         return o;
1566     }
1567     else if (type != OP_PADSV &&
1568              type != OP_PADAV &&
1569              type != OP_PADHV &&
1570              type != OP_PUSHMARK)
1571     {
1572         yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1573                           OP_DESC(o),
1574                           PL_in_my == KEY_our ? "our" : "my"));
1575         return o;
1576     }
1577     else if (attrs && type != OP_PUSHMARK) {
1578         HV *stash;
1579
1580         PL_in_my = FALSE;
1581         PL_in_my_stash = Nullhv;
1582
1583         /* check for C<my Dog $spot> when deciding package */
1584         stash = PAD_COMPNAME_TYPE(o->op_targ);
1585         if (!stash)
1586             stash = PL_curstash;
1587         apply_attrs_my(stash, o, attrs, imopsp);
1588     }
1589     o->op_flags |= OPf_MOD;
1590     o->op_private |= OPpLVAL_INTRO;
1591     return o;
1592 }
1593
1594 OP *
1595 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
1596 {
1597     OP *rops = Nullop;
1598     int maybe_scalar = 0;
1599
1600 /* [perl #17376]: this appears to be premature, and results in code such as
1601    C< our(%x); > executing in list mode rather than void mode */
1602 #if 0
1603     if (o->op_flags & OPf_PARENS)
1604         list(o);
1605     else
1606         maybe_scalar = 1;
1607 #else
1608     maybe_scalar = 1;
1609 #endif
1610     if (attrs)
1611         SAVEFREEOP(attrs);
1612     o = my_kid(o, attrs, &rops);
1613     if (rops) {
1614         if (maybe_scalar && o->op_type == OP_PADSV) {
1615             o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
1616             o->op_private |= OPpLVAL_INTRO;
1617         }
1618         else
1619             o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
1620     }
1621     PL_in_my = FALSE;
1622     PL_in_my_stash = Nullhv;
1623     return o;
1624 }
1625
1626 OP *
1627 Perl_my(pTHX_ OP *o)
1628 {
1629     return my_attrs(o, Nullop);
1630 }
1631
1632 OP *
1633 Perl_sawparens(pTHX_ OP *o)
1634 {
1635     if (o)
1636         o->op_flags |= OPf_PARENS;
1637     return o;
1638 }
1639
1640 OP *
1641 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
1642 {
1643     OP *o;
1644
1645     if (ckWARN(WARN_MISC) &&
1646       (left->op_type == OP_RV2AV ||
1647        left->op_type == OP_RV2HV ||
1648        left->op_type == OP_PADAV ||
1649        left->op_type == OP_PADHV)) {
1650       char *desc = PL_op_desc[(right->op_type == OP_SUBST ||
1651                             right->op_type == OP_TRANS)
1652                            ? right->op_type : OP_MATCH];
1653       const char *sample = ((left->op_type == OP_RV2AV ||
1654                              left->op_type == OP_PADAV)
1655                             ? "@array" : "%hash");
1656       Perl_warner(aTHX_ packWARN(WARN_MISC),
1657              "Applying %s to %s will act on scalar(%s)",
1658              desc, sample, sample);
1659     }
1660
1661     if (right->op_type == OP_CONST &&
1662         cSVOPx(right)->op_private & OPpCONST_BARE &&
1663         cSVOPx(right)->op_private & OPpCONST_STRICT)
1664     {
1665         no_bareword_allowed(right);
1666     }
1667
1668     if (!(right->op_flags & OPf_STACKED) &&
1669        (right->op_type == OP_MATCH ||
1670         right->op_type == OP_SUBST ||
1671         right->op_type == OP_TRANS)) {
1672         right->op_flags |= OPf_STACKED;
1673         if (right->op_type != OP_MATCH &&
1674             ! (right->op_type == OP_TRANS &&
1675                right->op_private & OPpTRANS_IDENTICAL))
1676             left = mod(left, right->op_type);
1677         if (right->op_type == OP_TRANS)
1678             o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
1679         else
1680             o = prepend_elem(right->op_type, scalar(left), right);
1681         if (type == OP_NOT)
1682             return newUNOP(OP_NOT, 0, scalar(o));
1683         return o;
1684     }
1685     else
1686         return bind_match(type, left,
1687                 pmruntime(newPMOP(OP_MATCH, 0), right, Nullop));
1688 }
1689
1690 OP *
1691 Perl_invert(pTHX_ OP *o)
1692 {
1693     if (!o)
1694         return o;
1695     /* XXX need to optimize away NOT NOT here?  Or do we let optimizer do it? */
1696     return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
1697 }
1698
1699 OP *
1700 Perl_scope(pTHX_ OP *o)
1701 {
1702     if (o) {
1703         if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
1704             o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
1705             o->op_type = OP_LEAVE;
1706             o->op_ppaddr = PL_ppaddr[OP_LEAVE];
1707         }
1708         else if (o->op_type == OP_LINESEQ) {
1709             OP *kid;
1710             o->op_type = OP_SCOPE;
1711             o->op_ppaddr = PL_ppaddr[OP_SCOPE];
1712             kid = ((LISTOP*)o)->op_first;
1713             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
1714                 op_null(kid);
1715         }
1716         else
1717             o = newLISTOP(OP_SCOPE, 0, o, Nullop);
1718     }
1719     return o;
1720 }
1721
1722 void
1723 Perl_save_hints(pTHX)
1724 {
1725     SAVEI32(PL_hints);
1726     SAVESPTR(GvHV(PL_hintgv));
1727     GvHV(PL_hintgv) = newHVhv(GvHV(PL_hintgv));
1728     SAVEFREESV(GvHV(PL_hintgv));
1729 }
1730
1731 int
1732 Perl_block_start(pTHX_ int full)
1733 {
1734     int retval = PL_savestack_ix;
1735     /* If there were syntax errors, don't try to start a block */
1736     if (PL_yynerrs) return retval;
1737
1738     pad_block_start(full);
1739     SAVEHINTS();
1740     PL_hints &= ~HINT_BLOCK_SCOPE;
1741     SAVESPTR(PL_compiling.cop_warnings);
1742     if (! specialWARN(PL_compiling.cop_warnings)) {
1743         PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
1744         SAVEFREESV(PL_compiling.cop_warnings) ;
1745     }
1746     SAVESPTR(PL_compiling.cop_io);
1747     if (! specialCopIO(PL_compiling.cop_io)) {
1748         PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
1749         SAVEFREESV(PL_compiling.cop_io) ;
1750     }
1751     return retval;
1752 }
1753
1754 OP*
1755 Perl_block_end(pTHX_ I32 floor, OP *seq)
1756 {
1757     int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
1758     OP* retval = scalarseq(seq);
1759     /* If there were syntax errors, don't try to close a block */
1760     if (PL_yynerrs) return retval;
1761     LEAVE_SCOPE(floor);
1762     PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
1763     if (needblockscope)
1764         PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
1765     pad_leavemy();
1766     return retval;
1767 }
1768
1769 STATIC OP *
1770 S_newDEFSVOP(pTHX)
1771 {
1772     return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
1773 }
1774
1775 void
1776 Perl_newPROG(pTHX_ OP *o)
1777 {
1778     if (PL_in_eval) {
1779         if (PL_eval_root)
1780                 return;
1781         PL_eval_root = newUNOP(OP_LEAVEEVAL,
1782                                ((PL_in_eval & EVAL_KEEPERR)
1783                                 ? OPf_SPECIAL : 0), o);
1784         PL_eval_start = linklist(PL_eval_root);
1785         PL_eval_root->op_private |= OPpREFCOUNTED;
1786         OpREFCNT_set(PL_eval_root, 1);
1787         PL_eval_root->op_next = 0;
1788         CALL_PEEP(PL_eval_start);
1789     }
1790     else {
1791         if (!o)
1792             return;
1793         PL_main_root = scope(sawparens(scalarvoid(o)));
1794         PL_curcop = &PL_compiling;
1795         PL_main_start = LINKLIST(PL_main_root);
1796         PL_main_root->op_private |= OPpREFCOUNTED;
1797         OpREFCNT_set(PL_main_root, 1);
1798         PL_main_root->op_next = 0;
1799         CALL_PEEP(PL_main_start);
1800         PL_compcv = 0;
1801
1802         /* Register with debugger */
1803         if (PERLDB_INTER) {
1804             CV *cv = get_cv("DB::postponed", FALSE);
1805             if (cv) {
1806                 dSP;
1807                 PUSHMARK(SP);
1808                 XPUSHs((SV*)CopFILEGV(&PL_compiling));
1809                 PUTBACK;
1810                 call_sv((SV*)cv, G_DISCARD);
1811             }
1812         }
1813     }
1814 }
1815
1816 OP *
1817 Perl_localize(pTHX_ OP *o, I32 lex)
1818 {
1819     if (o->op_flags & OPf_PARENS)
1820 /* [perl #17376]: this appears to be premature, and results in code such as
1821    C< our(%x); > executing in list mode rather than void mode */
1822 #if 0
1823         list(o);
1824 #else
1825         ;
1826 #endif
1827     else {
1828         if (ckWARN(WARN_PARENTHESIS)
1829             && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',')
1830         {
1831             char *s = PL_bufptr;
1832
1833             while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s) || strchr("@$%, ", *s)))
1834                 s++;
1835
1836             if (*s == ';' || *s == '=')
1837                 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
1838                             "Parentheses missing around \"%s\" list",
1839                             lex ? (PL_in_my == KEY_our ? "our" : "my") : "local");
1840         }
1841     }
1842     if (lex)
1843         o = my(o);
1844     else
1845         o = mod(o, OP_NULL);            /* a bit kludgey */
1846     PL_in_my = FALSE;
1847     PL_in_my_stash = Nullhv;
1848     return o;
1849 }
1850
1851 OP *
1852 Perl_jmaybe(pTHX_ OP *o)
1853 {
1854     if (o->op_type == OP_LIST) {
1855         OP *o2;
1856         o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
1857         o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
1858     }
1859     return o;
1860 }
1861
1862 OP *
1863 Perl_fold_constants(pTHX_ register OP *o)
1864 {
1865     register OP *curop;
1866     I32 type = o->op_type;
1867     SV *sv;
1868
1869     if (PL_opargs[type] & OA_RETSCALAR)
1870         scalar(o);
1871     if (PL_opargs[type] & OA_TARGET && !o->op_targ)
1872         o->op_targ = pad_alloc(type, SVs_PADTMP);
1873
1874     /* integerize op, unless it happens to be C<-foo>.
1875      * XXX should pp_i_negate() do magic string negation instead? */
1876     if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
1877         && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
1878              && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
1879     {
1880         o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
1881     }
1882
1883     if (!(PL_opargs[type] & OA_FOLDCONST))
1884         goto nope;
1885
1886     switch (type) {
1887     case OP_NEGATE:
1888         /* XXX might want a ck_negate() for this */
1889         cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
1890         break;
1891     case OP_SPRINTF:
1892     case OP_UCFIRST:
1893     case OP_LCFIRST:
1894     case OP_UC:
1895     case OP_LC:
1896     case OP_SLT:
1897     case OP_SGT:
1898     case OP_SLE:
1899     case OP_SGE:
1900     case OP_SCMP:
1901         /* XXX what about the numeric ops? */
1902         if (PL_hints & HINT_LOCALE)
1903             goto nope;
1904     }
1905
1906     if (PL_error_count)
1907         goto nope;              /* Don't try to run w/ errors */
1908
1909     for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
1910         if ((curop->op_type != OP_CONST ||
1911              (curop->op_private & OPpCONST_BARE)) &&
1912             curop->op_type != OP_LIST &&
1913             curop->op_type != OP_SCALAR &&
1914             curop->op_type != OP_NULL &&
1915             curop->op_type != OP_PUSHMARK)
1916         {
1917             goto nope;
1918         }
1919     }
1920
1921     curop = LINKLIST(o);
1922     o->op_next = 0;
1923     PL_op = curop;
1924     CALLRUNOPS(aTHX);
1925     sv = *(PL_stack_sp--);
1926     if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
1927         pad_swipe(o->op_targ,  FALSE);
1928     else if (SvTEMP(sv)) {                      /* grab mortal temp? */
1929         (void)SvREFCNT_inc(sv);
1930         SvTEMP_off(sv);
1931     }
1932     op_free(o);
1933     if (type == OP_RV2GV)
1934         return newGVOP(OP_GV, 0, (GV*)sv);
1935     return newSVOP(OP_CONST, 0, sv);
1936
1937   nope:
1938     return o;
1939 }
1940
1941 OP *
1942 Perl_gen_constant_list(pTHX_ register OP *o)
1943 {
1944     register OP *curop;
1945     I32 oldtmps_floor = PL_tmps_floor;
1946
1947     list(o);
1948     if (PL_error_count)
1949         return o;               /* Don't attempt to run with errors */
1950
1951     PL_op = curop = LINKLIST(o);
1952     o->op_next = 0;
1953     CALL_PEEP(curop);
1954     pp_pushmark();
1955     CALLRUNOPS(aTHX);
1956     PL_op = curop;
1957     pp_anonlist();
1958     PL_tmps_floor = oldtmps_floor;
1959
1960     o->op_type = OP_RV2AV;
1961     o->op_ppaddr = PL_ppaddr[OP_RV2AV];
1962     o->op_seq = 0;              /* needs to be revisited in peep() */
1963     curop = ((UNOP*)o)->op_first;
1964     ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
1965     op_free(curop);
1966     linklist(o);
1967     return list(o);
1968 }
1969
1970 OP *
1971 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
1972 {
1973     if (!o || o->op_type != OP_LIST)
1974         o = newLISTOP(OP_LIST, 0, o, Nullop);
1975     else
1976         o->op_flags &= ~OPf_WANT;
1977
1978     if (!(PL_opargs[type] & OA_MARK))
1979         op_null(cLISTOPo->op_first);
1980
1981     o->op_type = (OPCODE)type;
1982     o->op_ppaddr = PL_ppaddr[type];
1983     o->op_flags |= flags;
1984
1985     o = CHECKOP(type, o);
1986     if (o->op_type != type)
1987         return o;
1988
1989     return fold_constants(o);
1990 }
1991
1992 /* List constructors */
1993
1994 OP *
1995 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
1996 {
1997     if (!first)
1998         return last;
1999
2000     if (!last)
2001         return first;
2002
2003     if (first->op_type != type
2004         || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2005     {
2006         return newLISTOP(type, 0, first, last);
2007     }
2008
2009     if (first->op_flags & OPf_KIDS)
2010         ((LISTOP*)first)->op_last->op_sibling = last;
2011     else {
2012         first->op_flags |= OPf_KIDS;
2013         ((LISTOP*)first)->op_first = last;
2014     }
2015     ((LISTOP*)first)->op_last = last;
2016     return first;
2017 }
2018
2019 OP *
2020 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2021 {
2022     if (!first)
2023         return (OP*)last;
2024
2025     if (!last)
2026         return (OP*)first;
2027
2028     if (first->op_type != type)
2029         return prepend_elem(type, (OP*)first, (OP*)last);
2030
2031     if (last->op_type != type)
2032         return append_elem(type, (OP*)first, (OP*)last);
2033
2034     first->op_last->op_sibling = last->op_first;
2035     first->op_last = last->op_last;
2036     first->op_flags |= (last->op_flags & OPf_KIDS);
2037
2038     FreeOp(last);
2039
2040     return (OP*)first;
2041 }
2042
2043 OP *
2044 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2045 {
2046     if (!first)
2047         return last;
2048
2049     if (!last)
2050         return first;
2051
2052     if (last->op_type == type) {
2053         if (type == OP_LIST) {  /* already a PUSHMARK there */
2054             first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2055             ((LISTOP*)last)->op_first->op_sibling = first;
2056             if (!(first->op_flags & OPf_PARENS))
2057                 last->op_flags &= ~OPf_PARENS;
2058         }
2059         else {
2060             if (!(last->op_flags & OPf_KIDS)) {
2061                 ((LISTOP*)last)->op_last = first;
2062                 last->op_flags |= OPf_KIDS;
2063             }
2064             first->op_sibling = ((LISTOP*)last)->op_first;
2065             ((LISTOP*)last)->op_first = first;
2066         }
2067         last->op_flags |= OPf_KIDS;
2068         return last;
2069     }
2070
2071     return newLISTOP(type, 0, first, last);
2072 }
2073
2074 /* Constructors */
2075
2076 OP *
2077 Perl_newNULLLIST(pTHX)
2078 {
2079     return newOP(OP_STUB, 0);
2080 }
2081
2082 OP *
2083 Perl_force_list(pTHX_ OP *o)
2084 {
2085     if (!o || o->op_type != OP_LIST)
2086         o = newLISTOP(OP_LIST, 0, o, Nullop);
2087     op_null(o);
2088     return o;
2089 }
2090
2091 OP *
2092 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2093 {
2094     LISTOP *listop;
2095
2096     NewOp(1101, listop, 1, LISTOP);
2097
2098     listop->op_type = (OPCODE)type;
2099     listop->op_ppaddr = PL_ppaddr[type];
2100     if (first || last)
2101         flags |= OPf_KIDS;
2102     listop->op_flags = (U8)flags;
2103
2104     if (!last && first)
2105         last = first;
2106     else if (!first && last)
2107         first = last;
2108     else if (first)
2109         first->op_sibling = last;
2110     listop->op_first = first;
2111     listop->op_last = last;
2112     if (type == OP_LIST) {
2113         OP* pushop;
2114         pushop = newOP(OP_PUSHMARK, 0);
2115         pushop->op_sibling = first;
2116         listop->op_first = pushop;
2117         listop->op_flags |= OPf_KIDS;
2118         if (!last)
2119             listop->op_last = pushop;
2120     }
2121
2122     return (OP*)listop;
2123 }
2124
2125 OP *
2126 Perl_newOP(pTHX_ I32 type, I32 flags)
2127 {
2128     OP *o;
2129     NewOp(1101, o, 1, OP);
2130     o->op_type = (OPCODE)type;
2131     o->op_ppaddr = PL_ppaddr[type];
2132     o->op_flags = (U8)flags;
2133
2134     o->op_next = o;
2135     o->op_private = (U8)(0 | (flags >> 8));
2136     if (PL_opargs[type] & OA_RETSCALAR)
2137         scalar(o);
2138     if (PL_opargs[type] & OA_TARGET)
2139         o->op_targ = pad_alloc(type, SVs_PADTMP);
2140     return CHECKOP(type, o);
2141 }
2142
2143 OP *
2144 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2145 {
2146     UNOP *unop;
2147
2148     if (!first)
2149         first = newOP(OP_STUB, 0);
2150     if (PL_opargs[type] & OA_MARK)
2151         first = force_list(first);
2152
2153     NewOp(1101, unop, 1, UNOP);
2154     unop->op_type = (OPCODE)type;
2155     unop->op_ppaddr = PL_ppaddr[type];
2156     unop->op_first = first;
2157     unop->op_flags = flags | OPf_KIDS;
2158     unop->op_private = (U8)(1 | (flags >> 8));
2159     unop = (UNOP*) CHECKOP(type, unop);
2160     if (unop->op_next)
2161         return (OP*)unop;
2162
2163     return fold_constants((OP *) unop);
2164 }
2165
2166 OP *
2167 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2168 {
2169     BINOP *binop;
2170     NewOp(1101, binop, 1, BINOP);
2171
2172     if (!first)
2173         first = newOP(OP_NULL, 0);
2174
2175     binop->op_type = (OPCODE)type;
2176     binop->op_ppaddr = PL_ppaddr[type];
2177     binop->op_first = first;
2178     binop->op_flags = flags | OPf_KIDS;
2179     if (!last) {
2180         last = first;
2181         binop->op_private = (U8)(1 | (flags >> 8));
2182     }
2183     else {
2184         binop->op_private = (U8)(2 | (flags >> 8));
2185         first->op_sibling = last;
2186     }
2187
2188     binop = (BINOP*)CHECKOP(type, binop);
2189     if (binop->op_next || binop->op_type != (OPCODE)type)
2190         return (OP*)binop;
2191
2192     binop->op_last = binop->op_first->op_sibling;
2193
2194     return fold_constants((OP *)binop);
2195 }
2196
2197 static int
2198 uvcompare(const void *a, const void *b)
2199 {
2200     if (*((UV *)a) < (*(UV *)b))
2201         return -1;
2202     if (*((UV *)a) > (*(UV *)b))
2203         return 1;
2204     if (*((UV *)a+1) < (*(UV *)b+1))
2205         return -1;
2206     if (*((UV *)a+1) > (*(UV *)b+1))
2207         return 1;
2208     return 0;
2209 }
2210
2211 OP *
2212 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2213 {
2214     SV *tstr = ((SVOP*)expr)->op_sv;
2215     SV *rstr = ((SVOP*)repl)->op_sv;
2216     STRLEN tlen;
2217     STRLEN rlen;
2218     U8 *t = (U8*)SvPV(tstr, tlen);
2219     U8 *r = (U8*)SvPV(rstr, rlen);
2220     register I32 i;
2221     register I32 j;
2222     I32 del;
2223     I32 complement;
2224     I32 squash;
2225     I32 grows = 0;
2226     register short *tbl;
2227
2228     PL_hints |= HINT_BLOCK_SCOPE;
2229     complement  = o->op_private & OPpTRANS_COMPLEMENT;
2230     del         = o->op_private & OPpTRANS_DELETE;
2231     squash      = o->op_private & OPpTRANS_SQUASH;
2232
2233     if (SvUTF8(tstr))
2234         o->op_private |= OPpTRANS_FROM_UTF;
2235
2236     if (SvUTF8(rstr))
2237         o->op_private |= OPpTRANS_TO_UTF;
2238
2239     if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2240         SV* listsv = newSVpvn("# comment\n",10);
2241         SV* transv = 0;
2242         U8* tend = t + tlen;
2243         U8* rend = r + rlen;
2244         STRLEN ulen;
2245         U32 tfirst = 1;
2246         U32 tlast = 0;
2247         I32 tdiff;
2248         U32 rfirst = 1;
2249         U32 rlast = 0;
2250         I32 rdiff;
2251         I32 diff;
2252         I32 none = 0;
2253         U32 max = 0;
2254         I32 bits;
2255         I32 havefinal = 0;
2256         U32 final = 0;
2257         I32 from_utf    = o->op_private & OPpTRANS_FROM_UTF;
2258         I32 to_utf      = o->op_private & OPpTRANS_TO_UTF;
2259         U8* tsave = NULL;
2260         U8* rsave = NULL;
2261
2262         if (!from_utf) {
2263             STRLEN len = tlen;
2264             tsave = t = bytes_to_utf8(t, &len);
2265             tend = t + len;
2266         }
2267         if (!to_utf && rlen) {
2268             STRLEN len = rlen;
2269             rsave = r = bytes_to_utf8(r, &len);
2270             rend = r + len;
2271         }
2272
2273 /* There are several snags with this code on EBCDIC:
2274    1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2275    2. scan_const() in toke.c has encoded chars in native encoding which makes
2276       ranges at least in EBCDIC 0..255 range the bottom odd.
2277 */
2278
2279         if (complement) {
2280             U8 tmpbuf[UTF8_MAXLEN+1];
2281             UV *cp;
2282             UV nextmin = 0;
2283             New(1109, cp, 2*tlen, UV);
2284             i = 0;
2285             transv = newSVpvn("",0);
2286             while (t < tend) {
2287                 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2288                 t += ulen;
2289                 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2290                     t++;
2291                     cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2292                     t += ulen;
2293                 }
2294                 else {
2295                  cp[2*i+1] = cp[2*i];
2296                 }
2297                 i++;
2298             }
2299             qsort(cp, i, 2*sizeof(UV), uvcompare);
2300             for (j = 0; j < i; j++) {
2301                 UV  val = cp[2*j];
2302                 diff = val - nextmin;
2303                 if (diff > 0) {
2304                     t = uvuni_to_utf8(tmpbuf,nextmin);
2305                     sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2306                     if (diff > 1) {
2307                         U8  range_mark = UTF_TO_NATIVE(0xff);
2308                         t = uvuni_to_utf8(tmpbuf, val - 1);
2309                         sv_catpvn(transv, (char *)&range_mark, 1);
2310                         sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2311                     }
2312                 }
2313                 val = cp[2*j+1];
2314                 if (val >= nextmin)
2315                     nextmin = val + 1;
2316             }
2317             t = uvuni_to_utf8(tmpbuf,nextmin);
2318             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2319             {
2320                 U8 range_mark = UTF_TO_NATIVE(0xff);
2321                 sv_catpvn(transv, (char *)&range_mark, 1);
2322             }
2323             t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
2324                                     UNICODE_ALLOW_SUPER);
2325             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2326             t = (U8*)SvPVX(transv);
2327             tlen = SvCUR(transv);
2328             tend = t + tlen;
2329             Safefree(cp);
2330         }
2331         else if (!rlen && !del) {
2332             r = t; rlen = tlen; rend = tend;
2333         }
2334         if (!squash) {
2335                 if ((!rlen && !del) || t == r ||
2336                     (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2337                 {
2338                     o->op_private |= OPpTRANS_IDENTICAL;
2339                 }
2340         }
2341
2342         while (t < tend || tfirst <= tlast) {
2343             /* see if we need more "t" chars */
2344             if (tfirst > tlast) {
2345                 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2346                 t += ulen;
2347                 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {    /* illegal utf8 val indicates range */
2348                     t++;
2349                     tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2350                     t += ulen;
2351                 }
2352                 else
2353                     tlast = tfirst;
2354             }
2355
2356             /* now see if we need more "r" chars */
2357             if (rfirst > rlast) {
2358                 if (r < rend) {
2359                     rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2360                     r += ulen;
2361                     if (r < rend && NATIVE_TO_UTF(*r) == 0xff) {        /* illegal utf8 val indicates range */
2362                         r++;
2363                         rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2364                         r += ulen;
2365                     }
2366                     else
2367                         rlast = rfirst;
2368                 }
2369                 else {
2370                     if (!havefinal++)
2371                         final = rlast;
2372                     rfirst = rlast = 0xffffffff;
2373                 }
2374             }
2375
2376             /* now see which range will peter our first, if either. */
2377             tdiff = tlast - tfirst;
2378             rdiff = rlast - rfirst;
2379
2380             if (tdiff <= rdiff)
2381                 diff = tdiff;
2382             else
2383                 diff = rdiff;
2384
2385             if (rfirst == 0xffffffff) {
2386                 diff = tdiff;   /* oops, pretend rdiff is infinite */
2387                 if (diff > 0)
2388                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2389                                    (long)tfirst, (long)tlast);
2390                 else
2391                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2392             }
2393             else {
2394                 if (diff > 0)
2395                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2396                                    (long)tfirst, (long)(tfirst + diff),
2397                                    (long)rfirst);
2398                 else
2399                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2400                                    (long)tfirst, (long)rfirst);
2401
2402                 if (rfirst + diff > max)
2403                     max = rfirst + diff;
2404                 if (!grows)
2405                     grows = (tfirst < rfirst &&
2406                              UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2407                 rfirst += diff + 1;
2408             }
2409             tfirst += diff + 1;
2410         }
2411
2412         none = ++max;
2413         if (del)
2414             del = ++max;
2415
2416         if (max > 0xffff)
2417             bits = 32;
2418         else if (max > 0xff)
2419             bits = 16;
2420         else
2421             bits = 8;
2422
2423         Safefree(cPVOPo->op_pv);
2424         cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2425         SvREFCNT_dec(listsv);
2426         if (transv)
2427             SvREFCNT_dec(transv);
2428
2429         if (!del && havefinal && rlen)
2430             (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2431                            newSVuv((UV)final), 0);
2432
2433         if (grows)
2434             o->op_private |= OPpTRANS_GROWS;
2435
2436         if (tsave)
2437             Safefree(tsave);
2438         if (rsave)
2439             Safefree(rsave);
2440
2441         op_free(expr);
2442         op_free(repl);
2443         return o;
2444     }
2445
2446     tbl = (short*)cPVOPo->op_pv;
2447     if (complement) {
2448         Zero(tbl, 256, short);
2449         for (i = 0; i < (I32)tlen; i++)
2450             tbl[t[i]] = -1;
2451         for (i = 0, j = 0; i < 256; i++) {
2452             if (!tbl[i]) {
2453                 if (j >= (I32)rlen) {
2454                     if (del)
2455                         tbl[i] = -2;
2456                     else if (rlen)
2457                         tbl[i] = r[j-1];
2458                     else
2459                         tbl[i] = (short)i;
2460                 }
2461                 else {
2462                     if (i < 128 && r[j] >= 128)
2463                         grows = 1;
2464                     tbl[i] = r[j++];
2465                 }
2466             }
2467         }
2468         if (!del) {
2469             if (!rlen) {
2470                 j = rlen;
2471                 if (!squash)
2472                     o->op_private |= OPpTRANS_IDENTICAL;
2473             }
2474             else if (j >= (I32)rlen)
2475                 j = rlen - 1;
2476             else
2477                 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
2478             tbl[0x100] = rlen - j;
2479             for (i=0; i < (I32)rlen - j; i++)
2480                 tbl[0x101+i] = r[j+i];
2481         }
2482     }
2483     else {
2484         if (!rlen && !del) {
2485             r = t; rlen = tlen;
2486             if (!squash)
2487                 o->op_private |= OPpTRANS_IDENTICAL;
2488         }
2489         else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
2490             o->op_private |= OPpTRANS_IDENTICAL;
2491         }
2492         for (i = 0; i < 256; i++)
2493             tbl[i] = -1;
2494         for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
2495             if (j >= (I32)rlen) {
2496                 if (del) {
2497                     if (tbl[t[i]] == -1)
2498                         tbl[t[i]] = -2;
2499                     continue;
2500                 }
2501                 --j;
2502             }
2503             if (tbl[t[i]] == -1) {
2504                 if (t[i] < 128 && r[j] >= 128)
2505                     grows = 1;
2506                 tbl[t[i]] = r[j];
2507             }
2508         }
2509     }
2510     if (grows)
2511         o->op_private |= OPpTRANS_GROWS;
2512     op_free(expr);
2513     op_free(repl);
2514
2515     return o;
2516 }
2517
2518 OP *
2519 Perl_newPMOP(pTHX_ I32 type, I32 flags)
2520 {
2521     PMOP *pmop;
2522
2523     NewOp(1101, pmop, 1, PMOP);
2524     pmop->op_type = (OPCODE)type;
2525     pmop->op_ppaddr = PL_ppaddr[type];
2526     pmop->op_flags = (U8)flags;
2527     pmop->op_private = (U8)(0 | (flags >> 8));
2528
2529     if (PL_hints & HINT_RE_TAINT)
2530         pmop->op_pmpermflags |= PMf_RETAINT;
2531     if (PL_hints & HINT_LOCALE)
2532         pmop->op_pmpermflags |= PMf_LOCALE;
2533     pmop->op_pmflags = pmop->op_pmpermflags;
2534
2535 #ifdef USE_ITHREADS
2536     {
2537         SV* repointer;
2538         if(av_len((AV*) PL_regex_pad[0]) > -1) {
2539             repointer = av_pop((AV*)PL_regex_pad[0]);
2540             pmop->op_pmoffset = SvIV(repointer);
2541             SvREPADTMP_off(repointer);
2542             sv_setiv(repointer,0);
2543         } else {
2544             repointer = newSViv(0);
2545             av_push(PL_regex_padav,SvREFCNT_inc(repointer));
2546             pmop->op_pmoffset = av_len(PL_regex_padav);
2547             PL_regex_pad = AvARRAY(PL_regex_padav);
2548         }
2549     }
2550 #endif
2551
2552         /* link into pm list */
2553     if (type != OP_TRANS && PL_curstash) {
2554         pmop->op_pmnext = HvPMROOT(PL_curstash);
2555         HvPMROOT(PL_curstash) = pmop;
2556         PmopSTASH_set(pmop,PL_curstash);
2557     }
2558
2559     return (OP*)pmop;
2560 }
2561
2562 OP *
2563 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl)
2564 {
2565     PMOP *pm;
2566     LOGOP *rcop;
2567     I32 repl_has_vars = 0;
2568
2569     if (o->op_type == OP_TRANS)
2570         return pmtrans(o, expr, repl);
2571
2572     PL_hints |= HINT_BLOCK_SCOPE;
2573     pm = (PMOP*)o;
2574
2575     if (expr->op_type == OP_CONST) {
2576         STRLEN plen;
2577         SV *pat = ((SVOP*)expr)->op_sv;
2578         char *p = SvPV(pat, plen);
2579         if ((o->op_flags & OPf_SPECIAL) && strEQ(p, " ")) {
2580             sv_setpvn(pat, "\\s+", 3);
2581             p = SvPV(pat, plen);
2582             pm->op_pmflags |= PMf_SKIPWHITE;
2583         }
2584         if (DO_UTF8(pat))
2585             pm->op_pmdynflags |= PMdf_UTF8;
2586         PM_SETRE(pm, CALLREGCOMP(aTHX_ p, p + plen, pm));
2587         if (strEQ("\\s+", PM_GETRE(pm)->precomp))
2588             pm->op_pmflags |= PMf_WHITE;
2589         op_free(expr);
2590     }
2591     else {
2592         if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
2593             expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
2594                             ? OP_REGCRESET
2595                             : OP_REGCMAYBE),0,expr);
2596
2597         NewOp(1101, rcop, 1, LOGOP);
2598         rcop->op_type = OP_REGCOMP;
2599         rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
2600         rcop->op_first = scalar(expr);
2601         rcop->op_flags |= ((PL_hints & HINT_RE_EVAL)
2602                            ? (OPf_SPECIAL | OPf_KIDS)
2603                            : OPf_KIDS);
2604         rcop->op_private = 1;
2605         rcop->op_other = o;
2606
2607         /* establish postfix order */
2608         if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
2609             LINKLIST(expr);
2610             rcop->op_next = expr;
2611             ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
2612         }
2613         else {
2614             rcop->op_next = LINKLIST(expr);
2615             expr->op_next = (OP*)rcop;
2616         }
2617
2618         prepend_elem(o->op_type, scalar((OP*)rcop), o);
2619     }
2620
2621     if (repl) {
2622         OP *curop;
2623         if (pm->op_pmflags & PMf_EVAL) {
2624             curop = 0;
2625             if (CopLINE(PL_curcop) < PL_multi_end)
2626                 CopLINE_set(PL_curcop, (line_t)PL_multi_end);
2627         }
2628         else if (repl->op_type == OP_CONST)
2629             curop = repl;
2630         else {
2631             OP *lastop = 0;
2632             for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
2633                 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
2634                     if (curop->op_type == OP_GV) {
2635                         GV *gv = cGVOPx_gv(curop);
2636                         repl_has_vars = 1;
2637                         if (strchr("&`'123456789+", *GvENAME(gv)))
2638                             break;
2639                     }
2640                     else if (curop->op_type == OP_RV2CV)
2641                         break;
2642                     else if (curop->op_type == OP_RV2SV ||
2643                              curop->op_type == OP_RV2AV ||
2644                              curop->op_type == OP_RV2HV ||
2645                              curop->op_type == OP_RV2GV) {
2646                         if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
2647                             break;
2648                     }
2649                     else if (curop->op_type == OP_PADSV ||
2650                              curop->op_type == OP_PADAV ||
2651                              curop->op_type == OP_PADHV ||
2652                              curop->op_type == OP_PADANY) {
2653                         repl_has_vars = 1;
2654                     }
2655                     else if (curop->op_type == OP_PUSHRE)
2656                         ; /* Okay here, dangerous in newASSIGNOP */
2657                     else
2658                         break;
2659                 }
2660                 lastop = curop;
2661             }
2662         }
2663         if (curop == repl
2664             && !(repl_has_vars
2665                  && (!PM_GETRE(pm)
2666                      || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
2667             pm->op_pmflags |= PMf_CONST;        /* const for long enough */
2668             pm->op_pmpermflags |= PMf_CONST;    /* const for long enough */
2669             prepend_elem(o->op_type, scalar(repl), o);
2670         }
2671         else {
2672             if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
2673                 pm->op_pmflags |= PMf_MAYBE_CONST;
2674                 pm->op_pmpermflags |= PMf_MAYBE_CONST;
2675             }
2676             NewOp(1101, rcop, 1, LOGOP);
2677             rcop->op_type = OP_SUBSTCONT;
2678             rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
2679             rcop->op_first = scalar(repl);
2680             rcop->op_flags |= OPf_KIDS;
2681             rcop->op_private = 1;
2682             rcop->op_other = o;
2683
2684             /* establish postfix order */
2685             rcop->op_next = LINKLIST(repl);
2686             repl->op_next = (OP*)rcop;
2687
2688             pm->op_pmreplroot = scalar((OP*)rcop);
2689             pm->op_pmreplstart = LINKLIST(rcop);
2690             rcop->op_next = 0;
2691         }
2692     }
2693
2694     return (OP*)pm;
2695 }
2696
2697 OP *
2698 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
2699 {
2700     SVOP *svop;
2701     NewOp(1101, svop, 1, SVOP);
2702     svop->op_type = (OPCODE)type;
2703     svop->op_ppaddr = PL_ppaddr[type];
2704     svop->op_sv = sv;
2705     svop->op_next = (OP*)svop;
2706     svop->op_flags = (U8)flags;
2707     if (PL_opargs[type] & OA_RETSCALAR)
2708         scalar((OP*)svop);
2709     if (PL_opargs[type] & OA_TARGET)
2710         svop->op_targ = pad_alloc(type, SVs_PADTMP);
2711     return CHECKOP(type, svop);
2712 }
2713
2714 OP *
2715 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
2716 {
2717     PADOP *padop;
2718     NewOp(1101, padop, 1, PADOP);
2719     padop->op_type = (OPCODE)type;
2720     padop->op_ppaddr = PL_ppaddr[type];
2721     padop->op_padix = pad_alloc(type, SVs_PADTMP);
2722     SvREFCNT_dec(PAD_SVl(padop->op_padix));
2723     PAD_SETSV(padop->op_padix, sv);
2724     if (sv)
2725         SvPADTMP_on(sv);
2726     padop->op_next = (OP*)padop;
2727     padop->op_flags = (U8)flags;
2728     if (PL_opargs[type] & OA_RETSCALAR)
2729         scalar((OP*)padop);
2730     if (PL_opargs[type] & OA_TARGET)
2731         padop->op_targ = pad_alloc(type, SVs_PADTMP);
2732     return CHECKOP(type, padop);
2733 }
2734
2735 OP *
2736 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
2737 {
2738 #ifdef USE_ITHREADS
2739     if (gv)
2740         GvIN_PAD_on(gv);
2741     return newPADOP(type, flags, SvREFCNT_inc(gv));
2742 #else
2743     return newSVOP(type, flags, SvREFCNT_inc(gv));
2744 #endif
2745 }
2746
2747 OP *
2748 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
2749 {
2750     PVOP *pvop;
2751     NewOp(1101, pvop, 1, PVOP);
2752     pvop->op_type = (OPCODE)type;
2753     pvop->op_ppaddr = PL_ppaddr[type];
2754     pvop->op_pv = pv;
2755     pvop->op_next = (OP*)pvop;
2756     pvop->op_flags = (U8)flags;
2757     if (PL_opargs[type] & OA_RETSCALAR)
2758         scalar((OP*)pvop);
2759     if (PL_opargs[type] & OA_TARGET)
2760         pvop->op_targ = pad_alloc(type, SVs_PADTMP);
2761     return CHECKOP(type, pvop);
2762 }
2763
2764 void
2765 Perl_package(pTHX_ OP *o)
2766 {
2767     char *name;
2768     STRLEN len;
2769
2770     save_hptr(&PL_curstash);
2771     save_item(PL_curstname);
2772
2773     name = SvPV(cSVOPo->op_sv, len);
2774     PL_curstash = gv_stashpvn(name, len, TRUE);
2775     sv_setpvn(PL_curstname, name, len);
2776     op_free(o);
2777
2778     PL_hints |= HINT_BLOCK_SCOPE;
2779     PL_copline = NOLINE;
2780     PL_expect = XSTATE;
2781 }
2782
2783 void
2784 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg)
2785 {
2786     OP *pack;
2787     OP *imop;
2788     OP *veop;
2789
2790     if (id->op_type != OP_CONST)
2791         Perl_croak(aTHX_ "Module name must be constant");
2792
2793     veop = Nullop;
2794
2795     if (version != Nullop) {
2796         SV *vesv = ((SVOP*)version)->op_sv;
2797
2798         if (arg == Nullop && !SvNIOKp(vesv)) {
2799             arg = version;
2800         }
2801         else {
2802             OP *pack;
2803             SV *meth;
2804
2805             if (version->op_type != OP_CONST || !SvNIOKp(vesv))
2806                 Perl_croak(aTHX_ "Version number must be constant number");
2807
2808             /* Make copy of id so we don't free it twice */
2809             pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
2810
2811             /* Fake up a method call to VERSION */
2812             meth = newSVpvn("VERSION",7);
2813             sv_upgrade(meth, SVt_PVIV);
2814             (void)SvIOK_on(meth);
2815             PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
2816             veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
2817                             append_elem(OP_LIST,
2818                                         prepend_elem(OP_LIST, pack, list(version)),
2819                                         newSVOP(OP_METHOD_NAMED, 0, meth)));
2820         }
2821     }
2822
2823     /* Fake up an import/unimport */
2824     if (arg && arg->op_type == OP_STUB)
2825         imop = arg;             /* no import on explicit () */
2826     else if (SvNIOKp(((SVOP*)id)->op_sv)) {
2827         imop = Nullop;          /* use 5.0; */
2828     }
2829     else {
2830         SV *meth;
2831
2832         /* Make copy of id so we don't free it twice */
2833         pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
2834
2835         /* Fake up a method call to import/unimport */
2836         meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);
2837         (void)SvUPGRADE(meth, SVt_PVIV);
2838         (void)SvIOK_on(meth);
2839         PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
2840         imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
2841                        append_elem(OP_LIST,
2842                                    prepend_elem(OP_LIST, pack, list(arg)),
2843                                    newSVOP(OP_METHOD_NAMED, 0, meth)));
2844     }
2845
2846     /* Fake up the BEGIN {}, which does its thing immediately. */
2847     newATTRSUB(floor,
2848         newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
2849         Nullop,
2850         Nullop,
2851         append_elem(OP_LINESEQ,
2852             append_elem(OP_LINESEQ,
2853                 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, id)),
2854                 newSTATEOP(0, Nullch, veop)),
2855             newSTATEOP(0, Nullch, imop) ));
2856
2857     /* The "did you use incorrect case?" warning used to be here.
2858      * The problem is that on case-insensitive filesystems one
2859      * might get false positives for "use" (and "require"):
2860      * "use Strict" or "require CARP" will work.  This causes
2861      * portability problems for the script: in case-strict
2862      * filesystems the script will stop working.
2863      *
2864      * The "incorrect case" warning checked whether "use Foo"
2865      * imported "Foo" to your namespace, but that is wrong, too:
2866      * there is no requirement nor promise in the language that
2867      * a Foo.pm should or would contain anything in package "Foo".
2868      *
2869      * There is very little Configure-wise that can be done, either:
2870      * the case-sensitivity of the build filesystem of Perl does not
2871      * help in guessing the case-sensitivity of the runtime environment.
2872      */
2873
2874     PL_hints |= HINT_BLOCK_SCOPE;
2875     PL_copline = NOLINE;
2876     PL_expect = XSTATE;
2877 }
2878
2879 /*
2880 =head1 Embedding Functions
2881
2882 =for apidoc load_module
2883
2884 Loads the module whose name is pointed to by the string part of name.
2885 Note that the actual module name, not its filename, should be given.
2886 Eg, "Foo::Bar" instead of "Foo/Bar.pm".  flags can be any of
2887 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
2888 (or 0 for no flags). ver, if specified, provides version semantics
2889 similar to C<use Foo::Bar VERSION>.  The optional trailing SV*
2890 arguments can be used to specify arguments to the module's import()
2891 method, similar to C<use Foo::Bar VERSION LIST>.
2892
2893 =cut */
2894
2895 void
2896 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
2897 {
2898     va_list args;
2899     va_start(args, ver);
2900     vload_module(flags, name, ver, &args);
2901     va_end(args);
2902 }
2903
2904 #ifdef PERL_IMPLICIT_CONTEXT
2905 void
2906 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
2907 {
2908     dTHX;
2909     va_list args;
2910     va_start(args, ver);
2911     vload_module(flags, name, ver, &args);
2912     va_end(args);
2913 }
2914 #endif
2915
2916 void
2917 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
2918 {
2919     OP *modname, *veop, *imop;
2920
2921     modname = newSVOP(OP_CONST, 0, name);
2922     modname->op_private |= OPpCONST_BARE;
2923     if (ver) {
2924         veop = newSVOP(OP_CONST, 0, ver);
2925     }
2926     else
2927         veop = Nullop;
2928     if (flags & PERL_LOADMOD_NOIMPORT) {
2929         imop = sawparens(newNULLLIST());
2930     }
2931     else if (flags & PERL_LOADMOD_IMPORT_OPS) {
2932         imop = va_arg(*args, OP*);
2933     }
2934     else {
2935         SV *sv;
2936         imop = Nullop;
2937         sv = va_arg(*args, SV*);
2938         while (sv) {
2939             imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
2940             sv = va_arg(*args, SV*);
2941         }
2942     }
2943     {
2944         line_t ocopline = PL_copline;
2945         COP *ocurcop = PL_curcop;
2946         int oexpect = PL_expect;
2947
2948         utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
2949                 veop, modname, imop);
2950         PL_expect = oexpect;
2951         PL_copline = ocopline;
2952         PL_curcop = ocurcop;
2953     }
2954 }
2955
2956 OP *
2957 Perl_dofile(pTHX_ OP *term)
2958 {
2959     OP *doop;
2960     GV *gv;
2961
2962     gv = gv_fetchpv("do", FALSE, SVt_PVCV);
2963     if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
2964         gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
2965
2966     if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
2967         doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
2968                                append_elem(OP_LIST, term,
2969                                            scalar(newUNOP(OP_RV2CV, 0,
2970                                                           newGVOP(OP_GV, 0,
2971                                                                   gv))))));
2972     }
2973     else {
2974         doop = newUNOP(OP_DOFILE, 0, scalar(term));
2975     }
2976     return doop;
2977 }
2978
2979 OP *
2980 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
2981 {
2982     return newBINOP(OP_LSLICE, flags,
2983             list(force_list(subscript)),
2984             list(force_list(listval)) );
2985 }
2986
2987 STATIC I32
2988 S_list_assignment(pTHX_ register OP *o)
2989 {
2990     if (!o)
2991         return TRUE;
2992
2993     if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
2994         o = cUNOPo->op_first;
2995
2996     if (o->op_type == OP_COND_EXPR) {
2997         I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
2998         I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
2999
3000         if (t && f)
3001             return TRUE;
3002         if (t || f)
3003             yyerror("Assignment to both a list and a scalar");
3004         return FALSE;
3005     }
3006
3007     if (o->op_type == OP_LIST &&
3008         (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR &&
3009         o->op_private & OPpLVAL_INTRO)
3010         return FALSE;
3011
3012     if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3013         o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3014         o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3015         return TRUE;
3016
3017     if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3018         return TRUE;
3019
3020     if (o->op_type == OP_RV2SV)
3021         return FALSE;
3022
3023     return FALSE;
3024 }
3025
3026 OP *
3027 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3028 {
3029     OP *o;
3030
3031     if (optype) {
3032         if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
3033             return newLOGOP(optype, 0,
3034                 mod(scalar(left), optype),
3035                 newUNOP(OP_SASSIGN, 0, scalar(right)));
3036         }
3037         else {
3038             return newBINOP(optype, OPf_STACKED,
3039                 mod(scalar(left), optype), scalar(right));
3040         }
3041     }
3042
3043     if (list_assignment(left)) {
3044         OP *curop;
3045
3046         PL_modcount = 0;
3047         PL_eval_start = right;  /* Grandfathering $[ assignment here.  Bletch.*/
3048         left = mod(left, OP_AASSIGN);
3049         if (PL_eval_start)
3050             PL_eval_start = 0;
3051         else {
3052             op_free(left);
3053             op_free(right);
3054             return Nullop;
3055         }
3056         curop = list(force_list(left));
3057         o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3058         o->op_private = (U8)(0 | (flags >> 8));
3059
3060         /* PL_generation sorcery:
3061          * an assignment like ($a,$b) = ($c,$d) is easier than
3062          * ($a,$b) = ($c,$a), since there is no need for temporary vars.
3063          * To detect whether there are common vars, the global var
3064          * PL_generation is incremented for each assign op we compile.
3065          * Then, while compiling the assign op, we run through all the
3066          * variables on both sides of the assignment, setting a spare slot
3067          * in each of them to PL_generation. If any of them already have
3068          * that value, we know we've got commonality.  We could use a
3069          * single bit marker, but then we'd have to make 2 passes, first
3070          * to clear the flag, then to test and set it.  To find somewhere
3071          * to store these values, evil chicanery is done with SvCUR().
3072          */
3073
3074         if (!(left->op_private & OPpLVAL_INTRO)) {
3075             OP *lastop = o;
3076             PL_generation++;
3077             for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3078                 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3079                     if (curop->op_type == OP_GV) {
3080                         GV *gv = cGVOPx_gv(curop);
3081                         if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3082                             break;
3083                         SvCUR(gv) = PL_generation;
3084                     }
3085                     else if (curop->op_type == OP_PADSV ||
3086                              curop->op_type == OP_PADAV ||
3087                              curop->op_type == OP_PADHV ||
3088                              curop->op_type == OP_PADANY)
3089                     {
3090                         if (PAD_COMPNAME_GEN(curop->op_targ)
3091                                                     == (STRLEN)PL_generation)
3092                             break;
3093                         PAD_COMPNAME_GEN(curop->op_targ)
3094                                                         = PL_generation;
3095
3096                     }
3097                     else if (curop->op_type == OP_RV2CV)
3098                         break;
3099                     else if (curop->op_type == OP_RV2SV ||
3100                              curop->op_type == OP_RV2AV ||
3101                              curop->op_type == OP_RV2HV ||
3102                              curop->op_type == OP_RV2GV) {
3103                         if (lastop->op_type != OP_GV)   /* funny deref? */
3104                             break;
3105                     }
3106                     else if (curop->op_type == OP_PUSHRE) {
3107                         if (((PMOP*)curop)->op_pmreplroot) {
3108 #ifdef USE_ITHREADS
3109                             GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET,
3110                                         ((PMOP*)curop)->op_pmreplroot));
3111 #else
3112                             GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3113 #endif
3114                             if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3115                                 break;
3116                             SvCUR(gv) = PL_generation;
3117                         }
3118                     }
3119                     else
3120                         break;
3121                 }
3122                 lastop = curop;
3123             }
3124             if (curop != o)
3125                 o->op_private |= OPpASSIGN_COMMON;
3126         }
3127         if (right && right->op_type == OP_SPLIT) {
3128             OP* tmpop;
3129             if ((tmpop = ((LISTOP*)right)->op_first) &&
3130                 tmpop->op_type == OP_PUSHRE)
3131             {
3132                 PMOP *pm = (PMOP*)tmpop;
3133                 if (left->op_type == OP_RV2AV &&
3134                     !(left->op_private & OPpLVAL_INTRO) &&
3135                     !(o->op_private & OPpASSIGN_COMMON) )
3136                 {
3137                     tmpop = ((UNOP*)left)->op_first;
3138                     if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3139 #ifdef USE_ITHREADS
3140                         pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
3141                         cPADOPx(tmpop)->op_padix = 0;   /* steal it */
3142 #else
3143                         pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3144                         cSVOPx(tmpop)->op_sv = Nullsv;  /* steal it */
3145 #endif
3146                         pm->op_pmflags |= PMf_ONCE;
3147                         tmpop = cUNOPo->op_first;       /* to list (nulled) */
3148                         tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3149                         tmpop->op_sibling = Nullop;     /* don't free split */
3150                         right->op_next = tmpop->op_next;  /* fix starting loc */
3151                         op_free(o);                     /* blow off assign */
3152                         right->op_flags &= ~OPf_WANT;
3153                                 /* "I don't know and I don't care." */
3154                         return right;
3155                     }
3156                 }
3157                 else {
3158                    if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3159                       ((LISTOP*)right)->op_last->op_type == OP_CONST)
3160                     {
3161                         SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3162                         if (SvIVX(sv) == 0)
3163                             sv_setiv(sv, PL_modcount+1);
3164                     }
3165                 }
3166             }
3167         }
3168         return o;
3169     }
3170     if (!right)
3171         right = newOP(OP_UNDEF, 0);
3172     if (right->op_type == OP_READLINE) {
3173         right->op_flags |= OPf_STACKED;
3174         return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3175     }
3176     else {
3177         PL_eval_start = right;  /* Grandfathering $[ assignment here.  Bletch.*/
3178         o = newBINOP(OP_SASSIGN, flags,
3179             scalar(right), mod(scalar(left), OP_SASSIGN) );
3180         if (PL_eval_start)
3181             PL_eval_start = 0;
3182         else {
3183             op_free(o);
3184             return Nullop;
3185         }
3186     }
3187     return o;
3188 }
3189
3190 OP *
3191 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3192 {
3193     U32 seq = intro_my();
3194     register COP *cop;
3195
3196     NewOp(1101, cop, 1, COP);
3197     if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3198         cop->op_type = OP_DBSTATE;
3199         cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3200     }
3201     else {
3202         cop->op_type = OP_NEXTSTATE;
3203         cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3204     }
3205     cop->op_flags = (U8)flags;
3206     cop->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
3207 #ifdef NATIVE_HINTS
3208     cop->op_private |= NATIVE_HINTS;
3209 #endif
3210     PL_compiling.op_private = cop->op_private;
3211     cop->op_next = (OP*)cop;
3212
3213     if (label) {
3214         cop->cop_label = label;
3215         PL_hints |= HINT_BLOCK_SCOPE;
3216     }
3217     cop->cop_seq = seq;
3218     cop->cop_arybase = PL_curcop->cop_arybase;
3219     if (specialWARN(PL_curcop->cop_warnings))
3220         cop->cop_warnings = PL_curcop->cop_warnings ;
3221     else
3222         cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3223     if (specialCopIO(PL_curcop->cop_io))
3224         cop->cop_io = PL_curcop->cop_io;
3225     else
3226         cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3227
3228
3229     if (PL_copline == NOLINE)
3230         CopLINE_set(cop, CopLINE(PL_curcop));
3231     else {
3232         CopLINE_set(cop, PL_copline);
3233         PL_copline = NOLINE;
3234     }
3235 #ifdef USE_ITHREADS
3236     CopFILE_set(cop, CopFILE(PL_curcop));       /* XXX share in a pvtable? */
3237 #else
3238     CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3239 #endif
3240     CopSTASH_set(cop, PL_curstash);
3241
3242     if (PERLDB_LINE && PL_curstash != PL_debstash) {
3243         SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3244         if (svp && *svp != &PL_sv_undef ) {
3245            (void)SvIOK_on(*svp);
3246             SvIVX(*svp) = PTR2IV(cop);
3247         }
3248     }
3249
3250     return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3251 }
3252
3253
3254 OP *
3255 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3256 {
3257     return new_logop(type, flags, &first, &other);
3258 }
3259
3260 STATIC OP *
3261 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3262 {
3263     LOGOP *logop;
3264     OP *o;
3265     OP *first = *firstp;
3266     OP *other = *otherp;
3267
3268     if (type == OP_XOR)         /* Not short circuit, but here by precedence. */
3269         return newBINOP(type, flags, scalar(first), scalar(other));
3270
3271     scalarboolean(first);
3272     /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3273     if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3274         if (type == OP_AND || type == OP_OR) {
3275             if (type == OP_AND)
3276                 type = OP_OR;
3277             else
3278                 type = OP_AND;
3279             o = first;
3280             first = *firstp = cUNOPo->op_first;
3281             if (o->op_next)
3282                 first->op_next = o->op_next;
3283             cUNOPo->op_first = Nullop;
3284             op_free(o);
3285         }
3286     }
3287     if (first->op_type == OP_CONST) {
3288         if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE)) {
3289             if (first->op_private & OPpCONST_STRICT)
3290                 no_bareword_allowed(first);
3291             else
3292                 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
3293         }
3294         if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
3295             op_free(first);
3296             *firstp = Nullop;
3297             return other;
3298         }
3299         else {
3300             op_free(other);
3301             *otherp = Nullop;
3302             return first;
3303         }
3304     }
3305     else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS)) {
3306         OP *k1 = ((UNOP*)first)->op_first;
3307         OP *k2 = k1->op_sibling;
3308         OPCODE warnop = 0;
3309         switch (first->op_type)
3310         {
3311         case OP_NULL:
3312             if (k2 && k2->op_type == OP_READLINE
3313                   && (k2->op_flags & OPf_STACKED)
3314                   && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3315             {
3316                 warnop = k2->op_type;
3317             }
3318             break;
3319
3320         case OP_SASSIGN:
3321             if (k1->op_type == OP_READDIR
3322                   || k1->op_type == OP_GLOB
3323                   || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3324                   || k1->op_type == OP_EACH)
3325             {
3326                 warnop = ((k1->op_type == OP_NULL)
3327                           ? (OPCODE)k1->op_targ : k1->op_type);
3328             }
3329             break;
3330         }
3331         if (warnop) {
3332             line_t oldline = CopLINE(PL_curcop);
3333             CopLINE_set(PL_curcop, PL_copline);
3334             Perl_warner(aTHX_ packWARN(WARN_MISC),
3335                  "Value of %s%s can be \"0\"; test with defined()",
3336                  PL_op_desc[warnop],
3337                  ((warnop == OP_READLINE || warnop == OP_GLOB)
3338                   ? " construct" : "() operator"));
3339             CopLINE_set(PL_curcop, oldline);
3340         }
3341     }
3342
3343     if (!other)
3344         return first;
3345
3346     if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
3347         other->op_private |= OPpASSIGN_BACKWARDS;  /* other is an OP_SASSIGN */
3348
3349     NewOp(1101, logop, 1, LOGOP);
3350
3351     logop->op_type = (OPCODE)type;
3352     logop->op_ppaddr = PL_ppaddr[type];
3353     logop->op_first = first;
3354     logop->op_flags = flags | OPf_KIDS;
3355     logop->op_other = LINKLIST(other);
3356     logop->op_private = (U8)(1 | (flags >> 8));
3357
3358     /* establish postfix order */
3359     logop->op_next = LINKLIST(first);
3360     first->op_next = (OP*)logop;
3361     first->op_sibling = other;
3362
3363     o = newUNOP(OP_NULL, 0, (OP*)logop);
3364     other->op_next = o;
3365
3366     return o;
3367 }
3368
3369 OP *
3370 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3371 {
3372     LOGOP *logop;
3373     OP *start;
3374     OP *o;
3375
3376     if (!falseop)
3377         return newLOGOP(OP_AND, 0, first, trueop);
3378     if (!trueop)
3379         return newLOGOP(OP_OR, 0, first, falseop);
3380
3381     scalarboolean(first);
3382     if (first->op_type == OP_CONST) {
3383         if (first->op_private & OPpCONST_BARE &&
3384            first->op_private & OPpCONST_STRICT) {
3385            no_bareword_allowed(first);
3386        }
3387         if (SvTRUE(((SVOP*)first)->op_sv)) {
3388             op_free(first);
3389             op_free(falseop);
3390             return trueop;
3391         }
3392         else {
3393             op_free(first);
3394             op_free(trueop);
3395             return falseop;
3396         }
3397     }
3398     NewOp(1101, logop, 1, LOGOP);
3399     logop->op_type = OP_COND_EXPR;
3400     logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3401     logop->op_first = first;
3402     logop->op_flags = flags | OPf_KIDS;
3403     logop->op_private = (U8)(1 | (flags >> 8));
3404     logop->op_other = LINKLIST(trueop);
3405     logop->op_next = LINKLIST(falseop);
3406
3407
3408     /* establish postfix order */
3409     start = LINKLIST(first);
3410     first->op_next = (OP*)logop;
3411
3412     first->op_sibling = trueop;
3413     trueop->op_sibling = falseop;
3414     o = newUNOP(OP_NULL, 0, (OP*)logop);
3415
3416     trueop->op_next = falseop->op_next = o;
3417
3418     o->op_next = start;
3419     return o;
3420 }
3421
3422 OP *
3423 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3424 {
3425     LOGOP *range;
3426     OP *flip;
3427     OP *flop;
3428     OP *leftstart;
3429     OP *o;
3430
3431     NewOp(1101, range, 1, LOGOP);
3432
3433     range->op_type = OP_RANGE;
3434     range->op_ppaddr = PL_ppaddr[OP_RANGE];
3435     range->op_first = left;
3436     range->op_flags = OPf_KIDS;
3437     leftstart = LINKLIST(left);
3438     range->op_other = LINKLIST(right);
3439     range->op_private = (U8)(1 | (flags >> 8));
3440
3441     left->op_sibling = right;
3442
3443     range->op_next = (OP*)range;
3444     flip = newUNOP(OP_FLIP, flags, (OP*)range);
3445     flop = newUNOP(OP_FLOP, 0, flip);
3446     o = newUNOP(OP_NULL, 0, flop);
3447     linklist(flop);
3448     range->op_next = leftstart;
3449
3450     left->op_next = flip;
3451     right->op_next = flop;
3452
3453     range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3454     sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3455     flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3456     sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3457
3458     flip->op_private =  left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3459     flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3460
3461     flip->op_next = o;
3462     if (!flip->op_private || !flop->op_private)
3463         linklist(o);            /* blow off optimizer unless constant */
3464
3465     return o;
3466 }
3467
3468 OP *
3469 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3470 {
3471     OP* listop;
3472     OP* o;
3473     int once = block && block->op_flags & OPf_SPECIAL &&
3474       (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3475
3476     if (expr) {
3477         if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3478             return block;       /* do {} while 0 does once */
3479         if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3480             || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3481             expr = newUNOP(OP_DEFINED, 0,
3482                 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3483         } else if (expr->op_flags & OPf_KIDS) {
3484             OP *k1 = ((UNOP*)expr)->op_first;
3485             OP *k2 = (k1) ? k1->op_sibling : NULL;
3486             switch (expr->op_type) {
3487               case OP_NULL:
3488                 if (k2 && k2->op_type == OP_READLINE
3489                       && (k2->op_flags & OPf_STACKED)
3490                       && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3491                     expr = newUNOP(OP_DEFINED, 0, expr);
3492                 break;
3493
3494               case OP_SASSIGN:
3495                 if (k1->op_type == OP_READDIR
3496                       || k1->op_type == OP_GLOB
3497                       || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3498                       || k1->op_type == OP_EACH)
3499                     expr = newUNOP(OP_DEFINED, 0, expr);
3500                 break;
3501             }
3502         }
3503     }
3504
3505     listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3506     o = new_logop(OP_AND, 0, &expr, &listop);
3507
3508     if (listop)
3509         ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3510
3511     if (once && o != listop)
3512         o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3513
3514     if (o == listop)
3515         o = newUNOP(OP_NULL, 0, o);     /* or do {} while 1 loses outer block */
3516
3517     o->op_flags |= flags;
3518     o = scope(o);
3519     o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3520     return o;
3521 }
3522
3523 OP *
3524 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
3525 {
3526     OP *redo;
3527     OP *next = 0;
3528     OP *listop;
3529     OP *o;
3530     U8 loopflags = 0;
3531
3532     if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3533                  || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
3534         expr = newUNOP(OP_DEFINED, 0,
3535             newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3536     } else if (expr && (expr->op_flags & OPf_KIDS)) {
3537         OP *k1 = ((UNOP*)expr)->op_first;
3538         OP *k2 = (k1) ? k1->op_sibling : NULL;
3539         switch (expr->op_type) {
3540           case OP_NULL:
3541             if (k2 && k2->op_type == OP_READLINE
3542                   && (k2->op_flags & OPf_STACKED)
3543                   && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3544                 expr = newUNOP(OP_DEFINED, 0, expr);
3545             break;
3546
3547           case OP_SASSIGN:
3548             if (k1->op_type == OP_READDIR
3549                   || k1->op_type == OP_GLOB
3550                   || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3551                   || k1->op_type == OP_EACH)
3552                 expr = newUNOP(OP_DEFINED, 0, expr);
3553             break;
3554         }
3555     }
3556
3557     if (!block)
3558         block = newOP(OP_NULL, 0);
3559     else if (cont) {
3560         block = scope(block);
3561     }
3562
3563     if (cont) {
3564         next = LINKLIST(cont);
3565     }
3566     if (expr) {
3567         OP *unstack = newOP(OP_UNSTACK, 0);
3568         if (!next)
3569             next = unstack;
3570         cont = append_elem(OP_LINESEQ, cont, unstack);
3571         if ((line_t)whileline != NOLINE) {
3572             PL_copline = (line_t)whileline;
3573             cont = append_elem(OP_LINESEQ, cont,
3574                                newSTATEOP(0, Nullch, Nullop));
3575         }
3576     }
3577
3578     listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
3579     redo = LINKLIST(listop);
3580
3581     if (expr) {
3582         PL_copline = (line_t)whileline;
3583         scalar(listop);
3584         o = new_logop(OP_AND, 0, &expr, &listop);
3585         if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
3586             op_free(expr);              /* oops, it's a while (0) */
3587             op_free((OP*)loop);
3588             return Nullop;              /* listop already freed by new_logop */
3589         }
3590         if (listop)
3591             ((LISTOP*)listop)->op_last->op_next =
3592                 (o == listop ? redo : LINKLIST(o));
3593     }
3594     else
3595         o = listop;
3596
3597     if (!loop) {
3598         NewOp(1101,loop,1,LOOP);
3599         loop->op_type = OP_ENTERLOOP;
3600         loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
3601         loop->op_private = 0;
3602         loop->op_next = (OP*)loop;
3603     }
3604
3605     o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
3606
3607     loop->op_redoop = redo;
3608     loop->op_lastop = o;
3609     o->op_private |= loopflags;
3610
3611     if (next)
3612         loop->op_nextop = next;
3613     else
3614         loop->op_nextop = o;
3615
3616     o->op_flags |= flags;
3617     o->op_private |= (flags >> 8);
3618     return o;
3619 }
3620
3621 OP *
3622 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
3623 {
3624     LOOP *loop;
3625     OP *wop;
3626     PADOFFSET padoff = 0;
3627     I32 iterflags = 0;
3628
3629     if (sv) {
3630         if (sv->op_type == OP_RV2SV) {  /* symbol table variable */
3631             sv->op_type = OP_RV2GV;
3632             sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
3633         }
3634         else if (sv->op_type == OP_PADSV) { /* private variable */
3635             padoff = sv->op_targ;
3636             sv->op_targ = 0;
3637             op_free(sv);
3638             sv = Nullop;
3639         }
3640         else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
3641             padoff = sv->op_targ;
3642             sv->op_targ = 0;
3643             iterflags |= OPf_SPECIAL;
3644             op_free(sv);
3645             sv = Nullop;
3646         }
3647         else
3648             Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
3649     }
3650     else {
3651         sv = newGVOP(OP_GV, 0, PL_defgv);
3652     }
3653     if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
3654         expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
3655         iterflags |= OPf_STACKED;
3656     }
3657     else if (expr->op_type == OP_NULL &&
3658              (expr->op_flags & OPf_KIDS) &&
3659              ((BINOP*)expr)->op_first->op_type == OP_FLOP)
3660     {
3661         /* Basically turn for($x..$y) into the same as for($x,$y), but we
3662          * set the STACKED flag to indicate that these values are to be
3663          * treated as min/max values by 'pp_iterinit'.
3664          */
3665         UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
3666         LOGOP* range = (LOGOP*) flip->op_first;
3667         OP* left  = range->op_first;
3668         OP* right = left->op_sibling;
3669         LISTOP* listop;
3670
3671         range->op_flags &= ~OPf_KIDS;
3672         range->op_first = Nullop;
3673
3674         listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
3675         listop->op_first->op_next = range->op_next;
3676         left->op_next = range->op_other;
3677         right->op_next = (OP*)listop;
3678         listop->op_next = listop->op_first;
3679
3680         op_free(expr);
3681         expr = (OP*)(listop);
3682         op_null(expr);
3683         iterflags |= OPf_STACKED;
3684     }
3685     else {
3686         expr = mod(force_list(expr), OP_GREPSTART);
3687     }
3688
3689
3690     loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
3691                                append_elem(OP_LIST, expr, scalar(sv))));
3692     assert(!loop->op_next);
3693 #ifdef PL_OP_SLAB_ALLOC
3694     {
3695         LOOP *tmp;
3696         NewOp(1234,tmp,1,LOOP);
3697         Copy(loop,tmp,1,LOOP);
3698         FreeOp(loop);
3699         loop = tmp;
3700     }
3701 #else
3702     Renew(loop, 1, LOOP);
3703 #endif
3704     loop->op_targ = padoff;
3705     wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
3706     PL_copline = forline;
3707     return newSTATEOP(0, label, wop);
3708 }
3709
3710 OP*
3711 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
3712 {
3713     OP *o;
3714     STRLEN n_a;
3715
3716     if (type != OP_GOTO || label->op_type == OP_CONST) {
3717         /* "last()" means "last" */
3718         if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
3719             o = newOP(type, OPf_SPECIAL);
3720         else {
3721             o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
3722                                         ? SvPVx(((SVOP*)label)->op_sv, n_a)
3723                                         : ""));
3724         }
3725         op_free(label);
3726     }
3727     else {
3728         if (label->op_type == OP_ENTERSUB)
3729             label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
3730         o = newUNOP(type, OPf_STACKED, label);
3731     }
3732     PL_hints |= HINT_BLOCK_SCOPE;
3733     return o;
3734 }
3735
3736 /*
3737 =for apidoc cv_undef
3738
3739 Clear out all the active components of a CV. This can happen either
3740 by an explicit C<undef &foo>, or by the reference count going to zero.
3741 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
3742 children can still follow the full lexical scope chain.
3743
3744 =cut
3745 */
3746
3747 void
3748 Perl_cv_undef(pTHX_ CV *cv)
3749 {
3750 #ifdef USE_ITHREADS
3751     if (CvFILE(cv) && !CvXSUB(cv)) {
3752         /* for XSUBs CvFILE point directly to static memory; __FILE__ */
3753         Safefree(CvFILE(cv));
3754     }
3755     CvFILE(cv) = 0;
3756 #endif
3757
3758     if (!CvXSUB(cv) && CvROOT(cv)) {
3759         if (CvDEPTH(cv))
3760             Perl_croak(aTHX_ "Can't undef active subroutine");
3761         ENTER;
3762
3763         PAD_SAVE_SETNULLPAD();
3764
3765         op_free(CvROOT(cv));
3766         CvROOT(cv) = Nullop;
3767         LEAVE;
3768     }
3769     SvPOK_off((SV*)cv);         /* forget prototype */
3770     CvGV(cv) = Nullgv;
3771
3772     pad_undef(cv);
3773
3774     /* remove CvOUTSIDE unless this is an undef rather than a free */
3775     if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
3776         if (!CvWEAKOUTSIDE(cv))
3777             SvREFCNT_dec(CvOUTSIDE(cv));
3778         CvOUTSIDE(cv) = Nullcv;
3779     }
3780     if (CvCONST(cv)) {
3781         SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
3782         CvCONST_off(cv);
3783     }
3784     if (CvXSUB(cv)) {
3785         CvXSUB(cv) = 0;
3786     }
3787     /* delete all flags except WEAKOUTSIDE */
3788     CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
3789 }
3790
3791 void
3792 Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
3793 {
3794     if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
3795         SV* msg = sv_newmortal();
3796         SV* name = Nullsv;
3797
3798         if (gv)
3799             gv_efullname3(name = sv_newmortal(), gv, Nullch);
3800         sv_setpv(msg, "Prototype mismatch:");
3801         if (name)
3802             Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
3803         if (SvPOK(cv))
3804             Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (SV *)cv);
3805         sv_catpv(msg, " vs ");
3806         if (p)
3807             Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
3808         else
3809             sv_catpv(msg, "none");
3810         Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, msg);
3811     }
3812 }
3813
3814 static void const_sv_xsub(pTHX_ CV* cv);
3815
3816 /*
3817
3818 =head1 Optree Manipulation Functions
3819
3820 =for apidoc cv_const_sv
3821
3822 If C<cv> is a constant sub eligible for inlining. returns the constant
3823 value returned by the sub.  Otherwise, returns NULL.
3824
3825 Constant subs can be created with C<newCONSTSUB> or as described in
3826 L<perlsub/"Constant Functions">.
3827
3828 =cut
3829 */
3830 SV *
3831 Perl_cv_const_sv(pTHX_ CV *cv)
3832 {
3833     if (!cv || !CvCONST(cv))
3834         return Nullsv;
3835     return (SV*)CvXSUBANY(cv).any_ptr;
3836 }
3837
3838 SV *
3839 Perl_op_const_sv(pTHX_ OP *o, CV *cv)
3840 {
3841     SV *sv = Nullsv;
3842
3843     if (!o)
3844         return Nullsv;
3845
3846     if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
3847         o = cLISTOPo->op_first->op_sibling;
3848
3849     for (; o; o = o->op_next) {
3850         OPCODE type = o->op_type;
3851
3852         if (sv && o->op_next == o)
3853             return sv;
3854         if (o->op_next != o) {
3855             if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
3856                 continue;
3857             if (type == OP_DBSTATE)
3858                 continue;
3859         }
3860         if (type == OP_LEAVESUB || type == OP_RETURN)
3861             break;
3862         if (sv)
3863             return Nullsv;
3864         if (type == OP_CONST && cSVOPo->op_sv)
3865             sv = cSVOPo->op_sv;
3866         else if ((type == OP_PADSV || type == OP_CONST) && cv) {
3867             sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
3868             if (!sv)
3869                 return Nullsv;
3870             if (CvCONST(cv)) {
3871                 /* We get here only from cv_clone2() while creating a closure.
3872                    Copy the const value here instead of in cv_clone2 so that
3873                    SvREADONLY_on doesn't lead to problems when leaving
3874                    scope.
3875                 */
3876                 sv = newSVsv(sv);
3877             }
3878             if (!SvREADONLY(sv) && SvREFCNT(sv) > 1)
3879                 return Nullsv;
3880         }
3881         else
3882             return Nullsv;
3883     }
3884     if (sv)
3885         SvREADONLY_on(sv);
3886     return sv;
3887 }
3888
3889 void
3890 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
3891 {
3892     if (o)
3893         SAVEFREEOP(o);
3894     if (proto)
3895         SAVEFREEOP(proto);
3896     if (attrs)
3897         SAVEFREEOP(attrs);
3898     if (block)
3899         SAVEFREEOP(block);
3900     Perl_croak(aTHX_ "\"my sub\" not yet implemented");
3901 }
3902
3903 CV *
3904 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
3905 {
3906     return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
3907 }
3908
3909 CV *
3910 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
3911 {
3912     STRLEN n_a;
3913     char *name;
3914     char *aname;
3915     GV *gv;
3916     char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
3917     register CV *cv=0;
3918     SV *const_sv;
3919
3920     name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
3921     if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
3922         SV *sv = sv_newmortal();
3923         Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
3924                        PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
3925                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3926         aname = SvPVX(sv);
3927     }
3928     else
3929         aname = Nullch;
3930     gv = gv_fetchpv(name ? name : (aname ? aname :
3931                     (PL_curstash ? "__ANON__" : "__ANON__::__ANON__")),
3932                     GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
3933                     SVt_PVCV);
3934
3935     if (o)
3936         SAVEFREEOP(o);
3937     if (proto)
3938         SAVEFREEOP(proto);
3939     if (attrs)
3940         SAVEFREEOP(attrs);
3941
3942     if (SvTYPE(gv) != SVt_PVGV) {       /* Maybe prototype now, and had at
3943                                            maximum a prototype before. */
3944         if (SvTYPE(gv) > SVt_NULL) {
3945             if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
3946                 && ckWARN_d(WARN_PROTOTYPE))
3947             {
3948                 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
3949             }
3950             cv_ckproto((CV*)gv, NULL, ps);
3951         }
3952         if (ps)
3953             sv_setpv((SV*)gv, ps);
3954         else
3955             sv_setiv((SV*)gv, -1);
3956         SvREFCNT_dec(PL_compcv);
3957         cv = PL_compcv = NULL;
3958         PL_sub_generation++;
3959         goto done;
3960     }
3961
3962     cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
3963
3964 #ifdef GV_UNIQUE_CHECK
3965     if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
3966         Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
3967     }
3968 #endif
3969
3970     if (!block || !ps || *ps || attrs)
3971         const_sv = Nullsv;
3972     else
3973         const_sv = op_const_sv(block, Nullcv);
3974
3975     if (cv) {
3976         bool exists = CvROOT(cv) || CvXSUB(cv);
3977
3978 #ifdef GV_UNIQUE_CHECK
3979         if (exists && GvUNIQUE(gv)) {
3980             Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
3981         }
3982 #endif
3983
3984         /* if the subroutine doesn't exist and wasn't pre-declared
3985          * with a prototype, assume it will be AUTOLOADed,
3986          * skipping the prototype check
3987          */
3988         if (exists || SvPOK(cv))
3989             cv_ckproto(cv, gv, ps);
3990         /* already defined (or promised)? */
3991         if (exists || GvASSUMECV(gv)) {
3992             if (!block && !attrs) {
3993                 if (CvFLAGS(PL_compcv)) {
3994                     /* might have had built-in attrs applied */
3995                     CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
3996                 }
3997                 /* just a "sub foo;" when &foo is already defined */
3998                 SAVEFREESV(PL_compcv);
3999                 goto done;
4000             }
4001             /* ahem, death to those who redefine active sort subs */
4002             if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4003                 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4004             if (block) {
4005                 if (ckWARN(WARN_REDEFINE)
4006                     || (CvCONST(cv)
4007                         && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4008                 {
4009                     line_t oldline = CopLINE(PL_curcop);
4010                     if (PL_copline != NOLINE)
4011                         CopLINE_set(PL_curcop, PL_copline);
4012                     Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4013                         CvCONST(cv) ? "Constant subroutine %s redefined"
4014                                     : "Subroutine %s redefined", name);
4015                     CopLINE_set(PL_curcop, oldline);
4016                 }
4017                 SvREFCNT_dec(cv);
4018                 cv = Nullcv;
4019             }
4020         }
4021     }
4022     if (const_sv) {
4023         SvREFCNT_inc(const_sv);
4024         if (cv) {
4025             assert(!CvROOT(cv) && !CvCONST(cv));
4026             sv_setpv((SV*)cv, "");  /* prototype is "" */
4027             CvXSUBANY(cv).any_ptr = const_sv;
4028             CvXSUB(cv) = const_sv_xsub;
4029             CvCONST_on(cv);
4030         }
4031         else {
4032             GvCV(gv) = Nullcv;
4033             cv = newCONSTSUB(NULL, name, const_sv);
4034         }
4035         op_free(block);
4036         SvREFCNT_dec(PL_compcv);
4037         PL_compcv = NULL;
4038         PL_sub_generation++;
4039         goto done;
4040     }
4041     if (attrs) {
4042         HV *stash;
4043         SV *rcv;
4044
4045         /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4046          * before we clobber PL_compcv.
4047          */
4048         if (cv && !block) {
4049             rcv = (SV*)cv;
4050             /* Might have had built-in attributes applied -- propagate them. */
4051             CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4052             if (CvGV(cv) && GvSTASH(CvGV(cv)))
4053                 stash = GvSTASH(CvGV(cv));
4054             else if (CvSTASH(cv))
4055                 stash = CvSTASH(cv);
4056             else
4057                 stash = PL_curstash;
4058         }
4059         else {
4060             /* possibly about to re-define existing subr -- ignore old cv */
4061             rcv = (SV*)PL_compcv;
4062             if (name && GvSTASH(gv))
4063                 stash = GvSTASH(gv);
4064             else
4065                 stash = PL_curstash;
4066         }
4067         apply_attrs(stash, rcv, attrs, FALSE);
4068     }
4069     if (cv) {                           /* must reuse cv if autoloaded */
4070         if (!block) {
4071             /* got here with just attrs -- work done, so bug out */
4072             SAVEFREESV(PL_compcv);
4073             goto done;
4074         }
4075         /* transfer PL_compcv to cv */
4076         cv_undef(cv);
4077         CvFLAGS(cv) = CvFLAGS(PL_compcv);
4078         CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4079         CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
4080         CvOUTSIDE(PL_compcv) = 0;
4081         CvPADLIST(cv) = CvPADLIST(PL_compcv);
4082         CvPADLIST(PL_compcv) = 0;
4083         /* inner references to PL_compcv must be fixed up ... */
4084         pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
4085         /* ... before we throw it away */
4086         SvREFCNT_dec(PL_compcv);
4087         if (PERLDB_INTER)/* Advice debugger on the new sub. */
4088           ++PL_sub_generation;
4089     }
4090     else {
4091         cv = PL_compcv;
4092         if (name) {
4093             GvCV(gv) = cv;
4094             GvCVGEN(gv) = 0;
4095             PL_sub_generation++;
4096         }
4097     }
4098     CvGV(cv) = gv;
4099     CvFILE_set_from_cop(cv, PL_curcop);
4100     CvSTASH(cv) = PL_curstash;
4101
4102     if (ps)
4103         sv_setpv((SV*)cv, ps);
4104
4105     if (PL_error_count) {
4106         op_free(block);
4107         block = Nullop;
4108         if (name) {
4109             char *s = strrchr(name, ':');
4110             s = s ? s+1 : name;
4111             if (strEQ(s, "BEGIN")) {
4112                 char *not_safe =
4113                     "BEGIN not safe after errors--compilation aborted";
4114                 if (PL_in_eval & EVAL_KEEPERR)
4115                     Perl_croak(aTHX_ not_safe);
4116                 else {
4117                     /* force display of errors found but not reported */
4118                     sv_catpv(ERRSV, not_safe);
4119                     Perl_croak(aTHX_ "%"SVf, ERRSV);
4120                 }
4121             }
4122         }
4123     }
4124     if (!block)
4125         goto done;
4126
4127     if (CvLVALUE(cv)) {
4128         CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4129                              mod(scalarseq(block), OP_LEAVESUBLV));
4130     }
4131     else {
4132         CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4133     }
4134     CvROOT(cv)->op_private |= OPpREFCOUNTED;
4135     OpREFCNT_set(CvROOT(cv), 1);
4136     CvSTART(cv) = LINKLIST(CvROOT(cv));
4137     CvROOT(cv)->op_next = 0;
4138     CALL_PEEP(CvSTART(cv));
4139
4140     /* now that optimizer has done its work, adjust pad values */
4141
4142     pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
4143
4144     if (CvCLONE(cv)) {
4145         assert(!CvCONST(cv));
4146         if (ps && !*ps && op_const_sv(block, cv))
4147             CvCONST_on(cv);
4148     }
4149
4150     if (name || aname) {
4151         char *s;
4152         char *tname = (name ? name : aname);
4153
4154         if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4155             SV *sv = NEWSV(0,0);
4156             SV *tmpstr = sv_newmortal();
4157             GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4158             CV *pcv;
4159             HV *hv;
4160
4161             Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4162                            CopFILE(PL_curcop),
4163                            (long)PL_subline, (long)CopLINE(PL_curcop));
4164             gv_efullname3(tmpstr, gv, Nullch);
4165             hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
4166             hv = GvHVn(db_postponed);
4167             if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
4168                 && (pcv = GvCV(db_postponed)))
4169             {
4170                 dSP;
4171                 PUSHMARK(SP);
4172                 XPUSHs(tmpstr);
4173                 PUTBACK;
4174                 call_sv((SV*)pcv, G_DISCARD);
4175             }
4176         }
4177
4178         if ((s = strrchr(tname,':')))
4179             s++;
4180         else
4181             s = tname;
4182
4183         if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4184             goto done;
4185
4186         if (strEQ(s, "BEGIN")) {
4187             I32 oldscope = PL_scopestack_ix;
4188             ENTER;
4189             SAVECOPFILE(&PL_compiling);
4190             SAVECOPLINE(&PL_compiling);
4191
4192             if (!PL_beginav)
4193                 PL_beginav = newAV();
4194             DEBUG_x( dump_sub(gv) );
4195             av_push(PL_beginav, (SV*)cv);
4196             GvCV(gv) = 0;               /* cv has been hijacked */
4197             call_list(oldscope, PL_beginav);
4198
4199             PL_curcop = &PL_compiling;
4200             PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4201             LEAVE;
4202         }
4203         else if (strEQ(s, "END") && !PL_error_count) {
4204             if (!PL_endav)
4205                 PL_endav = newAV();
4206             DEBUG_x( dump_sub(gv) );
4207             av_unshift(PL_endav, 1);
4208             av_store(PL_endav, 0, (SV*)cv);
4209             GvCV(gv) = 0;               /* cv has been hijacked */
4210         }
4211         else if (strEQ(s, "CHECK") && !PL_error_count) {
4212             if (!PL_checkav)
4213                 PL_checkav = newAV();
4214             DEBUG_x( dump_sub(gv) );
4215             if (PL_main_start && ckWARN(WARN_VOID))
4216                 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4217             av_unshift(PL_checkav, 1);
4218             av_store(PL_checkav, 0, (SV*)cv);
4219             GvCV(gv) = 0;               /* cv has been hijacked */
4220         }
4221         else if (strEQ(s, "INIT") && !PL_error_count) {
4222             if (!PL_initav)
4223                 PL_initav = newAV();
4224             DEBUG_x( dump_sub(gv) );
4225             if (PL_main_start && ckWARN(WARN_VOID))
4226                 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4227             av_push(PL_initav, (SV*)cv);
4228             GvCV(gv) = 0;               /* cv has been hijacked */
4229         }
4230     }
4231
4232   done:
4233     PL_copline = NOLINE;
4234     LEAVE_SCOPE(floor);
4235     return cv;
4236 }
4237
4238 /* XXX unsafe for threads if eval_owner isn't held */
4239 /*
4240 =for apidoc newCONSTSUB
4241
4242 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4243 eligible for inlining at compile-time.
4244
4245 =cut
4246 */
4247
4248 CV *
4249 Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
4250 {
4251     CV* cv;
4252
4253     ENTER;
4254
4255     SAVECOPLINE(PL_curcop);
4256     CopLINE_set(PL_curcop, PL_copline);
4257
4258     SAVEHINTS();
4259     PL_hints &= ~HINT_BLOCK_SCOPE;
4260
4261     if (stash) {
4262         SAVESPTR(PL_curstash);
4263         SAVECOPSTASH(PL_curcop);
4264         PL_curstash = stash;
4265         CopSTASH_set(PL_curcop,stash);
4266     }
4267
4268     cv = newXS(name, const_sv_xsub, __FILE__);
4269     CvXSUBANY(cv).any_ptr = sv;
4270     CvCONST_on(cv);
4271     sv_setpv((SV*)cv, "");  /* prototype is "" */
4272
4273     LEAVE;
4274
4275     return cv;
4276 }
4277
4278 /*
4279 =for apidoc U||newXS
4280
4281 Used by C<xsubpp> to hook up XSUBs as Perl subs.
4282
4283 =cut
4284 */
4285
4286 CV *
4287 Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
4288 {
4289     GV *gv = gv_fetchpv(name ? name :
4290                         (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4291                         GV_ADDMULTI, SVt_PVCV);
4292     register CV *cv;
4293
4294     if (!subaddr)
4295         Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
4296
4297     if ((cv = (name ? GvCV(gv) : Nullcv))) {
4298         if (GvCVGEN(gv)) {
4299             /* just a cached method */
4300             SvREFCNT_dec(cv);
4301             cv = 0;
4302         }
4303         else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4304             /* already defined (or promised) */
4305             if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
4306                             && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
4307                 line_t oldline = CopLINE(PL_curcop);
4308                 if (PL_copline != NOLINE)
4309                     CopLINE_set(PL_curcop, PL_copline);
4310                 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4311                             CvCONST(cv) ? "Constant subroutine %s redefined"
4312                                         : "Subroutine %s redefined"
4313                             ,name);
4314                 CopLINE_set(PL_curcop, oldline);
4315             }
4316             SvREFCNT_dec(cv);
4317             cv = 0;
4318         }
4319     }
4320
4321     if (cv)                             /* must reuse cv if autoloaded */
4322         cv_undef(cv);
4323     else {
4324         cv = (CV*)NEWSV(1105,0);
4325         sv_upgrade((SV *)cv, SVt_PVCV);
4326         if (name) {
4327             GvCV(gv) = cv;
4328             GvCVGEN(gv) = 0;
4329             PL_sub_generation++;
4330         }
4331     }
4332     CvGV(cv) = gv;
4333     (void)gv_fetchfile(filename);
4334     CvFILE(cv) = filename;      /* NOTE: not copied, as it is expected to be
4335                                    an external constant string */
4336     CvXSUB(cv) = subaddr;
4337
4338     if (name) {
4339         char *s = strrchr(name,':');
4340         if (s)
4341             s++;
4342         else
4343             s = name;
4344
4345         if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4346             goto done;
4347
4348         if (strEQ(s, "BEGIN")) {
4349             if (!PL_beginav)
4350                 PL_beginav = newAV();
4351             av_push(PL_beginav, (SV*)cv);
4352             GvCV(gv) = 0;               /* cv has been hijacked */
4353         }
4354         else if (strEQ(s, "END")) {
4355             if (!PL_endav)
4356                 PL_endav = newAV();
4357             av_unshift(PL_endav, 1);
4358             av_store(PL_endav, 0, (SV*)cv);
4359             GvCV(gv) = 0;               /* cv has been hijacked */
4360         }
4361         else if (strEQ(s, "CHECK")) {
4362             if (!PL_checkav)
4363                 PL_checkav = newAV();
4364             if (PL_main_start && ckWARN(WARN_VOID))
4365                 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4366             av_unshift(PL_checkav, 1);
4367             av_store(PL_checkav, 0, (SV*)cv);
4368             GvCV(gv) = 0;               /* cv has been hijacked */
4369         }
4370         else if (strEQ(s, "INIT")) {
4371             if (!PL_initav)
4372                 PL_initav = newAV();
4373             if (PL_main_start && ckWARN(WARN_VOID))
4374                 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4375             av_push(PL_initav, (SV*)cv);
4376             GvCV(gv) = 0;               /* cv has been hijacked */
4377         }
4378     }
4379     else
4380         CvANON_on(cv);
4381
4382 done:
4383     return cv;
4384 }
4385
4386 void
4387 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
4388 {
4389     register CV *cv;
4390     char *name;
4391     GV *gv;
4392     STRLEN n_a;
4393
4394     if (o)
4395         name = SvPVx(cSVOPo->op_sv, n_a);
4396     else
4397         name = "STDOUT";
4398     gv = gv_fetchpv(name,TRUE, SVt_PVFM);
4399 #ifdef GV_UNIQUE_CHECK
4400     if (GvUNIQUE(gv)) {
4401         Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
4402     }
4403 #endif
4404     GvMULTI_on(gv);
4405     if ((cv = GvFORM(gv))) {
4406         if (ckWARN(WARN_REDEFINE)) {
4407             line_t oldline = CopLINE(PL_curcop);
4408             if (PL_copline != NOLINE)
4409                 CopLINE_set(PL_curcop, PL_copline);
4410             Perl_warner(aTHX_ packWARN(WARN_REDEFINE), "Format %s redefined",name);
4411             CopLINE_set(PL_curcop, oldline);
4412         }
4413         SvREFCNT_dec(cv);
4414     }
4415     cv = PL_compcv;
4416     GvFORM(gv) = cv;
4417     CvGV(cv) = gv;
4418     CvFILE_set_from_cop(cv, PL_curcop);
4419
4420
4421     pad_tidy(padtidy_FORMAT);
4422     CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
4423     CvROOT(cv)->op_private |= OPpREFCOUNTED;
4424     OpREFCNT_set(CvROOT(cv), 1);
4425     CvSTART(cv) = LINKLIST(CvROOT(cv));
4426     CvROOT(cv)->op_next = 0;
4427     CALL_PEEP(CvSTART(cv));
4428     op_free(o);
4429     PL_copline = NOLINE;
4430     LEAVE_SCOPE(floor);
4431 }
4432
4433 OP *
4434 Perl_newANONLIST(pTHX_ OP *o)
4435 {
4436     return newUNOP(OP_REFGEN, 0,
4437         mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
4438 }
4439
4440 OP *
4441 Perl_newANONHASH(pTHX_ OP *o)
4442 {
4443     return newUNOP(OP_REFGEN, 0,
4444         mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
4445 }
4446
4447 OP *
4448 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
4449 {
4450     return newANONATTRSUB(floor, proto, Nullop, block);
4451 }
4452
4453 OP *
4454 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
4455 {
4456     return newUNOP(OP_REFGEN, 0,
4457         newSVOP(OP_ANONCODE, 0,
4458                 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
4459 }
4460
4461 OP *
4462 Perl_oopsAV(pTHX_ OP *o)
4463 {
4464     switch (o->op_type) {
4465     case OP_PADSV:
4466         o->op_type = OP_PADAV;
4467         o->op_ppaddr = PL_ppaddr[OP_PADAV];
4468         return ref(o, OP_RV2AV);
4469
4470     case OP_RV2SV:
4471         o->op_type = OP_RV2AV;
4472         o->op_ppaddr = PL_ppaddr[OP_RV2AV];
4473         ref(o, OP_RV2AV);
4474         break;
4475
4476     default:
4477         if (ckWARN_d(WARN_INTERNAL))
4478             Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
4479         break;
4480     }
4481     return o;
4482 }
4483
4484 OP *
4485 Perl_oopsHV(pTHX_ OP *o)
4486 {
4487     switch (o->op_type) {
4488     case OP_PADSV:
4489     case OP_PADAV:
4490         o->op_type = OP_PADHV;
4491         o->op_ppaddr = PL_ppaddr[OP_PADHV];
4492         return ref(o, OP_RV2HV);
4493
4494     case OP_RV2SV:
4495     case OP_RV2AV:
4496         o->op_type = OP_RV2HV;
4497         o->op_ppaddr = PL_ppaddr[OP_RV2HV];
4498         ref(o, OP_RV2HV);
4499         break;
4500
4501     default:
4502         if (ckWARN_d(WARN_INTERNAL))
4503             Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
4504         break;
4505     }
4506     return o;
4507 }
4508
4509 OP *
4510 Perl_newAVREF(pTHX_ OP *o)
4511 {
4512     if (o->op_type == OP_PADANY) {
4513         o->op_type = OP_PADAV;
4514         o->op_ppaddr = PL_ppaddr[OP_PADAV];
4515         return o;
4516     }
4517     else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
4518                 && ckWARN(WARN_DEPRECATED)) {
4519         Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4520                 "Using an array as a reference is deprecated");
4521     }
4522     return newUNOP(OP_RV2AV, 0, scalar(o));
4523 }
4524
4525 OP *
4526 Perl_newGVREF(pTHX_ I32 type, OP *o)
4527 {
4528     if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
4529         return newUNOP(OP_NULL, 0, o);
4530     return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
4531 }
4532
4533 OP *
4534 Perl_newHVREF(pTHX_ OP *o)
4535 {
4536     if (o->op_type == OP_PADANY) {
4537         o->op_type = OP_PADHV;
4538         o->op_ppaddr = PL_ppaddr[OP_PADHV];
4539         return o;
4540     }
4541     else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
4542                 && ckWARN(WARN_DEPRECATED)) {
4543         Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4544                 "Using a hash as a reference is deprecated");
4545     }
4546     return newUNOP(OP_RV2HV, 0, scalar(o));
4547 }
4548
4549 OP *
4550 Perl_oopsCV(pTHX_ OP *o)
4551 {
4552     Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
4553     /* STUB */
4554     return o;
4555 }
4556
4557 OP *
4558 Perl_newCVREF(pTHX_ I32 flags, OP *o)
4559 {
4560     return newUNOP(OP_RV2CV, flags, scalar(o));
4561 }
4562
4563 OP *
4564 Perl_newSVREF(pTHX_ OP *o)
4565 {
4566     if (o->op_type == OP_PADANY) {
4567         o->op_type = OP_PADSV;
4568         o->op_ppaddr = PL_ppaddr[OP_PADSV];
4569         return o;
4570     }
4571     else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
4572         o->op_flags |= OPpDONE_SVREF;
4573         return o;
4574     }
4575     return newUNOP(OP_RV2SV, 0, scalar(o));
4576 }
4577
4578 /* Check routines. */
4579
4580 OP *
4581 Perl_ck_anoncode(pTHX_ OP *o)
4582 {
4583     cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
4584     cSVOPo->op_sv = Nullsv;
4585     return o;
4586 }
4587
4588 OP *
4589 Perl_ck_bitop(pTHX_ OP *o)
4590 {
4591 #define OP_IS_NUMCOMPARE(op) \
4592         ((op) == OP_LT   || (op) == OP_I_LT || \
4593          (op) == OP_GT   || (op) == OP_I_GT || \
4594          (op) == OP_LE   || (op) == OP_I_LE || \
4595          (op) == OP_GE   || (op) == OP_I_GE || \
4596          (op) == OP_EQ   || (op) == OP_I_EQ || \
4597          (op) == OP_NE   || (op) == OP_I_NE || \
4598          (op) == OP_NCMP || (op) == OP_I_NCMP)
4599     o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4600     if (o->op_type == OP_BIT_OR
4601             || o->op_type == OP_BIT_AND
4602             || o->op_type == OP_BIT_XOR)
4603     {
4604         OPCODE typfirst = cBINOPo->op_first->op_type;
4605         OPCODE typlast  = cBINOPo->op_first->op_sibling->op_type;
4606         if (OP_IS_NUMCOMPARE(typfirst) || OP_IS_NUMCOMPARE(typlast))
4607             if (ckWARN(WARN_PRECEDENCE))
4608                 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
4609                         "Possible precedence problem on bitwise %c operator",
4610                         o->op_type == OP_BIT_OR ? '|'
4611                             : o->op_type == OP_BIT_AND ? '&' : '^'
4612                         );
4613     }
4614     return o;
4615 }
4616
4617 OP *
4618 Perl_ck_concat(pTHX_ OP *o)
4619 {
4620     if (cUNOPo->op_first->op_type == OP_CONCAT)
4621         o->op_flags |= OPf_STACKED;
4622     return o;
4623 }
4624
4625 OP *
4626 Perl_ck_spair(pTHX_ OP *o)
4627 {
4628     if (o->op_flags & OPf_KIDS) {
4629         OP* newop;
4630         OP* kid;
4631         OPCODE type = o->op_type;
4632         o = modkids(ck_fun(o), type);
4633         kid = cUNOPo->op_first;
4634         newop = kUNOP->op_first->op_sibling;
4635         if (newop &&
4636             (newop->op_sibling ||
4637              !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
4638              newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
4639              newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
4640
4641             return o;
4642         }
4643         op_free(kUNOP->op_first);
4644         kUNOP->op_first = newop;
4645     }
4646     o->op_ppaddr = PL_ppaddr[++o->op_type];
4647     return ck_fun(o);
4648 }
4649
4650 OP *
4651 Perl_ck_delete(pTHX_ OP *o)
4652 {
4653     o = ck_fun(o);
4654     o->op_private = 0;
4655     if (o->op_flags & OPf_KIDS) {
4656         OP *kid = cUNOPo->op_first;
4657         switch (kid->op_type) {
4658         case OP_ASLICE:
4659             o->op_flags |= OPf_SPECIAL;
4660             /* FALL THROUGH */
4661         case OP_HSLICE:
4662             o->op_private |= OPpSLICE;
4663             break;
4664         case OP_AELEM:
4665             o->op_flags |= OPf_SPECIAL;
4666             /* FALL THROUGH */
4667         case OP_HELEM:
4668             break;
4669         default:
4670             Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
4671                   OP_DESC(o));
4672         }
4673         op_null(kid);
4674     }
4675     return o;
4676 }
4677
4678 OP *
4679 Perl_ck_die(pTHX_ OP *o)
4680 {
4681 #ifdef VMS
4682     if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
4683 #endif
4684     return ck_fun(o);
4685 }
4686
4687 OP *
4688 Perl_ck_eof(pTHX_ OP *o)
4689 {
4690     I32 type = o->op_type;
4691
4692     if (o->op_flags & OPf_KIDS) {
4693         if (cLISTOPo->op_first->op_type == OP_STUB) {
4694             op_free(o);
4695             o = newUNOP(type, OPf_SPECIAL,
4696                 newGVOP(OP_GV, 0, gv_fetchpv("main::ARGV", TRUE, SVt_PVAV)));
4697         }
4698         return ck_fun(o);
4699     }
4700     return o;
4701 }
4702
4703 OP *
4704 Perl_ck_eval(pTHX_ OP *o)
4705 {
4706     PL_hints |= HINT_BLOCK_SCOPE;
4707     if (o->op_flags & OPf_KIDS) {
4708         SVOP *kid = (SVOP*)cUNOPo->op_first;
4709
4710         if (!kid) {
4711             o->op_flags &= ~OPf_KIDS;
4712             op_null(o);
4713         }
4714         else if (kid->op_type == OP_LINESEQ) {
4715             LOGOP *enter;
4716
4717             kid->op_next = o->op_next;
4718             cUNOPo->op_first = 0;
4719             op_free(o);
4720
4721             NewOp(1101, enter, 1, LOGOP);
4722             enter->op_type = OP_ENTERTRY;
4723             enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
4724             enter->op_private = 0;
4725
4726             /* establish postfix order */
4727             enter->op_next = (OP*)enter;
4728
4729             o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
4730             o->op_type = OP_LEAVETRY;
4731             o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
4732             enter->op_other = o;
4733             return o;
4734         }
4735         else
4736             scalar((OP*)kid);
4737     }
4738     else {
4739         op_free(o);
4740         o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
4741     }
4742     o->op_targ = (PADOFFSET)PL_hints;
4743     return o;
4744 }
4745
4746 OP *
4747 Perl_ck_exit(pTHX_ OP *o)
4748 {
4749 #ifdef VMS
4750     HV *table = GvHV(PL_hintgv);
4751     if (table) {
4752        SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
4753        if (svp && *svp && SvTRUE(*svp))
4754            o->op_private |= OPpEXIT_VMSISH;
4755     }
4756     if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
4757 #endif
4758     return ck_fun(o);
4759 }
4760
4761 OP *
4762 Perl_ck_exec(pTHX_ OP *o)
4763 {
4764     OP *kid;
4765     if (o->op_flags & OPf_STACKED) {
4766         o = ck_fun(o);
4767         kid = cUNOPo->op_first->op_sibling;
4768         if (kid->op_type == OP_RV2GV)
4769             op_null(kid);
4770     }
4771     else
4772         o = listkids(o);
4773     return o;
4774 }
4775
4776 OP *
4777 Perl_ck_exists(pTHX_ OP *o)
4778 {
4779     o = ck_fun(o);
4780     if (o->op_flags & OPf_KIDS) {
4781         OP *kid = cUNOPo->op_first;
4782         if (kid->op_type == OP_ENTERSUB) {
4783             (void) ref(kid, o->op_type);
4784             if (kid->op_type != OP_RV2CV && !PL_error_count)
4785                 Perl_croak(aTHX_ "%s argument is not a subroutine name",
4786                             OP_DESC(o));
4787             o->op_private |= OPpEXISTS_SUB;
4788         }
4789         else if (kid->op_type == OP_AELEM)
4790             o->op_flags |= OPf_SPECIAL;
4791         else if (kid->op_type != OP_HELEM)
4792             Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
4793                         OP_DESC(o));
4794         op_null(kid);
4795     }
4796     return o;
4797 }
4798
4799 #if 0
4800 OP *
4801 Perl_ck_gvconst(pTHX_ register OP *o)
4802 {
4803     o = fold_constants(o);
4804     if (o->op_type == OP_CONST)
4805         o->op_type = OP_GV;
4806     return o;
4807 }
4808 #endif
4809
4810 OP *
4811 Perl_ck_rvconst(pTHX_ register OP *o)
4812 {
4813     SVOP *kid = (SVOP*)cUNOPo->op_first;
4814
4815     o->op_private |= (PL_hints & HINT_STRICT_REFS);
4816     if (kid->op_type == OP_CONST) {
4817         char *name;
4818         int iscv;
4819         GV *gv;
4820         SV *kidsv = kid->op_sv;
4821         STRLEN n_a;
4822
4823         /* Is it a constant from cv_const_sv()? */
4824         if (SvROK(kidsv) && SvREADONLY(kidsv)) {
4825             SV *rsv = SvRV(kidsv);
4826             int svtype = SvTYPE(rsv);
4827             char *badtype = Nullch;
4828
4829             switch (o->op_type) {
4830             case OP_RV2SV:
4831                 if (svtype > SVt_PVMG)
4832                     badtype = "a SCALAR";
4833                 break;
4834             case OP_RV2AV:
4835                 if (svtype != SVt_PVAV)
4836                     badtype = "an ARRAY";
4837                 break;
4838             case OP_RV2HV:
4839                 if (svtype != SVt_PVHV)
4840                     badtype = "a HASH";
4841                 break;
4842             case OP_RV2CV:
4843                 if (svtype != SVt_PVCV)