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