op.c

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