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_ARYBASE)))
1340             goto nomod;
1341         if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1342             PL_compiling.cop_arybase = (I32)SvIV(cSVOPx(PL_eval_start)->op_sv);
1343             PL_eval_start = 0;
1344         }
1345         else if (!type) {
1346             SAVEI32(PL_compiling.cop_arybase);
1347             PL_compiling.cop_arybase = 0;
1348         }
1349         else if (type == OP_REFGEN)
1350             goto nomod;
1351         else
1352             Perl_croak(aTHX_ "That use of $[ is unsupported");
1353         break;
1354     case OP_STUB:
1355         if (o->op_flags & OPf_PARENS)
1356             break;
1357         goto nomod;
1358     case OP_ENTERSUB:
1359         if ((type == OP_UNDEF || type == OP_REFGEN) &&
1360             !(o->op_flags & OPf_STACKED)) {
1361             o->op_type = OP_RV2CV;              /* entersub => rv2cv */
1362             o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1363             assert(cUNOPo->op_first->op_type == OP_NULL);
1364             null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1365             break;
1366         }
1367         else {                          /* lvalue subroutine call */
1368             o->op_private |= OPpLVAL_INTRO;
1369             if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1370                 /* Backward compatibility mode: */
1371                 o->op_private |= OPpENTERSUB_INARGS;
1372                 break;
1373             }
1374             else {                      /* Compile-time error message: */
1375                 OP *kid = cUNOPo->op_first;
1376                 CV *cv;
1377                 OP *okid;
1378
1379                 if (kid->op_type == OP_PUSHMARK)
1380                     goto skip_kids;
1381                 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1382                     Perl_croak(aTHX_
1383                                "panic: unexpected lvalue entersub "
1384                                "args: type/targ %ld:%ld",
1385                                (long)kid->op_type,kid->op_targ);
1386                 kid = kLISTOP->op_first;
1387               skip_kids:
1388                 while (kid->op_sibling)
1389                     kid = kid->op_sibling;
1390                 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1391                     /* Indirect call */
1392                     if (kid->op_type == OP_METHOD_NAMED
1393                         || kid->op_type == OP_METHOD)
1394                     {
1395                         UNOP *newop;
1396
1397                         if (kid->op_sibling || kid->op_next != kid) {
1398                             yyerror("panic: unexpected optree near method call");
1399                             break;
1400                         }
1401
1402                         NewOp(1101, newop, 1, UNOP);
1403                         newop->op_type = OP_RV2CV;
1404                         newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1405                         newop->op_first = Nullop;
1406                         newop->op_next = (OP*)newop;
1407                         kid->op_sibling = (OP*)newop;
1408                         newop->op_private |= OPpLVAL_INTRO;
1409                         break;
1410                     }
1411
1412                     if (kid->op_type != OP_RV2CV)
1413                         Perl_croak(aTHX_
1414                                    "panic: unexpected lvalue entersub "
1415                                    "entry via type/targ %ld:%ld",
1416                                    (long)kid->op_type,kid->op_targ);
1417                     kid->op_private |= OPpLVAL_INTRO;
1418                     break;      /* Postpone until runtime */
1419                 }
1420
1421                 okid = kid;
1422                 kid = kUNOP->op_first;
1423                 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1424                     kid = kUNOP->op_first;
1425                 if (kid->op_type == OP_NULL)
1426                     Perl_croak(aTHX_
1427                                "Unexpected constant lvalue entersub "
1428                                "entry via type/targ %ld:%ld",
1429                                (long)kid->op_type,kid->op_targ);
1430                 if (kid->op_type != OP_GV) {
1431                     /* Restore RV2CV to check lvalueness */
1432                   restore_2cv:
1433                     if (kid->op_next && kid->op_next != kid) { /* Happens? */
1434                         okid->op_next = kid->op_next;
1435                         kid->op_next = okid;
1436                     }
1437                     else
1438                         okid->op_next = Nullop;
1439                     okid->op_type = OP_RV2CV;
1440                     okid->op_targ = 0;
1441                     okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1442                     okid->op_private |= OPpLVAL_INTRO;
1443                     break;
1444                 }
1445
1446                 cv = GvCV(kGVOP_gv);
1447                 if (!cv)
1448                     goto restore_2cv;
1449                 if (CvLVALUE(cv))
1450                     break;
1451             }
1452         }
1453         /* FALL THROUGH */
1454     default:
1455       nomod:
1456         /* grep, foreach, subcalls, refgen */
1457         if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1458             break;
1459         yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1460                      (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1461                       ? "do block"
1462                       : (o->op_type == OP_ENTERSUB
1463                         ? "non-lvalue subroutine call"
1464                         : PL_op_desc[o->op_type])),
1465                      type ? PL_op_desc[type] : "local"));
1466         return o;
1467
1468     case OP_PREINC:
1469     case OP_PREDEC:
1470     case OP_POW:
1471     case OP_MULTIPLY:
1472     case OP_DIVIDE:
1473     case OP_MODULO:
1474     case OP_REPEAT:
1475     case OP_ADD:
1476     case OP_SUBTRACT:
1477     case OP_CONCAT:
1478     case OP_LEFT_SHIFT:
1479     case OP_RIGHT_SHIFT:
1480     case OP_BIT_AND:
1481     case OP_BIT_XOR:
1482     case OP_BIT_OR:
1483     case OP_I_MULTIPLY:
1484     case OP_I_DIVIDE:
1485     case OP_I_MODULO:
1486     case OP_I_ADD:
1487     case OP_I_SUBTRACT:
1488         if (!(o->op_flags & OPf_STACKED))
1489             goto nomod;
1490         PL_modcount++;
1491         break;
1492
1493     case OP_COND_EXPR:
1494         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1495             mod(kid, type);
1496         break;
1497
1498     case OP_RV2AV:
1499     case OP_RV2HV:
1500         if (!type && cUNOPo->op_first->op_type != OP_GV)
1501             Perl_croak(aTHX_ "Can't localize through a reference");
1502         if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1503             PL_modcount = 10000;
1504             return o;           /* Treat \(@foo) like ordinary list. */
1505         }
1506         /* FALL THROUGH */
1507     case OP_RV2GV:
1508         if (scalar_mod_type(o, type))
1509             goto nomod;
1510         ref(cUNOPo->op_first, o->op_type);
1511         /* FALL THROUGH */
1512     case OP_AASSIGN:
1513     case OP_ASLICE:
1514     case OP_HSLICE:
1515     case OP_NEXTSTATE:
1516     case OP_DBSTATE:
1517     case OP_REFGEN:
1518     case OP_CHOMP:
1519         PL_modcount = 10000;
1520         break;
1521     case OP_RV2SV:
1522         if (!type && cUNOPo->op_first->op_type != OP_GV)
1523             Perl_croak(aTHX_ "Can't localize through a reference");
1524         ref(cUNOPo->op_first, o->op_type);
1525         /* FALL THROUGH */
1526     case OP_GV:
1527     case OP_AV2ARYLEN:
1528         PL_hints |= HINT_BLOCK_SCOPE;
1529     case OP_SASSIGN:
1530     case OP_ANDASSIGN:
1531     case OP_ORASSIGN:
1532     case OP_AELEMFAST:
1533         PL_modcount++;
1534         break;
1535
1536     case OP_PADAV:
1537     case OP_PADHV:
1538         PL_modcount = 10000;
1539         if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1540             return o;           /* Treat \(@foo) like ordinary list. */
1541         if (scalar_mod_type(o, type))
1542             goto nomod;
1543         /* FALL THROUGH */
1544     case OP_PADSV:
1545         PL_modcount++;
1546         if (!type)
1547             Perl_croak(aTHX_ "Can't localize lexical variable %s",
1548                 SvPV(*av_fetch(PL_comppad_name, o->op_targ, 4), n_a));
1549         break;
1550
1551 #ifdef USE_THREADS
1552     case OP_THREADSV:
1553         PL_modcount++;  /* XXX ??? */
1554         break;
1555 #endif /* USE_THREADS */
1556
1557     case OP_PUSHMARK:
1558         break;
1559
1560     case OP_KEYS:
1561         if (type != OP_SASSIGN)
1562             goto nomod;
1563         goto lvalue_func;
1564     case OP_SUBSTR:
1565         if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1566             goto nomod;
1567         /* FALL THROUGH */
1568     case OP_POS:
1569     case OP_VEC:
1570       lvalue_func:
1571         pad_free(o->op_targ);
1572         o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1573         assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1574         if (o->op_flags & OPf_KIDS)
1575             mod(cBINOPo->op_first->op_sibling, type);
1576         break;
1577
1578     case OP_AELEM:
1579     case OP_HELEM:
1580         ref(cBINOPo->op_first, o->op_type);
1581         if (type == OP_ENTERSUB &&
1582              !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1583             o->op_private |= OPpLVAL_DEFER;
1584         PL_modcount++;
1585         break;
1586
1587     case OP_SCOPE:
1588     case OP_LEAVE:
1589     case OP_ENTER:
1590         if (o->op_flags & OPf_KIDS)
1591             mod(cLISTOPo->op_last, type);
1592         break;
1593
1594     case OP_NULL:
1595         if (o->op_flags & OPf_SPECIAL)          /* do BLOCK */
1596             goto nomod;
1597         else if (!(o->op_flags & OPf_KIDS))
1598             break;
1599         if (o->op_targ != OP_LIST) {
1600             mod(cBINOPo->op_first, type);
1601             break;
1602         }
1603         /* FALL THROUGH */
1604     case OP_LIST:
1605         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1606             mod(kid, type);
1607         break;
1608     }
1609     o->op_flags |= OPf_MOD;
1610
1611     if (type == OP_AASSIGN || type == OP_SASSIGN)
1612         o->op_flags |= OPf_SPECIAL|OPf_REF;
1613     else if (!type) {
1614         o->op_private |= OPpLVAL_INTRO;
1615         o->op_flags &= ~OPf_SPECIAL;
1616         PL_hints |= HINT_BLOCK_SCOPE;
1617     }
1618     else if (type != OP_GREPSTART && type != OP_ENTERSUB)
1619         o->op_flags |= OPf_REF;
1620     return o;
1621 }
1622
1623 STATIC bool
1624 S_scalar_mod_type(pTHX_ OP *o, I32 type)
1625 {
1626     switch (type) {
1627     case OP_SASSIGN:
1628         if (o->op_type == OP_RV2GV)
1629             return FALSE;
1630         /* FALL THROUGH */
1631     case OP_PREINC:
1632     case OP_PREDEC:
1633     case OP_POSTINC:
1634     case OP_POSTDEC:
1635     case OP_I_PREINC:
1636     case OP_I_PREDEC:
1637     case OP_I_POSTINC:
1638     case OP_I_POSTDEC:
1639     case OP_POW:
1640     case OP_MULTIPLY:
1641     case OP_DIVIDE:
1642     case OP_MODULO:
1643     case OP_REPEAT:
1644     case OP_ADD:
1645     case OP_SUBTRACT:
1646     case OP_I_MULTIPLY:
1647     case OP_I_DIVIDE:
1648     case OP_I_MODULO:
1649     case OP_I_ADD:
1650     case OP_I_SUBTRACT:
1651     case OP_LEFT_SHIFT:
1652     case OP_RIGHT_SHIFT:
1653     case OP_BIT_AND:
1654     case OP_BIT_XOR:
1655     case OP_BIT_OR:
1656     case OP_CONCAT:
1657     case OP_SUBST:
1658     case OP_TRANS:
1659     case OP_READ:
1660     case OP_SYSREAD:
1661     case OP_RECV:
1662     case OP_ANDASSIGN:
1663     case OP_ORASSIGN:
1664         return TRUE;
1665     default:
1666         return FALSE;
1667     }
1668 }
1669
1670 STATIC bool
1671 S_is_handle_constructor(pTHX_ OP *o, I32 argnum)
1672 {
1673     switch (o->op_type) {
1674     case OP_PIPE_OP:
1675     case OP_SOCKPAIR:
1676         if (argnum == 2)
1677             return TRUE;
1678         /* FALL THROUGH */
1679     case OP_SYSOPEN:
1680     case OP_OPEN:
1681     case OP_SELECT:             /* XXX c.f. SelectSaver.pm */
1682     case OP_SOCKET:
1683     case OP_OPEN_DIR:
1684     case OP_ACCEPT:
1685         if (argnum == 1)
1686             return TRUE;
1687         /* FALL THROUGH */
1688     default:
1689         return FALSE;
1690     }
1691 }
1692
1693 OP *
1694 Perl_refkids(pTHX_ OP *o, I32 type)
1695 {
1696     OP *kid;
1697     if (o && o->op_flags & OPf_KIDS) {
1698         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1699             ref(kid, type);
1700     }
1701     return o;
1702 }
1703
1704 OP *
1705 Perl_ref(pTHX_ OP *o, I32 type)
1706 {
1707     OP *kid;
1708
1709     if (!o || PL_error_count)
1710         return o;
1711
1712     switch (o->op_type) {
1713     case OP_ENTERSUB:
1714         if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1715             !(o->op_flags & OPf_STACKED)) {
1716             o->op_type = OP_RV2CV;             /* entersub => rv2cv */
1717             o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1718             assert(cUNOPo->op_first->op_type == OP_NULL);
1719             null(((LISTOP*)cUNOPo->op_first)->op_first);        /* disable pushmark */
1720             o->op_flags |= OPf_SPECIAL;
1721         }
1722         break;
1723
1724     case OP_COND_EXPR:
1725         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1726             ref(kid, type);
1727         break;
1728     case OP_RV2SV:
1729         if (type == OP_DEFINED)
1730             o->op_flags |= OPf_SPECIAL;         /* don't create GV */
1731         ref(cUNOPo->op_first, o->op_type);
1732         /* FALL THROUGH */
1733     case OP_PADSV:
1734         if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1735             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1736                               : type == OP_RV2HV ? OPpDEREF_HV
1737                               : OPpDEREF_SV);
1738             o->op_flags |= OPf_MOD;
1739         }
1740         break;
1741
1742     case OP_THREADSV:
1743         o->op_flags |= OPf_MOD;         /* XXX ??? */
1744         break;
1745
1746     case OP_RV2AV:
1747     case OP_RV2HV:
1748         o->op_flags |= OPf_REF;
1749         /* FALL THROUGH */
1750     case OP_RV2GV:
1751         if (type == OP_DEFINED)
1752             o->op_flags |= OPf_SPECIAL;         /* don't create GV */
1753         ref(cUNOPo->op_first, o->op_type);
1754         break;
1755
1756     case OP_PADAV:
1757     case OP_PADHV:
1758         o->op_flags |= OPf_REF;
1759         break;
1760
1761     case OP_SCALAR:
1762     case OP_NULL:
1763         if (!(o->op_flags & OPf_KIDS))
1764             break;
1765         ref(cBINOPo->op_first, type);
1766         break;
1767     case OP_AELEM:
1768     case OP_HELEM:
1769         ref(cBINOPo->op_first, o->op_type);
1770         if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1771             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1772                               : type == OP_RV2HV ? OPpDEREF_HV
1773                               : OPpDEREF_SV);
1774             o->op_flags |= OPf_MOD;
1775         }
1776         break;
1777
1778     case OP_SCOPE:
1779     case OP_LEAVE:
1780     case OP_ENTER:
1781     case OP_LIST:
1782         if (!(o->op_flags & OPf_KIDS))
1783             break;
1784         ref(cLISTOPo->op_last, type);
1785         break;
1786     default:
1787         break;
1788     }
1789     return scalar(o);
1790
1791 }
1792
1793 STATIC OP *
1794 S_dup_attrlist(pTHX_ OP *o)
1795 {
1796     OP *rop = Nullop;
1797
1798     /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1799      * where the first kid is OP_PUSHMARK and the remaining ones
1800      * are OP_CONST.  We need to push the OP_CONST values.
1801      */
1802     if (o->op_type == OP_CONST)
1803         rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc(cSVOPo->op_sv));
1804     else {
1805         assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1806         for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1807             if (o->op_type == OP_CONST)
1808                 rop = append_elem(OP_LIST, rop,
1809                                   newSVOP(OP_CONST, o->op_flags,
1810                                           SvREFCNT_inc(cSVOPo->op_sv)));
1811         }
1812     }
1813     return rop;
1814 }
1815
1816 STATIC void
1817 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
1818 {
1819     SV *stashsv;
1820
1821     /* fake up C<use attributes $pkg,$rv,@attrs> */
1822     ENTER;              /* need to protect against side-effects of 'use' */
1823     SAVEINT(PL_expect);
1824     if (stash && HvNAME(stash))
1825         stashsv = newSVpv(HvNAME(stash), 0);
1826     else
1827         stashsv = &PL_sv_no;
1828
1829 #define ATTRSMODULE "attributes"
1830
1831     Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1832                      newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1833                      Nullsv,
1834                      prepend_elem(OP_LIST,
1835                                   newSVOP(OP_CONST, 0, stashsv),
1836                                   prepend_elem(OP_LIST,
1837                                                newSVOP(OP_CONST, 0,
1838                                                        newRV(target)),
1839                                                dup_attrlist(attrs))));
1840     LEAVE;
1841 }
1842
1843 void
1844 Perl_apply_attrs_string(pTHX_ char *stashpv, CV *cv,
1845                         char *attrstr, STRLEN len)
1846 {
1847     OP *attrs = Nullop;
1848
1849     if (!len) {
1850         len = strlen(attrstr);
1851     }
1852
1853     while (len) {
1854         for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1855         if (len) {
1856             char *sstr = attrstr;
1857             for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1858             attrs = append_elem(OP_LIST, attrs,
1859                                 newSVOP(OP_CONST, 0,
1860                                         newSVpvn(sstr, attrstr-sstr)));
1861         }
1862     }
1863
1864     Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1865                      newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1866                      Nullsv, prepend_elem(OP_LIST,
1867                                   newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1868                                   prepend_elem(OP_LIST,
1869                                                newSVOP(OP_CONST, 0,
1870                                                        newRV((SV*)cv)),
1871                                                attrs)));
1872 }
1873
1874 STATIC OP *
1875 S_my_kid(pTHX_ OP *o, OP *attrs)
1876 {
1877     OP *kid;
1878     I32 type;
1879
1880     if (!o || PL_error_count)
1881         return o;
1882
1883     type = o->op_type;
1884     if (type == OP_LIST) {
1885         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1886             my_kid(kid, attrs);
1887     } else if (type == OP_UNDEF) {
1888         return o;
1889     } else if (type == OP_RV2SV ||      /* "our" declaration */
1890                type == OP_RV2AV ||
1891                type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1892         o->op_private |= OPpOUR_INTRO;
1893         return o;
1894     } else if (type != OP_PADSV &&
1895              type != OP_PADAV &&
1896              type != OP_PADHV &&
1897              type != OP_PUSHMARK)
1898     {
1899         yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1900                           PL_op_desc[o->op_type],
1901                           PL_in_my == KEY_our ? "our" : "my"));
1902         return o;
1903     }
1904     else if (attrs && type != OP_PUSHMARK) {
1905         HV *stash;
1906         SV *padsv;
1907         SV **namesvp;
1908
1909         PL_in_my = FALSE;
1910         PL_in_my_stash = Nullhv;
1911
1912         /* check for C<my Dog $spot> when deciding package */
1913         namesvp = av_fetch(PL_comppad_name, o->op_targ, FALSE);
1914         if (namesvp && *namesvp && SvOBJECT(*namesvp) && HvNAME(SvSTASH(*namesvp)))
1915             stash = SvSTASH(*namesvp);
1916         else
1917             stash = PL_curstash;
1918         padsv = PAD_SV(o->op_targ);
1919         apply_attrs(stash, padsv, attrs);
1920     }
1921     o->op_flags |= OPf_MOD;
1922     o->op_private |= OPpLVAL_INTRO;
1923     return o;
1924 }
1925
1926 OP *
1927 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
1928 {
1929     if (o->op_flags & OPf_PARENS)
1930         list(o);
1931     if (attrs)
1932         SAVEFREEOP(attrs);
1933     o = my_kid(o, attrs);
1934     PL_in_my = FALSE;
1935     PL_in_my_stash = Nullhv;
1936     return o;
1937 }
1938
1939 OP *
1940 Perl_my(pTHX_ OP *o)
1941 {
1942     return my_kid(o, Nullop);
1943 }
1944
1945 OP *
1946 Perl_sawparens(pTHX_ OP *o)
1947 {
1948     if (o)
1949         o->op_flags |= OPf_PARENS;
1950     return o;
1951 }
1952
1953 OP *
1954 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
1955 {
1956     OP *o;
1957
1958     if (ckWARN(WARN_MISC) &&
1959       (left->op_type == OP_RV2AV ||
1960        left->op_type == OP_RV2HV ||
1961        left->op_type == OP_PADAV ||
1962        left->op_type == OP_PADHV)) {
1963       char *desc = PL_op_desc[(right->op_type == OP_SUBST ||
1964                             right->op_type == OP_TRANS)
1965                            ? right->op_type : OP_MATCH];
1966       const char *sample = ((left->op_type == OP_RV2AV ||
1967                              left->op_type == OP_PADAV)
1968                             ? "@array" : "%hash");
1969       Perl_warner(aTHX_ WARN_MISC,
1970              "Applying %s to %s will act on scalar(%s)",
1971              desc, sample, sample);
1972     }
1973
1974     if (!(right->op_flags & OPf_STACKED) &&
1975        (right->op_type == OP_MATCH ||
1976         right->op_type == OP_SUBST ||
1977         right->op_type == OP_TRANS)) {
1978         right->op_flags |= OPf_STACKED;
1979         if (right->op_type != OP_MATCH &&
1980             ! (right->op_type == OP_TRANS &&
1981                right->op_private & OPpTRANS_IDENTICAL))
1982             left = mod(left, right->op_type);
1983         if (right->op_type == OP_TRANS)
1984             o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
1985         else
1986             o = prepend_elem(right->op_type, scalar(left), right);
1987         if (type == OP_NOT)
1988             return newUNOP(OP_NOT, 0, scalar(o));
1989         return o;
1990     }
1991     else
1992         return bind_match(type, left,
1993                 pmruntime(newPMOP(OP_MATCH, 0), right, Nullop));
1994 }
1995
1996 OP *
1997 Perl_invert(pTHX_ OP *o)
1998 {
1999     if (!o)
2000         return o;
2001     /* XXX need to optimize away NOT NOT here?  Or do we let optimizer do it? */
2002     return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2003 }
2004
2005 OP *
2006 Perl_scope(pTHX_ OP *o)
2007 {
2008     if (o) {
2009         if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2010             o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2011             o->op_type = OP_LEAVE;
2012             o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2013         }
2014         else {
2015             if (o->op_type == OP_LINESEQ) {
2016                 OP *kid;
2017                 o->op_type = OP_SCOPE;
2018                 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2019                 kid = ((LISTOP*)o)->op_first;
2020                 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
2021                     null(kid);
2022             }
2023             else
2024                 o = newLISTOP(OP_SCOPE, 0, o, Nullop);
2025         }
2026     }
2027     return o;
2028 }
2029
2030 void
2031 Perl_save_hints(pTHX)
2032 {
2033     SAVEI32(PL_hints);
2034     SAVESPTR(GvHV(PL_hintgv));
2035     GvHV(PL_hintgv) = newHVhv(GvHV(PL_hintgv));
2036     SAVEFREESV(GvHV(PL_hintgv));
2037 }
2038
2039 int
2040 Perl_block_start(pTHX_ int full)
2041 {
2042     int retval = PL_savestack_ix;
2043
2044     SAVEI32(PL_comppad_name_floor);
2045     PL_comppad_name_floor = AvFILLp(PL_comppad_name);
2046     if (full)
2047         PL_comppad_name_fill = PL_comppad_name_floor;
2048     if (PL_comppad_name_floor < 0)
2049         PL_comppad_name_floor = 0;
2050     SAVEI32(PL_min_intro_pending);
2051     SAVEI32(PL_max_intro_pending);
2052     PL_min_intro_pending = 0;
2053     SAVEI32(PL_comppad_name_fill);
2054     SAVEI32(PL_padix_floor);
2055     PL_padix_floor = PL_padix;
2056     PL_pad_reset_pending = FALSE;
2057     SAVEHINTS();
2058     PL_hints &= ~HINT_BLOCK_SCOPE;
2059     SAVESPTR(PL_compiling.cop_warnings);
2060     if (! specialWARN(PL_compiling.cop_warnings)) {
2061         PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
2062         SAVEFREESV(PL_compiling.cop_warnings) ;
2063     }
2064     SAVESPTR(PL_compiling.cop_io);
2065     if (! specialCopIO(PL_compiling.cop_io)) {
2066         PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
2067         SAVEFREESV(PL_compiling.cop_io) ;
2068     }
2069     return retval;
2070 }
2071
2072 OP*
2073 Perl_block_end(pTHX_ I32 floor, OP *seq)
2074 {
2075     int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2076     OP* retval = scalarseq(seq);
2077     LEAVE_SCOPE(floor);
2078     PL_pad_reset_pending = FALSE;
2079     PL_compiling.op_private = PL_hints;
2080     if (needblockscope)
2081         PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2082     pad_leavemy(PL_comppad_name_fill);
2083     PL_cop_seqmax++;
2084     return retval;
2085 }
2086
2087 STATIC OP *
2088 S_newDEFSVOP(pTHX)
2089 {
2090 #ifdef USE_THREADS
2091     OP *o = newOP(OP_THREADSV, 0);
2092     o->op_targ = find_threadsv("_");
2093     return o;
2094 #else
2095     return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2096 #endif /* USE_THREADS */
2097 }
2098
2099 void
2100 Perl_newPROG(pTHX_ OP *o)
2101 {
2102     if (PL_in_eval) {
2103         if (PL_eval_root)
2104                 return;
2105         PL_eval_root = newUNOP(OP_LEAVEEVAL,
2106                                ((PL_in_eval & EVAL_KEEPERR)
2107                                 ? OPf_SPECIAL : 0), o);
2108         PL_eval_start = linklist(PL_eval_root);
2109         PL_eval_root->op_private |= OPpREFCOUNTED;
2110         OpREFCNT_set(PL_eval_root, 1);
2111         PL_eval_root->op_next = 0;
2112         peep(PL_eval_start);
2113     }
2114     else {
2115         if (!o)
2116             return;
2117         PL_main_root = scope(sawparens(scalarvoid(o)));
2118         PL_curcop = &PL_compiling;
2119         PL_main_start = LINKLIST(PL_main_root);
2120         PL_main_root->op_private |= OPpREFCOUNTED;
2121         OpREFCNT_set(PL_main_root, 1);
2122         PL_main_root->op_next = 0;
2123         peep(PL_main_start);
2124         PL_compcv = 0;
2125
2126         /* Register with debugger */
2127         if (PERLDB_INTER) {
2128             CV *cv = get_cv("DB::postponed", FALSE);
2129             if (cv) {
2130                 dSP;
2131                 PUSHMARK(SP);
2132                 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2133                 PUTBACK;
2134                 call_sv((SV*)cv, G_DISCARD);
2135             }
2136         }
2137     }
2138 }
2139
2140 OP *
2141 Perl_localize(pTHX_ OP *o, I32 lex)
2142 {
2143     if (o->op_flags & OPf_PARENS)
2144         list(o);
2145     else {
2146         if (ckWARN(WARN_PARENTHESIS) && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',') {
2147             char *s;
2148             for (s = PL_bufptr; *s && (isALNUM(*s) || (*s & 0x80) || strchr("@$%, ",*s)); s++) ;
2149             if (*s == ';' || *s == '=')
2150                 Perl_warner(aTHX_ WARN_PARENTHESIS,
2151                             "Parentheses missing around \"%s\" list",
2152                             lex ? (PL_in_my == KEY_our ? "our" : "my") : "local");
2153         }
2154     }
2155     if (lex)
2156         o = my(o);
2157     else
2158         o = mod(o, OP_NULL);            /* a bit kludgey */
2159     PL_in_my = FALSE;
2160     PL_in_my_stash = Nullhv;
2161     return o;
2162 }
2163
2164 OP *
2165 Perl_jmaybe(pTHX_ OP *o)
2166 {
2167     if (o->op_type == OP_LIST) {
2168         OP *o2;
2169 #ifdef USE_THREADS
2170         o2 = newOP(OP_THREADSV, 0);
2171         o2->op_targ = find_threadsv(";");
2172 #else
2173         o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
2174 #endif /* USE_THREADS */
2175         o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2176     }
2177     return o;
2178 }
2179
2180 OP *
2181 Perl_fold_constants(pTHX_ register OP *o)
2182 {
2183     register OP *curop;
2184     I32 type = o->op_type;
2185     SV *sv;
2186
2187     if (PL_opargs[type] & OA_RETSCALAR)
2188         scalar(o);
2189     if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2190         o->op_targ = pad_alloc(type, SVs_PADTMP);
2191
2192     /* integerize op, unless it happens to be C<-foo>.
2193      * XXX should pp_i_negate() do magic string negation instead? */
2194     if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2195         && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2196              && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2197     {
2198         o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2199     }
2200
2201     if (!(PL_opargs[type] & OA_FOLDCONST))
2202         goto nope;
2203
2204     switch (type) {
2205     case OP_NEGATE:
2206         /* XXX might want a ck_negate() for this */
2207         cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2208         break;
2209     case OP_SPRINTF:
2210     case OP_UCFIRST:
2211     case OP_LCFIRST:
2212     case OP_UC:
2213     case OP_LC:
2214     case OP_SLT:
2215     case OP_SGT:
2216     case OP_SLE:
2217     case OP_SGE:
2218     case OP_SCMP:
2219
2220         if (o->op_private & OPpLOCALE)
2221             goto nope;
2222     }
2223
2224     if (PL_error_count)
2225         goto nope;              /* Don't try to run w/ errors */
2226
2227     for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2228         if ((curop->op_type != OP_CONST ||
2229              (curop->op_private & OPpCONST_BARE)) &&
2230             curop->op_type != OP_LIST &&
2231             curop->op_type != OP_SCALAR &&
2232             curop->op_type != OP_NULL &&
2233             curop->op_type != OP_PUSHMARK)
2234         {
2235             goto nope;
2236         }
2237     }
2238
2239     curop = LINKLIST(o);
2240     o->op_next = 0;
2241     PL_op = curop;
2242     CALLRUNOPS(aTHX);
2243     sv = *(PL_stack_sp--);
2244     if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2245         pad_swipe(o->op_targ);
2246     else if (SvTEMP(sv)) {                      /* grab mortal temp? */
2247         (void)SvREFCNT_inc(sv);
2248         SvTEMP_off(sv);
2249     }
2250     op_free(o);
2251     if (type == OP_RV2GV)
2252         return newGVOP(OP_GV, 0, (GV*)sv);
2253     else {
2254         /* try to smush double to int, but don't smush -2.0 to -2 */
2255         if ((SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK)) == SVf_NOK &&
2256             type != OP_NEGATE)
2257         {
2258 #ifdef PERL_PRESERVE_IVUV
2259             /* Only bother to attempt to fold to IV if
2260                most operators will benefit  */
2261             SvIV_please(sv);
2262 #endif
2263         }
2264         return newSVOP(OP_CONST, 0, sv);
2265     }
2266
2267   nope:
2268     if (!(PL_opargs[type] & OA_OTHERINT))
2269         return o;
2270
2271     if (!(PL_hints & HINT_INTEGER)) {
2272         if (type == OP_MODULO
2273             || type == OP_DIVIDE
2274             || !(o->op_flags & OPf_KIDS))
2275         {
2276             return o;
2277         }
2278
2279         for (curop = ((UNOP*)o)->op_first; curop; curop = curop->op_sibling) {
2280             if (curop->op_type == OP_CONST) {
2281                 if (SvIOK(((SVOP*)curop)->op_sv))
2282                     continue;
2283                 return o;
2284             }
2285             if (PL_opargs[curop->op_type] & OA_RETINTEGER)
2286                 continue;
2287             return o;
2288         }
2289         o->op_ppaddr = PL_ppaddr[++(o->op_type)];
2290     }
2291
2292     return o;
2293 }
2294
2295 OP *
2296 Perl_gen_constant_list(pTHX_ register OP *o)
2297 {
2298     register OP *curop;
2299     I32 oldtmps_floor = PL_tmps_floor;
2300
2301     list(o);
2302     if (PL_error_count)
2303         return o;               /* Don't attempt to run with errors */
2304
2305     PL_op = curop = LINKLIST(o);
2306     o->op_next = 0;
2307     peep(curop);
2308     pp_pushmark();
2309     CALLRUNOPS(aTHX);
2310     PL_op = curop;
2311     pp_anonlist();
2312     PL_tmps_floor = oldtmps_floor;
2313
2314     o->op_type = OP_RV2AV;
2315     o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2316     curop = ((UNOP*)o)->op_first;
2317     ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
2318     op_free(curop);
2319     linklist(o);
2320     return list(o);
2321 }
2322
2323 OP *
2324 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2325 {
2326     OP *kid;
2327     OP *last = 0;
2328
2329     if (!o || o->op_type != OP_LIST)
2330         o = newLISTOP(OP_LIST, 0, o, Nullop);
2331     else
2332         o->op_flags &= ~OPf_WANT;
2333
2334     if (!(PL_opargs[type] & OA_MARK))
2335         null(cLISTOPo->op_first);
2336
2337     o->op_type = type;
2338     o->op_ppaddr = PL_ppaddr[type];
2339     o->op_flags |= flags;
2340
2341     o = CHECKOP(type, o);
2342     if (o->op_type != type)
2343         return o;
2344
2345     if (cLISTOPo->op_children < 7) {
2346         /* XXX do we really need to do this if we're done appending?? */
2347         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2348             last = kid;
2349         cLISTOPo->op_last = last;       /* in case check substituted last arg */
2350     }
2351
2352     return fold_constants(o);
2353 }
2354
2355 /* List constructors */
2356
2357 OP *
2358 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2359 {
2360     if (!first)
2361         return last;
2362
2363     if (!last)
2364         return first;
2365
2366     if (first->op_type != type
2367         || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2368     {
2369         return newLISTOP(type, 0, first, last);
2370     }
2371
2372     if (first->op_flags & OPf_KIDS)
2373         ((LISTOP*)first)->op_last->op_sibling = last;
2374     else {
2375         first->op_flags |= OPf_KIDS;
2376         ((LISTOP*)first)->op_first = last;
2377     }
2378     ((LISTOP*)first)->op_last = last;
2379     ((LISTOP*)first)->op_children++;
2380     return first;
2381 }
2382
2383 OP *
2384 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2385 {
2386     if (!first)
2387         return (OP*)last;
2388
2389     if (!last)
2390         return (OP*)first;
2391
2392     if (first->op_type != type)
2393         return prepend_elem(type, (OP*)first, (OP*)last);
2394
2395     if (last->op_type != type)
2396         return append_elem(type, (OP*)first, (OP*)last);
2397
2398     first->op_last->op_sibling = last->op_first;
2399     first->op_last = last->op_last;
2400     first->op_children += last->op_children;
2401     if (first->op_children)
2402         first->op_flags |= OPf_KIDS;
2403
2404 #ifdef PL_OP_SLAB_ALLOC
2405 #else
2406     Safefree(last);
2407 #endif
2408     return (OP*)first;
2409 }
2410
2411 OP *
2412 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2413 {
2414     if (!first)
2415         return last;
2416
2417     if (!last)
2418         return first;
2419
2420     if (last->op_type == type) {
2421         if (type == OP_LIST) {  /* already a PUSHMARK there */
2422             first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2423             ((LISTOP*)last)->op_first->op_sibling = first;
2424         }
2425         else {
2426             if (!(last->op_flags & OPf_KIDS)) {
2427                 ((LISTOP*)last)->op_last = first;
2428                 last->op_flags |= OPf_KIDS;
2429             }
2430             first->op_sibling = ((LISTOP*)last)->op_first;
2431             ((LISTOP*)last)->op_first = first;
2432         }
2433         ((LISTOP*)last)->op_children++;
2434         return last;
2435     }
2436
2437     return newLISTOP(type, 0, first, last);
2438 }
2439
2440 /* Constructors */
2441
2442 OP *
2443 Perl_newNULLLIST(pTHX)
2444 {
2445     return newOP(OP_STUB, 0);
2446 }
2447
2448 OP *
2449 Perl_force_list(pTHX_ OP *o)
2450 {
2451     if (!o || o->op_type != OP_LIST)
2452         o = newLISTOP(OP_LIST, 0, o, Nullop);
2453     null(o);
2454     return o;
2455 }
2456
2457 OP *
2458 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2459 {
2460     LISTOP *listop;
2461
2462     NewOp(1101, listop, 1, LISTOP);
2463
2464     listop->op_type = type;
2465     listop->op_ppaddr = PL_ppaddr[type];
2466     listop->op_children = (first != 0) + (last != 0);
2467     listop->op_flags = flags;
2468
2469     if (!last && first)
2470         last = first;
2471     else if (!first && last)
2472         first = last;
2473     else if (first)
2474         first->op_sibling = last;
2475     listop->op_first = first;
2476     listop->op_last = last;
2477     if (type == OP_LIST) {
2478         OP* pushop;
2479         pushop = newOP(OP_PUSHMARK, 0);
2480         pushop->op_sibling = first;
2481         listop->op_first = pushop;
2482         listop->op_flags |= OPf_KIDS;
2483         if (!last)
2484             listop->op_last = pushop;
2485     }
2486     else if (listop->op_children)
2487         listop->op_flags |= OPf_KIDS;
2488
2489     return (OP*)listop;
2490 }
2491
2492 OP *
2493 Perl_newOP(pTHX_ I32 type, I32 flags)
2494 {
2495     OP *o;
2496     NewOp(1101, o, 1, OP);
2497     o->op_type = type;
2498     o->op_ppaddr = PL_ppaddr[type];
2499     o->op_flags = flags;
2500
2501     o->op_next = o;
2502     o->op_private = 0 + (flags >> 8);
2503     if (PL_opargs[type] & OA_RETSCALAR)
2504         scalar(o);
2505     if (PL_opargs[type] & OA_TARGET)
2506         o->op_targ = pad_alloc(type, SVs_PADTMP);
2507     return CHECKOP(type, o);
2508 }
2509
2510 OP *
2511 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2512 {
2513     UNOP *unop;
2514
2515     if (!first)
2516         first = newOP(OP_STUB, 0);
2517     if (PL_opargs[type] & OA_MARK)
2518         first = force_list(first);
2519
2520     NewOp(1101, unop, 1, UNOP);
2521     unop->op_type = type;
2522     unop->op_ppaddr = PL_ppaddr[type];
2523     unop->op_first = first;
2524     unop->op_flags = flags | OPf_KIDS;
2525     unop->op_private = 1 | (flags >> 8);
2526     unop = (UNOP*) CHECKOP(type, unop);
2527     if (unop->op_next)
2528         return (OP*)unop;
2529
2530     return fold_constants((OP *) unop);
2531 }
2532
2533 OP *
2534 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2535 {
2536     BINOP *binop;
2537     NewOp(1101, binop, 1, BINOP);
2538
2539     if (!first)
2540         first = newOP(OP_NULL, 0);
2541
2542     binop->op_type = type;
2543     binop->op_ppaddr = PL_ppaddr[type];
2544     binop->op_first = first;
2545     binop->op_flags = flags | OPf_KIDS;
2546     if (!last) {
2547         last = first;
2548         binop->op_private = 1 | (flags >> 8);
2549     }
2550     else {
2551         binop->op_private = 2 | (flags >> 8);
2552         first->op_sibling = last;
2553     }
2554
2555     binop = (BINOP*)CHECKOP(type, binop);
2556     if (binop->op_next || binop->op_type != type)
2557         return (OP*)binop;
2558
2559     binop->op_last = binop->op_first->op_sibling;
2560
2561     return fold_constants((OP *)binop);
2562 }
2563
2564 static int
2565 utf8compare(const void *a, const void *b)
2566 {
2567     int i;
2568     for (i = 0; i < 10; i++) {
2569         if ((*(U8**)a)[i] < (*(U8**)b)[i])
2570             return -1;
2571         if ((*(U8**)a)[i] > (*(U8**)b)[i])
2572             return 1;
2573     }
2574     return 0;
2575 }
2576
2577 OP *
2578 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2579 {
2580     SV *tstr = ((SVOP*)expr)->op_sv;
2581     SV *rstr = ((SVOP*)repl)->op_sv;
2582     STRLEN tlen;
2583     STRLEN rlen;
2584     register U8 *t = (U8*)SvPV(tstr, tlen);
2585     register U8 *r = (U8*)SvPV(rstr, rlen);
2586     register I32 i;
2587     register I32 j;
2588     I32 del;
2589     I32 complement;
2590     I32 squash;
2591     register short *tbl;
2592
2593     complement  = o->op_private & OPpTRANS_COMPLEMENT;
2594     del         = o->op_private & OPpTRANS_DELETE;
2595     squash      = o->op_private & OPpTRANS_SQUASH;
2596
2597     if (SvUTF8(tstr))
2598         o->op_private |= OPpTRANS_FROM_UTF;
2599
2600     if (SvUTF8(rstr))
2601         o->op_private |= OPpTRANS_TO_UTF;
2602
2603     if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2604         SV* listsv = newSVpvn("# comment\n",10);
2605         SV* transv = 0;
2606         U8* tend = t + tlen;
2607         U8* rend = r + rlen;
2608         STRLEN ulen;
2609         U32 tfirst = 1;
2610         U32 tlast = 0;
2611         I32 tdiff;
2612         U32 rfirst = 1;
2613         U32 rlast = 0;
2614         I32 rdiff;
2615         I32 diff;
2616         I32 none = 0;
2617         U32 max = 0;
2618         I32 bits;
2619         I32 grows = 0;
2620         I32 havefinal = 0;
2621         U32 final;
2622         I32 from_utf    = o->op_private & OPpTRANS_FROM_UTF;
2623         I32 to_utf      = o->op_private & OPpTRANS_TO_UTF;
2624
2625         if (complement) {
2626             U8 tmpbuf[UTF8_MAXLEN+1];
2627             U8** cp;
2628             I32* cl;
2629             UV nextmin = 0;
2630             New(1109, cp, tlen, U8*);
2631             i = 0;
2632             transv = newSVpvn("",0);
2633             while (t < tend) {
2634                 cp[i++] = t;
2635                 t += UTF8SKIP(t);
2636                 if (*t == 0xff) {
2637                     t++;
2638                     t += UTF8SKIP(t);
2639                 }
2640             }
2641             qsort(cp, i, sizeof(U8*), utf8compare);
2642             for (j = 0; j < i; j++) {
2643                 U8 *s = cp[j];
2644                 I32 cur = j < i ? cp[j+1] - s : tend - s;
2645                 UV  val = utf8_to_uv(s, cur, &ulen, 0);
2646                 s += ulen;
2647                 diff = val - nextmin;
2648                 if (diff > 0) {
2649                     t = uv_to_utf8(tmpbuf,nextmin);
2650                     sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2651                     if (diff > 1) {
2652                         t = uv_to_utf8(tmpbuf, val - 1);
2653                         sv_catpvn(transv, "\377", 1);
2654                         sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2655                     }
2656                 }
2657                 if (*s == 0xff)
2658                     val = utf8_to_uv(s+1, cur - 1, &ulen, 0);
2659                 if (val >= nextmin)
2660                     nextmin = val + 1;
2661             }
2662             t = uv_to_utf8(tmpbuf,nextmin);
2663             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2664             t = uv_to_utf8(tmpbuf, 0x7fffffff);
2665             sv_catpvn(transv, "\377", 1);
2666             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2667             t = (U8*)SvPVX(transv);
2668             tlen = SvCUR(transv);
2669             tend = t + tlen;
2670         }
2671         else if (!rlen && !del) {
2672             r = t; rlen = tlen; rend = tend;
2673         }
2674         if (!squash) {
2675                 if (t == r ||
2676                     (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2677                 {
2678                     o->op_private |= OPpTRANS_IDENTICAL;
2679                 }
2680         }
2681
2682         while (t < tend || tfirst <= tlast) {
2683             /* see if we need more "t" chars */
2684             if (tfirst > tlast) {
2685                 tfirst = (I32)utf8_to_uv(t, tend - t, &ulen, 0);
2686                 t += ulen;
2687                 if (t < tend && *t == 0xff) {   /* illegal utf8 val indicates range */
2688                     t++;
2689                     tlast = (I32)utf8_to_uv(t, tend - t, &ulen, 0);
2690                     t += ulen;
2691                 }
2692                 else
2693                     tlast = tfirst;
2694             }
2695
2696             /* now see if we need more "r" chars */
2697             if (rfirst > rlast) {
2698                 if (r < rend) {
2699                     rfirst = (I32)utf8_to_uv(r, rend - r, &ulen, 0);
2700                     r += ulen;
2701                     if (r < rend && *r == 0xff) {       /* illegal utf8 val indicates range */
2702                         r++;
2703                         rlast = (I32)utf8_to_uv(r, rend - r, &ulen, 0);
2704                         r += ulen;
2705                     }
2706                     else
2707                         rlast = rfirst;
2708                 }
2709                 else {
2710                     if (!havefinal++)
2711                         final = rlast;
2712                     rfirst = rlast = 0xffffffff;
2713                 }
2714             }
2715
2716             /* now see which range will peter our first, if either. */
2717             tdiff = tlast - tfirst;
2718             rdiff = rlast - rfirst;
2719
2720             if (tdiff <= rdiff)
2721                 diff = tdiff;
2722             else
2723                 diff = rdiff;
2724
2725             if (rfirst == 0xffffffff) {
2726                 diff = tdiff;   /* oops, pretend rdiff is infinite */
2727                 if (diff > 0)
2728                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2729                                    (long)tfirst, (long)tlast);
2730                 else
2731                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2732             }
2733             else {
2734                 if (diff > 0)
2735                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2736                                    (long)tfirst, (long)(tfirst + diff),
2737                                    (long)rfirst);
2738                 else
2739                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2740                                    (long)tfirst, (long)rfirst);
2741
2742                 if (rfirst + diff > max)
2743                     max = rfirst + diff;
2744                 rfirst += diff + 1;
2745                 if (!grows) {
2746                     if (rfirst <= 0x80)
2747                         ;
2748                     else if (rfirst <= 0x800)
2749                         grows |= (tfirst < 0x80);
2750                     else if (rfirst <= 0x10000)
2751                         grows |= (tfirst < 0x800);
2752                     else if (rfirst <= 0x200000)
2753                         grows |= (tfirst < 0x10000);
2754                     else if (rfirst <= 0x4000000)
2755                         grows |= (tfirst < 0x200000);
2756                     else if (rfirst <= 0x80000000)
2757                         grows |= (tfirst < 0x4000000);
2758                 }
2759             }
2760             tfirst += diff + 1;
2761         }
2762
2763         none = ++max;
2764         if (del)
2765             del = ++max;
2766
2767         if (max > 0xffff)
2768             bits = 32;
2769         else if (max > 0xff)
2770             bits = 16;
2771         else
2772             bits = 8;
2773
2774         cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2775         SvREFCNT_dec(listsv);
2776         if (transv)
2777             SvREFCNT_dec(transv);
2778
2779         if (!del && havefinal)
2780             (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2781                            newSVuv((UV)final), 0);
2782
2783         if (grows && to_utf)
2784             o->op_private |= OPpTRANS_GROWS;
2785
2786         op_free(expr);
2787         op_free(repl);
2788         return o;
2789     }
2790
2791     tbl = (short*)cPVOPo->op_pv;
2792     if (complement) {
2793         Zero(tbl, 256, short);
2794         for (i = 0; i < tlen; i++)
2795             tbl[t[i]] = -1;
2796         for (i = 0, j = 0; i < 256; i++) {
2797             if (!tbl[i]) {
2798                 if (j >= rlen) {
2799                     if (del)
2800                         tbl[i] = -2;
2801                     else if (rlen)
2802                         tbl[i] = r[j-1];
2803                     else
2804                         tbl[i] = i;
2805                 }
2806                 else
2807                     tbl[i] = r[j++];
2808             }
2809         }
2810     }
2811     else {
2812         if (!rlen && !del) {
2813             r = t; rlen = tlen;
2814             if (!squash)
2815                 o->op_private |= OPpTRANS_IDENTICAL;
2816         }
2817         for (i = 0; i < 256; i++)
2818             tbl[i] = -1;
2819         for (i = 0, j = 0; i < tlen; i++,j++) {
2820             if (j >= rlen) {
2821                 if (del) {
2822                     if (tbl[t[i]] == -1)
2823                         tbl[t[i]] = -2;
2824                     continue;
2825                 }
2826                 --j;
2827             }
2828             if (tbl[t[i]] == -1)
2829                 tbl[t[i]] = r[j];
2830         }
2831     }
2832     op_free(expr);
2833     op_free(repl);
2834
2835     return o;
2836 }
2837
2838 OP *
2839 Perl_newPMOP(pTHX_ I32 type, I32 flags)
2840 {
2841     PMOP *pmop;
2842
2843     NewOp(1101, pmop, 1, PMOP);
2844     pmop->op_type = type;
2845     pmop->op_ppaddr = PL_ppaddr[type];
2846     pmop->op_flags = flags;
2847     pmop->op_private = 0 | (flags >> 8);
2848
2849     if (PL_hints & HINT_RE_TAINT)
2850         pmop->op_pmpermflags |= PMf_RETAINT;
2851     if (PL_hints & HINT_LOCALE)
2852         pmop->op_pmpermflags |= PMf_LOCALE;
2853     pmop->op_pmflags = pmop->op_pmpermflags;
2854
2855     /* link into pm list */
2856     if (type != OP_TRANS && PL_curstash) {
2857         pmop->op_pmnext = HvPMROOT(PL_curstash);
2858         HvPMROOT(PL_curstash) = pmop;
2859     }
2860
2861     return (OP*)pmop;
2862 }
2863
2864 OP *
2865 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl)
2866 {
2867     PMOP *pm;
2868     LOGOP *rcop;
2869     I32 repl_has_vars = 0;
2870
2871     if (o->op_type == OP_TRANS)
2872         return pmtrans(o, expr, repl);
2873
2874     PL_hints |= HINT_BLOCK_SCOPE;
2875     pm = (PMOP*)o;
2876
2877     if (expr->op_type == OP_CONST) {
2878         STRLEN plen;
2879         SV *pat = ((SVOP*)expr)->op_sv;
2880         char *p = SvPV(pat, plen);
2881         if ((o->op_flags & OPf_SPECIAL) && strEQ(p, " ")) {
2882             sv_setpvn(pat, "\\s+", 3);
2883             p = SvPV(pat, plen);
2884             pm->op_pmflags |= PMf_SKIPWHITE;
2885         }
2886         if ((PL_hints & HINT_UTF8) || DO_UTF8(pat))
2887             pm->op_pmdynflags |= PMdf_UTF8;
2888         pm->op_pmregexp = CALLREGCOMP(aTHX_ p, p + plen, pm);
2889         if (strEQ("\\s+", pm->op_pmregexp->precomp))
2890             pm->op_pmflags |= PMf_WHITE;
2891         op_free(expr);
2892     }
2893     else {
2894         if (PL_hints & HINT_UTF8)
2895             pm->op_pmdynflags |= PMdf_UTF8;
2896         if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
2897             expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
2898                             ? OP_REGCRESET
2899                             : OP_REGCMAYBE),0,expr);
2900
2901         NewOp(1101, rcop, 1, LOGOP);
2902         rcop->op_type = OP_REGCOMP;
2903         rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
2904         rcop->op_first = scalar(expr);
2905         rcop->op_flags |= ((PL_hints & HINT_RE_EVAL)
2906                            ? (OPf_SPECIAL | OPf_KIDS)
2907                            : OPf_KIDS);
2908         rcop->op_private = 1;
2909         rcop->op_other = o;
2910
2911         /* establish postfix order */
2912         if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
2913             LINKLIST(expr);
2914             rcop->op_next = expr;
2915             ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
2916         }
2917         else {
2918             rcop->op_next = LINKLIST(expr);
2919             expr->op_next = (OP*)rcop;
2920         }
2921
2922         prepend_elem(o->op_type, scalar((OP*)rcop), o);
2923     }
2924
2925     if (repl) {
2926         OP *curop;
2927         if (pm->op_pmflags & PMf_EVAL) {
2928             curop = 0;
2929             if (CopLINE(PL_curcop) < PL_multi_end)
2930                 CopLINE_set(PL_curcop, PL_multi_end);
2931         }
2932 #ifdef USE_THREADS
2933         else if (repl->op_type == OP_THREADSV
2934                  && strchr("&`'123456789+",
2935                            PL_threadsv_names[repl->op_targ]))
2936         {
2937             curop = 0;
2938         }
2939 #endif /* USE_THREADS */
2940         else if (repl->op_type == OP_CONST)
2941             curop = repl;
2942         else {
2943             OP *lastop = 0;
2944             for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
2945                 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
2946 #ifdef USE_THREADS
2947                     if (curop->op_type == OP_THREADSV) {
2948                         repl_has_vars = 1;
2949                         if (strchr("&`'123456789+", curop->op_private))
2950                             break;
2951                     }
2952 #else
2953                     if (curop->op_type == OP_GV) {
2954                         GV *gv = cGVOPx_gv(curop);
2955                         repl_has_vars = 1;
2956                         if (strchr("&`'123456789+", *GvENAME(gv)))
2957                             break;
2958                     }
2959 #endif /* USE_THREADS */
2960                     else if (curop->op_type == OP_RV2CV)
2961                         break;
2962                     else if (curop->op_type == OP_RV2SV ||
2963                              curop->op_type == OP_RV2AV ||
2964                              curop->op_type == OP_RV2HV ||
2965                              curop->op_type == OP_RV2GV) {
2966                         if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
2967                             break;
2968                     }
2969                     else if (curop->op_type == OP_PADSV ||
2970                              curop->op_type == OP_PADAV ||
2971                              curop->op_type == OP_PADHV ||
2972                              curop->op_type == OP_PADANY) {
2973                         repl_has_vars = 1;
2974                     }
2975                     else if (curop->op_type == OP_PUSHRE)
2976                         ; /* Okay here, dangerous in newASSIGNOP */
2977                     else
2978                         break;
2979                 }
2980                 lastop = curop;
2981             }
2982         }
2983         if (curop == repl
2984             && !(repl_has_vars
2985                  && (!pm->op_pmregexp
2986                      || pm->op_pmregexp->reganch & ROPT_EVAL_SEEN))) {
2987             pm->op_pmflags |= PMf_CONST;        /* const for long enough */
2988             pm->op_pmpermflags |= PMf_CONST;    /* const for long enough */
2989             prepend_elem(o->op_type, scalar(repl), o);
2990         }
2991         else {
2992             if (curop == repl && !pm->op_pmregexp) { /* Has variables. */
2993                 pm->op_pmflags |= PMf_MAYBE_CONST;
2994                 pm->op_pmpermflags |= PMf_MAYBE_CONST;
2995             }
2996             NewOp(1101, rcop, 1, LOGOP);
2997             rcop->op_type = OP_SUBSTCONT;
2998             rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
2999             rcop->op_first = scalar(repl);
3000             rcop->op_flags |= OPf_KIDS;
3001             rcop->op_private = 1;
3002             rcop->op_other = o;
3003
3004             /* establish postfix order */
3005             rcop->op_next = LINKLIST(repl);
3006             repl->op_next = (OP*)rcop;
3007
3008             pm->op_pmreplroot = scalar((OP*)rcop);
3009             pm->op_pmreplstart = LINKLIST(rcop);
3010             rcop->op_next = 0;
3011         }
3012     }
3013
3014     return (OP*)pm;
3015 }
3016
3017 OP *
3018 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3019 {
3020     SVOP *svop;
3021     NewOp(1101, svop, 1, SVOP);
3022     svop->op_type = type;
3023     svop->op_ppaddr = PL_ppaddr[type];
3024     svop->op_sv = sv;
3025     svop->op_next = (OP*)svop;
3026     svop->op_flags = flags;
3027     if (PL_opargs[type] & OA_RETSCALAR)
3028         scalar((OP*)svop);
3029     if (PL_opargs[type] & OA_TARGET)
3030         svop->op_targ = pad_alloc(type, SVs_PADTMP);
3031     return CHECKOP(type, svop);
3032 }
3033
3034 OP *
3035 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3036 {
3037     PADOP *padop;
3038     NewOp(1101, padop, 1, PADOP);
3039     padop->op_type = type;
3040     padop->op_ppaddr = PL_ppaddr[type];
3041     padop->op_padix = pad_alloc(type, SVs_PADTMP);
3042     SvREFCNT_dec(PL_curpad[padop->op_padix]);
3043     PL_curpad[padop->op_padix] = sv;
3044     SvPADTMP_on(sv);
3045     padop->op_next = (OP*)padop;
3046     padop->op_flags = flags;
3047     if (PL_opargs[type] & OA_RETSCALAR)
3048         scalar((OP*)padop);
3049     if (PL_opargs[type] & OA_TARGET)
3050         padop->op_targ = pad_alloc(type, SVs_PADTMP);
3051     return CHECKOP(type, padop);
3052 }
3053
3054 OP *
3055 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3056 {
3057 #ifdef USE_ITHREADS
3058     GvIN_PAD_on(gv);
3059     return newPADOP(type, flags, SvREFCNT_inc(gv));
3060 #else
3061     return newSVOP(type, flags, SvREFCNT_inc(gv));
3062 #endif
3063 }
3064
3065 OP *
3066 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3067 {
3068     PVOP *pvop;
3069     NewOp(1101, pvop, 1, PVOP);
3070     pvop->op_type = type;
3071     pvop->op_ppaddr = PL_ppaddr[type];
3072     pvop->op_pv = pv;
3073     pvop->op_next = (OP*)pvop;
3074     pvop->op_flags = flags;
3075     if (PL_opargs[type] & OA_RETSCALAR)
3076         scalar((OP*)pvop);
3077     if (PL_opargs[type] & OA_TARGET)
3078         pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3079     return CHECKOP(type, pvop);
3080 }
3081
3082 void
3083 Perl_package(pTHX_ OP *o)
3084 {
3085     SV *sv;
3086
3087     save_hptr(&PL_curstash);
3088     save_item(PL_curstname);
3089     if (o) {
3090         STRLEN len;
3091         char *name;
3092         sv = cSVOPo->op_sv;
3093         name = SvPV(sv, len);
3094         PL_curstash = gv_stashpvn(name,len,TRUE);
3095         sv_setpvn(PL_curstname, name, len);
3096         op_free(o);
3097     }
3098     else {
3099         sv_setpv(PL_curstname,"<none>");
3100         PL_curstash = Nullhv;
3101     }
3102     PL_hints |= HINT_BLOCK_SCOPE;
3103     PL_copline = NOLINE;
3104     PL_expect = XSTATE;
3105 }
3106
3107 void
3108 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg)
3109 {
3110     OP *pack;
3111     OP *rqop;
3112     OP *imop;
3113     OP *veop;
3114     GV *gv;
3115
3116     if (id->op_type != OP_CONST)
3117         Perl_croak(aTHX_ "Module name must be constant");
3118
3119     veop = Nullop;
3120
3121     if (version != Nullop) {
3122         SV *vesv = ((SVOP*)version)->op_sv;
3123
3124         if (arg == Nullop && !SvNIOKp(vesv)) {
3125             arg = version;
3126         }
3127         else {
3128             OP *pack;
3129             SV *meth;
3130
3131             if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3132                 Perl_croak(aTHX_ "Version number must be constant number");
3133
3134             /* Make copy of id so we don't free it twice */
3135             pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3136
3137             /* Fake up a method call to VERSION */
3138             meth = newSVpvn("VERSION",7);
3139             sv_upgrade(meth, SVt_PVIV);
3140             (void)SvIOK_on(meth);
3141             PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3142             veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3143                             append_elem(OP_LIST,
3144                                         prepend_elem(OP_LIST, pack, list(version)),
3145                                         newSVOP(OP_METHOD_NAMED, 0, meth)));
3146         }
3147     }
3148
3149     /* Fake up an import/unimport */
3150     if (arg && arg->op_type == OP_STUB)
3151         imop = arg;             /* no import on explicit () */
3152     else if (SvNIOKp(((SVOP*)id)->op_sv)) {
3153         imop = Nullop;          /* use 5.0; */
3154     }
3155     else {
3156         SV *meth;
3157
3158         /* Make copy of id so we don't free it twice */
3159         pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3160
3161         /* Fake up a method call to import/unimport */
3162         meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);;
3163         sv_upgrade(meth, SVt_PVIV);
3164         (void)SvIOK_on(meth);
3165         PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3166         imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3167                        append_elem(OP_LIST,
3168                                    prepend_elem(OP_LIST, pack, list(arg)),
3169                                    newSVOP(OP_METHOD_NAMED, 0, meth)));
3170     }
3171
3172     /* Fake up a require, handle override, if any */
3173     gv = gv_fetchpv("require", FALSE, SVt_PVCV);
3174     if (!(gv && GvIMPORTED_CV(gv)))
3175         gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
3176
3177     if (gv && GvIMPORTED_CV(gv)) {
3178         rqop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3179                                append_elem(OP_LIST, id,
3180                                            scalar(newUNOP(OP_RV2CV, 0,
3181                                                           newGVOP(OP_GV, 0,
3182                                                                   gv))))));
3183     }
3184     else {
3185         rqop = newUNOP(OP_REQUIRE, 0, id);
3186     }
3187
3188     /* Fake up the BEGIN {}, which does its thing immediately. */
3189     newATTRSUB(floor,
3190         newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
3191         Nullop,
3192         Nullop,
3193         append_elem(OP_LINESEQ,
3194             append_elem(OP_LINESEQ,
3195                 newSTATEOP(0, Nullch, rqop),
3196                 newSTATEOP(0, Nullch, veop)),
3197             newSTATEOP(0, Nullch, imop) ));
3198
3199     PL_hints |= HINT_BLOCK_SCOPE;
3200     PL_copline = NOLINE;
3201     PL_expect = XSTATE;
3202 }
3203
3204 void
3205 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3206 {
3207     va_list args;
3208     va_start(args, ver);
3209     vload_module(flags, name, ver, &args);
3210     va_end(args);
3211 }
3212
3213 #ifdef PERL_IMPLICIT_CONTEXT
3214 void
3215 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3216 {
3217     dTHX;
3218     va_list args;
3219     va_start(args, ver);
3220     vload_module(flags, name, ver, &args);
3221     va_end(args);
3222 }
3223 #endif
3224
3225 void
3226 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3227 {
3228     OP *modname, *veop, *imop;
3229
3230     modname = newSVOP(OP_CONST, 0, name);
3231     modname->op_private |= OPpCONST_BARE;
3232     if (ver) {
3233         veop = newSVOP(OP_CONST, 0, ver);
3234     }
3235     else
3236         veop = Nullop;
3237     if (flags & PERL_LOADMOD_NOIMPORT) {
3238         imop = sawparens(newNULLLIST());
3239     }
3240     else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3241         imop = va_arg(*args, OP*);
3242     }
3243     else {
3244         SV *sv;
3245         imop = Nullop;
3246         sv = va_arg(*args, SV*);
3247         while (sv) {
3248             imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3249             sv = va_arg(*args, SV*);
3250         }
3251     }
3252     {
3253         line_t ocopline = PL_copline;
3254         int oexpect = PL_expect;
3255
3256         utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3257                 veop, modname, imop);
3258         PL_expect = oexpect;
3259         PL_copline = ocopline;
3260     }
3261 }
3262
3263 OP *
3264 Perl_dofile(pTHX_ OP *term)
3265 {
3266     OP *doop;
3267     GV *gv;
3268
3269     gv = gv_fetchpv("do", FALSE, SVt_PVCV);
3270     if (!(gv && GvIMPORTED_CV(gv)))
3271         gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3272
3273     if (gv && GvIMPORTED_CV(gv)) {
3274         doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3275                                append_elem(OP_LIST, term,
3276                                            scalar(newUNOP(OP_RV2CV, 0,
3277                                                           newGVOP(OP_GV, 0,
3278                                                                   gv))))));
3279     }
3280     else {
3281         doop = newUNOP(OP_DOFILE, 0, scalar(term));
3282     }
3283     return doop;
3284 }
3285
3286 OP *
3287 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3288 {
3289     return newBINOP(OP_LSLICE, flags,
3290             list(force_list(subscript)),
3291             list(force_list(listval)) );
3292 }
3293
3294 STATIC I32
3295 S_list_assignment(pTHX_ register OP *o)
3296 {
3297     if (!o)
3298         return TRUE;
3299
3300     if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3301         o = cUNOPo->op_first;
3302
3303     if (o->op_type == OP_COND_EXPR) {
3304         I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3305         I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3306
3307         if (t && f)
3308             return TRUE;
3309         if (t || f)
3310             yyerror("Assignment to both a list and a scalar");
3311         return FALSE;
3312     }
3313
3314     if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3315         o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3316         o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3317         return TRUE;
3318
3319     if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3320         return TRUE;
3321
3322     if (o->op_type == OP_RV2SV)
3323         return FALSE;
3324
3325     return FALSE;
3326 }
3327
3328 OP *
3329 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3330 {
3331     OP *o;
3332
3333     if (optype) {
3334         if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN) {
3335             return newLOGOP(optype, 0,
3336                 mod(scalar(left), optype),
3337                 newUNOP(OP_SASSIGN, 0, scalar(right)));
3338         }
3339         else {
3340             return newBINOP(optype, OPf_STACKED,
3341                 mod(scalar(left), optype), scalar(right));
3342         }
3343     }
3344
3345     if (list_assignment(left)) {
3346         OP *curop;
3347
3348         PL_modcount = 0;
3349         PL_eval_start = right;  /* Grandfathering $[ assignment here.  Bletch.*/
3350         left = mod(left, OP_AASSIGN);
3351         if (PL_eval_start)
3352             PL_eval_start = 0;
3353         else {
3354             op_free(left);
3355             op_free(right);
3356             return Nullop;
3357         }
3358         curop = list(force_list(left));
3359         o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3360         o->op_private = 0 | (flags >> 8);
3361         for (curop = ((LISTOP*)curop)->op_first;
3362              curop; curop = curop->op_sibling)
3363         {
3364             if (curop->op_type == OP_RV2HV &&
3365                 ((UNOP*)curop)->op_first->op_type != OP_GV) {
3366                 o->op_private |= OPpASSIGN_HASH;
3367                 break;
3368             }
3369         }
3370         if (!(left->op_private & OPpLVAL_INTRO)) {
3371             OP *lastop = o;
3372             PL_generation++;
3373             for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3374                 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3375                     if (curop->op_type == OP_GV) {
3376                         GV *gv = cGVOPx_gv(curop);
3377                         if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3378                             break;
3379                         SvCUR(gv) = PL_generation;
3380                     }
3381                     else if (curop->op_type == OP_PADSV ||
3382                              curop->op_type == OP_PADAV ||
3383                              curop->op_type == OP_PADHV ||
3384                              curop->op_type == OP_PADANY) {
3385                         SV **svp = AvARRAY(PL_comppad_name);
3386                         SV *sv = svp[curop->op_targ];
3387                         if (SvCUR(sv) == PL_generation)
3388                             break;
3389                         SvCUR(sv) = PL_generation;      /* (SvCUR not used any more) */
3390                     }
3391                     else if (curop->op_type == OP_RV2CV)
3392                         break;
3393                     else if (curop->op_type == OP_RV2SV ||
3394                              curop->op_type == OP_RV2AV ||
3395                              curop->op_type == OP_RV2HV ||
3396                              curop->op_type == OP_RV2GV) {
3397                         if (lastop->op_type != OP_GV)   /* funny deref? */
3398                             break;
3399                     }
3400                     else if (curop->op_type == OP_PUSHRE) {
3401                         if (((PMOP*)curop)->op_pmreplroot) {
3402 #ifdef USE_ITHREADS
3403                             GV *gv = (GV*)PL_curpad[(PADOFFSET)((PMOP*)curop)->op_pmreplroot];
3404 #else
3405                             GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3406 #endif
3407                             if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3408                                 break;
3409                             SvCUR(gv) = PL_generation;
3410                         }
3411                     }
3412                     else
3413                         break;
3414                 }
3415                 lastop = curop;
3416             }
3417             if (curop != o)
3418                 o->op_private |= OPpASSIGN_COMMON;
3419         }
3420         if (right && right->op_type == OP_SPLIT) {
3421             OP* tmpop;
3422             if ((tmpop = ((LISTOP*)right)->op_first) &&
3423                 tmpop->op_type == OP_PUSHRE)
3424             {
3425                 PMOP *pm = (PMOP*)tmpop;
3426                 if (left->op_type == OP_RV2AV &&
3427                     !(left->op_private & OPpLVAL_INTRO) &&
3428                     !(o->op_private & OPpASSIGN_COMMON) )
3429                 {
3430                     tmpop = ((UNOP*)left)->op_first;
3431                     if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3432 #ifdef USE_ITHREADS
3433                         pm->op_pmreplroot = (OP*)cPADOPx(tmpop)->op_padix;
3434                         cPADOPx(tmpop)->op_padix = 0;   /* steal it */
3435 #else
3436                         pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3437                         cSVOPx(tmpop)->op_sv = Nullsv;  /* steal it */
3438 #endif
3439                         pm->op_pmflags |= PMf_ONCE;
3440                         tmpop = cUNOPo->op_first;       /* to list (nulled) */
3441                         tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3442                         tmpop->op_sibling = Nullop;     /* don't free split */
3443                         right->op_next = tmpop->op_next;  /* fix starting loc */
3444                         op_free(o);                     /* blow off assign */
3445                         right->op_flags &= ~OPf_WANT;
3446                                 /* "I don't know and I don't care." */
3447                         return right;
3448                     }
3449                 }
3450                 else {
3451                     if (PL_modcount < 10000 &&
3452                       ((LISTOP*)right)->op_last->op_type == OP_CONST)
3453                     {
3454                         SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3455                         if (SvIVX(sv) == 0)
3456                             sv_setiv(sv, PL_modcount+1);
3457                     }
3458                 }
3459             }
3460         }
3461         return o;
3462     }
3463     if (!right)
3464         right = newOP(OP_UNDEF, 0);
3465     if (right->op_type == OP_READLINE) {
3466         right->op_flags |= OPf_STACKED;
3467         return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3468     }
3469     else {
3470         PL_eval_start = right;  /* Grandfathering $[ assignment here.  Bletch.*/
3471         o = newBINOP(OP_SASSIGN, flags,
3472             scalar(right), mod(scalar(left), OP_SASSIGN) );
3473         if (PL_eval_start)
3474             PL_eval_start = 0;
3475         else {
3476             op_free(o);
3477             return Nullop;
3478         }
3479     }
3480     return o;
3481 }
3482
3483 OP *
3484 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3485 {
3486     U32 seq = intro_my();
3487     register COP *cop;
3488
3489     NewOp(1101, cop, 1, COP);
3490     if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3491         cop->op_type = OP_DBSTATE;
3492         cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3493     }
3494     else {
3495         cop->op_type = OP_NEXTSTATE;
3496         cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3497     }
3498     cop->op_flags = flags;
3499     cop->op_private = (PL_hints & HINT_BYTE);
3500 #ifdef NATIVE_HINTS
3501     cop->op_private |= NATIVE_HINTS;
3502 #endif
3503     PL_compiling.op_private = cop->op_private;
3504     cop->op_next = (OP*)cop;
3505
3506     if (label) {
3507         cop->cop_label = label;
3508         PL_hints |= HINT_BLOCK_SCOPE;
3509     }
3510     cop->cop_seq = seq;
3511     cop->cop_arybase = PL_curcop->cop_arybase;
3512     if (specialWARN(PL_curcop->cop_warnings))
3513         cop->cop_warnings = PL_curcop->cop_warnings ;
3514     else
3515         cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3516     if (specialCopIO(PL_curcop->cop_io))
3517         cop->cop_io = PL_curcop->cop_io;
3518     else
3519         cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3520
3521
3522     if (PL_copline == NOLINE)
3523         CopLINE_set(cop, CopLINE(PL_curcop));
3524     else {
3525         CopLINE_set(cop, PL_copline);
3526         PL_copline = NOLINE;
3527     }
3528 #ifdef USE_ITHREADS
3529     CopFILE_set(cop, CopFILE(PL_curcop));       /* XXX share in a pvtable? */
3530 #else
3531     CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3532 #endif
3533     CopSTASH_set(cop, PL_curstash);
3534
3535     if (PERLDB_LINE && PL_curstash != PL_debstash) {
3536         SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3537         if (svp && *svp != &PL_sv_undef && !SvIOK(*svp)) {
3538             (void)SvIOK_on(*svp);
3539             SvIVX(*svp) = PTR2IV(cop);
3540         }
3541     }
3542
3543     return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3544 }
3545
3546 /* "Introduce" my variables to visible status. */
3547 U32
3548 Perl_intro_my(pTHX)
3549 {
3550     SV **svp;
3551     SV *sv;
3552     I32 i;
3553
3554     if (! PL_min_intro_pending)
3555         return PL_cop_seqmax;
3556
3557     svp = AvARRAY(PL_comppad_name);
3558     for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
3559         if ((sv = svp[i]) && sv != &PL_sv_undef && !SvIVX(sv)) {
3560             SvIVX(sv) = PAD_MAX;        /* Don't know scope end yet. */
3561             SvNVX(sv) = (NV)PL_cop_seqmax;
3562         }
3563     }
3564     PL_min_intro_pending = 0;
3565     PL_comppad_name_fill = PL_max_intro_pending;        /* Needn't search higher */
3566     return PL_cop_seqmax++;
3567 }
3568
3569 OP *
3570 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3571 {
3572     return new_logop(type, flags, &first, &other);
3573 }
3574
3575 STATIC OP *
3576 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3577 {
3578     LOGOP *logop;
3579     OP *o;
3580     OP *first = *firstp;
3581     OP *other = *otherp;
3582
3583     if (type == OP_XOR)         /* Not short circuit, but here by precedence. */
3584         return newBINOP(type, flags, scalar(first), scalar(other));
3585
3586     scalarboolean(first);
3587     /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3588     if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3589         if (type == OP_AND || type == OP_OR) {
3590             if (type == OP_AND)
3591                 type = OP_OR;
3592             else
3593                 type = OP_AND;
3594             o = first;
3595             first = *firstp = cUNOPo->op_first;
3596             if (o->op_next)
3597                 first->op_next = o->op_next;
3598             cUNOPo->op_first = Nullop;
3599             op_free(o);
3600         }
3601     }
3602     if (first->op_type == OP_CONST) {
3603         if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
3604             Perl_warner(aTHX_ WARN_BAREWORD, "Bareword found in conditional");
3605         if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
3606             op_free(first);
3607             *firstp = Nullop;
3608             return other;
3609         }
3610         else {
3611             op_free(other);
3612             *otherp = Nullop;
3613             return first;
3614         }
3615     }
3616     else if (first->op_type == OP_WANTARRAY) {
3617         if (type == OP_AND)
3618             list(other);
3619         else
3620             scalar(other);
3621     }
3622     else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS)) {
3623         OP *k1 = ((UNOP*)first)->op_first;
3624         OP *k2 = k1->op_sibling;
3625         OPCODE warnop = 0;
3626         switch (first->op_type)
3627         {
3628         case OP_NULL:
3629             if (k2 && k2->op_type == OP_READLINE
3630                   && (k2->op_flags & OPf_STACKED)
3631                   && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3632             {
3633                 warnop = k2->op_type;
3634             }
3635             break;
3636
3637         case OP_SASSIGN:
3638             if (k1->op_type == OP_READDIR
3639                   || k1->op_type == OP_GLOB
3640                   || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3641                   || k1->op_type == OP_EACH)
3642             {
3643                 warnop = ((k1->op_type == OP_NULL)
3644                           ? k1->op_targ : k1->op_type);
3645             }
3646             break;
3647         }
3648         if (warnop) {
3649             line_t oldline = CopLINE(PL_curcop);
3650             CopLINE_set(PL_curcop, PL_copline);
3651             Perl_warner(aTHX_ WARN_MISC,
3652                  "Value of %s%s can be \"0\"; test with defined()",
3653                  PL_op_desc[warnop],
3654                  ((warnop == OP_READLINE || warnop == OP_GLOB)
3655                   ? " construct" : "() operator"));
3656             CopLINE_set(PL_curcop, oldline);
3657         }
3658     }
3659
3660     if (!other)
3661         return first;
3662
3663     if (type == OP_ANDASSIGN || type == OP_ORASSIGN)
3664         other->op_private |= OPpASSIGN_BACKWARDS;  /* other is an OP_SASSIGN */
3665
3666     NewOp(1101, logop, 1, LOGOP);
3667
3668     logop->op_type = type;
3669     logop->op_ppaddr = PL_ppaddr[type];
3670     logop->op_first = first;
3671     logop->op_flags = flags | OPf_KIDS;
3672     logop->op_other = LINKLIST(other);
3673     logop->op_private = 1 | (flags >> 8);
3674
3675     /* establish postfix order */
3676     logop->op_next = LINKLIST(first);
3677     first->op_next = (OP*)logop;
3678     first->op_sibling = other;
3679
3680     o = newUNOP(OP_NULL, 0, (OP*)logop);
3681     other->op_next = o;
3682
3683     return o;
3684 }
3685
3686 OP *
3687 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3688 {
3689     LOGOP *logop;
3690     OP *start;
3691     OP *o;
3692
3693     if (!falseop)
3694         return newLOGOP(OP_AND, 0, first, trueop);
3695     if (!trueop)
3696         return newLOGOP(OP_OR, 0, first, falseop);
3697
3698     scalarboolean(first);
3699     if (first->op_type == OP_CONST) {
3700         if (SvTRUE(((SVOP*)first)->op_sv)) {
3701             op_free(first);
3702             op_free(falseop);
3703             return trueop;
3704         }
3705         else {
3706             op_free(first);
3707             op_free(trueop);
3708             return falseop;
3709         }
3710     }
3711     else if (first->op_type == OP_WANTARRAY) {
3712         list(trueop);
3713         scalar(falseop);
3714     }
3715     NewOp(1101, logop, 1, LOGOP);
3716     logop->op_type = OP_COND_EXPR;
3717     logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3718     logop->op_first = first;
3719     logop->op_flags = flags | OPf_KIDS;
3720     logop->op_private = 1 | (flags >> 8);
3721     logop->op_other = LINKLIST(trueop);
3722     logop->op_next = LINKLIST(falseop);
3723
3724
3725     /* establish postfix order */
3726     start = LINKLIST(first);
3727     first->op_next = (OP*)logop;
3728
3729     first->op_sibling = trueop;
3730     trueop->op_sibling = falseop;
3731     o = newUNOP(OP_NULL, 0, (OP*)logop);
3732
3733     trueop->op_next = falseop->op_next = o;
3734
3735     o->op_next = start;
3736     return o;
3737 }
3738
3739 OP *
3740 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3741 {
3742     LOGOP *range;
3743     OP *flip;
3744     OP *flop;
3745     OP *leftstart;
3746     OP *o;
3747
3748     NewOp(1101, range, 1, LOGOP);
3749
3750     range->op_type = OP_RANGE;
3751     range->op_ppaddr = PL_ppaddr[OP_RANGE];
3752     range->op_first = left;
3753     range->op_flags = OPf_KIDS;
3754     leftstart = LINKLIST(left);
3755     range->op_other = LINKLIST(right);
3756     range->op_private = 1 | (flags >> 8);
3757
3758     left->op_sibling = right;
3759
3760     range->op_next = (OP*)range;
3761     flip = newUNOP(OP_FLIP, flags, (OP*)range);
3762     flop = newUNOP(OP_FLOP, 0, flip);
3763     o = newUNOP(OP_NULL, 0, flop);
3764     linklist(flop);
3765     range->op_next = leftstart;
3766
3767     left->op_next = flip;
3768     right->op_next = flop;
3769
3770     range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3771     sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3772     flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3773     sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3774
3775     flip->op_private =  left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3776     flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3777
3778     flip->op_next = o;
3779     if (!flip->op_private || !flop->op_private)
3780         linklist(o);            /* blow off optimizer unless constant */
3781
3782     return o;
3783 }
3784
3785 OP *
3786 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3787 {
3788     OP* listop;
3789     OP* o;
3790     int once = block && block->op_flags & OPf_SPECIAL &&
3791       (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3792
3793     if (expr) {
3794         if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3795             return block;       /* do {} while 0 does once */
3796         if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3797             || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3798             expr = newUNOP(OP_DEFINED, 0,
3799                 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3800         } else if (expr->op_flags & OPf_KIDS) {
3801             OP *k1 = ((UNOP*)expr)->op_first;
3802             OP *k2 = (k1) ? k1->op_sibling : NULL;
3803             switch (expr->op_type) {
3804               case OP_NULL:
3805                 if (k2 && k2->op_type == OP_READLINE
3806                       && (k2->op_flags & OPf_STACKED)
3807                       && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3808                     expr = newUNOP(OP_DEFINED, 0, expr);
3809                 break;
3810
3811               case OP_SASSIGN:
3812                 if (k1->op_type == OP_READDIR
3813                       || k1->op_type == OP_GLOB
3814                       || (k1->op_type == OP_NULL && k1->op_targ == OP_NULL)
3815                       || k1->op_type == OP_EACH)
3816                     expr = newUNOP(OP_DEFINED, 0, expr);
3817                 break;
3818             }
3819         }
3820     }
3821
3822     listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3823     o = new_logop(OP_AND, 0, &expr, &listop);
3824
3825     if (listop)
3826         ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3827
3828     if (once && o != listop)
3829         o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3830
3831     if (o == listop)
3832         o = newUNOP(OP_NULL, 0, o);     /* or do {} while 1 loses outer block */
3833
3834     o->op_flags |= flags;
3835     o = scope(o);
3836     o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3837     return o;
3838 }
3839
3840 OP *
3841 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
3842 {
3843     OP *redo;
3844     OP *next = 0;
3845     OP *listop;
3846     OP *o;
3847     OP *condop;
3848     U8 loopflags = 0;
3849
3850     if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3851                  || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
3852         expr = newUNOP(OP_DEFINED, 0,
3853             newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3854     } else if (expr && (expr->op_flags & OPf_KIDS)) {
3855         OP *k1 = ((UNOP*)expr)->op_first;
3856         OP *k2 = (k1) ? k1->op_sibling : NULL;
3857         switch (expr->op_type) {
3858           case OP_NULL:
3859             if (k2 && k2->op_type == OP_READLINE
3860                   && (k2->op_flags & OPf_STACKED)
3861                   && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3862                 expr = newUNOP(OP_DEFINED, 0, expr);
3863             break;
3864
3865           case OP_SASSIGN:
3866             if (k1->op_type == OP_READDIR
3867                   || k1->op_type == OP_GLOB
3868                   || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3869                   || k1->op_type == OP_EACH)
3870                 expr = newUNOP(OP_DEFINED, 0, expr);
3871             break;
3872         }
3873     }
3874
3875     if (!block)
3876         block = newOP(OP_NULL, 0);
3877     else if (cont) {
3878         block = scope(block);
3879     }
3880
3881     if (cont) {
3882         next = LINKLIST(cont);
3883         loopflags |= OPpLOOP_CONTINUE;
3884     }
3885     if (expr) {
3886         OP *unstack = newOP(OP_UNSTACK, 0);
3887         if (!next)
3888             next = unstack;
3889         cont = append_elem(OP_LINESEQ, cont, unstack);
3890         if ((line_t)whileline != NOLINE) {
3891             PL_copline = whileline;
3892             cont = append_elem(OP_LINESEQ, cont,
3893                                newSTATEOP(0, Nullch, Nullop));
3894         }
3895     }
3896
3897     listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
3898     redo = LINKLIST(listop);
3899
3900     if (expr) {
3901         PL_copline = whileline;
3902         scalar(listop);
3903         o = new_logop(OP_AND, 0, &expr, &listop);
3904         if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
3905             op_free(expr);              /* oops, it's a while (0) */
3906             op_free((OP*)loop);
3907             return Nullop;              /* listop already freed by new_logop */
3908         }
3909         if (listop)
3910             ((LISTOP*)listop)->op_last->op_next = condop =
3911                 (o == listop ? redo : LINKLIST(o));
3912     }
3913     else
3914         o = listop;
3915
3916     if (!loop) {
3917         NewOp(1101,loop,1,LOOP);
3918         loop->op_type = OP_ENTERLOOP;
3919         loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
3920         loop->op_private = 0;
3921         loop->op_next = (OP*)loop;
3922     }
3923
3924     o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
3925
3926     loop->op_redoop = redo;
3927     loop->op_lastop = o;
3928     o->op_private |= loopflags;
3929
3930     if (next)
3931         loop->op_nextop = next;
3932     else
3933         loop->op_nextop = o;
3934
3935     o->op_flags |= flags;
3936     o->op_private |= (flags >> 8);
3937     return o;
3938 }
3939
3940 OP *
3941 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
3942 {
3943     LOOP *loop;
3944     OP *wop;
3945     int padoff = 0;
3946     I32 iterflags = 0;
3947
3948     if (sv) {
3949         if (sv->op_type == OP_RV2SV) {  /* symbol table variable */
3950             sv->op_type = OP_RV2GV;
3951             sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
3952         }
3953         else if (sv->op_type == OP_PADSV) { /* private variable */
3954             padoff = sv->op_targ;
3955             sv->op_targ = 0;
3956             op_free(sv);
3957             sv = Nullop;
3958         }
3959         else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
3960             padoff = sv->op_targ;
3961             sv->op_targ = 0;
3962             iterflags |= OPf_SPECIAL;
3963             op_free(sv);
3964             sv = Nullop;
3965         }
3966         else
3967             Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
3968     }
3969     else {
3970 #ifdef USE_THREADS
3971         padoff = find_threadsv("_");
3972         iterflags |= OPf_SPECIAL;
3973 #else
3974         sv = newGVOP(OP_GV, 0, PL_defgv);
3975 #endif
3976     }
3977     if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
3978         expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
3979         iterflags |= OPf_STACKED;
3980     }
3981     else if (expr->op_type == OP_NULL &&
3982              (expr->op_flags & OPf_KIDS) &&
3983              ((BINOP*)expr)->op_first->op_type == OP_FLOP)
3984     {
3985         /* Basically turn for($x..$y) into the same as for($x,$y), but we
3986          * set the STACKED flag to indicate that these values are to be
3987          * treated as min/max values by 'pp_iterinit'.
3988          */
3989         UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
3990         LOGOP* range = (LOGOP*) flip->op_first;
3991         OP* left  = range->op_first;
3992         OP* right = left->op_sibling;
3993         LISTOP* listop;
3994
3995         range->op_flags &= ~OPf_KIDS;
3996         range->op_first = Nullop;
3997
3998         listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
3999         listop->op_first->op_next = range->op_next;
4000         left->op_next = range->op_other;
4001         right->op_next = (OP*)listop;
4002         listop->op_next = listop->op_first;
4003
4004         op_free(expr);
4005         expr = (OP*)(listop);
4006         null(expr);
4007         iterflags |= OPf_STACKED;
4008     }
4009     else {
4010         expr = mod(force_list(expr), OP_GREPSTART);
4011     }
4012
4013
4014     loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4015                                append_elem(OP_LIST, expr, scalar(sv))));
4016     assert(!loop->op_next);
4017 #ifdef PL_OP_SLAB_ALLOC
4018     {
4019         LOOP *tmp;
4020         NewOp(1234,tmp,1,LOOP);
4021         Copy(loop,tmp,1,LOOP);
4022         loop = tmp;
4023     }
4024 #else
4025     Renew(loop, 1, LOOP);
4026 #endif
4027     loop->op_targ = padoff;
4028     wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
4029     PL_copline = forline;
4030     return newSTATEOP(0, label, wop);
4031 }
4032
4033 OP*
4034 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4035 {
4036     OP *o;
4037     STRLEN n_a;
4038
4039     if (type != OP_GOTO || label->op_type == OP_CONST) {
4040         /* "last()" means "last" */
4041         if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4042             o = newOP(type, OPf_SPECIAL);
4043         else {
4044             o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4045                                         ? SvPVx(((SVOP*)label)->op_sv, n_a)
4046                                         : ""));
4047         }
4048         op_free(label);
4049     }
4050     else {
4051         if (label->op_type == OP_ENTERSUB)
4052             label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4053         o = newUNOP(type, OPf_STACKED, label);
4054     }
4055     PL_hints |= HINT_BLOCK_SCOPE;
4056     return o;
4057 }
4058
4059 void
4060 Perl_cv_undef(pTHX_ CV *cv)
4061 {
4062 #ifdef USE_THREADS
4063     if (CvMUTEXP(cv)) {
4064         MUTEX_DESTROY(CvMUTEXP(cv));
4065         Safefree(CvMUTEXP(cv));
4066         CvMUTEXP(cv) = 0;
4067     }
4068 #endif /* USE_THREADS */
4069
4070     if (!CvXSUB(cv) && CvROOT(cv)) {
4071 #ifdef USE_THREADS
4072         if (CvDEPTH(cv) || (CvOWNER(cv) && CvOWNER(cv) != thr))
4073             Perl_croak(aTHX_ "Can't undef active subroutine");
4074 #else
4075         if (CvDEPTH(cv))
4076             Perl_croak(aTHX_ "Can't undef active subroutine");
4077 #endif /* USE_THREADS */
4078         ENTER;
4079
4080         SAVEVPTR(PL_curpad);
4081         PL_curpad = 0;
4082
4083         if (!CvCLONED(cv))
4084             op_free(CvROOT(cv));
4085         CvROOT(cv) = Nullop;
4086         LEAVE;
4087     }
4088     SvPOK_off((SV*)cv);         /* forget prototype */
4089     CvFLAGS(cv) = 0;
4090     SvREFCNT_dec(CvGV(cv));
4091     CvGV(cv) = Nullgv;
4092     SvREFCNT_dec(CvOUTSIDE(cv));
4093     CvOUTSIDE(cv) = Nullcv;
4094     if (CvCONST(cv)) {
4095         SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4096         CvCONST_off(cv);
4097     }
4098     if (CvPADLIST(cv)) {
4099         /* may be during global destruction */
4100         if (SvREFCNT(CvPADLIST(cv))) {
4101             I32 i = AvFILLp(CvPADLIST(cv));
4102             while (i >= 0) {
4103                 SV** svp = av_fetch(CvPADLIST(cv), i--, FALSE);
4104                 SV* sv = svp ? *svp : Nullsv;
4105                 if (!sv)
4106                     continue;
4107                 if (sv == (SV*)PL_comppad_name)
4108                     PL_comppad_name = Nullav;
4109                 else if (sv == (SV*)PL_comppad) {
4110                     PL_comppad = Nullav;
4111                     PL_curpad = Null(SV**);
4112                 }
4113                 SvREFCNT_dec(sv);
4114             }
4115             SvREFCNT_dec((SV*)CvPADLIST(cv));
4116         }
4117         CvPADLIST(cv) = Nullav;
4118     }
4119 }
4120
4121 STATIC void
4122 S_cv_dump(pTHX_ CV *cv)
4123 {
4124 #ifdef DEBUGGING
4125     CV *outside = CvOUTSIDE(cv);
4126     AV* padlist = CvPADLIST(cv);
4127     AV* pad_name;
4128     AV* pad;
4129     SV** pname;
4130     SV** ppad;
4131     I32 ix;
4132
4133     PerlIO_printf(Perl_debug_log,
4134                   "\tCV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
4135                   PTR2UV(cv),
4136                   (CvANON(cv) ? "ANON"
4137                    : (cv == PL_main_cv) ? "MAIN"
4138                    : CvUNIQUE(cv) ? "UNIQUE"
4139                    : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
4140                   PTR2UV(outside),
4141                   (!outside ? "null"
4142                    : CvANON(outside) ? "ANON"
4143                    : (outside == PL_main_cv) ? "MAIN"
4144                    : CvUNIQUE(outside) ? "UNIQUE"
4145                    : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
4146
4147     if (!padlist)
4148         return;
4149
4150     pad_name = (AV*)*av_fetch(padlist, 0, FALSE);
4151     pad = (AV*)*av_fetch(padlist, 1, FALSE);
4152     pname = AvARRAY(pad_name);
4153     ppad = AvARRAY(pad);
4154
4155     for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
4156         if (SvPOK(pname[ix]))
4157             PerlIO_printf(Perl_debug_log,
4158                           "\t%4d. 0x%"UVxf" (%s\"%s\" %"IVdf"-%"IVdf")\n",
4159                           (int)ix, PTR2UV(ppad[ix]),
4160                           SvFAKE(pname[ix]) ? "FAKE " : "",
4161                           SvPVX(pname[ix]),
4162                           (IV)I_32(SvNVX(pname[ix])),
4163                           SvIVX(pname[ix]));
4164     }
4165 #endif /* DEBUGGING */
4166 }
4167
4168 STATIC CV *
4169 S_cv_clone2(pTHX_ CV *proto, CV *outside)
4170 {
4171     AV* av;
4172     I32 ix;
4173     AV* protopadlist = CvPADLIST(proto);
4174     AV* protopad_name = (AV*)*av_fetch(protopadlist, 0, FALSE);
4175     AV* protopad = (AV*)*av_fetch(protopadlist, 1, FALSE);
4176     SV** pname = AvARRAY(protopad_name);
4177     SV** ppad = AvARRAY(protopad);
4178     I32 fname = AvFILLp(protopad_name);
4179     I32 fpad = AvFILLp(protopad);
4180     AV* comppadlist;
4181     CV* cv;
4182
4183     assert(!CvUNIQUE(proto));
4184
4185     ENTER;
4186     SAVECOMPPAD();
4187     SAVESPTR(PL_comppad_name);
4188     SAVESPTR(PL_compcv);
4189
4190     cv = PL_compcv = (CV*)NEWSV(1104,0);
4191     sv_upgrade((SV *)cv, SvTYPE(proto));
4192     CvFLAGS(cv) = CvFLAGS(proto) & ~CVf_CLONE;
4193     CvCLONED_on(cv);
4194
4195 #ifdef USE_THREADS
4196     New(666, CvMUTEXP(cv), 1, perl_mutex);
4197     MUTEX_INIT(CvMUTEXP(cv));
4198     CvOWNER(cv)         = 0;
4199 #endif /* USE_THREADS */
4200     CvFILE(cv)          = CvFILE(proto);
4201     CvGV(cv)            = (GV*)SvREFCNT_inc(CvGV(proto));
4202     CvSTASH(cv)         = CvSTASH(proto);
4203     CvROOT(cv)          = CvROOT(proto);
4204     CvSTART(cv)         = CvSTART(proto);
4205     if (outside)
4206         CvOUTSIDE(cv)   = (CV*)SvREFCNT_inc(outside);
4207
4208     if (SvPOK(proto))
4209         sv_setpvn((SV*)cv, SvPVX(proto), SvCUR(proto));
4210
4211     PL_comppad_name = newAV();
4212     for (ix = fname; ix >= 0; ix--)
4213         av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
4214
4215     PL_comppad = newAV();
4216
4217     comppadlist = newAV();
4218     AvREAL_off(comppadlist);
4219     av_store(comppadlist, 0, (SV*)PL_comppad_name);
4220     av_store(comppadlist, 1, (SV*)PL_comppad);
4221     CvPADLIST(cv) = comppadlist;
4222     av_fill(PL_comppad, AvFILLp(protopad));
4223     PL_curpad = AvARRAY(PL_comppad);
4224
4225     av = newAV();           /* will be @_ */
4226     av_extend(av, 0);
4227     av_store(PL_comppad, 0, (SV*)av);
4228     AvFLAGS(av) = AVf_REIFY;
4229
4230     for (ix = fpad; ix > 0; ix--) {
4231         SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4232         if (namesv && namesv != &PL_sv_undef) {
4233             char *name = SvPVX(namesv);    /* XXX */
4234             if (SvFLAGS(namesv) & SVf_FAKE) {   /* lexical from outside? */
4235                 I32 off = pad_findlex(name, ix, SvIVX(namesv),
4236                                       CvOUTSIDE(cv), cxstack_ix, 0, 0);
4237                 if (!off)
4238                     PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4239                 else if (off != ix)
4240                     Perl_croak(aTHX_ "panic: cv_clone: %s", name);
4241             }
4242             else {                              /* our own lexical */
4243                 SV* sv;
4244                 if (*name == '&') {
4245                     /* anon code -- we'll come back for it */
4246                     sv = SvREFCNT_inc(ppad[ix]);
4247                 }
4248                 else if (*name == '@')
4249                     sv = (SV*)newAV();
4250                 else if (*name == '%')
4251                     sv = (SV*)newHV();
4252                 else
4253                     sv = NEWSV(0,0);
4254                 if (!SvPADBUSY(sv))
4255                     SvPADMY_on(sv);
4256                 PL_curpad[ix] = sv;
4257             }
4258         }
4259         else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
4260             PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4261         }
4262         else {
4263             SV* sv = NEWSV(0,0);
4264             SvPADTMP_on(sv);
4265             PL_curpad[ix] = sv;
4266         }
4267     }
4268
4269     /* Now that vars are all in place, clone nested closures. */
4270
4271     for (ix = fpad; ix > 0; ix--) {
4272         SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4273         if (namesv
4274             && namesv != &PL_sv_undef
4275             && !(SvFLAGS(namesv) & SVf_FAKE)
4276             && *SvPVX(namesv) == '&'
4277             && CvCLONE(ppad[ix]))
4278         {
4279             CV *kid = cv_clone2((CV*)ppad[ix], cv);
4280             SvREFCNT_dec(ppad[ix]);
4281             CvCLONE_on(kid);
4282             SvPADMY_on(kid);
4283             PL_curpad[ix] = (SV*)kid;
4284         }
4285     }
4286
4287 #ifdef DEBUG_CLOSURES
4288     PerlIO_printf(Perl_debug_log, "Cloned inside:\n");
4289     cv_dump(outside);
4290     PerlIO_printf(Perl_debug_log, "  from:\n");
4291     cv_dump(proto);
4292     PerlIO_printf(Perl_debug_log, "   to:\n");
4293     cv_dump(cv);
4294 #endif
4295
4296     LEAVE;
4297
4298     if (CvCONST(cv)) {
4299         SV* const_sv = op_const_sv(CvSTART(cv), cv);
4300         assert(const_sv);
4301         /* constant sub () { $x } closing over $x - see lib/constant.pm */
4302         SvREFCNT_dec(cv);
4303         cv = newCONSTSUB(CvSTASH(proto), 0, const_sv);
4304     }
4305
4306     return cv;
4307 }
4308
4309 CV *
4310 Perl_cv_clone(pTHX_ CV *proto)
4311 {
4312     CV *cv;
4313     LOCK_CRED_MUTEX;                    /* XXX create separate mutex */
4314     cv = cv_clone2(proto, CvOUTSIDE(proto));
4315     UNLOCK_CRED_MUTEX;                  /* XXX create separate mutex */
4316     return cv;
4317 }
4318
4319 void
4320 Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
4321 {
4322     if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4323         SV* msg = sv_newmortal();
4324         SV* name = Nullsv;
4325
4326         if (gv)
4327             gv_efullname3(name = sv_newmortal(), gv, Nullch);
4328         sv_setpv(msg, "Prototype mismatch:");
4329         if (name)
4330             Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4331         if (SvPOK(cv))
4332             Perl_sv_catpvf(aTHX_ msg, " (%s)", SvPVX(cv));
4333         sv_catpv(msg, " vs ");
4334         if (p)
4335             Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4336         else
4337             sv_catpv(msg, "none");
4338         Perl_warner(aTHX_ WARN_PROTOTYPE, "%"SVf, msg);
4339     }
4340 }
4341
4342 static void const_sv_xsub(pTHXo_ CV* cv);
4343
4344 /*
4345 =for apidoc cv_const_sv
4346
4347 If C<cv> is a constant sub eligible for inlining. returns the constant
4348 value returned by the sub.  Otherwise, returns NULL.
4349
4350 Constant subs can be created with C<newCONSTSUB> or as described in
4351 L<perlsub/"Constant Functions">.
4352
4353 =cut
4354 */
4355 SV *
4356 Perl_cv_const_sv(pTHX_ CV *cv)
4357 {
4358     if (!cv || !CvCONST(cv))
4359         return Nullsv;
4360     return (SV*)CvXSUBANY(cv).any_ptr;
4361 }
4362
4363 SV *
4364 Perl_op_const_sv(pTHX_ OP *o, CV *cv)
4365 {
4366     SV *sv = Nullsv;
4367
4368     if (!o)
4369         return Nullsv;
4370
4371     if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4372         o = cLISTOPo->op_first->op_sibling;
4373
4374     for (; o; o = o->op_next) {
4375         OPCODE type = o->op_type;
4376
4377         if (sv && o->op_next == o)
4378             return sv;
4379         if (o->op_next != o) {
4380             if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4381                 continue;
4382             if (type == OP_DBSTATE)
4383                 continue;
4384         }
4385         if (type == OP_LEAVESUB || type == OP_RETURN)
4386             break;
4387         if (sv)
4388             return Nullsv;
4389         if (type == OP_CONST && cSVOPo->op_sv)
4390             sv = cSVOPo->op_sv;
4391         else if ((type == OP_PADSV || type == OP_CONST) && cv) {
4392             AV* padav = (AV*)(AvARRAY(CvPADLIST(cv))[1]);
4393             sv = padav ? AvARRAY(padav)[o->op_targ] : Nullsv;
4394             if (!sv)
4395                 return Nullsv;
4396             if (CvCONST(cv)) {
4397                 /* We get here only from cv_clone2() while creating a closure.
4398                    Copy the const value here instead of in cv_clone2 so that
4399                    SvREADONLY_on doesn't lead to problems when leaving
4400                    scope.
4401                 */
4402                 sv = newSVsv(sv);
4403             }
4404             if (!SvREADONLY(sv) && SvREFCNT(sv) > 1)
4405                 return Nullsv;
4406         }
4407         else
4408             return Nullsv;
4409     }
4410     if (sv)
4411         SvREADONLY_on(sv);
4412     return sv;
4413 }
4414
4415 void
4416 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4417 {
4418     if (o)
4419         SAVEFREEOP(o);
4420     if (proto)
4421         SAVEFREEOP(proto);
4422     if (attrs)
4423         SAVEFREEOP(attrs);
4424     if (block)
4425         SAVEFREEOP(block);
4426     Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4427 }
4428
4429 CV *
4430 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4431 {
4432     return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4433 }
4434
4435 CV *
4436 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4437 {
4438     STRLEN n_a;
4439     char *name;
4440     char *aname;
4441     GV *gv;
4442     char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
4443     register CV *cv=0;
4444     I32 ix;
4445     SV *const_sv;
4446
4447     name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4448     if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4449         SV *sv = sv_newmortal();
4450         Perl_sv_setpvf(aTHX_ sv, "__ANON__[%s:%"IVdf"]",
4451                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4452         aname = SvPVX(sv);
4453     }
4454     else
4455         aname = Nullch;
4456     gv = gv_fetchpv(name ? name : (aname ? aname : "__ANON__"),
4457                     GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4458                     SVt_PVCV);
4459
4460     if (o)
4461         SAVEFREEOP(o);
4462     if (proto)
4463         SAVEFREEOP(proto);
4464     if (attrs)
4465         SAVEFREEOP(attrs);
4466
4467     if (SvTYPE(gv) != SVt_PVGV) {       /* Maybe prototype now, and had at
4468                                            maximum a prototype before. */
4469         if (SvTYPE(gv) > SVt_NULL) {
4470             if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4471                 && ckWARN_d(WARN_PROTOTYPE))
4472             {
4473                 Perl_warner(aTHX_ WARN_PROTOTYPE, "Runaway prototype");
4474             }
4475             cv_ckproto((CV*)gv, NULL, ps);
4476         }
4477         if (ps)
4478             sv_setpv((SV*)gv, ps);
4479         else
4480             sv_setiv((SV*)gv, -1);
4481         SvREFCNT_dec(PL_compcv);
4482         cv = PL_compcv = NULL;
4483         PL_sub_generation++;
4484         goto done;
4485     }
4486
4487     cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4488
4489     if (!block || !ps || *ps || attrs)
4490         const_sv = Nullsv;
4491     else
4492         const_sv = op_const_sv(block, Nullcv);
4493
4494     if (cv) {
4495         bool exists = CvROOT(cv) || CvXSUB(cv);
4496         /* if the subroutine doesn't exist and wasn't pre-declared
4497          * with a prototype, assume it will be AUTOLOADed,
4498          * skipping the prototype check
4499          */
4500         if (exists || SvPOK(cv))
4501             cv_ckproto(cv, gv, ps);
4502         /* already defined (or promised)? */
4503         if (exists || GvASSUMECV(gv)) {
4504             if (!block && !attrs) {
4505                 /* just a "sub foo;" when &foo is already defined */
4506                 SAVEFREESV(PL_compcv);
4507                 goto done;
4508             }
4509             /* ahem, death to those who redefine active sort subs */
4510             if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4511                 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4512             if (block) {
4513                 if (ckWARN(WARN_REDEFINE)
4514                     || (CvCONST(cv)
4515                         && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4516                 {
4517                     line_t oldline = CopLINE(PL_curcop);
4518                     CopLINE_set(PL_curcop, PL_copline);
4519                     Perl_warner(aTHX_ WARN_REDEFINE,
4520                         CvCONST(cv) ? "Constant subroutine %s redefined"
4521                                     : "Subroutine %s redefined", name);
4522                     CopLINE_set(PL_curcop, oldline);
4523                 }
4524                 SvREFCNT_dec(cv);
4525                 cv = Nullcv;
4526             }
4527         }
4528     }
4529     if (const_sv) {
4530         SvREFCNT_inc(const_sv);
4531         if (cv) {
4532             assert(!CvROOT(cv) && !CvCONST(cv));
4533             sv_setpv((SV*)cv, "");  /* prototype is "" */
4534             CvXSUBANY(cv).any_ptr = const_sv;
4535             CvXSUB(cv) = const_sv_xsub;
4536             CvCONST_on(cv);
4537         }
4538         else {
4539             GvCV(gv) = Nullcv;
4540             cv = newCONSTSUB(NULL, name, const_sv);
4541         }
4542         op_free(block);
4543         SvREFCNT_dec(PL_compcv);
4544         PL_compcv = NULL;
4545         PL_sub_generation++;
4546         goto done;
4547     }
4548     if (attrs) {
4549         HV *stash;
4550         SV *rcv;
4551
4552         /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4553          * before we clobber PL_compcv.
4554          */
4555         if (cv && !block) {
4556             rcv = (SV*)cv;
4557             if (CvGV(cv) && GvSTASH(CvGV(cv)) && HvNAME(GvSTASH(CvGV(cv))))
4558                 stash = GvSTASH(CvGV(cv));
4559             else if (CvSTASH(cv) && HvNAME(CvSTASH(cv)))
4560                 stash = CvSTASH(cv);
4561             else
4562                 stash = PL_curstash;
4563         }
4564         else {
4565             /* possibly about to re-define existing subr -- ignore old cv */
4566             rcv = (SV*)PL_compcv;
4567             if (name && GvSTASH(gv) && HvNAME(GvSTASH(gv)))
4568                 stash = GvSTASH(gv);
4569             else
4570                 stash = PL_curstash;
4571         }
4572         apply_attrs(stash, rcv, attrs);
4573     }
4574     if (cv) {                           /* must reuse cv if autoloaded */
4575         if (!block) {
4576             /* got here with just attrs -- work done, so bug out */
4577             SAVEFREESV(PL_compcv);
4578             goto done;
4579         }
4580         cv_undef(cv);
4581         CvFLAGS(cv) = CvFLAGS(PL_compcv);
4582         CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4583         CvOUTSIDE(PL_compcv) = 0;
4584         CvPADLIST(cv) = CvPADLIST(PL_compcv);
4585         CvPADLIST(PL_compcv) = 0;
4586         if (SvREFCNT(PL_compcv) > 1) /* XXX Make closures transit through stub. */
4587             CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc((SV*)cv);
4588         SvREFCNT_dec(PL_compcv);
4589     }
4590     else {
4591         cv = PL_compcv;
4592         if (name) {
4593             GvCV(gv) = cv;
4594             GvCVGEN(gv) = 0;
4595             PL_sub_generation++;
4596         }
4597     }
4598     CvGV(cv) = (GV*)SvREFCNT_inc(gv);
4599     CvFILE(cv) = CopFILE(PL_curcop);
4600     CvSTASH(cv) = PL_curstash;
4601 #ifdef USE_THREADS
4602     CvOWNER(cv) = 0;
4603     if (!CvMUTEXP(cv)) {
4604         New(666, CvMUTEXP(cv), 1, perl_mutex);
4605         MUTEX_INIT(CvMUTEXP(cv));
4606     }
4607 #endif /* USE_THREADS */
4608
4609     if (ps)
4610         sv_setpv((SV*)cv, ps);
4611
4612     if (PL_error_count) {
4613         op_free(block);
4614         block = Nullop;
4615         if (name) {
4616             char *s = strrchr(name, ':');
4617             s = s ? s+1 : name;
4618             if (strEQ(s, "BEGIN")) {
4619                 char *not_safe =
4620                     "BEGIN not safe after errors--compilation aborted";
4621                 if (PL_in_eval & EVAL_KEEPERR)
4622                     Perl_croak(aTHX_ not_safe);
4623                 else {
4624                     /* force display of errors found but not reported */
4625                     sv_catpv(ERRSV, not_safe);
4626                     Perl_croak(aTHX_ "%s", SvPVx(ERRSV, n_a));
4627                 }
4628             }
4629         }
4630     }
4631     if (!block)
4632         goto done;
4633
4634     if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
4635         av_store(PL_comppad_name, AvFILLp(PL_comppad), Nullsv);
4636
4637     if (CvLVALUE(cv)) {
4638         CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0, scalarseq(block));
4639     }
4640     else {
4641         CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4642     }
4643     CvROOT(cv)->op_private |= OPpREFCOUNTED;
4644     OpREFCNT_set(CvROOT(cv), 1);
4645     CvSTART(cv) = LINKLIST(CvROOT(cv));
4646     CvROOT(cv)->op_next = 0;
4647     peep(CvSTART(cv));
4648
4649     /* now that optimizer has done its work, adjust pad values */
4650     if (CvCLONE(cv)) {
4651         SV **namep = AvARRAY(PL_comppad_name);
4652         for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4653             SV *namesv;
4654
4655             if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
4656                 continue;
4657             /*
4658              * The only things that a clonable function needs in its
4659              * pad are references to outer lexicals and anonymous subs.
4660              * The rest are created anew during cloning.
4661              */
4662             if (!((namesv = namep[ix]) != Nullsv &&
4663                   namesv != &PL_sv_undef &&
4664                   (SvFAKE(namesv) ||
4665                    *SvPVX(namesv) == '&')))
4666             {
4667                 SvREFCNT_dec(PL_curpad[ix]);
4668                 PL_curpad[ix] = Nullsv;
4669             }
4670         }
4671         assert(!CvCONST(cv));
4672         if (ps && !*ps && op_const_sv(block, cv))
4673             CvCONST_on(cv);
4674     }
4675     else {
4676         AV *av = newAV();                       /* Will be @_ */
4677         av_extend(av, 0);
4678         av_store(PL_comppad, 0, (SV*)av);
4679         AvFLAGS(av) = AVf_REIFY;
4680
4681         for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4682             if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
4683                 continue;
4684             if (!SvPADMY(PL_curpad[ix]))
4685                 SvPADTMP_on(PL_curpad[ix]);
4686         }
4687     }
4688
4689     if (name || aname) {
4690         char *s;
4691         char *tname = (name ? name : aname);
4692
4693         if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4694             SV *sv = NEWSV(0,0);
4695             SV *tmpstr = sv_newmortal();
4696             GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4697             CV *pcv;
4698             HV *hv;
4699
4700             Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4701                            CopFILE(PL_curcop),
4702                            (long)PL_subline, (long)CopLINE(PL_curcop));
4703             gv_efullname3(tmpstr, gv, Nullch);
4704             hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
4705             hv = GvHVn(db_postponed);
4706             if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
4707                 && (pcv = GvCV(db_postponed)))
4708             {
4709                 dSP;
4710                 PUSHMARK(SP);
4711                 XPUSHs(tmpstr);
4712                 PUTBACK;
4713                 call_sv((SV*)pcv, G_DISCARD);
4714             }
4715         }
4716
4717         if ((s = strrchr(tname,':')))
4718             s++;
4719         else
4720             s = tname;
4721
4722         if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4723             goto done;
4724
4725         if (strEQ(s, "BEGIN")) {
4726             I32 oldscope = PL_scopestack_ix;
4727             ENTER;
4728             SAVECOPFILE(&PL_compiling);
4729             SAVECOPLINE(&PL_compiling);
4730             save_svref(&PL_rs);
4731             sv_setsv(PL_rs, PL_nrs);
4732
4733             if (!PL_beginav)
4734                 PL_beginav = newAV();
4735             DEBUG_x( dump_sub(gv) );
4736             av_push(PL_beginav, (SV*)cv);
4737             GvCV(gv) = 0;               /* cv has been hijacked */
4738             call_list(oldscope, PL_beginav);
4739
4740             PL_curcop = &PL_compiling;
4741             PL_compiling.op_private = PL_hints;
4742             LEAVE;
4743         }
4744         else if (strEQ(s, "END") && !PL_error_count) {
4745             if (!PL_endav)
4746                 PL_endav = newAV();
4747             DEBUG_x( dump_sub(gv) );
4748             av_unshift(PL_endav, 1);
4749             av_store(PL_endav, 0, (SV*)cv);
4750             GvCV(gv) = 0;               /* cv has been hijacked */
4751         }
4752         else if (strEQ(s, "CHECK") && !PL_error_count) {
4753             if (!PL_checkav)
4754                 PL_checkav = newAV();
4755             DEBUG_x( dump_sub(gv) );
4756             if (PL_main_start && ckWARN(WARN_VOID))
4757                 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
4758             av_unshift(PL_checkav, 1);
4759             av_store(PL_checkav, 0, (SV*)cv);
4760             GvCV(gv) = 0;               /* cv has been hijacked */
4761         }
4762         else if (strEQ(s, "INIT") && !PL_error_count) {
4763             if (!PL_initav)
4764                 PL_initav = newAV();
4765             DEBUG_x( dump_sub(gv) );
4766             if (PL_main_start && ckWARN(WARN_VOID))
4767                 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
4768             av_push(PL_initav, (SV*)cv);
4769             GvCV(gv) = 0;               /* cv has been hijacked */
4770         }
4771     }
4772
4773   done:
4774     PL_copline = NOLINE;
4775     LEAVE_SCOPE(floor);
4776     return cv;
4777 }
4778
4779 /* XXX unsafe for threads if eval_owner isn't held */
4780 /*
4781 =for apidoc newCONSTSUB
4782
4783 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4784 eligible for inlining at compile-time.
4785
4786 =cut
4787 */
4788
4789 CV *
4790 Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
4791 {
4792     CV* cv;
4793
4794     ENTER;
4795
4796     SAVECOPLINE(PL_curcop);
4797     CopLINE_set(PL_curcop, PL_copline);
4798
4799     SAVEHINTS();
4800     PL_hints &= ~HINT_BLOCK_SCOPE;
4801
4802     if (stash) {
4803         SAVESPTR(PL_curstash);
4804         SAVECOPSTASH(PL_curcop);
4805         PL_curstash = stash;
4806 #ifdef USE_ITHREADS
4807         CopSTASHPV(PL_curcop) = stash ? HvNAME(stash) : Nullch;
4808 #else
4809         CopSTASH(PL_curcop) = stash;
4810 #endif
4811     }
4812
4813     cv = newXS(name, const_sv_xsub, __FILE__);
4814     CvXSUBANY(cv).any_ptr = sv;
4815     CvCONST_on(cv);
4816     sv_setpv((SV*)cv, "");  /* prototype is "" */
4817
4818     LEAVE;
4819
4820     return cv;
4821 }
4822
4823 /*
4824 =for apidoc U||newXS
4825
4826 Used by C<xsubpp> to hook up XSUBs as Perl subs.
4827
4828 =cut
4829 */
4830
4831 CV *
4832 Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
4833 {
4834     GV *gv = gv_fetchpv(name ? name : "__ANON__", GV_ADDMULTI, SVt_PVCV);
4835     register CV *cv;
4836
4837     if ((cv = (name ? GvCV(gv) : Nullcv))) {
4838         if (GvCVGEN(gv)) {
4839             /* just a cached method */
4840             SvREFCNT_dec(cv);
4841             cv = 0;
4842         }
4843         else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4844             /* already defined (or promised) */
4845             if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
4846                             && HvNAME(GvSTASH(CvGV(cv)))
4847                             && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
4848                 line_t oldline = CopLINE(PL_curcop);
4849                 if (PL_copline != NOLINE)
4850                     CopLINE_set(PL_curcop, PL_copline);
4851                 Perl_warner(aTHX_ WARN_REDEFINE,
4852                             CvCONST(cv) ? "Constant subroutine %s redefined"
4853                                         : "Subroutine %s redefined"
4854                             ,name);
4855                 CopLINE_set(PL_curcop, oldline);
4856             }
4857             SvREFCNT_dec(cv);
4858             cv = 0;
4859         }
4860     }
4861
4862     if (cv)                             /* must reuse cv if autoloaded */
4863         cv_undef(cv);
4864     else {
4865         cv = (CV*)NEWSV(1105,0);
4866         sv_upgrade((SV *)cv, SVt_PVCV);
4867         if (name) {
4868             GvCV(gv) = cv;
4869             GvCVGEN(gv) = 0;
4870             PL_sub_generation++;
4871         }
4872     }
4873     CvGV(cv) = (GV*)SvREFCNT_inc(gv);
4874 #ifdef USE_THREADS
4875     New(666, CvMUTEXP(cv), 1, perl_mutex);
4876     MUTEX_INIT(CvMUTEXP(cv));
4877     CvOWNER(cv) = 0;
4878 #endif /* USE_THREADS */
4879     (void)gv_fetchfile(filename);
4880     CvFILE(cv) = filename;      /* NOTE: not copied, as it is expected to be
4881                                    an external constant string */
4882     CvXSUB(cv) = subaddr;
4883
4884     if (name) {
4885         char *s = strrchr(name,':');
4886         if (s)
4887             s++;
4888         else
4889             s = name;
4890
4891         if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4892             goto done;
4893
4894         if (strEQ(s, "BEGIN")) {
4895             if (!PL_beginav)
4896                 PL_beginav = newAV();
4897             av_push(PL_beginav, (SV*)cv);
4898             GvCV(gv) = 0;               /* cv has been hijacked */
4899         }
4900         else if (strEQ(s, "END")) {
4901             if (!PL_endav)
4902                 PL_endav = newAV();
4903             av_unshift(PL_endav, 1);
4904             av_store(PL_endav, 0, (SV*)cv);
4905             GvCV(gv) = 0;               /* cv has been hijacked */
4906         }
4907         else if (strEQ(s, "CHECK")) {
4908             if (!PL_checkav)
4909                 PL_checkav = newAV();
4910             if (PL_main_start && ckWARN(WARN_VOID))
4911                 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
4912             av_unshift(PL_checkav, 1);
4913             av_store(PL_checkav, 0, (SV*)cv);
4914             GvCV(gv) = 0;               /* cv has been hijacked */
4915         }
4916         else if (strEQ(s, "INIT")) {
4917             if (!PL_initav)
4918                 PL_initav = newAV();
4919             if (PL_main_start && ckWARN(WARN_VOID))
4920                 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
4921             av_push(PL_initav, (SV*)cv);
4922             GvCV(gv) = 0;               /* cv has been hijacked */
4923         }
4924     }
4925     else
4926         CvANON_on(cv);
4927
4928 done:
4929     return cv;
4930 }
4931
4932 void
4933 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
4934 {
4935     register CV *cv;
4936     char *name;
4937     GV *gv;
4938     I32 ix;
4939     STRLEN n_a;
4940
4941     if (o)
4942         name = SvPVx(cSVOPo->op_sv, n_a);
4943     else
4944         name = "STDOUT";
4945     gv = gv_fetchpv(name,TRUE, SVt_PVFM);
4946     GvMULTI_on(gv);
4947     if ((cv = GvFORM(gv))) {
4948         if (ckWARN(WARN_REDEFINE)) {
4949             line_t oldline = CopLINE(PL_curcop);
4950
4951             CopLINE_set(PL_curcop, PL_copline);
4952             Perl_warner(aTHX_ WARN_REDEFINE, "Format %s redefined",name);
4953             CopLINE_set(PL_curcop, oldline);
4954         }
4955         SvREFCNT_dec(cv);
4956     }
4957     cv = PL_compcv;
4958     GvFORM(gv) = cv;
4959     CvGV(cv) = (GV*)SvREFCNT_inc(gv);
4960     CvFILE(cv) = CopFILE(PL_curcop);
4961
4962     for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4963         if (!SvPADMY(PL_curpad[ix]) && !SvIMMORTAL(PL_curpad[ix]))
4964             SvPADTMP_on(PL_curpad[ix]);
4965     }
4966
4967     CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
4968     CvROOT(cv)->op_private |= OPpREFCOUNTED;
4969     OpREFCNT_set(CvROOT(cv), 1);
4970     CvSTART(cv) = LINKLIST(CvROOT(cv));
4971     CvROOT(cv)->op_next = 0;
4972     peep(CvSTART(cv));
4973     op_free(o);
4974     PL_copline = NOLINE;
4975     LEAVE_SCOPE(floor);
4976 }
4977
4978 OP *
4979 Perl_newANONLIST(pTHX_ OP *o)
4980 {
4981     return newUNOP(OP_REFGEN, 0,
4982         mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
4983 }
4984
4985 OP *
4986 Perl_newANONHASH(pTHX_ OP *o)
4987 {
4988     return newUNOP(OP_REFGEN, 0,
4989         mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
4990 }
4991
4992 OP *
4993 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
4994 {
4995     return newANONATTRSUB(floor, proto, Nullop, block);
4996 }
4997
4998 OP *
4999 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5000 {
5001     return newUNOP(OP_REFGEN, 0,
5002         newSVOP(OP_ANONCODE, 0,
5003                 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5004 }
5005
5006 OP *
5007 Perl_oopsAV(pTHX_ OP *o)
5008 {
5009     switch (o->op_type) {
5010     case OP_PADSV:
5011         o->op_type = OP_PADAV;
5012         o->op_ppaddr = PL_ppaddr[OP_PADAV];
5013         return ref(o, OP_RV2AV);
5014
5015     case OP_RV2SV:
5016         o->op_type = OP_RV2AV;
5017         o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5018         ref(o, OP_RV2AV);
5019         break;
5020
5021     default:
5022         if (ckWARN_d(WARN_INTERNAL))
5023             Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsAV");
5024         break;
5025     }
5026     return o;
5027 }
5028
5029 OP *
5030 Perl_oopsHV(pTHX_ OP *o)
5031 {
5032     switch (o->op_type) {
5033     case OP_PADSV:
5034     case OP_PADAV:
5035         o->op_type = OP_PADHV;
5036         o->op_ppaddr = PL_ppaddr[OP_PADHV];
5037         return ref(o, OP_RV2HV);
5038
5039     case OP_RV2SV:
5040     case OP_RV2AV:
5041         o->op_type = OP_RV2HV;
5042         o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5043         ref(o, OP_RV2HV);
5044         break;
5045
5046     default:
5047         if (ckWARN_d(WARN_INTERNAL))
5048             Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsHV");
5049         break;
5050     }
5051     return o;
5052 }
5053
5054 OP *
5055 Perl_newAVREF(pTHX_ OP *o)
5056 {
5057     if (o->op_type == OP_PADANY) {
5058         o->op_type = OP_PADAV;
5059         o->op_ppaddr = PL_ppaddr[OP_PADAV];
5060         return o;
5061     }
5062     return newUNOP(OP_RV2AV, 0, scalar(o));
5063 }
5064
5065 OP *
5066 Perl_newGVREF(pTHX_ I32 type, OP *o)
5067 {
5068     if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5069         return newUNOP(OP_NULL, 0, o);
5070     return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5071 }
5072
5073 OP *
5074 Perl_newHVREF(pTHX_ OP *o)
5075 {
5076     if (o->op_type == OP_PADANY) {
5077         o->op_type = OP_PADHV;
5078         o->op_ppaddr = PL_ppaddr[OP_PADHV];
5079         return o;
5080     }
5081     return newUNOP(OP_RV2HV, 0, scalar(o));
5082 }
5083
5084 OP *
5085 Perl_oopsCV(pTHX_ OP *o)
5086 {
5087     Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5088     /* STUB */
5089     return o;
5090 }
5091
5092 OP *
5093 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5094 {
5095     return newUNOP(OP_RV2CV, flags, scalar(o));
5096 }
5097
5098 OP *
5099 Perl_newSVREF(pTHX_ OP *o)
5100 {
5101     if (o->op_type == OP_PADANY) {
5102         o->op_type = OP_PADSV;
5103         o->op_ppaddr = PL_ppaddr[OP_PADSV];
5104         return o;
5105     }
5106     else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5107         o->op_flags |= OPpDONE_SVREF;
5108         return o;
5109     }
5110     return newUNOP(OP_RV2SV, 0, scalar(o));
5111 }
5112
5113 /* Check routines. */
5114
5115 OP *
5116 Perl_ck_anoncode(pTHX_ OP *o)
5117 {
5118     PADOFFSET ix;
5119     SV* name;
5120
5121     name = NEWSV(1106,0);
5122     sv_upgrade(name, SVt_PVNV);
5123     sv_setpvn(name, "&", 1);
5124     SvIVX(name) = -1;
5125     SvNVX(name) = 1;
5126     ix = pad_alloc(o->op_type, SVs_PADMY);
5127     av_store(PL_comppad_name, ix, name);
5128     av_store(PL_comppad, ix, cSVOPo->op_sv);
5129     SvPADMY_on(cSVOPo->op_sv);
5130     cSVOPo->op_sv = Nullsv;
5131     cSVOPo->op_targ = ix;
5132     return o;
5133 }
5134
5135 OP *
5136 Perl_ck_bitop(pTHX_ OP *o)
5137 {
5138     o->op_private = PL_hints;
5139     return o;
5140 }
5141
5142 OP *
5143 Perl_ck_concat(pTHX_ OP *o)
5144 {
5145     if (cUNOPo->op_first->op_type == OP_CONCAT)
5146         o->op_flags |= OPf_STACKED;
5147     return o;
5148 }
5149
5150 OP *
5151 Perl_ck_spair(pTHX_ OP *o)
5152 {
5153     if (o->op_flags & OPf_KIDS) {
5154         OP* newop;
5155         OP* kid;
5156         OPCODE type = o->op_type;
5157         o = modkids(ck_fun(o), type);
5158         kid = cUNOPo->op_first;
5159         newop = kUNOP->op_first->op_sibling;
5160         if (newop &&
5161             (newop->op_sibling ||
5162              !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
5163              newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5164              newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
5165
5166             return o;
5167         }
5168         op_free(kUNOP->op_first);
5169         kUNOP->op_first = newop;
5170     }
5171     o->op_ppaddr = PL_ppaddr[++o->op_type];
5172     return ck_fun(o);
5173 }
5174
5175 OP *
5176 Perl_ck_delete(pTHX_ OP *o)
5177 {
5178     o = ck_fun(o);
5179     o->op_private = 0;
5180     if (o->op_flags & OPf_KIDS) {
5181         OP *kid = cUNOPo->op_first;
5182         switch (kid->op_type) {
5183         case OP_ASLICE:
5184             o->op_flags |= OPf_SPECIAL;
5185             /* FALL THROUGH */
5186         case OP_HSLICE:
5187             o->op_private |= OPpSLICE;
5188             break;
5189         case OP_AELEM:
5190             o->op_flags |= OPf_SPECIAL;
5191             /* FALL THROUGH */
5192         case OP_HELEM:
5193             break;
5194         default:
5195             Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5196                   PL_op_desc[o->op_type]);
5197         }
5198         null(kid);
5199     }
5200     return o;
5201 }
5202
5203 OP *
5204 Perl_ck_eof(pTHX_ OP *o)
5205 {
5206     I32 type = o->op_type;
5207
5208     if (o->op_flags & OPf_KIDS) {
5209         if (cLISTOPo->op_first->op_type == OP_STUB) {
5210             op_free(o);
5211             o = newUNOP(type, OPf_SPECIAL,
5212                 newGVOP(OP_GV, 0, gv_fetchpv("main::ARGV", TRUE, SVt_PVAV)));
5213         }
5214         return ck_fun(o);
5215     }
5216     return o;
5217 }
5218
5219 OP *
5220 Perl_ck_eval(pTHX_ OP *o)
5221 {
5222     PL_hints |= HINT_BLOCK_SCOPE;
5223     if (o->op_flags & OPf_KIDS) {
5224         SVOP *kid = (SVOP*)cUNOPo->op_first;
5225
5226         if (!kid) {
5227             o->op_flags &= ~OPf_KIDS;
5228             null(o);
5229         }
5230         else if (kid->op_type == OP_LINESEQ) {
5231             LOGOP *enter;
5232
5233             kid->op_next = o->op_next;
5234             cUNOPo->op_first = 0;
5235             op_free(o);
5236
5237             NewOp(1101, enter, 1, LOGOP);
5238             enter->op_type = OP_ENTERTRY;
5239             enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5240             enter->op_private = 0;
5241
5242             /* establish postfix order */
5243             enter->op_next = (OP*)enter;
5244
5245             o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5246             o->op_type = OP_LEAVETRY;
5247             o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5248             enter->op_other = o;
5249             return o;
5250         }
5251         else
5252             scalar((OP*)kid);
5253     }
5254     else {
5255         op_free(o);
5256         o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5257     }
5258     o->op_targ = (PADOFFSET)PL_hints;
5259     return o;
5260 }
5261
5262 OP *
5263 Perl_ck_exit(pTHX_ OP *o)
5264 {
5265 #ifdef VMS
5266     HV *table = GvHV(PL_hintgv);
5267     if (table) {
5268        SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
5269        if (svp && *svp && SvTRUE(*svp))
5270            o->op_private |= OPpEXIT_VMSISH;
5271     }
5272 #endif
5273     return ck_fun(o);
5274 }
5275
5276 OP *
5277 Perl_ck_exec(pTHX_ OP *o)
5278 {
5279     OP *kid;
5280     if (o->op_flags & OPf_STACKED) {
5281         o = ck_fun(o);
5282         kid = cUNOPo->op_first->op_sibling;
5283         if (kid->op_type == OP_RV2GV)
5284             null(kid);
5285     }
5286     else
5287         o = listkids(o);
5288     return o;
5289 }
5290
5291 OP *
5292 Perl_ck_exists(pTHX_ OP *o)
5293 {
5294     o = ck_fun(o);
5295     if (o->op_flags & OPf_KIDS) {
5296         OP *kid = cUNOPo->op_first;
5297         if (kid->op_type == OP_ENTERSUB) {
5298             (void) ref(kid, o->op_type);
5299             if (kid->op_type != OP_RV2CV && !PL_error_count)
5300                 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5301                            PL_op_desc[o->op_type]);
5302             o->op_private |= OPpEXISTS_SUB;
5303         }
5304         else if (kid->op_type == OP_AELEM)
5305             o->op_flags |= OPf_SPECIAL;
5306         else if (kid->op_type != OP_HELEM)
5307             Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5308                        PL_op_desc[o->op_type]);
5309         null(kid);
5310     }
5311     return o;
5312 }
5313
5314 #if 0
5315 OP *
5316 Perl_ck_gvconst(pTHX_ register OP *o)
5317 {
5318     o = fold_constants(o);
5319     if (o->op_type == OP_CONST)
5320         o->op_type = OP_GV;
5321     return o;
5322 }
5323 #endif
5324
5325 OP *
5326 Perl_ck_rvconst(pTHX_ register OP *o)
5327 {
5328     SVOP *kid = (SVOP*)cUNOPo->op_first;
5329
5330     o->op_private |= (PL_hints & HINT_STRICT_REFS);
5331     if (kid->op_type == OP_CONST) {
5332         char *name;
5333         int iscv;
5334         GV *gv;
5335         SV *kidsv = kid->op_sv;
5336         STRLEN n_a;
5337
5338         /* Is it a constant from cv_const_sv()? */
5339         if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5340             SV *rsv = SvRV(kidsv);
5341             int svtype = SvTYPE(rsv);
5342             char *badtype = Nullch;
5343
5344             switch (o->op_type) {
5345             case OP_RV2SV:
5346                 if (svtype > SVt_PVMG)
5347                     badtype = "a SCALAR";
5348                 break;
5349             case OP_RV2AV:
5350                 if (svtype != SVt_PVAV)
5351                     badtype = "an ARRAY";
5352                 break;
5353             case OP_RV2HV:
5354                 if (svtype != SVt_PVHV) {
5355                     if (svtype == SVt_PVAV) {   /* pseudohash? */
5356                         SV **ksv = av_fetch((AV*)rsv, 0, FALSE);
5357                         if (ksv && SvROK(*ksv)
5358                             && SvTYPE(SvRV(*ksv)) == SVt_PVHV)
5359                         {
5360                                 break;
5361                         }
5362                     }
5363                     badtype = "a HASH";
5364                 }
5365                 break;
5366             case OP_RV2CV:
5367                 if (svtype != SVt_PVCV)
5368                     badtype = "a CODE";
5369                 break;
5370             }
5371             if (badtype)
5372                 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5373             return o;
5374         }
5375         name = SvPV(kidsv, n_a);
5376         if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5377             char *badthing = Nullch;
5378             switch (o->op_type) {
5379             case OP_RV2SV:
5380                 badthing = "a SCALAR";
5381                 break;
5382             case OP_RV2AV:
5383                 badthing = "an ARRAY";
5384                 break;
5385             case OP_RV2HV:
5386                 badthing = "a HASH";
5387                 break;
5388             }
5389             if (badthing)
5390                 Perl_croak(aTHX_
5391           "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
5392                       name, badthing);
5393         }
5394         /*
5395          * This is a little tricky.  We only want to add the symbol if we
5396          * didn't add it in the lexer.  Otherwise we get duplicate strict
5397          * warnings.  But if we didn't add it in the lexer, we must at
5398          * least pretend like we wanted to add it even if it existed before,
5399          * or we get possible typo warnings.  OPpCONST_ENTERED says
5400          * whether the lexer already added THIS instance of this symbol.
5401          */
5402         iscv = (o->op_type == OP_RV2CV) * 2;
5403         do {
5404             gv = gv_fetchpv(name,
5405                 iscv | !(kid->op_private & OPpCONST_ENTERED),
5406                 iscv
5407                     ? SVt_PVCV
5408                     : o->op_type == OP_RV2SV
5409                         ? SVt_PV
5410                         : o->op_type == OP_RV2AV
5411                             ? SVt_PVAV
5412                             : o->op_type == OP_RV2HV
5413                                 ? SVt_PVHV
5414                                 : SVt_PVGV);
5415         } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5416         if (gv) {
5417             kid->op_type = OP_GV;
5418             SvREFCNT_dec(kid->op_sv);
5419 #ifdef USE_ITHREADS
5420             /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5421             kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5422             SvREFCNT_dec(PL_curpad[kPADOP->op_padix]);
5423             GvIN_PAD_on(gv);
5424             PL_curpad[kPADOP->op_padix] = SvREFCNT_inc(gv);
5425 #else
5426             kid->op_sv = SvREFCNT_inc(gv);
5427 #endif
5428             kid->op_ppaddr = PL_ppaddr[OP_GV];
5429         }
5430     }
5431     return o;
5432 }
5433
5434 OP *
5435 Perl_ck_ftst(pTHX_ OP *o)
5436 {
5437     I32 type = o->op_type;
5438
5439     if (o->op_flags & OPf_REF) {
5440         /* nothing */
5441     }
5442     else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5443         SVOP *kid = (SVOP*)cUNOPo->op_first;
5444
5445         if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5446             STRLEN n_a;
5447             OP *newop = newGVOP(type, OPf_REF,
5448                 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
5449             op_free(o);
5450             o = newop;
5451         }
5452     }
5453     else {
5454         op_free(o);
5455         if (type == OP_FTTTY)
5456            o =  newGVOP(type, OPf_REF, gv_fetchpv("main::STDIN", TRUE,
5457                                 SVt_PVIO));
5458         else
5459             o = newUNOP(type, 0, newDEFSVOP());
5460     }
5461 #ifdef USE_LOCALE
5462     if (type == OP_FTTEXT || type == OP_FTBINARY) {
5463         o->op_private = 0;
5464         if (PL_hints & HINT_LOCALE)
5465             o->op_private |= OPpLOCALE;
5466     }
5467 #endif
5468     return o;
5469 }
5470
5471 OP *
5472 Perl_ck_fun(pTHX_ OP *o)
5473 {
5474     register OP *kid;
5475     OP **tokid;
5476     OP *sibl;
5477     I32 numargs = 0;
5478     int type = o->op_type;
5479     register I32 oa = PL_opargs[type] >> OASHIFT;
5480
5481     if (o->op_flags & OPf_STACKED) {
5482         if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5483             oa &= ~OA_OPTIONAL;
5484         else
5485             return no_fh_allowed(o);
5486     }
5487
5488     if (o->op_flags & OPf_KIDS) {
5489         STRLEN n_a;
5490         tokid = &cLISTOPo->op_first;
5491         kid = cLISTOPo->op_first;
5492         if (kid->op_type == OP_PUSHMARK ||
5493             (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5494         {
5495             tokid = &kid->op_sibling;
5496             kid = kid->op_sibling;
5497         }
5498         if (!kid && PL_opargs[type] & OA_DEFGV)
5499             *tokid = kid = newDEFSVOP();
5500
5501         while (oa && kid) {
5502             numargs++;
5503             sibl = kid->op_sibling;
5504             switch (oa & 7) {
5505             case OA_SCALAR:
5506                 /* list seen where single (scalar) arg expected? */
5507                 if (numargs == 1 && !(oa >> 4)
5508                     && kid->op_type == OP_LIST && type != OP_SCALAR)
5509                 {
5510                     return too_many_arguments(o,PL_op_desc[type]);
5511                 }
5512                 scalar(kid);
5513                 break;
5514             case OA_LIST:
5515                 if (oa < 16) {
5516                     kid = 0;
5517                     continue;
5518                 }
5519                 else
5520                     list(kid);
5521                 break;
5522             case OA_AVREF:
5523                 if (kid->op_type == OP_CONST &&
5524                     (kid->op_private & OPpCONST_BARE))
5525                 {
5526                     char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5527                     OP *newop = newAVREF(newGVOP(OP_GV, 0,
5528                         gv_fetchpv(name, TRUE, SVt_PVAV) ));
5529                     if (ckWARN(WARN_DEPRECATED))
5530                         Perl_warner(aTHX_ WARN_DEPRECATED,
5531                             "Array @%s missing the @ in argument %"IVdf" of %s()",
5532                             name, (IV)numargs, PL_op_desc[type]);
5533                     op_free(kid);
5534                     kid = newop;
5535                     kid->op_sibling = sibl;
5536                     *tokid = kid;
5537                 }
5538                 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5539                     bad_type(numargs, "array", PL_op_desc[type], kid);
5540                 mod(kid, type);
5541                 break;
5542             case OA_HVREF:
5543                 if (kid->op_type == OP_CONST &&
5544                     (kid->op_private & OPpCONST_BARE))
5545                 {
5546                     char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5547                     OP *newop = newHVREF(newGVOP(OP_GV, 0,
5548                         gv_fetchpv(name, TRUE, SVt_PVHV) ));
5549                     if (ckWARN(WARN_DEPRECATED))
5550                         Perl_warner(aTHX_ WARN_DEPRECATED,
5551                             "Hash %%%s missing the %% in argument %"IVdf" of %s()",
5552                             name, (IV)numargs, PL_op_desc[type]);
5553                     op_free(kid);
5554                     kid = newop;
5555                     kid->op_sibling = sibl;
5556                     *tokid = kid;
5557                 }
5558                 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5559                     bad_type(numargs, "hash", PL_op_desc[type], kid);
5560                 mod(kid, type);
5561                 break;
5562             case OA_CVREF:
5563                 {
5564                     OP *newop = newUNOP(OP_NULL, 0, kid);
5565                     kid->op_sibling = 0;
5566                     linklist(kid);
5567                     newop->op_next = newop;
5568                     kid = newop;
5569                     kid->op_sibling = sibl;
5570                     *tokid = kid;
5571                 }
5572                 break;
5573             case OA_FILEREF:
5574                 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5575                     if (kid->op_type == OP_CONST &&
5576                         (kid->op_private & OPpCONST_BARE))
5577                     {
5578                         OP *newop = newGVOP(OP_GV, 0,
5579                             gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
5580                                         SVt_PVIO) );
5581                         op_free(kid);
5582                         kid = newop;
5583                     }
5584                     else if (kid->op_type == OP_READLINE) {
5585                         /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5586                         bad_type(numargs, "HANDLE", PL_op_desc[o->op_type], kid);
5587                     }
5588                     else {
5589                         I32 flags = OPf_SPECIAL;
5590                         I32 priv = 0;
5591                         PADOFFSET targ = 0;
5592
5593                         /* is this op a FH constructor? */
5594                         if (is_handle_constructor(o,numargs)) {
5595                             char *name = Nullch;
5596                             STRLEN len;
5597
5598                             flags = 0;
5599                             /* Set a flag to tell rv2gv to vivify
5600                              * need to "prove" flag does not mean something
5601                              * else already - NI-S 1999/05/07
5602                              */
5603                             priv = OPpDEREF;
5604                             if (kid->op_type == OP_PADSV) {
5605                                 SV **namep = av_fetch(PL_comppad_name,
5606                                                       kid->op_targ, 4);
5607                                 if (namep && *namep)
5608                                     name = SvPV(*namep, len);
5609                             }
5610                             else if (kid->op_type == OP_RV2SV
5611                                      && kUNOP->op_first->op_type == OP_GV)
5612                             {
5613                                 GV *gv = cGVOPx_gv(kUNOP->op_first);
5614                                 name = GvNAME(gv);
5615                                 len = GvNAMELEN(gv);
5616                             }
5617                             else if (kid->op_type == OP_AELEM
5618                                      || kid->op_type == OP_HELEM)
5619                             {
5620                                 name = "__ANONIO__";
5621                                 len = 10;
5622                                 mod(kid,type);
5623                             }
5624                             if (name) {
5625                                 SV *namesv;
5626                                 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5627                                 namesv = PL_curpad[targ];
5628                                 (void)SvUPGRADE(namesv, SVt_PV);
5629                                 if (*name != '$')
5630                                     sv_setpvn(namesv, "$", 1);
5631                                 sv_catpvn(namesv, name, len);
5632                             }
5633                         }
5634                         kid->op_sibling = 0;
5635                         kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5636                         kid->op_targ = targ;
5637                         kid->op_private |= priv;
5638                     }
5639                     kid->op_sibling = sibl;
5640                     *tokid = kid;
5641                 }
5642                 scalar(kid);
5643                 break;
5644             case OA_SCALARREF:
5645                 mod(scalar(kid), type);
5646                 break;
5647             }
5648             oa >>= 4;
5649             tokid = &kid->op_sibling;
5650             kid = kid->op_sibling;
5651         }
5652         o->op_private |= numargs;
5653         if (kid)
5654             return too_many_arguments(o,PL_op_desc[o->op_type]);
5655         listkids(o);
5656     }
5657     else if (PL_opargs[type] & OA_DEFGV) {
5658         op_free(o);
5659         return newUNOP(type, 0, newDEFSVOP());
5660     }
5661
5662     if (oa) {
5663         while (oa & OA_OPTIONAL)
5664             oa >>= 4;
5665         if (oa && oa != OA_LIST)
5666             return too_few_arguments(o,PL_op_desc[o->op_type]);
5667     }
5668     return o;
5669 }
5670
5671 OP *
5672 Perl_ck_glob(pTHX_ OP *o)
5673 {
5674     GV *gv;
5675
5676     o = ck_fun(o);
5677     if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5678         append_elem(OP_GLOB, o, newDEFSVOP());
5679
5680     if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV)) && GvIMPORTED_CV(gv)))
5681         gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5682
5683 #if !defined(PERL_EXTERNAL_GLOB)
5684     /* XXX this can be tightened up and made more failsafe. */
5685     if (!gv) {
5686         ENTER;
5687         Perl_load_module(aTHX_ 0, newSVpvn("File::Glob", 10), Nullsv,
5688                          /* null-terminated import list */
5689                          newSVpvn(":globally", 9), Nullsv);
5690         gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5691         LEAVE;
5692     }
5693 #endif /* PERL_EXTERNAL_GLOB */
5694
5695     if (gv && GvIMPORTED_CV(gv)) {
5696         append_elem(OP_GLOB, o,
5697                     newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5698         o->op_type = OP_LIST;
5699         o->op_ppaddr = PL_ppaddr[OP_LIST];
5700         cLISTOPo->op_first->op_type = OP_PUSHMARK;
5701         cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5702         o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5703                     append_elem(OP_LIST, o,
5704                                 scalar(newUNOP(OP_RV2CV, 0,
5705                                                newGVOP(OP_GV, 0, gv)))));
5706         o = newUNOP(OP_NULL, 0, ck_subr(o));
5707         o->op_targ = OP_GLOB;           /* hint at what it used to be */
5708         return o;
5709     }
5710     gv = newGVgen("main");
5711     gv_IOadd(gv);
5712     append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5713     scalarkids(o);
5714     return o;
5715 }
5716
5717 OP *
5718 Perl_ck_grep(pTHX_ OP *o)
5719 {
5720     LOGOP *gwop;
5721     OP *kid;
5722     OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5723
5724     o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5725     NewOp(1101, gwop, 1, LOGOP);
5726
5727     if (o->op_flags & OPf_STACKED) {
5728         OP* k;
5729         o = ck_sort(o);
5730         kid = cLISTOPo->op_first->op_sibling;
5731         for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
5732             kid = k;
5733         }
5734         kid->op_next = (OP*)gwop;
5735         o->op_flags &= ~OPf_STACKED;
5736     }
5737     kid = cLISTOPo->op_first->op_sibling;
5738     if (type == OP_MAPWHILE)
5739         list(kid);
5740     else
5741         scalar(kid);
5742     o = ck_fun(o);
5743     if (PL_error_count)
5744         return o;
5745     kid = cLISTOPo->op_first->op_sibling;
5746     if (kid->op_type != OP_NULL)
5747         Perl_croak(aTHX_ "panic: ck_grep");
5748     kid = kUNOP->op_first;
5749
5750     gwop->op_type = type;
5751     gwop->op_ppaddr = PL_ppaddr[type];
5752     gwop->op_first = listkids(o);
5753     gwop->op_flags |= OPf_KIDS;
5754     gwop->op_private = 1;
5755     gwop->op_other = LINKLIST(kid);
5756     gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5757     kid->op_next = (OP*)gwop;
5758
5759     kid = cLISTOPo->op_first->op_sibling;
5760     if (!kid || !kid->op_sibling)
5761         return too_few_arguments(o,PL_op_desc[o->op_type]);
5762     for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5763         mod(kid, OP_GREPSTART);
5764
5765     return (OP*)gwop;
5766 }
5767
5768 OP *
5769 Perl_ck_index(pTHX_ OP *o)
5770 {
5771     if (o->op_flags & OPf_KIDS) {
5772         OP *kid = cLISTOPo->op_first->op_sibling;       /* get past pushmark */
5773         if (kid)
5774             kid = kid->op_sibling;                      /* get past "big" */
5775         if (kid && kid->op_type == OP_CONST)
5776             fbm_compile(((SVOP*)kid)->op_sv, 0);
5777     }
5778     return ck_fun(o);
5779 }
5780
5781 OP *
5782 Perl_ck_lengthconst(pTHX_ OP *o)
5783 {
5784     /* XXX length optimization goes here */
5785     return ck_fun(o);
5786 }
5787
5788 OP *
5789 Perl_ck_lfun(pTHX_ OP *o)
5790 {
5791     OPCODE type = o->op_type;
5792     return modkids(ck_fun(o), type);
5793 }
5794
5795 OP *
5796 Perl_ck_defined(pTHX_ OP *o)            /* 19990527 MJD */
5797 {
5798     if ((o->op_flags & OPf_KIDS) && ckWARN(WARN_DEPRECATED)) {
5799         switch (cUNOPo->op_first->op_type) {
5800         case OP_RV2AV:
5801             /* This is needed for
5802                if (defined %stash::)
5803                to work.   Do not break Tk.
5804                */
5805             break;                      /* Globals via GV can be undef */
5806         case OP_PADAV:
5807         case OP_AASSIGN:                /* Is this a good idea? */
5808             Perl_warner(aTHX_ WARN_DEPRECATED,
5809                         "defined(@array) is deprecated");
5810             Perl_warner(aTHX_ WARN_DEPRECATED,
5811                         "\t(Maybe you should just omit the defined()?)\n");
5812         break;
5813         case OP_RV2HV:
5814             /* This is needed for
5815                if (defined %stash::)
5816                to work.   Do not break Tk.
5817                */
5818             break;                      /* Globals via GV can be undef */
5819         case OP_PADHV:
5820             Perl_warner(aTHX_ WARN_DEPRECATED,
5821                         "defined(%%hash) is deprecated");
5822             Perl_warner(aTHX_ WARN_DEPRECATED,
5823                         "\t(Maybe you should just omit the defined()?)\n");
5824             break;
5825         default:
5826             /* no warning */
5827             break;
5828         }
5829     }
5830     return ck_rfun(o);
5831 }
5832
5833 OP *
5834 Perl_ck_rfun(pTHX_ OP *o)
5835 {
5836     OPCODE type = o->op_type;
5837     return refkids(ck_fun(o), type);
5838 }
5839
5840 OP *
5841 Perl_ck_listiob(pTHX_ OP *o)
5842 {
5843     register OP *kid;
5844
5845     kid = cLISTOPo->op_first;
5846     if (!kid) {
5847         o = force_list(o);
5848         kid = cLISTOPo->op_first;
5849     }
5850     if (kid->op_type == OP_PUSHMARK)
5851         kid = kid->op_sibling;
5852     if (kid && o->op_flags & OPf_STACKED)
5853         kid = kid->op_sibling;
5854     else if (kid && !kid->op_sibling) {         /* print HANDLE; */
5855         if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
5856             o->op_flags |= OPf_STACKED; /* make it a filehandle */
5857             kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
5858             cLISTOPo->op_first->op_sibling = kid;
5859             cLISTOPo->op_last = kid;
5860             kid = kid->op_sibling;
5861         }
5862     }
5863
5864     if (!kid)
5865         append_elem(o->op_type, o, newDEFSVOP());
5866
5867     o = listkids(o);
5868
5869     o->op_private = 0;
5870 #ifdef USE_LOCALE
5871     if (PL_hints & HINT_LOCALE)
5872         o->op_private |= OPpLOCALE;
5873 #endif
5874
5875     return o;
5876 }
5877
5878 OP *
5879 Perl_ck_fun_locale(pTHX_ OP *o)
5880 {
5881     o = ck_fun(o);
5882
5883     o->op_private = 0;
5884 #ifdef USE_LOCALE
5885     if (PL_hints & HINT_LOCALE)
5886         o->op_private |= OPpLOCALE;
5887 #endif
5888
5889     return o;
5890 }
5891
5892 OP *
5893 Perl_ck_sassign(pTHX_ OP *o)
5894 {
5895     OP *kid = cLISTOPo->op_first;
5896     /* has a disposable target? */
5897     if ((PL_opargs[kid->op_type] & OA_TARGLEX)
5898         && !(kid->op_flags & OPf_STACKED)
5899         /* Cannot steal the second time! */
5900         && !(kid->op_private & OPpTARGET_MY))
5901     {
5902         OP *kkid = kid->op_sibling;
5903
5904         /* Can just relocate the target. */
5905         if (kkid && kkid->op_type == OP_PADSV
5906             && !(kkid->op_private & OPpLVAL_INTRO))
5907         {
5908             kid->op_targ = kkid->op_targ;
5909             kkid->op_targ = 0;
5910             /* Now we do not need PADSV and SASSIGN. */
5911             kid->op_sibling = o->op_sibling;    /* NULL */
5912             cLISTOPo->op_first = NULL;
5913             op_free(o);
5914             op_free(kkid);
5915             kid->op_private |= OPpTARGET_MY;    /* Used for context settings */
5916             return kid;
5917         }
5918     }
5919     return o;
5920 }
5921
5922 OP *
5923 Perl_ck_scmp(pTHX_ OP *o)
5924 {
5925     o->op_private = 0;
5926 #ifdef USE_LOCALE
5927     if (PL_hints & HINT_LOCALE)
5928         o->op_private |= OPpLOCALE;
5929 #endif
5930
5931     return o;
5932 }
5933
5934 OP *
5935 Perl_ck_match(pTHX_ OP *o)
5936 {
5937     o->op_private |= OPpRUNTIME;
5938     return o;
5939 }
5940
5941 OP *
5942 Perl_ck_method(pTHX_ OP *o)
5943 {
5944     OP *kid = cUNOPo->op_first;
5945     if (kid->op_type == OP_CONST) {
5946         SV* sv = kSVOP->op_sv;
5947         if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
5948             OP *cmop;
5949             if (!SvREADONLY(sv) || !SvFAKE(sv)) {
5950                 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
5951             }
5952             else {
5953                 kSVOP->op_sv = Nullsv;
5954             }
5955             cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
5956             op_free(o);
5957             return cmop;
5958         }
5959     }
5960     return o;
5961 }
5962
5963 OP *
5964 Perl_ck_null(pTHX_ OP *o)
5965 {
5966     return o;
5967 }
5968
5969 OP *
5970 Perl_ck_open(pTHX_ OP *o)
5971 {
5972     HV *table = GvHV(PL_hintgv);
5973     if (table) {
5974         SV **svp;
5975         I32 mode;
5976         svp = hv_fetch(table, "open_IN", 7, FALSE);
5977         if (svp && *svp) {
5978             mode = mode_from_discipline(*svp);
5979             if (mode & O_BINARY)
5980                 o->op_private |= OPpOPEN_IN_RAW;
5981             else if (mode & O_TEXT)
5982                 o->op_private |= OPpOPEN_IN_CRLF;
5983         }
5984
5985         svp = hv_fetch(table, "open_OUT", 8, FALSE);
5986         if (svp && *svp) {
5987             mode = mode_from_discipline(*svp);
5988             if (mode & O_BINARY)
5989                 o->op_private |= OPpOPEN_OUT_RAW;
5990             else if (mode & O_TEXT)
5991                 o->op_private |= OPpOPEN_OUT_CRLF;
5992         }
5993     }
5994     if (o->op_type == OP_BACKTICK)
5995         return o;
5996     return ck_fun(o);
5997 }
5998
5999 OP *
6000 Perl_ck_repeat(pTHX_ OP *o)
6001 {
6002     if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6003         o->op_private |= OPpREPEAT_DOLIST;
6004         cBINOPo->op_first = force_list(cBINOPo->op_first);
6005     }
6006     else
6007         scalar(o);
6008     return o;
6009 }
6010
6011 OP *
6012 Perl_ck_require(pTHX_ OP *o)
6013 {
6014     if (o->op_flags & OPf_KIDS) {       /* Shall we supply missing .pm? */
6015         SVOP *kid = (SVOP*)cUNOPo->op_first;
6016
6017         if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6018             char *s;
6019             for (s = SvPVX(kid->op_sv); *s; s++) {
6020                 if (*s == ':' && s[1] == ':') {
6021                     *s = '/';
6022                     Move(s+2, s+1, strlen(s+2)+1, char);
6023                     --SvCUR(kid->op_sv);
6024                 }
6025             }
6026             if (SvREADONLY(kid->op_sv)) {
6027                 SvREADONLY_off(kid->op_sv);
6028                 sv_catpvn(kid->op_sv, ".pm", 3);
6029                 SvREADONLY_on(kid->op_sv);
6030             }
6031             else
6032                 sv_catpvn(kid->op_sv, ".pm", 3);
6033         }
6034     }
6035     return ck_fun(o);
6036 }
6037
6038 #if 0
6039 OP *
6040 Perl_ck_retarget(pTHX_ OP *o)
6041 {
6042     Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
6043     /* STUB */
6044     return o;
6045 }
6046 #endif
6047
6048 OP *
6049 Perl_ck_select(pTHX_ OP *o)
6050 {
6051     OP* kid;
6052     if (o->op_flags & OPf_KIDS) {
6053         kid = cLISTOPo->op_first->op_sibling;   /* get past pushmark */
6054         if (kid && kid->op_sibling) {
6055             o->op_type = OP_SSELECT;
6056             o->op_ppaddr = PL_ppaddr[OP_SSELECT];
6057             o = ck_fun(o);
6058             return fold_constants(o);
6059         }
6060     }
6061     o = ck_fun(o);
6062     kid = cLISTOPo->op_first->op_sibling;    /* get past pushmark */
6063     if (kid && kid->op_type == OP_RV2GV)
6064         kid->op_private &= ~HINT_STRICT_REFS;
6065     return o;
6066 }
6067
6068 OP *
6069 Perl_ck_shift(pTHX_ OP *o)
6070 {
6071     I32 type = o->op_type;
6072
6073     if (!(o->op_flags & OPf_KIDS)) {
6074         OP *argop;
6075
6076         op_free(o);
6077 #ifdef USE_THREADS
6078         if (!CvUNIQUE(PL_compcv)) {
6079             argop = newOP(OP_PADAV, OPf_REF);
6080             argop->op_targ = 0;         /* PL_curpad[0] is @_ */
6081         }
6082         else {
6083             argop = newUNOP(OP_RV2AV, 0,
6084                 scalar(newGVOP(OP_GV, 0,
6085                     gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6086         }
6087 #else
6088         argop = newUNOP(OP_RV2AV, 0,
6089             scalar(newGVOP(OP_GV, 0, !CvUNIQUE(PL_compcv) ?
6090                            PL_defgv : gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6091 #endif /* USE_THREADS */
6092         return newUNOP(type, 0, scalar(argop));
6093     }
6094     return scalar(modkids(ck_fun(o), type));
6095 }
6096
6097 OP *
6098 Perl_ck_sort(pTHX_ OP *o)
6099 {
6100     OP *firstkid;
6101     o->op_private = 0;
6102 #ifdef USE_LOCALE
6103     if (PL_hints & HINT_LOCALE)
6104         o->op_private |= OPpLOCALE;
6105 #endif
6106
6107     if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6108         simplify_sort(o);
6109     firstkid = cLISTOPo->op_first->op_sibling;          /* get past pushmark */
6110     if (o->op_flags & OPf_STACKED) {                    /* may have been cleared */
6111         OP *k;
6112         OP *kid = cUNOPx(firstkid)->op_first;           /* get past null */
6113
6114         if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
6115             linklist(kid);
6116             if (kid->op_type == OP_SCOPE) {
6117                 k = kid->op_next;
6118                 kid->op_next = 0;
6119             }
6120             else if (kid->op_type == OP_LEAVE) {
6121                 if (o->op_type == OP_SORT) {
6122                     null(kid);                  /* wipe out leave */
6123                     kid->op_next = kid;
6124
6125                     for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6126                         if (k->op_next == kid)
6127                             k->op_next = 0;
6128                         /* don't descend into loops */
6129                         else if (k->op_type == OP_ENTERLOOP
6130                                  || k->op_type == OP_ENTERITER)
6131                         {
6132                             k = cLOOPx(k)->op_lastop;
6133                         }
6134                     }
6135                 }
6136                 else
6137                     kid->op_next = 0;           /* just disconnect the leave */
6138                 k = kLISTOP->op_first;
6139             }
6140             peep(k);
6141
6142             kid = firstkid;
6143             if (o->op_type == OP_SORT) {
6144                 /* provide scalar context for comparison function/block */
6145                 kid = scalar(kid);
6146                 kid->op_next = kid;
6147             }
6148             else
6149                 kid->op_next = k;
6150             o->op_flags |= OPf_SPECIAL;
6151         }
6152         else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6153             null(firstkid);
6154
6155         firstkid = firstkid->op_sibling;
6156     }
6157
6158     /* provide list context for arguments */
6159     if (o->op_type == OP_SORT)
6160         list(firstkid);
6161
6162     return o;
6163 }
6164
6165 STATIC void
6166 S_simplify_sort(pTHX_ OP *o)
6167 {
6168     register OP *kid = cLISTOPo->op_first->op_sibling;  /* get past pushmark */
6169     OP *k;
6170     int reversed;
6171     GV *gv;
6172     if (!(o->op_flags & OPf_STACKED))
6173         return;
6174     GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
6175     GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
6176     kid = kUNOP->op_first;                              /* get past null */
6177     if (kid->op_type != OP_SCOPE)
6178         return;
6179     kid = kLISTOP->op_last;                             /* get past scope */
6180     switch(kid->op_type) {
6181         case OP_NCMP:
6182         case OP_I_NCMP:
6183         case OP_SCMP:
6184             break;
6185         default:
6186             return;
6187     }
6188     k = kid;                                            /* remember this node*/
6189     if (kBINOP->op_first->op_type != OP_RV2SV)
6190         return;
6191     kid = kBINOP->op_first;                             /* get past cmp */
6192     if (kUNOP->op_first->op_type != OP_GV)
6193         return;
6194     kid = kUNOP->op_first;                              /* get past rv2sv */
6195     gv = kGVOP_gv;
6196     if (GvSTASH(gv) != PL_curstash)
6197         return;
6198     if (strEQ(GvNAME(gv), "a"))
6199         reversed = 0;
6200     else if (strEQ(GvNAME(gv), "b"))
6201         reversed = 1;
6202     else
6203         return;
6204     kid = k;                                            /* back to cmp */
6205     if (kBINOP->op_last->op_type != OP_RV2SV)
6206         return;
6207     kid = kBINOP->op_last;                              /* down to 2nd arg */
6208     if (kUNOP->op_first->op_type != OP_GV)
6209         return;
6210     kid = kUNOP->op_first;                              /* get past rv2sv */
6211     gv = kGVOP_gv;
6212     if (GvSTASH(gv) != PL_curstash
6213         || ( reversed
6214             ? strNE(GvNAME(gv), "a")
6215             : strNE(GvNAME(gv), "b")))
6216         return;
6217     o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6218     if (reversed)
6219         o->op_private |= OPpSORT_REVERSE;
6220     if (k->op_type == OP_NCMP)
6221         o->op_private |= OPpSORT_NUMERIC;
6222     if (k->op_type == OP_I_NCMP)
6223         o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6224     kid = cLISTOPo->op_first->op_sibling;
6225     cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6226     op_free(kid);                                     /* then delete it */
6227     cLISTOPo->op_children--;
6228 }
6229
6230 OP *
6231 Perl_ck_split(pTHX_ OP *o)
6232 {
6233     register OP *kid;
6234
6235     if (o->op_flags & OPf_STACKED)
6236         return no_fh_allowed(o);
6237
6238     kid = cLISTOPo->op_first;
6239     if (kid->op_type != OP_NULL)
6240         Perl_croak(aTHX_ "panic: ck_split");
6241     kid = kid->op_sibling;
6242     op_free(cLISTOPo->op_first);
6243     cLISTOPo->op_first = kid;
6244     if (!kid) {
6245         cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
6246         cLISTOPo->op_last = kid; /* There was only one element previously */
6247     }
6248
6249     if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6250         OP *sibl = kid->op_sibling;
6251         kid->op_sibling = 0;
6252         kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
6253         if (cLISTOPo->op_first == cLISTOPo->op_last)
6254             cLISTOPo->op_last = kid;
6255         cLISTOPo->op_first = kid;
6256         kid->op_sibling = sibl;
6257     }
6258
6259     kid->op_type = OP_PUSHRE;
6260     kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6261     scalar(kid);
6262
6263     if (!kid->op_sibling)
6264         append_elem(OP_SPLIT, o, newDEFSVOP());
6265
6266     kid = kid->op_sibling;
6267     scalar(kid);
6268
6269     if (!kid->op_sibling)
6270         append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6271
6272     kid = kid->op_sibling;
6273     scalar(kid);
6274
6275     if (kid->op_sibling)
6276         return too_many_arguments(o,PL_op_desc[o->op_type]);
6277
6278     return o;
6279 }
6280
6281 OP *
6282 Perl_ck_join(pTHX_ OP *o)
6283 {
6284     if (ckWARN(WARN_SYNTAX)) {
6285         OP *kid = cLISTOPo->op_first->op_sibling;
6286         if (kid && kid->op_type == OP_MATCH) {
6287             char *pmstr = "STRING";
6288             if (kPMOP->op_pmregexp)
6289                 pmstr = kPMOP->op_pmregexp->precomp;
6290             Perl_warner(aTHX_ WARN_SYNTAX,
6291                         "/%s/ should probably be written as \"%s\"",
6292                         pmstr, pmstr);
6293         }
6294     }
6295     return ck_fun(o);
6296 }
6297
6298 OP *
6299 Perl_ck_subr(pTHX_ OP *o)
6300 {
6301     OP *prev = ((cUNOPo->op_first->op_sibling)
6302              ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6303     OP *o2 = prev->op_sibling;
6304     OP *cvop;
6305     char *proto = 0;
6306     CV *cv = 0;
6307     GV *namegv = 0;
6308     int optional = 0;
6309     I32 arg = 0;
6310     STRLEN n_a;
6311
6312     o->op_private |= OPpENTERSUB_HASTARG;
6313     for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6314     if (cvop->op_type == OP_RV2CV) {
6315         SVOP* tmpop;
6316         o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6317         null(cvop);             /* disable rv2cv */
6318         tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6319         if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6320             GV *gv = cGVOPx_gv(tmpop);
6321             cv = GvCVu(gv);
6322             if (!cv)
6323                 tmpop->op_private |= OPpEARLY_CV;
6324             else if (SvPOK(cv)) {
6325                 namegv = CvANON(cv) ? gv : CvGV(cv);
6326                 proto = SvPV((SV*)cv, n_a);
6327             }
6328         }
6329     }
6330     else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6331         if (o2->op_type == OP_CONST)
6332             o2->op_private &= ~OPpCONST_STRICT;
6333         else if (o2->op_type == OP_LIST) {
6334             OP *o = ((UNOP*)o2)->op_first->op_sibling;
6335             if (o && o->op_type == OP_CONST)
6336                 o->op_private &= ~OPpCONST_STRICT;
6337         }
6338     }
6339     o->op_private |= (PL_hints & HINT_STRICT_REFS);
6340     if (PERLDB_SUB && PL_curstash != PL_debstash)
6341         o->op_private |= OPpENTERSUB_DB;
6342     while (o2 != cvop) {
6343         if (proto) {
6344             switch (*proto) {
6345             case '\0':
6346                 return too_many_arguments(o, gv_ename(namegv));
6347             case ';':
6348                 optional = 1;
6349                 proto++;
6350                 continue;
6351             case '$':
6352                 proto++;
6353                 arg++;
6354                 scalar(o2);
6355                 break;
6356             case '%':
6357             case '@':
6358                 list(o2);
6359                 arg++;
6360                 break;
6361             case '&':
6362                 proto++;
6363                 arg++;
6364                 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6365                     bad_type(arg,
6366                         arg == 1 ? "block or sub {}" : "sub {}",
6367                         gv_ename(namegv), o2);
6368                 break;
6369             case '*':
6370                 /* '*' allows any scalar type, including bareword */
6371                 proto++;
6372                 arg++;
6373                 if (o2->op_type == OP_RV2GV)
6374                     goto wrapref;       /* autoconvert GLOB -> GLOBref */
6375                 else if (o2->op_type == OP_CONST)
6376                     o2->op_private &= ~OPpCONST_STRICT;
6377                 else if (o2->op_type == OP_ENTERSUB) {
6378                     /* accidental subroutine, revert to bareword */
6379                     OP *gvop = ((UNOP*)o2)->op_first;
6380                     if (gvop && gvop->op_type == OP_NULL) {
6381                         gvop = ((UNOP*)gvop)->op_first;
6382                         if (gvop) {
6383                             for (; gvop->op_sibling; gvop = gvop->op_sibling)
6384                                 ;
6385                             if (gvop &&
6386                                 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6387                                 (gvop = ((UNOP*)gvop)->op_first) &&
6388                                 gvop->op_type == OP_GV)
6389                             {
6390                                 GV *gv = cGVOPx_gv(gvop);
6391                                 OP *sibling = o2->op_sibling;
6392                                 SV *n = newSVpvn("",0);
6393                                 op_free(o2);
6394                                 gv_fullname3(n, gv, "");
6395                                 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
6396                                     sv_chop(n, SvPVX(n)+6);
6397                                 o2 = newSVOP(OP_CONST, 0, n);
6398                                 prev->op_sibling = o2;
6399                                 o2->op_sibling = sibling;
6400                             }
6401                         }
6402                     }
6403                 }
6404                 scalar(o2);
6405                 break;
6406             case '\\':
6407                 proto++;
6408                 arg++;
6409                 switch (*proto++) {
6410                 case '*':
6411                     if (o2->op_type != OP_RV2GV)
6412                         bad_type(arg, "symbol", gv_ename(namegv), o2);
6413                     goto wrapref;
6414                 case '&':
6415                     if (o2->op_type != OP_ENTERSUB)
6416                         bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6417                     goto wrapref;
6418                 case '$':
6419                     if (o2->op_type != OP_RV2SV
6420                         && o2->op_type != OP_PADSV
6421                         && o2->op_type != OP_HELEM
6422                         && o2->op_type != OP_AELEM
6423                         && o2->op_type != OP_THREADSV)
6424                     {
6425                         bad_type(arg, "scalar", gv_ename(namegv), o2);
6426                     }
6427                     goto wrapref;
6428                 case '@':
6429                     if (o2->op_type != OP_RV2AV && o2->op_type != OP_PADAV)
6430                         bad_type(arg, "array", gv_ename(namegv), o2);
6431                     goto wrapref;
6432                 case '%':
6433                     if (o2->op_type != OP_RV2HV && o2->op_type != OP_PADHV)
6434                         bad_type(arg, "hash", gv_ename(namegv), o2);
6435                   wrapref:
6436                     {
6437                         OP* kid = o2;
6438                         OP* sib = kid->op_sibling;
6439                         kid->op_sibling = 0;
6440                         o2 = newUNOP(OP_REFGEN, 0, kid);
6441                         o2->op_sibling = sib;
6442                         prev->op_sibling = o2;
6443                     }
6444                     break;
6445                 default: goto oops;
6446                 }
6447                 break;
6448             case ' ':
6449                 proto++;
6450                 continue;
6451             default:
6452               oops:
6453                 Perl_croak(aTHX_ "Malformed prototype for %s: %s",
6454                         gv_ename(namegv), SvPV((SV*)cv, n_a));
6455             }
6456         }
6457         else
6458             list(o2);
6459         mod(o2, OP_ENTERSUB);
6460         prev = o2;
6461         o2 = o2->op_sibling;
6462     }
6463     if (proto && !optional &&
6464           (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6465         return too_few_arguments(o, gv_ename(namegv));
6466     return o;
6467 }
6468
6469 OP *
6470 Perl_ck_svconst(pTHX_ OP *o)
6471 {
6472     SvREADONLY_on(cSVOPo->op_sv);
6473     return o;
6474 }
6475
6476 OP *
6477 Perl_ck_trunc(pTHX_ OP *o)
6478 {
6479     if (o->op_flags & OPf_KIDS) {
6480         SVOP *kid = (SVOP*)cUNOPo->op_first;
6481
6482         if (kid->op_type == OP_NULL)
6483             kid = (SVOP*)kid->op_sibling;
6484         if (kid && kid->op_type == OP_CONST &&
6485             (kid->op_private & OPpCONST_BARE))
6486         {
6487             o->op_flags |= OPf_SPECIAL;
6488             kid->op_private &= ~OPpCONST_STRICT;
6489         }
6490     }
6491     return ck_fun(o);
6492 }
6493
6494 OP *
6495 Perl_ck_substr(pTHX_ OP *o)
6496 {
6497     o = ck_fun(o);
6498     if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6499         OP *kid = cLISTOPo->op_first;
6500
6501         if (kid->op_type == OP_NULL)
6502             kid = kid->op_sibling;
6503         if (kid)
6504             kid->op_flags |= OPf_MOD;
6505
6506     }
6507     return o;
6508 }
6509
6510 /* A peephole optimizer.  We visit the ops in the order they're to execute. */
6511
6512 void
6513 Perl_peep(pTHX_ register OP *o)
6514 {
6515     register OP* oldop = 0;
6516     STRLEN n_a;
6517     OP *last_composite = Nullop;
6518
6519     if (!o || o->op_seq)
6520         return;
6521     ENTER;
6522     SAVEOP();
6523     SAVEVPTR(PL_curcop);
6524     for (; o; o = o->op_next) {
6525         if (o->op_seq)
6526             break;
6527         if (!PL_op_seqmax)
6528             PL_op_seqmax++;
6529         PL_op = o;
6530         switch (o->op_type) {
6531         case OP_SETSTATE:
6532         case OP_NEXTSTATE:
6533         case OP_DBSTATE:
6534             PL_curcop = ((COP*)o);              /* for warnings */
6535             o->op_seq = PL_op_seqmax++;
6536             last_composite = Nullop;
6537             break;
6538
6539         case OP_CONST:
6540             if (cSVOPo->op_private & OPpCONST_STRICT)
6541                 no_bareword_allowed(o);
6542 #ifdef USE_ITHREADS
6543             /* Relocate sv to the pad for thread safety.
6544              * Despite being a "constant", the SV is written to,
6545              * for reference counts, sv_upgrade() etc. */
6546             if (cSVOP->op_sv) {
6547                 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6548                 if (SvPADTMP(cSVOPo->op_sv)) {
6549                     /* If op_sv is already a PADTMP then it is being used by
6550                      * some pad, so make a copy. */
6551                     sv_setsv(PL_curpad[ix],cSVOPo->op_sv);
6552                     SvREADONLY_on(PL_curpad[ix]);
6553                     SvREFCNT_dec(cSVOPo->op_sv);
6554                 }
6555                 else {
6556                     SvREFCNT_dec(PL_curpad[ix]);
6557                     SvPADTMP_on(cSVOPo->op_sv);
6558                     PL_curpad[ix] = cSVOPo->op_sv;
6559                     /* XXX I don't know how this isn't readonly already. */
6560                     SvREADONLY_on(PL_curpad[ix]);
6561                 }
6562                 cSVOPo->op_sv = Nullsv;
6563                 o->op_targ = ix;
6564             }
6565 #endif
6566             o->op_seq = PL_op_seqmax++;
6567             break;
6568
6569         case OP_CONCAT:
6570             if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6571                 if (o->op_next->op_private & OPpTARGET_MY) {
6572                     if (o->op_flags & OPf_STACKED) /* chained concats */
6573                         goto ignore_optimization;
6574                     else {
6575                         /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6576                         o->op_targ = o->op_next->op_targ;
6577                         o->op_next->op_targ = 0;
6578                         o->op_private |= OPpTARGET_MY;
6579                     }
6580                 }
6581                 null(o->op_next);
6582             }
6583           ignore_optimization:
6584             o->op_seq = PL_op_seqmax++;
6585             break;
6586         case OP_STUB:
6587             if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6588                 o->op_seq = PL_op_seqmax++;
6589                 break; /* Scalar stub must produce undef.  List stub is noop */
6590             }
6591             goto nothin;
6592         case OP_NULL:
6593             if (o->op_targ == OP_NEXTSTATE
6594                 || o->op_targ == OP_DBSTATE
6595                 || o->op_targ == OP_SETSTATE)
6596             {
6597                 PL_curcop = ((COP*)o);
6598             }
6599             goto nothin;
6600         case OP_SCALAR:
6601         case OP_LINESEQ:
6602         case OP_SCOPE:
6603           nothin:
6604             if (oldop && o->op_next) {
6605                 oldop->op_next = o->op_next;
6606                 continue;
6607             }
6608             o->op_seq = PL_op_seqmax++;
6609             break;
6610
6611         case OP_GV:
6612             if (o->op_next->op_type == OP_RV2SV) {
6613                 if (!(o->op_next->op_private & OPpDEREF)) {
6614                     null(o->op_next);
6615                     o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6616                                                                | OPpOUR_INTRO);
6617                     o->op_next = o->op_next->op_next;
6618                     o->op_type = OP_GVSV;
6619                     o->op_ppaddr = PL_ppaddr[OP_GVSV];
6620                 }
6621             }
6622             else if (o->op_next->op_type == OP_RV2AV) {
6623                 OP* pop = o->op_next->op_next;
6624                 IV i;
6625                 if (pop->op_type == OP_CONST &&
6626                     (PL_op = pop->op_next) &&
6627                     pop->op_next->op_type == OP_AELEM &&
6628                     !(pop->op_next->op_private &
6629                       (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF)) &&
6630                     (i = SvIV(((SVOP*)pop)->op_sv) - PL_compiling.cop_arybase)
6631                                 <= 255 &&
6632                     i >= 0)
6633                 {
6634                     GV *gv;
6635                     null(o->op_next);
6636                     null(pop->op_next);
6637                     null(pop);
6638                     o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6639                     o->op_next = pop->op_next->op_next;
6640                     o->op_type = OP_AELEMFAST;
6641                     o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6642                     o->op_private = (U8)i;
6643                     gv = cGVOPo_gv;
6644                     GvAVn(gv);
6645                 }
6646             }
6647             else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6648                 GV *gv = cGVOPo_gv;
6649                 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
6650                     /* XXX could check prototype here instead of just carping */
6651                     SV *sv = sv_newmortal();
6652                     gv_efullname3(sv, gv, Nullch);
6653                     Perl_warner(aTHX_ WARN_PROTOTYPE,
6654                                 "%s() called too early to check prototype",
6655                                 SvPV_nolen(sv));
6656                 }
6657             }
6658
6659             o->op_seq = PL_op_seqmax++;
6660             break;
6661
6662         case OP_MAPWHILE:
6663         case OP_GREPWHILE:
6664         case OP_AND:
6665         case OP_OR:
6666         case OP_ANDASSIGN:
6667         case OP_ORASSIGN:
6668         case OP_COND_EXPR:
6669         case OP_RANGE:
6670             o->op_seq = PL_op_seqmax++;
6671             while (cLOGOP->op_other->op_type == OP_NULL)
6672                 cLOGOP->op_other = cLOGOP->op_other->op_next;
6673             peep(cLOGOP->op_other);
6674             break;
6675
6676         case OP_ENTERLOOP:
6677             o->op_seq = PL_op_seqmax++;
6678             peep(cLOOP->op_redoop);
6679             peep(cLOOP->op_nextop);
6680             peep(cLOOP->op_lastop);
6681             break;
6682
6683         case OP_QR:
6684         case OP_MATCH:
6685         case OP_SUBST:
6686             o->op_seq = PL_op_seqmax++;
6687             peep(cPMOP->op_pmreplstart);
6688             break;
6689
6690         case OP_EXEC:
6691             o->op_seq = PL_op_seqmax++;
6692             if (ckWARN(WARN_SYNTAX) && o->op_next
6693                 && o->op_next->op_type == OP_NEXTSTATE) {
6694                 if (o->op_next->op_sibling &&
6695                         o->op_next->op_sibling->op_type != OP_EXIT &&
6696                         o->op_next->op_sibling->op_type != OP_WARN &&
6697                         o->op_next->op_sibling->op_type != OP_DIE) {
6698                     line_t oldline = CopLINE(PL_curcop);
6699
6700                     CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6701                     Perl_warner(aTHX_ WARN_EXEC,
6702                                 "Statement unlikely to be reached");
6703                     Perl_warner(aTHX_ WARN_EXEC,
6704                                 "\t(Maybe you meant system() when you said exec()?)\n");
6705                     CopLINE_set(PL_curcop, oldline);
6706                 }
6707             }
6708             break;
6709
6710         case OP_HELEM: {
6711             UNOP *rop;
6712             SV *lexname;
6713             GV **fields;
6714             SV **svp, **indsvp, *sv;
6715             I32 ind;
6716             char *key = NULL;
6717             STRLEN keylen;
6718
6719             o->op_seq = PL_op_seqmax++;
6720
6721             if (((BINOP*)o)->op_last->op_type != OP_CONST)
6722                 break;
6723
6724             /* Make the CONST have a shared SV */
6725             svp = cSVOPx_svp(((BINOP*)o)->op_last);
6726             if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
6727                 key = SvPV(sv, keylen);
6728                 if (SvUTF8(sv))
6729                   keylen = -keylen;
6730                 lexname = newSVpvn_share(key, keylen, 0);
6731                 SvREFCNT_dec(sv);
6732                 *svp = lexname;
6733             }
6734
6735             if ((o->op_private & (OPpLVAL_INTRO)))
6736                 break;
6737
6738             rop = (UNOP*)((BINOP*)o)->op_first;
6739             if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6740                 break;
6741             lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
6742             if (!SvOBJECT(lexname))
6743                 break;
6744             fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6745             if (!fields || !GvHV(*fields))
6746                 break;
6747             key = SvPV(*svp, keylen);
6748             indsvp = hv_fetch(GvHV(*fields), key, keylen, FALSE);
6749             if (!indsvp) {
6750                 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" in variable %s of type %s",
6751                       key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
6752             }
6753             ind = SvIV(*indsvp);
6754             if (ind < 1)
6755                 Perl_croak(aTHX_ "Bad index while coercing array into hash");
6756             rop->op_type = OP_RV2AV;
6757             rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
6758             o->op_type = OP_AELEM;
6759             o->op_ppaddr = PL_ppaddr[OP_AELEM];
6760             sv = newSViv(ind);
6761             if (SvREADONLY(*svp))
6762                 SvREADONLY_on(sv);
6763             SvFLAGS(sv) |= (SvFLAGS(*svp)
6764                             & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
6765             SvREFCNT_dec(*svp);
6766             *svp = sv;
6767             break;
6768         }
6769
6770         case OP_HSLICE: {
6771             UNOP *rop;
6772             SV *lexname;
6773             GV **fields;
6774             SV **svp, **indsvp, *sv;
6775             I32 ind;
6776             char *key;
6777             STRLEN keylen;
6778             SVOP *first_key_op, *key_op;
6779
6780             o->op_seq = PL_op_seqmax++;
6781             if ((o->op_private & (OPpLVAL_INTRO))
6782                 /* I bet there's always a pushmark... */
6783                 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
6784                 /* hmmm, no optimization if list contains only one key. */
6785                 break;
6786             rop = (UNOP*)((LISTOP*)o)->op_last;
6787             if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6788                 break;
6789             lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
6790             if (!SvOBJECT(lexname))
6791                 break;
6792             fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6793             if (!fields || !GvHV(*fields))
6794                 break;
6795             /* Again guessing that the pushmark can be jumped over.... */
6796             first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
6797                 ->op_first->op_sibling;
6798             /* Check that the key list contains only constants. */
6799             for (key_op = first_key_op; key_op;
6800                  key_op = (SVOP*)key_op->op_sibling)
6801                 if (key_op->op_type != OP_CONST)
6802                     break;
6803             if (key_op)
6804                 break;
6805             rop->op_type = OP_RV2AV;
6806             rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
6807             o->op_type = OP_ASLICE;
6808             o->op_ppaddr = PL_ppaddr[OP_ASLICE];
6809             for (key_op = first_key_op; key_op;
6810                  key_op = (SVOP*)key_op->op_sibling) {
6811                 svp = cSVOPx_svp(key_op);
6812                 key = SvPV(*svp, keylen);
6813                 indsvp = hv_fetch(GvHV(*fields), key, keylen, FALSE);
6814                 if (!indsvp) {
6815                     Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" "
6816                                "in variable %s of type %s",
6817                           key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
6818                 }
6819                 ind = SvIV(*indsvp);
6820                 if (ind < 1)
6821                     Perl_croak(aTHX_ "Bad index while coercing array into hash");
6822                 sv = newSViv(ind);
6823                 if (SvREADONLY(*svp))
6824                     SvREADONLY_on(sv);
6825                 SvFLAGS(sv) |= (SvFLAGS(*svp)
6826                                 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
6827                 SvREFCNT_dec(*svp);
6828                 *svp = sv;
6829             }
6830             break;
6831         }
6832
6833         case OP_RV2AV:
6834         case OP_RV2HV:
6835             if (!(o->op_flags & OPf_WANT)
6836                 || (o->op_flags & OPf_WANT) == OPf_WANT_LIST)
6837             {
6838                 last_composite = o;
6839             }
6840             o->op_seq = PL_op_seqmax++;
6841             break;
6842
6843         case OP_RETURN:
6844             if (o->op_next && o->op_next->op_type != OP_LEAVESUBLV) {
6845                 o->op_seq = PL_op_seqmax++;
6846                 break;
6847             }
6848             /* FALL THROUGH */
6849
6850         case OP_LEAVESUBLV:
6851             if (last_composite) {
6852                 OP *r = last_composite;
6853
6854                 while (r->op_sibling)
6855                    r = r->op_sibling;
6856                 if (r->op_next == o
6857                     || (r->op_next->op_type == OP_LIST
6858                         && r->op_next->op_next == o))
6859                 {
6860                     if (last_composite->op_type == OP_RV2AV)
6861                         yyerror("Lvalue subs returning arrays not implemented yet");
6862                     else
6863                         yyerror("Lvalue subs returning hashes not implemented yet");
6864                         ;
6865                 }
6866             }
6867             /* FALL THROUGH */
6868
6869         default:
6870             o->op_seq = PL_op_seqmax++;
6871             break;
6872         }
6873         oldop = o;
6874     }
6875     LEAVE;
6876 }
6877
6878 #include "XSUB.h"
6879
6880 /* Efficient sub that returns a constant scalar value. */
6881 static void
6882 const_sv_xsub(pTHXo_ CV* cv)
6883 {
6884     dXSARGS;
6885     EXTEND(sp, 1);
6886     ST(0) = (SV*)XSANY.any_ptr;
6887     XSRETURN(1);
6888 }