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