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