op.c

   1 /*    op.c
   2  *
   3  *    Copyright (c) 1991-2000, Larry Wall
   4  *
   5  *    You may distribute under the terms of either the GNU General Public
   6  *    License or the Artistic License, as specified in the README file.
   7  *
   8  */
   9
  10 /*
  11  * "You see: Mr. Drogo, he married poor Miss Primula Brandybuck.  She was
  12  * our Mr. Bilbo's first cousin on the mother's side (her mother being the
  13  * youngest of the Old Took's daughters); and Mr. Drogo was his second
  14  * cousin.  So Mr. Frodo is his first *and* second cousin, once removed
  15  * either way, as the saying is, if you follow me."  --the Gaffer
  16  */
  17
  18 #include "EXTERN.h"
  19 #define PERL_IN_OP_C
  20 #include "perl.h"
  21 #include "keywords.h"
  22
  23 /* #define PL_OP_SLAB_ALLOC */
  24
  25 #ifdef PL_OP_SLAB_ALLOC
  26 #define SLAB_SIZE 8192
  27 static char    *PL_OpPtr  = NULL;
  28 static int     PL_OpSpace = 0;
  29 #define NewOp(m,var,c,type) do { if ((PL_OpSpace -= c*sizeof(type)) >= 0)     \
  30                               var =  (type *)(PL_OpPtr -= c*sizeof(type));    \
  31                              else                                             \
  32                               var = (type *) Slab_Alloc(m,c*sizeof(type));    \
  33                            } while (0)
  34
  35 STATIC void *
  36 S_Slab_Alloc(pTHX_ int m, size_t sz)
  37 {
  38  Newz(m,PL_OpPtr,SLAB_SIZE,char);
  39  PL_OpSpace = SLAB_SIZE - sz;
  40  return PL_OpPtr += PL_OpSpace;
  41 }
  42
  43 #else
  44 #define NewOp(m, var, c, type) Newz(m, var, c, type)
  45 #endif
  46 /*
  47  * In the following definition, the ", Nullop" is just to make the compiler
  48  * think the expression is of the right type: croak actually does a Siglongjmp.
  49  */
  50 #define CHECKOP(type,o) \
  51     ((PL_op_mask && PL_op_mask[type])                                   \
  52      ? ( op_free((OP*)o),                                       \
  53          Perl_croak(aTHX_ "%s trapped by operation mask", PL_op_desc[type]),    \
  54          Nullop )                                               \
  55      : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o))
  56
  57 #define PAD_MAX 999999999
  58
  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         loopflags |= OPpLOOP_CONTINUE;
3911     }
3912     if (expr) {
3913         OP *unstack = newOP(OP_UNSTACK, 0);
3914         if (!next)
3915             next = unstack;
3916         cont = append_elem(OP_LINESEQ, cont, unstack);
3917         if ((line_t)whileline != NOLINE) {
3918             PL_copline = whileline;
3919             cont = append_elem(OP_LINESEQ, cont,
3920                                newSTATEOP(0, Nullch, Nullop));
3921         }
3922     }
3923
3924     listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
3925     redo = LINKLIST(listop);
3926
3927     if (expr) {
3928         PL_copline = whileline;
3929         scalar(listop);
3930         o = new_logop(OP_AND, 0, &expr, &listop);
3931         if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
3932             op_free(expr);              /* oops, it's a while (0) */
3933             op_free((OP*)loop);
3934             return Nullop;              /* listop already freed by new_logop */
3935         }
3936         if (listop)
3937             ((LISTOP*)listop)->op_last->op_next = condop =
3938                 (o == listop ? redo : LINKLIST(o));
3939     }
3940     else
3941         o = listop;
3942
3943     if (!loop) {
3944         NewOp(1101,loop,1,LOOP);
3945         loop->op_type = OP_ENTERLOOP;
3946         loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
3947         loop->op_private = 0;
3948         loop->op_next = (OP*)loop;
3949     }
3950
3951     o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
3952
3953     loop->op_redoop = redo;
3954     loop->op_lastop = o;
3955     o->op_private |= loopflags;
3956
3957     if (next)
3958         loop->op_nextop = next;
3959     else
3960         loop->op_nextop = o;
3961
3962     o->op_flags |= flags;
3963     o->op_private |= (flags >> 8);
3964     return o;
3965 }
3966
3967 OP *
3968 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
3969 {
3970     LOOP *loop;
3971     OP *wop;
3972     int padoff = 0;
3973     I32 iterflags = 0;
3974
3975     if (sv) {
3976         if (sv->op_type == OP_RV2SV) {  /* symbol table variable */
3977             sv->op_type = OP_RV2GV;
3978             sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
3979         }
3980         else if (sv->op_type == OP_PADSV) { /* private variable */
3981             padoff = sv->op_targ;
3982             sv->op_targ = 0;
3983             op_free(sv);
3984             sv = Nullop;
3985         }
3986         else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
3987             padoff = sv->op_targ;
3988             sv->op_targ = 0;
3989             iterflags |= OPf_SPECIAL;
3990             op_free(sv);
3991             sv = Nullop;
3992         }
3993         else
3994             Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
3995     }
3996     else {
3997 #ifdef USE_THREADS
3998         padoff = find_threadsv("_");
3999         iterflags |= OPf_SPECIAL;
4000 #else
4001         sv = newGVOP(OP_GV, 0, PL_defgv);
4002 #endif
4003     }
4004     if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4005         expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4006         iterflags |= OPf_STACKED;
4007     }
4008     else if (expr->op_type == OP_NULL &&
4009              (expr->op_flags & OPf_KIDS) &&
4010              ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4011     {
4012         /* Basically turn for($x..$y) into the same as for($x,$y), but we
4013          * set the STACKED flag to indicate that these values are to be
4014          * treated as min/max values by 'pp_iterinit'.
4015          */
4016         UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4017         LOGOP* range = (LOGOP*) flip->op_first;
4018         OP* left  = range->op_first;
4019         OP* right = left->op_sibling;
4020         LISTOP* listop;
4021
4022         range->op_flags &= ~OPf_KIDS;
4023         range->op_first = Nullop;
4024
4025         listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4026         listop->op_first->op_next = range->op_next;
4027         left->op_next = range->op_other;
4028         right->op_next = (OP*)listop;
4029         listop->op_next = listop->op_first;
4030
4031         op_free(expr);
4032         expr = (OP*)(listop);
4033         null(expr);
4034         iterflags |= OPf_STACKED;
4035     }
4036     else {
4037         expr = mod(force_list(expr), OP_GREPSTART);
4038     }
4039
4040
4041     loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4042                                append_elem(OP_LIST, expr, scalar(sv))));
4043     assert(!loop->op_next);
4044 #ifdef PL_OP_SLAB_ALLOC
4045     {
4046         LOOP *tmp;
4047         NewOp(1234,tmp,1,LOOP);
4048         Copy(loop,tmp,1,LOOP);
4049         loop = tmp;
4050     }
4051 #else
4052     Renew(loop, 1, LOOP);
4053 #endif
4054     loop->op_targ = padoff;
4055     wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
4056     PL_copline = forline;
4057     return newSTATEOP(0, label, wop);
4058 }
4059
4060 OP*
4061 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4062 {
4063     OP *o;
4064     STRLEN n_a;
4065
4066     if (type != OP_GOTO || label->op_type == OP_CONST) {
4067         /* "last()" means "last" */
4068         if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4069             o = newOP(type, OPf_SPECIAL);
4070         else {
4071             o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4072                                         ? SvPVx(((SVOP*)label)->op_sv, n_a)
4073                                         : ""));
4074         }
4075         op_free(label);
4076     }
4077     else {
4078         if (label->op_type == OP_ENTERSUB)
4079             label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4080         o = newUNOP(type, OPf_STACKED, label);
4081     }
4082     PL_hints |= HINT_BLOCK_SCOPE;
4083     return o;
4084 }
4085
4086 void
4087 Perl_cv_undef(pTHX_ CV *cv)
4088 {
4089 #ifdef USE_THREADS
4090     if (CvMUTEXP(cv)) {
4091         MUTEX_DESTROY(CvMUTEXP(cv));
4092         Safefree(CvMUTEXP(cv));
4093         CvMUTEXP(cv) = 0;
4094     }
4095 #endif /* USE_THREADS */
4096
4097     if (!CvXSUB(cv) && CvROOT(cv)) {
4098 #ifdef USE_THREADS
4099         if (CvDEPTH(cv) || (CvOWNER(cv) && CvOWNER(cv) != thr))
4100             Perl_croak(aTHX_ "Can't undef active subroutine");
4101 #else
4102         if (CvDEPTH(cv))
4103             Perl_croak(aTHX_ "Can't undef active subroutine");
4104 #endif /* USE_THREADS */
4105         ENTER;
4106
4107         SAVEVPTR(PL_curpad);
4108         PL_curpad = 0;
4109
4110         if (!CvCLONED(cv))
4111             op_free(CvROOT(cv));
4112         CvROOT(cv) = Nullop;
4113         LEAVE;
4114     }
4115     SvPOK_off((SV*)cv);         /* forget prototype */
4116     CvFLAGS(cv) = 0;
4117     SvREFCNT_dec(CvGV(cv));
4118     CvGV(cv) = Nullgv;
4119     SvREFCNT_dec(CvOUTSIDE(cv));
4120     CvOUTSIDE(cv) = Nullcv;
4121     if (CvCONST(cv)) {
4122         SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4123         CvCONST_off(cv);
4124     }
4125     if (CvPADLIST(cv)) {
4126         /* may be during global destruction */
4127         if (SvREFCNT(CvPADLIST(cv))) {
4128             I32 i = AvFILLp(CvPADLIST(cv));
4129             while (i >= 0) {
4130                 SV** svp = av_fetch(CvPADLIST(cv), i--, FALSE);
4131                 SV* sv = svp ? *svp : Nullsv;
4132                 if (!sv)
4133                     continue;
4134                 if (sv == (SV*)PL_comppad_name)
4135                     PL_comppad_name = Nullav;
4136                 else if (sv == (SV*)PL_comppad) {
4137                     PL_comppad = Nullav;
4138                     PL_curpad = Null(SV**);
4139                 }
4140                 SvREFCNT_dec(sv);
4141             }
4142             SvREFCNT_dec((SV*)CvPADLIST(cv));
4143         }
4144         CvPADLIST(cv) = Nullav;
4145     }
4146 }
4147
4148 STATIC void
4149 S_cv_dump(pTHX_ CV *cv)
4150 {
4151 #ifdef DEBUGGING
4152     CV *outside = CvOUTSIDE(cv);
4153     AV* padlist = CvPADLIST(cv);
4154     AV* pad_name;
4155     AV* pad;
4156     SV** pname;
4157     SV** ppad;
4158     I32 ix;
4159
4160     PerlIO_printf(Perl_debug_log,
4161                   "\tCV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
4162                   PTR2UV(cv),
4163                   (CvANON(cv) ? "ANON"
4164                    : (cv == PL_main_cv) ? "MAIN"
4165                    : CvUNIQUE(cv) ? "UNIQUE"
4166                    : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
4167                   PTR2UV(outside),
4168                   (!outside ? "null"
4169                    : CvANON(outside) ? "ANON"
4170                    : (outside == PL_main_cv) ? "MAIN"
4171                    : CvUNIQUE(outside) ? "UNIQUE"
4172                    : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
4173
4174     if (!padlist)
4175         return;
4176
4177     pad_name = (AV*)*av_fetch(padlist, 0, FALSE);
4178     pad = (AV*)*av_fetch(padlist, 1, FALSE);
4179     pname = AvARRAY(pad_name);
4180     ppad = AvARRAY(pad);
4181
4182     for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
4183         if (SvPOK(pname[ix]))
4184             PerlIO_printf(Perl_debug_log,
4185                           "\t%4d. 0x%"UVxf" (%s\"%s\" %"IVdf"-%"IVdf")\n",
4186                           (int)ix, PTR2UV(ppad[ix]),
4187                           SvFAKE(pname[ix]) ? "FAKE " : "",
4188                           SvPVX(pname[ix]),
4189                           (IV)I_32(SvNVX(pname[ix])),
4190                           SvIVX(pname[ix]));
4191     }
4192 #endif /* DEBUGGING */
4193 }
4194
4195 STATIC CV *
4196 S_cv_clone2(pTHX_ CV *proto, CV *outside)
4197 {
4198     AV* av;
4199     I32 ix;
4200     AV* protopadlist = CvPADLIST(proto);
4201     AV* protopad_name = (AV*)*av_fetch(protopadlist, 0, FALSE);
4202     AV* protopad = (AV*)*av_fetch(protopadlist, 1, FALSE);
4203     SV** pname = AvARRAY(protopad_name);
4204     SV** ppad = AvARRAY(protopad);
4205     I32 fname = AvFILLp(protopad_name);
4206     I32 fpad = AvFILLp(protopad);
4207     AV* comppadlist;
4208     CV* cv;
4209
4210     assert(!CvUNIQUE(proto));
4211
4212     ENTER;
4213     SAVECOMPPAD();
4214     SAVESPTR(PL_comppad_name);
4215     SAVESPTR(PL_compcv);
4216
4217     cv = PL_compcv = (CV*)NEWSV(1104,0);
4218     sv_upgrade((SV *)cv, SvTYPE(proto));
4219     CvFLAGS(cv) = CvFLAGS(proto) & ~CVf_CLONE;
4220     CvCLONED_on(cv);
4221
4222 #ifdef USE_THREADS
4223     New(666, CvMUTEXP(cv), 1, perl_mutex);
4224     MUTEX_INIT(CvMUTEXP(cv));
4225     CvOWNER(cv)         = 0;
4226 #endif /* USE_THREADS */
4227     CvFILE(cv)          = CvFILE(proto);
4228     CvGV(cv)            = (GV*)SvREFCNT_inc(CvGV(proto));
4229     CvSTASH(cv)         = CvSTASH(proto);
4230     CvROOT(cv)          = CvROOT(proto);
4231     CvSTART(cv)         = CvSTART(proto);
4232     if (outside)
4233         CvOUTSIDE(cv)   = (CV*)SvREFCNT_inc(outside);
4234
4235     if (SvPOK(proto))
4236         sv_setpvn((SV*)cv, SvPVX(proto), SvCUR(proto));
4237
4238     PL_comppad_name = newAV();
4239     for (ix = fname; ix >= 0; ix--)
4240         av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
4241
4242     PL_comppad = newAV();
4243
4244     comppadlist = newAV();
4245     AvREAL_off(comppadlist);
4246     av_store(comppadlist, 0, (SV*)PL_comppad_name);
4247     av_store(comppadlist, 1, (SV*)PL_comppad);
4248     CvPADLIST(cv) = comppadlist;
4249     av_fill(PL_comppad, AvFILLp(protopad));
4250     PL_curpad = AvARRAY(PL_comppad);
4251
4252     av = newAV();           /* will be @_ */
4253     av_extend(av, 0);
4254     av_store(PL_comppad, 0, (SV*)av);
4255     AvFLAGS(av) = AVf_REIFY;
4256
4257     for (ix = fpad; ix > 0; ix--) {
4258         SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4259         if (namesv && namesv != &PL_sv_undef) {
4260             char *name = SvPVX(namesv);    /* XXX */
4261             if (SvFLAGS(namesv) & SVf_FAKE) {   /* lexical from outside? */
4262                 I32 off = pad_findlex(name, ix, SvIVX(namesv),
4263                                       CvOUTSIDE(cv), cxstack_ix, 0, 0);
4264                 if (!off)
4265                     PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4266                 else if (off != ix)
4267                     Perl_croak(aTHX_ "panic: cv_clone: %s", name);
4268             }
4269             else {                              /* our own lexical */
4270                 SV* sv;
4271                 if (*name == '&') {
4272                     /* anon code -- we'll come back for it */
4273                     sv = SvREFCNT_inc(ppad[ix]);
4274                 }
4275                 else if (*name == '@')
4276                     sv = (SV*)newAV();
4277                 else if (*name == '%')
4278                     sv = (SV*)newHV();
4279                 else
4280                     sv = NEWSV(0,0);
4281                 if (!SvPADBUSY(sv))
4282                     SvPADMY_on(sv);
4283                 PL_curpad[ix] = sv;
4284             }
4285         }
4286         else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
4287             PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4288         }
4289         else {
4290             SV* sv = NEWSV(0,0);
4291             SvPADTMP_on(sv);
4292             PL_curpad[ix] = sv;
4293         }
4294     }
4295
4296     /* Now that vars are all in place, clone nested closures. */
4297
4298     for (ix = fpad; ix > 0; ix--) {
4299         SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4300         if (namesv
4301             && namesv != &PL_sv_undef
4302             && !(SvFLAGS(namesv) & SVf_FAKE)
4303             && *SvPVX(namesv) == '&'
4304             && CvCLONE(ppad[ix]))
4305         {
4306             CV *kid = cv_clone2((CV*)ppad[ix], cv);
4307             SvREFCNT_dec(ppad[ix]);
4308             CvCLONE_on(kid);
4309             SvPADMY_on(kid);
4310             PL_curpad[ix] = (SV*)kid;
4311         }
4312     }
4313
4314 #ifdef DEBUG_CLOSURES
4315     PerlIO_printf(Perl_debug_log, "Cloned inside:\n");
4316     cv_dump(outside);
4317     PerlIO_printf(Perl_debug_log, "  from:\n");
4318     cv_dump(proto);
4319     PerlIO_printf(Perl_debug_log, "   to:\n");
4320     cv_dump(cv);
4321 #endif
4322
4323     LEAVE;
4324
4325     if (CvCONST(cv)) {
4326         SV* const_sv = op_const_sv(CvSTART(cv), cv);
4327         assert(const_sv);
4328         /* constant sub () { $x } closing over $x - see lib/constant.pm */
4329         SvREFCNT_dec(cv);
4330         cv = newCONSTSUB(CvSTASH(proto), 0, const_sv);
4331     }
4332
4333     return cv;
4334 }
4335
4336 CV *
4337 Perl_cv_clone(pTHX_ CV *proto)
4338 {
4339     CV *cv;
4340     LOCK_CRED_MUTEX;                    /* XXX create separate mutex */
4341     cv = cv_clone2(proto, CvOUTSIDE(proto));
4342     UNLOCK_CRED_MUTEX;                  /* XXX create separate mutex */
4343     return cv;
4344 }
4345
4346 void
4347 Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
4348 {
4349     if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4350         SV* msg = sv_newmortal();
4351         SV* name = Nullsv;
4352
4353         if (gv)
4354             gv_efullname3(name = sv_newmortal(), gv, Nullch);
4355         sv_setpv(msg, "Prototype mismatch:");
4356         if (name)
4357             Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4358         if (SvPOK(cv))
4359             Perl_sv_catpvf(aTHX_ msg, " (%s)", SvPVX(cv));
4360         sv_catpv(msg, " vs ");
4361         if (p)
4362             Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4363         else
4364             sv_catpv(msg, "none");
4365         Perl_warner(aTHX_ WARN_PROTOTYPE, "%"SVf, msg);
4366     }
4367 }
4368
4369 static void const_sv_xsub(pTHXo_ CV* cv);
4370
4371 /*
4372 =for apidoc cv_const_sv
4373
4374 If C<cv> is a constant sub eligible for inlining. returns the constant
4375 value returned by the sub.  Otherwise, returns NULL.
4376
4377 Constant subs can be created with C<newCONSTSUB> or as described in
4378 L<perlsub/"Constant Functions">.
4379
4380 =cut
4381 */
4382 SV *
4383 Perl_cv_const_sv(pTHX_ CV *cv)
4384 {
4385     if (!cv || !CvCONST(cv))
4386         return Nullsv;
4387     return (SV*)CvXSUBANY(cv).any_ptr;
4388 }
4389
4390 SV *
4391 Perl_op_const_sv(pTHX_ OP *o, CV *cv)
4392 {
4393     SV *sv = Nullsv;
4394
4395     if (!o)
4396         return Nullsv;
4397
4398     if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4399         o = cLISTOPo->op_first->op_sibling;
4400
4401     for (; o; o = o->op_next) {
4402         OPCODE type = o->op_type;
4403
4404         if (sv && o->op_next == o)
4405             return sv;
4406         if (o->op_next != o) {
4407             if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4408                 continue;
4409             if (type == OP_DBSTATE)
4410                 continue;
4411         }
4412         if (type == OP_LEAVESUB || type == OP_RETURN)
4413             break;
4414         if (sv)
4415             return Nullsv;
4416         if (type == OP_CONST && cSVOPo->op_sv)
4417             sv = cSVOPo->op_sv;
4418         else if ((type == OP_PADSV || type == OP_CONST) && cv) {
4419             AV* padav = (AV*)(AvARRAY(CvPADLIST(cv))[1]);
4420             sv = padav ? AvARRAY(padav)[o->op_targ] : Nullsv;
4421             if (!sv)
4422                 return Nullsv;
4423             if (CvCONST(cv)) {
4424                 /* We get here only from cv_clone2() while creating a closure.
4425                    Copy the const value here instead of in cv_clone2 so that
4426                    SvREADONLY_on doesn't lead to problems when leaving
4427                    scope.
4428                 */
4429                 sv = newSVsv(sv);
4430             }
4431             if (!SvREADONLY(sv) && SvREFCNT(sv) > 1)
4432                 return Nullsv;
4433         }
4434         else
4435             return Nullsv;
4436     }
4437     if (sv)
4438         SvREADONLY_on(sv);
4439     return sv;
4440 }
4441
4442 void
4443 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4444 {
4445     if (o)
4446         SAVEFREEOP(o);
4447     if (proto)
4448         SAVEFREEOP(proto);
4449     if (attrs)
4450         SAVEFREEOP(attrs);
4451     if (block)
4452         SAVEFREEOP(block);
4453     Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4454 }
4455
4456 CV *
4457 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4458 {
4459     return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4460 }
4461
4462 CV *
4463 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4464 {
4465     STRLEN n_a;
4466     char *name;
4467     char *aname;
4468     GV *gv;
4469     char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
4470     register CV *cv=0;
4471     I32 ix;
4472     SV *const_sv;
4473
4474     name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4475     if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4476         SV *sv = sv_newmortal();
4477         Perl_sv_setpvf(aTHX_ sv, "__ANON__[%s:%"IVdf"]",
4478                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4479         aname = SvPVX(sv);
4480     }
4481     else
4482         aname = Nullch;
4483     gv = gv_fetchpv(name ? name : (aname ? aname : "__ANON__"),
4484                     GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4485                     SVt_PVCV);
4486
4487     if (o)
4488         SAVEFREEOP(o);
4489     if (proto)
4490         SAVEFREEOP(proto);
4491     if (attrs)
4492         SAVEFREEOP(attrs);
4493
4494     if (SvTYPE(gv) != SVt_PVGV) {       /* Maybe prototype now, and had at
4495                                            maximum a prototype before. */
4496         if (SvTYPE(gv) > SVt_NULL) {
4497             if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4498                 && ckWARN_d(WARN_PROTOTYPE))
4499             {
4500                 Perl_warner(aTHX_ WARN_PROTOTYPE, "Runaway prototype");
4501             }
4502             cv_ckproto((CV*)gv, NULL, ps);
4503         }
4504         if (ps)
4505             sv_setpv((SV*)gv, ps);
4506         else
4507             sv_setiv((SV*)gv, -1);
4508         SvREFCNT_dec(PL_compcv);
4509         cv = PL_compcv = NULL;
4510         PL_sub_generation++;
4511         goto done;
4512     }
4513
4514     cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4515
4516     if (!block || !ps || *ps || attrs)
4517         const_sv = Nullsv;
4518     else
4519         const_sv = op_const_sv(block, Nullcv);
4520
4521     if (cv) {
4522         bool exists = CvROOT(cv) || CvXSUB(cv);
4523         /* if the subroutine doesn't exist and wasn't pre-declared
4524          * with a prototype, assume it will be AUTOLOADed,
4525          * skipping the prototype check
4526          */
4527         if (exists || SvPOK(cv))
4528             cv_ckproto(cv, gv, ps);
4529         /* already defined (or promised)? */
4530         if (exists || GvASSUMECV(gv)) {
4531             if (!block && !attrs) {
4532                 /* just a "sub foo;" when &foo is already defined */
4533                 SAVEFREESV(PL_compcv);
4534                 goto done;
4535             }
4536             /* ahem, death to those who redefine active sort subs */
4537             if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4538                 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4539             if (block) {
4540                 if (ckWARN(WARN_REDEFINE)
4541                     || (CvCONST(cv)
4542                         && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4543                 {
4544                     line_t oldline = CopLINE(PL_curcop);
4545                     CopLINE_set(PL_curcop, PL_copline);
4546                     Perl_warner(aTHX_ WARN_REDEFINE,
4547                         CvCONST(cv) ? "Constant subroutine %s redefined"
4548                                     : "Subroutine %s redefined", name);
4549                     CopLINE_set(PL_curcop, oldline);
4550                 }
4551                 SvREFCNT_dec(cv);
4552                 cv = Nullcv;
4553             }
4554         }
4555     }
4556     if (const_sv) {
4557         SvREFCNT_inc(const_sv);
4558         if (cv) {
4559             assert(!CvROOT(cv) && !CvCONST(cv));
4560             sv_setpv((SV*)cv, "");  /* prototype is "" */
4561             CvXSUBANY(cv).any_ptr = const_sv;
4562             CvXSUB(cv) = const_sv_xsub;
4563             CvCONST_on(cv);
4564         }
4565         else {
4566             GvCV(gv) = Nullcv;
4567             cv = newCONSTSUB(NULL, name, const_sv);
4568         }
4569         op_free(block);
4570         SvREFCNT_dec(PL_compcv);
4571         PL_compcv = NULL;
4572         PL_sub_generation++;
4573         goto done;
4574     }
4575     if (attrs) {
4576         HV *stash;
4577         SV *rcv;
4578
4579         /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4580          * before we clobber PL_compcv.
4581          */
4582         if (cv && !block) {
4583             rcv = (SV*)cv;
4584             if (CvGV(cv) && GvSTASH(CvGV(cv)) && HvNAME(GvSTASH(CvGV(cv))))
4585                 stash = GvSTASH(CvGV(cv));
4586             else if (CvSTASH(cv) && HvNAME(CvSTASH(cv)))
4587                 stash = CvSTASH(cv);
4588             else
4589                 stash = PL_curstash;
4590         }
4591         else {
4592             /* possibly about to re-define existing subr -- ignore old cv */
4593             rcv = (SV*)PL_compcv;
4594             if (name && GvSTASH(gv) && HvNAME(GvSTASH(gv)))
4595                 stash = GvSTASH(gv);
4596             else
4597                 stash = PL_curstash;
4598         }
4599         apply_attrs(stash, rcv, attrs);
4600     }
4601     if (cv) {                           /* must reuse cv if autoloaded */
4602         if (!block) {
4603             /* got here with just attrs -- work done, so bug out */
4604             SAVEFREESV(PL_compcv);
4605             goto done;
4606         }
4607         cv_undef(cv);
4608         CvFLAGS(cv) = CvFLAGS(PL_compcv);
4609         CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4610         CvOUTSIDE(PL_compcv) = 0;
4611         CvPADLIST(cv) = CvPADLIST(PL_compcv);
4612         CvPADLIST(PL_compcv) = 0;
4613         if (SvREFCNT(PL_compcv) > 1) /* XXX Make closures transit through stub. */
4614             CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc((SV*)cv);
4615         SvREFCNT_dec(PL_compcv);
4616     }
4617     else {
4618         cv = PL_compcv;
4619         if (name) {
4620             GvCV(gv) = cv;
4621             GvCVGEN(gv) = 0;
4622             PL_sub_generation++;
4623         }
4624     }
4625     CvGV(cv) = (GV*)SvREFCNT_inc(gv);
4626     CvFILE(cv) = CopFILE(PL_curcop);
4627     CvSTASH(cv) = PL_curstash;
4628 #ifdef USE_THREADS
4629     CvOWNER(cv) = 0;
4630     if (!CvMUTEXP(cv)) {
4631         New(666, CvMUTEXP(cv), 1, perl_mutex);
4632         MUTEX_INIT(CvMUTEXP(cv));
4633     }
4634 #endif /* USE_THREADS */
4635
4636     if (ps)
4637         sv_setpv((SV*)cv, ps);
4638
4639     if (PL_error_count) {
4640         op_free(block);
4641         block = Nullop;
4642         if (name) {
4643             char *s = strrchr(name, ':');
4644             s = s ? s+1 : name;
4645             if (strEQ(s, "BEGIN")) {
4646                 char *not_safe =
4647                     "BEGIN not safe after errors--compilation aborted";
4648                 if (PL_in_eval & EVAL_KEEPERR)
4649                     Perl_croak(aTHX_ not_safe);
4650                 else {
4651                     /* force display of errors found but not reported */
4652                     sv_catpv(ERRSV, not_safe);
4653                     Perl_croak(aTHX_ "%s", SvPVx(ERRSV, n_a));
4654                 }
4655             }
4656         }
4657     }
4658     if (!block)
4659         goto done;
4660
4661     if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
4662         av_store(PL_comppad_name, AvFILLp(PL_comppad), Nullsv);
4663
4664     if (CvLVALUE(cv)) {
4665         CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0, scalarseq(block));
4666     }
4667     else {
4668         CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4669     }
4670     CvROOT(cv)->op_private |= OPpREFCOUNTED;
4671     OpREFCNT_set(CvROOT(cv), 1);
4672     CvSTART(cv) = LINKLIST(CvROOT(cv));
4673     CvROOT(cv)->op_next = 0;
4674     peep(CvSTART(cv));
4675
4676     /* now that optimizer has done its work, adjust pad values */
4677     if (CvCLONE(cv)) {
4678         SV **namep = AvARRAY(PL_comppad_name);
4679         for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4680             SV *namesv;
4681
4682             if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
4683                 continue;
4684             /*
4685              * The only things that a clonable function needs in its
4686              * pad are references to outer lexicals and anonymous subs.
4687              * The rest are created anew during cloning.
4688              */
4689             if (!((namesv = namep[ix]) != Nullsv &&
4690                   namesv != &PL_sv_undef &&
4691                   (SvFAKE(namesv) ||
4692                    *SvPVX(namesv) == '&')))
4693             {
4694                 SvREFCNT_dec(PL_curpad[ix]);
4695                 PL_curpad[ix] = Nullsv;
4696             }
4697         }
4698         assert(!CvCONST(cv));
4699         if (ps && !*ps && op_const_sv(block, cv))
4700             CvCONST_on(cv);
4701     }
4702     else {
4703         AV *av = newAV();                       /* Will be @_ */
4704         av_extend(av, 0);
4705         av_store(PL_comppad, 0, (SV*)av);
4706         AvFLAGS(av) = AVf_REIFY;
4707
4708         for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4709             if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
4710                 continue;
4711             if (!SvPADMY(PL_curpad[ix]))
4712                 SvPADTMP_on(PL_curpad[ix]);
4713         }
4714     }
4715
4716     if (name || aname) {
4717         char *s;
4718         char *tname = (name ? name : aname);
4719
4720         if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4721             SV *sv = NEWSV(0,0);
4722             SV *tmpstr = sv_newmortal();
4723             GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4724             CV *pcv;
4725             HV *hv;
4726
4727             Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4728                            CopFILE(PL_curcop),
4729                            (long)PL_subline, (long)CopLINE(PL_curcop));
4730             gv_efullname3(tmpstr, gv, Nullch);
4731             hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
4732             hv = GvHVn(db_postponed);
4733             if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
4734                 && (pcv = GvCV(db_postponed)))
4735             {
4736                 dSP;
4737                 PUSHMARK(SP);
4738                 XPUSHs(tmpstr);
4739                 PUTBACK;
4740                 call_sv((SV*)pcv, G_DISCARD);
4741             }
4742         }
4743
4744         if ((s = strrchr(tname,':')))
4745             s++;
4746         else
4747             s = tname;
4748
4749         if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4750             goto done;
4751
4752         if (strEQ(s, "BEGIN")) {
4753             I32 oldscope = PL_scopestack_ix;
4754             ENTER;
4755             SAVECOPFILE(&PL_compiling);
4756             SAVECOPLINE(&PL_compiling);
4757             save_svref(&PL_rs);
4758             sv_setsv(PL_rs, PL_nrs);
4759
4760             if (!PL_beginav)
4761                 PL_beginav = newAV();
4762             DEBUG_x( dump_sub(gv) );
4763             av_push(PL_beginav, (SV*)cv);
4764             GvCV(gv) = 0;               /* cv has been hijacked */
4765             call_list(oldscope, PL_beginav);
4766
4767             PL_curcop = &PL_compiling;
4768             PL_compiling.op_private = PL_hints;
4769             LEAVE;
4770         }
4771         else if (strEQ(s, "END") && !PL_error_count) {
4772             if (!PL_endav)
4773                 PL_endav = newAV();
4774             DEBUG_x( dump_sub(gv) );
4775             av_unshift(PL_endav, 1);
4776             av_store(PL_endav, 0, (SV*)cv);
4777             GvCV(gv) = 0;               /* cv has been hijacked */
4778         }
4779         else if (strEQ(s, "CHECK") && !PL_error_count) {
4780             if (!PL_checkav)
4781                 PL_checkav = newAV();
4782             DEBUG_x( dump_sub(gv) );
4783             if (PL_main_start && ckWARN(WARN_VOID))
4784                 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
4785             av_unshift(PL_checkav, 1);
4786             av_store(PL_checkav, 0, (SV*)cv);
4787             GvCV(gv) = 0;               /* cv has been hijacked */
4788         }
4789         else if (strEQ(s, "INIT") && !PL_error_count) {
4790             if (!PL_initav)
4791                 PL_initav = newAV();
4792             DEBUG_x( dump_sub(gv) );
4793             if (PL_main_start && ckWARN(WARN_VOID))
4794                 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
4795             av_push(PL_initav, (SV*)cv);
4796             GvCV(gv) = 0;               /* cv has been hijacked */
4797         }
4798     }
4799
4800   done:
4801     PL_copline = NOLINE;
4802     LEAVE_SCOPE(floor);
4803     return cv;
4804 }
4805
4806 /* XXX unsafe for threads if eval_owner isn't held */
4807 /*
4808 =for apidoc newCONSTSUB
4809
4810 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4811 eligible for inlining at compile-time.
4812
4813 =cut
4814 */
4815
4816 CV *
4817 Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
4818 {
4819     CV* cv;
4820
4821     ENTER;
4822
4823     SAVECOPLINE(PL_curcop);
4824     CopLINE_set(PL_curcop, PL_copline);
4825
4826     SAVEHINTS();
4827     PL_hints &= ~HINT_BLOCK_SCOPE;
4828
4829     if (stash) {
4830         SAVESPTR(PL_curstash);
4831         SAVECOPSTASH(PL_curcop);
4832         PL_curstash = stash;
4833 #ifdef USE_ITHREADS
4834         CopSTASHPV(PL_curcop) = stash ? HvNAME(stash) : Nullch;
4835 #else
4836         CopSTASH(PL_curcop) = stash;
4837 #endif
4838     }
4839
4840     cv = newXS(name, const_sv_xsub, __FILE__);
4841     CvXSUBANY(cv).any_ptr = sv;
4842     CvCONST_on(cv);
4843     sv_setpv((SV*)cv, "");  /* prototype is "" */
4844
4845     LEAVE;
4846
4847     return cv;
4848 }
4849
4850 /*
4851 =for apidoc U||newXS
4852
4853 Used by C<xsubpp> to hook up XSUBs as Perl subs.
4854
4855 =cut
4856 */
4857
4858 CV *
4859 Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
4860 {
4861     GV *gv = gv_fetchpv(name ? name : "__ANON__", GV_ADDMULTI, SVt_PVCV);
4862     register CV *cv;
4863
4864     if ((cv = (name ? GvCV(gv) : Nullcv))) {
4865         if (GvCVGEN(gv)) {
4866             /* just a cached method */
4867             SvREFCNT_dec(cv);
4868             cv = 0;
4869         }
4870         else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4871             /* already defined (or promised) */
4872             if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
4873                             && HvNAME(GvSTASH(CvGV(cv)))
4874                             && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
4875                 line_t oldline = CopLINE(PL_curcop);
4876                 if (PL_copline != NOLINE)
4877                     CopLINE_set(PL_curcop, PL_copline);
4878                 Perl_warner(aTHX_ WARN_REDEFINE,
4879                             CvCONST(cv) ? "Constant subroutine %s redefined"
4880                                         : "Subroutine %s redefined"
4881                             ,name);
4882                 CopLINE_set(PL_curcop, oldline);
4883             }
4884             SvREFCNT_dec(cv);
4885             cv = 0;
4886         }
4887     }
4888
4889     if (cv)                             /* must reuse cv if autoloaded */
4890         cv_undef(cv);
4891     else {
4892         cv = (CV*)NEWSV(1105,0);
4893         sv_upgrade((SV *)cv, SVt_PVCV);
4894         if (name) {
4895             GvCV(gv) = cv;
4896             GvCVGEN(gv) = 0;
4897             PL_sub_generation++;
4898         }
4899     }
4900     CvGV(cv) = (GV*)SvREFCNT_inc(gv);
4901 #ifdef USE_THREADS
4902     New(666, CvMUTEXP(cv), 1, perl_mutex);
4903     MUTEX_INIT(CvMUTEXP(cv));
4904     CvOWNER(cv) = 0;
4905 #endif /* USE_THREADS */
4906     (void)gv_fetchfile(filename);
4907     CvFILE(cv) = filename;      /* NOTE: not copied, as it is expected to be
4908                                    an external constant string */
4909     CvXSUB(cv) = subaddr;
4910
4911     if (name) {
4912         char *s = strrchr(name,':');
4913         if (s)
4914             s++;
4915         else
4916             s = name;
4917
4918         if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4919             goto done;
4920
4921         if (strEQ(s, "BEGIN")) {
4922             if (!PL_beginav)
4923                 PL_beginav = newAV();
4924             av_push(PL_beginav, (SV*)cv);
4925             GvCV(gv) = 0;               /* cv has been hijacked */
4926         }
4927         else if (strEQ(s, "END")) {
4928             if (!PL_endav)
4929                 PL_endav = newAV();
4930             av_unshift(PL_endav, 1);
4931             av_store(PL_endav, 0, (SV*)cv);
4932             GvCV(gv) = 0;               /* cv has been hijacked */
4933         }
4934         else if (strEQ(s, "CHECK")) {
4935             if (!PL_checkav)
4936                 PL_checkav = newAV();
4937             if (PL_main_start && ckWARN(WARN_VOID))
4938                 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
4939             av_unshift(PL_checkav, 1);
4940             av_store(PL_checkav, 0, (SV*)cv);
4941             GvCV(gv) = 0;               /* cv has been hijacked */
4942         }
4943         else if (strEQ(s, "INIT")) {
4944             if (!PL_initav)
4945                 PL_initav = newAV();
4946             if (PL_main_start && ckWARN(WARN_VOID))
4947                 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
4948             av_push(PL_initav, (SV*)cv);
4949             GvCV(gv) = 0;               /* cv has been hijacked */
4950         }
4951     }
4952     else
4953         CvANON_on(cv);
4954
4955 done:
4956     return cv;
4957 }
4958
4959 void
4960 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
4961 {
4962     register CV *cv;
4963     char *name;
4964     GV *gv;
4965     I32 ix;
4966     STRLEN n_a;
4967
4968     if (o)
4969         name = SvPVx(cSVOPo->op_sv, n_a);
4970     else
4971         name = "STDOUT";
4972     gv = gv_fetchpv(name,TRUE, SVt_PVFM);
4973     GvMULTI_on(gv);
4974     if ((cv = GvFORM(gv))) {
4975         if (ckWARN(WARN_REDEFINE)) {
4976             line_t oldline = CopLINE(PL_curcop);
4977
4978             CopLINE_set(PL_curcop, PL_copline);
4979             Perl_warner(aTHX_ WARN_REDEFINE, "Format %s redefined",name);
4980             CopLINE_set(PL_curcop, oldline);
4981         }
4982         SvREFCNT_dec(cv);
4983     }
4984     cv = PL_compcv;
4985     GvFORM(gv) = cv;
4986     CvGV(cv) = (GV*)SvREFCNT_inc(gv);
4987     CvFILE(cv) = CopFILE(PL_curcop);
4988
4989     for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4990         if (!SvPADMY(PL_curpad[ix]) && !SvIMMORTAL(PL_curpad[ix]))
4991             SvPADTMP_on(PL_curpad[ix]);
4992     }
4993
4994     CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
4995     CvROOT(cv)->op_private |= OPpREFCOUNTED;
4996     OpREFCNT_set(CvROOT(cv), 1);
4997     CvSTART(cv) = LINKLIST(CvROOT(cv));
4998     CvROOT(cv)->op_next = 0;
4999     peep(CvSTART(cv));
5000     op_free(o);
5001     PL_copline = NOLINE;
5002     LEAVE_SCOPE(floor);
5003 }
5004
5005 OP *
5006 Perl_newANONLIST(pTHX_ OP *o)
5007 {
5008     return newUNOP(OP_REFGEN, 0,
5009         mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
5010 }
5011
5012 OP *
5013 Perl_newANONHASH(pTHX_ OP *o)
5014 {
5015     return newUNOP(OP_REFGEN, 0,
5016         mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
5017 }
5018
5019 OP *
5020 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5021 {
5022     return newANONATTRSUB(floor, proto, Nullop, block);
5023 }
5024
5025 OP *
5026 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5027 {
5028     return newUNOP(OP_REFGEN, 0,
5029         newSVOP(OP_ANONCODE, 0,
5030                 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5031 }
5032
5033 OP *
5034 Perl_oopsAV(pTHX_ OP *o)
5035 {
5036     switch (o->op_type) {
5037     case OP_PADSV:
5038         o->op_type = OP_PADAV;
5039         o->op_ppaddr = PL_ppaddr[OP_PADAV];
5040         return ref(o, OP_RV2AV);
5041
5042     case OP_RV2SV:
5043         o->op_type = OP_RV2AV;
5044         o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5045         ref(o, OP_RV2AV);
5046         break;
5047
5048     default:
5049         if (ckWARN_d(WARN_INTERNAL))
5050             Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsAV");
5051         break;
5052     }
5053     return o;
5054 }
5055
5056 OP *
5057 Perl_oopsHV(pTHX_ OP *o)
5058 {
5059     switch (o->op_type) {
5060     case OP_PADSV:
5061     case OP_PADAV:
5062         o->op_type = OP_PADHV;
5063         o->op_ppaddr = PL_ppaddr[OP_PADHV];
5064         return ref(o, OP_RV2HV);
5065
5066     case OP_RV2SV:
5067     case OP_RV2AV:
5068         o->op_type = OP_RV2HV;
5069         o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5070         ref(o, OP_RV2HV);
5071         break;
5072
5073     default:
5074         if (ckWARN_d(WARN_INTERNAL))
5075             Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsHV");
5076         break;
5077     }
5078     return o;
5079 }
5080
5081 OP *
5082 Perl_newAVREF(pTHX_ OP *o)
5083 {
5084     if (o->op_type == OP_PADANY) {
5085         o->op_type = OP_PADAV;
5086         o->op_ppaddr = PL_ppaddr[OP_PADAV];
5087         return o;
5088     }
5089     return newUNOP(OP_RV2AV, 0, scalar(o));
5090 }
5091
5092 OP *
5093 Perl_newGVREF(pTHX_ I32 type, OP *o)
5094 {
5095     if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5096         return newUNOP(OP_NULL, 0, o);
5097     return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5098 }
5099
5100 OP *
5101 Perl_newHVREF(pTHX_ OP *o)
5102 {
5103     if (o->op_type == OP_PADANY) {
5104         o->op_type = OP_PADHV;
5105         o->op_ppaddr = PL_ppaddr[OP_PADHV];
5106         return o;
5107     }
5108     return newUNOP(OP_RV2HV, 0, scalar(o));
5109 }
5110
5111 OP *
5112 Perl_oopsCV(pTHX_ OP *o)
5113 {
5114     Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5115     /* STUB */
5116     return o;
5117 }
5118
5119 OP *
5120 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5121 {
5122     return newUNOP(OP_RV2CV, flags, scalar(o));
5123 }
5124
5125 OP *
5126 Perl_newSVREF(pTHX_ OP *o)
5127 {
5128     if (o->op_type == OP_PADANY) {
5129         o->op_type = OP_PADSV;
5130         o->op_ppaddr = PL_ppaddr[OP_PADSV];
5131         return o;
5132     }
5133     else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5134         o->op_flags |= OPpDONE_SVREF;
5135         return o;
5136     }
5137     return newUNOP(OP_RV2SV, 0, scalar(o));
5138 }
5139
5140 /* Check routines. */
5141
5142 OP *
5143 Perl_ck_anoncode(pTHX_ OP *o)
5144 {
5145     PADOFFSET ix;
5146     SV* name;
5147
5148     name = NEWSV(1106,0);
5149     sv_upgrade(name, SVt_PVNV);
5150     sv_setpvn(name, "&", 1);
5151     SvIVX(name) = -1;
5152     SvNVX(name) = 1;
5153     ix = pad_alloc(o->op_type, SVs_PADMY);
5154     av_store(PL_comppad_name, ix, name);
5155     av_store(PL_comppad, ix, cSVOPo->op_sv);
5156     SvPADMY_on(cSVOPo->op_sv);
5157     cSVOPo->op_sv = Nullsv;
5158     cSVOPo->op_targ = ix;
5159     return o;
5160 }
5161
5162 OP *
5163 Perl_ck_bitop(pTHX_ OP *o)
5164 {
5165     o->op_private = PL_hints;
5166     return o;
5167 }
5168
5169 OP *
5170 Perl_ck_concat(pTHX_ OP *o)
5171 {
5172     if (cUNOPo->op_first->op_type == OP_CONCAT)
5173         o->op_flags |= OPf_STACKED;
5174     return o;
5175 }
5176
5177 OP *
5178 Perl_ck_spair(pTHX_ OP *o)
5179 {
5180     if (o->op_flags & OPf_KIDS) {
5181         OP* newop;
5182         OP* kid;
5183         OPCODE type = o->op_type;
5184         o = modkids(ck_fun(o), type);
5185         kid = cUNOPo->op_first;
5186         newop = kUNOP->op_first->op_sibling;
5187         if (newop &&
5188             (newop->op_sibling ||
5189              !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
5190              newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5191              newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
5192
5193             return o;
5194         }
5195         op_free(kUNOP->op_first);
5196         kUNOP->op_first = newop;
5197     }
5198     o->op_ppaddr = PL_ppaddr[++o->op_type];
5199     return ck_fun(o);
5200 }
5201
5202 OP *
5203 Perl_ck_delete(pTHX_ OP *o)
5204 {
5205     o = ck_fun(o);
5206     o->op_private = 0;
5207     if (o->op_flags & OPf_KIDS) {
5208         OP *kid = cUNOPo->op_first;
5209         switch (kid->op_type) {
5210         case OP_ASLICE:
5211             o->op_flags |= OPf_SPECIAL;
5212             /* FALL THROUGH */
5213         case OP_HSLICE:
5214             o->op_private |= OPpSLICE;
5215             break;
5216         case OP_AELEM:
5217             o->op_flags |= OPf_SPECIAL;
5218             /* FALL THROUGH */
5219         case OP_HELEM:
5220             break;
5221         default:
5222             Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5223                   PL_op_desc[o->op_type]);
5224         }
5225         null(kid);
5226     }
5227     return o;
5228 }
5229
5230 OP *
5231 Perl_ck_eof(pTHX_ OP *o)
5232 {
5233     I32 type = o->op_type;
5234
5235     if (o->op_flags & OPf_KIDS) {
5236         if (cLISTOPo->op_first->op_type == OP_STUB) {
5237             op_free(o);
5238             o = newUNOP(type, OPf_SPECIAL,
5239                 newGVOP(OP_GV, 0, gv_fetchpv("main::ARGV", TRUE, SVt_PVAV)));
5240         }
5241         return ck_fun(o);
5242     }
5243     return o;
5244 }
5245
5246 OP *
5247 Perl_ck_eval(pTHX_ OP *o)
5248 {
5249     PL_hints |= HINT_BLOCK_SCOPE;
5250     if (o->op_flags & OPf_KIDS) {
5251         SVOP *kid = (SVOP*)cUNOPo->op_first;
5252
5253         if (!kid) {
5254             o->op_flags &= ~OPf_KIDS;
5255             null(o);
5256         }
5257         else if (kid->op_type == OP_LINESEQ) {
5258             LOGOP *enter;
5259
5260             kid->op_next = o->op_next;
5261             cUNOPo->op_first = 0;
5262             op_free(o);
5263
5264             NewOp(1101, enter, 1, LOGOP);
5265             enter->op_type = OP_ENTERTRY;
5266             enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5267             enter->op_private = 0;
5268
5269             /* establish postfix order */
5270             enter->op_next = (OP*)enter;
5271
5272             o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5273             o->op_type = OP_LEAVETRY;
5274             o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5275             enter->op_other = o;
5276             return o;
5277         }
5278         else
5279             scalar((OP*)kid);
5280     }
5281     else {
5282         op_free(o);
5283         o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5284     }
5285     o->op_targ = (PADOFFSET)PL_hints;
5286     return o;
5287 }
5288
5289 OP *
5290 Perl_ck_exit(pTHX_ OP *o)
5291 {
5292 #ifdef VMS
5293     HV *table = GvHV(PL_hintgv);
5294     if (table) {
5295        SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
5296        if (svp && *svp && SvTRUE(*svp))
5297            o->op_private |= OPpEXIT_VMSISH;
5298     }
5299 #endif
5300     return ck_fun(o);
5301 }
5302
5303 OP *
5304 Perl_ck_exec(pTHX_ OP *o)
5305 {
5306     OP *kid;
5307     if (o->op_flags & OPf_STACKED) {
5308         o = ck_fun(o);
5309         kid = cUNOPo->op_first->op_sibling;
5310         if (kid->op_type == OP_RV2GV)
5311             null(kid);
5312     }
5313     else
5314         o = listkids(o);
5315     return o;
5316 }
5317
5318 OP *
5319 Perl_ck_exists(pTHX_ OP *o)
5320 {
5321     o = ck_fun(o);
5322     if (o->op_flags & OPf_KIDS) {
5323         OP *kid = cUNOPo->op_first;
5324         if (kid->op_type == OP_ENTERSUB) {
5325             (void) ref(kid, o->op_type);
5326             if (kid->op_type != OP_RV2CV && !PL_error_count)
5327                 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5328                            PL_op_desc[o->op_type]);
5329             o->op_private |= OPpEXISTS_SUB;
5330         }
5331         else if (kid->op_type == OP_AELEM)
5332             o->op_flags |= OPf_SPECIAL;
5333         else if (kid->op_type != OP_HELEM)
5334             Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5335                        PL_op_desc[o->op_type]);
5336         null(kid);
5337     }
5338     return o;
5339 }
5340
5341 #if 0
5342 OP *
5343 Perl_ck_gvconst(pTHX_ register OP *o)
5344 {
5345     o = fold_constants(o);
5346     if (o->op_type == OP_CONST)
5347         o->op_type = OP_GV;
5348     return o;
5349 }
5350 #endif
5351
5352 OP *
5353 Perl_ck_rvconst(pTHX_ register OP *o)
5354 {
5355     SVOP *kid = (SVOP*)cUNOPo->op_first;
5356
5357     o->op_private |= (PL_hints & HINT_STRICT_REFS);
5358     if (kid->op_type == OP_CONST) {
5359         char *name;
5360         int iscv;
5361         GV *gv;
5362         SV *kidsv = kid->op_sv;
5363         STRLEN n_a;
5364
5365         /* Is it a constant from cv_const_sv()? */
5366         if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5367             SV *rsv = SvRV(kidsv);
5368             int svtype = SvTYPE(rsv);
5369             char *badtype = Nullch;
5370
5371             switch (o->op_type) {
5372             case OP_RV2SV:
5373                 if (svtype > SVt_PVMG)
5374                     badtype = "a SCALAR";
5375                 break;
5376             case OP_RV2AV:
5377                 if (svtype != SVt_PVAV)
5378                     badtype = "an ARRAY";
5379                 break;
5380             case OP_RV2HV:
5381                 if (svtype != SVt_PVHV) {
5382                     if (svtype == SVt_PVAV) {   /* pseudohash? */
5383                         SV **ksv = av_fetch((AV*)rsv, 0, FALSE);
5384                         if (ksv && SvROK(*ksv)
5385                             && SvTYPE(SvRV(*ksv)) == SVt_PVHV)
5386                         {
5387                                 break;
5388                         }
5389                     }
5390                     badtype = "a HASH";
5391                 }
5392                 break;
5393             case OP_RV2CV:
5394                 if (svtype != SVt_PVCV)
5395                     badtype = "a CODE";
5396                 break;
5397             }
5398             if (badtype)
5399                 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5400             return o;
5401         }
5402         name = SvPV(kidsv, n_a);
5403         if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5404             char *badthing = Nullch;
5405             switch (o->op_type) {
5406             case OP_RV2SV:
5407                 badthing = "a SCALAR";
5408                 break;
5409             case OP_RV2AV:
5410                 badthing = "an ARRAY";
5411                 break;
5412             case OP_RV2HV:
5413                 badthing = "a HASH";
5414                 break;
5415             }
5416             if (badthing)
5417                 Perl_croak(aTHX_
5418           "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
5419                       name, badthing);
5420         }
5421         /*
5422          * This is a little tricky.  We only want to add the symbol if we
5423          * didn't add it in the lexer.  Otherwise we get duplicate strict
5424          * warnings.  But if we didn't add it in the lexer, we must at
5425          * least pretend like we wanted to add it even if it existed before,
5426          * or we get possible typo warnings.  OPpCONST_ENTERED says
5427          * whether the lexer already added THIS instance of this symbol.
5428          */
5429         iscv = (o->op_type == OP_RV2CV) * 2;
5430         do {
5431             gv = gv_fetchpv(name,
5432                 iscv | !(kid->op_private & OPpCONST_ENTERED),
5433                 iscv
5434                     ? SVt_PVCV
5435                     : o->op_type == OP_RV2SV
5436                         ? SVt_PV
5437                         : o->op_type == OP_RV2AV
5438                             ? SVt_PVAV
5439                             : o->op_type == OP_RV2HV
5440                                 ? SVt_PVHV
5441                                 : SVt_PVGV);
5442         } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5443         if (gv) {
5444             kid->op_type = OP_GV;
5445             SvREFCNT_dec(kid->op_sv);
5446 #ifdef USE_ITHREADS
5447             /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5448             kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5449             SvREFCNT_dec(PL_curpad[kPADOP->op_padix]);
5450             GvIN_PAD_on(gv);
5451             PL_curpad[kPADOP->op_padix] = SvREFCNT_inc(gv);
5452 #else
5453             kid->op_sv = SvREFCNT_inc(gv);
5454 #endif
5455             kid->op_ppaddr = PL_ppaddr[OP_GV];
5456         }
5457     }
5458     return o;
5459 }
5460
5461 OP *
5462 Perl_ck_ftst(pTHX_ OP *o)
5463 {
5464     I32 type = o->op_type;
5465
5466     if (o->op_flags & OPf_REF) {
5467         /* nothing */
5468     }
5469     else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5470         SVOP *kid = (SVOP*)cUNOPo->op_first;
5471
5472         if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5473             STRLEN n_a;
5474             OP *newop = newGVOP(type, OPf_REF,
5475                 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
5476             op_free(o);
5477             o = newop;
5478         }
5479     }
5480     else {
5481         op_free(o);
5482         if (type == OP_FTTTY)
5483            o =  newGVOP(type, OPf_REF, gv_fetchpv("main::STDIN", TRUE,
5484                                 SVt_PVIO));
5485         else
5486             o = newUNOP(type, 0, newDEFSVOP());
5487     }
5488 #ifdef USE_LOCALE
5489     if (type == OP_FTTEXT || type == OP_FTBINARY) {
5490         o->op_private = 0;
5491         if (PL_hints & HINT_LOCALE)
5492             o->op_private |= OPpLOCALE;
5493     }
5494 #endif
5495     return o;
5496 }
5497
5498 OP *
5499 Perl_ck_fun(pTHX_ OP *o)
5500 {
5501     register OP *kid;
5502     OP **tokid;
5503     OP *sibl;
5504     I32 numargs = 0;
5505     int type = o->op_type;
5506     register I32 oa = PL_opargs[type] >> OASHIFT;
5507
5508     if (o->op_flags & OPf_STACKED) {
5509         if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5510             oa &= ~OA_OPTIONAL;
5511         else
5512             return no_fh_allowed(o);
5513     }
5514
5515     if (o->op_flags & OPf_KIDS) {
5516         STRLEN n_a;
5517         tokid = &cLISTOPo->op_first;
5518         kid = cLISTOPo->op_first;
5519         if (kid->op_type == OP_PUSHMARK ||
5520             (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5521         {
5522             tokid = &kid->op_sibling;
5523             kid = kid->op_sibling;
5524         }
5525         if (!kid && PL_opargs[type] & OA_DEFGV)
5526             *tokid = kid = newDEFSVOP();
5527
5528         while (oa && kid) {
5529             numargs++;
5530             sibl = kid->op_sibling;
5531             switch (oa & 7) {
5532             case OA_SCALAR:
5533                 /* list seen where single (scalar) arg expected? */
5534                 if (numargs == 1 && !(oa >> 4)
5535                     && kid->op_type == OP_LIST && type != OP_SCALAR)
5536                 {
5537                     return too_many_arguments(o,PL_op_desc[type]);
5538                 }
5539                 scalar(kid);
5540                 break;
5541             case OA_LIST:
5542                 if (oa < 16) {
5543                     kid = 0;
5544                     continue;
5545                 }
5546                 else
5547                     list(kid);
5548                 break;
5549             case OA_AVREF:
5550                 if (kid->op_type == OP_CONST &&
5551                     (kid->op_private & OPpCONST_BARE))
5552                 {
5553                     char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5554                     OP *newop = newAVREF(newGVOP(OP_GV, 0,
5555                         gv_fetchpv(name, TRUE, SVt_PVAV) ));
5556                     if (ckWARN(WARN_DEPRECATED))
5557                         Perl_warner(aTHX_ WARN_DEPRECATED,
5558                             "Array @%s missing the @ in argument %"IVdf" of %s()",
5559                             name, (IV)numargs, PL_op_desc[type]);
5560                     op_free(kid);
5561                     kid = newop;
5562                     kid->op_sibling = sibl;
5563                     *tokid = kid;
5564                 }
5565                 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5566                     bad_type(numargs, "array", PL_op_desc[type], kid);
5567                 mod(kid, type);
5568                 break;
5569             case OA_HVREF:
5570                 if (kid->op_type == OP_CONST &&
5571                     (kid->op_private & OPpCONST_BARE))
5572                 {
5573                     char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5574                     OP *newop = newHVREF(newGVOP(OP_GV, 0,
5575                         gv_fetchpv(name, TRUE, SVt_PVHV) ));
5576                     if (ckWARN(WARN_DEPRECATED))
5577                         Perl_warner(aTHX_ WARN_DEPRECATED,
5578                             "Hash %%%s missing the %% in argument %"IVdf" of %s()",
5579                             name, (IV)numargs, PL_op_desc[type]);
5580                     op_free(kid);
5581                     kid = newop;
5582                     kid->op_sibling = sibl;
5583                     *tokid = kid;
5584                 }
5585                 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5586                     bad_type(numargs, "hash", PL_op_desc[type], kid);
5587                 mod(kid, type);
5588                 break;
5589             case OA_CVREF:
5590                 {
5591                     OP *newop = newUNOP(OP_NULL, 0, kid);
5592                     kid->op_sibling = 0;
5593                     linklist(kid);
5594                     newop->op_next = newop;
5595                     kid = newop;
5596                     kid->op_sibling = sibl;
5597                     *tokid = kid;
5598                 }
5599                 break;
5600             case OA_FILEREF:
5601                 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5602                     if (kid->op_type == OP_CONST &&
5603                         (kid->op_private & OPpCONST_BARE))
5604                     {
5605                         OP *newop = newGVOP(OP_GV, 0,
5606                             gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
5607                                         SVt_PVIO) );
5608                         op_free(kid);
5609                         kid = newop;
5610                     }
5611                     else if (kid->op_type == OP_READLINE) {
5612                         /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5613                         bad_type(numargs, "HANDLE", PL_op_desc[o->op_type], kid);
5614                     }
5615                     else {
5616                         I32 flags = OPf_SPECIAL;
5617                         I32 priv = 0;
5618                         PADOFFSET targ = 0;
5619
5620                         /* is this op a FH constructor? */
5621                         if (is_handle_constructor(o,numargs)) {
5622                             char *name = Nullch;
5623                             STRLEN len;
5624
5625                             flags = 0;
5626                             /* Set a flag to tell rv2gv to vivify
5627                              * need to "prove" flag does not mean something
5628                              * else already - NI-S 1999/05/07
5629                              */
5630                             priv = OPpDEREF;
5631                             if (kid->op_type == OP_PADSV) {
5632                                 SV **namep = av_fetch(PL_comppad_name,
5633                                                       kid->op_targ, 4);
5634                                 if (namep && *namep)
5635                                     name = SvPV(*namep, len);
5636                             }
5637                             else if (kid->op_type == OP_RV2SV
5638                                      && kUNOP->op_first->op_type == OP_GV)
5639                             {
5640                                 GV *gv = cGVOPx_gv(kUNOP->op_first);
5641                                 name = GvNAME(gv);
5642                                 len = GvNAMELEN(gv);
5643                             }
5644                             else if (kid->op_type == OP_AELEM
5645                                      || kid->op_type == OP_HELEM)
5646                             {
5647                                 name = "__ANONIO__";
5648                                 len = 10;
5649                                 mod(kid,type);
5650                             }
5651                             if (name) {
5652                                 SV *namesv;
5653                                 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5654                                 namesv = PL_curpad[targ];
5655                                 (void)SvUPGRADE(namesv, SVt_PV);
5656                                 if (*name != '$')
5657                                     sv_setpvn(namesv, "$", 1);
5658                                 sv_catpvn(namesv, name, len);
5659                             }
5660                         }
5661                         kid->op_sibling = 0;
5662                         kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5663                         kid->op_targ = targ;
5664                         kid->op_private |= priv;
5665                     }
5666                     kid->op_sibling = sibl;
5667                     *tokid = kid;
5668                 }
5669                 scalar(kid);
5670                 break;
5671             case OA_SCALARREF:
5672                 mod(scalar(kid), type);
5673                 break;
5674             }
5675             oa >>= 4;
5676             tokid = &kid->op_sibling;
5677             kid = kid->op_sibling;
5678         }
5679         o->op_private |= numargs;
5680         if (kid)
5681             return too_many_arguments(o,PL_op_desc[o->op_type]);
5682         listkids(o);
5683     }
5684     else if (PL_opargs[type] & OA_DEFGV) {
5685         op_free(o);
5686         return newUNOP(type, 0, newDEFSVOP());
5687     }
5688
5689     if (oa) {
5690         while (oa & OA_OPTIONAL)
5691             oa >>= 4;
5692         if (oa && oa != OA_LIST)
5693             return too_few_arguments(o,PL_op_desc[o->op_type]);
5694     }
5695     return o;
5696 }
5697
5698 OP *
5699 Perl_ck_glob(pTHX_ OP *o)
5700 {
5701     GV *gv;
5702
5703     o = ck_fun(o);
5704     if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5705         append_elem(OP_GLOB, o, newDEFSVOP());
5706
5707     if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV)) && GvIMPORTED_CV(gv)))
5708         gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5709
5710 #if !defined(PERL_EXTERNAL_GLOB)
5711     /* XXX this can be tightened up and made more failsafe. */
5712     if (!gv) {
5713         ENTER;
5714         Perl_load_module(aTHX_ 0, newSVpvn("File::Glob", 10), Nullsv,
5715                          /* null-terminated import list */
5716                          newSVpvn(":globally", 9), Nullsv);
5717         gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5718         LEAVE;
5719     }
5720 #endif /* PERL_EXTERNAL_GLOB */
5721
5722     if (gv && GvIMPORTED_CV(gv)) {
5723         append_elem(OP_GLOB, o,
5724                     newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5725         o->op_type = OP_LIST;
5726         o->op_ppaddr = PL_ppaddr[OP_LIST];
5727         cLISTOPo->op_first->op_type = OP_PUSHMARK;
5728         cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5729         o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5730                     append_elem(OP_LIST, o,
5731                                 scalar(newUNOP(OP_RV2CV, 0,
5732                                                newGVOP(OP_GV, 0, gv)))));
5733         o = newUNOP(OP_NULL, 0, ck_subr(o));
5734         o->op_targ = OP_GLOB;           /* hint at what it used to be */
5735         return o;
5736     }
5737     gv = newGVgen("main");
5738     gv_IOadd(gv);
5739     append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5740     scalarkids(o);
5741     return o;
5742 }
5743
5744 OP *
5745 Perl_ck_grep(pTHX_ OP *o)
5746 {
5747     LOGOP *gwop;
5748     OP *kid;
5749     OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5750
5751     o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5752     NewOp(1101, gwop, 1, LOGOP);
5753
5754     if (o->op_flags & OPf_STACKED) {
5755         OP* k;
5756         o = ck_sort(o);
5757         kid = cLISTOPo->op_first->op_sibling;
5758         for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
5759             kid = k;
5760         }
5761         kid->op_next = (OP*)gwop;
5762         o->op_flags &= ~OPf_STACKED;
5763     }
5764     kid = cLISTOPo->op_first->op_sibling;
5765     if (type == OP_MAPWHILE)
5766         list(kid);
5767     else
5768         scalar(kid);
5769     o = ck_fun(o);
5770     if (PL_error_count)
5771         return o;
5772     kid = cLISTOPo->op_first->op_sibling;
5773     if (kid->op_type != OP_NULL)
5774         Perl_croak(aTHX_ "panic: ck_grep");
5775     kid = kUNOP->op_first;
5776
5777     gwop->op_type = type;
5778     gwop->op_ppaddr = PL_ppaddr[type];
5779     gwop->op_first = listkids(o);
5780     gwop->op_flags |= OPf_KIDS;
5781     gwop->op_private = 1;
5782     gwop->op_other = LINKLIST(kid);
5783     gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5784     kid->op_next = (OP*)gwop;
5785
5786     kid = cLISTOPo->op_first->op_sibling;
5787     if (!kid || !kid->op_sibling)
5788         return too_few_arguments(o,PL_op_desc[o->op_type]);
5789     for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5790         mod(kid, OP_GREPSTART);
5791
5792     return (OP*)gwop;
5793 }
5794
5795 OP *
5796 Perl_ck_index(pTHX_ OP *o)
5797 {
5798     if (o->op_flags & OPf_KIDS) {
5799         OP *kid = cLISTOPo->op_first->op_sibling;       /* get past pushmark */
5800         if (kid)
5801             kid = kid->op_sibling;                      /* get past "big" */
5802         if (kid && kid->op_type == OP_CONST)
5803             fbm_compile(((SVOP*)kid)->op_sv, 0);
5804     }
5805     return ck_fun(o);
5806 }
5807
5808 OP *
5809 Perl_ck_lengthconst(pTHX_ OP *o)
5810 {
5811     /* XXX length optimization goes here */
5812     return ck_fun(o);
5813 }
5814
5815 OP *
5816 Perl_ck_lfun(pTHX_ OP *o)
5817 {
5818     OPCODE type = o->op_type;
5819     return modkids(ck_fun(o), type);
5820 }
5821
5822 OP *
5823 Perl_ck_defined(pTHX_ OP *o)            /* 19990527 MJD */
5824 {
5825     if ((o->op_flags & OPf_KIDS) && ckWARN(WARN_DEPRECATED)) {
5826         switch (cUNOPo->op_first->op_type) {
5827         case OP_RV2AV:
5828             /* This is needed for
5829                if (defined %stash::)
5830                to work.   Do not break Tk.
5831                */
5832             break;                      /* Globals via GV can be undef */
5833         case OP_PADAV:
5834         case OP_AASSIGN:                /* Is this a good idea? */
5835             Perl_warner(aTHX_ WARN_DEPRECATED,
5836                         "defined(@array) is deprecated");
5837             Perl_warner(aTHX_ WARN_DEPRECATED,
5838                         "\t(Maybe you should just omit the defined()?)\n");
5839         break;
5840         case OP_RV2HV:
5841             /* This is needed for
5842                if (defined %stash::)
5843                to work.   Do not break Tk.
5844                */
5845             break;                      /* Globals via GV can be undef */
5846         case OP_PADHV:
5847             Perl_warner(aTHX_ WARN_DEPRECATED,
5848                         "defined(%%hash) is deprecated");
5849             Perl_warner(aTHX_ WARN_DEPRECATED,
5850                         "\t(Maybe you should just omit the defined()?)\n");
5851             break;
5852         default:
5853             /* no warning */
5854             break;
5855         }
5856     }
5857     return ck_rfun(o);
5858 }
5859
5860 OP *
5861 Perl_ck_rfun(pTHX_ OP *o)
5862 {
5863     OPCODE type = o->op_type;
5864     return refkids(ck_fun(o), type);
5865 }
5866
5867 OP *
5868 Perl_ck_listiob(pTHX_ OP *o)
5869 {
5870     register OP *kid;
5871
5872     kid = cLISTOPo->op_first;
5873     if (!kid) {
5874         o = force_list(o);
5875         kid = cLISTOPo->op_first;
5876     }
5877     if (kid->op_type == OP_PUSHMARK)
5878         kid = kid->op_sibling;
5879     if (kid && o->op_flags & OPf_STACKED)
5880         kid = kid->op_sibling;
5881     else if (kid && !kid->op_sibling) {         /* print HANDLE; */
5882         if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
5883             o->op_flags |= OPf_STACKED; /* make it a filehandle */
5884             kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
5885             cLISTOPo->op_first->op_sibling = kid;
5886             cLISTOPo->op_last = kid;
5887             kid = kid->op_sibling;
5888         }
5889     }
5890
5891     if (!kid)
5892         append_elem(o->op_type, o, newDEFSVOP());
5893
5894     o = listkids(o);
5895
5896     o->op_private = 0;
5897 #ifdef USE_LOCALE
5898     if (PL_hints & HINT_LOCALE)
5899         o->op_private |= OPpLOCALE;
5900 #endif
5901
5902     return o;
5903 }
5904
5905 OP *
5906 Perl_ck_fun_locale(pTHX_ OP *o)
5907 {
5908     o = ck_fun(o);
5909
5910     o->op_private = 0;
5911 #ifdef USE_LOCALE
5912     if (PL_hints & HINT_LOCALE)
5913         o->op_private |= OPpLOCALE;
5914 #endif
5915
5916     return o;
5917 }
5918
5919 OP *
5920 Perl_ck_sassign(pTHX_ OP *o)
5921 {
5922     OP *kid = cLISTOPo->op_first;
5923     /* has a disposable target? */
5924     if ((PL_opargs[kid->op_type] & OA_TARGLEX)
5925         && !(kid->op_flags & OPf_STACKED)
5926         /* Cannot steal the second time! */
5927         && !(kid->op_private & OPpTARGET_MY))
5928     {
5929         OP *kkid = kid->op_sibling;
5930
5931         /* Can just relocate the target. */
5932         if (kkid && kkid->op_type == OP_PADSV
5933             && !(kkid->op_private & OPpLVAL_INTRO))
5934         {
5935             kid->op_targ = kkid->op_targ;
5936             kkid->op_targ = 0;
5937             /* Now we do not need PADSV and SASSIGN. */
5938             kid->op_sibling = o->op_sibling;    /* NULL */
5939             cLISTOPo->op_first = NULL;
5940             op_free(o);
5941             op_free(kkid);
5942             kid->op_private |= OPpTARGET_MY;    /* Used for context settings */
5943             return kid;
5944         }
5945     }
5946     return o;
5947 }
5948
5949 OP *
5950 Perl_ck_scmp(pTHX_ OP *o)
5951 {
5952     o->op_private = 0;
5953 #ifdef USE_LOCALE
5954     if (PL_hints & HINT_LOCALE)
5955         o->op_private |= OPpLOCALE;
5956 #endif
5957
5958     return o;
5959 }
5960
5961 OP *
5962 Perl_ck_match(pTHX_ OP *o)
5963 {
5964     o->op_private |= OPpRUNTIME;
5965     return o;
5966 }
5967
5968 OP *
5969 Perl_ck_method(pTHX_ OP *o)
5970 {
5971     OP *kid = cUNOPo->op_first;
5972     if (kid->op_type == OP_CONST) {
5973         SV* sv = kSVOP->op_sv;
5974         if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
5975             OP *cmop;
5976             if (!SvREADONLY(sv) || !SvFAKE(sv)) {
5977                 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
5978             }
5979             else {
5980                 kSVOP->op_sv = Nullsv;
5981             }
5982             cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
5983             op_free(o);
5984             return cmop;
5985         }
5986     }
5987     return o;
5988 }
5989
5990 OP *
5991 Perl_ck_null(pTHX_ OP *o)
5992 {
5993     return o;
5994 }
5995
5996 OP *
5997 Perl_ck_open(pTHX_ OP *o)
5998 {
5999     HV *table = GvHV(PL_hintgv);
6000     if (table) {
6001         SV **svp;
6002         I32 mode;
6003         svp = hv_fetch(table, "open_IN", 7, FALSE);
6004         if (svp && *svp) {
6005             mode = mode_from_discipline(*svp);
6006             if (mode & O_BINARY)
6007                 o->op_private |= OPpOPEN_IN_RAW;
6008             else if (mode & O_TEXT)
6009                 o->op_private |= OPpOPEN_IN_CRLF;
6010         }
6011
6012         svp = hv_fetch(table, "open_OUT", 8, FALSE);
6013         if (svp && *svp) {
6014             mode = mode_from_discipline(*svp);
6015             if (mode & O_BINARY)
6016                 o->op_private |= OPpOPEN_OUT_RAW;
6017             else if (mode & O_TEXT)
6018                 o->op_private |= OPpOPEN_OUT_CRLF;
6019         }
6020     }
6021     if (o->op_type == OP_BACKTICK)
6022         return o;
6023     return ck_fun(o);
6024 }
6025
6026 OP *
6027 Perl_ck_repeat(pTHX_ OP *o)
6028 {
6029     if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6030         o->op_private |= OPpREPEAT_DOLIST;
6031         cBINOPo->op_first = force_list(cBINOPo->op_first);
6032     }
6033     else
6034         scalar(o);
6035     return o;
6036 }
6037
6038 OP *
6039 Perl_ck_require(pTHX_ OP *o)
6040 {
6041     if (o->op_flags & OPf_KIDS) {       /* Shall we supply missing .pm? */
6042         SVOP *kid = (SVOP*)cUNOPo->op_first;
6043
6044         if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6045             char *s;
6046             for (s = SvPVX(kid->op_sv); *s; s++) {
6047                 if (*s == ':' && s[1] == ':') {
6048                     *s = '/';
6049                     Move(s+2, s+1, strlen(s+2)+1, char);
6050                     --SvCUR(kid->op_sv);
6051                 }
6052             }
6053             if (SvREADONLY(kid->op_sv)) {
6054                 SvREADONLY_off(kid->op_sv);
6055                 sv_catpvn(kid->op_sv, ".pm", 3);
6056                 SvREADONLY_on(kid->op_sv);
6057             }
6058             else
6059                 sv_catpvn(kid->op_sv, ".pm", 3);
6060         }
6061     }
6062     return ck_fun(o);
6063 }
6064
6065 #if 0
6066 OP *
6067 Perl_ck_retarget(pTHX_ OP *o)
6068 {
6069     Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
6070     /* STUB */
6071     return o;
6072 }
6073 #endif
6074
6075 OP *
6076 Perl_ck_select(pTHX_ OP *o)
6077 {
6078     OP* kid;
6079     if (o->op_flags & OPf_KIDS) {
6080         kid = cLISTOPo->op_first->op_sibling;   /* get past pushmark */
6081         if (kid && kid->op_sibling) {
6082             o->op_type = OP_SSELECT;
6083             o->op_ppaddr = PL_ppaddr[OP_SSELECT];
6084             o = ck_fun(o);
6085             return fold_constants(o);
6086         }
6087     }
6088     o = ck_fun(o);
6089     kid = cLISTOPo->op_first->op_sibling;    /* get past pushmark */
6090     if (kid && kid->op_type == OP_RV2GV)
6091         kid->op_private &= ~HINT_STRICT_REFS;
6092     return o;
6093 }
6094
6095 OP *
6096 Perl_ck_shift(pTHX_ OP *o)
6097 {
6098     I32 type = o->op_type;
6099
6100     if (!(o->op_flags & OPf_KIDS)) {
6101         OP *argop;
6102
6103         op_free(o);
6104 #ifdef USE_THREADS
6105         if (!CvUNIQUE(PL_compcv)) {
6106             argop = newOP(OP_PADAV, OPf_REF);
6107             argop->op_targ = 0;         /* PL_curpad[0] is @_ */
6108         }
6109         else {
6110             argop = newUNOP(OP_RV2AV, 0,
6111                 scalar(newGVOP(OP_GV, 0,
6112                     gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6113         }
6114 #else
6115         argop = newUNOP(OP_RV2AV, 0,
6116             scalar(newGVOP(OP_GV, 0, !CvUNIQUE(PL_compcv) ?
6117                            PL_defgv : gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6118 #endif /* USE_THREADS */
6119         return newUNOP(type, 0, scalar(argop));
6120     }
6121     return scalar(modkids(ck_fun(o), type));
6122 }
6123
6124 OP *
6125 Perl_ck_sort(pTHX_ OP *o)
6126 {
6127     OP *firstkid;
6128     o->op_private = 0;
6129 #ifdef USE_LOCALE
6130     if (PL_hints & HINT_LOCALE)
6131         o->op_private |= OPpLOCALE;
6132 #endif
6133
6134     if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6135         simplify_sort(o);
6136     firstkid = cLISTOPo->op_first->op_sibling;          /* get past pushmark */
6137     if (o->op_flags & OPf_STACKED) {                    /* may have been cleared */
6138         OP *k;
6139         OP *kid = cUNOPx(firstkid)->op_first;           /* get past null */
6140
6141         if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
6142             linklist(kid);
6143             if (kid->op_type == OP_SCOPE) {
6144                 k = kid->op_next;
6145                 kid->op_next = 0;
6146             }
6147             else if (kid->op_type == OP_LEAVE) {
6148                 if (o->op_type == OP_SORT) {
6149                     null(kid);                  /* wipe out leave */
6150                     kid->op_next = kid;
6151
6152                     for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6153                         if (k->op_next == kid)
6154                             k->op_next = 0;
6155                         /* don't descend into loops */
6156                         else if (k->op_type == OP_ENTERLOOP
6157                                  || k->op_type == OP_ENTERITER)
6158                         {
6159                             k = cLOOPx(k)->op_lastop;
6160                         }
6161                     }
6162                 }
6163                 else
6164                     kid->op_next = 0;           /* just disconnect the leave */
6165                 k = kLISTOP->op_first;
6166             }
6167             peep(k);
6168
6169             kid = firstkid;
6170             if (o->op_type == OP_SORT) {
6171                 /* provide scalar context for comparison function/block */
6172                 kid = scalar(kid);
6173                 kid->op_next = kid;
6174             }
6175             else
6176                 kid->op_next = k;
6177             o->op_flags |= OPf_SPECIAL;
6178         }
6179         else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6180             null(firstkid);
6181
6182         firstkid = firstkid->op_sibling;
6183     }
6184
6185     /* provide list context for arguments */
6186     if (o->op_type == OP_SORT)
6187         list(firstkid);
6188
6189     return o;
6190 }
6191
6192 STATIC void
6193 S_simplify_sort(pTHX_ OP *o)
6194 {
6195     register OP *kid = cLISTOPo->op_first->op_sibling;  /* get past pushmark */
6196     OP *k;
6197     int reversed;
6198     GV *gv;
6199     if (!(o->op_flags & OPf_STACKED))
6200         return;
6201     GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
6202     GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
6203     kid = kUNOP->op_first;                              /* get past null */
6204     if (kid->op_type != OP_SCOPE)
6205         return;
6206     kid = kLISTOP->op_last;                             /* get past scope */
6207     switch(kid->op_type) {
6208         case OP_NCMP:
6209         case OP_I_NCMP:
6210         case OP_SCMP:
6211             break;
6212         default:
6213             return;
6214     }
6215     k = kid;                                            /* remember this node*/
6216     if (kBINOP->op_first->op_type != OP_RV2SV)
6217         return;
6218     kid = kBINOP->op_first;                             /* get past cmp */
6219     if (kUNOP->op_first->op_type != OP_GV)
6220         return;
6221     kid = kUNOP->op_first;                              /* get past rv2sv */
6222     gv = kGVOP_gv;
6223     if (GvSTASH(gv) != PL_curstash)
6224         return;
6225     if (strEQ(GvNAME(gv), "a"))
6226         reversed = 0;
6227     else if (strEQ(GvNAME(gv), "b"))
6228         reversed = 1;
6229     else
6230         return;
6231     kid = k;                                            /* back to cmp */
6232     if (kBINOP->op_last->op_type != OP_RV2SV)
6233         return;
6234     kid = kBINOP->op_last;                              /* down to 2nd arg */
6235     if (kUNOP->op_first->op_type != OP_GV)
6236         return;
6237     kid = kUNOP->op_first;                              /* get past rv2sv */
6238     gv = kGVOP_gv;
6239     if (GvSTASH(gv) != PL_curstash
6240         || ( reversed
6241             ? strNE(GvNAME(gv), "a")
6242             : strNE(GvNAME(gv), "b")))
6243         return;
6244     o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6245     if (reversed)
6246         o->op_private |= OPpSORT_REVERSE;
6247     if (k->op_type == OP_NCMP)
6248         o->op_private |= OPpSORT_NUMERIC;
6249     if (k->op_type == OP_I_NCMP)
6250         o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6251     kid = cLISTOPo->op_first->op_sibling;
6252     cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6253     op_free(kid);                                     /* then delete it */
6254     cLISTOPo->op_children--;
6255 }
6256
6257 OP *
6258 Perl_ck_split(pTHX_ OP *o)
6259 {
6260     register OP *kid;
6261
6262     if (o->op_flags & OPf_STACKED)
6263         return no_fh_allowed(o);
6264
6265     kid = cLISTOPo->op_first;
6266     if (kid->op_type != OP_NULL)
6267         Perl_croak(aTHX_ "panic: ck_split");
6268     kid = kid->op_sibling;
6269     op_free(cLISTOPo->op_first);
6270     cLISTOPo->op_first = kid;
6271     if (!kid) {
6272         cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
6273         cLISTOPo->op_last = kid; /* There was only one element previously */
6274     }
6275
6276     if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6277         OP *sibl = kid->op_sibling;
6278         kid->op_sibling = 0;
6279         kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
6280         if (cLISTOPo->op_first == cLISTOPo->op_last)
6281             cLISTOPo->op_last = kid;
6282         cLISTOPo->op_first = kid;
6283         kid->op_sibling = sibl;
6284     }
6285
6286     kid->op_type = OP_PUSHRE;
6287     kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6288     scalar(kid);
6289
6290     if (!kid->op_sibling)
6291         append_elem(OP_SPLIT, o, newDEFSVOP());
6292
6293     kid = kid->op_sibling;
6294     scalar(kid);
6295
6296     if (!kid->op_sibling)
6297         append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6298
6299     kid = kid->op_sibling;
6300     scalar(kid);
6301
6302     if (kid->op_sibling)
6303         return too_many_arguments(o,PL_op_desc[o->op_type]);
6304
6305     return o;
6306 }
6307
6308 OP *
6309 Perl_ck_join(pTHX_ OP *o)
6310 {
6311     if (ckWARN(WARN_SYNTAX)) {
6312         OP *kid = cLISTOPo->op_first->op_sibling;
6313         if (kid && kid->op_type == OP_MATCH) {
6314             char *pmstr = "STRING";
6315             if (kPMOP->op_pmregexp)
6316                 pmstr = kPMOP->op_pmregexp->precomp;
6317             Perl_warner(aTHX_ WARN_SYNTAX,
6318                         "/%s/ should probably be written as \"%s\"",
6319                         pmstr, pmstr);
6320         }
6321     }
6322     return ck_fun(o);
6323 }
6324
6325 OP *
6326 Perl_ck_subr(pTHX_ OP *o)
6327 {
6328     OP *prev = ((cUNOPo->op_first->op_sibling)
6329              ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6330     OP *o2 = prev->op_sibling;
6331     OP *cvop;
6332     char *proto = 0;
6333     CV *cv = 0;
6334     GV *namegv = 0;
6335     int optional = 0;
6336     I32 arg = 0;
6337     STRLEN n_a;
6338
6339     o->op_private |= OPpENTERSUB_HASTARG;
6340     for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6341     if (cvop->op_type == OP_RV2CV) {
6342         SVOP* tmpop;
6343         o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6344         null(cvop);             /* disable rv2cv */
6345         tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6346         if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6347             GV *gv = cGVOPx_gv(tmpop);
6348             cv = GvCVu(gv);
6349             if (!cv)
6350                 tmpop->op_private |= OPpEARLY_CV;
6351             else if (SvPOK(cv)) {
6352                 namegv = CvANON(cv) ? gv : CvGV(cv);
6353                 proto = SvPV((SV*)cv, n_a);
6354             }
6355         }
6356     }
6357     else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6358         if (o2->op_type == OP_CONST)
6359             o2->op_private &= ~OPpCONST_STRICT;
6360         else if (o2->op_type == OP_LIST) {
6361             OP *o = ((UNOP*)o2)->op_first->op_sibling;
6362             if (o && o->op_type == OP_CONST)
6363                 o->op_private &= ~OPpCONST_STRICT;
6364         }
6365     }
6366     o->op_private |= (PL_hints & HINT_STRICT_REFS);
6367     if (PERLDB_SUB && PL_curstash != PL_debstash)
6368         o->op_private |= OPpENTERSUB_DB;
6369     while (o2 != cvop) {
6370         if (proto) {
6371             switch (*proto) {
6372             case '\0':
6373                 return too_many_arguments(o, gv_ename(namegv));
6374             case ';':
6375                 optional = 1;
6376                 proto++;
6377                 continue;
6378             case '$':
6379                 proto++;
6380                 arg++;
6381                 scalar(o2);
6382                 break;
6383             case '%':
6384             case '@':
6385                 list(o2);
6386                 arg++;
6387                 break;
6388             case '&':
6389                 proto++;
6390                 arg++;
6391                 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6392                     bad_type(arg,
6393                         arg == 1 ? "block or sub {}" : "sub {}",
6394                         gv_ename(namegv), o2);
6395                 break;
6396             case '*':
6397                 /* '*' allows any scalar type, including bareword */
6398                 proto++;
6399                 arg++;
6400                 if (o2->op_type == OP_RV2GV)
6401                     goto wrapref;       /* autoconvert GLOB -> GLOBref */
6402                 else if (o2->op_type == OP_CONST)
6403                     o2->op_private &= ~OPpCONST_STRICT;
6404                 else if (o2->op_type == OP_ENTERSUB) {
6405                     /* accidental subroutine, revert to bareword */
6406                     OP *gvop = ((UNOP*)o2)->op_first;
6407                     if (gvop && gvop->op_type == OP_NULL) {
6408                         gvop = ((UNOP*)gvop)->op_first;
6409                         if (gvop) {
6410                             for (; gvop->op_sibling; gvop = gvop->op_sibling)
6411                                 ;
6412                             if (gvop &&
6413                                 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6414                                 (gvop = ((UNOP*)gvop)->op_first) &&
6415                                 gvop->op_type == OP_GV)
6416                             {
6417                                 GV *gv = cGVOPx_gv(gvop);
6418                                 OP *sibling = o2->op_sibling;
6419                                 SV *n = newSVpvn("",0);
6420                                 op_free(o2);
6421                                 gv_fullname3(n, gv, "");
6422                                 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
6423                                     sv_chop(n, SvPVX(n)+6);
6424                                 o2 = newSVOP(OP_CONST, 0, n);
6425                                 prev->op_sibling = o2;
6426                                 o2->op_sibling = sibling;
6427                             }
6428                         }
6429                     }
6430                 }
6431                 scalar(o2);
6432                 break;
6433             case '\\':
6434                 proto++;
6435                 arg++;
6436                 switch (*proto++) {
6437                 case '*':
6438                     if (o2->op_type != OP_RV2GV)
6439                         bad_type(arg, "symbol", gv_ename(namegv), o2);
6440                     goto wrapref;
6441                 case '&':
6442                     if (o2->op_type != OP_ENTERSUB)
6443                         bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6444                     goto wrapref;
6445                 case '$':
6446                     if (o2->op_type != OP_RV2SV
6447                         && o2->op_type != OP_PADSV
6448                         && o2->op_type != OP_HELEM
6449                         && o2->op_type != OP_AELEM
6450                         && o2->op_type != OP_THREADSV)
6451                     {
6452                         bad_type(arg, "scalar", gv_ename(namegv), o2);
6453                     }
6454                     goto wrapref;
6455                 case '@':
6456                     if (o2->op_type != OP_RV2AV && o2->op_type != OP_PADAV)
6457                         bad_type(arg, "array", gv_ename(namegv), o2);
6458                     goto wrapref;
6459                 case '%':
6460                     if (o2->op_type != OP_RV2HV && o2->op_type != OP_PADHV)
6461                         bad_type(arg, "hash", gv_ename(namegv), o2);
6462                   wrapref:
6463                     {
6464                         OP* kid = o2;
6465                         OP* sib = kid->op_sibling;
6466                         kid->op_sibling = 0;
6467                         o2 = newUNOP(OP_REFGEN, 0, kid);
6468                         o2->op_sibling = sib;
6469                         prev->op_sibling = o2;
6470                     }
6471                     break;
6472                 default: goto oops;
6473                 }
6474                 break;
6475             case ' ':
6476                 proto++;
6477                 continue;
6478             default:
6479               oops:
6480                 Perl_croak(aTHX_ "Malformed prototype for %s: %s",
6481                         gv_ename(namegv), SvPV((SV*)cv, n_a));
6482             }
6483         }
6484         else
6485             list(o2);
6486         mod(o2, OP_ENTERSUB);
6487         prev = o2;
6488         o2 = o2->op_sibling;
6489     }
6490     if (proto && !optional &&
6491           (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6492         return too_few_arguments(o, gv_ename(namegv));
6493     return o;
6494 }
6495
6496 OP *
6497 Perl_ck_svconst(pTHX_ OP *o)
6498 {
6499     SvREADONLY_on(cSVOPo->op_sv);
6500     return o;
6501 }
6502
6503 OP *
6504 Perl_ck_trunc(pTHX_ OP *o)
6505 {
6506     if (o->op_flags & OPf_KIDS) {
6507         SVOP *kid = (SVOP*)cUNOPo->op_first;
6508
6509         if (kid->op_type == OP_NULL)
6510             kid = (SVOP*)kid->op_sibling;
6511         if (kid && kid->op_type == OP_CONST &&
6512             (kid->op_private & OPpCONST_BARE))
6513         {
6514             o->op_flags |= OPf_SPECIAL;
6515             kid->op_private &= ~OPpCONST_STRICT;
6516         }
6517     }
6518     return ck_fun(o);
6519 }
6520
6521 OP *
6522 Perl_ck_substr(pTHX_ OP *o)
6523 {
6524     o = ck_fun(o);
6525     if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6526         OP *kid = cLISTOPo->op_first;
6527
6528         if (kid->op_type == OP_NULL)
6529             kid = kid->op_sibling;
6530         if (kid)
6531             kid->op_flags |= OPf_MOD;
6532
6533     }
6534     return o;
6535 }
6536
6537 /* A peephole optimizer.  We visit the ops in the order they're to execute. */
6538
6539 void
6540 Perl_peep(pTHX_ register OP *o)
6541 {
6542     register OP* oldop = 0;
6543     STRLEN n_a;
6544     OP *last_composite = Nullop;
6545
6546     if (!o || o->op_seq)
6547         return;
6548     ENTER;
6549     SAVEOP();
6550     SAVEVPTR(PL_curcop);
6551     for (; o; o = o->op_next) {
6552         if (o->op_seq)
6553             break;
6554         if (!PL_op_seqmax)
6555             PL_op_seqmax++;
6556         PL_op = o;
6557         switch (o->op_type) {
6558         case OP_SETSTATE:
6559         case OP_NEXTSTATE:
6560         case OP_DBSTATE:
6561             PL_curcop = ((COP*)o);              /* for warnings */
6562             o->op_seq = PL_op_seqmax++;
6563             last_composite = Nullop;
6564             break;
6565
6566         case OP_CONST:
6567             if (cSVOPo->op_private & OPpCONST_STRICT)
6568                 no_bareword_allowed(o);
6569 #ifdef USE_ITHREADS
6570             /* Relocate sv to the pad for thread safety.
6571              * Despite being a "constant", the SV is written to,
6572              * for reference counts, sv_upgrade() etc. */
6573             if (cSVOP->op_sv) {
6574                 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6575                 if (SvPADTMP(cSVOPo->op_sv)) {
6576                     /* If op_sv is already a PADTMP then it is being used by
6577                      * some pad, so make a copy. */
6578                     sv_setsv(PL_curpad[ix],cSVOPo->op_sv);
6579                     SvREADONLY_on(PL_curpad[ix]);
6580                     SvREFCNT_dec(cSVOPo->op_sv);
6581                 }
6582                 else {
6583                     SvREFCNT_dec(PL_curpad[ix]);
6584                     SvPADTMP_on(cSVOPo->op_sv);
6585                     PL_curpad[ix] = cSVOPo->op_sv;
6586                     /* XXX I don't know how this isn't readonly already. */
6587                     SvREADONLY_on(PL_curpad[ix]);
6588                 }
6589                 cSVOPo->op_sv = Nullsv;
6590                 o->op_targ = ix;
6591             }
6592 #endif
6593             o->op_seq = PL_op_seqmax++;
6594             break;
6595
6596         case OP_CONCAT:
6597             if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6598                 if (o->op_next->op_private & OPpTARGET_MY) {
6599                     if (o->op_flags & OPf_STACKED) /* chained concats */
6600                         goto ignore_optimization;
6601                     else {
6602                         /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6603                         o->op_targ = o->op_next->op_targ;
6604                         o->op_next->op_targ = 0;
6605                         o->op_private |= OPpTARGET_MY;
6606                     }
6607                 }
6608                 null(o->op_next);
6609             }
6610           ignore_optimization:
6611             o->op_seq = PL_op_seqmax++;
6612             break;
6613         case OP_STUB:
6614             if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6615                 o->op_seq = PL_op_seqmax++;
6616                 break; /* Scalar stub must produce undef.  List stub is noop */
6617             }
6618             goto nothin;
6619         case OP_NULL:
6620             if (o->op_targ == OP_NEXTSTATE
6621                 || o->op_targ == OP_DBSTATE
6622                 || o->op_targ == OP_SETSTATE)
6623             {
6624                 PL_curcop = ((COP*)o);
6625             }
6626             goto nothin;
6627         case OP_SCALAR:
6628         case OP_LINESEQ:
6629         case OP_SCOPE:
6630           nothin:
6631             if (oldop && o->op_next) {
6632                 oldop->op_next = o->op_next;
6633                 continue;
6634             }
6635             o->op_seq = PL_op_seqmax++;
6636             break;
6637
6638         case OP_GV:
6639             if (o->op_next->op_type == OP_RV2SV) {
6640                 if (!(o->op_next->op_private & OPpDEREF)) {
6641                     null(o->op_next);
6642                     o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6643                                                                | OPpOUR_INTRO);
6644                     o->op_next = o->op_next->op_next;
6645                     o->op_type = OP_GVSV;
6646                     o->op_ppaddr = PL_ppaddr[OP_GVSV];
6647                 }
6648             }
6649             else if (o->op_next->op_type == OP_RV2AV) {
6650                 OP* pop = o->op_next->op_next;
6651                 IV i;
6652                 if (pop->op_type == OP_CONST &&
6653                     (PL_op = pop->op_next) &&
6654                     pop->op_next->op_type == OP_AELEM &&
6655                     !(pop->op_next->op_private &
6656                       (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF)) &&
6657                     (i = SvIV(((SVOP*)pop)->op_sv) - PL_compiling.cop_arybase)
6658                                 <= 255 &&
6659                     i >= 0)
6660                 {
6661                     GV *gv;
6662                     null(o->op_next);
6663                     null(pop->op_next);
6664                     null(pop);
6665                     o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6666                     o->op_next = pop->op_next->op_next;
6667                     o->op_type = OP_AELEMFAST;
6668                     o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6669                     o->op_private = (U8)i;
6670                     gv = cGVOPo_gv;
6671                     GvAVn(gv);
6672                 }
6673             }
6674             else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6675                 GV *gv = cGVOPo_gv;
6676                 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
6677                     /* XXX could check prototype here instead of just carping */
6678                     SV *sv = sv_newmortal();
6679                     gv_efullname3(sv, gv, Nullch);
6680                     Perl_warner(aTHX_ WARN_PROTOTYPE,
6681                                 "%s() called too early to check prototype",
6682                                 SvPV_nolen(sv));
6683                 }
6684             }
6685
6686             o->op_seq = PL_op_seqmax++;
6687             break;
6688
6689         case OP_MAPWHILE:
6690         case OP_GREPWHILE:
6691         case OP_AND:
6692         case OP_OR:
6693         case OP_ANDASSIGN:
6694         case OP_ORASSIGN:
6695         case OP_COND_EXPR:
6696         case OP_RANGE:
6697             o->op_seq = PL_op_seqmax++;
6698             while (cLOGOP->op_other->op_type == OP_NULL)
6699                 cLOGOP->op_other = cLOGOP->op_other->op_next;
6700             peep(cLOGOP->op_other);
6701             break;
6702
6703         case OP_ENTERLOOP:
6704             o->op_seq = PL_op_seqmax++;
6705             peep(cLOOP->op_redoop);
6706             peep(cLOOP->op_nextop);
6707             peep(cLOOP->op_lastop);
6708             break;
6709
6710         case OP_QR:
6711         case OP_MATCH:
6712         case OP_SUBST:
6713             o->op_seq = PL_op_seqmax++;
6714             peep(cPMOP->op_pmreplstart);
6715             break;
6716
6717         case OP_EXEC:
6718             o->op_seq = PL_op_seqmax++;
6719             if (ckWARN(WARN_SYNTAX) && o->op_next
6720                 && o->op_next->op_type == OP_NEXTSTATE) {
6721                 if (o->op_next->op_sibling &&
6722                         o->op_next->op_sibling->op_type != OP_EXIT &&
6723                         o->op_next->op_sibling->op_type != OP_WARN &&
6724                         o->op_next->op_sibling->op_type != OP_DIE) {
6725                     line_t oldline = CopLINE(PL_curcop);
6726
6727                     CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6728                     Perl_warner(aTHX_ WARN_EXEC,
6729                                 "Statement unlikely to be reached");
6730                     Perl_warner(aTHX_ WARN_EXEC,
6731                                 "\t(Maybe you meant system() when you said exec()?)\n");
6732                     CopLINE_set(PL_curcop, oldline);
6733                 }
6734             }
6735             break;
6736
6737         case OP_HELEM: {
6738             UNOP *rop;
6739             SV *lexname;
6740             GV **fields;
6741             SV **svp, **indsvp, *sv;
6742             I32 ind;
6743             char *key = NULL;
6744             STRLEN keylen;
6745
6746             o->op_seq = PL_op_seqmax++;
6747
6748             if (((BINOP*)o)->op_last->op_type != OP_CONST)
6749                 break;
6750
6751             /* Make the CONST have a shared SV */
6752             svp = cSVOPx_svp(((BINOP*)o)->op_last);
6753             if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
6754                 key = SvPV(sv, keylen);
6755                 if (SvUTF8(sv))
6756                   keylen = -keylen;
6757                 lexname = newSVpvn_share(key, keylen, 0);
6758                 SvREFCNT_dec(sv);
6759                 *svp = lexname;
6760             }
6761
6762             if ((o->op_private & (OPpLVAL_INTRO)))
6763                 break;
6764
6765             rop = (UNOP*)((BINOP*)o)->op_first;
6766             if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6767                 break;
6768             lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
6769             if (!SvOBJECT(lexname))
6770                 break;
6771             fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6772             if (!fields || !GvHV(*fields))
6773                 break;
6774             key = SvPV(*svp, keylen);
6775             if (SvUTF8(*svp))
6776                 keylen = -keylen;
6777             indsvp = hv_fetch(GvHV(*fields), key, keylen, FALSE);
6778             if (!indsvp) {
6779                 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" in variable %s of type %s",
6780                       key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
6781             }
6782             ind = SvIV(*indsvp);
6783             if (ind < 1)
6784                 Perl_croak(aTHX_ "Bad index while coercing array into hash");
6785             rop->op_type = OP_RV2AV;
6786             rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
6787             o->op_type = OP_AELEM;
6788             o->op_ppaddr = PL_ppaddr[OP_AELEM];
6789             sv = newSViv(ind);
6790             if (SvREADONLY(*svp))
6791                 SvREADONLY_on(sv);
6792             SvFLAGS(sv) |= (SvFLAGS(*svp)
6793                             & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
6794             SvREFCNT_dec(*svp);
6795             *svp = sv;
6796             break;
6797         }
6798
6799         case OP_HSLICE: {
6800             UNOP *rop;
6801             SV *lexname;
6802             GV **fields;
6803             SV **svp, **indsvp, *sv;
6804             I32 ind;
6805             char *key;
6806             STRLEN keylen;
6807             SVOP *first_key_op, *key_op;
6808
6809             o->op_seq = PL_op_seqmax++;
6810             if ((o->op_private & (OPpLVAL_INTRO))
6811                 /* I bet there's always a pushmark... */
6812                 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
6813                 /* hmmm, no optimization if list contains only one key. */
6814                 break;
6815             rop = (UNOP*)((LISTOP*)o)->op_last;
6816             if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6817                 break;
6818             lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
6819             if (!SvOBJECT(lexname))
6820                 break;
6821             fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6822             if (!fields || !GvHV(*fields))
6823                 break;
6824             /* Again guessing that the pushmark can be jumped over.... */
6825             first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
6826                 ->op_first->op_sibling;
6827             /* Check that the key list contains only constants. */
6828             for (key_op = first_key_op; key_op;
6829                  key_op = (SVOP*)key_op->op_sibling)
6830                 if (key_op->op_type != OP_CONST)
6831                     break;
6832             if (key_op)
6833                 break;
6834             rop->op_type = OP_RV2AV;
6835             rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
6836             o->op_type = OP_ASLICE;
6837             o->op_ppaddr = PL_ppaddr[OP_ASLICE];
6838             for (key_op = first_key_op; key_op;
6839                  key_op = (SVOP*)key_op->op_sibling) {
6840                 svp = cSVOPx_svp(key_op);
6841                 key = SvPV(*svp, keylen);
6842                 if (SvUTF8(*svp))
6843                     keylen = -keylen;
6844                 indsvp = hv_fetch(GvHV(*fields), key, keylen, FALSE);
6845                 if (!indsvp) {
6846                     Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" "
6847                                "in variable %s of type %s",
6848                           key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
6849                 }
6850                 ind = SvIV(*indsvp);
6851                 if (ind < 1)
6852                     Perl_croak(aTHX_ "Bad index while coercing array into hash");
6853                 sv = newSViv(ind);
6854                 if (SvREADONLY(*svp))
6855                     SvREADONLY_on(sv);
6856                 SvFLAGS(sv) |= (SvFLAGS(*svp)
6857                                 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
6858                 SvREFCNT_dec(*svp);
6859                 *svp = sv;
6860             }
6861             break;
6862         }
6863
6864         case OP_RV2AV:
6865         case OP_RV2HV:
6866             if (!(o->op_flags & OPf_WANT)
6867                 || (o->op_flags & OPf_WANT) == OPf_WANT_LIST)
6868             {
6869                 last_composite = o;
6870             }
6871             o->op_seq = PL_op_seqmax++;
6872             break;
6873
6874         case OP_RETURN:
6875             if (o->op_next && o->op_next->op_type != OP_LEAVESUBLV) {
6876                 o->op_seq = PL_op_seqmax++;
6877                 break;
6878             }
6879             /* FALL THROUGH */
6880
6881         case OP_LEAVESUBLV:
6882             if (last_composite) {
6883                 OP *r = last_composite;
6884
6885                 while (r->op_sibling)
6886                    r = r->op_sibling;
6887                 if (r->op_next == o
6888                     || (r->op_next->op_type == OP_LIST
6889                         && r->op_next->op_next == o))
6890                 {
6891                     if (last_composite->op_type == OP_RV2AV)
6892                         yyerror("Lvalue subs returning arrays not implemented yet");
6893                     else
6894                         yyerror("Lvalue subs returning hashes not implemented yet");
6895                         ;
6896                 }
6897             }
6898             /* FALL THROUGH */
6899
6900         default:
6901             o->op_seq = PL_op_seqmax++;
6902             break;
6903         }
6904         oldop = o;
6905     }
6906     LEAVE;
6907 }
6908
6909 #include "XSUB.h"
6910
6911 /* Efficient sub that returns a constant scalar value. */
6912 static void
6913 const_sv_xsub(pTHXo_ CV* cv)
6914 {
6915     dXSARGS;
6916     EXTEND(sp, 1);
6917     ST(0) = (SV*)XSANY.any_ptr;
6918     XSRETURN(1);
6919 }