op.c

   1 /*    op.c
   2  *
   3  *    Copyright (c) 1991-2001, Larry Wall
   4  *
   5  *    You may distribute under the terms of either the GNU General Public
   6  *    License or the Artistic License, as specified in the README file.
   7  *
   8  */
   9
  10 /*
  11  * "You see: Mr. Drogo, he married poor Miss Primula Brandybuck.  She was
  12  * our Mr. Bilbo's first cousin on the mother's side (her mother being the
  13  * youngest of the Old Took's daughters); and Mr. Drogo was his second
  14  * cousin.  So Mr. Frodo is his first *and* second cousin, once removed
  15  * either way, as the saying is, if you follow me."  --the Gaffer
  16  */
  17
  18 #include "EXTERN.h"
  19 #define PERL_IN_OP_C
  20 #include "perl.h"
  21 #include "keywords.h"
  22
  23 /* #define PL_OP_SLAB_ALLOC */
  24
  25 #ifdef PL_OP_SLAB_ALLOC
  26 #define SLAB_SIZE 8192
  27 static char    *PL_OpPtr  = NULL;
  28 static int     PL_OpSpace = 0;
  29 #define NewOp(m,var,c,type) do { if ((PL_OpSpace -= c*sizeof(type)) >= 0)     \
  30                               var =  (type *)(PL_OpPtr -= c*sizeof(type));    \
  31                              else                                             \
  32                               var = (type *) Slab_Alloc(m,c*sizeof(type));    \
  33                            } while (0)
  34
  35 STATIC void *
  36 S_Slab_Alloc(pTHX_ int m, size_t sz)
  37 {
  38  Newz(m,PL_OpPtr,SLAB_SIZE,char);
  39  PL_OpSpace = SLAB_SIZE - sz;
  40  return PL_OpPtr += PL_OpSpace;
  41 }
  42
  43 #else
  44 #define NewOp(m, var, c, type) Newz(m, var, c, type)
  45 #endif
  46 /*
  47  * In the following definition, the ", Nullop" is just to make the compiler
  48  * think the expression is of the right type: croak actually does a Siglongjmp.
  49  */
  50 #define CHECKOP(type,o) \
  51     ((PL_op_mask && PL_op_mask[type])                                   \
  52      ? ( op_free((OP*)o),                                       \
  53          Perl_croak(aTHX_ "%s trapped by operation mask", PL_op_desc[type]),    \
  54          Nullop )                                               \
  55      : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o))
  56
  57 #define PAD_MAX 999999999
  58 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
  59
  60 STATIC char*
  61 S_gv_ename(pTHX_ GV *gv)
  62 {
  63     STRLEN n_a;
  64     SV* tmpsv = sv_newmortal();
  65     gv_efullname3(tmpsv, gv, Nullch);
  66     return SvPV(tmpsv,n_a);
  67 }
  68
  69 STATIC OP *
  70 S_no_fh_allowed(pTHX_ OP *o)
  71 {
  72     yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
  73                  PL_op_desc[o->op_type]));
  74     return o;
  75 }
  76
  77 STATIC OP *
  78 S_too_few_arguments(pTHX_ OP *o, char *name)
  79 {
  80     yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
  81     return o;
  82 }
  83
  84 STATIC OP *
  85 S_too_many_arguments(pTHX_ OP *o, char *name)
  86 {
  87     yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
  88     return o;
  89 }
  90
  91 STATIC void
  92 S_bad_type(pTHX_ I32 n, char *t, char *name, OP *kid)
  93 {
  94     yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
  95                  (int)n, name, t, PL_op_desc[kid->op_type]));
  96 }
  97
  98 STATIC void
  99 S_no_bareword_allowed(pTHX_ OP *o)
 100 {
 101     qerror(Perl_mess(aTHX_
 102                      "Bareword \"%s\" not allowed while \"strict subs\" in use",
 103                      SvPV_nolen(cSVOPo_sv)));
 104 }
 105
 106 STATIC U8*
 107 S_trlist_upgrade(pTHX_ U8** sp, U8** ep)
 108 {
 109     U8 *s = *sp;
 110     U8 *e = *ep;
 111     U8 *d;
 112
 113     Newz(801, d, (e - s) * 2, U8);
 114     *sp = d;
 115
 116     while (s < e) {
 117         if (NATIVE_IS_INVARIANT(*s) || NATIVE_TO_UTF(*s) == 0xff)
 118             *d++ = *s++;
 119         else {
 120             U8 c = NATIVE_TO_ASCII(*s++);
 121             *d++ = UTF8_EIGHT_BIT_HI(c);
 122             *d++ = UTF8_EIGHT_BIT_LO(c);
 123         }
 124     }
 125     *ep = d;
 126     return *sp;
 127 }
 128
 129
 130 /* "register" allocation */
 131
 132 PADOFFSET
 133 Perl_pad_allocmy(pTHX_ char *name)
 134 {
 135     PADOFFSET off;
 136     SV *sv;
 137
 138     if (!(PL_in_my == KEY_our ||
 139           isALPHA(name[1]) ||
 140           (PL_hints & HINT_UTF8 && UTF8_IS_START(name[1])) ||
 141           (name[1] == '_' && (int)strlen(name) > 2)))
 142     {
 143         if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
 144             /* 1999-02-27 mjd@plover.com */
 145             char *p;
 146             p = strchr(name, '\0');
 147             /* The next block assumes the buffer is at least 205 chars
 148                long.  At present, it's always at least 256 chars. */
 149             if (p-name > 200) {
 150                 strcpy(name+200, "...");
 151                 p = name+199;
 152             }
 153             else {
 154                 p[1] = '\0';
 155             }
 156             /* Move everything else down one character */
 157             for (; p-name > 2; p--)
 158                 *p = *(p-1);
 159             name[2] = toCTRL(name[1]);
 160             name[1] = '^';
 161         }
 162         yyerror(Perl_form(aTHX_ "Can't use global %s in \"my\"",name));
 163     }
 164     if (ckWARN(WARN_MISC) && AvFILLp(PL_comppad_name) >= 0) {
 165         SV **svp = AvARRAY(PL_comppad_name);
 166         HV *ourstash = (PL_curstash ? PL_curstash : PL_defstash);
 167         PADOFFSET top = AvFILLp(PL_comppad_name);
 168         for (off = top; off > PL_comppad_name_floor; off--) {
 169             if ((sv = svp[off])
 170                 && sv != &PL_sv_undef
 171                 && (SvIVX(sv) == PAD_MAX || SvIVX(sv) == 0)
 172                 && (PL_in_my != KEY_our
 173                     || ((SvFLAGS(sv) & SVpad_OUR) && GvSTASH(sv) == ourstash))
 174                 && strEQ(name, SvPVX(sv)))
 175             {
 176                 Perl_warner(aTHX_ WARN_MISC,
 177                     "\"%s\" variable %s masks earlier declaration in same %s",
 178                     (PL_in_my == KEY_our ? "our" : "my"),
 179                     name,
 180                     (SvIVX(sv) == PAD_MAX ? "scope" : "statement"));
 181                 --off;
 182                 break;
 183             }
 184         }
 185         if (PL_in_my == KEY_our) {
 186             do {
 187                 if ((sv = svp[off])
 188                     && sv != &PL_sv_undef
 189                     && (SvIVX(sv) == PAD_MAX || SvIVX(sv) == 0)
 190                     && ((SvFLAGS(sv) & SVpad_OUR) && GvSTASH(sv) == ourstash)
 191                     && strEQ(name, SvPVX(sv)))
 192                 {
 193                     Perl_warner(aTHX_ WARN_MISC,
 194                         "\"our\" variable %s redeclared", name);
 195                     Perl_warner(aTHX_ WARN_MISC,
 196                         "\t(Did you mean \"local\" instead of \"our\"?)\n");
 197                     break;
 198                 }
 199             } while ( off-- > 0 );
 200         }
 201     }
 202     off = pad_alloc(OP_PADSV, SVs_PADMY);
 203     sv = NEWSV(1102,0);
 204     sv_upgrade(sv, SVt_PVNV);
 205     sv_setpv(sv, name);
 206     if (PL_in_my_stash) {
 207         if (*name != '$')
 208             yyerror(Perl_form(aTHX_ "Can't declare class for non-scalar %s in \"%s\"",
 209                          name, PL_in_my == KEY_our ? "our" : "my"));
 210         SvOBJECT_on(sv);
 211         (void)SvUPGRADE(sv, SVt_PVMG);
 212         SvSTASH(sv) = (HV*)SvREFCNT_inc(PL_in_my_stash);
 213         PL_sv_objcount++;
 214     }
 215     if (PL_in_my == KEY_our) {
 216         (void)SvUPGRADE(sv, SVt_PVGV);
 217         GvSTASH(sv) = (HV*)SvREFCNT_inc(PL_curstash ? (SV*)PL_curstash : (SV*)PL_defstash);
 218         SvFLAGS(sv) |= SVpad_OUR;
 219     }
 220     av_store(PL_comppad_name, off, sv);
 221     SvNVX(sv) = (NV)PAD_MAX;
 222     SvIVX(sv) = 0;                      /* Not yet introduced--see newSTATEOP */
 223     if (!PL_min_intro_pending)
 224         PL_min_intro_pending = off;
 225     PL_max_intro_pending = off;
 226     if (*name == '@')
 227         av_store(PL_comppad, off, (SV*)newAV());
 228     else if (*name == '%')
 229         av_store(PL_comppad, off, (SV*)newHV());
 230     SvPADMY_on(PL_curpad[off]);
 231     return off;
 232 }
 233
 234 STATIC PADOFFSET
 235 S_pad_addlex(pTHX_ SV *proto_namesv)
 236 {
 237     SV *namesv = NEWSV(1103,0);
 238     PADOFFSET newoff = pad_alloc(OP_PADSV, SVs_PADMY);
 239     sv_upgrade(namesv, SVt_PVNV);
 240     sv_setpv(namesv, SvPVX(proto_namesv));
 241     av_store(PL_comppad_name, newoff, namesv);
 242     SvNVX(namesv) = (NV)PL_curcop->cop_seq;
 243     SvIVX(namesv) = PAD_MAX;                    /* A ref, intro immediately */
 244     SvFAKE_on(namesv);                          /* A ref, not a real var */
 245     if (SvFLAGS(proto_namesv) & SVpad_OUR) {    /* An "our" variable */
 246         SvFLAGS(namesv) |= SVpad_OUR;
 247         (void)SvUPGRADE(namesv, SVt_PVGV);
 248         GvSTASH(namesv) = (HV*)SvREFCNT_inc((SV*)GvSTASH(proto_namesv));
 249     }
 250     if (SvOBJECT(proto_namesv)) {               /* A typed var */
 251         SvOBJECT_on(namesv);
 252         (void)SvUPGRADE(namesv, SVt_PVMG);
 253         SvSTASH(namesv) = (HV*)SvREFCNT_inc((SV*)SvSTASH(proto_namesv));
 254         PL_sv_objcount++;
 255     }
 256     return newoff;
 257 }
 258
 259 #define FINDLEX_NOSEARCH        1               /* don't search outer contexts */
 260
 261 STATIC PADOFFSET
 262 S_pad_findlex(pTHX_ char *name, PADOFFSET newoff, U32 seq, CV* startcv,
 263             I32 cx_ix, I32 saweval, U32 flags)
 264 {
 265     CV *cv;
 266     I32 off;
 267     SV *sv;
 268     register I32 i;
 269     register PERL_CONTEXT *cx;
 270
 271     for (cv = startcv; cv; cv = CvOUTSIDE(cv)) {
 272         AV *curlist = CvPADLIST(cv);
 273         SV **svp = av_fetch(curlist, 0, FALSE);
 274         AV *curname;
 275
 276         if (!svp || *svp == &PL_sv_undef)
 277             continue;
 278         curname = (AV*)*svp;
 279         svp = AvARRAY(curname);
 280         for (off = AvFILLp(curname); off > 0; off--) {
 281             if ((sv = svp[off]) &&
 282                 sv != &PL_sv_undef &&
 283                 seq <= SvIVX(sv) &&
 284                 seq > I_32(SvNVX(sv)) &&
 285                 strEQ(SvPVX(sv), name))
 286             {
 287                 I32 depth;
 288                 AV *oldpad;
 289                 SV *oldsv;
 290
 291                 depth = CvDEPTH(cv);
 292                 if (!depth) {
 293                     if (newoff) {
 294                         if (SvFAKE(sv))
 295                             continue;
 296                         return 0; /* don't clone from inactive stack frame */
 297                     }
 298                     depth = 1;
 299                 }
 300                 oldpad = (AV*)AvARRAY(curlist)[depth];
 301                 oldsv = *av_fetch(oldpad, off, TRUE);
 302                 if (!newoff) {          /* Not a mere clone operation. */
 303                     newoff = pad_addlex(sv);
 304                     if (CvANON(PL_compcv) || SvTYPE(PL_compcv) == SVt_PVFM) {
 305                         /* "It's closures all the way down." */
 306                         CvCLONE_on(PL_compcv);
 307                         if (cv == startcv) {
 308                             if (CvANON(PL_compcv))
 309                                 oldsv = Nullsv; /* no need to keep ref */
 310                         }
 311                         else {
 312                             CV *bcv;
 313                             for (bcv = startcv;
 314                                  bcv && bcv != cv && !CvCLONE(bcv);
 315                                  bcv = CvOUTSIDE(bcv))
 316                             {
 317                                 if (CvANON(bcv)) {
 318                                     /* install the missing pad entry in intervening
 319                                      * nested subs and mark them cloneable.
 320                                      * XXX fix pad_foo() to not use globals */
 321                                     AV *ocomppad_name = PL_comppad_name;
 322                                     AV *ocomppad = PL_comppad;
 323                                     SV **ocurpad = PL_curpad;
 324                                     AV *padlist = CvPADLIST(bcv);
 325                                     PL_comppad_name = (AV*)AvARRAY(padlist)[0];
 326                                     PL_comppad = (AV*)AvARRAY(padlist)[1];
 327                                     PL_curpad = AvARRAY(PL_comppad);
 328                                     pad_addlex(sv);
 329                                     PL_comppad_name = ocomppad_name;
 330                                     PL_comppad = ocomppad;
 331                                     PL_curpad = ocurpad;
 332                                     CvCLONE_on(bcv);
 333                                 }
 334                                 else {
 335                                     if (ckWARN(WARN_CLOSURE)
 336                                         && !CvUNIQUE(bcv) && !CvUNIQUE(cv))
 337                                     {
 338                                         Perl_warner(aTHX_ WARN_CLOSURE,
 339                                           "Variable \"%s\" may be unavailable",
 340                                              name);
 341                                     }
 342                                     break;
 343                                 }
 344                             }
 345                         }
 346                     }
 347                     else if (!CvUNIQUE(PL_compcv)) {
 348                         if (ckWARN(WARN_CLOSURE) && !SvFAKE(sv) && !CvUNIQUE(cv)
 349                             && !(SvFLAGS(sv) & SVpad_OUR))
 350                         {
 351                             Perl_warner(aTHX_ WARN_CLOSURE,
 352                                 "Variable \"%s\" will not stay shared", name);
 353                         }
 354                     }
 355                 }
 356                 av_store(PL_comppad, newoff, SvREFCNT_inc(oldsv));
 357                 return newoff;
 358             }
 359         }
 360     }
 361
 362     if (flags & FINDLEX_NOSEARCH)
 363         return 0;
 364
 365     /* Nothing in current lexical context--try eval's context, if any.
 366      * This is necessary to let the perldb get at lexically scoped variables.
 367      * XXX This will also probably interact badly with eval tree caching.
 368      */
 369
 370     for (i = cx_ix; i >= 0; i--) {
 371         cx = &cxstack[i];
 372         switch (CxTYPE(cx)) {
 373         default:
 374             if (i == 0 && saweval) {
 375                 seq = cxstack[saweval].blk_oldcop->cop_seq;
 376                 return pad_findlex(name, newoff, seq, PL_main_cv, -1, saweval, 0);
 377             }
 378             break;
 379         case CXt_EVAL:
 380             switch (cx->blk_eval.old_op_type) {
 381             case OP_ENTEREVAL:
 382                 if (CxREALEVAL(cx))
 383                     saweval = i;
 384                 break;
 385             case OP_DOFILE:
 386             case OP_REQUIRE:
 387                 /* require/do must have their own scope */
 388                 return 0;
 389             }
 390             break;
 391         case CXt_FORMAT:
 392         case CXt_SUB:
 393             if (!saweval)
 394                 return 0;
 395             cv = cx->blk_sub.cv;
 396             if (PL_debstash && CvSTASH(cv) == PL_debstash) {    /* ignore DB'* scope */
 397                 saweval = i;    /* so we know where we were called from */
 398                 continue;
 399             }
 400             seq = cxstack[saweval].blk_oldcop->cop_seq;
 401             return pad_findlex(name, newoff, seq, cv, i-1, saweval,FINDLEX_NOSEARCH);
 402         }
 403     }
 404
 405     return 0;
 406 }
 407
 408 PADOFFSET
 409 Perl_pad_findmy(pTHX_ char *name)
 410 {
 411     I32 off;
 412     I32 pendoff = 0;
 413     SV *sv;
 414     SV **svp = AvARRAY(PL_comppad_name);
 415     U32 seq = PL_cop_seqmax;
 416     PERL_CONTEXT *cx;
 417     CV *outside;
 418
 419 #ifdef USE_THREADS
 420     /*
 421      * Special case to get lexical (and hence per-thread) @_.
 422      * XXX I need to find out how to tell at parse-time whether use
 423      * of @_ should refer to a lexical (from a sub) or defgv (global
 424      * scope and maybe weird sub-ish things like formats). See
 425      * startsub in perly.y.  It's possible that @_ could be lexical
 426      * (at least from subs) even in non-threaded perl.
 427      */
 428     if (strEQ(name, "@_"))
 429         return 0;               /* success. (NOT_IN_PAD indicates failure) */
 430 #endif /* USE_THREADS */
 431
 432     /* The one we're looking for is probably just before comppad_name_fill. */
 433     for (off = AvFILLp(PL_comppad_name); off > 0; off--) {
 434         if ((sv = svp[off]) &&
 435             sv != &PL_sv_undef &&
 436             (!SvIVX(sv) ||
 437              (seq <= SvIVX(sv) &&
 438               seq > I_32(SvNVX(sv)))) &&
 439             strEQ(SvPVX(sv), name))
 440         {
 441             if (SvIVX(sv) || SvFLAGS(sv) & SVpad_OUR)
 442                 return (PADOFFSET)off;
 443             pendoff = off;      /* this pending def. will override import */
 444         }
 445     }
 446
 447     outside = CvOUTSIDE(PL_compcv);
 448
 449     /* Check if if we're compiling an eval'', and adjust seq to be the
 450      * eval's seq number.  This depends on eval'' having a non-null
 451      * CvOUTSIDE() while it is being compiled.  The eval'' itself is
 452      * identified by CvEVAL being true and CvGV being null. */
 453     if (outside && CvEVAL(PL_compcv) && !CvGV(PL_compcv) && cxstack_ix >= 0) {
 454         cx = &cxstack[cxstack_ix];
 455         if (CxREALEVAL(cx))
 456             seq = cx->blk_oldcop->cop_seq;
 457     }
 458
 459     /* See if it's in a nested scope */
 460     off = pad_findlex(name, 0, seq, outside, cxstack_ix, 0, 0);
 461     if (off) {
 462         /* If there is a pending local definition, this new alias must die */
 463         if (pendoff)
 464             SvIVX(AvARRAY(PL_comppad_name)[off]) = seq;
 465         return off;             /* pad_findlex returns 0 for failure...*/
 466     }
 467     return NOT_IN_PAD;          /* ...but we return NOT_IN_PAD for failure */
 468 }
 469
 470 void
 471 Perl_pad_leavemy(pTHX_ I32 fill)
 472 {
 473     I32 off;
 474     SV **svp = AvARRAY(PL_comppad_name);
 475     SV *sv;
 476     if (PL_min_intro_pending && fill < PL_min_intro_pending) {
 477         for (off = PL_max_intro_pending; off >= PL_min_intro_pending; off--) {
 478             if ((sv = svp[off]) && sv != &PL_sv_undef && ckWARN_d(WARN_INTERNAL))
 479                 Perl_warner(aTHX_ WARN_INTERNAL, "%s never introduced", SvPVX(sv));
 480         }
 481     }
 482     /* "Deintroduce" my variables that are leaving with this scope. */
 483     for (off = AvFILLp(PL_comppad_name); off > fill; off--) {
 484         if ((sv = svp[off]) && sv != &PL_sv_undef && SvIVX(sv) == PAD_MAX)
 485             SvIVX(sv) = PL_cop_seqmax;
 486     }
 487 }
 488
 489 PADOFFSET
 490 Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype)
 491 {
 492     SV *sv;
 493     I32 retval;
 494
 495     if (AvARRAY(PL_comppad) != PL_curpad)
 496         Perl_croak(aTHX_ "panic: pad_alloc");
 497     if (PL_pad_reset_pending)
 498         pad_reset();
 499     if (tmptype & SVs_PADMY) {
 500         do {
 501             sv = *av_fetch(PL_comppad, AvFILLp(PL_comppad) + 1, TRUE);
 502         } while (SvPADBUSY(sv));                /* need a fresh one */
 503         retval = AvFILLp(PL_comppad);
 504     }
 505     else {
 506         SV **names = AvARRAY(PL_comppad_name);
 507         SSize_t names_fill = AvFILLp(PL_comppad_name);
 508         for (;;) {
 509             /*
 510              * "foreach" index vars temporarily become aliases to non-"my"
 511              * values.  Thus we must skip, not just pad values that are
 512              * marked as current pad values, but also those with names.
 513              */
 514             if (++PL_padix <= names_fill &&
 515                    (sv = names[PL_padix]) && sv != &PL_sv_undef)
 516                 continue;
 517             sv = *av_fetch(PL_comppad, PL_padix, TRUE);
 518             if (!(SvFLAGS(sv) & (SVs_PADTMP|SVs_PADMY)) &&
 519                 !IS_PADGV(sv) && !IS_PADCONST(sv))
 520                 break;
 521         }
 522         retval = PL_padix;
 523     }
 524     SvFLAGS(sv) |= tmptype;
 525     PL_curpad = AvARRAY(PL_comppad);
 526 #ifdef USE_THREADS
 527     DEBUG_X(PerlIO_printf(Perl_debug_log,
 528                           "0x%"UVxf" Pad 0x%"UVxf" alloc %ld for %s\n",
 529                           PTR2UV(thr), PTR2UV(PL_curpad),
 530                           (long) retval, PL_op_name[optype]));
 531 #else
 532     DEBUG_X(PerlIO_printf(Perl_debug_log,
 533                           "Pad 0x%"UVxf" alloc %ld for %s\n",
 534                           PTR2UV(PL_curpad),
 535                           (long) retval, PL_op_name[optype]));
 536 #endif /* USE_THREADS */
 537     return (PADOFFSET)retval;
 538 }
 539
 540 SV *
 541 Perl_pad_sv(pTHX_ PADOFFSET po)
 542 {
 543 #ifdef USE_THREADS
 544     DEBUG_X(PerlIO_printf(Perl_debug_log,
 545                           "0x%"UVxf" Pad 0x%"UVxf" sv %"IVdf"\n",
 546                           PTR2UV(thr), PTR2UV(PL_curpad), (IV)po));
 547 #else
 548     if (!po)
 549         Perl_croak(aTHX_ "panic: pad_sv po");
 550     DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" sv %"IVdf"\n",
 551                           PTR2UV(PL_curpad), (IV)po));
 552 #endif /* USE_THREADS */
 553     return PL_curpad[po];               /* eventually we'll turn this into a macro */
 554 }
 555
 556 void
 557 Perl_pad_free(pTHX_ PADOFFSET po)
 558 {
 559     if (!PL_curpad)
 560         return;
 561     if (AvARRAY(PL_comppad) != PL_curpad)
 562         Perl_croak(aTHX_ "panic: pad_free curpad");
 563     if (!po)
 564         Perl_croak(aTHX_ "panic: pad_free po");
 565 #ifdef USE_THREADS
 566     DEBUG_X(PerlIO_printf(Perl_debug_log,
 567                           "0x%"UVxf" Pad 0x%"UVxf" free %"IVdf"\n",
 568                           PTR2UV(thr), PTR2UV(PL_curpad), (IV)po));
 569 #else
 570     DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" free %"IVdf"\n",
 571                           PTR2UV(PL_curpad), (IV)po));
 572 #endif /* USE_THREADS */
 573     if (PL_curpad[po] && PL_curpad[po] != &PL_sv_undef) {
 574         SvPADTMP_off(PL_curpad[po]);
 575 #ifdef USE_ITHREADS
 576         SvREADONLY_off(PL_curpad[po]);  /* could be a freed constant */
 577 #endif
 578     }
 579     if ((I32)po < PL_padix)
 580         PL_padix = po - 1;
 581 }
 582
 583 void
 584 Perl_pad_swipe(pTHX_ PADOFFSET po)
 585 {
 586     if (AvARRAY(PL_comppad) != PL_curpad)
 587         Perl_croak(aTHX_ "panic: pad_swipe curpad");
 588     if (!po)
 589         Perl_croak(aTHX_ "panic: pad_swipe po");
 590 #ifdef USE_THREADS
 591     DEBUG_X(PerlIO_printf(Perl_debug_log,
 592                           "0x%"UVxf" Pad 0x%"UVxf" swipe %"IVdf"\n",
 593                           PTR2UV(thr), PTR2UV(PL_curpad), (IV)po));
 594 #else
 595     DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" swipe %"IVdf"\n",
 596                           PTR2UV(PL_curpad), (IV)po));
 597 #endif /* USE_THREADS */
 598     SvPADTMP_off(PL_curpad[po]);
 599     PL_curpad[po] = NEWSV(1107,0);
 600     SvPADTMP_on(PL_curpad[po]);
 601     if ((I32)po < PL_padix)
 602         PL_padix = po - 1;
 603 }
 604
 605 /* XXX pad_reset() is currently disabled because it results in serious bugs.
 606  * It causes pad temp TARGs to be shared between OPs. Since TARGs are pushed
 607  * on the stack by OPs that use them, there are several ways to get an alias
 608  * to  a shared TARG.  Such an alias will change randomly and unpredictably.
 609  * We avoid doing this until we can think of a Better Way.
 610  * GSAR 97-10-29 */
 611 void
 612 Perl_pad_reset(pTHX)
 613 {
 614 #ifdef USE_BROKEN_PAD_RESET
 615     register I32 po;
 616
 617     if (AvARRAY(PL_comppad) != PL_curpad)
 618         Perl_croak(aTHX_ "panic: pad_reset curpad");
 619 #ifdef USE_THREADS
 620     DEBUG_X(PerlIO_printf(Perl_debug_log,
 621                           "0x%"UVxf" Pad 0x%"UVxf" reset\n",
 622                           PTR2UV(thr), PTR2UV(PL_curpad)));
 623 #else
 624     DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" reset\n",
 625                           PTR2UV(PL_curpad)));
 626 #endif /* USE_THREADS */
 627     if (!PL_tainting) { /* Can't mix tainted and non-tainted temporaries. */
 628         for (po = AvMAX(PL_comppad); po > PL_padix_floor; po--) {
 629             if (PL_curpad[po] && !SvIMMORTAL(PL_curpad[po]))
 630                 SvPADTMP_off(PL_curpad[po]);
 631         }
 632         PL_padix = PL_padix_floor;
 633     }
 634 #endif
 635     PL_pad_reset_pending = FALSE;
 636 }
 637
 638 #ifdef USE_THREADS
 639 /* find_threadsv is not reentrant */
 640 PADOFFSET
 641 Perl_find_threadsv(pTHX_ const char *name)
 642 {
 643     char *p;
 644     PADOFFSET key;
 645     SV **svp;
 646     /* We currently only handle names of a single character */
 647     p = strchr(PL_threadsv_names, *name);
 648     if (!p)
 649         return NOT_IN_PAD;
 650     key = p - PL_threadsv_names;
 651     MUTEX_LOCK(&thr->mutex);
 652     svp = av_fetch(thr->threadsv, key, FALSE);
 653     if (svp)
 654         MUTEX_UNLOCK(&thr->mutex);
 655     else {
 656         SV *sv = NEWSV(0, 0);
 657         av_store(thr->threadsv, key, sv);
 658         thr->threadsvp = AvARRAY(thr->threadsv);
 659         MUTEX_UNLOCK(&thr->mutex);
 660         /*
 661          * Some magic variables used to be automagically initialised
 662          * in gv_fetchpv. Those which are now per-thread magicals get
 663          * initialised here instead.
 664          */
 665         switch (*name) {
 666         case '_':
 667             break;
 668         case ';':
 669             sv_setpv(sv, "\034");
 670             sv_magic(sv, 0, 0, name, 1);
 671             break;
 672         case '&':
 673         case '`':
 674         case '\'':
 675             PL_sawampersand = TRUE;
 676             /* FALL THROUGH */
 677         case '1':
 678         case '2':
 679         case '3':
 680         case '4':
 681         case '5':
 682         case '6':
 683         case '7':
 684         case '8':
 685         case '9':
 686             SvREADONLY_on(sv);
 687             /* FALL THROUGH */
 688
 689         /* XXX %! tied to Errno.pm needs to be added here.
 690          * See gv_fetchpv(). */
 691         /* case '!': */
 692
 693         default:
 694             sv_magic(sv, 0, 0, name, 1);
 695         }
 696         DEBUG_S(PerlIO_printf(Perl_error_log,
 697                               "find_threadsv: new SV %p for $%s%c\n",
 698                               sv, (*name < 32) ? "^" : "",
 699                               (*name < 32) ? toCTRL(*name) : *name));
 700     }
 701     return key;
 702 }
 703 #endif /* USE_THREADS */
 704
 705 /* Destructor */
 706
 707 void
 708 Perl_op_free(pTHX_ OP *o)
 709 {
 710     register OP *kid, *nextkid;
 711     OPCODE type;
 712
 713     if (!o || o->op_seq == (U16)-1)
 714         return;
 715
 716     if (o->op_private & OPpREFCOUNTED) {
 717         switch (o->op_type) {
 718         case OP_LEAVESUB:
 719         case OP_LEAVESUBLV:
 720         case OP_LEAVEEVAL:
 721         case OP_LEAVE:
 722         case OP_SCOPE:
 723         case OP_LEAVEWRITE:
 724             OP_REFCNT_LOCK;
 725             if (OpREFCNT_dec(o)) {
 726                 OP_REFCNT_UNLOCK;
 727                 return;
 728             }
 729             OP_REFCNT_UNLOCK;
 730             break;
 731         default:
 732             break;
 733         }
 734     }
 735
 736     if (o->op_flags & OPf_KIDS) {
 737         for (kid = cUNOPo->op_first; kid; kid = nextkid) {
 738             nextkid = kid->op_sibling; /* Get before next freeing kid */
 739             op_free(kid);
 740         }
 741     }
 742     type = o->op_type;
 743     if (type == OP_NULL)
 744         type = o->op_targ;
 745
 746     /* COP* is not cleared by op_clear() so that we may track line
 747      * numbers etc even after null() */
 748     if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE)
 749         cop_free((COP*)o);
 750
 751     op_clear(o);
 752
 753 #ifdef PL_OP_SLAB_ALLOC
 754     if ((char *) o == PL_OpPtr)
 755      {
 756      }
 757 #else
 758     Safefree(o);
 759 #endif
 760 }
 761
 762 STATIC void
 763 S_op_clear(pTHX_ OP *o)
 764 {
 765     switch (o->op_type) {
 766     case OP_NULL:       /* Was holding old type, if any. */
 767     case OP_ENTEREVAL:  /* Was holding hints. */
 768 #ifdef USE_THREADS
 769     case OP_THREADSV:   /* Was holding index into thr->threadsv AV. */
 770 #endif
 771         o->op_targ = 0;
 772         break;
 773 #ifdef USE_THREADS
 774     case OP_ENTERITER:
 775         if (!(o->op_flags & OPf_SPECIAL))
 776             break;
 777         /* FALL THROUGH */
 778 #endif /* USE_THREADS */
 779     default:
 780         if (!(o->op_flags & OPf_REF)
 781             || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
 782             break;
 783         /* FALL THROUGH */
 784     case OP_GVSV:
 785     case OP_GV:
 786     case OP_AELEMFAST:
 787 #ifdef USE_ITHREADS
 788         if (cPADOPo->op_padix > 0) {
 789             if (PL_curpad) {
 790                 GV *gv = cGVOPo_gv;
 791                 pad_swipe(cPADOPo->op_padix);
 792                 /* No GvIN_PAD_off(gv) here, because other references may still
 793                  * exist on the pad */
 794                 SvREFCNT_dec(gv);
 795             }
 796             cPADOPo->op_padix = 0;
 797         }
 798 #else
 799         SvREFCNT_dec(cSVOPo->op_sv);
 800         cSVOPo->op_sv = Nullsv;
 801 #endif
 802         break;
 803     case OP_METHOD_NAMED:
 804     case OP_CONST:
 805         SvREFCNT_dec(cSVOPo->op_sv);
 806         cSVOPo->op_sv = Nullsv;
 807         break;
 808     case OP_GOTO:
 809     case OP_NEXT:
 810     case OP_LAST:
 811     case OP_REDO:
 812         if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
 813             break;
 814         /* FALL THROUGH */
 815     case OP_TRANS:
 816         if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
 817             SvREFCNT_dec(cSVOPo->op_sv);
 818             cSVOPo->op_sv = Nullsv;
 819         }
 820         else {
 821             Safefree(cPVOPo->op_pv);
 822             cPVOPo->op_pv = Nullch;
 823         }
 824         break;
 825     case OP_SUBST:
 826         op_free(cPMOPo->op_pmreplroot);
 827         goto clear_pmop;
 828     case OP_PUSHRE:
 829 #ifdef USE_ITHREADS
 830         if ((PADOFFSET)cPMOPo->op_pmreplroot) {
 831             if (PL_curpad) {
 832                 GV *gv = (GV*)PL_curpad[(PADOFFSET)cPMOPo->op_pmreplroot];
 833                 pad_swipe((PADOFFSET)cPMOPo->op_pmreplroot);
 834                 /* No GvIN_PAD_off(gv) here, because other references may still
 835                  * exist on the pad */
 836                 SvREFCNT_dec(gv);
 837             }
 838         }
 839 #else
 840         SvREFCNT_dec((SV*)cPMOPo->op_pmreplroot);
 841 #endif
 842         /* FALL THROUGH */
 843     case OP_MATCH:
 844     case OP_QR:
 845 clear_pmop:
 846         {
 847             HV *pmstash = PmopSTASH(cPMOPo);
 848             if (pmstash && SvREFCNT(pmstash)) {
 849                 PMOP *pmop = HvPMROOT(pmstash);
 850                 PMOP *lastpmop = NULL;
 851                 while (pmop) {
 852                     if (cPMOPo == pmop) {
 853                         if (lastpmop)
 854                             lastpmop->op_pmnext = pmop->op_pmnext;
 855                         else
 856                             HvPMROOT(pmstash) = pmop->op_pmnext;
 857                         break;
 858                     }
 859                     lastpmop = pmop;
 860                     pmop = pmop->op_pmnext;
 861                 }
 862 #ifdef USE_ITHREADS
 863                 Safefree(PmopSTASHPV(cPMOPo));
 864 #else
 865                 /* NOTE: PMOP.op_pmstash is not refcounted */
 866 #endif
 867             }
 868         }
 869         cPMOPo->op_pmreplroot = Nullop;
 870         ReREFCNT_dec(cPMOPo->op_pmregexp);
 871         cPMOPo->op_pmregexp = (REGEXP*)NULL;
 872         break;
 873     }
 874
 875     if (o->op_targ > 0) {
 876         pad_free(o->op_targ);
 877         o->op_targ = 0;
 878     }
 879 }
 880
 881 STATIC void
 882 S_cop_free(pTHX_ COP* cop)
 883 {
 884     Safefree(cop->cop_label);
 885 #ifdef USE_ITHREADS
 886     Safefree(CopFILE(cop));             /* XXX share in a pvtable? */
 887     Safefree(CopSTASHPV(cop));          /* XXX share in a pvtable? */
 888 #else
 889     /* NOTE: COP.cop_stash is not refcounted */
 890     SvREFCNT_dec(CopFILEGV(cop));
 891 #endif
 892     if (! specialWARN(cop->cop_warnings))
 893         SvREFCNT_dec(cop->cop_warnings);
 894     if (! specialCopIO(cop->cop_io))
 895         SvREFCNT_dec(cop->cop_io);
 896 }
 897
 898 STATIC void
 899 S_null(pTHX_ OP *o)
 900 {
 901     if (o->op_type == OP_NULL)
 902         return;
 903     op_clear(o);
 904     o->op_targ = o->op_type;
 905     o->op_type = OP_NULL;
 906     o->op_ppaddr = PL_ppaddr[OP_NULL];
 907 }
 908
 909 /* Contextualizers */
 910
 911 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
 912
 913 OP *
 914 Perl_linklist(pTHX_ OP *o)
 915 {
 916     register OP *kid;
 917
 918     if (o->op_next)
 919         return o->op_next;
 920
 921     /* establish postfix order */
 922     if (cUNOPo->op_first) {
 923         o->op_next = LINKLIST(cUNOPo->op_first);
 924         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
 925             if (kid->op_sibling)
 926                 kid->op_next = LINKLIST(kid->op_sibling);
 927             else
 928                 kid->op_next = o;
 929         }
 930     }
 931     else
 932         o->op_next = o;
 933
 934     return o->op_next;
 935 }
 936
 937 OP *
 938 Perl_scalarkids(pTHX_ OP *o)
 939 {
 940     OP *kid;
 941     if (o && o->op_flags & OPf_KIDS) {
 942         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
 943             scalar(kid);
 944     }
 945     return o;
 946 }
 947
 948 STATIC OP *
 949 S_scalarboolean(pTHX_ OP *o)
 950 {
 951     if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
 952         if (ckWARN(WARN_SYNTAX)) {
 953             line_t oldline = CopLINE(PL_curcop);
 954
 955             if (PL_copline != NOLINE)
 956                 CopLINE_set(PL_curcop, PL_copline);
 957             Perl_warner(aTHX_ WARN_SYNTAX, "Found = in conditional, should be ==");
 958             CopLINE_set(PL_curcop, oldline);
 959         }
 960     }
 961     return scalar(o);
 962 }
 963
 964 OP *
 965 Perl_scalar(pTHX_ OP *o)
 966 {
 967     OP *kid;
 968
 969     /* assumes no premature commitment */
 970     if (!o || (o->op_flags & OPf_WANT) || PL_error_count
 971          || o->op_type == OP_RETURN)
 972     {
 973         return o;
 974     }
 975
 976     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
 977
 978     switch (o->op_type) {
 979     case OP_REPEAT:
 980         if (o->op_private & OPpREPEAT_DOLIST)
 981             null(((LISTOP*)cBINOPo->op_first)->op_first);
 982         scalar(cBINOPo->op_first);
 983         break;
 984     case OP_OR:
 985     case OP_AND:
 986     case OP_COND_EXPR:
 987         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
 988             scalar(kid);
 989         break;
 990     case OP_SPLIT:
 991         if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
 992             if (!kPMOP->op_pmreplroot)
 993                 deprecate("implicit split to @_");
 994         }
 995         /* FALL THROUGH */
 996     case OP_MATCH:
 997     case OP_QR:
 998     case OP_SUBST:
 999     case OP_NULL:
1000     default:
1001         if (o->op_flags & OPf_KIDS) {
1002             for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
1003                 scalar(kid);
1004         }
1005         break;
1006     case OP_LEAVE:
1007     case OP_LEAVETRY:
1008         kid = cLISTOPo->op_first;
1009         scalar(kid);
1010         while ((kid = kid->op_sibling)) {
1011             if (kid->op_sibling)
1012                 scalarvoid(kid);
1013             else
1014                 scalar(kid);
1015         }
1016         WITH_THR(PL_curcop = &PL_compiling);
1017         break;
1018     case OP_SCOPE:
1019     case OP_LINESEQ:
1020     case OP_LIST:
1021         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1022             if (kid->op_sibling)
1023                 scalarvoid(kid);
1024             else
1025                 scalar(kid);
1026         }
1027         WITH_THR(PL_curcop = &PL_compiling);
1028         break;
1029     }
1030     return o;
1031 }
1032
1033 OP *
1034 Perl_scalarvoid(pTHX_ OP *o)
1035 {
1036     OP *kid;
1037     char* useless = 0;
1038     SV* sv;
1039     U8 want;
1040
1041     if (o->op_type == OP_NEXTSTATE
1042         || o->op_type == OP_SETSTATE
1043         || o->op_type == OP_DBSTATE
1044         || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1045                                       || o->op_targ == OP_SETSTATE
1046                                       || o->op_targ == OP_DBSTATE)))
1047         PL_curcop = (COP*)o;            /* for warning below */
1048
1049     /* assumes no premature commitment */
1050     want = o->op_flags & OPf_WANT;
1051     if ((want && want != OPf_WANT_SCALAR) || PL_error_count
1052          || o->op_type == OP_RETURN)
1053     {
1054         return o;
1055     }
1056
1057     if ((o->op_private & OPpTARGET_MY)
1058         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1059     {
1060         return scalar(o);                       /* As if inside SASSIGN */
1061     }
1062
1063     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1064
1065     switch (o->op_type) {
1066     default:
1067         if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1068             break;
1069         /* FALL THROUGH */
1070     case OP_REPEAT:
1071         if (o->op_flags & OPf_STACKED)
1072             break;
1073         goto func_ops;
1074     case OP_SUBSTR:
1075         if (o->op_private == 4)
1076             break;
1077         /* FALL THROUGH */
1078     case OP_GVSV:
1079     case OP_WANTARRAY:
1080     case OP_GV:
1081     case OP_PADSV:
1082     case OP_PADAV:
1083     case OP_PADHV:
1084     case OP_PADANY:
1085     case OP_AV2ARYLEN:
1086     case OP_REF:
1087     case OP_REFGEN:
1088     case OP_SREFGEN:
1089     case OP_DEFINED:
1090     case OP_HEX:
1091     case OP_OCT:
1092     case OP_LENGTH:
1093     case OP_VEC:
1094     case OP_INDEX:
1095     case OP_RINDEX:
1096     case OP_SPRINTF:
1097     case OP_AELEM:
1098     case OP_AELEMFAST:
1099     case OP_ASLICE:
1100     case OP_HELEM:
1101     case OP_HSLICE:
1102     case OP_UNPACK:
1103     case OP_PACK:
1104     case OP_JOIN:
1105     case OP_LSLICE:
1106     case OP_ANONLIST:
1107     case OP_ANONHASH:
1108     case OP_SORT:
1109     case OP_REVERSE:
1110     case OP_RANGE:
1111     case OP_FLIP:
1112     case OP_FLOP:
1113     case OP_CALLER:
1114     case OP_FILENO:
1115     case OP_EOF:
1116     case OP_TELL:
1117     case OP_GETSOCKNAME:
1118     case OP_GETPEERNAME:
1119     case OP_READLINK:
1120     case OP_TELLDIR:
1121     case OP_GETPPID:
1122     case OP_GETPGRP:
1123     case OP_GETPRIORITY:
1124     case OP_TIME:
1125     case OP_TMS:
1126     case OP_LOCALTIME:
1127     case OP_GMTIME:
1128     case OP_GHBYNAME:
1129     case OP_GHBYADDR:
1130     case OP_GHOSTENT:
1131     case OP_GNBYNAME:
1132     case OP_GNBYADDR:
1133     case OP_GNETENT:
1134     case OP_GPBYNAME:
1135     case OP_GPBYNUMBER:
1136     case OP_GPROTOENT:
1137     case OP_GSBYNAME:
1138     case OP_GSBYPORT:
1139     case OP_GSERVENT:
1140     case OP_GPWNAM:
1141     case OP_GPWUID:
1142     case OP_GGRNAM:
1143     case OP_GGRGID:
1144     case OP_GETLOGIN:
1145       func_ops:
1146         if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1147             useless = PL_op_desc[o->op_type];
1148         break;
1149
1150     case OP_RV2GV:
1151     case OP_RV2SV:
1152     case OP_RV2AV:
1153     case OP_RV2HV:
1154         if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1155                 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
1156             useless = "a variable";
1157         break;
1158
1159     case OP_CONST:
1160         sv = cSVOPo_sv;
1161         if (cSVOPo->op_private & OPpCONST_STRICT)
1162             no_bareword_allowed(o);
1163         else {
1164             if (ckWARN(WARN_VOID)) {
1165                 useless = "a constant";
1166                 if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
1167                     useless = 0;
1168                 else if (SvPOK(sv)) {
1169                   /* perl4's way of mixing documentation and code
1170                      (before the invention of POD) was based on a
1171                      trick to mix nroff and perl code. The trick was
1172                      built upon these three nroff macros being used in
1173                      void context. The pink camel has the details in
1174                      the script wrapman near page 319. */
1175                     if (strnEQ(SvPVX(sv), "di", 2) ||
1176                         strnEQ(SvPVX(sv), "ds", 2) ||
1177                         strnEQ(SvPVX(sv), "ig", 2))
1178                             useless = 0;
1179                 }
1180             }
1181         }
1182         null(o);                /* don't execute or even remember it */
1183         break;
1184
1185     case OP_POSTINC:
1186         o->op_type = OP_PREINC;         /* pre-increment is faster */
1187         o->op_ppaddr = PL_ppaddr[OP_PREINC];
1188         break;
1189
1190     case OP_POSTDEC:
1191         o->op_type = OP_PREDEC;         /* pre-decrement is faster */
1192         o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1193         break;
1194
1195     case OP_OR:
1196     case OP_AND:
1197     case OP_COND_EXPR:
1198         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1199             scalarvoid(kid);
1200         break;
1201
1202     case OP_NULL:
1203         if (o->op_flags & OPf_STACKED)
1204             break;
1205         /* FALL THROUGH */
1206     case OP_NEXTSTATE:
1207     case OP_DBSTATE:
1208     case OP_ENTERTRY:
1209     case OP_ENTER:
1210         if (!(o->op_flags & OPf_KIDS))
1211             break;
1212         /* FALL THROUGH */
1213     case OP_SCOPE:
1214     case OP_LEAVE:
1215     case OP_LEAVETRY:
1216     case OP_LEAVELOOP:
1217     case OP_LINESEQ:
1218     case OP_LIST:
1219         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1220             scalarvoid(kid);
1221         break;
1222     case OP_ENTEREVAL:
1223         scalarkids(o);
1224         break;
1225     case OP_REQUIRE:
1226         /* all requires must return a boolean value */
1227         o->op_flags &= ~OPf_WANT;
1228         /* FALL THROUGH */
1229     case OP_SCALAR:
1230         return scalar(o);
1231     case OP_SPLIT:
1232         if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
1233             if (!kPMOP->op_pmreplroot)
1234                 deprecate("implicit split to @_");
1235         }
1236         break;
1237     }
1238     if (useless && ckWARN(WARN_VOID))
1239         Perl_warner(aTHX_ WARN_VOID, "Useless use of %s in void context", useless);
1240     return o;
1241 }
1242
1243 OP *
1244 Perl_listkids(pTHX_ OP *o)
1245 {
1246     OP *kid;
1247     if (o && o->op_flags & OPf_KIDS) {
1248         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1249             list(kid);
1250     }
1251     return o;
1252 }
1253
1254 OP *
1255 Perl_list(pTHX_ OP *o)
1256 {
1257     OP *kid;
1258
1259     /* assumes no premature commitment */
1260     if (!o || (o->op_flags & OPf_WANT) || PL_error_count
1261          || o->op_type == OP_RETURN)
1262     {
1263         return o;
1264     }
1265
1266     if ((o->op_private & OPpTARGET_MY)
1267         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1268     {
1269         return o;                               /* As if inside SASSIGN */
1270     }
1271
1272     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1273
1274     switch (o->op_type) {
1275     case OP_FLOP:
1276     case OP_REPEAT:
1277         list(cBINOPo->op_first);
1278         break;
1279     case OP_OR:
1280     case OP_AND:
1281     case OP_COND_EXPR:
1282         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1283             list(kid);
1284         break;
1285     default:
1286     case OP_MATCH:
1287     case OP_QR:
1288     case OP_SUBST:
1289     case OP_NULL:
1290         if (!(o->op_flags & OPf_KIDS))
1291             break;
1292         if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1293             list(cBINOPo->op_first);
1294             return gen_constant_list(o);
1295         }
1296     case OP_LIST:
1297         listkids(o);
1298         break;
1299     case OP_LEAVE:
1300     case OP_LEAVETRY:
1301         kid = cLISTOPo->op_first;
1302         list(kid);
1303         while ((kid = kid->op_sibling)) {
1304             if (kid->op_sibling)
1305                 scalarvoid(kid);
1306             else
1307                 list(kid);
1308         }
1309         WITH_THR(PL_curcop = &PL_compiling);
1310         break;
1311     case OP_SCOPE:
1312     case OP_LINESEQ:
1313         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1314             if (kid->op_sibling)
1315                 scalarvoid(kid);
1316             else
1317                 list(kid);
1318         }
1319         WITH_THR(PL_curcop = &PL_compiling);
1320         break;
1321     case OP_REQUIRE:
1322         /* all requires must return a boolean value */
1323         o->op_flags &= ~OPf_WANT;
1324         return scalar(o);
1325     }
1326     return o;
1327 }
1328
1329 OP *
1330 Perl_scalarseq(pTHX_ OP *o)
1331 {
1332     OP *kid;
1333
1334     if (o) {
1335         if (o->op_type == OP_LINESEQ ||
1336              o->op_type == OP_SCOPE ||
1337              o->op_type == OP_LEAVE ||
1338              o->op_type == OP_LEAVETRY)
1339         {
1340             for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1341                 if (kid->op_sibling) {
1342                     scalarvoid(kid);
1343                 }
1344             }
1345             PL_curcop = &PL_compiling;
1346         }
1347         o->op_flags &= ~OPf_PARENS;
1348         if (PL_hints & HINT_BLOCK_SCOPE)
1349             o->op_flags |= OPf_PARENS;
1350     }
1351     else
1352         o = newOP(OP_STUB, 0);
1353     return o;
1354 }
1355
1356 STATIC OP *
1357 S_modkids(pTHX_ OP *o, I32 type)
1358 {
1359     OP *kid;
1360     if (o && o->op_flags & OPf_KIDS) {
1361         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1362             mod(kid, type);
1363     }
1364     return o;
1365 }
1366
1367 OP *
1368 Perl_mod(pTHX_ OP *o, I32 type)
1369 {
1370     OP *kid;
1371     STRLEN n_a;
1372
1373     if (!o || PL_error_count)
1374         return o;
1375
1376     if ((o->op_private & OPpTARGET_MY)
1377         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1378     {
1379         return o;
1380     }
1381
1382     switch (o->op_type) {
1383     case OP_UNDEF:
1384         PL_modcount++;
1385         return o;
1386     case OP_CONST:
1387         if (o->op_private & (OPpCONST_BARE) &&
1388                 !(type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)) {
1389             SV *sv = ((SVOP*)o)->op_sv;
1390             GV *gv;
1391
1392             /* Could be a filehandle */
1393             if ((gv = gv_fetchpv(SvPV_nolen(sv), FALSE, SVt_PVIO))) {
1394                 OP* gvio = newUNOP(OP_RV2GV, 0, newGVOP(OP_GV, 0, gv));
1395                 op_free(o);
1396                 o = gvio;
1397             } else {
1398                 /* OK, it's a sub */
1399                 OP* enter;
1400                 gv = gv_fetchpv(SvPV_nolen(sv), TRUE, SVt_PVCV);
1401
1402                 enter = newUNOP(OP_ENTERSUB,0,
1403                         newUNOP(OP_RV2CV, 0,
1404                             newGVOP(OP_GV, 0, gv)
1405                         ));
1406                 enter->op_private |= OPpLVAL_INTRO;
1407                 op_free(o);
1408                 o = enter;
1409             }
1410             break;
1411         }
1412         if (!(o->op_private & (OPpCONST_ARYBASE)))
1413             goto nomod;
1414         if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1415             PL_compiling.cop_arybase = (I32)SvIV(cSVOPx(PL_eval_start)->op_sv);
1416             PL_eval_start = 0;
1417         }
1418         else if (!type) {
1419             SAVEI32(PL_compiling.cop_arybase);
1420             PL_compiling.cop_arybase = 0;
1421         }
1422         else if (type == OP_REFGEN)
1423             goto nomod;
1424         else
1425             Perl_croak(aTHX_ "That use of $[ is unsupported");
1426         break;
1427     case OP_STUB:
1428         if (o->op_flags & OPf_PARENS)
1429             break;
1430         goto nomod;
1431     case OP_ENTERSUB:
1432         if ((type == OP_UNDEF || type == OP_REFGEN) &&
1433             !(o->op_flags & OPf_STACKED)) {
1434             o->op_type = OP_RV2CV;              /* entersub => rv2cv */
1435             o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1436             assert(cUNOPo->op_first->op_type == OP_NULL);
1437             null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1438             break;
1439         }
1440         else {                          /* lvalue subroutine call */
1441             o->op_private |= OPpLVAL_INTRO;
1442             PL_modcount = RETURN_UNLIMITED_NUMBER;
1443             if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1444                 /* Backward compatibility mode: */
1445                 o->op_private |= OPpENTERSUB_INARGS;
1446                 break;
1447             }
1448             else {                      /* Compile-time error message: */
1449                 OP *kid = cUNOPo->op_first;
1450                 CV *cv;
1451                 OP *okid;
1452
1453                 if (kid->op_type == OP_PUSHMARK)
1454                     goto skip_kids;
1455                 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1456                     Perl_croak(aTHX_
1457                                "panic: unexpected lvalue entersub "
1458                                "args: type/targ %ld:%ld",
1459                                (long)kid->op_type,kid->op_targ);
1460                 kid = kLISTOP->op_first;
1461               skip_kids:
1462                 while (kid->op_sibling)
1463                     kid = kid->op_sibling;
1464                 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1465                     /* Indirect call */
1466                     if (kid->op_type == OP_METHOD_NAMED
1467                         || kid->op_type == OP_METHOD)
1468                     {
1469                         UNOP *newop;
1470
1471                         if (kid->op_sibling || kid->op_next != kid) {
1472                             yyerror("panic: unexpected optree near method call");
1473                             break;
1474                         }
1475
1476                         NewOp(1101, newop, 1, UNOP);
1477                         newop->op_type = OP_RV2CV;
1478                         newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1479                         newop->op_first = Nullop;
1480                         newop->op_next = (OP*)newop;
1481                         kid->op_sibling = (OP*)newop;
1482                         newop->op_private |= OPpLVAL_INTRO;
1483                         break;
1484                     }
1485
1486                     if (kid->op_type != OP_RV2CV)
1487                         Perl_croak(aTHX_
1488                                    "panic: unexpected lvalue entersub "
1489                                    "entry via type/targ %ld:%ld",
1490                                    (long)kid->op_type,kid->op_targ);
1491                     kid->op_private |= OPpLVAL_INTRO;
1492                     break;      /* Postpone until runtime */
1493                 }
1494
1495                 okid = kid;
1496                 kid = kUNOP->op_first;
1497                 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1498                     kid = kUNOP->op_first;
1499                 if (kid->op_type == OP_NULL)
1500                     Perl_croak(aTHX_
1501                                "Unexpected constant lvalue entersub "
1502                                "entry via type/targ %ld:%ld",
1503                                (long)kid->op_type,kid->op_targ);
1504                 if (kid->op_type != OP_GV) {
1505                     /* Restore RV2CV to check lvalueness */
1506                   restore_2cv:
1507                     if (kid->op_next && kid->op_next != kid) { /* Happens? */
1508                         okid->op_next = kid->op_next;
1509                         kid->op_next = okid;
1510                     }
1511                     else
1512                         okid->op_next = Nullop;
1513                     okid->op_type = OP_RV2CV;
1514                     okid->op_targ = 0;
1515                     okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1516                     okid->op_private |= OPpLVAL_INTRO;
1517                     break;
1518                 }
1519
1520                 cv = GvCV(kGVOP_gv);
1521                 if (!cv)
1522                     goto restore_2cv;
1523                 if (CvLVALUE(cv))
1524                     break;
1525             }
1526         }
1527         /* FALL THROUGH */
1528     default:
1529       nomod:
1530         /* grep, foreach, subcalls, refgen */
1531         if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1532             break;
1533         yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1534                      (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1535                       ? "do block"
1536                       : (o->op_type == OP_ENTERSUB
1537                         ? "non-lvalue subroutine call"
1538                         : PL_op_desc[o->op_type])),
1539                      type ? PL_op_desc[type] : "local"));
1540         return o;
1541
1542     case OP_PREINC:
1543     case OP_PREDEC:
1544     case OP_POW:
1545     case OP_MULTIPLY:
1546     case OP_DIVIDE:
1547     case OP_MODULO:
1548     case OP_REPEAT:
1549     case OP_ADD:
1550     case OP_SUBTRACT:
1551     case OP_CONCAT:
1552     case OP_LEFT_SHIFT:
1553     case OP_RIGHT_SHIFT:
1554     case OP_BIT_AND:
1555     case OP_BIT_XOR:
1556     case OP_BIT_OR:
1557     case OP_I_MULTIPLY:
1558     case OP_I_DIVIDE:
1559     case OP_I_MODULO:
1560     case OP_I_ADD:
1561     case OP_I_SUBTRACT:
1562         if (!(o->op_flags & OPf_STACKED))
1563             goto nomod;
1564         PL_modcount++;
1565         break;
1566
1567     case OP_COND_EXPR:
1568         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1569             mod(kid, type);
1570         break;
1571
1572     case OP_RV2AV:
1573     case OP_RV2HV:
1574         if (!type && cUNOPo->op_first->op_type != OP_GV)
1575             Perl_croak(aTHX_ "Can't localize through a reference");
1576         if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1577            PL_modcount = RETURN_UNLIMITED_NUMBER;
1578             return o;           /* Treat \(@foo) like ordinary list. */
1579         }
1580         /* FALL THROUGH */
1581     case OP_RV2GV:
1582         if (scalar_mod_type(o, type))
1583             goto nomod;
1584         ref(cUNOPo->op_first, o->op_type);
1585         /* FALL THROUGH */
1586     case OP_ASLICE:
1587     case OP_HSLICE:
1588         if (type == OP_LEAVESUBLV)
1589             o->op_private |= OPpMAYBE_LVSUB;
1590         /* FALL THROUGH */
1591     case OP_AASSIGN:
1592     case OP_NEXTSTATE:
1593     case OP_DBSTATE:
1594     case OP_CHOMP:
1595        PL_modcount = RETURN_UNLIMITED_NUMBER;
1596         break;
1597     case OP_RV2SV:
1598         if (!type && cUNOPo->op_first->op_type != OP_GV)
1599             Perl_croak(aTHX_ "Can't localize through a reference");
1600         ref(cUNOPo->op_first, o->op_type);
1601         /* FALL THROUGH */
1602     case OP_GV:
1603     case OP_AV2ARYLEN:
1604         PL_hints |= HINT_BLOCK_SCOPE;
1605     case OP_SASSIGN:
1606     case OP_ANDASSIGN:
1607     case OP_ORASSIGN:
1608     case OP_AELEMFAST:
1609         PL_modcount++;
1610         break;
1611
1612     case OP_PADAV:
1613     case OP_PADHV:
1614        PL_modcount = RETURN_UNLIMITED_NUMBER;
1615         if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1616             return o;           /* Treat \(@foo) like ordinary list. */
1617         if (scalar_mod_type(o, type))
1618             goto nomod;
1619         if (type == OP_LEAVESUBLV)
1620             o->op_private |= OPpMAYBE_LVSUB;
1621         /* FALL THROUGH */
1622     case OP_PADSV:
1623         PL_modcount++;
1624         if (!type)
1625             Perl_croak(aTHX_ "Can't localize lexical variable %s",
1626                 SvPV(*av_fetch(PL_comppad_name, o->op_targ, 4), n_a));
1627         break;
1628
1629 #ifdef USE_THREADS
1630     case OP_THREADSV:
1631         PL_modcount++;  /* XXX ??? */
1632         break;
1633 #endif /* USE_THREADS */
1634
1635     case OP_PUSHMARK:
1636         break;
1637
1638     case OP_KEYS:
1639         if (type != OP_SASSIGN)
1640             goto nomod;
1641         goto lvalue_func;
1642     case OP_SUBSTR:
1643         if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1644             goto nomod;
1645         /* FALL THROUGH */
1646     case OP_POS:
1647     case OP_VEC:
1648         if (type == OP_LEAVESUBLV)
1649             o->op_private |= OPpMAYBE_LVSUB;
1650       lvalue_func:
1651         pad_free(o->op_targ);
1652         o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1653         assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1654         if (o->op_flags & OPf_KIDS)
1655             mod(cBINOPo->op_first->op_sibling, type);
1656         break;
1657
1658     case OP_AELEM:
1659     case OP_HELEM:
1660         ref(cBINOPo->op_first, o->op_type);
1661         if (type == OP_ENTERSUB &&
1662              !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1663             o->op_private |= OPpLVAL_DEFER;
1664         if (type == OP_LEAVESUBLV)
1665             o->op_private |= OPpMAYBE_LVSUB;
1666         PL_modcount++;
1667         break;
1668
1669     case OP_SCOPE:
1670     case OP_LEAVE:
1671     case OP_ENTER:
1672     case OP_LINESEQ:
1673         if (o->op_flags & OPf_KIDS)
1674             mod(cLISTOPo->op_last, type);
1675         break;
1676
1677     case OP_NULL:
1678         if (o->op_flags & OPf_SPECIAL)          /* do BLOCK */
1679             goto nomod;
1680         else if (!(o->op_flags & OPf_KIDS))
1681             break;
1682         if (o->op_targ != OP_LIST) {
1683             mod(cBINOPo->op_first, type);
1684             break;
1685         }
1686         /* FALL THROUGH */
1687     case OP_LIST:
1688         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1689             mod(kid, type);
1690         break;
1691
1692     case OP_RETURN:
1693         if (type != OP_LEAVESUBLV)
1694             goto nomod;
1695         break; /* mod()ing was handled by ck_return() */
1696     }
1697     if (type != OP_LEAVESUBLV)
1698         o->op_flags |= OPf_MOD;
1699
1700     if (type == OP_AASSIGN || type == OP_SASSIGN)
1701         o->op_flags |= OPf_SPECIAL|OPf_REF;
1702     else if (!type) {
1703         o->op_private |= OPpLVAL_INTRO;
1704         o->op_flags &= ~OPf_SPECIAL;
1705         PL_hints |= HINT_BLOCK_SCOPE;
1706     }
1707     else if (type != OP_GREPSTART && type != OP_ENTERSUB
1708              && type != OP_LEAVESUBLV)
1709         o->op_flags |= OPf_REF;
1710     return o;
1711 }
1712
1713 STATIC bool
1714 S_scalar_mod_type(pTHX_ OP *o, I32 type)
1715 {
1716     switch (type) {
1717     case OP_SASSIGN:
1718         if (o->op_type == OP_RV2GV)
1719             return FALSE;
1720         /* FALL THROUGH */
1721     case OP_PREINC:
1722     case OP_PREDEC:
1723     case OP_POSTINC:
1724     case OP_POSTDEC:
1725     case OP_I_PREINC:
1726     case OP_I_PREDEC:
1727     case OP_I_POSTINC:
1728     case OP_I_POSTDEC:
1729     case OP_POW:
1730     case OP_MULTIPLY:
1731     case OP_DIVIDE:
1732     case OP_MODULO:
1733     case OP_REPEAT:
1734     case OP_ADD:
1735     case OP_SUBTRACT:
1736     case OP_I_MULTIPLY:
1737     case OP_I_DIVIDE:
1738     case OP_I_MODULO:
1739     case OP_I_ADD:
1740     case OP_I_SUBTRACT:
1741     case OP_LEFT_SHIFT:
1742     case OP_RIGHT_SHIFT:
1743     case OP_BIT_AND:
1744     case OP_BIT_XOR:
1745     case OP_BIT_OR:
1746     case OP_CONCAT:
1747     case OP_SUBST:
1748     case OP_TRANS:
1749     case OP_READ:
1750     case OP_SYSREAD:
1751     case OP_RECV:
1752     case OP_ANDASSIGN:
1753     case OP_ORASSIGN:
1754         return TRUE;
1755     default:
1756         return FALSE;
1757     }
1758 }
1759
1760 STATIC bool
1761 S_is_handle_constructor(pTHX_ OP *o, I32 argnum)
1762 {
1763     switch (o->op_type) {
1764     case OP_PIPE_OP:
1765     case OP_SOCKPAIR:
1766         if (argnum == 2)
1767             return TRUE;
1768         /* FALL THROUGH */
1769     case OP_SYSOPEN:
1770     case OP_OPEN:
1771     case OP_SELECT:             /* XXX c.f. SelectSaver.pm */
1772     case OP_SOCKET:
1773     case OP_OPEN_DIR:
1774     case OP_ACCEPT:
1775         if (argnum == 1)
1776             return TRUE;
1777         /* FALL THROUGH */
1778     default:
1779         return FALSE;
1780     }
1781 }
1782
1783 OP *
1784 Perl_refkids(pTHX_ OP *o, I32 type)
1785 {
1786     OP *kid;
1787     if (o && o->op_flags & OPf_KIDS) {
1788         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1789             ref(kid, type);
1790     }
1791     return o;
1792 }
1793
1794 OP *
1795 Perl_ref(pTHX_ OP *o, I32 type)
1796 {
1797     OP *kid;
1798
1799     if (!o || PL_error_count)
1800         return o;
1801
1802     switch (o->op_type) {
1803     case OP_ENTERSUB:
1804         if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1805             !(o->op_flags & OPf_STACKED)) {
1806             o->op_type = OP_RV2CV;             /* entersub => rv2cv */
1807             o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1808             assert(cUNOPo->op_first->op_type == OP_NULL);
1809             null(((LISTOP*)cUNOPo->op_first)->op_first);        /* disable pushmark */
1810             o->op_flags |= OPf_SPECIAL;
1811         }
1812         break;
1813
1814     case OP_COND_EXPR:
1815         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1816             ref(kid, type);
1817         break;
1818     case OP_RV2SV:
1819         if (type == OP_DEFINED)
1820             o->op_flags |= OPf_SPECIAL;         /* don't create GV */
1821         ref(cUNOPo->op_first, o->op_type);
1822         /* FALL THROUGH */
1823     case OP_PADSV:
1824         if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1825             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1826                               : type == OP_RV2HV ? OPpDEREF_HV
1827                               : OPpDEREF_SV);
1828             o->op_flags |= OPf_MOD;
1829         }
1830         break;
1831
1832     case OP_THREADSV:
1833         o->op_flags |= OPf_MOD;         /* XXX ??? */
1834         break;
1835
1836     case OP_RV2AV:
1837     case OP_RV2HV:
1838         o->op_flags |= OPf_REF;
1839         /* FALL THROUGH */
1840     case OP_RV2GV:
1841         if (type == OP_DEFINED)
1842             o->op_flags |= OPf_SPECIAL;         /* don't create GV */
1843         ref(cUNOPo->op_first, o->op_type);
1844         break;
1845
1846     case OP_PADAV:
1847     case OP_PADHV:
1848         o->op_flags |= OPf_REF;
1849         break;
1850
1851     case OP_SCALAR:
1852     case OP_NULL:
1853         if (!(o->op_flags & OPf_KIDS))
1854             break;
1855         ref(cBINOPo->op_first, type);
1856         break;
1857     case OP_AELEM:
1858     case OP_HELEM:
1859         ref(cBINOPo->op_first, o->op_type);
1860         if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1861             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1862                               : type == OP_RV2HV ? OPpDEREF_HV
1863                               : OPpDEREF_SV);
1864             o->op_flags |= OPf_MOD;
1865         }
1866         break;
1867
1868     case OP_SCOPE:
1869     case OP_LEAVE:
1870     case OP_ENTER:
1871     case OP_LIST:
1872         if (!(o->op_flags & OPf_KIDS))
1873             break;
1874         ref(cLISTOPo->op_last, type);
1875         break;
1876     default:
1877         break;
1878     }
1879     return scalar(o);
1880
1881 }
1882
1883 STATIC OP *
1884 S_dup_attrlist(pTHX_ OP *o)
1885 {
1886     OP *rop = Nullop;
1887
1888     /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1889      * where the first kid is OP_PUSHMARK and the remaining ones
1890      * are OP_CONST.  We need to push the OP_CONST values.
1891      */
1892     if (o->op_type == OP_CONST)
1893         rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc(cSVOPo->op_sv));
1894     else {
1895         assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1896         for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1897             if (o->op_type == OP_CONST)
1898                 rop = append_elem(OP_LIST, rop,
1899                                   newSVOP(OP_CONST, o->op_flags,
1900                                           SvREFCNT_inc(cSVOPo->op_sv)));
1901         }
1902     }
1903     return rop;
1904 }
1905
1906 STATIC void
1907 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
1908 {
1909     SV *stashsv;
1910
1911     /* fake up C<use attributes $pkg,$rv,@attrs> */
1912     ENTER;              /* need to protect against side-effects of 'use' */
1913     SAVEINT(PL_expect);
1914     if (stash && HvNAME(stash))
1915         stashsv = newSVpv(HvNAME(stash), 0);
1916     else
1917         stashsv = &PL_sv_no;
1918
1919 #define ATTRSMODULE "attributes"
1920
1921     Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1922                      newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1923                      Nullsv,
1924                      prepend_elem(OP_LIST,
1925                                   newSVOP(OP_CONST, 0, stashsv),
1926                                   prepend_elem(OP_LIST,
1927                                                newSVOP(OP_CONST, 0,
1928                                                        newRV(target)),
1929                                                dup_attrlist(attrs))));
1930     LEAVE;
1931 }
1932
1933 void
1934 Perl_apply_attrs_string(pTHX_ char *stashpv, CV *cv,
1935                         char *attrstr, STRLEN len)
1936 {
1937     OP *attrs = Nullop;
1938
1939     if (!len) {
1940         len = strlen(attrstr);
1941     }
1942
1943     while (len) {
1944         for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1945         if (len) {
1946             char *sstr = attrstr;
1947             for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1948             attrs = append_elem(OP_LIST, attrs,
1949                                 newSVOP(OP_CONST, 0,
1950                                         newSVpvn(sstr, attrstr-sstr)));
1951         }
1952     }
1953
1954     Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1955                      newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1956                      Nullsv, prepend_elem(OP_LIST,
1957                                   newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1958                                   prepend_elem(OP_LIST,
1959                                                newSVOP(OP_CONST, 0,
1960                                                        newRV((SV*)cv)),
1961                                                attrs)));
1962 }
1963
1964 STATIC OP *
1965 S_my_kid(pTHX_ OP *o, OP *attrs)
1966 {
1967     OP *kid;
1968     I32 type;
1969
1970     if (!o || PL_error_count)
1971         return o;
1972
1973     type = o->op_type;
1974     if (type == OP_LIST) {
1975         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1976             my_kid(kid, attrs);
1977     } else if (type == OP_UNDEF) {
1978         return o;
1979     } else if (type == OP_RV2SV ||      /* "our" declaration */
1980                type == OP_RV2AV ||
1981                type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1982         if (attrs) {
1983             GV *gv = cGVOPx_gv(cUNOPo->op_first);
1984             PL_in_my = FALSE;
1985             PL_in_my_stash = Nullhv;
1986             apply_attrs(GvSTASH(gv),
1987                         (type == OP_RV2SV ? GvSV(gv) :
1988                          type == OP_RV2AV ? (SV*)GvAV(gv) :
1989                          type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1990                         attrs);
1991         }
1992         o->op_private |= OPpOUR_INTRO;
1993         return o;
1994     } else if (type != OP_PADSV &&
1995              type != OP_PADAV &&
1996              type != OP_PADHV &&
1997              type != OP_PUSHMARK)
1998     {
1999         yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2000                           PL_op_desc[o->op_type],
2001                           PL_in_my == KEY_our ? "our" : "my"));
2002         return o;
2003     }
2004     else if (attrs && type != OP_PUSHMARK) {
2005         HV *stash;
2006         SV *padsv;
2007         SV **namesvp;
2008
2009         PL_in_my = FALSE;
2010         PL_in_my_stash = Nullhv;
2011
2012         /* check for C<my Dog $spot> when deciding package */
2013         namesvp = av_fetch(PL_comppad_name, o->op_targ, FALSE);
2014         if (namesvp && *namesvp && SvOBJECT(*namesvp) && HvNAME(SvSTASH(*namesvp)))
2015             stash = SvSTASH(*namesvp);
2016         else
2017             stash = PL_curstash;
2018         padsv = PAD_SV(o->op_targ);
2019         apply_attrs(stash, padsv, attrs);
2020     }
2021     o->op_flags |= OPf_MOD;
2022     o->op_private |= OPpLVAL_INTRO;
2023     return o;
2024 }
2025
2026 OP *
2027 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2028 {
2029     if (o->op_flags & OPf_PARENS)
2030         list(o);
2031     if (attrs)
2032         SAVEFREEOP(attrs);
2033     o = my_kid(o, attrs);
2034     PL_in_my = FALSE;
2035     PL_in_my_stash = Nullhv;
2036     return o;
2037 }
2038
2039 OP *
2040 Perl_my(pTHX_ OP *o)
2041 {
2042     return my_kid(o, Nullop);
2043 }
2044
2045 OP *
2046 Perl_sawparens(pTHX_ OP *o)
2047 {
2048     if (o)
2049         o->op_flags |= OPf_PARENS;
2050     return o;
2051 }
2052
2053 OP *
2054 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2055 {
2056     OP *o;
2057
2058     if (ckWARN(WARN_MISC) &&
2059       (left->op_type == OP_RV2AV ||
2060        left->op_type == OP_RV2HV ||
2061        left->op_type == OP_PADAV ||
2062        left->op_type == OP_PADHV)) {
2063       char *desc = PL_op_desc[(right->op_type == OP_SUBST ||
2064                             right->op_type == OP_TRANS)
2065                            ? right->op_type : OP_MATCH];
2066       const char *sample = ((left->op_type == OP_RV2AV ||
2067                              left->op_type == OP_PADAV)
2068                             ? "@array" : "%hash");
2069       Perl_warner(aTHX_ WARN_MISC,
2070              "Applying %s to %s will act on scalar(%s)",
2071              desc, sample, sample);
2072     }
2073
2074     if (!(right->op_flags & OPf_STACKED) &&
2075        (right->op_type == OP_MATCH ||
2076         right->op_type == OP_SUBST ||
2077         right->op_type == OP_TRANS)) {
2078         right->op_flags |= OPf_STACKED;
2079         if (right->op_type != OP_MATCH &&
2080             ! (right->op_type == OP_TRANS &&
2081                right->op_private & OPpTRANS_IDENTICAL))
2082             left = mod(left, right->op_type);
2083         if (right->op_type == OP_TRANS)
2084             o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
2085         else
2086             o = prepend_elem(right->op_type, scalar(left), right);
2087         if (type == OP_NOT)
2088             return newUNOP(OP_NOT, 0, scalar(o));
2089         return o;
2090     }
2091     else
2092         return bind_match(type, left,
2093                 pmruntime(newPMOP(OP_MATCH, 0), right, Nullop));
2094 }
2095
2096 OP *
2097 Perl_invert(pTHX_ OP *o)
2098 {
2099     if (!o)
2100         return o;
2101     /* XXX need to optimize away NOT NOT here?  Or do we let optimizer do it? */
2102     return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2103 }
2104
2105 OP *
2106 Perl_scope(pTHX_ OP *o)
2107 {
2108     if (o) {
2109         if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2110             o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2111             o->op_type = OP_LEAVE;
2112             o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2113         }
2114         else {
2115             if (o->op_type == OP_LINESEQ) {
2116                 OP *kid;
2117                 o->op_type = OP_SCOPE;
2118                 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2119                 kid = ((LISTOP*)o)->op_first;
2120                 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
2121                     null(kid);
2122             }
2123             else
2124                 o = newLISTOP(OP_SCOPE, 0, o, Nullop);
2125         }
2126     }
2127     return o;
2128 }
2129
2130 void
2131 Perl_save_hints(pTHX)
2132 {
2133     SAVEI32(PL_hints);
2134     SAVESPTR(GvHV(PL_hintgv));
2135     GvHV(PL_hintgv) = newHVhv(GvHV(PL_hintgv));
2136     SAVEFREESV(GvHV(PL_hintgv));
2137 }
2138
2139 int
2140 Perl_block_start(pTHX_ int full)
2141 {
2142     int retval = PL_savestack_ix;
2143
2144     SAVEI32(PL_comppad_name_floor);
2145     PL_comppad_name_floor = AvFILLp(PL_comppad_name);
2146     if (full)
2147         PL_comppad_name_fill = PL_comppad_name_floor;
2148     if (PL_comppad_name_floor < 0)
2149         PL_comppad_name_floor = 0;
2150     SAVEI32(PL_min_intro_pending);
2151     SAVEI32(PL_max_intro_pending);
2152     PL_min_intro_pending = 0;
2153     SAVEI32(PL_comppad_name_fill);
2154     SAVEI32(PL_padix_floor);
2155     PL_padix_floor = PL_padix;
2156     PL_pad_reset_pending = FALSE;
2157     SAVEHINTS();
2158     PL_hints &= ~HINT_BLOCK_SCOPE;
2159     SAVESPTR(PL_compiling.cop_warnings);
2160     if (! specialWARN(PL_compiling.cop_warnings)) {
2161         PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
2162         SAVEFREESV(PL_compiling.cop_warnings) ;
2163     }
2164     SAVESPTR(PL_compiling.cop_io);
2165     if (! specialCopIO(PL_compiling.cop_io)) {
2166         PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
2167         SAVEFREESV(PL_compiling.cop_io) ;
2168     }
2169     return retval;
2170 }
2171
2172 OP*
2173 Perl_block_end(pTHX_ I32 floor, OP *seq)
2174 {
2175     int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2176     OP* retval = scalarseq(seq);
2177     LEAVE_SCOPE(floor);
2178     PL_pad_reset_pending = FALSE;
2179     PL_compiling.op_private = PL_hints;
2180     if (needblockscope)
2181         PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2182     pad_leavemy(PL_comppad_name_fill);
2183     PL_cop_seqmax++;
2184     return retval;
2185 }
2186
2187 STATIC OP *
2188 S_newDEFSVOP(pTHX)
2189 {
2190 #ifdef USE_THREADS
2191     OP *o = newOP(OP_THREADSV, 0);
2192     o->op_targ = find_threadsv("_");
2193     return o;
2194 #else
2195     return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2196 #endif /* USE_THREADS */
2197 }
2198
2199 void
2200 Perl_newPROG(pTHX_ OP *o)
2201 {
2202     if (PL_in_eval) {
2203         if (PL_eval_root)
2204                 return;
2205         PL_eval_root = newUNOP(OP_LEAVEEVAL,
2206                                ((PL_in_eval & EVAL_KEEPERR)
2207                                 ? OPf_SPECIAL : 0), o);
2208         PL_eval_start = linklist(PL_eval_root);
2209         PL_eval_root->op_private |= OPpREFCOUNTED;
2210         OpREFCNT_set(PL_eval_root, 1);
2211         PL_eval_root->op_next = 0;
2212         peep(PL_eval_start);
2213     }
2214     else {
2215         if (!o)
2216             return;
2217         PL_main_root = scope(sawparens(scalarvoid(o)));
2218         PL_curcop = &PL_compiling;
2219         PL_main_start = LINKLIST(PL_main_root);
2220         PL_main_root->op_private |= OPpREFCOUNTED;
2221         OpREFCNT_set(PL_main_root, 1);
2222         PL_main_root->op_next = 0;
2223         peep(PL_main_start);
2224         PL_compcv = 0;
2225
2226         /* Register with debugger */
2227         if (PERLDB_INTER) {
2228             CV *cv = get_cv("DB::postponed", FALSE);
2229             if (cv) {
2230                 dSP;
2231                 PUSHMARK(SP);
2232                 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2233                 PUTBACK;
2234                 call_sv((SV*)cv, G_DISCARD);
2235             }
2236         }
2237     }
2238 }
2239
2240 OP *
2241 Perl_localize(pTHX_ OP *o, I32 lex)
2242 {
2243     if (o->op_flags & OPf_PARENS)
2244         list(o);
2245     else {
2246         if (ckWARN(WARN_PARENTHESIS) && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',') {
2247             char *s;
2248             for (s = PL_bufptr; *s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s) || strchr("@$%, ",*s)); s++) ;
2249             if (*s == ';' || *s == '=')
2250                 Perl_warner(aTHX_ WARN_PARENTHESIS,
2251                             "Parentheses missing around \"%s\" list",
2252                             lex ? (PL_in_my == KEY_our ? "our" : "my") : "local");
2253         }
2254     }
2255     if (lex)
2256         o = my(o);
2257     else
2258         o = mod(o, OP_NULL);            /* a bit kludgey */
2259     PL_in_my = FALSE;
2260     PL_in_my_stash = Nullhv;
2261     return o;
2262 }
2263
2264 OP *
2265 Perl_jmaybe(pTHX_ OP *o)
2266 {
2267     if (o->op_type == OP_LIST) {
2268         OP *o2;
2269 #ifdef USE_THREADS
2270         o2 = newOP(OP_THREADSV, 0);
2271         o2->op_targ = find_threadsv(";");
2272 #else
2273         o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
2274 #endif /* USE_THREADS */
2275         o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2276     }
2277     return o;
2278 }
2279
2280 OP *
2281 Perl_fold_constants(pTHX_ register OP *o)
2282 {
2283     register OP *curop;
2284     I32 type = o->op_type;
2285     SV *sv;
2286
2287     if (PL_opargs[type] & OA_RETSCALAR)
2288         scalar(o);
2289     if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2290         o->op_targ = pad_alloc(type, SVs_PADTMP);
2291
2292     /* integerize op, unless it happens to be C<-foo>.
2293      * XXX should pp_i_negate() do magic string negation instead? */
2294     if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2295         && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2296              && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2297     {
2298         o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2299     }
2300
2301     if (!(PL_opargs[type] & OA_FOLDCONST))
2302         goto nope;
2303
2304     switch (type) {
2305     case OP_NEGATE:
2306         /* XXX might want a ck_negate() for this */
2307         cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2308         break;
2309     case OP_SPRINTF:
2310     case OP_UCFIRST:
2311     case OP_LCFIRST:
2312     case OP_UC:
2313     case OP_LC:
2314     case OP_SLT:
2315     case OP_SGT:
2316     case OP_SLE:
2317     case OP_SGE:
2318     case OP_SCMP:
2319
2320         if (o->op_private & OPpLOCALE)
2321             goto nope;
2322     }
2323
2324     if (PL_error_count)
2325         goto nope;              /* Don't try to run w/ errors */
2326
2327     for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2328         if ((curop->op_type != OP_CONST ||
2329              (curop->op_private & OPpCONST_BARE)) &&
2330             curop->op_type != OP_LIST &&
2331             curop->op_type != OP_SCALAR &&
2332             curop->op_type != OP_NULL &&
2333             curop->op_type != OP_PUSHMARK)
2334         {
2335             goto nope;
2336         }
2337     }
2338
2339     curop = LINKLIST(o);
2340     o->op_next = 0;
2341     PL_op = curop;
2342     CALLRUNOPS(aTHX);
2343     sv = *(PL_stack_sp--);
2344     if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2345         pad_swipe(o->op_targ);
2346     else if (SvTEMP(sv)) {                      /* grab mortal temp? */
2347         (void)SvREFCNT_inc(sv);
2348         SvTEMP_off(sv);
2349     }
2350     op_free(o);
2351     if (type == OP_RV2GV)
2352         return newGVOP(OP_GV, 0, (GV*)sv);
2353     else {
2354         /* try to smush double to int, but don't smush -2.0 to -2 */
2355         if ((SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK)) == SVf_NOK &&
2356             type != OP_NEGATE)
2357         {
2358 #ifdef PERL_PRESERVE_IVUV
2359             /* Only bother to attempt to fold to IV if
2360                most operators will benefit  */
2361             SvIV_please(sv);
2362 #endif
2363         }
2364         return newSVOP(OP_CONST, 0, sv);
2365     }
2366
2367   nope:
2368     if (!(PL_opargs[type] & OA_OTHERINT))
2369         return o;
2370
2371     if (!(PL_hints & HINT_INTEGER)) {
2372         if (type == OP_MODULO
2373             || type == OP_DIVIDE
2374             || !(o->op_flags & OPf_KIDS))
2375         {
2376             return o;
2377         }
2378
2379         for (curop = ((UNOP*)o)->op_first; curop; curop = curop->op_sibling) {
2380             if (curop->op_type == OP_CONST) {
2381                 if (SvIOK(((SVOP*)curop)->op_sv))
2382                     continue;
2383                 return o;
2384             }
2385             if (PL_opargs[curop->op_type] & OA_RETINTEGER)
2386                 continue;
2387             return o;
2388         }
2389         o->op_ppaddr = PL_ppaddr[++(o->op_type)];
2390     }
2391
2392     return o;
2393 }
2394
2395 OP *
2396 Perl_gen_constant_list(pTHX_ register OP *o)
2397 {
2398     register OP *curop;
2399     I32 oldtmps_floor = PL_tmps_floor;
2400
2401     list(o);
2402     if (PL_error_count)
2403         return o;               /* Don't attempt to run with errors */
2404
2405     PL_op = curop = LINKLIST(o);
2406     o->op_next = 0;
2407     peep(curop);
2408     pp_pushmark();
2409     CALLRUNOPS(aTHX);
2410     PL_op = curop;
2411     pp_anonlist();
2412     PL_tmps_floor = oldtmps_floor;
2413
2414     o->op_type = OP_RV2AV;
2415     o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2416     curop = ((UNOP*)o)->op_first;
2417     ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
2418     op_free(curop);
2419     linklist(o);
2420     return list(o);
2421 }
2422
2423 OP *
2424 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2425 {
2426     if (!o || o->op_type != OP_LIST)
2427         o = newLISTOP(OP_LIST, 0, o, Nullop);
2428     else
2429         o->op_flags &= ~OPf_WANT;
2430
2431     if (!(PL_opargs[type] & OA_MARK))
2432         null(cLISTOPo->op_first);
2433
2434     o->op_type = type;
2435     o->op_ppaddr = PL_ppaddr[type];
2436     o->op_flags |= flags;
2437
2438     o = CHECKOP(type, o);
2439     if (o->op_type != type)
2440         return o;
2441
2442     return fold_constants(o);
2443 }
2444
2445 /* List constructors */
2446
2447 OP *
2448 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2449 {
2450     if (!first)
2451         return last;
2452
2453     if (!last)
2454         return first;
2455
2456     if (first->op_type != type
2457         || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2458     {
2459         return newLISTOP(type, 0, first, last);
2460     }
2461
2462     if (first->op_flags & OPf_KIDS)
2463         ((LISTOP*)first)->op_last->op_sibling = last;
2464     else {
2465         first->op_flags |= OPf_KIDS;
2466         ((LISTOP*)first)->op_first = last;
2467     }
2468     ((LISTOP*)first)->op_last = last;
2469     return first;
2470 }
2471
2472 OP *
2473 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2474 {
2475     if (!first)
2476         return (OP*)last;
2477
2478     if (!last)
2479         return (OP*)first;
2480
2481     if (first->op_type != type)
2482         return prepend_elem(type, (OP*)first, (OP*)last);
2483
2484     if (last->op_type != type)
2485         return append_elem(type, (OP*)first, (OP*)last);
2486
2487     first->op_last->op_sibling = last->op_first;
2488     first->op_last = last->op_last;
2489     first->op_flags |= (last->op_flags & OPf_KIDS);
2490
2491 #ifdef PL_OP_SLAB_ALLOC
2492 #else
2493     Safefree(last);
2494 #endif
2495     return (OP*)first;
2496 }
2497
2498 OP *
2499 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2500 {
2501     if (!first)
2502         return last;
2503
2504     if (!last)
2505         return first;
2506
2507     if (last->op_type == type) {
2508         if (type == OP_LIST) {  /* already a PUSHMARK there */
2509             first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2510             ((LISTOP*)last)->op_first->op_sibling = first;
2511             if (!(first->op_flags & OPf_PARENS))
2512                 last->op_flags &= ~OPf_PARENS;
2513         }
2514         else {
2515             if (!(last->op_flags & OPf_KIDS)) {
2516                 ((LISTOP*)last)->op_last = first;
2517                 last->op_flags |= OPf_KIDS;
2518             }
2519             first->op_sibling = ((LISTOP*)last)->op_first;
2520             ((LISTOP*)last)->op_first = first;
2521         }
2522         last->op_flags |= OPf_KIDS;
2523         return last;
2524     }
2525
2526     return newLISTOP(type, 0, first, last);
2527 }
2528
2529 /* Constructors */
2530
2531 OP *
2532 Perl_newNULLLIST(pTHX)
2533 {
2534     return newOP(OP_STUB, 0);
2535 }
2536
2537 OP *
2538 Perl_force_list(pTHX_ OP *o)
2539 {
2540     if (!o || o->op_type != OP_LIST)
2541         o = newLISTOP(OP_LIST, 0, o, Nullop);
2542     null(o);
2543     return o;
2544 }
2545
2546 OP *
2547 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2548 {
2549     LISTOP *listop;
2550
2551     NewOp(1101, listop, 1, LISTOP);
2552
2553     listop->op_type = type;
2554     listop->op_ppaddr = PL_ppaddr[type];
2555     if (first || last)
2556         flags |= OPf_KIDS;
2557     listop->op_flags = flags;
2558
2559     if (!last && first)
2560         last = first;
2561     else if (!first && last)
2562         first = last;
2563     else if (first)
2564         first->op_sibling = last;
2565     listop->op_first = first;
2566     listop->op_last = last;
2567     if (type == OP_LIST) {
2568         OP* pushop;
2569         pushop = newOP(OP_PUSHMARK, 0);
2570         pushop->op_sibling = first;
2571         listop->op_first = pushop;
2572         listop->op_flags |= OPf_KIDS;
2573         if (!last)
2574             listop->op_last = pushop;
2575     }
2576
2577     return (OP*)listop;
2578 }
2579
2580 OP *
2581 Perl_newOP(pTHX_ I32 type, I32 flags)
2582 {
2583     OP *o;
2584     NewOp(1101, o, 1, OP);
2585     o->op_type = type;
2586     o->op_ppaddr = PL_ppaddr[type];
2587     o->op_flags = flags;
2588
2589     o->op_next = o;
2590     o->op_private = 0 + (flags >> 8);
2591     if (PL_opargs[type] & OA_RETSCALAR)
2592         scalar(o);
2593     if (PL_opargs[type] & OA_TARGET)
2594         o->op_targ = pad_alloc(type, SVs_PADTMP);
2595     return CHECKOP(type, o);
2596 }
2597
2598 OP *
2599 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2600 {
2601     UNOP *unop;
2602
2603     if (!first)
2604         first = newOP(OP_STUB, 0);
2605     if (PL_opargs[type] & OA_MARK)
2606         first = force_list(first);
2607
2608     NewOp(1101, unop, 1, UNOP);
2609     unop->op_type = type;
2610     unop->op_ppaddr = PL_ppaddr[type];
2611     unop->op_first = first;
2612     unop->op_flags = flags | OPf_KIDS;
2613     unop->op_private = 1 | (flags >> 8);
2614     unop = (UNOP*) CHECKOP(type, unop);
2615     if (unop->op_next)
2616         return (OP*)unop;
2617
2618     return fold_constants((OP *) unop);
2619 }
2620
2621 OP *
2622 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2623 {
2624     BINOP *binop;
2625     NewOp(1101, binop, 1, BINOP);
2626
2627     if (!first)
2628         first = newOP(OP_NULL, 0);
2629
2630     binop->op_type = type;
2631     binop->op_ppaddr = PL_ppaddr[type];
2632     binop->op_first = first;
2633     binop->op_flags = flags | OPf_KIDS;
2634     if (!last) {
2635         last = first;
2636         binop->op_private = 1 | (flags >> 8);
2637     }
2638     else {
2639         binop->op_private = 2 | (flags >> 8);
2640         first->op_sibling = last;
2641     }
2642
2643     binop = (BINOP*)CHECKOP(type, binop);
2644     if (binop->op_next || binop->op_type != type)
2645         return (OP*)binop;
2646
2647     binop->op_last = binop->op_first->op_sibling;
2648
2649     return fold_constants((OP *)binop);
2650 }
2651
2652 static int
2653 uvcompare(const void *a, const void *b)
2654 {
2655     if (*((UV *)a) < (*(UV *)b))
2656         return -1;
2657     if (*((UV *)a) > (*(UV *)b))
2658         return 1;
2659     if (*((UV *)a+1) < (*(UV *)b+1))
2660         return -1;
2661     if (*((UV *)a+1) > (*(UV *)b+1))
2662         return 1;
2663     return 0;
2664 }
2665
2666 OP *
2667 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2668 {
2669     SV *tstr = ((SVOP*)expr)->op_sv;
2670     SV *rstr = ((SVOP*)repl)->op_sv;
2671     STRLEN tlen;
2672     STRLEN rlen;
2673     U8 *t = (U8*)SvPV(tstr, tlen);
2674     U8 *r = (U8*)SvPV(rstr, rlen);
2675     register I32 i;
2676     register I32 j;
2677     I32 del;
2678     I32 complement;
2679     I32 squash;
2680     I32 grows = 0;
2681     register short *tbl;
2682
2683     complement  = o->op_private & OPpTRANS_COMPLEMENT;
2684     del         = o->op_private & OPpTRANS_DELETE;
2685     squash      = o->op_private & OPpTRANS_SQUASH;
2686
2687     if (SvUTF8(tstr))
2688         o->op_private |= OPpTRANS_FROM_UTF;
2689
2690     if (SvUTF8(rstr))
2691         o->op_private |= OPpTRANS_TO_UTF;
2692
2693     if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2694         SV* listsv = newSVpvn("# comment\n",10);
2695         SV* transv = 0;
2696         U8* tend = t + tlen;
2697         U8* rend = r + rlen;
2698         STRLEN ulen;
2699         U32 tfirst = 1;
2700         U32 tlast = 0;
2701         I32 tdiff;
2702         U32 rfirst = 1;
2703         U32 rlast = 0;
2704         I32 rdiff;
2705         I32 diff;
2706         I32 none = 0;
2707         U32 max = 0;
2708         I32 bits;
2709         I32 havefinal = 0;
2710         U32 final;
2711         I32 from_utf    = o->op_private & OPpTRANS_FROM_UTF;
2712         I32 to_utf      = o->op_private & OPpTRANS_TO_UTF;
2713         U8* tsave = from_utf ? NULL : trlist_upgrade(&t, &tend);
2714         U8* rsave = (to_utf || !rlen) ? NULL : trlist_upgrade(&r, &rend);
2715
2716 /* There are several snags with this code on EBCDIC:
2717    1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2718    2. scan_const() in toke.c has encoded chars in native encoding which makes
2719       ranges at least in EBCDIC 0..255 range the bottom odd.
2720 */
2721
2722         if (complement) {
2723             U8 tmpbuf[UTF8_MAXLEN+1];
2724             UV *cp;
2725             UV nextmin = 0;
2726             New(1109, cp, 2*tlen, UV);
2727             i = 0;
2728             transv = newSVpvn("",0);
2729             while (t < tend) {
2730                 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2731                 t += ulen;
2732                 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2733                     t++;
2734                     cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2735                     t += ulen;
2736                 }
2737                 else {
2738                  cp[2*i+1] = cp[2*i];
2739                 }
2740                 i++;
2741             }
2742             qsort(cp, i, 2*sizeof(UV), uvcompare);
2743             for (j = 0; j < i; j++) {
2744                 UV  val = cp[2*j];
2745                 diff = val - nextmin;
2746                 if (diff > 0) {
2747                     t = uvuni_to_utf8(tmpbuf,nextmin);
2748                     sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2749                     if (diff > 1) {
2750                         U8  range_mark = UTF_TO_NATIVE(0xff);
2751                         t = uvuni_to_utf8(tmpbuf, val - 1);
2752                         sv_catpvn(transv, (char *)&range_mark, 1);
2753                         sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2754                     }
2755                 }
2756                 val = cp[2*j+1];
2757                 if (val >= nextmin)
2758                     nextmin = val + 1;
2759             }
2760             t = uvuni_to_utf8(tmpbuf,nextmin);
2761             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2762             {
2763                 U8 range_mark = UTF_TO_NATIVE(0xff);
2764                 sv_catpvn(transv, (char *)&range_mark, 1);
2765             }
2766             t = uvuni_to_utf8(tmpbuf, 0x7fffffff);
2767             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2768             t = (U8*)SvPVX(transv);
2769             tlen = SvCUR(transv);
2770             tend = t + tlen;
2771             Safefree(cp);
2772         }
2773         else if (!rlen && !del) {
2774             r = t; rlen = tlen; rend = tend;
2775         }
2776         if (!squash) {
2777                 if ((!rlen && !del) || t == r ||
2778                     (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2779                 {
2780                     o->op_private |= OPpTRANS_IDENTICAL;
2781                 }
2782         }
2783
2784         while (t < tend || tfirst <= tlast) {
2785             /* see if we need more "t" chars */
2786             if (tfirst > tlast) {
2787                 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2788                 t += ulen;
2789                 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {    /* illegal utf8 val indicates range */
2790                     t++;
2791                     tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2792                     t += ulen;
2793                 }
2794                 else
2795                     tlast = tfirst;
2796             }
2797
2798             /* now see if we need more "r" chars */
2799             if (rfirst > rlast) {
2800                 if (r < rend) {
2801                     rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2802                     r += ulen;
2803                     if (r < rend && NATIVE_TO_UTF(*r) == 0xff) {        /* illegal utf8 val indicates range */
2804                         r++;
2805                         rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2806                         r += ulen;
2807                     }
2808                     else
2809                         rlast = rfirst;
2810                 }
2811                 else {
2812                     if (!havefinal++)
2813                         final = rlast;
2814                     rfirst = rlast = 0xffffffff;
2815                 }
2816             }
2817
2818             /* now see which range will peter our first, if either. */
2819             tdiff = tlast - tfirst;
2820             rdiff = rlast - rfirst;
2821
2822             if (tdiff <= rdiff)
2823                 diff = tdiff;
2824             else
2825                 diff = rdiff;
2826
2827             if (rfirst == 0xffffffff) {
2828                 diff = tdiff;   /* oops, pretend rdiff is infinite */
2829                 if (diff > 0)
2830                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2831                                    (long)tfirst, (long)tlast);
2832                 else
2833                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2834             }
2835             else {
2836                 if (diff > 0)
2837                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2838                                    (long)tfirst, (long)(tfirst + diff),
2839                                    (long)rfirst);
2840                 else
2841                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2842                                    (long)tfirst, (long)rfirst);
2843
2844                 if (rfirst + diff > max)
2845                     max = rfirst + diff;
2846                 if (!grows)
2847                     grows = (tfirst < rfirst &&
2848                              UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2849                 rfirst += diff + 1;
2850             }
2851             tfirst += diff + 1;
2852         }
2853
2854         none = ++max;
2855         if (del)
2856             del = ++max;
2857
2858         if (max > 0xffff)
2859             bits = 32;
2860         else if (max > 0xff)
2861             bits = 16;
2862         else
2863             bits = 8;
2864
2865         Safefree(cPVOPo->op_pv);
2866         cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2867         SvREFCNT_dec(listsv);
2868         if (transv)
2869             SvREFCNT_dec(transv);
2870
2871         if (!del && havefinal && rlen)
2872             (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2873                            newSVuv((UV)final), 0);
2874
2875         if (grows)
2876             o->op_private |= OPpTRANS_GROWS;
2877
2878         if (tsave)
2879             Safefree(tsave);
2880         if (rsave)
2881             Safefree(rsave);
2882
2883         op_free(expr);
2884         op_free(repl);
2885         return o;
2886     }
2887
2888     tbl = (short*)cPVOPo->op_pv;
2889     if (complement) {
2890         Zero(tbl, 256, short);
2891         for (i = 0; i < tlen; i++)
2892             tbl[t[i]] = -1;
2893         for (i = 0, j = 0; i < 256; i++) {
2894             if (!tbl[i]) {
2895                 if (j >= rlen) {
2896                     if (del)
2897                         tbl[i] = -2;
2898                     else if (rlen)
2899                         tbl[i] = r[j-1];
2900                     else
2901                         tbl[i] = i;
2902                 }
2903                 else {
2904                     if (i < 128 && r[j] >= 128)
2905                         grows = 1;
2906                     tbl[i] = r[j++];
2907                 }
2908             }
2909         }
2910         if (!del) {
2911             if (!rlen) {
2912                 j = rlen;
2913                 if (!squash)
2914                     o->op_private |= OPpTRANS_IDENTICAL;
2915             }
2916             else if (j >= rlen)
2917                 j = rlen - 1;
2918             else
2919                 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
2920             tbl[0x100] = rlen - j;
2921             for (i=0; i < rlen - j; i++)
2922                 tbl[0x101+i] = r[j+i];
2923         }
2924     }
2925     else {
2926         if (!rlen && !del) {
2927             r = t; rlen = tlen;
2928             if (!squash)
2929                 o->op_private |= OPpTRANS_IDENTICAL;
2930         }
2931         for (i = 0; i < 256; i++)
2932             tbl[i] = -1;
2933         for (i = 0, j = 0; i < tlen; i++,j++) {
2934             if (j >= rlen) {
2935                 if (del) {
2936                     if (tbl[t[i]] == -1)
2937                         tbl[t[i]] = -2;
2938                     continue;
2939                 }
2940                 --j;
2941             }
2942             if (tbl[t[i]] == -1) {
2943                 if (t[i] < 128 && r[j] >= 128)
2944                     grows = 1;
2945                 tbl[t[i]] = r[j];
2946             }
2947         }
2948     }
2949     if (grows)
2950         o->op_private |= OPpTRANS_GROWS;
2951     op_free(expr);
2952     op_free(repl);
2953
2954     return o;
2955 }
2956
2957 OP *
2958 Perl_newPMOP(pTHX_ I32 type, I32 flags)
2959 {
2960     PMOP *pmop;
2961
2962     NewOp(1101, pmop, 1, PMOP);
2963     pmop->op_type = type;
2964     pmop->op_ppaddr = PL_ppaddr[type];
2965     pmop->op_flags = flags;
2966     pmop->op_private = 0 | (flags >> 8);
2967
2968     if (PL_hints & HINT_RE_TAINT)
2969         pmop->op_pmpermflags |= PMf_RETAINT;
2970     if (PL_hints & HINT_LOCALE)
2971         pmop->op_pmpermflags |= PMf_LOCALE;
2972     pmop->op_pmflags = pmop->op_pmpermflags;
2973
2974     /* link into pm list */
2975     if (type != OP_TRANS && PL_curstash) {
2976         pmop->op_pmnext = HvPMROOT(PL_curstash);
2977         HvPMROOT(PL_curstash) = pmop;
2978         PmopSTASH_set(pmop,PL_curstash);
2979     }
2980
2981     return (OP*)pmop;
2982 }
2983
2984 OP *
2985 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl)
2986 {
2987     PMOP *pm;
2988     LOGOP *rcop;
2989     I32 repl_has_vars = 0;
2990
2991     if (o->op_type == OP_TRANS)
2992         return pmtrans(o, expr, repl);
2993
2994     PL_hints |= HINT_BLOCK_SCOPE;
2995     pm = (PMOP*)o;
2996
2997     if (expr->op_type == OP_CONST) {
2998         STRLEN plen;
2999         SV *pat = ((SVOP*)expr)->op_sv;
3000         char *p = SvPV(pat, plen);
3001         if ((o->op_flags & OPf_SPECIAL) && strEQ(p, " ")) {
3002             sv_setpvn(pat, "\\s+", 3);
3003             p = SvPV(pat, plen);
3004             pm->op_pmflags |= PMf_SKIPWHITE;
3005         }
3006         if ((PL_hints & HINT_UTF8) || DO_UTF8(pat))
3007             pm->op_pmdynflags |= PMdf_UTF8;
3008         pm->op_pmregexp = CALLREGCOMP(aTHX_ p, p + plen, pm);
3009         if (strEQ("\\s+", pm->op_pmregexp->precomp))
3010             pm->op_pmflags |= PMf_WHITE;
3011         op_free(expr);
3012     }
3013     else {
3014         if (PL_hints & HINT_UTF8)
3015             pm->op_pmdynflags |= PMdf_UTF8;
3016         if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3017             expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3018                             ? OP_REGCRESET
3019                             : OP_REGCMAYBE),0,expr);
3020
3021         NewOp(1101, rcop, 1, LOGOP);
3022         rcop->op_type = OP_REGCOMP;
3023         rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3024         rcop->op_first = scalar(expr);
3025         rcop->op_flags |= ((PL_hints & HINT_RE_EVAL)
3026                            ? (OPf_SPECIAL | OPf_KIDS)
3027                            : OPf_KIDS);
3028         rcop->op_private = 1;
3029         rcop->op_other = o;
3030
3031         /* establish postfix order */
3032         if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3033             LINKLIST(expr);
3034             rcop->op_next = expr;
3035             ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3036         }
3037         else {
3038             rcop->op_next = LINKLIST(expr);
3039             expr->op_next = (OP*)rcop;
3040         }
3041
3042         prepend_elem(o->op_type, scalar((OP*)rcop), o);
3043     }
3044
3045     if (repl) {
3046         OP *curop;
3047         if (pm->op_pmflags & PMf_EVAL) {
3048             curop = 0;
3049             if (CopLINE(PL_curcop) < PL_multi_end)
3050                 CopLINE_set(PL_curcop, PL_multi_end);
3051         }
3052 #ifdef USE_THREADS
3053         else if (repl->op_type == OP_THREADSV
3054                  && strchr("&`'123456789+",
3055                            PL_threadsv_names[repl->op_targ]))
3056         {
3057             curop = 0;
3058         }
3059 #endif /* USE_THREADS */
3060         else if (repl->op_type == OP_CONST)
3061             curop = repl;
3062         else {
3063             OP *lastop = 0;
3064             for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3065                 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3066 #ifdef USE_THREADS
3067                     if (curop->op_type == OP_THREADSV) {
3068                         repl_has_vars = 1;
3069                         if (strchr("&`'123456789+", curop->op_private))
3070                             break;
3071                     }
3072 #else
3073                     if (curop->op_type == OP_GV) {
3074                         GV *gv = cGVOPx_gv(curop);
3075                         repl_has_vars = 1;
3076                         if (strchr("&`'123456789+", *GvENAME(gv)))
3077                             break;
3078                     }
3079 #endif /* USE_THREADS */
3080                     else if (curop->op_type == OP_RV2CV)
3081                         break;
3082                     else if (curop->op_type == OP_RV2SV ||
3083                              curop->op_type == OP_RV2AV ||
3084                              curop->op_type == OP_RV2HV ||
3085                              curop->op_type == OP_RV2GV) {
3086                         if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3087                             break;
3088                     }
3089                     else if (curop->op_type == OP_PADSV ||
3090                              curop->op_type == OP_PADAV ||
3091                              curop->op_type == OP_PADHV ||
3092                              curop->op_type == OP_PADANY) {
3093                         repl_has_vars = 1;
3094                     }
3095                     else if (curop->op_type == OP_PUSHRE)
3096                         ; /* Okay here, dangerous in newASSIGNOP */
3097                     else
3098                         break;
3099                 }
3100                 lastop = curop;
3101             }
3102         }
3103         if (curop == repl
3104             && !(repl_has_vars
3105                  && (!pm->op_pmregexp
3106                      || pm->op_pmregexp->reganch & ROPT_EVAL_SEEN))) {
3107             pm->op_pmflags |= PMf_CONST;        /* const for long enough */
3108             pm->op_pmpermflags |= PMf_CONST;    /* const for long enough */
3109             prepend_elem(o->op_type, scalar(repl), o);
3110         }
3111         else {
3112             if (curop == repl && !pm->op_pmregexp) { /* Has variables. */
3113                 pm->op_pmflags |= PMf_MAYBE_CONST;
3114                 pm->op_pmpermflags |= PMf_MAYBE_CONST;
3115             }
3116             NewOp(1101, rcop, 1, LOGOP);
3117             rcop->op_type = OP_SUBSTCONT;
3118             rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3119             rcop->op_first = scalar(repl);
3120             rcop->op_flags |= OPf_KIDS;
3121             rcop->op_private = 1;
3122             rcop->op_other = o;
3123
3124             /* establish postfix order */
3125             rcop->op_next = LINKLIST(repl);
3126             repl->op_next = (OP*)rcop;
3127
3128             pm->op_pmreplroot = scalar((OP*)rcop);
3129             pm->op_pmreplstart = LINKLIST(rcop);
3130             rcop->op_next = 0;
3131         }
3132     }
3133
3134     return (OP*)pm;
3135 }
3136
3137 OP *
3138 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3139 {
3140     SVOP *svop;
3141     NewOp(1101, svop, 1, SVOP);
3142     svop->op_type = type;
3143     svop->op_ppaddr = PL_ppaddr[type];
3144     svop->op_sv = sv;
3145     svop->op_next = (OP*)svop;
3146     svop->op_flags = flags;
3147     if (PL_opargs[type] & OA_RETSCALAR)
3148         scalar((OP*)svop);
3149     if (PL_opargs[type] & OA_TARGET)
3150         svop->op_targ = pad_alloc(type, SVs_PADTMP);
3151     return CHECKOP(type, svop);
3152 }
3153
3154 OP *
3155 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3156 {
3157     PADOP *padop;
3158     NewOp(1101, padop, 1, PADOP);
3159     padop->op_type = type;
3160     padop->op_ppaddr = PL_ppaddr[type];
3161     padop->op_padix = pad_alloc(type, SVs_PADTMP);
3162     SvREFCNT_dec(PL_curpad[padop->op_padix]);
3163     PL_curpad[padop->op_padix] = sv;
3164     SvPADTMP_on(sv);
3165     padop->op_next = (OP*)padop;
3166     padop->op_flags = flags;
3167     if (PL_opargs[type] & OA_RETSCALAR)
3168         scalar((OP*)padop);
3169     if (PL_opargs[type] & OA_TARGET)
3170         padop->op_targ = pad_alloc(type, SVs_PADTMP);
3171     return CHECKOP(type, padop);
3172 }
3173
3174 OP *
3175 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3176 {
3177 #ifdef USE_ITHREADS
3178     GvIN_PAD_on(gv);
3179     return newPADOP(type, flags, SvREFCNT_inc(gv));
3180 #else
3181     return newSVOP(type, flags, SvREFCNT_inc(gv));
3182 #endif
3183 }
3184
3185 OP *
3186 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3187 {
3188     PVOP *pvop;
3189     NewOp(1101, pvop, 1, PVOP);
3190     pvop->op_type = type;
3191     pvop->op_ppaddr = PL_ppaddr[type];
3192     pvop->op_pv = pv;
3193     pvop->op_next = (OP*)pvop;
3194     pvop->op_flags = flags;
3195     if (PL_opargs[type] & OA_RETSCALAR)
3196         scalar((OP*)pvop);
3197     if (PL_opargs[type] & OA_TARGET)
3198         pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3199     return CHECKOP(type, pvop);
3200 }
3201
3202 void
3203 Perl_package(pTHX_ OP *o)
3204 {
3205     SV *sv;
3206
3207     save_hptr(&PL_curstash);
3208     save_item(PL_curstname);
3209     if (o) {
3210         STRLEN len;
3211         char *name;
3212         sv = cSVOPo->op_sv;
3213         name = SvPV(sv, len);
3214         PL_curstash = gv_stashpvn(name,len,TRUE);
3215         sv_setpvn(PL_curstname, name, len);
3216         op_free(o);
3217     }
3218     else {
3219         sv_setpv(PL_curstname,"<none>");
3220         PL_curstash = Nullhv;
3221     }
3222     PL_hints |= HINT_BLOCK_SCOPE;
3223     PL_copline = NOLINE;
3224     PL_expect = XSTATE;
3225 }
3226
3227 void
3228 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg)
3229 {
3230     OP *pack;
3231     OP *rqop;
3232     OP *imop;
3233     OP *veop;
3234     GV *gv;
3235
3236     if (id->op_type != OP_CONST)
3237         Perl_croak(aTHX_ "Module name must be constant");
3238
3239     veop = Nullop;
3240
3241     if (version != Nullop) {
3242         SV *vesv = ((SVOP*)version)->op_sv;
3243
3244         if (arg == Nullop && !SvNIOKp(vesv)) {
3245             arg = version;
3246         }
3247         else {
3248             OP *pack;
3249             SV *meth;
3250
3251             if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3252                 Perl_croak(aTHX_ "Version number must be constant number");
3253
3254             /* Make copy of id so we don't free it twice */
3255             pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3256
3257             /* Fake up a method call to VERSION */
3258             meth = newSVpvn("VERSION",7);
3259             sv_upgrade(meth, SVt_PVIV);
3260             (void)SvIOK_on(meth);
3261             PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3262             veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3263                             append_elem(OP_LIST,
3264                                         prepend_elem(OP_LIST, pack, list(version)),
3265                                         newSVOP(OP_METHOD_NAMED, 0, meth)));
3266         }
3267     }
3268
3269     /* Fake up an import/unimport */
3270     if (arg && arg->op_type == OP_STUB)
3271         imop = arg;             /* no import on explicit () */
3272     else if (SvNIOKp(((SVOP*)id)->op_sv)) {
3273         imop = Nullop;          /* use 5.0; */
3274     }
3275     else {
3276         SV *meth;
3277
3278         /* Make copy of id so we don't free it twice */
3279         pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3280
3281         /* Fake up a method call to import/unimport */
3282         meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);;
3283         sv_upgrade(meth, SVt_PVIV);
3284         (void)SvIOK_on(meth);
3285         PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3286         imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3287                        append_elem(OP_LIST,
3288                                    prepend_elem(OP_LIST, pack, list(arg)),
3289                                    newSVOP(OP_METHOD_NAMED, 0, meth)));
3290     }
3291
3292     /* Fake up a require, handle override, if any */
3293     gv = gv_fetchpv("require", FALSE, SVt_PVCV);
3294     if (!(gv && GvIMPORTED_CV(gv)))
3295         gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
3296
3297     if (gv && GvIMPORTED_CV(gv)) {
3298         rqop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3299                                append_elem(OP_LIST, id,
3300                                            scalar(newUNOP(OP_RV2CV, 0,
3301                                                           newGVOP(OP_GV, 0,
3302                                                                   gv))))));
3303     }
3304     else {
3305         rqop = newUNOP(OP_REQUIRE, 0, id);
3306     }
3307
3308     /* Fake up the BEGIN {}, which does its thing immediately. */
3309     newATTRSUB(floor,
3310         newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
3311         Nullop,
3312         Nullop,
3313         append_elem(OP_LINESEQ,
3314             append_elem(OP_LINESEQ,
3315                 newSTATEOP(0, Nullch, rqop),
3316                 newSTATEOP(0, Nullch, veop)),
3317             newSTATEOP(0, Nullch, imop) ));
3318
3319     PL_hints |= HINT_BLOCK_SCOPE;
3320     PL_copline = NOLINE;
3321     PL_expect = XSTATE;
3322 }
3323
3324 void
3325 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3326 {
3327     va_list args;
3328     va_start(args, ver);
3329     vload_module(flags, name, ver, &args);
3330     va_end(args);
3331 }
3332
3333 #ifdef PERL_IMPLICIT_CONTEXT
3334 void
3335 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3336 {
3337     dTHX;
3338     va_list args;
3339     va_start(args, ver);
3340     vload_module(flags, name, ver, &args);
3341     va_end(args);
3342 }
3343 #endif
3344
3345 void
3346 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3347 {
3348     OP *modname, *veop, *imop;
3349
3350     modname = newSVOP(OP_CONST, 0, name);
3351     modname->op_private |= OPpCONST_BARE;
3352     if (ver) {
3353         veop = newSVOP(OP_CONST, 0, ver);
3354     }
3355     else
3356         veop = Nullop;
3357     if (flags & PERL_LOADMOD_NOIMPORT) {
3358         imop = sawparens(newNULLLIST());
3359     }
3360     else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3361         imop = va_arg(*args, OP*);
3362     }
3363     else {
3364         SV *sv;
3365         imop = Nullop;
3366         sv = va_arg(*args, SV*);
3367         while (sv) {
3368             imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3369             sv = va_arg(*args, SV*);
3370         }
3371     }
3372     {
3373         line_t ocopline = PL_copline;
3374         int oexpect = PL_expect;
3375
3376         utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3377                 veop, modname, imop);
3378         PL_expect = oexpect;
3379         PL_copline = ocopline;
3380     }
3381 }
3382
3383 OP *
3384 Perl_dofile(pTHX_ OP *term)
3385 {
3386     OP *doop;
3387     GV *gv;
3388
3389     gv = gv_fetchpv("do", FALSE, SVt_PVCV);
3390     if (!(gv && GvIMPORTED_CV(gv)))
3391         gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3392
3393     if (gv && GvIMPORTED_CV(gv)) {
3394         doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3395                                append_elem(OP_LIST, term,
3396                                            scalar(newUNOP(OP_RV2CV, 0,
3397                                                           newGVOP(OP_GV, 0,
3398                                                                   gv))))));
3399     }
3400     else {
3401         doop = newUNOP(OP_DOFILE, 0, scalar(term));
3402     }
3403     return doop;
3404 }
3405
3406 OP *
3407 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3408 {
3409     return newBINOP(OP_LSLICE, flags,
3410             list(force_list(subscript)),
3411             list(force_list(listval)) );
3412 }
3413
3414 STATIC I32
3415 S_list_assignment(pTHX_ register OP *o)
3416 {
3417     if (!o)
3418         return TRUE;
3419
3420     if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3421         o = cUNOPo->op_first;
3422
3423     if (o->op_type == OP_COND_EXPR) {
3424         I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3425         I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3426
3427         if (t && f)
3428             return TRUE;
3429         if (t || f)
3430             yyerror("Assignment to both a list and a scalar");
3431         return FALSE;
3432     }
3433
3434     if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3435         o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3436         o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3437         return TRUE;
3438
3439     if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3440         return TRUE;
3441
3442     if (o->op_type == OP_RV2SV)
3443         return FALSE;
3444
3445     return FALSE;
3446 }
3447
3448 OP *
3449 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3450 {
3451     OP *o;
3452
3453     if (optype) {
3454         if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN) {
3455             return newLOGOP(optype, 0,
3456                 mod(scalar(left), optype),
3457                 newUNOP(OP_SASSIGN, 0, scalar(right)));
3458         }
3459         else {
3460             return newBINOP(optype, OPf_STACKED,
3461                 mod(scalar(left), optype), scalar(right));
3462         }
3463     }
3464
3465     if (list_assignment(left)) {
3466         OP *curop;
3467
3468         PL_modcount = 0;
3469         PL_eval_start = right;  /* Grandfathering $[ assignment here.  Bletch.*/
3470         left = mod(left, OP_AASSIGN);
3471         if (PL_eval_start)
3472             PL_eval_start = 0;
3473         else {
3474             op_free(left);
3475             op_free(right);
3476             return Nullop;
3477         }
3478         curop = list(force_list(left));
3479         o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3480         o->op_private = 0 | (flags >> 8);
3481         for (curop = ((LISTOP*)curop)->op_first;
3482              curop; curop = curop->op_sibling)
3483         {
3484             if (curop->op_type == OP_RV2HV &&
3485                 ((UNOP*)curop)->op_first->op_type != OP_GV) {
3486                 o->op_private |= OPpASSIGN_HASH;
3487                 break;
3488             }
3489         }
3490         if (!(left->op_private & OPpLVAL_INTRO)) {
3491             OP *lastop = o;
3492             PL_generation++;
3493             for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3494                 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3495                     if (curop->op_type == OP_GV) {
3496                         GV *gv = cGVOPx_gv(curop);
3497                         if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3498                             break;
3499                         SvCUR(gv) = PL_generation;
3500                     }
3501                     else if (curop->op_type == OP_PADSV ||
3502                              curop->op_type == OP_PADAV ||
3503                              curop->op_type == OP_PADHV ||
3504                              curop->op_type == OP_PADANY) {
3505                         SV **svp = AvARRAY(PL_comppad_name);
3506                         SV *sv = svp[curop->op_targ];
3507                         if (SvCUR(sv) == PL_generation)
3508                             break;
3509                         SvCUR(sv) = PL_generation;      /* (SvCUR not used any more) */
3510                     }
3511                     else if (curop->op_type == OP_RV2CV)
3512                         break;
3513                     else if (curop->op_type == OP_RV2SV ||
3514                              curop->op_type == OP_RV2AV ||
3515                              curop->op_type == OP_RV2HV ||
3516                              curop->op_type == OP_RV2GV) {
3517                         if (lastop->op_type != OP_GV)   /* funny deref? */
3518                             break;
3519                     }
3520                     else if (curop->op_type == OP_PUSHRE) {
3521                         if (((PMOP*)curop)->op_pmreplroot) {
3522 #ifdef USE_ITHREADS
3523                             GV *gv = (GV*)PL_curpad[(PADOFFSET)((PMOP*)curop)->op_pmreplroot];
3524 #else
3525                             GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3526 #endif
3527                             if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3528                                 break;
3529                             SvCUR(gv) = PL_generation;
3530                         }
3531                     }
3532                     else
3533                         break;
3534                 }
3535                 lastop = curop;
3536             }
3537             if (curop != o)
3538                 o->op_private |= OPpASSIGN_COMMON;
3539         }
3540         if (right && right->op_type == OP_SPLIT) {
3541             OP* tmpop;
3542             if ((tmpop = ((LISTOP*)right)->op_first) &&
3543                 tmpop->op_type == OP_PUSHRE)
3544             {
3545                 PMOP *pm = (PMOP*)tmpop;
3546                 if (left->op_type == OP_RV2AV &&
3547                     !(left->op_private & OPpLVAL_INTRO) &&
3548                     !(o->op_private & OPpASSIGN_COMMON) )
3549                 {
3550                     tmpop = ((UNOP*)left)->op_first;
3551                     if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3552 #ifdef USE_ITHREADS
3553                         pm->op_pmreplroot = (OP*)cPADOPx(tmpop)->op_padix;
3554                         cPADOPx(tmpop)->op_padix = 0;   /* steal it */
3555 #else
3556                         pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3557                         cSVOPx(tmpop)->op_sv = Nullsv;  /* steal it */
3558 #endif
3559                         pm->op_pmflags |= PMf_ONCE;
3560                         tmpop = cUNOPo->op_first;       /* to list (nulled) */
3561                         tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3562                         tmpop->op_sibling = Nullop;     /* don't free split */
3563                         right->op_next = tmpop->op_next;  /* fix starting loc */
3564                         op_free(o);                     /* blow off assign */
3565                         right->op_flags &= ~OPf_WANT;
3566                                 /* "I don't know and I don't care." */
3567                         return right;
3568                     }
3569                 }
3570                 else {
3571                    if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3572                       ((LISTOP*)right)->op_last->op_type == OP_CONST)
3573                     {
3574                         SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3575                         if (SvIVX(sv) == 0)
3576                             sv_setiv(sv, PL_modcount+1);
3577                     }
3578                 }
3579             }
3580         }
3581         return o;
3582     }
3583     if (!right)
3584         right = newOP(OP_UNDEF, 0);
3585     if (right->op_type == OP_READLINE) {
3586         right->op_flags |= OPf_STACKED;
3587         return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3588     }
3589     else {
3590         PL_eval_start = right;  /* Grandfathering $[ assignment here.  Bletch.*/
3591         o = newBINOP(OP_SASSIGN, flags,
3592             scalar(right), mod(scalar(left), OP_SASSIGN) );
3593         if (PL_eval_start)
3594             PL_eval_start = 0;
3595         else {
3596             op_free(o);
3597             return Nullop;
3598         }
3599     }
3600     return o;
3601 }
3602
3603 OP *
3604 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3605 {
3606     U32 seq = intro_my();
3607     register COP *cop;
3608
3609     NewOp(1101, cop, 1, COP);
3610     if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3611         cop->op_type = OP_DBSTATE;
3612         cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3613     }
3614     else {
3615         cop->op_type = OP_NEXTSTATE;
3616         cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3617     }
3618     cop->op_flags = flags;
3619     cop->op_private = (PL_hints & HINT_BYTE);
3620 #ifdef NATIVE_HINTS
3621     cop->op_private |= NATIVE_HINTS;
3622 #endif
3623     PL_compiling.op_private = cop->op_private;
3624     cop->op_next = (OP*)cop;
3625
3626     if (label) {
3627         cop->cop_label = label;
3628         PL_hints |= HINT_BLOCK_SCOPE;
3629     }
3630     cop->cop_seq = seq;
3631     cop->cop_arybase = PL_curcop->cop_arybase;
3632     if (specialWARN(PL_curcop->cop_warnings))
3633         cop->cop_warnings = PL_curcop->cop_warnings ;
3634     else
3635         cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3636     if (specialCopIO(PL_curcop->cop_io))
3637         cop->cop_io = PL_curcop->cop_io;
3638     else
3639         cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3640
3641
3642     if (PL_copline == NOLINE)
3643         CopLINE_set(cop, CopLINE(PL_curcop));
3644     else {
3645         CopLINE_set(cop, PL_copline);
3646         PL_copline = NOLINE;
3647     }
3648 #ifdef USE_ITHREADS
3649     CopFILE_set(cop, CopFILE(PL_curcop));       /* XXX share in a pvtable? */
3650 #else
3651     CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3652 #endif
3653     CopSTASH_set(cop, PL_curstash);
3654
3655     if (PERLDB_LINE && PL_curstash != PL_debstash) {
3656         SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3657         if (svp && *svp != &PL_sv_undef && !SvIOK(*svp)) {
3658             (void)SvIOK_on(*svp);
3659             SvIVX(*svp) = PTR2IV(cop);
3660         }
3661     }
3662
3663     return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3664 }
3665
3666 /* "Introduce" my variables to visible status. */
3667 U32
3668 Perl_intro_my(pTHX)
3669 {
3670     SV **svp;
3671     SV *sv;
3672     I32 i;
3673
3674     if (! PL_min_intro_pending)
3675         return PL_cop_seqmax;
3676
3677     svp = AvARRAY(PL_comppad_name);
3678     for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
3679         if ((sv = svp[i]) && sv != &PL_sv_undef && !SvIVX(sv)) {
3680             SvIVX(sv) = PAD_MAX;        /* Don't know scope end yet. */
3681             SvNVX(sv) = (NV)PL_cop_seqmax;
3682         }
3683     }
3684     PL_min_intro_pending = 0;
3685     PL_comppad_name_fill = PL_max_intro_pending;        /* Needn't search higher */
3686     return PL_cop_seqmax++;
3687 }
3688
3689 OP *
3690 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3691 {
3692     return new_logop(type, flags, &first, &other);
3693 }
3694
3695 STATIC OP *
3696 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3697 {
3698     LOGOP *logop;
3699     OP *o;
3700     OP *first = *firstp;
3701     OP *other = *otherp;
3702
3703     if (type == OP_XOR)         /* Not short circuit, but here by precedence. */
3704         return newBINOP(type, flags, scalar(first), scalar(other));
3705
3706     scalarboolean(first);
3707     /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3708     if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3709         if (type == OP_AND || type == OP_OR) {
3710             if (type == OP_AND)
3711                 type = OP_OR;
3712             else
3713                 type = OP_AND;
3714             o = first;
3715             first = *firstp = cUNOPo->op_first;
3716             if (o->op_next)
3717                 first->op_next = o->op_next;
3718             cUNOPo->op_first = Nullop;
3719             op_free(o);
3720         }
3721     }
3722     if (first->op_type == OP_CONST) {
3723         if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
3724             Perl_warner(aTHX_ WARN_BAREWORD, "Bareword found in conditional");
3725         if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
3726             op_free(first);
3727             *firstp = Nullop;
3728             return other;
3729         }
3730         else {
3731             op_free(other);
3732             *otherp = Nullop;
3733             return first;
3734         }
3735     }
3736     else if (first->op_type == OP_WANTARRAY) {
3737         if (type == OP_AND)
3738             list(other);
3739         else
3740             scalar(other);
3741     }
3742     else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS)) {
3743         OP *k1 = ((UNOP*)first)->op_first;
3744         OP *k2 = k1->op_sibling;
3745         OPCODE warnop = 0;
3746         switch (first->op_type)
3747         {
3748         case OP_NULL:
3749             if (k2 && k2->op_type == OP_READLINE
3750                   && (k2->op_flags & OPf_STACKED)
3751                   && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3752             {
3753                 warnop = k2->op_type;
3754             }
3755             break;
3756
3757         case OP_SASSIGN:
3758             if (k1->op_type == OP_READDIR
3759                   || k1->op_type == OP_GLOB
3760                   || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3761                   || k1->op_type == OP_EACH)
3762             {
3763                 warnop = ((k1->op_type == OP_NULL)
3764                           ? k1->op_targ : k1->op_type);
3765             }
3766             break;
3767         }
3768         if (warnop) {
3769             line_t oldline = CopLINE(PL_curcop);
3770             CopLINE_set(PL_curcop, PL_copline);
3771             Perl_warner(aTHX_ WARN_MISC,
3772                  "Value of %s%s can be \"0\"; test with defined()",
3773                  PL_op_desc[warnop],
3774                  ((warnop == OP_READLINE || warnop == OP_GLOB)
3775                   ? " construct" : "() operator"));
3776             CopLINE_set(PL_curcop, oldline);
3777         }
3778     }
3779
3780     if (!other)
3781         return first;
3782
3783     if (type == OP_ANDASSIGN || type == OP_ORASSIGN)
3784         other->op_private |= OPpASSIGN_BACKWARDS;  /* other is an OP_SASSIGN */
3785
3786     NewOp(1101, logop, 1, LOGOP);
3787
3788     logop->op_type = type;
3789     logop->op_ppaddr = PL_ppaddr[type];
3790     logop->op_first = first;
3791     logop->op_flags = flags | OPf_KIDS;
3792     logop->op_other = LINKLIST(other);
3793     logop->op_private = 1 | (flags >> 8);
3794
3795     /* establish postfix order */
3796     logop->op_next = LINKLIST(first);
3797     first->op_next = (OP*)logop;
3798     first->op_sibling = other;
3799
3800     o = newUNOP(OP_NULL, 0, (OP*)logop);
3801     other->op_next = o;
3802
3803     return o;
3804 }
3805
3806 OP *
3807 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3808 {
3809     LOGOP *logop;
3810     OP *start;
3811     OP *o;
3812
3813     if (!falseop)
3814         return newLOGOP(OP_AND, 0, first, trueop);
3815     if (!trueop)
3816         return newLOGOP(OP_OR, 0, first, falseop);
3817
3818     scalarboolean(first);
3819     if (first->op_type == OP_CONST) {
3820         if (SvTRUE(((SVOP*)first)->op_sv)) {
3821             op_free(first);
3822             op_free(falseop);
3823             return trueop;
3824         }
3825         else {
3826             op_free(first);
3827             op_free(trueop);
3828             return falseop;
3829         }
3830     }
3831     else if (first->op_type == OP_WANTARRAY) {
3832         list(trueop);
3833         scalar(falseop);
3834     }
3835     NewOp(1101, logop, 1, LOGOP);
3836     logop->op_type = OP_COND_EXPR;
3837     logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3838     logop->op_first = first;
3839     logop->op_flags = flags | OPf_KIDS;
3840     logop->op_private = 1 | (flags >> 8);
3841     logop->op_other = LINKLIST(trueop);
3842     logop->op_next = LINKLIST(falseop);
3843
3844
3845     /* establish postfix order */
3846     start = LINKLIST(first);
3847     first->op_next = (OP*)logop;
3848
3849     first->op_sibling = trueop;
3850     trueop->op_sibling = falseop;
3851     o = newUNOP(OP_NULL, 0, (OP*)logop);
3852
3853     trueop->op_next = falseop->op_next = o;
3854
3855     o->op_next = start;
3856     return o;
3857 }
3858
3859 OP *
3860 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3861 {
3862     LOGOP *range;
3863     OP *flip;
3864     OP *flop;
3865     OP *leftstart;
3866     OP *o;
3867
3868     NewOp(1101, range, 1, LOGOP);
3869
3870     range->op_type = OP_RANGE;
3871     range->op_ppaddr = PL_ppaddr[OP_RANGE];
3872     range->op_first = left;
3873     range->op_flags = OPf_KIDS;
3874     leftstart = LINKLIST(left);
3875     range->op_other = LINKLIST(right);
3876     range->op_private = 1 | (flags >> 8);
3877
3878     left->op_sibling = right;
3879
3880     range->op_next = (OP*)range;
3881     flip = newUNOP(OP_FLIP, flags, (OP*)range);
3882     flop = newUNOP(OP_FLOP, 0, flip);
3883     o = newUNOP(OP_NULL, 0, flop);
3884     linklist(flop);
3885     range->op_next = leftstart;
3886
3887     left->op_next = flip;
3888     right->op_next = flop;
3889
3890     range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3891     sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3892     flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3893     sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3894
3895     flip->op_private =  left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3896     flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3897
3898     flip->op_next = o;
3899     if (!flip->op_private || !flop->op_private)
3900         linklist(o);            /* blow off optimizer unless constant */
3901
3902     return o;
3903 }
3904
3905 OP *
3906 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3907 {
3908     OP* listop;
3909     OP* o;
3910     int once = block && block->op_flags & OPf_SPECIAL &&
3911       (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3912
3913     if (expr) {
3914         if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3915             return block;       /* do {} while 0 does once */
3916         if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3917             || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3918             expr = newUNOP(OP_DEFINED, 0,
3919                 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3920         } else if (expr->op_flags & OPf_KIDS) {
3921             OP *k1 = ((UNOP*)expr)->op_first;
3922             OP *k2 = (k1) ? k1->op_sibling : NULL;
3923             switch (expr->op_type) {
3924               case OP_NULL:
3925                 if (k2 && k2->op_type == OP_READLINE
3926                       && (k2->op_flags & OPf_STACKED)
3927                       && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3928                     expr = newUNOP(OP_DEFINED, 0, expr);
3929                 break;
3930
3931               case OP_SASSIGN:
3932                 if (k1->op_type == OP_READDIR
3933                       || k1->op_type == OP_GLOB
3934                       || (k1->op_type == OP_NULL && k1->op_targ == OP_NULL)
3935                       || k1->op_type == OP_EACH)
3936                     expr = newUNOP(OP_DEFINED, 0, expr);
3937                 break;
3938             }
3939         }
3940     }
3941
3942     listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3943     o = new_logop(OP_AND, 0, &expr, &listop);
3944
3945     if (listop)
3946         ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3947
3948     if (once && o != listop)
3949         o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3950
3951     if (o == listop)
3952         o = newUNOP(OP_NULL, 0, o);     /* or do {} while 1 loses outer block */
3953
3954     o->op_flags |= flags;
3955     o = scope(o);
3956     o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3957     return o;
3958 }
3959
3960 OP *
3961 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
3962 {
3963     OP *redo;
3964     OP *next = 0;
3965     OP *listop;
3966     OP *o;
3967     OP *condop;
3968     U8 loopflags = 0;
3969
3970     if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3971                  || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
3972         expr = newUNOP(OP_DEFINED, 0,
3973             newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3974     } else if (expr && (expr->op_flags & OPf_KIDS)) {
3975         OP *k1 = ((UNOP*)expr)->op_first;
3976         OP *k2 = (k1) ? k1->op_sibling : NULL;
3977         switch (expr->op_type) {
3978           case OP_NULL:
3979             if (k2 && k2->op_type == OP_READLINE
3980                   && (k2->op_flags & OPf_STACKED)
3981                   && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3982                 expr = newUNOP(OP_DEFINED, 0, expr);
3983             break;
3984
3985           case OP_SASSIGN:
3986             if (k1->op_type == OP_READDIR
3987                   || k1->op_type == OP_GLOB
3988                   || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3989                   || k1->op_type == OP_EACH)
3990                 expr = newUNOP(OP_DEFINED, 0, expr);
3991             break;
3992         }
3993     }
3994
3995     if (!block)
3996         block = newOP(OP_NULL, 0);
3997     else if (cont) {
3998         block = scope(block);
3999     }
4000
4001     if (cont) {
4002         next = LINKLIST(cont);
4003     }
4004     if (expr) {
4005         OP *unstack = newOP(OP_UNSTACK, 0);
4006         if (!next)
4007             next = unstack;
4008         cont = append_elem(OP_LINESEQ, cont, unstack);
4009         if ((line_t)whileline != NOLINE) {
4010             PL_copline = whileline;
4011             cont = append_elem(OP_LINESEQ, cont,
4012                                newSTATEOP(0, Nullch, Nullop));
4013         }
4014     }
4015
4016     listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4017     redo = LINKLIST(listop);
4018
4019     if (expr) {
4020         PL_copline = whileline;
4021         scalar(listop);
4022         o = new_logop(OP_AND, 0, &expr, &listop);
4023         if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4024             op_free(expr);              /* oops, it's a while (0) */
4025             op_free((OP*)loop);
4026             return Nullop;              /* listop already freed by new_logop */
4027         }
4028         if (listop)
4029             ((LISTOP*)listop)->op_last->op_next = condop =
4030                 (o == listop ? redo : LINKLIST(o));
4031     }
4032     else
4033         o = listop;
4034
4035     if (!loop) {
4036         NewOp(1101,loop,1,LOOP);
4037         loop->op_type = OP_ENTERLOOP;
4038         loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4039         loop->op_private = 0;
4040         loop->op_next = (OP*)loop;
4041     }
4042
4043     o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4044
4045     loop->op_redoop = redo;
4046     loop->op_lastop = o;
4047     o->op_private |= loopflags;
4048
4049     if (next)
4050         loop->op_nextop = next;
4051     else
4052         loop->op_nextop = o;
4053
4054     o->op_flags |= flags;
4055     o->op_private |= (flags >> 8);
4056     return o;
4057 }
4058
4059 OP *
4060 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
4061 {
4062     LOOP *loop;
4063     OP *wop;
4064     int padoff = 0;
4065     I32 iterflags = 0;
4066
4067     if (sv) {
4068         if (sv->op_type == OP_RV2SV) {  /* symbol table variable */
4069             sv->op_type = OP_RV2GV;
4070             sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4071         }
4072         else if (sv->op_type == OP_PADSV) { /* private variable */
4073             padoff = sv->op_targ;
4074             sv->op_targ = 0;
4075             op_free(sv);
4076             sv = Nullop;
4077         }
4078         else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
4079             padoff = sv->op_targ;
4080             sv->op_targ = 0;
4081             iterflags |= OPf_SPECIAL;
4082             op_free(sv);
4083             sv = Nullop;
4084         }
4085         else
4086             Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4087     }
4088     else {
4089 #ifdef USE_THREADS
4090         padoff = find_threadsv("_");
4091         iterflags |= OPf_SPECIAL;
4092 #else
4093         sv = newGVOP(OP_GV, 0, PL_defgv);
4094 #endif
4095     }
4096     if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4097         expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4098         iterflags |= OPf_STACKED;
4099     }
4100     else if (expr->op_type == OP_NULL &&
4101              (expr->op_flags & OPf_KIDS) &&
4102              ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4103     {
4104         /* Basically turn for($x..$y) into the same as for($x,$y), but we
4105          * set the STACKED flag to indicate that these values are to be
4106          * treated as min/max values by 'pp_iterinit'.
4107          */
4108         UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4109         LOGOP* range = (LOGOP*) flip->op_first;
4110         OP* left  = range->op_first;
4111         OP* right = left->op_sibling;
4112         LISTOP* listop;
4113
4114         range->op_flags &= ~OPf_KIDS;
4115         range->op_first = Nullop;
4116
4117         listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4118         listop->op_first->op_next = range->op_next;
4119         left->op_next = range->op_other;
4120         right->op_next = (OP*)listop;
4121         listop->op_next = listop->op_first;
4122
4123         op_free(expr);
4124         expr = (OP*)(listop);
4125         null(expr);
4126         iterflags |= OPf_STACKED;
4127     }
4128     else {
4129         expr = mod(force_list(expr), OP_GREPSTART);
4130     }
4131
4132
4133     loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4134                                append_elem(OP_LIST, expr, scalar(sv))));
4135     assert(!loop->op_next);
4136 #ifdef PL_OP_SLAB_ALLOC
4137     {
4138         LOOP *tmp;
4139         NewOp(1234,tmp,1,LOOP);
4140         Copy(loop,tmp,1,LOOP);
4141         loop = tmp;
4142     }
4143 #else
4144     Renew(loop, 1, LOOP);
4145 #endif
4146     loop->op_targ = padoff;
4147     wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
4148     PL_copline = forline;
4149     return newSTATEOP(0, label, wop);
4150 }
4151
4152 OP*
4153 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4154 {
4155     OP *o;
4156     STRLEN n_a;
4157
4158     if (type != OP_GOTO || label->op_type == OP_CONST) {
4159         /* "last()" means "last" */
4160         if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4161             o = newOP(type, OPf_SPECIAL);
4162         else {
4163             o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4164                                         ? SvPVx(((SVOP*)label)->op_sv, n_a)
4165                                         : ""));
4166         }
4167         op_free(label);
4168     }
4169     else {
4170         if (label->op_type == OP_ENTERSUB)
4171             label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4172         o = newUNOP(type, OPf_STACKED, label);
4173     }
4174     PL_hints |= HINT_BLOCK_SCOPE;
4175     return o;
4176 }
4177
4178 void
4179 Perl_cv_undef(pTHX_ CV *cv)
4180 {
4181 #ifdef USE_THREADS
4182     if (CvMUTEXP(cv)) {
4183         MUTEX_DESTROY(CvMUTEXP(cv));
4184         Safefree(CvMUTEXP(cv));
4185         CvMUTEXP(cv) = 0;
4186     }
4187 #endif /* USE_THREADS */
4188
4189     if (!CvXSUB(cv) && CvROOT(cv)) {
4190 #ifdef USE_THREADS
4191         if (CvDEPTH(cv) || (CvOWNER(cv) && CvOWNER(cv) != thr))
4192             Perl_croak(aTHX_ "Can't undef active subroutine");
4193 #else
4194         if (CvDEPTH(cv))
4195             Perl_croak(aTHX_ "Can't undef active subroutine");
4196 #endif /* USE_THREADS */
4197         ENTER;
4198
4199         SAVEVPTR(PL_curpad);
4200         PL_curpad = 0;
4201
4202         op_free(CvROOT(cv));
4203         CvROOT(cv) = Nullop;
4204         LEAVE;
4205     }
4206     SvPOK_off((SV*)cv);         /* forget prototype */
4207     CvGV(cv) = Nullgv;
4208     /* Since closure prototypes have the same lifetime as the containing
4209      * CV, they don't hold a refcount on the outside CV.  This avoids
4210      * the refcount loop between the outer CV (which keeps a refcount to
4211      * the closure prototype in the pad entry for pp_anoncode()) and the
4212      * closure prototype, and the ensuing memory leak.  --GSAR */
4213     if (!CvANON(cv) || CvCLONED(cv))
4214         SvREFCNT_dec(CvOUTSIDE(cv));
4215     CvOUTSIDE(cv) = Nullcv;
4216     if (CvCONST(cv)) {
4217         SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4218         CvCONST_off(cv);
4219     }
4220     if (CvPADLIST(cv)) {
4221         /* may be during global destruction */
4222         if (SvREFCNT(CvPADLIST(cv))) {
4223             I32 i = AvFILLp(CvPADLIST(cv));
4224             while (i >= 0) {
4225                 SV** svp = av_fetch(CvPADLIST(cv), i--, FALSE);
4226                 SV* sv = svp ? *svp : Nullsv;
4227                 if (!sv)
4228                     continue;
4229                 if (sv == (SV*)PL_comppad_name)
4230                     PL_comppad_name = Nullav;
4231                 else if (sv == (SV*)PL_comppad) {
4232                     PL_comppad = Nullav;
4233                     PL_curpad = Null(SV**);
4234                 }
4235                 SvREFCNT_dec(sv);
4236             }
4237             SvREFCNT_dec((SV*)CvPADLIST(cv));
4238         }
4239         CvPADLIST(cv) = Nullav;
4240     }
4241     CvFLAGS(cv) = 0;
4242 }
4243
4244 #ifdef DEBUG_CLOSURES
4245 STATIC void
4246 S_cv_dump(pTHX_ CV *cv)
4247 {
4248 #ifdef DEBUGGING
4249     CV *outside = CvOUTSIDE(cv);
4250     AV* padlist = CvPADLIST(cv);
4251     AV* pad_name;
4252     AV* pad;
4253     SV** pname;
4254     SV** ppad;
4255     I32 ix;
4256
4257     PerlIO_printf(Perl_debug_log,
4258                   "\tCV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
4259                   PTR2UV(cv),
4260                   (CvANON(cv) ? "ANON"
4261                    : (cv == PL_main_cv) ? "MAIN"
4262                    : CvUNIQUE(cv) ? "UNIQUE"
4263                    : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
4264                   PTR2UV(outside),
4265                   (!outside ? "null"
4266                    : CvANON(outside) ? "ANON"
4267                    : (outside == PL_main_cv) ? "MAIN"
4268                    : CvUNIQUE(outside) ? "UNIQUE"
4269                    : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
4270
4271     if (!padlist)
4272         return;
4273
4274     pad_name = (AV*)*av_fetch(padlist, 0, FALSE);
4275     pad = (AV*)*av_fetch(padlist, 1, FALSE);
4276     pname = AvARRAY(pad_name);
4277     ppad = AvARRAY(pad);
4278
4279     for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
4280         if (SvPOK(pname[ix]))
4281             PerlIO_printf(Perl_debug_log,
4282                           "\t%4d. 0x%"UVxf" (%s\"%s\" %"IVdf"-%"IVdf")\n",
4283                           (int)ix, PTR2UV(ppad[ix]),
4284                           SvFAKE(pname[ix]) ? "FAKE " : "",
4285                           SvPVX(pname[ix]),
4286                           (IV)I_32(SvNVX(pname[ix])),
4287                           SvIVX(pname[ix]));
4288     }
4289 #endif /* DEBUGGING */
4290 }
4291 #endif /* DEBUG_CLOSURES */
4292
4293 STATIC CV *
4294 S_cv_clone2(pTHX_ CV *proto, CV *outside)
4295 {
4296     AV* av;
4297     I32 ix;
4298     AV* protopadlist = CvPADLIST(proto);
4299     AV* protopad_name = (AV*)*av_fetch(protopadlist, 0, FALSE);
4300     AV* protopad = (AV*)*av_fetch(protopadlist, 1, FALSE);
4301     SV** pname = AvARRAY(protopad_name);
4302     SV** ppad = AvARRAY(protopad);
4303     I32 fname = AvFILLp(protopad_name);
4304     I32 fpad = AvFILLp(protopad);
4305     AV* comppadlist;
4306     CV* cv;
4307
4308     assert(!CvUNIQUE(proto));
4309
4310     ENTER;
4311     SAVECOMPPAD();
4312     SAVESPTR(PL_comppad_name);
4313     SAVESPTR(PL_compcv);
4314
4315     cv = PL_compcv = (CV*)NEWSV(1104,0);
4316     sv_upgrade((SV *)cv, SvTYPE(proto));
4317     CvFLAGS(cv) = CvFLAGS(proto) & ~CVf_CLONE;
4318     CvCLONED_on(cv);
4319
4320 #ifdef USE_THREADS
4321     New(666, CvMUTEXP(cv), 1, perl_mutex);
4322     MUTEX_INIT(CvMUTEXP(cv));
4323     CvOWNER(cv)         = 0;
4324 #endif /* USE_THREADS */
4325     CvFILE(cv)          = CvFILE(proto);
4326     CvGV(cv)            = CvGV(proto);
4327     CvSTASH(cv)         = CvSTASH(proto);
4328     CvROOT(cv)          = OpREFCNT_inc(CvROOT(proto));
4329     CvSTART(cv)         = CvSTART(proto);
4330     if (outside)
4331         CvOUTSIDE(cv)   = (CV*)SvREFCNT_inc(outside);
4332
4333     if (SvPOK(proto))
4334         sv_setpvn((SV*)cv, SvPVX(proto), SvCUR(proto));
4335
4336     PL_comppad_name = newAV();
4337     for (ix = fname; ix >= 0; ix--)
4338         av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
4339
4340     PL_comppad = newAV();
4341
4342     comppadlist = newAV();
4343     AvREAL_off(comppadlist);
4344     av_store(comppadlist, 0, (SV*)PL_comppad_name);
4345     av_store(comppadlist, 1, (SV*)PL_comppad);
4346     CvPADLIST(cv) = comppadlist;
4347     av_fill(PL_comppad, AvFILLp(protopad));
4348     PL_curpad = AvARRAY(PL_comppad);
4349
4350     av = newAV();           /* will be @_ */
4351     av_extend(av, 0);
4352     av_store(PL_comppad, 0, (SV*)av);
4353     AvFLAGS(av) = AVf_REIFY;
4354
4355     for (ix = fpad; ix > 0; ix--) {
4356         SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4357         if (namesv && namesv != &PL_sv_undef) {
4358             char *name = SvPVX(namesv);    /* XXX */
4359             if (SvFLAGS(namesv) & SVf_FAKE) {   /* lexical from outside? */
4360                 I32 off = pad_findlex(name, ix, SvIVX(namesv),
4361                                       CvOUTSIDE(cv), cxstack_ix, 0, 0);
4362                 if (!off)
4363                     PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4364                 else if (off != ix)
4365                     Perl_croak(aTHX_ "panic: cv_clone: %s", name);
4366             }
4367             else {                              /* our own lexical */
4368                 SV* sv;
4369                 if (*name == '&') {
4370                     /* anon code -- we'll come back for it */
4371                     sv = SvREFCNT_inc(ppad[ix]);
4372                 }
4373                 else if (*name == '@')
4374                     sv = (SV*)newAV();
4375                 else if (*name == '%')
4376                     sv = (SV*)newHV();
4377                 else
4378                     sv = NEWSV(0,0);
4379                 if (!SvPADBUSY(sv))
4380                     SvPADMY_on(sv);
4381                 PL_curpad[ix] = sv;
4382             }
4383         }
4384         else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
4385             PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4386         }
4387         else {
4388             SV* sv = NEWSV(0,0);
4389             SvPADTMP_on(sv);
4390             PL_curpad[ix] = sv;
4391         }
4392     }
4393
4394     /* Now that vars are all in place, clone nested closures. */
4395
4396     for (ix = fpad; ix > 0; ix--) {
4397         SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4398         if (namesv
4399             && namesv != &PL_sv_undef
4400             && !(SvFLAGS(namesv) & SVf_FAKE)
4401             && *SvPVX(namesv) == '&'
4402             && CvCLONE(ppad[ix]))
4403         {
4404             CV *kid = cv_clone2((CV*)ppad[ix], cv);
4405             SvREFCNT_dec(ppad[ix]);
4406             CvCLONE_on(kid);
4407             SvPADMY_on(kid);
4408             PL_curpad[ix] = (SV*)kid;
4409         }
4410     }
4411
4412 #ifdef DEBUG_CLOSURES
4413     PerlIO_printf(Perl_debug_log, "Cloned inside:\n");
4414     cv_dump(outside);
4415     PerlIO_printf(Perl_debug_log, "  from:\n");
4416     cv_dump(proto);
4417     PerlIO_printf(Perl_debug_log, "   to:\n");
4418     cv_dump(cv);
4419 #endif
4420
4421     LEAVE;
4422
4423     if (CvCONST(cv)) {
4424         SV* const_sv = op_const_sv(CvSTART(cv), cv);
4425         assert(const_sv);
4426         /* constant sub () { $x } closing over $x - see lib/constant.pm */
4427         SvREFCNT_dec(cv);
4428         cv = newCONSTSUB(CvSTASH(proto), 0, const_sv);
4429     }
4430
4431     return cv;
4432 }
4433
4434 CV *
4435 Perl_cv_clone(pTHX_ CV *proto)
4436 {
4437     CV *cv;
4438     LOCK_CRED_MUTEX;                    /* XXX create separate mutex */
4439     cv = cv_clone2(proto, CvOUTSIDE(proto));
4440     UNLOCK_CRED_MUTEX;                  /* XXX create separate mutex */
4441     return cv;
4442 }
4443
4444 void
4445 Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
4446 {
4447     if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4448         SV* msg = sv_newmortal();
4449         SV* name = Nullsv;
4450
4451         if (gv)
4452             gv_efullname3(name = sv_newmortal(), gv, Nullch);
4453         sv_setpv(msg, "Prototype mismatch:");
4454         if (name)
4455             Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4456         if (SvPOK(cv))
4457             Perl_sv_catpvf(aTHX_ msg, " (%s)", SvPVX(cv));
4458         sv_catpv(msg, " vs ");
4459         if (p)
4460             Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4461         else
4462             sv_catpv(msg, "none");
4463         Perl_warner(aTHX_ WARN_PROTOTYPE, "%"SVf, msg);
4464     }
4465 }
4466
4467 static void const_sv_xsub(pTHXo_ CV* cv);
4468
4469 /*
4470 =for apidoc cv_const_sv
4471
4472 If C<cv> is a constant sub eligible for inlining. returns the constant
4473 value returned by the sub.  Otherwise, returns NULL.
4474
4475 Constant subs can be created with C<newCONSTSUB> or as described in
4476 L<perlsub/"Constant Functions">.
4477
4478 =cut
4479 */
4480 SV *
4481 Perl_cv_const_sv(pTHX_ CV *cv)
4482 {
4483     if (!cv || !CvCONST(cv))
4484         return Nullsv;
4485     return (SV*)CvXSUBANY(cv).any_ptr;
4486 }
4487
4488 SV *
4489 Perl_op_const_sv(pTHX_ OP *o, CV *cv)
4490 {
4491     SV *sv = Nullsv;
4492
4493     if (!o)
4494         return Nullsv;
4495
4496     if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4497         o = cLISTOPo->op_first->op_sibling;
4498
4499     for (; o; o = o->op_next) {
4500         OPCODE type = o->op_type;
4501
4502         if (sv && o->op_next == o)
4503             return sv;
4504         if (o->op_next != o) {
4505             if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4506                 continue;
4507             if (type == OP_DBSTATE)
4508                 continue;
4509         }
4510         if (type == OP_LEAVESUB || type == OP_RETURN)
4511             break;
4512         if (sv)
4513             return Nullsv;
4514         if (type == OP_CONST && cSVOPo->op_sv)
4515             sv = cSVOPo->op_sv;
4516         else if ((type == OP_PADSV || type == OP_CONST) && cv) {
4517             AV* padav = (AV*)(AvARRAY(CvPADLIST(cv))[1]);
4518             sv = padav ? AvARRAY(padav)[o->op_targ] : Nullsv;
4519             if (!sv)
4520                 return Nullsv;
4521             if (CvCONST(cv)) {
4522                 /* We get here only from cv_clone2() while creating a closure.
4523                    Copy the const value here instead of in cv_clone2 so that
4524                    SvREADONLY_on doesn't lead to problems when leaving
4525                    scope.
4526                 */
4527                 sv = newSVsv(sv);
4528             }
4529             if (!SvREADONLY(sv) && SvREFCNT(sv) > 1)
4530                 return Nullsv;
4531         }
4532         else
4533             return Nullsv;
4534     }
4535     if (sv)
4536         SvREADONLY_on(sv);
4537     return sv;
4538 }
4539
4540 void
4541 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4542 {
4543     if (o)
4544         SAVEFREEOP(o);
4545     if (proto)
4546         SAVEFREEOP(proto);
4547     if (attrs)
4548         SAVEFREEOP(attrs);
4549     if (block)
4550         SAVEFREEOP(block);
4551     Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4552 }
4553
4554 CV *
4555 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4556 {
4557     return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4558 }
4559
4560 CV *
4561 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4562 {
4563     STRLEN n_a;
4564     char *name;
4565     char *aname;
4566     GV *gv;
4567     char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
4568     register CV *cv=0;
4569     I32 ix;
4570     SV *const_sv;
4571
4572     name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4573     if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4574         SV *sv = sv_newmortal();
4575         Perl_sv_setpvf(aTHX_ sv, "__ANON__[%s:%"IVdf"]",
4576                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4577         aname = SvPVX(sv);
4578     }
4579     else
4580         aname = Nullch;
4581     gv = gv_fetchpv(name ? name : (aname ? aname : "__ANON__"),
4582                     GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4583                     SVt_PVCV);
4584
4585     if (o)
4586         SAVEFREEOP(o);
4587     if (proto)
4588         SAVEFREEOP(proto);
4589     if (attrs)
4590         SAVEFREEOP(attrs);
4591
4592     if (SvTYPE(gv) != SVt_PVGV) {       /* Maybe prototype now, and had at
4593                                            maximum a prototype before. */
4594         if (SvTYPE(gv) > SVt_NULL) {
4595             if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4596                 && ckWARN_d(WARN_PROTOTYPE))
4597             {
4598                 Perl_warner(aTHX_ WARN_PROTOTYPE, "Runaway prototype");
4599             }
4600             cv_ckproto((CV*)gv, NULL, ps);
4601         }
4602         if (ps)
4603             sv_setpv((SV*)gv, ps);
4604         else
4605             sv_setiv((SV*)gv, -1);
4606         SvREFCNT_dec(PL_compcv);
4607         cv = PL_compcv = NULL;
4608         PL_sub_generation++;
4609         goto done;
4610     }
4611
4612     cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4613
4614 #ifdef GV_SHARED_CHECK
4615     if (cv && GvSHARED(gv) && SvREADONLY(cv)) {
4616         Perl_croak(aTHX_ "Can't define subroutine %s (GV is shared)", name);
4617     }
4618 #endif
4619
4620     if (!block || !ps || *ps || attrs)
4621         const_sv = Nullsv;
4622     else
4623         const_sv = op_const_sv(block, Nullcv);
4624
4625     if (cv) {
4626         bool exists = CvROOT(cv) || CvXSUB(cv);
4627
4628 #ifdef GV_SHARED_CHECK
4629         if (exists && GvSHARED(gv)) {
4630             Perl_croak(aTHX_ "Can't redefine shared subroutine %s", name);
4631         }
4632 #endif
4633
4634         /* if the subroutine doesn't exist and wasn't pre-declared
4635          * with a prototype, assume it will be AUTOLOADed,
4636          * skipping the prototype check
4637          */
4638         if (exists || SvPOK(cv))
4639             cv_ckproto(cv, gv, ps);
4640         /* already defined (or promised)? */
4641         if (exists || GvASSUMECV(gv)) {
4642             if (!block && !attrs) {
4643                 /* just a "sub foo;" when &foo is already defined */
4644                 SAVEFREESV(PL_compcv);
4645                 goto done;
4646             }
4647             /* ahem, death to those who redefine active sort subs */
4648             if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4649                 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4650             if (block) {
4651                 if (ckWARN(WARN_REDEFINE)
4652                     || (CvCONST(cv)
4653                         && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4654                 {
4655                     line_t oldline = CopLINE(PL_curcop);
4656                     CopLINE_set(PL_curcop, PL_copline);
4657                     Perl_warner(aTHX_ WARN_REDEFINE,
4658                         CvCONST(cv) ? "Constant subroutine %s redefined"
4659                                     : "Subroutine %s redefined", name);
4660                     CopLINE_set(PL_curcop, oldline);
4661                 }
4662                 SvREFCNT_dec(cv);
4663                 cv = Nullcv;
4664             }
4665         }
4666     }
4667     if (const_sv) {
4668         SvREFCNT_inc(const_sv);
4669         if (cv) {
4670             assert(!CvROOT(cv) && !CvCONST(cv));
4671             sv_setpv((SV*)cv, "");  /* prototype is "" */
4672             CvXSUBANY(cv).any_ptr = const_sv;
4673             CvXSUB(cv) = const_sv_xsub;
4674             CvCONST_on(cv);
4675         }
4676         else {
4677             GvCV(gv) = Nullcv;
4678             cv = newCONSTSUB(NULL, name, const_sv);
4679         }
4680         op_free(block);
4681         SvREFCNT_dec(PL_compcv);
4682         PL_compcv = NULL;
4683         PL_sub_generation++;
4684         goto done;
4685     }
4686     if (attrs) {
4687         HV *stash;
4688         SV *rcv;
4689
4690         /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4691          * before we clobber PL_compcv.
4692          */
4693         if (cv && !block) {
4694             rcv = (SV*)cv;
4695             if (CvGV(cv) && GvSTASH(CvGV(cv)) && HvNAME(GvSTASH(CvGV(cv))))
4696                 stash = GvSTASH(CvGV(cv));
4697             else if (CvSTASH(cv) && HvNAME(CvSTASH(cv)))
4698                 stash = CvSTASH(cv);
4699             else
4700                 stash = PL_curstash;
4701         }
4702         else {
4703             /* possibly about to re-define existing subr -- ignore old cv */
4704             rcv = (SV*)PL_compcv;
4705             if (name && GvSTASH(gv) && HvNAME(GvSTASH(gv)))
4706                 stash = GvSTASH(gv);
4707             else
4708                 stash = PL_curstash;
4709         }
4710         apply_attrs(stash, rcv, attrs);
4711     }
4712     if (cv) {                           /* must reuse cv if autoloaded */
4713         if (!block) {
4714             /* got here with just attrs -- work done, so bug out */
4715             SAVEFREESV(PL_compcv);
4716             goto done;
4717         }
4718         cv_undef(cv);
4719         CvFLAGS(cv) = CvFLAGS(PL_compcv);
4720         CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4721         CvOUTSIDE(PL_compcv) = 0;
4722         CvPADLIST(cv) = CvPADLIST(PL_compcv);
4723         CvPADLIST(PL_compcv) = 0;
4724         /* inner references to PL_compcv must be fixed up ... */
4725         {
4726             AV *padlist = CvPADLIST(cv);
4727             AV *comppad_name = (AV*)AvARRAY(padlist)[0];
4728             AV *comppad = (AV*)AvARRAY(padlist)[1];
4729             SV **namepad = AvARRAY(comppad_name);
4730             SV **curpad = AvARRAY(comppad);
4731             for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
4732                 SV *namesv = namepad[ix];
4733                 if (namesv && namesv != &PL_sv_undef
4734                     && *SvPVX(namesv) == '&')
4735                 {
4736                     CV *innercv = (CV*)curpad[ix];
4737                     if (CvOUTSIDE(innercv) == PL_compcv) {
4738                         CvOUTSIDE(innercv) = cv;
4739                         if (!CvANON(innercv) || CvCLONED(innercv)) {
4740                             (void)SvREFCNT_inc(cv);
4741                             SvREFCNT_dec(PL_compcv);
4742                         }
4743                     }
4744                 }
4745             }
4746         }
4747         /* ... before we throw it away */
4748         SvREFCNT_dec(PL_compcv);
4749     }
4750     else {
4751         cv = PL_compcv;
4752         if (name) {
4753             GvCV(gv) = cv;
4754             GvCVGEN(gv) = 0;
4755             PL_sub_generation++;
4756         }
4757     }
4758     CvGV(cv) = gv;
4759     CvFILE(cv) = CopFILE(PL_curcop);
4760     CvSTASH(cv) = PL_curstash;
4761 #ifdef USE_THREADS
4762     CvOWNER(cv) = 0;
4763     if (!CvMUTEXP(cv)) {
4764         New(666, CvMUTEXP(cv), 1, perl_mutex);
4765         MUTEX_INIT(CvMUTEXP(cv));
4766     }
4767 #endif /* USE_THREADS */
4768
4769     if (ps)
4770         sv_setpv((SV*)cv, ps);
4771
4772     if (PL_error_count) {
4773         op_free(block);
4774         block = Nullop;
4775         if (name) {
4776             char *s = strrchr(name, ':');
4777             s = s ? s+1 : name;
4778             if (strEQ(s, "BEGIN")) {
4779                 char *not_safe =
4780                     "BEGIN not safe after errors--compilation aborted";
4781                 if (PL_in_eval & EVAL_KEEPERR)
4782                     Perl_croak(aTHX_ not_safe);
4783                 else {
4784                     /* force display of errors found but not reported */
4785                     sv_catpv(ERRSV, not_safe);
4786                     Perl_croak(aTHX_ "%s", SvPVx(ERRSV, n_a));
4787                 }
4788             }
4789         }
4790     }
4791     if (!block)
4792         goto done;
4793
4794     if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
4795         av_store(PL_comppad_name, AvFILLp(PL_comppad), Nullsv);
4796
4797     if (CvLVALUE(cv)) {
4798         CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4799                              mod(scalarseq(block), OP_LEAVESUBLV));
4800     }
4801     else {
4802         CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4803     }
4804     CvROOT(cv)->op_private |= OPpREFCOUNTED;
4805     OpREFCNT_set(CvROOT(cv), 1);
4806     CvSTART(cv) = LINKLIST(CvROOT(cv));
4807     CvROOT(cv)->op_next = 0;
4808     peep(CvSTART(cv));
4809
4810     /* now that optimizer has done its work, adjust pad values */
4811     if (CvCLONE(cv)) {
4812         SV **namep = AvARRAY(PL_comppad_name);
4813         for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4814             SV *namesv;
4815
4816             if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
4817                 continue;
4818             /*
4819              * The only things that a clonable function needs in its
4820              * pad are references to outer lexicals and anonymous subs.
4821              * The rest are created anew during cloning.
4822              */
4823             if (!((namesv = namep[ix]) != Nullsv &&
4824                   namesv != &PL_sv_undef &&
4825                   (SvFAKE(namesv) ||
4826                    *SvPVX(namesv) == '&')))
4827             {
4828                 SvREFCNT_dec(PL_curpad[ix]);
4829                 PL_curpad[ix] = Nullsv;
4830             }
4831         }
4832         assert(!CvCONST(cv));
4833         if (ps && !*ps && op_const_sv(block, cv))
4834             CvCONST_on(cv);
4835     }
4836     else {
4837         AV *av = newAV();                       /* Will be @_ */
4838         av_extend(av, 0);
4839         av_store(PL_comppad, 0, (SV*)av);
4840         AvFLAGS(av) = AVf_REIFY;
4841
4842         for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4843             if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
4844                 continue;
4845             if (!SvPADMY(PL_curpad[ix]))
4846                 SvPADTMP_on(PL_curpad[ix]);
4847         }
4848     }
4849
4850     /* If a potential closure prototype, don't keep a refcount on outer CV.
4851      * This is okay as the lifetime of the prototype is tied to the
4852      * lifetime of the outer CV.  Avoids memory leak due to reference
4853      * loop. --GSAR */
4854     if (!name)
4855         SvREFCNT_dec(CvOUTSIDE(cv));
4856
4857     if (name || aname) {
4858         char *s;
4859         char *tname = (name ? name : aname);
4860
4861         if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4862             SV *sv = NEWSV(0,0);
4863             SV *tmpstr = sv_newmortal();
4864             GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4865             CV *pcv;
4866             HV *hv;
4867
4868             Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4869                            CopFILE(PL_curcop),
4870                            (long)PL_subline, (long)CopLINE(PL_curcop));
4871             gv_efullname3(tmpstr, gv, Nullch);
4872             hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
4873             hv = GvHVn(db_postponed);
4874             if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
4875                 && (pcv = GvCV(db_postponed)))
4876             {
4877                 dSP;
4878                 PUSHMARK(SP);
4879                 XPUSHs(tmpstr);
4880                 PUTBACK;
4881                 call_sv((SV*)pcv, G_DISCARD);
4882             }
4883         }
4884
4885         if ((s = strrchr(tname,':')))
4886             s++;
4887         else
4888             s = tname;
4889
4890         if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4891             goto done;
4892
4893         if (strEQ(s, "BEGIN")) {
4894             I32 oldscope = PL_scopestack_ix;
4895             ENTER;
4896             SAVECOPFILE(&PL_compiling);
4897             SAVECOPLINE(&PL_compiling);
4898             save_svref(&PL_rs);
4899             sv_setsv(PL_rs, PL_nrs);
4900
4901             if (!PL_beginav)
4902                 PL_beginav = newAV();
4903             DEBUG_x( dump_sub(gv) );
4904             av_push(PL_beginav, (SV*)cv);
4905             GvCV(gv) = 0;               /* cv has been hijacked */
4906             call_list(oldscope, PL_beginav);
4907
4908             PL_curcop = &PL_compiling;
4909             PL_compiling.op_private = PL_hints;
4910             LEAVE;
4911         }
4912         else if (strEQ(s, "END") && !PL_error_count) {
4913             if (!PL_endav)
4914                 PL_endav = newAV();
4915             DEBUG_x( dump_sub(gv) );
4916             av_unshift(PL_endav, 1);
4917             av_store(PL_endav, 0, (SV*)cv);
4918             GvCV(gv) = 0;               /* cv has been hijacked */
4919         }
4920         else if (strEQ(s, "CHECK") && !PL_error_count) {
4921             if (!PL_checkav)
4922                 PL_checkav = newAV();
4923             DEBUG_x( dump_sub(gv) );
4924             if (PL_main_start && ckWARN(WARN_VOID))
4925                 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
4926             av_unshift(PL_checkav, 1);
4927             av_store(PL_checkav, 0, (SV*)cv);
4928             GvCV(gv) = 0;               /* cv has been hijacked */
4929         }
4930         else if (strEQ(s, "INIT") && !PL_error_count) {
4931             if (!PL_initav)
4932                 PL_initav = newAV();
4933             DEBUG_x( dump_sub(gv) );
4934             if (PL_main_start && ckWARN(WARN_VOID))
4935                 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
4936             av_push(PL_initav, (SV*)cv);
4937             GvCV(gv) = 0;               /* cv has been hijacked */
4938         }
4939     }
4940
4941   done:
4942     PL_copline = NOLINE;
4943     LEAVE_SCOPE(floor);
4944     return cv;
4945 }
4946
4947 /* XXX unsafe for threads if eval_owner isn't held */
4948 /*
4949 =for apidoc newCONSTSUB
4950
4951 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4952 eligible for inlining at compile-time.
4953
4954 =cut
4955 */
4956
4957 CV *
4958 Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
4959 {
4960     CV* cv;
4961
4962     ENTER;
4963
4964     SAVECOPLINE(PL_curcop);
4965     CopLINE_set(PL_curcop, PL_copline);
4966
4967     SAVEHINTS();
4968     PL_hints &= ~HINT_BLOCK_SCOPE;
4969
4970     if (stash) {
4971         SAVESPTR(PL_curstash);
4972         SAVECOPSTASH(PL_curcop);
4973         PL_curstash = stash;
4974 #ifdef USE_ITHREADS
4975         CopSTASHPV(PL_curcop) = stash ? HvNAME(stash) : Nullch;
4976 #else
4977         CopSTASH(PL_curcop) = stash;
4978 #endif
4979     }
4980
4981     cv = newXS(name, const_sv_xsub, __FILE__);
4982     CvXSUBANY(cv).any_ptr = sv;
4983     CvCONST_on(cv);
4984     sv_setpv((SV*)cv, "");  /* prototype is "" */
4985
4986     LEAVE;
4987
4988     return cv;
4989 }
4990
4991 /*
4992 =for apidoc U||newXS
4993
4994 Used by C<xsubpp> to hook up XSUBs as Perl subs.
4995
4996 =cut
4997 */
4998
4999 CV *
5000 Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
5001 {
5002     GV *gv = gv_fetchpv(name ? name : "__ANON__", GV_ADDMULTI, SVt_PVCV);
5003     register CV *cv;
5004
5005     if ((cv = (name ? GvCV(gv) : Nullcv))) {
5006         if (GvCVGEN(gv)) {
5007             /* just a cached method */
5008             SvREFCNT_dec(cv);
5009             cv = 0;
5010         }
5011         else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
5012             /* already defined (or promised) */
5013             if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
5014                             && HvNAME(GvSTASH(CvGV(cv)))
5015                             && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
5016                 line_t oldline = CopLINE(PL_curcop);
5017                 if (PL_copline != NOLINE)
5018                     CopLINE_set(PL_curcop, PL_copline);
5019                 Perl_warner(aTHX_ WARN_REDEFINE,
5020                             CvCONST(cv) ? "Constant subroutine %s redefined"
5021                                         : "Subroutine %s redefined"
5022                             ,name);
5023                 CopLINE_set(PL_curcop, oldline);
5024             }
5025             SvREFCNT_dec(cv);
5026             cv = 0;
5027         }
5028     }
5029
5030     if (cv)                             /* must reuse cv if autoloaded */
5031         cv_undef(cv);
5032     else {
5033         cv = (CV*)NEWSV(1105,0);
5034         sv_upgrade((SV *)cv, SVt_PVCV);
5035         if (name) {
5036             GvCV(gv) = cv;
5037             GvCVGEN(gv) = 0;
5038             PL_sub_generation++;
5039         }
5040     }
5041     CvGV(cv) = gv;
5042 #ifdef USE_THREADS
5043     New(666, CvMUTEXP(cv), 1, perl_mutex);
5044     MUTEX_INIT(CvMUTEXP(cv));
5045     CvOWNER(cv) = 0;
5046 #endif /* USE_THREADS */
5047     (void)gv_fetchfile(filename);
5048     CvFILE(cv) = filename;      /* NOTE: not copied, as it is expected to be
5049                                    an external constant string */
5050     CvXSUB(cv) = subaddr;
5051
5052     if (name) {
5053         char *s = strrchr(name,':');
5054         if (s)
5055             s++;
5056         else
5057             s = name;
5058
5059         if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5060             goto done;
5061
5062         if (strEQ(s, "BEGIN")) {
5063             if (!PL_beginav)
5064                 PL_beginav = newAV();
5065             av_push(PL_beginav, (SV*)cv);
5066             GvCV(gv) = 0;               /* cv has been hijacked */
5067         }
5068         else if (strEQ(s, "END")) {
5069             if (!PL_endav)
5070                 PL_endav = newAV();
5071             av_unshift(PL_endav, 1);
5072             av_store(PL_endav, 0, (SV*)cv);
5073             GvCV(gv) = 0;               /* cv has been hijacked */
5074         }
5075         else if (strEQ(s, "CHECK")) {
5076             if (!PL_checkav)
5077                 PL_checkav = newAV();
5078             if (PL_main_start && ckWARN(WARN_VOID))
5079                 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
5080             av_unshift(PL_checkav, 1);
5081             av_store(PL_checkav, 0, (SV*)cv);
5082             GvCV(gv) = 0;               /* cv has been hijacked */
5083         }
5084         else if (strEQ(s, "INIT")) {
5085             if (!PL_initav)
5086                 PL_initav = newAV();
5087             if (PL_main_start && ckWARN(WARN_VOID))
5088                 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
5089             av_push(PL_initav, (SV*)cv);
5090             GvCV(gv) = 0;               /* cv has been hijacked */
5091         }
5092     }
5093     else
5094         CvANON_on(cv);
5095
5096 done:
5097     return cv;
5098 }
5099
5100 void
5101 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
5102 {
5103     register CV *cv;
5104     char *name;
5105     GV *gv;
5106     I32 ix;
5107     STRLEN n_a;
5108
5109     if (o)
5110         name = SvPVx(cSVOPo->op_sv, n_a);
5111     else
5112         name = "STDOUT";
5113     gv = gv_fetchpv(name,TRUE, SVt_PVFM);
5114 #ifdef GV_SHARED_CHECK
5115     if (GvSHARED(gv)) {
5116         Perl_croak(aTHX_ "Bad symbol for form (GV is shared)");
5117     }
5118 #endif
5119     GvMULTI_on(gv);
5120     if ((cv = GvFORM(gv))) {
5121         if (ckWARN(WARN_REDEFINE)) {
5122             line_t oldline = CopLINE(PL_curcop);
5123
5124             CopLINE_set(PL_curcop, PL_copline);
5125             Perl_warner(aTHX_ WARN_REDEFINE, "Format %s redefined",name);
5126             CopLINE_set(PL_curcop, oldline);
5127         }
5128         SvREFCNT_dec(cv);
5129     }
5130     cv = PL_compcv;
5131     GvFORM(gv) = cv;
5132     CvGV(cv) = gv;
5133     CvFILE(cv) = CopFILE(PL_curcop);
5134
5135     for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
5136         if (!SvPADMY(PL_curpad[ix]) && !SvIMMORTAL(PL_curpad[ix]))
5137             SvPADTMP_on(PL_curpad[ix]);
5138     }
5139
5140     CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5141     CvROOT(cv)->op_private |= OPpREFCOUNTED;
5142     OpREFCNT_set(CvROOT(cv), 1);
5143     CvSTART(cv) = LINKLIST(CvROOT(cv));
5144     CvROOT(cv)->op_next = 0;
5145     peep(CvSTART(cv));
5146     op_free(o);
5147     PL_copline = NOLINE;
5148     LEAVE_SCOPE(floor);
5149 }
5150
5151 OP *
5152 Perl_newANONLIST(pTHX_ OP *o)
5153 {
5154     return newUNOP(OP_REFGEN, 0,
5155         mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
5156 }
5157
5158 OP *
5159 Perl_newANONHASH(pTHX_ OP *o)
5160 {
5161     return newUNOP(OP_REFGEN, 0,
5162         mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
5163 }
5164
5165 OP *
5166 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5167 {
5168     return newANONATTRSUB(floor, proto, Nullop, block);
5169 }
5170
5171 OP *
5172 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5173 {
5174     return newUNOP(OP_REFGEN, 0,
5175         newSVOP(OP_ANONCODE, 0,
5176                 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5177 }
5178
5179 OP *
5180 Perl_oopsAV(pTHX_ OP *o)
5181 {
5182     switch (o->op_type) {
5183     case OP_PADSV:
5184         o->op_type = OP_PADAV;
5185         o->op_ppaddr = PL_ppaddr[OP_PADAV];
5186         return ref(o, OP_RV2AV);
5187
5188     case OP_RV2SV:
5189         o->op_type = OP_RV2AV;
5190         o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5191         ref(o, OP_RV2AV);
5192         break;
5193
5194     default:
5195         if (ckWARN_d(WARN_INTERNAL))
5196             Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsAV");
5197         break;
5198     }
5199     return o;
5200 }
5201
5202 OP *
5203 Perl_oopsHV(pTHX_ OP *o)
5204 {
5205     switch (o->op_type) {
5206     case OP_PADSV:
5207     case OP_PADAV:
5208         o->op_type = OP_PADHV;
5209         o->op_ppaddr = PL_ppaddr[OP_PADHV];
5210         return ref(o, OP_RV2HV);
5211
5212     case OP_RV2SV:
5213     case OP_RV2AV:
5214         o->op_type = OP_RV2HV;
5215         o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5216         ref(o, OP_RV2HV);
5217         break;
5218
5219     default:
5220         if (ckWARN_d(WARN_INTERNAL))
5221             Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsHV");
5222         break;
5223     }
5224     return o;
5225 }
5226
5227 OP *
5228 Perl_newAVREF(pTHX_ OP *o)
5229 {
5230     if (o->op_type == OP_PADANY) {
5231         o->op_type = OP_PADAV;
5232         o->op_ppaddr = PL_ppaddr[OP_PADAV];
5233         return o;
5234     }
5235     return newUNOP(OP_RV2AV, 0, scalar(o));
5236 }
5237
5238 OP *
5239 Perl_newGVREF(pTHX_ I32 type, OP *o)
5240 {
5241     if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5242         return newUNOP(OP_NULL, 0, o);
5243     return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5244 }
5245
5246 OP *
5247 Perl_newHVREF(pTHX_ OP *o)
5248 {
5249     if (o->op_type == OP_PADANY) {
5250         o->op_type = OP_PADHV;
5251         o->op_ppaddr = PL_ppaddr[OP_PADHV];
5252         return o;
5253     }
5254     return newUNOP(OP_RV2HV, 0, scalar(o));
5255 }
5256
5257 OP *
5258 Perl_oopsCV(pTHX_ OP *o)
5259 {
5260     Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5261     /* STUB */
5262     return o;
5263 }
5264
5265 OP *
5266 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5267 {
5268     return newUNOP(OP_RV2CV, flags, scalar(o));
5269 }
5270
5271 OP *
5272 Perl_newSVREF(pTHX_ OP *o)
5273 {
5274     if (o->op_type == OP_PADANY) {
5275         o->op_type = OP_PADSV;
5276         o->op_ppaddr = PL_ppaddr[OP_PADSV];
5277         return o;
5278     }
5279     else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5280         o->op_flags |= OPpDONE_SVREF;
5281         return o;
5282     }
5283     return newUNOP(OP_RV2SV, 0, scalar(o));
5284 }
5285
5286 /* Check routines. */
5287
5288 OP *
5289 Perl_ck_anoncode(pTHX_ OP *o)
5290 {
5291     PADOFFSET ix;
5292     SV* name;
5293
5294     name = NEWSV(1106,0);
5295     sv_upgrade(name, SVt_PVNV);
5296     sv_setpvn(name, "&", 1);
5297     SvIVX(name) = -1;
5298     SvNVX(name) = 1;
5299     ix = pad_alloc(o->op_type, SVs_PADMY);
5300     av_store(PL_comppad_name, ix, name);
5301     av_store(PL_comppad, ix, cSVOPo->op_sv);
5302     SvPADMY_on(cSVOPo->op_sv);
5303     cSVOPo->op_sv = Nullsv;
5304     cSVOPo->op_targ = ix;
5305     return o;
5306 }
5307
5308 OP *
5309 Perl_ck_bitop(pTHX_ OP *o)
5310 {
5311     o->op_private = PL_hints;
5312     return o;
5313 }
5314
5315 OP *
5316 Perl_ck_concat(pTHX_ OP *o)
5317 {
5318     if (cUNOPo->op_first->op_type == OP_CONCAT)
5319         o->op_flags |= OPf_STACKED;
5320     return o;
5321 }
5322
5323 OP *
5324 Perl_ck_spair(pTHX_ OP *o)
5325 {
5326     if (o->op_flags & OPf_KIDS) {
5327         OP* newop;
5328         OP* kid;
5329         OPCODE type = o->op_type;
5330         o = modkids(ck_fun(o), type);
5331         kid = cUNOPo->op_first;
5332         newop = kUNOP->op_first->op_sibling;
5333         if (newop &&
5334             (newop->op_sibling ||
5335              !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
5336              newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5337              newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
5338
5339             return o;
5340         }
5341         op_free(kUNOP->op_first);
5342         kUNOP->op_first = newop;
5343     }
5344     o->op_ppaddr = PL_ppaddr[++o->op_type];
5345     return ck_fun(o);
5346 }
5347
5348 OP *
5349 Perl_ck_delete(pTHX_ OP *o)
5350 {
5351     o = ck_fun(o);
5352     o->op_private = 0;
5353     if (o->op_flags & OPf_KIDS) {
5354         OP *kid = cUNOPo->op_first;
5355         switch (kid->op_type) {
5356         case OP_ASLICE:
5357             o->op_flags |= OPf_SPECIAL;
5358             /* FALL THROUGH */
5359         case OP_HSLICE:
5360             o->op_private |= OPpSLICE;
5361             break;
5362         case OP_AELEM:
5363             o->op_flags |= OPf_SPECIAL;
5364             /* FALL THROUGH */
5365         case OP_HELEM:
5366             break;
5367         default:
5368             Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5369                   PL_op_desc[o->op_type]);
5370         }
5371         null(kid);
5372     }
5373     return o;
5374 }
5375
5376 OP *
5377 Perl_ck_eof(pTHX_ OP *o)
5378 {
5379     I32 type = o->op_type;
5380
5381     if (o->op_flags & OPf_KIDS) {
5382         if (cLISTOPo->op_first->op_type == OP_STUB) {
5383             op_free(o);
5384             o = newUNOP(type, OPf_SPECIAL,
5385                 newGVOP(OP_GV, 0, gv_fetchpv("main::ARGV", TRUE, SVt_PVAV)));
5386         }
5387         return ck_fun(o);
5388     }
5389     return o;
5390 }
5391
5392 OP *
5393 Perl_ck_eval(pTHX_ OP *o)
5394 {
5395     PL_hints |= HINT_BLOCK_SCOPE;
5396     if (o->op_flags & OPf_KIDS) {
5397         SVOP *kid = (SVOP*)cUNOPo->op_first;
5398
5399         if (!kid) {
5400             o->op_flags &= ~OPf_KIDS;
5401             null(o);
5402         }
5403         else if (kid->op_type == OP_LINESEQ) {
5404             LOGOP *enter;
5405
5406             kid->op_next = o->op_next;
5407             cUNOPo->op_first = 0;
5408             op_free(o);
5409
5410             NewOp(1101, enter, 1, LOGOP);
5411             enter->op_type = OP_ENTERTRY;
5412             enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5413             enter->op_private = 0;
5414
5415             /* establish postfix order */
5416             enter->op_next = (OP*)enter;
5417
5418             o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5419             o->op_type = OP_LEAVETRY;
5420             o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5421             enter->op_other = o;
5422             return o;
5423         }
5424         else
5425             scalar((OP*)kid);
5426     }
5427     else {
5428         op_free(o);
5429         o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5430     }
5431     o->op_targ = (PADOFFSET)PL_hints;
5432     return o;
5433 }
5434
5435 OP *
5436 Perl_ck_exit(pTHX_ OP *o)
5437 {
5438 #ifdef VMS
5439     HV *table = GvHV(PL_hintgv);
5440     if (table) {
5441        SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
5442        if (svp && *svp && SvTRUE(*svp))
5443            o->op_private |= OPpEXIT_VMSISH;
5444     }
5445 #endif
5446     return ck_fun(o);
5447 }
5448
5449 OP *
5450 Perl_ck_exec(pTHX_ OP *o)
5451 {
5452     OP *kid;
5453     if (o->op_flags & OPf_STACKED) {
5454         o = ck_fun(o);
5455         kid = cUNOPo->op_first->op_sibling;
5456         if (kid->op_type == OP_RV2GV)
5457             null(kid);
5458     }
5459     else
5460         o = listkids(o);
5461     return o;
5462 }
5463
5464 OP *
5465 Perl_ck_exists(pTHX_ OP *o)
5466 {
5467     o = ck_fun(o);
5468     if (o->op_flags & OPf_KIDS) {
5469         OP *kid = cUNOPo->op_first;
5470         if (kid->op_type == OP_ENTERSUB) {
5471             (void) ref(kid, o->op_type);
5472             if (kid->op_type != OP_RV2CV && !PL_error_count)
5473                 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5474                            PL_op_desc[o->op_type]);
5475             o->op_private |= OPpEXISTS_SUB;
5476         }
5477         else if (kid->op_type == OP_AELEM)
5478             o->op_flags |= OPf_SPECIAL;
5479         else if (kid->op_type != OP_HELEM)
5480             Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5481                        PL_op_desc[o->op_type]);
5482         null(kid);
5483     }
5484     return o;
5485 }
5486
5487 #if 0
5488 OP *
5489 Perl_ck_gvconst(pTHX_ register OP *o)
5490 {
5491     o = fold_constants(o);
5492     if (o->op_type == OP_CONST)
5493         o->op_type = OP_GV;
5494     return o;
5495 }
5496 #endif
5497
5498 OP *
5499 Perl_ck_rvconst(pTHX_ register OP *o)
5500 {
5501     SVOP *kid = (SVOP*)cUNOPo->op_first;
5502
5503     o->op_private |= (PL_hints & HINT_STRICT_REFS);
5504     if (kid->op_type == OP_CONST) {
5505         char *name;
5506         int iscv;
5507         GV *gv;
5508         SV *kidsv = kid->op_sv;
5509         STRLEN n_a;
5510
5511         /* Is it a constant from cv_const_sv()? */
5512         if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5513             SV *rsv = SvRV(kidsv);
5514             int svtype = SvTYPE(rsv);
5515             char *badtype = Nullch;
5516
5517             switch (o->op_type) {
5518             case OP_RV2SV:
5519                 if (svtype > SVt_PVMG)
5520                     badtype = "a SCALAR";
5521                 break;
5522             case OP_RV2AV:
5523                 if (svtype != SVt_PVAV)
5524                     badtype = "an ARRAY";
5525                 break;
5526             case OP_RV2HV:
5527                 if (svtype != SVt_PVHV) {
5528                     if (svtype == SVt_PVAV) {   /* pseudohash? */
5529                         SV **ksv = av_fetch((AV*)rsv, 0, FALSE);
5530                         if (ksv && SvROK(*ksv)
5531                             && SvTYPE(SvRV(*ksv)) == SVt_PVHV)
5532                         {
5533                                 break;
5534                         }
5535                     }
5536                     badtype = "a HASH";
5537                 }
5538                 break;
5539             case OP_RV2CV:
5540                 if (svtype != SVt_PVCV)
5541                     badtype = "a CODE";
5542                 break;
5543             }
5544             if (badtype)
5545                 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5546             return o;
5547         }
5548         name = SvPV(kidsv, n_a);
5549         if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5550             char *badthing = Nullch;
5551             switch (o->op_type) {
5552             case OP_RV2SV:
5553                 badthing = "a SCALAR";
5554                 break;
5555             case OP_RV2AV:
5556                 badthing = "an ARRAY";
5557                 break;
5558             case OP_RV2HV:
5559                 badthing = "a HASH";
5560                 break;
5561             }
5562             if (badthing)
5563                 Perl_croak(aTHX_
5564           "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
5565                       name, badthing);
5566         }
5567         /*
5568          * This is a little tricky.  We only want to add the symbol if we
5569          * didn't add it in the lexer.  Otherwise we get duplicate strict
5570          * warnings.  But if we didn't add it in the lexer, we must at
5571          * least pretend like we wanted to add it even if it existed before,
5572          * or we get possible typo warnings.  OPpCONST_ENTERED says
5573          * whether the lexer already added THIS instance of this symbol.
5574          */
5575         iscv = (o->op_type == OP_RV2CV) * 2;
5576         do {
5577             gv = gv_fetchpv(name,
5578                 iscv | !(kid->op_private & OPpCONST_ENTERED),
5579                 iscv
5580                     ? SVt_PVCV
5581                     : o->op_type == OP_RV2SV
5582                         ? SVt_PV
5583                         : o->op_type == OP_RV2AV
5584                             ? SVt_PVAV
5585                             : o->op_type == OP_RV2HV
5586                                 ? SVt_PVHV
5587                                 : SVt_PVGV);
5588         } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5589         if (gv) {
5590             kid->op_type = OP_GV;
5591             SvREFCNT_dec(kid->op_sv);
5592 #ifdef USE_ITHREADS
5593             /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5594             kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5595             SvREFCNT_dec(PL_curpad[kPADOP->op_padix]);
5596             GvIN_PAD_on(gv);
5597             PL_curpad[kPADOP->op_padix] = SvREFCNT_inc(gv);
5598 #else
5599             kid->op_sv = SvREFCNT_inc(gv);
5600 #endif
5601             kid->op_private = 0;
5602             kid->op_ppaddr = PL_ppaddr[OP_GV];
5603         }
5604     }
5605     return o;
5606 }
5607
5608 OP *
5609 Perl_ck_ftst(pTHX_ OP *o)
5610 {
5611     I32 type = o->op_type;
5612
5613     if (o->op_flags & OPf_REF) {
5614         /* nothing */
5615     }
5616     else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5617         SVOP *kid = (SVOP*)cUNOPo->op_first;
5618
5619         if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5620             STRLEN n_a;
5621             OP *newop = newGVOP(type, OPf_REF,
5622                 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
5623             op_free(o);
5624             o = newop;
5625         }
5626     }
5627     else {
5628         op_free(o);
5629         if (type == OP_FTTTY)
5630            o =  newGVOP(type, OPf_REF, gv_fetchpv("main::STDIN", TRUE,
5631                                 SVt_PVIO));
5632         else
5633             o = newUNOP(type, 0, newDEFSVOP());
5634     }
5635 #ifdef USE_LOCALE
5636     if (type == OP_FTTEXT || type == OP_FTBINARY) {
5637         o->op_private = 0;
5638         if (PL_hints & HINT_LOCALE)
5639             o->op_private |= OPpLOCALE;
5640     }
5641 #endif
5642     return o;
5643 }
5644
5645 OP *
5646 Perl_ck_fun(pTHX_ OP *o)
5647 {
5648     register OP *kid;
5649     OP **tokid;
5650     OP *sibl;
5651     I32 numargs = 0;
5652     int type = o->op_type;
5653     register I32 oa = PL_opargs[type] >> OASHIFT;
5654
5655     if (o->op_flags & OPf_STACKED) {
5656         if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5657             oa &= ~OA_OPTIONAL;
5658         else
5659             return no_fh_allowed(o);
5660     }
5661
5662     if (o->op_flags & OPf_KIDS) {
5663         STRLEN n_a;
5664         tokid = &cLISTOPo->op_first;
5665         kid = cLISTOPo->op_first;
5666         if (kid->op_type == OP_PUSHMARK ||
5667             (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5668         {
5669             tokid = &kid->op_sibling;
5670             kid = kid->op_sibling;
5671         }
5672         if (!kid && PL_opargs[type] & OA_DEFGV)
5673             *tokid = kid = newDEFSVOP();
5674
5675         while (oa && kid) {
5676             numargs++;
5677             sibl = kid->op_sibling;
5678             switch (oa & 7) {
5679             case OA_SCALAR:
5680                 /* list seen where single (scalar) arg expected? */
5681                 if (numargs == 1 && !(oa >> 4)
5682                     && kid->op_type == OP_LIST && type != OP_SCALAR)
5683                 {
5684                     return too_many_arguments(o,PL_op_desc[type]);
5685                 }
5686                 scalar(kid);
5687                 break;
5688             case OA_LIST:
5689                 if (oa < 16) {
5690                     kid = 0;
5691                     continue;
5692                 }
5693                 else
5694                     list(kid);
5695                 break;
5696             case OA_AVREF:
5697                 if (kid->op_type == OP_CONST &&
5698                     (kid->op_private & OPpCONST_BARE))
5699                 {
5700                     char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5701                     OP *newop = newAVREF(newGVOP(OP_GV, 0,
5702                         gv_fetchpv(name, TRUE, SVt_PVAV) ));
5703                     if (ckWARN(WARN_DEPRECATED))
5704                         Perl_warner(aTHX_ WARN_DEPRECATED,
5705                             "Array @%s missing the @ in argument %"IVdf" of %s()",
5706                             name, (IV)numargs, PL_op_desc[type]);
5707                     op_free(kid);
5708                     kid = newop;
5709                     kid->op_sibling = sibl;
5710                     *tokid = kid;
5711                 }
5712                 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5713                     bad_type(numargs, "array", PL_op_desc[type], kid);
5714                 mod(kid, type);
5715                 break;
5716             case OA_HVREF:
5717                 if (kid->op_type == OP_CONST &&
5718                     (kid->op_private & OPpCONST_BARE))
5719                 {
5720                     char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5721                     OP *newop = newHVREF(newGVOP(OP_GV, 0,
5722                         gv_fetchpv(name, TRUE, SVt_PVHV) ));
5723                     if (ckWARN(WARN_DEPRECATED))
5724                         Perl_warner(aTHX_ WARN_DEPRECATED,
5725                             "Hash %%%s missing the %% in argument %"IVdf" of %s()",
5726                             name, (IV)numargs, PL_op_desc[type]);
5727                     op_free(kid);
5728                     kid = newop;
5729                     kid->op_sibling = sibl;
5730                     *tokid = kid;
5731                 }
5732                 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5733                     bad_type(numargs, "hash", PL_op_desc[type], kid);
5734                 mod(kid, type);
5735                 break;
5736             case OA_CVREF:
5737                 {
5738                     OP *newop = newUNOP(OP_NULL, 0, kid);
5739                     kid->op_sibling = 0;
5740                     linklist(kid);
5741                     newop->op_next = newop;
5742                     kid = newop;
5743                     kid->op_sibling = sibl;
5744                     *tokid = kid;
5745                 }
5746                 break;
5747             case OA_FILEREF:
5748                 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5749                     if (kid->op_type == OP_CONST &&
5750                         (kid->op_private & OPpCONST_BARE))
5751                     {
5752                         OP *newop = newGVOP(OP_GV, 0,
5753                             gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
5754                                         SVt_PVIO) );
5755                         op_free(kid);
5756                         kid = newop;
5757                     }
5758                     else if (kid->op_type == OP_READLINE) {
5759                         /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5760                         bad_type(numargs, "HANDLE", PL_op_desc[o->op_type], kid);
5761                     }
5762                     else {
5763                         I32 flags = OPf_SPECIAL;
5764                         I32 priv = 0;
5765                         PADOFFSET targ = 0;
5766
5767                         /* is this op a FH constructor? */
5768                         if (is_handle_constructor(o,numargs)) {
5769                             char *name = Nullch;
5770                             STRLEN len;
5771
5772                             flags = 0;
5773                             /* Set a flag to tell rv2gv to vivify
5774                              * need to "prove" flag does not mean something
5775                              * else already - NI-S 1999/05/07
5776                              */
5777                             priv = OPpDEREF;
5778                             if (kid->op_type == OP_PADSV) {
5779                                 SV **namep = av_fetch(PL_comppad_name,
5780                                                       kid->op_targ, 4);
5781                                 if (namep && *namep)
5782                                     name = SvPV(*namep, len);
5783                             }
5784                             else if (kid->op_type == OP_RV2SV
5785                                      && kUNOP->op_first->op_type == OP_GV)
5786                             {
5787                                 GV *gv = cGVOPx_gv(kUNOP->op_first);
5788                                 name = GvNAME(gv);
5789                                 len = GvNAMELEN(gv);
5790                             }
5791                             else if (kid->op_type == OP_AELEM
5792                                      || kid->op_type == OP_HELEM)
5793                             {
5794                                 name = "__ANONIO__";
5795                                 len = 10;
5796                                 mod(kid,type);
5797                             }
5798                             if (name) {
5799                                 SV *namesv;
5800                                 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5801                                 namesv = PL_curpad[targ];
5802                                 (void)SvUPGRADE(namesv, SVt_PV);
5803                                 if (*name != '$')
5804                                     sv_setpvn(namesv, "$", 1);
5805                                 sv_catpvn(namesv, name, len);
5806                             }
5807                         }
5808                         kid->op_sibling = 0;
5809                         kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5810                         kid->op_targ = targ;
5811                         kid->op_private |= priv;
5812                     }
5813                     kid->op_sibling = sibl;
5814                     *tokid = kid;
5815                 }
5816                 scalar(kid);
5817                 break;
5818             case OA_SCALARREF:
5819                 mod(scalar(kid), type);
5820                 break;
5821             }
5822             oa >>= 4;
5823             tokid = &kid->op_sibling;
5824             kid = kid->op_sibling;
5825         }
5826         o->op_private |= numargs;
5827         if (kid)
5828             return too_many_arguments(o,PL_op_desc[o->op_type]);
5829         listkids(o);
5830     }
5831     else if (PL_opargs[type] & OA_DEFGV) {
5832         op_free(o);
5833         return newUNOP(type, 0, newDEFSVOP());
5834     }
5835
5836     if (oa) {
5837         while (oa & OA_OPTIONAL)
5838             oa >>= 4;
5839         if (oa && oa != OA_LIST)
5840             return too_few_arguments(o,PL_op_desc[o->op_type]);
5841     }
5842     return o;
5843 }
5844
5845 OP *
5846 Perl_ck_glob(pTHX_ OP *o)
5847 {
5848     GV *gv;
5849
5850     o = ck_fun(o);
5851     if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5852         append_elem(OP_GLOB, o, newDEFSVOP());
5853
5854     if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV)) && GvIMPORTED_CV(gv)))
5855         gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5856
5857 #if !defined(PERL_EXTERNAL_GLOB)
5858     /* XXX this can be tightened up and made more failsafe. */
5859     if (!gv) {
5860         ENTER;
5861         Perl_load_module(aTHX_ 0, newSVpvn("File::Glob", 10), Nullsv,
5862                          /* null-terminated import list */
5863                          newSVpvn(":globally", 9), Nullsv);
5864         gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5865         LEAVE;
5866     }
5867 #endif /* PERL_EXTERNAL_GLOB */
5868
5869     if (gv && GvIMPORTED_CV(gv)) {
5870         append_elem(OP_GLOB, o,
5871                     newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5872         o->op_type = OP_LIST;
5873         o->op_ppaddr = PL_ppaddr[OP_LIST];
5874         cLISTOPo->op_first->op_type = OP_PUSHMARK;
5875         cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5876         o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5877                     append_elem(OP_LIST, o,
5878                                 scalar(newUNOP(OP_RV2CV, 0,
5879                                                newGVOP(OP_GV, 0, gv)))));
5880         o = newUNOP(OP_NULL, 0, ck_subr(o));
5881         o->op_targ = OP_GLOB;           /* hint at what it used to be */
5882         return o;
5883     }
5884     gv = newGVgen("main");
5885     gv_IOadd(gv);
5886     append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5887     scalarkids(o);
5888     return o;
5889 }
5890
5891 OP *
5892 Perl_ck_grep(pTHX_ OP *o)
5893 {
5894     LOGOP *gwop;
5895     OP *kid;
5896     OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5897
5898     o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5899     NewOp(1101, gwop, 1, LOGOP);
5900
5901     if (o->op_flags & OPf_STACKED) {
5902         OP* k;
5903         o = ck_sort(o);
5904         kid = cLISTOPo->op_first->op_sibling;
5905         for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
5906             kid = k;
5907         }
5908         kid->op_next = (OP*)gwop;
5909         o->op_flags &= ~OPf_STACKED;
5910     }
5911     kid = cLISTOPo->op_first->op_sibling;
5912     if (type == OP_MAPWHILE)
5913         list(kid);
5914     else
5915         scalar(kid);
5916     o = ck_fun(o);
5917     if (PL_error_count)
5918         return o;
5919     kid = cLISTOPo->op_first->op_sibling;
5920     if (kid->op_type != OP_NULL)
5921         Perl_croak(aTHX_ "panic: ck_grep");
5922     kid = kUNOP->op_first;
5923
5924     gwop->op_type = type;
5925     gwop->op_ppaddr = PL_ppaddr[type];
5926     gwop->op_first = listkids(o);
5927     gwop->op_flags |= OPf_KIDS;
5928     gwop->op_private = 1;
5929     gwop->op_other = LINKLIST(kid);
5930     gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5931     kid->op_next = (OP*)gwop;
5932
5933     kid = cLISTOPo->op_first->op_sibling;
5934     if (!kid || !kid->op_sibling)
5935         return too_few_arguments(o,PL_op_desc[o->op_type]);
5936     for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5937         mod(kid, OP_GREPSTART);
5938
5939     return (OP*)gwop;
5940 }
5941
5942 OP *
5943 Perl_ck_index(pTHX_ OP *o)
5944 {
5945     if (o->op_flags & OPf_KIDS) {
5946         OP *kid = cLISTOPo->op_first->op_sibling;       /* get past pushmark */
5947         if (kid)
5948             kid = kid->op_sibling;                      /* get past "big" */
5949         if (kid && kid->op_type == OP_CONST)
5950             fbm_compile(((SVOP*)kid)->op_sv, 0);
5951     }
5952     return ck_fun(o);
5953 }
5954
5955 OP *
5956 Perl_ck_lengthconst(pTHX_ OP *o)
5957 {
5958     /* XXX length optimization goes here */
5959     return ck_fun(o);
5960 }
5961
5962 OP *
5963 Perl_ck_lfun(pTHX_ OP *o)
5964 {
5965     OPCODE type = o->op_type;
5966     return modkids(ck_fun(o), type);
5967 }
5968
5969 OP *
5970 Perl_ck_defined(pTHX_ OP *o)            /* 19990527 MJD */
5971 {
5972     if ((o->op_flags & OPf_KIDS) && ckWARN(WARN_DEPRECATED)) {
5973         switch (cUNOPo->op_first->op_type) {
5974         case OP_RV2AV:
5975             /* This is needed for
5976                if (defined %stash::)
5977                to work.   Do not break Tk.
5978                */
5979             break;                      /* Globals via GV can be undef */
5980         case OP_PADAV:
5981         case OP_AASSIGN:                /* Is this a good idea? */
5982             Perl_warner(aTHX_ WARN_DEPRECATED,
5983                         "defined(@array) is deprecated");
5984             Perl_warner(aTHX_ WARN_DEPRECATED,
5985                         "\t(Maybe you should just omit the defined()?)\n");
5986         break;
5987         case OP_RV2HV:
5988             /* This is needed for
5989                if (defined %stash::)
5990                to work.   Do not break Tk.
5991                */
5992             break;                      /* Globals via GV can be undef */
5993         case OP_PADHV:
5994             Perl_warner(aTHX_ WARN_DEPRECATED,
5995                         "defined(%%hash) is deprecated");
5996             Perl_warner(aTHX_ WARN_DEPRECATED,
5997                         "\t(Maybe you should just omit the defined()?)\n");
5998             break;
5999         default:
6000             /* no warning */
6001             break;
6002         }
6003     }
6004     return ck_rfun(o);
6005 }
6006
6007 OP *
6008 Perl_ck_rfun(pTHX_ OP *o)
6009 {
6010     OPCODE type = o->op_type;
6011     return refkids(ck_fun(o), type);
6012 }
6013
6014 OP *
6015 Perl_ck_listiob(pTHX_ OP *o)
6016 {
6017     register OP *kid;
6018
6019     kid = cLISTOPo->op_first;
6020     if (!kid) {
6021         o = force_list(o);
6022         kid = cLISTOPo->op_first;
6023     }
6024     if (kid->op_type == OP_PUSHMARK)
6025         kid = kid->op_sibling;
6026     if (kid && o->op_flags & OPf_STACKED)
6027         kid = kid->op_sibling;
6028     else if (kid && !kid->op_sibling) {         /* print HANDLE; */
6029         if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
6030             o->op_flags |= OPf_STACKED; /* make it a filehandle */
6031             kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
6032             cLISTOPo->op_first->op_sibling = kid;
6033             cLISTOPo->op_last = kid;
6034             kid = kid->op_sibling;
6035         }
6036     }
6037
6038     if (!kid)
6039         append_elem(o->op_type, o, newDEFSVOP());
6040
6041     o = listkids(o);
6042
6043     o->op_private = 0;
6044 #ifdef USE_LOCALE
6045     if (PL_hints & HINT_LOCALE)
6046         o->op_private |= OPpLOCALE;
6047 #endif
6048
6049     return o;
6050 }
6051
6052 OP *
6053 Perl_ck_fun_locale(pTHX_ OP *o)
6054 {
6055     o = ck_fun(o);
6056
6057     o->op_private = 0;
6058 #ifdef USE_LOCALE
6059     if (PL_hints & HINT_LOCALE)
6060         o->op_private |= OPpLOCALE;
6061 #endif
6062
6063     return o;
6064 }
6065
6066 OP *
6067 Perl_ck_sassign(pTHX_ OP *o)
6068 {
6069     OP *kid = cLISTOPo->op_first;
6070     /* has a disposable target? */
6071     if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6072         && !(kid->op_flags & OPf_STACKED)
6073         /* Cannot steal the second time! */
6074         && !(kid->op_private & OPpTARGET_MY))
6075     {
6076         OP *kkid = kid->op_sibling;
6077
6078         /* Can just relocate the target. */
6079         if (kkid && kkid->op_type == OP_PADSV
6080             && !(kkid->op_private & OPpLVAL_INTRO))
6081         {
6082             kid->op_targ = kkid->op_targ;
6083             kkid->op_targ = 0;
6084             /* Now we do not need PADSV and SASSIGN. */
6085             kid->op_sibling = o->op_sibling;    /* NULL */
6086             cLISTOPo->op_first = NULL;
6087             op_free(o);
6088             op_free(kkid);
6089             kid->op_private |= OPpTARGET_MY;    /* Used for context settings */
6090             return kid;
6091         }
6092     }
6093     return o;
6094 }
6095
6096 OP *
6097 Perl_ck_scmp(pTHX_ OP *o)
6098 {
6099     o->op_private = 0;
6100 #ifdef USE_LOCALE
6101     if (PL_hints & HINT_LOCALE)
6102         o->op_private |= OPpLOCALE;
6103 #endif
6104
6105     return o;
6106 }
6107
6108 OP *
6109 Perl_ck_match(pTHX_ OP *o)
6110 {
6111     o->op_private |= OPpRUNTIME;
6112     return o;
6113 }
6114
6115 OP *
6116 Perl_ck_method(pTHX_ OP *o)
6117 {
6118     OP *kid = cUNOPo->op_first;
6119     if (kid->op_type == OP_CONST) {
6120         SV* sv = kSVOP->op_sv;
6121         if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
6122             OP *cmop;
6123             if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6124                 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
6125             }
6126             else {
6127                 kSVOP->op_sv = Nullsv;
6128             }
6129             cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6130             op_free(o);
6131             return cmop;
6132         }
6133     }
6134     return o;
6135 }
6136
6137 OP *
6138 Perl_ck_null(pTHX_ OP *o)
6139 {
6140     return o;
6141 }
6142
6143 OP *
6144 Perl_ck_open(pTHX_ OP *o)
6145 {
6146     HV *table = GvHV(PL_hintgv);
6147     if (table) {
6148         SV **svp;
6149         I32 mode;
6150         svp = hv_fetch(table, "open_IN", 7, FALSE);
6151         if (svp && *svp) {
6152             mode = mode_from_discipline(*svp);
6153             if (mode & O_BINARY)
6154                 o->op_private |= OPpOPEN_IN_RAW;
6155             else if (mode & O_TEXT)
6156                 o->op_private |= OPpOPEN_IN_CRLF;
6157         }
6158
6159         svp = hv_fetch(table, "open_OUT", 8, FALSE);
6160         if (svp && *svp) {
6161             mode = mode_from_discipline(*svp);
6162             if (mode & O_BINARY)
6163                 o->op_private |= OPpOPEN_OUT_RAW;
6164             else if (mode & O_TEXT)
6165                 o->op_private |= OPpOPEN_OUT_CRLF;
6166         }
6167     }
6168     if (o->op_type == OP_BACKTICK)
6169         return o;
6170     return ck_fun(o);
6171 }
6172
6173 OP *
6174 Perl_ck_repeat(pTHX_ OP *o)
6175 {
6176     if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6177         o->op_private |= OPpREPEAT_DOLIST;
6178         cBINOPo->op_first = force_list(cBINOPo->op_first);
6179     }
6180     else
6181         scalar(o);
6182     return o;
6183 }
6184
6185 OP *
6186 Perl_ck_require(pTHX_ OP *o)
6187 {
6188     if (o->op_flags & OPf_KIDS) {       /* Shall we supply missing .pm? */
6189         SVOP *kid = (SVOP*)cUNOPo->op_first;
6190
6191         if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6192             char *s;
6193             for (s = SvPVX(kid->op_sv); *s; s++) {
6194                 if (*s == ':' && s[1] == ':') {
6195                     *s = '/';
6196                     Move(s+2, s+1, strlen(s+2)+1, char);
6197                     --SvCUR(kid->op_sv);
6198                 }
6199             }
6200             if (SvREADONLY(kid->op_sv)) {
6201                 SvREADONLY_off(kid->op_sv);
6202                 sv_catpvn(kid->op_sv, ".pm", 3);
6203                 SvREADONLY_on(kid->op_sv);
6204             }
6205             else
6206                 sv_catpvn(kid->op_sv, ".pm", 3);
6207         }
6208     }
6209     return ck_fun(o);
6210 }
6211
6212 OP *
6213 Perl_ck_return(pTHX_ OP *o)
6214 {
6215     OP *kid;
6216     if (CvLVALUE(PL_compcv)) {
6217         for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
6218             mod(kid, OP_LEAVESUBLV);
6219     }
6220     return o;
6221 }
6222
6223 #if 0
6224 OP *
6225 Perl_ck_retarget(pTHX_ OP *o)
6226 {
6227     Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
6228     /* STUB */
6229     return o;
6230 }
6231 #endif
6232
6233 OP *
6234 Perl_ck_select(pTHX_ OP *o)
6235 {
6236     OP* kid;
6237     if (o->op_flags & OPf_KIDS) {
6238         kid = cLISTOPo->op_first->op_sibling;   /* get past pushmark */
6239         if (kid && kid->op_sibling) {
6240             o->op_type = OP_SSELECT;
6241             o->op_ppaddr = PL_ppaddr[OP_SSELECT];
6242             o = ck_fun(o);
6243             return fold_constants(o);
6244         }
6245     }
6246     o = ck_fun(o);
6247     kid = cLISTOPo->op_first->op_sibling;    /* get past pushmark */
6248     if (kid && kid->op_type == OP_RV2GV)
6249         kid->op_private &= ~HINT_STRICT_REFS;
6250     return o;
6251 }
6252
6253 OP *
6254 Perl_ck_shift(pTHX_ OP *o)
6255 {
6256     I32 type = o->op_type;
6257
6258     if (!(o->op_flags & OPf_KIDS)) {
6259         OP *argop;
6260
6261         op_free(o);
6262 #ifdef USE_THREADS
6263         if (!CvUNIQUE(PL_compcv)) {
6264             argop = newOP(OP_PADAV, OPf_REF);
6265             argop->op_targ = 0;         /* PL_curpad[0] is @_ */
6266         }
6267         else {
6268             argop = newUNOP(OP_RV2AV, 0,
6269                 scalar(newGVOP(OP_GV, 0,
6270                     gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6271         }
6272 #else
6273         argop = newUNOP(OP_RV2AV, 0,
6274             scalar(newGVOP(OP_GV, 0, !CvUNIQUE(PL_compcv) ?
6275                            PL_defgv : gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6276 #endif /* USE_THREADS */
6277         return newUNOP(type, 0, scalar(argop));
6278     }
6279     return scalar(modkids(ck_fun(o), type));
6280 }
6281
6282 OP *
6283 Perl_ck_sort(pTHX_ OP *o)
6284 {
6285     OP *firstkid;
6286     o->op_private = 0;
6287 #ifdef USE_LOCALE
6288     if (PL_hints & HINT_LOCALE)
6289         o->op_private |= OPpLOCALE;
6290 #endif
6291
6292     if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6293         simplify_sort(o);
6294     firstkid = cLISTOPo->op_first->op_sibling;          /* get past pushmark */
6295     if (o->op_flags & OPf_STACKED) {                    /* may have been cleared */
6296         OP *k;
6297         OP *kid = cUNOPx(firstkid)->op_first;           /* get past null */
6298
6299         if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
6300             linklist(kid);
6301             if (kid->op_type == OP_SCOPE) {
6302                 k = kid->op_next;
6303                 kid->op_next = 0;
6304             }
6305             else if (kid->op_type == OP_LEAVE) {
6306                 if (o->op_type == OP_SORT) {
6307                     null(kid);                  /* wipe out leave */
6308                     kid->op_next = kid;
6309
6310                     for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6311                         if (k->op_next == kid)
6312                             k->op_next = 0;
6313                         /* don't descend into loops */
6314                         else if (k->op_type == OP_ENTERLOOP
6315                                  || k->op_type == OP_ENTERITER)
6316                         {
6317                             k = cLOOPx(k)->op_lastop;
6318                         }
6319                     }
6320                 }
6321                 else
6322                     kid->op_next = 0;           /* just disconnect the leave */
6323                 k = kLISTOP->op_first;
6324             }
6325             peep(k);
6326
6327             kid = firstkid;
6328             if (o->op_type == OP_SORT) {
6329                 /* provide scalar context for comparison function/block */
6330                 kid = scalar(kid);
6331                 kid->op_next = kid;
6332             }
6333             else
6334                 kid->op_next = k;
6335             o->op_flags |= OPf_SPECIAL;
6336         }
6337         else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6338             null(firstkid);
6339
6340         firstkid = firstkid->op_sibling;
6341     }
6342
6343     /* provide list context for arguments */
6344     if (o->op_type == OP_SORT)
6345         list(firstkid);
6346
6347     return o;
6348 }
6349
6350 STATIC void
6351 S_simplify_sort(pTHX_ OP *o)
6352 {
6353     register OP *kid = cLISTOPo->op_first->op_sibling;  /* get past pushmark */
6354     OP *k;
6355     int reversed;
6356     GV *gv;
6357     if (!(o->op_flags & OPf_STACKED))
6358         return;
6359     GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
6360     GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
6361     kid = kUNOP->op_first;                              /* get past null */
6362     if (kid->op_type != OP_SCOPE)
6363         return;
6364     kid = kLISTOP->op_last;                             /* get past scope */
6365     switch(kid->op_type) {
6366         case OP_NCMP:
6367         case OP_I_NCMP:
6368         case OP_SCMP:
6369             break;
6370         default:
6371             return;
6372     }
6373     k = kid;                                            /* remember this node*/
6374     if (kBINOP->op_first->op_type != OP_RV2SV)
6375         return;
6376     kid = kBINOP->op_first;                             /* get past cmp */
6377     if (kUNOP->op_first->op_type != OP_GV)
6378         return;
6379     kid = kUNOP->op_first;                              /* get past rv2sv */
6380     gv = kGVOP_gv;
6381     if (GvSTASH(gv) != PL_curstash)
6382         return;
6383     if (strEQ(GvNAME(gv), "a"))
6384         reversed = 0;
6385     else if (strEQ(GvNAME(gv), "b"))
6386         reversed = 1;
6387     else
6388         return;
6389     kid = k;                                            /* back to cmp */
6390     if (kBINOP->op_last->op_type != OP_RV2SV)
6391         return;
6392     kid = kBINOP->op_last;                              /* down to 2nd arg */
6393     if (kUNOP->op_first->op_type != OP_GV)
6394         return;
6395     kid = kUNOP->op_first;                              /* get past rv2sv */
6396     gv = kGVOP_gv;
6397     if (GvSTASH(gv) != PL_curstash
6398         || ( reversed
6399             ? strNE(GvNAME(gv), "a")
6400             : strNE(GvNAME(gv), "b")))
6401         return;
6402     o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6403     if (reversed)
6404         o->op_private |= OPpSORT_REVERSE;
6405     if (k->op_type == OP_NCMP)
6406         o->op_private |= OPpSORT_NUMERIC;
6407     if (k->op_type == OP_I_NCMP)
6408         o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6409     kid = cLISTOPo->op_first->op_sibling;
6410     cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6411     op_free(kid);                                     /* then delete it */
6412 }
6413
6414 OP *
6415 Perl_ck_split(pTHX_ OP *o)
6416 {
6417     register OP *kid;
6418
6419     if (o->op_flags & OPf_STACKED)
6420         return no_fh_allowed(o);
6421
6422     kid = cLISTOPo->op_first;
6423     if (kid->op_type != OP_NULL)
6424         Perl_croak(aTHX_ "panic: ck_split");
6425     kid = kid->op_sibling;
6426     op_free(cLISTOPo->op_first);
6427     cLISTOPo->op_first = kid;
6428     if (!kid) {
6429         cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
6430         cLISTOPo->op_last = kid; /* There was only one element previously */
6431     }
6432
6433     if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6434         OP *sibl = kid->op_sibling;
6435         kid->op_sibling = 0;
6436         kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
6437         if (cLISTOPo->op_first == cLISTOPo->op_last)
6438             cLISTOPo->op_last = kid;
6439         cLISTOPo->op_first = kid;
6440         kid->op_sibling = sibl;
6441     }
6442
6443     kid->op_type = OP_PUSHRE;
6444     kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6445     scalar(kid);
6446
6447     if (!kid->op_sibling)
6448         append_elem(OP_SPLIT, o, newDEFSVOP());
6449
6450     kid = kid->op_sibling;
6451     scalar(kid);
6452
6453     if (!kid->op_sibling)
6454         append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6455
6456     kid = kid->op_sibling;
6457     scalar(kid);
6458
6459     if (kid->op_sibling)
6460         return too_many_arguments(o,PL_op_desc[o->op_type]);
6461
6462     return o;
6463 }
6464
6465 OP *
6466 Perl_ck_join(pTHX_ OP *o)
6467 {
6468     if (ckWARN(WARN_SYNTAX)) {
6469         OP *kid = cLISTOPo->op_first->op_sibling;
6470         if (kid && kid->op_type == OP_MATCH) {
6471             char *pmstr = "STRING";
6472             if (kPMOP->op_pmregexp)
6473                 pmstr = kPMOP->op_pmregexp->precomp;
6474             Perl_warner(aTHX_ WARN_SYNTAX,
6475                         "/%s/ should probably be written as \"%s\"",
6476                         pmstr, pmstr);
6477         }
6478     }
6479     return ck_fun(o);
6480 }
6481
6482 OP *
6483 Perl_ck_subr(pTHX_ OP *o)
6484 {
6485     OP *prev = ((cUNOPo->op_first->op_sibling)
6486              ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6487     OP *o2 = prev->op_sibling;
6488     OP *cvop;
6489     char *proto = 0;
6490     CV *cv = 0;
6491     GV *namegv = 0;
6492     int optional = 0;
6493     I32 arg = 0;
6494     STRLEN n_a;
6495
6496     o->op_private |= OPpENTERSUB_HASTARG;
6497     for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6498     if (cvop->op_type == OP_RV2CV) {
6499         SVOP* tmpop;
6500         o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6501         null(cvop);             /* disable rv2cv */
6502         tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6503         if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6504             GV *gv = cGVOPx_gv(tmpop);
6505             cv = GvCVu(gv);
6506             if (!cv)
6507                 tmpop->op_private |= OPpEARLY_CV;
6508             else if (SvPOK(cv)) {
6509                 namegv = CvANON(cv) ? gv : CvGV(cv);
6510                 proto = SvPV((SV*)cv, n_a);
6511             }
6512         }
6513     }
6514     else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6515         if (o2->op_type == OP_CONST)
6516             o2->op_private &= ~OPpCONST_STRICT;
6517         else if (o2->op_type == OP_LIST) {
6518             OP *o = ((UNOP*)o2)->op_first->op_sibling;
6519             if (o && o->op_type == OP_CONST)
6520                 o->op_private &= ~OPpCONST_STRICT;
6521         }
6522     }
6523     o->op_private |= (PL_hints & HINT_STRICT_REFS);
6524     if (PERLDB_SUB && PL_curstash != PL_debstash)
6525         o->op_private |= OPpENTERSUB_DB;
6526     while (o2 != cvop) {
6527         if (proto) {
6528             switch (*proto) {
6529             case '\0':
6530                 return too_many_arguments(o, gv_ename(namegv));
6531             case ';':
6532                 optional = 1;
6533                 proto++;
6534                 continue;
6535             case '$':
6536                 proto++;
6537                 arg++;
6538                 scalar(o2);
6539                 break;
6540             case '%':
6541             case '@':
6542                 list(o2);
6543                 arg++;
6544                 break;
6545             case '&':
6546                 proto++;
6547                 arg++;
6548                 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6549                     bad_type(arg,
6550                         arg == 1 ? "block or sub {}" : "sub {}",
6551                         gv_ename(namegv), o2);
6552                 break;
6553             case '*':
6554                 /* '*' allows any scalar type, including bareword */
6555                 proto++;
6556                 arg++;
6557                 if (o2->op_type == OP_RV2GV)
6558                     goto wrapref;       /* autoconvert GLOB -> GLOBref */
6559                 else if (o2->op_type == OP_CONST)
6560                     o2->op_private &= ~OPpCONST_STRICT;
6561                 else if (o2->op_type == OP_ENTERSUB) {
6562                     /* accidental subroutine, revert to bareword */
6563                     OP *gvop = ((UNOP*)o2)->op_first;
6564                     if (gvop && gvop->op_type == OP_NULL) {
6565                         gvop = ((UNOP*)gvop)->op_first;
6566                         if (gvop) {
6567                             for (; gvop->op_sibling; gvop = gvop->op_sibling)
6568                                 ;
6569                             if (gvop &&
6570                                 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6571                                 (gvop = ((UNOP*)gvop)->op_first) &&
6572                                 gvop->op_type == OP_GV)
6573                             {
6574                                 GV *gv = cGVOPx_gv(gvop);
6575                                 OP *sibling = o2->op_sibling;
6576                                 SV *n = newSVpvn("",0);
6577                                 op_free(o2);
6578                                 gv_fullname3(n, gv, "");
6579                                 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
6580                                     sv_chop(n, SvPVX(n)+6);
6581                                 o2 = newSVOP(OP_CONST, 0, n);
6582                                 prev->op_sibling = o2;
6583                                 o2->op_sibling = sibling;
6584                             }
6585                         }
6586                     }
6587                 }
6588                 scalar(o2);
6589                 break;
6590             case '\\':
6591                 proto++;
6592                 arg++;
6593                 switch (*proto++) {
6594                 case '*':
6595                     if (o2->op_type != OP_RV2GV)
6596                         bad_type(arg, "symbol", gv_ename(namegv), o2);
6597                     goto wrapref;
6598                 case '&':
6599                     if (o2->op_type != OP_ENTERSUB)
6600                         bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6601                     goto wrapref;
6602                 case '$':
6603                     if (o2->op_type != OP_RV2SV
6604                         && o2->op_type != OP_PADSV
6605                         && o2->op_type != OP_HELEM
6606                         && o2->op_type != OP_AELEM
6607                         && o2->op_type != OP_THREADSV)
6608                     {
6609                         bad_type(arg, "scalar", gv_ename(namegv), o2);
6610                     }
6611                     goto wrapref;
6612                 case '@':
6613                     if (o2->op_type != OP_RV2AV && o2->op_type != OP_PADAV)
6614                         bad_type(arg, "array", gv_ename(namegv), o2);
6615                     goto wrapref;
6616                 case '%':
6617                     if (o2->op_type != OP_RV2HV && o2->op_type != OP_PADHV)
6618                         bad_type(arg, "hash", gv_ename(namegv), o2);
6619                   wrapref:
6620                     {
6621                         OP* kid = o2;
6622                         OP* sib = kid->op_sibling;
6623                         kid->op_sibling = 0;
6624                         o2 = newUNOP(OP_REFGEN, 0, kid);
6625                         o2->op_sibling = sib;
6626                         prev->op_sibling = o2;
6627                     }
6628                     break;
6629                 default: goto oops;
6630                 }
6631                 break;
6632             case ' ':
6633                 proto++;
6634                 continue;
6635             default:
6636               oops:
6637                 Perl_croak(aTHX_ "Malformed prototype for %s: %s",
6638                         gv_ename(namegv), SvPV((SV*)cv, n_a));
6639             }
6640         }
6641         else
6642             list(o2);
6643         mod(o2, OP_ENTERSUB);
6644         prev = o2;
6645         o2 = o2->op_sibling;
6646     }
6647     if (proto && !optional &&
6648           (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6649         return too_few_arguments(o, gv_ename(namegv));
6650     return o;
6651 }
6652
6653 OP *
6654 Perl_ck_svconst(pTHX_ OP *o)
6655 {
6656     SvREADONLY_on(cSVOPo->op_sv);
6657     return o;
6658 }
6659
6660 OP *
6661 Perl_ck_trunc(pTHX_ OP *o)
6662 {
6663     if (o->op_flags & OPf_KIDS) {
6664         SVOP *kid = (SVOP*)cUNOPo->op_first;
6665
6666         if (kid->op_type == OP_NULL)
6667             kid = (SVOP*)kid->op_sibling;
6668         if (kid && kid->op_type == OP_CONST &&
6669             (kid->op_private & OPpCONST_BARE))
6670         {
6671             o->op_flags |= OPf_SPECIAL;
6672             kid->op_private &= ~OPpCONST_STRICT;
6673         }
6674     }
6675     return ck_fun(o);
6676 }
6677
6678 OP *
6679 Perl_ck_substr(pTHX_ OP *o)
6680 {
6681     o = ck_fun(o);
6682     if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6683         OP *kid = cLISTOPo->op_first;
6684
6685         if (kid->op_type == OP_NULL)
6686             kid = kid->op_sibling;
6687         if (kid)
6688             kid->op_flags |= OPf_MOD;
6689
6690     }
6691     return o;
6692 }
6693
6694 /* A peephole optimizer.  We visit the ops in the order they're to execute. */
6695
6696 void
6697 Perl_peep(pTHX_ register OP *o)
6698 {
6699     register OP* oldop = 0;
6700     STRLEN n_a;
6701
6702     if (!o || o->op_seq)
6703         return;
6704     ENTER;
6705     SAVEOP();
6706     SAVEVPTR(PL_curcop);
6707     for (; o; o = o->op_next) {
6708         if (o->op_seq)
6709             break;
6710         if (!PL_op_seqmax)
6711             PL_op_seqmax++;
6712         PL_op = o;
6713         switch (o->op_type) {
6714         case OP_SETSTATE:
6715         case OP_NEXTSTATE:
6716         case OP_DBSTATE:
6717             PL_curcop = ((COP*)o);              /* for warnings */
6718             o->op_seq = PL_op_seqmax++;
6719             break;
6720
6721         case OP_CONST:
6722             if (cSVOPo->op_private & OPpCONST_STRICT)
6723                 no_bareword_allowed(o);
6724 #ifdef USE_ITHREADS
6725             /* Relocate sv to the pad for thread safety.
6726              * Despite being a "constant", the SV is written to,
6727              * for reference counts, sv_upgrade() etc. */
6728             if (cSVOP->op_sv) {
6729                 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6730                 if (SvPADTMP(cSVOPo->op_sv)) {
6731                     /* If op_sv is already a PADTMP then it is being used by
6732                      * some pad, so make a copy. */
6733                     sv_setsv(PL_curpad[ix],cSVOPo->op_sv);
6734                     SvREADONLY_on(PL_curpad[ix]);
6735                     SvREFCNT_dec(cSVOPo->op_sv);
6736                 }
6737                 else {
6738                     SvREFCNT_dec(PL_curpad[ix]);
6739                     SvPADTMP_on(cSVOPo->op_sv);
6740                     PL_curpad[ix] = cSVOPo->op_sv;
6741                     /* XXX I don't know how this isn't readonly already. */
6742                     SvREADONLY_on(PL_curpad[ix]);
6743                 }
6744                 cSVOPo->op_sv = Nullsv;
6745                 o->op_targ = ix;
6746             }
6747 #endif
6748             o->op_seq = PL_op_seqmax++;
6749             break;
6750
6751         case OP_CONCAT:
6752             if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6753                 if (o->op_next->op_private & OPpTARGET_MY) {
6754                     if (o->op_flags & OPf_STACKED) /* chained concats */
6755                         goto ignore_optimization;
6756                     else {
6757                         /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6758                         o->op_targ = o->op_next->op_targ;
6759                         o->op_next->op_targ = 0;
6760                         o->op_private |= OPpTARGET_MY;
6761                     }
6762                 }
6763                 null(o->op_next);
6764             }
6765           ignore_optimization:
6766             o->op_seq = PL_op_seqmax++;
6767             break;
6768         case OP_STUB:
6769             if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6770                 o->op_seq = PL_op_seqmax++;
6771                 break; /* Scalar stub must produce undef.  List stub is noop */
6772             }
6773             goto nothin;
6774         case OP_NULL:
6775             if (o->op_targ == OP_NEXTSTATE
6776                 || o->op_targ == OP_DBSTATE
6777                 || o->op_targ == OP_SETSTATE)
6778             {
6779                 PL_curcop = ((COP*)o);
6780             }
6781             goto nothin;
6782         case OP_SCALAR:
6783         case OP_LINESEQ:
6784         case OP_SCOPE:
6785           nothin:
6786             if (oldop && o->op_next) {
6787                 oldop->op_next = o->op_next;
6788                 continue;
6789             }
6790             o->op_seq = PL_op_seqmax++;
6791             break;
6792
6793         case OP_GV:
6794             if (o->op_next->op_type == OP_RV2SV) {
6795                 if (!(o->op_next->op_private & OPpDEREF)) {
6796                     null(o->op_next);
6797                     o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6798                                                                | OPpOUR_INTRO);
6799                     o->op_next = o->op_next->op_next;
6800                     o->op_type = OP_GVSV;
6801                     o->op_ppaddr = PL_ppaddr[OP_GVSV];
6802                 }
6803             }
6804             else if (o->op_next->op_type == OP_RV2AV) {
6805                 OP* pop = o->op_next->op_next;
6806                 IV i;
6807                 if (pop->op_type == OP_CONST &&
6808                     (PL_op = pop->op_next) &&
6809                     pop->op_next->op_type == OP_AELEM &&
6810                     !(pop->op_next->op_private &
6811                       (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6812                     (i = SvIV(((SVOP*)pop)->op_sv) - PL_compiling.cop_arybase)
6813                                 <= 255 &&
6814                     i >= 0)
6815                 {
6816                     GV *gv;
6817                     null(o->op_next);
6818                     null(pop->op_next);
6819                     null(pop);
6820                     o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6821                     o->op_next = pop->op_next->op_next;
6822                     o->op_type = OP_AELEMFAST;
6823                     o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6824                     o->op_private = (U8)i;
6825                     gv = cGVOPo_gv;
6826                     GvAVn(gv);
6827                 }
6828             }
6829             else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6830                 GV *gv = cGVOPo_gv;
6831                 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
6832                     /* XXX could check prototype here instead of just carping */
6833                     SV *sv = sv_newmortal();
6834                     gv_efullname3(sv, gv, Nullch);
6835                     Perl_warner(aTHX_ WARN_PROTOTYPE,
6836                                 "%s() called too early to check prototype",
6837                                 SvPV_nolen(sv));
6838                 }
6839             }
6840
6841             o->op_seq = PL_op_seqmax++;
6842             break;
6843
6844         case OP_MAPWHILE:
6845         case OP_GREPWHILE:
6846         case OP_AND:
6847         case OP_OR:
6848         case OP_ANDASSIGN:
6849         case OP_ORASSIGN:
6850         case OP_COND_EXPR:
6851         case OP_RANGE:
6852             o->op_seq = PL_op_seqmax++;
6853             while (cLOGOP->op_other->op_type == OP_NULL)
6854                 cLOGOP->op_other = cLOGOP->op_other->op_next;
6855             peep(cLOGOP->op_other);
6856             break;
6857
6858         case OP_ENTERLOOP:
6859             o->op_seq = PL_op_seqmax++;
6860             while (cLOOP->op_redoop->op_type == OP_NULL)
6861                 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6862             peep(cLOOP->op_redoop);
6863             while (cLOOP->op_nextop->op_type == OP_NULL)
6864                 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6865             peep(cLOOP->op_nextop);
6866             while (cLOOP->op_lastop->op_type == OP_NULL)
6867                 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6868             peep(cLOOP->op_lastop);
6869             break;
6870
6871         case OP_QR:
6872         case OP_MATCH:
6873         case OP_SUBST:
6874             o->op_seq = PL_op_seqmax++;
6875             while (cPMOP->op_pmreplstart &&
6876                    cPMOP->op_pmreplstart->op_type == OP_NULL)
6877                 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6878             peep(cPMOP->op_pmreplstart);
6879             break;
6880
6881         case OP_EXEC:
6882             o->op_seq = PL_op_seqmax++;
6883             if (ckWARN(WARN_SYNTAX) && o->op_next
6884                 && o->op_next->op_type == OP_NEXTSTATE) {
6885                 if (o->op_next->op_sibling &&
6886                         o->op_next->op_sibling->op_type != OP_EXIT &&
6887                         o->op_next->op_sibling->op_type != OP_WARN &&
6888                         o->op_next->op_sibling->op_type != OP_DIE) {
6889                     line_t oldline = CopLINE(PL_curcop);
6890
6891                     CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6892                     Perl_warner(aTHX_ WARN_EXEC,
6893                                 "Statement unlikely to be reached");
6894                     Perl_warner(aTHX_ WARN_EXEC,
6895                                 "\t(Maybe you meant system() when you said exec()?)\n");
6896                     CopLINE_set(PL_curcop, oldline);
6897                 }
6898             }
6899             break;
6900
6901         case OP_HELEM: {
6902             UNOP *rop;
6903             SV *lexname;
6904             GV **fields;
6905             SV **svp, **indsvp, *sv;
6906             I32 ind;
6907             char *key = NULL;
6908             STRLEN keylen;
6909
6910             o->op_seq = PL_op_seqmax++;
6911
6912             if (((BINOP*)o)->op_last->op_type != OP_CONST)
6913                 break;
6914
6915             /* Make the CONST have a shared SV */
6916             svp = cSVOPx_svp(((BINOP*)o)->op_last);
6917             if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
6918                 key = SvPV(sv, keylen);
6919                 if (SvUTF8(sv))
6920                   keylen = -keylen;
6921                 lexname = newSVpvn_share(key, keylen, 0);
6922                 SvREFCNT_dec(sv);
6923                 *svp = lexname;
6924             }
6925
6926             if ((o->op_private & (OPpLVAL_INTRO)))
6927                 break;
6928
6929             rop = (UNOP*)((BINOP*)o)->op_first;
6930             if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6931                 break;
6932             lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
6933             if (!SvOBJECT(lexname))
6934                 break;
6935             fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6936             if (!fields || !GvHV(*fields))
6937                 break;
6938             key = SvPV(*svp, keylen);
6939             if (SvUTF8(*svp))
6940                 keylen = -keylen;
6941             indsvp = hv_fetch(GvHV(*fields), key, keylen, FALSE);
6942             if (!indsvp) {
6943                 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" in variable %s of type %s",
6944                       key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
6945             }
6946             ind = SvIV(*indsvp);
6947             if (ind < 1)
6948                 Perl_croak(aTHX_ "Bad index while coercing array into hash");
6949             rop->op_type = OP_RV2AV;
6950             rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
6951             o->op_type = OP_AELEM;
6952             o->op_ppaddr = PL_ppaddr[OP_AELEM];
6953             sv = newSViv(ind);
6954             if (SvREADONLY(*svp))
6955                 SvREADONLY_on(sv);
6956             SvFLAGS(sv) |= (SvFLAGS(*svp)
6957                             & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
6958             SvREFCNT_dec(*svp);
6959             *svp = sv;
6960             break;
6961         }
6962
6963         case OP_HSLICE: {
6964             UNOP *rop;
6965             SV *lexname;
6966             GV **fields;
6967             SV **svp, **indsvp, *sv;
6968             I32 ind;
6969             char *key;
6970             STRLEN keylen;
6971             SVOP *first_key_op, *key_op;
6972
6973             o->op_seq = PL_op_seqmax++;
6974             if ((o->op_private & (OPpLVAL_INTRO))
6975                 /* I bet there's always a pushmark... */
6976                 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
6977                 /* hmmm, no optimization if list contains only one key. */
6978                 break;
6979             rop = (UNOP*)((LISTOP*)o)->op_last;
6980             if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6981                 break;
6982             lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
6983             if (!SvOBJECT(lexname))
6984                 break;
6985             fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6986             if (!fields || !GvHV(*fields))
6987                 break;
6988             /* Again guessing that the pushmark can be jumped over.... */
6989             first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
6990                 ->op_first->op_sibling;
6991             /* Check that the key list contains only constants. */
6992             for (key_op = first_key_op; key_op;
6993                  key_op = (SVOP*)key_op->op_sibling)
6994                 if (key_op->op_type != OP_CONST)
6995                     break;
6996             if (key_op)
6997                 break;
6998             rop->op_type = OP_RV2AV;
6999             rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
7000             o->op_type = OP_ASLICE;
7001             o->op_ppaddr = PL_ppaddr[OP_ASLICE];
7002             for (key_op = first_key_op; key_op;
7003                  key_op = (SVOP*)key_op->op_sibling) {
7004                 svp = cSVOPx_svp(key_op);
7005                 key = SvPV(*svp, keylen);
7006                 if (SvUTF8(*svp))
7007                     keylen = -keylen;
7008                 indsvp = hv_fetch(GvHV(*fields), key, keylen, FALSE);
7009                 if (!indsvp) {
7010                     Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" "
7011                                "in variable %s of type %s",
7012                           key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
7013                 }
7014                 ind = SvIV(*indsvp);
7015                 if (ind < 1)
7016                     Perl_croak(aTHX_ "Bad index while coercing array into hash");
7017                 sv = newSViv(ind);
7018                 if (SvREADONLY(*svp))
7019                     SvREADONLY_on(sv);
7020                 SvFLAGS(sv) |= (SvFLAGS(*svp)
7021                                 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
7022                 SvREFCNT_dec(*svp);
7023                 *svp = sv;
7024             }
7025             break;
7026         }
7027
7028         default:
7029             o->op_seq = PL_op_seqmax++;
7030             break;
7031         }
7032         oldop = o;
7033     }
7034     LEAVE;
7035 }
7036
7037 #include "XSUB.h"
7038
7039 /* Efficient sub that returns a constant scalar value. */
7040 static void
7041 const_sv_xsub(pTHXo_ CV* cv)
7042 {
7043     dXSARGS;
7044     if (items != 0) {
7045 #if 0
7046         Perl_croak(aTHX_ "usage: %s::%s()",
7047                    HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
7048 #endif
7049     }
7050     EXTEND(sp, 1);
7051     ST(0) = (SV*)XSANY.any_ptr;
7052     XSRETURN(1);
7053 }
7054