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