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