op.c

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