home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / perl560.zip / pp_hot.c < prev    next >
C/C++ Source or Header  |  2000-03-17  |  68KB  |  2,913 lines
  1. /*    pp_hot.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.  * Then he heard Merry change the note, and up went the Horn-cry of Buckland,
  12.  * shaking the air.
  13.  *
  14.  *            Awake!  Awake!  Fear, Fire, Foes!  Awake!
  15.  *                     Fire, Foes!  Awake!
  16.  */
  17.  
  18. #include "EXTERN.h"
  19. #define PERL_IN_PP_HOT_C
  20. #include "perl.h"
  21.  
  22. #ifdef I_UNISTD
  23. #include <unistd.h>
  24. #endif
  25.  
  26. /* Hot code. */
  27.  
  28. #ifdef USE_THREADS
  29. static void unset_cvowner(pTHXo_ void *cvarg);
  30. #endif /* USE_THREADS */
  31.  
  32. PP(pp_const)
  33. {
  34.     djSP;
  35.     XPUSHs(cSVOP_sv);
  36.     RETURN;
  37. }
  38.  
  39. PP(pp_nextstate)
  40. {
  41.     PL_curcop = (COP*)PL_op;
  42.     TAINT_NOT;        /* Each statement is presumed innocent */
  43.     PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
  44.     FREETMPS;
  45.     return NORMAL;
  46. }
  47.  
  48. PP(pp_gvsv)
  49. {
  50.     djSP;
  51.     EXTEND(SP,1);
  52.     if (PL_op->op_private & OPpLVAL_INTRO)
  53.     PUSHs(save_scalar(cGVOP_gv));
  54.     else
  55.     PUSHs(GvSV(cGVOP_gv));
  56.     RETURN;
  57. }
  58.  
  59. PP(pp_null)
  60. {
  61.     return NORMAL;
  62. }
  63.  
  64. PP(pp_setstate)
  65. {
  66.     PL_curcop = (COP*)PL_op;
  67.     return NORMAL;
  68. }
  69.  
  70. PP(pp_pushmark)
  71. {
  72.     PUSHMARK(PL_stack_sp);
  73.     return NORMAL;
  74. }
  75.  
  76. PP(pp_stringify)
  77. {
  78.     djSP; dTARGET;
  79.     STRLEN len;
  80.     char *s;
  81.     s = SvPV(TOPs,len);
  82.     sv_setpvn(TARG,s,len);
  83.     if (SvUTF8(TOPs) && !IN_BYTE)
  84.     SvUTF8_on(TARG);
  85.     SETTARG;
  86.     RETURN;
  87. }
  88.  
  89. PP(pp_gv)
  90. {
  91.     djSP;
  92.     XPUSHs((SV*)cGVOP_gv);
  93.     RETURN;
  94. }
  95.  
  96. PP(pp_and)
  97. {
  98.     djSP;
  99.     if (!SvTRUE(TOPs))
  100.     RETURN;
  101.     else {
  102.     --SP;
  103.     RETURNOP(cLOGOP->op_other);
  104.     }
  105. }
  106.  
  107. PP(pp_sassign)
  108. {
  109.     djSP; dPOPTOPssrl;
  110.  
  111.     if (PL_op->op_private & OPpASSIGN_BACKWARDS) {
  112.     SV *temp;
  113.     temp = left; left = right; right = temp;
  114.     }
  115.     if (PL_tainting && PL_tainted && !SvTAINTED(left))
  116.     TAINT_NOT;
  117.     SvSetMagicSV(right, left);
  118.     SETs(right);
  119.     RETURN;
  120. }
  121.  
  122. PP(pp_cond_expr)
  123. {
  124.     djSP;
  125.     if (SvTRUEx(POPs))
  126.     RETURNOP(cLOGOP->op_other);
  127.     else
  128.     RETURNOP(cLOGOP->op_next);
  129. }
  130.  
  131. PP(pp_unstack)
  132. {
  133.     I32 oldsave;
  134.     TAINT_NOT;        /* Each statement is presumed innocent */
  135.     PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
  136.     FREETMPS;
  137.     oldsave = PL_scopestack[PL_scopestack_ix - 1];
  138.     LEAVE_SCOPE(oldsave);
  139.     return NORMAL;
  140. }
  141.  
  142. PP(pp_concat)
  143. {
  144.   djSP; dATARGET; tryAMAGICbin(concat,opASSIGN);
  145.   {
  146.     dPOPTOPssrl;
  147.     STRLEN len;
  148.     char *s;
  149.  
  150.     if (TARG != left) {
  151.     s = SvPV(left,len);
  152.     if (TARG == right) {
  153.         sv_insert(TARG, 0, 0, s, len);
  154.         SETs(TARG);
  155.         RETURN;
  156.     }
  157.     sv_setpvn(TARG,s,len);
  158.     }
  159.     else if (SvGMAGICAL(TARG))
  160.     mg_get(TARG);
  161.     else if (!SvOK(TARG) && SvTYPE(TARG) <= SVt_PVMG) {
  162.     sv_setpv(TARG, "");    /* Suppress warning. */
  163.     s = SvPV_force(TARG, len);
  164.     }
  165.     s = SvPV(right,len);
  166.     if (SvOK(TARG)) {
  167. #if defined(PERL_Y2KWARN)
  168.     if ((SvIOK(right) || SvNOK(right)) && ckWARN(WARN_Y2K)) {
  169.         STRLEN n;
  170.         char *s = SvPV(TARG,n);
  171.         if (n >= 2 && s[n-2] == '1' && s[n-1] == '9'
  172.         && (n == 2 || !isDIGIT(s[n-3])))
  173.         {
  174.         Perl_warner(aTHX_ WARN_Y2K, "Possible Y2K bug: %s",
  175.                 "about to append an integer to '19'");
  176.         }
  177.     }
  178. #endif
  179.     if (DO_UTF8(right))
  180.         sv_utf8_upgrade(TARG);
  181.     sv_catpvn(TARG,s,len);
  182.     if (!IN_BYTE) {
  183.         if (SvUTF8(right))
  184.         SvUTF8_on(TARG);
  185.     }
  186.     else if (!SvUTF8(right)) {
  187.         SvUTF8_off(TARG);
  188.     }
  189.     }
  190.     else
  191.     sv_setpvn(TARG,s,len);    /* suppress warning */
  192.     SETTARG;
  193.     RETURN;
  194.   }
  195. }
  196.  
  197. PP(pp_padsv)
  198. {
  199.     djSP; dTARGET;
  200.     XPUSHs(TARG);
  201.     if (PL_op->op_flags & OPf_MOD) {
  202.     if (PL_op->op_private & OPpLVAL_INTRO)
  203.         SAVECLEARSV(PL_curpad[PL_op->op_targ]);
  204.         else if (PL_op->op_private & OPpDEREF) {
  205.         PUTBACK;
  206.         vivify_ref(PL_curpad[PL_op->op_targ], PL_op->op_private & OPpDEREF);
  207.         SPAGAIN;
  208.     }
  209.     }
  210.     RETURN;
  211. }
  212.  
  213. PP(pp_readline)
  214. {
  215.     tryAMAGICunTARGET(iter, 0);
  216.     PL_last_in_gv = (GV*)(*PL_stack_sp--);
  217.     if (SvTYPE(PL_last_in_gv) != SVt_PVGV) {
  218.     if (SvROK(PL_last_in_gv) && SvTYPE(SvRV(PL_last_in_gv)) == SVt_PVGV) 
  219.         PL_last_in_gv = (GV*)SvRV(PL_last_in_gv);
  220.     else {
  221.         dSP;
  222.         XPUSHs((SV*)PL_last_in_gv);
  223.         PUTBACK;
  224.         pp_rv2gv();
  225.         PL_last_in_gv = (GV*)(*PL_stack_sp--);
  226.     }
  227.     }
  228.     return do_readline();
  229. }
  230.  
  231. PP(pp_eq)
  232. {
  233.     djSP; tryAMAGICbinSET(eq,0); 
  234.     {
  235.       dPOPnv;
  236.       SETs(boolSV(TOPn == value));
  237.       RETURN;
  238.     }
  239. }
  240.  
  241. PP(pp_preinc)
  242. {
  243.     djSP;
  244.     if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
  245.     DIE(aTHX_ PL_no_modify);
  246.     if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
  247.         SvIVX(TOPs) != IV_MAX)
  248.     {
  249.     ++SvIVX(TOPs);
  250.     SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
  251.     }
  252.     else
  253.     sv_inc(TOPs);
  254.     SvSETMAGIC(TOPs);
  255.     return NORMAL;
  256. }
  257.  
  258. PP(pp_or)
  259. {
  260.     djSP;
  261.     if (SvTRUE(TOPs))
  262.     RETURN;
  263.     else {
  264.     --SP;
  265.     RETURNOP(cLOGOP->op_other);
  266.     }
  267. }
  268.  
  269. PP(pp_add)
  270. {
  271.     djSP; dATARGET; tryAMAGICbin(add,opASSIGN); 
  272.     {
  273.       dPOPTOPnnrl_ul;
  274.       SETn( left + right );
  275.       RETURN;
  276.     }
  277. }
  278.  
  279. PP(pp_aelemfast)
  280. {
  281.     djSP;
  282.     AV *av = GvAV(cGVOP_gv);
  283.     U32 lval = PL_op->op_flags & OPf_MOD;
  284.     SV** svp = av_fetch(av, PL_op->op_private, lval);
  285.     SV *sv = (svp ? *svp : &PL_sv_undef);
  286.     EXTEND(SP, 1);
  287.     if (!lval && SvGMAGICAL(sv))    /* see note in pp_helem() */
  288.     sv = sv_mortalcopy(sv);
  289.     PUSHs(sv);
  290.     RETURN;
  291. }
  292.  
  293. PP(pp_join)
  294. {
  295.     djSP; dMARK; dTARGET;
  296.     MARK++;
  297.     do_join(TARG, *MARK, MARK, SP);
  298.     SP = MARK;
  299.     SETs(TARG);
  300.     RETURN;
  301. }
  302.  
  303. PP(pp_pushre)
  304. {
  305.     djSP;
  306. #ifdef DEBUGGING
  307.     /*
  308.      * We ass_u_me that LvTARGOFF() comes first, and that two STRLENs
  309.      * will be enough to hold an OP*.
  310.      */
  311.     SV* sv = sv_newmortal();
  312.     sv_upgrade(sv, SVt_PVLV);
  313.     LvTYPE(sv) = '/';
  314.     Copy(&PL_op, &LvTARGOFF(sv), 1, OP*);
  315.     XPUSHs(sv);
  316. #else
  317.     XPUSHs((SV*)PL_op);
  318. #endif
  319.     RETURN;
  320. }
  321.  
  322. /* Oversized hot code. */
  323.  
  324. PP(pp_print)
  325. {
  326.     djSP; dMARK; dORIGMARK;
  327.     GV *gv;
  328.     IO *io;
  329.     register PerlIO *fp;
  330.     MAGIC *mg;
  331.     STRLEN n_a;
  332.  
  333.     if (PL_op->op_flags & OPf_STACKED)
  334.     gv = (GV*)*++MARK;
  335.     else
  336.     gv = PL_defoutgv;
  337.     if ((mg = SvTIED_mg((SV*)gv, 'q'))) {
  338.     if (MARK == ORIGMARK) {
  339.         /* If using default handle then we need to make space to 
  340.          * pass object as 1st arg, so move other args up ...
  341.          */
  342.         MEXTEND(SP, 1);
  343.         ++MARK;
  344.         Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
  345.         ++SP;
  346.     }
  347.     PUSHMARK(MARK - 1);
  348.     *MARK = SvTIED_obj((SV*)gv, mg);
  349.     PUTBACK;
  350.     ENTER;
  351.     call_method("PRINT", G_SCALAR);
  352.     LEAVE;
  353.     SPAGAIN;
  354.     MARK = ORIGMARK + 1;
  355.     *MARK = *SP;
  356.     SP = MARK;
  357.     RETURN;
  358.     }
  359.     if (!(io = GvIO(gv))) {
  360.     if (ckWARN(WARN_UNOPENED)) {
  361.         SV* sv = sv_newmortal();
  362.         gv_efullname3(sv, gv, Nullch);
  363.             Perl_warner(aTHX_ WARN_UNOPENED, "Filehandle %s never opened",
  364.             SvPV(sv,n_a));
  365.         }
  366.     SETERRNO(EBADF,RMS$_IFI);
  367.     goto just_say_no;
  368.     }
  369.     else if (!(fp = IoOFP(io))) {
  370.     if (ckWARN2(WARN_CLOSED, WARN_IO))  {
  371.         if (IoIFP(io)) {
  372.         SV* sv = sv_newmortal();
  373.         gv_efullname3(sv, gv, Nullch);
  374.         Perl_warner(aTHX_ WARN_IO,
  375.                 "Filehandle %s opened only for input",
  376.                 SvPV(sv,n_a));
  377.         }
  378.         else if (ckWARN(WARN_CLOSED))
  379.         report_closed_fh(gv, io, "print", "filehandle");
  380.     }
  381.     SETERRNO(EBADF,IoIFP(io)?RMS$_FAC:RMS$_IFI);
  382.     goto just_say_no;
  383.     }
  384.     else {
  385.     MARK++;
  386.     if (PL_ofslen) {
  387.         while (MARK <= SP) {
  388.         if (!do_print(*MARK, fp))
  389.             break;
  390.         MARK++;
  391.         if (MARK <= SP) {
  392.             if (PerlIO_write(fp, PL_ofs, PL_ofslen) == 0 || PerlIO_error(fp)) {
  393.             MARK--;
  394.             break;
  395.             }
  396.         }
  397.         }
  398.     }
  399.     else {
  400.         while (MARK <= SP) {
  401.         if (!do_print(*MARK, fp))
  402.             break;
  403.         MARK++;
  404.         }
  405.     }
  406.     if (MARK <= SP)
  407.         goto just_say_no;
  408.     else {
  409.         if (PL_orslen)
  410.         if (PerlIO_write(fp, PL_ors, PL_orslen) == 0 || PerlIO_error(fp))
  411.             goto just_say_no;
  412.  
  413.         if (IoFLAGS(io) & IOf_FLUSH)
  414.         if (PerlIO_flush(fp) == EOF)
  415.             goto just_say_no;
  416.     }
  417.     }
  418.     SP = ORIGMARK;
  419.     PUSHs(&PL_sv_yes);
  420.     RETURN;
  421.  
  422.   just_say_no:
  423.     SP = ORIGMARK;
  424.     PUSHs(&PL_sv_undef);
  425.     RETURN;
  426. }
  427.  
  428. PP(pp_rv2av)
  429. {
  430.     djSP; dTOPss;
  431.     AV *av;
  432.  
  433.     if (SvROK(sv)) {
  434.       wasref:
  435.     tryAMAGICunDEREF(to_av);
  436.  
  437.     av = (AV*)SvRV(sv);
  438.     if (SvTYPE(av) != SVt_PVAV)
  439.         DIE(aTHX_ "Not an ARRAY reference");
  440.     if (PL_op->op_flags & OPf_REF) {
  441.         SETs((SV*)av);
  442.         RETURN;
  443.     }
  444.     }
  445.     else {
  446.     if (SvTYPE(sv) == SVt_PVAV) {
  447.         av = (AV*)sv;
  448.         if (PL_op->op_flags & OPf_REF) {
  449.         SETs((SV*)av);
  450.         RETURN;
  451.         }
  452.     }
  453.     else {
  454.         GV *gv;
  455.         
  456.         if (SvTYPE(sv) != SVt_PVGV) {
  457.         char *sym;
  458.         STRLEN n_a;
  459.  
  460.         if (SvGMAGICAL(sv)) {
  461.             mg_get(sv);
  462.             if (SvROK(sv))
  463.             goto wasref;
  464.         }
  465.         if (!SvOK(sv)) {
  466.             if (PL_op->op_flags & OPf_REF ||
  467.               PL_op->op_private & HINT_STRICT_REFS)
  468.             DIE(aTHX_ PL_no_usym, "an ARRAY");
  469.             if (ckWARN(WARN_UNINITIALIZED))
  470.             report_uninit();
  471.             if (GIMME == G_ARRAY) {
  472.             (void)POPs;
  473.             RETURN;
  474.             }
  475.             RETSETUNDEF;
  476.         }
  477.         sym = SvPV(sv,n_a);
  478.         if ((PL_op->op_flags & OPf_SPECIAL) &&
  479.             !(PL_op->op_flags & OPf_MOD))
  480.         {
  481.             gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PVAV);
  482.             if (!gv)
  483.             RETSETUNDEF;
  484.         }
  485.         else {
  486.             if (PL_op->op_private & HINT_STRICT_REFS)
  487.             DIE(aTHX_ PL_no_symref, sym, "an ARRAY");
  488.             gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVAV);
  489.         }
  490.         }
  491.         else {
  492.         gv = (GV*)sv;
  493.         }
  494.         av = GvAVn(gv);
  495.         if (PL_op->op_private & OPpLVAL_INTRO)
  496.         av = save_ary(gv);
  497.         if (PL_op->op_flags & OPf_REF) {
  498.         SETs((SV*)av);
  499.         RETURN;
  500.         }
  501.     }
  502.     }
  503.  
  504.     if (GIMME == G_ARRAY) {
  505.     I32 maxarg = AvFILL(av) + 1;
  506.     (void)POPs;            /* XXXX May be optimized away? */
  507.     EXTEND(SP, maxarg);          
  508.     if (SvRMAGICAL(av)) {
  509.         U32 i; 
  510.         for (i=0; i < maxarg; i++) {
  511.         SV **svp = av_fetch(av, i, FALSE);
  512.         SP[i+1] = (svp) ? *svp : &PL_sv_undef;
  513.         }
  514.     } 
  515.     else {
  516.         Copy(AvARRAY(av), SP+1, maxarg, SV*);
  517.     }
  518.     SP += maxarg;
  519.     }
  520.     else {
  521.     dTARGET;
  522.     I32 maxarg = AvFILL(av) + 1;
  523.     SETi(maxarg);
  524.     }
  525.     RETURN;
  526. }
  527.  
  528. PP(pp_rv2hv)
  529. {
  530.     djSP; dTOPss;
  531.     HV *hv;
  532.  
  533.     if (SvROK(sv)) {
  534.       wasref:
  535.     tryAMAGICunDEREF(to_hv);
  536.  
  537.     hv = (HV*)SvRV(sv);
  538.     if (SvTYPE(hv) != SVt_PVHV && SvTYPE(hv) != SVt_PVAV)
  539.         DIE(aTHX_ "Not a HASH reference");
  540.     if (PL_op->op_flags & OPf_REF) {
  541.         SETs((SV*)hv);
  542.         RETURN;
  543.     }
  544.     }
  545.     else {
  546.     if (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) {
  547.         hv = (HV*)sv;
  548.         if (PL_op->op_flags & OPf_REF) {
  549.         SETs((SV*)hv);
  550.         RETURN;
  551.         }
  552.     }
  553.     else {
  554.         GV *gv;
  555.         
  556.         if (SvTYPE(sv) != SVt_PVGV) {
  557.         char *sym;
  558.         STRLEN n_a;
  559.  
  560.         if (SvGMAGICAL(sv)) {
  561.             mg_get(sv);
  562.             if (SvROK(sv))
  563.             goto wasref;
  564.         }
  565.         if (!SvOK(sv)) {
  566.             if (PL_op->op_flags & OPf_REF ||
  567.               PL_op->op_private & HINT_STRICT_REFS)
  568.             DIE(aTHX_ PL_no_usym, "a HASH");
  569.             if (ckWARN(WARN_UNINITIALIZED))
  570.             report_uninit();
  571.             if (GIMME == G_ARRAY) {
  572.             SP--;
  573.             RETURN;
  574.             }
  575.             RETSETUNDEF;
  576.         }
  577.         sym = SvPV(sv,n_a);
  578.         if ((PL_op->op_flags & OPf_SPECIAL) &&
  579.             !(PL_op->op_flags & OPf_MOD))
  580.         {
  581.             gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PVHV);
  582.             if (!gv)
  583.             RETSETUNDEF;
  584.         }
  585.         else {
  586.             if (PL_op->op_private & HINT_STRICT_REFS)
  587.             DIE(aTHX_ PL_no_symref, sym, "a HASH");
  588.             gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVHV);
  589.         }
  590.         }
  591.         else {
  592.         gv = (GV*)sv;
  593.         }
  594.         hv = GvHVn(gv);
  595.         if (PL_op->op_private & OPpLVAL_INTRO)
  596.         hv = save_hash(gv);
  597.         if (PL_op->op_flags & OPf_REF) {
  598.         SETs((SV*)hv);
  599.         RETURN;
  600.         }
  601.     }
  602.     }
  603.  
  604.     if (GIMME == G_ARRAY) { /* array wanted */
  605.     *PL_stack_sp = (SV*)hv;
  606.     return do_kv();
  607.     }
  608.     else {
  609.     dTARGET;
  610.     if (SvTYPE(hv) == SVt_PVAV)
  611.         hv = avhv_keys((AV*)hv);
  612.     if (HvFILL(hv))
  613.             Perl_sv_setpvf(aTHX_ TARG, "%"IVdf"/%"IVdf,
  614.                (IV)HvFILL(hv), (IV)HvMAX(hv) + 1);
  615.     else
  616.         sv_setiv(TARG, 0);
  617.     
  618.     SETTARG;
  619.     RETURN;
  620.     }
  621. }
  622.  
  623. STATIC int
  624. S_do_maybe_phash(pTHX_ AV *ary, SV **lelem, SV **firstlelem, SV **relem,
  625.          SV **lastrelem)
  626. {
  627.     OP *leftop;
  628.     I32 i;
  629.  
  630.     leftop = ((BINOP*)PL_op)->op_last;
  631.     assert(leftop);
  632.     assert(leftop->op_type == OP_NULL && leftop->op_targ == OP_LIST);
  633.     leftop = ((LISTOP*)leftop)->op_first;
  634.     assert(leftop);
  635.     /* Skip PUSHMARK and each element already assigned to. */
  636.     for (i = lelem - firstlelem; i > 0; i--) {
  637.     leftop = leftop->op_sibling;
  638.     assert(leftop);
  639.     }
  640.     if (leftop->op_type != OP_RV2HV)
  641.     return 0;
  642.  
  643.     /* pseudohash */
  644.     if (av_len(ary) > 0)
  645.     av_fill(ary, 0);        /* clear all but the fields hash */
  646.     if (lastrelem >= relem) {
  647.     while (relem < lastrelem) {    /* gobble up all the rest */
  648.         SV *tmpstr;
  649.         assert(relem[0]);
  650.         assert(relem[1]);
  651.         /* Avoid a memory leak when avhv_store_ent dies. */
  652.         tmpstr = sv_newmortal();
  653.         sv_setsv(tmpstr,relem[1]);    /* value */
  654.         relem[1] = tmpstr;
  655.         if (avhv_store_ent(ary,relem[0],tmpstr,0))
  656.         (void)SvREFCNT_inc(tmpstr);
  657.         if (SvMAGICAL(ary) != 0 && SvSMAGICAL(tmpstr))
  658.         mg_set(tmpstr);
  659.         relem += 2;
  660.         TAINT_NOT;
  661.     }
  662.     }
  663.     if (relem == lastrelem)
  664.     return 1;
  665.     return 2;
  666. }
  667.  
  668. STATIC void
  669. S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem)
  670. {
  671.     if (*relem) {
  672.     SV *tmpstr;
  673.     if (ckWARN(WARN_MISC)) {
  674.         if (relem == firstrelem &&
  675.         SvROK(*relem) &&
  676.         (SvTYPE(SvRV(*relem)) == SVt_PVAV ||
  677.          SvTYPE(SvRV(*relem)) == SVt_PVHV))
  678.         {
  679.         Perl_warner(aTHX_ WARN_MISC,
  680.                 "Reference found where even-sized list expected");
  681.         }
  682.         else
  683.         Perl_warner(aTHX_ WARN_MISC,
  684.                 "Odd number of elements in hash assignment");
  685.     }
  686.     if (SvTYPE(hash) == SVt_PVAV) {
  687.         /* pseudohash */
  688.         tmpstr = sv_newmortal();
  689.         if (avhv_store_ent((AV*)hash,*relem,tmpstr,0))
  690.         (void)SvREFCNT_inc(tmpstr);
  691.         if (SvMAGICAL(hash) && SvSMAGICAL(tmpstr))
  692.         mg_set(tmpstr);
  693.     }
  694.     else {
  695.         HE *didstore;
  696.         tmpstr = NEWSV(29,0);
  697.         didstore = hv_store_ent(hash,*relem,tmpstr,0);
  698.         if (SvMAGICAL(hash)) {
  699.         if (SvSMAGICAL(tmpstr))
  700.             mg_set(tmpstr);
  701.         if (!didstore)
  702.             sv_2mortal(tmpstr);
  703.         }
  704.     }
  705.     TAINT_NOT;
  706.     }
  707. }
  708.  
  709. PP(pp_aassign)
  710. {
  711.     djSP;
  712.     SV **lastlelem = PL_stack_sp;
  713.     SV **lastrelem = PL_stack_base + POPMARK;
  714.     SV **firstrelem = PL_stack_base + POPMARK + 1;
  715.     SV **firstlelem = lastrelem + 1;
  716.  
  717.     register SV **relem;
  718.     register SV **lelem;
  719.  
  720.     register SV *sv;
  721.     register AV *ary;
  722.  
  723.     I32 gimme;
  724.     HV *hash;
  725.     I32 i;
  726.     int magic;
  727.  
  728.     PL_delaymagic = DM_DELAY;        /* catch simultaneous items */
  729.  
  730.     /* If there's a common identifier on both sides we have to take
  731.      * special care that assigning the identifier on the left doesn't
  732.      * clobber a value on the right that's used later in the list.
  733.      */
  734.     if (PL_op->op_private & (OPpASSIGN_COMMON)) {
  735.     EXTEND_MORTAL(lastrelem - firstrelem + 1);
  736.     for (relem = firstrelem; relem <= lastrelem; relem++) {
  737.         /*SUPPRESS 560*/
  738.         if ((sv = *relem)) {
  739.         TAINT_NOT;    /* Each item is independent */
  740.         *relem = sv_mortalcopy(sv);
  741.         }
  742.     }
  743.     }
  744.  
  745.     relem = firstrelem;
  746.     lelem = firstlelem;
  747.     ary = Null(AV*);
  748.     hash = Null(HV*);
  749.  
  750.     while (lelem <= lastlelem) {
  751.     TAINT_NOT;        /* Each item stands on its own, taintwise. */
  752.     sv = *lelem++;
  753.     switch (SvTYPE(sv)) {
  754.     case SVt_PVAV:
  755.         ary = (AV*)sv;
  756.         magic = SvMAGICAL(ary) != 0;
  757.         if (PL_op->op_private & OPpASSIGN_HASH) {
  758.         switch (do_maybe_phash(ary, lelem, firstlelem, relem,
  759.                        lastrelem))
  760.         {
  761.         case 0:
  762.             goto normal_array;
  763.         case 1:
  764.             do_oddball((HV*)ary, relem, firstrelem);
  765.         }
  766.         relem = lastrelem + 1;
  767.         break;
  768.         }
  769.     normal_array:
  770.         av_clear(ary);
  771.         av_extend(ary, lastrelem - relem);
  772.         i = 0;
  773.         while (relem <= lastrelem) {    /* gobble up all the rest */
  774.         SV **didstore;
  775.         sv = NEWSV(28,0);
  776.         assert(*relem);
  777.         sv_setsv(sv,*relem);
  778.         *(relem++) = sv;
  779.         didstore = av_store(ary,i++,sv);
  780.         if (magic) {
  781.             if (SvSMAGICAL(sv))
  782.             mg_set(sv);
  783.             if (!didstore)
  784.             sv_2mortal(sv);
  785.         }
  786.         TAINT_NOT;
  787.         }
  788.         break;
  789.     case SVt_PVHV: {                /* normal hash */
  790.         SV *tmpstr;
  791.  
  792.         hash = (HV*)sv;
  793.         magic = SvMAGICAL(hash) != 0;
  794.         hv_clear(hash);
  795.  
  796.         while (relem < lastrelem) {    /* gobble up all the rest */
  797.             HE *didstore;
  798.             if (*relem)
  799.             sv = *(relem++);
  800.             else
  801.             sv = &PL_sv_no, relem++;
  802.             tmpstr = NEWSV(29,0);
  803.             if (*relem)
  804.             sv_setsv(tmpstr,*relem);    /* value */
  805.             *(relem++) = tmpstr;
  806.             didstore = hv_store_ent(hash,sv,tmpstr,0);
  807.             if (magic) {
  808.             if (SvSMAGICAL(tmpstr))
  809.                 mg_set(tmpstr);
  810.             if (!didstore)
  811.                 sv_2mortal(tmpstr);
  812.             }
  813.             TAINT_NOT;
  814.         }
  815.         if (relem == lastrelem) {
  816.             do_oddball(hash, relem, firstrelem);
  817.             relem++;
  818.         }
  819.         }
  820.         break;
  821.     default:
  822.         if (SvIMMORTAL(sv)) {
  823.         if (relem <= lastrelem)
  824.             relem++;
  825.         break;
  826.         }
  827.         if (relem <= lastrelem) {
  828.         sv_setsv(sv, *relem);
  829.         *(relem++) = sv;
  830.         }
  831.         else
  832.         sv_setsv(sv, &PL_sv_undef);
  833.         SvSETMAGIC(sv);
  834.         break;
  835.     }
  836.     }
  837.     if (PL_delaymagic & ~DM_DELAY) {
  838.     if (PL_delaymagic & DM_UID) {
  839. #ifdef HAS_SETRESUID
  840.         (void)setresuid(PL_uid,PL_euid,(Uid_t)-1);
  841. #else
  842. #  ifdef HAS_SETREUID
  843.         (void)setreuid(PL_uid,PL_euid);
  844. #  else
  845. #    ifdef HAS_SETRUID
  846.         if ((PL_delaymagic & DM_UID) == DM_RUID) {
  847.         (void)setruid(PL_uid);
  848.         PL_delaymagic &= ~DM_RUID;
  849.         }
  850. #    endif /* HAS_SETRUID */
  851. #    ifdef HAS_SETEUID
  852.         if ((PL_delaymagic & DM_UID) == DM_EUID) {
  853.         (void)seteuid(PL_uid);
  854.         PL_delaymagic &= ~DM_EUID;
  855.         }
  856. #    endif /* HAS_SETEUID */
  857.         if (PL_delaymagic & DM_UID) {
  858.         if (PL_uid != PL_euid)
  859.             DIE(aTHX_ "No setreuid available");
  860.         (void)PerlProc_setuid(PL_uid);
  861.         }
  862. #  endif /* HAS_SETREUID */
  863. #endif /* HAS_SETRESUID */
  864.         PL_uid = PerlProc_getuid();
  865.         PL_euid = PerlProc_geteuid();
  866.     }
  867.     if (PL_delaymagic & DM_GID) {
  868. #ifdef HAS_SETRESGID
  869.         (void)setresgid(PL_gid,PL_egid,(Gid_t)-1);
  870. #else
  871. #  ifdef HAS_SETREGID
  872.         (void)setregid(PL_gid,PL_egid);
  873. #  else
  874. #    ifdef HAS_SETRGID
  875.         if ((PL_delaymagic & DM_GID) == DM_RGID) {
  876.         (void)setrgid(PL_gid);
  877.         PL_delaymagic &= ~DM_RGID;
  878.         }
  879. #    endif /* HAS_SETRGID */
  880. #    ifdef HAS_SETEGID
  881.         if ((PL_delaymagic & DM_GID) == DM_EGID) {
  882.         (void)setegid(PL_gid);
  883.         PL_delaymagic &= ~DM_EGID;
  884.         }
  885. #    endif /* HAS_SETEGID */
  886.         if (PL_delaymagic & DM_GID) {
  887.         if (PL_gid != PL_egid)
  888.             DIE(aTHX_ "No setregid available");
  889.         (void)PerlProc_setgid(PL_gid);
  890.         }
  891. #  endif /* HAS_SETREGID */
  892. #endif /* HAS_SETRESGID */
  893.         PL_gid = PerlProc_getgid();
  894.         PL_egid = PerlProc_getegid();
  895.     }
  896.     PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
  897.     }
  898.     PL_delaymagic = 0;
  899.  
  900.     gimme = GIMME_V;
  901.     if (gimme == G_VOID)
  902.     SP = firstrelem - 1;
  903.     else if (gimme == G_SCALAR) {
  904.     dTARGET;
  905.     SP = firstrelem;
  906.     SETi(lastrelem - firstrelem + 1);
  907.     }
  908.     else {
  909.     if (ary || hash)
  910.         SP = lastrelem;
  911.     else
  912.         SP = firstrelem + (lastlelem - firstlelem);
  913.     lelem = firstlelem + (relem - firstrelem);
  914.     while (relem <= SP)
  915.         *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
  916.     }
  917.     RETURN;
  918. }
  919.  
  920. PP(pp_qr)
  921. {
  922.     djSP;
  923.     register PMOP *pm = cPMOP;
  924.     SV *rv = sv_newmortal();
  925.     SV *sv = newSVrv(rv, "Regexp");
  926.     sv_magic(sv,(SV*)ReREFCNT_inc(pm->op_pmregexp),'r',0,0);
  927.     RETURNX(PUSHs(rv));
  928. }
  929.  
  930. PP(pp_match)
  931. {
  932.     djSP; dTARG;
  933.     register PMOP *pm = cPMOP;
  934.     register char *t;
  935.     register char *s;
  936.     char *strend;
  937.     I32 global;
  938.     I32 r_flags = REXEC_CHECKED;
  939.     char *truebase;            /* Start of string  */
  940.     register REGEXP *rx = pm->op_pmregexp;
  941.     bool rxtainted;
  942.     I32 gimme = GIMME;
  943.     STRLEN len;
  944.     I32 minmatch = 0;
  945.     I32 oldsave = PL_savestack_ix;
  946.     I32 update_minmatch = 1;
  947.     I32 had_zerolen = 0;
  948.  
  949.     if (PL_op->op_flags & OPf_STACKED)
  950.     TARG = POPs;
  951.     else {
  952.     TARG = DEFSV;
  953.     EXTEND(SP,1);
  954.     }
  955.     PUTBACK;                /* EVAL blocks need stack_sp. */
  956.     s = SvPV(TARG, len);
  957.     strend = s + len;
  958.     if (!s)
  959.     DIE(aTHX_ "panic: do_match");
  960.     rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
  961.          (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
  962.     TAINT_NOT;
  963.  
  964.     if (pm->op_pmdynflags & PMdf_USED) {
  965.       failure:
  966.     if (gimme == G_ARRAY)
  967.         RETURN;
  968.     RETPUSHNO;
  969.     }
  970.  
  971.     if (!rx->prelen && PL_curpm) {
  972.     pm = PL_curpm;
  973.     rx = pm->op_pmregexp;
  974.     }
  975.     if (rx->minlen > len) goto failure;
  976.  
  977.     truebase = t = s;
  978.  
  979.     /* XXXX What part of this is needed with true \G-support? */
  980.     if ((global = pm->op_pmflags & PMf_GLOBAL)) {
  981.     rx->startp[0] = -1;
  982.     if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
  983.         MAGIC* mg = mg_find(TARG, 'g');
  984.         if (mg && mg->mg_len >= 0) {
  985.         if (!(rx->reganch & ROPT_GPOS_SEEN))
  986.             rx->endp[0] = rx->startp[0] = mg->mg_len; 
  987.         else if (rx->reganch & ROPT_ANCH_GPOS) {
  988.             r_flags |= REXEC_IGNOREPOS;
  989.             rx->endp[0] = rx->startp[0] = mg->mg_len; 
  990.         }
  991.         minmatch = (mg->mg_flags & MGf_MINMATCH);
  992.         update_minmatch = 0;
  993.         }
  994.     }
  995.     }
  996.     if ((gimme != G_ARRAY && !global && rx->nparens)
  997.         || SvTEMP(TARG) || PL_sawampersand)
  998.     r_flags |= REXEC_COPY_STR;
  999.     if (SvSCREAM(TARG)) 
  1000.     r_flags |= REXEC_SCREAM;
  1001.  
  1002.     if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
  1003.     SAVEINT(PL_multiline);
  1004.     PL_multiline = pm->op_pmflags & PMf_MULTILINE;
  1005.     }
  1006.  
  1007. play_it_again:
  1008.     if (global && rx->startp[0] != -1) {
  1009.     t = s = rx->endp[0] + truebase;
  1010.     if ((s + rx->minlen) > strend)
  1011.         goto nope;
  1012.     if (update_minmatch++)
  1013.         minmatch = had_zerolen;
  1014.     }
  1015.     if (rx->reganch & RE_USE_INTUIT) {
  1016.     s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
  1017.  
  1018.     if (!s)
  1019.         goto nope;
  1020.     if ( (rx->reganch & ROPT_CHECK_ALL)
  1021.          && !PL_sawampersand 
  1022.          && ((rx->reganch & ROPT_NOSCAN)
  1023.          || !((rx->reganch & RE_INTUIT_TAIL)
  1024.               && (r_flags & REXEC_SCREAM))))
  1025.         goto yup;
  1026.     }
  1027.     if (CALLREGEXEC(aTHX_ rx, s, strend, truebase, minmatch, TARG, NULL, r_flags))
  1028.     {
  1029.     PL_curpm = pm;
  1030.     if (pm->op_pmflags & PMf_ONCE)
  1031.         pm->op_pmdynflags |= PMdf_USED;
  1032.     goto gotcha;
  1033.     }
  1034.     else
  1035.     goto ret_no;
  1036.     /*NOTREACHED*/
  1037.  
  1038.   gotcha:
  1039.     if (rxtainted)
  1040.     RX_MATCH_TAINTED_on(rx);
  1041.     TAINT_IF(RX_MATCH_TAINTED(rx));
  1042.     if (gimme == G_ARRAY) {
  1043.     I32 iters, i, len;
  1044.  
  1045.     iters = rx->nparens;
  1046.     if (global && !iters)
  1047.         i = 1;
  1048.     else
  1049.         i = 0;
  1050.     SPAGAIN;            /* EVAL blocks could move the stack. */
  1051.     EXTEND(SP, iters + i);
  1052.     EXTEND_MORTAL(iters + i);
  1053.     for (i = !i; i <= iters; i++) {
  1054.         PUSHs(sv_newmortal());
  1055.         /*SUPPRESS 560*/
  1056.         if ((rx->startp[i] != -1) && rx->endp[i] != -1 ) {
  1057.         len = rx->endp[i] - rx->startp[i];
  1058.         s = rx->startp[i] + truebase;
  1059.         sv_setpvn(*SP, s, len);
  1060.         if ((pm->op_pmdynflags & PMdf_UTF8) && !IN_BYTE) {
  1061.             SvUTF8_on(*SP);
  1062.             sv_utf8_downgrade(*SP, TRUE);
  1063.         }
  1064.         }
  1065.     }
  1066.     if (global) {
  1067.         had_zerolen = (rx->startp[0] != -1
  1068.                && rx->startp[0] == rx->endp[0]);
  1069.         PUTBACK;            /* EVAL blocks may use stack */
  1070.         r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
  1071.         goto play_it_again;
  1072.     }
  1073.     else if (!iters)
  1074.         XPUSHs(&PL_sv_yes);
  1075.     LEAVE_SCOPE(oldsave);
  1076.     RETURN;
  1077.     }
  1078.     else {
  1079.     if (global) {
  1080.         MAGIC* mg = 0;
  1081.         if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
  1082.         mg = mg_find(TARG, 'g');
  1083.         if (!mg) {
  1084.         sv_magic(TARG, (SV*)0, 'g', Nullch, 0);
  1085.         mg = mg_find(TARG, 'g');
  1086.         }
  1087.         if (rx->startp[0] != -1) {
  1088.         mg->mg_len = rx->endp[0];
  1089.         if (rx->startp[0] == rx->endp[0])
  1090.             mg->mg_flags |= MGf_MINMATCH;
  1091.         else
  1092.             mg->mg_flags &= ~MGf_MINMATCH;
  1093.         }
  1094.     }
  1095.     LEAVE_SCOPE(oldsave);
  1096.     RETPUSHYES;
  1097.     }
  1098.  
  1099. yup:                    /* Confirmed by INTUIT */
  1100.     if (rxtainted)
  1101.     RX_MATCH_TAINTED_on(rx);
  1102.     TAINT_IF(RX_MATCH_TAINTED(rx));
  1103.     PL_curpm = pm;
  1104.     if (pm->op_pmflags & PMf_ONCE)
  1105.     pm->op_pmdynflags |= PMdf_USED;
  1106.     if (RX_MATCH_COPIED(rx))
  1107.     Safefree(rx->subbeg);
  1108.     RX_MATCH_COPIED_off(rx);
  1109.     rx->subbeg = Nullch;
  1110.     if (global) {
  1111.     rx->subbeg = truebase;
  1112.     rx->startp[0] = s - truebase;
  1113.     rx->endp[0] = s - truebase + rx->minlen;
  1114.     rx->sublen = strend - truebase;
  1115.     goto gotcha;
  1116.     } 
  1117.     if (PL_sawampersand) {
  1118.     I32 off;
  1119.  
  1120.     rx->subbeg = savepvn(t, strend - t);
  1121.     rx->sublen = strend - t;
  1122.     RX_MATCH_COPIED_on(rx);
  1123.     off = rx->startp[0] = s - t;
  1124.     rx->endp[0] = off + rx->minlen;
  1125.     }
  1126.     else {            /* startp/endp are used by @- @+. */
  1127.     rx->startp[0] = s - truebase;
  1128.     rx->endp[0] = s - truebase + rx->minlen;
  1129.     }
  1130.     rx->nparens = rx->lastparen = 0;    /* used by @- and @+ */
  1131.     LEAVE_SCOPE(oldsave);
  1132.     RETPUSHYES;
  1133.  
  1134. nope:
  1135. ret_no:
  1136.     if (global && !(pm->op_pmflags & PMf_CONTINUE)) {
  1137.     if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
  1138.         MAGIC* mg = mg_find(TARG, 'g');
  1139.         if (mg)
  1140.         mg->mg_len = -1;
  1141.     }
  1142.     }
  1143.     LEAVE_SCOPE(oldsave);
  1144.     if (gimme == G_ARRAY)
  1145.     RETURN;
  1146.     RETPUSHNO;
  1147. }
  1148.  
  1149. OP *
  1150. Perl_do_readline(pTHX)
  1151. {
  1152.     dSP; dTARGETSTACKED;
  1153.     register SV *sv;
  1154.     STRLEN tmplen = 0;
  1155.     STRLEN offset;
  1156.     PerlIO *fp;
  1157.     register IO *io = GvIO(PL_last_in_gv);
  1158.     register I32 type = PL_op->op_type;
  1159.     I32 gimme = GIMME_V;
  1160.     MAGIC *mg;
  1161.  
  1162.     if ((mg = SvTIED_mg((SV*)PL_last_in_gv, 'q'))) {
  1163.     PUSHMARK(SP);
  1164.     XPUSHs(SvTIED_obj((SV*)PL_last_in_gv, mg));
  1165.     PUTBACK;
  1166.     ENTER;
  1167.     call_method("READLINE", gimme);
  1168.     LEAVE;
  1169.     SPAGAIN;
  1170.     if (gimme == G_SCALAR)
  1171.         SvSetMagicSV_nosteal(TARG, TOPs);
  1172.     RETURN;
  1173.     }
  1174.     fp = Nullfp;
  1175.     if (io) {
  1176.     fp = IoIFP(io);
  1177.     if (!fp) {
  1178.         if (IoFLAGS(io) & IOf_ARGV) {
  1179.         if (IoFLAGS(io) & IOf_START) {
  1180.             IoLINES(io) = 0;
  1181.             if (av_len(GvAVn(PL_last_in_gv)) < 0) {
  1182.             IoFLAGS(io) &= ~IOf_START;
  1183.             do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,Nullfp);
  1184.             sv_setpvn(GvSV(PL_last_in_gv), "-", 1);
  1185.             SvSETMAGIC(GvSV(PL_last_in_gv));
  1186.             fp = IoIFP(io);
  1187.             goto have_fp;
  1188.             }
  1189.         }
  1190.         fp = nextargv(PL_last_in_gv);
  1191.         if (!fp) { /* Note: fp != IoIFP(io) */
  1192.             (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
  1193.         }
  1194.         }
  1195.         else if (type == OP_GLOB) {
  1196.         SV *tmpcmd = NEWSV(55, 0);
  1197.         SV *tmpglob = POPs;
  1198.         ENTER;
  1199.         SAVEFREESV(tmpcmd);
  1200. #ifdef VMS /* expand the wildcards right here, rather than opening a pipe, */
  1201.            /* since spawning off a process is a real performance hit */
  1202.         {
  1203. #include <descrip.h>
  1204. #include <lib$routines.h>
  1205. #include <nam.h>
  1206. #include <rmsdef.h>
  1207.             char rslt[NAM$C_MAXRSS+1+sizeof(unsigned short int)] = {'\0','\0'};
  1208.             char vmsspec[NAM$C_MAXRSS+1];
  1209.             char *rstr = rslt + sizeof(unsigned short int), *begin, *end, *cp;
  1210.             char tmpfnam[L_tmpnam] = "SYS$SCRATCH:";
  1211.             $DESCRIPTOR(dfltdsc,"SYS$DISK:[]*.*;");
  1212.             PerlIO *tmpfp;
  1213.             STRLEN i;
  1214.             struct dsc$descriptor_s wilddsc
  1215.                = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
  1216.             struct dsc$descriptor_vs rsdsc
  1217.                = {sizeof rslt, DSC$K_DTYPE_VT, DSC$K_CLASS_VS, rslt};
  1218.             unsigned long int cxt = 0, sts = 0, ok = 1, hasdir = 0, hasver = 0, isunix = 0;
  1219.  
  1220.             /* We could find out if there's an explicit dev/dir or version
  1221.                by peeking into lib$find_file's internal context at
  1222.                ((struct NAM *)((struct FAB *)cxt)->fab$l_nam)->nam$l_fnb
  1223.                but that's unsupported, so I don't want to do it now and
  1224.                have it bite someone in the future. */
  1225.             strcat(tmpfnam,PerlLIO_tmpnam(NULL));
  1226.             cp = SvPV(tmpglob,i);
  1227.             for (; i; i--) {
  1228.                if (cp[i] == ';') hasver = 1;
  1229.                if (cp[i] == '.') {
  1230.                    if (sts) hasver = 1;
  1231.                    else sts = 1;
  1232.                }
  1233.                if (cp[i] == '/') {
  1234.                   hasdir = isunix = 1;
  1235.                   break;
  1236.                }
  1237.                if (cp[i] == ']' || cp[i] == '>' || cp[i] == ':') {
  1238.                    hasdir = 1;
  1239.                    break;
  1240.                }
  1241.             }
  1242.             if ((tmpfp = PerlIO_open(tmpfnam,"w+","fop=dlt")) != NULL) {
  1243.                 Stat_t st;
  1244.                 if (!PerlLIO_stat(SvPVX(tmpglob),&st) && S_ISDIR(st.st_mode))
  1245.                   ok = ((wilddsc.dsc$a_pointer = tovmspath(SvPVX(tmpglob),vmsspec)) != NULL);
  1246.                 else ok = ((wilddsc.dsc$a_pointer = tovmsspec(SvPVX(tmpglob),vmsspec)) != NULL);
  1247.                 if (ok) wilddsc.dsc$w_length = (unsigned short int) strlen(wilddsc.dsc$a_pointer);
  1248.                 while (ok && ((sts = lib$find_file(&wilddsc,&rsdsc,&cxt,
  1249.                                             &dfltdsc,NULL,NULL,NULL))&1)) {
  1250.                     end = rstr + (unsigned long int) *rslt;
  1251.                     if (!hasver) while (*end != ';') end--;
  1252.                     *(end++) = '\n';  *end = '\0';
  1253.                     for (cp = rstr; *cp; cp++) *cp = _tolower(*cp);
  1254.                     if (hasdir) {
  1255.                       if (isunix) trim_unixpath(rstr,SvPVX(tmpglob),1);
  1256.                       begin = rstr;
  1257.                     }
  1258.                     else {
  1259.                         begin = end;
  1260.                         while (*(--begin) != ']' && *begin != '>') ;
  1261.                         ++begin;
  1262.                     }
  1263.                     ok = (PerlIO_puts(tmpfp,begin) != EOF);
  1264.                 }
  1265.                 if (cxt) (void)lib$find_file_end(&cxt);
  1266.                 if (ok && sts != RMS$_NMF &&
  1267.                     sts != RMS$_DNF && sts != RMS$_FNF) ok = 0;
  1268.                 if (!ok) {
  1269.                     if (!(sts & 1)) {
  1270.                       SETERRNO((sts == RMS$_SYN ? EINVAL : EVMSERR),sts);
  1271.                     }
  1272.                     PerlIO_close(tmpfp);
  1273.                     fp = NULL;
  1274.                 }
  1275.                 else {
  1276.                    PerlIO_rewind(tmpfp);
  1277.                    IoTYPE(io) = '<';
  1278.                    IoIFP(io) = fp = tmpfp;
  1279.                    IoFLAGS(io) &= ~IOf_UNTAINT;  /* maybe redundant */
  1280.                 }
  1281.             }
  1282.         }
  1283. #else /* !VMS */
  1284. #ifdef MACOS_TRADITIONAL
  1285.         sv_setpv(tmpcmd, "glob ");
  1286.         sv_catsv(tmpcmd, tmpglob);
  1287.         sv_catpv(tmpcmd, " |");
  1288. #else
  1289. #ifdef DOSISH
  1290. #ifdef OS2
  1291.         sv_setpv(tmpcmd, "for a in ");
  1292.         sv_catsv(tmpcmd, tmpglob);
  1293.         sv_catpv(tmpcmd, "; do echo \"$a\\0\\c\"; done |");
  1294. #else
  1295. #ifdef DJGPP
  1296.         sv_setpv(tmpcmd, "/dev/dosglob/"); /* File System Extension */
  1297.         sv_catsv(tmpcmd, tmpglob);
  1298. #else
  1299.         sv_setpv(tmpcmd, "perlglob ");
  1300.         sv_catsv(tmpcmd, tmpglob);
  1301.         sv_catpv(tmpcmd, " |");
  1302. #endif /* !DJGPP */
  1303. #endif /* !OS2 */
  1304. #else /* !DOSISH */
  1305. #if defined(CSH)
  1306.         sv_setpvn(tmpcmd, PL_cshname, PL_cshlen);
  1307.         sv_catpv(tmpcmd, " -cf 'set nonomatch; glob ");
  1308.         sv_catsv(tmpcmd, tmpglob);
  1309.         sv_catpv(tmpcmd, "' 2>/dev/null |");
  1310. #else
  1311.         sv_setpv(tmpcmd, "echo ");
  1312.         sv_catsv(tmpcmd, tmpglob);
  1313. #if 'z' - 'a' == 25
  1314.         sv_catpv(tmpcmd, "|tr -s ' \t\f\r' '\\012\\012\\012\\012'|");
  1315. #else
  1316.         sv_catpv(tmpcmd, "|tr -s ' \t\f\r' '\\n\\n\\n\\n'|");
  1317. #endif
  1318. #endif /* !CSH */
  1319. #endif /* !DOSISH */
  1320. #endif /* MACOS_TRADITIONAL */
  1321.         (void)do_open(PL_last_in_gv, SvPVX(tmpcmd), SvCUR(tmpcmd),
  1322.                   FALSE, O_RDONLY, 0, Nullfp);
  1323.         fp = IoIFP(io);
  1324. #endif /* !VMS */
  1325.         LEAVE;
  1326.         }
  1327.     }
  1328.     else if (type == OP_GLOB)
  1329.         SP--;
  1330.     else if (ckWARN(WARN_IO)    /* stdout/stderr or other write fh */
  1331.          && (IoTYPE(io) == '>' || fp == PerlIO_stdout()
  1332.              || fp == PerlIO_stderr()))
  1333.     {
  1334.         SV* sv = sv_newmortal();
  1335.         gv_efullname3(sv, PL_last_in_gv, Nullch);
  1336.         Perl_warner(aTHX_ WARN_IO, "Filehandle %s opened only for output",
  1337.             SvPV_nolen(sv));
  1338.     }
  1339.     }
  1340.     if (!fp) {
  1341.     if (ckWARN2(WARN_GLOB,WARN_CLOSED) && io && !(IoFLAGS(io) & IOf_START)) {
  1342.         if (type == OP_GLOB)
  1343.         Perl_warner(aTHX_ WARN_GLOB,
  1344.                 "glob failed (can't start child: %s)",
  1345.                 Strerror(errno));
  1346.         else
  1347.         report_closed_fh(PL_last_in_gv, io, "readline", "filehandle");
  1348.     }
  1349.     if (gimme == G_SCALAR) {
  1350.         (void)SvOK_off(TARG);
  1351.         PUSHTARG;
  1352.     }
  1353.     RETURN;
  1354.     }
  1355.   have_fp:
  1356.     if (gimme == G_SCALAR) {
  1357.     sv = TARG;
  1358.     if (SvROK(sv))
  1359.         sv_unref(sv);
  1360.     (void)SvUPGRADE(sv, SVt_PV);
  1361.     tmplen = SvLEN(sv);    /* remember if already alloced */
  1362.     if (!tmplen)
  1363.         Sv_Grow(sv, 80);    /* try short-buffering it */
  1364.     if (type == OP_RCATLINE)
  1365.         offset = SvCUR(sv);
  1366.     else
  1367.         offset = 0;
  1368.     }
  1369.     else {
  1370.     sv = sv_2mortal(NEWSV(57, 80));
  1371.     offset = 0;
  1372.     }
  1373.  
  1374. /* delay EOF state for a snarfed empty file */
  1375. #define SNARF_EOF(gimme,rs,io,sv) \
  1376.     (gimme != G_SCALAR || SvCUR(sv)                    \
  1377.      || !RsSNARF(rs) || (IoFLAGS(io) & IOf_NOLINE)            \
  1378.      || ((IoFLAGS(io) |= IOf_NOLINE), FALSE))
  1379.  
  1380.     for (;;) {
  1381.     if (!sv_gets(sv, fp, offset)
  1382.         && (type == OP_GLOB || SNARF_EOF(gimme, PL_rs, io, sv)))
  1383.     {
  1384.         PerlIO_clearerr(fp);
  1385.         if (IoFLAGS(io) & IOf_ARGV) {
  1386.         fp = nextargv(PL_last_in_gv);
  1387.         if (fp)
  1388.             continue;
  1389.         (void)do_close(PL_last_in_gv, FALSE);
  1390.         }
  1391.         else if (type == OP_GLOB) {
  1392.         if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_GLOB)) {
  1393.             Perl_warner(aTHX_ WARN_GLOB,
  1394.                "glob failed (child exited with status %d%s)",
  1395.                (int)(STATUS_CURRENT >> 8),
  1396.                (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
  1397.         }
  1398.         }
  1399.         if (gimme == G_SCALAR) {
  1400.         (void)SvOK_off(TARG);
  1401.         PUSHTARG;
  1402.         }
  1403.         RETURN;
  1404.     }
  1405.     /* This should not be marked tainted if the fp is marked clean */
  1406.     if (!(IoFLAGS(io) & IOf_UNTAINT)) {
  1407.         TAINT;
  1408.         SvTAINTED_on(sv);
  1409.     }
  1410.     IoLINES(io)++;
  1411.     SvSETMAGIC(sv);
  1412.     XPUSHs(sv);
  1413.     if (type == OP_GLOB) {
  1414.         char *tmps;
  1415.  
  1416.         if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
  1417.         tmps = SvEND(sv) - 1;
  1418.         if (*tmps == *SvPVX(PL_rs)) {
  1419.             *tmps = '\0';
  1420.             SvCUR(sv)--;
  1421.         }
  1422.         }
  1423.         for (tmps = SvPVX(sv); *tmps; tmps++)
  1424.         if (!isALPHA(*tmps) && !isDIGIT(*tmps) &&
  1425.             strchr("$&*(){}[]'\";\\|?<>~`", *tmps))
  1426.             break;
  1427.         if (*tmps && PerlLIO_lstat(SvPVX(sv), &PL_statbuf) < 0) {
  1428.         (void)POPs;        /* Unmatched wildcard?  Chuck it... */
  1429.         continue;
  1430.         }
  1431.     }
  1432.     if (gimme == G_ARRAY) {
  1433.         if (SvLEN(sv) - SvCUR(sv) > 20) {
  1434.         SvLEN_set(sv, SvCUR(sv)+1);
  1435.         Renew(SvPVX(sv), SvLEN(sv), char);
  1436.         }
  1437.         sv = sv_2mortal(NEWSV(58, 80));
  1438.         continue;
  1439.     }
  1440.     else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
  1441.         /* try to reclaim a bit of scalar space (only on 1st alloc) */
  1442.         if (SvCUR(sv) < 60)
  1443.         SvLEN_set(sv, 80);
  1444.         else
  1445.         SvLEN_set(sv, SvCUR(sv)+40);    /* allow some slop */
  1446.         Renew(SvPVX(sv), SvLEN(sv), char);
  1447.     }
  1448.     RETURN;
  1449.     }
  1450. }
  1451.  
  1452. PP(pp_enter)
  1453. {
  1454.     djSP;
  1455.     register PERL_CONTEXT *cx;
  1456.     I32 gimme = OP_GIMME(PL_op, -1);
  1457.  
  1458.     if (gimme == -1) {
  1459.     if (cxstack_ix >= 0)
  1460.         gimme = cxstack[cxstack_ix].blk_gimme;
  1461.     else
  1462.         gimme = G_SCALAR;
  1463.     }
  1464.  
  1465.     ENTER;
  1466.  
  1467.     SAVETMPS;
  1468.     PUSHBLOCK(cx, CXt_BLOCK, SP);
  1469.  
  1470.     RETURN;
  1471. }
  1472.  
  1473. PP(pp_helem)
  1474. {
  1475.     djSP;
  1476.     HE* he;
  1477.     SV **svp;
  1478.     SV *keysv = POPs;
  1479.     HV *hv = (HV*)POPs;
  1480.     U32 lval = PL_op->op_flags & OPf_MOD;
  1481.     U32 defer = PL_op->op_private & OPpLVAL_DEFER;
  1482.     SV *sv;
  1483.  
  1484.     if (SvTYPE(hv) == SVt_PVHV) {
  1485.     he = hv_fetch_ent(hv, keysv, lval && !defer, 0);
  1486.     svp = he ? &HeVAL(he) : 0;
  1487.     }
  1488.     else if (SvTYPE(hv) == SVt_PVAV) {
  1489.     if (PL_op->op_private & OPpLVAL_INTRO)
  1490.         DIE(aTHX_ "Can't localize pseudo-hash element");
  1491.     svp = avhv_fetch_ent((AV*)hv, keysv, lval && !defer, 0);
  1492.     }
  1493.     else {
  1494.     RETPUSHUNDEF;
  1495.     }
  1496.     if (lval) {
  1497.     if (!svp || *svp == &PL_sv_undef) {
  1498.         SV* lv;
  1499.         SV* key2;
  1500.         if (!defer) {
  1501.         STRLEN n_a;
  1502.         DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
  1503.         }
  1504.         lv = sv_newmortal();
  1505.         sv_upgrade(lv, SVt_PVLV);
  1506.         LvTYPE(lv) = 'y';
  1507.         sv_magic(lv, key2 = newSVsv(keysv), 'y', Nullch, 0);
  1508.         SvREFCNT_dec(key2);    /* sv_magic() increments refcount */
  1509.         LvTARG(lv) = SvREFCNT_inc(hv);
  1510.         LvTARGLEN(lv) = 1;
  1511.         PUSHs(lv);
  1512.         RETURN;
  1513.     }
  1514.     if (PL_op->op_private & OPpLVAL_INTRO) {
  1515.         if (HvNAME(hv) && isGV(*svp))
  1516.         save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
  1517.         else
  1518.         save_helem(hv, keysv, svp);
  1519.     }
  1520.     else if (PL_op->op_private & OPpDEREF)
  1521.         vivify_ref(*svp, PL_op->op_private & OPpDEREF);
  1522.     }
  1523.     sv = (svp ? *svp : &PL_sv_undef);
  1524.     /* This makes C<local $tied{foo} = $tied{foo}> possible.
  1525.      * Pushing the magical RHS on to the stack is useless, since
  1526.      * that magic is soon destined to be misled by the local(),
  1527.      * and thus the later pp_sassign() will fail to mg_get() the
  1528.      * old value.  This should also cure problems with delayed
  1529.      * mg_get()s.  GSAR 98-07-03 */
  1530.     if (!lval && SvGMAGICAL(sv))
  1531.     sv = sv_mortalcopy(sv);
  1532.     PUSHs(sv);
  1533.     RETURN;
  1534. }
  1535.  
  1536. PP(pp_leave)
  1537. {
  1538.     djSP;
  1539.     register PERL_CONTEXT *cx;
  1540.     register SV **mark;
  1541.     SV **newsp;
  1542.     PMOP *newpm;
  1543.     I32 gimme;
  1544.  
  1545.     if (PL_op->op_flags & OPf_SPECIAL) {
  1546.     cx = &cxstack[cxstack_ix];
  1547.     cx->blk_oldpm = PL_curpm;    /* fake block should preserve $1 et al */
  1548.     }
  1549.  
  1550.     POPBLOCK(cx,newpm);
  1551.  
  1552.     gimme = OP_GIMME(PL_op, -1);
  1553.     if (gimme == -1) {
  1554.     if (cxstack_ix >= 0)
  1555.         gimme = cxstack[cxstack_ix].blk_gimme;
  1556.     else
  1557.         gimme = G_SCALAR;
  1558.     }
  1559.  
  1560.     TAINT_NOT;
  1561.     if (gimme == G_VOID)
  1562.     SP = newsp;
  1563.     else if (gimme == G_SCALAR) {
  1564.     MARK = newsp + 1;
  1565.     if (MARK <= SP)
  1566.         if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
  1567.         *MARK = TOPs;
  1568.         else
  1569.         *MARK = sv_mortalcopy(TOPs);
  1570.     else {
  1571.         MEXTEND(mark,0);
  1572.         *MARK = &PL_sv_undef;
  1573.     }
  1574.     SP = MARK;
  1575.     }
  1576.     else if (gimme == G_ARRAY) {
  1577.     /* in case LEAVE wipes old return values */
  1578.     for (mark = newsp + 1; mark <= SP; mark++) {
  1579.         if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
  1580.         *mark = sv_mortalcopy(*mark);
  1581.         TAINT_NOT;    /* Each item is independent */
  1582.         }
  1583.     }
  1584.     }
  1585.     PL_curpm = newpm;    /* Don't pop $1 et al till now */
  1586.  
  1587.     LEAVE;
  1588.  
  1589.     RETURN;
  1590. }
  1591.  
  1592. PP(pp_iter)
  1593. {
  1594.     djSP;
  1595.     register PERL_CONTEXT *cx;
  1596.     SV* sv;
  1597.     AV* av;
  1598.     SV **itersvp;
  1599.  
  1600.     EXTEND(SP, 1);
  1601.     cx = &cxstack[cxstack_ix];
  1602.     if (CxTYPE(cx) != CXt_LOOP)
  1603.     DIE(aTHX_ "panic: pp_iter");
  1604.  
  1605.     itersvp = CxITERVAR(cx);
  1606.     av = cx->blk_loop.iterary;
  1607.     if (SvTYPE(av) != SVt_PVAV) {
  1608.     /* iterate ($min .. $max) */
  1609.     if (cx->blk_loop.iterlval) {
  1610.         /* string increment */
  1611.         register SV* cur = cx->blk_loop.iterlval;
  1612.         STRLEN maxlen;
  1613.         char *max = SvPV((SV*)av, maxlen);
  1614.         if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
  1615. #ifndef USE_THREADS              /* don't risk potential race */
  1616.         if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
  1617.             /* safe to reuse old SV */
  1618.             sv_setsv(*itersvp, cur);
  1619.         }
  1620.         else 
  1621. #endif
  1622.         {
  1623.             /* we need a fresh SV every time so that loop body sees a
  1624.              * completely new SV for closures/references to work as
  1625.              * they used to */
  1626.             SvREFCNT_dec(*itersvp);
  1627.             *itersvp = newSVsv(cur);
  1628.         }
  1629.         if (strEQ(SvPVX(cur), max))
  1630.             sv_setiv(cur, 0); /* terminate next time */
  1631.         else
  1632.             sv_inc(cur);
  1633.         RETPUSHYES;
  1634.         }
  1635.         RETPUSHNO;
  1636.     }
  1637.     /* integer increment */
  1638.     if (cx->blk_loop.iterix > cx->blk_loop.itermax)
  1639.         RETPUSHNO;
  1640.  
  1641. #ifndef USE_THREADS              /* don't risk potential race */
  1642.     if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
  1643.         /* safe to reuse old SV */
  1644.         sv_setiv(*itersvp, cx->blk_loop.iterix++);
  1645.     }
  1646.     else 
  1647. #endif
  1648.     {
  1649.         /* we need a fresh SV every time so that loop body sees a
  1650.          * completely new SV for closures/references to work as they
  1651.          * used to */
  1652.         SvREFCNT_dec(*itersvp);
  1653.         *itersvp = newSViv(cx->blk_loop.iterix++);
  1654.     }
  1655.     RETPUSHYES;
  1656.     }
  1657.  
  1658.     /* iterate array */
  1659.     if (cx->blk_loop.iterix >= (av == PL_curstack ? cx->blk_oldsp : AvFILL(av)))
  1660.     RETPUSHNO;
  1661.  
  1662.     SvREFCNT_dec(*itersvp);
  1663.  
  1664.     if ((sv = SvMAGICAL(av)
  1665.           ? *av_fetch(av, ++cx->blk_loop.iterix, FALSE) 
  1666.           : AvARRAY(av)[++cx->blk_loop.iterix]))
  1667.     SvTEMP_off(sv);
  1668.     else
  1669.     sv = &PL_sv_undef;
  1670.     if (av != PL_curstack && SvIMMORTAL(sv)) {
  1671.     SV *lv = cx->blk_loop.iterlval;
  1672.     if (lv && SvREFCNT(lv) > 1) {
  1673.         SvREFCNT_dec(lv);
  1674.         lv = Nullsv;
  1675.     }
  1676.     if (lv)
  1677.         SvREFCNT_dec(LvTARG(lv));
  1678.     else {
  1679.         lv = cx->blk_loop.iterlval = NEWSV(26, 0);
  1680.         sv_upgrade(lv, SVt_PVLV);
  1681.         LvTYPE(lv) = 'y';
  1682.         sv_magic(lv, Nullsv, 'y', Nullch, 0);
  1683.     }
  1684.     LvTARG(lv) = SvREFCNT_inc(av);
  1685.     LvTARGOFF(lv) = cx->blk_loop.iterix;
  1686.     LvTARGLEN(lv) = (STRLEN)UV_MAX;
  1687.     sv = (SV*)lv;
  1688.     }
  1689.  
  1690.     *itersvp = SvREFCNT_inc(sv);
  1691.     RETPUSHYES;
  1692. }
  1693.  
  1694. PP(pp_subst)
  1695. {
  1696.     djSP; dTARG;
  1697.     register PMOP *pm = cPMOP;
  1698.     PMOP *rpm = pm;
  1699.     register SV *dstr;
  1700.     register char *s;
  1701.     char *strend;
  1702.     register char *m;
  1703.     char *c;
  1704.     register char *d;
  1705.     STRLEN clen;
  1706.     I32 iters = 0;
  1707.     I32 maxiters;
  1708.     register I32 i;
  1709.     bool once;
  1710.     bool rxtainted;
  1711.     char *orig;
  1712.     I32 r_flags;
  1713.     register REGEXP *rx = pm->op_pmregexp;
  1714.     STRLEN len;
  1715.     int force_on_match = 0;
  1716.     I32 oldsave = PL_savestack_ix;
  1717.  
  1718.     /* known replacement string? */
  1719.     dstr = (pm->op_pmflags & PMf_CONST) ? POPs : Nullsv;
  1720.     if (PL_op->op_flags & OPf_STACKED)
  1721.     TARG = POPs;
  1722.     else {
  1723.     TARG = DEFSV;
  1724.     EXTEND(SP,1);
  1725.     }                  
  1726.     if (SvREADONLY(TARG)
  1727.     || (SvTYPE(TARG) > SVt_PVLV
  1728.         && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG))))
  1729.     DIE(aTHX_ PL_no_modify);
  1730.     PUTBACK;
  1731.  
  1732.     s = SvPV(TARG, len);
  1733.     if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
  1734.     force_on_match = 1;
  1735.     rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
  1736.          (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
  1737.     if (PL_tainted)
  1738.     rxtainted |= 2;
  1739.     TAINT_NOT;
  1740.  
  1741.   force_it:
  1742.     if (!pm || !s)
  1743.     DIE(aTHX_ "panic: do_subst");
  1744.  
  1745.     strend = s + len;
  1746.     maxiters = 2*(strend - s) + 10;    /* We can match twice at each 
  1747.                        position, once with zero-length,
  1748.                        second time with non-zero. */
  1749.  
  1750.     if (!rx->prelen && PL_curpm) {
  1751.     pm = PL_curpm;
  1752.     rx = pm->op_pmregexp;
  1753.     }
  1754.     r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand)
  1755.         ? REXEC_COPY_STR : 0;
  1756.     if (SvSCREAM(TARG))
  1757.     r_flags |= REXEC_SCREAM;
  1758.     if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
  1759.     SAVEINT(PL_multiline);
  1760.     PL_multiline = pm->op_pmflags & PMf_MULTILINE;
  1761.     }
  1762.     orig = m = s;
  1763.     if (rx->reganch & RE_USE_INTUIT) {
  1764.     s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
  1765.  
  1766.     if (!s)
  1767.         goto nope;
  1768.     /* How to do it in subst? */
  1769. /*    if ( (rx->reganch & ROPT_CHECK_ALL)
  1770.          && !PL_sawampersand 
  1771.          && ((rx->reganch & ROPT_NOSCAN)
  1772.          || !((rx->reganch & RE_INTUIT_TAIL)
  1773.               && (r_flags & REXEC_SCREAM))))
  1774.         goto yup;
  1775. */
  1776.     }
  1777.  
  1778.     /* only replace once? */
  1779.     once = !(rpm->op_pmflags & PMf_GLOBAL);
  1780.  
  1781.     /* known replacement string? */
  1782.     c = dstr ? SvPV(dstr, clen) : Nullch;
  1783.  
  1784.     /* can do inplace substitution? */
  1785.     if (c && clen <= rx->minlen && (once || !(r_flags & REXEC_COPY_STR))
  1786.     && !(rx->reganch & ROPT_LOOKBEHIND_SEEN)) {
  1787.     if (!CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
  1788.              r_flags | REXEC_CHECKED))
  1789.     {
  1790.         SPAGAIN;
  1791.         PUSHs(&PL_sv_no);
  1792.         LEAVE_SCOPE(oldsave);
  1793.         RETURN;
  1794.     }
  1795.     if (force_on_match) {
  1796.         force_on_match = 0;
  1797.         s = SvPV_force(TARG, len);
  1798.         goto force_it;
  1799.     }
  1800.     d = s;
  1801.     PL_curpm = pm;
  1802.     SvSCREAM_off(TARG);    /* disable possible screamer */
  1803.     if (once) {
  1804.         rxtainted |= RX_MATCH_TAINTED(rx);
  1805.         m = orig + rx->startp[0];
  1806.         d = orig + rx->endp[0];
  1807.         s = orig;
  1808.         if (m - s > strend - d) {  /* faster to shorten from end */
  1809.         if (clen) {
  1810.             Copy(c, m, clen, char);
  1811.             m += clen;
  1812.         }
  1813.         i = strend - d;
  1814.         if (i > 0) {
  1815.             Move(d, m, i, char);
  1816.             m += i;
  1817.         }
  1818.         *m = '\0';
  1819.         SvCUR_set(TARG, m - s);
  1820.         }
  1821.         /*SUPPRESS 560*/
  1822.         else if ((i = m - s)) {    /* faster from front */
  1823.         d -= clen;
  1824.         m = d;
  1825.         sv_chop(TARG, d-i);
  1826.         s += i;
  1827.         while (i--)
  1828.             *--d = *--s;
  1829.         if (clen)
  1830.             Copy(c, m, clen, char);
  1831.         }
  1832.         else if (clen) {
  1833.         d -= clen;
  1834.         sv_chop(TARG, d);
  1835.         Copy(c, d, clen, char);
  1836.         }
  1837.         else {
  1838.         sv_chop(TARG, d);
  1839.         }
  1840.         TAINT_IF(rxtainted & 1);
  1841.         SPAGAIN;
  1842.         PUSHs(&PL_sv_yes);
  1843.     }
  1844.     else {
  1845.         do {
  1846.         if (iters++ > maxiters)
  1847.             DIE(aTHX_ "Substitution loop");
  1848.         rxtainted |= RX_MATCH_TAINTED(rx);
  1849.         m = rx->startp[0] + orig;
  1850.         /*SUPPRESS 560*/
  1851.         if ((i = m - s)) {
  1852.             if (s != d)
  1853.             Move(s, d, i, char);
  1854.             d += i;
  1855.         }
  1856.         if (clen) {
  1857.             Copy(c, d, clen, char);
  1858.             d += clen;
  1859.         }
  1860.         s = rx->endp[0] + orig;
  1861.         } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
  1862.                  TARG, NULL,
  1863.                  /* don't match same null twice */
  1864.                  REXEC_NOT_FIRST|REXEC_IGNOREPOS));
  1865.         if (s != d) {
  1866.         i = strend - s;
  1867.         SvCUR_set(TARG, d - SvPVX(TARG) + i);
  1868.         Move(s, d, i+1, char);        /* include the NUL */
  1869.         }
  1870.         TAINT_IF(rxtainted & 1);
  1871.         SPAGAIN;
  1872.         PUSHs(sv_2mortal(newSViv((I32)iters)));
  1873.     }
  1874.     (void)SvPOK_only(TARG);
  1875.     TAINT_IF(rxtainted);
  1876.     if (SvSMAGICAL(TARG)) {
  1877.         PUTBACK;
  1878.         mg_set(TARG);
  1879.         SPAGAIN;
  1880.     }
  1881.     SvTAINT(TARG);
  1882.     LEAVE_SCOPE(oldsave);
  1883.     RETURN;
  1884.     }
  1885.  
  1886.     if (CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
  1887.             r_flags | REXEC_CHECKED))
  1888.     {
  1889.     if (force_on_match) {
  1890.         force_on_match = 0;
  1891.         s = SvPV_force(TARG, len);
  1892.         goto force_it;
  1893.     }
  1894.     rxtainted |= RX_MATCH_TAINTED(rx);
  1895.     dstr = NEWSV(25, len);
  1896.     sv_setpvn(dstr, m, s-m);
  1897.     PL_curpm = pm;
  1898.     if (!c) {
  1899.         register PERL_CONTEXT *cx;
  1900.         SPAGAIN;
  1901.         PUSHSUBST(cx);
  1902.         RETURNOP(cPMOP->op_pmreplroot);
  1903.     }
  1904.     r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
  1905.     do {
  1906.         if (iters++ > maxiters)
  1907.         DIE(aTHX_ "Substitution loop");
  1908.         rxtainted |= RX_MATCH_TAINTED(rx);
  1909.         if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
  1910.         m = s;
  1911.         s = orig;
  1912.         orig = rx->subbeg;
  1913.         s = orig + (m - s);
  1914.         strend = s + (strend - m);
  1915.         }
  1916.         m = rx->startp[0] + orig;
  1917.         sv_catpvn(dstr, s, m-s);
  1918.         s = rx->endp[0] + orig;
  1919.         if (clen)
  1920.         sv_catpvn(dstr, c, clen);
  1921.         if (once)
  1922.         break;
  1923.     } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m, TARG, NULL, r_flags));
  1924.     sv_catpvn(dstr, s, strend - s);
  1925.  
  1926.     (void)SvOOK_off(TARG);
  1927.     Safefree(SvPVX(TARG));
  1928.     SvPVX(TARG) = SvPVX(dstr);
  1929.     SvCUR_set(TARG, SvCUR(dstr));
  1930.     SvLEN_set(TARG, SvLEN(dstr));
  1931.     SvPVX(dstr) = 0;
  1932.     sv_free(dstr);
  1933.  
  1934.     TAINT_IF(rxtainted & 1);
  1935.     SPAGAIN;
  1936.     PUSHs(sv_2mortal(newSViv((I32)iters)));
  1937.  
  1938.     (void)SvPOK_only(TARG);
  1939.     TAINT_IF(rxtainted);
  1940.     SvSETMAGIC(TARG);
  1941.     SvTAINT(TARG);
  1942.     LEAVE_SCOPE(oldsave);
  1943.     RETURN;
  1944.     }
  1945.     goto ret_no;
  1946.  
  1947. nope:
  1948. ret_no:         
  1949.     SPAGAIN;
  1950.     PUSHs(&PL_sv_no);
  1951.     LEAVE_SCOPE(oldsave);
  1952.     RETURN;
  1953. }
  1954.  
  1955. PP(pp_grepwhile)
  1956. {
  1957.     djSP;
  1958.  
  1959.     if (SvTRUEx(POPs))
  1960.     PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
  1961.     ++*PL_markstack_ptr;
  1962.     LEAVE;                    /* exit inner scope */
  1963.  
  1964.     /* All done yet? */
  1965.     if (PL_stack_base + *PL_markstack_ptr > SP) {
  1966.     I32 items;
  1967.     I32 gimme = GIMME_V;
  1968.  
  1969.     LEAVE;                    /* exit outer scope */
  1970.     (void)POPMARK;                /* pop src */
  1971.     items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
  1972.     (void)POPMARK;                /* pop dst */
  1973.     SP = PL_stack_base + POPMARK;        /* pop original mark */
  1974.     if (gimme == G_SCALAR) {
  1975.         dTARGET;
  1976.         XPUSHi(items);
  1977.     }
  1978.     else if (gimme == G_ARRAY)
  1979.         SP += items;
  1980.     RETURN;
  1981.     }
  1982.     else {
  1983.     SV *src;
  1984.  
  1985.     ENTER;                    /* enter inner scope */
  1986.     SAVEVPTR(PL_curpm);
  1987.  
  1988.     src = PL_stack_base[*PL_markstack_ptr];
  1989.     SvTEMP_off(src);
  1990.     DEFSV = src;
  1991.  
  1992.     RETURNOP(cLOGOP->op_other);
  1993.     }
  1994. }
  1995.  
  1996. PP(pp_leavesub)
  1997. {
  1998.     djSP;
  1999.     SV **mark;
  2000.     SV **newsp;
  2001.     PMOP *newpm;
  2002.     I32 gimme;
  2003.     register PERL_CONTEXT *cx;
  2004.     SV *sv;
  2005.  
  2006.     POPBLOCK(cx,newpm);
  2007.  
  2008.     TAINT_NOT;
  2009.     if (gimme == G_SCALAR) {
  2010.     MARK = newsp + 1;
  2011.     if (MARK <= SP) {
  2012.         if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
  2013.         if (SvTEMP(TOPs)) {
  2014.             *MARK = SvREFCNT_inc(TOPs);
  2015.             FREETMPS;
  2016.             sv_2mortal(*MARK);
  2017.         }
  2018.         else {
  2019.             sv = SvREFCNT_inc(TOPs);    /* FREETMPS could clobber it */
  2020.             FREETMPS;
  2021.             *MARK = sv_mortalcopy(sv);
  2022.             SvREFCNT_dec(sv);
  2023.         }
  2024.         }
  2025.         else
  2026.         *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
  2027.     }
  2028.     else {
  2029.         MEXTEND(MARK, 0);
  2030.         *MARK = &PL_sv_undef;
  2031.     }
  2032.     SP = MARK;
  2033.     }
  2034.     else if (gimme == G_ARRAY) {
  2035.     for (MARK = newsp + 1; MARK <= SP; MARK++) {
  2036.         if (!SvTEMP(*MARK)) {
  2037.         *MARK = sv_mortalcopy(*MARK);
  2038.         TAINT_NOT;    /* Each item is independent */
  2039.         }
  2040.     }
  2041.     }
  2042.     PUTBACK;
  2043.     
  2044.     POPSUB(cx,sv);    /* Stack values are safe: release CV and @_ ... */
  2045.     PL_curpm = newpm;    /* ... and pop $1 et al */
  2046.  
  2047.     LEAVE;
  2048.     LEAVESUB(sv);
  2049.     return pop_return();
  2050. }
  2051.  
  2052. /* This duplicates the above code because the above code must not
  2053.  * get any slower by more conditions */
  2054. PP(pp_leavesublv)
  2055. {
  2056.     djSP;
  2057.     SV **mark;
  2058.     SV **newsp;
  2059.     PMOP *newpm;
  2060.     I32 gimme;
  2061.     register PERL_CONTEXT *cx;
  2062.     SV *sv;
  2063.  
  2064.     POPBLOCK(cx,newpm);
  2065.  
  2066.     TAINT_NOT;
  2067.  
  2068.     if (cx->blk_sub.lval & OPpENTERSUB_INARGS) {
  2069.     /* We are an argument to a function or grep().
  2070.      * This kind of lvalueness was legal before lvalue
  2071.      * subroutines too, so be backward compatible:
  2072.      * cannot report errors.  */
  2073.  
  2074.     /* Scalar context *is* possible, on the LHS of -> only,
  2075.      * as in f()->meth().  But this is not an lvalue. */
  2076.     if (gimme == G_SCALAR)
  2077.         goto temporise;
  2078.     if (gimme == G_ARRAY) {
  2079.         if (!CvLVALUE(cx->blk_sub.cv))
  2080.         goto temporise_array;
  2081.         EXTEND_MORTAL(SP - newsp);
  2082.         for (mark = newsp + 1; mark <= SP; mark++) {
  2083.         if (SvTEMP(*mark))
  2084.             /* empty */ ;
  2085.         else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
  2086.             *mark = sv_mortalcopy(*mark);
  2087.         else {
  2088.             /* Can be a localized value subject to deletion. */
  2089.             PL_tmps_stack[++PL_tmps_ix] = *mark;
  2090.             (void)SvREFCNT_inc(*mark);
  2091.         }
  2092.         }
  2093.     }
  2094.     }
  2095.     else if (cx->blk_sub.lval) {     /* Leave it as it is if we can. */
  2096.     /* Here we go for robustness, not for speed, so we change all
  2097.      * the refcounts so the caller gets a live guy. Cannot set
  2098.      * TEMP, so sv_2mortal is out of question. */
  2099.     if (!CvLVALUE(cx->blk_sub.cv)) {
  2100.         POPSUB(cx,sv);
  2101.         PL_curpm = newpm;
  2102.         LEAVE;
  2103.         LEAVESUB(sv);
  2104.         DIE(aTHX_ "Can't modify non-lvalue subroutine call");
  2105.     }
  2106.     if (gimme == G_SCALAR) {
  2107.         MARK = newsp + 1;
  2108.         EXTEND_MORTAL(1);
  2109.         if (MARK == SP) {
  2110.         if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
  2111.             POPSUB(cx,sv);
  2112.             PL_curpm = newpm;
  2113.             LEAVE;
  2114.             LEAVESUB(sv);
  2115.             DIE(aTHX_ "Can't return a %s from lvalue subroutine",
  2116.             SvREADONLY(TOPs) ? "readonly value" : "temporary");
  2117.         }
  2118.         else {                  /* Can be a localized value
  2119.                      * subject to deletion. */
  2120.             PL_tmps_stack[++PL_tmps_ix] = *mark;
  2121.             (void)SvREFCNT_inc(*mark);
  2122.         }
  2123.         }
  2124.         else {            /* Should not happen? */
  2125.         POPSUB(cx,sv);
  2126.         PL_curpm = newpm;
  2127.         LEAVE;
  2128.         LEAVESUB(sv);
  2129.         DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
  2130.             (MARK > SP ? "Empty array" : "Array"));
  2131.         }
  2132.         SP = MARK;
  2133.     }
  2134.     else if (gimme == G_ARRAY) {
  2135.         EXTEND_MORTAL(SP - newsp);
  2136.         for (mark = newsp + 1; mark <= SP; mark++) {
  2137.         if (SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
  2138.             /* Might be flattened array after $#array =  */
  2139.             PUTBACK;
  2140.             POPSUB(cx,sv);
  2141.             PL_curpm = newpm;
  2142.             LEAVE;
  2143.             LEAVESUB(sv);
  2144.             DIE(aTHX_ "Can't return %s from lvalue subroutine",
  2145.             (*mark != &PL_sv_undef)
  2146.             ? (SvREADONLY(TOPs)
  2147.                 ? "a readonly value" : "a temporary")
  2148.             : "an uninitialized value");
  2149.         }
  2150.         else {
  2151.             /* Can be a localized value subject to deletion. */
  2152.             PL_tmps_stack[++PL_tmps_ix] = *mark;
  2153.             (void)SvREFCNT_inc(*mark);
  2154.         }
  2155.         }
  2156.     }
  2157.     }
  2158.     else {
  2159.     if (gimme == G_SCALAR) {
  2160.       temporise:
  2161.         MARK = newsp + 1;
  2162.         if (MARK <= SP) {
  2163.         if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
  2164.             if (SvTEMP(TOPs)) {
  2165.             *MARK = SvREFCNT_inc(TOPs);
  2166.             FREETMPS;
  2167.             sv_2mortal(*MARK);
  2168.             }
  2169.             else {
  2170.             sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
  2171.             FREETMPS;
  2172.             *MARK = sv_mortalcopy(sv);
  2173.             SvREFCNT_dec(sv);
  2174.             }
  2175.         }
  2176.         else
  2177.             *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
  2178.         }
  2179.         else {
  2180.         MEXTEND(MARK, 0);
  2181.         *MARK = &PL_sv_undef;
  2182.         }
  2183.         SP = MARK;
  2184.     }
  2185.     else if (gimme == G_ARRAY) {
  2186.       temporise_array:
  2187.         for (MARK = newsp + 1; MARK <= SP; MARK++) {
  2188.         if (!SvTEMP(*MARK)) {
  2189.             *MARK = sv_mortalcopy(*MARK);
  2190.             TAINT_NOT;  /* Each item is independent */
  2191.         }
  2192.         }
  2193.     }
  2194.     }
  2195.     PUTBACK;
  2196.     
  2197.     POPSUB(cx,sv);    /* Stack values are safe: release CV and @_ ... */
  2198.     PL_curpm = newpm;    /* ... and pop $1 et al */
  2199.  
  2200.     LEAVE;
  2201.     LEAVESUB(sv);
  2202.     return pop_return();
  2203. }
  2204.  
  2205.  
  2206. STATIC CV *
  2207. S_get_db_sub(pTHX_ SV **svp, CV *cv)
  2208. {
  2209.     dTHR;
  2210.     SV *dbsv = GvSV(PL_DBsub);
  2211.  
  2212.     if (!PERLDB_SUB_NN) {
  2213.     GV *gv = CvGV(cv);
  2214.  
  2215.     save_item(dbsv);
  2216.     if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
  2217.          || strEQ(GvNAME(gv), "END") 
  2218.          || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
  2219.          !( (SvTYPE(*svp) == SVt_PVGV) && (GvCV((GV*)*svp) == cv)
  2220.             && (gv = (GV*)*svp) ))) {
  2221.         /* Use GV from the stack as a fallback. */
  2222.         /* GV is potentially non-unique, or contain different CV. */
  2223.         sv_setsv(dbsv, newRV((SV*)cv));
  2224.     }
  2225.     else {
  2226.         gv_efullname3(dbsv, gv, Nullch);
  2227.     }
  2228.     }
  2229.     else {
  2230.     (void)SvUPGRADE(dbsv, SVt_PVIV);
  2231.     (void)SvIOK_on(dbsv);
  2232.     SAVEIV(SvIVX(dbsv));
  2233.     SvIVX(dbsv) = PTR2IV(cv);    /* Do it the quickest way  */
  2234.     }
  2235.  
  2236.     if (CvXSUB(cv))
  2237.     PL_curcopdb = PL_curcop;
  2238.     cv = GvCV(PL_DBsub);
  2239.     return cv;
  2240. }
  2241.  
  2242. PP(pp_entersub)
  2243. {
  2244.     djSP; dPOPss;
  2245.     GV *gv;
  2246.     HV *stash;
  2247.     register CV *cv;
  2248.     register PERL_CONTEXT *cx;
  2249.     I32 gimme;
  2250.     bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
  2251.  
  2252.     if (!sv)
  2253.     DIE(aTHX_ "Not a CODE reference");
  2254.     switch (SvTYPE(sv)) {
  2255.     default:
  2256.     if (!SvROK(sv)) {
  2257.         char *sym;
  2258.         STRLEN n_a;
  2259.  
  2260.         if (sv == &PL_sv_yes) {        /* unfound import, ignore */
  2261.         if (hasargs)
  2262.             SP = PL_stack_base + POPMARK;
  2263.         RETURN;
  2264.         }
  2265.         if (SvGMAGICAL(sv)) {
  2266.         mg_get(sv);
  2267.         sym = SvPOKp(sv) ? SvPVX(sv) : Nullch;
  2268.         }
  2269.         else
  2270.         sym = SvPV(sv, n_a);
  2271.         if (!sym)
  2272.         DIE(aTHX_ PL_no_usym, "a subroutine");
  2273.         if (PL_op->op_private & HINT_STRICT_REFS)
  2274.         DIE(aTHX_ PL_no_symref, sym, "a subroutine");
  2275.         cv = get_cv(sym, TRUE);
  2276.         break;
  2277.     }
  2278.     {
  2279.         SV **sp = &sv;        /* Used in tryAMAGICunDEREF macro. */
  2280.         tryAMAGICunDEREF(to_cv);
  2281.     }    
  2282.     cv = (CV*)SvRV(sv);
  2283.     if (SvTYPE(cv) == SVt_PVCV)
  2284.         break;
  2285.     /* FALL THROUGH */
  2286.     case SVt_PVHV:
  2287.     case SVt_PVAV:
  2288.     DIE(aTHX_ "Not a CODE reference");
  2289.     case SVt_PVCV:
  2290.     cv = (CV*)sv;
  2291.     break;
  2292.     case SVt_PVGV:
  2293.     if (!(cv = GvCVu((GV*)sv)))
  2294.         cv = sv_2cv(sv, &stash, &gv, FALSE);
  2295.     if (!cv) {
  2296.         ENTER;
  2297.         SAVETMPS;
  2298.         goto try_autoload;
  2299.     }
  2300.     break;
  2301.     }
  2302.  
  2303.     ENTER;
  2304.     SAVETMPS;
  2305.  
  2306.   retry:
  2307.     if (!CvROOT(cv) && !CvXSUB(cv)) {
  2308.     GV* autogv;
  2309.     SV* sub_name;
  2310.  
  2311.     /* anonymous or undef'd function leaves us no recourse */
  2312.     if (CvANON(cv) || !(gv = CvGV(cv)))
  2313.         DIE(aTHX_ "Undefined subroutine called");
  2314.  
  2315.     /* autoloaded stub? */
  2316.     if (cv != GvCV(gv)) {
  2317.         cv = GvCV(gv);
  2318.     }
  2319.     /* should call AUTOLOAD now? */
  2320.     else {
  2321. try_autoload:
  2322.         if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
  2323.                    FALSE)))
  2324.         {
  2325.         cv = GvCV(autogv);
  2326.         }
  2327.         /* sorry */
  2328.         else {
  2329.         sub_name = sv_newmortal();
  2330.         gv_efullname3(sub_name, gv, Nullch);
  2331.         DIE(aTHX_ "Undefined subroutine &%s called", SvPVX(sub_name));
  2332.         }
  2333.     }
  2334.     if (!cv)
  2335.         DIE(aTHX_ "Not a CODE reference");
  2336.     goto retry;
  2337.     }
  2338.  
  2339.     gimme = GIMME_V;
  2340.     if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
  2341.     cv = get_db_sub(&sv, cv);
  2342.     if (!cv)
  2343.         DIE(aTHX_ "No DBsub routine");
  2344.     }
  2345.  
  2346. #ifdef USE_THREADS
  2347.     /*
  2348.      * First we need to check if the sub or method requires locking.
  2349.      * If so, we gain a lock on the CV, the first argument or the
  2350.      * stash (for static methods), as appropriate. This has to be
  2351.      * inline because for FAKE_THREADS, COND_WAIT inlines code to
  2352.      * reschedule by returning a new op.
  2353.      */
  2354.     MUTEX_LOCK(CvMUTEXP(cv));
  2355.     if (CvFLAGS(cv) & CVf_LOCKED) {
  2356.     MAGIC *mg;    
  2357.     if (CvFLAGS(cv) & CVf_METHOD) {
  2358.         if (SP > PL_stack_base + TOPMARK)
  2359.         sv = *(PL_stack_base + TOPMARK + 1);
  2360.         else {
  2361.         AV *av = (AV*)PL_curpad[0];
  2362.         if (hasargs || !av || AvFILLp(av) < 0
  2363.             || !(sv = AvARRAY(av)[0]))
  2364.         {
  2365.             MUTEX_UNLOCK(CvMUTEXP(cv));
  2366.             DIE(aTHX_ "no argument for locked method call");
  2367.         }
  2368.         }
  2369.         if (SvROK(sv))
  2370.         sv = SvRV(sv);
  2371.         else {        
  2372.         STRLEN len;
  2373.         char *stashname = SvPV(sv, len);
  2374.         sv = (SV*)gv_stashpvn(stashname, len, TRUE);
  2375.         }
  2376.     }
  2377.     else {
  2378.         sv = (SV*)cv;
  2379.     }
  2380.     MUTEX_UNLOCK(CvMUTEXP(cv));
  2381.     mg = condpair_magic(sv);
  2382.     MUTEX_LOCK(MgMUTEXP(mg));
  2383.     if (MgOWNER(mg) == thr)
  2384.         MUTEX_UNLOCK(MgMUTEXP(mg));
  2385.     else {
  2386.         while (MgOWNER(mg))
  2387.         COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
  2388.         MgOWNER(mg) = thr;
  2389.         DEBUG_S(PerlIO_printf(Perl_debug_log, "%p: pp_entersub lock %p\n",
  2390.                   thr, sv);)
  2391.         MUTEX_UNLOCK(MgMUTEXP(mg));
  2392.         SAVEDESTRUCTOR_X(Perl_unlock_condpair, sv);
  2393.     }
  2394.     MUTEX_LOCK(CvMUTEXP(cv));
  2395.     }
  2396.     /*
  2397.      * Now we have permission to enter the sub, we must distinguish
  2398.      * four cases. (0) It's an XSUB (in which case we don't care
  2399.      * about ownership); (1) it's ours already (and we're recursing);
  2400.      * (2) it's free (but we may already be using a cached clone);
  2401.      * (3) another thread owns it. Case (1) is easy: we just use it.
  2402.      * Case (2) means we look for a clone--if we have one, use it
  2403.      * otherwise grab ownership of cv. Case (3) means we look for a
  2404.      * clone (for non-XSUBs) and have to create one if we don't
  2405.      * already have one.
  2406.      * Why look for a clone in case (2) when we could just grab
  2407.      * ownership of cv straight away? Well, we could be recursing,
  2408.      * i.e. we originally tried to enter cv while another thread
  2409.      * owned it (hence we used a clone) but it has been freed up
  2410.      * and we're now recursing into it. It may or may not be "better"
  2411.      * to use the clone but at least CvDEPTH can be trusted.
  2412.      */
  2413.     if (CvOWNER(cv) == thr || CvXSUB(cv))
  2414.     MUTEX_UNLOCK(CvMUTEXP(cv));
  2415.     else {
  2416.     /* Case (2) or (3) */
  2417.     SV **svp;
  2418.     
  2419.     /*
  2420.      * XXX Might it be better to release CvMUTEXP(cv) while we
  2421.           * do the hv_fetch? We might find someone has pinched it
  2422.           * when we look again, in which case we would be in case
  2423.           * (3) instead of (2) so we'd have to clone. Would the fact
  2424.           * that we released the mutex more quickly make up for this?
  2425.           */
  2426.     if ((svp = hv_fetch(thr->cvcache, (char *)cv, sizeof(cv), FALSE)))
  2427.     {
  2428.         /* We already have a clone to use */
  2429.         MUTEX_UNLOCK(CvMUTEXP(cv));
  2430.         cv = *(CV**)svp;
  2431.         DEBUG_S(PerlIO_printf(Perl_debug_log,
  2432.                   "entersub: %p already has clone %p:%s\n",
  2433.                   thr, cv, SvPEEK((SV*)cv)));
  2434.         CvOWNER(cv) = thr;
  2435.         SvREFCNT_inc(cv);
  2436.         if (CvDEPTH(cv) == 0)
  2437.         SAVEDESTRUCTOR_X(unset_cvowner, (void*) cv);
  2438.     }
  2439.     else {
  2440.         /* (2) => grab ownership of cv. (3) => make clone */
  2441.         if (!CvOWNER(cv)) {
  2442.         CvOWNER(cv) = thr;
  2443.         SvREFCNT_inc(cv);
  2444.         MUTEX_UNLOCK(CvMUTEXP(cv));
  2445.         DEBUG_S(PerlIO_printf(Perl_debug_log,
  2446.                 "entersub: %p grabbing %p:%s in stash %s\n",
  2447.                 thr, cv, SvPEEK((SV*)cv), CvSTASH(cv) ?
  2448.                     HvNAME(CvSTASH(cv)) : "(none)"));
  2449.         }
  2450.         else {
  2451.         /* Make a new clone. */
  2452.         CV *clonecv;
  2453.         SvREFCNT_inc(cv); /* don't let it vanish from under us */
  2454.         MUTEX_UNLOCK(CvMUTEXP(cv));
  2455.         DEBUG_S((PerlIO_printf(Perl_debug_log,
  2456.                        "entersub: %p cloning %p:%s\n",
  2457.                        thr, cv, SvPEEK((SV*)cv))));
  2458.         /*
  2459.              * We're creating a new clone so there's no race
  2460.          * between the original MUTEX_UNLOCK and the
  2461.          * SvREFCNT_inc since no one will be trying to undef
  2462.          * it out from underneath us. At least, I don't think
  2463.          * there's a race...
  2464.          */
  2465.              clonecv = cv_clone(cv);
  2466.             SvREFCNT_dec(cv); /* finished with this */
  2467.         hv_store(thr->cvcache, (char*)cv, sizeof(cv), (SV*)clonecv,0);
  2468.         CvOWNER(clonecv) = thr;
  2469.         cv = clonecv;
  2470.         SvREFCNT_inc(cv);
  2471.         }
  2472.         DEBUG_S(if (CvDEPTH(cv) != 0)
  2473.             PerlIO_printf(Perl_debug_log, "depth %ld != 0\n",
  2474.                       CvDEPTH(cv)););
  2475.         SAVEDESTRUCTOR_X(unset_cvowner, (void*) cv);
  2476.     }
  2477.     }
  2478. #endif /* USE_THREADS */
  2479.  
  2480.     if (CvXSUB(cv)) {
  2481. #ifdef PERL_XSUB_OLDSTYLE
  2482.     if (CvOLDSTYLE(cv)) {
  2483.         I32 (*fp3)(int,int,int);
  2484.         dMARK;
  2485.         register I32 items = SP - MARK;
  2486.                     /* We dont worry to copy from @_. */
  2487.         while (SP > mark) {
  2488.         SP[1] = SP[0];
  2489.         SP--;
  2490.         }
  2491.         PL_stack_sp = mark + 1;
  2492.         fp3 = (I32(*)(int,int,int))CvXSUB(cv);
  2493.         items = (*fp3)(CvXSUBANY(cv).any_i32, 
  2494.                MARK - PL_stack_base + 1,
  2495.                items);
  2496.         PL_stack_sp = PL_stack_base + items;
  2497.     }
  2498.     else
  2499. #endif /* PERL_XSUB_OLDSTYLE */
  2500.     {
  2501.         I32 markix = TOPMARK;
  2502.  
  2503.         PUTBACK;
  2504.  
  2505.         if (!hasargs) {
  2506.         /* Need to copy @_ to stack. Alternative may be to
  2507.          * switch stack to @_, and copy return values
  2508.          * back. This would allow popping @_ in XSUB, e.g.. XXXX */
  2509.         AV* av;
  2510.         I32 items;
  2511. #ifdef USE_THREADS
  2512.         av = (AV*)PL_curpad[0];
  2513. #else
  2514.         av = GvAV(PL_defgv);
  2515. #endif /* USE_THREADS */        
  2516.         items = AvFILLp(av) + 1;   /* @_ is not tieable */
  2517.  
  2518.         if (items) {
  2519.             /* Mark is at the end of the stack. */
  2520.             EXTEND(SP, items);
  2521.             Copy(AvARRAY(av), SP + 1, items, SV*);
  2522.             SP += items;
  2523.             PUTBACK ;            
  2524.         }
  2525.         }
  2526.         /* We assume first XSUB in &DB::sub is the called one. */
  2527.         if (PL_curcopdb) {
  2528.         SAVEVPTR(PL_curcop);
  2529.         PL_curcop = PL_curcopdb;
  2530.         PL_curcopdb = NULL;
  2531.         }
  2532.         /* Do we need to open block here? XXXX */
  2533.         (void)(*CvXSUB(cv))(aTHXo_ cv);
  2534.  
  2535.         /* Enforce some sanity in scalar context. */
  2536.         if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
  2537.         if (markix > PL_stack_sp - PL_stack_base)
  2538.             *(PL_stack_base + markix) = &PL_sv_undef;
  2539.         else
  2540.             *(PL_stack_base + markix) = *PL_stack_sp;
  2541.         PL_stack_sp = PL_stack_base + markix;
  2542.         }
  2543.     }
  2544.     LEAVE;
  2545.     return NORMAL;
  2546.     }
  2547.     else {
  2548.     dMARK;
  2549.     register I32 items = SP - MARK;
  2550.     AV* padlist = CvPADLIST(cv);
  2551.     SV** svp = AvARRAY(padlist);
  2552.     push_return(PL_op->op_next);
  2553.     PUSHBLOCK(cx, CXt_SUB, MARK);
  2554.     PUSHSUB(cx);
  2555.     CvDEPTH(cv)++;
  2556.     /* XXX This would be a natural place to set C<PL_compcv = cv> so
  2557.      * that eval'' ops within this sub know the correct lexical space.
  2558.      * Owing the speed considerations, we choose to search for the cv
  2559.      * in doeval() instead.
  2560.      */
  2561.     if (CvDEPTH(cv) < 2)
  2562.         (void)SvREFCNT_inc(cv);
  2563.     else {    /* save temporaries on recursion? */
  2564.         PERL_STACK_OVERFLOW_CHECK();
  2565.         if (CvDEPTH(cv) > AvFILLp(padlist)) {
  2566.         AV *av;
  2567.         AV *newpad = newAV();
  2568.         SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
  2569.         I32 ix = AvFILLp((AV*)svp[1]);
  2570.         I32 names_fill = AvFILLp((AV*)svp[0]);
  2571.         svp = AvARRAY(svp[0]);
  2572.         for ( ;ix > 0; ix--) {
  2573.             if (names_fill >= ix && svp[ix] != &PL_sv_undef) {
  2574.             char *name = SvPVX(svp[ix]);
  2575.             if ((SvFLAGS(svp[ix]) & SVf_FAKE) /* outer lexical? */
  2576.                 || *name == '&')          /* anonymous code? */
  2577.             {
  2578.                 av_store(newpad, ix, SvREFCNT_inc(oldpad[ix]));
  2579.             }
  2580.             else {                /* our own lexical */
  2581.                 if (*name == '@')
  2582.                 av_store(newpad, ix, sv = (SV*)newAV());
  2583.                 else if (*name == '%')
  2584.                 av_store(newpad, ix, sv = (SV*)newHV());
  2585.                 else
  2586.                 av_store(newpad, ix, sv = NEWSV(0,0));
  2587.                 SvPADMY_on(sv);
  2588.             }
  2589.             }
  2590.             else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
  2591.             av_store(newpad, ix, sv = SvREFCNT_inc(oldpad[ix]));
  2592.             }
  2593.             else {
  2594.             av_store(newpad, ix, sv = NEWSV(0,0));
  2595.             SvPADTMP_on(sv);
  2596.             }
  2597.         }
  2598.         av = newAV();        /* will be @_ */
  2599.         av_extend(av, 0);
  2600.         av_store(newpad, 0, (SV*)av);
  2601.         AvFLAGS(av) = AVf_REIFY;
  2602.         av_store(padlist, CvDEPTH(cv), (SV*)newpad);
  2603.         AvFILLp(padlist) = CvDEPTH(cv);
  2604.         svp = AvARRAY(padlist);
  2605.         }
  2606.     }
  2607. #ifdef USE_THREADS
  2608.     if (!hasargs) {
  2609.         AV* av = (AV*)PL_curpad[0];
  2610.  
  2611.         items = AvFILLp(av) + 1;
  2612.         if (items) {
  2613.         /* Mark is at the end of the stack. */
  2614.         EXTEND(SP, items);
  2615.         Copy(AvARRAY(av), SP + 1, items, SV*);
  2616.         SP += items;
  2617.         PUTBACK ;            
  2618.         }
  2619.     }
  2620. #endif /* USE_THREADS */        
  2621.     SAVEVPTR(PL_curpad);
  2622.         PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
  2623. #ifndef USE_THREADS
  2624.     if (hasargs)
  2625. #endif /* USE_THREADS */
  2626.     {
  2627.         AV* av;
  2628.         SV** ary;
  2629.  
  2630. #if 0
  2631.         DEBUG_S(PerlIO_printf(Perl_debug_log,
  2632.                       "%p entersub preparing @_\n", thr));
  2633. #endif
  2634.         av = (AV*)PL_curpad[0];
  2635.         if (AvREAL(av)) {
  2636.         /* @_ is normally not REAL--this should only ever
  2637.          * happen when DB::sub() calls things that modify @_ */
  2638.         av_clear(av);
  2639.         AvREAL_off(av);
  2640.         AvREIFY_on(av);
  2641.         }
  2642. #ifndef USE_THREADS
  2643.         cx->blk_sub.savearray = GvAV(PL_defgv);
  2644.         GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
  2645. #endif /* USE_THREADS */
  2646.         cx->blk_sub.argarray = av;
  2647.         ++MARK;
  2648.  
  2649.         if (items > AvMAX(av) + 1) {
  2650.         ary = AvALLOC(av);
  2651.         if (AvARRAY(av) != ary) {
  2652.             AvMAX(av) += AvARRAY(av) - AvALLOC(av);
  2653.             SvPVX(av) = (char*)ary;
  2654.         }
  2655.         if (items > AvMAX(av) + 1) {
  2656.             AvMAX(av) = items - 1;
  2657.             Renew(ary,items,SV*);
  2658.             AvALLOC(av) = ary;
  2659.             SvPVX(av) = (char*)ary;
  2660.         }
  2661.         }
  2662.         Copy(MARK,AvARRAY(av),items,SV*);
  2663.         AvFILLp(av) = items - 1;
  2664.         
  2665.         while (items--) {
  2666.         if (*MARK)
  2667.             SvTEMP_off(*MARK);
  2668.         MARK++;
  2669.         }
  2670.     }
  2671.     /* warning must come *after* we fully set up the context
  2672.      * stuff so that __WARN__ handlers can safely dounwind()
  2673.      * if they want to
  2674.      */
  2675.     if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)
  2676.         && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
  2677.         sub_crush_depth(cv);
  2678. #if 0
  2679.     DEBUG_S(PerlIO_printf(Perl_debug_log,
  2680.                   "%p entersub returning %p\n", thr, CvSTART(cv)));
  2681. #endif
  2682.     RETURNOP(CvSTART(cv));
  2683.     }
  2684. }
  2685.  
  2686. void
  2687. Perl_sub_crush_depth(pTHX_ CV *cv)
  2688. {
  2689.     if (CvANON(cv))
  2690.     Perl_warner(aTHX_ WARN_RECURSION, "Deep recursion on anonymous subroutine");
  2691.     else {
  2692.     SV* tmpstr = sv_newmortal();
  2693.     gv_efullname3(tmpstr, CvGV(cv), Nullch);
  2694.     Perl_warner(aTHX_ WARN_RECURSION, "Deep recursion on subroutine \"%s\"", 
  2695.         SvPVX(tmpstr));
  2696.     }
  2697. }
  2698.  
  2699. PP(pp_aelem)
  2700. {
  2701.     djSP;
  2702.     SV** svp;
  2703.     I32 elem = POPi;
  2704.     AV* av = (AV*)POPs;
  2705.     U32 lval = PL_op->op_flags & OPf_MOD;
  2706.     U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > AvFILL(av));
  2707.     SV *sv;
  2708.  
  2709.     if (elem > 0)
  2710.     elem -= PL_curcop->cop_arybase;
  2711.     if (SvTYPE(av) != SVt_PVAV)
  2712.     RETPUSHUNDEF;
  2713.     svp = av_fetch(av, elem, lval && !defer);
  2714.     if (lval) {
  2715.     if (!svp || *svp == &PL_sv_undef) {
  2716.         SV* lv;
  2717.         if (!defer)
  2718.         DIE(aTHX_ PL_no_aelem, elem);
  2719.         lv = sv_newmortal();
  2720.         sv_upgrade(lv, SVt_PVLV);
  2721.         LvTYPE(lv) = 'y';
  2722.         sv_magic(lv, Nullsv, 'y', Nullch, 0);
  2723.         LvTARG(lv) = SvREFCNT_inc(av);
  2724.         LvTARGOFF(lv) = elem;
  2725.         LvTARGLEN(lv) = 1;
  2726.         PUSHs(lv);
  2727.         RETURN;
  2728.     }
  2729.     if (PL_op->op_private & OPpLVAL_INTRO)
  2730.         save_aelem(av, elem, svp);
  2731.     else if (PL_op->op_private & OPpDEREF)
  2732.         vivify_ref(*svp, PL_op->op_private & OPpDEREF);
  2733.     }
  2734.     sv = (svp ? *svp : &PL_sv_undef);
  2735.     if (!lval && SvGMAGICAL(sv))    /* see note in pp_helem() */
  2736.     sv = sv_mortalcopy(sv);
  2737.     PUSHs(sv);
  2738.     RETURN;
  2739. }
  2740.  
  2741. void
  2742. Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
  2743. {
  2744.     if (SvGMAGICAL(sv))
  2745.     mg_get(sv);
  2746.     if (!SvOK(sv)) {
  2747.     if (SvREADONLY(sv))
  2748.         Perl_croak(aTHX_ PL_no_modify);
  2749.     if (SvTYPE(sv) < SVt_RV)
  2750.         sv_upgrade(sv, SVt_RV);
  2751.     else if (SvTYPE(sv) >= SVt_PV) {
  2752.         (void)SvOOK_off(sv);
  2753.         Safefree(SvPVX(sv));
  2754.         SvLEN(sv) = SvCUR(sv) = 0;
  2755.     }
  2756.     switch (to_what) {
  2757.     case OPpDEREF_SV:
  2758.         SvRV(sv) = NEWSV(355,0);
  2759.         break;
  2760.     case OPpDEREF_AV:
  2761.         SvRV(sv) = (SV*)newAV();
  2762.         break;
  2763.     case OPpDEREF_HV:
  2764.         SvRV(sv) = (SV*)newHV();
  2765.         break;
  2766.     }
  2767.     SvROK_on(sv);
  2768.     SvSETMAGIC(sv);
  2769.     }
  2770. }
  2771.  
  2772. PP(pp_method)
  2773. {
  2774.     djSP;
  2775.     SV* sv = TOPs;
  2776.  
  2777.     if (SvROK(sv)) {
  2778.     SV* rsv = SvRV(sv);
  2779.     if (SvTYPE(rsv) == SVt_PVCV) {
  2780.         SETs(rsv);
  2781.         RETURN;
  2782.     }
  2783.     }
  2784.  
  2785.     SETs(method_common(sv, Null(U32*)));
  2786.     RETURN;
  2787. }
  2788.  
  2789. PP(pp_method_named)
  2790. {
  2791.     djSP;
  2792.     SV* sv = cSVOP->op_sv;
  2793.     U32 hash = SvUVX(sv);
  2794.  
  2795.     XPUSHs(method_common(sv, &hash));
  2796.     RETURN;
  2797. }
  2798.  
  2799. STATIC SV *
  2800. S_method_common(pTHX_ SV* meth, U32* hashp)
  2801. {
  2802.     SV* sv;
  2803.     SV* ob;
  2804.     GV* gv;
  2805.     HV* stash;
  2806.     char* name;
  2807.     STRLEN namelen;
  2808.     char* packname;
  2809.     STRLEN packlen;
  2810.  
  2811.     name = SvPV(meth, namelen);
  2812.     sv = *(PL_stack_base + TOPMARK + 1);
  2813.  
  2814.     if (SvGMAGICAL(sv))
  2815.         mg_get(sv);
  2816.     if (SvROK(sv))
  2817.     ob = (SV*)SvRV(sv);
  2818.     else {
  2819.     GV* iogv;
  2820.  
  2821.     packname = Nullch;
  2822.     if (!SvOK(sv) ||
  2823.         !(packname = SvPV(sv, packlen)) ||
  2824.         !(iogv = gv_fetchpv(packname, FALSE, SVt_PVIO)) ||
  2825.         !(ob=(SV*)GvIO(iogv)))
  2826.     {
  2827.         if (!packname || 
  2828.         ((*(U8*)packname >= 0xc0 && DO_UTF8(sv))
  2829.             ? !isIDFIRST_utf8((U8*)packname)
  2830.             : !isIDFIRST(*packname)
  2831.         ))
  2832.         {
  2833.         Perl_croak(aTHX_ "Can't call method \"%s\" %s", name,
  2834.                SvOK(sv) ? "without a package or object reference"
  2835.                     : "on an undefined value");
  2836.         }
  2837.         stash = gv_stashpvn(packname, packlen, TRUE);
  2838.         goto fetch;
  2839.     }
  2840.     *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv));
  2841.     }
  2842.  
  2843.     if (!ob || !(SvOBJECT(ob)
  2844.          || (SvTYPE(ob) == SVt_PVGV && (ob = (SV*)GvIO((GV*)ob))
  2845.              && SvOBJECT(ob))))
  2846.     {
  2847.     Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
  2848.            name);
  2849.     }
  2850.  
  2851.     stash = SvSTASH(ob);
  2852.  
  2853.   fetch:
  2854.     /* shortcut for simple names */
  2855.     if (hashp) {
  2856.     HE* he = hv_fetch_ent(stash, meth, 0, *hashp);
  2857.     if (he) {
  2858.         gv = (GV*)HeVAL(he);
  2859.         if (isGV(gv) && GvCV(gv) &&
  2860.         (!GvCVGEN(gv) || GvCVGEN(gv) == PL_sub_generation))
  2861.         return (SV*)GvCV(gv);
  2862.     }
  2863.     }
  2864.  
  2865.     gv = gv_fetchmethod(stash, name);
  2866.     if (!gv) {
  2867.     char* leaf = name;
  2868.     char* sep = Nullch;
  2869.     char* p;
  2870.  
  2871.     for (p = name; *p; p++) {
  2872.         if (*p == '\'')
  2873.         sep = p, leaf = p + 1;
  2874.         else if (*p == ':' && *(p + 1) == ':')
  2875.         sep = p, leaf = p + 2;
  2876.     }
  2877.     if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) {
  2878.         packname = sep ? CopSTASHPV(PL_curcop) : HvNAME(stash);
  2879.         packlen = strlen(packname);
  2880.     }
  2881.     else {
  2882.         packname = name;
  2883.         packlen = sep - name;
  2884.     }
  2885.     Perl_croak(aTHX_
  2886.            "Can't locate object method \"%s\" via package \"%s\"",
  2887.            leaf, packname);
  2888.     }
  2889.     return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;
  2890. }
  2891.  
  2892. #ifdef USE_THREADS
  2893. static void
  2894. unset_cvowner(pTHXo_ void *cvarg)
  2895. {
  2896.     register CV* cv = (CV *) cvarg;
  2897. #ifdef DEBUGGING
  2898.     dTHR;
  2899. #endif /* DEBUGGING */
  2900.  
  2901.     DEBUG_S((PerlIO_printf(Perl_debug_log, "%p unsetting CvOWNER of %p:%s\n",
  2902.                thr, cv, SvPEEK((SV*)cv))));
  2903.     MUTEX_LOCK(CvMUTEXP(cv));
  2904.     DEBUG_S(if (CvDEPTH(cv) != 0)
  2905.         PerlIO_printf(Perl_debug_log, "depth %ld != 0\n",
  2906.                   CvDEPTH(cv)););
  2907.     assert(thr == CvOWNER(cv));
  2908.     CvOWNER(cv) = 0;
  2909.     MUTEX_UNLOCK(CvMUTEXP(cv));
  2910.     SvREFCNT_dec(cv);
  2911. }
  2912. #endif /* USE_THREADS */
  2913.