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         return newSVOP(OP_CONST, 0, sv);
2330     }
2331
2332   nope:
2333     if (!(PL_opargs[type] & OA_OTHERINT))
2334         return o;
2335
2336     if (!(PL_hints & HINT_INTEGER)) {
2337         if (type == OP_MODULO
2338             || type == OP_DIVIDE
2339             || !(o->op_flags & OPf_KIDS))
2340         {
2341             return o;
2342         }
2343
2344         for (curop = ((UNOP*)o)->op_first; curop; curop = curop->op_sibling) {
2345             if (curop->op_type == OP_CONST) {
2346                 if (SvIOK(((SVOP*)curop)->op_sv))
2347                     continue;
2348                 return o;
2349             }
2350             if (PL_opargs[curop->op_type] & OA_RETINTEGER)
2351                 continue;
2352             return o;
2353         }
2354         o->op_ppaddr = PL_ppaddr[++(o->op_type)];
2355     }
2356
2357     return o;
2358 }
2359
2360 OP *
2361 Perl_gen_constant_list(pTHX_ register OP *o)
2362 {
2363     register OP *curop;
2364     I32 oldtmps_floor = PL_tmps_floor;
2365
2366     list(o);
2367     if (PL_error_count)
2368         return o;               /* Don't attempt to run with errors */
2369
2370     PL_op = curop = LINKLIST(o);
2371     o->op_next = 0;
2372     peep(curop);
2373     pp_pushmark();
2374     CALLRUNOPS(aTHX);
2375     PL_op = curop;
2376     pp_anonlist();
2377     PL_tmps_floor = oldtmps_floor;
2378
2379     o->op_type = OP_RV2AV;
2380     o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2381     curop = ((UNOP*)o)->op_first;
2382     ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
2383     op_free(curop);
2384     linklist(o);
2385     return list(o);
2386 }
2387
2388 OP *
2389 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2390 {
2391     if (!o || o->op_type != OP_LIST)
2392         o = newLISTOP(OP_LIST, 0, o, Nullop);
2393     else
2394         o->op_flags &= ~OPf_WANT;
2395
2396     if (!(PL_opargs[type] & OA_MARK))
2397         op_null(cLISTOPo->op_first);
2398
2399     o->op_type = type;
2400     o->op_ppaddr = PL_ppaddr[type];
2401     o->op_flags |= flags;
2402
2403     o = CHECKOP(type, o);
2404     if (o->op_type != type)
2405         return o;
2406
2407     return fold_constants(o);
2408 }
2409
2410 /* List constructors */
2411
2412 OP *
2413 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2414 {
2415     if (!first)
2416         return last;
2417
2418     if (!last)
2419         return first;
2420
2421     if (first->op_type != type
2422         || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2423     {
2424         return newLISTOP(type, 0, first, last);
2425     }
2426
2427     if (first->op_flags & OPf_KIDS)
2428         ((LISTOP*)first)->op_last->op_sibling = last;
2429     else {
2430         first->op_flags |= OPf_KIDS;
2431         ((LISTOP*)first)->op_first = last;
2432     }
2433     ((LISTOP*)first)->op_last = last;
2434     return first;
2435 }
2436
2437 OP *
2438 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2439 {
2440     if (!first)
2441         return (OP*)last;
2442
2443     if (!last)
2444         return (OP*)first;
2445
2446     if (first->op_type != type)
2447         return prepend_elem(type, (OP*)first, (OP*)last);
2448
2449     if (last->op_type != type)
2450         return append_elem(type, (OP*)first, (OP*)last);
2451
2452     first->op_last->op_sibling = last->op_first;
2453     first->op_last = last->op_last;
2454     first->op_flags |= (last->op_flags & OPf_KIDS);
2455
2456 #ifdef PL_OP_SLAB_ALLOC
2457 #else
2458     Safefree(last);
2459 #endif
2460     return (OP*)first;
2461 }
2462
2463 OP *
2464 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2465 {
2466     if (!first)
2467         return last;
2468
2469     if (!last)
2470         return first;
2471
2472     if (last->op_type == type) {
2473         if (type == OP_LIST) {  /* already a PUSHMARK there */
2474             first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2475             ((LISTOP*)last)->op_first->op_sibling = first;
2476             if (!(first->op_flags & OPf_PARENS))
2477                 last->op_flags &= ~OPf_PARENS;
2478         }
2479         else {
2480             if (!(last->op_flags & OPf_KIDS)) {
2481                 ((LISTOP*)last)->op_last = first;
2482                 last->op_flags |= OPf_KIDS;
2483             }
2484             first->op_sibling = ((LISTOP*)last)->op_first;
2485             ((LISTOP*)last)->op_first = first;
2486         }
2487         last->op_flags |= OPf_KIDS;
2488         return last;
2489     }
2490
2491     return newLISTOP(type, 0, first, last);
2492 }
2493
2494 /* Constructors */
2495
2496 OP *
2497 Perl_newNULLLIST(pTHX)
2498 {
2499     return newOP(OP_STUB, 0);
2500 }
2501
2502 OP *
2503 Perl_force_list(pTHX_ OP *o)
2504 {
2505     if (!o || o->op_type != OP_LIST)
2506         o = newLISTOP(OP_LIST, 0, o, Nullop);
2507     op_null(o);
2508     return o;
2509 }
2510
2511 OP *
2512 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2513 {
2514     LISTOP *listop;
2515
2516     NewOp(1101, listop, 1, LISTOP);
2517
2518     listop->op_type = type;
2519     listop->op_ppaddr = PL_ppaddr[type];
2520     if (first || last)
2521         flags |= OPf_KIDS;
2522     listop->op_flags = flags;
2523
2524     if (!last && first)
2525         last = first;
2526     else if (!first && last)
2527         first = last;
2528     else if (first)
2529         first->op_sibling = last;
2530     listop->op_first = first;
2531     listop->op_last = last;
2532     if (type == OP_LIST) {
2533         OP* pushop;
2534         pushop = newOP(OP_PUSHMARK, 0);
2535         pushop->op_sibling = first;
2536         listop->op_first = pushop;
2537         listop->op_flags |= OPf_KIDS;
2538         if (!last)
2539             listop->op_last = pushop;
2540     }
2541
2542     return (OP*)listop;
2543 }
2544
2545 OP *
2546 Perl_newOP(pTHX_ I32 type, I32 flags)
2547 {
2548     OP *o;
2549     NewOp(1101, o, 1, OP);
2550     o->op_type = type;
2551     o->op_ppaddr = PL_ppaddr[type];
2552     o->op_flags = flags;
2553
2554     o->op_next = o;
2555     o->op_private = 0 + (flags >> 8);
2556     if (PL_opargs[type] & OA_RETSCALAR)
2557         scalar(o);
2558     if (PL_opargs[type] & OA_TARGET)
2559         o->op_targ = pad_alloc(type, SVs_PADTMP);
2560     return CHECKOP(type, o);
2561 }
2562
2563 OP *
2564 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2565 {
2566     UNOP *unop;
2567
2568     if (!first)
2569         first = newOP(OP_STUB, 0);
2570     if (PL_opargs[type] & OA_MARK)
2571         first = force_list(first);
2572
2573     NewOp(1101, unop, 1, UNOP);
2574     unop->op_type = type;
2575     unop->op_ppaddr = PL_ppaddr[type];
2576     unop->op_first = first;
2577     unop->op_flags = flags | OPf_KIDS;
2578     unop->op_private = 1 | (flags >> 8);
2579     unop = (UNOP*) CHECKOP(type, unop);
2580     if (unop->op_next)
2581         return (OP*)unop;
2582
2583     return fold_constants((OP *) unop);
2584 }
2585
2586 OP *
2587 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2588 {
2589     BINOP *binop;
2590     NewOp(1101, binop, 1, BINOP);
2591
2592     if (!first)
2593         first = newOP(OP_NULL, 0);
2594
2595     binop->op_type = type;
2596     binop->op_ppaddr = PL_ppaddr[type];
2597     binop->op_first = first;
2598     binop->op_flags = flags | OPf_KIDS;
2599     if (!last) {
2600         last = first;
2601         binop->op_private = 1 | (flags >> 8);
2602     }
2603     else {
2604         binop->op_private = 2 | (flags >> 8);
2605         first->op_sibling = last;
2606     }
2607
2608     binop = (BINOP*)CHECKOP(type, binop);
2609     if (binop->op_next || binop->op_type != type)
2610         return (OP*)binop;
2611
2612     binop->op_last = binop->op_first->op_sibling;
2613
2614     return fold_constants((OP *)binop);
2615 }
2616
2617 static int
2618 uvcompare(const void *a, const void *b)
2619 {
2620     if (*((UV *)a) < (*(UV *)b))
2621         return -1;
2622     if (*((UV *)a) > (*(UV *)b))
2623         return 1;
2624     if (*((UV *)a+1) < (*(UV *)b+1))
2625         return -1;
2626     if (*((UV *)a+1) > (*(UV *)b+1))
2627         return 1;
2628     return 0;
2629 }
2630
2631 OP *
2632 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2633 {
2634     SV *tstr = ((SVOP*)expr)->op_sv;
2635     SV *rstr = ((SVOP*)repl)->op_sv;
2636     STRLEN tlen;
2637     STRLEN rlen;
2638     U8 *t = (U8*)SvPV(tstr, tlen);
2639     U8 *r = (U8*)SvPV(rstr, rlen);
2640     register I32 i;
2641     register I32 j;
2642     I32 del;
2643     I32 complement;
2644     I32 squash;
2645     I32 grows = 0;
2646     register short *tbl;
2647
2648     PL_hints |= HINT_BLOCK_SCOPE;
2649     complement  = o->op_private & OPpTRANS_COMPLEMENT;
2650     del         = o->op_private & OPpTRANS_DELETE;
2651     squash      = o->op_private & OPpTRANS_SQUASH;
2652
2653     if (SvUTF8(tstr))
2654         o->op_private |= OPpTRANS_FROM_UTF;
2655
2656     if (SvUTF8(rstr))
2657         o->op_private |= OPpTRANS_TO_UTF;
2658
2659     if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2660         SV* listsv = newSVpvn("# comment\n",10);
2661         SV* transv = 0;
2662         U8* tend = t + tlen;
2663         U8* rend = r + rlen;
2664         STRLEN ulen;
2665         U32 tfirst = 1;
2666         U32 tlast = 0;
2667         I32 tdiff;
2668         U32 rfirst = 1;
2669         U32 rlast = 0;
2670         I32 rdiff;
2671         I32 diff;
2672         I32 none = 0;
2673         U32 max = 0;
2674         I32 bits;
2675         I32 havefinal = 0;
2676         U32 final = 0;
2677         I32 from_utf    = o->op_private & OPpTRANS_FROM_UTF;
2678         I32 to_utf      = o->op_private & OPpTRANS_TO_UTF;
2679         U8* tsave = NULL;
2680         U8* rsave = NULL;
2681
2682         if (!from_utf) {
2683             STRLEN len = tlen;
2684             tsave = t = bytes_to_utf8(t, &len);
2685             tend = t + len;
2686         }
2687         if (!to_utf && rlen) {
2688             STRLEN len = rlen;
2689             rsave = r = bytes_to_utf8(r, &len);
2690             rend = r + len;
2691         }
2692
2693 /* There are several snags with this code on EBCDIC:
2694    1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2695    2. scan_const() in toke.c has encoded chars in native encoding which makes
2696       ranges at least in EBCDIC 0..255 range the bottom odd.
2697 */
2698
2699         if (complement) {
2700             U8 tmpbuf[UTF8_MAXLEN+1];
2701             UV *cp;
2702             UV nextmin = 0;
2703             New(1109, cp, 2*tlen, UV);
2704             i = 0;
2705             transv = newSVpvn("",0);
2706             while (t < tend) {
2707                 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2708                 t += ulen;
2709                 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2710                     t++;
2711                     cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2712                     t += ulen;
2713                 }
2714                 else {
2715                  cp[2*i+1] = cp[2*i];
2716                 }
2717                 i++;
2718             }
2719             qsort(cp, i, 2*sizeof(UV), uvcompare);
2720             for (j = 0; j < i; j++) {
2721                 UV  val = cp[2*j];
2722                 diff = val - nextmin;
2723                 if (diff > 0) {
2724                     t = uvuni_to_utf8(tmpbuf,nextmin);
2725                     sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2726                     if (diff > 1) {
2727                         U8  range_mark = UTF_TO_NATIVE(0xff);
2728                         t = uvuni_to_utf8(tmpbuf, val - 1);
2729                         sv_catpvn(transv, (char *)&range_mark, 1);
2730                         sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2731                     }
2732                 }
2733                 val = cp[2*j+1];
2734                 if (val >= nextmin)
2735                     nextmin = val + 1;
2736             }
2737             t = uvuni_to_utf8(tmpbuf,nextmin);
2738             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2739             {
2740                 U8 range_mark = UTF_TO_NATIVE(0xff);
2741                 sv_catpvn(transv, (char *)&range_mark, 1);
2742             }
2743             t = uvuni_to_utf8(tmpbuf, 0x7fffffff);
2744             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2745             t = (U8*)SvPVX(transv);
2746             tlen = SvCUR(transv);
2747             tend = t + tlen;
2748             Safefree(cp);
2749         }
2750         else if (!rlen && !del) {
2751             r = t; rlen = tlen; rend = tend;
2752         }
2753         if (!squash) {
2754                 if ((!rlen && !del) || t == r ||
2755                     (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2756                 {
2757                     o->op_private |= OPpTRANS_IDENTICAL;
2758                 }
2759         }
2760
2761         while (t < tend || tfirst <= tlast) {
2762             /* see if we need more "t" chars */
2763             if (tfirst > tlast) {
2764                 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2765                 t += ulen;
2766                 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {    /* illegal utf8 val indicates range */
2767                     t++;
2768                     tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2769                     t += ulen;
2770                 }
2771                 else
2772                     tlast = tfirst;
2773             }
2774
2775             /* now see if we need more "r" chars */
2776             if (rfirst > rlast) {
2777                 if (r < rend) {
2778                     rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2779                     r += ulen;
2780                     if (r < rend && NATIVE_TO_UTF(*r) == 0xff) {        /* illegal utf8 val indicates range */
2781                         r++;
2782                         rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2783                         r += ulen;
2784                     }
2785                     else
2786                         rlast = rfirst;
2787                 }
2788                 else {
2789                     if (!havefinal++)
2790                         final = rlast;
2791                     rfirst = rlast = 0xffffffff;
2792                 }
2793             }
2794
2795             /* now see which range will peter our first, if either. */
2796             tdiff = tlast - tfirst;
2797             rdiff = rlast - rfirst;
2798
2799             if (tdiff <= rdiff)
2800                 diff = tdiff;
2801             else
2802                 diff = rdiff;
2803
2804             if (rfirst == 0xffffffff) {
2805                 diff = tdiff;   /* oops, pretend rdiff is infinite */
2806                 if (diff > 0)
2807                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2808                                    (long)tfirst, (long)tlast);
2809                 else
2810                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2811             }
2812             else {
2813                 if (diff > 0)
2814                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2815                                    (long)tfirst, (long)(tfirst + diff),
2816                                    (long)rfirst);
2817                 else
2818                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2819                                    (long)tfirst, (long)rfirst);
2820
2821                 if (rfirst + diff > max)
2822                     max = rfirst + diff;
2823                 if (!grows)
2824                     grows = (tfirst < rfirst &&
2825                              UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2826                 rfirst += diff + 1;
2827             }
2828             tfirst += diff + 1;
2829         }
2830
2831         none = ++max;
2832         if (del)
2833             del = ++max;
2834
2835         if (max > 0xffff)
2836             bits = 32;
2837         else if (max > 0xff)
2838             bits = 16;
2839         else
2840             bits = 8;
2841
2842         Safefree(cPVOPo->op_pv);
2843         cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2844         SvREFCNT_dec(listsv);
2845         if (transv)
2846             SvREFCNT_dec(transv);
2847
2848         if (!del && havefinal && rlen)
2849             (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2850                            newSVuv((UV)final), 0);
2851
2852         if (grows)
2853             o->op_private |= OPpTRANS_GROWS;
2854
2855         if (tsave)
2856             Safefree(tsave);
2857         if (rsave)
2858             Safefree(rsave);
2859
2860         op_free(expr);
2861         op_free(repl);
2862         return o;
2863     }
2864
2865     tbl = (short*)cPVOPo->op_pv;
2866     if (complement) {
2867         Zero(tbl, 256, short);
2868         for (i = 0; i < tlen; i++)
2869             tbl[t[i]] = -1;
2870         for (i = 0, j = 0; i < 256; i++) {
2871             if (!tbl[i]) {
2872                 if (j >= rlen) {
2873                     if (del)
2874                         tbl[i] = -2;
2875                     else if (rlen)
2876                         tbl[i] = r[j-1];
2877                     else
2878                         tbl[i] = i;
2879                 }
2880                 else {
2881                     if (i < 128 && r[j] >= 128)
2882                         grows = 1;
2883                     tbl[i] = r[j++];
2884                 }
2885             }
2886         }
2887         if (!del) {
2888             if (!rlen) {
2889                 j = rlen;
2890                 if (!squash)
2891                     o->op_private |= OPpTRANS_IDENTICAL;
2892             }
2893             else if (j >= rlen)
2894                 j = rlen - 1;
2895             else
2896                 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
2897             tbl[0x100] = rlen - j;
2898             for (i=0; i < rlen - j; i++)
2899                 tbl[0x101+i] = r[j+i];
2900         }
2901     }
2902     else {
2903         if (!rlen && !del) {
2904             r = t; rlen = tlen;
2905             if (!squash)
2906                 o->op_private |= OPpTRANS_IDENTICAL;
2907         }
2908         for (i = 0; i < 256; i++)
2909             tbl[i] = -1;
2910         for (i = 0, j = 0; i < tlen; i++,j++) {
2911             if (j >= rlen) {
2912                 if (del) {
2913                     if (tbl[t[i]] == -1)
2914                         tbl[t[i]] = -2;
2915                     continue;
2916                 }
2917                 --j;
2918             }
2919             if (tbl[t[i]] == -1) {
2920                 if (t[i] < 128 && r[j] >= 128)
2921                     grows = 1;
2922                 tbl[t[i]] = r[j];
2923             }
2924         }
2925     }
2926     if (grows)
2927         o->op_private |= OPpTRANS_GROWS;
2928     op_free(expr);
2929     op_free(repl);
2930
2931     return o;
2932 }
2933
2934 OP *
2935 Perl_newPMOP(pTHX_ I32 type, I32 flags)
2936 {
2937     PMOP *pmop;
2938
2939     NewOp(1101, pmop, 1, PMOP);
2940     pmop->op_type = type;
2941     pmop->op_ppaddr = PL_ppaddr[type];
2942     pmop->op_flags = flags;
2943     pmop->op_private = 0 | (flags >> 8);
2944
2945     if (PL_hints & HINT_RE_TAINT)
2946         pmop->op_pmpermflags |= PMf_RETAINT;
2947     if (PL_hints & HINT_LOCALE)
2948         pmop->op_pmpermflags |= PMf_LOCALE;
2949     pmop->op_pmflags = pmop->op_pmpermflags;
2950
2951  #ifdef USE_ITHREADS
2952         {
2953                 SV* repointer = newSViv(0);
2954                 av_push(PL_regex_padav,SvREFCNT_inc(repointer));
2955                 pmop->op_pmoffset = av_len(PL_regex_padav);
2956                 PL_regex_pad = AvARRAY(PL_regex_padav);
2957         }
2958  #endif
2959
2960         /* link into pm list */
2961     if (type != OP_TRANS && PL_curstash) {
2962         pmop->op_pmnext = HvPMROOT(PL_curstash);
2963         HvPMROOT(PL_curstash) = pmop;
2964         PmopSTASH_set(pmop,PL_curstash);
2965     }
2966
2967     return (OP*)pmop;
2968 }
2969
2970 OP *
2971 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl)
2972 {
2973     PMOP *pm;
2974     LOGOP *rcop;
2975     I32 repl_has_vars = 0;
2976
2977     if (o->op_type == OP_TRANS)
2978         return pmtrans(o, expr, repl);
2979
2980     PL_hints |= HINT_BLOCK_SCOPE;
2981     pm = (PMOP*)o;
2982
2983     if (expr->op_type == OP_CONST) {
2984         STRLEN plen;
2985         SV *pat = ((SVOP*)expr)->op_sv;
2986         char *p = SvPV(pat, plen);
2987         if ((o->op_flags & OPf_SPECIAL) && strEQ(p, " ")) {
2988             sv_setpvn(pat, "\\s+", 3);
2989             p = SvPV(pat, plen);
2990             pm->op_pmflags |= PMf_SKIPWHITE;
2991         }
2992         if ((PL_hints & HINT_UTF8) || DO_UTF8(pat))
2993             pm->op_pmdynflags |= PMdf_UTF8;
2994         PM_SETRE(pm, CALLREGCOMP(aTHX_ p, p + plen, pm));
2995         if (strEQ("\\s+", PM_GETRE(pm)->precomp))
2996             pm->op_pmflags |= PMf_WHITE;
2997         op_free(expr);
2998     }
2999     else {
3000         if (PL_hints & HINT_UTF8)
3001             pm->op_pmdynflags |= PMdf_UTF8;
3002         if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3003             expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3004                             ? OP_REGCRESET
3005                             : OP_REGCMAYBE),0,expr);
3006
3007         NewOp(1101, rcop, 1, LOGOP);
3008         rcop->op_type = OP_REGCOMP;
3009         rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3010         rcop->op_first = scalar(expr);
3011         rcop->op_flags |= ((PL_hints & HINT_RE_EVAL)
3012                            ? (OPf_SPECIAL | OPf_KIDS)
3013                            : OPf_KIDS);
3014         rcop->op_private = 1;
3015         rcop->op_other = o;
3016
3017         /* establish postfix order */
3018         if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3019             LINKLIST(expr);
3020             rcop->op_next = expr;
3021             ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3022         }
3023         else {
3024             rcop->op_next = LINKLIST(expr);
3025             expr->op_next = (OP*)rcop;
3026         }
3027
3028         prepend_elem(o->op_type, scalar((OP*)rcop), o);
3029     }
3030
3031     if (repl) {
3032         OP *curop;
3033         if (pm->op_pmflags & PMf_EVAL) {
3034             curop = 0;
3035             if (CopLINE(PL_curcop) < PL_multi_end)
3036                 CopLINE_set(PL_curcop, PL_multi_end);
3037         }
3038 #ifdef USE_THREADS
3039         else if (repl->op_type == OP_THREADSV
3040                  && strchr("&`'123456789+",
3041                            PL_threadsv_names[repl->op_targ]))
3042         {
3043             curop = 0;
3044         }
3045 #endif /* USE_THREADS */
3046         else if (repl->op_type == OP_CONST)
3047             curop = repl;
3048         else {
3049             OP *lastop = 0;
3050             for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3051                 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3052 #ifdef USE_THREADS
3053                     if (curop->op_type == OP_THREADSV) {
3054                         repl_has_vars = 1;
3055                         if (strchr("&`'123456789+", curop->op_private))
3056                             break;
3057                     }
3058 #else
3059                     if (curop->op_type == OP_GV) {
3060                         GV *gv = cGVOPx_gv(curop);
3061                         repl_has_vars = 1;
3062                         if (strchr("&`'123456789+", *GvENAME(gv)))
3063                             break;
3064                     }
3065 #endif /* USE_THREADS */
3066                     else if (curop->op_type == OP_RV2CV)
3067                         break;
3068                     else if (curop->op_type == OP_RV2SV ||
3069                              curop->op_type == OP_RV2AV ||
3070                              curop->op_type == OP_RV2HV ||
3071                              curop->op_type == OP_RV2GV) {
3072                         if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3073                             break;
3074                     }
3075                     else if (curop->op_type == OP_PADSV ||
3076                              curop->op_type == OP_PADAV ||
3077                              curop->op_type == OP_PADHV ||
3078                              curop->op_type == OP_PADANY) {
3079                         repl_has_vars = 1;
3080                     }
3081                     else if (curop->op_type == OP_PUSHRE)
3082                         ; /* Okay here, dangerous in newASSIGNOP */
3083                     else
3084                         break;
3085                 }
3086                 lastop = curop;
3087             }
3088         }
3089         if (curop == repl
3090             && !(repl_has_vars
3091                  && (!PM_GETRE(pm)
3092                      || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
3093             pm->op_pmflags |= PMf_CONST;        /* const for long enough */
3094             pm->op_pmpermflags |= PMf_CONST;    /* const for long enough */
3095             prepend_elem(o->op_type, scalar(repl), o);
3096         }
3097         else {
3098             if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3099                 pm->op_pmflags |= PMf_MAYBE_CONST;
3100                 pm->op_pmpermflags |= PMf_MAYBE_CONST;
3101             }
3102             NewOp(1101, rcop, 1, LOGOP);
3103             rcop->op_type = OP_SUBSTCONT;
3104             rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3105             rcop->op_first = scalar(repl);
3106             rcop->op_flags |= OPf_KIDS;
3107             rcop->op_private = 1;
3108             rcop->op_other = o;
3109
3110             /* establish postfix order */
3111             rcop->op_next = LINKLIST(repl);
3112             repl->op_next = (OP*)rcop;
3113
3114             pm->op_pmreplroot = scalar((OP*)rcop);
3115             pm->op_pmreplstart = LINKLIST(rcop);
3116             rcop->op_next = 0;
3117         }
3118     }
3119
3120     return (OP*)pm;
3121 }
3122
3123 OP *
3124 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3125 {
3126     SVOP *svop;
3127     NewOp(1101, svop, 1, SVOP);
3128     svop->op_type = type;
3129     svop->op_ppaddr = PL_ppaddr[type];
3130     svop->op_sv = sv;
3131     svop->op_next = (OP*)svop;
3132     svop->op_flags = flags;
3133     if (PL_opargs[type] & OA_RETSCALAR)
3134         scalar((OP*)svop);
3135     if (PL_opargs[type] & OA_TARGET)
3136         svop->op_targ = pad_alloc(type, SVs_PADTMP);
3137     return CHECKOP(type, svop);
3138 }
3139
3140 OP *
3141 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3142 {
3143     PADOP *padop;
3144     NewOp(1101, padop, 1, PADOP);
3145     padop->op_type = type;
3146     padop->op_ppaddr = PL_ppaddr[type];
3147     padop->op_padix = pad_alloc(type, SVs_PADTMP);
3148     SvREFCNT_dec(PL_curpad[padop->op_padix]);
3149     PL_curpad[padop->op_padix] = sv;
3150     SvPADTMP_on(sv);
3151     padop->op_next = (OP*)padop;
3152     padop->op_flags = flags;
3153     if (PL_opargs[type] & OA_RETSCALAR)
3154         scalar((OP*)padop);
3155     if (PL_opargs[type] & OA_TARGET)
3156         padop->op_targ = pad_alloc(type, SVs_PADTMP);
3157     return CHECKOP(type, padop);
3158 }
3159
3160 OP *
3161 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3162 {
3163 #ifdef USE_ITHREADS
3164     GvIN_PAD_on(gv);
3165     return newPADOP(type, flags, SvREFCNT_inc(gv));
3166 #else
3167     return newSVOP(type, flags, SvREFCNT_inc(gv));
3168 #endif
3169 }
3170
3171 OP *
3172 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3173 {
3174     PVOP *pvop;
3175     NewOp(1101, pvop, 1, PVOP);
3176     pvop->op_type = type;
3177     pvop->op_ppaddr = PL_ppaddr[type];
3178     pvop->op_pv = pv;
3179     pvop->op_next = (OP*)pvop;
3180     pvop->op_flags = flags;
3181     if (PL_opargs[type] & OA_RETSCALAR)
3182         scalar((OP*)pvop);
3183     if (PL_opargs[type] & OA_TARGET)
3184         pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3185     return CHECKOP(type, pvop);
3186 }
3187
3188 void
3189 Perl_package(pTHX_ OP *o)
3190 {
3191     SV *sv;
3192
3193     save_hptr(&PL_curstash);
3194     save_item(PL_curstname);
3195     if (o) {
3196         STRLEN len;
3197         char *name;
3198         sv = cSVOPo->op_sv;
3199         name = SvPV(sv, len);
3200         PL_curstash = gv_stashpvn(name,len,TRUE);
3201         sv_setpvn(PL_curstname, name, len);
3202         op_free(o);
3203     }
3204     else {
3205         deprecate("\"package\" with no arguments");
3206         sv_setpv(PL_curstname,"<none>");
3207         PL_curstash = Nullhv;
3208     }
3209     PL_hints |= HINT_BLOCK_SCOPE;
3210     PL_copline = NOLINE;
3211     PL_expect = XSTATE;
3212 }
3213
3214 void
3215 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg)
3216 {
3217     OP *pack;
3218     OP *imop;
3219     OP *veop;
3220     char *packname = Nullch;
3221     STRLEN packlen;
3222     SV *packsv;
3223
3224     if (id->op_type != OP_CONST)
3225         Perl_croak(aTHX_ "Module name must be constant");
3226
3227     veop = Nullop;
3228
3229     if (version != Nullop) {
3230         SV *vesv = ((SVOP*)version)->op_sv;
3231
3232         if (arg == Nullop && !SvNIOKp(vesv)) {
3233             arg = version;
3234         }
3235         else {
3236             OP *pack;
3237             SV *meth;
3238
3239             if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3240                 Perl_croak(aTHX_ "Version number must be constant number");
3241
3242             /* Make copy of id so we don't free it twice */
3243             pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3244
3245             /* Fake up a method call to VERSION */
3246             meth = newSVpvn("VERSION",7);
3247             sv_upgrade(meth, SVt_PVIV);
3248             (void)SvIOK_on(meth);
3249             PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3250             veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3251                             append_elem(OP_LIST,
3252                                         prepend_elem(OP_LIST, pack, list(version)),
3253                                         newSVOP(OP_METHOD_NAMED, 0, meth)));
3254         }
3255     }
3256
3257     /* Fake up an import/unimport */
3258     if (arg && arg->op_type == OP_STUB)
3259         imop = arg;             /* no import on explicit () */
3260     else if (SvNIOKp(((SVOP*)id)->op_sv)) {
3261         imop = Nullop;          /* use 5.0; */
3262     }
3263     else {
3264         SV *meth;
3265
3266         /* Make copy of id so we don't free it twice */
3267         pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3268
3269         /* Fake up a method call to import/unimport */
3270         meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);;
3271         sv_upgrade(meth, SVt_PVIV);
3272         (void)SvIOK_on(meth);
3273         PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3274         imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3275                        append_elem(OP_LIST,
3276                                    prepend_elem(OP_LIST, pack, list(arg)),
3277                                    newSVOP(OP_METHOD_NAMED, 0, meth)));
3278     }
3279
3280     if (ckWARN(WARN_MISC) && imop && SvPOK(packsv = ((SVOP*)id)->op_sv)) {
3281         /* BEGIN will free the ops, so we need to make a copy */
3282         packlen = SvCUR(packsv);
3283         packname = savepvn(SvPVX(packsv), packlen);
3284     }
3285
3286     /* Fake up the BEGIN {}, which does its thing immediately. */
3287     newATTRSUB(floor,
3288         newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
3289         Nullop,
3290         Nullop,
3291         append_elem(OP_LINESEQ,
3292             append_elem(OP_LINESEQ,
3293                 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, id)),
3294                 newSTATEOP(0, Nullch, veop)),
3295             newSTATEOP(0, Nullch, imop) ));
3296
3297     if (packname) {
3298         if (ckWARN(WARN_MISC) && !gv_stashpvn(packname, packlen, FALSE)) {
3299             Perl_warner(aTHX_ WARN_MISC,
3300                         "Package `%s' not found "
3301                         "(did you use the incorrect case?)", packname);
3302         }
3303         safefree(packname);
3304     }
3305
3306     PL_hints |= HINT_BLOCK_SCOPE;
3307     PL_copline = NOLINE;
3308     PL_expect = XSTATE;
3309 }
3310
3311 /*
3312 =for apidoc load_module
3313
3314 Loads the module whose name is pointed to by the string part of name.
3315 Note that the actual module name, not its filename, should be given.
3316 Eg, "Foo::Bar" instead of "Foo/Bar.pm".  flags can be any of
3317 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3318 (or 0 for no flags). ver, if specified, provides version semantics
3319 similar to C<use Foo::Bar VERSION>.  The optional trailing SV*
3320 arguments can be used to specify arguments to the module's import()
3321 method, similar to C<use Foo::Bar VERSION LIST>.
3322
3323 =cut */
3324
3325 void
3326 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3327 {
3328     va_list args;
3329     va_start(args, ver);
3330     vload_module(flags, name, ver, &args);
3331     va_end(args);
3332 }
3333
3334 #ifdef PERL_IMPLICIT_CONTEXT
3335 void
3336 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3337 {
3338     dTHX;
3339     va_list args;
3340     va_start(args, ver);
3341     vload_module(flags, name, ver, &args);
3342     va_end(args);
3343 }
3344 #endif
3345
3346 void
3347 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3348 {
3349     OP *modname, *veop, *imop;
3350
3351     modname = newSVOP(OP_CONST, 0, name);
3352     modname->op_private |= OPpCONST_BARE;
3353     if (ver) {
3354         veop = newSVOP(OP_CONST, 0, ver);
3355     }
3356     else
3357         veop = Nullop;
3358     if (flags & PERL_LOADMOD_NOIMPORT) {
3359         imop = sawparens(newNULLLIST());
3360     }
3361     else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3362         imop = va_arg(*args, OP*);
3363     }
3364     else {
3365         SV *sv;
3366         imop = Nullop;
3367         sv = va_arg(*args, SV*);
3368         while (sv) {
3369             imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3370             sv = va_arg(*args, SV*);
3371         }
3372     }
3373     {
3374         line_t ocopline = PL_copline;
3375         int oexpect = PL_expect;
3376
3377         utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3378                 veop, modname, imop);
3379         PL_expect = oexpect;
3380         PL_copline = ocopline;
3381     }
3382 }
3383
3384 OP *
3385 Perl_dofile(pTHX_ OP *term)
3386 {
3387     OP *doop;
3388     GV *gv;
3389
3390     gv = gv_fetchpv("do", FALSE, SVt_PVCV);
3391     if (!(gv && GvIMPORTED_CV(gv)))
3392         gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3393
3394     if (gv && GvIMPORTED_CV(gv)) {
3395         doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3396                                append_elem(OP_LIST, term,
3397                                            scalar(newUNOP(OP_RV2CV, 0,
3398                                                           newGVOP(OP_GV, 0,
3399                                                                   gv))))));
3400     }
3401     else {
3402         doop = newUNOP(OP_DOFILE, 0, scalar(term));
3403     }
3404     return doop;
3405 }
3406
3407 OP *
3408 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3409 {
3410     return newBINOP(OP_LSLICE, flags,
3411             list(force_list(subscript)),
3412             list(force_list(listval)) );
3413 }
3414
3415 STATIC I32
3416 S_list_assignment(pTHX_ register OP *o)
3417 {
3418     if (!o)
3419         return TRUE;
3420
3421     if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3422         o = cUNOPo->op_first;
3423
3424     if (o->op_type == OP_COND_EXPR) {
3425         I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3426         I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3427
3428         if (t && f)
3429             return TRUE;
3430         if (t || f)
3431             yyerror("Assignment to both a list and a scalar");
3432         return FALSE;
3433     }
3434
3435     if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3436         o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3437         o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3438         return TRUE;
3439
3440     if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3441         return TRUE;
3442
3443     if (o->op_type == OP_RV2SV)
3444         return FALSE;
3445
3446     return FALSE;
3447 }
3448
3449 OP *
3450 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3451 {
3452     OP *o;
3453
3454     if (optype) {
3455         if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN) {
3456             return newLOGOP(optype, 0,
3457                 mod(scalar(left), optype),
3458                 newUNOP(OP_SASSIGN, 0, scalar(right)));
3459         }
3460         else {
3461             return newBINOP(optype, OPf_STACKED,
3462                 mod(scalar(left), optype), scalar(right));
3463         }
3464     }
3465
3466     if (list_assignment(left)) {
3467         OP *curop;
3468
3469         PL_modcount = 0;
3470         PL_eval_start = right;  /* Grandfathering $[ assignment here.  Bletch.*/
3471         left = mod(left, OP_AASSIGN);
3472         if (PL_eval_start)
3473             PL_eval_start = 0;
3474         else {
3475             op_free(left);
3476             op_free(right);
3477             return Nullop;
3478         }
3479         curop = list(force_list(left));
3480         o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3481         o->op_private = 0 | (flags >> 8);
3482         for (curop = ((LISTOP*)curop)->op_first;
3483              curop; curop = curop->op_sibling)
3484         {
3485             if (curop->op_type == OP_RV2HV &&
3486                 ((UNOP*)curop)->op_first->op_type != OP_GV) {
3487                 o->op_private |= OPpASSIGN_HASH;
3488                 break;
3489             }
3490         }
3491         if (!(left->op_private & OPpLVAL_INTRO)) {
3492             OP *lastop = o;
3493             PL_generation++;
3494             for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3495                 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3496                     if (curop->op_type == OP_GV) {
3497                         GV *gv = cGVOPx_gv(curop);
3498                         if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3499                             break;
3500                         SvCUR(gv) = PL_generation;
3501                     }
3502                     else if (curop->op_type == OP_PADSV ||
3503                              curop->op_type == OP_PADAV ||
3504                              curop->op_type == OP_PADHV ||
3505                              curop->op_type == OP_PADANY) {
3506                         SV **svp = AvARRAY(PL_comppad_name);
3507                         SV *sv = svp[curop->op_targ];
3508                         if (SvCUR(sv) == PL_generation)
3509                             break;
3510                         SvCUR(sv) = PL_generation;      /* (SvCUR not used any more) */
3511                     }
3512                     else if (curop->op_type == OP_RV2CV)
3513                         break;
3514                     else if (curop->op_type == OP_RV2SV ||
3515                              curop->op_type == OP_RV2AV ||
3516                              curop->op_type == OP_RV2HV ||
3517                              curop->op_type == OP_RV2GV) {
3518                         if (lastop->op_type != OP_GV)   /* funny deref? */
3519                             break;
3520                     }
3521                     else if (curop->op_type == OP_PUSHRE) {
3522                         if (((PMOP*)curop)->op_pmreplroot) {
3523 #ifdef USE_ITHREADS
3524                             GV *gv = (GV*)PL_curpad[(PADOFFSET)((PMOP*)curop)->op_pmreplroot];
3525 #else
3526                             GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3527 #endif
3528                             if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3529                                 break;
3530                             SvCUR(gv) = PL_generation;
3531                         }
3532                     }
3533                     else
3534                         break;
3535                 }
3536                 lastop = curop;
3537             }
3538             if (curop != o)
3539                 o->op_private |= OPpASSIGN_COMMON;
3540         }
3541         if (right && right->op_type == OP_SPLIT) {
3542             OP* tmpop;
3543             if ((tmpop = ((LISTOP*)right)->op_first) &&
3544                 tmpop->op_type == OP_PUSHRE)
3545             {
3546                 PMOP *pm = (PMOP*)tmpop;
3547                 if (left->op_type == OP_RV2AV &&
3548                     !(left->op_private & OPpLVAL_INTRO) &&
3549                     !(o->op_private & OPpASSIGN_COMMON) )
3550                 {
3551                     tmpop = ((UNOP*)left)->op_first;
3552                     if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3553 #ifdef USE_ITHREADS
3554                         pm->op_pmreplroot = (OP*)cPADOPx(tmpop)->op_padix;
3555                         cPADOPx(tmpop)->op_padix = 0;   /* steal it */
3556 #else
3557                         pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3558                         cSVOPx(tmpop)->op_sv = Nullsv;  /* steal it */
3559 #endif
3560                         pm->op_pmflags |= PMf_ONCE;
3561                         tmpop = cUNOPo->op_first;       /* to list (nulled) */
3562                         tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3563                         tmpop->op_sibling = Nullop;     /* don't free split */
3564                         right->op_next = tmpop->op_next;  /* fix starting loc */
3565                         op_free(o);                     /* blow off assign */
3566                         right->op_flags &= ~OPf_WANT;
3567                                 /* "I don't know and I don't care." */
3568                         return right;
3569                     }
3570                 }
3571                 else {
3572                    if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3573                       ((LISTOP*)right)->op_last->op_type == OP_CONST)
3574                     {
3575                         SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3576                         if (SvIVX(sv) == 0)
3577                             sv_setiv(sv, PL_modcount+1);
3578                     }
3579                 }
3580             }
3581         }
3582         return o;
3583     }
3584     if (!right)
3585         right = newOP(OP_UNDEF, 0);
3586     if (right->op_type == OP_READLINE) {
3587         right->op_flags |= OPf_STACKED;
3588         return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3589     }
3590     else {
3591         PL_eval_start = right;  /* Grandfathering $[ assignment here.  Bletch.*/
3592         o = newBINOP(OP_SASSIGN, flags,
3593             scalar(right), mod(scalar(left), OP_SASSIGN) );
3594         if (PL_eval_start)
3595             PL_eval_start = 0;
3596         else {
3597             op_free(o);
3598             return Nullop;
3599         }
3600     }
3601     return o;
3602 }
3603
3604 OP *
3605 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3606 {
3607     U32 seq = intro_my();
3608     register COP *cop;
3609
3610     NewOp(1101, cop, 1, COP);
3611     if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3612         cop->op_type = OP_DBSTATE;
3613         cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3614     }
3615     else {
3616         cop->op_type = OP_NEXTSTATE;
3617         cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3618     }
3619     cop->op_flags = flags;
3620     cop->op_private = (PL_hints & HINT_PRIVATE_MASK);
3621 #ifdef NATIVE_HINTS
3622     cop->op_private |= NATIVE_HINTS;
3623 #endif
3624     PL_compiling.op_private = cop->op_private;
3625     cop->op_next = (OP*)cop;
3626
3627     if (label) {
3628         cop->cop_label = label;
3629         PL_hints |= HINT_BLOCK_SCOPE;
3630     }
3631     cop->cop_seq = seq;
3632     cop->cop_arybase = PL_curcop->cop_arybase;
3633     if (specialWARN(PL_curcop->cop_warnings))
3634         cop->cop_warnings = PL_curcop->cop_warnings ;
3635     else
3636         cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3637     if (specialCopIO(PL_curcop->cop_io))
3638         cop->cop_io = PL_curcop->cop_io;
3639     else
3640         cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3641
3642
3643     if (PL_copline == NOLINE)
3644         CopLINE_set(cop, CopLINE(PL_curcop));
3645     else {
3646         CopLINE_set(cop, PL_copline);
3647         PL_copline = NOLINE;
3648     }
3649 #ifdef USE_ITHREADS
3650     CopFILE_set(cop, CopFILE(PL_curcop));       /* XXX share in a pvtable? */
3651 #else
3652     CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3653 #endif
3654     CopSTASH_set(cop, PL_curstash);
3655
3656     if (PERLDB_LINE && PL_curstash != PL_debstash) {
3657         SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3658         if (svp && *svp != &PL_sv_undef && !SvIOK(*svp)) {
3659             (void)SvIOK_on(*svp);
3660             SvIVX(*svp) = PTR2IV(cop);
3661         }
3662     }
3663
3664     return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3665 }
3666
3667 /* "Introduce" my variables to visible status. */
3668 U32
3669 Perl_intro_my(pTHX)
3670 {
3671     SV **svp;
3672     SV *sv;
3673     I32 i;
3674
3675     if (! PL_min_intro_pending)
3676         return PL_cop_seqmax;
3677
3678     svp = AvARRAY(PL_comppad_name);
3679     for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
3680         if ((sv = svp[i]) && sv != &PL_sv_undef && !SvIVX(sv)) {
3681             SvIVX(sv) = PAD_MAX;        /* Don't know scope end yet. */
3682             SvNVX(sv) = (NV)PL_cop_seqmax;
3683         }
3684     }
3685     PL_min_intro_pending = 0;
3686     PL_comppad_name_fill = PL_max_intro_pending;        /* Needn't search higher */
3687     return PL_cop_seqmax++;
3688 }
3689
3690 OP *
3691 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3692 {
3693     return new_logop(type, flags, &first, &other);
3694 }
3695
3696 STATIC OP *
3697 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3698 {
3699     LOGOP *logop;
3700     OP *o;
3701     OP *first = *firstp;
3702     OP *other = *otherp;
3703
3704     if (type == OP_XOR)         /* Not short circuit, but here by precedence. */
3705         return newBINOP(type, flags, scalar(first), scalar(other));
3706
3707     scalarboolean(first);
3708     /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3709     if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3710         if (type == OP_AND || type == OP_OR) {
3711             if (type == OP_AND)
3712                 type = OP_OR;
3713             else
3714                 type = OP_AND;
3715             o = first;
3716             first = *firstp = cUNOPo->op_first;
3717             if (o->op_next)
3718                 first->op_next = o->op_next;
3719             cUNOPo->op_first = Nullop;
3720             op_free(o);
3721         }
3722     }
3723     if (first->op_type == OP_CONST) {
3724         if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
3725             Perl_warner(aTHX_ WARN_BAREWORD, "Bareword found in conditional");
3726         if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
3727             op_free(first);
3728             *firstp = Nullop;
3729             return other;
3730         }
3731         else {
3732             op_free(other);
3733             *otherp = Nullop;
3734             return first;
3735         }
3736     }
3737     else if (first->op_type == OP_WANTARRAY) {
3738         if (type == OP_AND)
3739             list(other);
3740         else
3741             scalar(other);
3742     }
3743     else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS)) {
3744         OP *k1 = ((UNOP*)first)->op_first;
3745         OP *k2 = k1->op_sibling;
3746         OPCODE warnop = 0;
3747         switch (first->op_type)
3748         {
3749         case OP_NULL:
3750             if (k2 && k2->op_type == OP_READLINE
3751                   && (k2->op_flags & OPf_STACKED)
3752                   && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3753             {
3754                 warnop = k2->op_type;
3755             }
3756             break;
3757
3758         case OP_SASSIGN:
3759             if (k1->op_type == OP_READDIR
3760                   || k1->op_type == OP_GLOB
3761                   || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3762                   || k1->op_type == OP_EACH)
3763             {
3764                 warnop = ((k1->op_type == OP_NULL)
3765                           ? k1->op_targ : k1->op_type);
3766             }
3767             break;
3768         }
3769         if (warnop) {
3770             line_t oldline = CopLINE(PL_curcop);
3771             CopLINE_set(PL_curcop, PL_copline);
3772             Perl_warner(aTHX_ WARN_MISC,
3773                  "Value of %s%s can be \"0\"; test with defined()",
3774                  PL_op_desc[warnop],
3775                  ((warnop == OP_READLINE || warnop == OP_GLOB)
3776                   ? " construct" : "() operator"));
3777             CopLINE_set(PL_curcop, oldline);
3778         }
3779     }
3780
3781     if (!other)
3782         return first;
3783
3784     if (type == OP_ANDASSIGN || type == OP_ORASSIGN)
3785         other->op_private |= OPpASSIGN_BACKWARDS;  /* other is an OP_SASSIGN */
3786
3787     NewOp(1101, logop, 1, LOGOP);
3788
3789     logop->op_type = type;
3790     logop->op_ppaddr = PL_ppaddr[type];
3791     logop->op_first = first;
3792     logop->op_flags = flags | OPf_KIDS;
3793     logop->op_other = LINKLIST(other);
3794     logop->op_private = 1 | (flags >> 8);
3795
3796     /* establish postfix order */
3797     logop->op_next = LINKLIST(first);
3798     first->op_next = (OP*)logop;
3799     first->op_sibling = other;
3800
3801     o = newUNOP(OP_NULL, 0, (OP*)logop);
3802     other->op_next = o;
3803
3804     return o;
3805 }
3806
3807 OP *
3808 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3809 {
3810     LOGOP *logop;
3811     OP *start;
3812     OP *o;
3813
3814     if (!falseop)
3815         return newLOGOP(OP_AND, 0, first, trueop);
3816     if (!trueop)
3817         return newLOGOP(OP_OR, 0, first, falseop);
3818
3819     scalarboolean(first);
3820     if (first->op_type == OP_CONST) {
3821         if (SvTRUE(((SVOP*)first)->op_sv)) {
3822             op_free(first);
3823             op_free(falseop);
3824             return trueop;
3825         }
3826         else {
3827             op_free(first);
3828             op_free(trueop);
3829             return falseop;
3830         }
3831     }
3832     else if (first->op_type == OP_WANTARRAY) {
3833         list(trueop);
3834         scalar(falseop);
3835     }
3836     NewOp(1101, logop, 1, LOGOP);
3837     logop->op_type = OP_COND_EXPR;
3838     logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3839     logop->op_first = first;
3840     logop->op_flags = flags | OPf_KIDS;
3841     logop->op_private = 1 | (flags >> 8);
3842     logop->op_other = LINKLIST(trueop);
3843     logop->op_next = LINKLIST(falseop);
3844
3845
3846     /* establish postfix order */
3847     start = LINKLIST(first);
3848     first->op_next = (OP*)logop;
3849
3850     first->op_sibling = trueop;
3851     trueop->op_sibling = falseop;
3852     o = newUNOP(OP_NULL, 0, (OP*)logop);
3853
3854     trueop->op_next = falseop->op_next = o;
3855
3856     o->op_next = start;
3857     return o;
3858 }
3859
3860 OP *
3861 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3862 {
3863     LOGOP *range;
3864     OP *flip;
3865     OP *flop;
3866     OP *leftstart;
3867     OP *o;
3868
3869     NewOp(1101, range, 1, LOGOP);
3870
3871     range->op_type = OP_RANGE;
3872     range->op_ppaddr = PL_ppaddr[OP_RANGE];
3873     range->op_first = left;
3874     range->op_flags = OPf_KIDS;
3875     leftstart = LINKLIST(left);
3876     range->op_other = LINKLIST(right);
3877     range->op_private = 1 | (flags >> 8);
3878
3879     left->op_sibling = right;
3880
3881     range->op_next = (OP*)range;
3882     flip = newUNOP(OP_FLIP, flags, (OP*)range);
3883     flop = newUNOP(OP_FLOP, 0, flip);
3884     o = newUNOP(OP_NULL, 0, flop);
3885     linklist(flop);
3886     range->op_next = leftstart;
3887
3888     left->op_next = flip;
3889     right->op_next = flop;
3890
3891     range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3892     sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3893     flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3894     sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3895
3896     flip->op_private =  left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3897     flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3898
3899     flip->op_next = o;
3900     if (!flip->op_private || !flop->op_private)
3901         linklist(o);            /* blow off optimizer unless constant */
3902
3903     return o;
3904 }
3905
3906 OP *
3907 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3908 {
3909     OP* listop;
3910     OP* o;
3911     int once = block && block->op_flags & OPf_SPECIAL &&
3912       (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3913
3914     if (expr) {
3915         if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3916             return block;       /* do {} while 0 does once */
3917         if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3918             || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3919             expr = newUNOP(OP_DEFINED, 0,
3920                 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3921         } else if (expr->op_flags & OPf_KIDS) {
3922             OP *k1 = ((UNOP*)expr)->op_first;
3923             OP *k2 = (k1) ? k1->op_sibling : NULL;
3924             switch (expr->op_type) {
3925               case OP_NULL:
3926                 if (k2 && k2->op_type == OP_READLINE
3927                       && (k2->op_flags & OPf_STACKED)
3928                       && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3929                     expr = newUNOP(OP_DEFINED, 0, expr);
3930                 break;
3931
3932               case OP_SASSIGN:
3933                 if (k1->op_type == OP_READDIR
3934                       || k1->op_type == OP_GLOB
3935                       || (k1->op_type == OP_NULL && k1->op_targ == OP_NULL)
3936                       || k1->op_type == OP_EACH)
3937                     expr = newUNOP(OP_DEFINED, 0, expr);
3938                 break;
3939             }
3940         }
3941     }
3942
3943     listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3944     o = new_logop(OP_AND, 0, &expr, &listop);
3945
3946     if (listop)
3947         ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3948
3949     if (once && o != listop)
3950         o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3951
3952     if (o == listop)
3953         o = newUNOP(OP_NULL, 0, o);     /* or do {} while 1 loses outer block */
3954
3955     o->op_flags |= flags;
3956     o = scope(o);
3957     o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3958     return o;
3959 }
3960
3961 OP *
3962 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
3963 {
3964     OP *redo;
3965     OP *next = 0;
3966     OP *listop;
3967     OP *o;
3968     U8 loopflags = 0;
3969
3970     if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3971                  || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
3972         expr = newUNOP(OP_DEFINED, 0,
3973             newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3974     } else if (expr && (expr->op_flags & OPf_KIDS)) {
3975         OP *k1 = ((UNOP*)expr)->op_first;
3976         OP *k2 = (k1) ? k1->op_sibling : NULL;
3977         switch (expr->op_type) {
3978           case OP_NULL:
3979             if (k2 && k2->op_type == OP_READLINE
3980                   && (k2->op_flags & OPf_STACKED)
3981                   && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3982                 expr = newUNOP(OP_DEFINED, 0, expr);
3983             break;
3984
3985           case OP_SASSIGN:
3986             if (k1->op_type == OP_READDIR
3987                   || k1->op_type == OP_GLOB
3988                   || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3989                   || k1->op_type == OP_EACH)
3990                 expr = newUNOP(OP_DEFINED, 0, expr);
3991             break;
3992         }
3993     }
3994
3995     if (!block)
3996         block = newOP(OP_NULL, 0);
3997     else if (cont) {
3998         block = scope(block);
3999     }
4000
4001     if (cont) {
4002         next = LINKLIST(cont);
4003     }
4004     if (expr) {
4005         OP *unstack = newOP(OP_UNSTACK, 0);
4006         if (!next)
4007             next = unstack;
4008         cont = append_elem(OP_LINESEQ, cont, unstack);
4009         if ((line_t)whileline != NOLINE) {
4010             PL_copline = whileline;
4011             cont = append_elem(OP_LINESEQ, cont,
4012                                newSTATEOP(0, Nullch, Nullop));
4013         }
4014     }
4015
4016     listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4017     redo = LINKLIST(listop);
4018
4019     if (expr) {
4020         PL_copline = whileline;
4021         scalar(listop);
4022         o = new_logop(OP_AND, 0, &expr, &listop);
4023         if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4024             op_free(expr);              /* oops, it's a while (0) */
4025             op_free((OP*)loop);
4026             return Nullop;              /* listop already freed by new_logop */
4027         }
4028         if (listop)
4029             ((LISTOP*)listop)->op_last->op_next =
4030                 (o == listop ? redo : LINKLIST(o));
4031     }
4032     else
4033         o = listop;
4034
4035     if (!loop) {
4036         NewOp(1101,loop,1,LOOP);
4037         loop->op_type = OP_ENTERLOOP;
4038         loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4039         loop->op_private = 0;
4040         loop->op_next = (OP*)loop;
4041     }
4042
4043     o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4044
4045     loop->op_redoop = redo;
4046     loop->op_lastop = o;
4047     o->op_private |= loopflags;
4048
4049     if (next)
4050         loop->op_nextop = next;
4051     else
4052         loop->op_nextop = o;
4053
4054     o->op_flags |= flags;
4055     o->op_private |= (flags >> 8);
4056     return o;
4057 }
4058
4059 OP *
4060 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
4061 {
4062     LOOP *loop;
4063     OP *wop;
4064     int padoff = 0;
4065     I32 iterflags = 0;
4066
4067     if (sv) {
4068         if (sv->op_type == OP_RV2SV) {  /* symbol table variable */
4069             sv->op_type = OP_RV2GV;
4070             sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4071         }
4072         else if (sv->op_type == OP_PADSV) { /* private variable */
4073             padoff = sv->op_targ;
4074             sv->op_targ = 0;
4075             op_free(sv);
4076             sv = Nullop;
4077         }
4078         else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
4079             padoff = sv->op_targ;
4080             sv->op_targ = 0;
4081             iterflags |= OPf_SPECIAL;
4082             op_free(sv);
4083             sv = Nullop;
4084         }
4085         else
4086             Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4087     }
4088     else {
4089 #ifdef USE_THREADS
4090         padoff = find_threadsv("_");
4091         iterflags |= OPf_SPECIAL;
4092 #else
4093         sv = newGVOP(OP_GV, 0, PL_defgv);
4094 #endif
4095     }
4096     if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4097         expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4098         iterflags |= OPf_STACKED;
4099     }
4100     else if (expr->op_type == OP_NULL &&
4101              (expr->op_flags & OPf_KIDS) &&
4102              ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4103     {
4104         /* Basically turn for($x..$y) into the same as for($x,$y), but we
4105          * set the STACKED flag to indicate that these values are to be
4106          * treated as min/max values by 'pp_iterinit'.
4107          */
4108         UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4109         LOGOP* range = (LOGOP*) flip->op_first;
4110         OP* left  = range->op_first;
4111         OP* right = left->op_sibling;
4112         LISTOP* listop;
4113
4114         range->op_flags &= ~OPf_KIDS;
4115         range->op_first = Nullop;
4116
4117         listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4118         listop->op_first->op_next = range->op_next;
4119         left->op_next = range->op_other;
4120         right->op_next = (OP*)listop;
4121         listop->op_next = listop->op_first;
4122
4123         op_free(expr);
4124         expr = (OP*)(listop);
4125         op_null(expr);
4126         iterflags |= OPf_STACKED;
4127     }
4128     else {
4129         expr = mod(force_list(expr), OP_GREPSTART);
4130     }
4131
4132
4133     loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4134                                append_elem(OP_LIST, expr, scalar(sv))));
4135     assert(!loop->op_next);
4136 #ifdef PL_OP_SLAB_ALLOC
4137     {
4138         LOOP *tmp;
4139         NewOp(1234,tmp,1,LOOP);
4140         Copy(loop,tmp,1,LOOP);
4141         loop = tmp;
4142     }
4143 #else
4144     Renew(loop, 1, LOOP);
4145 #endif
4146     loop->op_targ = padoff;
4147     wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
4148     PL_copline = forline;
4149     return newSTATEOP(0, label, wop);
4150 }
4151
4152 OP*
4153 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4154 {
4155     OP *o;
4156     STRLEN n_a;
4157
4158     if (type != OP_GOTO || label->op_type == OP_CONST) {
4159         /* "last()" means "last" */
4160         if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4161             o = newOP(type, OPf_SPECIAL);
4162         else {
4163             o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4164                                         ? SvPVx(((SVOP*)label)->op_sv, n_a)
4165                                         : ""));
4166         }
4167         op_free(label);
4168     }
4169     else {
4170         if (label->op_type == OP_ENTERSUB)
4171             label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4172         o = newUNOP(type, OPf_STACKED, label);
4173     }
4174     PL_hints |= HINT_BLOCK_SCOPE;
4175     return o;
4176 }
4177
4178 void
4179 Perl_cv_undef(pTHX_ CV *cv)
4180 {
4181 #ifdef USE_THREADS
4182     if (CvMUTEXP(cv)) {
4183         MUTEX_DESTROY(CvMUTEXP(cv));
4184         Safefree(CvMUTEXP(cv));
4185         CvMUTEXP(cv) = 0;
4186     }
4187 #endif /* USE_THREADS */
4188
4189 #ifdef USE_ITHREADS
4190     if (CvFILE(cv) && !CvXSUB(cv)) {
4191         /* for XSUBs CvFILE point directly to static memory; __FILE__ */
4192         Safefree(CvFILE(cv));
4193     }
4194     CvFILE(cv) = 0;
4195 #endif
4196
4197     if (!CvXSUB(cv) && CvROOT(cv)) {
4198 #ifdef USE_THREADS
4199         if (CvDEPTH(cv) || (CvOWNER(cv) && CvOWNER(cv) != thr))
4200             Perl_croak(aTHX_ "Can't undef active subroutine");
4201 #else
4202         if (CvDEPTH(cv))
4203             Perl_croak(aTHX_ "Can't undef active subroutine");
4204 #endif /* USE_THREADS */
4205         ENTER;
4206
4207         SAVEVPTR(PL_curpad);
4208         PL_curpad = 0;
4209
4210         op_free(CvROOT(cv));
4211         CvROOT(cv) = Nullop;
4212         LEAVE;
4213     }
4214     SvPOK_off((SV*)cv);         /* forget prototype */
4215     CvGV(cv) = Nullgv;
4216     /* Since closure prototypes have the same lifetime as the containing
4217      * CV, they don't hold a refcount on the outside CV.  This avoids
4218      * the refcount loop between the outer CV (which keeps a refcount to
4219      * the closure prototype in the pad entry for pp_anoncode()) and the
4220      * closure prototype, and the ensuing memory leak.  This does not
4221      * apply to closures generated within eval"", since eval"" CVs are
4222      * ephemeral. --GSAR */
4223     if (!CvANON(cv) || CvCLONED(cv)
4224         || (CvOUTSIDE(cv) && SvTYPE(CvOUTSIDE(cv)) == SVt_PVCV
4225             && CvEVAL(CvOUTSIDE(cv)) && !CvGV(CvOUTSIDE(cv))))
4226     {
4227         SvREFCNT_dec(CvOUTSIDE(cv));
4228     }
4229     CvOUTSIDE(cv) = Nullcv;
4230     if (CvCONST(cv)) {
4231         SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4232         CvCONST_off(cv);
4233     }
4234     if (CvPADLIST(cv)) {
4235         /* may be during global destruction */
4236         if (SvREFCNT(CvPADLIST(cv))) {
4237             I32 i = AvFILLp(CvPADLIST(cv));
4238             while (i >= 0) {
4239                 SV** svp = av_fetch(CvPADLIST(cv), i--, FALSE);
4240                 SV* sv = svp ? *svp : Nullsv;
4241                 if (!sv)
4242                     continue;
4243                 if (sv == (SV*)PL_comppad_name)
4244                     PL_comppad_name = Nullav;
4245                 else if (sv == (SV*)PL_comppad) {
4246                     PL_comppad = Nullav;
4247                     PL_curpad = Null(SV**);
4248                 }
4249                 SvREFCNT_dec(sv);
4250             }
4251             SvREFCNT_dec((SV*)CvPADLIST(cv));
4252         }
4253         CvPADLIST(cv) = Nullav;
4254     }
4255     if (CvXSUB(cv)) {
4256         CvXSUB(cv) = 0;
4257     }
4258     CvFLAGS(cv) = 0;
4259 }
4260
4261 #ifdef DEBUG_CLOSURES
4262 STATIC void
4263 S_cv_dump(pTHX_ CV *cv)
4264 {
4265 #ifdef DEBUGGING
4266     CV *outside = CvOUTSIDE(cv);
4267     AV* padlist = CvPADLIST(cv);
4268     AV* pad_name;
4269     AV* pad;
4270     SV** pname;
4271     SV** ppad;
4272     I32 ix;
4273
4274     PerlIO_printf(Perl_debug_log,
4275                   "\tCV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
4276                   PTR2UV(cv),
4277                   (CvANON(cv) ? "ANON"
4278                    : (cv == PL_main_cv) ? "MAIN"
4279                    : CvUNIQUE(cv) ? "UNIQUE"
4280                    : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
4281                   PTR2UV(outside),
4282                   (!outside ? "null"
4283                    : CvANON(outside) ? "ANON"
4284                    : (outside == PL_main_cv) ? "MAIN"
4285                    : CvUNIQUE(outside) ? "UNIQUE"
4286                    : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
4287
4288     if (!padlist)
4289         return;
4290
4291     pad_name = (AV*)*av_fetch(padlist, 0, FALSE);
4292     pad = (AV*)*av_fetch(padlist, 1, FALSE);
4293     pname = AvARRAY(pad_name);
4294     ppad = AvARRAY(pad);
4295
4296     for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
4297         if (SvPOK(pname[ix]))
4298             PerlIO_printf(Perl_debug_log,
4299                           "\t%4d. 0x%"UVxf" (%s\"%s\" %"IVdf"-%"IVdf")\n",
4300                           (int)ix, PTR2UV(ppad[ix]),
4301                           SvFAKE(pname[ix]) ? "FAKE " : "",
4302                           SvPVX(pname[ix]),
4303                           (IV)I_32(SvNVX(pname[ix])),
4304                           SvIVX(pname[ix]));
4305     }
4306 #endif /* DEBUGGING */
4307 }
4308 #endif /* DEBUG_CLOSURES */
4309
4310 STATIC CV *
4311 S_cv_clone2(pTHX_ CV *proto, CV *outside)
4312 {
4313     AV* av;
4314     I32 ix;
4315     AV* protopadlist = CvPADLIST(proto);
4316     AV* protopad_name = (AV*)*av_fetch(protopadlist, 0, FALSE);
4317     AV* protopad = (AV*)*av_fetch(protopadlist, 1, FALSE);
4318     SV** pname = AvARRAY(protopad_name);
4319     SV** ppad = AvARRAY(protopad);
4320     I32 fname = AvFILLp(protopad_name);
4321     I32 fpad = AvFILLp(protopad);
4322     AV* comppadlist;
4323     CV* cv;
4324
4325     assert(!CvUNIQUE(proto));
4326
4327     ENTER;
4328     SAVECOMPPAD();
4329     SAVESPTR(PL_comppad_name);
4330     SAVESPTR(PL_compcv);
4331
4332     cv = PL_compcv = (CV*)NEWSV(1104,0);
4333     sv_upgrade((SV *)cv, SvTYPE(proto));
4334     CvFLAGS(cv) = CvFLAGS(proto) & ~CVf_CLONE;
4335     CvCLONED_on(cv);
4336
4337 #ifdef USE_THREADS
4338     New(666, CvMUTEXP(cv), 1, perl_mutex);
4339     MUTEX_INIT(CvMUTEXP(cv));
4340     CvOWNER(cv)         = 0;
4341 #endif /* USE_THREADS */
4342 #ifdef USE_ITHREADS
4343     CvFILE(cv)          = CvXSUB(proto) ? CvFILE(proto)
4344                                         : savepv(CvFILE(proto));
4345 #else
4346     CvFILE(cv)          = CvFILE(proto);
4347 #endif
4348     CvGV(cv)            = CvGV(proto);
4349     CvSTASH(cv)         = CvSTASH(proto);
4350     CvROOT(cv)          = OpREFCNT_inc(CvROOT(proto));
4351     CvSTART(cv)         = CvSTART(proto);
4352     if (outside)
4353         CvOUTSIDE(cv)   = (CV*)SvREFCNT_inc(outside);
4354
4355     if (SvPOK(proto))
4356         sv_setpvn((SV*)cv, SvPVX(proto), SvCUR(proto));
4357
4358     PL_comppad_name = newAV();
4359     for (ix = fname; ix >= 0; ix--)
4360         av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
4361
4362     PL_comppad = newAV();
4363
4364     comppadlist = newAV();
4365     AvREAL_off(comppadlist);
4366     av_store(comppadlist, 0, (SV*)PL_comppad_name);
4367     av_store(comppadlist, 1, (SV*)PL_comppad);
4368     CvPADLIST(cv) = comppadlist;
4369     av_fill(PL_comppad, AvFILLp(protopad));
4370     PL_curpad = AvARRAY(PL_comppad);
4371
4372     av = newAV();           /* will be @_ */
4373     av_extend(av, 0);
4374     av_store(PL_comppad, 0, (SV*)av);
4375     AvFLAGS(av) = AVf_REIFY;
4376
4377     for (ix = fpad; ix > 0; ix--) {
4378         SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4379         if (namesv && namesv != &PL_sv_undef) {
4380             char *name = SvPVX(namesv);    /* XXX */
4381             if (SvFLAGS(namesv) & SVf_FAKE) {   /* lexical from outside? */
4382                 I32 off = pad_findlex(name, ix, SvIVX(namesv),
4383                                       CvOUTSIDE(cv), cxstack_ix, 0, 0);
4384                 if (!off)
4385                     PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4386                 else if (off != ix)
4387                     Perl_croak(aTHX_ "panic: cv_clone: %s", name);
4388             }
4389             else {                              /* our own lexical */
4390                 SV* sv;
4391                 if (*name == '&') {
4392                     /* anon code -- we'll come back for it */
4393                     sv = SvREFCNT_inc(ppad[ix]);
4394                 }
4395                 else if (*name == '@')
4396                     sv = (SV*)newAV();
4397                 else if (*name == '%')
4398                     sv = (SV*)newHV();
4399                 else
4400                     sv = NEWSV(0,0);
4401                 if (!SvPADBUSY(sv))
4402                     SvPADMY_on(sv);
4403                 PL_curpad[ix] = sv;
4404             }
4405         }
4406         else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
4407             PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4408         }
4409         else {
4410             SV* sv = NEWSV(0,0);
4411             SvPADTMP_on(sv);
4412             PL_curpad[ix] = sv;
4413         }
4414     }
4415
4416     /* Now that vars are all in place, clone nested closures. */
4417
4418     for (ix = fpad; ix > 0; ix--) {
4419         SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4420         if (namesv
4421             && namesv != &PL_sv_undef
4422             && !(SvFLAGS(namesv) & SVf_FAKE)
4423             && *SvPVX(namesv) == '&'
4424             && CvCLONE(ppad[ix]))
4425         {
4426             CV *kid = cv_clone2((CV*)ppad[ix], cv);
4427             SvREFCNT_dec(ppad[ix]);
4428             CvCLONE_on(kid);
4429             SvPADMY_on(kid);
4430             PL_curpad[ix] = (SV*)kid;
4431         }
4432     }
4433
4434 #ifdef DEBUG_CLOSURES
4435     PerlIO_printf(Perl_debug_log, "Cloned inside:\n");
4436     cv_dump(outside);
4437     PerlIO_printf(Perl_debug_log, "  from:\n");
4438     cv_dump(proto);
4439     PerlIO_printf(Perl_debug_log, "   to:\n");
4440     cv_dump(cv);
4441 #endif
4442
4443     LEAVE;
4444
4445     if (CvCONST(cv)) {
4446         SV* const_sv = op_const_sv(CvSTART(cv), cv);
4447         assert(const_sv);
4448         /* constant sub () { $x } closing over $x - see lib/constant.pm */
4449         SvREFCNT_dec(cv);
4450         cv = newCONSTSUB(CvSTASH(proto), 0, const_sv);
4451     }
4452
4453     return cv;
4454 }
4455
4456 CV *
4457 Perl_cv_clone(pTHX_ CV *proto)
4458 {
4459     CV *cv;
4460     LOCK_CRED_MUTEX;                    /* XXX create separate mutex */
4461     cv = cv_clone2(proto, CvOUTSIDE(proto));
4462     UNLOCK_CRED_MUTEX;                  /* XXX create separate mutex */
4463     return cv;
4464 }
4465
4466 void
4467 Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
4468 {
4469     if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4470         SV* msg = sv_newmortal();
4471         SV* name = Nullsv;
4472
4473         if (gv)
4474             gv_efullname3(name = sv_newmortal(), gv, Nullch);
4475         sv_setpv(msg, "Prototype mismatch:");
4476         if (name)
4477             Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4478         if (SvPOK(cv))
4479             Perl_sv_catpvf(aTHX_ msg, " (%s)", SvPVX(cv));
4480         sv_catpv(msg, " vs ");
4481         if (p)
4482             Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4483         else
4484             sv_catpv(msg, "none");
4485         Perl_warner(aTHX_ WARN_PROTOTYPE, "%"SVf, msg);
4486     }
4487 }
4488
4489 static void const_sv_xsub(pTHXo_ CV* cv);
4490
4491 /*
4492 =for apidoc cv_const_sv
4493
4494 If C<cv> is a constant sub eligible for inlining. returns the constant
4495 value returned by the sub.  Otherwise, returns NULL.
4496
4497 Constant subs can be created with C<newCONSTSUB> or as described in
4498 L<perlsub/"Constant Functions">.
4499
4500 =cut
4501 */
4502 SV *
4503 Perl_cv_const_sv(pTHX_ CV *cv)
4504 {
4505     if (!cv || !CvCONST(cv))
4506         return Nullsv;
4507     return (SV*)CvXSUBANY(cv).any_ptr;
4508 }
4509
4510 SV *
4511 Perl_op_const_sv(pTHX_ OP *o, CV *cv)
4512 {
4513     SV *sv = Nullsv;
4514
4515     if (!o)
4516         return Nullsv;
4517
4518     if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4519         o = cLISTOPo->op_first->op_sibling;
4520
4521     for (; o; o = o->op_next) {
4522         OPCODE type = o->op_type;
4523
4524         if (sv && o->op_next == o)
4525             return sv;
4526         if (o->op_next != o) {
4527             if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4528                 continue;
4529             if (type == OP_DBSTATE)
4530                 continue;
4531         }
4532         if (type == OP_LEAVESUB || type == OP_RETURN)
4533             break;
4534         if (sv)
4535             return Nullsv;
4536         if (type == OP_CONST && cSVOPo->op_sv)
4537             sv = cSVOPo->op_sv;
4538         else if ((type == OP_PADSV || type == OP_CONST) && cv) {
4539             AV* padav = (AV*)(AvARRAY(CvPADLIST(cv))[1]);
4540             sv = padav ? AvARRAY(padav)[o->op_targ] : Nullsv;
4541             if (!sv)
4542                 return Nullsv;
4543             if (CvCONST(cv)) {
4544                 /* We get here only from cv_clone2() while creating a closure.
4545                    Copy the const value here instead of in cv_clone2 so that
4546                    SvREADONLY_on doesn't lead to problems when leaving
4547                    scope.
4548                 */
4549                 sv = newSVsv(sv);
4550             }
4551             if (!SvREADONLY(sv) && SvREFCNT(sv) > 1)
4552                 return Nullsv;
4553         }
4554         else
4555             return Nullsv;
4556     }
4557     if (sv)
4558         SvREADONLY_on(sv);
4559     return sv;
4560 }
4561
4562 void
4563 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4564 {
4565     if (o)
4566         SAVEFREEOP(o);
4567     if (proto)
4568         SAVEFREEOP(proto);
4569     if (attrs)
4570         SAVEFREEOP(attrs);
4571     if (block)
4572         SAVEFREEOP(block);
4573     Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4574 }
4575
4576 CV *
4577 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4578 {
4579     return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4580 }
4581
4582 CV *
4583 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4584 {
4585     STRLEN n_a;
4586     char *name;
4587     char *aname;
4588     GV *gv;
4589     char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
4590     register CV *cv=0;
4591     I32 ix;
4592     SV *const_sv;
4593
4594     name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4595     if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4596         SV *sv = sv_newmortal();
4597         Perl_sv_setpvf(aTHX_ sv, "__ANON__[%s:%"IVdf"]",
4598                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4599         aname = SvPVX(sv);
4600     }
4601     else
4602         aname = Nullch;
4603     gv = gv_fetchpv(name ? name : (aname ? aname : "__ANON__"),
4604                     GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4605                     SVt_PVCV);
4606
4607     if (o)
4608         SAVEFREEOP(o);
4609     if (proto)
4610         SAVEFREEOP(proto);
4611     if (attrs)
4612         SAVEFREEOP(attrs);
4613
4614     if (SvTYPE(gv) != SVt_PVGV) {       /* Maybe prototype now, and had at
4615                                            maximum a prototype before. */
4616         if (SvTYPE(gv) > SVt_NULL) {
4617             if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4618                 && ckWARN_d(WARN_PROTOTYPE))
4619             {
4620                 Perl_warner(aTHX_ WARN_PROTOTYPE, "Runaway prototype");
4621             }
4622             cv_ckproto((CV*)gv, NULL, ps);
4623         }
4624         if (ps)
4625             sv_setpv((SV*)gv, ps);
4626         else
4627             sv_setiv((SV*)gv, -1);
4628         SvREFCNT_dec(PL_compcv);
4629         cv = PL_compcv = NULL;
4630         PL_sub_generation++;
4631         goto done;
4632     }
4633
4634     cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4635
4636 #ifdef GV_UNIQUE_CHECK
4637     if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4638         Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
4639     }
4640 #endif
4641
4642     if (!block || !ps || *ps || attrs)
4643         const_sv = Nullsv;
4644     else
4645         const_sv = op_const_sv(block, Nullcv);
4646
4647     if (cv) {
4648         bool exists = CvROOT(cv) || CvXSUB(cv);
4649
4650 #ifdef GV_UNIQUE_CHECK
4651         if (exists && GvUNIQUE(gv)) {
4652             Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
4653         }
4654 #endif
4655
4656         /* if the subroutine doesn't exist and wasn't pre-declared
4657          * with a prototype, assume it will be AUTOLOADed,
4658          * skipping the prototype check
4659          */
4660         if (exists || SvPOK(cv))
4661             cv_ckproto(cv, gv, ps);
4662         /* already defined (or promised)? */
4663         if (exists || GvASSUMECV(gv)) {
4664             if (!block && !attrs) {
4665                 /* just a "sub foo;" when &foo is already defined */
4666                 SAVEFREESV(PL_compcv);
4667                 goto done;
4668             }
4669             /* ahem, death to those who redefine active sort subs */
4670             if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4671                 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4672             if (block) {
4673                 if (ckWARN(WARN_REDEFINE)
4674                     || (CvCONST(cv)
4675                         && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4676                 {
4677                     line_t oldline = CopLINE(PL_curcop);
4678                     CopLINE_set(PL_curcop, PL_copline);
4679                     Perl_warner(aTHX_ WARN_REDEFINE,
4680                         CvCONST(cv) ? "Constant subroutine %s redefined"
4681                                     : "Subroutine %s redefined", name);
4682                     CopLINE_set(PL_curcop, oldline);
4683                 }
4684                 SvREFCNT_dec(cv);
4685                 cv = Nullcv;
4686             }
4687         }
4688     }
4689     if (const_sv) {
4690         SvREFCNT_inc(const_sv);
4691         if (cv) {
4692             assert(!CvROOT(cv) && !CvCONST(cv));
4693             sv_setpv((SV*)cv, "");  /* prototype is "" */
4694             CvXSUBANY(cv).any_ptr = const_sv;
4695             CvXSUB(cv) = const_sv_xsub;
4696             CvCONST_on(cv);
4697         }
4698         else {
4699             GvCV(gv) = Nullcv;
4700             cv = newCONSTSUB(NULL, name, const_sv);
4701         }
4702         op_free(block);
4703         SvREFCNT_dec(PL_compcv);
4704         PL_compcv = NULL;
4705         PL_sub_generation++;
4706         goto done;
4707     }
4708     if (attrs) {
4709         HV *stash;
4710         SV *rcv;
4711
4712         /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4713          * before we clobber PL_compcv.
4714          */
4715         if (cv && !block) {
4716             rcv = (SV*)cv;
4717             if (CvGV(cv) && GvSTASH(CvGV(cv)))
4718                 stash = GvSTASH(CvGV(cv));
4719             else if (CvSTASH(cv))
4720                 stash = CvSTASH(cv);
4721             else
4722                 stash = PL_curstash;
4723         }
4724         else {
4725             /* possibly about to re-define existing subr -- ignore old cv */
4726             rcv = (SV*)PL_compcv;
4727             if (name && GvSTASH(gv))
4728                 stash = GvSTASH(gv);
4729             else
4730                 stash = PL_curstash;
4731         }
4732         apply_attrs(stash, rcv, attrs);
4733     }
4734     if (cv) {                           /* must reuse cv if autoloaded */
4735         if (!block) {
4736             /* got here with just attrs -- work done, so bug out */
4737             SAVEFREESV(PL_compcv);
4738             goto done;
4739         }
4740         cv_undef(cv);
4741         CvFLAGS(cv) = CvFLAGS(PL_compcv);
4742         CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4743         CvOUTSIDE(PL_compcv) = 0;
4744         CvPADLIST(cv) = CvPADLIST(PL_compcv);
4745         CvPADLIST(PL_compcv) = 0;
4746         /* inner references to PL_compcv must be fixed up ... */
4747         {
4748             AV *padlist = CvPADLIST(cv);
4749             AV *comppad_name = (AV*)AvARRAY(padlist)[0];
4750             AV *comppad = (AV*)AvARRAY(padlist)[1];
4751             SV **namepad = AvARRAY(comppad_name);
4752             SV **curpad = AvARRAY(comppad);
4753             for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
4754                 SV *namesv = namepad[ix];
4755                 if (namesv && namesv != &PL_sv_undef
4756                     && *SvPVX(namesv) == '&')
4757                 {
4758                     CV *innercv = (CV*)curpad[ix];
4759                     if (CvOUTSIDE(innercv) == PL_compcv) {
4760                         CvOUTSIDE(innercv) = cv;
4761                         if (!CvANON(innercv) || CvCLONED(innercv)) {
4762                             (void)SvREFCNT_inc(cv);
4763                             SvREFCNT_dec(PL_compcv);
4764                         }
4765                     }
4766                 }
4767             }
4768         }
4769         /* ... before we throw it away */
4770         SvREFCNT_dec(PL_compcv);
4771         if (PERLDB_INTER)/* Advice debugger on the new sub. */
4772           ++PL_sub_generation;
4773     }
4774     else {
4775         cv = PL_compcv;
4776         if (name) {
4777             GvCV(gv) = cv;
4778             GvCVGEN(gv) = 0;
4779             PL_sub_generation++;
4780         }
4781     }
4782     CvGV(cv) = gv;
4783     CvFILE_set_from_cop(cv, PL_curcop);
4784     CvSTASH(cv) = PL_curstash;
4785 #ifdef USE_THREADS
4786     CvOWNER(cv) = 0;
4787     if (!CvMUTEXP(cv)) {
4788         New(666, CvMUTEXP(cv), 1, perl_mutex);
4789         MUTEX_INIT(CvMUTEXP(cv));
4790     }
4791 #endif /* USE_THREADS */
4792
4793     if (ps)
4794         sv_setpv((SV*)cv, ps);
4795
4796     if (PL_error_count) {
4797         op_free(block);
4798         block = Nullop;
4799         if (name) {
4800             char *s = strrchr(name, ':');
4801             s = s ? s+1 : name;
4802             if (strEQ(s, "BEGIN")) {
4803                 char *not_safe =
4804                     "BEGIN not safe after errors--compilation aborted";
4805                 if (PL_in_eval & EVAL_KEEPERR)
4806                     Perl_croak(aTHX_ not_safe);
4807                 else {
4808                     /* force display of errors found but not reported */
4809                     sv_catpv(ERRSV, not_safe);
4810                     Perl_croak(aTHX_ "%s", SvPVx(ERRSV, n_a));
4811                 }
4812             }
4813         }
4814     }
4815     if (!block)
4816         goto done;
4817
4818     if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
4819         av_store(PL_comppad_name, AvFILLp(PL_comppad), Nullsv);
4820
4821     if (CvLVALUE(cv)) {
4822         CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4823                              mod(scalarseq(block), OP_LEAVESUBLV));
4824     }
4825     else {
4826         CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4827     }
4828     CvROOT(cv)->op_private |= OPpREFCOUNTED;
4829     OpREFCNT_set(CvROOT(cv), 1);
4830     CvSTART(cv) = LINKLIST(CvROOT(cv));
4831     CvROOT(cv)->op_next = 0;
4832     peep(CvSTART(cv));
4833
4834     /* now that optimizer has done its work, adjust pad values */
4835     if (CvCLONE(cv)) {
4836         SV **namep = AvARRAY(PL_comppad_name);
4837         for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4838             SV *namesv;
4839
4840             if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
4841                 continue;
4842             /*
4843              * The only things that a clonable function needs in its
4844              * pad are references to outer lexicals and anonymous subs.
4845              * The rest are created anew during cloning.
4846              */
4847             if (!((namesv = namep[ix]) != Nullsv &&
4848                   namesv != &PL_sv_undef &&
4849                   (SvFAKE(namesv) ||
4850                    *SvPVX(namesv) == '&')))
4851             {
4852                 SvREFCNT_dec(PL_curpad[ix]);
4853                 PL_curpad[ix] = Nullsv;
4854             }
4855         }
4856         assert(!CvCONST(cv));
4857         if (ps && !*ps && op_const_sv(block, cv))
4858             CvCONST_on(cv);
4859     }
4860     else {
4861         AV *av = newAV();                       /* Will be @_ */
4862         av_extend(av, 0);
4863         av_store(PL_comppad, 0, (SV*)av);
4864         AvFLAGS(av) = AVf_REIFY;
4865
4866         for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4867             if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
4868                 continue;
4869             if (!SvPADMY(PL_curpad[ix]))
4870                 SvPADTMP_on(PL_curpad[ix]);
4871         }
4872     }
4873
4874     /* If a potential closure prototype, don't keep a refcount on
4875      * outer CV, unless the latter happens to be a passing eval"".
4876      * This is okay as the lifetime of the prototype is tied to the
4877      * lifetime of the outer CV.  Avoids memory leak due to reference
4878      * loop. --GSAR */
4879     if (!name && CvOUTSIDE(cv)
4880         && !(SvTYPE(CvOUTSIDE(cv)) == SVt_PVCV
4881              && CvEVAL(CvOUTSIDE(cv)) && !CvGV(CvOUTSIDE(cv))))
4882     {
4883         SvREFCNT_dec(CvOUTSIDE(cv));
4884     }
4885
4886     if (name || aname) {
4887         char *s;
4888         char *tname = (name ? name : aname);
4889
4890         if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4891             SV *sv = NEWSV(0,0);
4892             SV *tmpstr = sv_newmortal();
4893             GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4894             CV *pcv;
4895             HV *hv;
4896
4897             Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4898                            CopFILE(PL_curcop),
4899                            (long)PL_subline, (long)CopLINE(PL_curcop));
4900             gv_efullname3(tmpstr, gv, Nullch);
4901             hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
4902             hv = GvHVn(db_postponed);
4903             if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
4904                 && (pcv = GvCV(db_postponed)))
4905             {
4906                 dSP;
4907                 PUSHMARK(SP);
4908                 XPUSHs(tmpstr);
4909                 PUTBACK;
4910                 call_sv((SV*)pcv, G_DISCARD);
4911             }
4912         }
4913
4914         if ((s = strrchr(tname,':')))
4915             s++;
4916         else
4917             s = tname;
4918
4919         if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4920             goto done;
4921
4922         if (strEQ(s, "BEGIN")) {
4923             I32 oldscope = PL_scopestack_ix;
4924             ENTER;
4925             SAVECOPFILE(&PL_compiling);
4926             SAVECOPLINE(&PL_compiling);
4927             save_svref(&PL_rs);
4928             sv_setsv(PL_rs, PL_nrs);
4929
4930             if (!PL_beginav)
4931                 PL_beginav = newAV();
4932             DEBUG_x( dump_sub(gv) );
4933             av_push(PL_beginav, (SV*)cv);
4934             GvCV(gv) = 0;               /* cv has been hijacked */
4935             call_list(oldscope, PL_beginav);
4936
4937             PL_curcop = &PL_compiling;
4938             PL_compiling.op_private = PL_hints;
4939             LEAVE;
4940         }
4941         else if (strEQ(s, "END") && !PL_error_count) {
4942             if (!PL_endav)
4943                 PL_endav = newAV();
4944             DEBUG_x( dump_sub(gv) );
4945             av_unshift(PL_endav, 1);
4946             av_store(PL_endav, 0, (SV*)cv);
4947             GvCV(gv) = 0;               /* cv has been hijacked */
4948         }
4949         else if (strEQ(s, "CHECK") && !PL_error_count) {
4950             if (!PL_checkav)
4951                 PL_checkav = newAV();
4952             DEBUG_x( dump_sub(gv) );
4953             if (PL_main_start && ckWARN(WARN_VOID))
4954                 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
4955             av_unshift(PL_checkav, 1);
4956             av_store(PL_checkav, 0, (SV*)cv);
4957             GvCV(gv) = 0;               /* cv has been hijacked */
4958         }
4959         else if (strEQ(s, "INIT") && !PL_error_count) {
4960             if (!PL_initav)
4961                 PL_initav = newAV();
4962             DEBUG_x( dump_sub(gv) );
4963             if (PL_main_start && ckWARN(WARN_VOID))
4964                 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
4965             av_push(PL_initav, (SV*)cv);
4966             GvCV(gv) = 0;               /* cv has been hijacked */
4967         }
4968     }
4969
4970   done:
4971     PL_copline = NOLINE;
4972     LEAVE_SCOPE(floor);
4973     return cv;
4974 }
4975
4976 /* XXX unsafe for threads if eval_owner isn't held */
4977 /*
4978 =for apidoc newCONSTSUB
4979
4980 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4981 eligible for inlining at compile-time.
4982
4983 =cut
4984 */
4985
4986 CV *
4987 Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
4988 {
4989     CV* cv;
4990
4991     ENTER;
4992
4993     SAVECOPLINE(PL_curcop);
4994     CopLINE_set(PL_curcop, PL_copline);
4995
4996     SAVEHINTS();
4997     PL_hints &= ~HINT_BLOCK_SCOPE;
4998
4999     if (stash) {
5000         SAVESPTR(PL_curstash);
5001         SAVECOPSTASH(PL_curcop);
5002         PL_curstash = stash;
5003 #ifdef USE_ITHREADS
5004         CopSTASHPV(PL_curcop) = stash ? HvNAME(stash) : Nullch;
5005 #else
5006         CopSTASH(PL_curcop) = stash;
5007 #endif
5008     }
5009
5010     cv = newXS(name, const_sv_xsub, __FILE__);
5011     CvXSUBANY(cv).any_ptr = sv;
5012     CvCONST_on(cv);
5013     sv_setpv((SV*)cv, "");  /* prototype is "" */
5014
5015     LEAVE;
5016
5017     return cv;
5018 }
5019
5020 /*
5021 =for apidoc U||newXS
5022
5023 Used by C<xsubpp> to hook up XSUBs as Perl subs.
5024
5025 =cut
5026 */
5027
5028 CV *
5029 Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
5030 {
5031     GV *gv = gv_fetchpv(name ? name : "__ANON__", GV_ADDMULTI, SVt_PVCV);
5032     register CV *cv;
5033
5034     if ((cv = (name ? GvCV(gv) : Nullcv))) {
5035         if (GvCVGEN(gv)) {
5036             /* just a cached method */
5037             SvREFCNT_dec(cv);
5038             cv = 0;
5039         }
5040         else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
5041             /* already defined (or promised) */
5042             if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
5043                             && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
5044                 line_t oldline = CopLINE(PL_curcop);
5045                 if (PL_copline != NOLINE)
5046                     CopLINE_set(PL_curcop, PL_copline);
5047                 Perl_warner(aTHX_ WARN_REDEFINE,
5048                             CvCONST(cv) ? "Constant subroutine %s redefined"
5049                                         : "Subroutine %s redefined"
5050                             ,name);
5051                 CopLINE_set(PL_curcop, oldline);
5052             }
5053             SvREFCNT_dec(cv);
5054             cv = 0;
5055         }
5056     }
5057
5058     if (cv)                             /* must reuse cv if autoloaded */
5059         cv_undef(cv);
5060     else {
5061         cv = (CV*)NEWSV(1105,0);
5062         sv_upgrade((SV *)cv, SVt_PVCV);
5063         if (name) {
5064             GvCV(gv) = cv;
5065             GvCVGEN(gv) = 0;
5066             PL_sub_generation++;
5067         }
5068     }
5069     CvGV(cv) = gv;
5070 #ifdef USE_THREADS
5071     New(666, CvMUTEXP(cv), 1, perl_mutex);
5072     MUTEX_INIT(CvMUTEXP(cv));
5073     CvOWNER(cv) = 0;
5074 #endif /* USE_THREADS */
5075     (void)gv_fetchfile(filename);
5076     CvFILE(cv) = filename;      /* NOTE: not copied, as it is expected to be
5077                                    an external constant string */
5078     CvXSUB(cv) = subaddr;
5079
5080     if (name) {
5081         char *s = strrchr(name,':');
5082         if (s)
5083             s++;
5084         else
5085             s = name;
5086
5087         if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5088             goto done;
5089
5090         if (strEQ(s, "BEGIN")) {
5091             if (!PL_beginav)
5092                 PL_beginav = newAV();
5093             av_push(PL_beginav, (SV*)cv);
5094             GvCV(gv) = 0;               /* cv has been hijacked */
5095         }
5096         else if (strEQ(s, "END")) {
5097             if (!PL_endav)
5098                 PL_endav = newAV();
5099             av_unshift(PL_endav, 1);
5100             av_store(PL_endav, 0, (SV*)cv);
5101             GvCV(gv) = 0;               /* cv has been hijacked */
5102         }
5103         else if (strEQ(s, "CHECK")) {
5104             if (!PL_checkav)
5105                 PL_checkav = newAV();
5106             if (PL_main_start && ckWARN(WARN_VOID))
5107                 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
5108             av_unshift(PL_checkav, 1);
5109             av_store(PL_checkav, 0, (SV*)cv);
5110             GvCV(gv) = 0;               /* cv has been hijacked */
5111         }
5112         else if (strEQ(s, "INIT")) {
5113             if (!PL_initav)
5114                 PL_initav = newAV();
5115             if (PL_main_start && ckWARN(WARN_VOID))
5116                 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
5117             av_push(PL_initav, (SV*)cv);
5118             GvCV(gv) = 0;               /* cv has been hijacked */
5119         }
5120     }
5121     else
5122         CvANON_on(cv);
5123
5124 done:
5125     return cv;
5126 }
5127
5128 void
5129 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
5130 {
5131     register CV *cv;
5132     char *name;
5133     GV *gv;
5134     I32 ix;
5135     STRLEN n_a;
5136
5137     if (o)
5138         name = SvPVx(cSVOPo->op_sv, n_a);
5139     else
5140         name = "STDOUT";
5141     gv = gv_fetchpv(name,TRUE, SVt_PVFM);
5142 #ifdef GV_UNIQUE_CHECK
5143     if (GvUNIQUE(gv)) {
5144         Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
5145     }
5146 #endif
5147     GvMULTI_on(gv);
5148     if ((cv = GvFORM(gv))) {
5149         if (ckWARN(WARN_REDEFINE)) {
5150             line_t oldline = CopLINE(PL_curcop);
5151
5152             CopLINE_set(PL_curcop, PL_copline);
5153             Perl_warner(aTHX_ WARN_REDEFINE, "Format %s redefined",name);
5154             CopLINE_set(PL_curcop, oldline);
5155         }
5156         SvREFCNT_dec(cv);
5157     }
5158     cv = PL_compcv;
5159     GvFORM(gv) = cv;
5160     CvGV(cv) = gv;
5161     CvFILE_set_from_cop(cv, PL_curcop);
5162
5163     for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
5164         if (!SvPADMY(PL_curpad[ix]) && !SvIMMORTAL(PL_curpad[ix]))
5165             SvPADTMP_on(PL_curpad[ix]);
5166     }
5167
5168     CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5169     CvROOT(cv)->op_private |= OPpREFCOUNTED;
5170     OpREFCNT_set(CvROOT(cv), 1);
5171     CvSTART(cv) = LINKLIST(CvROOT(cv));
5172     CvROOT(cv)->op_next = 0;
5173     peep(CvSTART(cv));
5174     op_free(o);
5175     PL_copline = NOLINE;
5176     LEAVE_SCOPE(floor);
5177 }
5178
5179 OP *
5180 Perl_newANONLIST(pTHX_ OP *o)
5181 {
5182     return newUNOP(OP_REFGEN, 0,
5183         mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
5184 }
5185
5186 OP *
5187 Perl_newANONHASH(pTHX_ OP *o)
5188 {
5189     return newUNOP(OP_REFGEN, 0,
5190         mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
5191 }
5192
5193 OP *
5194 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5195 {
5196     return newANONATTRSUB(floor, proto, Nullop, block);
5197 }
5198
5199 OP *
5200 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5201 {
5202     return newUNOP(OP_REFGEN, 0,
5203         newSVOP(OP_ANONCODE, 0,
5204                 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5205 }
5206
5207 OP *
5208 Perl_oopsAV(pTHX_ OP *o)
5209 {
5210     switch (o->op_type) {
5211     case OP_PADSV:
5212         o->op_type = OP_PADAV;
5213         o->op_ppaddr = PL_ppaddr[OP_PADAV];
5214         return ref(o, OP_RV2AV);
5215
5216     case OP_RV2SV:
5217         o->op_type = OP_RV2AV;
5218         o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5219         ref(o, OP_RV2AV);
5220         break;
5221
5222     default:
5223         if (ckWARN_d(WARN_INTERNAL))
5224             Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsAV");
5225         break;
5226     }
5227     return o;
5228 }
5229
5230 OP *
5231 Perl_oopsHV(pTHX_ OP *o)
5232 {
5233     switch (o->op_type) {
5234     case OP_PADSV:
5235     case OP_PADAV:
5236         o->op_type = OP_PADHV;
5237         o->op_ppaddr = PL_ppaddr[OP_PADHV];
5238         return ref(o, OP_RV2HV);
5239
5240     case OP_RV2SV:
5241     case OP_RV2AV:
5242         o->op_type = OP_RV2HV;
5243         o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5244         ref(o, OP_RV2HV);
5245         break;
5246
5247     default:
5248         if (ckWARN_d(WARN_INTERNAL))
5249             Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsHV");
5250         break;
5251     }
5252     return o;
5253 }
5254
5255 OP *
5256 Perl_newAVREF(pTHX_ OP *o)
5257 {
5258     if (o->op_type == OP_PADANY) {
5259         o->op_type = OP_PADAV;
5260         o->op_ppaddr = PL_ppaddr[OP_PADAV];
5261         return o;
5262     }
5263     else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
5264                 && ckWARN(WARN_DEPRECATED)) {
5265         Perl_warner(aTHX_ WARN_DEPRECATED,
5266                 "Using an array as a reference is deprecated");
5267     }
5268     return newUNOP(OP_RV2AV, 0, scalar(o));
5269 }
5270
5271 OP *
5272 Perl_newGVREF(pTHX_ I32 type, OP *o)
5273 {
5274     if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5275         return newUNOP(OP_NULL, 0, o);
5276     return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5277 }
5278
5279 OP *
5280 Perl_newHVREF(pTHX_ OP *o)
5281 {
5282     if (o->op_type == OP_PADANY) {
5283         o->op_type = OP_PADHV;
5284         o->op_ppaddr = PL_ppaddr[OP_PADHV];
5285         return o;
5286     }
5287     else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
5288                 && ckWARN(WARN_DEPRECATED)) {
5289         Perl_warner(aTHX_ WARN_DEPRECATED,
5290                 "Using a hash as a reference is deprecated");
5291     }
5292     return newUNOP(OP_RV2HV, 0, scalar(o));
5293 }
5294
5295 OP *
5296 Perl_oopsCV(pTHX_ OP *o)
5297 {
5298     Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5299     /* STUB */
5300     return o;
5301 }
5302
5303 OP *
5304 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5305 {
5306     return newUNOP(OP_RV2CV, flags, scalar(o));
5307 }
5308
5309 OP *
5310 Perl_newSVREF(pTHX_ OP *o)
5311 {
5312     if (o->op_type == OP_PADANY) {
5313         o->op_type = OP_PADSV;
5314         o->op_ppaddr = PL_ppaddr[OP_PADSV];
5315         return o;
5316     }
5317     else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5318         o->op_flags |= OPpDONE_SVREF;
5319         return o;
5320     }
5321     return newUNOP(OP_RV2SV, 0, scalar(o));
5322 }
5323
5324 /* Check routines. */
5325
5326 OP *
5327 Perl_ck_anoncode(pTHX_ OP *o)
5328 {
5329     PADOFFSET ix;
5330     SV* name;
5331
5332     name = NEWSV(1106,0);
5333     sv_upgrade(name, SVt_PVNV);
5334     sv_setpvn(name, "&", 1);
5335     SvIVX(name) = -1;
5336     SvNVX(name) = 1;
5337     ix = pad_alloc(o->op_type, SVs_PADMY);
5338     av_store(PL_comppad_name, ix, name);
5339     av_store(PL_comppad, ix, cSVOPo->op_sv);
5340     SvPADMY_on(cSVOPo->op_sv);
5341     cSVOPo->op_sv = Nullsv;
5342     cSVOPo->op_targ = ix;
5343     return o;
5344 }
5345
5346 OP *
5347 Perl_ck_bitop(pTHX_ OP *o)
5348 {
5349     o->op_private = PL_hints;
5350     return o;
5351 }
5352
5353 OP *
5354 Perl_ck_concat(pTHX_ OP *o)
5355 {
5356     if (cUNOPo->op_first->op_type == OP_CONCAT)
5357         o->op_flags |= OPf_STACKED;
5358     return o;
5359 }
5360
5361 OP *
5362 Perl_ck_spair(pTHX_ OP *o)
5363 {
5364     if (o->op_flags & OPf_KIDS) {
5365         OP* newop;
5366         OP* kid;
5367         OPCODE type = o->op_type;
5368         o = modkids(ck_fun(o), type);
5369         kid = cUNOPo->op_first;
5370         newop = kUNOP->op_first->op_sibling;
5371         if (newop &&
5372             (newop->op_sibling ||
5373              !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
5374              newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5375              newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
5376
5377             return o;
5378         }
5379         op_free(kUNOP->op_first);
5380         kUNOP->op_first = newop;
5381     }
5382     o->op_ppaddr = PL_ppaddr[++o->op_type];
5383     return ck_fun(o);
5384 }
5385
5386 OP *
5387 Perl_ck_delete(pTHX_ OP *o)
5388 {
5389     o = ck_fun(o);
5390     o->op_private = 0;
5391     if (o->op_flags & OPf_KIDS) {
5392         OP *kid = cUNOPo->op_first;
5393         switch (kid->op_type) {
5394         case OP_ASLICE:
5395             o->op_flags |= OPf_SPECIAL;
5396             /* FALL THROUGH */
5397         case OP_HSLICE:
5398             o->op_private |= OPpSLICE;
5399             break;
5400         case OP_AELEM:
5401             o->op_flags |= OPf_SPECIAL;
5402             /* FALL THROUGH */
5403         case OP_HELEM:
5404             break;
5405         default:
5406             Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5407                   PL_op_desc[o->op_type]);
5408         }
5409         op_null(kid);
5410     }
5411     return o;
5412 }
5413
5414 OP *
5415 Perl_ck_eof(pTHX_ OP *o)
5416 {
5417     I32 type = o->op_type;
5418
5419     if (o->op_flags & OPf_KIDS) {
5420         if (cLISTOPo->op_first->op_type == OP_STUB) {
5421             op_free(o);
5422             o = newUNOP(type, OPf_SPECIAL,
5423                 newGVOP(OP_GV, 0, gv_fetchpv("main::ARGV", TRUE, SVt_PVAV)));
5424         }
5425         return ck_fun(o);
5426     }
5427     return o;
5428 }
5429
5430 OP *
5431 Perl_ck_eval(pTHX_ OP *o)
5432 {
5433     PL_hints |= HINT_BLOCK_SCOPE;
5434     if (o->op_flags & OPf_KIDS) {
5435         SVOP *kid = (SVOP*)cUNOPo->op_first;
5436
5437         if (!kid) {
5438             o->op_flags &= ~OPf_KIDS;
5439             op_null(o);
5440         }
5441         else if (kid->op_type == OP_LINESEQ) {
5442             LOGOP *enter;
5443
5444             kid->op_next = o->op_next;
5445             cUNOPo->op_first = 0;
5446             op_free(o);
5447
5448             NewOp(1101, enter, 1, LOGOP);
5449             enter->op_type = OP_ENTERTRY;
5450             enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5451             enter->op_private = 0;
5452
5453             /* establish postfix order */
5454             enter->op_next = (OP*)enter;
5455
5456             o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5457             o->op_type = OP_LEAVETRY;
5458             o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5459             enter->op_other = o;
5460             return o;
5461         }
5462         else
5463             scalar((OP*)kid);
5464     }
5465     else {
5466         op_free(o);
5467         o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5468     }
5469     o->op_targ = (PADOFFSET)PL_hints;
5470     return o;
5471 }
5472
5473 OP *
5474 Perl_ck_exit(pTHX_ OP *o)
5475 {
5476 #ifdef VMS
5477     HV *table = GvHV(PL_hintgv);
5478     if (table) {
5479        SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
5480        if (svp && *svp && SvTRUE(*svp))
5481            o->op_private |= OPpEXIT_VMSISH;
5482     }
5483 #endif
5484     return ck_fun(o);
5485 }
5486
5487 OP *
5488 Perl_ck_exec(pTHX_ OP *o)
5489 {
5490     OP *kid;
5491     if (o->op_flags & OPf_STACKED) {
5492         o = ck_fun(o);
5493         kid = cUNOPo->op_first->op_sibling;
5494         if (kid->op_type == OP_RV2GV)
5495             op_null(kid);
5496     }
5497     else
5498         o = listkids(o);
5499     return o;
5500 }
5501
5502 OP *
5503 Perl_ck_exists(pTHX_ OP *o)
5504 {
5505     o = ck_fun(o);
5506     if (o->op_flags & OPf_KIDS) {
5507         OP *kid = cUNOPo->op_first;
5508         if (kid->op_type == OP_ENTERSUB) {
5509             (void) ref(kid, o->op_type);
5510             if (kid->op_type != OP_RV2CV && !PL_error_count)
5511                 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5512                            PL_op_desc[o->op_type]);
5513             o->op_private |= OPpEXISTS_SUB;
5514         }
5515         else if (kid->op_type == OP_AELEM)
5516             o->op_flags |= OPf_SPECIAL;
5517         else if (kid->op_type != OP_HELEM)
5518             Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5519                        PL_op_desc[o->op_type]);
5520         op_null(kid);
5521     }
5522     return o;
5523 }
5524
5525 #if 0
5526 OP *
5527 Perl_ck_gvconst(pTHX_ register OP *o)
5528 {
5529     o = fold_constants(o);
5530     if (o->op_type == OP_CONST)
5531         o->op_type = OP_GV;
5532     return o;
5533 }
5534 #endif
5535
5536 OP *
5537 Perl_ck_rvconst(pTHX_ register OP *o)
5538 {
5539     SVOP *kid = (SVOP*)cUNOPo->op_first;
5540
5541     o->op_private |= (PL_hints & HINT_STRICT_REFS);
5542     if (kid->op_type == OP_CONST) {
5543         char *name;
5544         int iscv;
5545         GV *gv;
5546         SV *kidsv = kid->op_sv;
5547         STRLEN n_a;
5548
5549         /* Is it a constant from cv_const_sv()? */
5550         if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5551             SV *rsv = SvRV(kidsv);
5552             int svtype = SvTYPE(rsv);
5553             char *badtype = Nullch;
5554
5555             switch (o->op_type) {
5556             case OP_RV2SV:
5557                 if (svtype > SVt_PVMG)
5558                     badtype = "a SCALAR";
5559                 break;
5560             case OP_RV2AV:
5561                 if (svtype != SVt_PVAV)
5562                     badtype = "an ARRAY";
5563                 break;
5564             case OP_RV2HV:
5565                 if (svtype != SVt_PVHV) {
5566                     if (svtype == SVt_PVAV) {   /* pseudohash? */
5567                         SV **ksv = av_fetch((AV*)rsv, 0, FALSE);
5568                         if (ksv && SvROK(*ksv)
5569                             && SvTYPE(SvRV(*ksv)) == SVt_PVHV)
5570                         {
5571                                 break;
5572                         }
5573                     }
5574                     badtype = "a HASH";
5575                 }
5576                 break;
5577             case OP_RV2CV:
5578                 if (svtype != SVt_PVCV)
5579                     badtype = "a CODE";
5580                 break;
5581             }
5582             if (badtype)
5583                 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5584             return o;
5585         }
5586         name = SvPV(kidsv, n_a);
5587         if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5588             char *badthing = Nullch;
5589             switch (o->op_type) {
5590             case OP_RV2SV:
5591                 badthing = "a SCALAR";
5592                 break;
5593             case OP_RV2AV:
5594                 badthing = "an ARRAY";
5595                 break;
5596             case OP_RV2HV:
5597                 badthing = "a HASH";
5598                 break;
5599             }
5600             if (badthing)
5601                 Perl_croak(aTHX_
5602           "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
5603                       name, badthing);
5604         }
5605         /*
5606          * This is a little tricky.  We only want to add the symbol if we
5607          * didn't add it in the lexer.  Otherwise we get duplicate strict
5608          * warnings.  But if we didn't add it in the lexer, we must at
5609          * least pretend like we wanted to add it even if it existed before,
5610          * or we get possible typo warnings.  OPpCONST_ENTERED says
5611          * whether the lexer already added THIS instance of this symbol.
5612          */
5613         iscv = (o->op_type == OP_RV2CV) * 2;
5614         do {
5615             gv = gv_fetchpv(name,
5616                 iscv | !(kid->op_private & OPpCONST_ENTERED),
5617                 iscv
5618                     ? SVt_PVCV
5619                     : o->op_type == OP_RV2SV
5620                         ? SVt_PV
5621                         : o->op_type == OP_RV2AV
5622                             ? SVt_PVAV
5623                             : o->op_type == OP_RV2HV
5624                                 ? SVt_PVHV
5625                                 : SVt_PVGV);
5626         } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5627         if (gv) {
5628             kid->op_type = OP_GV;
5629             SvREFCNT_dec(kid->op_sv);
5630 #ifdef USE_ITHREADS
5631             /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5632             kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5633             SvREFCNT_dec(PL_curpad[kPADOP->op_padix]);
5634             GvIN_PAD_on(gv);
5635             PL_curpad[kPADOP->op_padix] = SvREFCNT_inc(gv);
5636 #else
5637             kid->op_sv = SvREFCNT_inc(gv);
5638 #endif
5639             kid->op_private = 0;
5640             kid->op_ppaddr = PL_ppaddr[OP_GV];
5641         }
5642     }
5643     return o;
5644 }
5645
5646 OP *
5647 Perl_ck_ftst(pTHX_ OP *o)
5648 {
5649     I32 type = o->op_type;
5650
5651     if (o->op_flags & OPf_REF) {
5652         /* nothing */
5653     }
5654     else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5655         SVOP *kid = (SVOP*)cUNOPo->op_first;
5656
5657         if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5658             STRLEN n_a;
5659             OP *newop = newGVOP(type, OPf_REF,
5660                 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
5661             op_free(o);
5662             o = newop;
5663         }
5664     }
5665     else {
5666         op_free(o);
5667         if (type == OP_FTTTY)
5668            o =  newGVOP(type, OPf_REF, gv_fetchpv("main::STDIN", TRUE,
5669                                 SVt_PVIO));
5670         else
5671             o = newUNOP(type, 0, newDEFSVOP());
5672     }
5673     return o;
5674 }
5675
5676 OP *
5677 Perl_ck_fun(pTHX_ OP *o)
5678 {
5679     register OP *kid;
5680     OP **tokid;
5681     OP *sibl;
5682     I32 numargs = 0;
5683     int type = o->op_type;
5684     register I32 oa = PL_opargs[type] >> OASHIFT;
5685
5686     if (o->op_flags & OPf_STACKED) {
5687         if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5688             oa &= ~OA_OPTIONAL;
5689         else
5690             return no_fh_allowed(o);
5691     }
5692
5693     if (o->op_flags & OPf_KIDS) {
5694         STRLEN n_a;
5695         tokid = &cLISTOPo->op_first;
5696         kid = cLISTOPo->op_first;
5697         if (kid->op_type == OP_PUSHMARK ||
5698             (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5699         {
5700             tokid = &kid->op_sibling;
5701             kid = kid->op_sibling;
5702         }
5703         if (!kid && PL_opargs[type] & OA_DEFGV)
5704             *tokid = kid = newDEFSVOP();
5705
5706         while (oa && kid) {
5707             numargs++;
5708             sibl = kid->op_sibling;
5709             switch (oa & 7) {
5710             case OA_SCALAR:
5711                 /* list seen where single (scalar) arg expected? */
5712                 if (numargs == 1 && !(oa >> 4)
5713                     && kid->op_type == OP_LIST && type != OP_SCALAR)
5714                 {
5715                     return too_many_arguments(o,PL_op_desc[type]);
5716                 }
5717                 scalar(kid);
5718                 break;
5719             case OA_LIST:
5720                 if (oa < 16) {
5721                     kid = 0;
5722                     continue;
5723                 }
5724                 else
5725                     list(kid);
5726                 break;
5727             case OA_AVREF:
5728                 if ((type == OP_PUSH || type == OP_UNSHIFT)
5729                     && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5730                     Perl_warner(aTHX_ WARN_SYNTAX,
5731                         "Useless use of %s with no values",
5732                         PL_op_desc[type]);
5733
5734                 if (kid->op_type == OP_CONST &&
5735                     (kid->op_private & OPpCONST_BARE))
5736                 {
5737                     char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5738                     OP *newop = newAVREF(newGVOP(OP_GV, 0,
5739                         gv_fetchpv(name, TRUE, SVt_PVAV) ));
5740                     if (ckWARN(WARN_DEPRECATED))
5741                         Perl_warner(aTHX_ WARN_DEPRECATED,
5742                             "Array @%s missing the @ in argument %"IVdf" of %s()",
5743                             name, (IV)numargs, PL_op_desc[type]);
5744                     op_free(kid);
5745                     kid = newop;
5746                     kid->op_sibling = sibl;
5747                     *tokid = kid;
5748                 }
5749                 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5750                     bad_type(numargs, "array", PL_op_desc[type], kid);
5751                 mod(kid, type);
5752                 break;
5753             case OA_HVREF:
5754                 if (kid->op_type == OP_CONST &&
5755                     (kid->op_private & OPpCONST_BARE))
5756                 {
5757                     char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5758                     OP *newop = newHVREF(newGVOP(OP_GV, 0,
5759                         gv_fetchpv(name, TRUE, SVt_PVHV) ));
5760                     if (ckWARN(WARN_DEPRECATED))
5761                         Perl_warner(aTHX_ WARN_DEPRECATED,
5762                             "Hash %%%s missing the %% in argument %"IVdf" of %s()",
5763                             name, (IV)numargs, PL_op_desc[type]);
5764                     op_free(kid);
5765                     kid = newop;
5766                     kid->op_sibling = sibl;
5767                     *tokid = kid;
5768                 }
5769                 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5770                     bad_type(numargs, "hash", PL_op_desc[type], kid);
5771                 mod(kid, type);
5772                 break;
5773             case OA_CVREF:
5774                 {
5775                     OP *newop = newUNOP(OP_NULL, 0, kid);
5776                     kid->op_sibling = 0;
5777                     linklist(kid);
5778                     newop->op_next = newop;
5779                     kid = newop;
5780                     kid->op_sibling = sibl;
5781                     *tokid = kid;
5782                 }
5783                 break;
5784             case OA_FILEREF:
5785                 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5786                     if (kid->op_type == OP_CONST &&
5787                         (kid->op_private & OPpCONST_BARE))
5788                     {
5789                         OP *newop = newGVOP(OP_GV, 0,
5790                             gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
5791                                         SVt_PVIO) );
5792                         op_free(kid);
5793                         kid = newop;
5794                     }
5795                     else if (kid->op_type == OP_READLINE) {
5796                         /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5797                         bad_type(numargs, "HANDLE", PL_op_desc[o->op_type], kid);
5798                     }
5799                     else {
5800                         I32 flags = OPf_SPECIAL;
5801                         I32 priv = 0;
5802                         PADOFFSET targ = 0;
5803
5804                         /* is this op a FH constructor? */
5805                         if (is_handle_constructor(o,numargs)) {
5806                             char *name = Nullch;
5807                             STRLEN len;
5808
5809                             flags = 0;
5810                             /* Set a flag to tell rv2gv to vivify
5811                              * need to "prove" flag does not mean something
5812                              * else already - NI-S 1999/05/07
5813                              */
5814                             priv = OPpDEREF;
5815                             if (kid->op_type == OP_PADSV) {
5816                                 SV **namep = av_fetch(PL_comppad_name,
5817                                                       kid->op_targ, 4);
5818                                 if (namep && *namep)
5819                                     name = SvPV(*namep, len);
5820                             }
5821                             else if (kid->op_type == OP_RV2SV
5822                                      && kUNOP->op_first->op_type == OP_GV)
5823                             {
5824                                 GV *gv = cGVOPx_gv(kUNOP->op_first);
5825                                 name = GvNAME(gv);
5826                                 len = GvNAMELEN(gv);
5827                             }
5828                             else if (kid->op_type == OP_AELEM
5829                                      || kid->op_type == OP_HELEM)
5830                             {
5831                                 name = "__ANONIO__";
5832                                 len = 10;
5833                                 mod(kid,type);
5834                             }
5835                             if (name) {
5836                                 SV *namesv;
5837                                 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5838                                 namesv = PL_curpad[targ];
5839                                 (void)SvUPGRADE(namesv, SVt_PV);
5840                                 if (*name != '$')
5841                                     sv_setpvn(namesv, "$", 1);
5842                                 sv_catpvn(namesv, name, len);
5843                             }
5844                         }
5845                         kid->op_sibling = 0;
5846                         kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5847                         kid->op_targ = targ;
5848                         kid->op_private |= priv;
5849                     }
5850                     kid->op_sibling = sibl;
5851                     *tokid = kid;
5852                 }
5853                 scalar(kid);
5854                 break;
5855             case OA_SCALARREF:
5856                 mod(scalar(kid), type);
5857                 break;
5858             }
5859             oa >>= 4;
5860             tokid = &kid->op_sibling;
5861             kid = kid->op_sibling;
5862         }
5863         o->op_private |= numargs;
5864         if (kid)
5865             return too_many_arguments(o,PL_op_desc[o->op_type]);
5866         listkids(o);
5867     }
5868     else if (PL_opargs[type] & OA_DEFGV) {
5869         op_free(o);
5870         return newUNOP(type, 0, newDEFSVOP());
5871     }
5872
5873     if (oa) {
5874         while (oa & OA_OPTIONAL)
5875             oa >>= 4;
5876         if (oa && oa != OA_LIST)
5877             return too_few_arguments(o,PL_op_desc[o->op_type]);
5878     }
5879     return o;
5880 }
5881
5882 OP *
5883 Perl_ck_glob(pTHX_ OP *o)
5884 {
5885     GV *gv;
5886
5887     o = ck_fun(o);
5888     if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5889         append_elem(OP_GLOB, o, newDEFSVOP());
5890
5891     if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV)) && GvIMPORTED_CV(gv)))
5892         gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5893
5894 #if !defined(PERL_EXTERNAL_GLOB)
5895     /* XXX this can be tightened up and made more failsafe. */
5896     if (!gv) {
5897         GV *glob_gv;
5898         ENTER;
5899         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, newSVpvn("File::Glob", 10), Nullsv,
5900                          Nullsv, Nullsv);
5901         gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5902         glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
5903         GvCV(gv) = GvCV(glob_gv);
5904         SvREFCNT_inc((SV*)GvCV(gv));
5905         GvIMPORTED_CV_on(gv);
5906         LEAVE;
5907     }
5908 #endif /* PERL_EXTERNAL_GLOB */
5909
5910     if (gv && GvIMPORTED_CV(gv)) {
5911         append_elem(OP_GLOB, o,
5912                     newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5913         o->op_type = OP_LIST;
5914         o->op_ppaddr = PL_ppaddr[OP_LIST];
5915         cLISTOPo->op_first->op_type = OP_PUSHMARK;
5916         cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5917         o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5918                     append_elem(OP_LIST, o,
5919                                 scalar(newUNOP(OP_RV2CV, 0,
5920                                                newGVOP(OP_GV, 0, gv)))));
5921         o = newUNOP(OP_NULL, 0, ck_subr(o));
5922         o->op_targ = OP_GLOB;           /* hint at what it used to be */
5923         return o;
5924     }
5925     gv = newGVgen("main");
5926     gv_IOadd(gv);
5927     append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5928     scalarkids(o);
5929     return o;
5930 }
5931
5932 OP *
5933 Perl_ck_grep(pTHX_ OP *o)
5934 {
5935     LOGOP *gwop;
5936     OP *kid;
5937     OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5938
5939     o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5940     NewOp(1101, gwop, 1, LOGOP);
5941
5942     if (o->op_flags & OPf_STACKED) {
5943         OP* k;
5944         o = ck_sort(o);
5945         kid = cLISTOPo->op_first->op_sibling;
5946         for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
5947             kid = k;
5948         }
5949         kid->op_next = (OP*)gwop;
5950         o->op_flags &= ~OPf_STACKED;
5951     }
5952     kid = cLISTOPo->op_first->op_sibling;
5953     if (type == OP_MAPWHILE)
5954         list(kid);
5955     else
5956         scalar(kid);
5957     o = ck_fun(o);
5958     if (PL_error_count)
5959         return o;
5960     kid = cLISTOPo->op_first->op_sibling;
5961     if (kid->op_type != OP_NULL)
5962         Perl_croak(aTHX_ "panic: ck_grep");
5963     kid = kUNOP->op_first;
5964
5965     gwop->op_type = type;
5966     gwop->op_ppaddr = PL_ppaddr[type];
5967     gwop->op_first = listkids(o);
5968     gwop->op_flags |= OPf_KIDS;
5969     gwop->op_private = 1;
5970     gwop->op_other = LINKLIST(kid);
5971     gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5972     kid->op_next = (OP*)gwop;
5973
5974     kid = cLISTOPo->op_first->op_sibling;
5975     if (!kid || !kid->op_sibling)
5976         return too_few_arguments(o,PL_op_desc[o->op_type]);
5977     for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5978         mod(kid, OP_GREPSTART);
5979
5980     return (OP*)gwop;
5981 }
5982
5983 OP *
5984 Perl_ck_index(pTHX_ OP *o)
5985 {
5986     if (o->op_flags & OPf_KIDS) {
5987         OP *kid = cLISTOPo->op_first->op_sibling;       /* get past pushmark */
5988         if (kid)
5989             kid = kid->op_sibling;                      /* get past "big" */
5990         if (kid && kid->op_type == OP_CONST)
5991             fbm_compile(((SVOP*)kid)->op_sv, 0);
5992     }
5993     return ck_fun(o);
5994 }
5995
5996 OP *
5997 Perl_ck_lengthconst(pTHX_ OP *o)
5998 {
5999     /* XXX length optimization goes here */
6000     return ck_fun(o);
6001 }
6002
6003 OP *
6004 Perl_ck_lfun(pTHX_ OP *o)
6005 {
6006     OPCODE type = o->op_type;
6007     return modkids(ck_fun(o), type);
6008 }
6009
6010 OP *
6011 Perl_ck_defined(pTHX_ OP *o)            /* 19990527 MJD */
6012 {
6013     if ((o->op_flags & OPf_KIDS) && ckWARN(WARN_DEPRECATED)) {
6014         switch (cUNOPo->op_first->op_type) {
6015         case OP_RV2AV:
6016             /* This is needed for
6017                if (defined %stash::)
6018                to work.   Do not break Tk.
6019                */
6020             break;                      /* Globals via GV can be undef */
6021         case OP_PADAV:
6022         case OP_AASSIGN:                /* Is this a good idea? */
6023             Perl_warner(aTHX_ WARN_DEPRECATED,
6024                         "defined(@array) is deprecated");
6025             Perl_warner(aTHX_ WARN_DEPRECATED,
6026                         "\t(Maybe you should just omit the defined()?)\n");
6027         break;
6028         case OP_RV2HV:
6029             /* This is needed for
6030                if (defined %stash::)
6031                to work.   Do not break Tk.
6032                */
6033             break;                      /* Globals via GV can be undef */
6034         case OP_PADHV:
6035             Perl_warner(aTHX_ WARN_DEPRECATED,
6036                         "defined(%%hash) is deprecated");
6037             Perl_warner(aTHX_ WARN_DEPRECATED,
6038                         "\t(Maybe you should just omit the defined()?)\n");
6039             break;
6040         default:
6041             /* no warning */
6042             break;
6043         }
6044     }
6045     return ck_rfun(o);
6046 }
6047
6048 OP *
6049 Perl_ck_rfun(pTHX_ OP *o)
6050 {
6051     OPCODE type = o->op_type;
6052     return refkids(ck_fun(o), type);
6053 }
6054
6055 OP *
6056 Perl_ck_listiob(pTHX_ OP *o)
6057 {
6058     register OP *kid;
6059
6060     kid = cLISTOPo->op_first;
6061     if (!kid) {
6062         o = force_list(o);
6063         kid = cLISTOPo->op_first;
6064     }
6065     if (kid->op_type == OP_PUSHMARK)
6066         kid = kid->op_sibling;
6067     if (kid && o->op_flags & OPf_STACKED)
6068         kid = kid->op_sibling;
6069     else if (kid && !kid->op_sibling) {         /* print HANDLE; */
6070         if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
6071             o->op_flags |= OPf_STACKED; /* make it a filehandle */
6072             kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
6073             cLISTOPo->op_first->op_sibling = kid;
6074             cLISTOPo->op_last = kid;
6075             kid = kid->op_sibling;
6076         }
6077     }
6078
6079     if (!kid)
6080         append_elem(o->op_type, o, newDEFSVOP());
6081
6082     return listkids(o);
6083 }
6084
6085 OP *
6086 Perl_ck_sassign(pTHX_ OP *o)
6087 {
6088     OP *kid = cLISTOPo->op_first;
6089     /* has a disposable target? */
6090     if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6091         && !(kid->op_flags & OPf_STACKED)
6092         /* Cannot steal the second time! */
6093         && !(kid->op_private & OPpTARGET_MY))
6094     {
6095         OP *kkid = kid->op_sibling;
6096
6097         /* Can just relocate the target. */
6098         if (kkid && kkid->op_type == OP_PADSV
6099             && !(kkid->op_private & OPpLVAL_INTRO))
6100         {
6101             kid->op_targ = kkid->op_targ;
6102             kkid->op_targ = 0;
6103             /* Now we do not need PADSV and SASSIGN. */
6104             kid->op_sibling = o->op_sibling;    /* NULL */
6105             cLISTOPo->op_first = NULL;
6106             op_free(o);
6107             op_free(kkid);
6108             kid->op_private |= OPpTARGET_MY;    /* Used for context settings */
6109             return kid;
6110         }
6111     }
6112     return o;
6113 }
6114
6115 OP *
6116 Perl_ck_match(pTHX_ OP *o)
6117 {
6118     o->op_private |= OPpRUNTIME;
6119     return o;
6120 }
6121
6122 OP *
6123 Perl_ck_method(pTHX_ OP *o)
6124 {
6125     OP *kid = cUNOPo->op_first;
6126     if (kid->op_type == OP_CONST) {
6127         SV* sv = kSVOP->op_sv;
6128         if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
6129             OP *cmop;
6130             if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6131                 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
6132             }
6133             else {
6134                 kSVOP->op_sv = Nullsv;
6135             }
6136             cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6137             op_free(o);
6138             return cmop;
6139         }
6140     }
6141     return o;
6142 }
6143
6144 OP *
6145 Perl_ck_null(pTHX_ OP *o)
6146 {
6147     return o;
6148 }
6149
6150 OP *
6151 Perl_ck_open(pTHX_ OP *o)
6152 {
6153     HV *table = GvHV(PL_hintgv);
6154     if (table) {
6155         SV **svp;
6156         I32 mode;
6157         svp = hv_fetch(table, "open_IN", 7, FALSE);
6158         if (svp && *svp) {
6159             mode = mode_from_discipline(*svp);
6160             if (mode & O_BINARY)
6161                 o->op_private |= OPpOPEN_IN_RAW;
6162             else if (mode & O_TEXT)
6163                 o->op_private |= OPpOPEN_IN_CRLF;
6164         }
6165
6166         svp = hv_fetch(table, "open_OUT", 8, FALSE);
6167         if (svp && *svp) {
6168             mode = mode_from_discipline(*svp);
6169             if (mode & O_BINARY)
6170                 o->op_private |= OPpOPEN_OUT_RAW;
6171             else if (mode & O_TEXT)
6172                 o->op_private |= OPpOPEN_OUT_CRLF;
6173         }
6174     }
6175     if (o->op_type == OP_BACKTICK)
6176         return o;
6177     return ck_fun(o);
6178 }
6179
6180 OP *
6181 Perl_ck_repeat(pTHX_ OP *o)
6182 {
6183     if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6184         o->op_private |= OPpREPEAT_DOLIST;
6185         cBINOPo->op_first = force_list(cBINOPo->op_first);
6186     }
6187     else
6188         scalar(o);
6189     return o;
6190 }
6191
6192 OP *
6193 Perl_ck_require(pTHX_ OP *o)
6194 {
6195     GV* gv;
6196
6197     if (o->op_flags & OPf_KIDS) {       /* Shall we supply missing .pm? */
6198         SVOP *kid = (SVOP*)cUNOPo->op_first;
6199
6200         if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6201             char *s;
6202             for (s = SvPVX(kid->op_sv); *s; s++) {
6203                 if (*s == ':' && s[1] == ':') {
6204                     *s = '/';
6205                     Move(s+2, s+1, strlen(s+2)+1, char);
6206                     --SvCUR(kid->op_sv);
6207                 }
6208             }
6209             if (SvREADONLY(kid->op_sv)) {
6210                 SvREADONLY_off(kid->op_sv);
6211                 sv_catpvn(kid->op_sv, ".pm", 3);
6212                 SvREADONLY_on(kid->op_sv);
6213             }
6214             else
6215                 sv_catpvn(kid->op_sv, ".pm", 3);
6216         }
6217     }
6218
6219     /* handle override, if any */
6220     gv = gv_fetchpv("require", FALSE, SVt_PVCV);
6221     if (!(gv && GvIMPORTED_CV(gv)))
6222         gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
6223
6224     if (gv && GvIMPORTED_CV(gv)) {
6225         OP *kid = cUNOPo->op_first;
6226         cUNOPo->op_first = 0;
6227         op_free(o);
6228         return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
6229                                append_elem(OP_LIST, kid,
6230                                            scalar(newUNOP(OP_RV2CV, 0,
6231                                                           newGVOP(OP_GV, 0,
6232                                                                   gv))))));
6233     }
6234
6235     return ck_fun(o);
6236 }
6237
6238 OP *
6239 Perl_ck_return(pTHX_ OP *o)
6240 {
6241     OP *kid;
6242     if (CvLVALUE(PL_compcv)) {
6243         for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
6244             mod(kid, OP_LEAVESUBLV);
6245     }
6246     return o;
6247 }
6248
6249 #if 0
6250 OP *
6251 Perl_ck_retarget(pTHX_ OP *o)
6252 {
6253     Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
6254     /* STUB */
6255     return o;
6256 }
6257 #endif
6258
6259 OP *
6260 Perl_ck_select(pTHX_ OP *o)
6261 {
6262     OP* kid;
6263     if (o->op_flags & OPf_KIDS) {
6264         kid = cLISTOPo->op_first->op_sibling;   /* get past pushmark */
6265         if (kid && kid->op_sibling) {
6266             o->op_type = OP_SSELECT;
6267             o->op_ppaddr = PL_ppaddr[OP_SSELECT];
6268             o = ck_fun(o);
6269             return fold_constants(o);
6270         }
6271     }
6272     o = ck_fun(o);
6273     kid = cLISTOPo->op_first->op_sibling;    /* get past pushmark */
6274     if (kid && kid->op_type == OP_RV2GV)
6275         kid->op_private &= ~HINT_STRICT_REFS;
6276     return o;
6277 }
6278
6279 OP *
6280 Perl_ck_shift(pTHX_ OP *o)
6281 {
6282     I32 type = o->op_type;
6283
6284     if (!(o->op_flags & OPf_KIDS)) {
6285         OP *argop;
6286
6287         op_free(o);
6288 #ifdef USE_THREADS
6289         if (!CvUNIQUE(PL_compcv)) {
6290             argop = newOP(OP_PADAV, OPf_REF);
6291             argop->op_targ = 0;         /* PL_curpad[0] is @_ */
6292         }
6293         else {
6294             argop = newUNOP(OP_RV2AV, 0,
6295                 scalar(newGVOP(OP_GV, 0,
6296                     gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6297         }
6298 #else
6299         argop = newUNOP(OP_RV2AV, 0,
6300             scalar(newGVOP(OP_GV, 0, !CvUNIQUE(PL_compcv) ?
6301                            PL_defgv : gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6302 #endif /* USE_THREADS */
6303         return newUNOP(type, 0, scalar(argop));
6304     }
6305     return scalar(modkids(ck_fun(o), type));
6306 }
6307
6308 OP *
6309 Perl_ck_sort(pTHX_ OP *o)
6310 {
6311     OP *firstkid;
6312
6313     if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6314         simplify_sort(o);
6315     firstkid = cLISTOPo->op_first->op_sibling;          /* get past pushmark */
6316     if (o->op_flags & OPf_STACKED) {                    /* may have been cleared */
6317         OP *k = NULL;
6318         OP *kid = cUNOPx(firstkid)->op_first;           /* get past null */
6319
6320         if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
6321             linklist(kid);
6322             if (kid->op_type == OP_SCOPE) {
6323                 k = kid->op_next;
6324                 kid->op_next = 0;
6325             }
6326             else if (kid->op_type == OP_LEAVE) {
6327                 if (o->op_type == OP_SORT) {
6328                     op_null(kid);                       /* wipe out leave */
6329                     kid->op_next = kid;
6330
6331                     for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6332                         if (k->op_next == kid)
6333                             k->op_next = 0;
6334                         /* don't descend into loops */
6335                         else if (k->op_type == OP_ENTERLOOP
6336                                  || k->op_type == OP_ENTERITER)
6337                         {
6338                             k = cLOOPx(k)->op_lastop;
6339                         }
6340                     }
6341                 }
6342                 else
6343                     kid->op_next = 0;           /* just disconnect the leave */
6344                 k = kLISTOP->op_first;
6345             }
6346             peep(k);
6347
6348             kid = firstkid;
6349             if (o->op_type == OP_SORT) {
6350                 /* provide scalar context for comparison function/block */
6351                 kid = scalar(kid);
6352                 kid->op_next = kid;
6353             }
6354             else
6355                 kid->op_next = k;
6356             o->op_flags |= OPf_SPECIAL;
6357         }
6358         else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6359             op_null(firstkid);
6360
6361         firstkid = firstkid->op_sibling;
6362     }
6363
6364     /* provide list context for arguments */
6365     if (o->op_type == OP_SORT)
6366         list(firstkid);
6367
6368     return o;
6369 }
6370
6371 STATIC void
6372 S_simplify_sort(pTHX_ OP *o)
6373 {
6374     register OP *kid = cLISTOPo->op_first->op_sibling;  /* get past pushmark */
6375     OP *k;
6376     int reversed;
6377     GV *gv;
6378     if (!(o->op_flags & OPf_STACKED))
6379         return;
6380     GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
6381     GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
6382     kid = kUNOP->op_first;                              /* get past null */
6383     if (kid->op_type != OP_SCOPE)
6384         return;
6385     kid = kLISTOP->op_last;                             /* get past scope */
6386     switch(kid->op_type) {
6387         case OP_NCMP:
6388         case OP_I_NCMP:
6389         case OP_SCMP:
6390             break;
6391         default:
6392             return;
6393     }
6394     k = kid;                                            /* remember this node*/
6395     if (kBINOP->op_first->op_type != OP_RV2SV)
6396         return;
6397     kid = kBINOP->op_first;                             /* get past cmp */
6398     if (kUNOP->op_first->op_type != OP_GV)
6399         return;
6400     kid = kUNOP->op_first;                              /* get past rv2sv */
6401     gv = kGVOP_gv;
6402     if (GvSTASH(gv) != PL_curstash)
6403         return;
6404     if (strEQ(GvNAME(gv), "a"))
6405         reversed = 0;
6406     else if (strEQ(GvNAME(gv), "b"))
6407         reversed = 1;
6408     else
6409         return;
6410     kid = k;                                            /* back to cmp */
6411     if (kBINOP->op_last->op_type != OP_RV2SV)
6412         return;
6413     kid = kBINOP->op_last;                              /* down to 2nd arg */
6414     if (kUNOP->op_first->op_type != OP_GV)
6415         return;
6416     kid = kUNOP->op_first;                              /* get past rv2sv */
6417     gv = kGVOP_gv;
6418     if (GvSTASH(gv) != PL_curstash
6419         || ( reversed
6420             ? strNE(GvNAME(gv), "a")
6421             : strNE(GvNAME(gv), "b")))
6422         return;
6423     o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6424     if (reversed)
6425         o->op_private |= OPpSORT_REVERSE;
6426     if (k->op_type == OP_NCMP)
6427         o->op_private |= OPpSORT_NUMERIC;
6428     if (k->op_type == OP_I_NCMP)
6429         o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6430     kid = cLISTOPo->op_first->op_sibling;
6431     cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6432     op_free(kid);                                     /* then delete it */
6433 }
6434
6435 OP *
6436 Perl_ck_split(pTHX_ OP *o)
6437 {
6438     register OP *kid;
6439
6440     if (o->op_flags & OPf_STACKED)
6441         return no_fh_allowed(o);
6442
6443     kid = cLISTOPo->op_first;
6444     if (kid->op_type != OP_NULL)
6445         Perl_croak(aTHX_ "panic: ck_split");
6446     kid = kid->op_sibling;
6447     op_free(cLISTOPo->op_first);
6448     cLISTOPo->op_first = kid;
6449     if (!kid) {
6450         cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
6451         cLISTOPo->op_last = kid; /* There was only one element previously */
6452     }
6453
6454     if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6455         OP *sibl = kid->op_sibling;
6456         kid->op_sibling = 0;
6457         kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
6458         if (cLISTOPo->op_first == cLISTOPo->op_last)
6459             cLISTOPo->op_last = kid;
6460         cLISTOPo->op_first = kid;
6461         kid->op_sibling = sibl;
6462     }
6463
6464     kid->op_type = OP_PUSHRE;
6465     kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6466     scalar(kid);
6467
6468     if (!kid->op_sibling)
6469         append_elem(OP_SPLIT, o, newDEFSVOP());
6470
6471     kid = kid->op_sibling;
6472     scalar(kid);
6473
6474     if (!kid->op_sibling)
6475         append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6476
6477     kid = kid->op_sibling;
6478     scalar(kid);
6479
6480     if (kid->op_sibling)
6481         return too_many_arguments(o,PL_op_desc[o->op_type]);
6482
6483     return o;
6484 }
6485
6486 OP *
6487 Perl_ck_join(pTHX_ OP *o)
6488 {
6489     if (ckWARN(WARN_SYNTAX)) {
6490         OP *kid = cLISTOPo->op_first->op_sibling;
6491         if (kid && kid->op_type == OP_MATCH) {
6492             char *pmstr = "STRING";
6493             if (PM_GETRE(kPMOP))
6494                 pmstr = PM_GETRE(kPMOP)->precomp;
6495             Perl_warner(aTHX_ WARN_SYNTAX,
6496                         "/%s/ should probably be written as \"%s\"",
6497                         pmstr, pmstr);
6498         }
6499     }
6500     return ck_fun(o);
6501 }
6502
6503 OP *
6504 Perl_ck_subr(pTHX_ OP *o)
6505 {
6506     OP *prev = ((cUNOPo->op_first->op_sibling)
6507              ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6508     OP *o2 = prev->op_sibling;
6509     OP *cvop;
6510     char *proto = 0;
6511     CV *cv = 0;
6512     GV *namegv = 0;
6513     int optional = 0;
6514     I32 arg = 0;
6515     STRLEN n_a;
6516
6517     o->op_private |= OPpENTERSUB_HASTARG;
6518     for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6519     if (cvop->op_type == OP_RV2CV) {
6520         SVOP* tmpop;
6521         o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6522         op_null(cvop);          /* disable rv2cv */
6523         tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6524         if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6525             GV *gv = cGVOPx_gv(tmpop);
6526             cv = GvCVu(gv);
6527             if (!cv)
6528                 tmpop->op_private |= OPpEARLY_CV;
6529             else if (SvPOK(cv)) {
6530                 namegv = CvANON(cv) ? gv : CvGV(cv);
6531                 proto = SvPV((SV*)cv, n_a);
6532             }
6533         }
6534     }
6535     else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6536         if (o2->op_type == OP_CONST)
6537             o2->op_private &= ~OPpCONST_STRICT;
6538         else if (o2->op_type == OP_LIST) {
6539             OP *o = ((UNOP*)o2)->op_first->op_sibling;
6540             if (o && o->op_type == OP_CONST)
6541                 o->op_private &= ~OPpCONST_STRICT;
6542         }
6543     }
6544     o->op_private |= (PL_hints & HINT_STRICT_REFS);
6545     if (PERLDB_SUB && PL_curstash != PL_debstash)
6546         o->op_private |= OPpENTERSUB_DB;
6547     while (o2 != cvop) {
6548         if (proto) {
6549             switch (*proto) {
6550             case '\0':
6551                 return too_many_arguments(o, gv_ename(namegv));
6552             case ';':
6553                 optional = 1;
6554                 proto++;
6555                 continue;
6556             case '$':
6557                 proto++;
6558                 arg++;
6559                 scalar(o2);
6560                 break;
6561             case '%':
6562             case '@':
6563                 list(o2);
6564                 arg++;
6565                 break;
6566             case '&':
6567                 proto++;
6568                 arg++;
6569                 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6570                     bad_type(arg,
6571                         arg == 1 ? "block or sub {}" : "sub {}",
6572                         gv_ename(namegv), o2);
6573                 break;
6574             case '*':
6575                 /* '*' allows any scalar type, including bareword */
6576                 proto++;
6577                 arg++;
6578                 if (o2->op_type == OP_RV2GV)
6579                     goto wrapref;       /* autoconvert GLOB -> GLOBref */
6580                 else if (o2->op_type == OP_CONST)
6581                     o2->op_private &= ~OPpCONST_STRICT;
6582                 else if (o2->op_type == OP_ENTERSUB) {
6583                     /* accidental subroutine, revert to bareword */
6584                     OP *gvop = ((UNOP*)o2)->op_first;
6585                     if (gvop && gvop->op_type == OP_NULL) {
6586                         gvop = ((UNOP*)gvop)->op_first;
6587                         if (gvop) {
6588                             for (; gvop->op_sibling; gvop = gvop->op_sibling)
6589                                 ;
6590                             if (gvop &&
6591                                 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6592                                 (gvop = ((UNOP*)gvop)->op_first) &&
6593                                 gvop->op_type == OP_GV)
6594                             {
6595                                 GV *gv = cGVOPx_gv(gvop);
6596                                 OP *sibling = o2->op_sibling;
6597                                 SV *n = newSVpvn("",0);
6598                                 op_free(o2);
6599                                 gv_fullname3(n, gv, "");
6600                                 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
6601                                     sv_chop(n, SvPVX(n)+6);
6602                                 o2 = newSVOP(OP_CONST, 0, n);
6603                                 prev->op_sibling = o2;
6604                                 o2->op_sibling = sibling;
6605                             }
6606                         }
6607                     }
6608                 }
6609                 scalar(o2);
6610                 break;
6611             case '\\':
6612                 proto++;
6613                 arg++;
6614                 switch (*proto++) {
6615                 case '*':
6616                     if (o2->op_type != OP_RV2GV)
6617                         bad_type(arg, "symbol", gv_ename(namegv), o2);
6618                     goto wrapref;
6619                 case '&':
6620                     if (o2->op_type != OP_ENTERSUB)
6621                         bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6622                     goto wrapref;
6623                 case '$':
6624                     if (o2->op_type != OP_RV2SV
6625                         && o2->op_type != OP_PADSV
6626                         && o2->op_type != OP_HELEM
6627                         && o2->op_type != OP_AELEM
6628                         && o2->op_type != OP_THREADSV)
6629                     {
6630                         bad_type(arg, "scalar", gv_ename(namegv), o2);
6631                     }
6632                     goto wrapref;
6633                 case '@':
6634                     if (o2->op_type != OP_RV2AV && o2->op_type != OP_PADAV)
6635                         bad_type(arg, "array", gv_ename(namegv), o2);
6636                     goto wrapref;
6637                 case '%':
6638                     if (o2->op_type != OP_RV2HV && o2->op_type != OP_PADHV)
6639                         bad_type(arg, "hash", gv_ename(namegv), o2);
6640                   wrapref:
6641                     {
6642                         OP* kid = o2;
6643                         OP* sib = kid->op_sibling;
6644                         kid->op_sibling = 0;
6645                         o2 = newUNOP(OP_REFGEN, 0, kid);
6646                         o2->op_sibling = sib;
6647                         prev->op_sibling = o2;
6648                     }
6649                     break;
6650                 default: goto oops;
6651                 }
6652                 break;
6653             case ' ':
6654                 proto++;
6655                 continue;
6656             default:
6657               oops:
6658                 Perl_croak(aTHX_ "Malformed prototype for %s: %s",
6659                         gv_ename(namegv), SvPV((SV*)cv, n_a));
6660             }
6661         }
6662         else
6663             list(o2);
6664         mod(o2, OP_ENTERSUB);
6665         prev = o2;
6666         o2 = o2->op_sibling;
6667     }
6668     if (proto && !optional &&
6669           (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6670         return too_few_arguments(o, gv_ename(namegv));
6671     return o;
6672 }
6673
6674 OP *
6675 Perl_ck_svconst(pTHX_ OP *o)
6676 {
6677     SvREADONLY_on(cSVOPo->op_sv);
6678     return o;
6679 }
6680
6681 OP *
6682 Perl_ck_trunc(pTHX_ OP *o)
6683 {
6684     if (o->op_flags & OPf_KIDS) {
6685         SVOP *kid = (SVOP*)cUNOPo->op_first;
6686
6687         if (kid->op_type == OP_NULL)
6688             kid = (SVOP*)kid->op_sibling;
6689         if (kid && kid->op_type == OP_CONST &&
6690             (kid->op_private & OPpCONST_BARE))
6691         {
6692             o->op_flags |= OPf_SPECIAL;
6693             kid->op_private &= ~OPpCONST_STRICT;
6694         }
6695     }
6696     return ck_fun(o);
6697 }
6698
6699 OP *
6700 Perl_ck_substr(pTHX_ OP *o)
6701 {
6702     o = ck_fun(o);
6703     if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6704         OP *kid = cLISTOPo->op_first;
6705
6706         if (kid->op_type == OP_NULL)
6707             kid = kid->op_sibling;
6708         if (kid)
6709             kid->op_flags |= OPf_MOD;
6710
6711     }
6712     return o;
6713 }
6714
6715 /* A peephole optimizer.  We visit the ops in the order they're to execute. */
6716
6717 void
6718 Perl_peep(pTHX_ register OP *o)
6719 {
6720     register OP* oldop = 0;
6721     STRLEN n_a;
6722
6723     if (!o || o->op_seq)
6724         return;
6725     ENTER;
6726     SAVEOP();
6727     SAVEVPTR(PL_curcop);
6728     for (; o; o = o->op_next) {
6729         if (o->op_seq)
6730             break;
6731         if (!PL_op_seqmax)
6732             PL_op_seqmax++;
6733         PL_op = o;
6734         switch (o->op_type) {
6735         case OP_SETSTATE:
6736         case OP_NEXTSTATE:
6737         case OP_DBSTATE:
6738             PL_curcop = ((COP*)o);              /* for warnings */
6739             o->op_seq = PL_op_seqmax++;
6740             break;
6741
6742         case OP_CONST:
6743             if (cSVOPo->op_private & OPpCONST_STRICT)
6744                 no_bareword_allowed(o);
6745 #ifdef USE_ITHREADS
6746             /* Relocate sv to the pad for thread safety.
6747              * Despite being a "constant", the SV is written to,
6748              * for reference counts, sv_upgrade() etc. */
6749             if (cSVOP->op_sv) {
6750                 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6751                 if (SvPADTMP(cSVOPo->op_sv)) {
6752                     /* If op_sv is already a PADTMP then it is being used by
6753                      * some pad, so make a copy. */
6754                     sv_setsv(PL_curpad[ix],cSVOPo->op_sv);
6755                     SvREADONLY_on(PL_curpad[ix]);
6756                     SvREFCNT_dec(cSVOPo->op_sv);
6757                 }
6758                 else {
6759                     SvREFCNT_dec(PL_curpad[ix]);
6760                     SvPADTMP_on(cSVOPo->op_sv);
6761                     PL_curpad[ix] = cSVOPo->op_sv;
6762                     /* XXX I don't know how this isn't readonly already. */
6763                     SvREADONLY_on(PL_curpad[ix]);
6764                 }
6765                 cSVOPo->op_sv = Nullsv;
6766                 o->op_targ = ix;
6767             }
6768 #endif
6769             o->op_seq = PL_op_seqmax++;
6770             break;
6771
6772         case OP_CONCAT:
6773             if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6774                 if (o->op_next->op_private & OPpTARGET_MY) {
6775                     if (o->op_flags & OPf_STACKED) /* chained concats */
6776                         goto ignore_optimization;
6777                     else {
6778                         /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6779                         o->op_targ = o->op_next->op_targ;
6780                         o->op_next->op_targ = 0;
6781                         o->op_private |= OPpTARGET_MY;
6782                     }
6783                 }
6784                 op_null(o->op_next);
6785             }
6786           ignore_optimization:
6787             o->op_seq = PL_op_seqmax++;
6788             break;
6789         case OP_STUB:
6790             if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6791                 o->op_seq = PL_op_seqmax++;
6792                 break; /* Scalar stub must produce undef.  List stub is noop */
6793             }
6794             goto nothin;
6795         case OP_NULL:
6796             if (o->op_targ == OP_NEXTSTATE
6797                 || o->op_targ == OP_DBSTATE
6798                 || o->op_targ == OP_SETSTATE)
6799             {
6800                 PL_curcop = ((COP*)o);
6801             }
6802             /* XXX: We avoid setting op_seq here to prevent later calls
6803                to peep() from mistakenly concluding that optimisation
6804                has already occurred. This doesn't fix the real problem,
6805                though (See 20010220.007). AMS 20010719 */
6806             if (oldop && o->op_next) {
6807                 oldop->op_next = o->op_next;
6808                 continue;
6809             }
6810             break;
6811         case OP_SCALAR:
6812         case OP_LINESEQ:
6813         case OP_SCOPE:
6814           nothin:
6815             if (oldop && o->op_next) {
6816                 oldop->op_next = o->op_next;
6817                 continue;
6818             }
6819             o->op_seq = PL_op_seqmax++;
6820             break;
6821
6822         case OP_GV:
6823             if (o->op_next->op_type == OP_RV2SV) {
6824                 if (!(o->op_next->op_private & OPpDEREF)) {
6825                     op_null(o->op_next);
6826                     o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6827                                                                | OPpOUR_INTRO);
6828                     o->op_next = o->op_next->op_next;
6829                     o->op_type = OP_GVSV;
6830                     o->op_ppaddr = PL_ppaddr[OP_GVSV];
6831                 }
6832             }
6833             else if (o->op_next->op_type == OP_RV2AV) {
6834                 OP* pop = o->op_next->op_next;
6835                 IV i;
6836                 if (pop->op_type == OP_CONST &&
6837                     (PL_op = pop->op_next) &&
6838                     pop->op_next->op_type == OP_AELEM &&
6839                     !(pop->op_next->op_private &
6840                       (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6841                     (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
6842                                 <= 255 &&
6843                     i >= 0)
6844                 {
6845                     GV *gv;
6846                     op_null(o->op_next);
6847                     op_null(pop->op_next);
6848                     op_null(pop);
6849                     o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6850                     o->op_next = pop->op_next->op_next;
6851                     o->op_type = OP_AELEMFAST;
6852                     o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6853                     o->op_private = (U8)i;
6854                     gv = cGVOPo_gv;
6855                     GvAVn(gv);
6856                 }
6857             }
6858             else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6859                 GV *gv = cGVOPo_gv;
6860                 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
6861                     /* XXX could check prototype here instead of just carping */
6862                     SV *sv = sv_newmortal();
6863                     gv_efullname3(sv, gv, Nullch);
6864                     Perl_warner(aTHX_ WARN_PROTOTYPE,
6865                                 "%s() called too early to check prototype",
6866                                 SvPV_nolen(sv));
6867                 }
6868             }
6869
6870             o->op_seq = PL_op_seqmax++;
6871             break;
6872
6873         case OP_MAPWHILE:
6874         case OP_GREPWHILE:
6875         case OP_AND:
6876         case OP_OR:
6877         case OP_ANDASSIGN:
6878         case OP_ORASSIGN:
6879         case OP_COND_EXPR:
6880         case OP_RANGE:
6881             o->op_seq = PL_op_seqmax++;
6882             while (cLOGOP->op_other->op_type == OP_NULL)
6883                 cLOGOP->op_other = cLOGOP->op_other->op_next;
6884             peep(cLOGOP->op_other);
6885             break;
6886
6887         case OP_ENTERLOOP:
6888         case OP_ENTERITER:
6889             o->op_seq = PL_op_seqmax++;
6890             while (cLOOP->op_redoop->op_type == OP_NULL)
6891                 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6892             peep(cLOOP->op_redoop);
6893             while (cLOOP->op_nextop->op_type == OP_NULL)
6894                 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6895             peep(cLOOP->op_nextop);
6896             while (cLOOP->op_lastop->op_type == OP_NULL)
6897                 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6898             peep(cLOOP->op_lastop);
6899             break;
6900
6901         case OP_QR:
6902         case OP_MATCH:
6903         case OP_SUBST:
6904             o->op_seq = PL_op_seqmax++;
6905             while (cPMOP->op_pmreplstart &&
6906                    cPMOP->op_pmreplstart->op_type == OP_NULL)
6907                 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6908             peep(cPMOP->op_pmreplstart);
6909             break;
6910
6911         case OP_EXEC:
6912             o->op_seq = PL_op_seqmax++;
6913             if (ckWARN(WARN_SYNTAX) && o->op_next
6914                 && o->op_next->op_type == OP_NEXTSTATE) {
6915                 if (o->op_next->op_sibling &&
6916                         o->op_next->op_sibling->op_type != OP_EXIT &&
6917                         o->op_next->op_sibling->op_type != OP_WARN &&
6918                         o->op_next->op_sibling->op_type != OP_DIE) {
6919                     line_t oldline = CopLINE(PL_curcop);
6920
6921                     CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6922                     Perl_warner(aTHX_ WARN_EXEC,
6923                                 "Statement unlikely to be reached");
6924                     Perl_warner(aTHX_ WARN_EXEC,
6925                                 "\t(Maybe you meant system() when you said exec()?)\n");
6926                     CopLINE_set(PL_curcop, oldline);
6927                 }
6928             }
6929             break;
6930
6931         case OP_HELEM: {
6932             UNOP *rop;
6933             SV *lexname;
6934             GV **fields;
6935             SV **svp, **indsvp, *sv;
6936             I32 ind;
6937             char *key = NULL;
6938             STRLEN keylen;
6939
6940             o->op_seq = PL_op_seqmax++;
6941
6942             if (((BINOP*)o)->op_last->op_type != OP_CONST)
6943                 break;
6944
6945             /* Make the CONST have a shared SV */
6946             svp = cSVOPx_svp(((BINOP*)o)->op_last);
6947             if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
6948                 key = SvPV(sv, keylen);
6949                 lexname = newSVpvn_share(key,
6950                                          SvUTF8(sv) ? -(I32)keylen : keylen,
6951                                          0);
6952                 SvREFCNT_dec(sv);
6953                 *svp = lexname;
6954             }
6955
6956             if ((o->op_private & (OPpLVAL_INTRO)))
6957                 break;
6958
6959             rop = (UNOP*)((BINOP*)o)->op_first;
6960             if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6961                 break;
6962             lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
6963             if (!(SvFLAGS(lexname) & SVpad_TYPED))
6964                 break;
6965             fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6966             if (!fields || !GvHV(*fields))
6967                 break;
6968             key = SvPV(*svp, keylen);
6969             indsvp = hv_fetch(GvHV(*fields), key,
6970                               SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE);
6971             if (!indsvp) {
6972                 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" in variable %s of type %s",
6973                       key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
6974             }
6975             ind = SvIV(*indsvp);
6976             if (ind < 1)
6977                 Perl_croak(aTHX_ "Bad index while coercing array into hash");
6978             rop->op_type = OP_RV2AV;
6979             rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
6980             o->op_type = OP_AELEM;
6981             o->op_ppaddr = PL_ppaddr[OP_AELEM];
6982             sv = newSViv(ind);
6983             if (SvREADONLY(*svp))
6984                 SvREADONLY_on(sv);
6985             SvFLAGS(sv) |= (SvFLAGS(*svp)
6986                             & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
6987             SvREFCNT_dec(*svp);
6988             *svp = sv;
6989             break;
6990         }
6991
6992         case OP_HSLICE: {
6993             UNOP *rop;
6994             SV *lexname;
6995             GV **fields;
6996             SV **svp, **indsvp, *sv;
6997             I32 ind;
6998             char *key;
6999             STRLEN keylen;
7000             SVOP *first_key_op, *key_op;
7001
7002             o->op_seq = PL_op_seqmax++;
7003             if ((o->op_private & (OPpLVAL_INTRO))
7004                 /* I bet there's always a pushmark... */
7005                 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
7006                 /* hmmm, no optimization if list contains only one key. */
7007                 break;
7008             rop = (UNOP*)((LISTOP*)o)->op_last;
7009             if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
7010                 break;
7011             lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
7012             if (!(SvFLAGS(lexname) & SVpad_TYPED))
7013                 break;
7014             fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
7015             if (!fields || !GvHV(*fields))
7016                 break;
7017             /* Again guessing that the pushmark can be jumped over.... */
7018             first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
7019                 ->op_first->op_sibling;
7020             /* Check that the key list contains only constants. */
7021             for (key_op = first_key_op; key_op;
7022                  key_op = (SVOP*)key_op->op_sibling)
7023                 if (key_op->op_type != OP_CONST)
7024                     break;
7025             if (key_op)
7026                 break;
7027             rop->op_type = OP_RV2AV;
7028             rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
7029             o->op_type = OP_ASLICE;
7030             o->op_ppaddr = PL_ppaddr[OP_ASLICE];
7031             for (key_op = first_key_op; key_op;
7032                  key_op = (SVOP*)key_op->op_sibling) {
7033                 svp = cSVOPx_svp(key_op);
7034                 key = SvPV(*svp, keylen);
7035                 indsvp = hv_fetch(GvHV(*fields), key,
7036                                   SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE);
7037                 if (!indsvp) {
7038                     Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" "
7039                                "in variable %s of type %s",
7040                           key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
7041                 }
7042                 ind = SvIV(*indsvp);
7043                 if (ind < 1)
7044                     Perl_croak(aTHX_ "Bad index while coercing array into hash");
7045                 sv = newSViv(ind);
7046                 if (SvREADONLY(*svp))
7047                     SvREADONLY_on(sv);
7048                 SvFLAGS(sv) |= (SvFLAGS(*svp)
7049                                 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
7050                 SvREFCNT_dec(*svp);
7051                 *svp = sv;
7052             }
7053             break;
7054         }
7055
7056         default:
7057             o->op_seq = PL_op_seqmax++;
7058             break;
7059         }
7060         oldop = o;
7061     }
7062     LEAVE;
7063 }
7064
7065 #include "XSUB.h"
7066
7067 /* Efficient sub that returns a constant scalar value. */
7068 static void
7069 const_sv_xsub(pTHXo_ CV* cv)
7070 {
7071     dXSARGS;
7072     if (items != 0) {
7073 #if 0
7074         Perl_croak(aTHX_ "usage: %s::%s()",
7075                    HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
7076 #endif
7077     }
7078     EXTEND(sp, 1);
7079     ST(0) = (SV*)XSANY.any_ptr;
7080     XSRETURN(1);
7081 }
7082