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