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