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