op.c

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