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