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