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