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, newGVOP(OP_GV, 0, PL_argvgv));
4696         }
4697         return ck_fun(o);
4698     }
4699     return o;
4700 }
4701
4702 OP *
4703 Perl_ck_eval(pTHX_ OP *o)
4704 {
4705     PL_hints |= HINT_BLOCK_SCOPE;
4706     if (o->op_flags & OPf_KIDS) {
4707         SVOP *kid = (SVOP*)cUNOPo->op_first;
4708
4709         if (!kid) {
4710             o->op_flags &= ~OPf_KIDS;
4711             op_null(o);
4712         }
4713         else if (kid->op_type == OP_LINESEQ) {
4714             LOGOP *enter;
4715
4716             kid->op_next = o->op_next;
4717             cUNOPo->op_first = 0;
4718             op_free(o);
4719
4720             NewOp(1101, enter, 1, LOGOP);
4721             enter->op_type = OP_ENTERTRY;
4722             enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
4723             enter->op_private = 0;
4724
4725             /* establish postfix order */
4726             enter->op_next = (OP*)enter;
4727
4728             o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
4729             o->op_type = OP_LEAVETRY;
4730             o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
4731             enter->op_other = o;
4732             return o;
4733         }
4734         else
4735             scalar((OP*)kid);
4736     }
4737     else {
4738         op_free(o);
4739         o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
4740     }
4741     o->op_targ = (PADOFFSET)PL_hints;
4742     return o;
4743 }
4744
4745 OP *
4746 Perl_ck_exit(pTHX_ OP *o)
4747 {
4748 #ifdef VMS
4749     HV *table = GvHV(PL_hintgv);
4750     if (table) {
4751        SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
4752        if (svp && *svp && SvTRUE(*svp))
4753            o->op_private |= OPpEXIT_VMSISH;
4754     }
4755     if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
4756 #endif
4757     return ck_fun(o);
4758 }
4759
4760 OP *
4761 Perl_ck_exec(pTHX_ OP *o)
4762 {
4763     OP *kid;
4764     if (o->op_flags & OPf_STACKED) {
4765         o = ck_fun(o);
4766         kid = cUNOPo->op_first->op_sibling;
4767         if (kid->op_type == OP_RV2GV)
4768             op_null(kid);
4769     }
4770     else
4771         o = listkids(o);
4772     return o;
4773 }
4774
4775 OP *
4776 Perl_ck_exists(pTHX_ OP *o)
4777 {
4778     o = ck_fun(o);
4779     if (o->op_flags & OPf_KIDS) {
4780         OP *kid = cUNOPo->op_first;
4781         if (kid->op_type == OP_ENTERSUB) {
4782             (void) ref(kid, o->op_type);
4783             if (kid->op_type != OP_RV2CV && !PL_error_count)
4784                 Perl_croak(aTHX_ "%s argument is not a subroutine name",
4785                             OP_DESC(o));
4786             o->op_private |= OPpEXISTS_SUB;
4787         }
4788         else if (kid->op_type == OP_AELEM)
4789             o->op_flags |= OPf_SPECIAL;
4790         else if (kid->op_type != OP_HELEM)
4791             Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
4792                         OP_DESC(o));
4793         op_null(kid);
4794     }
4795     return o;
4796 }
4797
4798 #if 0
4799 OP *
4800 Perl_ck_gvconst(pTHX_ register OP *o)
4801 {
4802     o = fold_constants(o);
4803     if (o->op_type == OP_CONST)
4804         o->op_type = OP_GV;
4805     return o;
4806 }
4807 #endif
4808
4809 OP *
4810 Perl_ck_rvconst(pTHX_ register OP *o)
4811 {
4812     SVOP *kid = (SVOP*)cUNOPo->op_first;
4813
4814     o->op_private |= (PL_hints & HINT_STRICT_REFS);
4815     if (kid->op_type == OP_CONST) {
4816         char *name;
4817         int iscv;
4818         GV *gv;
4819         SV *kidsv = kid->op_sv;
4820         STRLEN n_a;
4821
4822         /* Is it a constant from cv_const_sv()? */
4823         if (SvROK(kidsv) && SvREADONLY(kidsv)) {
4824             SV *rsv = SvRV(kidsv);
4825             int svtype = SvTYPE(rsv);
4826             char *badtype = Nullch;
4827
4828             switch (o->op_type) {
4829             case OP_RV2SV:
4830                 if (svtype > SVt_PVMG)
4831                     badtype = "a SCALAR";
4832                 break;
4833             case OP_RV2AV:
4834                 if (svtype != SVt_PVAV)
4835                     badtype = "an ARRAY";
4836                 break;
4837             case OP_RV2HV:
4838                 if (svtype != SVt_PVHV)
4839                     badtype = "a HASH";
4840                 break;
4841             case OP_RV2CV:
4842                 if (svtype != SVt_PVCV)
4843                     badtype = "a CODE";
4844                 break;
4845             }
4846             if (badtype)
4847                 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
4848             return o;
4849         }
4850         name = SvPV(kidsv, n_a);
4851         if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
4852             char *badthing = Nullch;
4853             switch (o->op_type) {
4854             case OP_RV2SV:
4855                 badthing = "a SCALAR";
4856                 break;
4857             case OP_RV2AV:
4858                 badthing = "an ARRAY";
4859                 break;
4860             case OP_RV2HV:
4861                 badthing = "a HASH";
4862                 break;
4863             }
4864             if (badthing)
4865                 Perl_croak(aTHX_
4866           "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
4867                       name, badthing);
4868         }
4869         /*
4870          * This is a little tricky.  We only want to add the symbol if we
4871          * didn't add it in the lexer.  Otherwise we get duplicate strict
4872          * warnings.  But if we didn't add it in the lexer, we must at
4873          * least pretend like we wanted to add it even if it existed before,
4874          * or we get possible typo warnings.  OPpCONST_ENTERED says
4875          * whether the lexer already added THIS instance of this symbol.
4876          */
4877         iscv = (o->op_type == OP_RV2CV) * 2;
4878         do {
4879             gv = gv_fetchpv(name,
4880                 iscv | !(kid->op_private & OPpCONST_ENTERED),
4881                 iscv
4882                     ? SVt_PVCV
4883                     : o->op_type == OP_RV2SV
4884                         ? SVt_PV
4885                         : o->op_type == OP_RV2AV
4886                             ? SVt_PVAV
4887                             : o->op_type == OP_RV2HV
4888                                 ? SVt_PVHV
4889                                 : SVt_PVGV);
4890         } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
4891         if (gv) {
4892             kid->op_type = OP_GV;
4893             SvREFCNT_dec(kid->op_sv);
4894 #ifdef USE_ITHREADS
4895             /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
4896             kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
4897             SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
4898             GvIN_PAD_on(gv);
4899             PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc(gv));
4900 #else
4901             kid->op_sv = SvREFCNT_inc(gv);
4902 #endif
4903             kid->op_private = 0;
4904             kid->op_ppaddr = PL_ppaddr[OP_GV];
4905         }
4906     }
4907     return o;
4908 }
4909
4910 OP *
4911 Perl_ck_ftst(pTHX_ OP *o)
4912 {
4913     I32 type = o->op_type;
4914
4915     if (o->op_flags & OPf_REF) {
4916         /* nothing */
4917     }
4918     else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
4919         SVOP *kid = (SVOP*)cUNOPo->op_first;
4920
4921         if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
4922             STRLEN n_a;
4923             OP *newop = newGVOP(type, OPf_REF,
4924                 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
4925             op_free(o);
4926             o = newop;
4927         }
4928     }
4929     else {
4930         op_free(o);
4931         if (type == OP_FTTTY)
4932             o = newGVOP(type, OPf_REF, PL_stdingv);
4933         else
4934             o = newUNOP(type, 0, newDEFSVOP());
4935     }
4936     return o;
4937 }
4938
4939 OP *
4940 Perl_ck_fun(pTHX_ OP *o)
4941 {
4942     register OP *kid;
4943     OP **tokid;
4944     OP *sibl;
4945     I32 numargs = 0;
4946     int type = o->op_type;
4947     register I32 oa = PL_opargs[type] >> OASHIFT;
4948
4949     if (o->op_flags & OPf_STACKED) {
4950         if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
4951             oa &= ~OA_OPTIONAL;
4952         else
4953             return no_fh_allowed(o);
4954     }
4955
4956     if (o->op_flags & OPf_KIDS) {
4957         STRLEN n_a;
4958         tokid = &cLISTOPo->op_first;
4959         kid = cLISTOPo->op_first;
4960         if (kid->op_type == OP_PUSHMARK ||
4961             (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
4962         {
4963             tokid = &kid->op_sibling;
4964             kid = kid->op_sibling;
4965         }
4966         if (!kid && PL_opargs[type] & OA_DEFGV)
4967             *tokid = kid = newDEFSVOP();
4968
4969         while (oa && kid) {
4970             numargs++;
4971             sibl = kid->op_sibling;
4972             switch (oa & 7) {
4973             case OA_SCALAR:
4974                 /* list seen where single (scalar) arg expected? */
4975                 if (numargs == 1 && !(oa >> 4)
4976                     && kid->op_type == OP_LIST && type != OP_SCALAR)
4977                 {
4978                     return too_many_arguments(o,PL_op_desc[type]);
4979                 }
4980                 scalar(kid);
4981                 break;
4982             case OA_LIST:
4983                 if (oa < 16) {
4984                     kid = 0;
4985                     continue;
4986                 }
4987                 else
4988                     list(kid);
4989                 break;
4990             case OA_AVREF:
4991                 if ((type == OP_PUSH || type == OP_UNSHIFT)
4992                     && !kid->op_sibling && ckWARN(WARN_SYNTAX))
4993                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
4994                         "Useless use of %s with no values",
4995                         PL_op_desc[type]);
4996
4997                 if (kid->op_type == OP_CONST &&
4998                     (kid->op_private & OPpCONST_BARE))
4999                 {
5000                     char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5001                     OP *newop = newAVREF(newGVOP(OP_GV, 0,
5002                         gv_fetchpv(name, TRUE, SVt_PVAV) ));
5003                     if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5004                         Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5005                             "Array @%s missing the @ in argument %"IVdf" of %s()",
5006                             name, (IV)numargs, PL_op_desc[type]);
5007                     op_free(kid);
5008                     kid = newop;
5009                     kid->op_sibling = sibl;
5010                     *tokid = kid;
5011                 }
5012                 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5013                     bad_type(numargs, "array", PL_op_desc[type], kid);
5014                 mod(kid, type);
5015                 break;
5016             case OA_HVREF:
5017                 if (kid->op_type == OP_CONST &&
5018                     (kid->op_private & OPpCONST_BARE))
5019                 {
5020                     char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5021                     OP *newop = newHVREF(newGVOP(OP_GV, 0,
5022                         gv_fetchpv(name, TRUE, SVt_PVHV) ));
5023                     if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5024                         Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5025                             "Hash %%%s missing the %% in argument %"IVdf" of %s()",
5026                             name, (IV)numargs, PL_op_desc[type]);
5027                     op_free(kid);
5028                     kid = newop;
5029                     kid->op_sibling = sibl;
5030                     *tokid = kid;
5031                 }
5032                 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5033                     bad_type(numargs, "hash", PL_op_desc[type], kid);
5034                 mod(kid, type);
5035                 break;
5036             case OA_CVREF:
5037                 {
5038                     OP *newop = newUNOP(OP_NULL, 0, kid);
5039                     kid->op_sibling = 0;
5040                     linklist(kid);
5041                     newop->op_next = newop;
5042                     kid = newop;
5043                     kid->op_sibling = sibl;
5044                     *tokid = kid;
5045                 }
5046                 break;
5047             case OA_FILEREF:
5048                 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5049                     if (kid->op_type == OP_CONST &&
5050                         (kid->op_private & OPpCONST_BARE))
5051                     {
5052                         OP *newop = newGVOP(OP_GV, 0,
5053                             gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
5054                                         SVt_PVIO) );
5055                         if (!(o->op_private & 1) && /* if not unop */
5056                             kid == cLISTOPo->op_last)
5057                             cLISTOPo->op_last = newop;
5058                         op_free(kid);
5059                         kid = newop;
5060                     }
5061                     else if (kid->op_type == OP_READLINE) {
5062                         /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5063                         bad_type(numargs, "HANDLE", OP_DESC(o), kid);
5064                     }
5065                     else {
5066                         I32 flags = OPf_SPECIAL;
5067                         I32 priv = 0;
5068                         PADOFFSET targ = 0;
5069
5070                         /* is this op a FH constructor? */
5071                         if (is_handle_constructor(o,numargs)) {
5072                             char *name = Nullch;
5073                             STRLEN len = 0;
5074
5075                             flags = 0;
5076                             /* Set a flag to tell rv2gv to vivify
5077                              * need to "prove" flag does not mean something
5078                              * else already - NI-S 1999/05/07
5079                              */
5080                             priv = OPpDEREF;
5081                             if (kid->op_type == OP_PADSV) {
5082                                 /*XXX DAPM 2002.08.25 tmp assert test */
5083                                 /*XXX*/ assert(av_fetch(PL_comppad_name, (kid->op_targ), FALSE));
5084                                 /*XXX*/ assert(*av_fetch(PL_comppad_name, (kid->op_targ), FALSE));
5085
5086                                 name = PAD_COMPNAME_PV(kid->op_targ);
5087                                 /* SvCUR of a pad namesv can't be trusted
5088                                  * (see PL_generation), so calc its length
5089                                  * manually */
5090                                 if (name)
5091                                     len = strlen(name);
5092
5093                             }
5094                             else if (kid->op_type == OP_RV2SV
5095                                      && kUNOP->op_first->op_type == OP_GV)
5096                             {
5097                                 GV *gv = cGVOPx_gv(kUNOP->op_first);
5098                                 name = GvNAME(gv);
5099                                 len = GvNAMELEN(gv);
5100                             }
5101                             else if (kid->op_type == OP_AELEM
5102                                      || kid->op_type == OP_HELEM)
5103                             {
5104                                 name = "__ANONIO__";
5105                                 len = 10;
5106                                 mod(kid,type);
5107                             }
5108                             if (name) {
5109                                 SV *namesv;
5110                                 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5111                                 namesv = PAD_SVl(targ);
5112                                 (void)SvUPGRADE(namesv, SVt_PV);
5113                                 if (*name != '$')
5114                                     sv_setpvn(namesv, "$", 1);
5115                                 sv_catpvn(namesv, name, len);
5116                             }
5117                         }
5118                         kid->op_sibling = 0;
5119                         kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5120                         kid->op_targ = targ;
5121                         kid->op_private |= priv;
5122                     }
5123                     kid->op_sibling = sibl;
5124                     *tokid = kid;
5125                 }
5126                 scalar(kid);
5127                 break;
5128             case OA_SCALARREF:
5129                 mod(scalar(kid), type);
5130                 break;
5131             }
5132             oa >>= 4;
5133             tokid = &kid->op_sibling;
5134             kid = kid->op_sibling;
5135         }
5136         o->op_private |= numargs;
5137         if (kid)
5138             return too_many_arguments(o,OP_DESC(o));
5139         listkids(o);
5140     }
5141     else if (PL_opargs[type] & OA_DEFGV) {
5142         op_free(o);
5143         return newUNOP(type, 0, newDEFSVOP());
5144     }
5145
5146     if (oa) {
5147         while (oa & OA_OPTIONAL)
5148             oa >>= 4;
5149         if (oa && oa != OA_LIST)
5150             return too_few_arguments(o,OP_DESC(o));
5151     }
5152     return o;
5153 }
5154
5155 OP *
5156 Perl_ck_glob(pTHX_ OP *o)
5157 {
5158     GV *gv;
5159
5160     o = ck_fun(o);
5161     if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5162         append_elem(OP_GLOB, o, newDEFSVOP());
5163
5164     if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV))
5165           && GvCVu(gv) && GvIMPORTED_CV(gv)))
5166     {
5167         gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5168     }
5169
5170 #if !defined(PERL_EXTERNAL_GLOB)
5171     /* XXX this can be tightened up and made more failsafe. */
5172     if (!gv) {
5173         GV *glob_gv;
5174         ENTER;
5175         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
5176                 newSVpvn("File::Glob", 10), Nullsv, Nullsv, Nullsv);
5177         gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5178         glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
5179         GvCV(gv) = GvCV(glob_gv);
5180         SvREFCNT_inc((SV*)GvCV(gv));
5181         GvIMPORTED_CV_on(gv);
5182         LEAVE;
5183     }
5184 #endif /* PERL_EXTERNAL_GLOB */
5185
5186     if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5187         append_elem(OP_GLOB, o,
5188                     newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5189         o->op_type = OP_LIST;
5190         o->op_ppaddr = PL_ppaddr[OP_LIST];
5191         cLISTOPo->op_first->op_type = OP_PUSHMARK;
5192         cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5193         o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5194                     append_elem(OP_LIST, o,
5195                                 scalar(newUNOP(OP_RV2CV, 0,
5196                                                newGVOP(OP_GV, 0, gv)))));
5197         o = newUNOP(OP_NULL, 0, ck_subr(o));
5198         o->op_targ = OP_GLOB;           /* hint at what it used to be */
5199         return o;
5200     }
5201     gv = newGVgen("main");
5202     gv_IOadd(gv);
5203     append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5204     scalarkids(o);
5205     return o;
5206 }
5207
5208 OP *
5209 Perl_ck_grep(pTHX_ OP *o)
5210 {
5211     LOGOP *gwop;
5212     OP *kid;
5213     OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5214
5215     o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5216     NewOp(1101, gwop, 1, LOGOP);
5217
5218     if (o->op_flags & OPf_STACKED) {
5219         OP* k;
5220         o = ck_sort(o);
5221         kid = cLISTOPo->op_first->op_sibling;
5222         for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
5223             kid = k;
5224         }
5225         kid->op_next = (OP*)gwop;
5226         o->op_flags &= ~OPf_STACKED;
5227     }
5228     kid = cLISTOPo->op_first->op_sibling;
5229     if (type == OP_MAPWHILE)
5230         list(kid);
5231     else
5232         scalar(kid);
5233     o = ck_fun(o);
5234     if (PL_error_count)
5235         return o;
5236     kid = cLISTOPo->op_first->op_sibling;
5237     if (kid->op_type != OP_NULL)
5238         Perl_croak(aTHX_ "panic: ck_grep");
5239     kid = kUNOP->op_first;
5240
5241     gwop->op_type = type;
5242     gwop->op_ppaddr = PL_ppaddr[type];
5243     gwop->op_first = listkids(o);
5244     gwop->op_flags |= OPf_KIDS;
5245     gwop->op_private = 1;
5246     gwop->op_other = LINKLIST(kid);
5247     gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5248     kid->op_next = (OP*)gwop;
5249
5250     kid = cLISTOPo->op_first->op_sibling;
5251     if (!kid || !kid->op_sibling)
5252         return too_few_arguments(o,OP_DESC(o));
5253     for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5254         mod(kid, OP_GREPSTART);
5255
5256     return (OP*)gwop;
5257 }
5258
5259 OP *
5260 Perl_ck_index(pTHX_ OP *o)
5261 {
5262     if (o->op_flags & OPf_KIDS) {
5263         OP *kid = cLISTOPo->op_first->op_sibling;       /* get past pushmark */
5264         if (kid)
5265             kid = kid->op_sibling;                      /* get past "big" */
5266         if (kid && kid->op_type == OP_CONST)
5267             fbm_compile(((SVOP*)kid)->op_sv, 0);
5268     }
5269     return ck_fun(o);
5270 }
5271
5272 OP *
5273 Perl_ck_lengthconst(pTHX_ OP *o)
5274 {
5275     /* XXX length optimization goes here */
5276     return ck_fun(o);
5277 }
5278
5279 OP *
5280 Perl_ck_lfun(pTHX_ OP *o)
5281 {
5282     OPCODE type = o->op_type;
5283     return modkids(ck_fun(o), type);
5284 }
5285
5286 OP *
5287 Perl_ck_defined(pTHX_ OP *o)            /* 19990527 MJD */
5288 {
5289     if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
5290         switch (cUNOPo->op_first->op_type) {
5291         case OP_RV2AV:
5292             /* This is needed for
5293                if (defined %stash::)
5294                to work.   Do not break Tk.
5295                */
5296             break;                      /* Globals via GV can be undef */
5297         case OP_PADAV:
5298         case OP_AASSIGN:                /* Is this a good idea? */
5299             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5300                         "defined(@array) is deprecated");
5301             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5302                         "\t(Maybe you should just omit the defined()?)\n");
5303         break;
5304         case OP_RV2HV:
5305             /* This is needed for
5306                if (defined %stash::)
5307                to work.   Do not break Tk.
5308                */
5309             break;                      /* Globals via GV can be undef */
5310         case OP_PADHV:
5311             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5312                         "defined(%%hash) is deprecated");
5313             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5314                         "\t(Maybe you should just omit the defined()?)\n");
5315             break;
5316         default:
5317             /* no warning */
5318             break;
5319         }
5320     }
5321     return ck_rfun(o);
5322 }
5323
5324 OP *
5325 Perl_ck_rfun(pTHX_ OP *o)
5326 {
5327     OPCODE type = o->op_type;
5328     return refkids(ck_fun(o), type);
5329 }
5330
5331 OP *
5332 Perl_ck_listiob(pTHX_ OP *o)
5333 {
5334     register OP *kid;
5335
5336     kid = cLISTOPo->op_first;
5337     if (!kid) {
5338         o = force_list(o);
5339         kid = cLISTOPo->op_first;
5340     }
5341     if (kid->op_type == OP_PUSHMARK)
5342         kid = kid->op_sibling;
5343     if (kid && o->op_flags & OPf_STACKED)
5344         kid = kid->op_sibling;
5345     else if (kid && !kid->op_sibling) {         /* print HANDLE; */
5346         if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
5347             o->op_flags |= OPf_STACKED; /* make it a filehandle */
5348             kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
5349             cLISTOPo->op_first->op_sibling = kid;
5350             cLISTOPo->op_last = kid;
5351             kid = kid->op_sibling;
5352         }
5353     }
5354
5355     if (!kid)
5356         append_elem(o->op_type, o, newDEFSVOP());
5357
5358     return listkids(o);
5359 }
5360
5361 OP *
5362 Perl_ck_sassign(pTHX_ OP *o)
5363 {
5364     OP *kid = cLISTOPo->op_first;
5365     /* has a disposable target? */
5366     if ((PL_opargs[kid->op_type] & OA_TARGLEX)
5367         && !(kid->op_flags & OPf_STACKED)
5368         /* Cannot steal the second time! */
5369         && !(kid->op_private & OPpTARGET_MY))
5370     {
5371         OP *kkid = kid->op_sibling;
5372
5373         /* Can just relocate the target. */
5374         if (kkid && kkid->op_type == OP_PADSV
5375             && !(kkid->op_private & OPpLVAL_INTRO))
5376         {
5377             kid->op_targ = kkid->op_targ;
5378             kkid->op_targ = 0;
5379             /* Now we do not need PADSV and SASSIGN. */
5380             kid->op_sibling = o->op_sibling;    /* NULL */
5381             cLISTOPo->op_first = NULL;
5382             op_free(o);
5383             op_free(kkid);
5384             kid->op_private |= OPpTARGET_MY;    /* Used for context settings */
5385             return kid;
5386         }
5387     }
5388     return o;
5389 }
5390
5391 OP *
5392 Perl_ck_match(pTHX_ OP *o)
5393 {
5394     o->op_private |= OPpRUNTIME;
5395     return o;
5396 }
5397
5398 OP *
5399 Perl_ck_method(pTHX_ OP *o)
5400 {
5401     OP *kid = cUNOPo->op_first;
5402     if (kid->op_type == OP_CONST) {
5403         SV* sv = kSVOP->op_sv;
5404         if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
5405             OP *cmop;
5406             if (!SvREADONLY(sv) || !SvFAKE(sv)) {
5407                 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
5408             }
5409             else {
5410                 kSVOP->op_sv = Nullsv;
5411             }
5412             cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
5413             op_free(o);
5414             return cmop;
5415         }
5416     }
5417     return o;
5418 }
5419
5420 OP *
5421 Perl_ck_null(pTHX_ OP *o)
5422 {
5423     return o;
5424 }
5425
5426 OP *
5427 Perl_ck_open(pTHX_ OP *o)
5428 {
5429     HV *table = GvHV(PL_hintgv);
5430     if (table) {
5431         SV **svp;
5432         I32 mode;
5433         svp = hv_fetch(table, "open_IN", 7, FALSE);
5434         if (svp && *svp) {
5435             mode = mode_from_discipline(*svp);
5436             if (mode & O_BINARY)
5437                 o->op_private |= OPpOPEN_IN_RAW;
5438             else if (mode & O_TEXT)
5439                 o->op_private |= OPpOPEN_IN_CRLF;
5440         }
5441
5442         svp = hv_fetch(table, "open_OUT", 8, FALSE);
5443         if (svp && *svp) {
5444             mode = mode_from_discipline(*svp);
5445             if (mode & O_BINARY)
5446                 o->op_private |= OPpOPEN_OUT_RAW;
5447             else if (mode & O_TEXT)
5448                 o->op_private |= OPpOPEN_OUT_CRLF;
5449         }
5450     }
5451     if (o->op_type == OP_BACKTICK)
5452         return o;
5453     return ck_fun(o);
5454 }
5455
5456 OP *
5457 Perl_ck_repeat(pTHX_ OP *o)
5458 {
5459     if (cBINOPo->op_first->op_flags & OPf_PARENS) {
5460         o->op_private |= OPpREPEAT_DOLIST;
5461         cBINOPo->op_first = force_list(cBINOPo->op_first);
5462     }
5463     else
5464         scalar(o);
5465     return o;
5466 }
5467
5468 OP *
5469 Perl_ck_require(pTHX_ OP *o)
5470 {
5471     GV* gv;
5472
5473     if (o->op_flags & OPf_KIDS) {       /* Shall we supply missing .pm? */
5474         SVOP *kid = (SVOP*)cUNOPo->op_first;
5475
5476         if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5477             char *s;
5478             for (s = SvPVX(kid->op_sv); *s; s++) {
5479                 if (*s == ':' && s[1] == ':') {
5480                     *s = '/';
5481                     Move(s+2, s+1, strlen(s+2)+1, char);
5482                     --SvCUR(kid->op_sv);
5483                 }
5484             }
5485             if (SvREADONLY(kid->op_sv)) {
5486                 SvREADONLY_off(kid->op_sv);
5487                 sv_catpvn(kid->op_sv, ".pm", 3);
5488                 SvREADONLY_on(kid->op_sv);
5489             }
5490             else
5491                 sv_catpvn(kid->op_sv, ".pm", 3);
5492         }
5493     }
5494
5495     /* handle override, if any */
5496     gv = gv_fetchpv("require", FALSE, SVt_PVCV);
5497     if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
5498         gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
5499
5500     if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5501         OP *kid = cUNOPo->op_first;
5502         cUNOPo->op_first = 0;
5503         op_free(o);
5504         return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
5505                                append_elem(OP_LIST, kid,
5506                                            scalar(newUNOP(OP_RV2CV, 0,
5507                                                           newGVOP(OP_GV, 0,
5508                                                                   gv))))));
5509     }
5510
5511     return ck_fun(o);
5512 }
5513
5514 OP *
5515 Perl_ck_return(pTHX_ OP *o)
5516 {
5517     OP *kid;
5518     if (CvLVALUE(PL_compcv)) {
5519         for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
5520             mod(kid, OP_LEAVESUBLV);
5521     }
5522     return o;
5523 }
5524
5525 #if 0
5526 OP *
5527 Perl_ck_retarget(pTHX_ OP *o)
5528 {
5529     Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5530     /* STUB */
5531     return o;
5532 }
5533 #endif
5534
5535 OP *
5536 Perl_ck_select(pTHX_ OP *o)
5537 {
5538     OP* kid;
5539     if (o->op_flags & OPf_KIDS) {
5540         kid = cLISTOPo->op_first->op_sibling;   /* get past pushmark */
5541         if (kid && kid->op_sibling) {
5542             o->op_type = OP_SSELECT;
5543             o->op_ppaddr = PL_ppaddr[OP_SSELECT];
5544             o = ck_fun(o);
5545             return fold_constants(o);
5546         }
5547     }
5548     o = ck_fun(o);
5549     kid = cLISTOPo->op_first->op_sibling;    /* get past pushmark */
5550     if (kid && kid->op_type == OP_RV2GV)
5551         kid->op_private &= ~HINT_STRICT_REFS;
5552     return o;
5553 }
5554
5555 OP *
5556 Perl_ck_shift(pTHX_ OP *o)
5557 {
5558     I32 type = o->op_type;
5559
5560     if (!(o->op_flags & OPf_KIDS)) {
5561         OP *argop;
5562
5563         op_free(o);
5564         argop = newUNOP(OP_RV2AV, 0,
5565             scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
5566         return newUNOP(type, 0, scalar(argop));
5567     }
5568     return scalar(modkids(ck_fun(o), type));
5569 }
5570
5571 OP *
5572 Perl_ck_sort(pTHX_ OP *o)
5573 {
5574     OP *firstkid;
5575
5576     if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
5577         simplify_sort(o);
5578     firstkid = cLISTOPo->op_first->op_sibling;          /* get past pushmark */
5579     if (o->op_flags & OPf_STACKED) {                    /* may have been cleared */
5580         OP *k = NULL;
5581         OP *kid = cUNOPx(firstkid)->op_first;           /* get past null */
5582
5583         if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
5584             linklist(kid);
5585             if (kid->op_type == OP_SCOPE) {
5586                 k = kid->op_next;
5587                 kid->op_next = 0;
5588             }
5589             else if (kid->op_type == OP_LEAVE) {
5590                 if (o->op_type == OP_SORT) {
5591                     op_null(kid);                       /* wipe out leave */
5592                     kid->op_next = kid;
5593
5594                     for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
5595                         if (k->op_next == kid)
5596                             k->op_next = 0;
5597                         /* don't descend into loops */
5598                         else if (k->op_type == OP_ENTERLOOP
5599                                  || k->op_type == OP_ENTERITER)
5600                         {
5601                             k = cLOOPx(k)->op_lastop;
5602                         }
5603                     }
5604                 }
5605                 else
5606                     kid->op_next = 0;           /* just disconnect the leave */
5607                 k = kLISTOP->op_first;
5608             }
5609             CALL_PEEP(k);
5610
5611             kid = firstkid;
5612             if (o->op_type == OP_SORT) {
5613                 /* provide scalar context for comparison function/block */
5614                 kid = scalar(kid);
5615                 kid->op_next = kid;
5616             }
5617             else
5618                 kid->op_next = k;
5619             o->op_flags |= OPf_SPECIAL;
5620         }
5621         else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
5622             op_null(firstkid);
5623
5624         firstkid = firstkid->op_sibling;
5625     }
5626
5627     /* provide list context for arguments */
5628     if (o->op_type == OP_SORT)
5629         list(firstkid);
5630
5631     return o;
5632 }
5633
5634 STATIC void
5635 S_simplify_sort(pTHX_ OP *o)
5636 {
5637     register OP *kid = cLISTOPo->op_first->op_sibling;  /* get past pushmark */
5638     OP *k;
5639     int reversed;
5640     GV *gv;
5641     if (!(o->op_flags & OPf_STACKED))
5642         return;
5643     GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
5644     GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
5645     kid = kUNOP->op_first;                              /* get past null */
5646     if (kid->op_type != OP_SCOPE)
5647         return;
5648     kid = kLISTOP->op_last;                             /* get past scope */
5649     switch(kid->op_type) {
5650         case OP_NCMP:
5651         case OP_I_NCMP:
5652         case OP_SCMP:
5653             break;
5654         default:
5655             return;
5656     }
5657     k = kid;                                            /* remember this node*/
5658     if (kBINOP->op_first->op_type != OP_RV2SV)
5659         return;
5660     kid = kBINOP->op_first;                             /* get past cmp */
5661     if (kUNOP->op_first->op_type != OP_GV)
5662         return;
5663     kid = kUNOP->op_first;                              /* get past rv2sv */
5664     gv = kGVOP_gv;
5665     if (GvSTASH(gv) != PL_curstash)
5666         return;
5667     if (strEQ(GvNAME(gv), "a"))
5668         reversed = 0;
5669     else if (strEQ(GvNAME(gv), "b"))
5670         reversed = 1;
5671     else
5672         return;
5673     kid = k;                                            /* back to cmp */
5674     if (kBINOP->op_last->op_type != OP_RV2SV)
5675         return;
5676     kid = kBINOP->op_last;                              /* down to 2nd arg */
5677     if (kUNOP->op_first->op_type != OP_GV)
5678         return;
5679     kid = kUNOP->op_first;                              /* get past rv2sv */
5680     gv = kGVOP_gv;
5681     if (GvSTASH(gv) != PL_curstash
5682         || ( reversed
5683             ? strNE(GvNAME(gv), "a")
5684             : strNE(GvNAME(gv), "b")))
5685         return;
5686     o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
5687     if (reversed)
5688         o->op_private |= OPpSORT_REVERSE;
5689     if (k->op_type == OP_NCMP)
5690         o->op_private |= OPpSORT_NUMERIC;
5691     if (k->op_type == OP_I_NCMP)
5692         o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
5693     kid = cLISTOPo->op_first->op_sibling;
5694     cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
5695     op_free(kid);                                     /* then delete it */
5696 }
5697
5698 OP *
5699 Perl_ck_split(pTHX_ OP *o)
5700 {
5701     register OP *kid;
5702
5703     if (o->op_flags & OPf_STACKED)
5704         return no_fh_allowed(o);
5705
5706     kid = cLISTOPo->op_first;
5707     if (kid->op_type != OP_NULL)
5708         Perl_croak(aTHX_ "panic: ck_split");
5709     kid = kid->op_sibling;
5710     op_free(cLISTOPo->op_first);
5711     cLISTOPo->op_first = kid;
5712     if (!kid) {
5713         cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
5714         cLISTOPo->op_last = kid; /* There was only one element previously */
5715     }
5716
5717     if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
5718         OP *sibl = kid->op_sibling;
5719         kid->op_sibling = 0;
5720         kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
5721         if (cLISTOPo->op_first == cLISTOPo->op_last)
5722             cLISTOPo->op_last = kid;
5723         cLISTOPo->op_first = kid;
5724         kid->op_sibling = sibl;
5725     }
5726
5727     kid->op_type = OP_PUSHRE;
5728     kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
5729     scalar(kid);
5730     if (ckWARN(WARN_REGEXP) && ((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
5731       Perl_warner(aTHX_ packWARN(WARN_REGEXP),
5732                   "Use of /g modifier is meaningless in split");
5733     }
5734
5735     if (!kid->op_sibling)
5736         append_elem(OP_SPLIT, o, newDEFSVOP());
5737
5738     kid = kid->op_sibling;
5739     scalar(kid);
5740
5741     if (!kid->op_sibling)
5742         append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
5743
5744     kid = kid->op_sibling;
5745     scalar(kid);
5746
5747     if (kid->op_sibling)
5748         return too_many_arguments(o,OP_DESC(o));
5749
5750     return o;
5751 }
5752
5753 OP *
5754 Perl_ck_join(pTHX_ OP *o)
5755 {
5756     if (ckWARN(WARN_SYNTAX)) {
5757         OP *kid = cLISTOPo->op_first->op_sibling;
5758         if (kid && kid->op_type == OP_MATCH) {
5759             char *pmstr = "STRING";
5760             if (PM_GETRE(kPMOP))
5761                 pmstr = PM_GETRE(kPMOP)->precomp;
5762             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5763                         "/%s/ should probably be written as \"%s\"",
5764                         pmstr, pmstr);
5765         }
5766     }
5767     return ck_fun(o);
5768 }
5769
5770 OP *
5771 Perl_ck_subr(pTHX_ OP *o)
5772 {
5773     OP *prev = ((cUNOPo->op_first->op_sibling)
5774              ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
5775     OP *o2 = prev->op_sibling;
5776     OP *cvop;
5777     char *proto = 0;
5778     CV *cv = 0;
5779     GV *namegv = 0;
5780     int optional = 0;
5781     I32 arg = 0;
5782     I32 contextclass = 0;
5783     char *e = 0;
5784     STRLEN n_a;
5785     bool delete=0;
5786
5787     o->op_private |= OPpENTERSUB_HASTARG;
5788     for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
5789     if (cvop->op_type == OP_RV2CV) {
5790         SVOP* tmpop;
5791         o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
5792         op_null(cvop);          /* disable rv2cv */
5793         tmpop = (SVOP*)((UNOP*)cvop)->op_first;
5794         if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
5795             GV *gv = cGVOPx_gv(tmpop);
5796             cv = GvCVu(gv);
5797             if (!cv)
5798                 tmpop->op_private |= OPpEARLY_CV;
5799             else {
5800                 if (SvPOK(cv)) {
5801                     namegv = CvANON(cv) ? gv : CvGV(cv);
5802                     proto = SvPV((SV*)cv, n_a);
5803                 }
5804                 if (CvASSERTION(cv)) {
5805                     if (PL_hints & HINT_ASSERTING) {
5806                         if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
5807                             o->op_private |= OPpENTERSUB_DB;
5808                     }
5809                     else delete=1;
5810                 }
5811             }
5812         }
5813     }
5814     else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
5815         if (o2->op_type == OP_CONST)
5816             o2->op_private &= ~OPpCONST_STRICT;
5817         else if (o2->op_type == OP_LIST) {
5818             OP *o = ((UNOP*)o2)->op_first->op_sibling;
5819             if (o && o->op_type == OP_CONST)
5820                 o->op_private &= ~OPpCONST_STRICT;
5821         }
5822     }
5823     o->op_private |= (PL_hints & HINT_STRICT_REFS);
5824     if (PERLDB_SUB && PL_curstash != PL_debstash)
5825         o->op_private |= OPpENTERSUB_DB;
5826     while (o2 != cvop) {
5827         if (proto) {
5828             switch (*proto) {
5829             case '\0':
5830                 return too_many_arguments(o, gv_ename(namegv));
5831             case ';':
5832                 optional = 1;
5833                 proto++;
5834                 continue;
5835             case '$':
5836                 proto++;
5837                 arg++;
5838                 scalar(o2);
5839                 break;
5840             case '%':
5841             case '@':
5842                 list(o2);
5843                 arg++;
5844                 break;
5845             case '&':
5846                 proto++;
5847                 arg++;
5848                 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
5849                     bad_type(arg,
5850                         arg == 1 ? "block or sub {}" : "sub {}",
5851                         gv_ename(namegv), o2);
5852                 break;
5853             case '*':
5854                 /* '*' allows any scalar type, including bareword */
5855                 proto++;
5856                 arg++;
5857                 if (o2->op_type == OP_RV2GV)
5858                     goto wrapref;       /* autoconvert GLOB -> GLOBref */
5859                 else if (o2->op_type == OP_CONST)
5860                     o2->op_private &= ~OPpCONST_STRICT;
5861                 else if (o2->op_type == OP_ENTERSUB) {
5862                     /* accidental subroutine, revert to bareword */
5863                     OP *gvop = ((UNOP*)o2)->op_first;
5864                     if (gvop && gvop->op_type == OP_NULL) {
5865                         gvop = ((UNOP*)gvop)->op_first;
5866                         if (gvop) {
5867                             for (; gvop->op_sibling; gvop = gvop->op_sibling)
5868                                 ;
5869                             if (gvop &&
5870                                 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
5871                                 (gvop = ((UNOP*)gvop)->op_first) &&
5872                                 gvop->op_type == OP_GV)
5873                             {
5874                                 GV *gv = cGVOPx_gv(gvop);
5875                                 OP *sibling = o2->op_sibling;
5876                                 SV *n = newSVpvn("",0);
5877                                 op_free(o2);
5878                                 gv_fullname3(n, gv, "");
5879                                 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
5880                                     sv_chop(n, SvPVX(n)+6);
5881                                 o2 = newSVOP(OP_CONST, 0, n);
5882                                 prev->op_sibling = o2;
5883                                 o2->op_sibling = sibling;
5884                             }
5885                         }
5886                     }
5887                 }
5888                 scalar(o2);
5889                 break;
5890             case '[': case ']':
5891                  goto oops;
5892                  break;
5893             case '\\':
5894                 proto++;
5895                 arg++;
5896             again:
5897                 switch (*proto++) {
5898                 case '[':
5899                      if (contextclass++ == 0) {
5900                           e = strchr(proto, ']');
5901                           if (!e || e == proto)
5902                                goto oops;
5903                      }
5904                      else
5905                           goto oops;
5906                      goto again;
5907                      break;
5908                 case ']':
5909                      if (contextclass) {
5910                          char *p = proto;
5911                          char s = *p;
5912                          contextclass = 0;
5913                          *p = '\0';
5914                          while (*--p != '[');
5915                          bad_type(arg, Perl_form(aTHX_ "one of %s", p),
5916                                  gv_ename(namegv), o2);
5917                          *proto = s;
5918                      } else
5919                           goto oops;
5920                      break;
5921                 case '*':
5922                      if (o2->op_type == OP_RV2GV)
5923                           goto wrapref;
5924                      if (!contextclass)
5925                           bad_type(arg, "symbol", gv_ename(namegv), o2);
5926                      break;
5927                 case '&':
5928                      if (o2->op_type == OP_ENTERSUB)
5929                           goto wrapref;
5930                      if (!contextclass)
5931                           bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
5932                      break;
5933                 case '$':
5934                     if (o2->op_type == OP_RV2SV ||
5935                         o2->op_type == OP_PADSV ||
5936                         o2->op_type == OP_HELEM ||
5937                         o2->op_type == OP_AELEM ||
5938                         o2->op_type == OP_THREADSV)
5939                          goto wrapref;
5940                     if (!contextclass)
5941                         bad_type(arg, "scalar", gv_ename(namegv), o2);
5942                      break;
5943                 case '@':
5944                     if (o2->op_type == OP_RV2AV ||
5945                         o2->op_type == OP_PADAV)
5946                          goto wrapref;
5947                     if (!contextclass)
5948                         bad_type(arg, "array", gv_ename(namegv), o2);
5949                     break;
5950                 case '%':
5951                     if (o2->op_type == OP_RV2HV ||
5952                         o2->op_type == OP_PADHV)
5953                          goto wrapref;
5954                     if (!contextclass)
5955                          bad_type(arg, "hash", gv_ename(namegv), o2);
5956                     break;
5957                 wrapref:
5958                     {
5959                         OP* kid = o2;
5960                         OP* sib = kid->op_sibling;
5961                         kid->op_sibling = 0;
5962                         o2 = newUNOP(OP_REFGEN, 0, kid);
5963                         o2->op_sibling = sib;
5964                         prev->op_sibling = o2;
5965                     }
5966                     if (contextclass && e) {
5967                          proto = e + 1;
5968                          contextclass = 0;
5969                     }
5970                     break;
5971                 default: goto oops;
5972                 }
5973                 if (contextclass)
5974                      goto again;
5975                 break;
5976             case ' ':
5977                 proto++;
5978                 continue;
5979             default:
5980               oops:
5981                 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
5982                            gv_ename(namegv), cv);
5983             }
5984         }
5985         else
5986             list(o2);
5987         mod(o2, OP_ENTERSUB);
5988         prev = o2;
5989         o2 = o2->op_sibling;
5990     }
5991     if (proto && !optional &&
5992           (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
5993         return too_few_arguments(o, gv_ename(namegv));
5994     if(delete) {
5995         op_free(o);
5996         o=newSVOP(OP_CONST, 0, newSViv(0));
5997     }
5998     return o;
5999 }
6000
6001 OP *
6002 Perl_ck_svconst(pTHX_ OP *o)
6003 {
6004     SvREADONLY_on(cSVOPo->op_sv);
6005     return o;
6006 }
6007
6008 OP *
6009 Perl_ck_trunc(pTHX_ OP *o)
6010 {
6011     if (o->op_flags & OPf_KIDS) {
6012         SVOP *kid = (SVOP*)cUNOPo->op_first;
6013
6014         if (kid->op_type == OP_NULL)
6015             kid = (SVOP*)kid->op_sibling;
6016         if (kid && kid->op_type == OP_CONST &&
6017             (kid->op_private & OPpCONST_BARE))
6018         {
6019             o->op_flags |= OPf_SPECIAL;
6020             kid->op_private &= ~OPpCONST_STRICT;
6021         }
6022     }
6023     return ck_fun(o);
6024 }
6025
6026 OP *
6027 Perl_ck_substr(pTHX_ OP *o)
6028 {
6029     o = ck_fun(o);
6030     if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6031         OP *kid = cLISTOPo->op_first;
6032
6033         if (kid->op_type == OP_NULL)
6034             kid = kid->op_sibling;
6035         if (kid)
6036             kid->op_flags |= OPf_MOD;
6037
6038     }
6039     return o;
6040 }
6041
6042 /* A peephole optimizer.  We visit the ops in the order they're to execute. */
6043
6044 void
6045 Perl_peep(pTHX_ register OP *o)
6046 {
6047     register OP* oldop = 0;
6048
6049     if (!o || o->op_seq)
6050         return;
6051     ENTER;
6052     SAVEOP();
6053     SAVEVPTR(PL_curcop);
6054     for (; o; o = o->op_next) {
6055         if (o->op_seq)
6056             break;
6057         /* The special value -1 is used by the B::C compiler backend to indicate
6058          * that an op is statically defined and should not be freed */
6059         if (!PL_op_seqmax || PL_op_seqmax == (U16)-1)
6060             PL_op_seqmax = 1;
6061         PL_op = o;
6062         switch (o->op_type) {
6063         case OP_SETSTATE:
6064         case OP_NEXTSTATE:
6065         case OP_DBSTATE:
6066             PL_curcop = ((COP*)o);              /* for warnings */
6067             o->op_seq = PL_op_seqmax++;
6068             break;
6069
6070         case OP_CONST:
6071             if (cSVOPo->op_private & OPpCONST_STRICT)
6072                 no_bareword_allowed(o);
6073 #ifdef USE_ITHREADS
6074         case OP_METHOD_NAMED:
6075             /* Relocate sv to the pad for thread safety.
6076              * Despite being a "constant", the SV is written to,
6077              * for reference counts, sv_upgrade() etc. */
6078             if (cSVOP->op_sv) {
6079                 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6080                 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
6081                     /* If op_sv is already a PADTMP then it is being used by
6082                      * some pad, so make a copy. */
6083                     sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
6084                     SvREADONLY_on(PAD_SVl(ix));
6085                     SvREFCNT_dec(cSVOPo->op_sv);
6086                 }
6087                 else {
6088                     SvREFCNT_dec(PAD_SVl(ix));
6089                     SvPADTMP_on(cSVOPo->op_sv);
6090                     PAD_SETSV(ix, cSVOPo->op_sv);
6091                     /* XXX I don't know how this isn't readonly already. */
6092                     SvREADONLY_on(PAD_SVl(ix));
6093                 }
6094                 cSVOPo->op_sv = Nullsv;
6095                 o->op_targ = ix;
6096             }
6097 #endif
6098             o->op_seq = PL_op_seqmax++;
6099             break;
6100
6101         case OP_CONCAT:
6102             if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6103                 if (o->op_next->op_private & OPpTARGET_MY) {
6104                     if (o->op_flags & OPf_STACKED) /* chained concats */
6105                         goto ignore_optimization;
6106                     else {
6107                         /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6108                         o->op_targ = o->op_next->op_targ;
6109                         o->op_next->op_targ = 0;
6110                         o->op_private |= OPpTARGET_MY;
6111                     }
6112                 }
6113                 op_null(o->op_next);
6114             }
6115           ignore_optimization:
6116             o->op_seq = PL_op_seqmax++;
6117             break;
6118         case OP_STUB:
6119             if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6120                 o->op_seq = PL_op_seqmax++;
6121                 break; /* Scalar stub must produce undef.  List stub is noop */
6122             }
6123             goto nothin;
6124         case OP_NULL:
6125             if (o->op_targ == OP_NEXTSTATE
6126                 || o->op_targ == OP_DBSTATE
6127                 || o->op_targ == OP_SETSTATE)
6128             {
6129                 PL_curcop = ((COP*)o);
6130             }
6131             /* XXX: We avoid setting op_seq here to prevent later calls
6132                to peep() from mistakenly concluding that optimisation
6133                has already occurred. This doesn't fix the real problem,
6134                though (See 20010220.007). AMS 20010719 */
6135             if (oldop && o->op_next) {
6136                 oldop->op_next = o->op_next;
6137                 continue;
6138             }
6139             break;
6140         case OP_SCALAR:
6141         case OP_LINESEQ:
6142         case OP_SCOPE:
6143           nothin:
6144             if (oldop && o->op_next) {
6145                 oldop->op_next = o->op_next;
6146                 continue;
6147             }
6148             o->op_seq = PL_op_seqmax++;
6149             break;
6150
6151         case OP_GV:
6152             if (o->op_next->op_type == OP_RV2SV) {
6153                 if (!(o->op_next->op_private & OPpDEREF)) {
6154                     op_null(o->op_next);
6155                     o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6156                                                                | OPpOUR_INTRO);
6157                     o->op_next = o->op_next->op_next;
6158                     o->op_type = OP_GVSV;
6159                     o->op_ppaddr = PL_ppaddr[OP_GVSV];
6160                 }
6161             }
6162             else if (o->op_next->op_type == OP_RV2AV) {
6163                 OP* pop = o->op_next->op_next;
6164                 IV i;
6165                 if (pop && pop->op_type == OP_CONST &&
6166                     (PL_op = pop->op_next) &&
6167                     pop->op_next->op_type == OP_AELEM &&
6168                     !(pop->op_next->op_private &
6169                       (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6170                     (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
6171                                 <= 255 &&
6172                     i >= 0)
6173                 {
6174                     GV *gv;
6175                     op_null(o->op_next);
6176                     op_null(pop->op_next);
6177                     op_null(pop);
6178                     o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6179                     o->op_next = pop->op_next->op_next;
6180                     o->op_type = OP_AELEMFAST;
6181                     o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6182                     o->op_private = (U8)i;
6183                     gv = cGVOPo_gv;
6184                     GvAVn(gv);
6185                 }
6186             }
6187             else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6188                 GV *gv = cGVOPo_gv;
6189                 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
6190                     /* XXX could check prototype here instead of just carping */
6191                     SV *sv = sv_newmortal();
6192                     gv_efullname3(sv, gv, Nullch);
6193                     Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
6194                                 "%"SVf"() called too early to check prototype",
6195                                 sv);
6196                 }
6197             }
6198             else if (o->op_next->op_type == OP_READLINE
6199                     && o->op_next->op_next->op_type == OP_CONCAT
6200                     && (o->op_next->op_next->op_flags & OPf_STACKED))
6201             {
6202                 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
6203                 o->op_type   = OP_RCATLINE;
6204                 o->op_flags |= OPf_STACKED;
6205                 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
6206                 op_null(o->op_next->op_next);
6207                 op_null(o->op_next);
6208             }
6209
6210             o->op_seq = PL_op_seqmax++;
6211             break;
6212
6213         case OP_MAPWHILE:
6214         case OP_GREPWHILE:
6215         case OP_AND:
6216         case OP_OR:
6217         case OP_DOR:
6218         case OP_ANDASSIGN:
6219         case OP_ORASSIGN:
6220         case OP_DORASSIGN:
6221         case OP_COND_EXPR:
6222         case OP_RANGE:
6223             o->op_seq = PL_op_seqmax++;
6224             while (cLOGOP->op_other->op_type == OP_NULL)
6225                 cLOGOP->op_other = cLOGOP->op_other->op_next;
6226             peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
6227             break;
6228
6229         case OP_ENTERLOOP:
6230         case OP_ENTERITER:
6231             o->op_seq = PL_op_seqmax++;
6232             while (cLOOP->op_redoop->op_type == OP_NULL)
6233                 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6234             peep(cLOOP->op_redoop);
6235             while (cLOOP->op_nextop->op_type == OP_NULL)
6236                 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6237             peep(cLOOP->op_nextop);
6238             while (cLOOP->op_lastop->op_type == OP_NULL)
6239                 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6240             peep(cLOOP->op_lastop);
6241             break;
6242
6243         case OP_QR:
6244         case OP_MATCH:
6245         case OP_SUBST:
6246             o->op_seq = PL_op_seqmax++;
6247             while (cPMOP->op_pmreplstart &&
6248                    cPMOP->op_pmreplstart->op_type == OP_NULL)
6249                 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6250             peep(cPMOP->op_pmreplstart);
6251             break;
6252
6253         case OP_EXEC:
6254             o->op_seq = PL_op_seqmax++;
6255             if (ckWARN(WARN_SYNTAX) && o->op_next
6256                 && o->op_next->op_type == OP_NEXTSTATE) {
6257                 if (o->op_next->op_sibling &&
6258                         o->op_next->op_sibling->op_type != OP_EXIT &&
6259                         o->op_next->op_sibling->op_type != OP_WARN &&
6260                         o->op_next->op_sibling->op_type != OP_DIE) {
6261                     line_t oldline = CopLINE(PL_curcop);
6262
6263                     CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6264                     Perl_warner(aTHX_ packWARN(WARN_EXEC),
6265                                 "Statement unlikely to be reached");
6266                     Perl_warner(aTHX_ packWARN(WARN_EXEC),
6267                                 "\t(Maybe you meant system() when you said exec()?)\n");
6268                     CopLINE_set(PL_curcop, oldline);
6269                 }
6270             }
6271             break;
6272
6273         case OP_HELEM: {
6274             SV *lexname;
6275             SV **svp, *sv;
6276             char *key = NULL;
6277             STRLEN keylen;
6278
6279             o->op_seq = PL_op_seqmax++;
6280
6281             if (((BINOP*)o)->op_last->op_type != OP_CONST)
6282                 break;
6283
6284             /* Make the CONST have a shared SV */
6285             svp = cSVOPx_svp(((BINOP*)o)->op_last);
6286             if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
6287                 key = SvPV(sv, keylen);
6288                 lexname = newSVpvn_share(key,
6289                                          SvUTF8(sv) ? -(I32)keylen : keylen,
6290                                          0);
6291                 SvREFCNT_dec(sv);
6292                 *svp = lexname;
6293             }
6294             break;
6295         }
6296
6297         default:
6298             o->op_seq = PL_op_seqmax++;
6299             break;
6300         }
6301         oldop = o;
6302     }
6303     LEAVE;
6304 }
6305
6306
6307
6308 char* Perl_custom_op_name(pTHX_ OP* o)
6309 {
6310     IV  index = PTR2IV(o->op_ppaddr);
6311     SV* keysv;
6312     HE* he;
6313
6314     if (!PL_custom_op_names) /* This probably shouldn't happen */
6315         return PL_op_name[OP_CUSTOM];
6316
6317     keysv = sv_2mortal(newSViv(index));
6318
6319     he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
6320     if (!he)
6321         return PL_op_name[OP_CUSTOM]; /* Don't know who you are */
6322
6323     return SvPV_nolen(HeVAL(he));
6324 }
6325
6326 char* Perl_custom_op_desc(pTHX_ OP* o)
6327 {
6328     IV  index = PTR2IV(o->op_ppaddr);
6329     SV* keysv;
6330     HE* he;
6331
6332     if (!PL_custom_op_descs)
6333         return PL_op_desc[OP_CUSTOM];
6334
6335     keysv = sv_2mortal(newSViv(index));
6336
6337     he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
6338     if (!he)
6339         return PL_op_desc[OP_CUSTOM];
6340
6341     return SvPV_nolen(HeVAL(he));
6342 }
6343
6344
6345 #include "XSUB.h"
6346
6347 /* Efficient sub that returns a constant scalar value. */
6348 static void
6349 const_sv_xsub(pTHX_ CV* cv)
6350 {
6351     dXSARGS;
6352     if (items != 0) {
6353 #if 0
6354         Perl_croak(aTHX_ "usage: %s::%s()",
6355                    HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
6356 #endif
6357     }
6358     EXTEND(sp, 1);
6359     ST(0) = (SV*)XSANY.any_ptr;
6360     XSRETURN(1);
6361 }