op.c

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