op.c

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