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