op.c

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